diff --git a/Feldspar/C/feldspar.c b/Feldspar/C/feldspar.c --- a/Feldspar/C/feldspar.c +++ b/Feldspar/C/feldspar.c @@ -1,214 +1,237 @@ -/* - * 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 0 && b > 0) || (a < 0 && b < 0)) return a % b; + return (a % b) * (-1); +} + +int mod_fun_unsigned_int( unsigned int a, unsigned int b ) +{ + return a % b; +} + +long mod_fun_signed_long( long a, long b ) +{ + if ((a > 0 && b > 0) || (a < 0 && b < 0)) return a % b; + return (a % b) * (-1); +} + +long mod_fun_unsigned_long( unsigned long a, unsigned long b ) +{ + return a % b; +} + + + +int pow_fun_signed_int( int a, int b) +{ + int out = 1; + int i; + for(i=0; i> -i; + if (i > 0) return x << i; + return x; + } + + +int bit_rotate_fun_signed_int( int x, int i ) +{ + if (i < 0 && x < 0) { + int left = i + sizeof(x) * 8; + return ((x >> -i) & ~bit_shift_fun_signed_int(-1, left)) ^ bit_shift_fun_signed_int(x, left); + } + if (i < 0) return x >> -i ^ bit_shift_fun_signed_int(x, i + sizeof(x) * 8); + else if (i == 0) return x; + else return x << i ^ bit_shift_fun_signed_int(x, i - sizeof(x) * 8); +} + +int rotateL_fun_signed_int( int x, int i ) +{ + return bit_rotate_fun_signed_int(x, i); +} + +int rotateR_fun_signed_int( int x, int i ) +{ + return bit_rotate_fun_signed_int(x, -i); +} + + + + +int bitSize_fun_signed_int( int x ) +{ + return sizeof x * 8; +} + +int isSigned_fun_signed_int( int x ) +{ + (void) x; + return 1; +} + + + +int abs_fun_signed_int( int a ) +{ + if (a < 0) return a*(-1); + return a; +} + +int abs_fun_unsigned_int( unsigned int a ) +{ + return a; +} + +long abs_fun_signed_long( long a ) +{ + if (a < 0) return a*(-1); + return a; +} + +long abs_fun_unsigned_long( unsigned long a ) +{ + return a; +} + +double abs_fun_float( float a ) +{ + if (a < 0) return a*(-1); + return a; +} + +double abs_fun_double( double a ) +{ + if (a < 0) return a*(-1); + return a; +} + + + +int signum_fun_signed_int( int a ) +{ + if (a < 0) return -1; + if (a > 0) return 1; + return 0; +} + +int signum_fun_unsigned_int( unsigned int a ) +{ + 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; + return 0; +} + +double signum_fun_float( float 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]) +type Writer t = (CompilationMode -> t -> FilePath -> Precompiler.OriginalFeldsparFunctionSignature -> Options -> IO ()) ------------------------- -- 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 +replace :: Eq a => [a] -> [a] -> [a] -> [a] +replace [] _ _ = [] +replace s find repl | take (length find) s == find = repl ++ (replace (drop (length find) s) find repl) + | otherwise = [head s] ++ (replace (tail s) find repl) +fixFunctionName :: String -> String +fixFunctionName functionName = replace (replace functionName "_" "__") "'" "_prime" + +coreCompile :: (Reify.Program t) => + Writer t -> CompilationMode -> t -> FilePath -> FilePath -> Precompiler.OriginalFeldsparFunctionSignature -> Options -> IO () +coreCompile write compilationMode prg inputFileName outputFileName originalFeldsparFunctionSignature opts = + write compilationMode prg outputFileName originalFeldsparFunctionSignature { + Precompiler.originalFeldsparFunctionName = fixFunctionName $ Precompiler.originalFeldsparFunctionName originalFeldsparFunctionSignature + } opts + ------------------------- -- Standalone compiler -- ------------------------- includeGeneration :: FilePath -> IO () -includeGeneration fileName +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 +standaloneWrite :: (Reify.Program t) => Writer t +standaloneWrite compilationMode prg outFileName originalFeldsparFunctionSignature opts + = appendFile outFileName $ compToC $ executePluginChain compilationMode prg originalFeldsparFunctionSignature opts +standaloneCompile :: (Reify.Program t) => t -> FilePath -> FilePath -> Precompiler.OriginalFeldsparFunctionSignature -> Options -> IO () +standaloneCompile prg inputFileName outputFileName originalFeldsparFunctionSignature opts + = coreCompile standaloneWrite Standalone prg inputFileName outputFileName originalFeldsparFunctionSignature opts ------------------------------------------------ -- Invoking the compiler from the interpreter -- ------------------------------------------------ - -fileWrite stage prg fileName functionName opts - = writeFile fileName $ intro ++ (toC 0 $ stage prg functionName opts) +fileWrite :: (Reify.Program t) => Writer t +fileWrite compilationMode prg fileName originalFeldsparFunctionSignature opts + = writeFile fileName $ intro ++ (compToC $ executePluginChain compilationMode prg originalFeldsparFunctionSignature opts) -compile :: (Expr.Program t) => t -> FilePath -> String -> Options -> IO () +compile :: (Reify.Program t) => t -> FilePath -> String -> Options -> IO () compile prg fileName functionName opts - = coreCompile fileWrite prg fileName functionName opts + = coreCompile fileWrite Interactive prg "" fileName (Precompiler.OriginalFeldsparFunctionSignature functionName []) opts +writeOut :: (Reify.Program t) => Writer t +writeOut compilationMode prg fileName functionName opts + = putStrLn $ intro ++ (compToC $ executePluginChain compilationMode prg functionName opts) -writeOut stage prg fileName functionName opts - = putStrLn $ intro ++ (toC 0 $ stage prg functionName opts) +icompile :: (Reify.Program t) => t -> IO () +icompile prg + = coreCompile writeOut Interactive prg "" "" (Precompiler.OriginalFeldsparFunctionSignature "test" []) defaultOptions -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 +icompile' :: (Reify.Program t) => t -> String -> Options -> IO () +icompile' prg functionName opts + = coreCompile writeOut Interactive prg "" "" (Precompiler.OriginalFeldsparFunctionSignature functionName []) opts ------------------------ -- Predefined options -- @@ -123,11 +110,15 @@ defaultOptions = Options - { platform = AnsiC - , unroll = NoUnroll - , debug = NoDebug + { platform = AnsiC + , unroll = NoUnroll + , debug = NoDebug + , defaultArraySize = 16 } +c99Options + = defaultOptions { platform = C99 } + unrollOptions = defaultOptions { unroll = Unroll 8 } @@ -137,27 +128,45 @@ noPrimitiveInstructionHandling = defaultOptions { debug = NoPrimitiveInstructionHandling } ----------------------- --- Helper functions -- ----------------------- +-- =========================================================================== +-- == Plugin system +-- =========================================================================== -stage1:: (Expr.Program t) => t -> HierarchicalGraph -stage1 = makeHierarchical . toGraph +pluginChain :: ExternalInfoCollection -> Procedure InitSemInf -> Procedure PrettyPrintSemanticInfo +pluginChain externalInfo + = (executePlugin PrettyPrint (prettyPrintExternalInfo externalInfo)) + . (executePlugin ConstantFolding ()) + . (executePlugin UnrollPlugin (unrollExternalInfo externalInfo)) + . (executePlugin Precompilation (precompilationExternalInfo externalInfo)) + . (executePlugin ForwardPropagation (forwardPropagationExternalInfo externalInfo)) + . (executePlugin HandlePrimitives (handlePrimitivesExternalInfo externalInfo)) + . (executePlugin BackwardPropagation (backwardPropagationExternalInfo externalInfo)) -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 +data ExternalInfoCollection = ExternalInfoCollection { + precompilationExternalInfo :: ExternalInfo Precompilation, + prettyPrintExternalInfo :: ExternalInfo PrettyPrint, + unrollExternalInfo :: ExternalInfo UnrollPlugin, + handlePrimitivesExternalInfo :: ExternalInfo HandlePrimitives, + forwardPropagationExternalInfo :: ExternalInfo ForwardPropagation, + backwardPropagationExternalInfo :: ExternalInfo BackwardPropagation +} -stage7:: (Expr.Program t) => t -> String -> Options -> [ImpFunction] -stage7 prg name opt = doUnroll opt $ stage6 prg name opt +executePluginChain :: (Reify.Program p) => CompilationMode -> p -> Precompiler.OriginalFeldsparFunctionSignature -> Options -> [Procedure PrettyPrintSemanticInfo] +executePluginChain compilationMode prg originalFeldsparFunctionSignatureParam opt = + Prelude.map (pluginChain ExternalInfoCollection { + precompilationExternalInfo = PrecompilationExternalInfo { + originalFeldsparFunctionSignature = originalFeldsparFunctionSignatureParam, + graphInputInterfaceType = interfaceInputType $ hierGraphInterface hierarchicalGraph, + numberOfFunctionArguments = Reify.numArgs (mkT prg), + compilationMode = compilationMode + }, + prettyPrintExternalInfo = (platform opt, defaultArraySize opt), + unrollExternalInfo = unroll opt, + handlePrimitivesExternalInfo = (defaultArraySize opt, debug opt), + forwardPropagationExternalInfo = debug opt, + backwardPropagationExternalInfo = debug opt + }) + (graphToImperative hierarchicalGraph) + where + hierarchicalGraph = replaceNoInlines $ makeHierarchical $ reify prg diff --git a/Feldspar/Compiler/CompilerMain.hs b/Feldspar/Compiler/CompilerMain.hs --- a/Feldspar/Compiler/CompilerMain.hs +++ b/Feldspar/Compiler/CompilerMain.hs @@ -1,39 +1,8 @@ -{- - - 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 qualified Feldspar.Compiler.Compiler -- ONLY for improving compilation speed in normal mode import System.Exit import System.Environment @@ -44,6 +13,8 @@ import Control.Monad import Control.Monad.Error +import Control.Monad.CatchIO +import Control.Exception import Data.List import System.Console.GetOpt @@ -51,28 +22,34 @@ import Language.Haskell.Interpreter -generateCompileCode outputFileName options functionName = - "standaloneCompile " ++ functionName ++ " \""++ outputFileName ++"\" " ++ "\""++ functionName ++"\" " ++ - options +warningPrefix = "[WARNING]: " +errorPrefix = "[ERROR ]: " -generateUltimateCode outputFileName declarationList options = -- final code for the interpreter - "do " ++ (concat $ map (generateCompileCode outputFileName options) declarationList) +serializeOriginalFeldsparFunctionSignature originalFeldsparFunctionSignature = + "(OriginalFeldsparFunctionSignature \"" ++ (originalFeldsparFunctionName originalFeldsparFunctionSignature) ++ "\" " ++ (show $ originalFeldsparParameterNames originalFeldsparFunctionSignature) ++ ")" -compileFunction :: String -> String -> String -> Interpreter () -compileFunction outputFileName options functionName = do - lift $ putStr $ "Compiling function " ++ functionName ++ "...\t" +generateCompileCode :: String -> String -> String -> OriginalFeldsparFunctionSignature -> String +generateCompileCode inputFileName outputFileName options originalFeldsparFunctionSignature = + "standaloneCompile " ++ (originalFeldsparFunctionName originalFeldsparFunctionSignature) ++ " \"" ++ inputFileName ++ "\" " ++ " \""++ + outputFileName ++"\" " ++ (serializeOriginalFeldsparFunctionSignature originalFeldsparFunctionSignature) ++ " " ++ options + +compileFunction :: String -> String -> String -> OriginalFeldsparFunctionSignature -> Interpreter () +compileFunction inFileName outFileName options originalFeldsparFunctionSignature = do + iPutStr $ "Compiling function " ++ (originalFeldsparFunctionName originalFeldsparFunctionSignature) ++ "...\t" --result <- catchError ( interpret (generateCompileCode outputFileName options functionName) (as::IO()) ) (\_->error "error") - result <- interpret (generateCompileCode outputFileName options functionName) (as::IO()) + result <- interpret (generateCompileCode inFileName outFileName options originalFeldsparFunctionSignature) (as::IO()) lift result - say "[OK]" + iPutStrLn "[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 +compileAllFunctions :: String -> String -> String -> [OriginalFeldsparFunctionSignature] -> Interpreter () +compileAllFunctions inFileName outFileName options [] = return() +compileAllFunctions inFileName outFileName options (x:xs) = do + (catchError (compileFunction inFileName outFileName options x) ( const $ iPutStrLn "[FAILED]")) + `Control.Monad.CatchIO.catch` + (\msg -> iPutStrLn $ errorPrefix ++ show (msg::Control.Exception.ErrorCall)) + compileAllFunctions inFileName outFileName options xs -globalImportList = ["Feldspar.Fs2dot", "Feldspar.Compiler.Compiler"] +globalImportList = ["Feldspar.Fs2dot", "Feldspar.Compiler.Compiler", "Feldspar.Compiler.Precompiler.Precompiler"] generateIncludeLine :: String -> Interpreter () generateIncludeLine outputFileName = do @@ -80,20 +57,20 @@ 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()) +singleFunctionCompilationBody :: String -> String -> String -> OriginalFeldsparFunctionSignature -> Interpreter (IO ()) +singleFunctionCompilationBody inFileName outFileName options originalFeldsparFunctionSignature = do + iPutStrLn $ "Output file: " ++ outFileName + iPutStrLn $ "Compiling function " ++ (originalFeldsparFunctionName originalFeldsparFunctionSignature) ++ "..." + generateIncludeLine outFileName + result <- interpret (generateCompileCode inFileName outFileName options originalFeldsparFunctionSignature) (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 +multiFunctionCompilationBody :: String -> String -> String -> [OriginalFeldsparFunctionSignature] -> Interpreter (IO ()) +multiFunctionCompilationBody inFileName outFileName compilerOptions declarationList = do + iPutStrLn $ "Output file: " ++ outFileName + generateIncludeLine outFileName + compileAllFunctions inFileName outFileName compilerOptions declarationList return(return()) -- | A general interpreter body for interpreting an expression @@ -112,9 +89,9 @@ actionToExecute <- runInterpreter $ do set [ languageExtensions := (glasgowExtensions ++ [NoMonomorphismRestriction, OverlappingInstances, Rank2Types, UndecidableInstances]) ] - say $ "Loading module " ++ moduleName ++ "..." + iPutStrLn $ "Loading module " ++ moduleName ++ "..." #ifdef RELEASE - loadModules [inputFileName] -- the globalImportList modules are package modules and should not be loaded, only imported + loadModules [inputFileName] -- globalImportList modules are package modules and shouldn't be loaded, only imported #else loadModules $ [inputFileName] ++ globalImportList -- in normal mode, we need to load them before importing them #endif @@ -123,6 +100,7 @@ interpreterBody either printInterpreterError id actionToExecute + printGhcError (GhcError {errMsg=s}) = putStrLn s printInterpreterError :: InterpreterError -> IO () @@ -175,7 +153,7 @@ (ReqArg (\arg opt -> return opt { optCompilerMode = arg }) "compilerMode") - "Changes compiler mode. Valid options are: unrollOptions, noSimplification, noPrimitiveInstructionHandling" + "Changes compiler mode. Valid options are: unrollOptions, noSimplification, noPrimitiveInstructionHandling, c99Options" , Option "h" ["help"] (NoArg @@ -229,7 +207,7 @@ let outputFileName = convertOutputFileName inputFileName maybeOutputFileName when (not $ compilerMode `elem` - ["defaultOptions", "unrollOptions", "noSimplification", "noPrimitiveInstructionHandling"]) (do + ["defaultOptions", "unrollOptions", "noSimplification", "noPrimitiveInstructionHandling", "c99Options"]) (do putStrLn $ "Invalid compiler mode \"" ++ compilerMode ++ "\"" exitWith (ExitFailure 1)) @@ -237,13 +215,17 @@ compilationCore functionMode inputFileName outputFileName commandLineOptions dotGeneration dotFileName compilerMode = do putStrLn $ "Starting the Standalone Feldspar Compiler..." - - removeFile outputFileName `catch` (const $ return ()) + -- -- -- Input file preparations -- -- -- + removeFile (replaceExtension inputFileName ".hi") `Prelude.catch` (const $ return()) + removeFile (replaceExtension inputFileName ".o" ) `Prelude.catch` (const $ return()) + -- -- -- Output file preparations -- -- -- + renameFile outputFileName (outputFileName ++ ".bak") `Prelude.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 declarationList = getExtendedDeclarationList fileContents + let moduleName = getModuleName fileContents let highLevelInterpreterWithModuleInfo = highLevelInterpreter moduleName inputFileName @@ -252,25 +234,35 @@ Options { optDotGeneration = True} -> do putStrLn "Dot generation enabled" case functionMode of - SingleFunction functionName -> case dotFileName of + SingleFunction funName -> case dotFileName of Just fileName -> highLevelInterpreterWithModuleInfo - (generalInterpreterBody $ "writeDot \"" ++ fileName ++ "\" " ++ functionName) + (generalInterpreterBody $ "writeDot \"" ++ fileName ++ "\" " ++ funName) Nothing -> highLevelInterpreterWithModuleInfo - (generalInterpreterBody $ "putStr $ fs2dot " ++ functionName) + (generalInterpreterBody $ "putStr $ fs2dot " ++ funName) 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 ++ "..." + MultiFunction + | length declarationList == 0 -> putStrLn "Multi-function mode: Nothing to do." + | otherwise -> do + if length declarationList > 1 + then putStrLn $ "Multi-function mode, compiling " ++ (show $ length declarationList) ++ " functions..." + else putStrLn $ "Multi-function mode, compiling the only function (" ++ (originalFeldsparFunctionName $ head declarationList) ++ ")..." + highLevelInterpreterWithModuleInfo (multiFunctionCompilationBody inputFileName outputFileName compilerMode declarationList) + SingleFunction funName -> do + putStrLn $ "Single-function mode, compiling function " ++ funName ++ "..." + let originalFeldsparFunctionSignatureNeeded = case filter ((==funName).originalFeldsparFunctionName) declarationList of + [a] -> a + [] -> error $ "Function " ++ funName ++ " not found" + _ -> error "Unexpected error SC/01" highLevelInterpreterWithModuleInfo - (singleFunctionCompilationBody outputFileName compilerMode functionName) + (singleFunctionCompilationBody inputFileName outputFileName compilerMode originalFeldsparFunctionSignatureNeeded) -say :: String -> Interpreter () -say = liftIO . putStrLn +iPutStrLn :: String -> Interpreter () +iPutStrLn = liftIO . putStrLn + +iPutStr :: String -> Interpreter () +iPutStr = liftIO . putStr diff --git a/Feldspar/Compiler/Error.hs b/Feldspar/Compiler/Error.hs new file mode 100644 --- /dev/null +++ b/Feldspar/Compiler/Error.hs @@ -0,0 +1,7 @@ +module Feldspar.Compiler.Error where + +data ErrorClass = InvariantViolation | InternalError + deriving (Show, Eq) + +handleError :: String -> ErrorClass -> String -> a +handleError place errorClass message = error $ "[" ++ show errorClass ++ " @ " ++ place ++ "]: " ++ message diff --git a/Feldspar/Compiler/Imperative/CodeGeneration.hs b/Feldspar/Compiler/Imperative/CodeGeneration.hs new file mode 100644 --- /dev/null +++ b/Feldspar/Compiler/Imperative/CodeGeneration.hs @@ -0,0 +1,295 @@ +{-# LANGUAGE FlexibleInstances #-} + +module Feldspar.Compiler.Imperative.CodeGeneration where + +import Feldspar.Compiler.Imperative.Representation +import Feldspar.Compiler.Imperative.Semantics +import Feldspar.Compiler.Error +import qualified Data.List as List (last) + +------------------------ +-- C code generation -- +------------------------ + +codeGenerationError = handleError "CodeGeneration" + +data Place = + Declaration_pl + --value of var, need type, type array-style + --declare variables + | MainParameter_pl + --value of var need type, type pointer-style + --main fun parameters + | ValueNeed_pl + --value of var, not need type - + --in Expressions + | AddressNeed_pl + --access of var, not need type - + --output of fun + | FunctionCallIn_pl + --value of var, not need type - SPEC ARRAY FORMAT + --input of fun + deriving (Eq,Show) + +compToC :: ToC a => a -> String +compToC = toC Declaration_pl + +class ToC a where + toC :: Place -> a -> String + +instance ToC Size where + toC _ S8 = "char" + toC _ S16 = "short" + toC _ S32 = "int" + toC _ S64 = "long long" + +instance ToC Signedness where + toC _ ImpSigned = "signed" + toC _ ImpUnsigned = "unsigned" + +instance ToC Type where + toC _ BoolType = "int" + toC _ FloatType = "float" + toC p (Numeric s t) = listprint id " " [toC p s, toC p t] + --arraytype handled in variable + +instance ToC (Variable PrettyPrintSemanticInfo) where + toC p a@(Variable (VariableData r t n) _) = show_variable r p t n NoRestrict + +show_variable :: VariableRole -> Place -> Type -> String -> IsRestrict -> String +show_variable r p t n restr = listprint (id) " " [variableType, show_name r p t n ++ arrLn] --concat [addSpace $ variableType, show_name r p t n, arrLn] + where + (variableType,arrLn) = show_type p t restr + show_type :: Place -> Type -> IsRestrict -> (String,String) + show_type MainParameter_pl (ImpArrayType s t@(ImpArrayType s2 t2)) restr = decl_matr_type s t2 s2 restr + show_type Declaration_pl (ImpArrayType s t) restr = decl_arr_type t s ("","") + show_type MainParameter_pl (ImpArrayType s t) restr = decl_arr_type_0 t s restr + show_type Declaration_pl t _ = (toC p t,"") + show_type MainParameter_pl t _ = (toC p t,"") + show_type _ _ _ = ("","") + + decl_arr_type_0 :: Type -> Length -> IsRestrict -> (String,String) + decl_arr_type_0 t s Restrict = ((toC Declaration_pl t) ++ " * const restrict", "") + decl_arr_type_0 t s _ = ((toC Declaration_pl t) ++ " *", "") + + decl_matr_type :: Length -> Type -> Length -> IsRestrict -> (String,String) + decl_matr_type mb t2 s2 Restrict = decl_arr_type t2 s2 (" (* const restrict", ")") + decl_matr_type mb t2 s2 _ = decl_arr_type t2 s2 (" (*", ")") + + decl_arr_type :: Type -> Length -> (String,String) -> (String,String) + decl_arr_type (ImpArrayType s2 t2) mb (st1,st2) = decl_arr_type t2 s2 (st1,st2 ++ (show_brackets mb)) + decl_arr_type t mb (st1,st2) = ((toC Declaration_pl t) ++ st1, st2 ++ show_brackets mb) + + show_brackets :: Length -> String + show_brackets Undefined = codeGenerationError InternalError $ "Unattended unknown array size" + show_brackets (Norm i) = concat["[",show i,"]"] + show_brackets (Defined i) = concat["[", show i, defaultArraySizeWarning, "]"] + + defaultArraySizeWarning :: String + defaultArraySizeWarning = " /* WARNING: Default size used!! */" + + show_name :: VariableRole -> Place-> Type -> String -> String + show_name _ FunctionCallIn_pl t@(ImpArrayType _ _) n = concat["&(",n,genIndex t,")"] + show_name _ AddressNeed_pl t@(ImpArrayType _ _) n = concat["&(",n,genIndex t,")"] + show_name _ _ (ImpArrayType _ _) n = n + show_name Value place t n + | place == AddressNeed_pl = "&" ++ n + | otherwise = n + show_name FunOut place t n + | place == AddressNeed_pl = n + | place == Declaration_pl = codeGenerationError InternalError $ "You can't declare output variable of the function" + | place == MainParameter_pl = "* " ++ n + | List.last n == ']' = n + | otherwise = "(* " ++ n ++ ")" + + genIndex :: Type -> String + genIndex (ImpArrayType _ t) = "[0]" ++ genIndex t + genIndex _ = "" + +instance ToC (Constant PrettyPrintSemanticInfo) where + toC _ (IntConstant i) = show (intConstantValue i) + toC _ (FloatConstant i) = show (floatConstantValue i) ++ "f" + toC _ (BoolConstant (BoolConstantType True _)) = "1" + toC _ (BoolConstant (BoolConstantType False _)) = "0" + toC p a@(ArrayConstant l) = "{" ++ (toCArray p a) ++ "}" + +toCArray :: Place -> Constant PrettyPrintSemanticInfo -> String +toCArray p (ArrayConstant l) = listprint (toCArray p) "," (arrayConstantValue l) +toCArray p i = toC p i + +instance ToC (LeftValue PrettyPrintSemanticInfo) where + toC p (VariableLeftValue (VariableInLeftValue v _)) = toC p v + toC p (ArrayElemReferenceLeftValue leftArrayElemReference) = toC p $ insertIndex (arrayName $ arrayElemReferenceData leftArrayElemReference) where + insertIndex :: LeftValue PrettyPrintSemanticInfo -> LeftValue PrettyPrintSemanticInfo + insertIndex (VariableLeftValue (VariableInLeftValue variable semInf)) = VariableLeftValue $ VariableInLeftValue + (variable { + variableData = (variableData variable) { + variableType = decrArrayDepth (variableType $ variableData variable), + variableName = (concat[variableName $ variableData variable,"[", + toC ValueNeed_pl (arrayIndex $ arrayElemReferenceData leftArrayElemReference), "]"]) + } + }) semInf + insertIndex (ArrayElemReferenceLeftValue leftArrayElemReference) = + ArrayElemReferenceLeftValue $ leftArrayElemReference { + arrayElemReferenceData = ArrayElemReferenceData (insertIndex (arrayName $ arrayElemReferenceData leftArrayElemReference)) + (arrayIndex $ arrayElemReferenceData leftArrayElemReference) + } + +instance ToC (ActualParameter PrettyPrintSemanticInfo) where + toC p (InputActualParameter (InputActualParameterType e _)) = toC FunctionCallIn_pl e + toC p (OutputActualParameter (OutputActualParameterType l _)) = toC AddressNeed_pl l + +instance ToC (Expression PrettyPrintSemanticInfo) where + toC p (LeftValueExpression (LeftValueInExpression lv _)) = toC p lv + toC p (ConstantExpression c) = toC p c + toC p (FunctionCallExpression (FunctionCall (FunctionCallData InfixOp _ f [a,b]) _)) = concat["(",toC p a," ",f," ",toC p b,")"] + toC p (FunctionCallExpression (FunctionCall (FunctionCallData _ t f x) _)) = concat [f,"(",listprint (toC p) ", " x,")"] + +instance ToC (Procedure PrettyPrintSemanticInfo) where + toC p (Procedure n il ol pr semInf) = concat ["void ",n,"(",param,")\n{\n",prog,"}\n"] + where + param = listprint (toC MainParameter_pl) ", " (il ++ ol) + prog = ind (toC Declaration_pl) pr + +instance ToC (Block PrettyPrintSemanticInfo) where + toC p (Block (BlockData d pr) semInf) = listprint id "\n" [decl,toC p pr] + where + decl = concat $ map (\a->toC Declaration_pl a ++ ";\n") d + +instance ToC (FormalParameter PrettyPrintSemanticInfo) where + toC p (FormalParameter v restr) = (helper p v restr) + where + helper :: Place -> Variable PrettyPrintSemanticInfo -> IsRestrict -> String + helper MainParameter_pl (Variable (VariableData r t n) _) restr + = show_variable r MainParameter_pl t n restr + helper _ (Variable (VariableData r t n) _) restr + = show_variable r Declaration_pl t n restr + +instance ToC (LocalDeclaration PrettyPrintSemanticInfo) where + toC p (LocalDeclaration (LocalDeclarationData v i) isDefArrSize) = (helper p v i) + where + helper :: Place -> Variable PrettyPrintSemanticInfo -> (Maybe (Expression PrettyPrintSemanticInfo)) -> String + helper MainParameter_pl v i = concat [toC MainParameter_pl v,init i] + helper _ v i = concat [toC Declaration_pl v,init i] + init :: Maybe (Expression PrettyPrintSemanticInfo) -> String + init Nothing = "" + init (Just e) = " = " ++ toC ValueNeed_pl e + +instance ToC (Instruction PrettyPrintSemanticInfo) where + toC p (AssignmentInstruction assignment) = + concat [toC ValueNeed_pl (assignmentLhs $ assignmentData assignment)," = ",toC ValueNeed_pl (assignmentRhs $ assignmentData assignment),";\n"] + toC p (ProcedureCallInstruction procedureCall) = + concat [nameOfProcedureToCall $ procedureCallData procedureCall,"(", + listprint (toC p) ", " (actualParametersOfProcedureToCall $ procedureCallData procedureCall),");\n"] + -- TODO ProcedureCall.actualParameters procedureCall -----> External helper functions !!! + +instance ToC (Program PrettyPrintSemanticInfo) where + toC p (Program (EmptyProgram (Empty i)) seminf) = "" + toC p (Program (PrimitiveProgram (Primitive i seminf)) psi) = toC p i + toC p (Program (SequenceProgram (Sequence ps _)) psi) = listprint (toC p) "" ps + toC p (Program (BranchProgram (Branch (BranchData con tPrg ePrg) _)) psi) + = concat ["if(",toC ValueNeed_pl con,")\n{\n", ind (toC p) tPrg,"}\nelse\n{\n",ind (toC p) ePrg,"}\n"] + toC p (Program (SequentialLoopProgram (SequentialLoop (SequentialLoopData condVar condCalc loopBody) _)) psi) = concat["{\n",ind id whereBody,"}\n"] + where + whereBody = concat [toC p condCalc,"while(",toC ValueNeed_pl condVar,")\n", + "{\n",ind (toC p) loopBody,ind (toC p) (blockInstructions $ blockData condCalc),"}\n"] + toC p (Program (ParallelLoopProgram (ParallelLoop (ParallelLoopData v num step prg) _)) psi) = concat ["{\n",ind id for_seq,"}\n"] + where + for_seq = concat [toC Declaration_pl v,";\nfor(",for_init,for_test,for_inc,")\n{\n",ind (toC p) prg,"}\n"] + for_init = concat [toC ValueNeed_pl v," = 0; "] + for_test = concat [toC ValueNeed_pl v," < ",toC ValueNeed_pl num,"; "] + for_inc = concat [toC ValueNeed_pl v," += ",show step] + +instance ToC a => ToC (Maybe a) where + toC p Nothing = "" + toC p (Just a) = toC p a + +instance (ToC a) => ToC [a] where + toC p xs = listprint (toC p) "\n" xs + +---------------------- +-- Type -- +---------------------- + +class HasType a where + typeof :: a -> Type + +instance (SemanticInfo t) => HasType (Variable t) where + typeof (Variable (VariableData r t s) _) = t + +instance (SemanticInfo t) => HasType (LeftValue t) where + typeof (VariableLeftValue (VariableInLeftValue v _)) = typeof v + typeof (ArrayElemReferenceLeftValue arrayElemReference) = + decrArrayDepth (typeof (arrayName $ arrayElemReferenceData arrayElemReference)) + +instance (SemanticInfo t) => HasType (Constant t) where + typeof (IntConstant _) = Numeric ImpSigned S32 + typeof (FloatConstant _) = FloatType + typeof (BoolConstant _) = BoolType + typeof arr@(ArrayConstant l) = ImpArrayType (Norm $ length innerConstList) elemtype + where + elemtype = case innerConstList of + [] -> codeGenerationError InternalError $ "Const array with 0 elements: " ++ show arr + _ -> checktype (typeof $ head innerConstList) (map typeof innerConstList) + innerConstList = arrayConstantValue l + checktype :: Type -> [Type] -> Type + checktype t [] = t + checktype t (x:xs) + | t == x = checktype t xs + | otherwise = codeGenerationError InternalError $ "Different element types in constant array: " ++ show arr + +instance (SemanticInfo t) => HasType (Expression t) where + typeof (LeftValueExpression lve) = typeof $ leftValueExpressionContents lve + typeof (ConstantExpression c) = typeof c + typeof (FunctionCallExpression functionCallExpression) = typeOfFunctionToCall $ functionCallData functionCallExpression + +instance (SemanticInfo t) => HasType (ActualParameter t) where + typeof (InputActualParameter (InputActualParameterType e _)) = typeof e + typeof (OutputActualParameter (OutputActualParameterType l _)) = typeof l + +---------------------- +-- Helper functions -- +---------------------- + +ind :: (a-> String) -> a -> String +ind f x = unlines $ map (\a -> " " ++ a) $ lines $ f x + +listprint :: (a->String) -> String -> [a] -> String +listprint f s xs = listprint' s $ filter (\a -> a /= "")$ map f xs where + listprint' _ [] = "" + listprint' _ [x] = x + listprint' s (x:y:xs) = x ++ s ++ listprint' s (y:xs) + +parameterToExpression :: (SemanticInfo t) => ActualParameter t -> Expression t +parameterToExpression (InputActualParameter (InputActualParameterType e _)) = e +parameterToExpression (OutputActualParameter (OutputActualParameterType lv _)) = + LeftValueExpression $ LeftValueInExpression lv undefined -- TODO undefined + +decrArrayDepth :: Type -> Type +decrArrayDepth (ImpArrayType _ t) = t +decrArrayDepth _ = codeGenerationError InternalError $ "A variable is indexed, but not array!" + +simpleType :: Type -> Bool +simpleType BoolType = True +simpleType (Numeric _ _) = True +simpleType FloatType = True +simpleType (ImpArrayType _ _) = False + +toLeftValue :: (SemanticInfo t) => Expression t -> LeftValue t +toLeftValue (LeftValueExpression (LeftValueInExpression lv _)) = lv +toLeftValue e = codeGenerationError InternalError $ show e ++ " is not a left value." + +contains :: (SemanticInfo t) => String -> Expression t -> Bool +contains n (LeftValueExpression (LeftValueInExpression lv _)) = contains' n lv where + contains' n (VariableLeftValue + (VariableInLeftValue (Variable (VariableData _ _ n' ) _) _) + ) = n == n' + contains' n (ArrayElemReferenceLeftValue arrayElemReference) = contains' n (arrayName $ arrayElemReferenceData arrayElemReference) || + contains n (arrayIndex $ arrayElemReferenceData arrayElemReference) +contains _ (ConstantExpression _) = False +contains n (FunctionCallExpression functionCallExpression) = + any (contains n) (actualParametersOfFunctionToCall $ functionCallData functionCallExpression) + +getVarName :: (SemanticInfo t) => LeftValue t -> String +getVarName (VariableLeftValue (VariableInLeftValue ( Variable (VariableData _ _ n) _ ) _ )) = n +getVarName (ArrayElemReferenceLeftValue arrayElemReference) = getVarName (arrayName $ arrayElemReferenceData arrayElemReference) diff --git a/Feldspar/Compiler/Imperative/Representation.hs b/Feldspar/Compiler/Imperative/Representation.hs --- a/Feldspar/Compiler/Imperative/Representation.hs +++ b/Feldspar/Compiler/Imperative/Representation.hs @@ -1,485 +1,266 @@ -{- - - 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 TypeFamilies #-} 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) +import Feldspar.Compiler.Imperative.Semantics -data FunRole = SimpleFun | InfixOp | PrefixOp deriving (Eq,Show) +-- =========================================================================== +-- == Representation of imperative programs +-- =========================================================================== -data Instruction = - Assign LeftValue ImpLangExpr - | CFun String [Parameter] - deriving (Eq,Show) +-- ========================= [ Procedure ] =================================== -data Parameter - = In ImpLangExpr - | Out (ParameterKind,ImpLangExpr) - deriving (Eq,Show) +data (SemanticInfo t) => Procedure t = Procedure { + procedureName :: String, + inParameters :: [FormalParameter t], + outParameters :: [FormalParameter t], + procedureBody :: Block t, + procedureSemInf :: ProcedureInfo t +} deriving (Eq,Show) -data ParameterKind = Normal | OutKind - deriving (Eq,Show) +-- ========================= [ Block ] ======================================= -data ImpFunction = - Fun { funName :: String, - inParameters :: [Declaration], - outParameters :: [Declaration], - prg :: CompleteProgram - } - deriving (Eq,Show) +data (SemanticInfo t) => Block t = Block { + blockData :: BlockData t, + blockSemInf :: BlockInfo t +} deriving (Eq,Show) -data CompleteProgram = - CompPrg { - locals :: [Declaration], - body :: Program - } - deriving (Eq,Show) +data (SemanticInfo t) => BlockData t = BlockData { + blockDeclarations :: [LocalDeclaration t], + blockInstructions :: Program t +} deriving (Eq,Show) -data Declaration - = Decl - { var :: Variable - , declType :: Type - , initVal :: Maybe ImpLangExpr - , semInfVar :: SemInfVar - } - deriving (Eq,Show) +-- ========================= [ Program ] ===================================== -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 (SemanticInfo t) => Program t = Program { + programConstruction :: ProgramConstruction t, + programSemInf :: ProgramInfo t +} deriving (Eq,Show) -data Array = - Array - Variable -- array typed var - Type -- element type - Int -- length of array +data (SemanticInfo t) => ProgramConstruction t = + EmptyProgram (Empty t) + | PrimitiveProgram (Primitive t) + | SequenceProgram (Sequence t) + | BranchProgram (Branch t) + | SequentialLoopProgram (SequentialLoop t) + | ParallelLoopProgram (ParallelLoop t) 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 +data (SemanticInfo t) => Empty t = Empty { + emptySemInf :: EmptyInfo t +} deriving (Eq,Show) -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) ++ ")" +data (SemanticInfo t) => Primitive t = Primitive { + primitiveInstruction :: Instruction t, + primitiveSemInf :: PrimitiveInfo t +} deriving (Eq,Show) -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) ++ "}" +data (SemanticInfo t) => Sequence t = Sequence { + sequenceProgramList :: [Program t], + sequenceSemInf :: SequenceInfo t +} deriving (Eq,Show) -toCArray:: Constant -> String -toCArray (ArrayConst ln elements) = listprint toCArray "," elements -toCArray i = toC 0 i +data (SemanticInfo t) => Branch t = Branch { + branchData :: BranchData t, + branchSemInf :: BranchInfo t +} deriving (Eq,Show) -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) ++ ")" +data (SemanticInfo t) => BranchData t = BranchData { + branchConditionVariable :: Variable t, -- ??? + thenBlock :: Block t, + elseBlock :: Block t +} deriving (Eq, Show) -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 +data (SemanticInfo t) => SequentialLoop t = SequentialLoop { + sequentialLoopData :: SequentialLoopData t, + sequentialLoopSemInf :: SequentialLoopInfo t +} deriving (Eq,Show) -arrayDepths :: Type -> String -arrayDepths (ImpArrayType (Just n) t) = "["++(show n)++"]" ++ arrayDepths t -arrayDepths (ImpArrayType Nothing t) = "[16]" ++ arrayDepths t -arrayDepths _ = "" +data (SemanticInfo t) => SequentialLoopData t = SequentialLoopData { + sequentialLoopCondition :: Expression t, + conditionCalculation :: Block t, -- ??? + sequentialLoopCore :: Block t +} deriving (Eq, Show) -instance ToC CompleteProgram where - toC sc (CompPrg locals body) = (foldl (++) "" (map (\x-> (toC sc x)) locals)) ++ "\n" ++ (toC sc body) +data (SemanticInfo t) => ParallelLoop t = ParallelLoop { + parallelLoopData :: ParallelLoopData t, + parallelLoopSemInf :: ParallelLoopInfo t +} deriving (Eq,Show) -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 +data (SemanticInfo t) => ParallelLoopData t = ParallelLoopData { + parallelLoopConditionVariable :: Variable t, + numberOfIterations :: Expression t, -- ??? + parallelLoopStep :: Int, -- ??? + parallelLoopCore :: Block t +} deriving (Eq, Show) -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" +-- ========================= [ FormalParameter ] ============================= -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 +data (SemanticInfo t) => FormalParameter t = FormalParameter { + formalParameterVariable :: Variable t, + formalParameterSemInf :: FormalParameterInfo t +} deriving (Eq,Show) -instance (ToC a) => ToC [a] where - toC sc xs = concatMap (toC sc) xs +-- ========================= [ LocalDeclaration ] ============================ -instance ToC Array where - toC sc (Array v t i) = (toC sc v) +data (SemanticInfo t) => LocalDeclaration t = LocalDeclaration { + localDeclarationData :: LocalDeclarationData t, + localDeclarationSemInf :: LocalDeclarationInfo t +} deriving (Eq,Show) ----------------------- --- Helper functions -- ----------------------- +data (SemanticInfo t) => LocalDeclarationData t = LocalDeclarationData { + localVariable :: Variable t, + localInitValue :: Maybe (Expression t) +} deriving (Eq,Show) -simpleType :: Type -> Bool -simpleType BoolType = True -simpleType FloatType = True -simpleType (Numeric _ _) = True -simpleType (ImpArrayType _ _) = False -simpleType (Feldspar.Compiler.Imperative.Representation.Pointer _) = False +-- ========================= [ Expression ] ================================== -toCPrimType:: Type -> String -toCPrimType (ImpArrayType _ t) = toCPrimType t -toCPrimType t = toC 0 t +data (SemanticInfo t) => Expression t = + LeftValueExpression (LeftValueInExpression t) + | ConstantExpression (Constant t) + | FunctionCallExpression (FunctionCall t) + deriving (Eq, Show) -isArrayType:: Type -> String -isArrayType (ImpArrayType _ t) = "* const" -isArrayType _ = "" +data (SemanticInfo t) => LeftValueInExpression t = LeftValueInExpression { + leftValueExpressionContents :: LeftValue t, + leftValueExpressionSemInf :: LeftValueExpressionInfo t +} deriving (Eq, Show) -tab sc = replicate (sc * 4) ' ' +data (SemanticInfo t) => FunctionCall t = FunctionCall { + functionCallData :: FunctionCallData t, + functionCallSemInf :: FunctionCallInfo t +} deriving (Eq, Show) -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) +data (SemanticInfo t) => FunctionCallData t = FunctionCallData { + roleOfFunctionToCall :: FunctionRole, + typeOfFunctionToCall :: Type, + nameOfFunctionToCall :: String, + actualParametersOfFunctionToCall :: [Expression t] +} deriving (Eq,Show) -toLeftValue :: ImpLangExpr -> LeftValue -toLeftValue (Expr (LeftExpr lv) _) = lv -toLeftValue e = error $ "Error: " ++ toC 0 e ++ " is not a left value." +-- ========================= [ LeftValue ] =================================== -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 +data (SemanticInfo t) => LeftValue t = + VariableLeftValue (VariableInLeftValue t) + | ArrayElemReferenceLeftValue (ArrayElemReference t) + deriving (Eq,Show) -getVariable :: ImpLangExpr -> Maybe Variable -getVariable (Expr (LeftExpr (LVar v)) _) = Just v -getVariable _ = Nothing +data (SemanticInfo t) => VariableInLeftValue t = VariableInLeftValue { + variableLeftValueContents :: Variable t, + variableLeftValueSemInf :: VariableInLeftValueInfo t +} deriving (Eq,Show) -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 +data (SemanticInfo t) => ArrayElemReference t = ArrayElemReference { + arrayElemReferenceData :: ArrayElemReferenceData t, + arrayElemReferenceSemInf :: ArrayElemReferenceInfo t +} deriving (Eq,Show) -getVarName :: LeftValue -> String -getVarName (LVar (Var n _ _)) = n -getVarName (ArrayElem lv _) = getVarName lv -getVarName (PointedVal lv) = getVarName lv +data (SemanticInfo t) => ArrayElemReferenceData t = ArrayElemReferenceData { + arrayName :: LeftValue t, + arrayIndex :: Expression t +} deriving (Eq,Show) -getLeftValue :: ImpLangExpr -> LeftValue -getLeftValue (Expr (LeftExpr lv) t) = lv -getLeftValue e = error $ "Error in Compiler.Imperative.Representation.getLeftValue:\n" ++ toC 0 e +-- ========================= [ Instruction ] ================================= -{- -isInParam :: Parameter -> Bool -isInParam (In _) = True -isInParam _ = False --} +data (SemanticInfo t) => Instruction t = + AssignmentInstruction (Assignment t) + | ProcedureCallInstruction (ProcedureCall t) + deriving (Eq,Show) --------------------------------------- --- Semantics of imperative programs -- --------------------------------------- +data (SemanticInfo t) => Assignment t = Assignment { + assignmentData :: AssignmentData t, + assignmentSemInf :: AssignmentInfo t +} deriving (Eq,Show) -type VariableMap = Map.Map String SemInfVar +data (SemanticInfo t) => AssignmentData t = AssignmentData { + assignmentLhs :: LeftValue t, + assignmentRhs :: Expression t +} deriving (Eq,Show) -data SemInfPrim - = SemInfPrim - { varMap :: VariableMap - , output :: Bool - } - deriving (Eq,Show) +data (SemanticInfo t) => ProcedureCall t = ProcedureCall { + procedureCallData :: ProcedureCallData t, + procedureCallSemInf :: ProcedureCallInfo t +} deriving (Eq,Show) -data SemInfVar - = SemInfVar - { usedLeft :: LeftUse - , usedRight :: RightUse - } - deriving (Eq) +data (SemanticInfo t) => ProcedureCallData t = ProcedureCallData { + nameOfProcedureToCall :: String, + actualParametersOfProcedureToCall :: [ActualParameter t] +} deriving (Eq,Show) -instance Show SemInfVar where - show sem = show (usedLeft sem) ++ ", " ++ show (usedRight sem) +-- ========================= [ ActualParameter ] ============================= -unknownSemInfVar = SemInfVar UnknownL UnknownR +data (SemanticInfo t) => ActualParameter t = + InputActualParameter (InputActualParameterType t) + | OutputActualParameter (OutputActualParameterType t) + deriving (Eq,Show) -data LeftUse = UnknownL | None | Single (Maybe ImpLangExpr) | MultipleL - deriving (Eq) +data (SemanticInfo t) => InputActualParameterType t = InputActualParameterType { + inputActualParameterExpression :: Expression t, + inputActualParameterSemInf :: InputActualParameterInfo t +} deriving (Eq,Show) -data RightUse = UnknownR | Times Int | MultipleR - deriving (Eq) +data (SemanticInfo t) => OutputActualParameterType t = OutputActualParameterType { + outputActualParameterLeftValue :: LeftValue t, + outputActualParameterSemInf :: OutputActualParameterInfo t +} deriving (Eq,Show) -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 +-- ========================= [ Constant ] ==================================== -leftVars :: VariableMap -> [String] -leftVars sem = Map.keys $ Map.filter isLeft sem where - isLeft :: SemInfVar -> Bool - isLeft sem - | usedLeft sem == None = False - | otherwise = True +data Constant t = IntConstant (IntConstantType t) + | FloatConstant (FloatConstantType t) + | BoolConstant (BoolConstantType t) + | ArrayConstant (ArrayConstantType t) + deriving (Eq,Show) + +data (SemanticInfo t) => IntConstantType t = IntConstantType { + intConstantValue :: Int, + intConstantSemInf :: IntConstantInfo t +} deriving (Eq, Show) -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" +data (SemanticInfo t) => FloatConstantType t = FloatConstantType { + floatConstantValue :: Float, + floatConstantSemInf :: FloatConstantInfo t +} deriving (Eq, Show) -instance Show RightUse where - show r = "used: " ++ case r of - UnknownR -> "no information" - Times i -> show i ++ " times" - MultipleR -> "multiple times" +data (SemanticInfo t) => BoolConstantType t = BoolConstantType { + boolConstantValue :: Bool, + boolConstantSemInf :: BoolConstantInfo t +} deriving (Eq, Show) -type SemInfPrgSeq = [String] -type SemInfBr = [String] -type SemInfParLoop = [String] -type SemInfIf = [String] -type SemInfSeqLoop = [String] -type SemInfSeq = [String] +data (SemanticInfo t) => ArrayConstantType t = ArrayConstantType { + arrayConstantValue :: [Constant t], + arrayConstantSemInf :: ArrayConstantInfo t +} deriving (Eq, Show) --------------------------------------------------------- --- Computing statistics of variables in an expression -- --- on the right and left hand sides of an assignement -- --------------------------------------------------------- +-- ========================= [ Variable ] ==================================== -class RightVarMap a where - rightVarMap :: a -> VariableMap +data (SemanticInfo t) => Variable t = Variable { + variableData :: VariableData, + variableSemInf :: VariableInfo t +} deriving (Eq,Show) -instance RightVarMap ImpLangExpr where - rightVarMap e = rightVarMap $ exprCore e +data VariableData = VariableData { + variableRole :: VariableRole, + variableType :: Type, + variableName :: String +} deriving (Eq,Show) -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 +-- ========================= [ Basic structures ] ============================ -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 +data Length = Norm Int | Defined Int | Undefined + deriving (Eq,Show) -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 +data Size = S8 | S16 | S32 | S64 + deriving (Eq,Show) -addVarMap :: VariableMap -> VariableMap -> VariableMap -addVarMap m1 m2 = Map.unionWith addSemInfVar m1 m2 where +data Signedness = ImpSigned | ImpUnsigned + deriving (Eq,Show) -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 +data Type = BoolType | FloatType | Numeric Signedness Size | ImpArrayType Length Type + deriving (Eq,Show) + +data FunctionRole = SimpleFun | InfixOp | PrefixOp + deriving (Eq,Show) +data VariableRole = Value {- input of main & local -} | FunOut {- output of main -} + deriving (Eq,Show) diff --git a/Feldspar/Compiler/Imperative/Semantics.hs b/Feldspar/Compiler/Imperative/Semantics.hs new file mode 100644 --- /dev/null +++ b/Feldspar/Compiler/Imperative/Semantics.hs @@ -0,0 +1,163 @@ +{-# LANGUAGE TypeFamilies, EmptyDataDecls, FlexibleContexts #-} +module Feldspar.Compiler.Imperative.Semantics where + +-- =========================================================================== +-- == Semantic info class +-- =========================================================================== + +class (Show (ProcedureInfo t), + Show (BlockInfo t), + Show (ProgramInfo t), + Show (EmptyInfo t), Show (PrimitiveInfo t), Show (SequenceInfo t), Show (BranchInfo t), Show (SequentialLoopInfo t), Show (ParallelLoopInfo t), + Show (FormalParameterInfo t), + Show (LocalDeclarationInfo t), + Show (FunctionCallInfo t), + Show (LeftValueExpressionInfo t), + Show (VariableInLeftValueInfo t), + Show (ArrayElemReferenceInfo t), + Show (InputActualParameterInfo t), Show (OutputActualParameterInfo t), + Show (AssignmentInfo t), + Show (ProcedureCallInfo t), + Show (IntConstantInfo t), Show (FloatConstantInfo t), Show (BoolConstantInfo t), Show (ArrayConstantInfo t), + Show (VariableInfo t), + Eq (ProcedureInfo t), + Eq (BlockInfo t), + Eq (ProgramInfo t), + Eq (EmptyInfo t), Eq (PrimitiveInfo t), Eq (SequenceInfo t), Eq (BranchInfo t), Eq (SequentialLoopInfo t), Eq (ParallelLoopInfo t), + Eq (FormalParameterInfo t), + Eq (LocalDeclarationInfo t), + Eq (FunctionCallInfo t), + Eq (LeftValueExpressionInfo t), + Eq (VariableInLeftValueInfo t), + Eq (ArrayElemReferenceInfo t), + Eq (InputActualParameterInfo t), Eq (OutputActualParameterInfo t), + Eq (AssignmentInfo t), + Eq (ProcedureCallInfo t), + Eq (IntConstantInfo t), Eq (FloatConstantInfo t), Eq (BoolConstantInfo t), Eq (ArrayConstantInfo t), + Eq (VariableInfo t)) + => SemanticInfo t where + type ProcedureInfo t + type BlockInfo t + type ProgramInfo t + type EmptyInfo t + type PrimitiveInfo t + type SequenceInfo t + type BranchInfo t + type SequentialLoopInfo t + type ParallelLoopInfo t + type FormalParameterInfo t + type LocalDeclarationInfo t + type LeftValueExpressionInfo t + type VariableInLeftValueInfo t + type ArrayElemReferenceInfo t + type InputActualParameterInfo t + type OutputActualParameterInfo t + type AssignmentInfo t + type ProcedureCallInfo t + type FunctionCallInfo t + type IntConstantInfo t + type FloatConstantInfo t + type BoolConstantInfo t + type ArrayConstantInfo t + type VariableInfo t + +-- =========================================================================== +-- == Unit semantic info instance +-- =========================================================================== + +instance SemanticInfo () where + type ProcedureInfo () = () + type BlockInfo () = () + type ProgramInfo () = () + type EmptyInfo () = () + type PrimitiveInfo () = () + type SequenceInfo () = () + type BranchInfo () = () + type SequentialLoopInfo () = () + type ParallelLoopInfo () = () + type FormalParameterInfo () = () + type LocalDeclarationInfo () = () + type LeftValueExpressionInfo () = () + type VariableInLeftValueInfo () = () + type ArrayElemReferenceInfo () = () + type InputActualParameterInfo () = () + type OutputActualParameterInfo () = () + type AssignmentInfo () = () + type ProcedureCallInfo () = () + type FunctionCallInfo () = () + type IntConstantInfo () = () + type FloatConstantInfo () = () + type BoolConstantInfo () = () + type ArrayConstantInfo () = () + type VariableInfo () = () + +-- =========================================================================== +-- == Basic semantic info instance +-- =========================================================================== + +data InitSemInf + +instance SemanticInfo InitSemInf where + type ProcedureInfo InitSemInf = () + type BlockInfo InitSemInf = () + type ProgramInfo InitSemInf = () + type EmptyInfo InitSemInf = () + type PrimitiveInfo InitSemInf = Bool + type SequenceInfo InitSemInf = () + type BranchInfo InitSemInf = () + type SequentialLoopInfo InitSemInf = () + type ParallelLoopInfo InitSemInf = () + type FormalParameterInfo InitSemInf = () + type LocalDeclarationInfo InitSemInf = () + type LeftValueExpressionInfo InitSemInf = () + type VariableInLeftValueInfo InitSemInf = () + type ArrayElemReferenceInfo InitSemInf = () + type InputActualParameterInfo InitSemInf = () + type OutputActualParameterInfo InitSemInf = () + type AssignmentInfo InitSemInf = () + type ProcedureCallInfo InitSemInf = () + type FunctionCallInfo InitSemInf = () + type IntConstantInfo InitSemInf = () + type FloatConstantInfo InitSemInf = () + type BoolConstantInfo InitSemInf = () + type ArrayConstantInfo InitSemInf = () + type VariableInfo InitSemInf = () + +-- =========================================================================== +-- == PrettyPrint semantic info instance +-- =========================================================================== + + +data IsRestrict = Restrict | NoRestrict + deriving (Show,Eq) + +data IsDefaultArraySize = DefaultArraySize | NoDefaultArraySize + deriving (Show,Eq) + +data PrettyPrintSemanticInfo + +instance SemanticInfo PrettyPrintSemanticInfo where + type ProcedureInfo PrettyPrintSemanticInfo = () + type BlockInfo PrettyPrintSemanticInfo = () + type ProgramInfo PrettyPrintSemanticInfo = () + type EmptyInfo PrettyPrintSemanticInfo = () + type PrimitiveInfo PrettyPrintSemanticInfo = () + type SequenceInfo PrettyPrintSemanticInfo = () + type BranchInfo PrettyPrintSemanticInfo = () + type SequentialLoopInfo PrettyPrintSemanticInfo = () + type ParallelLoopInfo PrettyPrintSemanticInfo = () + type FormalParameterInfo PrettyPrintSemanticInfo = IsRestrict + type LocalDeclarationInfo PrettyPrintSemanticInfo = () + type LeftValueExpressionInfo PrettyPrintSemanticInfo = () + type VariableInLeftValueInfo PrettyPrintSemanticInfo = () + type ArrayElemReferenceInfo PrettyPrintSemanticInfo = () + type InputActualParameterInfo PrettyPrintSemanticInfo = () + type OutputActualParameterInfo PrettyPrintSemanticInfo = () + type AssignmentInfo PrettyPrintSemanticInfo = () + type ProcedureCallInfo PrettyPrintSemanticInfo = () + type FunctionCallInfo PrettyPrintSemanticInfo = () + type IntConstantInfo PrettyPrintSemanticInfo = () + type FloatConstantInfo PrettyPrintSemanticInfo = () + type BoolConstantInfo PrettyPrintSemanticInfo = () + type ArrayConstantInfo PrettyPrintSemanticInfo = () + type VariableInfo PrettyPrintSemanticInfo = () diff --git a/Feldspar/Compiler/Optimization/PrimitiveInstructions.hs b/Feldspar/Compiler/Optimization/PrimitiveInstructions.hs deleted file mode 100644 --- a/Feldspar/Compiler/Optimization/PrimitiveInstructions.hs +++ /dev/null @@ -1,191 +0,0 @@ -{- - - 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 deleted file mode 100644 --- a/Feldspar/Compiler/Optimization/Replace.hs +++ /dev/null @@ -1,173 +0,0 @@ -{- - - 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 deleted file mode 100644 --- a/Feldspar/Compiler/Optimization/Simplification.hs +++ /dev/null @@ -1,390 +0,0 @@ -{- - - 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 deleted file mode 100644 --- a/Feldspar/Compiler/Optimization/Unroll.hs +++ /dev/null @@ -1,132 +0,0 @@ -{- - - 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 --- a/Feldspar/Compiler/Options.hs +++ b/Feldspar/Compiler/Options.hs @@ -1,45 +1,14 @@ -{- - - 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 + { platform :: Platform + , unroll :: UnrollStrategy + , debug :: DebugOption + , defaultArraySize :: Int } -data Platform = AnsiC | TI --- | other platforms will come later... +data Platform = AnsiC | C99 data UnrollStrategy = NoUnroll | Unroll Int data DebugOption = NoDebug | NoSimplification | NoPrimitiveInstructionHandling + deriving Eq diff --git a/Feldspar/Compiler/PluginArchitecture.hs b/Feldspar/Compiler/PluginArchitecture.hs new file mode 100644 --- /dev/null +++ b/Feldspar/Compiler/PluginArchitecture.hs @@ -0,0 +1,776 @@ +{-# LANGUAGE TypeFamilies, FlexibleContexts, Rank2Types #-} + +module Feldspar.Compiler.PluginArchitecture ( + module Feldspar.Compiler.PluginArchitecture, + module Feldspar.Compiler.Imperative.Representation, + module Feldspar.Compiler.Imperative.Semantics, + module Feldspar.Compiler.PluginArchitecture.DefaultConvert +) where + +import Feldspar.Compiler.Imperative.Representation +import Feldspar.Compiler.Imperative.Semantics +import Feldspar.Compiler.PluginArchitecture.DefaultConvert + +-- ================================================================================================================================== +-- == Plugin class +-- ================================================================================================================================== + +type Walker t construction = (TransformationPhase t) => t -> Downwards t -> construction (From t) -> (construction (To t), Upwards t) + +class (TransformationPhase t) => Plugin t where + type ExternalInfo t + executePlugin :: t -> ExternalInfo t -> Procedure (From t) -> Procedure (To t) + +class (SemanticInfo (From t), SemanticInfo (To t) + , ConvertAllInfos (From t) (To t) + , Combine (Upwards t), Default (Upwards t)) => TransformationPhase t where + type From t + type To t + type Downwards t + type Upwards t + + executeTransformationPhase :: Walker t Procedure + executeTransformationPhase = walkProcedure + +-- ================================================================================================================================== +-- == Node Transformers specification +-- ================================================================================================================================== + + downwardsProcedure :: t -> Downwards t -> Procedure (From t) -> Downwards t + transformProcedure :: t -> Downwards t -> Procedure (From t) -> InfosFromProcedureParts t -> Procedure (To t) + upwardsProcedure :: t -> Downwards t -> Procedure (From t) -> InfosFromProcedureParts t -> Procedure (To t) -> Upwards t + + downwardsBlock :: t -> Downwards t -> Block (From t) -> Downwards t + transformBlock :: t -> Downwards t -> Block (From t) -> InfosFromBlockParts t -> Block (To t) + upwardsBlock :: t -> Downwards t -> Block (From t) -> InfosFromBlockParts t -> Block (To t) -> Upwards t + + downwardsProgram :: t -> Downwards t -> Program (From t) -> Downwards t + transformProgram :: t -> Downwards t -> Program (From t) -> InfosFromProgramParts t -> Program (To t) + upwardsProgram :: t -> Downwards t -> Program (From t) -> InfosFromProgramParts t -> Program (To t) -> Upwards t + + transformEmpty :: t -> Downwards t -> Empty (From t) -> ProgramConstruction (To t) + upwardsEmpty :: t -> Downwards t -> Empty (From t) -> ProgramConstruction (To t) -> Upwards t + + downwardsPrimitive :: t -> Downwards t -> Primitive (From t) -> Downwards t + transformPrimitive :: t -> Downwards t -> Primitive (From t) -> InfosFromPrimitiveParts t -> ProgramConstruction (To t) + upwardsPrimitive :: t -> Downwards t -> Primitive (From t) -> InfosFromPrimitiveParts t -> ProgramConstruction (To t) -> Upwards t + + downwardsSequence :: t -> Downwards t -> Sequence (From t) -> Downwards t + transformSequence :: t -> Downwards t -> Sequence (From t) -> InfosFromSequenceParts t -> ProgramConstruction (To t) + upwardsSequence :: t -> Downwards t -> Sequence (From t) -> InfosFromSequenceParts t -> ProgramConstruction (To t) -> Upwards t + + downwardsBranch :: t -> Downwards t -> Branch (From t) -> Downwards t + transformBranch :: t -> Downwards t -> Branch (From t) -> InfosFromBranchParts t -> ProgramConstruction (To t) + upwardsBranch :: t -> Downwards t -> Branch (From t) -> InfosFromBranchParts t -> ProgramConstruction (To t) -> Upwards t + + downwardsSequentialLoop :: t -> Downwards t -> SequentialLoop (From t) -> Downwards t + transformSequentialLoop :: t -> Downwards t -> SequentialLoop (From t) -> InfosFromSequentialLoopParts t -> ProgramConstruction (To t) + upwardsSequentialLoop :: t -> Downwards t -> SequentialLoop (From t) -> InfosFromSequentialLoopParts t -> ProgramConstruction (To t) -> Upwards t + + downwardsParallelLoop :: t -> Downwards t -> ParallelLoop (From t) -> Downwards t + transformParallelLoop :: t -> Downwards t -> ParallelLoop (From t) -> InfosFromParallelLoopParts t -> ProgramConstruction (To t) + upwardsParallelLoop :: t -> Downwards t -> ParallelLoop (From t) -> InfosFromParallelLoopParts t -> ProgramConstruction (To t) -> Upwards t + + downwardsFormalParameter :: t -> Downwards t -> FormalParameter (From t) -> Downwards t + transformFormalParameter :: t -> Downwards t -> FormalParameter (From t) -> InfosFromFormalParameterParts t -> FormalParameter (To t) + upwardsFormalParameter :: t -> Downwards t -> FormalParameter (From t) -> InfosFromFormalParameterParts t -> FormalParameter (To t) -> Upwards t + + downwardsLocalDeclaration :: t -> Downwards t -> LocalDeclaration (From t) -> Downwards t + transformLocalDeclaration :: t -> Downwards t -> LocalDeclaration (From t) -> InfosFromLocalDeclarationParts t -> LocalDeclaration (To t) + upwardsLocalDeclaration :: t -> Downwards t -> LocalDeclaration (From t) -> InfosFromLocalDeclarationParts t -> LocalDeclaration (To t) -> Upwards t + + downwardsAssignment :: t -> Downwards t -> Assignment (From t) -> Downwards t + transformAssignment :: t -> Downwards t -> Assignment (From t) -> InfosFromAssignmentParts t -> Instruction (To t) + upwardsAssignment :: t -> Downwards t -> Assignment (From t) -> InfosFromAssignmentParts t -> Instruction (To t) -> Upwards t + + downwardsProcedureCall :: t -> Downwards t -> ProcedureCall (From t) -> Downwards t + transformProcedureCall :: t -> Downwards t -> ProcedureCall (From t) -> InfosFromProcedureCallParts t -> Instruction (To t) + upwardsProcedureCall :: t -> Downwards t -> ProcedureCall (From t) -> InfosFromProcedureCallParts t -> Instruction (To t) -> Upwards t + + downwardsInputActualParameter :: t -> Downwards t -> InputActualParameterType (From t) -> Downwards t + transformInputActualParameter :: t -> Downwards t -> InputActualParameterType (From t) -> InfosFromInputActualParameterParts t -> ActualParameter (To t) + upwardsInputActualParameter :: t -> Downwards t -> InputActualParameterType (From t) -> InfosFromInputActualParameterParts t -> ActualParameter (To t) -> Upwards t + + downwardsOutputActualParameter :: t -> Downwards t -> OutputActualParameterType (From t) -> Downwards t + transformOutputActualParameter :: t -> Downwards t -> OutputActualParameterType (From t) -> InfosFromOutputActualParameterParts t -> ActualParameter (To t) + upwardsOutputActualParameter :: t -> Downwards t -> OutputActualParameterType (From t) -> InfosFromOutputActualParameterParts t -> ActualParameter (To t) -> Upwards t + + downwardsVariableInLeftValue :: t -> Downwards t -> VariableInLeftValue (From t) -> Downwards t + transformVariableInLeftValue :: t -> Downwards t -> VariableInLeftValue (From t) -> InfosFromVariableLeftValueParts t -> LeftValue (To t) + upwardsVariableInLeftValue :: t -> Downwards t -> VariableInLeftValue (From t) -> InfosFromVariableLeftValueParts t -> LeftValue (To t) -> Upwards t + + downwardsArrayElemReference :: t -> Downwards t -> ArrayElemReference (From t) -> Downwards t + transformArrayElemReference :: t -> Downwards t -> ArrayElemReference (From t) -> InfosFromArrayElemReferenceParts t -> LeftValue (To t) + upwardsArrayElemReference :: t -> Downwards t -> ArrayElemReference (From t) -> InfosFromArrayElemReferenceParts t -> LeftValue (To t) -> Upwards t + + downwardsLeftValueExpression :: t -> Downwards t -> LeftValueInExpression (From t) -> Downwards t + transformLeftValueExpression :: t -> Downwards t -> LeftValueInExpression (From t) -> InfosFromLeftValueExpressionParts t -> Expression (To t) + upwardsLeftValueExpression :: t -> Downwards t -> LeftValueInExpression (From t) -> InfosFromLeftValueExpressionParts t -> Expression (To t) -> Upwards t + + downwardsFunctionCall :: t -> Downwards t -> FunctionCall (From t) -> Downwards t + transformFunctionCall :: t -> Downwards t -> FunctionCall (From t) -> InfosFromFunctionCallParts t -> Expression (To t) + upwardsFunctionCall :: t -> Downwards t -> FunctionCall (From t) -> InfosFromFunctionCallParts t -> Expression (To t) -> Upwards t + + transformIntConstant :: t -> Downwards t -> IntConstantType (From t) -> Constant (To t) + upwardsIntConstant :: t -> Downwards t -> IntConstantType (From t) -> Constant (To t) -> Upwards t + + transformFloatConstant :: t -> Downwards t -> FloatConstantType (From t) -> Constant (To t) + upwardsFloatConstant :: t -> Downwards t -> FloatConstantType (From t) -> Constant (To t) -> Upwards t + + transformBoolConstant :: t -> Downwards t -> BoolConstantType (From t) -> Constant (To t) + upwardsBoolConstant :: t -> Downwards t -> BoolConstantType (From t) -> Constant (To t) -> Upwards t + + downwardsArrayConstant :: t -> Downwards t -> ArrayConstantType (From t) -> Downwards t + transformArrayConstant :: t -> Downwards t -> ArrayConstantType (From t) -> InfosFromArrayConstantParts t -> Constant (To t) + upwardsArrayConstant :: t -> Downwards t -> ArrayConstantType (From t) -> InfosFromArrayConstantParts t -> Constant (To t) -> Upwards t + + transformVariable :: t -> Downwards t -> Variable (From t) -> Variable (To t) + upwardsVariable :: t -> Downwards t -> Variable (From t) -> Variable (To t) -> Upwards t + +-- ================================================================================================================================== +-- == Node Transformer defaults +-- ================================================================================================================================== + + downwardsProcedure self = const + transformProcedure self fromAbove originalProcedure fromBelow = originalProcedure { + inParameters = recursivelyTransformedInParameters fromBelow, + outParameters = recursivelyTransformedOutParameters fromBelow, + procedureBody = recursivelyTransformedProcedureBody fromBelow, + procedureSemInf = convert $ procedureSemInf originalProcedure + } + upwardsProcedure self fromAbove originalProcedure fromBelow transformedProcedure = foldl combine (upwardsInfoFromProcedureBody fromBelow) + ((upwardsInfoFromInParameters fromBelow)++(upwardsInfoFromOutParameters fromBelow)) + + downwardsBlock self = const + transformBlock self fromAbove originalBlock fromBelow = Block { + blockData = recursivelyTransformedBlockData fromBelow, + blockSemInf = convert $ blockSemInf originalBlock + } + upwardsBlock self fromAbove originalBlock fromBelow transformedBlock = foldl combine + (upwardsInfoFromBlockInstructions fromBelow) (upwardsInfoFromBlockDeclarations fromBelow) + + downwardsProgram self = const + transformProgram self fromAbove originalProgram fromBelow = Program { + programConstruction = recursivelyTransformedProgramConstruction fromBelow, + programSemInf = convert $ programSemInf originalProgram + } + upwardsProgram self fromAbove originalProgram fromBelow transformedProgram = upwardsInfoFromProgramConstruction fromBelow + + transformEmpty self fromAbove originalEmpty = EmptyProgram $ Empty { + emptySemInf = convert $ emptySemInf originalEmpty + } + upwardsEmpty self fromAbove originalEmpty transformedEmpty = defaultValue + + downwardsPrimitive self = const + transformPrimitive self fromAbove originalPrimitive fromBelow = PrimitiveProgram $ Primitive { + primitiveInstruction = recursivelyTransformedPrimitiveInstruction fromBelow, + primitiveSemInf = convert $ primitiveSemInf originalPrimitive + } + upwardsPrimitive self fromAbove originalPrimitive fromBelow transformedPrimitive = upwardsInfoFromPrimitiveInstruction fromBelow + + downwardsSequence self = const + transformSequence self fromAbove originalSequence fromBelow = SequenceProgram $ Sequence { + sequenceProgramList = recursivelyTransformedSequenceProgramList fromBelow, + sequenceSemInf = convert $ sequenceSemInf originalSequence + } + upwardsSequence self fromAbove originalSequence fromBelow transformedSequence = case ul of + [] -> defaultValue + otherwise -> foldl combine (head ul) (tail ul) + where ul = upwardsInfoFromSequenceProgramList fromBelow + + downwardsBranch self = const + transformBranch self fromAbove originalBranch fromBelow = BranchProgram $ Branch { + branchData = recursivelyTransformedBranchData fromBelow, + branchSemInf = convert $ branchSemInf originalBranch + } + upwardsBranch self fromAbove originalBranch fromBelow transformedBranch = + foldl combine (upwardsInfoFromBranchConditionVariable fromBelow) [upwardsInfoFromThenBlock fromBelow, upwardsInfoFromElseBlock fromBelow] + + downwardsSequentialLoop self = const + transformSequentialLoop self fromAbove originalSequentialLoop fromBelow = SequentialLoopProgram $ SequentialLoop { + sequentialLoopData = recursivelyTransformedSequentialLoopData fromBelow, + sequentialLoopSemInf = convert $ sequentialLoopSemInf originalSequentialLoop + } + upwardsSequentialLoop self fromAbove originalSequentialLoop fromBelow transformedSequentialLoop = + foldl combine (upwardsInfoFromSequentialLoopConditionVariable fromBelow) + [upwardsInfoFromSequentialLoopConditionCalculation fromBelow, upwardsInfoFromSequentialLoopCore fromBelow] + + downwardsParallelLoop self = const + transformParallelLoop self fromAbove originalParallelLoop fromBelow = ParallelLoopProgram $ ParallelLoop { + parallelLoopData = recursivelyTransformedParallelLoopData fromBelow, + parallelLoopSemInf = convert $ parallelLoopSemInf originalParallelLoop + } + upwardsParallelLoop self fromAbove originalParallelLoop fromBelow transformedParallelLoop = + foldl combine (upwardsInfoFromParallelLoopConditionVariable fromBelow) + [upwardsInfoFromNumberOfIterations fromBelow, upwardsInfoFromParallelLoopCore fromBelow] + + downwardsFormalParameter self = const + transformFormalParameter self fromAbove originalFormalParameter fromBelow = FormalParameter { + formalParameterVariable = recursivelyTransformedFormalParameterVariable fromBelow, + formalParameterSemInf = convert $ formalParameterSemInf originalFormalParameter + } + upwardsFormalParameter self fromAbove originalFormalParameter fromBelow transformedFormalParameter = + upwardsInfoFromFormalParameterVariable fromBelow + + downwardsLocalDeclaration self = const + transformLocalDeclaration self fromAbove originalLocalDeclaration fromBelow = LocalDeclaration { + localDeclarationData = recursivelyTransformedLocalDeclarationData fromBelow, + localDeclarationSemInf = convert $ localDeclarationSemInf originalLocalDeclaration + } + upwardsLocalDeclaration self fromAbove originalLocalDeclaration fromBelow transformedLocalDeclaration = + case (upwardsInfoFromLocalInitValue fromBelow) of + Nothing -> (upwardsInfoFromLocalVariable fromBelow) + Just justUpFromLocalInitValue -> combine (upwardsInfoFromLocalVariable fromBelow) justUpFromLocalInitValue + + downwardsAssignment self = const + transformAssignment self fromAbove originalAssignment fromBelow = AssignmentInstruction $ Assignment { + assignmentData = recursivelyTransformedAssignmentData fromBelow, + assignmentSemInf = convert $ assignmentSemInf originalAssignment + } + upwardsAssignment self fromAbove originalAssignment fromBelow transformedAssignment = + combine (upwardsInfoFromAssignmentLhs fromBelow) (upwardsInfoFromAssignmentRhs fromBelow) + + downwardsProcedureCall self = const + transformProcedureCall self fromAbove originalProcedureCall fromBelow = ProcedureCallInstruction $ ProcedureCall { + procedureCallData = recursivelyTransformedProcedureCallData fromBelow, + procedureCallSemInf = convert $ procedureCallSemInf originalProcedureCall + } + upwardsProcedureCall self fromAbove originalProcedureCall fromBelow transformedProcedureCall = + case ul of + [] -> defaultValue + otherwise -> foldl combine (head ul) (tail ul) + where + ul = upwardsInfoFromActualParametersOfProcedureToCall fromBelow + + downwardsInputActualParameter self = const + transformInputActualParameter self fromAbove originalInputActualParameter fromBelow = InputActualParameter $ InputActualParameterType { + inputActualParameterExpression = recursivelyTransformedInputActualParameterExpression fromBelow, + inputActualParameterSemInf = convert $ inputActualParameterSemInf originalInputActualParameter + } + upwardsInputActualParameter self fromAbove originalInputActualParameter fromBelow transformedInputActualParameter = + upwardsInfoFromInputActualParameter fromBelow + + downwardsOutputActualParameter self = const + transformOutputActualParameter self fromAbove originalOutputActualParameter fromBelow = OutputActualParameter $ OutputActualParameterType { + outputActualParameterLeftValue = recursivelyTransformedOutputActualParameterLeftValue fromBelow, + outputActualParameterSemInf = convert $ outputActualParameterSemInf originalOutputActualParameter + } + upwardsOutputActualParameter self fromAbove originalOutputActualParameter fromBelow transformedOutputActualParameter = + upwardsInfoFromOutputActualParameterLeftValue fromBelow + + downwardsVariableInLeftValue self = const + transformVariableInLeftValue self fromAbove originalVariableInLeftValue fromBelow = VariableLeftValue $ VariableInLeftValue { + variableLeftValueContents = recursivelyTransformedVariableLeftValueContents fromBelow, + variableLeftValueSemInf = convert $ variableLeftValueSemInf originalVariableInLeftValue + } + upwardsVariableInLeftValue self fromAbove originalVariableInLeftValue fromBelow transformedVariableInLeftValue = + upwardsInfoFromVariableLeftValueContents fromBelow + + downwardsArrayElemReference self = const + transformArrayElemReference self fromAbove originalArrayElemReference fromBelow = ArrayElemReferenceLeftValue $ ArrayElemReference { + arrayElemReferenceData = recursivelyTransformedArrayElemReferenceData fromBelow, + arrayElemReferenceSemInf = convert $ arrayElemReferenceSemInf originalArrayElemReference + } + upwardsArrayElemReference self fromAbove originalArrayElemReference fromBelow transformedArrayElemReference = + combine (upwardsInfoFromArrayName fromBelow) (upwardsInfoFromArrayIndex fromBelow) + + downwardsLeftValueExpression self = const + transformLeftValueExpression self fromAbove originalLeftValueExpression fromBelow = LeftValueExpression $ LeftValueInExpression { + leftValueExpressionContents = recursivelyTransformedLeftValueExpressionContents fromBelow, + leftValueExpressionSemInf = convert $ leftValueExpressionSemInf originalLeftValueExpression + } + upwardsLeftValueExpression self fromAbove originalLeftValueExpression fromBelow transformedLeftValueExpression = + upwardsInfoFromLeftValueExpressionContents fromBelow + + downwardsFunctionCall self = const + transformFunctionCall self fromAbove originalFunctionCall fromBelow = FunctionCallExpression $ FunctionCall { + functionCallData = recursivelyTransformedFunctionCallData fromBelow, + functionCallSemInf = convert $ functionCallSemInf originalFunctionCall + } + upwardsFunctionCall self fromAbove originalFunctionCall fromBelow transformedFunctionCall = case ul of + [] -> defaultValue + otherwise -> foldl combine (head ul) (tail ul) + where ul = upwardsInfoFromActualParametersOfFunctionToCall fromBelow + + transformIntConstant self fromAbove originalIntConstant = IntConstant originalIntConstant { + intConstantSemInf = convert $ intConstantSemInf originalIntConstant + } + upwardsIntConstant self fromAbove originalIntConstant transformedIntConstant = defaultValue + + transformFloatConstant self fromAbove originalFloatConstant = FloatConstant originalFloatConstant { + floatConstantSemInf = convert $ floatConstantSemInf originalFloatConstant + } + upwardsFloatConstant self fromAbove originalFloatConstant transformedFloatConstant = defaultValue + + transformBoolConstant self fromAbove originalBoolConstant = BoolConstant originalBoolConstant { + boolConstantSemInf = convert $ boolConstantSemInf originalBoolConstant + } + upwardsBoolConstant self fromAbove originalBoolConstant transformedBoolConstant = defaultValue + + downwardsArrayConstant self = const + transformArrayConstant self fromAbove originalArrayConstant fromBelow = ArrayConstant $ ArrayConstantType { + arrayConstantValue = recursivelyTransformedArrayConstantValue fromBelow, + arrayConstantSemInf = convert $ arrayConstantSemInf originalArrayConstant + } + upwardsArrayConstant self fromAbove originalArrayConstant fromBelow transformedArrayConstant = case ul of + [] -> defaultValue + otherwise -> foldl combine (head ul) (tail ul) + where ul = upwardsInfoFromConstantList fromBelow + + transformVariable self fromAbove originalVariable = originalVariable { + variableSemInf = convert $ variableSemInf originalVariable + } + upwardsVariable self fromAbove originalVariable transformedVariable = defaultValue + +-- ================================================================================================================================== +-- == Walker defaults +-- ================================================================================================================================== + + walkProcedure :: Walker t Procedure + walkProcedure selfpointer fromAbove construction = (transformedProcedure, toAbove) + where + toBelow = downwardsProcedure selfpointer fromAbove construction + transformedInParameters = map (walkFormalParameter selfpointer toBelow) $ inParameters construction + transformedOutParameters = map (walkFormalParameter selfpointer toBelow) $ outParameters construction + transformedProcedureBody = (walkBlock selfpointer toBelow) $ procedureBody construction + fromBelow = InfosFromProcedureParts { + recursivelyTransformedInParameters = map fst transformedInParameters, + upwardsInfoFromInParameters = map snd transformedInParameters, + recursivelyTransformedOutParameters = map fst transformedOutParameters, + upwardsInfoFromOutParameters = map snd transformedOutParameters, + recursivelyTransformedProcedureBody = fst transformedProcedureBody, + upwardsInfoFromProcedureBody = snd transformedProcedureBody + } + transformedProcedure = transformProcedure selfpointer fromAbove construction fromBelow + toAbove = upwardsProcedure selfpointer fromAbove construction fromBelow transformedProcedure + + walkFormalParameter :: Walker t FormalParameter + walkFormalParameter selfpointer fromAbove p = (transformedFormalParameter, toAbove) + where + toBelow = downwardsFormalParameter selfpointer fromAbove p + transformedVariable = walkVariable selfpointer toBelow (formalParameterVariable p) + fromBelow = InfosFromFormalParameterParts { + recursivelyTransformedFormalParameterVariable = fst transformedVariable, + upwardsInfoFromFormalParameterVariable = snd transformedVariable + } + transformedFormalParameter = transformFormalParameter selfpointer fromAbove p fromBelow + toAbove = upwardsFormalParameter selfpointer fromAbove p fromBelow transformedFormalParameter + + walkBlock :: Walker t Block + walkBlock selfpointer fromAbove block = (transformedBlock, toAbove) + where + toBelow = downwardsBlock selfpointer fromAbove block + transformedLocalDeclarations = map (walkLocalDeclaration selfpointer toBelow) $ blockDeclarations $ blockData block + transformedProgram = walkProgram selfpointer toBelow $ blockInstructions $ blockData block + fromBelow = InfosFromBlockParts { + recursivelyTransformedBlockData = BlockData { + blockDeclarations = map fst transformedLocalDeclarations, + blockInstructions = fst transformedProgram + }, + upwardsInfoFromBlockDeclarations = map snd transformedLocalDeclarations, + upwardsInfoFromBlockInstructions = snd transformedProgram + } + transformedBlock = transformBlock selfpointer fromAbove block fromBelow + toAbove = upwardsBlock selfpointer fromAbove block fromBelow transformedBlock + + walkProgram :: Walker t Program + walkProgram selfpointer fromAbove program = (transformedProgram, toAbove) + where + toBelow = downwardsProgram selfpointer fromAbove program + transformedProgramConstruction = case programConstruction program of + EmptyProgram empty -> walkEmpty selfpointer toBelow empty + PrimitiveProgram primitive -> walkPrimitive selfpointer toBelow primitive + SequenceProgram sequence -> walkSequence selfpointer toBelow sequence + BranchProgram branch -> walkBranch selfpointer toBelow branch + SequentialLoopProgram sequentialLoop -> walkSequentialLoop selfpointer toBelow sequentialLoop + ParallelLoopProgram parallelLoop -> walkParallelLoop selfpointer toBelow parallelLoop + fromBelow = InfosFromProgramParts { + recursivelyTransformedProgramConstruction = fst transformedProgramConstruction, + upwardsInfoFromProgramConstruction = snd transformedProgramConstruction + } + transformedProgram = transformProgram selfpointer fromAbove program fromBelow + toAbove = upwardsProgram selfpointer fromAbove program fromBelow transformedProgram + + walkEmpty :: (TransformationPhase t) => t -> Downwards t -> Empty (From t) -> (ProgramConstruction (To t), Upwards t) + walkEmpty selfpointer fromAbove empty = (transformedEmpty, toAbove) + where + transformedEmpty = transformEmpty selfpointer fromAbove empty + toAbove = upwardsEmpty selfpointer fromAbove empty transformedEmpty + + walkPrimitive :: (TransformationPhase t) => t -> Downwards t -> Primitive (From t) -> (ProgramConstruction (To t), Upwards t) + walkPrimitive selfpointer fromAbove primitive = (transformedPrimitive, toAbove) + where + toBelow = downwardsPrimitive selfpointer fromAbove primitive + transformedPrimitiveInstruction = + walkInstruction selfpointer toBelow (primitiveInstruction primitive) + fromBelow = InfosFromPrimitiveParts { + recursivelyTransformedPrimitiveInstruction = fst transformedPrimitiveInstruction, + upwardsInfoFromPrimitiveInstruction = snd transformedPrimitiveInstruction + } + transformedPrimitive = transformPrimitive selfpointer fromAbove primitive fromBelow + toAbove = upwardsPrimitive selfpointer fromAbove primitive fromBelow transformedPrimitive + + walkSequence :: (TransformationPhase t) => t -> Downwards t -> Sequence (From t) -> (ProgramConstruction (To t), Upwards t) + walkSequence selfpointer fromAbove sequence = (transformedSequence, toAbove) + where + toBelow = downwardsSequence selfpointer fromAbove sequence + transformedProgramList = + map (walkProgram selfpointer toBelow) (sequenceProgramList sequence) + fromBelow = InfosFromSequenceParts { + recursivelyTransformedSequenceProgramList = map fst transformedProgramList, + upwardsInfoFromSequenceProgramList = map snd transformedProgramList + } + transformedSequence = transformSequence selfpointer fromAbove sequence fromBelow + toAbove = upwardsSequence selfpointer fromAbove sequence fromBelow transformedSequence + + walkBranch :: (TransformationPhase t) => t -> Downwards t -> Branch (From t) -> (ProgramConstruction (To t), Upwards t) + walkBranch selfpointer fromAbove branch = (transformedBranch, toAbove) + where + toBelow = downwardsBranch selfpointer fromAbove branch + transformedBranchConditionVariable = walkVariable selfpointer toBelow (branchConditionVariable $ branchData branch) + transformedThenBlock = walkBlock selfpointer toBelow (thenBlock $ branchData branch) + transformedElseBlock = walkBlock selfpointer toBelow (elseBlock $ branchData branch) + fromBelow = InfosFromBranchParts { + recursivelyTransformedBranchData = BranchData { + branchConditionVariable = fst transformedBranchConditionVariable, + thenBlock = fst transformedThenBlock, + elseBlock = fst transformedElseBlock + }, + upwardsInfoFromBranchConditionVariable = snd transformedBranchConditionVariable, + upwardsInfoFromThenBlock = snd transformedThenBlock, + upwardsInfoFromElseBlock = snd transformedElseBlock + } + transformedBranch = transformBranch selfpointer fromAbove branch fromBelow + toAbove = upwardsBranch selfpointer fromAbove branch fromBelow transformedBranch + + walkSequentialLoop :: (TransformationPhase t) => t -> Downwards t -> SequentialLoop (From t) -> (ProgramConstruction (To t), Upwards t) + walkSequentialLoop selfpointer fromAbove loop = (transformedSequentialLoop, toAbove) + where + toBelow = downwardsSequentialLoop selfpointer fromAbove loop + transformedLoopConditionVariable = + walkExpression selfpointer toBelow (sequentialLoopCondition $ sequentialLoopData loop) + transformedConditionCalculation = + walkBlock selfpointer toBelow (conditionCalculation $ sequentialLoopData loop) + transformedSequentialLoopCore = + walkBlock selfpointer toBelow (sequentialLoopCore $ sequentialLoopData loop) + fromBelow = InfosFromSequentialLoopParts { + recursivelyTransformedSequentialLoopData = SequentialLoopData { + sequentialLoopCondition = fst transformedLoopConditionVariable, + conditionCalculation = fst transformedConditionCalculation, + sequentialLoopCore = fst transformedSequentialLoopCore + }, + upwardsInfoFromSequentialLoopConditionVariable = snd transformedLoopConditionVariable, + upwardsInfoFromSequentialLoopConditionCalculation = snd transformedConditionCalculation, + upwardsInfoFromSequentialLoopCore = snd transformedSequentialLoopCore + } + transformedSequentialLoop = transformSequentialLoop selfpointer fromAbove loop fromBelow + toAbove = upwardsSequentialLoop selfpointer fromAbove loop fromBelow transformedSequentialLoop + + walkParallelLoop :: (TransformationPhase t) => t -> Downwards t -> ParallelLoop (From t) -> (ProgramConstruction (To t), Upwards t) + walkParallelLoop selfpointer fromAbove loop = (transformedParallelLoop, toAbove) + where + toBelow = downwardsParallelLoop selfpointer fromAbove loop + transformedParallelLoopConditionVariable = + walkVariable selfpointer toBelow (parallelLoopConditionVariable $ parallelLoopData loop) + transformedNumberOfIterations = + walkExpression selfpointer toBelow (numberOfIterations $ parallelLoopData loop) + transformedParallelLoopCore = + walkBlock selfpointer toBelow (parallelLoopCore $ parallelLoopData loop) + fromBelow = InfosFromParallelLoopParts { + recursivelyTransformedParallelLoopData = ParallelLoopData { + parallelLoopConditionVariable = fst transformedParallelLoopConditionVariable, + numberOfIterations = fst transformedNumberOfIterations, + parallelLoopStep = parallelLoopStep $ parallelLoopData loop, + parallelLoopCore = fst transformedParallelLoopCore + }, + upwardsInfoFromParallelLoopConditionVariable = snd transformedParallelLoopConditionVariable, + upwardsInfoFromNumberOfIterations = snd transformedNumberOfIterations, + upwardsInfoFromParallelLoopCore = snd transformedParallelLoopCore + } + transformedParallelLoop = transformParallelLoop selfpointer fromAbove loop fromBelow + toAbove = upwardsParallelLoop selfpointer fromAbove loop fromBelow transformedParallelLoop + + walkLocalDeclaration :: Walker t LocalDeclaration + walkLocalDeclaration selfpointer fromAbove local = (transformedLocalDeclaration, toAbove) + where + toBelow = downwardsLocalDeclaration selfpointer fromAbove local + transformedLocalVariable = walkVariable selfpointer toBelow (localVariable $ localDeclarationData local) + transformedLocalInitValue = case localInitValue $ localDeclarationData local of + Nothing -> (Nothing, Nothing) + Just localInitExpression -> (Just (fst transformedLocalInitExpression), Just (snd transformedLocalInitExpression)) + where transformedLocalInitExpression = walkExpression selfpointer toBelow localInitExpression + fromBelow = InfosFromLocalDeclarationParts { + recursivelyTransformedLocalDeclarationData = LocalDeclarationData { + localVariable = fst transformedLocalVariable, + localInitValue = fst transformedLocalInitValue + }, + upwardsInfoFromLocalVariable = snd transformedLocalVariable, + upwardsInfoFromLocalInitValue = snd transformedLocalInitValue + } + transformedLocalDeclaration = transformLocalDeclaration selfpointer fromAbove local fromBelow + toAbove = upwardsLocalDeclaration selfpointer fromAbove local fromBelow transformedLocalDeclaration + + walkExpression :: Walker t Expression + walkExpression selfpointer fromAbove expression = case expression of + LeftValueExpression leftValueExpression -> (transformedLeftValueExpression, toAbove) + where + toBelow = downwardsLeftValueExpression selfpointer fromAbove leftValueExpression + transformedLeftValueExpressionContents = walkLeftValue selfpointer + toBelow (leftValueExpressionContents leftValueExpression) + fromBelow = InfosFromLeftValueExpressionParts { + recursivelyTransformedLeftValueExpressionContents = fst transformedLeftValueExpressionContents, + upwardsInfoFromLeftValueExpressionContents = snd transformedLeftValueExpressionContents + } + transformedLeftValueExpression = transformLeftValueExpression selfpointer fromAbove leftValueExpression fromBelow + toAbove = upwardsLeftValueExpression selfpointer fromAbove leftValueExpression fromBelow transformedLeftValueExpression + ConstantExpression constant -> ((ConstantExpression $ fst transformedConstant), snd transformedConstant) + where + toBelow = fromAbove -- calculations are done in WalkConstant, used only in the ArrayConstant branch + transformedConstant = walkConstant selfpointer toBelow constant + FunctionCallExpression functionCall -> (transformedFunctionCallExpression, toAbove) + where + toBelow = downwardsFunctionCall selfpointer fromAbove functionCall + transformedActualParametersOfFunctionToCall = map + (walkExpression selfpointer toBelow) + (actualParametersOfFunctionToCall $ functionCallData functionCall) + fromBelow = InfosFromFunctionCallParts { + recursivelyTransformedFunctionCallData = (functionCallData functionCall) { + actualParametersOfFunctionToCall = map fst transformedActualParametersOfFunctionToCall + }, + upwardsInfoFromActualParametersOfFunctionToCall = map snd transformedActualParametersOfFunctionToCall + } + transformedFunctionCallExpression = transformFunctionCall selfpointer fromAbove functionCall fromBelow + toAbove = upwardsFunctionCall selfpointer fromAbove functionCall fromBelow transformedFunctionCallExpression + + walkConstant :: Walker t Constant + walkConstant selfpointer fromAbove constant = case constant of + IntConstant intConstant -> (transformedIntConstant, toAbove) + where + transformedIntConstant = transformIntConstant selfpointer fromAbove intConstant + toAbove = upwardsIntConstant selfpointer fromAbove intConstant transformedIntConstant + FloatConstant floatConstant -> (transformedFloatConstant, toAbove) + where + transformedFloatConstant = transformFloatConstant selfpointer fromAbove floatConstant + toAbove = upwardsFloatConstant selfpointer fromAbove floatConstant transformedFloatConstant + BoolConstant boolConstant -> (transformedBoolConstant, toAbove) + where + transformedBoolConstant = transformBoolConstant selfpointer fromAbove boolConstant + toAbove = upwardsBoolConstant selfpointer fromAbove boolConstant transformedBoolConstant + ArrayConstant arrayConstant -> (transformedArrayConstant, toAbove) + where + toBelow = downwardsArrayConstant selfpointer fromAbove arrayConstant + transformedConstantList = map (walkConstant selfpointer toBelow) (arrayConstantValue arrayConstant) + fromBelow = InfosFromArrayConstantParts { + recursivelyTransformedArrayConstantValue = map fst transformedConstantList, + upwardsInfoFromConstantList = map snd transformedConstantList + } + transformedArrayConstant = transformArrayConstant selfpointer fromAbove arrayConstant fromBelow + toAbove = upwardsArrayConstant selfpointer fromAbove arrayConstant fromBelow transformedArrayConstant + + walkLeftValue :: Walker t LeftValue + walkLeftValue selfpointer fromAbove leftValue = case leftValue of + VariableLeftValue lvt -> (transformedVariableLeftValue, toAbove) + where + toBelow = downwardsVariableInLeftValue selfpointer fromAbove lvt + transformedVariableLeftValueContents = + walkVariable selfpointer toBelow (variableLeftValueContents lvt) + fromBelow = InfosFromVariableLeftValueParts { + recursivelyTransformedVariableLeftValueContents = fst transformedVariableLeftValueContents, + upwardsInfoFromVariableLeftValueContents = snd transformedVariableLeftValueContents + } + transformedVariableLeftValue = transformVariableInLeftValue selfpointer fromAbove lvt fromBelow + toAbove = upwardsVariableInLeftValue selfpointer fromAbove lvt fromBelow transformedVariableLeftValue + ArrayElemReferenceLeftValue arrayElemReference -> (transformedArrayElemReference, toAbove) + where + toBelow = downwardsArrayElemReference selfpointer fromAbove arrayElemReference + transformedArrayName = + walkLeftValue selfpointer toBelow (arrayName $ arrayElemReferenceData arrayElemReference) + transformedArrayIndex = + walkExpression selfpointer toBelow (arrayIndex $ arrayElemReferenceData arrayElemReference) + fromBelow = InfosFromArrayElemReferenceParts { + recursivelyTransformedArrayElemReferenceData = ArrayElemReferenceData { + arrayName = fst transformedArrayName, + arrayIndex = fst transformedArrayIndex + }, + upwardsInfoFromArrayName = snd transformedArrayName, + upwardsInfoFromArrayIndex = snd transformedArrayIndex + } + transformedArrayElemReference = transformArrayElemReference selfpointer fromAbove arrayElemReference fromBelow + toAbove = upwardsArrayElemReference selfpointer fromAbove arrayElemReference fromBelow transformedArrayElemReference + + walkActualParameter :: Walker t ActualParameter + walkActualParameter selfpointer fromAbove actualParameter = case actualParameter of + InputActualParameter input -> (transformedInputActualParameter, toAbove) + where + toBelow = downwardsInputActualParameter selfpointer fromAbove input + transformedInputActualParameterExpression = + walkExpression selfpointer toBelow (inputActualParameterExpression input) + fromBelow = InfosFromInputActualParameterParts { + recursivelyTransformedInputActualParameterExpression = fst transformedInputActualParameterExpression, + upwardsInfoFromInputActualParameter = snd transformedInputActualParameterExpression + } + transformedInputActualParameter = transformInputActualParameter selfpointer fromAbove input fromBelow + toAbove = upwardsInputActualParameter selfpointer fromAbove input fromBelow transformedInputActualParameter + OutputActualParameter output -> (transformedOutputActualParameter, toAbove) + where + toBelow = downwardsOutputActualParameter selfpointer fromAbove output + transformedOutputActualParameterLeftValue = + walkLeftValue selfpointer toBelow (outputActualParameterLeftValue output) + fromBelow = InfosFromOutputActualParameterParts { + recursivelyTransformedOutputActualParameterLeftValue = fst transformedOutputActualParameterLeftValue, + upwardsInfoFromOutputActualParameterLeftValue = snd transformedOutputActualParameterLeftValue + } + transformedOutputActualParameter = transformOutputActualParameter selfpointer fromAbove output fromBelow + toAbove = upwardsOutputActualParameter selfpointer fromAbove output fromBelow transformedOutputActualParameter + + + walkInstruction :: Walker t Instruction + walkInstruction selfpointer fromAbove instruction = case instruction of + AssignmentInstruction assignment -> (transformedAssignment, toAbove) + where + toBelow = downwardsAssignment selfpointer fromAbove assignment + transformedAssignmentLhs = walkLeftValue selfpointer toBelow (assignmentLhs $ assignmentData assignment) + transformedAssignmentRhs = walkExpression selfpointer toBelow (assignmentRhs $ assignmentData assignment) + fromBelow = InfosFromAssignmentParts { + recursivelyTransformedAssignmentData = AssignmentData { + assignmentLhs = fst transformedAssignmentLhs, + assignmentRhs = fst transformedAssignmentRhs + }, + upwardsInfoFromAssignmentLhs = snd transformedAssignmentLhs, + upwardsInfoFromAssignmentRhs = snd transformedAssignmentRhs + } + transformedAssignment = transformAssignment selfpointer fromAbove assignment fromBelow + toAbove = upwardsAssignment selfpointer fromAbove assignment fromBelow transformedAssignment + ProcedureCallInstruction procedureCall -> (transformedProcedureCall, toAbove) + where + toBelow = downwardsProcedureCall selfpointer fromAbove procedureCall + transformedActualParametersOfProcedureToCall = map (walkActualParameter selfpointer toBelow) + (actualParametersOfProcedureToCall $ procedureCallData procedureCall) + fromBelow = InfosFromProcedureCallParts { + recursivelyTransformedProcedureCallData = (procedureCallData procedureCall) { + actualParametersOfProcedureToCall = map fst transformedActualParametersOfProcedureToCall + }, + upwardsInfoFromActualParametersOfProcedureToCall = map snd transformedActualParametersOfProcedureToCall + } + transformedProcedureCall = transformProcedureCall selfpointer fromAbove procedureCall fromBelow + toAbove = upwardsProcedureCall selfpointer fromAbove procedureCall fromBelow transformedProcedureCall + + walkVariable :: Walker t Variable + walkVariable selfpointer fromAbove v = (transformedVariable, toAbove) + where + transformedVariable = transformVariable selfpointer fromAbove v + toAbove = upwardsVariable selfpointer fromAbove v transformedVariable + +-- ================================================================================================================================== +-- == Upwards infos +-- ================================================================================================================================== + +data (TransformationPhase t) => InfosFromProcedureParts t = InfosFromProcedureParts { + recursivelyTransformedInParameters :: [FormalParameter (To t)], + upwardsInfoFromInParameters :: [Upwards t], + recursivelyTransformedOutParameters :: [FormalParameter (To t)], + upwardsInfoFromOutParameters :: [Upwards t], + recursivelyTransformedProcedureBody :: Block (To t), + upwardsInfoFromProcedureBody :: Upwards t +} + +data (TransformationPhase t) => InfosFromBlockParts t = InfosFromBlockParts { + recursivelyTransformedBlockData :: BlockData (To t), + upwardsInfoFromBlockDeclarations :: [Upwards t], + upwardsInfoFromBlockInstructions :: Upwards t +} + +data (TransformationPhase t) => InfosFromProgramParts t = InfosFromProgramParts { + recursivelyTransformedProgramConstruction :: ProgramConstruction (To t), + upwardsInfoFromProgramConstruction :: Upwards t +} + +data (TransformationPhase t) => InfosFromPrimitiveParts t = InfosFromPrimitiveParts { + recursivelyTransformedPrimitiveInstruction :: Instruction (To t), + upwardsInfoFromPrimitiveInstruction :: Upwards t +} + +data (TransformationPhase t) => InfosFromSequenceParts t = InfosFromSequenceParts { + recursivelyTransformedSequenceProgramList :: [Program (To t)], + upwardsInfoFromSequenceProgramList :: [Upwards t] +} + +data (TransformationPhase t) => InfosFromBranchParts t = InfosFromBranchParts { + recursivelyTransformedBranchData :: BranchData (To t), + upwardsInfoFromBranchConditionVariable :: Upwards t, + upwardsInfoFromThenBlock :: Upwards t, + upwardsInfoFromElseBlock :: Upwards t +} + +data (TransformationPhase t) => InfosFromSequentialLoopParts t = InfosFromSequentialLoopParts { + recursivelyTransformedSequentialLoopData :: SequentialLoopData (To t), + upwardsInfoFromSequentialLoopConditionVariable :: Upwards t, + upwardsInfoFromSequentialLoopConditionCalculation :: Upwards t, + upwardsInfoFromSequentialLoopCore :: Upwards t +} + +data (TransformationPhase t) => InfosFromParallelLoopParts t = InfosFromParallelLoopParts { + recursivelyTransformedParallelLoopData :: ParallelLoopData (To t), + upwardsInfoFromParallelLoopConditionVariable :: Upwards t, + upwardsInfoFromNumberOfIterations :: Upwards t, + upwardsInfoFromParallelLoopCore :: Upwards t +} + +data (TransformationPhase t) => InfosFromFormalParameterParts t = InfosFromFormalParameterParts { + recursivelyTransformedFormalParameterVariable :: Variable (To t), + upwardsInfoFromFormalParameterVariable :: Upwards t +} + +data (TransformationPhase t) => InfosFromLocalDeclarationParts t = InfosFromLocalDeclarationParts { + recursivelyTransformedLocalDeclarationData :: LocalDeclarationData (To t), + upwardsInfoFromLocalVariable :: Upwards t, + upwardsInfoFromLocalInitValue :: Maybe (Upwards t) +} + +data (TransformationPhase t) => InfosFromAssignmentParts t = InfosFromAssignmentParts { + recursivelyTransformedAssignmentData :: AssignmentData (To t), + upwardsInfoFromAssignmentLhs :: Upwards t, + upwardsInfoFromAssignmentRhs :: Upwards t +} + +data (TransformationPhase t) => InfosFromProcedureCallParts t = InfosFromProcedureCallParts { + recursivelyTransformedProcedureCallData :: ProcedureCallData (To t), + upwardsInfoFromActualParametersOfProcedureToCall :: [Upwards t] +} + +data (TransformationPhase t) => InfosFromInputActualParameterParts t = InfosFromInputActualParameterParts { + recursivelyTransformedInputActualParameterExpression :: Expression (To t), + upwardsInfoFromInputActualParameter :: Upwards t +} + +data (TransformationPhase t) => InfosFromOutputActualParameterParts t = InfosFromOutputActualParameterParts { + recursivelyTransformedOutputActualParameterLeftValue :: LeftValue (To t), + upwardsInfoFromOutputActualParameterLeftValue :: Upwards t +} + +data (TransformationPhase t) => InfosFromArrayElemReferenceParts t = InfosFromArrayElemReferenceParts { + recursivelyTransformedArrayElemReferenceData :: ArrayElemReferenceData (To t), + upwardsInfoFromArrayName :: Upwards t, + upwardsInfoFromArrayIndex :: Upwards t +} + +data (TransformationPhase t) => InfosFromVariableLeftValueParts t = InfosFromVariableLeftValueParts { + recursivelyTransformedVariableLeftValueContents :: Variable (To t), + upwardsInfoFromVariableLeftValueContents :: Upwards t +} + +data (TransformationPhase t) => InfosFromLeftValueExpressionParts t = InfosFromLeftValueExpressionParts { + recursivelyTransformedLeftValueExpressionContents :: LeftValue (To t), + upwardsInfoFromLeftValueExpressionContents :: Upwards t +} + +data (TransformationPhase t) => InfosFromFunctionCallParts t = InfosFromFunctionCallParts { + recursivelyTransformedFunctionCallData :: FunctionCallData (To t), + upwardsInfoFromActualParametersOfFunctionToCall :: [Upwards t] +} + +data (TransformationPhase t) => InfosFromArrayConstantParts t = InfosFromArrayConstantParts { + recursivelyTransformedArrayConstantValue :: [Constant (To t)], + upwardsInfoFromConstantList :: [Upwards t] +} + diff --git a/Feldspar/Compiler/PluginArchitecture/DefaultConvert.hs b/Feldspar/Compiler/PluginArchitecture/DefaultConvert.hs new file mode 100644 --- /dev/null +++ b/Feldspar/Compiler/PluginArchitecture/DefaultConvert.hs @@ -0,0 +1,93 @@ +{-# LANGUAGE UndecidableInstances, MultiParamTypeClasses, FlexibleContexts, FlexibleInstances #-} + +module Feldspar.Compiler.PluginArchitecture.DefaultConvert where + +import Feldspar.Compiler.Imperative.Semantics +-- =========================================================================== +-- == Defaults +-- =========================================================================== + +class Default t where + defaultValue :: t + defaultValue = error "Default value requested." + +class Combine t where + combine :: t -> t -> t + combine = error "Default combination function used." + +instance Default Int where + defaultValue = 0 +instance Combine Int where + combine = (+) + +instance Default Bool where + defaultValue = False + +instance Default () where + defaultValue = () +instance Combine () where + combine _ _ = () + +instance (Default a, Default b) => Default (a,b) where + defaultValue = (defaultValue, defaultValue) + +class Convert a b where + convert :: a -> b + +{-instance Convert a a where + convert = id-} + +instance Default b => Convert a b where + convert _ = defaultValue + +class (SemanticInfo from, SemanticInfo to + , Convert (ProcedureInfo from) (ProcedureInfo to) + , Convert (BlockInfo from) (BlockInfo to) + , Default (ProgramInfo to) + , Convert (EmptyInfo from) (EmptyInfo to) + , Convert (PrimitiveInfo from) (PrimitiveInfo to) + , Convert (SequenceInfo from) (SequenceInfo to) + , Convert (BranchInfo from) (BranchInfo to) + , Convert (FormalParameterInfo from) (FormalParameterInfo to) + , Convert (SequentialLoopInfo from) (SequentialLoopInfo to) + , Convert (ParallelLoopInfo from) (ParallelLoopInfo to) + , Convert (LocalDeclarationInfo from) (LocalDeclarationInfo to) + , Convert (LeftValueExpressionInfo from) (LeftValueExpressionInfo to) + , Convert (InputActualParameterInfo from) (InputActualParameterInfo to) + , Convert (OutputActualParameterInfo from) (OutputActualParameterInfo to) + , Convert (VariableInLeftValueInfo from) (VariableInLeftValueInfo to) + , Convert (ArrayElemReferenceInfo from) (ArrayElemReferenceInfo to) + , Convert (ProcedureCallInfo from) (ProcedureCallInfo to) + , Convert (AssignmentInfo from) (AssignmentInfo to) + , Convert (FunctionCallInfo from) (FunctionCallInfo to) + , Convert (IntConstantInfo from) (IntConstantInfo to) + , Convert (FloatConstantInfo from) (FloatConstantInfo to) + , Convert (BoolConstantInfo from) (BoolConstantInfo to) + , Convert (ArrayConstantInfo from) (ArrayConstantInfo to) + , Convert (VariableInfo from) (VariableInfo to)) => ConvertAllInfos from to + +instance (SemanticInfo from, SemanticInfo to -- TODO general instance needs UndecidableInstances, check whether it is ok + , Convert (ProcedureInfo from) (ProcedureInfo to) + , Convert (BlockInfo from) (BlockInfo to) + , Default (ProgramInfo to) + , Convert (EmptyInfo from) (EmptyInfo to) + , Convert (PrimitiveInfo from) (PrimitiveInfo to) + , Convert (SequenceInfo from) (SequenceInfo to) + , Convert (BranchInfo from) (BranchInfo to) + , Convert (FormalParameterInfo from) (FormalParameterInfo to) + , Convert (SequentialLoopInfo from) (SequentialLoopInfo to) + , Convert (ParallelLoopInfo from) (ParallelLoopInfo to) + , Convert (LocalDeclarationInfo from) (LocalDeclarationInfo to) + , Convert (LeftValueExpressionInfo from) (LeftValueExpressionInfo to) + , Convert (InputActualParameterInfo from) (InputActualParameterInfo to) + , Convert (OutputActualParameterInfo from) (OutputActualParameterInfo to) + , Convert (VariableInLeftValueInfo from) (VariableInLeftValueInfo to) + , Convert (ArrayElemReferenceInfo from) (ArrayElemReferenceInfo to) + , Convert (ProcedureCallInfo from) (ProcedureCallInfo to) + , Convert (AssignmentInfo from) (AssignmentInfo to) + , Convert (FunctionCallInfo from) (FunctionCallInfo to) + , Convert (IntConstantInfo from) (IntConstantInfo to) + , Convert (FloatConstantInfo from) (FloatConstantInfo to) + , Convert (BoolConstantInfo from) (BoolConstantInfo to) + , Convert (ArrayConstantInfo from) (ArrayConstantInfo to) + , Convert (VariableInfo from) (VariableInfo to)) => ConvertAllInfos from to diff --git a/Feldspar/Compiler/Plugins/BackwardPropagation.hs b/Feldspar/Compiler/Plugins/BackwardPropagation.hs new file mode 100644 --- /dev/null +++ b/Feldspar/Compiler/Plugins/BackwardPropagation.hs @@ -0,0 +1,264 @@ +{-# LANGUAGE EmptyDataDecls, TypeFamilies, FlexibleInstances #-} + +module Feldspar.Compiler.Plugins.BackwardPropagation + where + +import Feldspar.Compiler.PluginArchitecture +import Feldspar.Compiler.Plugins.PropagationUtils +import qualified Data.Map as Map +import qualified Data.List as List +import Data.Maybe +import Feldspar.Compiler.Options + +-- =========================================================================== +-- == Copy propagation plugin (backward) +-- =========================================================================== + +type VarStatBck = VarStatistics () + +data BackwardPropagation = BackwardPropagation + +instance TransformationPhase BackwardPropagation where + type From BackwardPropagation = InitSemInf + type To BackwardPropagation = () + type Downwards BackwardPropagation = () + type Upwards BackwardPropagation = () + +instance Plugin BackwardPropagation where + type ExternalInfo BackwardPropagation = DebugOption + executePlugin BackwardPropagation externalInfo procedure + | externalInfo == NoSimplification = fst $ executeTransformationPhase BackwardPropagation () procedure + | otherwise = fst $ executeTransformationPhase PropagationTransform [] $ fst $ executeTransformationPhase PropagationCollect (Occurrence_read,False) procedure + +-- ==================== +-- Collect +-- ==================== + +instance Default [(VariableData, LeftValue ())] where + defaultValue = [] + +-- meaning (out,var,out written in a sequence before out=var) +instance Default [(VariableData, LeftValue (),Bool)] where + defaultValue = [] + +instance Combine (VarStatBck, [(VariableData, LeftValue (),Bool)]) where + combine (m1,x1) (m2,x2) = (combine m1 m2, x1 ++ x2) + +instance Default (Maybe (VariableData, LeftValue (),Bool)) where + defaultValue = Nothing + +data PropagationSemInf + +instance SemanticInfo PropagationSemInf where + type ProcedureInfo PropagationSemInf = () + type BlockInfo PropagationSemInf = [(VariableData, LeftValue ())] --replacements inside block + type ProgramInfo PropagationSemInf = () + type EmptyInfo PropagationSemInf = () + type PrimitiveInfo PropagationSemInf = Maybe (VariableData, LeftValue (), Bool) --if the primitive is a copy assignment the datas of the assigment, just because when we delete primitives at 2nd phase we need this + type SequenceInfo PropagationSemInf = () + type BranchInfo PropagationSemInf = () + type SequentialLoopInfo PropagationSemInf = () + type ParallelLoopInfo PropagationSemInf = () + type FormalParameterInfo PropagationSemInf = () + type LocalDeclarationInfo PropagationSemInf = () + type LeftValueExpressionInfo PropagationSemInf = () + type VariableInLeftValueInfo PropagationSemInf = () + type ArrayElemReferenceInfo PropagationSemInf = () + type InputActualParameterInfo PropagationSemInf = () + type OutputActualParameterInfo PropagationSemInf = () + type AssignmentInfo PropagationSemInf = () + type ProcedureCallInfo PropagationSemInf = () + type FunctionCallInfo PropagationSemInf = () + type IntConstantInfo PropagationSemInf = () + type FloatConstantInfo PropagationSemInf = () + type BoolConstantInfo PropagationSemInf = () + type ArrayConstantInfo PropagationSemInf = () + type VariableInfo PropagationSemInf = () + +data PropagationCollect = PropagationCollect + +instance TransformationPhase PropagationCollect where + type From PropagationCollect = InitSemInf + type To PropagationCollect = PropagationSemInf + type Downwards PropagationCollect = (Occurrence_place, Bool) + type Upwards PropagationCollect = (VarStatBck, [(VariableData, LeftValue (),Bool)]) + downwardsBranch self d orig = (occurrenceDownwards orig, False) + downwardsSequentialLoop self d orig = (occurrenceDownwards orig, False) + downwardsParallelLoop self d orig = (occurrenceDownwards orig, False) + downwardsFormalParameter self d orig = (occurrenceDownwards orig, False) + downwardsLocalDeclaration self d orig = (occurrenceDownwards orig, isJust $ localInitValue $ localDeclarationData orig) + downwardsAssignment self d orig = (occurrenceDownwards orig, False) + downwardsInputActualParameter self d orig = (occurrenceDownwards orig, False) + downwardsOutputActualParameter self d orig = (occurrenceDownwards orig, False) + downwardsLeftValueExpression self d orig = (occurrenceDownwards orig, False) + downwardsFunctionCall self d orig = (occurrenceDownwards orig, False) + upwardsVariable self (d,me) origVar newVar = case d of + Occurrence_declare + | me -> (Map.singleton (variableData origVar) $ Occurrences (One Nothing) Zero, []) + | otherwise -> (Map.singleton (variableData origVar) $ Occurrences Zero Zero, []) + Occurrence_read -> (Map.singleton (variableData origVar) $ Occurrences Zero (One ()), []) + Occurrence_write -> (Map.singleton (variableData origVar) $ Occurrences (One Nothing) Zero, []) + Occurrence_notopt -> (Map.singleton (variableData origVar) $ Occurrences Multiple Multiple, []) + upwardsPrimitive self d origPrimitive u newPrimitive = case newPrimitive of + PrimitiveProgram newPr -> case primitiveSemInf newPr of + Just e -> (fst $ upwardsInfoFromPrimitiveInstruction u, [e]) + Nothing -> upwardsInfoFromPrimitiveInstruction u + _ -> upwardsInfoFromPrimitiveInstruction u + upwardsBlock self d origBlock u newBlock = (deleteFromVarStatistics (map (fst) $ blockSemInf newBlock) $ fst $ upwardsInfoFromBlockInstructions u,[]) + upwardsSequence self d origiSeq u transformedSequence = checkInSequence $ upwardsInfoFromSequenceProgramList u + transformBlock self d origBlock u = Block { + blockData = recursivelyTransformedBlockData u, + blockSemInf = unChain $ checkInDeclatation origBlock $ upwardsInfoFromBlockInstructions u + } + transformPrimitive self d origPrimitive u = PrimitiveProgram $ Primitive { + primitiveInstruction = recursivelyTransformedPrimitiveInstruction u, + primitiveSemInf = getNames origPrimitive + } + +getNames :: (SemanticInfo t) => Primitive t -> Maybe (VariableData, LeftValue (),Bool) +getNames pr = getNames' $ primitiveInstruction pr where + getNames' (AssignmentInstruction _) = Nothing + getNames' (ProcedureCallInstruction pc) + | goodName pc = getParamNames $ actualParametersOfProcedureToCall $ procedureCallData pc + | otherwise = Nothing + goodName pc = "copy" == (nameOfProcedureToCall $ procedureCallData pc) + getParamNames [InputActualParameter i, OutputActualParameter o] = pairJust (getIName i) (getOName o) + getParamNames _ = Nothing + pairJust (Just a) (Just b) = Just (a,b,False) + pairJust _ _ = Nothing + getIName i = getExpName $ inputActualParameterExpression i + getOName o = Just $ deleteSemInf $ outputActualParameterLeftValue o + getExpName (LeftValueExpression le) = getLvName_noarr $ leftValueExpressionContents le + getExpName _ = Nothing + getLvName_noarr (VariableLeftValue vlv) = Just $ variableData $ variableLeftValueContents vlv + getLvName_noarr _ = Nothing + +getLvName :: (SemanticInfo t) => LeftValue t -> VariableData +getLvName (VariableLeftValue vlv) = variableData $ variableLeftValueContents vlv +getLvName (ArrayElemReferenceLeftValue aer) = getLvName $ arrayName $ arrayElemReferenceData aer + +checkInSequence :: [(VarStatBck, [(VariableData, LeftValue (), Bool)])] -> (VarStatBck, [(VariableData, LeftValue (), Bool)]) +checkInSequence [] = defaultValue +checkInSequence xs = (varstat $ map fst xs, mapMaybe (checkSeq xs False False False) $ foldl (\ls (vs,s) -> s++ls) [] xs) + where + varstat :: [VarStatBck] -> VarStatBck + varstat = foldl combine defaultValue + checkSeq :: [(VarStatBck, [(VariableData, LeftValue (), Bool)])] -> Bool{-usedVar-} -> Bool{-usedOut-} -> Bool{-after-} -> (VariableData {-var-}, LeftValue () {-out-}, Bool) -> Maybe (VariableData, LeftValue (), Bool) + checkSeq [] _ usedOut _ (var,outD,outUsedLower) = Just (var,outD,usedOut) + checkSeq ((vs,s):ys) usedVar usedOut after sp@(var,outD,outUsedLower) + | after && (vs `notUse` var) = checkSeq ys usedVar usedOut after sp + | after {- && (vs `hasUse` var) -} = Nothing + | {-(not after) && -} (sp `List.elem` s) && ((not outUsedLower) || (not usedVar)) = checkSeq ys usedVar usedOut True sp + | {-(not after) && -} usedVar && (vs `notUse` out) = checkSeq ys usedVar usedOut after sp + | {-(not after) && -} usedVar {- && (vs `hasUse` out)-} = Nothing + | {-(not after) && (not usedVar) && -} (vs `hasRead` var) && (vs `notUse` out) = checkSeq ys True usedOut after sp + | {-(not after) && (not usedVar) && -} (vs `hasRead` var) {- && (vs `hasUse` out) -} = Nothing + | {-(not after) && (not usedVar) && -} (vs `hasWrite` var) && (vs `hasWrite` out) = Nothing + | {-(not after) && (not usedVar) && -} (vs `hasWrite` var) {- && (vs `notWrite` out)-} = checkSeq ys True usedOut after sp + | {-(not after) && (not usedVar) && (vs `notUse` var) && -} (vs `hasUse` out) = checkSeq ys usedVar True after sp + | {-(not after) && (not usedVar) && (vs `notUse` var) && (vs `notUse` out)-} otherwise = checkSeq ys usedVar usedOut after sp + where + --var = variableName varD + out = getLvName outD +{- +check the sequence format: +______________ +| use out | +| ___________| +|__|= | +| use var | +|_____________| +out = var +______________ +| not use var | +|_____________| + +| +-} + +checkInDeclatation :: Block InitSemInf -> (VarStatBck, [(VariableData, LeftValue (), Bool)]) -> [(VariableData, LeftValue ())] +checkInDeclatation origBlock u = mapMaybe (checkDecl $ decl) (snd u) where + decl = blockDeclarations $ blockData origBlock + checkDecl :: [LocalDeclaration InitSemInf] -> (VariableData, LeftValue (), Bool) -> Maybe (VariableData, LeftValue ()) + checkDecl lds (var,outD,outUsedLower) = case List.find (\ld -> var == declaredVar ld) lds of + Nothing -> Nothing + Just ld -> case localInitValue $ localDeclarationData ld of + Nothing -> Just (var,outD) + Just exp -> case outUsedLower of + True -> Nothing + False -> Just (var,outD) +{- +check var get initValue, because it is a write, and it means we can't use out because "out=var" +-} + +-- ==================== +-- BackwardPropagation +-- ==================== + +data PropagationTransform = PropagationTransform + +instance TransformationPhase PropagationTransform where + type From PropagationTransform = PropagationSemInf + type To PropagationTransform = () + type Downwards PropagationTransform = [(VariableData, LeftValue ())] + type Upwards PropagationTransform = () + downwardsBlock self d origBlock = foldl addChain (blockSemInf origBlock) d + downwardsLocalDeclaration self d origLocDecl = [] + transformBlock self d orig fromBelow = delUnusedDecl (map fst $ foldl addChain (blockSemInf orig) d) orig $ recursivelyTransformedBlockData fromBelow + transformPrimitive self d origPrimitive u = + case primitiveSemInf origPrimitive of + Nothing -> makedPrim + Just (var,outD,_) + | List.elem (var,outD) d || ((List.elem (getLvName outD) $ map fst d) && (List.elem var $ map fst d) ) -> EmptyProgram $ Empty () + | otherwise -> makedPrim + where + makedPrim = PrimitiveProgram $ Primitive { + primitiveInstruction = recursivelyTransformedPrimitiveInstruction u, + primitiveSemInf =() + } + transformVariableInLeftValue self d origVIL u = case List.find (\(a,b) -> a == newVar) d of + Nothing -> VariableLeftValue $ VariableInLeftValue { + variableLeftValueContents = recursivelyTransformedVariableLeftValueContents u, + variableLeftValueSemInf = () + } + Just (var,out) -> out + where + newVar = variableData $ recursivelyTransformedVariableLeftValueContents u + +unChain :: [(VariableData, LeftValue ())] -> [(VariableData, LeftValue ())] +unChain s = foldl addChain [] s + +addChain :: [(VariableData, LeftValue ())] -> (VariableData, LeftValue ()) -> [(VariableData, LeftValue ())] +addChain [] pair = [pair] +addChain (x@(mibe1,mit1):xs) r@(mibe2,mit2) + | (getLvName mit1) == mibe2 = (mibe1,changeInnerArrayName mit1 mit2):r:xs + | (getLvName mit2) == mibe1 = (mibe2,changeInnerArrayName mit2 mit1):x:xs + | otherwise = x:(addChain xs r) + where + changeInnerArrayName :: LeftValue () {-toChange-} -> LeftValue () {-newName-} -> LeftValue () + changeInnerArrayName toChange (ArrayElemReferenceLeftValue aer) = ArrayElemReferenceLeftValue aer { + arrayElemReferenceData = (arrayElemReferenceData aer) { + arrayName = changeInnerArrayName toChange (arrayName $ arrayElemReferenceData aer) + } + } + changeInnerArrayName (ArrayElemReferenceLeftValue aer) newName@(VariableLeftValue _) = ArrayElemReferenceLeftValue aer { + arrayElemReferenceData = (arrayElemReferenceData aer) { + arrayName = changeInnerArrayName (arrayName $ arrayElemReferenceData aer) newName + } + } + changeInnerArrayName (VariableLeftValue _) newName@(VariableLeftValue _) = newName + +{- +addChain [ (a, b) ] (b, c) = [ (a, b), (a, c) ] +addChain [ (a, b) ] (b[i],c) = [ (a, b), (a[i], c) ] +addChain [ (a[m],b) ] (b[i],c) = [ (a[m],b), (a[m][i], c) ] +addChain [ (b, c) ] (a, b) = [ (a, b), (a, c) ] +addChain [ (b, c) ] (a[i],b) = [ (a, b), (a[i], c) ] +addChain [ (b[i],c) ] (a[m],b) = [ (a[m],b), (a[m][i], c) ] + +but arrayof(arrayof(lv,index1)index2) = lv[index2][index1] +so first go down in newNames indexes and put these outwards +then go down toChanges indexes, and when no indexes change + +-} + diff --git a/Feldspar/Compiler/Plugins/ConstantFolding.hs b/Feldspar/Compiler/Plugins/ConstantFolding.hs new file mode 100644 --- /dev/null +++ b/Feldspar/Compiler/Plugins/ConstantFolding.hs @@ -0,0 +1,40 @@ +{-# LANGUAGE TypeFamilies #-} + +module Feldspar.Compiler.Plugins.ConstantFolding where + +import Feldspar.Compiler.PluginArchitecture + +data ConstantFolding = ConstantFolding + +instance Plugin ConstantFolding where + type ExternalInfo ConstantFolding = () + executePlugin ConstantFolding _ procedure = + fst $ executeTransformationPhase ConstantFolding () procedure + +instance TransformationPhase ConstantFolding where + type From ConstantFolding = () + type To ConstantFolding = () + type Downwards ConstantFolding = () + type Upwards ConstantFolding = () + + transformFunctionCall ConstantFolding _ _ (InfosFromFunctionCallParts funData _) = + case roleOfFunctionToCall $ funData of + InfixOp -> case nameOfFunctionToCall $ funData of + "+" -> elimParamIf (isConstIntN 0) True funCall + "-" -> elimParamIf (isConstIntN 0) False funCall + "*" -> elimParamIf (isConstIntN 1) True funCall + _ -> FunctionCallExpression funCall + _ -> FunctionCallExpression funCall + + where + funCall = FunctionCall (funData) () + + isConstIntN n (ConstantExpression (IntConstant (IntConstantType i _))) = n == i + isConstIntN _ _ = False + + elimParamIf pred flippable funCall@(FunctionCall (FunctionCallData InfixOp _ _ (x:xs)) _) + | pred (head xs) = x + | flippable && pred x = head xs + | otherwise = FunctionCallExpression funCall + elimParamIf _ _ funCall = FunctionCallExpression funCall + diff --git a/Feldspar/Compiler/Plugins/ForwardPropagation.hs b/Feldspar/Compiler/Plugins/ForwardPropagation.hs new file mode 100644 --- /dev/null +++ b/Feldspar/Compiler/Plugins/ForwardPropagation.hs @@ -0,0 +1,311 @@ +{-# LANGUAGE EmptyDataDecls, TypeFamilies, FlexibleInstances #-} + +module Feldspar.Compiler.Plugins.ForwardPropagation where + +import Feldspar.Compiler.PluginArchitecture +import qualified Data.Map as Map +import qualified Data.Set as Set +import qualified Data.List as List +import Feldspar.Compiler.Plugins.PropagationUtils +import Feldspar.Compiler.Error +import Feldspar.Compiler.Options +import Feldspar.Compiler.Imperative.CodeGeneration (simpleType) + +fwdPropError = handleError "PluginArch/ForwardPropagation" InternalError + +-- =========================================================================== +-- == Copy propagation plugin (forward) +-- =========================================================================== + +type VarStatFwd = VarStatistics (Expression ForwardPropagationpSemInf,[VariableData],Bool) +type OccurrencesFwd = Occurrences (Expression ForwardPropagationpSemInf,[VariableData],Bool) + +data ForwardPropagation = ForwardPropagation + +instance Plugin ForwardPropagation where + type ExternalInfo ForwardPropagation = DebugOption + executePlugin ForwardPropagation externalInfo procedure + | externalInfo == NoSimplification || externalInfo == NoPrimitiveInstructionHandling = procedure + | otherwise = fst $ executeTransformationPhase ForwardPropagationTransform (fst globals1) procedureCollected1 + where + (procedureCollected1,globals1) = executeTransformationPhase ForwardPropagationCollect Occurrence_read procedure + +instance TransformationPhase ForwardPropagation where + type From ForwardPropagation = () + type To ForwardPropagation = () + type Downwards ForwardPropagation = () + type Upwards ForwardPropagation = () + +-- ==================== +-- Collect +-- ==================== + +data ForwardPropagationpSemInf + +instance SemanticInfo ForwardPropagationpSemInf where + type ProcedureInfo ForwardPropagationpSemInf = () + type BlockInfo ForwardPropagationpSemInf = VarStatFwd + type ProgramInfo ForwardPropagationpSemInf = () + type EmptyInfo ForwardPropagationpSemInf = () + type PrimitiveInfo ForwardPropagationpSemInf = () + type SequenceInfo ForwardPropagationpSemInf = () + type BranchInfo ForwardPropagationpSemInf = () + type SequentialLoopInfo ForwardPropagationpSemInf = VarStatFwd + type ParallelLoopInfo ForwardPropagationpSemInf = () + type FormalParameterInfo ForwardPropagationpSemInf = () + type LocalDeclarationInfo ForwardPropagationpSemInf = () + type LeftValueExpressionInfo ForwardPropagationpSemInf = () + type VariableInLeftValueInfo ForwardPropagationpSemInf = () + type ArrayElemReferenceInfo ForwardPropagationpSemInf = Maybe VariableData --name of the indexed variable + type InputActualParameterInfo ForwardPropagationpSemInf = () + type OutputActualParameterInfo ForwardPropagationpSemInf = () + type AssignmentInfo ForwardPropagationpSemInf = () + type ProcedureCallInfo ForwardPropagationpSemInf = () + type FunctionCallInfo ForwardPropagationpSemInf = () + type IntConstantInfo ForwardPropagationpSemInf = () + type FloatConstantInfo ForwardPropagationpSemInf = () + type BoolConstantInfo ForwardPropagationpSemInf = () + type ArrayConstantInfo ForwardPropagationpSemInf = () + type VariableInfo ForwardPropagationpSemInf = Occurrence_place + +instance Default (Maybe VariableData) where + defaultValue = Nothing + +instance Combine (VarStatFwd, Maybe VariableData) where + combine a b = (combine (fst a) $ fst b, Nothing) + +data ForwardPropagationCollect = ForwardPropagationCollect + +instance TransformationPhase ForwardPropagationCollect where + type From ForwardPropagationCollect = () + type To ForwardPropagationCollect = ForwardPropagationpSemInf + type Downwards ForwardPropagationCollect = Occurrence_place + type Upwards ForwardPropagationCollect = (VarStatFwd, Maybe VariableData) + downwardsBranch self d orig = occurrenceDownwards orig + downwardsSequentialLoop self d orig = occurrenceDownwards orig + downwardsParallelLoop self d orig = occurrenceDownwards orig + downwardsFormalParameter self d orig = occurrenceDownwards orig + downwardsLocalDeclaration self d orig = occurrenceDownwards orig + downwardsAssignment self d orig = occurrenceDownwards orig + downwardsInputActualParameter self d orig = occurrenceDownwards orig + downwardsOutputActualParameter self d orig = occurrenceDownwards orig + downwardsLeftValueExpression self d orig = occurrenceDownwards orig + downwardsFunctionCall self d orig = occurrenceDownwards orig + transformBlock self d origBlock u = Block { + blockData = recursivelyTransformedBlockData u, + blockSemInf = selectFromVarStatistics ( declaredVars origBlock) belowStatistics + } where + belowStatistics = checkFwdDeclaration (map fst $ upwardsInfoFromBlockDeclarations u) (fst $ upwardsInfoFromBlockInstructions u) + --belowStatistics = foldl combine (fst $ upwardsInfoFromBlockInstructions u) $ map fst $ upwardsInfoFromBlockDeclarations u + transformVariable self d origVar = origVar { + variableSemInf = d + } + upwardsVariable self d origVar newVar = case d of + Occurrence_declare -> (Map.singleton (variableData origVar) $ Occurrences Zero Zero, Just $ variableData origVar) + Occurrence_read -> (Map.singleton (variableData origVar) $ Occurrences Zero (One ()), Just $ variableData origVar) + Occurrence_write -> (Map.singleton (variableData origVar) $ Occurrences (One Nothing) Zero, Just $ variableData origVar) + Occurrence_notopt -> (Map.singleton (variableData origVar) $ Occurrences Multiple Multiple, Just $ variableData origVar) --LIE to save variables + upwardsSequence self d origSeq u transSeq = (checkFwdSequence $ map fst $ upwardsInfoFromSequenceProgramList u, Nothing) + upwardsBlock self d origBlock u newBlock = (deleteFromVarStatistics (declaredVars origBlock) belowStatistics, Nothing) where + belowStatistics = foldl combine (fst $ upwardsInfoFromBlockInstructions u) $ map fst $ upwardsInfoFromBlockDeclarations u + upwardsParallelLoop self d origParLoop u transParLoop = (multipleVarStatistics $ + foldl combine (fst $ upwardsInfoFromParallelLoopConditionVariable u) + [fst $ upwardsInfoFromNumberOfIterations u, fst $ upwardsInfoFromParallelLoopCore u], Nothing) + upwardsAssignment self d origAssign u transAssig = case assignmentLhs $ assignmentData origAssign of + VariableLeftValue vlv -> (Map.insert var occ $ fst $ upwardsInfoFromAssignmentRhs u, Nothing) + where + var = variableData $ variableLeftValueContents vlv + occ = Occurrences (One $ Just (assRs, Map.keys $ fst $ upwardsInfoFromAssignmentRhs u, False)) Zero + assRs = case transAssig of + AssignmentInstruction newAssign -> assignmentRhs $ assignmentData newAssign + _ -> fwdPropError $ "Internal error: ForwardPropagation/1!" + ArrayElemReferenceLeftValue aer -> (combine (fst $ upwardsInfoFromAssignmentLhs u) (fst $ upwardsInfoFromAssignmentRhs u), Nothing) + upwardsLocalDeclaration self d origDecl u newDecl = case localInitValue $ localDeclarationData newDecl of + Nothing -> defaultCase + Just (ConstantExpression (ArrayConstant ac)) -> defaultCase + Just initExp -> case upwardsInfoFromLocalInitValue u of + Nothing -> defaultCase + Just justUpFromLocalInitValue -> (Map.insert var (occ initExp $ fst justUpFromLocalInitValue) $ fst justUpFromLocalInitValue, Nothing) + where + var = variableData $ localVariable $ localDeclarationData $ origDecl + occ initExp justUpFromLocalInitValue = Occurrences (One $ Just (initExp, Map.keys justUpFromLocalInitValue, False)) Zero + defaultCase = (fst $ upwardsInfoFromLocalVariable u, Nothing) + upwardsProcedureCall self d origProcCall u transProcCall + | List.isPrefixOf "copy" $ nameOfProcedureToCall $ procedureCallData origProcCall = case actParams of -- TODO: eliminate string constant + [InputActualParameter inArr, InputActualParameter arrSize, OutputActualParameter outArr] -> + case outputActualParameterLeftValue outArr of + VariableLeftValue vlv -> (Map.insert (var vlv) (occ inArr) $ fst $ head ul, Nothing) + ArrayElemReferenceLeftValue aer -> defaultTr + _ -> defaultTr + | otherwise = defaultTr + where + defaultTr = case ul of + [] -> defaultValue + otherwise -> foldl combine (head ul) (tail ul) + ul = upwardsInfoFromActualParametersOfProcedureToCall u + actParams = case transProcCall of + ProcedureCallInstruction pc -> actualParametersOfProcedureToCall $ procedureCallData pc + _ -> fwdPropError $ "Internal error: ForwardPropagation/2!" + var vlv = variableData $ variableLeftValueContents vlv + occ inArr = Occurrences (One $ Just (inputActualParameterExpression inArr, Map.keys $ fst $ head ul, False)) Zero + transformSequentialLoop self d origSeqLoop u = SequentialLoopProgram $ SequentialLoop { + sequentialLoopData = (recursivelyTransformedSequentialLoopData u) { + conditionCalculation = (conditionCalculation $ recursivelyTransformedSequentialLoopData u) { + blockSemInf = Map.empty + } + }, + sequentialLoopSemInf = blockSemInf $ conditionCalculation $ recursivelyTransformedSequentialLoopData u + } + upwardsSequentialLoop self d origSeqLoop u newSeqLoop = (multipleVarStatistics $ + combine (fst $ upwardsInfoFromSequentialLoopConditionCalculation u) $ fst $ upwardsInfoFromSequentialLoopCore u, Nothing) + transformArrayElemReference self d origArrRef u = ArrayElemReferenceLeftValue $ ArrayElemReference { + arrayElemReferenceData = recursivelyTransformedArrayElemReferenceData u, + arrayElemReferenceSemInf = snd $ upwardsInfoFromArrayName u + } + upwardsArrayElemReference self d origArrayRef u transArrayRefe = + (combine (fst $ upwardsInfoFromArrayName u) (fst $ upwardsInfoFromArrayIndex u), snd $ upwardsInfoFromArrayName u) + +checkFwdSequence :: [VarStatFwd] -> VarStatFwd +checkFwdSequence [] = defaultValue +checkFwdSequence xs = List.foldl checkInSeq Map.empty xs + where + checkInSeq :: VarStatFwd -> VarStatFwd -> VarStatFwd + checkInSeq preSeq curr = combine curr $ Map.mapWithKey (updatePreSeq curr) preSeq + updatePreSeq :: VarStatFwd -> VariableData -> OccurrencesFwd -> OccurrencesFwd + updatePreSeq curr preSeqVar preSeqOcc = case writeVar preSeqOcc of + One (Just (preSeqExp,preSeqVars,preSeqVarsWritten)) + | preSeqVarsWritten && curr `hasRead` preSeqVar -> Occurrences (One Nothing) $ readVar preSeqOcc + | any (hasWrite curr) preSeqVars -> case (curr `hasRead` preSeqVar) && not ((simpleType $ variableType preSeqVar) && readVar preSeqOcc /= Multiple) of + True -> Occurrences (One Nothing) $ readVar preSeqOcc + False -> Occurrences (One (Just (preSeqExp,preSeqVars ++ (addDep curr preSeqVar),True))) $ readVar preSeqOcc + | otherwise -> case curr `getWrite` preSeqVar of + Nothing -> preSeqOcc + Just (exp,vars,varsWritten) + | exp == preSeqExp -> Occurrences Zero $ readVar preSeqOcc + | otherwise -> preSeqOcc + _ -> preSeqOcc + addDep curr preSeqVar = case curr `getWrite` preSeqVar of + Nothing -> [] + Just (exp,vars,varsWritten) -> vars + +checkFwdDeclaration :: [VarStatFwd] -> VarStatFwd -> VarStatFwd +checkFwdDeclaration [] blockStat = blockStat +checkFwdDeclaration declStat blockStat = checkFwdSequence $ declStat ++ [blockStat] + +-- ==================== +-- ForwardPropagation +-- ==================== + +type VarWrite t = [(VariableData,Expression t)] + +toVarWrite :: VarStatFwd -> VarWrite ForwardPropagationpSemInf +toVarWrite vs = Map.foldWithKey (getExp) [] vs where + getExp :: VariableData -> OccurrencesFwd -> VarWrite ForwardPropagationpSemInf -> VarWrite ForwardPropagationpSemInf + getExp name (Occurrences (One (Just (exp,_,_))) reads) vw + | reads /= Multiple && notConstArray exp = (name,exp):vw --used once and complex expr + | simpleExpr exp = (name,exp):vw --used several and simple expr + | otherwise = vw + getExp name _ vw = vw + notConstArray e = case e of + ConstantExpression c -> simplConst c + _ -> True + simpleExpr e = case e of + ConstantExpression c -> simplConst c + LeftValueExpression l -> case leftValueExpressionContents l of + VariableLeftValue v -> True + ArrayElemReferenceLeftValue a -> simpleExpr $ arrayIndex $ arrayElemReferenceData a + _ -> False + simplConst (ArrayConstant ac) = False + simplConst _ = True + +instance Default (Set.Set VariableData) where + defaultValue = Set.empty + +instance Combine (Set.Set VariableData) where + combine = Set.union + +data ForwardPropagationTransform = ForwardPropagationTransform + +instance TransformationPhase ForwardPropagationTransform where + type From ForwardPropagationTransform = ForwardPropagationpSemInf + type To ForwardPropagationTransform = () + type Downwards ForwardPropagationTransform = VarStatFwd + type Upwards ForwardPropagationTransform = Set.Set VariableData + downwardsBlock self d origBlock = combine d $ blockSemInf origBlock + downwardsSequentialLoop self d origSeqLoop = combine d $ sequentialLoopSemInf origSeqLoop + transformLeftValueExpression self d origLVE u = case leftValueExpressionContents origLVE of + VariableLeftValue origVar -> case List.find (\(vn,e) -> (vn == var origVar)) varwrite of + Nothing -> defaultTr + Just repl -> fst $ walkExpression self d (snd repl) + ArrayElemReferenceLeftValue origArr -> defaultTr + where + var v = variableData $ variableLeftValueContents v + varwrite = toVarWrite d + defaultTr = LeftValueExpression $ LeftValueInExpression { + leftValueExpressionContents = recursivelyTransformedLeftValueExpressionContents u, + leftValueExpressionSemInf = () + } + transformVariableInLeftValue self d origVarLV u = case List.find (\(vn,e) -> (vn == var)) varwrite of + Nothing -> defaultTr + Just repl -> case repl of + (_,LeftValueExpression lve) -> fst $ walkLeftValue self d $ leftValueExpressionContents lve + _ -> defaultTr + where + var = variableData $ variableLeftValueContents origVarLV + varwrite = toVarWrite d + defaultTr = VariableLeftValue $ VariableInLeftValue { + variableLeftValueContents = recursivelyTransformedVariableLeftValueContents u, + variableLeftValueSemInf = () + } + transformArrayElemReference self d origArrayRef u = case List.find (\(vn,e) -> (vn == var)) varwrite of + Nothing -> defaultTr + Just repl -> case repl of + (_,LeftValueExpression lve) -> case leftValueExpressionContents lve of + VariableLeftValue vlv -> defaultTr + ArrayElemReferenceLeftValue aer -> ArrayElemReferenceLeftValue $ ArrayElemReference { + arrayElemReferenceData = ArrayElemReferenceData { + arrayName = fst $ walkLeftValue self (newD d var aer origArrayRef) $ arrayName $ arrayElemReferenceData origArrayRef + , arrayIndex = fst $ walkExpression self d $ arrayIndex $ arrayElemReferenceData aer + }, + arrayElemReferenceSemInf = () + } + _ -> defaultTr + where + newD :: VarStatFwd -> VariableData -> ArrayElemReference ForwardPropagationpSemInf -> ArrayElemReference ForwardPropagationpSemInf -> VarStatFwd + newD d var rep orig = Map.adjust (newDD var rep orig) var d + newDD var rep orig x = x { + writeVar = One $ Just ( LeftValueExpression $ LeftValueInExpression { + leftValueExpressionContents = ArrayElemReferenceLeftValue $ ArrayElemReference { + arrayElemReferenceData = ArrayElemReferenceData { + arrayName = arrayName $ arrayElemReferenceData rep + , arrayIndex = arrayIndex $ arrayElemReferenceData orig + }, + arrayElemReferenceSemInf = Just var + }, + leftValueExpressionSemInf = () + },[],False) + } + var = getJust $ arrayElemReferenceSemInf origArrayRef + getJust (Just a) = a + varwrite = toVarWrite d + defaultTr = ArrayElemReferenceLeftValue $ ArrayElemReference { + arrayElemReferenceData = recursivelyTransformedArrayElemReferenceData u, + arrayElemReferenceSemInf = convert $ arrayElemReferenceSemInf origArrayRef + } + upwardsVariable self d origVar newVar = case variableSemInf origVar of + Occurrence_declare -> Set.empty + Occurrence_read -> Set.empty + Occurrence_write -> Set.singleton (variableData origVar) + Occurrence_notopt -> Set.empty + upwardsBlock self d origBlock u transformedBlock = foldl (\s e -> Set.delete e s) (upwardsInfoFromBlockInstructions u) (declaredVars origBlock) --Not need just optimalize compliler (not try delete locals outside block) + transformBlock self d origBlock u = delUnusedDecl (map fst $ toVarWrite $ combine d $ blockSemInf origBlock) origBlock (recursivelyTransformedBlockData u) + transformPrimitive self d originalPrimitive u = case canDelete of + True -> EmptyProgram $ Empty () + False -> + PrimitiveProgram $ Primitive { + primitiveInstruction = recursivelyTransformedPrimitiveInstruction u, + primitiveSemInf = () + } + where + canDelete = Set.isSubsetOf (upwardsInfoFromPrimitiveInstruction u) (Set.fromList $ map fst $ toVarWrite d) + diff --git a/Feldspar/Compiler/Plugins/HandlePrimitives.hs b/Feldspar/Compiler/Plugins/HandlePrimitives.hs new file mode 100644 --- /dev/null +++ b/Feldspar/Compiler/Plugins/HandlePrimitives.hs @@ -0,0 +1,186 @@ +{-# LANGUAGE TypeFamilies #-} + +module Feldspar.Compiler.Plugins.HandlePrimitives + ( HandlePrimitives(..) + , makeAssignment + , makePrimitive, + ) where + + +import Feldspar.Compiler.Imperative.Representation +import Feldspar.Compiler.Imperative.Semantics (SemanticInfo) +import Feldspar.Compiler.Imperative.CodeGeneration (simpleType, typeof, listprint, compToC, toLeftValue) +import Feldspar.Compiler.PluginArchitecture (TransformationPhase(..), Plugin(..), InfosFromPrimitiveParts(..)) +import Feldspar.Compiler.Options +import Feldspar.Compiler.Error + + + +handlePrimitivesError = handleError "PluginArch/HandlePrimitives" InternalError + + +data HandlePrimitives = HandlePrimitives + + +instance TransformationPhase HandlePrimitives where + type From HandlePrimitives = () + type To HandlePrimitives = () + type Downwards HandlePrimitives = Int + type Upwards HandlePrimitives = () + transformPrimitive = transformPrimitive' + + +instance Plugin HandlePrimitives where + type ExternalInfo HandlePrimitives = (Int,DebugOption) + executePlugin _ (_,NoPrimitiveInstructionHandling) procedure = procedure + executePlugin _ (defArrSize,_) procedure = fst $ executeTransformationPhase HandlePrimitives defArrSize procedure + + + +transformPrimitive' :: HandlePrimitives -> Int -> Primitive () -> InfosFromPrimitiveParts HandlePrimitives -> ProgramConstruction () +transformPrimitive' _ defArrSize old modified' + = case (nameS,as) of + ("(==)", [InputActualParameter _, InputActualParameter _, OutputActualParameter _]) -> mkPrg $ makePrimitive InfixOp 2 as "equal" "==" + ("(/=)", [InputActualParameter _, InputActualParameter _, OutputActualParameter _]) -> mkPrg $ makePrimitive InfixOp 2 as "not_equal" "!=" + ("(<)", [InputActualParameter _, InputActualParameter _, OutputActualParameter _]) -> mkPrg $ makePrimitive InfixOp 2 as "less" "<" + ("(>)", [InputActualParameter _, InputActualParameter _, OutputActualParameter _]) -> mkPrg $ makePrimitive InfixOp 2 as "greater" ">" + ("(<=)", [InputActualParameter _, InputActualParameter _, OutputActualParameter _]) -> mkPrg $ makePrimitive InfixOp 2 as "less_equal" "<=" + ("(>=)", [InputActualParameter _, InputActualParameter _, OutputActualParameter _]) -> mkPrg $ makePrimitive InfixOp 2 as "greater_equal" ">=" + ("not", [InputActualParameter _, OutputActualParameter _]) -> mkPrg $ makePrimitive PrefixOp 1 as "not" "!" + ("(&&)", [InputActualParameter _, InputActualParameter _, OutputActualParameter _]) -> mkPrg $ makePrimitive InfixOp 2 as "and" "&&" + ("(||)", [InputActualParameter _, InputActualParameter _, OutputActualParameter _]) -> mkPrg $ makePrimitive InfixOp 2 as "or" "||" + ("div", [InputActualParameter _, InputActualParameter _, OutputActualParameter _]) -> mkPrg $ makePrimitive InfixOp 2 as "divide" "/" + ("rem", [InputActualParameter _, InputActualParameter _, OutputActualParameter _]) -> mkPrg $ makePrimitive InfixOp 2 as "remainder" "%" + ("mod", [InputActualParameter _, InputActualParameter _, OutputActualParameter _]) -> mkPrg $ makePrimitive SimpleFun 2 as "mod" "" + ("(^)", [InputActualParameter _, InputActualParameter _, OutputActualParameter _]) -> mkPrg $ makePrimitive SimpleFun 2 as "pow" "" + + ("(.&.)", [InputActualParameter _, InputActualParameter _, OutputActualParameter _]) -> mkPrg $ makePrimitive InfixOp 2 as "bit_and" "&" + ("(.|.)", [InputActualParameter _, InputActualParameter _, OutputActualParameter _]) -> mkPrg $ makePrimitive InfixOp 2 as "bit_or" "|" + ("xor", [InputActualParameter _, InputActualParameter _, OutputActualParameter _]) -> mkPrg $ makePrimitive InfixOp 2 as "bit_xor" "^" + ("complement", [InputActualParameter _, OutputActualParameter _]) -> mkPrg $ makePrimitive PrefixOp 1 as "bit_not" "~" + ("bit", [InputActualParameter _, OutputActualParameter _]) -> mkPrg $ makePrimitive SimpleFun 1 as "bit" "" + ("setBit", [InputActualParameter _, InputActualParameter _, OutputActualParameter _]) -> mkPrg $ makePrimitive SimpleFun 2 as "setBit" "" + ("clearBit", [InputActualParameter _, InputActualParameter _, OutputActualParameter _]) -> mkPrg $ makePrimitive SimpleFun 2 as "clearBit" "" + ("complementBit", [InputActualParameter _, InputActualParameter _, OutputActualParameter _]) -> mkPrg $ makePrimitive SimpleFun 2 as "complementBit" "" + ("testBit", [InputActualParameter _, InputActualParameter _, OutputActualParameter _]) -> mkPrg $ makePrimitive SimpleFun 2 as "testBit" "" + ("shiftL", [InputActualParameter _, InputActualParameter _, OutputActualParameter _]) -> mkPrg $ makePrimitive InfixOp 2 as "shiftL" "<<" + ("shiftR", [InputActualParameter _, InputActualParameter _, OutputActualParameter _]) -> mkPrg $ makePrimitive InfixOp 2 as "shiftR" ">>" + ("rotateL", [InputActualParameter _, InputActualParameter _, OutputActualParameter _]) -> mkPrg $ makePrimitive SimpleFun 2 as "rotateL" "" + ("rotateR", [InputActualParameter _, InputActualParameter _, OutputActualParameter _]) -> mkPrg $ makePrimitive SimpleFun 2 as "rotateR" "" + -- ("shift", [InputActualParameter _, InputActualParameter _, OutputActualParameter _]) -> mkPrg $ makePrimitive SimpleFun 2 as "bit_shift" "" + -- ("rotate", [InputActualParameter _, InputActualParameter _, OutputActualParameter _]) -> mkPrg $ makePrimitive SimpleFun 2 as "bit_rotate" "" + ("bitSize", [InputActualParameter _, OutputActualParameter _]) -> mkPrg $ makePrimitive SimpleFun 1 as "bitSize" "" + ("isSigned", [InputActualParameter _, OutputActualParameter _]) -> mkPrg $ makePrimitive SimpleFun 1 as "isSigned" "" + + ("abs", [InputActualParameter _, OutputActualParameter _]) -> mkPrg $ makePrimitive SimpleFun 1 as "abs" "" + ("signum", [InputActualParameter _, OutputActualParameter _]) -> mkPrg $ makePrimitive SimpleFun 1 as "signum" "" + ("(+)", [InputActualParameter _, InputActualParameter _, OutputActualParameter _]) -> mkPrg $ makePrimitive InfixOp 2 as "add" "+" + ("(-)", [InputActualParameter _, InputActualParameter _, OutputActualParameter _]) -> mkPrg $ makePrimitive InfixOp 2 as "sub" "-" + ("(*)", [InputActualParameter _, InputActualParameter _, OutputActualParameter _]) -> mkPrg $ makePrimitive InfixOp 2 as "mult" "*" + ("(/)", [InputActualParameter _, InputActualParameter _, OutputActualParameter _]) -> mkPrg $ makePrimitive InfixOp 2 as "divide" "/" + + ("(!)", [arr@(InputActualParameter _), idx@(InputActualParameter _), out@(OutputActualParameter _)]) + -> mkPrg $ makeAssignment + (LeftValueExpression $ LeftValueInExpression + (ArrayElemReferenceLeftValue $ ArrayElemReference + (ArrayElemReferenceData (toLeftValue $ aToE arr) $ aToE idx) () + ) () + ) (aToL out) defArrSize + + ("setIx", [original@(InputActualParameter _), idx@(InputActualParameter _), val@(InputActualParameter _), result@(OutputActualParameter _)]) + -> SequenceProgram $ Sequence + [ Program (PrimitiveProgram $ Primitive (makeAssignment (aToE original) (aToL result) defArrSize) ()) () + , Program (PrimitiveProgram $ Primitive + (makeAssignment + (aToE val) + (ArrayElemReferenceLeftValue $ ArrayElemReference (ArrayElemReferenceData (aToL result) $ aToE idx) ()) + defArrSize + ) ()) () + ] () + + ("copy", [in1@(InputActualParameter _), out@(OutputActualParameter _)]) + -> mkPrg $ makeAssignment (aToE in1) (aToL out) defArrSize + + _ -> mkPrg $ modified + + where + nameS = nameOfProcedureToCall $ procedureCallData $ (\(ProcedureCallInstruction x) -> x) $ primitiveInstruction old + as = actualParametersOfProcedureToCall $ procedureCallData $ (\(ProcedureCallInstruction x) -> x) modified + modified = recursivelyTransformedPrimitiveInstruction modified' + mkPrg x = PrimitiveProgram (Primitive x ()) + + + +makeAssignment :: Expression () -> LeftValue () -> Int -> Instruction () +makeAssignment in1 out defaultArraySize + | simpleType (typeof in1) = AssignmentInstruction $ Assignment (AssignmentData out in1) () + | otherwise = case (typeof in1) of + (ImpArrayType _ t) -> makePrimitive SimpleFun 2 [eToA in1, eToA $ arraySize (typeof in1) defaultArraySize, lToA out] "copy" "" + _ -> handlePrimitivesError $ "Unknown type in makeAssignment:\n" ++ show (typeof in1) + + + +makePrimitive :: FunctionRole -> Int -> [ActualParameter ()] -> String -> String -> Instruction () +makePrimitive primType parNum as cFunName cOpName + | simpleType (typeof out) = AssignmentInstruction $ Assignment (AssignmentData out (FunctionCallExpression funCall)) () + | otherwise = ProcedureCallInstruction procCall + where + funCall = case (primType, parNum) of + (SimpleFun, 1) -> FunctionCall (FunctionCallData SimpleFun (typeof out) completeFunName [in1]) () + (SimpleFun, 2) -> FunctionCall (FunctionCallData SimpleFun (typeof out) completeFunName [in1, in2]) () + (PrefixOp, 1) -> FunctionCall (FunctionCallData PrefixOp (typeof out) cOpName [in1]) () + (InfixOp, 2) -> FunctionCall (FunctionCallData InfixOp (typeof out) cOpName [in1, in2]) () + _ -> handlePrimitivesError $ "Invalid arguments:\n" ++ show (primType, parNum) + procCall = case (primType, parNum) of + (SimpleFun, 1) -> ProcedureCall (ProcedureCallData completeProcName [in1', out']) () + (SimpleFun, 2) -> ProcedureCall (ProcedureCallData completeProcName [in1', in2', out']) () + (PrefixOp, 1) -> ProcedureCall (ProcedureCallData completeProcName [in1', out']) () + (InfixOp, 2) -> ProcedureCall (ProcedureCallData completeProcName [in1', in2', out']) () + _ -> handlePrimitivesError $ "Invalid arguments:\n" ++ show (primType, parNum) + completeFunName = cFunName ++ "_fun_" ++ toFunName (typeof in1) + completeProcName = cFunName ++ "_" ++ toFunName (typeof in1) + (in1,in1') = case (filter isInparam as) of + x:_ -> (aToE x,x) + _ -> handlePrimitivesError $ "There is not any Input parameter:\n" ++ show as + (in2,in2') = case (filter isInparam as) of + _:x:_ -> (aToE x,x) + _ -> handlePrimitivesError $ "There is not enough Input parameter:\n" ++ show as + (out,out') = case (filter (not . isInparam) as) of + x:_ -> (aToL x,x) + _ -> handlePrimitivesError $ "There is not any Output parameter:\n" ++ show as + + + +toFunName :: Type -> String +toFunName BoolType = "bool" +toFunName FloatType = "float" +toFunName (Numeric sig siz) = listprint id "_" [compToC sig, compToC siz] +toFunName (ImpArrayType _ t@(ImpArrayType _ _)) = toFunName t +toFunName (ImpArrayType _ t) = "arrayOf_" ++ toFunName t + + + +arraySize :: Type -> Int -> Expression () +arraySize a@(ImpArrayType _ t) defaultArraySize + = ConstantExpression $ IntConstant $ IntConstantType (arraySize' a) () + where + arraySize' (ImpArrayType (Norm n) t) = n * arraySize' t + arraySize' (ImpArrayType (Defined n) t) = n * arraySize' t + arraySize' (ImpArrayType Undefined t) = defaultArraySize * arraySize' t + arraySize' _ = 1 + + + +isInparam (InputActualParameter _) = True +isInparam (OutputActualParameter _) = False + + + +aToE (InputActualParameter x) = inputActualParameterExpression x +aToL (OutputActualParameter x) = outputActualParameterLeftValue x +-- TODO create a simple wrapper interface based on these functions + +eToA x = InputActualParameter $ InputActualParameterType x () +lToA x = OutputActualParameter $ OutputActualParameterType x () + + diff --git a/Feldspar/Compiler/Plugins/Precompilation.hs b/Feldspar/Compiler/Plugins/Precompilation.hs new file mode 100644 --- /dev/null +++ b/Feldspar/Compiler/Plugins/Precompilation.hs @@ -0,0 +1,175 @@ +{-# LANGUAGE EmptyDataDecls, TypeFamilies #-} + +module Feldspar.Compiler.Plugins.Precompilation where + +import Feldspar.Compiler.PluginArchitecture +import qualified Feldspar.Core.Expr as Expr +import Feldspar.Core.Types + +import qualified Feldspar.Compiler.Precompiler.Precompiler as Precompiler +import Feldspar.Compiler.Error + +import System.IO.Unsafe + +-- =========================================================================== +-- == Precompilation plugin +-- =========================================================================== + +data CompilationMode = Interactive | Standalone + deriving (Show, Eq) + +data SignatureInformation = SignatureInformation { + originalFeldsparFunctionName :: String, + generatedImperativeParameterNames :: [String], + originalFeldsparParameterNames :: Maybe [Maybe String] +} deriving (Show, Eq) + +instance Default SignatureInformation where defaultValue = precompilationError InternalError "Default value should not be used" + +precompilationError = handleError "PluginArch/Precompilation" + +data PrecompilationSemanticInfo + +instance SemanticInfo PrecompilationSemanticInfo where + type ProcedureInfo PrecompilationSemanticInfo = SignatureInformation + type BlockInfo PrecompilationSemanticInfo = () + type ProgramInfo PrecompilationSemanticInfo = () + type EmptyInfo PrecompilationSemanticInfo = () + type PrimitiveInfo PrecompilationSemanticInfo = () + type SequenceInfo PrecompilationSemanticInfo = () + type BranchInfo PrecompilationSemanticInfo = () + type SequentialLoopInfo PrecompilationSemanticInfo = () + type ParallelLoopInfo PrecompilationSemanticInfo = () + type FormalParameterInfo PrecompilationSemanticInfo = () + type LocalDeclarationInfo PrecompilationSemanticInfo = () + type LeftValueExpressionInfo PrecompilationSemanticInfo = () + type VariableInLeftValueInfo PrecompilationSemanticInfo = () + type ArrayElemReferenceInfo PrecompilationSemanticInfo = () + type InputActualParameterInfo PrecompilationSemanticInfo = () + type OutputActualParameterInfo PrecompilationSemanticInfo = () + type AssignmentInfo PrecompilationSemanticInfo = () + type ProcedureCallInfo PrecompilationSemanticInfo = () + type FunctionCallInfo PrecompilationSemanticInfo = () + type IntConstantInfo PrecompilationSemanticInfo = () + type FloatConstantInfo PrecompilationSemanticInfo = () + type BoolConstantInfo PrecompilationSemanticInfo = () + type ArrayConstantInfo PrecompilationSemanticInfo = () + type VariableInfo PrecompilationSemanticInfo = SignatureInformation + +data Precompilation = Precompilation + +instance TransformationPhase Precompilation where + type From Precompilation = () + type To Precompilation = () + type Downwards Precompilation = SignatureInformation + type Upwards Precompilation = () + downwardsProcedure Precompilation fromAbove procedure = fromAbove { + generatedImperativeParameterNames = + map (variableName . variableData . formalParameterVariable) (inParameters procedure) + } + transformProcedure Precompilation fromAbove originalProcedure fromBelow = + Procedure { -- NOTE: fromAbove won't have the generated imperative parameter names right here + procedureName = originalFeldsparFunctionName fromAbove, + inParameters = recursivelyTransformedInParameters fromBelow, + outParameters = recursivelyTransformedOutParameters fromBelow, + procedureBody = recursivelyTransformedProcedureBody fromBelow, + procedureSemInf = () + } + transformVariable = myTransformVariable + +getVariableName :: SignatureInformation -> String -> String +getVariableName signatureInformation origname = case (originalFeldsparParameterNames signatureInformation) of + Just originalParameterNameList -> + if length (generatedImperativeParameterNames signatureInformation) == length originalParameterNameList then + case searchResults of + [] -> origname + otherwise -> case snd $ head $ searchResults of + Just newname -> newname + Nothing -> origname + else + precompilationError InternalError $ "parameter name list length mismatch:" ++ + show (generatedImperativeParameterNames signatureInformation) ++ " " ++ show originalParameterNameList + where + searchResults = (filter (((==) origname).fst) (zip (generatedImperativeParameterNames signatureInformation) originalParameterNameList)) + Nothing -> origname + +myTransformVariable :: Precompilation -> SignatureInformation -> Variable () -> Variable () +myTransformVariable Precompilation fromAbove v = v { + variableData = (variableData v) { + variableName = getVariableName fromAbove (variableName $ variableData v) + }, + variableSemInf = () +} + +data PrecompilationExternalInfo = PrecompilationExternalInfo { + originalFeldsparFunctionSignature :: Precompiler.OriginalFeldsparFunctionSignature, + graphInputInterfaceType :: Tuple StorableType, + numberOfFunctionArguments :: Int, + compilationMode :: CompilationMode +} + +countTuple :: Tuple a -> Int +countTuple (One x) = 1 +countTuple (Tup list) = sum (map countTuple list) + +addPostfixNumbersToMaybeList :: [Maybe String] -> [Maybe String] +addPostfixNumbersToMaybeList list + | length list > 1 = map addPostfixNumberToMaybeString (zip list [1..]) -- postfix numbers only needed for lists with length > 1 + | otherwise = list + +addPostfixNumberToMaybeString :: (Maybe String, Int) -> Maybe String +addPostfixNumberToMaybeString (ms, num) = case ms of + Just s -> Just $ s ++ (show num) + Nothing -> Nothing + +inflate :: Int -> [Maybe String] -> [Maybe String] +inflate target list | length list < target = inflate target (list++[Nothing]) + | length list == target = list + | otherwise = precompilationError InternalError "Unexpected situation in 'inflate'" + +-- Applies some tweaks the original parameter name list based on the graph's input interface type signature +parameterNameListConsolidator :: PrecompilationExternalInfo -> [Maybe String] +parameterNameListConsolidator externalInfo = case graphInputInterfaceType externalInfo of + One x -> Precompiler.originalFeldsparParameterNames $ originalFeldsparFunctionSignature externalInfo + tuple@(Tup list) -> case numberOfFunctionArguments externalInfo of + 0 -> precompilationError InternalError "parameter name list consolidator function shouldn't be called when numArgs==0" + 1 -> addPostfixNumbersToMaybeList $ replicate (countTuple tuple) + (head $ Precompiler.originalFeldsparParameterNames $ originalFeldsparFunctionSignature externalInfo) + otherwise -> concat $ map (\(cnt,name)->addPostfixNumbersToMaybeList (replicate cnt name)) + (zip (map countTuple list) (Precompiler.originalFeldsparParameterNames $ originalFeldsparFunctionSignature externalInfo)) + +instance Plugin Precompilation where + type ExternalInfo Precompilation = PrecompilationExternalInfo + executePlugin Precompilation externalInfo procedure = fst + $ executeTransformationPhase Precompilation (SignatureInformation { + originalFeldsparFunctionName = Precompiler.originalFeldsparFunctionName $ originalFeldsparFunctionSignature externalInfo, + generatedImperativeParameterNames = precompilationError InternalError "GIPN should have been overwritten", + originalFeldsparParameterNames = if numberOfFunctionArguments externalInfo == 0 + then + Nothing -- if there are no arguments, disable parameter name handling (needed because of the dummy var0) + else + (case compilationMode externalInfo of + Standalone -> + if -- ultimate check, should be enough... + numberOfFunctionArguments externalInfo == + length (Precompiler.originalFeldsparParameterNames $ originalFeldsparFunctionSignature externalInfo) + then + Just $ parameterNameListConsolidator externalInfo + else + (unsafePerformIO $ do + putStrLn $ "[WARNING @ PluginArch/Precompilation]: argument count mismatch in function " ++ + (Precompiler.originalFeldsparFunctionName $ originalFeldsparFunctionSignature externalInfo) ++ + ", inflating incomplete parameter name list..." + putStrLn $ "numArgs: " ++ show (numberOfFunctionArguments externalInfo) ++ ", parameter list: " ++ + show (Precompiler.originalFeldsparParameterNames $ originalFeldsparFunctionSignature externalInfo) + return $ Just $ parameterNameListConsolidator (externalInfo { + originalFeldsparFunctionSignature = (originalFeldsparFunctionSignature externalInfo) { + Precompiler.originalFeldsparParameterNames = inflate (numberOfFunctionArguments externalInfo) $ + Precompiler.originalFeldsparParameterNames $ originalFeldsparFunctionSignature externalInfo + } + }) + ) + Interactive -> Nothing -- no parameter name handling in interactive mode + ) + }) procedure + diff --git a/Feldspar/Compiler/Plugins/PrettyPrint.hs b/Feldspar/Compiler/Plugins/PrettyPrint.hs new file mode 100644 --- /dev/null +++ b/Feldspar/Compiler/Plugins/PrettyPrint.hs @@ -0,0 +1,64 @@ +{-# LANGUAGE TypeFamilies #-} + +module Feldspar.Compiler.Plugins.PrettyPrint where + +import Feldspar.Compiler.PluginArchitecture +import Feldspar.Compiler.Options + +-- =========================================================================== +-- == PrettyPrint plugin +-- =========================================================================== + +instance Default IsRestrict where + defaultValue = NoRestrict + + +instance Default IsDefaultArraySize where + defaultValue = NoDefaultArraySize + + +data PrettyPrint = PrettyPrint + + +instance TransformationPhase PrettyPrint where + type From PrettyPrint = () + type To PrettyPrint = PrettyPrintSemanticInfo + type Downwards PrettyPrint = (IsRestrict, Int) + type Upwards PrettyPrint = () + + transformFormalParameter _ (platform,defArrSize) _ up = + FormalParameter { + formalParameterVariable = addDefaultArraySizes v defArrSize, + formalParameterSemInf = platform + } + where + v = recursivelyTransformedFormalParameterVariable up + + transformLocalDeclaration _ (_,defArrSize) _ up = + LocalDeclaration { + localDeclarationData = ldd{localVariable = addDefaultArraySizes v defArrSize}, + localDeclarationSemInf = () + } + where + ldd = recursivelyTransformedLocalDeclarationData up + v = localVariable ldd + + +instance Plugin PrettyPrint where + type ExternalInfo PrettyPrint = (Platform,Int) + executePlugin PrettyPrint (platform,defArrSize) procedure = fst + $ executeTransformationPhase PrettyPrint (isRestrict,defArrSize) procedure where + isRestrict = case platform of + C99 -> Restrict + _ -> NoRestrict + + +addDefaultArraySizes :: (SemanticInfo t) => Variable t -> Int -> Variable t +addDefaultArraySizes v defArrSize = v{variableData = vd{variableType = addDefaultArraySizes' t}} + where + vd = variableData v + t = variableType vd + addDefaultArraySizes' (ImpArrayType (Norm n) t) = ImpArrayType (Norm n) $ addDefaultArraySizes' t + addDefaultArraySizes' (ImpArrayType Undefined t) = ImpArrayType (Defined defArrSize) $ addDefaultArraySizes' t + addDefaultArraySizes' t = t + diff --git a/Feldspar/Compiler/Plugins/PropagationUtils.hs b/Feldspar/Compiler/Plugins/PropagationUtils.hs new file mode 100644 --- /dev/null +++ b/Feldspar/Compiler/Plugins/PropagationUtils.hs @@ -0,0 +1,217 @@ +{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-} + +module Feldspar.Compiler.Plugins.PropagationUtils where + +import Feldspar.Compiler.PluginArchitecture +import qualified Data.Map as Map +--import qualified Data.Set as Set +import qualified Data.List as List + +-- ======================== +-- VarStatistics +-- ======================== + +instance Ord VariableData where + compare v1 v2 = compare (variableName v1) $ variableName v2 + +type VarStatistics t = Map.Map VariableData (Occurrences t) + +data Occurrences t + = Occurrences + { writeVar :: Occurrence (Maybe t) --(Maybe (Expression t,[String],Bool)) + , readVar :: Occurrence () + } + deriving (Eq,Show) + +data Occurrence t = Zero | One t | Multiple + deriving (Eq,Show) + +hasUse :: VarStatistics t -> VariableData -> Bool +hasUse vs var = hasRead vs var || hasWrite vs var + +notUse :: VarStatistics t -> VariableData -> Bool +notUse vs var = not $ hasUse vs var + +hasRead :: VarStatistics t -> VariableData -> Bool +hasRead vs var = case Map.lookup var vs of + Nothing -> False + Just occ -> case readVar occ of + Zero -> False + _ -> True + +notRead :: VarStatistics t -> VariableData -> Bool +notRead vs var = not $ hasRead vs var + +hasWrite :: VarStatistics t -> VariableData -> Bool +hasWrite vs var = case Map.lookup var vs of + Nothing -> False + Just occ -> case writeVar occ of + Zero -> False + _ -> True + +notWrite :: VarStatistics t -> VariableData -> Bool +notWrite vs var = not $ hasWrite vs var + +getWrite :: VarStatistics t -> VariableData -> Maybe t +getWrite vs var = case Map.lookup var vs of + Nothing -> Nothing + Just occ -> case writeVar occ of + One val -> val + _ -> Nothing + +instance Default (VarStatistics t) where + defaultValue = Map.empty + +instance Combine (VarStatistics t) where + combine fst snd = Map.unionWith combine fst snd + +instance Combine (Occurrences t) where + combine o1 o2 = Occurrences + (combine (writeVar o1) (writeVar o2) ) + (combine (readVar o1) (readVar o2) ) + +instance Combine (Occurrence t) where + combine Zero x = x + combine Multiple x = Multiple + combine e@(One _) Zero = e + combine (One _) _ = Multiple + +multipleVarStatistics :: VarStatistics t -> VarStatistics t +multipleVarStatistics vs = Map.map multipleOccurrences vs where + multipleOccurrences (Occurrences write read) = Occurrences (multipleOccurrence write) (multipleOccurrence read) + multipleOccurrence Zero = Zero + multipleOccurrence (One _) = Multiple + multipleOccurrence Multiple = Multiple + +variablesInVarStatistics :: VarStatistics t -> [VariableData] +variablesInVarStatistics vs = Map.keys vs + +selectFromVarStatistics :: [VariableData] -> VarStatistics t -> VarStatistics t +selectFromVarStatistics s vs = Map.filterWithKey (\v o -> v `elem` s) vs + +deleteFromVarStatistics :: [VariableData] -> VarStatistics t -> VarStatistics t +deleteFromVarStatistics s vs = Map.filterWithKey (\v o -> not $ v `elem` s) vs + + +-- ======================== +-- Downwards +-- ======================== + +data Occurrence_place = Occurrence_read | Occurrence_write | Occurrence_declare | Occurrence_notopt + deriving (Eq,Show) + +instance Default Occurrence_place where + defaultValue = Occurrence_read + +class OccurrenceDownwards node where + occurrenceDownwards :: node -> Occurrence_place + +instance OccurrenceDownwards (Branch t) where + occurrenceDownwards _ = Occurrence_notopt --condition variable OK +instance OccurrenceDownwards (SequentialLoop t) where + occurrenceDownwards _ = Occurrence_read --condition variable OK +instance OccurrenceDownwards (ParallelLoop t) where + occurrenceDownwards _ = Occurrence_notopt --condition variable OK +instance OccurrenceDownwards (FormalParameter t) where + occurrenceDownwards _ = Occurrence_notopt +instance OccurrenceDownwards (LocalDeclaration t) where + occurrenceDownwards _ = Occurrence_declare +instance OccurrenceDownwards (Assignment t) where + occurrenceDownwards _ = Occurrence_write --left OK, right is expression +instance OccurrenceDownwards (InputActualParameterType t) where + occurrenceDownwards _ = Occurrence_read +instance OccurrenceDownwards (OutputActualParameterType t) where + occurrenceDownwards _ = Occurrence_write +instance OccurrenceDownwards (LeftValueInExpression t) where + occurrenceDownwards _ = Occurrence_read -- OK +instance OccurrenceDownwards (FunctionCall t) where + occurrenceDownwards _ = Occurrence_read -- OK + + + +-- ======================== +-- Other utils +-- ======================== + +instance Default [VariableData] where + defaultValue = [] + + +declaredVar :: (SemanticInfo t) => LocalDeclaration t -> VariableData +declaredVar = variableData.localVariable.localDeclarationData + +declaredVars :: (SemanticInfo t) => Block t -> [VariableData] +declaredVars block = map declaredVar $ blockDeclarations $ blockData block + +delUnusedDecl :: (ConvertAllInfos via to) => [VariableData] -> Block via -> BlockData to -> Block to +delUnusedDecl unusedList origblock partiallyTransformedBlock = + Block { + blockData = BlockData { + blockDeclarations = filter (\d -> not $ List.elem (declaredVar d) unusedList) $ blockDeclarations partiallyTransformedBlock, + blockInstructions = blockInstructions partiallyTransformedBlock + }, + blockSemInf = convert $ blockSemInf origblock + } + +-- ======================== +-- SemInfUtils +-- ======================== + +class SemInfUtils node where + deleteSemInf :: (SemanticInfo t) => node t -> node () + +instance SemInfUtils Expression where + deleteSemInf (LeftValueExpression lve) = LeftValueExpression $ lve { + leftValueExpressionContents = deleteSemInf $ leftValueExpressionContents lve, + leftValueExpressionSemInf = () + } + deleteSemInf (ConstantExpression ce) = (ConstantExpression $ deleteSemInf ce) + deleteSemInf (FunctionCallExpression fce) = FunctionCallExpression $ fce { + functionCallData = (functionCallData fce) { + actualParametersOfFunctionToCall = map deleteSemInf $ actualParametersOfFunctionToCall $ functionCallData fce + }, + functionCallSemInf = () + } + +instance SemInfUtils LeftValue where + deleteSemInf (VariableLeftValue vlv) = VariableLeftValue vlv { + variableLeftValueContents = deleteSemInf $ variableLeftValueContents vlv, + variableLeftValueSemInf = () + } + deleteSemInf (ArrayElemReferenceLeftValue aer) = ArrayElemReferenceLeftValue aer { + arrayElemReferenceData = (arrayElemReferenceData aer){ + arrayName = deleteSemInf $ arrayName $ arrayElemReferenceData aer, + arrayIndex = deleteSemInf $ arrayIndex $ arrayElemReferenceData aer + }, + arrayElemReferenceSemInf = () + } + +instance SemInfUtils Variable where + deleteSemInf var = var { + variableSemInf = () + } + +instance SemInfUtils ActualParameter where + deleteSemInf (InputActualParameter iap) = InputActualParameter iap { + inputActualParameterExpression = deleteSemInf $ inputActualParameterExpression iap, + inputActualParameterSemInf = () + } + deleteSemInf (OutputActualParameter oap) = OutputActualParameter oap { + outputActualParameterLeftValue = deleteSemInf $ outputActualParameterLeftValue oap, + outputActualParameterSemInf = () + } + +instance SemInfUtils Constant where + deleteSemInf (IntConstant ic) = IntConstant ic { + intConstantSemInf = () + } + deleteSemInf (FloatConstant fc) = FloatConstant fc { + floatConstantSemInf = () + } + deleteSemInf (BoolConstant bc) = BoolConstant bc { + boolConstantSemInf = () + } + deleteSemInf (ArrayConstant ac) = ArrayConstant ac { + arrayConstantValue = map deleteSemInf $ arrayConstantValue ac, + arrayConstantSemInf = () + } diff --git a/Feldspar/Compiler/Plugins/Unroll.hs b/Feldspar/Compiler/Plugins/Unroll.hs new file mode 100644 --- /dev/null +++ b/Feldspar/Compiler/Plugins/Unroll.hs @@ -0,0 +1,152 @@ +{-# LANGUAGE FlexibleInstances, TypeFamilies #-} + +module Feldspar.Compiler.Plugins.Unroll where + +import Feldspar.Compiler.Imperative.Representation +import Feldspar.Compiler.Options +import Prelude +import Feldspar.Compiler.Imperative.Semantics +import Feldspar.Compiler.PluginArchitecture + + +instance Plugin UnrollPlugin where + type ExternalInfo UnrollPlugin = UnrollStrategy + executePlugin UnrollPlugin ei p = case ei of + NoUnroll -> p + Unroll unrollCount -> fst $ executeTransformationPhase Unroll_2 Nothing $ fst $ executeTransformationPhase Unroll_1 unrollCount p + +data UnrollPlugin = UnrollPlugin +instance TransformationPhase UnrollPlugin where + type From UnrollPlugin = () + type To UnrollPlugin = () + type Downwards UnrollPlugin = () + type Upwards UnrollPlugin = () + +data Unroll_1 = Unroll_1 +instance TransformationPhase Unroll_1 where + type From Unroll_1 = () + type To Unroll_1 = UnrollSemInf + type Downwards Unroll_1 = Int + type Upwards Unroll_1 = Bool + upwardsParallelLoop _ _ _ _ _ = True + transformParallelLoop Unroll_1 d pl u = trParLoop1 d pl u + +data Unroll_2 = Unroll_2 +instance TransformationPhase Unroll_2 where + type From Unroll_2 = UnrollSemInf + type To Unroll_2 = () + type Downwards Unroll_2 = Maybe SemInfPrg + type Upwards Unroll_2 = () + downwardsProgram Unroll_2 d p + | programSemInf p == Nothing = d + | otherwise = programSemInf p + transformVariable Unroll_2 d v = trVariable d v + transformLeftValueExpression Unroll_2 d lvie u = trLVIE d lvie u + +data UnrollSemInf = UnrollSemInf +instance SemanticInfo UnrollSemInf where + type ProcedureInfo UnrollSemInf = () + type BlockInfo UnrollSemInf = () + type ProgramInfo UnrollSemInf = Maybe SemInfPrg + type EmptyInfo UnrollSemInf = Maybe SemInfPrg + type PrimitiveInfo UnrollSemInf = Maybe SemInfPrg + type SequenceInfo UnrollSemInf = Maybe SemInfPrg + type BranchInfo UnrollSemInf = () + type SequentialLoopInfo UnrollSemInf = () + type ParallelLoopInfo UnrollSemInf = () + type FormalParameterInfo UnrollSemInf = () + type LocalDeclarationInfo UnrollSemInf = () + type LeftValueExpressionInfo UnrollSemInf = () + type VariableInLeftValueInfo UnrollSemInf = () + type ArrayElemReferenceInfo UnrollSemInf = () + type InputActualParameterInfo UnrollSemInf = () + type OutputActualParameterInfo UnrollSemInf = () + type AssignmentInfo UnrollSemInf = () + type ProcedureCallInfo UnrollSemInf = () + type FunctionCallInfo UnrollSemInf = () + type IntConstantInfo UnrollSemInf = () + type FloatConstantInfo UnrollSemInf = () + type BoolConstantInfo UnrollSemInf = () + type ArrayConstantInfo UnrollSemInf = () + type VariableInfo UnrollSemInf = () + +instance Combine Bool where + combine = (||) + +data SemInfPrg = SemInfPrg + { position :: Int + , varNames :: [String] + , loopVar :: String + } deriving (Eq, Show) +instance Default (Maybe SemInfPrg) where defaultValue = Nothing + +trLVIE d lvie u = case d of + Just x -> result x + otherwise -> orig + where + leftValue = leftValueExpressionContents $ lvie + name = case leftValue of + VariableLeftValue (VariableInLeftValue d _) -> Just $ getVarName d + otherwise -> Nothing + result x = case name of + Just n + | n == loopVar x -> FunctionCallExpression $ FunctionCall (FunctionCallData (InfixOp) (Numeric ImpSigned S32) ("+") ([loopVarPar, plusPar])) () + | otherwise -> orig + otherwise -> orig + where + loopVarPar = orig + num = position x + plusPar = ConstantExpression $ IntConstant $ IntConstantType num () + orig = LeftValueExpression $ LeftValueInExpression (recursivelyTransformedLeftValueExpressionContents u ) () + +trVariable d v + | d /= Nothing && elementOf (varNames (valueFromJust d)) (getVarName v) = v { variableData = (variableData v){ variableName = (variableName $ variableData v) ++ "_u" ++ (show $ position $ valueFromJust d) },variableSemInf = ()} + | otherwise = v {variableSemInf = ()} + +trParLoop1 d pl u + | ( upwardsInfoFromParallelLoopCore u ) == False && (unrollPossible || varInExpr ) = ParallelLoopProgram newParLoop + | otherwise = ParallelLoopProgram (ParallelLoop trPL ()) + where + newParLoop = pl { parallelLoopData = ( trPL ) + { parallelLoopStep = unrollNum + , parallelLoopCore = newLoopCore} + , parallelLoopSemInf = ()} + newLoopCore = origLoopCore + { blockData = (blockData origLoopCore) + { blockDeclarations = unrollDecls + , blockInstructions = unrollPrg + } + , blockSemInf = ()} + unrollPrg = Program (SequenceProgram $ Sequence prgs (Nothing)) (Nothing) + prgs = map (\(i,p) -> writeSemInfToPrg p (Just $ SemInfPrg i varNames loopCounter)) $ zip [0,1..] replPrg + writeSemInfToPrg prg semInf = prg { programSemInf = semInf } + replPrg = replicate unrollNum origPrg + origPrg = blockInstructions $ blockData origLoopCore + unrollDecls = concat $ map (\(i,ds) -> renameDecls ds i) $ zip [0,1..] replDecls + renameDecls ds i = map (\d -> renameDeclaration d ((getVarNameDecl d) ++ "_u" ++ (show i))) ds + replDecls = replicate unrollNum origDecls + origDecls = blockDeclarations $ blockData origLoopCore + origLoopCore = parallelLoopCore $ trPL + iterExpr = numberOfIterations $ trPL + trPL = recursivelyTransformedParallelLoopData u + unrollNum = d + loopCounter = getVarName $ parallelLoopConditionVariable trPL + varNames = map (\d -> getVarNameDecl d) origDecls + iterTemp = iterNumFromExpr iterExpr + origIterNum = valueFromJust iterTemp + iterNumIsConstant = isJust iterTemp + unrollPossible = iterNumIsConstant && ( mod origIterNum d == 0 ) + varInExpr = not $ isJust iterTemp + +-- helper functions : +iterNumFromExpr (ConstantExpression (IntConstant (IntConstantType i _))) = Just i +iterNumFromExpr _ = Nothing +isJust (Just x) = True +isJust _ = False +getVarNameDecl d = getVarName $ localVariable $ localDeclarationData $ d +getVarName v = variableName $ variableData v +valueFromJust (Just v) = v +valueFromJust Nothing = error "This was Nothing" +renameDeclaration d n = d { localDeclarationData = (localDeclarationData d) { localVariable = renameVariable (localVariable $ localDeclarationData d) n } } +renameVariable v n = v { variableData = (variableData v) { variableName = n } } +elementOf ss s = (length $ filter (\s' -> s' == s) ss) > 0 diff --git a/Feldspar/Compiler/Precompiler/Precompiler.hs b/Feldspar/Compiler/Precompiler/Precompiler.hs --- a/Feldspar/Compiler/Precompiler/Precompiler.hs +++ b/Feldspar/Compiler/Precompiler/Precompiler.hs @@ -1,57 +1,47 @@ -{- - - 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 System.IO.Unsafe import Language.Haskell.Exts +import Feldspar.Compiler.Error +data OriginalFeldsparFunctionSignature = OriginalFeldsparFunctionSignature { + originalFeldsparFunctionName :: String, + originalFeldsparParameterNames :: [Maybe String] +} deriving (Eq) + +instance Show OriginalFeldsparFunctionSignature where + show (OriginalFeldsparFunctionSignature fn pl) = "function name: " ++ show fn ++ ", parameter list: " ++ show pl + +precompilerError errorClass msg = handleError "Precompiler" errorClass msg + +neutralName = "kiscica<>#&@{}-$;>" + +-- Module SrcLoc ModuleName [OptionPragma] (Maybe WarningText) (Maybe [ExportSpec]) [ImportDecl] [Decl] 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 :: Decl -> OriginalFeldsparFunctionSignature 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 + FunBind ((Match a b c d e f):rest) -> OriginalFeldsparFunctionSignature (stripName b) (map stripPattern c) -- going for name and parameter list + -- "Match SrcLoc Name [Pat] (Maybe Type) Rhs Binds" + -- TODO handle other patterns, not only the first one (head)? + PatBind a b c d e -> case stripPattern b of + Just functionName -> OriginalFeldsparFunctionSignature functionName [] -- parameterless declarations (?) + Nothing -> precompilerError InternalError ("Unsupported pattern binding: " ++ show b) + TypeSig a b c -> OriginalFeldsparFunctionSignature neutralName [] --head b -- we don't need the type signature (yet) + DataDecl a b c d e f g -> OriginalFeldsparFunctionSignature neutralName [] + InstDecl a b c d e -> OriginalFeldsparFunctionSignature neutralName [] + -- TypeDecl SrcLoc Name [TyVarBind] Type + TypeDecl a b c d -> OriginalFeldsparFunctionSignature neutralName [] + unknown -> precompilerError InternalError ("Unsupported language element [SFB/1]: " ++ show unknown) -stripMatch (Match a b c d e f) = b +stripPattern :: Pat -> Maybe String +stripPattern (PVar x) = Just $ stripName x +stripPattern PWildCard = Nothing +stripPattern (PAsPat x _) = Just $ stripName x +stripPattern (PParen pattern) = stripPattern pattern +stripPattern _ = Nothing stripName :: Name -> String stripName (Ident a) = a @@ -62,20 +52,22 @@ stripModuleName (ModuleName x) = x getModuleName :: String -> String -- filecontents -> modulename -getModuleName = stripModuleName . stripModule2 . stripResult . customizedParse +getModuleName = stripModuleName . stripModule2 . fromParseResult . customizedParse usedExtensions = glasgowExts ++ [ExplicitForall] +-- Ultimate debug function getParseOutput fileName = parseFileWithMode (defaultParseMode { extensions = usedExtensions }) fileName -- or: parseFileContentsWithMode customizedParse = parseModuleWithMode (defaultParseMode { extensions = usedExtensions }) -getFullDeclarationList fileContents = - map (stripName . stripFunBind) (stripModule $ stripResult $ customizedParse fileContents ) +getFullDeclarationListWithParameterList :: String -> [OriginalFeldsparFunctionSignature] +getFullDeclarationListWithParameterList fileContents = + map stripFunBind (stripModule $ fromParseResult $ customizedParse fileContents ) functionNameNeeded :: String -> Bool -functionNameNeeded functionName = (functionName /="DUMMY") && (functionName /="main") +functionNameNeeded functionName = (functionName /= neutralName) stripUnnecessary :: [String] -> [String] stripUnnecessary = filter functionNameNeeded @@ -85,5 +77,29 @@ fileContents <- hGetContents handle return $ getDeclarationList fileContents +printDeclarationListWithParameterList fileName = do + handle <- openFile fileName ReadMode + fileContents <- hGetContents handle + putStrLn $ show $ filter (functionNameNeeded . originalFeldsparFunctionName) (getFullDeclarationListWithParameterList fileContents) + +printParameterListOfFunction :: FilePath -> String -> IO [Maybe String] +printParameterListOfFunction fileName functionName = getParameterList fileName functionName + +-- The interface getDeclarationList :: String -> [String] -- filecontents -> Stringlist -getDeclarationList = stripUnnecessary . getFullDeclarationList +getDeclarationList = stripUnnecessary . (map originalFeldsparFunctionName) . getFullDeclarationListWithParameterList + +getExtendedDeclarationList :: String -> [OriginalFeldsparFunctionSignature] -- filecontents -> ExtDeclList +getExtendedDeclarationList fileContents = filter (functionNameNeeded . originalFeldsparFunctionName) + (getFullDeclarationListWithParameterList fileContents) + +getParameterListOld :: String -> String -> [Maybe String] +getParameterListOld fileContents funName = originalFeldsparParameterNames $ head $ + filter ((==funName) . originalFeldsparFunctionName) (getExtendedDeclarationList fileContents) + +getParameterList :: FilePath -> String -> IO [Maybe String] +getParameterList fileName funName = do + handle <- openFile fileName ReadMode + fileContents <- hGetContents handle + return $ originalFeldsparParameterNames $ head $ + filter ((==funName) . originalFeldsparFunctionName) (getExtendedDeclarationList fileContents) diff --git a/Feldspar/Compiler/Transformation/GraphToImperative.hs b/Feldspar/Compiler/Transformation/GraphToImperative.hs --- a/Feldspar/Compiler/Transformation/GraphToImperative.hs +++ b/Feldspar/Compiler/Transformation/GraphToImperative.hs @@ -1,74 +1,46 @@ -{- - - 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 FlexibleInstances #-} module Feldspar.Compiler.Transformation.GraphToImperative where import Feldspar.Core.Graph +import Feldspar.Range +import qualified Feldspar.Core.Graph as Graph import Feldspar.Core.Types hiding (typeOf) -import Feldspar.Compiler.Imperative.Representation hiding (Array) +import qualified Feldspar.Core.Types as CoreTypes +import Feldspar.Compiler.Imperative.Representation +import Feldspar.Compiler.Imperative.CodeGeneration +import qualified Feldspar.Compiler.Imperative.Representation as Representation import Feldspar.Compiler.Transformation.GraphUtils import Data.List import qualified Data.Map as Map +import qualified Data.Maybe as Maybe +import Feldspar.Compiler.Error +import Feldspar.Compiler.Imperative.Semantics -- 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 - } +graphToImperative :: HierarchicalGraph -> [Procedure InitSemInf] +graphToImperative g = map transformSourceToProcedure sources where + sources = this : collectSources g + this = ProcedureSource + { 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 +data ProcedureSource + = ProcedureSource + { 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] + collectSources :: t -> [ProcedureSource] instance Collect HierarchicalGraph where collectSources g = collectSources $ graphHierarchy g @@ -83,7 +55,7 @@ collectSources (n,hs) = this ++ collectSources hs where this = case function n of NoInline name interface -> case hs of - [hierarchy] -> [ImpFunctionSource name interface hierarchy] + [hierarchy] -> [ProcedureSource interface hierarchy] _ -> error $ "Graph error: malformed hierarchy list in the 'NoInline' node with id " ++ show (nodeId n) _ -> [] @@ -92,106 +64,174 @@ -- 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) [] - } +transformSourceToProcedure :: ProcedureSource -> Procedure InitSemInf +transformSourceToProcedure (ProcedureSource ifc (Hierarchy pairs)) + = Procedure { + procedureName = "PLACEHOLDER", + inParameters = inputDecls, + outParameters = outputDecls, + procedureBody = Block { + blockData = BlockData { + blockDeclarations = localDecls, + blockInstructions = Program { + programConstruction = SequenceProgram $ Sequence { + sequenceProgramList = ( map transformNodeToProgram pairs + ++ copyToOutput (interfaceOutput ifc) (interfaceOutputType ifc) True ), + sequenceSemInf = () + }, + programSemInf = () + } + }, + blockSemInf = () + }, + procedureSemInf = () } 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 + inputDecls = case inputNodes of + [inputNode] -> transformNodeToFormalParameter inputNode + [] -> handleError "GraphToImperative" InvariantViolation $ "no input node found" ++ (show (map fst pairs)) + _ -> handleError "GraphToImperative" InvariantViolation $ "exactly one input node expected; nodeId==" ++ (show $ nodeId $ head inputNodes) + localDecls = concatMap transformNodeToLocalDeclaration localNodes + outputDecls = tupleWalk transformSourceToFormalParameter $ interfaceOutputType ifc + transformSourceToFormalParameter :: [Int] -> StorableType -> FormalParameter InitSemInf + transformSourceToFormalParameter path typ = FormalParameter { + formalParameterVariable = Representation.Variable (VariableData FunOut ctyp (outName path)) (), + formalParameterSemInf = () + } where + ctyp = compileStorableType typ + (inputNodes,localNodes) = partition (\n -> nodeId n == interfaceInput ifc) $ 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 +transformNodeToFormalParameter :: Node -> [FormalParameter InitSemInf] +transformNodeToFormalParameter 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 + = FormalParameter { + formalParameterVariable = Representation.Variable (VariableData Value ctyp (varPrefix (nodeId n) ++ varPath path)) (), + formalParameterSemInf = () + } 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 +transformNodeToLocalDeclaration :: Node -> [LocalDeclaration InitSemInf] +transformNodeToLocalDeclaration n = tupleWalk genDecl $ tupleZip (outTyps,initVals) where + genDecl path (typ,ini) = LocalDeclaration { + localDeclarationData = LocalDeclarationData { + localVariable = Representation.Variable { + variableData = VariableData { + variableRole = Value, + variableType = ctyp, + variableName = (varPrefix (nodeId n) ++ varPath path) + }, + variableSemInf = () + }, + localInitValue = ini + }, + localDeclarationSemInf = () + } 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." + otherwise -> genNothingTuple outTyps + genNothingTuple (One _) = One Nothing + genNothingTuple (Tup xs) = Tup $ map genNothingTuple xs +transformNodeListToFormalParameters :: [Node] -> [FormalParameter InitSemInf] +transformNodeListToFormalParameters ns = concatMap transformNodeToFormalParameter ns + +transformNodeListToLocalDeclarations :: [Node] -> [LocalDeclaration InitSemInf] +transformNodeListToLocalDeclarations ns = concatMap transformNodeToLocalDeclaration ns + -- Transforms a node and its subgraphs (if any) to an imperative program. -transformNodeToProgram :: (Node, [Hierarchy]) -> Program +transformNodeToProgram :: (Node, [Hierarchy]) -> Program InitSemInf 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) + Graph.Input -> Program (EmptyProgram $ Empty ()) () + Array _ -> Program (EmptyProgram $ Empty ()) () + Function s -> Program { + programConstruction = PrimitiveProgram $ Primitive { + primitiveInstruction = (ProcedureCallInstruction $ ProcedureCall { + procedureCallData = ProcedureCallData { + nameOfProcedureToCall = s, + actualParametersOfProcedureToCall = passInArgs (input n) (inputType n) ++ + passOutArgs (nodeId n) (outputType n) + }, + procedureCallSemInf = () + }), + primitiveSemInf = False + }, + programSemInf = () + } -- 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) + NoInline s ifc -> Program { + programConstruction = PrimitiveProgram $ Primitive { + primitiveInstruction = (ProcedureCallInstruction $ ProcedureCall { + procedureCallData = ProcedureCallData { + nameOfProcedureToCall = s, + actualParametersOfProcedureToCall = passInArgs (input n) (inputType n) ++ + passOutArgs (nodeId n) (outputType n) + }, + procedureCallSemInf = () + }), + primitiveSemInf = False + }, + programSemInf = () + } -- 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 + 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 + | otherwise -> Program { + programConstruction = BranchProgram $ Branch { + branchData = BranchData { + branchConditionVariable = condVar, + thenBlock = mkBranch n thenIfc thenH, + elseBlock = mkBranch n elseIfc elseH + }, + branchSemInf = () + }, + programSemInf = () + } 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) - []) + mkBranch :: Node -> Interface -> Hierarchy -> Block InitSemInf + mkBranch n ifc h@(Hierarchy pairs) = Block { + blockData = BlockData { + blockDeclarations = (transformNodeListToLocalDeclarations $ map fst pairs), + blockInstructions = Program { + programConstruction = SequenceProgram $ Sequence { + sequenceProgramList = (copyResult inp (interfaceInput ifc) inTyp False + ++ transformNodeListToPrograms pairs + ++ copyResult (interfaceOutput ifc) (nodeId n) (outputType n) True), + sequenceSemInf = () + }, + programSemInf = () + } + }, + blockSemInf = () + } condVar = case cond of - One (Variable (id,path)) -> Var (varName id path) Normal Feldspar.Compiler.Imperative.Representation.BoolType + One (Graph.Variable (id,path)) -> + Representation.Variable (VariableData Value Representation.BoolType (varName id path)) () _ -> 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" @@ -204,47 +244,71 @@ -- 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 + While condIfc bodyIfc -> Program { + programConstruction = SequenceProgram $ Sequence { + sequenceProgramList = + (copyResult (input n) (nodeId n) (outputType n) True ++ + [Program { + programConstruction = SequentialLoopProgram $ SequentialLoop { + sequentialLoopData = SequentialLoopData { + sequentialLoopCondition = (case interfaceOutput condIfc of + One (Graph.Variable (id,path)) -> varToExpr $ Representation.Variable (VariableData Value Representation.BoolType (varName id path)) () + _ -> error "Error in a while loop: Malformed interface output of condition calculation." + -- TODO: should this hold? + ), + conditionCalculation = Block { + blockData = BlockData { + blockDeclarations = (transformNodeListToLocalDeclarations condNodes), + blockInstructions = Program { + programConstruction = (SequenceProgram (Sequence (copyStateToCond ++ calculationCond) ())), + programSemInf = () + } + }, + blockSemInf = () + }, + sequentialLoopCore = Block { + blockData = BlockData { + blockDeclarations = (transformNodeListToLocalDeclarations bodyNodes), + blockInstructions = Program { + programConstruction = (SequenceProgram (Sequence (copyStateToBody ++ calculationBody ++ copyResultToState) ())), + programSemInf = () + } + }, + blockSemInf = () + } + }, + sequentialLoopSemInf = () + }, + programSemInf = () + } + ]), + sequenceSemInf = () + }, + programSemInf = () + } + 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 + calculationCond = transformNodeListToPrograms condHier copyStateToBody = copyNode (nodeId n) (interfaceInput bodyIfc) (outputType n) False - calculationBody = transformNodeListToPrograms bodyHier + 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 + Parallel ifc -> + Program { + programConstruction = ParallelLoopProgram (ParallelLoop (ParallelLoopData + (Representation.Variable (VariableData Value (Numeric ImpSigned S32) (varName inpId [])) ()) num 1 prg + ) ()), + programSemInf = () + } where num = case (input n, inputType n) of (One inp, One intyp) -> transformSourceToExpr inp intyp otherwise -> error "Invalid input of a Parallel node." @@ -252,44 +316,71 @@ [(Hierarchy hist)] -> hist _ -> error "More than one Hierarchy in a Parallel construct" isInp (node,hs) = case (function node) of - Input -> True - _ -> False + Graph.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 + topLevelNodes = map fst notInps + declarations = concatMap transformNodeToLocalDeclaration topLevelNodes outSrc = case interfaceOutput ifc of One src -> src _ -> error "The interfaceOutput of a Parallel is not (One ...) " - outTyp = case interfaceOutputType ifc of + outTypElem = 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) - ] - ) [] --} - } + outTypArray = case outputType n of + One typ -> typ + _ -> error "The outputType of a Parallel is not (One ...) " + outTypArrayImp = compileStorableType outTypArray + outTypElemImp = compileStorableType outTypElem + prg = Block { + blockData = BlockData { + blockDeclarations = declarations, + blockInstructions = Program { + programConstruction = SequenceProgram $ Sequence { + sequenceProgramList = map transformNodeToProgram notInps ++ + [ Program { + programConstruction = PrimitiveProgram $ Primitive { + primitiveInstruction = makeCopyFromExprs + (transformSourceToExpr outSrc outTypElem) + (LeftValueExpression $ LeftValueInExpression { + leftValueExpressionContents = ArrayElemReferenceLeftValue $ ArrayElemReference { + arrayElemReferenceData = ArrayElemReferenceData { + arrayName = VariableLeftValue $ VariableInLeftValue { + variableLeftValueContents = Representation.Variable { + variableData = VariableData { + variableRole = Value, + variableType = outTypArrayImp, + variableName = (varName (nodeId n) []) + }, + variableSemInf = () + }, + variableLeftValueSemInf = () + }, + arrayIndex = (genVar inpId [] intType) + }, + arrayElemReferenceSemInf = () + }, + leftValueExpressionSemInf = () + }), + primitiveSemInf = True + }, + programSemInf = () + } ], + sequenceSemInf = () + }, + programSemInf = () + } + }, + blockSemInf = () + } -transformNodeListToPrograms :: [(Node, [Hierarchy])] -> [Program] +transformNodeListToPrograms :: [(Node, [Hierarchy])] -> [Program InitSemInf] 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 @@ -304,8 +395,17 @@ 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 +genVar :: NodeId -> [Int] -> Type -> Expression InitSemInf +genVar id path typ = LeftValueExpression $ LeftValueInExpression { + leftValueExpressionContents = VariableLeftValue $ VariableInLeftValue { + variableLeftValueContents = Representation.Variable { + variableData = VariableData { variableRole = Value, variableType = typ, variableName = (varName id path) }, + variableSemInf = () + }, + variableLeftValueSemInf = () + }, + leftValueExpressionSemInf = () +} -- Prefix of output parameters outPrefix :: String @@ -316,23 +416,37 @@ outName path = outPrefix ++ varPath path -- Generates an output variable -genOut :: [Int] -> Type -> UntypedExpression -genOut path typ = LeftExpr $ LVar $ Var (outName path) OutKind typ +genOut :: [Int] -> Type -> Expression InitSemInf +genOut path typ =LeftValueExpression $ LeftValueInExpression { + leftValueExpressionContents = VariableLeftValue $ VariableInLeftValue { + variableLeftValueContents = Representation.Variable { + variableData = VariableData { variableRole = FunOut, variableType = typ, variableName = (outName path) }, + variableSemInf = () + }, + variableLeftValueSemInf = () + }, + leftValueExpressionSemInf = () +} -- Generates input parameters of a function call from the node input. -passInArgs :: Tuple Source -> Tuple StorableType -> [Parameter] +passInArgs :: Tuple Source -> Tuple StorableType -> [ActualParameter InitSemInf] 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 + genArg _ (Constant primData, StorableType _ typ) = InputActualParameter $ InputActualParameterType { + inputActualParameterExpression = compilePrimData primData typ, + inputActualParameterSemInf = () + } + genArg _ (Graph.Variable (id, path), typ) = InputActualParameter $ InputActualParameterType { + inputActualParameterExpression = genVar id path (compileStorableType typ), + inputActualParameterSemInf = () + } -- Generates output parameters of a function call from the node id and output type. -passOutArgs :: NodeId -> Tuple StorableType -> [Parameter] +passOutArgs :: NodeId -> Tuple StorableType -> [ActualParameter InitSemInf] passOutArgs id typs = tupleWalk genArg typs where - genArg path t = Out (Normal,Expr (genVar id path ctyp) $ ctyp) - where - ctyp = compileStorableType t + genArg path t = OutputActualParameter $ OutputActualParameterType { + outputActualParameterLeftValue = toLeftValue $ genVar id path (compileStorableType t), + outputActualParameterSemInf = () + } ------------------------------------------------- -- Compilation of type and data representation -- @@ -342,94 +456,134 @@ compileStorableType :: StorableType -> Type compileStorableType (StorableType dims elemTyp) = case dims of [] -> compilePrimitiveType elemTyp - (d:ds) -> ImpArrayType (Just d) $ compileStorableType $ StorableType ds elemTyp + (d:ds) -> ImpArrayType (getLength $ upperBound d) $ compileStorableType $ StorableType ds elemTyp +getLength (Just i) = Norm i +getLength _ = Undefined + -- 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! + UnitType -> Representation.BoolType + CoreTypes.BoolType -> Representation.BoolType + IntType True 8 _ -> Numeric ImpSigned S8 + IntType True 16 _ -> Numeric ImpSigned S16 + IntType True 32 _ -> Numeric ImpSigned S32 + IntType True 64 _ -> Numeric ImpSigned S64 + IntType False 8 _ -> Numeric ImpUnsigned S8 + IntType False 16 _ -> Numeric ImpUnsigned S16 + IntType False 32 _ -> Numeric ImpUnsigned S32 + IntType False 64 _ -> Numeric ImpUnsigned S64 + IntType sig size _ -> handleError "GraphToImperative" InvariantViolation $ "unknown integer type: IntType" ++ (show sig) ++ " " ++ (show size) + CoreTypes.FloatType x -> 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 +compileStorableDataToConst :: StorableData -> Constant InitSemInf +compileStorableDataToConst (CoreTypes.PrimitiveData pd) = compilePrimDataToConst pd +compileStorableDataToConst (StorableData ds) = ArrayConstant $ ArrayConstantType (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 +compilePrimDataToConst :: CoreTypes.PrimitiveData -> Constant InitSemInf +compilePrimDataToConst (UnitData ()) = BoolConstant $ BoolConstantType False () +compilePrimDataToConst (BoolData x) = BoolConstant $ BoolConstantType x () +compilePrimDataToConst (IntData x) = IntConstant $ IntConstantType (fromInteger x) () +compilePrimDataToConst (FloatData x) = FloatConstant $ FloatConstantType 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 +compileStorableData :: StorableData -> StorableType -> Expression InitSemInf +compileStorableData (CoreTypes.PrimitiveData pd) (StorableType _ elemTyp) = compilePrimData pd elemTyp +compileStorableData a@(StorableData ds) typ = (ConstantExpression $ compileStorableDataToConst a) -- Transforms a primitive data to an imperative typed expression. -compilePrimData :: PrimitiveData -> PrimitiveType -> ImpLangExpr -compilePrimData d t = Expr (ConstExpr $ compilePrimDataToConst d) $ compilePrimitiveType t +compilePrimData :: CoreTypes.PrimitiveData -> PrimitiveType -> Expression InitSemInf +compilePrimData d t = ConstantExpression $ compilePrimDataToConst d charType = Numeric ImpSigned S8 intType = Numeric ImpSigned S32 -- Transforms a Source to an imperative expression. -transformSourceToExpr :: Source -> StorableType -> ImpLangExpr +transformSourceToExpr :: Source -> StorableType -> Expression InitSemInf transformSourceToExpr (Constant primData) (StorableType _ typ) = compilePrimData primData typ -transformSourceToExpr (Variable (id,path)) typ = Expr (genVar id path ctyp) $ ctyp +transformSourceToExpr (Graph.Variable (id,path)) typ = genVar id path ctyp where ctyp = compileStorableType typ -- Generates a copy call from variable ids and types. -makeCopyFromIds :: (NodeId,[Int],StorableType) -> (NodeId,[Int],StorableType) -> Instruction +makeCopyFromIds :: (NodeId,[Int],StorableType) -> (NodeId,[Int],StorableType) -> Instruction InitSemInf makeCopyFromIds (idFrom,pathFrom,typeFrom) (idTo,pathTo,typeTo) = makeCopyFromExprs - (Expr (genVar idFrom pathFrom ctypFrom) ctypFrom) - (Expr (genVar idTo pathTo ctypTo) ctypTo) + (genVar idFrom pathFrom ctypFrom) + (genVar idTo pathTo 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)] +makeCopyFromExprs :: Expression InitSemInf -> Expression InitSemInf -> Instruction InitSemInf +makeCopyFromExprs from to = ProcedureCallInstruction $ + ProcedureCall { + procedureCallData = ProcedureCallData "copy" [InputActualParameter $ InputActualParameterType { + inputActualParameterExpression = from, + inputActualParameterSemInf = () + }, + OutputActualParameter $ OutputActualParameterType { + outputActualParameterLeftValue = (toLeftValue to), + outputActualParameterSemInf = () + }], + procedureCallSemInf = () + } -- Generates copies for all variables of a node to all variables of another node. -copyNode :: NodeId -> NodeId -> Tuple StorableType -> Bool -> [Program] +copyNode :: NodeId -> NodeId -> Tuple StorableType -> Bool -> [Program InitSemInf] copyNode fromId toId typeStructure isOutputCopying = tupleWalk (\path typ -> - Primitive - (makeCopyFromIds (fromId,path,typ) (toId,path,typ)) - (SemInfPrim Map.empty isOutputCopying) + Program { + programConstruction = PrimitiveProgram (Primitive { + primitiveInstruction = (makeCopyFromIds (fromId,path,typ) (toId,path,typ)), + primitiveSemInf = isOutputCopying + }), + programSemInf = () + } ) typeStructure -- Generates copies from sources to all variables of a node. -copyResult :: Tuple Source -> NodeId -> Tuple StorableType -> Bool -> [Program] +copyResult :: Tuple Source -> NodeId -> Tuple StorableType -> Bool -> [Program InitSemInf] 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 + Program { + programConstruction = PrimitiveProgram (Primitive { + primitiveInstruction = (makeCopyFromExprs (transformSourceToExpr out typ) (genVar nid path $ compileStorableType typ)), + primitiveSemInf = isOutputCopying + }), + programSemInf = () + } ) (tupleZip (ifcOut, outTyp)) -- Generates copies from sources to output variables. -copyToOutput :: Tuple Source -> Tuple StorableType -> Bool -> [Program] +copyToOutput :: Tuple Source -> Tuple StorableType -> Bool -> [Program InitSemInf] 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 + Program { + programConstruction = PrimitiveProgram (Primitive { + primitiveInstruction = (makeCopyFromExprs (transformSourceToExpr out typ) (genOut path $ compileStorableType typ)), + primitiveSemInf = isOutputCopying + }), + programSemInf = () + } ) (tupleZip (ifcOut, outTyp)) + + +varToExpr :: Representation.Variable InitSemInf -> Expression InitSemInf +varToExpr v = + LeftValueExpression + (LeftValueInExpression + (VariableLeftValue $ + VariableInLeftValue v() ) + () + ) diff --git a/Feldspar/Compiler/Transformation/GraphUtils.hs b/Feldspar/Compiler/Transformation/GraphUtils.hs --- a/Feldspar/Compiler/Transformation/GraphUtils.hs +++ b/Feldspar/Compiler/Transformation/GraphUtils.hs @@ -1,34 +1,4 @@ -{- - - 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 FlexibleInstances, TypeSynonymInstances #-} module Feldspar.Compiler.Transformation.GraphUtils ( tupleWalk @@ -41,6 +11,7 @@ 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 @@ -71,7 +42,7 @@ 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 (Parallel ifc) = (Parallel (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 diff --git a/Feldspar/Compiler/Transformation/Lifting.hs b/Feldspar/Compiler/Transformation/Lifting.hs --- a/Feldspar/Compiler/Transformation/Lifting.hs +++ b/Feldspar/Compiler/Transformation/Lifting.hs @@ -1,34 +1,4 @@ -{- - - 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 FlexibleInstances #-} module Feldspar.Compiler.Transformation.Lifting where @@ -121,7 +91,7 @@ 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 (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 diff --git a/Feldspar/Fs2dot.hs b/Feldspar/Fs2dot.hs --- a/Feldspar/Fs2dot.hs +++ b/Feldspar/Fs2dot.hs @@ -1,35 +1,3 @@ -{- - - 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. @@ -42,7 +10,7 @@ import Feldspar.Core.Types import Feldspar.Core.Graph -import Feldspar.Core.Expr (toGraph, Program) +import Feldspar.Core.Reify (reify, Program) import Prelude hiding (id) {- frontend -} @@ -52,7 +20,7 @@ fs2dot :: (Program prg) => prg -- ^Feldspar function -> DOTSource -- ^DOT language source -fs2dot = toDot . fromGraph . makeHierarchical . toGraph +fs2dot = toDot . fromGraph . makeHierarchical . reify -- |'writeDot' creates a DOT language format source file. Expected arguments -- are the desired filename and the Feldspar function to be output in DOT @@ -248,7 +216,7 @@ fun2label (NoInline str ifc) = "NoInLine " ++ (show str) fun2label (IfThenElse ifc1 ifc2) = "IfThenElse" fun2label (While ifc1 ifc2) = "While" -fun2label (Parallel i ifc) = "Parallel " ++ (show i) +fun2label (Parallel ifc) = "Parallel" -- ++ (show i) {- utility functions -} diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright (c) 2009, ERICSSON AB +Copyright (c) 2009-2010, ERICSSON AB All rights reserved. Redistribution and use in source and binary forms, with or without diff --git a/feldspar-compiler.cabal b/feldspar-compiler.cabal --- a/feldspar-compiler.cabal +++ b/feldspar-compiler.cabal @@ -1,10 +1,10 @@ name: feldspar-compiler -version: 0.1 -cabal-version: >= 1.2 +version: 0.2 +cabal-version: >= 1.2.3 build-type: Simple license: BSD3 license-file: LICENSE -copyright: Copyright (c) 2009, ERICSSON AB +copyright: Copyright (c) 2009-2010, ERICSSON AB author: Feldspar group, Eotvos Lorand University Faculty of Informatics maintainer: deva@inf.elte.hu @@ -19,32 +19,54 @@ language both according to ANSI C and also targeted to a real DSP HW. category: Compiler -tested-with: GHC==6.10.4 +tested-with: GHC==6.10.* library exposed-modules: + Feldspar.Compiler.Imperative.CodeGeneration Feldspar.Compiler.Imperative.Representation - Feldspar.Compiler.Optimization.PrimitiveInstructions - Feldspar.Compiler.Optimization.Replace - Feldspar.Compiler.Optimization.Simplification - Feldspar.Compiler.Optimization.Unroll + Feldspar.Compiler.Imperative.Semantics + Feldspar.Compiler.PluginArchitecture.DefaultConvert + Feldspar.Compiler.Plugins.BackwardPropagation + Feldspar.Compiler.Plugins.ConstantFolding + Feldspar.Compiler.Plugins.ForwardPropagation + Feldspar.Compiler.Plugins.HandlePrimitives + Feldspar.Compiler.Plugins.Precompilation + Feldspar.Compiler.Plugins.PrettyPrint + Feldspar.Compiler.Plugins.PropagationUtils + Feldspar.Compiler.Plugins.Unroll Feldspar.Compiler.Precompiler.Precompiler Feldspar.Compiler.Transformation.GraphToImperative Feldspar.Compiler.Transformation.GraphUtils Feldspar.Compiler.Transformation.Lifting Feldspar.Compiler.Compiler + Feldspar.Compiler.Error Feldspar.Compiler.Options + Feldspar.Compiler.PluginArchitecture Feldspar.Compiler Feldspar.Fs2dot build-depends: - feldspar-language, base >= 3 && < 4, containers, directory, filepath, - haskell-src-exts, hint, mtl, process + feldspar-language == 0.2, + base >= 4.0 && < 4.2, + containers, + haskell-src-exts, + directory, + filepath, + hint, + MonadCatchIO-mtl, + mtl, + process extensions: + EmptyDataDecls + FlexibleContexts FlexibleInstances + MultiParamTypeClasses + Rank2Types + TypeFamilies TypeSynonymInstances - NoMonomorphismRestriction + UndecidableInstances include-dirs: ./Feldspar/C @@ -58,8 +80,13 @@ extensions: CPP + EmptyDataDecls + FlexibleContexts FlexibleInstances + MultiParamTypeClasses + Rank2Types + TypeFamilies TypeSynonymInstances - NoMonomorphismRestriction + UndecidableInstances cpp-options: -DRELEASE