---- Copyright (c) 2009-2011, ERICSSON AB-- All rights reserved.-- -- Redistribution and use in source and binary forms, with or without-- modification, are permitted provided that the following conditions are met:-- -- * Redistributions of source code must retain the above copyright notice, -- this list of conditions and the following disclaimer.-- * Redistributions in binary form must reproduce the above copyright-- notice, this list of conditions and the following disclaimer in the-- documentation and/or other materials provided with the distribution.-- * Neither the name of the ERICSSON AB nor the names of its contributors-- may be used to endorse or promote products derived from this software-- without specific prior written permission.-- -- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"-- AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE-- IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -- DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE-- FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL-- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR-- SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER-- CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,-- OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE-- OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.--{-# LANGUAGE TypeFamilies #-}{-# LANGUAGE MultiParamTypeClasses #-}moduleFeldspar.Compiler.Imperative.Plugin.NamingwhereimportData.List(isPrefixOf)importFeldspar.TransformationimportqualifiedFeldspar.NameExtractorasPrecompilerimportFeldspar.Compiler.ErrorimportFeldspar.Compiler.Backend.C.LibraryimportSystem.IO.Unsafe-- ===========================================================================-- == Precompilation plugin-- ===========================================================================dataSignatureInformation=SignatureInformation{originalFunctionName::String,generatedImperativeParameterNames::[String],originalParameterNames::Maybe[MaybeString]}deriving(Show,Eq)instanceDefaultSignatureInformationwheredef=precompilationErrorInternalError"Default value should not be used"precompilationError::ErrorClass->String->aprecompilationError=handleError"PluginArch/Naming"dataPrecompilation=PrecompilationinstanceTransformationPrecompilationwheretypeFromPrecompilation=()typeToPrecompilation=()typeDownPrecompilation=SignatureInformationtypeUpPrecompilation=()typeStatePrecompilation=()instanceTransformablePrecompilationEntitywheretransformtsdx@(ProcDefni____)|n=="PLACEHOLDER"=tr{result=(resulttr){procName=n'}}whered'=d{generatedImperativeParameterNames=mapvarNamei}tr=defaultTransformtsd'xn'=originalFunctionNamedtransformtsdx@(ProcDefn_____)|any(n`isPrefixOf`)proceduresToPrefix=tr{result=(resulttr){procName=n'}}wheren'=prefixdntr=defaultTransformtsd'xd'=d{generatedImperativeParameterNames=[]}transformtsdx@ProcDef{}=defaultTransformtsd'xwhered'=d{generatedImperativeParameterNames=[]}transformtsdx=defaultTransformtsdxinstanceTransformablePrecompilationVariablewheretransform_sdv=ResultnewVarsdefwherenewVar=v{varName=maybeStr2Str(getVariableNamed$varNamev)++varNamev,varLabel=()}instanceTransformablePrecompilationActualParameterwheretransform_sd(FunParameternaddr_)|any(n`isPrefixOf`)proceduresToPrefix=Result(FunParameter(prefixdn)addr())sdeftransformtsdx=defaultTransformtsdxinstanceTransformablePrecompilationProgramwheretransformtsdc@(ProcedureCalln___)|any(n`isPrefixOf`)proceduresToPrefix=tr{result=(resulttr){procCallName=n'}}wheretr=defaultTransformtsdcn'=prefixdntransformtsdx=defaultTransformtsdxproceduresToPrefix::[String]proceduresToPrefix=["noinline","task"]prefix::SignatureInformation->String->Stringprefixdn=originalFunctionNamed++"_"++ngetVariableName::SignatureInformation->String->MaybeStringgetVariableNamesignatureInformationorigname=caseoriginalParameterNamessignatureInformationofJustoriginalParameterNameList->iflength(generatedImperativeParameterNamessignatureInformation)==lengthoriginalParameterNameListthencasesearchResultsof[]->Nothing_->snd$headsearchResultselseNothing-- precompilationError InternalError $ "parameter name list length mismatch:" ++-- show (generatedImperativeParameterNames signatureInformation) ++ " " ++ show originalParameterNameListwheresearchResults=filter((origname==).fst)(zip(generatedImperativeParameterNamessignatureInformation)originalParameterNameList)Nothing->NothingmaybeStr2Str::MaybeString->StringmaybeStr2Str(Justs)=s++"_"maybeStr2StrNothing=""dataPrecompilationExternalInfo=PrecompilationExternalInfo{originalFunctionSignature::Precompiler.OriginalFunctionSignature,inputParametersDescriptor::[Int],numberOfFunctionArguments::Int,compilationMode::CompilationMode}addPostfixNumberToMaybeString::(MaybeString,Int)->MaybeStringaddPostfixNumberToMaybeString(ms,num)=ms>>=\s->return$s++shownuminflate::Int->[MaybeString]->[MaybeString]inflatetargetlist|lengthlist<target=inflatetarget(list++[Nothing])|lengthlist==target=list|otherwise=precompilationErrorInternalError"Unexpected situation in 'inflate'"-- Replicates each element of the [parameter list given by the precompiler] based on the input parameter descriptorparameterNameListConsolidator::PrecompilationExternalInfo->[MaybeString]parameterNameListConsolidatorexternalInfo=ifnumberOfFunctionArgumentsexternalInfo==length(inputParametersDescriptorexternalInfo)thenconcatMap(uncurryreplicate)(zip(inputParametersDescriptorexternalInfo)(Precompiler.originalParameterNames$originalFunctionSignatureexternalInfo))elseprecompilationErrorInternalError"numArgs should be equal to the length of the input parameters' descriptor"instancePluginPrecompilationwheretypeExternalInfoPrecompilation=PrecompilationExternalInfoexecutePluginPrecompilationexternalInfoprocedure=result$transformPrecompilation({-state-})SignatureInformation{originalFunctionName=Precompiler.originalFunctionName$originalFunctionSignatureexternalInfo,generatedImperativeParameterNames=precompilationErrorInternalError"GIPN should have been overwritten",originalParameterNames=casecompilationModeexternalInfoofStandalone->if-- ultimate check, should be enough...numberOfFunctionArgumentsexternalInfo==length(Precompiler.originalParameterNames$originalFunctionSignatureexternalInfo)thenJust$parameterNameListConsolidatorexternalInfoelseunsafePerformIO$dowithColorYellow$putStrLn$unwords["[WARNING @ PluginArch/Naming]:"," not enough named parameters in function ",Precompiler.originalFunctionName(originalFunctionSignatureexternalInfo)]withColorYellow$putStrLn$"numArgs: "++show(numberOfFunctionArgumentsexternalInfo)++", parameter list: "++show(Precompiler.originalParameterNames$originalFunctionSignatureexternalInfo)return$Just$parameterNameListConsolidator(externalInfo{originalFunctionSignature=(originalFunctionSignatureexternalInfo){Precompiler.originalParameterNames=inflate(numberOfFunctionArgumentsexternalInfo)$Precompiler.originalParameterNames$originalFunctionSignatureexternalInfo}})Interactive->Nothing-- no parameter name handling in interactive mode}procedure