diff --git a/Feldspar/C/feldspar.c b/Feldspar/C/feldspar.c new file mode 100644 --- /dev/null +++ b/Feldspar/C/feldspar.c @@ -0,0 +1,214 @@ +/* + * Copyright (c) 2009, 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. + */ + +#include "feldspar.h" + + + +int pow_fun_signed_int( int a, int b) +{ + int out = 1; + int i; + for(i=0; i 0) return 1; + return 0; +} + +int signum_fun_unsigned_int( unsigned int a ) +{ + if (a < 0) return -1; + if (a > 0) return 1; + return 0; +} + +long signum_fun_signed_long( long a ) +{ + if (a < 0) return -1; + if (a > 0) return 1; + return 0; +} + +long signum_fun_unsigned_long( unsigned long a ) +{ + if (a < 0) return -1; + if (a > 0) return 1; + return 0; +} + +double signum_fun_double( double a ) +{ + if (a < 0) return -1; + if (a > 0) return 1; + return 0; +} + + + +void copy_arrayOf_signed_int( int* a, int a1, int* b) +{ + int i; + for( i=0; i String -> Options -> [ImpFunction]) + +------------------------- +-- Core compiler -- +------------------------- + +coreCompile :: (Expr.Program t) => (Stage t -> t -> FilePath -> String -> Options -> IO ()) + -> t -> FilePath -> String -> Options -> IO () +coreCompile write prg fileName funname opts = write stage prg fileName funname opts where + stage :: (Expr.Program t) => t -> String -> Options -> [ImpFunction] + stage = case debug opts of + NoDebug -> stage7 + NoSimplification -> stage5 + NoPrimitiveInstructionHandling -> stage3 + +------------------------- +-- Standalone compiler -- +------------------------- + +includeGeneration :: FilePath -> IO () +includeGeneration fileName + = appendFile fileName intro + +standaloneWrite stage prg fileName functionName opts + = appendFile fileName $ toC 0 $ stage prg functionName opts + +standaloneCompile:: (Expr.Program t) => t -> FilePath -> String -> Options -> IO () +standaloneCompile prg fileName functionName opts + = coreCompile standaloneWrite prg fileName functionName opts + + +------------------------------------------------ +-- Invoking the compiler from the interpreter -- +------------------------------------------------ + + +fileWrite stage prg fileName functionName opts + = writeFile fileName $ intro ++ (toC 0 $ stage prg functionName opts) + +compile :: (Expr.Program t) => t -> FilePath -> String -> Options -> IO () +compile prg fileName functionName opts + = coreCompile fileWrite prg fileName functionName opts + + +writeOut stage prg fileName functionName opts + = putStrLn $ intro ++ (toC 0 $ stage prg functionName opts) + +icompile :: (Expr.Program t) => t -> IO () +icompile prg + = coreCompile writeOut prg "" "test" defaultOptions + +icompile' :: (Expr.Program t) => t -> String -> Options -> IO () +icompile' prg functionName opts + = coreCompile writeOut prg "" functionName opts + +------------------------ +-- Predefined options -- +------------------------ + +defaultOptions + = Options + { platform = AnsiC + , unroll = NoUnroll + , debug = NoDebug + } + +unrollOptions + = defaultOptions { unroll = Unroll 8 } + +noSimplification + = defaultOptions { debug = NoSimplification } + +noPrimitiveInstructionHandling + = defaultOptions { debug = NoPrimitiveInstructionHandling } + +---------------------- +-- Helper functions -- +---------------------- + +stage1:: (Expr.Program t) => t -> HierarchicalGraph +stage1 = makeHierarchical . toGraph + +stage2:: (Expr.Program t) => t -> HierarchicalGraph +stage2 = replaceNoInlines . stage1 + +stage3:: (Expr.Program t) => t -> String -> Options -> [ImpFunction] +stage3 prg name opt = graphToImperative name $ stage2 prg + +stage4:: (Expr.Program t) => t -> String -> Options -> [ImpFunction] +stage4 prg name opt = handlePrimitives opt $ stage3 prg name opt + +stage5:: (Expr.Program t) => t -> String -> Options -> [ImpFunction] +stage5 prg name opt = fst . computeSemInfVar $ stage4 prg name opt + +stage6:: (Expr.Program t) => t -> String -> Options -> [ImpFunction] +stage6 prg name opt = doSimplification $ stage5 prg name opt + +stage7:: (Expr.Program t) => t -> String -> Options -> [ImpFunction] +stage7 prg name opt = doUnroll opt $ stage6 prg name opt diff --git a/Feldspar/Compiler/CompilerMain.hs b/Feldspar/Compiler/CompilerMain.hs new file mode 100644 --- /dev/null +++ b/Feldspar/Compiler/CompilerMain.hs @@ -0,0 +1,276 @@ +{- + - Copyright (c) 2009, 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 CPP #-} +module Main where + +import Feldspar.Compiler.Precompiler.Precompiler + +import System.Exit +import System.Environment +import System.IO +import System.Process +import System.Info +import System.Directory + +import Control.Monad +import Control.Monad.Error + +import Data.List +import System.Console.GetOpt +import System.FilePath + +import Language.Haskell.Interpreter + +generateCompileCode outputFileName options functionName = + "standaloneCompile " ++ functionName ++ " \""++ outputFileName ++"\" " ++ "\""++ functionName ++"\" " ++ + options + +generateUltimateCode outputFileName declarationList options = -- final code for the interpreter + "do " ++ (concat $ map (generateCompileCode outputFileName options) declarationList) + +compileFunction :: String -> String -> String -> Interpreter () +compileFunction outputFileName options functionName = do + lift $ putStr $ "Compiling function " ++ functionName ++ "...\t" + --result <- catchError ( interpret (generateCompileCode outputFileName options functionName) (as::IO()) ) (\_->error "error") + result <- interpret (generateCompileCode outputFileName options functionName) (as::IO()) + lift result + say "[OK]" + +compileAllFunctions :: String -> String -> [String] -> Interpreter () +compileAllFunctions outputFileName options [] = return() +compileAllFunctions outputFileName options (x:xs) = do + catchError (compileFunction outputFileName options x) ( const $ say "[FAILED]") + compileAllFunctions outputFileName options xs + +globalImportList = ["Feldspar.Fs2dot", "Feldspar.Compiler.Compiler"] + +generateIncludeLine :: String -> Interpreter () +generateIncludeLine outputFileName = do + result <- interpret ("includeGeneration \"" ++ outputFileName ++ "\"") (as::IO()) + lift result + +-- | Interpreter body for single-function compilation +singleFunctionCompilationBody :: String -> String -> String -> Interpreter (IO ()) +singleFunctionCompilationBody outputFileName options functionName = do + say $ "Output file: " ++ outputFileName + say $ "Compiling function " ++ functionName ++ "..." + generateIncludeLine outputFileName + result <- interpret (generateCompileCode outputFileName options functionName) (as::IO()) + return result + +-- | Interpreter body for multi-function compilation +multiFunctionCompilationBody :: String -> String -> [String] -> Interpreter (IO ()) +multiFunctionCompilationBody outputFileName compilerOptions declarationList = do + say $ "Output file: " ++ outputFileName + generateIncludeLine outputFileName + compileAllFunctions outputFileName compilerOptions declarationList + return(return()) + +-- | A general interpreter body for interpreting an expression +generalInterpreterBody :: String -- ^ the expression to interpret + -> Interpreter (IO ()) +generalInterpreterBody expression = do + result <- interpret expression (as::IO()) + return result + +-- | A high-level interface for calling the interpreter +highLevelInterpreter :: String -- ^ the module name (for example My.Module) + -> String -- ^ the input file name (for example "My/Module.hs") + -> Interpreter (IO ()) -- ^ an interpreter body + -> IO () +highLevelInterpreter moduleName inputFileName interpreterBody = do + actionToExecute <- runInterpreter $ do + set [ languageExtensions := (glasgowExtensions ++ + [NoMonomorphismRestriction, OverlappingInstances, Rank2Types, UndecidableInstances]) ] + say $ "Loading module " ++ moduleName ++ "..." +#ifdef RELEASE + loadModules [inputFileName] -- the globalImportList modules are package modules and should not be loaded, only imported +#else + loadModules $ [inputFileName] ++ globalImportList -- in normal mode, we need to load them before importing them +#endif + setTopLevelModules [moduleName] + setImports globalImportList + interpreterBody + either printInterpreterError id actionToExecute + +printGhcError (GhcError {errMsg=s}) = putStrLn s + +printInterpreterError :: InterpreterError -> IO () +printInterpreterError (WontCompile []) = return() +printInterpreterError (WontCompile (x:xs)) = do + printGhcError x + printInterpreterError (WontCompile xs) +printInterpreterError e = putStrLn $ "Code generation failed: " ++ (show e) + +data FunctionMode = SingleFunction String | MultiFunction + +data Options = Options { optSingleFunction :: FunctionMode + , optOutputFileName :: Maybe String + , optDotGeneration :: Bool + , optDotFileName :: Maybe String + , optCompilerMode :: String + } + +-- | Default options +startOptions :: Options +startOptions = Options { optSingleFunction = MultiFunction + , optOutputFileName = Nothing + , optDotGeneration = False + , optDotFileName = Nothing + , optCompilerMode = "defaultOptions" + } + +-- | Option descriptions for getOpt +options :: [ OptDescr (Options -> IO Options) ] +options = + [ Option "f" ["singlefunction"] + (ReqArg + (\arg opt -> return opt { optSingleFunction = SingleFunction arg }) + "FUNCTION") + "Enables single-function compilation" + + , Option "o" ["output"] + (ReqArg + (\arg opt -> return opt { optOutputFileName = Just arg }) + "outputfile.c") + "Overrides the file name for the generated output code" + + , Option "d" ["todot"] + (OptArg + (\arg opt -> return opt { optDotFileName = arg, optDotGeneration = True }) + "dotfile.dot") + "Enables dot generation (outputs to stdout if no filename is specified)" + + , Option "c" ["compilermode"] + (ReqArg + (\arg opt -> return opt { optCompilerMode = arg }) + "compilerMode") + "Changes compiler mode. Valid options are: unrollOptions, noSimplification, noPrimitiveInstructionHandling" + + , Option "h" ["help"] + (NoArg + (\_ -> do + --prg <- getProgName + hPutStrLn stderr (usageInfo header options) + exitWith ExitSuccess)) + "Show this help message" + ] + +header = "Standalone Feldspar Compiler\nUsage: feldspar [options] inputfile\n" ++ + "Notes: \n" ++ + " * When no output file name is specified, the input file's name with .c extension is used\n" ++ + " * The inputfile parameter is always needed, even in single-function mode\n" ++ + "\nAvailable options: \n" + +-- | Calculates the output file name. +convertOutputFileName :: String -> Maybe String -> String +convertOutputFileName inputFileName maybeOutputFileName = case maybeOutputFileName of + Nothing -> takeFileName $ replaceExtension inputFileName ".c" -- remove takeFileName to return the full path + Just overriddenFileName -> overriddenFileName + +main = do + args <- getArgs + + when (length args == 0) (do + putStrLn $ usageInfo header options + exitWith ExitSuccess) + + -- Parse options, getting a list of option actions + let (actions, nonOptions, errors) = getOpt Permute options args + + when (length errors > 0) (do + putStrLn $ concat errors + putStrLn $ usageInfo header options + exitWith (ExitFailure 1)) + + -- Here we thread startOptions through all supplied option actions + opts <- foldl (>>=) (return startOptions) actions + + when (length nonOptions /= 1) (do + putStrLn "ERROR: Exactly one input file expected." + exitWith (ExitFailure 1)) + + let Options { optSingleFunction = functionMode + , optOutputFileName = maybeOutputFileName + , optDotGeneration = dotGeneration + , optDotFileName = dotFileName + , optCompilerMode = compilerMode } = opts + let inputFileName = head nonOptions -- change it for multi-file operation + let outputFileName = convertOutputFileName inputFileName maybeOutputFileName + + when (not $ compilerMode `elem` + ["defaultOptions", "unrollOptions", "noSimplification", "noPrimitiveInstructionHandling"]) (do + putStrLn $ "Invalid compiler mode \"" ++ compilerMode ++ "\"" + exitWith (ExitFailure 1)) + + compilationCore functionMode inputFileName outputFileName opts dotGeneration dotFileName compilerMode + +compilationCore functionMode inputFileName outputFileName commandLineOptions dotGeneration dotFileName compilerMode = do + putStrLn $ "Starting the Standalone Feldspar Compiler..." + + removeFile outputFileName `catch` (const $ return ()) + fileDescriptor <- openFile inputFileName ReadMode + fileContents <- hGetContents fileDescriptor + putStrLn $ "Parsing source file with the precompiler..." + declarationList <- return $ getDeclarationList fileContents + moduleName <- return $ getModuleName fileContents + + let highLevelInterpreterWithModuleInfo = highLevelInterpreter moduleName inputFileName + + -- Dot generation + case commandLineOptions of + Options { optDotGeneration = True} -> do + putStrLn "Dot generation enabled" + case functionMode of + SingleFunction functionName -> case dotFileName of + Just fileName -> highLevelInterpreterWithModuleInfo + (generalInterpreterBody $ "writeDot \"" ++ fileName ++ "\" " ++ functionName) + Nothing -> highLevelInterpreterWithModuleInfo + (generalInterpreterBody $ "putStr $ fs2dot " ++ functionName) + MultiFunction -> putStrLn $ "ERROR: Dot generation requested, but not supported in multi-function mode\n"++ + "(use the \"-f function\" option to enable single-function mode)" + _ -> putStrLn "Dot generation disabled" + + -- C code generation + case functionMode of + MultiFunction -> do + putStrLn $ "Multi-function mode, compiling " ++ (show $ length declarationList) ++ " functions..." + highLevelInterpreterWithModuleInfo + (multiFunctionCompilationBody outputFileName compilerMode declarationList) + SingleFunction functionName -> do + putStrLn $ "Single-function mode, compiling function " ++ functionName ++ "..." + highLevelInterpreterWithModuleInfo + (singleFunctionCompilationBody outputFileName compilerMode functionName) + +say :: String -> Interpreter () +say = liftIO . putStrLn diff --git a/Feldspar/Compiler/Imperative/Representation.hs b/Feldspar/Compiler/Imperative/Representation.hs new file mode 100644 --- /dev/null +++ b/Feldspar/Compiler/Imperative/Representation.hs @@ -0,0 +1,485 @@ +{- + - Copyright (c) 2009, 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. + -} + +module Feldspar.Compiler.Imperative.Representation where + +import Data.Maybe +import qualified Data.Map as Map + +------------------------------------------------ +-- Data types to encode an imperative program -- +------------------------------------------------ + +data Size = + S4 + | S8 + | S16 + | S32 + | S64 + deriving (Eq,Show) + +data Signedness = + ImpSigned + | ImpUnsigned + deriving (Eq,Show) + +data Type = + BoolType + | FloatType + | Numeric Signedness Size + | ImpArrayType (Maybe Int) Type + | Pointer Type + deriving (Eq,Show) + +data ImpLangExpr = + Expr + { exprCore :: UntypedExpression + , exprType :: Type + } + deriving (Eq,Show) + +data Variable = + Var { name :: String, kind :: ParameterKind, vartype :: Type} + deriving (Eq,Show) + +data LeftValue = + LVar Variable + | ArrayElem + LeftValue -- array variable + ImpLangExpr -- index + | PointedVal LeftValue + deriving (Eq, Show) + +data UntypedExpression = + LeftExpr LeftValue + | AddressOf LeftValue + | ConstExpr Constant + | FunCall FunRole String [ImpLangExpr] + deriving (Eq,Show) + +data Constant + = IntConst Int + | FloatConst Float + | BoolConst Bool + | ArrayConst Int [Constant] + deriving (Eq,Show) + +data FunRole = SimpleFun | InfixOp | PrefixOp deriving (Eq,Show) + +data Instruction = + Assign LeftValue ImpLangExpr + | CFun String [Parameter] + deriving (Eq,Show) + +data Parameter + = In ImpLangExpr + | Out (ParameterKind,ImpLangExpr) + deriving (Eq,Show) + +data ParameterKind = Normal | OutKind + deriving (Eq,Show) + +data ImpFunction = + Fun { funName :: String, + inParameters :: [Declaration], + outParameters :: [Declaration], + prg :: CompleteProgram + } + deriving (Eq,Show) + +data CompleteProgram = + CompPrg { + locals :: [Declaration], + body :: Program + } + deriving (Eq,Show) + +data Declaration + = Decl + { var :: Variable + , declType :: Type + , initVal :: Maybe ImpLangExpr + , semInfVar :: SemInfVar + } + deriving (Eq,Show) + +data Program = + Empty + | Primitive Instruction SemInfPrim + | Seq [Program] SemInfPrgSeq + | IfThenElse + Variable -- condition variable + CompleteProgram -- then part + CompleteProgram -- else part + SemInfIf -- semantic info + | SeqLoop + Variable -- condition variable + CompleteProgram -- condition calculation + CompleteProgram -- loop body + SemInfSeqLoop -- semantic info + | ParLoop + Variable -- counter (this is expected to be an integer) + ImpLangExpr -- number of iterations + Int -- step + CompleteProgram -- loop body + SemInfParLoop -- semantic info + deriving (Eq,Show) + +data Array = + Array + Variable -- array typed var + Type -- element type + Int -- length of array + deriving (Eq,Show) + +------------------------ +-- C code genetartion -- +------------------------ + +class ToC a where + toC :: Int -> a -> String + +compToC :: ToC a => a -> String +compToC x = toC 0 x + +instance ToC Size where + toC sc S8 = "char" + toC sc S16 = "short" + toC sc S32 = "int" + toC sc S64 = "long" + +instance ToC Signedness where + toC sc ImpSigned = "signed" + toC sc ImpUnsigned = "unsigned" + +instance ToC ImpLangExpr where + toC sc (Expr ue t) = toC sc ue + +instance ToC Type where + toC sc BoolType = "int" + toC sc FloatType = "float" + toC sc (Numeric sig siz) = (toC sc sig) ++ " " ++ (toC sc siz) + toC sc (ImpArrayType _ t) = (toC sc t) ++ "[]" -- TODO: ImpArrayType Just ... + toC sc (Pointer t) = (toC sc t) ++ "*" + +instance ToC Variable where + toC sc (Var s k t) + | simpleType t && k == OutKind = "*" ++ s + | otherwise = s + +instance ToC LeftValue where + toC sc (LVar v) = toC sc v + toC sc (ArrayElem v e) = (toC sc v) ++ "[" ++ (toC sc e) ++ "]" + toC sc (PointedVal v) = ("*(" ++ toC sc v ++ ")") + +instance ToC UntypedExpression where + toC sc (LeftExpr v) = (toC sc v) + toC sc (AddressOf v) = ("&(" ++ toC sc v ++ ")") + toC sc (ConstExpr c) = toC sc c + toC sc (FunCall InfixOp s [a,b]) = "(" ++ toC sc a ++ " " ++ s ++ " " ++ toC sc b ++ ")" + toC sc (FunCall _ s es) = s ++ "(" ++ (listprint (toC sc) ", " es) ++ ")" + +instance ToC Constant where + toC sc (IntConst i) = show i + toC sc (FloatConst i) = show i ++ "f" + toC sc (BoolConst True) = "1" + toC sc (BoolConst False) = "0" + toC sc (ArrayConst ln elements) = "{" ++ toCArray (ArrayConst ln elements) ++ "}" + +toCArray:: Constant -> String +toCArray (ArrayConst ln elements) = listprint toCArray "," elements +toCArray i = toC 0 i + +instance ToC Instruction where + toC sc (Assign v e) = (toC sc v) ++ " = " ++ (toC sc e) + toC sc (CFun s es) = s ++ "(" ++ (listprint (toC sc) ", " es) ++ ")" + +instance ToC Parameter where + toC sc (In e) = toC sc e + toC sc (Out (kind,e)) + | kind == Normal && simpleType (exprType e) = "&(" ++ toC sc e ++ ")" + | otherwise = toC sc e + +instance ToC ImpFunction where + toC sc (Fun funName inParameters outParameters prg) = + "void " ++ funName + ++ "( " ++ ( listprint toCParam ", " $ inParameters ++ outParameters ) ++ " )" -- function parameters + ++ "\n{\n" ++ (toC (sc+1) prg) ++ "}\n\n" -- core function + where + toCParam:: Declaration -> String + toCParam (Decl v BoolType _ _) = toC 0 BoolType ++ (' ' : (toC 0 v)) + toCParam (Decl v FloatType _ _) = toC 0 FloatType ++ (' ' : (toC 0 v)) + toCParam (Decl v n@(Numeric sig siz) _ _) = (toC 0 n) ++ " " ++ (toC 0 v) + toCParam (Decl v (Pointer t) _ _) = (toC 0 t) ++ "* " ++ (toC 0 v) + toCParam (Decl v t _ _) = (toCPrimType t) ++ " " ++ (toC 0 v) ++ arrayDepths t + +arrayDepths :: Type -> String +arrayDepths (ImpArrayType (Just n) t) = "["++(show n)++"]" ++ arrayDepths t +arrayDepths (ImpArrayType Nothing t) = "[16]" ++ arrayDepths t +arrayDepths _ = "" + +instance ToC CompleteProgram where + toC sc (CompPrg locals body) = (foldl (++) "" (map (\x-> (toC sc x)) locals)) ++ "\n" ++ (toC sc body) + +instance ToC Declaration where + toC sc (Decl var declType initExpr inf) + = tab sc ++ (toCdecl var declType "" (isInit initExpr)) ++ (declMay initExpr) ++ ";\n" + -- without seminf + -- = tab sc ++ (toCdecl var declType "" (isInit initExpr)) ++ (declMay initExpr) ++ "; " ++ show inf ++ "\n" + -- with seminf + where + declMay :: (Maybe ImpLangExpr) -> String + declMay (Just initVal) = " = " ++ (toC 0 initVal) + declMay Nothing = "" + + toCdecl:: Variable -> Type -> String -> Bool -> String + toCdecl var (ImpArrayType _ t) _ True = (toCPrimType t) ++ (replicateArrayDepth t "*" 1) ++ " " ++ (toC 0 var) + toCdecl var (ImpArrayType Nothing t) str False = (toCdecl var t (str ++ "[16]") False) + toCdecl var (ImpArrayType (Just ln) t) str False = (toCdecl var t (str ++ "["++ show ln ++"]") False) + toCdecl var declType str _ = (toC 0 declType) ++ " " ++ (toC 0 var) ++ str + + isInit Nothing = False + isInit (Just initExpr) = + case exprCore initExpr of + (ConstExpr _) -> False + _ -> True + +instance ToC Program where + toC sc Empty = "" + toC sc (Primitive i seminf) + = (tab sc) ++ (toC sc i) ++ ";\n" -- without seminf + -- = (tab sc) ++ (toC sc i) ++ ";\n" ++ toC (sc+1) seminf ++ "\n" -- with seminf + toC sc (Seq ps _) = foldr (++) "" $ map (toC sc) ps + toC sc (IfThenElse con tPrg ePrg _) + = (tab sc) ++ "if(" ++ (toC sc con) ++ ")\n"++ (tab sc) ++"{\n" ++ (toC (sc+1) tPrg) ++ (tab sc) ++ "}\n" + ++ (tab sc) ++ "else\n" ++ (tab sc) ++ "{\n" ++ (toC (sc+1) ePrg) ++ (tab sc) ++ "}\n" + toC sc (SeqLoop condVar condCalc loopBody _) + = (tab sc) ++ "{\n" ++ (toC (sc+1) condCalc) ++ (tab $ sc+1) + ++ "while(" ++ (toC 0 condVar) ++ ")\n" ++ tab (sc+1) ++ "{\n" + ++ (toC (sc+2) loopBody) ++ (toC (sc+2) (body condCalc)) ++ (tab $ sc+1) ++ "}\n" ++ (tab sc) ++ "}\n" + toC sc (ParLoop (Var cv _ _) num step prg _) = (tab sc) ++ "{\n" ++ toCPar (sc+1) ++ (tab sc) ++ "}\n" + where toCPar sc = + (tab sc) ++ "int " ++ cv ++ ";\n" + ++ (tab sc) ++ "for( " ++ cv ++ " = 0; " ++ cv ++ " < " ++ (toC 0 num) ++ "; " ++ cv ++ " += " ++ (show step) ++")\n" + ++ (tab sc) ++ "{\n" ++ (toC (sc+1) prg) ++ (tab sc) ++ "}\n" + +instance ToC SemInfPrim where + toC sc seminf + | output seminf = tab sc ++ "// !!!\n" ++ stat + | otherwise = stat + where + stat = tab sc ++ "// " ++ listprint (\(var,stat) -> var ++ " in this instruction: " ++ show stat) ("\n" ++ tab sc ++ "// ") (Map.toList $ varMap seminf) + +instance ToC a => ToC (Maybe a) where + toC sc Nothing = "" + toC sc (Just a) = toC sc a + +instance (ToC a) => ToC [a] where + toC sc xs = concatMap (toC sc) xs + +instance ToC Array where + toC sc (Array v t i) = (toC sc v) + +---------------------- +-- Helper functions -- +---------------------- + +simpleType :: Type -> Bool +simpleType BoolType = True +simpleType FloatType = True +simpleType (Numeric _ _) = True +simpleType (ImpArrayType _ _) = False +simpleType (Feldspar.Compiler.Imperative.Representation.Pointer _) = False + +toCPrimType:: Type -> String +toCPrimType (ImpArrayType _ t) = toCPrimType t +toCPrimType t = toC 0 t + +isArrayType:: Type -> String +isArrayType (ImpArrayType _ t) = "* const" +isArrayType _ = "" + +tab sc = replicate (sc * 4) ' ' + +listprint :: (a->String) -> String -> [a] -> String +listprint _ _ [] = "" +listprint f _ [x] = f x +listprint f s (x:y:xs) = f x ++ s ++ listprint f s (y:xs) + +toLeftValue :: ImpLangExpr -> LeftValue +toLeftValue (Expr (LeftExpr lv) _) = lv +toLeftValue e = error $ "Error: " ++ toC 0 e ++ " is not a left value." + +replicateArrayDepth:: Type -> String -> Int-> String --String: what to replicate; Int: modifier +replicateArrayDepth t n m = filter (/=' ') $ unwords $ replicate ( (arrayDepth t) +m) n +arrayDepth:: Type -> Int +arrayDepth (ImpArrayType _ t) = 1 + (arrayDepth t) +arrayDepth _ = 0 + +getVariable :: ImpLangExpr -> Maybe Variable +getVariable (Expr (LeftExpr (LVar v)) _) = Just v +getVariable _ = Nothing + +contains :: String -> ImpLangExpr -> Bool +contains n (Expr e _) = contains' n e where + contains' n (LeftExpr lv) = contains'' n lv + contains' n (AddressOf lv) = contains'' n lv + contains' _ (ConstExpr _) = False + contains' n (FunCall _ _ es) = any (contains n) es + contains'' n (LVar (Var n' _ _)) = n == n' + contains'' n (ArrayElem lv exp) = contains'' n lv || contains n exp + contains'' n (PointedVal lv) = contains'' n lv + +getVarName :: LeftValue -> String +getVarName (LVar (Var n _ _)) = n +getVarName (ArrayElem lv _) = getVarName lv +getVarName (PointedVal lv) = getVarName lv + +getLeftValue :: ImpLangExpr -> LeftValue +getLeftValue (Expr (LeftExpr lv) t) = lv +getLeftValue e = error $ "Error in Compiler.Imperative.Representation.getLeftValue:\n" ++ toC 0 e + +{- +isInParam :: Parameter -> Bool +isInParam (In _) = True +isInParam _ = False +-} + +-------------------------------------- +-- Semantics of imperative programs -- +-------------------------------------- + +type VariableMap = Map.Map String SemInfVar + +data SemInfPrim + = SemInfPrim + { varMap :: VariableMap + , output :: Bool + } + deriving (Eq,Show) + +data SemInfVar + = SemInfVar + { usedLeft :: LeftUse + , usedRight :: RightUse + } + deriving (Eq) + +instance Show SemInfVar where + show sem = show (usedLeft sem) ++ ", " ++ show (usedRight sem) + +unknownSemInfVar = SemInfVar UnknownL UnknownR + +data LeftUse = UnknownL | None | Single (Maybe ImpLangExpr) | MultipleL + deriving (Eq) + +data RightUse = UnknownR | Times Int | MultipleR + deriving (Eq) + +getValue :: SemInfVar -> ImpLangExpr +getValue s = case usedLeft s of + Single (Just expr) -> expr + otherwise -> error $ "Error in Representation.getValue for the semantic information:\n" ++ show s + +leftVars :: VariableMap -> [String] +leftVars sem = Map.keys $ Map.filter isLeft sem where + isLeft :: SemInfVar -> Bool + isLeft sem + | usedLeft sem == None = False + | otherwise = True + +instance Show LeftUse where + show l = "set: " ++ case l of + UnknownL -> "no information" + None -> "never" + Single Nothing -> "once" + Single (Just e) -> "once (" ++ toC 0 e ++ ")" + MultipleL -> "multiple times" + +instance Show RightUse where + show r = "used: " ++ case r of + UnknownR -> "no information" + Times i -> show i ++ " times" + MultipleR -> "multiple times" + +type SemInfPrgSeq = [String] +type SemInfBr = [String] +type SemInfParLoop = [String] +type SemInfIf = [String] +type SemInfSeqLoop = [String] +type SemInfSeq = [String] + +-------------------------------------------------------- +-- Computing statistics of variables in an expression -- +-- on the right and left hand sides of an assignement -- +-------------------------------------------------------- + +class RightVarMap a where + rightVarMap :: a -> VariableMap + +instance RightVarMap ImpLangExpr where + rightVarMap e = rightVarMap $ exprCore e + +instance RightVarMap UntypedExpression where + rightVarMap (LeftExpr lv) = rightVarMap lv + rightVarMap (AddressOf lv) = rightVarMap lv + rightVarMap (ConstExpr _) = Map.empty + rightVarMap (FunCall _ _ es) = foldr addVarMap Map.empty $ map rightVarMap es + +instance RightVarMap LeftValue where + rightVarMap (LVar (Var name _ _)) = Map.singleton name $ SemInfVar None (Times 1) + rightVarMap (ArrayElem lv e) = addVarMap (rightVarMap lv) (rightVarMap e) + rightVarMap (PointedVal e) = rightVarMap e + +leftVarMap :: LeftValue -> Maybe ImpLangExpr -> VariableMap +leftVarMap (LVar (Var name _ _)) expr = Map.singleton name $ SemInfVar (Single expr) (Times 0) +leftVarMap (ArrayElem lv e) _ = addVarMap (leftVarMap lv Nothing) (rightVarMap e) +leftVarMap (PointedVal e) _ = leftVarMap e Nothing + +addVarMap :: VariableMap -> VariableMap -> VariableMap +addVarMap m1 m2 = Map.unionWith addSemInfVar m1 m2 where + +addSemInfVar s1 s2 + = SemInfVar + { usedLeft = combineLeft (usedLeft s1) (usedLeft s2) + , usedRight = combineRight (usedRight s1) (usedRight s2) + } where + combineLeft UnknownL _ = UnknownL + combineLeft _ UnknownL = UnknownL + combineLeft None x = x + combineLeft x None = x + combineLeft _ _ = MultipleL + combineRight UnknownR _ = UnknownR + combineRight _ UnknownR = UnknownR + combineRight (Times x) (Times y) = Times (x + y) + combineRight _ _ = MultipleR + diff --git a/Feldspar/Compiler/Optimization/PrimitiveInstructions.hs b/Feldspar/Compiler/Optimization/PrimitiveInstructions.hs new file mode 100644 --- /dev/null +++ b/Feldspar/Compiler/Optimization/PrimitiveInstructions.hs @@ -0,0 +1,191 @@ +{- + - Copyright (c) 2009, 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. + -} + +module Feldspar.Compiler.Optimization.PrimitiveInstructions where + +import Feldspar.Compiler.Imperative.Representation +import Feldspar.Compiler.Options +import Data.Map hiding (filter,map) + +-- Implementation of the mapping from high-level DSL primitives +-- to low level primitive instructions. + +class HandlePrimitives t where + handlePrimitives :: Options -> t -> t + +instance (HandlePrimitives a) => HandlePrimitives [a] where + handlePrimitives opts = map (handlePrimitives opts) + +instance HandlePrimitives ImpFunction where + handlePrimitives opts (Fun n i o prg) = Fun n i o $ handlePrimitives opts prg + +instance HandlePrimitives CompleteProgram where + handlePrimitives opts (CompPrg d b) = CompPrg d $ handlePrimitives opts b + +instance HandlePrimitives Program where + handlePrimitives opts Empty = Empty + handlePrimitives opts (Primitive instr s) = transformPrimitive opts instr s + handlePrimitives opts (Seq prgs s) = Seq (map (handlePrimitives opts) prgs) s + handlePrimitives opts (IfThenElse v b1 b2 s) = IfThenElse v (handlePrimitives opts b1) (handlePrimitives opts b2) s + handlePrimitives opts (SeqLoop cnd condCalc bod s) + = SeqLoop cnd (handlePrimitives opts condCalc) (handlePrimitives opts bod) s + handlePrimitives opts (ParLoop cnt max st bod s) = ParLoop cnt max st (handlePrimitives opts bod) s + +transformPrimitive :: Options -> Instruction -> SemInfPrim -> Program +{- -- Do we still have a 'tuple' function? +transformPrimitive opt i@(CFun "tuple" ps) s + | length ins == length outs + = Seq (map (\pair -> mkCopy opt pair s) $ zip ins outs) [] + | otherwise + = error ("Error: Number of parameters is odd in a 'tuple' call.\n\t" ++ toC 0 i) + where + ins = inParams ps + outs = outParams ps +-} +transformPrimitive opts (CFun "(==)" [In in1, In in2, Out out]) s = op2 in1 in2 out "==" "equal" s +transformPrimitive opts (CFun "(/=)" [In in1, In in2, Out out]) s = op2 in1 in2 out "!=" "not_equal" s +transformPrimitive opts (CFun "(<)" [In in1, In in2, Out out]) s = op2 in1 in2 out "<" "less" s +transformPrimitive opts (CFun "(>)" [In in1, In in2, Out out]) s = op2 in1 in2 out ">" "greater" s +transformPrimitive opts (CFun "(<=)" [In in1, In in2, Out out]) s = op2 in1 in2 out "<=" "less_equal" s +transformPrimitive opts (CFun "(>=)" [In in1, In in2, Out out]) s = op2 in1 in2 out ">=" "greater_equal" s +transformPrimitive opts (CFun "not" [In in1, Out out]) s = op1 in1 out "!" "not" s +transformPrimitive opts (CFun "(&&)" [In in1, In in2, Out out]) s = op2 in1 in2 out "&&" "and" s +transformPrimitive opts (CFun "(||)" [In in1, In in2, Out out]) s = op2 in1 in2 out "||" "or" s +transformPrimitive opts (CFun "div" [In in1, In in2, Out out]) s = op2 in1 in2 out "/" "divide" s +transformPrimitive opts (CFun "(^)" [In in1, In in2, Out out]) s = fun2 in1 in2 out "pow" s + +transformPrimitive opts (CFun "abs" [In in1, Out out]) s = fun1 in1 out "abs" s +transformPrimitive opts (CFun "signum" [In in1, Out out]) s = fun1 in1 out "signum" s +transformPrimitive opts (CFun "(+)" [In in1, In in2, Out out]) s = op2 in1 in2 out "+" "add" s +transformPrimitive opts (CFun "(-)" [In in1, In in2, Out out]) s = op2 in1 in2 out "-" "sub" s +transformPrimitive opts (CFun "(*)" [In in1, In in2, Out out]) s = op2 in1 in2 out "*" "mult" s +transformPrimitive opts (CFun "(/)" [In in1, In in2, Out out]) s = op2 in1 in2 out "/" "divide" s + +transformPrimitive opts (CFun "(!)" [In arr, In idx, Out (kind,out)]) s + = Primitive (Assign left right) semInf + where + left = toLeftValue out + right = Expr (LeftExpr $ ArrayElem (toLeftValue arr) idx) $ exprType out + semInf = s{ varMap = addVarMap (leftVarMap left $ Just right) (rightVarMap right) } +transformPrimitive opts (CFun "setIx" [In original, In index, In value, Out (kind,result)]) s + = Seq + [ mkCopy opts (original,(kind, result)) s + , mkCopy opts (value, (Normal,Expr (LeftExpr $ ArrayElem (toLeftValue result) index) $ exprType value)) s + ] [] +transformPrimitive opts (CFun "copy" [In in1, Out (kind,out)]) s + | simpleType (exprType in1) && kind == Normal + = Primitive (Assign (toLeftValue out) $ in1) semInf + | simpleType (exprType in1) && kind == OutKind + = Primitive (Assign (PointedVal $ toLeftValue out) $ in1) semInf + | otherwise = Primitive (CFun ("copy" ++ "_" ++ toFunName (exprType in1)) ([In in1] ++ arrayDim (exprType in1) ++ [Out (kind,out)])) semInf + where + semInf = s{ varMap = vm } + vm = addVarMap (leftVarMap (toLeftValue out) $ Just in1) (rightVarMap in1) + arrayDim (ImpArrayType (Just n) t) = In (Expr (ConstExpr (IntConst n)) (Numeric ImpSigned S32)) : arrayDim t + arrayDim (ImpArrayType Nothing t) = In (Expr (ConstExpr (IntConst 16)) (Numeric ImpSigned S32)) : arrayDim t + arrayDim _ = [] + +transformPrimitive opts c@(CFun "copy" pars) s + | length ins /= length outs = error $ "Error: invalid arguments to 'copy':\n" ++ toC 0 c + | otherwise = Seq (map genTwoParamCopy $ zip ins outs) [] + where + ins = filter inparam pars + outs = filter (not . inparam) pars + genTwoParamCopy (i,o) = transformPrimitive opts (CFun "copy" [i,o]) s + +transformPrimitive _ i@(CFun _ pars) s = Primitive i semInf where + semInf = s{ varMap = foldr addVarMap Data.Map.empty mapList } + mapList + = map rightVarMap (inParams pars) + ++ map (\out -> leftVarMap (toLeftValue out) Nothing) (map snd $ outParams pars) + +fun1 in1 (kind,out) cFunName s + | simpleType (exprType out) && kind == Normal + = Primitive (Assign (toLeftValue out) right) semInf + | simpleType (exprType out) && kind == OutKind + = Primitive (Assign (PointedVal $ toLeftValue out) right) semInf + | otherwise + = Primitive (CFun (cFunName ++ "_" ++ toFunName (exprType in1)) [In in1, Out (kind,out)]) semInf + where + right = Expr (FunCall SimpleFun (cFunName ++ "_fun_" ++ toFunName (exprType in1)) [in1]) (exprType out) + semInf = s{ varMap = addVarMap (leftVarMap (toLeftValue out) $ Just right) (rightVarMap right) } + +fun2 in1 in2 (kind,out) cFunName s + | simpleType (exprType out) && kind == Normal + = Primitive (Assign (toLeftValue out) right) semInf + | simpleType (exprType out) && kind == OutKind + = Primitive (Assign (PointedVal $ toLeftValue out) right) semInf + | otherwise + = Primitive (CFun (cFunName ++ "_" ++ toFunName (exprType in1)) [In in1, In in2, Out (kind,out)]) semInf + where + right = Expr (FunCall SimpleFun (cFunName ++ "_fun_" ++ toFunName (exprType in1)) [in1, in2]) (exprType out) + semInf = s{varMap = addVarMap (leftVarMap (toLeftValue out) $ Just right) (rightVarMap right) } + +op1 in1 (kind,out) cOpName cFunName s + | simpleType (exprType out) && kind == Normal + = Primitive (Assign (toLeftValue out) right) semInf + | simpleType (exprType out) && kind == OutKind + = Primitive (Assign (PointedVal $ toLeftValue out) right) semInf + | otherwise + = Primitive (CFun (cFunName ++ "_" ++ toFunName (exprType in1)) [In in1, Out (kind,out)]) semInf + where + right = Expr (FunCall PrefixOp cOpName [in1]) $ exprType out + semInf = s{ varMap = addVarMap (leftVarMap (toLeftValue out) $ Just right) (rightVarMap right) } + +op2 in1 in2 (kind,out) cOpName cFunName s + | simpleType (exprType out) && kind == Normal + = Primitive (Assign (toLeftValue out) right) semInf + | simpleType (exprType out) && kind == OutKind + = Primitive (Assign (PointedVal $ toLeftValue out) right) semInf + | otherwise + = Primitive (CFun (cFunName ++ "_" ++ toFunName (exprType in1)) [In in1, In in2, Out (kind,out)]) semInf + where + right = Expr (FunCall InfixOp cOpName [in1,in2]) $ exprType out + semInf = s{ varMap = addVarMap (leftVarMap (toLeftValue out) $ Just right) (rightVarMap right) } + +inParams ps = map (\(In x) -> x) $ filter inparam ps +outParams ps = map (\(Out x) -> x) $ filter (not . inparam) ps + +inparam p = case p of + In _ -> True + Out _ -> False + +mkCopy opt (in1,out) s = transformPrimitive opt (CFun "copy" [In in1, Out out]) s + + +toFunName :: Type -> String +toFunName BoolType = "bool" +toFunName FloatType = "float" +toFunName (Numeric sig siz) = toC 0 sig ++ "_" ++ toC 0 siz +toFunName (ImpArrayType _ t) = "arrayOf_" ++ toFunName t +toFunName (Feldspar.Compiler.Imperative.Representation.Pointer t) = "pointerTo_" ++ toFunName t + diff --git a/Feldspar/Compiler/Optimization/Replace.hs b/Feldspar/Compiler/Optimization/Replace.hs new file mode 100644 --- /dev/null +++ b/Feldspar/Compiler/Optimization/Replace.hs @@ -0,0 +1,173 @@ +{- + - Copyright (c) 2009, 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. + -} + +module Feldspar.Compiler.Optimization.Replace where + +import Feldspar.Compiler.Imperative.Representation + +--This class for the replace of a variable to an other variable, an expression or a leftvalue in any datatypes. +class Replace a where + replaceVar :: a -> (String,String) -> a + replaceUExpr :: a -> (String,UntypedExpression) -> a + replaceLExpr :: a -> (String,LeftValue) -> a + +instance Replace ImpLangExpr where + replaceVar (Expr exprCore exprType) re = Expr (replaceVar exprCore re) exprType + replaceUExpr (Expr exprCore exprType) re = Expr (replaceUExpr exprCore re) exprType + replaceLExpr (Expr exprCore exprType) re = Expr (replaceLExpr exprCore re) exprType + +instance Replace Variable where + replaceVar (Var s k t) (s0,s1) + | s == s0 = (Var s1 k t) + | otherwise = (Var s k t) + replaceUExpr v _ = v + replaceLExpr v _ = v + +instance Replace LeftValue where + replaceVar (LVar v) re = LVar (replaceVar v re) + replaceVar (ArrayElem lv i) re = ArrayElem (replaceVar lv re) (replaceVar i re) + replaceVar (PointedVal lv) re = PointedVal (replaceVar lv re) + replaceUExpr (LVar v) re = LVar v + replaceUExpr (ArrayElem lv i) re = ArrayElem lv (replaceUExpr i re) + replaceUExpr (PointedVal lv) re = PointedVal (replaceUExpr lv re) + replaceLExpr (LVar v) (n,l) + | n == name v = l + | otherwise = LVar v + replaceLExpr (ArrayElem lv i) re = ArrayElem (replaceLExpr lv re) (replaceLExpr i re) + replaceLExpr (PointedVal lv) re = PointedVal (replaceLExpr lv re) + +instance Replace Constant where + replaceVar (IntConst i) (s0,s1) + | s0 == (show i) = IntConst (read s1::Int) + | otherwise = IntConst i + replaceVar (FloatConst i) (s0,s1) + | s0 == (show i) = FloatConst (read s1::Float) + | otherwise = FloatConst i + replaceVar (BoolConst b) (s0,s1) + | s0 == (show b) = BoolConst (read s1::Bool) + | otherwise = BoolConst b + replaceVar a@(ArrayConst i cs) _ = a + replaceUExpr c _ = c -- error "Error in replace: 'repaceUExpr' called on a constant." + replaceLExpr c _ = c -- error "Error in replace: 'repaceLExpr' called on a constant." + +instance Replace UntypedExpression where + replaceVar (LeftExpr lv) re = LeftExpr (replaceVar lv re) + replaceVar (AddressOf lv) re = AddressOf (replaceVar lv re) + replaceVar (ConstExpr c) re = ConstExpr (replaceVar c re) + replaceVar (FunCall r s is) re = FunCall r s (replaceVar is re) + replaceUExpr (LeftExpr (LVar (Var varname k t))) (name,expr) + | varname == name = expr + | otherwise = (LeftExpr (LVar (Var varname k t))) + replaceUExpr (LeftExpr l) re = LeftExpr (replaceUExpr l re) + replaceUExpr (AddressOf l) re = AddressOf $ replaceUExpr l re + replaceUExpr (ConstExpr s) _ = (ConstExpr s) + replaceUExpr (FunCall r s is) re = (FunCall r s (replaceUExpr is re)) + replaceLExpr (LeftExpr lv) re = LeftExpr (replaceLExpr lv re) + replaceLExpr (AddressOf lv) re = AddressOf (replaceLExpr lv re) + replaceLExpr (ConstExpr c) re = ConstExpr (replaceLExpr c re) + replaceLExpr (FunCall r s is) re = FunCall r s (replaceLExpr is re) + +instance Replace Instruction where + replaceVar (Assign lv i) re = Assign (replaceVar lv re) (replaceVar i re) + replaceVar (CFun s ps) re = CFun s (replaceVar ps re) + replaceUExpr (Assign lv i) re = Assign (replaceUExpr lv re) (replaceUExpr i re) + replaceUExpr (CFun s ps) re = CFun s (replaceUExpr ps re) + replaceLExpr (Assign lv i) re = Assign (replaceLExpr lv re) (replaceLExpr i re) + replaceLExpr (CFun s ps) re = CFun s (replaceLExpr ps re) + +instance Replace Parameter where + replaceVar (In i) re = In (replaceVar i re) + replaceVar (Out (pk,i)) re = Out (pk, (replaceVar i re)) + replaceUExpr (In i) re = In (replaceUExpr i re) + replaceUExpr (Out (pk,i)) re = Out (pk, (replaceUExpr i re)) + replaceLExpr (In i) re = In (replaceLExpr i re) + replaceLExpr (Out (pk,i)) re = Out (pk, (replaceLExpr i re)) + +instance Replace ImpFunction where + replaceVar (Fun funName inParamteters outParameters prg) re = Fun funName (replaceVar inParamteters re) (replaceVar outParameters re) (replaceVar prg re) + replaceUExpr (Fun funName inParamteters outParameters prg) re = Fun funName (replaceUExpr inParamteters re) (replaceUExpr outParameters re) (replaceUExpr prg re) + replaceLExpr (Fun funName inParamteters outParameters prg) re = Fun funName (replaceLExpr inParamteters re) (replaceLExpr outParameters re) (replaceLExpr prg re) + +instance Replace CompleteProgram where + replaceVar (CompPrg locals body) re = CompPrg (replaceVar locals re) (replaceVar body re) + replaceUExpr (CompPrg locals body) re = CompPrg (replaceUExpr locals re) (replaceUExpr body re) + replaceLExpr (CompPrg locals body) re = CompPrg (replaceLExpr locals re) (replaceLExpr body re) + +instance Replace Declaration where + replaceVar (Decl var declType initval sem) re = Decl (replaceVar var re) declType (replaceVar initval re) sem + replaceUExpr (Decl var declType initval sem) re = Decl var declType (replaceUExpr initval re) sem + replaceLExpr (Decl var declType initval sem) re = Decl var declType (replaceLExpr initval re) sem + +instance Replace Program where + replaceVar (Primitive i inf) re = Primitive (replaceVar i re) inf + replaceVar (Seq ps inf) re = Seq (replaceVar ps re) inf + replaceVar (IfThenElse v cpt cpe inf) re = IfThenElse (replaceVar v re) (replaceVar cpt re) (replaceVar cpe re) inf + replaceVar (ParLoop v max step cp inf) re = ParLoop (replaceVar v re) max step (replaceVar cp re) inf + replaceVar (SeqLoop cond calcCp bodyCp inf) re = SeqLoop (replaceVar cond re) (replaceVar calcCp re) (replaceVar bodyCp re) inf + replaceVar Empty _ = Empty + replaceUExpr (Primitive i inf) re = Primitive (replaceUExpr i re) inf + replaceUExpr (Seq ps inf) re = Seq (replaceUExpr ps re) inf + replaceUExpr (IfThenElse v cpt cpe inf) re = IfThenElse (replaceUExpr v re) (replaceUExpr cpt re) (replaceUExpr cpe re) inf + replaceUExpr (ParLoop v max step cp inf) re = ParLoop (replaceUExpr v re) max step (replaceUExpr cp re) inf + replaceUExpr (SeqLoop cond calcCp bodyCp inf) re = SeqLoop (replaceUExpr cond re) (replaceUExpr calcCp re) (replaceUExpr bodyCp re) inf + replaceUExpr Empty _ = Empty + replaceLExpr (Primitive i inf) re = Primitive (replaceLExpr i re) inf + replaceLExpr (Seq ps inf) re = Seq (replaceLExpr ps re) inf + replaceLExpr (IfThenElse v cpt cpe inf) re = IfThenElse (replaceLExpr v re) (replaceLExpr cpt re) (replaceLExpr cpe re) inf + replaceLExpr (ParLoop v max step cp inf) re = ParLoop (replaceLExpr v re) max step (replaceLExpr cp re) inf + replaceLExpr (SeqLoop cond calcCp bodyCp inf) re = SeqLoop (replaceLExpr cond re) (replaceLExpr calcCp re) (replaceLExpr bodyCp re) inf + replaceLExpr Empty _ = Empty + +instance Replace Array where + replaceVar (Array v t i) re = Array (replaceVar v re) t i + replaceUExpr (Array v t i) re = Array v t i + replaceLExpr (Array v t i) re = Array v t i + +instance (Replace a) => Replace [a] where + replaceVar l re = map (\x -> replaceVar x re) l + replaceUExpr l re = map (\x -> replaceUExpr x re) l + replaceLExpr l re = map (\x -> replaceLExpr x re) l + +instance (Replace a) => Replace (Maybe a) where + replaceVar l re = fmap (\x -> replaceVar x re) l + replaceUExpr l re = fmap (\x -> replaceUExpr x re) l + replaceLExpr l re = fmap (\x -> replaceLExpr x re) l + +instance (Replace a, Replace b) => Replace (a, b) where + replaceVar (x, y) re = (replaceVar x re, replaceVar y re) + replaceUExpr (x, y) re = (replaceUExpr x re, replaceUExpr y re) + replaceLExpr (x, y) re = (replaceLExpr x re, replaceLExpr y re) + +instance (Replace a, Replace b, Replace c) => Replace (a, b, c) where + replaceVar (x, y, z) re = (replaceVar x re, replaceVar y re, replaceVar z re) + replaceUExpr (x, y, z) re = (replaceUExpr x re, replaceUExpr y re, replaceUExpr z re) + replaceLExpr (x, y, z) re = (replaceLExpr x re, replaceLExpr y re, replaceLExpr z re) diff --git a/Feldspar/Compiler/Optimization/Simplification.hs b/Feldspar/Compiler/Optimization/Simplification.hs new file mode 100644 --- /dev/null +++ b/Feldspar/Compiler/Optimization/Simplification.hs @@ -0,0 +1,390 @@ +{- + - Copyright (c) 2009, 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. + -} + +module Feldspar.Compiler.Optimization.Simplification where + +import qualified Data.Map as Map +import qualified Data.Set as Set +import Data.List hiding (insert,union) +import Data.Maybe +import Feldspar.Compiler.Imperative.Representation +import Feldspar.Compiler.Optimization.Replace + +doSimplification :: [ImpFunction] -> [ImpFunction] +doSimplification = map doSimplificationOne + +doSimplificationOne :: ImpFunction -> ImpFunction +doSimplificationOne = backward . delUnused Set.empty . fst . computeSemInfVar . fst . propagate Map.empty . fst . computeSemInfVar + +-------------------------------------------------------------- +-- Computing semantic information for variable declarations -- +-------------------------------------------------------------- + +class ComputeSemInfVar t where + computeSemInfVar :: t -> (t, VariableMap) + +instance ComputeSemInfVar ImpFunction where + computeSemInfVar fun = (fun{ prg = fst result}, snd result) + where + result = computeSemInfVar $ prg fun + +instance ComputeSemInfVar CompleteProgram where + computeSemInfVar (CompPrg locals body) = (CompPrg locs $ fst result, rest) + where + result = computeSemInfVar body + dresult = computeSemInfVar locals + locs = map updateLocal locals + rest = Map.filterWithKey (\k _ -> not $ isLocal k) (snd result) + isLocal name = Prelude.filter (\(Decl (Var n _ _) _ _ _) -> n == name) locals /= [] + updateLocal d@(Decl (Var name _ _) _ _ _) = case Map.lookup name $ addVarMap (snd result) (snd dresult) of + Nothing -> d + Just inf -> d{ semInfVar = inf } + +instance ComputeSemInfVar Program where + computeSemInfVar Empty = (Empty,Map.empty) + computeSemInfVar p@(Primitive _ seminf) = (p, varMap seminf) + computeSemInfVar (Seq ps sem) = (Seq (map fst result) sem, foldr addVarMap Map.empty $ map snd result) where + result = map computeSemInfVar ps + computeSemInfVar (IfThenElse (Var cName k t) p1 p2 sem) + = (IfThenElse (Var cName k t) (fst result1) (fst result2) sem, foldr addVarMap condResult [snd result1, snd result2]) where + result1 = computeSemInfVar p1 + result2 = computeSemInfVar p2 + condResult = Map.singleton cName $ SemInfVar None UnknownR + computeSemInfVar (SeqLoop z@(Var c _ _) cp bp sem) + = (SeqLoop z (fst cresult) (fst bresult) sem, iterated) where + cresult = addCondVarInf $ computeSemInfVar cp + bresult = computeSemInfVar bp + iterated = multiply $ addVarMap (snd cresult) (snd bresult) + addCondVarInf (CompPrg locs bod, sem) = (CompPrg (map addCondVarInfToDecl locs) bod, sem) + addCondVarInfToDecl d + | var d == z = d{ semInfVar = addSemInfVar (SemInfVar None MultipleR) $ semInfVar d} + | otherwise = d + computeSemInfVar (ParLoop init test count body seminfo) + = (ParLoop init test count (fst bodyResult) seminfo, result) + where + result = multiply $ addVarMap (snd bodyResult) testResult + bodyResult = computeSemInfVar body + testResult = rightVarMap $ (\(Expr core _) -> core) test + +multiply m = fmap multiplyOne m +multiplyOne sem = sem{ usedLeft = multiplyLeft $ usedLeft sem, usedRight = multiplyRight $ usedRight sem } +multiplyLeft (Single _) = MultipleL +multiplyLeft l = l +multiplyRight (Times 0) = Times 0 +multiplyRight (Times _) = MultipleR +multiplyRight r = r + +instance (ComputeSemInfVar a) => ComputeSemInfVar [a] where + computeSemInfVar xs = (fst result, foldr addVarMap Map.empty $ snd result) where + result = unzip $ map computeSemInfVar xs + +instance ComputeSemInfVar Declaration where + computeSemInfVar d@(Decl (Var name _ _) _ (Just ini) _) = (d, Map.singleton name $ SemInfVar (Single $ Just ini) (Times 0) ) + computeSemInfVar d@(Decl (Var name _ _) _ Nothing _) = (d, Map.empty) + +-------------------- +-- Simplification -- +-------------------- + +type PropagateMap = Map.Map String (Maybe ImpLangExpr) +type DelSet = Set.Set String + +class Simplification a where + propagate :: PropagateMap -> a -> (a,PropagateMap) + delUnused :: DelSet -> a -> a + backward :: a -> a + writesVar :: a -> String -> Bool + readsVar :: a -> String -> Bool + +instance Simplification ImpFunction where + propagate m (Fun n ips ops cprg) = (Fun n ips ops $ fst $ propagate m cprg, Map.empty) + delUnused s (Fun n ips ops cprg) = Fun n ips ops $ delUnused s cprg + backward fun = fun { prg = backward $ prg fun } + writesVar fun var = False -- Should not be used. + readsVar fun var = False -- Should not be used. + +instance Simplification CompleteProgram where + propagate m (CompPrg dl b) = (CompPrg dl $ fst result, purgePropagateMap (snd result) dl) where + result = propagate (Map.union m $ makePropagateMap dl) b + delUnused s (CompPrg dl b) = CompPrg (fst result) $ delUnused (Set.union s $ snd result) b where + result = makeUnusedSet dl + backward (CompPrg dl b) = doBackward dl $ toPrgList $ backward b + writesVar (CompPrg _ b) var = writesVar b var + readsVar (CompPrg _ b) var = readsVar b var + +instance Simplification Program where + propagate m Empty = (Empty, m) + propagate m (Primitive instr seminf) = (Primitive (fst $ propagate m instr) (fst seminf'), snd seminf') where + seminf' = propagate m seminf + propagate m s@(Seq ps seminf) = (Seq (fst result) seminf, snd result) where + result = propagate m ps + propagate m (IfThenElse v cp1 cp2 seminf) + = (IfThenElse v (fst result1) (fst result2) seminf, Map.intersectionWith combineExpr (snd result1) (snd result2)) where + result1 = propagate m cp1 + result2 = propagate m cp2 + propagate m (SeqLoop v cp1 cp2 seminf) + = (SeqLoop v (fst result1) (fst result2) seminf, Map.intersectionWith combineExpr (snd result1) (snd result2)) where + result1 = propagate m cp1 + result2 = propagate m cp2 + propagate m (ParLoop v i1 i2 cp seminf) = (ParLoop v i1 i2 (fst result) seminf, snd result) where + result = propagate m cp + delUnused _ Empty = Empty + delUnused s p@(Primitive _ seminf) + | all (\v -> Set.member v s) $ leftVars $ varMap seminf = Empty + | otherwise = p + delUnused s (Seq ps seminf) = Seq (delUnused s ps) seminf + delUnused s (IfThenElse v cp1 cp2 seminf) = IfThenElse v (delUnused s cp1) (delUnused s cp2) seminf + delUnused s (SeqLoop v cp1 cp2 seminf) = SeqLoop v (delUnused s cp1) (delUnused s cp2) seminf + delUnused s (ParLoop v i1 i2 cp seminf) = ParLoop v i1 i2 (delUnused s cp) seminf + backward (Seq ps seminf) = Seq (backward ps) seminf + backward (IfThenElse v cp1 cp2 seminf) = IfThenElse v (backward cp1) (backward cp2) seminf + backward (ParLoop v i1 i2 cp seminf) = ParLoop v i1 i2 (backward cp) seminf + backward (SeqLoop v cp1 cp2 seminf) = SeqLoop v (backward cp1) (backward cp2) seminf + backward x = x + writesVar Empty _ = False + writesVar (Primitive i _) var = writesVar i var + writesVar (Seq ps _) var = writesVar ps var + writesVar (IfThenElse v cp1 cp2 _) var = writesVar cp1 var || writesVar cp2 var + writesVar (SeqLoop _ cp1 cp2 _) var = writesVar cp1 var || writesVar cp2 var + writesVar (ParLoop _ _ _ cp _) var = writesVar cp var + readsVar Empty _ = False + readsVar (Primitive i _) var = readsVar i var + readsVar (Seq ps _) var = readsVar ps var + readsVar (IfThenElse v cp1 cp2 _) var = (name v == var) || readsVar cp1 var || readsVar cp2 var + readsVar (SeqLoop _ cp1 cp2 _) var = readsVar cp1 var || readsVar cp2 var + readsVar (ParLoop _ _ _ cp _) var = readsVar cp var + +instance (Simplification a) => Simplification [a] where + propagate m [] = ([],m) + propagate m (x:xs) = (fst xresult : fst xsresult, snd xsresult) where + xresult = propagate m x + xsresult = propagate (snd xresult) xs + delUnused s xs = map (delUnused s) xs + backward xs = map backward xs + writesVar xs var = any (\x -> writesVar x var) xs + readsVar xs var = any (\x -> readsVar x var) xs + +instance Simplification Instruction where + propagate m (Assign left right) = (Assign (fst $ propagate m left) (fst $ propagate m right), m) + propagate m (CFun name ps) = (CFun name $ map (fst . propagate m) ps, m) + delUnused _ = id + backward = id + writesVar (Assign left _) var = writesVar left var + writesVar (CFun _ ps) var = any (\p -> writesVar p var) ps + readsVar (Assign left right) var = readsVarHelp left var || readsVar right var + readsVar (CFun _ ps) var = any (\p -> readsVar p var) ps + +instance Simplification SemInfPrim where + propagate m seminf = (seminf{ varMap = seminf' }, updated) where + updated = Map.map upd2 $ Map.mapWithKey upd1 m + upd1 name expr = case Map.lookup name seminf' of + Nothing -> expr + Just sem -> case usedLeft sem of + None -> expr + Single e -> e + _ -> Nothing + upd2 expr = case expr of + Nothing -> expr + Just e + | any (\v -> contains v e) $ leftVars seminf' -> Nothing + | otherwise -> expr + seminf' = Map.foldWithKey prop Map.empty $ varMap seminf + prop :: String -> SemInfVar -> Map.Map String SemInfVar -> Map.Map String SemInfVar + prop name sem other + = addVarMap other $ addVarMap (Map.singleton name $ SemInfVar (propLeft $ usedLeft sem) (Times 0)) $ propRight name $ usedRight sem + propLeft (Single (Just expr)) = Single $ Just $ fst $ propagate m expr + propLeft x = x + propRight :: String -> RightUse -> Map.Map String SemInfVar + propRight name right = case Map.lookup name m of + Just (Just e) -> Map.map (mult right) $ rightVarMap e + _ -> Map.singleton name (SemInfVar None right) + mult UnknownR sem = sem{ usedRight=UnknownR } + mult (Times n) sem = case usedRight sem of + Times n' -> sem{ usedRight = Times $ n*n' } + _ -> sem + mult MultipleR sem = case usedRight sem of + UnknownR -> sem + _ -> sem{ usedRight = MultipleR } + delUnused _ = id + backward = id + writesVar _ _ = False + readsVar _ _ = False + +instance Simplification ImpLangExpr where + propagate m i@(Expr (LeftExpr (LVar (Var n _ _))) t) + | Map.member n m = case m Map.! n of + Nothing -> (i,m) + Just expr -> (fst $ propagate m expr, m) + | otherwise = (i,m) + propagate m (Expr (LeftExpr x) t) = (Expr (LeftExpr (fst $ propagate m x)) t, m) + propagate m (Expr (FunCall r s is) t) = (Expr (FunCall r s (map (fst . propagate m) is)) t, m) + propagate m x = (x,m) + delUnused _ = id + backward = id + writesVar (Expr (LeftExpr lv) _) var = writesVar lv var + writesVar _ _ = False + readsVar (Expr (LeftExpr lv) _) var = readsVar lv var + readsVar (Expr (AddressOf lv) _) var = readsVar lv var + readsVar (Expr (ConstExpr _) _) var = False + readsVar (Expr (FunCall _ _ es) _) var = any (\e -> readsVar e var) es + +instance Simplification LeftValue where + propagate m l@(LVar (Var n _ _)) + | Map.member n m = case m Map.! n of + Nothing -> (l,m) + Just expr -> (getLeftValue $ fst $ propagate m expr, m) + | otherwise = (l, m) + propagate m (ArrayElem lv ile) = (ArrayElem (fst $ propagate m lv) (fst $ propagate m ile), m) + propagate m (PointedVal lv) = (PointedVal (fst $ propagate m lv), m) + delUnused _ = id + backward = id + writesVar (LVar v) var = name v == var + writesVar (ArrayElem lv exp) var = writesVar lv var + writesVar (PointedVal lv) var = writesVar lv var + readsVar (LVar v) var = name v == var + readsVar (ArrayElem lv exp) var = readsVar lv var || readsVar exp var + readsVar (PointedVal lv) var = readsVar lv var + +instance Simplification Parameter where + propagate m (In ile) = (In (fst $ propagate m ile), m) + propagate m (Out (k, ile)) = (Out (k, (fst $ propagate m ile)), m) + delUnused _ = id + backward = id + writesVar (In _) _ = False + writesVar (Out (_,exp)) var = writesVar exp var + readsVar (In exp) var = readsVar exp var + readsVar (Out (_,exp)) var = readsVarHelp (getLeftValue exp) var + +makePropagateMap :: [Declaration] -> PropagateMap +makePropagateMap dl = foldr Map.union Map.empty $ map makePropagateMap' dl where + makePropagateMap' d = case usedLeft $ semInfVar d of + Single (Just e) + | usedRight (semInfVar d) == Times 1 || simpleExpr e -> Map.singleton (name $ var d) $ initVal d + | otherwise -> Map.empty + otherwise -> Map.empty + simpleExpr (Expr (LeftExpr (LVar _)) _) = True + simpleExpr (Expr (ConstExpr _) t) = simpleType t + simpleExpr _ = False + +purgePropagateMap :: PropagateMap -> [Declaration] -> PropagateMap +purgePropagateMap m dl = Map.differenceWith (\_ _ -> Nothing) m (makePropagateMap dl) + +combineExpr :: Maybe ImpLangExpr -> Maybe ImpLangExpr -> Maybe ImpLangExpr +combineExpr e1 e2 + | e1 == e2 = e1 + | otherwise = Nothing + +makeUnusedSet :: [Declaration] -> ([Declaration],DelSet) +makeUnusedSet [] = ([],Set.empty) +makeUnusedSet (d:ds) = case usedRight $ semInfVar d of + Times 0 -> (fst result, Set.insert (name $ var d) $ snd result) + _ -> (d : fst result, snd result) + where + result = makeUnusedSet ds + +readsVarHelp :: LeftValue -> String -> Bool +readsVarHelp (LVar _) _ = False +readsVarHelp (ArrayElem lv exp) var = readsVarHelp lv var || readsVar exp var +readsVarHelp (PointedVal lv) _ = False + +----------------------------- +-- Backward simplification -- +----------------------------- + +doBackward :: [Declaration] -> [Program] -> CompleteProgram +doBackward ds ps + | cont = doBackward ds' ps' + | otherwise = CompPrg ds' (Seq ps' []) + where + (cont,ds',ps') = backwardRec ds ([],ps) + +backwardRec :: [Declaration] -> ([Program],[Program]) -> (Bool, [Declaration], [Program]) +backwardRec ds (xs,[]) = (False, ds, reverse xs) +backwardRec ds (xs,y:ys) = case backwardPossible ds xs y ys of + Nothing -> backwardRec ds (y:xs,ys) + Just (left,right,init) -> (True, fst result, init : snd result) where + result = backwardRepl left right ds xs ys + +backwardPossible :: [Declaration] -> [Program] -> Program -> [Program] -> Maybe (LeftValue,String,Program) +backwardPossible ds xs y ys = case y of + (Primitive (Assign left (Expr (LeftExpr (LVar (Var name _ _))) _)) (SemInfPrim _ True)) + -> check left name + (Primitive (CFun fname [In (Expr (LeftExpr (LVar (Var name _ _))) _), Out (_,(Expr (LeftExpr left) _))]) (SemInfPrim _ True)) + | isPrefixOf "copy" fname -> check left name -- TODO: eliminate string constant + | otherwise -> Nothing + _ -> Nothing + where + check left name + | isJust declarationOK && beforeOK && afterOK + = Just (left,name,fromJust declarationOK) + | otherwise + = Nothing + where + declarationOK = case find (declares name) ds of + Just d -> case initVal d of + Nothing -> Just Empty + Just expr + | simpleType (exprType expr) -> Just $ Primitive (Assign left expr) $ SemInfPrim Map.empty False + | otherwise -> Nothing + Nothing -> Nothing + beforeOK = case useBefore of + (False, _) -> False + (True, False) -> True + (True, True) -> case declarationOK of + Nothing -> False + Just Empty -> True + Just _ -> False + afterOK = not $ any (\p -> readsVar p name || writesVar p name) ys + useBefore = foldl step (True,False) xs + step (ok,out) prg = (ok',out') where + out' = out || outRead || outWritten + ok' + | not ok = False + | out && (varWritten || varRead) = False + | outWritten && (varWritten || varRead) = False + | outRead && varRead = False + | otherwise = True + outWritten = prg `writesVar` outName + outRead = prg `readsVar` outName + outName = getVarName left + varWritten = prg `writesVar` name + varRead = prg `readsVar` name + +backwardRepl :: LeftValue -> String -> [Declaration] -> [Program] -> [Program] -> ([Declaration], [Program]) +backwardRepl lv var ds xs ys = (filter (not . declares var) ds, replaceLExpr (reverse xs ++ ys) (var,lv)) + +toPrgList :: Program -> [Program] +toPrgList (Seq ps _) = ps +toPrgList p = [p] + +declares :: String -> Declaration -> Bool +declares n d = n == name (var d) diff --git a/Feldspar/Compiler/Optimization/Unroll.hs b/Feldspar/Compiler/Optimization/Unroll.hs new file mode 100644 --- /dev/null +++ b/Feldspar/Compiler/Optimization/Unroll.hs @@ -0,0 +1,132 @@ +{- + - Copyright (c) 2009, 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. + -} + +module Feldspar.Compiler.Optimization.Unroll where + +import Feldspar.Compiler.Imperative.Representation hiding (None) +import Feldspar.Compiler.Options +import Feldspar.Compiler.Optimization.Replace +import Prelude + +-- | Unroll opreation for imperative functions. +doUnroll :: Options -> [ImpFunction] -> [ImpFunction] +doUnroll opt ps = map (doUnrollOne opt) ps + +-- Unroll opreation for an Imperative function. +doUnrollOne :: Options -> ImpFunction -> ImpFunction +doUnrollOne opt p = case unroll opt of + NoUnroll -> p + (Unroll i) -> unrollStruc i p + +-- If the second parameter is a For loop which contains Empty, Primitive or Seq programtypes and the modulo of the first parameret and the maximum iteration of loop, will terurn true. +unrollPossible :: Int -> Program -> Bool +unrollPossible i (ParLoop counter num 1 (CompPrg _ prg) inf) = moduloOk && unrollPossible' prg + where + moduloOk = case num of + Expr (ConstExpr (IntConst x)) _ -> x `mod` i == 0 + otherwise -> True + unrollPossible' Empty = True + unrollPossible' (Primitive i s) = True + unrollPossible' (Seq ps si) = and $ map unrollPossible' ps + unrollPossible' _ = False +unrollPossible _ _ = False + +-- Collects variable names from a declaration bloc. +collectVars :: [Declaration] -> [String] +collectVars ds = map collectVar ds where + collectVar (Decl (Var s _ _) declType initVal inf) = s + +-- Concatenates the first and second parameters and returnes as a string. +alterVarName :: String -> Int -> String +alterVarName old idx = old ++ "_" ++ show idx + +-- Creates a new additional expression from the loop counter and a positive constant. +alterVar :: String -> Int -> UntypedExpression +alterVar name idx = FunCall InfixOp "+" [var,const] + where + var = Expr (LeftExpr $ LVar $ Var name Normal int) int + const = Expr (ConstExpr $ IntConst idx) int + int = (Numeric ImpSigned S32) + +-- Replicates the declarated variables with new names. +unrollDecl :: [Declaration] -> String -> Int -> [Declaration] +unrollDecl decllist loopvar i + = unrollDecl' decllist todolists + where + todolists = zip (replicate i ((collectVars decllist),loopvar)) [0,1..(i-1)] + unrollDecl' :: [Declaration] -> [(([String],String),Int)] -> [Declaration] + unrollDecl' decllist todolists = foldl (++) [] (map (unrollOneDecl decllist) todolists) + unrollOneDecl:: [Declaration] -> (([String],String),Int) -> [Declaration] + unrollOneDecl decllist ((local_vars,loopvar),idx) + | idx < 1 = foldl (\decllist var -> (replaceVar decllist (var,alterVarName var idx))) decllist local_vars + | otherwise = foldl (\decllist var -> (replaceVar decllist (var,alterVarName var idx))) + (replaceUExpr decllist (loopvar,(alterVar loopvar idx))) local_vars + +-- Replicates the for loop body using the new variables. +unrollPrg :: Program -> String -> [String] -> Int -> [Program] +unrollPrg prg loopvar locals num = + map alter $ zip (replicate num prg) [0..] where + alter (p,idx) + | idx < 1 = foldl (\p' tr -> tr p') p (map (alterLocal idx) locals) + | otherwise = foldl (\p' tr -> tr p') (alterLoopVar (p,idx)) (map (alterLocal idx) locals) + alterLoopVar (p,idx) = replaceUExpr p (loopvar, alterVar loopvar idx) + alterLocal idx loc p = replaceVar p (loc, alterVarName loc idx) + +-- Unrolls the declaration and the body of the loop, if the unroll operation is possible. If not possible, then tries to find sub-loops in the current loop. +unrollRepeatSimple :: Program -> Int -> Program +unrollRepeatSimple p i = urs p i (unrollPossible i p) where + urs (ParLoop (Var v k t) max step cprg inf) i True + = ParLoop (Var v k t) max (step*i) (CompPrg (unrollDecl (locals cprg) v i) (Seq (unrollPrg (body cprg) v (collectVars (locals cprg)) i) inf)) inf + urs (ParLoop (Var v k t) max step cprg inf) i False + = ParLoop (Var v k t) max step cprg{ body = unrollStruc i (body cprg)} inf + urs p i False = p + +-- Finds for loops in data hierarchy and make the unroll opertaion. + + + +class Unroll t where + unrollStruc :: Int -> t -> t + +instance Unroll ImpFunction where + unrollStruc i f = f{ prg = unrollStruc i $ prg f } + +instance Unroll CompleteProgram where + unrollStruc i c = c{ body = unrollStruc i $ body c } + +instance Unroll Program where + unrollStruc i (Seq ps inf) = Seq (map (unrollStruc i) ps) inf + unrollStruc i (IfThenElse v cpt cpe inf) = IfThenElse v (unrollStruc i cpt) (unrollStruc i cpe) inf + unrollStruc i for@(ParLoop _ _ _ _ _) = unrollRepeatSimple for i + unrollStruc i (SeqLoop v calc body inf) = SeqLoop v (unrollStruc i calc) (unrollStruc i body) inf + unrollStruc _ x = x + diff --git a/Feldspar/Compiler/Options.hs b/Feldspar/Compiler/Options.hs new file mode 100644 --- /dev/null +++ b/Feldspar/Compiler/Options.hs @@ -0,0 +1,45 @@ +{- + - Copyright (c) 2009, 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. + -} + +module Feldspar.Compiler.Options where + +data Options = + Options + { platform :: Platform + , unroll :: UnrollStrategy + , debug :: DebugOption + } + +data Platform = AnsiC | TI +-- | other platforms will come later... +data UnrollStrategy = NoUnroll | Unroll Int +data DebugOption = NoDebug | NoSimplification | NoPrimitiveInstructionHandling diff --git a/Feldspar/Compiler/Precompiler/Precompiler.hs b/Feldspar/Compiler/Precompiler/Precompiler.hs new file mode 100644 --- /dev/null +++ b/Feldspar/Compiler/Precompiler/Precompiler.hs @@ -0,0 +1,89 @@ +{- + - Copyright (c) 2009, 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. + -} + +module Feldspar.Compiler.Precompiler.Precompiler where + +import Feldspar.Compiler -- TODO remove +import System.IO + +import Language.Haskell.Exts + +stripModule x = case x of + Module a b c d e f g -> g + +stripResult (ParseOk a) = a +stripResult (ParseFailed srcloc message) = error message -- TODO use srcloc + +stripFunBind :: Decl -> Name +stripFunBind x = case x of + FunBind a -> stripMatch $ head a + PatBind a b c d e -> stripPat b + TypeSig a b c -> Ident "DUMMY" --head b -- we don't need the type signature (yet) + +stripPat (PVar x) = x + +stripMatch (Match a b c d e f) = b + +stripName :: Name -> String +stripName (Ident a) = a +stripName (Symbol a) = a + +stripModule2 (Module a b c d e f g) = b + +stripModuleName (ModuleName x) = x + +getModuleName :: String -> String -- filecontents -> modulename +getModuleName = stripModuleName . stripModule2 . stripResult . customizedParse + +usedExtensions = glasgowExts ++ [ExplicitForall] + +getParseOutput fileName = parseFileWithMode (defaultParseMode { extensions = usedExtensions }) fileName + +-- or: parseFileContentsWithMode +customizedParse = parseModuleWithMode (defaultParseMode { extensions = usedExtensions }) + +getFullDeclarationList fileContents = + map (stripName . stripFunBind) (stripModule $ stripResult $ customizedParse fileContents ) + +functionNameNeeded :: String -> Bool +functionNameNeeded functionName = (functionName /="DUMMY") && (functionName /="main") + +stripUnnecessary :: [String] -> [String] +stripUnnecessary = filter functionNameNeeded + +printDeclarationList fileName = do + handle <- openFile fileName ReadMode + fileContents <- hGetContents handle + return $ getDeclarationList fileContents + +getDeclarationList :: String -> [String] -- filecontents -> Stringlist +getDeclarationList = stripUnnecessary . getFullDeclarationList diff --git a/Feldspar/Compiler/Transformation/GraphToImperative.hs b/Feldspar/Compiler/Transformation/GraphToImperative.hs new file mode 100644 --- /dev/null +++ b/Feldspar/Compiler/Transformation/GraphToImperative.hs @@ -0,0 +1,435 @@ +{- + - Copyright (c) 2009, 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. + -} + +module Feldspar.Compiler.Transformation.GraphToImperative where + +import Feldspar.Core.Graph +import Feldspar.Core.Types hiding (typeOf) +import Feldspar.Compiler.Imperative.Representation hiding (Array) +import Feldspar.Compiler.Transformation.GraphUtils +import Data.List +import qualified Data.Map as Map + +-- Transforms a hierarchical graph to a list of imperative functions. + -- collect sources for each function + -- compile each of them + -- put the results in a list +graphToImperative :: String -> HierarchicalGraph -> [ImpFunction] +graphToImperative s g = map transformSourceToImpFunction sources where + sources = this : collectSources g + this = ImpFunctionSource + { functionName = s + , interface = hierGraphInterface g + , hierarchy = graphHierarchy g + } + +-- A datastructure to represent all data needed for transformation to an +-- imperative function. +data ImpFunctionSource + = ImpFunctionSource + { functionName :: String + , interface :: Interface + , hierarchy :: Hierarchy + } + +-- Just for debugging purposes: +instance Show ImpFunctionSource where + show (ImpFunctionSource s _ _) = s + +-- 'collectSources' walks thorugh the graph and collects the interfaces +-- and hierarchies of 'NoInline' nodes. +class Collect t where + collectSources :: t -> [ImpFunctionSource] + +instance Collect HierarchicalGraph where + collectSources g = collectSources $ graphHierarchy g + +instance Collect Hierarchy where + collectSources (Hierarchy xs) = collectSources xs + +instance (Collect t) => Collect [t] where + collectSources xs = concatMap collectSources xs + +instance Collect (Node,[Hierarchy]) where + collectSources (n,hs) = this ++ collectSources hs where + this = case function n of + NoInline name interface -> case hs of + [hierarchy] -> [ImpFunctionSource name interface hierarchy] + _ -> error $ "Graph error: malformed hierarchy list in the 'NoInline' node with id " ++ show (nodeId n) + _ -> [] + +-- Transforms an interface and a hierarchy to an imperative function. + -- transform top level nodes to declarations + -- split the declarations into 'input' and 'local' groups + -- generate output parameters + -- transform each top-level node to a Program +transformSourceToImpFunction :: ImpFunctionSource -> ImpFunction +transformSourceToImpFunction (ImpFunctionSource n ifc (Hierarchy pairs)) + = Fun + { funName = n + , inParameters = inputDecls + , outParameters = outputDecls + , prg + = CompPrg + { locals = localDecls + , body = Seq ( map transformNodeToProgram pairs + ++ copyToOutput (interfaceOutput ifc) (interfaceOutputType ifc) True) [] + } + } where + (inputDecls, localDecls) = partition isInputDecl declarations where + isInputDecl d = isPrefixOf (varPrefix $ interfaceInput ifc) (name $ var d) + outputDecls = tupleWalk transformSourceToDecl $ interfaceOutputType ifc + transformSourceToDecl path typ + = Decl + { var = Var (outName path) OutKind ctyp + , declType = ctyp + , initVal = Nothing + , semInfVar = unknownSemInfVar + } where + ctyp = compileStorableType typ + declarations = concatMap transformNodeToDeclaration topLevelNodes + topLevelNodes = map fst pairs + +-- Transforms a node to declarations. The number of generated declarations is +-- determined by the tuple leafs of the tuple structure in the node type. + -- walk through the tuple structure in the node type + -- variable name: "var" ++ 'node id' ++ 'path in the tuple structure' + -- variable type: type of the leaf in the structure +transformNodeToDeclaration :: Node -> [Declaration] +transformNodeToDeclaration n = tupleWalk genDecl $ tupleZip (outTyps,initVals) where + genDecl path (typ,ini) + = Decl + { var = Var (varPrefix (nodeId n) ++ varPath path) Normal ctyp + , declType = ctyp + , initVal = ini + , semInfVar = unknownSemInfVar + } where + ctyp = compileStorableType typ + outTyps = outputType n + initVals = case function n of + Array d -> case outTyps of + One t -> One $ Just $ compileStorableData d t + _ -> error "Error: malformed output type of array node." +{- While ifc1 ifc2 -> fmap (\(d,t) -> Just $ transformSourceToExpr d t) $ tupleZip (input n, outTyps) + initPart = case input n of + Tup [cond,ini] -> ini + _ -> error "Error in while loop: malformed input." +-} + otherwise -> genNothingTuple outTyps + genNothingTuple (One _) = One Nothing + genNothingTuple (Tup xs) = Tup $ map genNothingTuple xs + + +transformNodeListToDeclarations :: [Node] -> [Declaration] +transformNodeListToDeclarations ns = concatMap transformNodeToDeclaration ns + +-- Transforms a node and its subgraphs (if any) to an imperative program. +transformNodeToProgram :: (Node, [Hierarchy]) -> Program +transformNodeToProgram (n,hs) = case function n of + Input -> Empty + Array _ -> Empty + Function s -> Primitive + (CFun s $ passInArgs (input n) (inputType n) ++ passOutArgs (nodeId n) (outputType n)) + (SemInfPrim Map.empty False) + -- non-inlined function node: + -- call the non-inlined function + -- actual arguments come from the node input and the node id + NoInline s ifc -> Primitive + (CFun s $ passInArgs (input n) (inputType n) ++ passOutArgs (nodeId n) (outputType n)) + (SemInfPrim Map.empty False) + -- conditional node: + -- condition: first element of the input tuple + -- then branch: compiled from the first interface and the first hierarchy + -- else branch: compiled from the second interface and the second hierarchy + Feldspar.Core.Graph.IfThenElse thenIfc elseIfc -> case hs of + [thenH, elseH] -> case (input n, inputType n) of + (Tup [cond, inp], Tup [One condTyp, inTyp]) + | interfaceInputType thenIfc /= inTyp || interfaceInputType elseIfc /= inTyp + -> error "Error in 'ifThenElse' node: incorrect interface input type." + | compileStorableType condTyp /= Feldspar.Compiler.Imperative.Representation.BoolType + -> error "Error in 'ifThenElse' node: node output is expected to be 'Bool'." + | otherwise -> Feldspar.Compiler.Imperative.Representation.IfThenElse + condVar -- condition variable + (mkBranch n thenIfc thenH) -- then part + (mkBranch n elseIfc elseH) -- else part + [] -- semantic info + where + mkBranch :: Node -> Interface -> Hierarchy -> CompleteProgram + mkBranch n ifc h@(Hierarchy pairs) = CompPrg + (transformNodeListToDeclarations $ map fst pairs) + (Seq (copyResult inp (interfaceInput ifc) inTyp False + ++ transformNodeListToPrograms pairs + ++ copyResult (interfaceOutput ifc) (nodeId n) (outputType n) True) + []) + condVar = case cond of + One (Variable (id,path)) -> Var (varName id path) Normal Feldspar.Compiler.Imperative.Representation.BoolType + _ -> error "Error in 'ifThenElse' node: condition is not a variable." + -- TODO: it seems that in case of constant condition the program is already simplified on the graph level + otherwise -> error $ "Error in 'ifThenElse' node: incorrect node input or node input type" + otherwise -> error $ "Error in 'ifThenElse' node: two hierarchies expected, found " ++ show (length hs) + -- while node: + -- state variables: id of the while node + -- condition calculation: first interface and hierarchy + -- input gets the state + -- condition: output of condition calculation + -- body: second interface and hierarchy + -- input gets the state + -- output is written back to the state + While condIfc bodyIfc -> Seq + (copyResult (input n) (nodeId n) (outputType n) False ++ + [SeqLoop + -- condition variable: + (case interfaceOutput condIfc of + One (Variable (id,path)) -> Var (varName id path) Normal Feldspar.Compiler.Imperative.Representation.BoolType + _ -> error "Error in a while loop: Malformed interface output of condition calculation." + -- TODO: should this hold? + ) + -- condition calculation (CompleteProgram) + (CompPrg + (transformNodeListToDeclarations condNodes) + (Seq (copyStateToCond ++ calculationCond) []) + ) + -- loop body (CompleteProgram) + (CompPrg + (transformNodeListToDeclarations bodyNodes) + (Seq (copyStateToBody ++ calculationBody ++ copyResultToState) []) + ) + -- semantic info (SemInfSeqLoop) + [] + ]) [] where + (Hierarchy condHier, Hierarchy bodyHier) = case hs of + [c,b] -> (c,b) + _ -> error $ "Error in a while node: expected 2 hierarchies, but found " ++ show (length hs) + condNodes = map fst condHier + bodyNodes = map fst bodyHier + copyStateToCond = copyNode (nodeId n) (interfaceInput condIfc) (outputType n) False + calculationCond = transformNodeListToPrograms condHier + copyStateToBody = copyNode (nodeId n) (interfaceInput bodyIfc) (outputType n) False + calculationBody = transformNodeListToPrograms bodyHier + copyResultToState = copyResult (interfaceOutput bodyIfc) (nodeId n) (outputType n) True + -- initState = tupleWalk genInitCopy tupleZip (input n, outputType n) + -- genInitCopy path (i,t) = + -- parallel node: + -- number of iterations: first parameter of 'Parallel' constructor + -- (vs. input of the node, may change later) + -- index variable: input node of the embedded graph + -- body: embedded graph and its interface + Parallel _ ifc -> + ParLoop (Var (varName inpId []) Normal $ Numeric ImpSigned S32) num 1 prg [] where + num = case (input n, inputType n) of + (One inp, One intyp) -> transformSourceToExpr inp intyp + otherwise -> error "Invalid input of a Parallel node." + hist = case hs of + [(Hierarchy hist)] -> hist + _ -> error "More than one Hierarchy in a Parallel construct" + isInp (node,hs) = case (function node) of + Input -> True + _ -> False + (inps,notInps) = partition isInp hist + inpId = case inps of + [(node,hs)] -> nodeId node + _ -> error "More than one input node inside the Hierarchy of a Parallel construct" + topLevelNodes = map fst notInps + declarations = concatMap transformNodeToDeclaration topLevelNodes + outSrc = case interfaceOutput ifc of + One src -> src + _ -> error "The interfaceOutput of a Parallel is not (One ...) " + outTyp = case interfaceOutputType ifc of + One typ -> typ + _ -> error "The interfaceOutputType of a Parallel is not (One ...) " + prg = CompPrg + { locals = declarations + , body = Seq ( map transformNodeToProgram notInps ++ + [ Primitive ( makeCopyFromExprs + (transformSourceToExpr outSrc outTyp) + (Expr (LeftExpr $ ArrayElem (LVar (Var (varName (nodeId n) []) Normal intType)) (Expr (genVar inpId [] intType) intType)) intType) -- TODO: fix the type + ) + (SemInfPrim Map.empty True) + ] + ) [] +{- + [ Primitive + (Assign + (ArrayElem (LVar (Var (varName (nodeId n) []))) (Expr (genVar inpId []) intType)) + (transformSourceToExpr outSrc outTyp) + ) (SemInfPrim Map.empty True) + ] + ) [] +-} + } + +transformNodeListToPrograms :: [(Node, [Hierarchy])] -> [Program] +transformNodeListToPrograms pairs = map transformNodeToProgram pairs + +-- Generates the common prefix of variables belonging to the given node id. +varPrefix :: NodeId -> String +varPrefix id = "var" ++ show id + +-- Generates a variable's id list that describes the variable's location +-- inside the nodes it belongs to. +varPath :: [Int] -> String +varPath path = concatMap (\id -> '_' : show id) path + +-- Generates a variable from its id and location. +varName :: NodeId -> [Int] -> String +varName id path = varPrefix id ++ varPath path + +-- Generates a variable +genVar :: NodeId -> [Int] -> Type -> UntypedExpression +genVar id path typ = LeftExpr $ LVar $ Var (varName id path) Normal typ + +-- Prefix of output parameters +outPrefix :: String +outPrefix = "out" + +-- Generaes the name of an output parameter +outName :: [Int] -> String +outName path = outPrefix ++ varPath path + +-- Generates an output variable +genOut :: [Int] -> Type -> UntypedExpression +genOut path typ = LeftExpr $ LVar $ Var (outName path) OutKind typ + +-- Generates input parameters of a function call from the node input. +passInArgs :: Tuple Source -> Tuple StorableType -> [Parameter] +passInArgs tup typs = tupleWalk genArg $ tupleZip (tup,typs) where + genArg _ (Constant primData, StorableType _ typ) = In $ compilePrimData primData typ + genArg _ (Variable (id, path), typ) = In $ Expr (genVar id path ctyp) $ ctyp + where + ctyp = compileStorableType typ + +-- Generates output parameters of a function call from the node id and output type. +passOutArgs :: NodeId -> Tuple StorableType -> [Parameter] +passOutArgs id typs = tupleWalk genArg typs where + genArg path t = Out (Normal,Expr (genVar id path ctyp) $ ctyp) + where + ctyp = compileStorableType t + +------------------------------------------------- +-- Compilation of type and data representation -- +------------------------------------------------- + +-- Transforms a 'StorableType' to an imperative 'Type' +compileStorableType :: StorableType -> Type +compileStorableType (StorableType dims elemTyp) = case dims of + [] -> compilePrimitiveType elemTyp + (d:ds) -> ImpArrayType (Just d) $ compileStorableType $ StorableType ds elemTyp + +-- Transforms a 'PrimitiveType' to an imperative 'Type' +compilePrimitiveType :: PrimitiveType -> Type +compilePrimitiveType typ = case typ of + UnitType -> Feldspar.Compiler.Imperative.Representation.BoolType + Feldspar.Core.Types.BoolType + -> Feldspar.Compiler.Imperative.Representation.BoolType + IntType -> Numeric ImpSigned S32 + Feldspar.Core.Types.FloatType + -> Feldspar.Compiler.Imperative.Representation.FloatType -- TODO: think about the imperative typesystem! + +-- Transforms an array or primitive data to an imperative constant. +compileStorableDataToConst :: StorableData -> Constant +compileStorableDataToConst (PrimitiveData pd) = compilePrimDataToConst pd +compileStorableDataToConst (StorableData len ds) = ArrayConst len $ map compileStorableDataToConst ds + +-- Transforms a primitive data to an imperative constant. +compilePrimDataToConst :: PrimitiveData -> Constant +compilePrimDataToConst UnitData = BoolConst False +compilePrimDataToConst (BoolData x) = BoolConst x +compilePrimDataToConst (IntData x) = IntConst x +compilePrimDataToConst (FloatData x) = FloatConst x -- TODO + +-- Transforms an array or primitive data to an imperative typed expression. +compileStorableData :: StorableData -> StorableType -> ImpLangExpr +compileStorableData (PrimitiveData pd) (StorableType _ elemTyp) = compilePrimData pd elemTyp +compileStorableData a@(StorableData len ds) typ = Expr (ConstExpr $ compileStorableDataToConst a) $ compileStorableType typ + +-- Transforms a primitive data to an imperative typed expression. +compilePrimData :: PrimitiveData -> PrimitiveType -> ImpLangExpr +compilePrimData d t = Expr (ConstExpr $ compilePrimDataToConst d) $ compilePrimitiveType t + +charType = Numeric ImpSigned S8 +intType = Numeric ImpSigned S32 + +-- Transforms a Source to an imperative expression. +transformSourceToExpr :: Source -> StorableType -> ImpLangExpr +transformSourceToExpr (Constant primData) (StorableType _ typ) = compilePrimData primData typ +transformSourceToExpr (Variable (id,path)) typ = Expr (genVar id path ctyp) $ ctyp + where + ctyp = compileStorableType typ + +-- Generates a copy call from variable ids and types. +makeCopyFromIds :: (NodeId,[Int],StorableType) -> (NodeId,[Int],StorableType) -> Instruction +makeCopyFromIds (idFrom,pathFrom,typeFrom) (idTo,pathTo,typeTo) = + makeCopyFromExprs + (Expr (genVar idFrom pathFrom ctypFrom) ctypFrom) + (Expr (genVar idTo pathTo ctypTo) ctypTo) + where + ctypTo = compileStorableType typeTo + ctypFrom = compileStorableType typeFrom + +-- Generates a copy call from two expressions. +makeCopyFromExprs :: ImpLangExpr -> ImpLangExpr -> Instruction +makeCopyFromExprs from to = CFun "copy" [In from, Out (Normal,to)] + +-- Generates copies for all variables of a node to all variables of another node. +copyNode :: NodeId -> NodeId -> Tuple StorableType -> Bool -> [Program] +copyNode fromId toId typeStructure isOutputCopying = + tupleWalk + (\path typ -> + Primitive + (makeCopyFromIds (fromId,path,typ) (toId,path,typ)) + (SemInfPrim Map.empty isOutputCopying) + ) + typeStructure + +-- Generates copies from sources to all variables of a node. +copyResult :: Tuple Source -> NodeId -> Tuple StorableType -> Bool -> [Program] +copyResult ifcOut nid outTyp isOutputCopying = + tupleWalk + (\path (out,typ) -> + Primitive + (makeCopyFromExprs (transformSourceToExpr out typ) (Expr (genVar nid path $ compileStorableType typ) $ compileStorableType typ)) + (SemInfPrim Map.empty isOutputCopying) + --TODO: ctyp = compileStorableType typ + ) + (tupleZip (ifcOut, outTyp)) + +-- Generates copies from sources to output variables. +copyToOutput :: Tuple Source -> Tuple StorableType -> Bool -> [Program] +copyToOutput ifcOut outTyp isOutputCopying = + tupleWalk + (\path (out,typ) -> + Primitive + (makeCopyFromExprs (transformSourceToExpr out typ) (Expr (genOut path $ compileStorableType typ) $ compileStorableType typ)) + (SemInfPrim Map.empty isOutputCopying) + -- TODO : ctyp + ) + (tupleZip (ifcOut, outTyp)) diff --git a/Feldspar/Compiler/Transformation/GraphUtils.hs b/Feldspar/Compiler/Transformation/GraphUtils.hs new file mode 100644 --- /dev/null +++ b/Feldspar/Compiler/Transformation/GraphUtils.hs @@ -0,0 +1,103 @@ +{- + - Copyright (c) 2009, 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. + -} + +module Feldspar.Compiler.Transformation.GraphUtils + ( tupleWalk + , tupleZip + , tupleZipList + , replaceVars + ) where + +import Feldspar.Core.Graph +import Feldspar.Core.Types +import Data.List + +-- replaceVars [(var,fun)] ndhier ---- replace the variable (or the variables of the same node +----- if the list part is empty) according to the "fun" +class RepVars a where + replaceVars:: [(Variable, Variable -> Variable)] -> a -> a + +instance RepVars (Node, [Hierarchy]) where + replaceVars chLs (node, hs) = (replaceVars chLs node, map (replaceVars chLs) hs) + +instance RepVars Hierarchy where + replaceVars chLs (Hierarchy ndHrs) = Hierarchy (map (replaceVars chLs) ndHrs) + +instance RepVars Node where + replaceVars chLs (node@(Node {input = nInp, function = nFunc})) + = node{input= replaceVars chLs nInp, function = replaceVars chLs nFunc} + +instance RepVars (Tuple Source) where + replaceVars chLs (One (Constant x)) = One (Constant x) + replaceVars chLs (One (Variable x)) = One (Variable (replaceVars chLs x)) + replaceVars chLs (Tup tls) = Tup (map (replaceVars chLs) tls) + +instance RepVars Variable where + replaceVars chLs (nId, ls) + = case find (\((v,_),_) -> v == nId) chLs of + Nothing -> (nId, ls) + Just ((v,vls),tr) -> case vls of + [] -> tr (nId, ls) + _ -> if (vls == ls) then (tr (nId,ls)) else (nId,ls) + +instance RepVars Function where + replaceVars chLs (NoInline str ifc) = (NoInline str (replaceVars chLs ifc)) + replaceVars chLs (Parallel int ifc) = (Parallel int (replaceVars chLs ifc)) + replaceVars chLs (IfThenElse ifc1 ifc2) = (IfThenElse (replaceVars chLs ifc1) (replaceVars chLs ifc2)) + replaceVars chLs (While ifc1 ifc2) = (While (replaceVars chLs ifc1) (replaceVars chLs ifc2)) + replaceVars chLs fun = fun + +instance RepVars Interface where + replaceVars chLs ifc@ (Interface {interfaceOutput = ifOut}) + = ifc{interfaceOutput = replaceVars chLs ifOut} + +-- The 'tupleWalk' function walks through a tuple, applies the given +-- function to every leaf (while provides information about the place of +-- the leaf) and puts the results in a list. +tupleWalk :: ([Int] -> a -> b) -> Tuple a -> [b] +tupleWalk = tupleWalk' [] where + tupleWalk' :: [Int] -> ([Int] -> a -> b) -> Tuple a -> [b] + tupleWalk' p f (One x) = [f p x] + tupleWalk' p f (Tup xs) = concatMap ff $ zip xs [0..] where + ff (x,idx) = tupleWalk' (p ++ [idx]) f x + +-- Zips to tuples of the same structure. +tupleZip :: (Tuple a, Tuple b) -> Tuple (a,b) +tupleZip (One x, One y) = One (x,y) +tupleZip (Tup xs, Tup ys) = Tup (map tupleZip $ zip xs ys) +tupleZip _ = error "Error: Tuples with different structure are zipped." + +-- Zips the "leafs" to list of tuples. +tupleZipList :: (Tuple a, Tuple b) -> [(a,b)] +tupleZipList (One x, One y) = [(x,y)] +tupleZipList (Tup xs, Tup ys) = concatMap tupleZipList $ zip xs ys +tupleZipList _ = error "Error: Tuples with different structure are zipped." diff --git a/Feldspar/Compiler/Transformation/Lifting.hs b/Feldspar/Compiler/Transformation/Lifting.hs new file mode 100644 --- /dev/null +++ b/Feldspar/Compiler/Transformation/Lifting.hs @@ -0,0 +1,146 @@ +{- + - Copyright (c) 2009, 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. + -} + +module Feldspar.Compiler.Transformation.Lifting where + +import Feldspar.Core.Graph +import Feldspar.Core.Types hiding (typeOf) +import Feldspar.Compiler.Transformation.GraphUtils +import Data.List + + +replaceNoInlines:: HierarchicalGraph -> HierarchicalGraph +replaceNoInlines g = HierGraph (replaceNoInlinesHr (graphHierarchy g)) (hierGraphInterface g) + +replaceNoInlinesHrList:: [Hierarchy]-> [Hierarchy] +replaceNoInlinesHrList hrlist = map replaceNoInlinesHr hrlist + +replaceNoInlinesHr:: Hierarchy-> Hierarchy +replaceNoInlinesHr (Hierarchy hrlist) = Hierarchy (map replaceNoInlinesNode hrlist) + +replaceNoInlinesNode:: (Node,[Hierarchy]) -> (Node,[Hierarchy]) + +replaceNoInlinesNode (n,hs) = + case function n of + NoInline name interface -> case replaceList of + [] -> (n,replaceNoInlinesHrList hs) + _ -> (nNew, replaceNoInlinesHrList hsNew) + where + replaceList = foldl (collectChangesHr (interfaceInput interface, hs)) (collectChangesInterface interface hs) hs + (nNew_, hsNew_) = changeInp (interfaceInput interface) replaceList (n,hs) + fullReplaceList = [((interfaceInput interface, []), inpVarsChange)] ++ (map fst replaceList) + (nNew, hsNew) = (nNew_{function= replaceVars fullReplaceList (function nNew_)}, map (replaceVars fullReplaceList) hsNew_) + _ -> (n,replaceNoInlinesHrList hs) + + +changeInp:: NodeId -> [((Variable, Variable -> Variable), Tuple StorableType)] -> (Node, [Hierarchy]) -> (Node, [Hierarchy]) +changeInp inpNode chLs (node, hs) = (newNode, newHs) + where + newNode = Node (nodeId node) + (addIfcInpTypes newTyps (function node)) + (addInps (map (fst . fst) chLs) (input node)) + (addInpTypes newTyps (inputType node)) + (outputType node) + newHs = map (addOutTypesHr inpNode newTyps) hs + newTyps = map snd chLs + addInps vars input = Tup ([input] ++ (map (One . Variable) vars)) + addInpTypes types inpType = Tup ([inpType] ++ types) + addIfcInpTypes types (NoInline str ifc@(Interface {interfaceInputType = ifcType})) + = NoInline str ifc{interfaceInputType = Tup ([ifcType] ++ types)} + addOutTypesHr:: NodeId -> [Tuple StorableType] -> Hierarchy -> Hierarchy + addOutTypesHr id types (Hierarchy ndHrs) = Hierarchy (map (addOutTypesNode id types) ndHrs) + addOutTypesNode:: NodeId -> [Tuple StorableType] -> (Node, [Hierarchy]) -> (Node, [Hierarchy]) + addOutTypesNode id types (node@(Node {nodeId = nId, outputType=outType}) ,hs) + = if (id == nId) then (node{outputType = Tup ([outType] ++ types)}, hs) else (node, hs) + +collectChangesInterface :: Interface -> [Hierarchy] -> [((Variable, Variable -> Variable), Tuple StorableType)] +collectChangesInterface iface hs = map (genChange (interfaceInput iface)) $ zip [1..] $ filter ((mustChange hs) . fst) (tupleZipList (interfaceOutput iface, interfaceOutputType iface)) + + +genChange:: NodeId -> (NodeId, (Source, StorableType)) -> ((Variable, Variable -> Variable), Tuple StorableType) +genChange inpId (index, (Variable (id, list), typ)) = (((id, list), varChange inpId index) , One typ) + +mustChange:: [Hierarchy] -> Source -> Bool +mustChange hs x + = case x of + (Variable (id, list)) -> (notInHr id hs) + _ -> False + +inpVarsChange:: Variable -> Variable +inpVarsChange (id,list) = (id, [0] ++ list) + +varChange:: NodeId -> Int -> Variable -> Variable +varChange id index _ = (id, [index]) + + + +class CollectChangesHr a where + collectChangesHr:: (NodeId, [Hierarchy]) -> [((Variable, Variable -> Variable), Tuple StorableType)] -> a -> [((Variable, Variable -> Variable), Tuple StorableType)] + +instance CollectChangesHr Hierarchy where + collectChangesHr nhs changesList (Hierarchy nodeHsList) = foldl (collectChangesHr nhs) changesList nodeHsList + +instance CollectChangesHr (Node, [Hierarchy]) where + collectChangesHr nhs changesList (node, hsList) = foldl (collectChangesHr nhs) (collectChangesHr nhs changesList node) hsList + +instance CollectChangesHr Node where + collectChangesHr nhs changesList node = collectChangesHr nhs (collectChangesHr nhs changesList (filter ((mustChange (snd nhs)) . fst) (tupleZipList (input node, inputType node)))) (function node) + + +instance CollectChangesHr [(Source,StorableType)] where + collectChangesHr (nodeId,hs) changesList sourceList = changesList ++ (map (genChange nodeId) $ zip [((length changesList) + 1)..] $ sourceList) + +instance CollectChangesHr Function where + collectChangesHr nhs changesList (NoInline _ ifc) = collectChangesHr nhs changesList ifc + collectChangesHr nhs changesList (Parallel _ ifc) = collectChangesHr nhs changesList ifc + collectChangesHr nhs changesList (IfThenElse ifc1 ifc2) = collectChangesHr nhs (collectChangesHr nhs changesList ifc1) ifc2 + collectChangesHr nhs changesList (While ifc1 ifc2) = collectChangesHr nhs (collectChangesHr nhs changesList ifc1) ifc2 + collectChangesHr (nodeId,hs) changesList _ = changesList + +instance CollectChangesHr Interface where + collectChangesHr (nodeId,hs) changesList ifc = changesList ++ (map (genChange nodeId) $ zip [((length changesList) + 1)..] $ filter (mustChange hs . fst) (tupleZipList (interfaceOutput ifc, interfaceOutputType ifc))) + +class NotInHr a where + notInHr :: NodeId -> a -> Bool + +instance NotInHr [Hierarchy] where + notInHr id hs = and $ map (notInHr id) hs + +instance NotInHr Hierarchy where + notInHr id (Hierarchy nodeHs) = and $ map (notInHr id) nodeHs + +instance NotInHr (Node, [Hierarchy]) where + notInHr id (node, hs) = (notInHr id node) && (notInHr id hs) + +instance NotInHr Node where + notInHr id node = id /= (nodeId node) + diff --git a/Feldspar/Fs2dot.hs b/Feldspar/Fs2dot.hs new file mode 100644 --- /dev/null +++ b/Feldspar/Fs2dot.hs @@ -0,0 +1,270 @@ +{- + - Copyright (c) 2009, 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. + -} + +-- |Fs2dot is to help us create a visualisation of an algorithm written in +-- Feldspar by converting its graph into dot format -- which can be further +-- processed by the Graphviz suite. +module Feldspar.Fs2dot + ( fs2dot + , writeDot + , DOTSource + ) + where + +import Feldspar.Core.Types +import Feldspar.Core.Graph +import Feldspar.Core.Expr (toGraph, Program) +import Prelude hiding (id) + +{- frontend -} + +-- |'fs2dot' takes a Feldspar function as its argument and produces DOT language +-- source. +fs2dot :: (Program prg) + => prg -- ^Feldspar function + -> DOTSource -- ^DOT language source +fs2dot = toDot . fromGraph . makeHierarchical . toGraph + +-- |'writeDot' creates a DOT language format source file. Expected arguments +-- are the desired filename and the Feldspar function to be output in DOT +-- language. +writeDot :: (Program prg) + => FilePath -- ^output filename + -> prg -- ^Feldspar function + -> IO () +writeDot filename prg = writeFile filename $ fs2dot prg + +-- |This is for clarity. +type DOTSource = String + +{- data types -} + +data DGraph = + DGraph + { inputs :: [NodeId] + , outputs :: [NodeId] + , nodes :: [DNode] + , edges :: [DEdge] + } + deriving (Eq, Show) + +data DNode = + DNode + { id :: Int + , role :: Function + , subgraphs :: [DGraph] + , label :: String + } + deriving (Eq, Show) + +data DEdge = + DEdge + { start :: DConnector + , end :: DConnector + } + deriving (Eq, Show) + +data DConnector = + DNodeConn (NodeId, Int) + | DConstConn PrimitiveData + deriving (Eq, Show) + +{- core -} + +fromGraph :: HierarchicalGraph + -> DGraph +fromGraph graph = + DGraph + { inputs = enumerateInputs graph + , outputs = enumerateOutputs graph + , nodes = (\(Hierarchy h) -> enumerateNodes h) $ graphHierarchy graph + , edges = (\(Hierarchy h) -> enumerateEdges h) $ graphHierarchy graph + } + + where + enumerateInputs graph = [interfaceInput $ hierGraphInterface graph] + enumerateOutputs graph = graph + |> tuple2list . interfaceOutput . hierGraphInterface + |> map (\(Variable (n, _)) -> n) . filter isVariable + + enumerateNodes = map + (\(node, hiers) -> + DNode + { id = nodeId node + , role = function node + , subgraphs = hiers |> map + (\hier -> DGraph + { inputs = [] + , outputs = [] + , nodes = (\(Hierarchy h) -> enumerateNodes h) hier + , edges = [] + } + ) + , label = (fun2label (function node) + ++ " (" ++ show (nodeId node) ++ ")") |> subst '"' '\'' + } + ) + + enumerateEdges :: [(Node, [Hierarchy])] -> [DEdge] + enumerateEdges = concatMap + (\(node, hiers) -> + [ DEdge + { start = DNodeConn (inputnode, 0) + , end = DNodeConn (nodeId node, 0) + } + | inputnode <- + (tuple2list $ input node) + |> filter isVariable |> map (\(Variable (n, _)) -> n) + ] ++ + [ DEdge + { start = DConstConn (constval) + , end = DNodeConn (nodeId node, 0) + } + | constval <- + (tuple2list $ input node) + |> filter (not.isVariable) |> map (\(Constant val) -> val) + ] ++ + concatMap (\(Hierarchy h) -> enumerateEdges h) hiers + ) + + isVariable src = case src of + Variable _ -> True + _ -> False + +toDot :: DGraph + -> DOTSource +toDot graph = + [ dGraphHead + , dGraphOptions + , dGraphNodes graph + , dGraphEdges graph + , dGraphOutputs graph + , dGraphTail + ] |> unlines + |> unlines . filter (not.null) . lines + + where + dGraphHead = "digraph G {" + dGraphOptions = + [ "node [shape=box]" + , "compound=true bgcolor=\"lightgray\"" + , "node [style=filled color=\"black\" fillcolor=\"steelblue\"]" + , "edge []" + ] |> unlines + + dGraphNodes graph = + nodes graph + |> map + (\node -> + if compound node + then + [ "subgraph cluster" ++ show (id node) ++ " {" + , "label =\"" ++ label node ++ "\"" + , subgraphs node |> map + (\subgraph -> + [ dGraphNodes subgraph + , dGraphEdges subgraph + ] |> unlines + ) |> unlines + , "}" + ] |> unlines + else + [ "node" ++ show (id node) + , "[label=\"" ++ label node ++ "\"" + , "href=\"#node" ++ show (id node) ++ "\"]" + ] |> unwords + ) + |> unlines + + dGraphEdges graph = + zip [1..] (edges graph) + |> map + (\(n, edge) -> + if constEdge edge + then "const" ++ show ((\(DNodeConn (i, _)) -> i) $ end edge) + ++ "_" ++ show n + ++ " [label=\"" + ++ show ((\(DEdge (DConstConn val) _) -> val) edge) + ++ "\"]\n" + ++ "const" ++ show ((\(DNodeConn (i, _)) -> i) $ end edge) + ++ "_" ++ show n + ++ " -> " + ++ "node" ++ show ((\(DNodeConn (i, _)) -> i) $ end edge) + else "node" ++ show ((\(DNodeConn (i, _)) -> i) $ start edge) + ++ " -> " + ++ "node" ++ show ((\(DNodeConn (i, _)) -> i) $ end edge) + ) + |> unlines + + where + label edge = "" + constEdge edge = case edge of + DEdge (DConstConn _) _ -> True + _ -> False + + dGraphOutputs graph = zip [0 ..] (outputs graph) |> map + (\(n, opid) -> + [ "node" ++ show opid ++ " -> output" ++ show n + , "output" ++ show n ++ " [label=\"Output " ++ show n ++ "\"]" + ] |> unlines + ) |> unlines + dGraphTail = "}" + compound = \n -> (not.null) $ subgraphs n + +fun2label :: Function + -> String +fun2label (Input) = "Input" +fun2label (Array sd) = "Array " ++ (show sd) +fun2label (Function str) = "Function " ++ (show str) +fun2label (NoInline str ifc) = "NoInLine " ++ (show str) +fun2label (IfThenElse ifc1 ifc2) = "IfThenElse" +fun2label (While ifc1 ifc2) = "While" +fun2label (Parallel i ifc) = "Parallel " ++ (show i) + +{- utility functions -} + +tupleCount :: Tuple a -> Int +tupleCount (One a) = 1 +tupleCount (Tup as) = sum $ map tupleCount as + +tuple2list :: Tuple a -> [a] +tuple2list (One a) = [a] +tuple2list (Tup as) = concatMap tuple2list as + +subst :: (Eq a) => a -> a -> [a] -> [a] +subst _ _ [] = [] +subst a b (x:xs) = (if a == x then b else x) : subst a b xs + +infixl 1 |> +(|>) :: a -> (a -> b) -> b +(|>) x f = f x + diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,25 @@ +Copyright (c) 2009, 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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,6 @@ +module Main (main) where + +import Distribution.Simple + +main :: IO () +main = defaultMain diff --git a/feldspar-compiler.cabal b/feldspar-compiler.cabal new file mode 100644 --- /dev/null +++ b/feldspar-compiler.cabal @@ -0,0 +1,65 @@ +name: feldspar-compiler +version: 0.1 +cabal-version: >= 1.2 +build-type: Simple +license: BSD3 +license-file: LICENSE +copyright: Copyright (c) 2009, ERICSSON AB +author: Feldspar group, + Eotvos Lorand University Faculty of Informatics +maintainer: deva@inf.elte.hu +stability: experimental +homepage: http://feldspar.sourceforge.net/ +synopsis: Compiler for the Feldspar language +description: Feldspar (**F**unctional **E**mbedded **L**anguage for **DSP** + and **PAR**allelism) is an embedded DSL for describing digital + signal processing algorithms. + This library (FeldsparCompiler) contains a prototype compiler + that supports C code generation from programs written in this + language both according to ANSI C and also targeted to a real + DSP HW. +category: Compiler +tested-with: GHC==6.10.4 + +library + exposed-modules: + Feldspar.Compiler.Imperative.Representation + Feldspar.Compiler.Optimization.PrimitiveInstructions + Feldspar.Compiler.Optimization.Replace + Feldspar.Compiler.Optimization.Simplification + Feldspar.Compiler.Optimization.Unroll + Feldspar.Compiler.Precompiler.Precompiler + Feldspar.Compiler.Transformation.GraphToImperative + Feldspar.Compiler.Transformation.GraphUtils + Feldspar.Compiler.Transformation.Lifting + Feldspar.Compiler.Compiler + Feldspar.Compiler.Options + Feldspar.Compiler + Feldspar.Fs2dot + + build-depends: + feldspar-language, base >= 3 && < 4, containers, directory, filepath, + haskell-src-exts, hint, mtl, process + + extensions: + FlexibleInstances + TypeSynonymInstances + NoMonomorphismRestriction + + include-dirs: + ./Feldspar/C + + install-includes: + feldspar.h + feldspar.c + +executable feldspar + main-is : ./Feldspar/Compiler/CompilerMain.hs + + extensions: + CPP + FlexibleInstances + TypeSynonymInstances + NoMonomorphismRestriction + + cpp-options: -DRELEASE