packages feed

feldspar-compiler (empty) → 0.1

raw patch · 19 files changed

+3317/−0 lines, 19 filesdep +basedep +containersdep +directorysetup-changed

Dependencies added: base, containers, directory, feldspar-language, filepath, haskell-src-exts, hint, mtl, process

Files

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