feldspar-compiler-0.3: Feldspar/Compiler/Plugins/Precompilation.hs
--
-- Copyright (c) 2009-2010, 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 EmptyDataDecls, TypeFamilies #-}
module Feldspar.Compiler.Plugins.Precompilation where
import Feldspar.Compiler.PluginArchitecture
import qualified Feldspar.Core.Expr as Expr
import Feldspar.Core.Types
import qualified Feldspar.Compiler.Precompiler.Precompiler as Precompiler
import Feldspar.Compiler.Error
import System.IO.Unsafe
-- ===========================================================================
-- == Precompilation plugin
-- ===========================================================================
data CompilationMode = Interactive | Standalone
deriving (Show, Eq)
data SignatureInformation = SignatureInformation {
originalFeldsparFunctionName :: String,
generatedImperativeParameterNames :: [String],
originalFeldsparParameterNames :: Maybe [Maybe String]
} deriving (Show, Eq)
instance Default SignatureInformation where defaultValue = precompilationError InternalError "Default value should not be used"
precompilationError = handleError "PluginArch/Precompilation"
data PrecompilationSemanticInfo
instance SemanticInfo PrecompilationSemanticInfo where
type ProcedureInfo PrecompilationSemanticInfo = SignatureInformation
type BlockInfo PrecompilationSemanticInfo = ()
type ProgramInfo PrecompilationSemanticInfo = ()
type EmptyInfo PrecompilationSemanticInfo = ()
type PrimitiveInfo PrecompilationSemanticInfo = ()
type SequenceInfo PrecompilationSemanticInfo = ()
type BranchInfo PrecompilationSemanticInfo = ()
type SequentialLoopInfo PrecompilationSemanticInfo = ()
type ParallelLoopInfo PrecompilationSemanticInfo = ()
type FormalParameterInfo PrecompilationSemanticInfo = ()
type LocalDeclarationInfo PrecompilationSemanticInfo = ()
type ExpressionInfo PrecompilationSemanticInfo = ()
type ConstantInfo PrecompilationSemanticInfo = ()
type FunctionCallInfo PrecompilationSemanticInfo = ()
type LeftValueInfo PrecompilationSemanticInfo = ()
type ArrayElemReferenceInfo PrecompilationSemanticInfo = ()
type InstructionInfo PrecompilationSemanticInfo = ()
type AssignmentInfo PrecompilationSemanticInfo = ()
type ProcedureCallInfo PrecompilationSemanticInfo = ()
type ActualParameterInfo PrecompilationSemanticInfo = ()
type IntConstantInfo PrecompilationSemanticInfo = ()
type FloatConstantInfo PrecompilationSemanticInfo = ()
type BoolConstantInfo PrecompilationSemanticInfo = ()
type ArrayConstantInfo PrecompilationSemanticInfo = ()
type VariableInfo PrecompilationSemanticInfo = SignatureInformation
data Precompilation = Precompilation
instance TransformationPhase Precompilation where
type From Precompilation = ()
type To Precompilation = ()
type Downwards Precompilation = SignatureInformation
type Upwards Precompilation = ()
downwardsProcedure Precompilation fromAbove procedure = fromAbove {
generatedImperativeParameterNames =
map (variableName . formalParameterVariable) (inParameters procedure)
}
transformProcedure Precompilation fromAbove originalProcedure fromBelow =
Procedure { -- NOTE: fromAbove won't have the generated imperative parameter names right here
procedureName = originalFeldsparFunctionName fromAbove,
inParameters = recursivelyTransformedInParameters fromBelow,
outParameters = recursivelyTransformedOutParameters fromBelow,
procedureBody = recursivelyTransformedProcedureBody fromBelow,
procedureSemInf = ()
}
transformVariable = myTransformVariable
transformVariableLeftValueInLeftValue = myTransformVariableLeftValueInLeftValue
getVariableName :: SignatureInformation -> String -> String
getVariableName signatureInformation origname = case (originalFeldsparParameterNames signatureInformation) of
Just originalParameterNameList ->
if length (generatedImperativeParameterNames signatureInformation) == length originalParameterNameList then
case searchResults of
[] -> origname
otherwise -> case snd $ head $ searchResults of
Just newname -> newname
Nothing -> origname
else
precompilationError InternalError $ "parameter name list length mismatch:" ++
show (generatedImperativeParameterNames signatureInformation) ++ " " ++ show originalParameterNameList
where
searchResults = (filter (((==) origname).fst) (zip (generatedImperativeParameterNames signatureInformation) originalParameterNameList))
Nothing -> origname
myTransformVariable :: Precompilation -> SignatureInformation -> Variable () -> Variable ()
myTransformVariable Precompilation fromAbove v = v {
variableName = getVariableName fromAbove (variableName v),
variableSemInf = ()
}
myTransformVariableLeftValueInLeftValue :: Precompilation -> SignatureInformation -> Variable () -> LeftValueData ()
myTransformVariableLeftValueInLeftValue Precompilation fromAbove v = VariableLeftValue $ myTransformVariable Precompilation fromAbove v
data PrecompilationExternalInfo = PrecompilationExternalInfo {
originalFeldsparFunctionSignature :: Precompiler.OriginalFeldsparFunctionSignature,
graphInputInterfaceType :: Tuple StorableType,
numberOfFunctionArguments :: Int,
compilationMode :: CompilationMode
}
countTuple :: Tuple a -> Int
countTuple (One x) = 1
countTuple (Tup list) = sum (map countTuple list)
addPostfixNumbersToMaybeList :: [Maybe String] -> [Maybe String]
addPostfixNumbersToMaybeList list
| length list > 1 = map addPostfixNumberToMaybeString (zip list [1..]) -- postfix numbers only needed for lists with length > 1
| otherwise = list
addPostfixNumberToMaybeString :: (Maybe String, Int) -> Maybe String
addPostfixNumberToMaybeString (ms, num) = case ms of
Just s -> Just $ s ++ (show num)
Nothing -> Nothing
inflate :: Int -> [Maybe String] -> [Maybe String]
inflate target list | length list < target = inflate target (list++[Nothing])
| length list == target = list
| otherwise = precompilationError InternalError "Unexpected situation in 'inflate'"
-- Applies some tweaks the original parameter name list based on the graph's input interface type signature
parameterNameListConsolidator :: PrecompilationExternalInfo -> [Maybe String]
parameterNameListConsolidator externalInfo = case graphInputInterfaceType externalInfo of
One x -> Precompiler.originalFeldsparParameterNames $ originalFeldsparFunctionSignature externalInfo
tuple@(Tup list) -> case numberOfFunctionArguments externalInfo of
0 -> precompilationError InternalError "parameter name list consolidator function shouldn't be called when numArgs==0"
1 -> addPostfixNumbersToMaybeList $ replicate (countTuple tuple)
(head $ Precompiler.originalFeldsparParameterNames $ originalFeldsparFunctionSignature externalInfo)
otherwise -> concat $ map (\(cnt,name)->addPostfixNumbersToMaybeList (replicate cnt name))
(zip (map countTuple list) (Precompiler.originalFeldsparParameterNames $ originalFeldsparFunctionSignature externalInfo))
instance Plugin Precompilation where
type ExternalInfo Precompilation = PrecompilationExternalInfo
executePlugin Precompilation externalInfo procedure = fst
$ executeTransformationPhase Precompilation (SignatureInformation {
originalFeldsparFunctionName = Precompiler.originalFeldsparFunctionName $ originalFeldsparFunctionSignature externalInfo,
generatedImperativeParameterNames = precompilationError InternalError "GIPN should have been overwritten",
originalFeldsparParameterNames = if numberOfFunctionArguments externalInfo == 0
then
Nothing -- if there are no arguments, disable parameter name handling (needed because of the dummy var0)
else
(case compilationMode externalInfo of
Standalone ->
if -- ultimate check, should be enough...
numberOfFunctionArguments externalInfo ==
length (Precompiler.originalFeldsparParameterNames $ originalFeldsparFunctionSignature externalInfo)
then
Just $ parameterNameListConsolidator externalInfo
else
(unsafePerformIO $ do
putStrLn $ "[WARNING @ PluginArch/Precompilation]: argument count mismatch in function " ++
(Precompiler.originalFeldsparFunctionName $ originalFeldsparFunctionSignature externalInfo) ++
", inflating incomplete parameter name list..."
putStrLn $ "numArgs: " ++ show (numberOfFunctionArguments externalInfo) ++ ", parameter list: " ++
show (Precompiler.originalFeldsparParameterNames $ originalFeldsparFunctionSignature externalInfo)
return $ Just $ parameterNameListConsolidator (externalInfo {
originalFeldsparFunctionSignature = (originalFeldsparFunctionSignature externalInfo) {
Precompiler.originalFeldsparParameterNames = inflate (numberOfFunctionArguments externalInfo) $
Precompiler.originalFeldsparParameterNames $ originalFeldsparFunctionSignature externalInfo
}
})
)
Interactive -> Nothing -- no parameter name handling in interactive mode
)
}) procedure