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