packages feed

feldspar-compiler 0.4.0.2 → 0.5.0.1

raw patch · 57 files changed

+4786/−2587 lines, 57 filesdep +syntacticdep ~feldspar-languagesetup-changed

Dependencies added: syntactic

Dependency ranges changed: feldspar-language

Files

Feldspar/C/feldspar_array.c view
@@ -1,72 +1,61 @@+//+// Copyright (c) 2009-2011, 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_array.h" #include <string.h>--/* Deep array copy */-void copyArray(struct array *to, struct array from)-{-    to->length = from.length;-    to->elemSize = from.elemSize;-    if( from.elemSize == (-1) )-    {-        unsigned i;-        for( i = 0; i < from.length; ++i )-            copyArray( &at(struct array, *to, i), at(struct array, from, i) );-    }-    else-    {-        memcpy( to->buffer, from.buffer, from.length * from.elemSize );-    }-}--/* Deep array copy to a given position */-void copyArrayPos(struct array *to, unsigned pos, struct array from)-{-    to->length = pos + from.length;-    to->elemSize = from.elemSize;-    if( from.elemSize == (-1) )-    {-        unsigned i;-        for( i = 0; i < from.length; ++i )-            copyArray( &at(struct array, *to, i + pos), at(struct array, from, i) );-    }-    else-    {-        memcpy( (char*)(to->buffer) + pos * from.elemSize, from.buffer, from.length * from.elemSize );-    }-}+#include <assert.h>+#include <stdio.h>  /* Deep array copy with a given length */-void copyArrayLen(struct array *to, struct array from, unsigned len)+void copyArrayLen(struct array *to, struct array *from, int32_t len) {-    to->length = len;-    to->elemSize = from.elemSize;-    if( from.elemSize == (-1) )+    assert(to);+    assert(from);+    if( from->elemSize < 0 )     {         unsigned i;         for( i = 0; i < len; ++i )-            copyArray( &at(struct array, *to, i), at(struct array, from, i) );+            copyArray( &at(struct array, to, i), &at(struct array, from, i) );     }     else     {-        memcpy( to->buffer, from.buffer, len * from.elemSize );+        assert(to->buffer);+        assert(from->buffer);+        memcpy( to->buffer, from->buffer, len * from->elemSize );     } } -/* Array length */-unsigned length(struct array arr)-{-    return arr.length;-} -/* (Re)set array length */-void setLength(struct array *arr, unsigned len)-{-    arr->length = len;-}- /* Reset array length by increasing it */-void increaseLength(struct array *arr, unsigned len)+void increaseLength(struct array *arr, int32_t len) {+    assert(arr);+    assert(arr->bytes >= abs(arr->elemSize) * (len + arr->length));     arr->length += len; }
Feldspar/C/feldspar_array.h view
@@ -1,33 +1,112 @@+//+// Copyright (c) 2009-2011, 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_ARRAY_H #define FELDSPAR_ARRAY_H +#include <stdint.h>+#include <string.h>+#include <assert.h>+#include <stdlib.h>++// TODO qualify the names to avoid clashes with Haskell names+ struct array {-    void* buffer;       /* pointer to the buffer of elements */-    unsigned int length;    /* number of elements in the array */-    int elemSize;       /* size of elements in bytes; (-1) for nested arrays */+    void*    buffer;   /* pointer to the buffer of elements */+    int32_t  length;   /* number of elements in the array */+    int32_t  elemSize; /* size of elements in bytes; (- sizeof(struct array)) for nested arrays */+    uint32_t bytes;    /* The number of bytes the buffer can hold */ }; +/* Indexing into an array: */+/* Result: element of type 'type' */+#define at(type,arr,idx) (((type*)((arr)->buffer))[idx])++ /* Deep array copy */-void copyArray(struct array *to, struct array from);+static inline void copyArray(struct array *to, struct array *from)+{+    assert(to);+    assert(from);+    if( from->elemSize < 0 )+    {+        unsigned i;+        for( i = 0; i < from->length; ++i )+            copyArray( &at(struct array, to, i), &at(struct array, from, i) );+    }+    else+    {+        assert(to->buffer);+        assert(from->buffer);+        memcpy( to->buffer, from->buffer, to->length * to->elemSize );+    }+}  /* Deep array copy to a given position */-void copyArrayPos(struct array *to, unsigned pos, struct array from);+static inline void copyArrayPos(struct array *to, unsigned pos, struct array *from)+{+    assert(to);+    assert(from);+    if( from->elemSize < 0 )+    {+        unsigned i;+        for( i = 0; i < from->length; ++i )+            copyArray( &at(struct array, to, i + pos), &at(struct array, from, i) );+    }+    else+    {+        assert(to->buffer);+        assert(from->buffer);+        memcpy( (char*)(to->buffer) + pos * to->elemSize, from->buffer, to->length * to->elemSize );+    }+} + /* Deep array copy with a given length */-void copyArrayLen(struct array *to, struct array from, unsigned len);+void copyArrayLen(struct array *to, struct array *from, int32_t len);  /* Array length */-unsigned length(struct array arr);+static inline int32_t getLength(struct array *arr)+{+  assert(arr);+  return arr->length;+}  /* (Re)set array length */-void setLength(struct array *arr, unsigned len);+static inline void setLength(struct array *arr, int32_t len)+{+  assert(arr);+  assert(arr->bytes >= arr->length * abs(arr->elemSize));+  arr->length = len;+}  /* Reset array length by increasing it */-void increaseLength(struct array *arr, unsigned len);--/* Indexing into an array: */-/* Result: element of type 'type' */-#define at(type,arr,idx) (((type*)((arr).buffer))[idx])+void increaseLength(struct array *arr, int32_t len);  #endif
Feldspar/C/feldspar_c99.c view
@@ -1,3 +1,31 @@+//+// Copyright (c) 2009-2011, 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_c99.h"  #include <stdint.h>@@ -1708,7 +1736,7 @@         tv.tv_sec = tv.tv_sec - trace_start_time.tv_sec - 1;         tv.tv_usec = 1000000 + tv.tv_usec - trace_start_time.tv_usec;     }-    sprintf(str, "%ld.%06ld", tv.tv_sec, tv.tv_usec);+    sprintf(str, "%ld.%06d", tv.tv_sec, tv.tv_usec); }  #endif /* WIN32 */
Feldspar/C/feldspar_c99.h view
@@ -1,3 +1,31 @@+//+// Copyright (c) 2009-2011, 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_C99_H #define FELDSPAR_C99_H @@ -5,6 +33,9 @@ #include <complex.h>  ++#define min(X, Y)  ((X) < (Y) ? (X) : (Y))+#define max(X, Y)  ((X) > (Y) ? (X) : (Y))  int8_t pow_fun_int8( int8_t, int8_t ); int16_t pow_fun_int16( int16_t, int16_t );
Feldspar/C/feldspar_tic64x.c view
@@ -1,3 +1,31 @@+//+// Copyright (c) 2009-2011, 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_tic64x.h"  #include <stdio.h>
Feldspar/C/feldspar_tic64x.h view
@@ -1,3 +1,31 @@+//+// Copyright (c) 2009-2011, 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_TI_C64X_H #define FELDSPAR_TI_C64X_H
Feldspar/Compiler.hs view
@@ -1,18 +1,44 @@+--+-- Copyright (c) 2009-2011, 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'-    , icompileWithInfos_  -    , getProgram-    , forPrg-    , ifPrg-    , switchPrg-    , assignPrg -    , defaultOptions+    ( defaultOptions     , c99PlatformOptions     , tic64xPlatformOptions     , unrollOptions     , noPrimitiveInstructionHandling+    , noMemoryInformation+    , module Feldspar.Compiler.Frontend.Interactive.Interface+    , module Feldspar.Compiler.Backend.C.Options+    , module Feldspar.Compiler.Imperative.Frontend     ) where  import Feldspar.Compiler.Compiler+import Feldspar.Compiler.Frontend.Interactive.Interface+import Feldspar.Compiler.Backend.C.Options -- hiding (Var, Fun)+import Feldspar.Compiler.Imperative.Frontend hiding (Type)
Feldspar/Compiler/Backend/C/CodeGeneration.hs view
@@ -1,3 +1,31 @@+--+-- Copyright (c) 2009-2011, 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.Backend.C.CodeGeneration where@@ -6,6 +34,7 @@ import Feldspar.Compiler.Error import Feldspar.Compiler.Backend.C.Options import Feldspar.Compiler.Backend.C.Library+import Feldspar.Compiler.Backend.C.Plugin.AllocationEliminator  import qualified Data.List as List (last,find) @@ -41,29 +70,25 @@ getStructTypeName :: Options -> Place -> Type -> String getStructTypeName options place t@(StructType types) =     "_" ++ concat (map ((++"_") . getStructTypeName options place . snd) types)-getStructTypeName options place t@(UnionType types) =-    "_" ++ concat (map ((++"_") . getStructTypeName options place . snd) types) getStructTypeName options place t@(ArrayType len innerType) =      "arr_T" ++ getStructTypeName options place innerType ++ "_S" ++ len2str len     where         len2str :: Length -> String         len2str UndefinedLen = "UD"         len2str (LiteralLen i) = show i-        len2str (IndirectLen s) = s getStructTypeName options place t = replace (toC options place t) " " "" -- float complex -> floatcomplex  instance ToC Type where+    toC options place VoidType = "void"     toC options place t@(StructType types) = "struct s" ++ getStructTypeName options place t-    toC options place t@(UnionType types) = "union u" ++ getStructTypeName options place t     toC options place (UserType u) = u-    toC options place VoidType = "void"     -- arraytype handled in variable     toC options place t = case (List.find (\(t',_,_) -> t == t') $ types $ platform options) of         Just (_,s,_)  -> s         Nothing       -> codeGenerationError InternalError $                          "Unhandled type in platform " ++ (name $ platform options) ++ ": " ++ show t ++ " place: " ++ show place -instance ToC (Variable ()) where+instance ToC (Variable AllocationEliminatorSemanticInfo) where     toC options place a@(Variable name typ role _) = show_variable options place role typ name  show_variable :: Options -> Place -> VariableRole -> Type -> String -> String@@ -74,16 +99,20 @@         | otherwise = NoRestrict  show_type :: Options -> Place -> Type -> IsRestrict -> String-show_type options Declaration_pl (ArrayType s t) restr = codeGenerationError InternalError $ "Array allocation is not allowed."-show_type options MainParameter_pl (ArrayType s t) restr = "struct array"+show_type options Declaration_pl (ArrayType s t) restr = arrayTypeName+show_type options MainParameter_pl (ArrayType s t) restr = arrayTypeName show_type options Declaration_pl t _ = toC options Declaration_pl t show_type options MainParameter_pl t _ = toC options MainParameter_pl t show_type options _ _ _ = "" +arrayTypeName = "struct array"+ show_name :: VariableRole -> Place -> Type -> String  -> String show_name Value place t n     | place == AddressNeed_pl = "&" ++ n     | otherwise = n+show_name Pointer MainParameter_pl (ArrayType _ _) n = "* " ++ n+show_name Pointer p (ArrayType _ _) n = n show_name Pointer place t n     | place == AddressNeed_pl && List.last n == ']' = "&" ++ n     | place == AddressNeed_pl && List.last n /= ']' = n@@ -102,45 +131,6 @@ -- genIndex _ = ""  -------------------------   Type           ---------------------------class HasType a where-    typeof :: a -> Type--instance HasType (Variable t) where-    typeof (Variable r t s _) = t    --instance (ShowLabel t) => HasType (Constant t) where-    typeof (IntConst _ _ _) = NumType Signed S32-    typeof (FloatConst _ _ _) = FloatType-    typeof (BoolConst _ _ _) = BoolType-    typeof (ComplexConst r i _ _) = ComplexType (typeof r)-    typeof arr@(ArrayConst l _ _) = ArrayType (LiteralLen $ length l) elemtype-        where-            elemtype = case l of-                []  -> codeGenerationError InternalError $ "Const array with 0 elements: " ++ show arr-                _   -> checktype (typeof $ head l) (map typeof 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 (ShowLabel t) => HasType (Expression t) where-    typeof (VarExpr v _) = typeof v-    typeof (ArrayElem n i _ _) = decrArrayDepth (typeof n)-    typeof (StructField s f _ _) = getStructFieldType f (typeof s)-    typeof (ConstExpr c _) = typeof c-    typeof (FunctionCall f t r p _ _) = t-    typeof (Cast t e _ _) = t-    typeof (SizeOf s _ _) = NumType Signed S32--instance (ShowLabel t) => HasType (ActualParameter t) where-    typeof (In e _) = typeof e-    typeof (Out l _) = typeof l------------------------ -- Helper functions -- ---------------------- @@ -148,19 +138,20 @@ 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 f s xs = listprint' s $ filter (\a -> a /= "") $ map f xs where     listprint' _ [] = ""     listprint' _ [x] = x     listprint' s (x:xs) = x ++ s ++ listprint' s (xs)  decrArrayDepth :: Type -> Type decrArrayDepth (ArrayType _ t) = t-decrArrayDepth _ = codeGenerationError InternalError "Non-array variable is indexed!"+decrArrayDepth t = codeGenerationError InternalError $ "Non-array variable of type " ++ show t ++ " is indexed!"  getStructFieldType :: String -> Type -> Type getStructFieldType f (StructType l) = case List.find (\(a,_) -> a == f) l of     Just (_,t) -> t     Nothing -> structFieldNotFound f-getStructFieldType f t = codeGenerationError InternalError $ "Trying to get a struct field from not a struct typed expression\n" ++ "Field: " ++ f ++ "\nType:  " ++ show t+getStructFieldType f t = codeGenerationError InternalError $+    "Trying to get a struct field from not a struct typed expression\n" ++ "Field: " ++ f ++ "\nType:  " ++ show t  structFieldNotFound f = codeGenerationError InternalError $ "Not found struct field with this name: " ++ f
Feldspar/Compiler/Backend/C/Library.hs view
@@ -1,13 +1,45 @@+--+-- Copyright (c) 2009-2011, 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.Backend.C.Library     (module System.Console.ANSI,      module Feldspar.Compiler.Backend.C.Library) where  import Control.Monad.State import System.Console.ANSI+import System.FilePath+import qualified Feldspar.Compiler.Imperative.Representation as AIR  data CompilationMode = Interactive | Standalone     deriving (Show, Eq) +type AllocationInfo = ([AIR.Type],[AIR.Type],[AIR.Type])+     -- =========================================================================== --  == String tools -- ===========================================================================@@ -19,6 +51,18 @@  fixFunctionName :: String -> String fixFunctionName functionName = replace (replace functionName "_" "__") "'" "_prime"++makeDebugHFileName :: String -> String+makeDebugHFileName = (<.> "h.dbg.txt")++makeDebugCFileName :: String -> String+makeDebugCFileName = (<.> "c.dbg.txt")++makeHFileName :: String -> String+makeHFileName = (<.> "h")++makeCFileName :: String -> String+makeCFileName = (<.> "c")  -- =========================================================================== --  == Name generator
Feldspar/Compiler/Backend/C/Options.hs view
@@ -1,83 +1,66 @@+--+-- Copyright (c) 2009-2011, 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 TypeSynonymInstances #-}  module Feldspar.Compiler.Backend.C.Options where +import Data.Typeable  import Feldspar.Compiler.Imperative.Representation-+import Feldspar.Compiler.Imperative.Frontend hiding (UserType, Type, Var)+import Feldspar.Compiler.Backend.C.Plugin.AllocationEliminator  data Options =     Options     { platform          :: Platform     , unroll            :: UnrollStrategy     , debug             :: DebugOption-    , defaultArraySize  :: Int+    , memoryInfoVisible :: Bool+    , rules             :: [Rule]     } deriving (Eq, Show) - data UnrollStrategy = NoUnroll | Unroll Int     deriving (Eq, Show) - data DebugOption = NoDebug | NoPrimitiveInstructionHandling     deriving (Eq, Show) -- data Platform = Platform {-    name        :: String,-    types       :: [(Type, String, String)],-    values      :: [(Type, ShowValue)],-    primitives  :: [(FeldPrimDesc, Either CPrimDesc TransformPrim)],-    includes    :: [String],-    isRestrict  :: IsRestrict-} deriving (Eq, Show)---data FeldPrimDesc = FeldPrimDesc {-    fName   :: String,-    inputs  :: [TypeDesc]-} deriving (Eq, Show)---data CPrimDesc = Op1 {-    cOp         :: String-} | Op2 {-    cOp         :: String-} | Fun {-    cName       :: String,-    funPf       :: FunPostfixDescr-} | Proc {-    cName       :: String,-    funPf       :: FunPostfixDescr-} | Assig-  | Cas-  | InvalidDesc-  deriving (Eq, Show)---data TypeDesc-    = AllT-    | BoolT-    | RealT-    | FloatT-    | IntT | IntTS | IntTU | IntTS_ Size | IntTU_ Size | IntT_ Size-    | ComplexT TypeDesc-    | UserT String-  deriving (Eq, Show)---data FunPostfixDescr = FunPostfixDescr {-    useInputs   :: Int,-    useOutputs  :: Int+    name            :: String,+    types           :: [(Type, String, String)],+    values          :: [(Type, ShowValue)],+    includes        :: [String],+    platformRules   :: [Rule],+    isRestrict      :: IsRestrict } deriving (Eq, Show) -noneFP      = FunPostfixDescr 0 0-firstInFP   = FunPostfixDescr 1 0-firstOutFP  = FunPostfixDescr 0 1---type ShowValue = Constant () -> String+type ShowValue = Constant AllocationEliminatorSemanticInfo -> String  instance Eq ShowValue where     (==) _ _ = True@@ -85,60 +68,32 @@ instance Show ShowValue where     show _ = "<<ShowValue>>" --type TransformPrim-    = FeldPrimDesc-    -> [Expression ()]-    -> Type-    -> PrgDesc--instance Eq TransformPrim where-    (==) _ _ = True--instance Show TransformPrim where-    show _ = "<<TransformPrim>>"---data PrgDesc-    = PrgDesc [Crt] [Line] Rgt-  deriving (Eq, Show)--data Crt-    = Crt Type Var (Maybe Rgt)-  deriving (Eq, Show)+data IsRestrict = Restrict | NoRestrict+    deriving (Show,Eq) -data Line-    = Asg Var Rgt-    | Prc CPrimDesc [Rgt] [Var]-  deriving (Eq, Show)+-- * Actions and rules -data Rgt-    = Exp (Expression ())-    | Fnc CPrimDesc [Rgt] Type-    | VarR Var-  deriving (Eq, Show)+data Action t+    = Replace t+    | Propagate Rule+    | WithId (Int -> [Action t])+    | WithOptions (Options -> [Action t])+  deriving Typeable -data Var-    = Var String-  deriving (Eq, Show)+data Rule where+    Rule :: (Typeable t) => (t -> [Action t]) -> Rule -data IsRestrict = Restrict | NoRestrict-    deriving (Show,Eq)+instance Show Rule where+    show _ = "Transformation rule."+    +instance Eq Rule where+    _ == _ = False -machTypes :: TypeDesc -> Type -> Bool-machTypes AllT _                    = True-machTypes BoolT BoolType            = True-machTypes RealT FloatType           = True-machTypes RealT (NumType _ _)       = True-machTypes FloatT FloatType          = True-machTypes IntT (NumType _ _)        = True-machTypes IntTS (NumType Signed _)            = True-machTypes IntTU (NumType Unsigned _)          = True-machTypes (IntTS_ s) (NumType Signed s')      = s == s'-machTypes (IntTU_ s) (NumType Unsigned s')    = s == s'-machTypes (IntT_ s) (NumType _ s')            = s == s'-machTypes (ComplexT a) (ComplexType a')       = machTypes a a'-machTypes (UserT s) (UserType s')   = s == s'-machTypes _ _                       = False+rule :: (Interface t, Typeable (Repr t)) => (t -> [Action (Repr t)]) -> Rule+rule f = Rule $ \x -> f $ toInterface x +replaceWith :: (Interface t) => t -> Action (Repr t)+replaceWith = Replace . fromInterface +propagate :: (Interface t, Typeable (Repr t)) => (t -> [Action (Repr t)]) -> Action t'+propagate = Propagate . rule
Feldspar/Compiler/Backend/C/Platforms.hs view
@@ -1,23 +1,51 @@+--+-- Copyright (c) 2009-2011, 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 ViewPatterns #-}+ module Feldspar.Compiler.Backend.C.Platforms     ( availablePlatforms     , c99     , tic64x+    , c99Rules+    , tic64xRules+    , traceRules     ) where   import Feldspar.Compiler.Backend.C.Options-import Feldspar.Compiler.Imperative.Representation-import Feldspar.Compiler.Backend.C.CodeGeneration (typeof)--+import qualified Feldspar.Compiler.Backend.C.Options as Opts+import Feldspar.Compiler.Imperative.Representation hiding (Type, Cast, In, Out, Block)+import Feldspar.Compiler.Imperative.Frontend  availablePlatforms :: [Platform] availablePlatforms = [ c99, tic64x ] ---- ansiC = Platform "ansiC" undefined [] [] ["\"feldspar.h\""] NoRestrict-- c99 = Platform {     name = "c99",     types =@@ -29,165 +57,21 @@         , (NumType Unsigned S16, "uint16_t", "uint16")         , (NumType Unsigned S32, "uint32_t", "uint32")         , (NumType Unsigned S64, "uint64_t", "uint64")-        , (BoolType,  "int",    "int")+        , (BoolType,  "uint32_t",    "uint32_t") -- TODO sizeof(bool) is implementation dependent         , (FloatType, "float",  "float")-        , (ComplexType (NumType Signed S8),    "complexOf_int8",   "complexOf_int8")-        , (ComplexType (NumType Signed S16),   "complexOf_int16",  "complexOf_int16")-        , (ComplexType (NumType Signed S32),   "complexOf_int32",  "complexOf_int32")-        , (ComplexType (NumType Signed S64),   "complexOf_int64",  "complexOf_int64")-        , (ComplexType (NumType Unsigned S8),  "complexOf_uint8",  "complexOf_uint8")-        , (ComplexType (NumType Unsigned S16), "complexOf_uint16", "complexOf_uint16")-        , (ComplexType (NumType Unsigned S32), "complexOf_uint32", "complexOf_uint32")-        , (ComplexType (NumType Unsigned S64), "complexOf_uint64", "complexOf_uint64")         , (ComplexType FloatType,              "float complex",    "complexOf_float")         ] ,-    values = -        [ (ComplexType (NumType Signed S8),-              (\cx -> "complex_fun_int8(" ++ showRe cx ++ "," ++ showIm cx ++ ")"))-        , (ComplexType (NumType Signed S16),-              (\cx -> "complex_fun_int16(" ++ showRe cx ++ "," ++ showIm cx ++ ")"))-        , (ComplexType (NumType Signed S32),-              (\cx -> "complex_fun_int32(" ++ showRe cx ++ "," ++ showIm cx ++ ")"))-        , (ComplexType (NumType Signed S64),-              (\cx -> "complex_fun_int64(" ++ showRe cx ++ "," ++ showIm cx ++ ")"))-        , (ComplexType (NumType Unsigned S8),-              (\cx-> "complex_fun_uint8(" ++ showRe cx ++ "," ++ showIm cx ++ ")"))-        , (ComplexType (NumType Unsigned S16),-              (\cx -> "complex_fun_uint16(" ++ showRe cx ++ "," ++ showIm cx ++ ")"))-        , (ComplexType (NumType Unsigned S32),-              (\cx -> "complex_fun_uint32(" ++ showRe cx ++ "," ++ showIm cx ++ ")"))-        , (ComplexType (NumType Unsigned S64),-              (\cx -> "complex_fun_uint64(" ++ showRe cx ++ "," ++ showIm cx ++ ")"))-        , (ComplexType FloatType,+    values =+        [ (ComplexType FloatType,               (\cx -> "(" ++ showRe cx ++ "+" ++ showIm cx ++ "i)"))-        ] ,-    primitives =-        [ (FeldPrimDesc "(==)" [ComplexT IntT, ComplexT IntT],  Left $ Fun "equal" firstInFP)   -- Eq instanced for Bool, Int, Float, Complex (Eq.hs)-        , (FeldPrimDesc "(==)" [AllT, AllT],                    Left $ Op2 "==")-        , (FeldPrimDesc "(/=)" [ComplexT IntT, ComplexT IntT],  Left $ Fun "!equal" firstInFP)-        , (FeldPrimDesc "(/=)" [AllT, AllT],                    Left $ Op2 "!=")-        -        , (FeldPrimDesc "(<)" [RealT, RealT],   Left $ Op2 "<")                     -- Ord instanced for Int, Float (Ord.hs)-        , (FeldPrimDesc "(>)" [RealT, RealT],   Left $ Op2 ">")-        , (FeldPrimDesc "(<=)" [RealT, RealT],  Left $ Op2 "<=")-        , (FeldPrimDesc "(>=)" [RealT, RealT],  Left $ Op2 ">=")-        -        , (FeldPrimDesc "not" [BoolT],          Left $ Op1 "!")                     -- Logic operations for Bool (Logic.hs)-        , (FeldPrimDesc "(&&)" [BoolT, BoolT],  Left $ Op2 "&&")-        , (FeldPrimDesc "(||)" [BoolT, BoolT],  Left $ Op2 "||")-        -       , (FeldPrimDesc "quot" [IntT, IntT],    Left $ Op2 "/")---        , (FeldPrimDesc "quot" [IntT, IntT],    Right optimizedDivide)              -- Integral instanced for Int (Integral.hs)-            --      This optimization is invalid for odd negative numbers-        , (FeldPrimDesc "rem" [IntT, IntT],     Left $ Op2 "%")-        , (FeldPrimDesc "(^)" [IntT, IntT],     Left $ Fun "pow" firstInFP)-        -        , (FeldPrimDesc "negate" [ComplexT FloatT], Left $ Op1 "-")                 -- Num instanced for Int, Float, Complex (Num.hs)-        , (FeldPrimDesc "negate" [ComplexT IntT],   Left $ Fun "negate" firstInFP)-        , (FeldPrimDesc "negate" [RealT],           Left $ Op1 "-")-        , (FeldPrimDesc "abs" [ComplexT FloatT],    Left $ Fun "cabsf" noneFP)-        , (FeldPrimDesc "abs" [ComplexT IntT],      Left $ Fun "abs" firstInFP)-        , (FeldPrimDesc "abs" [FloatT],             Left $ Fun "fabsf" noneFP)-        , (FeldPrimDesc "abs" [IntTU],              Left Assig)---         , (FeldPrimDesc "abs" [IntTS],              Right absIntTS)-        , (FeldPrimDesc "abs" [IntTS],              Left $ Fun "abs" firstInFP)-        , (FeldPrimDesc "signum" [ComplexT RealT],  Left $ Fun "signum" firstInFP)---         , (FeldPrimDesc "signum" [RealT],           Right signumRealT)-        , (FeldPrimDesc "signum" [RealT],           Left $ Fun "signum" firstInFP)-        , (FeldPrimDesc "(+)" [ComplexT IntT, ComplexT IntT],     Left $ Fun "add" firstInFP)-        , (FeldPrimDesc "(+)" [ComplexT FloatT, ComplexT FloatT], Left $ Op2 "+")-        , (FeldPrimDesc "(+)" [RealT, RealT],                     Left $ Op2 "+")-        , (FeldPrimDesc "(-)" [ComplexT IntT, ComplexT IntT],     Left $ Fun "sub" firstInFP)-        , (FeldPrimDesc "(-)" [ComplexT FloatT, ComplexT FloatT], Left $ Op2 "-")-        , (FeldPrimDesc "(-)" [RealT, RealT],                     Right optimizedSubtract)-        , (FeldPrimDesc "(*)" [ComplexT IntT, ComplexT IntT],     Left $ Fun "mult" firstInFP)-        , (FeldPrimDesc "(*)" [ComplexT FloatT, ComplexT FloatT], Left $ Op2 "*")-        , (FeldPrimDesc "(*)" [RealT, RealT],                     Right optimizedMultiply)-        -        , (FeldPrimDesc "(/)" [ComplexT FloatT, ComplexT FloatT], Left $ Op2 "/")   -- Fractional instanced for Float, Complex Float (Fractional.hs)-        , (FeldPrimDesc "(/)" [FloatT, FloatT],                   Left $ Op2 "/")-        -        , (FeldPrimDesc "exp" [FloatT],             Left $ Fun "expf" noneFP)       -- Floating instanced for Float, Complex Float (Floating.hs)-        , (FeldPrimDesc "exp" [ComplexT FloatT],    Left $ Fun "cexpf" noneFP)-        , (FeldPrimDesc "sqrt" [FloatT],            Left $ Fun "sqrtf" noneFP)-        , (FeldPrimDesc "sqrt" [ComplexT FloatT],   Left $ Fun "csqrtf" noneFP)-        , (FeldPrimDesc "log" [FloatT],             Left $ Fun "logf" noneFP)-        , (FeldPrimDesc "log" [ComplexT FloatT],    Left $ Fun "clogf" noneFP)-        , (FeldPrimDesc "(**)" [FloatT, FloatT],                      Left $ Fun "powf" noneFP)-        , (FeldPrimDesc "(**)" [ComplexT FloatT, ComplexT FloatT],    Left $ Fun "cpowf" noneFP)-        , (FeldPrimDesc "logBase" [FloatT, FloatT],                   Left $ Fun "logBase" firstInFP)-        , (FeldPrimDesc "logBase" [ComplexT FloatT, ComplexT FloatT], Left $ Fun "logBase" firstInFP)-        , (FeldPrimDesc "sin" [FloatT],             Left $ Fun "sinf" noneFP)-        , (FeldPrimDesc "sin" [ComplexT FloatT],    Left $ Fun "csinf" noneFP)-        , (FeldPrimDesc "tan" [FloatT],             Left $ Fun "tanf" noneFP)-        , (FeldPrimDesc "tan" [ComplexT FloatT],    Left $ Fun "ctanf" noneFP)-        , (FeldPrimDesc "cos" [FloatT],             Left $ Fun "cosf" noneFP)-        , (FeldPrimDesc "cos" [ComplexT FloatT],    Left $ Fun "ccosf" noneFP)-        , (FeldPrimDesc "asin" [FloatT],            Left $ Fun "asinf" noneFP)-        , (FeldPrimDesc "asin" [ComplexT FloatT],   Left $ Fun "casinf" noneFP)-        , (FeldPrimDesc "atan" [FloatT],            Left $ Fun "atanf" noneFP)-        , (FeldPrimDesc "atan" [ComplexT FloatT],   Left $ Fun "catanf" noneFP)-        , (FeldPrimDesc "acos" [FloatT],            Left $ Fun "acosf" noneFP)-        , (FeldPrimDesc "acos" [ComplexT FloatT],   Left $ Fun "cacosf" noneFP)-        , (FeldPrimDesc "sinh" [FloatT],            Left $ Fun "sinhf" noneFP)-        , (FeldPrimDesc "sinh" [ComplexT FloatT],   Left $ Fun "csinhf" noneFP)-        , (FeldPrimDesc "tanh" [FloatT],            Left $ Fun "tanhf" noneFP)-        , (FeldPrimDesc "tanh" [ComplexT FloatT],   Left $ Fun "ctanhf" noneFP)-        , (FeldPrimDesc "cosh" [FloatT],            Left $ Fun "coshf" noneFP)-        , (FeldPrimDesc "cosh" [ComplexT FloatT],   Left $ Fun "ccoshf" noneFP)-        , (FeldPrimDesc "asinh" [FloatT],           Left $ Fun "asinhf" noneFP)-        , (FeldPrimDesc "asinh" [ComplexT FloatT],  Left $ Fun "casinhf" noneFP)-        , (FeldPrimDesc "atanh" [FloatT],           Left $ Fun "atanhf" noneFP)-        , (FeldPrimDesc "atanh" [ComplexT FloatT],  Left $ Fun "catanhf" noneFP)-        , (FeldPrimDesc "acosh" [FloatT],           Left $ Fun "acoshf" noneFP)-        , (FeldPrimDesc "acosh" [ComplexT FloatT],  Left $ Fun "cacoshf" noneFP)-        -        , (FeldPrimDesc "(.&.)" [IntT, IntT],   Left $ Op2 "&")                     -- Bits instanced for Int (Bits.hs)-        , (FeldPrimDesc "(.|.)" [IntT, IntT],   Left $ Op2 "|")-        , (FeldPrimDesc "xor" [IntT, IntT],     Left $ Op2 "^")-        , (FeldPrimDesc "complement" [IntT],    Left $ Op1 "~")-        , (FeldPrimDesc "bit" [IntT],           Right bitFunToShift)-        , (FeldPrimDesc "setBit" [IntT, IntT],  Left $ Fun "setBit" firstInFP)-        , (FeldPrimDesc "clearBit" [IntT, IntT],      Left $ Fun "clearBit" firstInFP)-        , (FeldPrimDesc "complementBit" [IntT, IntT], Left $ Fun "complementBit" firstInFP)-        , (FeldPrimDesc "testBit" [IntT, IntT], Left $ Fun "testBit" firstInFP)-        , (FeldPrimDesc "shiftL" [IntT, IntT],  Left $ Op2 "<<")-        , (FeldPrimDesc "shiftR" [IntT, IntT],  Left $ Op2 ">>")-        , (FeldPrimDesc "rotateL" [IntT, IntT], Left $ Fun "rotateL" firstInFP)-        , (FeldPrimDesc "rotateR" [IntT, IntT], Left $ Fun "rotateR" firstInFP)-        , (FeldPrimDesc "reverseBits" [IntT],   Left $ Fun "reverseBits" firstInFP)-        , (FeldPrimDesc "bitScan" [IntT],       Left $ Fun "bitScan" firstInFP)-        , (FeldPrimDesc "bitCount" [IntT],      Left $ Fun "bitCount" firstInFP)-        , (FeldPrimDesc "bitSize" [IntT],       Right bitSizeFunToConst)-        , (FeldPrimDesc "isSigned" [IntT],      Right isSignedFunToConst)-        -        , (FeldPrimDesc "complex" [RealT, RealT],       Left $ Fun "complex" firstInFP)   -- Complex operations for Complex (Complex.hs)-        , (FeldPrimDesc "creal" [ComplexT FloatT],      Left $ Fun "crealf" noneFP)-        , (FeldPrimDesc "creal" [ComplexT IntT],        Left $ Fun "creal" firstInFP)-        , (FeldPrimDesc "cimag" [ComplexT FloatT],      Left $ Fun "cimagf" noneFP)-        , (FeldPrimDesc "cimag" [ComplexT IntT],        Left $ Fun "cimag" firstInFP)-        , (FeldPrimDesc "conjugate" [ComplexT FloatT],  Left $ Fun "conjf" noneFP)-        , (FeldPrimDesc "conjugate" [ComplexT IntT],    Left $ Fun "conj" firstInFP)-        , (FeldPrimDesc "magnitude" [ComplexT FloatT],  Left $ Fun "cabsf" noneFP)-        , (FeldPrimDesc "magnitude" [ComplexT IntT],    Left $ Fun "magnitude" firstInFP)-        , (FeldPrimDesc "phase" [ComplexT FloatT],      Left $ Fun "cargf" noneFP)-        , (FeldPrimDesc "phase" [ComplexT IntT],        Left $ Fun "phase" firstInFP)-        , (FeldPrimDesc "mkPolar" [RealT, RealT],       Left $ Fun "mkPolar" firstInFP)-        , (FeldPrimDesc "cis" [RealT],                  Left $ Fun "cis" firstInFP)-        -        , (FeldPrimDesc "f2i" [FloatT],         Right (\_ [i] ot -> PrgDesc [] [] (Fnc Cas [Fnc (Fun "truncf" noneFP) [Exp i] FloatType] ot)))-        , (FeldPrimDesc "i2n" [IntT],           Right i2n)-        , (FeldPrimDesc "b2i" [BoolT],          Left $ Cas)-        , (FeldPrimDesc "round" [FloatT],       Right (\_ [i] ot -> PrgDesc [] [] (Fnc Cas [Fnc (Fun "roundf" noneFP) [Exp i] FloatType] ot)))-        , (FeldPrimDesc "ceiling" [FloatT],     Right (\_ [i] ot -> PrgDesc [] [] (Fnc Cas [Fnc (Fun "ceilf" noneFP) [Exp i] FloatType] ot)))-        , (FeldPrimDesc "floor" [FloatT],       Right (\_ [i] ot -> PrgDesc [] [] (Fnc Cas [Fnc (Fun "floorf" noneFP) [Exp i] FloatType] ot)))+        , (BoolType,+          (\b -> if boolValue b then "true" else "false"))         ] ,-    includes = ["\"feldspar_c99.h\"", "\"feldspar_array.h\"", "<stdint.h>", "<string.h>", "<math.h>", "<complex.h>"],+    includes = ["\"feldspar_c99.h\"", "\"feldspar_array.h\"", "<stdint.h>", "<string.h>", "<math.h>", "<stdbool.h>", "<complex.h>"],+    platformRules = c99Rules ++ traceRules,     isRestrict = NoRestrict } -- tic64x = Platform {     name = "tic64x",     types =@@ -201,206 +85,184 @@         , (NumType Unsigned S32, "unsigned",       "uint")         , (NumType Unsigned S40, "unsigned long",  "ulong")         , (NumType Unsigned S64, "unsigned long long", "ullong")-        , (BoolType,  "int",    "int")+        , (BoolType,  "int",    "bool")         , (FloatType, "float",  "float")-        , (ComplexType (NumType Signed S8),    "complexOf_char",   "complexOf_char")-        , (ComplexType (NumType Signed S16),   "unsigned",         "complexOf_short")-        , (ComplexType (NumType Signed S32),   "complexOf_int",    "complexOf_int")-        , (ComplexType (NumType Signed S40),   "complexOf_long",   "complexOf_long")-        , (ComplexType (NumType Signed S64),   "complexOf_llong",  "complexOf_llong")-        , (ComplexType (NumType Unsigned S8),  "complexOf_uchar",  "complexOf_uchar")-        , (ComplexType (NumType Unsigned S16), "unsigned",         "complexOf_ushort")-        , (ComplexType (NumType Unsigned S32), "complexOf_uint",   "complexOf_uint")-        , (ComplexType (NumType Unsigned S40), "complexOf_ulong",  "complexOf_ulong")-        , (ComplexType (NumType Unsigned S64), "complexOf_ullong", "complexOf_ullong")         , (ComplexType FloatType,              "complexOf_float",  "complexOf_float")         ] ,     values = -        [ (ComplexType (NumType Signed S8),-              (\cx -> "complex_fun_char(" ++ showRe cx ++ "," ++ showIm cx ++ ")"))-        , (ComplexType (NumType Signed S16),-              (\cx -> "_pack2(" ++ showRe cx ++ "," ++ showIm cx ++ ")"))-        , (ComplexType (NumType Signed S32),-              (\cx -> "complex_fun_int(" ++ showRe cx ++ "," ++ showIm cx ++ ")"))-        , (ComplexType (NumType Signed S40),-              (\cx -> "complex_fun_long(" ++ showRe cx ++ "," ++ showIm cx ++ ")"))-        , (ComplexType (NumType Signed S64),-              (\cx -> "complex_fun_llong(" ++ showRe cx ++ "," ++ showIm cx ++ ")"))-        , (ComplexType (NumType Unsigned S8),-              (\cx -> "complex_fun_uchar(" ++ showRe cx ++ "," ++ showIm cx ++ ")"))-        , (ComplexType (NumType Unsigned S16),-              (\cx -> "_pack2(" ++ showRe cx ++ "," ++ showIm cx ++ ")"))-        , (ComplexType (NumType Unsigned S32),-              (\cx -> "complex_fun_uint(" ++ showRe cx ++ "," ++ showIm cx ++ ")"))-        , (ComplexType (NumType Unsigned S40),-              (\cx -> "complex_fun_ulong(" ++ showRe cx ++ "," ++ showIm cx ++ ")"))-        , (ComplexType (NumType Unsigned S64),-              (\cx -> "complex_fun_ullong(" ++ showRe cx ++ "," ++ showIm cx ++ ")"))-        , (ComplexType FloatType,+        [ (ComplexType FloatType,               (\cx -> "complex_fun_float(" ++ showRe cx ++ "," ++ showIm cx ++ ")"))+        , (BoolType,+          (\b -> if boolValue b then "1" else "0"))         ] ,-    primitives =-        [ (FeldPrimDesc "(==)" [ComplexT FloatT, ComplexT FloatT],            Left $ Fun "equal" firstInFP)-        , (FeldPrimDesc "(==)" [ComplexT (IntT_ S16), ComplexT (IntT_ S16)],  Left $ Op2 "==")-        , (FeldPrimDesc "(/=)" [ComplexT FloatT, ComplexT FloatT],            Left $ Fun "!equal" firstInFP)-        , (FeldPrimDesc "(/=)" [ComplexT (IntT_ S16), ComplexT (IntT_ S16)],  Left $ Op2 "!=")-        -        , (FeldPrimDesc "negate" [ComplexT FloatT],                         Left $ Fun "negate" firstInFP)-        , (FeldPrimDesc "negate" [ComplexT (IntT_ S16)],                    Right (\_ [i] ot -> PrgDesc [] [] (Fnc (Fun "_sub2" noneFP) [Exp $ intToCe 0, Exp i] ot)))-        , (FeldPrimDesc "abs" [ComplexT FloatT],                            Left $ Fun "abs" firstInFP)-        , (FeldPrimDesc "abs" [FloatT],                                     Left $ Fun "_fabsf" noneFP)-        , (FeldPrimDesc "abs" [IntTS_ S32],                                 Left $ Fun "_abs" noneFP)-        , (FeldPrimDesc "(+)" [ComplexT FloatT, ComplexT FloatT],           Left $ Fun "add" firstInFP)-        , (FeldPrimDesc "(+)" [ComplexT (IntT_ S16), ComplexT (IntT_ S16)], Left $ Fun "_add2" noneFP)-        , (FeldPrimDesc "(-)" [ComplexT FloatT, ComplexT FloatT],           Left $ Fun "sub" firstInFP)-        , (FeldPrimDesc "(-)" [ComplexT (IntT_ S16), ComplexT (IntT_ S16)], Left $ Fun "_sub2" noneFP)-        , (FeldPrimDesc "(*)" [ComplexT FloatT, ComplexT FloatT],           Left $ Fun "mult" firstInFP)---        , (FeldPrimDesc "(*)" [ComplexT (IntT_ S16), ComplexT (IntT_ S16)], Left $ Fun "_cmpyr" noneFP)   -- Just on TI C64x+-        -        , (FeldPrimDesc "(/)" [ComplexT FloatT, ComplexT FloatT],           Left $ Fun "div" firstInFP)-        -        , (FeldPrimDesc "exp" [ComplexT FloatT],    Left $ Fun "exp" firstInFP)-        , (FeldPrimDesc "sqrt" [ComplexT FloatT],   Left $ Fun "sqrt" firstInFP)-        , (FeldPrimDesc "log" [ComplexT FloatT],    Left $ Fun "log" firstInFP)-        , (FeldPrimDesc "(**)" [ComplexT FloatT, ComplexT FloatT],    Left $ Fun "cpow" firstInFP)-        , (FeldPrimDesc "logBase" [ComplexT FloatT, ComplexT FloatT], Left $ Fun "logBase" firstInFP)-        , (FeldPrimDesc "sin" [ComplexT FloatT],    Left $ Fun "sin" firstInFP)-        , (FeldPrimDesc "tan" [ComplexT FloatT],    Left $ Fun "tan" firstInFP)-        , (FeldPrimDesc "cos" [ComplexT FloatT],    Left $ Fun "cos" firstInFP)-        , (FeldPrimDesc "asin" [ComplexT FloatT],   Left $ Fun "asin" firstInFP)-        , (FeldPrimDesc "atan" [ComplexT FloatT],   Left $ Fun "atan" firstInFP)-        , (FeldPrimDesc "acos" [ComplexT FloatT],   Left $ Fun "acos" firstInFP)-        , (FeldPrimDesc "sinh" [ComplexT FloatT],   Left $ Fun "sinh" firstInFP)-        , (FeldPrimDesc "tanh" [ComplexT FloatT],   Left $ Fun "tanh" firstInFP)-        , (FeldPrimDesc "cosh" [ComplexT FloatT],   Left $ Fun "cosh" firstInFP)-        , (FeldPrimDesc "asinh" [ComplexT FloatT],  Left $ Fun "asinh" firstInFP)-        , (FeldPrimDesc "atanh" [ComplexT FloatT],  Left $ Fun "atanh" firstInFP)-        , (FeldPrimDesc "acosh" [ComplexT FloatT],  Left $ Fun "acosh" firstInFP)-        -        , (FeldPrimDesc "rotateL" [IntTU_ S32, IntT],       Left $ Fun "_rotl" noneFP)-        , (FeldPrimDesc "reverseBits" [IntTU_ S32],         Left $ Fun "_bitr" noneFP)-        , (FeldPrimDesc "bitCount" [IntTU_ S32],            Right optimizedBitCount)-        -        , (FeldPrimDesc "complex" [IntT_ S16, IntT_ S16],   Left $ Fun "_pack2" noneFP)-        , (FeldPrimDesc "creal" [ComplexT FloatT],          Left $ Fun "creal" firstInFP)-        , (FeldPrimDesc "cimag" [ComplexT FloatT],          Left $ Fun "cimag" firstInFP)-        , (FeldPrimDesc "conjugate" [ComplexT FloatT],      Left $ Fun "conj" firstInFP)-        , (FeldPrimDesc "magnitude" [ComplexT FloatT],      Left $ Fun "magnitude" firstInFP)-        , (FeldPrimDesc "phase" [ComplexT FloatT],          Left $ Fun "phase" firstInFP)-        -        , (FeldPrimDesc "i2n" [IntT_ S16],         Right (\_ [i] ot -> PrgDesc [] [] (Fnc (Fun "_pack2" noneFP) [Exp i, Exp $ intToCe 0] ot)))-        ]-        ++ primitives c99,     includes = ["\"feldspar_tic64x.h\"", "\"feldspar_array.h\"", "<c6x.h>", "<string.h>", "<math.h>"],+    platformRules = tic64xRules ++ c99Rules ++ traceRules,     isRestrict = Restrict } --optimizedSubtract :: TransformPrim-optimizedSubtract _ [x, y] ot = case (x,y) of-    ((ConstExpr (IntConst 0 _ _) _), _) -> PrgDesc [] [] (Fnc (Op1 "-") [Exp y] ot)-    (_, _) -> PrgDesc [] [] (Fnc (Op2 "-") [Exp x, Exp y] ot)+showRe = showConstant . realPartComplexValue +showIm = showConstant . imagPartComplexValue +showConstant (IntConst c _ _ _)    = show c+showConstant (FloatConst c _ _)  = show c ++ "f" -optimizedMultiply :: TransformPrim-optimizedMultiply _ [x, y] ot = case (x,y) of-    (_, (ConstExpr (IntConst _ _ _) _)) -> optimizedMultiply' x y-    ((ConstExpr (IntConst _ _ _) _), _) -> optimizedMultiply' y x-    (_, _conjugate) -> PrgDesc [] [] (Fnc (Op2 "*") [Exp x, Exp y] ot)+c99Rules = [rule copy, rule c99]   where-    optimizedMultiply' int con-        | (machTypes IntT $ typeof int) -          && (con' >= 0) -          && (2 ^ (numberOfTwoPrimeFactors con') == con')-              = PrgDesc [] [] (Fnc (Op2 "<<") [Exp int, Exp $ intToCe $ numberOfTwoPrimeFactors con'] ot)-        | (machTypes IntT $ typeof int) -          && (con' < 0) -          && (2 ^ (numberOfTwoPrimeFactors $ con' * (-1)) == con' * (-1))-              = PrgDesc [] [] (Fnc (Op1 "-") [Fnc (Op2 "<<") [Exp int, Exp $ intToCe $ numberOfTwoPrimeFactors $ con' * (-1)] ot] ot)-        | otherwise = PrgDesc [] [] (Fnc (Op2 "*") [Exp x, Exp y] ot)-      where-        con' = ceToInt con----- optimizedDivide :: TransformPrim--- optimizedDivide _ [x, y] ot = case (x,y) of-    -- (_, (ConstExpr (IntConst _ _ _) _)) -> optimizedDivide' x y-    -- (_, _) -> PrgDesc [] [] (Fnc (Op2 "/") [Exp x, Exp y] ot)-  -- where-    -- optimizedDivide' int con-        -- | (machTypes IntT $ typeof int) -          -- && (con' >= 0) -          -- && (2 ^ (numberOfTwoPrimeFactors con') == con')-              -- = PrgDesc [] [] (Fnc (Op2 ">>") [Exp int, Exp $ intToCe $ numberOfTwoPrimeFactors con'] ot)-        -- | (machTypes IntT $ typeof int) -          -- && (con' < 0) -          -- && (2 ^ (numberOfTwoPrimeFactors $ con' * (-1)) == con' * (-1))-              -- = PrgDesc [] [] (Fnc (Op1 "-") [Fnc (Op2 ">>") [Exp int, Exp $ intToCe $ numberOfTwoPrimeFactors $ con' * (-1)] ot] ot)-        -- | otherwise = PrgDesc [] [] (Fnc (Op2 "/") [Exp x, Exp y] ot)-      -- where-        -- con' = ceToInt con---bitFunToShift _ [i] ot = PrgDesc [] [] (Fnc (Op2 "<<") [Exp $ intToCe 1, Exp i] ot)---bitSizeFunToConst :: TransformPrim-bitSizeFunToConst _ [i] _ = case (typeof i) of-    (NumType _ s)  -> PrgDesc [] [] (Exp $ intToCe $ sizeToInt s)---isSignedFunToConst :: TransformPrim-isSignedFunToConst _ [i] _ = case (typeof i) of-    (NumType Signed _)   -> PrgDesc [] [] (Exp $ boolToCe True)-    (NumType Unsigned _) -> PrgDesc [] [] (Exp $ boolToCe False)---i2n :: TransformPrim-i2n _ [i] ot@(ComplexType _)  = PrgDesc [] [] (Fnc (Fun "complex" firstInFP) [Exp i, Exp $ intToCe 0] ot)-i2n _ [i] ot                  = PrgDesc [] [] (Fnc Cas [Exp i] ot)---optimizedBitCount :: TransformPrim-optimizedBitCount _ [i] ot-    = PrgDesc [] [] (Fnc (Fun "_dotpu4" noneFP) [Fnc (Fun "_bitc4" noneFP) [Exp i] ot, Exp $ intToCe 0x01010101] ot)----- absIntTS :: TransformPrim--- absIntTS _ [i] ot@(NumType _ s)---     = PrgDesc ---         [Crt ot (Var "mask") (Just $ Fnc (Op2 ">>") [Exp i, Exp $ intToCe $ sizeToInt s - 1] ot)]---         []---         (Fnc (Op2 "^") [Fnc (Op2 "+") [Exp i, VarR (Var "mask")] ot, VarR (Var "mask")] ot)----- signumRealT :: TransformPrim--- signumRealT _ [i] ot@(NumType Signed s)    = PrgDesc [] [] (Fnc (Op2 "|") [Fnc (Op2 "!=") [Exp i, Exp $ intToCe 0] ot, Fnc (Op2 ">>") [Exp i, Exp $ intToCe $ sizeToInt s - 1] ot] ot)--- signumRealT _ [i] ot@(NumType Unsigned s)  = PrgDesc [] [] (Fnc (Op2 ">") [Exp i, Exp $ intToCe 0] ot)--- signumRealT _ [i] ot@(FloatType)           = PrgDesc [] [] (Fnc (Op2 "-") [Fnc (Op2 ">") [Exp i, Exp $ intToCe 0] ot, Fnc (Op2 "<") [Exp i, Exp $ intToCe 0] ot] ot)---numberOfTwoPrimeFactors 2 = 1-numberOfTwoPrimeFactors x | x `mod` 2 == 0  = (numberOfTwoPrimeFactors $ x `div` 2) + 1-                          | otherwise       = 0--sizeToInt :: Size -> Integer-sizeToInt S8  = 8-sizeToInt S16 = 16-sizeToInt S32 = 32-sizeToInt S40 = 40-sizeToInt S64 = 64---ceToInt (ConstExpr (IntConst x _ _) _) = x-intToCe x = ConstExpr (IntConst x () ()) ()-boolToCe x = ConstExpr (BoolConst x () ()) ()+    copy (Call "copy" [Out arg1, In arg2])+        | isArray (typeof arg1) = [replaceWith $ Call "copyArray" [Out arg1,In arg2]]+        | otherwise = [replaceWith $ arg1 := arg2]+    copy _ = []+    c99 (Fun t "(!)" [arg1,arg2])    = [replaceWith $ arg1 :!: arg2]+    c99 (Fun t "getFst" [arg]) = [replaceWith $ arg :.: first]+    c99 (Fun t "getSnd" [arg]) = [replaceWith $ arg :.: second]+    c99 (Fun t "(==)" [arg1, arg2])  = [replaceWith $ Binop t "==" [arg1, arg2]]+    c99 (Fun t "(/=)" [arg1, arg2])  = [replaceWith $ Binop t "!=" [arg1, arg2]]+    c99 (Fun t "(<)" [arg1, arg2])   = [replaceWith $ Binop t "<" [arg1, arg2]]+    c99 (Fun t "(>)" [arg1, arg2])   = [replaceWith $ Binop t ">" [arg1, arg2]]+    c99 (Fun t "(<=)" [arg1, arg2])  = [replaceWith $ Binop t "<=" [arg1, arg2]]+    c99 (Fun t "(>=)" [arg1, arg2])  = [replaceWith $ Binop t ">=" [arg1, arg2]]+    c99 (Fun t "not" [arg])  = [replaceWith $ Fun t "!" [arg]]+    c99 (Fun t "(&&)" [arg1, arg2])  = [replaceWith $ Binop t "&&" [arg1, arg2]]+    c99 (Fun t "(||)" [arg1, arg2])  = [replaceWith $ Binop t "||" [arg1, arg2]]+    c99 (Fun t "quot" [arg1, arg2])  = [replaceWith $ Binop t "/" [arg1, arg2]]+    c99 (Fun t "rem" [arg1, arg2])   = [replaceWith $ Binop t "%" [arg1, arg2]]+    c99 (Fun t "(^)" [arg1, arg2])   = [replaceWith $ Fun t (extend "pow" t) [arg1, arg2]]+    c99 (Fun t "abs" [arg])  = [replaceWith $ Fun t (extend "abs" t) [arg]]+    c99 (Fun t "signum" [arg])   = [replaceWith $ Fun t (extend "signum" t) [arg]]+    c99 (Fun t "(+)" [arg1, arg2])   = [replaceWith $ Binop t "+" [arg1, arg2]]+    c99 (Fun t "(-)" [LitI _ 0, arg2])   = [replaceWith $ Fun t "-" [arg2]]+    c99 (Fun t "(-)" [LitF 0, arg2]) = [replaceWith $ Fun t "-" [arg2]]+    c99 (Fun t "(-)" [arg1, arg2])   = [replaceWith $ Binop t "-" [arg1, arg2]]+    c99 (Fun t "(*)" [LitI _ (log2 -> Just n), arg2])    = [replaceWith $ Binop t "<<" [arg2, LitI I32 n]]+    c99 (Fun t "(*)" [arg1, LitI _ (log2 -> Just n)])    = [replaceWith $ Binop t "<<" [arg1, LitI I32 n]]+    c99 (Fun t "(*)" [arg1, arg2])   = [replaceWith $ Binop t "*" [arg1, arg2]]+    c99 (Fun t "(/)" [arg1, arg2])   = [replaceWith $ Binop t "/" [arg1, arg2]]+    c99 (Fun t@(Complex _) "exp" [arg])  = [replaceWith $ Fun t "cexpf" [arg]]+    c99 (Fun t "exp" [arg])  = [replaceWith $ Fun t "expf" [arg]]+    c99 (Fun t@(Complex _) "sqrt" [arg]) = [replaceWith $ Fun t "csqrtf" [arg]]+    c99 (Fun t "sqrt" [arg]) = [replaceWith $ Fun t "sqrtf" [arg]]+    c99 (Fun t@(Complex _) "log" [arg])  = [replaceWith $ Fun t "clogf" [arg]]+    c99 (Fun t "log" [arg])  = [replaceWith $ Fun t "logf" [arg]]+    c99 (Fun t@(Complex _) "(**)" [arg1, arg2])  = [replaceWith $ Fun t "cpowf" [arg1,arg2]]+    c99 (Fun t "(**)" [arg1, arg2])  = [replaceWith $ Fun t "powf" [arg1,arg2]]+    c99 (Fun t "logBase" [arg1, arg2])   = [replaceWith $ Fun t (extend "logBase" t) [arg1,arg2]]+    c99 (Fun t@(Complex _) "sin" [arg])  = [replaceWith $ Fun t "csinf" [arg]]+    c99 (Fun t "sin" [arg])  = [replaceWith $ Fun t "sinf" [arg]]+    c99 (Fun t@(Complex _) "tan" [arg])  = [replaceWith $ Fun t "ctanf" [arg]]+    c99 (Fun t "tan" [arg])  = [replaceWith $ Fun t "tanf" [arg]]+    c99 (Fun t@(Complex _) "cos" [arg])  = [replaceWith $ Fun t "ccosf" [arg]]+    c99 (Fun t "cos" [arg])  = [replaceWith $ Fun t "cosf" [arg]]+    c99 (Fun t@(Complex _) "asin" [arg]) = [replaceWith $ Fun t "casinf" [arg]]+    c99 (Fun t "asin" [arg]) = [replaceWith $ Fun t "asinf" [arg]]+    c99 (Fun t@(Complex _) "atan" [arg]) = [replaceWith $ Fun t "catanf" [arg]]+    c99 (Fun t "atan" [arg]) = [replaceWith $ Fun t "atanf" [arg]]+    c99 (Fun t@(Complex _) "acos" [arg]) = [replaceWith $ Fun t "cacosf" [arg]]+    c99 (Fun t "acos" [arg]) = [replaceWith $ Fun t "acosf" [arg]]+    c99 (Fun t@(Complex _) "sinh" [arg]) = [replaceWith $ Fun t "csinhf" [arg]]+    c99 (Fun t "sinh" [arg]) = [replaceWith $ Fun t "sinhf" [arg]]+    c99 (Fun t@(Complex _) "tanh" [arg]) = [replaceWith $ Fun t "ctanhf" [arg]]+    c99 (Fun t "tanh" [arg]) = [replaceWith $ Fun t "tanhf" [arg]]+    c99 (Fun t@(Complex _) "cosh" [arg]) = [replaceWith $ Fun t "ccoshf" [arg]]+    c99 (Fun t "cosh" [arg]) = [replaceWith $ Fun t "coshf" [arg]]+    c99 (Fun t@(Complex _) "asinh" [arg])    = [replaceWith $ Fun t "casinhf" [arg]]+    c99 (Fun t "asinh" [arg])    = [replaceWith $ Fun t "asinhf" [arg]]+    c99 (Fun t@(Complex _) "atanh" [arg])    = [replaceWith $ Fun t "catanhf" [arg]]+    c99 (Fun t "atanh" [arg])    = [replaceWith $ Fun t "atanhf" [arg]]+    c99 (Fun t@(Complex _) "acosh" [arg])    = [replaceWith $ Fun t "cacoshf" [arg]]+    c99 (Fun t "acosh" [arg])    = [replaceWith $ Fun t "acoshf" [arg]]+    c99 (Fun t "(.&.)" [arg1, arg2]) = [replaceWith $ Binop t "&" [arg1, arg2]]+    c99 (Fun t "(.|.)" [arg1, arg2]) = [replaceWith $ Binop t "|" [arg1, arg2]]+    c99 (Fun t "xor" [arg1, arg2])   = [replaceWith $ Binop t "^" [arg1, arg2]]+    c99 (Fun t "complement" [arg])   = [replaceWith $ Fun t "~" [arg]]+    c99 (Fun t "bit" [arg])  = [replaceWith $ Binop t "<<" [LitI t 1, arg]]+    c99 (Fun t "setBit" [arg1, arg2])    = [replaceWith $ Fun t (extend "setBit" t) [arg1, arg2]]+    c99 (Fun t "clearBit" [arg1, arg2])  = [replaceWith $ Fun t (extend "clearBit" t) [arg1, arg2]]+    c99 (Fun t "complementBit" [arg1, arg2]) = [replaceWith $ Fun t (extend "complementBit" t) [arg1, arg2]]+    c99 (Fun t "testBit" [arg1, arg2])   = [replaceWith $ Fun t (extend "testBit" $ typeof arg1) [arg1, arg2]]+    c99 (Fun t "shiftL" [arg1, arg2])    = [replaceWith $ Binop t "<<" [arg1, arg2]]+    c99 (Fun t "shiftR" [arg1, arg2])    = [replaceWith $ Binop t ">>" [arg1, arg2]]+    c99 (Fun t "rotateL" [arg1, arg2])   = [replaceWith $ Fun t (extend "rotateL" t) [arg1, arg2]]+    c99 (Fun t "rotateR" [arg1, arg2])   = [replaceWith $ Fun t (extend "rotateR" t) [arg1, arg2]]+    c99 (Fun t "reverseBits" [arg])  = [replaceWith $ Fun t (extend "reverseBits" t) [arg]]+    c99 (Fun t "bitScan" [arg])  = [replaceWith $ Fun t (extend "bitScan" $ typeof arg) [arg]]+    c99 (Fun t "bitCount" [arg]) = [replaceWith $ Fun t (extend "bitCount" $ typeof arg) [arg]]+    c99 (Fun t "bitSize" [intWidth . typeof -> Just n])  = [replaceWith $ LitI U32 n]+    c99 (Fun t "isSigned" [intSigned . typeof -> Just b])    = [replaceWith $ litB b]+    c99 (Fun t "complex" [arg1, arg2])   = [replaceWith $ Fun t (extend "complex" $ typeof arg1) [arg1,arg2]]+    c99 (Fun t "creal" [arg])    = [replaceWith $ Fun t "crealf" [arg]]+    c99 (Fun t "cimag" [arg])    = [replaceWith $ Fun t "cimagf" [arg]]+    c99 (Fun t "conjugate" [arg])    = [replaceWith $ Fun t "conjf" [arg]]+    c99 (Fun t "magnitude" [arg])    = [replaceWith $ Fun t "cabsf" [arg]]+    c99 (Fun t "phase" [arg])    = [replaceWith $ Fun t "cargf" [arg]]+    c99 (Fun t "mkPolar" [arg1, arg2])   = [replaceWith $ Fun t (extend "mkPolar" $ typeof arg1) [arg1, arg2]]+    c99 (Fun t "cis" [arg])  = [replaceWith $ Fun t (extend "cis" $ typeof arg) [arg]]+    c99 (Fun t "f2i" [arg])  = [replaceWith $ Cast t $ Fun Floating "truncf" [arg]]+    c99 (Fun (Complex t) "i2n" [arg])    = [replaceWith $ Fun (Complex t) (extend "complex" t) [Cast t arg, LitF 0]]+    c99 (Fun t "i2n" [arg])  = [replaceWith $ Cast t arg]+    c99 (Fun t "b2i" [arg])  = [replaceWith $ Cast t arg]+    c99 (Fun t "round" [arg])    = [replaceWith $ Cast t $ Fun Floating "roundf" [arg]]+    c99 (Fun t "ceiling" [arg])  = [replaceWith $ Cast t $ Fun Floating "ceilf" [arg]]+    c99 (Fun t "floor" [arg])    = [replaceWith $ Cast t $ Fun Floating "floorf" [arg]]+    c99 _ = [] +tic64xRules = [rule tic64x]+  where+    tic64x (Fun t "(==)" [arg1@(typeof -> Complex _), arg2])    = [replaceWith $ Fun t (extend "equal" $ typeof arg1) [arg1, arg2]]+    tic64x (Fun t "(/=)" [arg1@(typeof -> Complex _), arg2])    = [replaceWith $ Fun t "!" [Fun t (extend "equal" $ typeof arg1) [arg1, arg2]]]+    tic64x (Fun t "abs" [arg@(typeof -> Floating)]) = [replaceWith $ Fun t "_fabs" [arg]]+    tic64x (Fun t "abs" [arg@(typeof -> I32)])  = [replaceWith $ Fun t "_abs" [arg]]+    tic64x (Fun t "(+)" [arg1@(typeof -> Complex _), arg2]) = [replaceWith $ Fun t (extend "add" $ typeof arg1) [arg1, arg2]]+    tic64x (Fun t "(-)" [arg1@(typeof -> Complex _), arg2]) = [replaceWith $ Fun t (extend "sub" $ typeof arg1) [arg1, arg2]]+    tic64x (Fun t "(*)" [arg1@(typeof -> Complex _), arg2]) = [replaceWith $ Fun t (extend "mult" $ typeof arg1) [arg1, arg2]]+    tic64x (Fun t "(/)" [arg1@(typeof -> Complex _), arg2]) = [replaceWith $ Fun t (extend "div" $ typeof arg1) [arg1, arg2]]+    tic64x (Fun t "exp" [arg1@(typeof -> Complex _), arg2]) = [replaceWith $ Fun t (extend "exp" $ typeof arg1) [arg1, arg2]]+    tic64x (Fun t "sqrt" [arg1@(typeof -> Complex _), arg2])    = [replaceWith $ Fun t (extend "sqrt" $ typeof arg1) [arg1, arg2]]+    tic64x (Fun t "log" [arg1@(typeof -> Complex _), arg2]) = [replaceWith $ Fun t (extend "log" $ typeof arg1) [arg1, arg2]]+    tic64x (Fun t "(**)" [arg1@(typeof -> Complex _), arg2])    = [replaceWith $ Fun t (extend "cpow" $ typeof arg1) [arg1, arg2]]+    tic64x (Fun t "logBase" [arg1@(typeof -> Complex _), arg2]) = [replaceWith $ Fun t (extend "logBase" $ typeof arg1) [arg1, arg2]]+    tic64x (Fun t name [arg@(typeof -> Complex _)])+        | name `elem` ["sin","tan","cos","asin","atan","acos","sinh","tanh","cosh","asinh","atanh","acosh","creal","cimag","conjugate","magnitude","phase"]+            = [replaceWith $ Fun t (extend name $ typeof arg) [arg]]+    tic64x (Fun t "rotateL" [arg1@(typeof -> U32), arg2])   = [replaceWith $ Fun t "_rotl" [arg1, arg2]]+    tic64x (Fun t "reverseBits" [arg@(typeof -> U32)])  = [replaceWith $ Fun t "_bitr" [arg]]+    tic64x (Fun t "bitCount" [arg@(typeof -> U32)])  = [replaceWith $ Fun t "_dotpu4" [Fun t "_bitc4" [arg], LitI U32 0x01010101]]+    tic64x (Fun t name [arg@(typeof -> Complex _)]) = [replaceWith $ Fun t (extend "creal" $ typeof arg) [arg]]+    tic64x _ = [] -showRe = showConstant . realPartComplexValue -showIm = showConstant . imagPartComplexValue+traceRules = [rule trace]+  where+    trace (Fun t "trace" [lab, val]) = [WithId acts]+      where+       acts i = [replaceWith trcVar, propagate decl, propagate trc, propagate frame]+         where+            trcVar = Var t trcVarName+            trcVarName = "trc" ++ show i+            defTrcVar = Def t trcVarName+            decl (Bl defs prg) = [replaceWith $ Bl (defs ++ [defTrcVar]) prg]+            trc :: Prog -> [Action (Repr Prog)]+            trc instr = [replaceWith $ Seq [init,trcCall,instr]]+            trcCall = Call (extend' "trace" t) [In trcVar, In lab]+            init = trcVar := val+            frame (ProcDf pname ins outs prg) = [replaceWith $ ProcDf pname ins outs prg']+              where+                prg' = case prg of+                    Seq (Call "traceStart" [] : _) -> prg+                    Block _ (Seq (Call "traceStart" [] : _)) -> prg+                    _ -> Seq [Call "traceStart" [], prg, Call "traceEnd" []]+    trace _ = [] +extend :: String -> Type -> String+extend s t = s ++ "_fun_" ++ show t -showConstant (IntConst c _ _)    = show c-showConstant (FloatConst c _ _)  = show c ++ "f"+extend' :: String -> Type -> String+extend' s t = s ++ "_" ++ show t +log2 :: Integer -> Maybe Integer+log2 n+    | n == 2 Prelude.^ l    = Just l+    | otherwise             = Nothing+  where+    l = toInteger $ length $ takeWhile (<=n) $ map (2 Prelude.^) [1..] +first = "member1"+second = "member2"
Feldspar/Compiler/Backend/C/Plugin/AllocationEliminator.hs view
@@ -1,30 +1,163 @@+--+-- Copyright (c) 2009-2011, 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.Backend.C.Plugin.AllocationEliminator where  import Data.Map (Map) import qualified Data.Map as Map import Feldspar.Transformation+import Feldspar.Compiler.Backend.C.Library  data AllocationEliminator = AllocationEliminator +data AllocationEliminatorSemanticInfo++instance Annotation AllocationEliminatorSemanticInfo Module where+    type Label AllocationEliminatorSemanticInfo Module = ()++instance Annotation AllocationEliminatorSemanticInfo Entity where+    type Label AllocationEliminatorSemanticInfo Entity = ()++instance Annotation AllocationEliminatorSemanticInfo Struct where+    type Label AllocationEliminatorSemanticInfo Struct = ()++instance Annotation AllocationEliminatorSemanticInfo ProcDef where+    type Label AllocationEliminatorSemanticInfo ProcDef = AllocationInfo++instance Annotation AllocationEliminatorSemanticInfo ProcDecl where+    type Label AllocationEliminatorSemanticInfo ProcDecl = AllocationInfo++instance Annotation AllocationEliminatorSemanticInfo StructMember where+    type Label AllocationEliminatorSemanticInfo StructMember = ()++instance Annotation AllocationEliminatorSemanticInfo Block where+    type Label AllocationEliminatorSemanticInfo Block = ()++instance Annotation AllocationEliminatorSemanticInfo Program where+    type Label AllocationEliminatorSemanticInfo Program = ()++instance Annotation AllocationEliminatorSemanticInfo Empty where+    type Label AllocationEliminatorSemanticInfo Empty = ()++instance Annotation AllocationEliminatorSemanticInfo Assign where+    type Label AllocationEliminatorSemanticInfo Assign = ()++instance Annotation AllocationEliminatorSemanticInfo ProcedureCall where+    type Label AllocationEliminatorSemanticInfo ProcedureCall = ()++instance Annotation AllocationEliminatorSemanticInfo Sequence where+    type Label AllocationEliminatorSemanticInfo Sequence = ()++instance Annotation AllocationEliminatorSemanticInfo Branch where+    type Label AllocationEliminatorSemanticInfo Branch = ()++instance Annotation AllocationEliminatorSemanticInfo SeqLoop where+    type Label AllocationEliminatorSemanticInfo SeqLoop = ()++instance Annotation AllocationEliminatorSemanticInfo ParLoop where+    type Label AllocationEliminatorSemanticInfo ParLoop = ()++instance Annotation AllocationEliminatorSemanticInfo ActualParameter where+    type Label AllocationEliminatorSemanticInfo ActualParameter = ()++instance Annotation AllocationEliminatorSemanticInfo Declaration where+    type Label AllocationEliminatorSemanticInfo Declaration = ()++instance Annotation AllocationEliminatorSemanticInfo Expression where+    type Label AllocationEliminatorSemanticInfo Expression = ()++instance Annotation AllocationEliminatorSemanticInfo FunctionCall where+    type Label AllocationEliminatorSemanticInfo FunctionCall = ()++instance Annotation AllocationEliminatorSemanticInfo SizeOf where+    type Label AllocationEliminatorSemanticInfo SizeOf = ()++instance Annotation AllocationEliminatorSemanticInfo ArrayElem where+    type Label AllocationEliminatorSemanticInfo ArrayElem = ()++instance Annotation AllocationEliminatorSemanticInfo StructField where+    type Label AllocationEliminatorSemanticInfo StructField = ()++instance Annotation AllocationEliminatorSemanticInfo Constant where+    type Label AllocationEliminatorSemanticInfo Constant = ()++instance Annotation AllocationEliminatorSemanticInfo IntConst where+    type Label AllocationEliminatorSemanticInfo IntConst = ()++instance Annotation AllocationEliminatorSemanticInfo FloatConst where+    type Label AllocationEliminatorSemanticInfo FloatConst = ()++instance Annotation AllocationEliminatorSemanticInfo BoolConst where+    type Label AllocationEliminatorSemanticInfo BoolConst = ()++instance Annotation AllocationEliminatorSemanticInfo ArrayConst where+    type Label AllocationEliminatorSemanticInfo ArrayConst = ()++instance Annotation AllocationEliminatorSemanticInfo ComplexConst where+    type Label AllocationEliminatorSemanticInfo ComplexConst = ()++instance Annotation AllocationEliminatorSemanticInfo Variable where+    type Label AllocationEliminatorSemanticInfo Variable = ()++instance Annotation AllocationEliminatorSemanticInfo Cast where+    type Label AllocationEliminatorSemanticInfo Cast = ()++instance Annotation AllocationEliminatorSemanticInfo Comment where+    type Label AllocationEliminatorSemanticInfo Comment = ()++ instance Transformation AllocationEliminator   where     type From AllocationEliminator = ()-    type To AllocationEliminator = ()+    type To AllocationEliminator = AllocationEliminatorSemanticInfo     type Down AllocationEliminator = ()     type Up AllocationEliminator = ()-    type State AllocationEliminator = (Integer, Map String Integer)+    type State AllocationEliminator = (Integer, Map String (Integer, Type)) -instance Transformable AllocationEliminator Definition+instance Transformable AllocationEliminator Entity   where-    transform t s d proc@(Procedure _ _ _ _ _ _) = Result proc'{ inParams = mem : inParams proc' } s' u'+    transform t s d proc@(ProcDef _ _ _ _ _ _) = Result proc'+        { inParams = mem : ins'+        , procDefLabel = (localsOf s', typesOf ins', typesOf outs')+        }+        (0,Map.empty) u'       where         Result proc' s' u' = defaultTransform t s d proc         mem = Variable             { varName = "mem"             , varType = ArrayType UndefinedLen $ ArrayType UndefinedLen VoidType-            , varRole = Value+            , varRole = Pointer             , varLabel = ()             }+        ins'  = inParams proc'+        outs' = outParams proc'+        localsOf = map (\(_,(_,t)) -> t) . Map.toList . snd+        typesOf  = map varType      transform t s d x = defaultTransform t s d x @@ -32,12 +165,12 @@   where     transform t s@(idx,m) d e@(VarExpr v lab) = case Map.lookup (varName v) m of         Nothing -> defaultTransform t s d e-        Just i  -> Result ArrayElem+        Just (i,_) -> Result ArrayElem             { array         = VarExpr                 { var   = Variable                     { varName = "mem"                     , varType = ArrayType UndefinedLen $ varType v-                    , varRole = Value+                    , varRole = Pointer                     , varLabel = ()                     }                 , exprLabel = ()@@ -45,6 +178,7 @@             , arrayIndex    = ConstExpr                 { constExpr = IntConst                     { intValue = i+                    , intType = NumType Signed S32                     , intConstLabel = ()                     , constLabel = ()                     }@@ -59,10 +193,11 @@   where     transform1 t s d [] = Result1 [] s ()     transform1 t s@(idx,m) d (x:xs) = case varType $ declVar x of-        ArrayType _ _   -> transform1 t (idx+1, Map.insert (varName $ declVar x) idx m) d xs-        _               -> Result1 (x:xs') s' u'+        ArrayType _ _   -> transform1 t (idx + 1, Map.insert (varName $ declVar x) (idx, varType $ declVar x) m) d xs+        _               -> Result1 (x':xs') s'' ()       where-        Result1 xs' s' u' = transform1 t s d xs+        Result1 xs' s'' () = transform1 t s' d xs+        Result x' s' ()    = transform t s d x  instance Plugin AllocationEliminator   where
Feldspar/Compiler/Backend/C/Plugin/BlockProgramHandler.hs view
@@ -1,3 +1,31 @@+--+-- Copyright (c) 2009-2011, ERICSSON AB+-- All rights reserved.+-- +-- Redistribution and use in source and binary forms, with or without+-- modification, are permitted provided that the following conditions are met:+-- +--     * Redistributions of source code must retain the above copyright notice, +--       this list of conditions and the following disclaimer.+--     * Redistributions in binary form must reproduce the above copyright+--       notice, this list of conditions and the following disclaimer in the+--       documentation and/or other materials provided with the distribution.+--     * Neither the name of the ERICSSON AB nor the names of its contributors+--       may be used to endorse or promote products derived from this software+--       without specific prior written permission.+-- +-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"+-- AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE+-- IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +-- DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE+-- FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+-- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR+-- SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER+-- CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,+-- OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+-- OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.+--+ {-# LANGUAGE EmptyDataDecls, TypeFamilies #-}  module Feldspar.Compiler.Backend.C.Plugin.BlockProgramHandler where
− Feldspar/Compiler/Backend/C/Plugin/HandlePrimitives.hs 
@@ -1,364 +0,0 @@-{-# LANGUAGE FlexibleInstances, TypeFamilies #-}--module Feldspar.Compiler.Backend.C.Plugin.HandlePrimitives-    ( HandlePrimitives(..)-    , completeFunProcName-    ) where--import Data.List (find)-import Data.Maybe (fromJust)--import Feldspar.Compiler.Imperative.Representation-import Feldspar.Compiler.Backend.C.CodeGeneration (typeof, defaultMemberName)-import Feldspar.Transformation-import Feldspar.Compiler.Backend.C.Options-import Feldspar.Compiler.Error--handlePrimitivesError = handleError "PluginArch/HandlePrimitives" InternalError--data HandleTraceFunctions = HandleTraceFunctions--instance Default Bool where-    def = False--instance Combine Bool where-    combine x y = or [x,y]--instance Transformation HandleTraceFunctions where-    type From HandleTraceFunctions      = ()-    type To HandleTraceFunctions        = ()-    type Down HandleTraceFunctions      = ()-    type Up HandleTraceFunctions        = Bool-    type State HandleTraceFunctions     = ()--instance Transformable HandleTraceFunctions Expression where-    transform t s d p = tr { up = combine u' (up tr) } where-        tr = defaultTransform t s d p-        u' = case p of-            FunctionCall "trace" _ _ _ _ _ -> True-            _ -> False--instance Transformable HandleTraceFunctions Definition where-    transform t s d p@(Procedure n i o b _ _) = case up tr of-        False -> tr-        True -> tr-                { result = (result tr)-                    { procBody = (procBody $ result tr)-                        { blockBody = addTraceSE $ blockBody $ procBody $ result tr-                        }-                    }-                } -        where-            tr = defaultTransform t s d p-            addTraceSE sequ@(Sequence _ _ _) = sequ { sequenceProgs = [traceStart] ++ (sequenceProgs sequ) ++ [traceEnd] }-            addTraceSE p               = Sequence [traceStart, p, traceEnd] () ()-            traceStart = ProcedureCall "traceStart" [] () ()-            traceEnd   = ProcedureCall "traceEnd" [] () ()-    transform t s d p = defaultTransform t s d p-data HandlePrimitives = HandlePrimitives---instance Transformation HandlePrimitives where-    type From HandlePrimitives      = ()-    type To HandlePrimitives        = ()-    type Down HandlePrimitives = (Int, Platform, Maybe (Expression ()))-    type Up HandlePrimitives   = ([Declaration ()], [Program ()])-    type State HandlePrimitives = Int---instance Plugin HandlePrimitives where-    type ExternalInfo HandlePrimitives = (Int, DebugOption, Platform)-    executePlugin _ (_,NoPrimitiveInstructionHandling,_) procedure = procedure-    executePlugin _ (defArrSize,_,platform) procedure-        = result $ transform HandlePrimitives 0 (defArrSize, platform, Nothing) $-          result $ transform HandleTraceFunctions ({-state-}) ({-down-}) procedure--instance Combine ([Declaration ()], [Program ()]) where-    combine (xl, xi) (yl, yi) = (xl ++ yl, xi ++ yi)--instance Default [Declaration ()] where-    def = []--instance Default [Program ()] where-    def = []----instance Transformable HandlePrimitives Block where-        transform t s d b = tr-            { result = addToBlock (result tr) (up tr)-            , up = ([],[])-            } where-            tr = case (up tr') of-                (_,[])  -> tr'-                _       -> handlePrimitivesError $ "transform Block: upwards program list is not empty."-            tr' = defaultTransform t s d b---instance Transformable HandlePrimitives Program where-    transform t s d p@(ProcedureCall "copy" [o@(Out out _), i@(In inp _)] _ _) = case typeof out of-        (ArrayType _ _) -> Result (ProcedureCall "copyArray" [out', inp'] () ()) arrS' arrU'-        _               -> Result (Assign lhs rhs () ()) assS' assU'-      where-        (Result out' arrS arrU1) = transform t s d o-        (Result inp' arrS' arrU2) = transform t arrS d i-        arrU' = arrU1 `combine` arrU2-        (Result lhs assS assU1) = transform t s d out-        (Result rhs assS' assU2) = transform t assS d inp-        assU' = assU1 `combine` assU2-    -- transform t s d@(das, pfm, _) p@(ProcedureCall "copy" [Out out _, In _ _] _ _) = tr { result = makeAssignment (das, pfm) inp' out' } where-        -- tr = case out of-            -- e@(VarExpr v _)       -> defaultTransform t s (das, pfm, Just e) p-            -- e@(ArrayElem _ _ _ _) -> defaultTransform t s (das, pfm, Just e) p-            -- e@(StructField _ _ _ _) -> defaultTransform t s (das, pfm, Just e) p-            -- _                     -> defaultTransform t s (das, pfm, Nothing) p-        -- inp' = aToE $ head $ filter isInparam $ procCallParams $ result tr-        -- out' = aToE $ head $ filter (not . isInparam) $ procCallParams  $ result tr-    transform t s d (SeqLoop c cc p inf1 inf2) = Result (SeqLoop (result tr1) cc' (result tr3) (convert inf1) $ convert inf2) (state tr3) ([],[]) where-            tr1 = transform t s d c-            tr2 = transform t (state tr1) d cc-            tr3 = transform t (state tr2) d p-            cc' = addToBlock (result tr2) (up tr1)-    transform t s d p =  defaultTransform t s d p---instance Transformable1 HandlePrimitives [] Program where-        transform1 t s d [] = Result1 [] s def-        transform1 t s d (x:xs) = Result1 (snd (up tr1) ++ [result tr1] ++ (result1 tr2)) (state1 tr2) (concatMap fst [up tr1,up1 tr2],[]) where-            tr1 = transform t s d x-            tr2 = transform1 t (state tr1) d xs---instance Transformable HandlePrimitives Declaration where-        transform t s d@(das, pfm, _) (Declaration v i inf) = Result (Declaration (result tr1) i' $ convert inf) (state1 tr2) u' where-            tr1 = transform t s d v-            tr2 = transform1 t (state tr1) d i-            (i',u') = case (up1 tr2) of-                u@(ls,[]) -> (result1 tr2, combine (up tr1) u)-                (ls, is)  -> (Nothing, (ls, is ++ [makeAssignment (das, pfm) (fromJust $ result1 tr2) (vToE $ result tr1)]))--instance Transformable HandlePrimitives Expression where-        transform t s d@(das, pfm, me) f@(FunctionCall nameS ot origRole origInps _ _) = res-          where-                res = case (nameS, origInps) of-                    ("getFst", [FunctionCall "pair" _ _ [fs,sn] _ _]) -> transform t s (das, pfm, Nothing) fs-                    ("getSnd", [FunctionCall "pair" _ _ [fs,sn] _ _]) -> transform t s (das, pfm, Nothing) sn-                    _ -> Result e' s' $ combine (up tr) (l',p')-                tr = defaultTransform t s (das, pfm, Nothing) f-                s2 = state tr-                (s',l',p',e') = case (nameS, inps, me) of-                    ("(!)", [arr, idx], _)    -> (s2, [], [], ArrayElem arr idx () ())-                    ("setIx", [arr, idx, val], _) -> (s2-                                                , []-                                                , [ makeAssignment d' val (ArrayElem arr idx () ()) ]-                                                , arr-                                                )-                    ("getFst", [l], _)        -> (s2, [], [], StructField l (defaultMemberName ++ "1") () ())-                    ("getSnd", [l], _)        -> (s2, [], [], StructField l (defaultMemberName ++ "2") () ())-                    ("pair", [a,b], Just e)   -> (s2-                                                , []-                                                , [ makeAssignment d' a (StructField e (defaultMemberName ++ "1") () ())-                                                  , makeAssignment d' b (StructField e (defaultMemberName ++ "2") () ())-                                                  ]-                                                , e-                                                )-                    ("pair", [a,b], Nothing)  -> (s3-                                                , [ makeDeclaration stc Nothing ]-                                                , [ makeAssignment d' a (StructField (VarExpr stc ()) (defaultMemberName ++ "1") () ())-                                                  , makeAssignment d' b (StructField (VarExpr stc ()) (defaultMemberName ++ "2") () ())-                                                  ]-                                                , VarExpr stc ()-                                                ) where (s3, stc) = makeVariable ot "stc" s2-                    ("trace", [lab, orig], Just e) -> (s2-                                                , []-                                                , [ makeAssignment d' orig e-                                                  , makeProcedureCall pfm (Proc "trace" firstInFP) [e, lab] []-                                                  ]-                                                , e-                                                )-                    ("trace", [lab, orig], Nothing) -> (s3-                                                , [ makeDeclaration trc Nothing ]-                                                , [ makeAssignment d' orig (VarExpr trc ())-                                                  , makeProcedureCall pfm (Proc "trace" firstInFP) [VarExpr trc (), lab] []-                                                  ]-                                                , VarExpr trc ()-                                                ) where (s3, trc) = makeVariable ot "trc" s2-                    _                         -> case (find matchPrimitive $ primitives pfm) of-                                                    Just (fd,Right tp)  -> transformPrgDesc d' s2 (tp fd inps ot)-                                                    Just (fd,Left cd)   -> transformCPrimDesc d' s2 cd inps ot-                                                    Nothing             -> (s2, [], [], result tr)-                matchPrimitive (fd,_) = (fName fd == nameS) && (matchTypes' (inputs fd) inps)-                inps = funCallParams $ result tr-                d' = (das, pfm)-        transform t s d@(das, pfm, _) p = defaultTransform t s (das, pfm, Nothing) p---addToBlock :: Block () -> ([Declaration ()], [Program ()]) -> Block ()-addToBlock b (ls,is)-    = b {-        locals = locals b ++ ls,-        blockBody = case (blockBody b) of-            (Sequence s () ()) -> Sequence (s ++ is) () ()-            p ->                  Sequence ([p] ++ is) () ()-    }----transformCPrimDesc :: (Int,Platform) -> Int -> CPrimDesc -> [Expression ()] -> Type -> (Int, [Declaration ()], [Program ()], Expression ())-transformCPrimDesc (_,pfm) serial cd inps ot-    = case (cd, length inps) of -        (Op1 op, 1)   -> (serial, [], [], FunctionCall op ot PrefixOp inps () ())-        (Op2 op, 2)   -> (serial, [], [], FunctionCall op ot InfixOp inps () ())-        (Fun _ _, _)  -> (serial, [], [], FunctionCall (completeFunProcName pfm cd (map typeof inps) [ot]) ot SimpleFun inps () ())-        (Cas, 1)     ->  (serial, [], [], Cast ot (head inps) () ())-        (Assig, 1)    -> (serial, [], [], head inps)-        _             -> (serial', [makeDeclaration ov Nothing], [makeProcedureCall pfm cd inps [vToE ov]], vToE ov)-  where-    (serial', ov) = makeVariable ot "vhp" serial----transformPrgDesc :: (Int,Platform) -> Int -> PrgDesc -> (Int, [Declaration ()], [Program ()], Expression ())-transformPrgDesc down@(_,pfm) serial (PrgDesc crts lns rgt)-    = (serial', map (\(_,_,v,me) -> makeDeclaration v me) vars, ins, transformRgt vars rgt)-  where-    (serial', vars') = foldl transformCrtFold (serial, []) (map searchDuplicateLabels crts)-    (vars, ins) = foldl transformLineFold (vars', []) lns-    -    searchDuplicateLabels c = if (length $ filter (==c) crts) > 1 then handlePrimitivesError $ "multiple declaration"  ++ show c else c-    -    transformCrtFold (n ,vs) (Crt t v@(Var s) (Just r)) = (n', vs ++ [(v, True, mv, Just $ transformRgt vs r)])-      where-        (n', mv) = makeVariable t s n-    transformCrtFold (n ,vs) (Crt t v@(Var s) Nothing)  = (n', vs ++ [(v, False, mv, Nothing)])-      where-        (n', mv) = makeVariable t s n-    -    transformLineFold (vs, is) ln = case (ln) of -            (Asg v r)           -> (updateVars [v],  is ++ [makeAssignment down (transformRgt' r) (transformVarL' v)])-            (Prc cd inps outs)  -> (updateVars outs, is ++ [makeProcedureCall pfm cd (map transformRgt' inps) (map transformVarL' outs)])-      where-        updateVars xs   = map (\y@(v',_,vv,mr) -> if elem v' xs then (v',True,vv,mr) else y) vs-        transformRgt'   = transformRgt vs-        transformVarL'  = vToE . transformVarL vs-    -    transformRgt vs (Exp e)           = e-    transformRgt vs (Fnc cd rgts ot)  = makeFunctionCallOrCast down cd (map (transformRgt vs) rgts) ot-    transformRgt vs (VarR v)          = vToE $ transformVarR vs v-    -    transformVarL vs v@(Var s) = case (find (\(v',_,_,_) -> v' == v) vs) of-            Just (_,_,vv,_) -> vv-            Nothing         -> handlePrimitivesError $ "Not declared: " ++ show v-    transformVarR vs v@(Var s) = case (find (\(v',_,_,_) -> v' == v) vs) of-            Just (_,True,vv,_)  -> vv-            Just (_,False,vv,_) -> vv     -- Do not check that is there any initial assignment -- quick bugfix with pair - set_pair macros-            -- Just _              -> handlePrimitivesError $ "The variable hasn't got value yet: " ++ show v-            Nothing             -> handlePrimitivesError $ "Not declared: " ++ show v-----makeFunctionCallOrCast :: (Int,Platform) ->  CPrimDesc -> [Expression ()] -> Type -> Expression ()-makeFunctionCallOrCast down cd inps ot-    = case (transformCPrimDesc down (-1) cd inps ot) of-        (_, [], [], ed) -> ed-        _               -> handlePrimitivesError $ "it's not a FunctionCall: " ++ show cd ++ "number of inputs: " ++ (show $ length inps)---makeVariable :: Type -> String -> Int -> (Int, Variable ())-makeVariable t s n = (n+1, Variable (s ++ show n) t Value ())---makeDeclaration :: Variable () -> Maybe (Expression ()) -> Declaration ()-makeDeclaration v me = Declaration v me ()---makeAssignment :: (Int,Platform) -> Expression () -> Expression ()  -> Program ()-makeAssignment (defArrSize,pfm) inp out-    = case (sameVariable inp out, typeof inp) of-        (True, _)           -> Empty () ()-        (_, ArrayType _ t)  -> ProcedureCall "copyArray" [eToOut out, eToIn inp] () ()-          where-            -- size = prod_const (arraySize (typeof out) defArrSize) (SizeOf (Left $ baseType t) () ())-            -- baseType (ArrayType _ t) = baseType t-            -- baseType t               = t-        _                   -> Assign out inp () ()-  where-    sameVariable (VarExpr v1 _) (VarExpr v2 _)  | v1 == v2  = True-                                                | otherwise = False-    sameVariable (ArrayElem a1 i1 _ _) (ArrayElem a2 i2 _ _)  | a1 == a2 && i1 == i2  = True-                                                              | otherwise             = False-    sameVariable _ _ = False--makeProcedureCall :: Platform -> CPrimDesc -> [Expression ()] -> [Expression ()] -> Program ()-makeProcedureCall pfm cd@(Proc _ _) inps outs = ProcedureCall (completeFunProcName pfm cd its ots) (inps' ++ outs') () ()-  where-    inps' = map eToIn inps-    outs' = map eToOut outs-    its = map typeof inps-    ots = map typeof outs-    -makeProcedureCall _ cd _ _ = handlePrimitivesError $ "Wrong C pirmitive description in makeProcedureCall:\n" ++ show cd-----matchTypes' :: [TypeDesc] -> [Expression ()] -> Bool-matchTypes' [] []     = True-matchTypes' [] (y:ys) = False-matchTypes' (x:xs) [] = False-matchTypes' (x:xs) (y:ys) = (machTypes x $ typeof y) && (matchTypes' xs ys)---completeFunProcName :: Platform -> CPrimDesc -> [Type] -> [Type] -> String-completeFunProcName pfm desc its ots-    | funPf desc == noneFP  = cName desc-    | otherwise             = cName desc ++ ifFun ++ apsToName-  where-    ifFun = case desc of-        Fun _ _ -> "_fun"-        Proc _ _ -> ""-    apsToName = concatMap (("_"++) . (toFunName pfm)) apsToNameList-    apsToNameList = (take (useInputs $ funPf desc) its) ++ (take (useOutputs $ funPf desc) ots)---toFunName :: Platform -> Type -> String-toFunName pfm (ArrayType _ t@(ArrayType _ _)) = toFunName pfm t-toFunName pfm (ArrayType _ t)                    = "arrayOf_" ++ toFunName pfm t-toFunName pfm t = case (find (\(t',_,_) -> t == t') $ types pfm) of-    Just (_,_,s)  -> map (\c -> if c == ' ' then '_' else c) $ s-    Nothing       -> handlePrimitivesError $ "Unhandled type in platform " ++ name pfm----- arraySize :: Type -> Int -> Expression ()--- arraySize a@(ArrayType _ t) defaultArraySize = toExp $ arraySize' a-  -- where-    -- arraySize' :: Type -> (Int,Int)-    -- arraySize' (ArrayType (LiteralLen n) t) = (n * fst at, snd at) where-        -- at = arraySize' t-    -- arraySize' (ArrayType UndefinedLen t) = (fst at, 1 + snd at) where-        -- at = arraySize' t-    -- arraySize' _ = (1,0)-    -- toExp :: (Int,Int) -> Expression ()-    -- toExp (c, 0) =  intToCe $ toInteger c-    -- toExp (c, i) = prod_const (toExp (c, i-1)) (vToE $ Variable defaultArraySizeConstantName (NumType Unsigned S32) Value ())---prod_const a b = FunctionCall "*" (NumType Unsigned S32) InfixOp [a,b] () ()--isInparam (In _ _)  = True-isInparam (Out _ _) = False---aToE (In x ())  = x-aToE (Out x ()) = x--eToIn x  = In x ()-eToOut x = Out x ()----- ceToInt (Expression (ConstantExpression (Constant (IntConstant (IntConstantType x _)) _)) _) = x-intToCe x = ConstExpr (IntConst x () ()) ()--vToE v = VarExpr v ()-
Feldspar/Compiler/Backend/C/Plugin/Locator.hs view
@@ -1,3 +1,31 @@+--+-- Copyright (c) 2009-2011, 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.Backend.C.Plugin.Locator where@@ -130,49 +158,71 @@      transform t () (line, col) pr = defaultTransform t () (line, col) pr          +-----------------------------------------------------+--- GetPrg plugin for ProcedureCall+----------------------------------------------------- +data GetPrgProcCall = GetPrgProcCall++instance Transformation GetPrgProcCall where+    type From GetPrgProcCall    = DebugToCSemanticInfo+    type To GetPrgProcCall      = DebugToCSemanticInfo+    type Down GetPrgProcCall    = (Int, Int)  +    type Up GetPrgProcCall      = (Bool, Program DebugToCSemanticInfo)+    type State GetPrgProcCall   = ()+++instance Plugin GetPrgProcCall where+    type ExternalInfo GetPrgProcCall = (Int, Int)+    executePlugin GetPrgProcCall (line, col) procedure =+        result $ transform GetPrgProcCall () (line, col) procedure+          +getPrgProcCall :: (Int, Int) -> Module DebugToCSemanticInfo -> (Bool, Program DebugToCSemanticInfo)+getPrgProcCall (line, col) procedure = up res where+    res = transform GetPrgProcCall () (line, col) procedure        +        +instance Transformable GetPrgProcCall Program where       +    transform t () (line, col) pc@(ProcedureCall _ _ inf1 inf2) = Result pc () info where +        info  = case contains (line, col) inf1  of+                    True    -> (True, pc)+                    _       ->    def+    transform t () (line, col) pr = defaultTransform t () (line, col) pr + --------------------------------------------------------- GetPrg plugin for Switch+--- GetPrg plugin for SeqLoop ----------------------------------------------------- -data GetPrgSwitch = GetPrgSwitch+data GetPrgSeqLoop = GetPrgSeqLoop -instance Transformation GetPrgSwitch where-    type From GetPrgSwitch    = DebugToCSemanticInfo-    type To GetPrgSwitch     = DebugToCSemanticInfo-    type Down GetPrgSwitch  = (Int, Int)  -    type Up GetPrgSwitch      = (Bool, Program DebugToCSemanticInfo)-    type State GetPrgSwitch   = ()+instance Transformation GetPrgSeqLoop where+    type From GetPrgSeqLoop    = DebugToCSemanticInfo+    type To GetPrgSeqLoop      = DebugToCSemanticInfo+    type Down GetPrgSeqLoop    = (Int, Int)  +    type Up GetPrgSeqLoop      = (Bool, Program DebugToCSemanticInfo)+    type State GetPrgSeqLoop   = ()  -instance Plugin GetPrgSwitch where-    type ExternalInfo GetPrgSwitch = (Int, Int)-    executePlugin GetPrgSwitch (line, col) procedure =-        result $ transform GetPrgSwitch () (line, col) procedure+instance Plugin GetPrgSeqLoop where+    type ExternalInfo GetPrgSeqLoop = (Int, Int)+    executePlugin GetPrgSeqLoop (line, col) procedure =+        result $ transform GetPrgSeqLoop () (line, col) procedure           -getPrgSwitch :: (Int, Int) -> Module DebugToCSemanticInfo -> (Bool, Program DebugToCSemanticInfo)-getPrgSwitch (line, col) procedure = up res where-    res = transform GetPrgSwitch () (line, col) procedure        +getPrgSeqLoop :: (Int, Int) -> Module DebugToCSemanticInfo -> (Bool, Program DebugToCSemanticInfo)+getPrgSeqLoop (line, col) procedure = up res where+    res = transform GetPrgSeqLoop () (line, col) procedure                 -instance Transformable GetPrgSwitch Program where       -    transform GetPrgSwitch () (line, col) sw@(Switch _ cases inf1 inf2) = Result sw () info where +instance Transformable GetPrgSeqLoop Program where       +    transform t () (line, col) sl@(SeqLoop _ _ prog inf1 inf2) = Result sl () info where          info  = case contains (line, col) inf1  of                     True -> infoCr where-                        res = prgSwList (line, col) cases-                        infoCr = case (fst $ res) of-                            True -> res-                            _    -> (True, sw)    +                        res = transform t () (line, col) prog+                        infoCr = case (fst $ up res) of+                            True -> up res+                            _    -> (True, sl)                         _    -> def+    transform t () (line, col) pr = defaultTransform t () (line, col) pr  -    transform t () (line, col) pr = defaultTransform t () (line, col) pr          -prgSwList:: (Int, Int) -> [SwitchCase DebugToCSemanticInfo] -> (Bool, Program DebugToCSemanticInfo)-prgSwList (line, col) [] = def-prgSwList (line, col) (x:xs) = combine info1 info2 where-    info1 = up $ transform GetPrgSwitch () (line, col) x-    info2 = prgSwList (line, col) xs-        -         ------------------------------------------------- ------ Helper functions -------------------------------------------------
Feldspar/Compiler/Backend/C/Plugin/PrettyPrint.hs view
@@ -1,22 +1,50 @@+--+-- Copyright (c) 2009-2011, 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.Backend.C.Plugin.PrettyPrint where  import Feldspar.Transformation import Feldspar.Compiler.Backend.C.CodeGeneration--- import Feldspar.Compiler.Backend.C.Plugin.PrettyPrintHelp+import Feldspar.Compiler.Backend.C.Plugin.AllocationEliminator import Feldspar.Compiler.Backend.C.Platforms import Feldspar.Compiler.Backend.C.Options+import Feldspar.Compiler.Backend.C.Library import Feldspar.Compiler.Error -import qualified Data.List as List (last,find)-+import qualified Data.List as List (last,find, intersperse)+import qualified Control.Monad.State as StateMonad (get, put, runState)  -- =========================================================================== --  == DebugToC plugin -- =========================================================================== - data DebugToC = DebugToC  data DebugToCSemanticInfo@@ -24,15 +52,18 @@ instance Annotation DebugToCSemanticInfo Module where     type Label DebugToCSemanticInfo Module = ((Int, Int), (Int, Int)) -instance Annotation DebugToCSemanticInfo Definition where-    type Label DebugToCSemanticInfo Definition = ((Int, Int), (Int, Int))+instance Annotation DebugToCSemanticInfo Entity where+    type Label DebugToCSemanticInfo Entity = ((Int, Int), (Int, Int))  instance Annotation DebugToCSemanticInfo Struct where     type Label DebugToCSemanticInfo Struct = ((Int, Int), (Int, Int)) -instance Annotation DebugToCSemanticInfo Procedure where-    type Label DebugToCSemanticInfo Procedure = ((Int, Int), (Int, Int))+instance Annotation DebugToCSemanticInfo ProcDef where+    type Label DebugToCSemanticInfo ProcDef = ((Int, Int), (Int, Int)) +instance Annotation DebugToCSemanticInfo ProcDecl where+    type Label DebugToCSemanticInfo ProcDecl = ((Int, Int), (Int, Int))+ instance Annotation DebugToCSemanticInfo StructMember where     type Label DebugToCSemanticInfo StructMember = ((Int, Int), (Int, Int)) @@ -77,7 +108,7 @@  instance Annotation DebugToCSemanticInfo SizeOf where     type Label DebugToCSemanticInfo SizeOf = ((Int, Int), (Int, Int))-    + instance Annotation DebugToCSemanticInfo ArrayElem where     type Label DebugToCSemanticInfo ArrayElem = ((Int, Int), (Int, Int)) @@ -105,36 +136,15 @@ instance Annotation DebugToCSemanticInfo Variable where     type Label DebugToCSemanticInfo Variable = ((Int, Int), (Int, Int)) -instance Annotation DebugToCSemanticInfo UnionField where-    type Label DebugToCSemanticInfo UnionField = ((Int, Int), (Int, Int))- instance Annotation DebugToCSemanticInfo Cast where     type Label DebugToCSemanticInfo Cast = ((Int, Int), (Int, Int))--instance Annotation DebugToCSemanticInfo SwitchCase where-    type Label DebugToCSemanticInfo SwitchCase = ((Int, Int), (Int, Int))    --instance Annotation DebugToCSemanticInfo Switch where-    type Label DebugToCSemanticInfo Switch = ((Int, Int), (Int, Int))      instance Annotation DebugToCSemanticInfo Comment where-    type Label DebugToCSemanticInfo Comment = ((Int, Int), (Int, Int))    -    -instance Annotation DebugToCSemanticInfo UnionMember where-    type Label DebugToCSemanticInfo UnionMember = ((Int, Int), (Int, Int))    -    -instance Annotation DebugToCSemanticInfo GlobalVar where-    type Label DebugToCSemanticInfo GlobalVar = ((Int, Int), (Int, Int))    -    -instance Annotation DebugToCSemanticInfo Prototype where-    type Label DebugToCSemanticInfo Prototype = ((Int, Int), (Int, Int))    -    -instance Annotation DebugToCSemanticInfo Union where-    type Label DebugToCSemanticInfo Union = ((Int, Int), (Int, Int))    +    type Label DebugToCSemanticInfo Comment = ((Int, Int), (Int, Int))   instance Transformation DebugToC where-    type From DebugToC    = ()+    type From DebugToC    = AllocationEliminatorSemanticInfo     type To DebugToC      = DebugToCSemanticInfo     type Down DebugToC    = (Options, Place, Int)  -- Platform, Place and Indentation     type Up DebugToC      = String@@ -145,320 +155,298 @@     executePlugin DebugToC ((options, place), line) procedure =         result $ transform DebugToC (line, 0) (options, place, 0) procedure -compToC :: ((Options, Place), Int) -> Module () -> (String, (Int, Int))+compToC :: ((Options, Place), Int) -> Module AllocationEliminatorSemanticInfo -> (String, (Int, Int)) compToC ((options, place), line) procedure = (up res, state res) where     res = transform DebugToC (line, 0) (options, place, 0) procedure -compToCWithInfos :: ((Options, Place), Int) -> Module () -> (Module DebugToCSemanticInfo, (String, (Int, Int)))+compToCWithInfos :: ((Options, Place), Int) -> Module AllocationEliminatorSemanticInfo -> (Module DebugToCSemanticInfo, (String, (Int, Int))) compToCWithInfos ((options, place), line) procedure = (result res, (up res, state res)) where     res = transform DebugToC (line, 0) (options, place, 0) procedure  instance Transformable DebugToC Variable where-    transform t (line, col) (options, place, indent) x@(Variable name typ role inf) = Result (Variable name typ role newInf) (line, newCol) cRep where-        newInf = ((line, col),(line, newCol))-        newCol = col + length cRep-        cRep = toC options place x+    transform t (line, col) (options, ValueNeed_pl, indent) x@(Variable name typ@(ArrayType _ _) role inf) = Result (Variable name typ role newInf) (snd newInf) cRep+        where+            ((newInf), (cRep, newLine, newCol)) = flip StateMonad.runState (defaultState line col) $ do+                code $ toC options AddressNeed_pl x+                (_, nl, nc) <- StateMonad.get+                let newInf = ((line, col), (nl, nc))+                return newInf+    transform t (line, col) (options, place, indent) x@(Variable name typ role inf) = Result (Variable name typ role newInf) (snd newInf) cRep+        where+            ((newInf), (cRep, newLine, newCol)) = flip StateMonad.runState (defaultState line col) $ do+                code $ toC options place x+                (_, nl, nc) <- StateMonad.get+                let newInf = ((line, col), (nl, nc))+                return newInf  instance Transformable1 DebugToC [] Constant where-    transform1 t (line, col) (options, place, indent) [] = Result1 [] (line, col) ""-    transform1 t (line, col) (options, place, indent) (x:[]) = Result1 ((result newX):[]) (state newX) (up newX) where-        newX = transform t (line, col) (options, place, indent) x-    transform1 t (line, col) (options, place, indent) (x:xs) = Result1 ((result newX):(result1 newXs)) (state1 newXs) (up newX ++ ", " ++ up1 newXs) where-        newX = transform t (line, col) (options, place, indent) x-        (line2, col2) =  state newX-        newSt = (line2, col2 + length ", ") -        newXs = transform1 t newSt (options, place, indent) xs+    transform1 t pos@(line, col) down@(options, place, indent) l = transform1' t pos down l ", " 0  instance Transformable DebugToC Constant where-    transform t (line, col) (options, place, indent) (ArrayConst list inf1 inf2) = Result (ArrayConst (result1 newList) newInf newInf) (line2, newCol) cRep where-        newList = transform1 t (line, col + length "{") (options, place, indent) list-        (line2, col2) = state1 newList-        newCol = col2 + length "}"-        newInf = ((line, col),(line, newCol))-        cRep = "{" ++ up1 newList ++ "}"+    transform t pos@(line, col) down@(options, place, indent) const@(IntConst c _ inf1 inf2) = transformConst t pos down const (show c) -    transform t (line, col) (options, place, indent) const@(IntConst c inf1 inf2) = Result (IntConst c newInf newInf) (line, newCol) cRep where-        newInf = ((line, col),(line, newCol))-        newCol = col + length cRep-        cRep = case (List.find (\(t',_) -> t' == typeof const) $ values $ platform options) of-            Just (_,f) -> f const-            Nothing    -> show c-        -    transform t (line, col) (options, place, indent) const@(FloatConst c inf1 inf2) = Result (FloatConst c newInf newInf) (line, newCol) cRep where-        newInf = ((line, col),(line, newCol))-        newCol = col + length cRep-        cRep = case (List.find (\(t',_) -> t' == typeof const) $ values $ platform options) of-            Just (_,f) -> f const-            Nothing    -> show c ++ "f"+    transform t pos@(line, col) down@(options, place, indent) const@(FloatConst c inf1 inf2) = transformConst t pos down const (show c ++ "f") -    transform t (line, col) (options, place, indent) const@(BoolConst False inf1 inf2) = Result (BoolConst False newInf newInf) (line, newCol) cRep where-        newInf = ((line, col),(line, newCol))-        newCol = col + length cRep-        cRep = case (List.find (\(t',_) -> t' == typeof const) $ values $ platform options) of-            Just (_,f) -> f const-            Nothing    -> "0"+    transform t pos@(line, col) down@(options, place, indent) const@(BoolConst False inf1 inf2) = transformConst t pos down const "0" -    transform t (line, col) (options, place, indent) const@(BoolConst True inf1 inf2) = Result (BoolConst True newInf newInf) (line, newCol) cRep where-        newInf = ((line, col),(line, newCol))-        newCol = col + length cRep-        cRep = case (List.find (\(t',_) -> t' == typeof const) $ values $ platform options) of-            Just (_,f) -> f const-            Nothing    -> "1"+    transform t pos@(line, col) down@(options, place, indent) const@(BoolConst True inf1 inf2) = transformConst t pos down const "1"      transform t (line, col) (options, place, indent) const@(ComplexConst real im inf1 inf2)          = case (List.find (\(t',_) -> t' == typeof const) $ values $ platform options) of             Just (_,f) -> -                Result (ComplexConst (result newReal) (result newIm) newInf newInf) (line, newCol) cRep where-                    newInf = ((line, col),(line, newCol))-                    newCol = col + length cRep-                    cRep = f const          -                    newReal = transform t (line, col) (options, place, indent) real -- TODO: Is this case valid -                    newIm = transform t (line, col) (options, place, indent) im     -- TODO:   by ComplexConst ??? +                Result (ComplexConst (result newReal) (result newIm) newInf newInf) (snd newInf) cRep +                    where+                        ((newReal, newIm, newInf), (cRep, newLine, newCol)) = flip StateMonad.runState (defaultState line col) $ do+                            newReal <- complexTransform t (options, place, indent) real+                            newIm <- complexTransform t (options, place, indent) im+                            code $ f const+                            (_, nl, nc) <- StateMonad.get+                            let newInf = ((line, col), (nl, nc))+                            return (newReal, newIm, newInf)             Nothing    -> -                Result (ComplexConst (result newReal) (result newIm) newInf newInf) (line3, newCol) cRep where-                    newReal = transform t (line, col + length "complex(") (options, place, indent) real-                    (line2, col2) = state newReal-                    newIm = transform t (line2, col2 + length ",") (options, place, indent) im-                    (line3, col3)  = state newIm-                    newCol = col3 + length ")"-                    newInf = ((line, col),(line, newCol))-                    cRep = "complex(" ++ up newReal ++ "," ++ up newIm ++ ")"+                Result (ComplexConst (result newReal) (result newIm) newInf newInf) (snd newInf) cRep +                    where+                        ((newReal, newIm, newInf), (cRep, newLine, newCol)) = flip StateMonad.runState (defaultState line col) $ do+                            code "complex("+                            newReal <- monadicTransform' t (options, place, indent) real+                            code ","+                            newIm <- monadicTransform' t (options, place, indent) im+                            code ")"+                            (_, nl, nc) <- StateMonad.get+                            let newInf = ((line, col), (nl, nc))+                            return (newReal, newIm, newInf) -  instance Transformable DebugToC ActualParameter where-    transform t (line, col) (options, place, indent) (In param@(VarExpr (Variable _ (StructType _) _ _) _) inf) = Result (In (result newParam) newInf) newSt cRep where-        newParam = transform t (line, col) (options, AddressNeed_pl, indent) param-        (line2, col2) = state newParam -        newSt  = (line2, col2)-        newInf = ((line, col), newSt)-        cRep = up newParam--    transform t (line, col) (options, place, indent) (In param inf) = Result (In (result newParam) newInf) newSt cRep where-        newParam = transform t (line, col) (options, FunctionCallIn_pl, indent) param-        (line2, col2) = state newParam -        newSt  = (line2, col2)-        newInf = ((line, col), newSt)-        cRep = up newParam--    transform t (line, col) (options, place, indent) (Out param inf) = Result (Out (result newParam) newInf) newSt cRep where-        newParam = transform t (line, col) (options, AddressNeed_pl, indent) param-        (line2, col2) = state newParam -        newSt  = (line2, col2)-        newInf = ((line, col), newSt)-        cRep = up newParam+    transform t pos@(line, col) down@(options, place, indent) act@(In param@(VarExpr (Variable _ (StructType _) _ _) _) inf) =+        transformActParam t pos down act AddressNeed_pl+    transform t pos@(line, col) down@(options, place, indent) act@(In param@(VarExpr (Variable _ (ArrayType _ _) _ _) _) inf) =+        transformActParam t pos down act AddressNeed_pl+    transform t pos@(line, col) down@(options, place, indent) act@(In _ _) = transformActParam t pos down act FunctionCallIn_pl+    transform t pos@(line, col) down@(options, place, indent) act@(Out _ _) = transformActParam t pos down act AddressNeed_pl  instance Transformable1 DebugToC [] Expression where-    transform1 t (line, col) (options, place, indent) [] = Result1 [] (line, col) ""-    transform1 t (line, col) (options, place, indent) (x:[]) = Result1 ((result newX):[]) (state newX) (up newX) where-        newX = transform t (line, col) (options, place, indent) x-    transform1 t (line, col) (options, place, indent) (x:xs) = Result1 ((result newX):(result1 newXs)) (state1 newXs) (up newX ++ ", " ++ up1 newXs) where-        newX = transform t (line, col) (options, place, indent) x-        (line2, col2) =  state newX-        newSt = (line2, col2 + length ", ") -        newXs = transform1 t newSt (options, place, indent) xs+    transform1 t pos@(line, col) down@(options, place, indent) l = transform1' t pos down l ", " 0  instance Transformable DebugToC Expression where-    transform t (line, col) (options, place, indent) (VarExpr val inf) = Result (VarExpr (result newVal) newInf) newSt cRep where-        newVal = transform t (line, col) (options, place, indent) val-        (line2, col2) = state newVal -        newSt  = (line2, col2)-        newInf = ((line, col), newSt)-        cRep = up newVal+    transform t (line, col) (options, place, indent) (VarExpr val inf) = Result (VarExpr (result newVal) newInf) (snd newInf) cRep+        where+            ((newVal, newInf), (cRep, newLine, newCol)) = flip StateMonad.runState (defaultState line col) $ do+                newVal <- monadicTransform' t (options, place, indent) val+                (_, nl, nc) <- StateMonad.get+                let newInf = ((line, col), (nl, nc))+                return (newVal, newInf) -    transform t (line, col) (options, place, indent) e@(ArrayElem name index inf1 inf2) = Result (ArrayElem (result newName) (result newIndex) newInf newInf) newSt cRep where-        prefix = case place of-            AddressNeed_pl  -> "&"-            _               -> ""-        at = prefix ++ "at(" ++ show_type options MainParameter_pl (typeof e) NoRestrict ++ ","-        newName = transform t (line, col + length at) (options, ValueNeed_pl, indent) name-        (line2, col2) = state newName-        newIndex = transform t (line2, col2 + length ",") (options, ValueNeed_pl, indent) index-        (line3, col3) = state newIndex-        newSt  = (line3, col3 + length ")")-        newInf = ((line, col), newSt)-        cRep = at ++ up newName ++ "," ++ up newIndex ++ ")"-        -    transform t (line, col) (options, place, indent) (StructField str field inf1 inf2) = Result (StructField (result newStr) field newInf newInf) newSt cRep where   -        newStr = transform t (line, col) (options, ValueNeed_pl, indent) str-        (line2, col2) = state newStr-        newSt  = (line2, col2 + length ("." ++ field))-        newInf = ((line, col), newSt)-        cRep = up newStr ++ "." ++ field+    transform t (line, col) (options, place, indent) e@(ArrayElem name index inf1 inf2) = Result (ArrayElem (result newName) (result newIndex) newInf newInf) (snd newInf) cRep +        where+            ((newName, newIndex, newInf), (cRep, newLine, newCol)) = flip StateMonad.runState (defaultState line col) $ do+                let prefix = case (place, typeof e) of+                       (AddressNeed_pl, _) -> "&"+                       (_, ArrayType _ _)  -> "&" -- TODO the call site should set the place to AddressNeed_pl for Arrays+                       _                   -> ""+                code $ prefix ++ "at(" ++ show_type options MainParameter_pl (typeof e) NoRestrict ++ ","+                newName  <- monadicTransform' t (options, AddressNeed_pl, indent) name+                code ","+                newIndex <- monadicTransform' t (options, ValueNeed_pl, indent) index+                code ")"+                (_, newLine, newCol) <- StateMonad.get+                let newInf = ((line, col), (newLine, newCol))+                return (newName, newIndex, newInf) -    transform t (line, col) (options, place, indent) (UnionField targetUnion field inf1 inf2) = Result (StructField (result newTarget) field newInf newInf) newSt cRep where   -        newTarget = transform t (line, col) (options, ValueNeed_pl, indent) targetUnion-        (line2, col2) = state newTarget-        newSt  = (line2, col2 + length ("." ++ field))-        newInf = ((line, col), newSt)-        cRep = up newTarget ++ "." ++ field+    transform t pos@(line, col) down@(options, place, indent) expr@(StructField str field inf1 inf2) = transformExpr t pos down expr ("." ++ field) field ValueNeed_pl -    transform t (line, col) (options, place, indent) (ConstExpr val inf) = Result (ConstExpr (result newVal) newInf) newSt cRep where-        newVal = transform t (line, col) (options, place, indent) val-        (line2, col2) = state newVal -        newSt  = (line2, col2)-        newInf = ((line, col), newSt)-        cRep = up newVal+    transform t (line, col) (options, place, indent) (ConstExpr val inf) = Result (ConstExpr (result newVal) newInf) (snd newInf) cRep+        where+            ((newVal, newInf), (cRep, newLine, newCol)) = flip StateMonad.runState (defaultState line col) $ do+                newVal <- monadicTransform' t (options, place, indent) val+                (_, nl, nc) <- StateMonad.get+                let newInf = ((line, col), (nl, nc))+                return (newVal, newInf) -    transform t (line, col) (options, place, indent) (FunctionCall "!" typ role [a,b] inf1 inf2) = Result (FunctionCall "!" typ role [result newA, result newB] newInf newInf) newSt cRep where   -        newA = transform t (line, col+3) (options, place, indent) a-        (line2, col2) = state newA-        newB = transform t (line2, col2 + length ",") (options, place, indent) b-        (line3, col3) = state newB-        newSt = (line3, col3 + length ")")-        newInf = ((line, col), newSt)-        cRep = "at(" ++ up newA ++ "," ++ up newB ++ ")"+    transform t pos@(line, col) down@(options, place, indent)+                fc@(FunctionCall f [a,b] inf1 inf2) | funName f == "!" =+                transformFuncCall t pos down fc "at(" "," ")" -    transform t (line, col) (options, place, indent) (FunctionCall fun typ InfixOp [a,b] inf1 inf2) = Result (FunctionCall fun typ InfixOp [result newA, result newB] newInf newInf) newSt cRep where   -        newA = transform t (line, col + length "(") (options, place, indent) a-        (line2, col2) = state newA-        newB = transform t (line2, col2 + length (" " ++ fun ++ " ")) (options, place, indent) b-        (line3, col3) = state newB-        newSt = (line3, col3 + length ")")-        newInf = ((line, col), newSt)-        cRep = "(" ++ up newA ++ " " ++ fun ++ " " ++ up newB ++ ")"-        -    transform t (line, col) (options, place, indent) (FunctionCall fun typ role paramlist inf1 inf2) =  Result (FunctionCall fun typ role (result1 newParamlist) newInf newInf) newSt cRep where   -        newParamlist = transform1 t (line, col + length (fun ++ "(")) (options, place, indent) paramlist        -        (line2, col2) = state1 newParamlist-        newSt = (line2, col2 + length ")")-        newInf = ((line, col), newSt)-        cRep = fun ++ "(" ++ up1 newParamlist ++ ")"+    transform t pos@(line, col) down@(options, place, indent)+                fc@(FunctionCall f [a,b] inf1 inf2) | funMode f == Infix =+                transformFuncCall t pos down fc "(" (" " ++ funName f ++ " ") ")" -    transform t (line, col) (options, place, indent) (Cast typ exp inf1 inf2) =  Result (Cast typ (result newExp) newInf newInf) newSt cRep where   -        prefix = concat ["(", toC options place typ, ")("]-        newExp = transform t (line, col + length prefix) (options, place, indent) exp-        (line2, col2) = state newExp-        newSt  = (line2, col2 + length ")")-        newInf = ((line, col), newSt)-        cRep = prefix ++ up newExp ++ ")" +    transform t (line, col) (options, place, indent)+                (FunctionCall f paramlist inf1 inf2) =+                Result (FunctionCall f (result1 newParamlist) newInf newInf) (snd newInf) cRep +        where+            ((newParamlist, newInf), (cRep, newLine, newCol)) = flip StateMonad.runState (defaultState line col) $ do+                code $ funName f ++ "("+                newParamlist <- monadicListTransform' t (options, place, indent) paramlist+                code ")"+                (_, nl, nc) <- StateMonad.get+                let newInf = ((line, col), (nl, nc))+                return (newParamlist, newInf) -    transform t (line, col) (options, place, indent) (SizeOf (Left typ) inf1 inf2) = Result (SizeOf (Left typ) newInf newInf) newSt cRep where   -        col2 = col + length cRep-        newSt = (line, col2)-        newInf = ((line, col), newSt)-        cRep = "sizeof(" ++ toC options place typ ++ ")"-        -    transform t (line, col) (options, place, indent) (SizeOf (Right exp) inf1 inf2) = Result (SizeOf (Right (result newExp)) newInf newInf) newSt cRep where   -        newExp = transform t (line, col + length "sizeof(") (options, place, indent) exp-        (line2, col2) = state newExp-        newSt  = (line2, col2 + length ")")-        newInf = ((line, col), newSt)-        cRep = "sizeof(" ++ up newExp ++ ")"   +    transform t (line, col) (options, place, indent) (Cast typ exp inf1 inf2) =  Result (Cast typ (result newExp) newInf newInf) (snd newInf) cRep +        where+            ((newExp, newInf), (cRep, newLine, newCol)) = flip StateMonad.runState (defaultState line col) $ do+                code $ concat ["(", toC options place typ, ")("]+                newExp <- monadicTransform' t (options, place, indent) exp+                code ")"+                (_, nl, nc) <- StateMonad.get+                let newInf = ((line, col), (nl, nc))+                return (newExp, newInf) -instance Transformable1 DebugToC [] Definition where-    transform1 t (line, col) (options, place, indent) [] = Result1 [] (line, col) ""-    transform1 t (line, col) (options, place, indent) (x:xs) = Result1 ((result newX):(result1 newXs)) (state1 newXs) (up newX ++ up1 newXs) where-        newX = transform t (line, col) (options, place, indent) x-        (line2, col2) =  state newX-        newSt = (line2, col2) -        newXs = transform1 t newSt (options, place, indent) xs+    transform t (line, col) (options, place, indent) (SizeOf (Left typ) inf1 inf2) = Result (SizeOf (Left typ) newInf newInf) (snd newInf) cRep +        where+            ((newInf), (cRep, newLine, newCol)) = flip StateMonad.runState (defaultState line col) $ do+                code ("sizeof(" ++ toC options place typ ++ ")")+                (_, nl, nc) <- StateMonad.get+                let newInf = ((line, col), (nl, nc))+                return newInf +    transform t (line, col) (options, place, indent) (SizeOf (Right exp) inf1 inf2) = Result (SizeOf (Right (result newExp)) newInf newInf) (newLine, newCol) cRep +        where+            ((newExp, newInf), (cRep, newLine, newCol)) = flip StateMonad.runState (defaultState line col) $ do+                code "sizeof"+                newExp <- monadicTransform' t (options, place, indent) exp+                code ")"+                (_, nl, nc) <- StateMonad.get+                let newInf = ((line, col), (nl, nc))+                return (newExp, newInf) +instance Transformable1 DebugToC [] Entity where+    transform1 t pos@(line, col) down@(options, place, indent) l = transform1' t pos down l "" 0+ instance Transformable DebugToC Module where-    transform t (line, col) (options, place, indent) (Module defList inf) = Result (Module (result1 newDefList) newInf) newSt cRep where   -        newDefList = transform1 t (line, col) (options, place, indent) defList        -        (line2, col2) = state1 newDefList-        newSt = (line2, col2)-        newInf = ((line, col), newSt)-        cRep = up1 newDefList+    transform t (line, col) (options, place, indent) (Module defList inf) = Result (Module (result1 newDefList) newInf) (snd newInf) cRep +        where+            ((newDefList, newInf), (cRep, newLine, newCol)) = flip StateMonad.runState (defaultState line col) $ do+                newDefList <- monadicListTransform' t (options, place, indent) defList+                (_, nl, nc) <- StateMonad.get+                let newInf = ((line, col), (nl, nc))+                return (newDefList, newInf)  instance Transformable1 DebugToC [] Variable where-    transform1 t (line, col) (options, place, indent) [] = Result1 [] (line, col) ""-    transform1 t (line, col) (options, place, indent) (x:[]) = Result1 ((result newX):[]) (state newX) (up newX) where-        newX = transform t (line, col) (options, place, indent) x-    transform1 t (line, col) (options, place, indent) (x:xs) = Result1 ((result newX):(result1 newXs)) (state1 newXs) (up newX ++ ", " ++ up1 newXs) where-        newX = transform t (line, col) (options, place, indent) x-        (line2, col2) =  state newX-        newSt = (line2, col2 + length ", ") -        newXs = transform1 t newSt (options, place, indent) xs-+    transform1 t pos@(line, col) down@(options, place, indent) l = transform1' t pos down l ", " 0  instance Transformable1 DebugToC [] StructMember where     transform1 t (line, col) (options, place, indent) [] = Result1 [] (line, col) ""-    transform1 t (line, col) (options, place, indent) (x:xs) = Result1 ((result newX):(result1 newXs)) (state1 newXs) ((putIndent indent ++ up newX ++"\n" ) ++ up1 newXs) where-        newX = transform t (line, col) (options, place, indent) x-        (line2, col2) =  state newX-        newSt = (line2 + 1, indent) -        newXs = transform1 t newSt (options, place, indent) xs+    transform1 t (line, col) (options, place, indent) (x:xs) = Result1 ((result newX):(result1 newXs)) (state1 newXs) (cRep) where+        ((newX, newXs), (cRep, newLine, newCol)) = flip StateMonad.runState (defaultState line col) $ do+            indenter indent+            newX <- monadicTransform' t (options, place, indent) x+            newXs <- monadicListTransform' t (options, place, indent) xs+            return (newX, newXs) -instance Transformable1 DebugToC [] UnionMember where-    transform1 t (line, col) (options, place, indent) [] = Result1 [] (line, col) ""-    transform1 t (line, col) (options, place, indent) (x:xs) = Result1 ((result newX):(result1 newXs)) (state1 newXs) ((putIndent indent ++ up newX ++"\n" ) ++ up1 newXs) where-        newX = transform t (line, col) (options, place, indent) x-        (line2, col2) =  state newX-        newSt = (line2 + 1, indent) -        newXs = transform1 t newSt (options, place, indent) xs -instance Transformable DebugToC Definition where-    transform t (line, col) (options, place, indent) (Struct name members inf1 inf2) = Result (Struct name (result1 newMembers) newInf newInf) newSt cRep where   -        newIndent = indent + 4-        newMembers = transform1 t (line + 1, newIndent) (options, place, newIndent) members -        (line2, col2) = state1 newMembers-        newSt = (line2 + 1, indent)-        newInf = ((line, col), newSt)-        cRep = name ++ " {\n"  ++ up1 newMembers ++ putIndent indent ++ "};\n" +instance Transformable DebugToC Entity where+    transform t (line, col) (options, place, indent) (StructDef name members inf1 inf2) = Result (StructDef name (result1 newMembers) newInf newInf) (snd newInf) cRep+        where+            ((newMembers, newInf), (cRep, newLine, newCol)) = flip StateMonad.runState (defaultState line col) $ do+                code $ name ++ " {\n"+                (crep, cl, cc) <- StateMonad.get+                StateMonad.put (crep, cl, cc + (addIndent indent))+                newMembers <- monadicListTransform' t (options, place, addIndent indent) members+                indenter indent+                code "};\n"+                (crep, cl, _) <- StateMonad.get+                StateMonad.put (crep, cl, indent)+                let newInf = ((line, col), (cl, indent))+                return (newMembers, newInf) -    transform t (line, col) (options, place, indent) (Union name members inf1 inf2) = Result (Union name (result1 newMembers) newInf newInf) newSt cRep where   -        newIndent = indent + 4-        newMembers = transform1 t (line + 1, newIndent) (options, place, newIndent) members -        (line2, col2) = state1 newMembers-        newSt = (line2 + 1, indent)-        newInf = ((line, col), newSt)-        cRep = name ++ " {\n"  ++ up1 newMembers ++ putIndent indent ++ "};\n"  +    transform t (line, col) (options, place, indent) (ProcDef name inParam outParam body inf1 inf2) =+      Result (ProcDef name (result1 newInParam) (result1 newOutParam) (result newBody) newInf newInf) (snd newInf) cRep+        where+            ((newInParam, newOutParam, newBody, newInf), (cRep, newLine, newCol)) = flip StateMonad.runState (defaultState line col) $ do+                code $ memoryInformation options indent inf1+                indenter indent+                -- code "#include <stdio.h>\n"+                code $ "void " ++ name ++ "("+                newInParam <- monadicListTransform' t (options, MainParameter_pl, indent) inParam+                let str = case up1 newInParam of+                     ""            -> ""+                     otherwise     -> ", "+                code str+                newOutParam <- monadicListTransform' t (options, MainParameter_pl, indent) outParam+                code $ ")\n"+                indenter indent+                -- code "{\nprintf(\"enter\\n\");\n"+                -- code "printf(\"out:%p buffer:%p len:%d esize:%d\\n\", out, out->buffer, out->length, out->elemSize);\n"+                code "{\n"+                (crep, al, _) <- StateMonad.get+                StateMonad.put (crep, al, addIndent indent)+                newBody <- monadicTransform' t (options, Declaration_pl, addIndent indent) body+                indenter indent+                code "}\n"+                -- code "printf(\"leave\\n\");\n}\n"+                (_, nl, _) <- StateMonad.get+                let newInf = ((line, col), (nl, indent))+                return (newInParam, newOutParam, newBody, newInf) -    transform t (line, col) (options, place, indent) (Procedure name inParam outParam body inf1 inf2) = Result (Procedure name (result1 newInParam) (result1 newOutParam) (result newBody) newInf newInf) newSt cRep where   -        newInParam = transform1 t (line, col + length ("void " ++ name ++ "(")) (options, MainParameter_pl, indent) inParam-        (line2, col2) = state1 newInParam-        (newSt1, newInPStr) | up1 newInParam == ""  = ((line2, col2), "")-                            | otherwise             = ((line2, col2 + length ", "), up1 newInParam ++ ", ")-        newOutParam = transform1 t newSt1 (options, MainParameter_pl, indent) outParam-        (line3, col3) = state1 newOutParam-        newIndent = indent + 4-        newBody = transform t (line3 + 2, newIndent) (options, Declaration_pl, newIndent) body-        (line4, col4) = state newBody-        newSt = (line4 + 1, indent)-        newInf = ((line, col), newSt)-        cRep = putIndent indent ++ "void "++ name ++ "(" ++ newInPStr ++ up1 newOutParam ++ ")\n" ++ putIndent indent ++ "{\n"  ++ up newBody ++ putIndent indent ++ "}\n" +    transform t (line, col) (options, place, indent) (ProcDecl name inParam outParam inf1 inf2) =+      Result (ProcDecl name (result1 newInParam) (result1 newOutParam) newInf newInf) (snd newInf) cRep+        where+            ((newInParam, newOutParam, newInf), (cRep, newLine, newCol)) = flip StateMonad.runState (defaultState line col) $ do+                code $ memoryInformation options indent inf1+                indenter indent+                code $ "void " ++ name ++ "("+                newInParam <- monadicListTransform' t (options, MainParameter_pl, indent) inParam+                let str = case up1 newInParam of+                     ""            -> ""+                     otherwise     -> ", "+                code str+                newOutParam <- monadicListTransform' t (options, MainParameter_pl, indent) outParam+                code $ ");\n"+                (_, nl, _) <- StateMonad.get+                let newInf = ((line, col), (nl, indent))+                return (newInParam, newOutParam, newInf) -    transform t (line, col) (options, place, indent) (Prototype returnType name inParam outParam inf1 inf2) = Result (Prototype returnType name (result1 newInParam) (result1 newOutParam) newInf newInf) newSt cRep where   -        newInParam = transform1 t (line, col + length (" " ++ name ++ "(")) (options, MainParameter_pl, indent) inParam-        (line2, col2) = state1 newInParam-        (newSt1, newInPStr) | up1 newInParam == ""  = ((line2, col2), "")-                            | otherwise             = ((line2, col2 + length ", "), up1 newInParam ++ ", ")-        newOutParam = transform1 t newSt1 (options, MainParameter_pl, indent) outParam-        (line3, col3) = state1 newOutParam-        newSt = (line3 + 1, indent)-        newInf = ((line, col), newSt)-        cRep = putIndent indent ++ " "++ name ++ "(" ++ newInPStr ++ up1 newOutParam ++ ");\n"  +memoryInformation :: Options -> Int -> AllocationInfo -> String+memoryInformation options indent inf1+    | (memoryInfoVisible options) = displayComment indent $ ["Memory information", "" ] +++        (zipWith displayMemInfo ["Local", "Input", "Output"] [localMI, inputMI, outputMI]) ++ [ "" ]+    | otherwise = ""+        where (localMI, inputMI, outputMI) = inf1 -    transform t (line, col) (options, place, indent) (GlobalVar decl inf1 inf2) = Result (GlobalVar (result newDecl) newInf newInf) newSt cRep where -        newDecl = transform t (line, col) (options, place, indent) decl-        (line2, col2) = state newDecl-        newSt = (line2 + 1, indent)-        newInf = ((line, col), newSt)-        cRep = up newDecl ++ ";\n"-        -instance Transformable DebugToC StructMember where-    transform t (line, col) (options, place, indent) dsm@(StructMember str typ inf) = Result (StructMember str typ newInf) newSt cRep where   -        col2 = col + length cRep-        newSt = (line, col2)-        newInf = ((line, col), newSt)-        cRep = case structMemberType dsm of-            ArrayType len innerType -> show_variable options place Value (structMemberType dsm)-                                                 (structMemberName dsm) ++ ";"-            otherwise -> (toC options place $ structMemberType dsm) ++ " " ++ structMemberName dsm ++ ";"+displayComment :: Int -> [String] -> String+displayComment indent = unlines . map (putIndent indent ++) . (["/*"] ++) . (++ [" */"]) . map (" * " ++) -instance Transformable DebugToC UnionMember where-    transform t (line, col) (options, place, indent) dsm@(UnionMember str typ inf) = Result (UnionMember str typ newInf) newSt cRep where   -        col2 = col + length cRep-        newSt = (line, col2)-        newInf = ((line, col), newSt)-        cRep = case unionMemberType dsm of-            ArrayType len innerType -> show_variable options place Value (unionMemberType dsm)-                                                 (unionMemberName dsm) ++ ";"-            otherwise -> (toC options place $ unionMemberType dsm) ++ " " ++ unionMemberName dsm ++ ";"+displayMemInfo :: String -> [Type] -> String+displayMemInfo name [] = name ++ ": none"+displayMemInfo name info = name ++ ": " ++ (concat $ List.intersperse ", " $ map displayType info) +displayType :: Type -> String+displayType (ArrayType (LiteralLen n) (ArrayType (LiteralLen m) t)) =+    unwords [displayType t, concat ["array(", show n, "x", show m, ")"]]+displayType (ArrayType (LiteralLen n) t) = unwords [displayType t, concat ["array(", show n, ")"]]+displayType (ArrayType UndefinedLen t) = unwords [displayType t, "array"]+displayType VoidType = "void"+displayType BoolType = "Boolean"+displayType BitType = "bit"+displayType FloatType = "float"+displayType (NumType signed size) = unwords [sg signed, (sz size) ++ "-bit", "integer"]+  where+    sg Signed   = "signed"+    sg Unsigned = "unsigned"+    sz S8  = "8"+    sz S16 = "16"+    sz S32 = "32"+    sz S40 = "40"+    sz S64 = "64"+displayType (ComplexType t) = unwords ["complex", displayType t]+displayType (UserType s) = s+displayType (StructType fields) = "struct"++instance Transformable DebugToC StructMember where+    transform t (line, col) (options, place, indent) dsm@(StructMember str typ inf) = Result (StructMember str typ newInf) (snd newInf) cRep +        where+            ((newInf), (cRep, newLine, newCol)) = flip StateMonad.runState (defaultState line col) $ do+                let t = case structMemberType dsm of+                     ArrayType len innerType -> show_variable options place Value (structMemberType dsm)+                                                     (structMemberName dsm) ++ ";"+                     otherwise -> (toC options place $ structMemberType dsm) ++ " " ++ structMemberName dsm ++ ";"+                code t+                (_, nl, nc) <- StateMonad.get+                let newInf = ((line, col), (nl, nc))+                return newInf+ instance Transformable1 DebugToC [] Declaration where     transform1 t (line, col) (options, place, indent) [] = Result1 [] (line, col) ""     transform1 t (line, col) (options, place, indent) (x:xs) = Result1 ((result newX):(result1 newXs)) (state1 newXs) ((putIndent indent ++ up newX ++ ";\n" ) ++ up1 newXs) where@@ -468,179 +456,267 @@         newXs = transform1 t newSt (options, place, indent) xs  instance Transformable DebugToC Block where-    transform t (line, col) (options, place, indent) (Block locs body inf) = Result (Block (result1 newLocs) (result newBody) newInf) newSt cRep where   -        newLocs = transform1 t (line, col) (options, Declaration_pl, indent) locs-        (line2, col2) = state1 newLocs-        newSt1  | up1 newLocs == "" = (line2, col2)-                | otherwise         = (line2 + 1, indent) -        newBody = transform t newSt1 (options, place, indent) body-        (line3, col3) = state newBody-        newSt = (line3, col3) -        newInf = ((line, col), newSt)-        --cRep = up1 newLocs ++ "\n"  ++ up newBody-        cRep =  listprint id "\n" [up1 newLocs, up newBody]-    +    transform t (line, col) (options, place, indent) (Block locs body inf) = Result (Block (result1 newLocs) (result newBody) newInf) (snd newInf) cRep+        where+            ((newLocs, newBody, newInf), (cRep, newLine, newcol)) = flip StateMonad.runState (defaultState line col) $ do+                newLocs <- monadicListTransform' t (options, Declaration_pl, indent) locs+                let str = case up1 newLocs of +                     ""             -> ""+                     otherwise     -> "\n"+                code str+                newBody <- monadicTransform' t (options, place, indent) body+                (_, nl, nc) <- StateMonad.get+                let newInf = ((line, col), (nl, indent))+                return (newLocs, newBody, newInf)+ instance Transformable DebugToC Declaration where-    transform t (line, col) (options, place, indent) (Declaration declVar Nothing inf) = Result (Declaration (result newDeclVar) Nothing newInf) newSt cRep where-        newDeclVar = transform t (line, col) (options, Declaration_pl, indent) declVar-        (line2, col2) = state newDeclVar-        newSt = (line2, col2)-        newInf = ((line, col), newSt)-        cRep = up newDeclVar-        -    transform t (line, col) (options, place, indent) (Declaration declVar (Just expr) inf) = Result (Declaration (result newDeclVar) (Just (result newExpr)) newInf) newSt cRep where-        newDeclVar = transform t (line, col) (options, Declaration_pl, indent) declVar-        (line2, col2) = state newDeclVar-        newExpr = transform t (line2, col2 + length " = ") (options, ValueNeed_pl, indent) expr-        (line3, col3) = state newExpr-        newSt = (line3, col3)-        newInf = ((line, col), newSt)-        cRep = up newDeclVar ++ " = " ++ up newExpr+    transform t (line, col) (options, place, indent) (Declaration declVar Nothing inf) = Result (Declaration (result newDeclVar) Nothing newInf) (snd newInf) cRep+        where+            ((newDeclVar, newInf), (cRep, newLine, newCol)) = flip StateMonad.runState (defaultState line col) $ do+                newDeclVar <- monadicTransform' t (options, Declaration_pl, indent) declVar+                (_, nl, nc) <- StateMonad.get+                let newInf = ((line, col), (nl, nc))+                return (newDeclVar, newInf) +    transform t (line, col) (options, place, indent) (Declaration declVar (Just expr) inf) = Result (Declaration (result newDeclVar) (Just (result newExpr)) newInf) (snd newInf) cRep +        where+            ((newDeclVar, newExpr, newInf), (cRep, newLine, newCol)) = flip StateMonad.runState (defaultState line col) $ do+                newDeclVar <- monadicTransform' t (options, Declaration_pl, indent) declVar+                code " = "+                newExpr <- monadicTransform' t (options, ValueNeed_pl, indent) expr+                (_, nl, nc) <- StateMonad.get+                let newInf = ((line, col), (nl, nc))+                return (newDeclVar, newExpr, newInf)+ instance Transformable1 DebugToC [] ActualParameter where-    transform1 t (line, col) (options, place, indent) [] = Result1 [] (line, col) ""-    transform1 t (line, col) (options, place, indent) [x] = Result1 [(result newX)] (state newX) (up newX)-        where      -            newX = transform t (line, col) (options, place, indent) x-            -    transform1 t (line, col) (options, place, indent) (x:xs) =-        Result1 ((result newX):(result1 newXs)) (state1 newXs) ((up newX ++ ", ") ++ up1 newXs)-          where-            newX = transform t (line, col) (options, place, indent) x-            (line2, col2) =  state newX-            newSt = (line2 , col2 + length ", ") -            newXs = transform1 t newSt (options, place, indent) xs+    transform1 t pos@(line, col) down@(options, place, indent) l = transform1' t pos down l ", " 0  instance Transformable1 DebugToC [] Program where-    transform1 t (line, col) (options, place, indent) [] = Result1 [] (line, col) ""-    transform1 t (line, col) (options, place, indent) (x:xs) = Result1 ((result newX):(result1 newXs)) (state1 newXs) (up newX ++ up1 newXs) where-        newX = transform t (line, col) (options, place, indent) x-        (line2, col2) =  state newX-        newSt = (line2, col2) -        newXs = transform1 t newSt (options, place, indent) xs+    transform1 t pos@(line, col) down@(options, place, indent) l = transform1' t pos down l "" 0 -instance Transformable1 DebugToC [] SwitchCase where-    transform1 t (line, col) (options, place, indent) [] = Result1 [] (line, col) ""-    transform1 t (line, col) (options, place, indent) (x:xs) = Result1 ((result newX):(result1 newXs)) (state1 newXs) ((up newX ++"break;\n" ) ++ up1 newXs) where-        newX = transform t (line, col) (options, place, indent) x-        (line2, col2) =  state newX-        newSt = (line2 + 1, indent) -        newXs = transform1 t newSt (options, place, indent) xs  instance Transformable DebugToC Program where     transform t (line, col) (options, place, indent) (Empty inf1 inf2) = Result (Empty newInf newInf) newSt cRep where          newSt = (line, col)-        newInf = ((line, col), newSt)      -        cRep = ""  +        newInf = ((line, col), newSt)+        cRep = "" -    transform t (line, col) (options, place, indent) (Comment True comment inf1 inf2) = Result (Comment True comment newInf newInf) newSt cRep where -        lineNum = length $ lines $ comment ++ "a"-        newSt = (lineNum + 1, indent)-        newInf = ((line, col), newSt)      -        cRep = "/* " ++ comment ++ " */\n"  +    transform t (line, col) (options, place, indent) (Comment True comment inf1 inf2) = Result (Comment True comment newInf newInf) (snd newInf) cRep +        where+            ((newInf), (cRep, newLine, newCol)) = flip StateMonad.runState (defaultState line col) $ do+                indenter indent+                code $ "/* " ++ comment ++ " */\n"+                (_, nl, nc) <- StateMonad.get+                let newInf = ((line, col), (nl, nc))+                return (newInf) -    transform t (line, col) (options, place, indent) (Comment False comment inf1 inf2) = Result (Comment False comment newInf newInf) newSt cRep where -        newSt = (line + 1, indent)-        newInf = ((line, col), newSt)      -        cRep = "// " ++ comment ++ "\n"  +    transform t (line, col) (options, place, indent) (Comment False comment inf1 inf2) = Result (Comment False comment newInf newInf) (snd newInf) cRep +        where +            ((newInf), (cRep, newLine, newCol)) = flip StateMonad.runState (defaultState line col) $ do+                indenter indent+                code $ "// " ++ comment ++ "\n"+                (_, nl, nc) <- StateMonad.get+                let newInf = ((line, col), (nl, nc))+                return (newInf) -    transform t (line, col) (options, place, indent) (Assign lhs rhs inf1 inf2) = Result (Assign (result newLhs) (result newRhs) newInf newInf) newSt cRep where -        newLhs = transform t (line, col) (options, ValueNeed_pl, indent) lhs-        (line2, col2) = state newLhs-        newRhs = transform t (line2, col2 + length " = ") (options, ValueNeed_pl, indent) rhs-        (line3, col3) = state newRhs-        newSt = (line3 + 1, indent)    -        newInf = ((line, col), newSt)-        cRep = putIndent indent ++ up newLhs ++ " = " ++ up newRhs ++ ";\n" +    transform t (line, col) (options, place, indent) (Assign lhs rhs inf1 inf2) = Result (Assign (result newLhs) (result newRhs) newInf newInf) (snd newInf) cRep+        where+            ((newLhs, newRhs, newInf), (cRep, newLine, newCol)) = flip StateMonad.runState (defaultState line col) $ do+                indenter indent+                newLhs <- monadicTransform' t (options, ValueNeed_pl, indent) lhs+                code " = "+                newRhs <- monadicTransform' t (options, ValueNeed_pl, indent) rhs+                code ";\n"+                (_, nl, nc) <- StateMonad.get+                let newInf = ((line, col), (nl, indent))+                return (newLhs, newRhs, newInf) -    transform t (line, col) (options, place, indent) (ProcedureCall name param inf1 inf2) = Result (ProcedureCall name (result1 newParam) newInf newInf) newSt cRep where -        newParam = transform1 t (line, col + length name + length "(") (options, place, indent) param -        (line2, col2) = state1 newParam-        newSt = (line2 +1, indent) -        newInf = ((line, col), newSt)-        cRep = putIndent indent ++ name ++ "(" ++ up1 newParam ++ ");\n" +    transform t (line, col) (options, place, indent) (ProcedureCall name param inf1 inf2) = Result (ProcedureCall name (result1 newParam) newInf newInf) (snd newInf) cRep +        where+            ((newParam, newInf), (cRep, newLine, newCol)) = flip StateMonad.runState (defaultState line col) $ do+                indenter indent+                code $ name ++ "("+                newParam <- monadicListTransform' t (options, place, indent) param+                code ");\n"+                (_, nl, nc) <- StateMonad.get+                let newInf = ((line, col), (nl, indent))+                return (newParam, newInf) -    transform t (line, col) (options, place, indent) (Sequence prog inf1 inf2) = Result (Sequence (result1 newProg) newInf newInf) newSt cRep where -        newProg = transform1 t (line, col) (options, place, indent) prog-        (line2, col2) = state1 newProg-        newSt = (line2, col2) -        newInf = ((line, col), newSt)-        cRep = up1 newProg-        -    transform t (line, col) (options, place, indent) (Branch con tPrg ePrg inf1 inf2) = Result (Branch (result newCon) (result newTPrg) (result newEPrg) newInf newInf) newSt cRep where -        newCon = transform t (line, col + length "if(") (options, ValueNeed_pl, indent) con-        (line2, col2) = state newCon-        newTPrg = transform t (line2 + 2, indent + 4) (options, place, indent + 4) tPrg-        (line3, col3) = state newTPrg-        newEPrg = transform t (line3 + 3, indent + 4) (options, place, indent + 4) ePrg-        (line4, col4) = state newEPrg-        newSt = (line4 + 1, indent)-        newInf = ((line, col), newSt)-        cRep = putIndent indent ++ "if(" ++ up newCon ++ ")\n" ++ putIndent indent ++ "{\n" ++-            up newTPrg ++ putIndent indent ++ "}\n" ++ putIndent indent ++ "else\n" ++ putIndent indent -            ++ "{\n" ++ up newEPrg ++ putIndent indent ++ "}\n"+    transform t (line, col) (options, place, indent) (Sequence prog inf1 inf2) = Result (Sequence (result1 newProg) newInf newInf) (snd newInf) cRep +        where+            ((newProg, newInf), (cRep, newLine, newCol)) = flip StateMonad.runState (defaultState line col) $ do+                newProg <- monadicListTransform' t (options, place, indent) prog+                let newInf = ((line, col), state1 newProg)+                return (newProg, newInf) -    transform t (line, col) (options, place, indent) (Switch cond cases inf1 inf2) = Result (Switch (result newCond) (result1 newCases) newInf newInf) newSt cRep where -        newCond = transform t (line, col + length "switch (") (options, ValueNeed_pl, indent) cond-        (line2, col2) = state newCond-        newCases = transform1 t (line + 2, indent + 4) (options, place, indent + 4) cases-        (line3, col3) = state1 newCases-        newSt = (line3 + 1, indent)-        newInf = ((line, col), newSt)-        cRep = "switch (" ++ up newCond ++")\n" ++ putIndent indent ++ "{\n" ++ up1 newCases ++ putIndent indent ++ "}\n"-        -    transform t (line, col) (options, place, indent) (SeqLoop con conPrg blockPrg inf1 inf2) = Result (SeqLoop (result newCon) (result newConPrg) (result newBlockPrg) newInf newInf) newSt cRep where     -        newConPrg = transform t (line + 1, indent + 4) (options, place, indent + 4) conPrg-        (line2, col2) = state newConPrg-        newCon = transform t (line2, indent + 4 + length "while(") (options, ValueNeed_pl, indent + 4) con-        (line3, col3) = state newCon-        newBlockPrg = transform t (line2 + 2, indent + 4 + length "{\n") (options, place, indent + 8) blockPrg-        (line4, col4) = state newBlockPrg-        loopEnd = transform t (line4, col4) (options, place, indent + 8) (blockBody conPrg)-        (line5, col5) = state loopEnd-        newSt = (line5 + 2, indent)-        newInf = ((line, col), newSt)-        cRep = putIndent indent ++ "{\n" ++ up newConPrg ++ putIndent (indent + 4) ++ "while(" ++-            up newCon ++ ")\n" ++ putIndent (indent + 4) ++ "{\n" ++ up newBlockPrg ++ up loopEnd ++ -            putIndent (indent + 4) ++ "}\n" ++ putIndent indent ++ "}\n"-    -    transform t (line, col) (options, place, indent) (ParLoop count bound step prog inf1 inf2) = Result (ParLoop (result newCount) (result newBound) step (result newProg) newInf newInf) newSt cRep where     -        newCount = transform t (line + 1, indent + 4) (options, Declaration_pl, indent + 4) count-        (line2, col2) = state newCount-        for_init = transform t (line2 + 1, indent + 4 + length "for(") (options, ValueNeed_pl, indent + 4) count-        (line3, col3) = state for_init-        for_test = transform t (line3, col3 + length " = 0; ") (options, ValueNeed_pl, indent + 4) count -        (line4, col4) = state for_test-        newBound = transform t (line4, col4 + length " < ") (options, ValueNeed_pl, indent + 4) bound-        (line5, col5) = state newBound-        for_inc = transform t (line5, col5 + length "; ") (options, ValueNeed_pl, indent + 4) count-        (line6, col6) = state for_inc-        newProg = transform t (line6 + 2, indent + 8) (options, place, indent + 8) prog-        (line7, col7) = state newProg-        newSt = (line7 + 2, indent)-        newInf = ((line, col), newSt)-        cRep = putIndent indent ++ "{\n" ++ putIndent (indent + 4) ++ up newCount ++ ";\n" ++ putIndent (indent + 4) ++ -            "for(" ++ up for_init ++ " = 0; " ++ up for_test ++ " < " ++ up newBound ++ "; " ++ up for_inc ++-            " += " ++ show step ++  ")\n" ++ putIndent (indent + 4) ++ "{\n" ++ up newProg ++ putIndent (indent + 4) ++  -            "}\n" ++ putIndent indent ++ "}\n"-    -    transform t (line, col) (options, place, indent) (BlockProgram prog inf) = Result (BlockProgram (result newProg) newInf) newSt cRep where     -        newProg = transform t (line + 1, indent + 4) (options, place, indent + 4) prog-        (line2, col2) = state newProg-        newSt = (line2 + 1, indent)-        newInf = ((line, col), newSt)-        cRep =  putIndent indent ++ "{\n" ++ up newProg ++ putIndent indent ++ "}\n"  +    transform t (line, col) (options, place, indent) (Branch con tPrg ePrg inf1 inf2) = Result (Branch (result newCon) (result newTPrg) (result newEPrg) newInf newInf) (snd newInf) cRep +        where +            ((newCon, newTPrg, newEPrg, newInf), (cRep, newLine, newCol)) = flip StateMonad.runState (defaultState line col) $ do+                indenter indent+                code "if("+                newCon <- monadicTransform' t (options, ValueNeed_pl, indent) con+                code ")\n" +                indenter indent+                code "{\n"+                newTPrg <- monadicTransform' t (options, place, addIndent indent) tPrg+                indenter indent+                code "}\n" +                indenter indent +                code "else\n" +                indenter indent +                code "{\n"+                newEPrg <- monadicTransform' t (options, place, addIndent indent) ePrg+                indenter indent +                code "}\n"+                (_, nl, nc) <- StateMonad.get+                let newInf = ((line, col), (nl, nc))+                return (newCon, newTPrg, newEPrg, newInf) -instance Transformable DebugToC SwitchCase where-    transform t (line, col) (options, place, indent) (SwitchCase matcher impl inf) = Result (SwitchCase (result newMatcher) (result newImpl) newInf) newSt cRep where -        newMatcher = transform t (line, indent + length "case ") (options, place, indent) matcher-        (line2, col2) = state newMatcher-        newImpl = transform t (line2 + 1, indent + 4) (options, place, indent + 4) impl-        (line3, col3) = state newImpl-        newSt = (line3, col3 + length "}")-        newInf = ((line, col), newSt)      -        cRep = "case " ++ up newMatcher ++ ": {\n" ++ up newImpl ++ putIndent indent ++ "}"  +    transform t (line, col) (options, place, indent) (SeqLoop con conPrg blockPrg inf1 inf2) = Result (SeqLoop (result newCon) (result newConPrg) (result newBlockPrg) newInf newInf) (snd newInf) cRep +        where+            ((newCon, newConPrg, newBlockPrg, newInf), (cRep, newLine, newCol)) = flip StateMonad.runState (defaultState line col) $ do+                indenter indent+                code "{\n"+                newConPrg <- monadicTransform' t (options, place, addIndent indent) conPrg+                indenter $ addIndent indent+                code "while("+                newCon <- monadicTransform' t (options, ValueNeed_pl, addIndent indent) con+                code $ ")\n" +                indenter $ addIndent indent+                code "{\n"+                newBlockPrg <- monadicTransform' t (options, place, addIndent $ addIndent indent) blockPrg+                monadicTransform' t (options, place, addIndent $ addIndent indent) (blockBody conPrg)+                indenter $ addIndent indent+                code "}\n" +                indenter indent +                code "}\n"+                (_, nl, nc) <- StateMonad.get+                let newInf = ((line, col), (nl, nc))+                return (newCon, newConPrg, newBlockPrg, newInf) -    -            +    transform t (line, col) (options, place, indent) (ParLoop count bound step prog inf1 inf2) = Result (ParLoop (result newCount) (result newBound) step (result newProg) newInf newInf) (snd newInf) cRep +        where+            ((newCount, newBound, newProg, newInf), (cRep, newLine, newCol)) = flip StateMonad.runState (defaultState line col) $ do+                indenter indent+                code "for("+                newCount <- monadicTransform' t (options, Declaration_pl, addIndent indent) count+                code $ " = 0; "+                loopVariable <- monadicTransform' t (options, ValueNeed_pl, addIndent indent) count+                code $ " < "+                newBound <- monadicTransform' t (options, ValueNeed_pl, addIndent indent) bound+                code $ "; " ++ up loopVariable ++ " += " ++ show step ++ ")\n" +                indenter indent+                code "{\n"+                -- code "printf(\"before\\n\");\n"+                newProg <- monadicTransform' t (options, place, addIndent indent) prog+                -- code "printf(\"after\\n\");\n"+                indenter indent+                code "}\n" +                (_, nl, nc) <- StateMonad.get+                let newInf = ((line, col), (nl, nc))+                return (loopVariable, newBound, newProg, newInf)++    transform t (line, col) (options, place, indent) (BlockProgram prog inf) = Result (BlockProgram (result newProg) newInf) (snd newInf) cRep +        where+            ((newProg, newInf), (cRep, newLine, newCol)) = flip StateMonad.runState (defaultState line col) $ do+                indenter indent +                code "{\n"+                newProg <- monadicTransform' t (options, place, addIndent indent) prog+                indenter indent +                code "}\n"+                (_, nl, nc) <- StateMonad.get+                let newInf = ((line, col), (newLine, newCol))+                return (newProg, newInf)+ putIndent ind = concat $ replicate ind " "++addIndent :: Int -> Int+addIndent indent = indent + 4++transform1' t (line, col) (options, place, indent) [] str num = Result1 [] (line, col) ""+transform1' t (line, col) (options, place, indent) (x:[]) str num = Result1 ((result newX):[]) (state newX) (up newX) where+    newX = transform t (line, col) (options, place, indent) x+transform1' t (line, col) (options, place, indent) (x:xs) str num = Result1 ((result newX):(result1 newXs)) (state1 newXs) (up newX ++ str ++ up1 newXs) where+    newX = transform t (line, col) (options, place, indent) x+    (line2, col2) =  state newX+    newSt = (line2 + num, col2 + length str) +    newXs = transform1 t newSt (options, place, indent) xs++transformConst t (line, col) (options, place, indent) const str = Result (newConst const) (line, newCol) cRep +    where+        newConst (IntConst c t _ _) = (IntConst c t newInf newInf)+        newConst (FloatConst c _ _) = (FloatConst c newInf newInf)+        newConst (BoolConst c _ _) = (BoolConst c newInf newInf)+        newInf = ((line, col), (line, newCol))+        (cRep, newLine, newCol) = snd $ flip StateMonad.runState (defaultState line col) $ do+        let s = case (List.find (\(t',_) -> t' == typeof const) $ values $ platform options) of+             Just (_,f) -> f const+             Nothing    -> str+        code s++transformActParam t (line, col) (options, place, indent) act paramType = Result (newActParam act) (snd newInf) cRep +    where+        newActParam (Out _ _) = (Out (result newParam) newInf)+        newActParam _ = (In (result newParam) newInf)+        getParam (In param _) = param+        getParam (Out param _) = param+        ((newParam, newInf), (cRep, newLine, newCol)) = flip StateMonad.runState (defaultState line col) $ do+            newParam <- monadicTransform' t (options, paramType, indent) (getParam act)+            (_, nl, nc) <- StateMonad.get+            let newInf = ((line, col), (nl, nc))+            return (newParam, newInf)++transformFuncCall t (line, col) (options, place, indent)+                  (FunctionCall f [a, b] inf1 inf2) str1 str2 str3 =+                  Result (FunctionCall f [result newA, result newB] newInf newInf) (snd newInf) cRep+    where+        ((newA, newB, newInf), (cRep, newLine, newCol)) = flip StateMonad.runState (defaultState line col) $ do+            code str1+            newA <- monadicTransform' t (options, place, indent) a+            code str2+            newB <- monadicTransform' t (options, place, indent) b+            code str3+            (_, nl, nc) <- StateMonad.get+            let newInf = ((line, col), (nl, nc))+            return (newA, newB, newInf)++transformExpr t (line, col) (options, place, indent) expr str field paramType = Result (newExpr expr) (snd newInf) cRep +    where+        newExpr (StructField e s _ _ ) = (StructField (result newTarget) s newInf newInf)+        getExpr (StructField e _ _ _ ) = e+        ((newTarget, newInf), (cRep, newLine, newCol)) = flip StateMonad.runState (defaultState line col) $ do+            newTarget <- monadicTransform' t (options, paramType, indent)  (getExpr expr)+            code str+            (_, nl, nc) <- StateMonad.get+            let newInf = ((line, col), (nl, nc))+            return (newTarget, newInf)+++code s = do+    (str, line, col) <- StateMonad.get+    let numEOF = length (filter (=='\n') s)+    StateMonad.put (str++s,line + numEOF, (if numEOF == 0 then col else 0) + (length $ takeWhile (/='\n') $ reverse s))++indenter n = do+    (str, line, col) <- StateMonad.get+    StateMonad.put (str ++ (concat $ replicate n " "), line, col)++monadicTransform' t down@(options, place, indent) d = do+    (cRep, line, col) <- StateMonad.get+    let res = transform t (line, col) down d+    code $ up res+    return res++complexTransform t down@(options, place, indent) d = do+    (cRep, line, col) <- StateMonad.get+    let res = transform t (line, col) down d+    return res++monadicListTransform' t down@(options, place, indent) l = do+    (_, line, col) <- StateMonad.get+    let resList = transform1 t (line, col) down l+    code $ up1 resList+    return resList++defaultState :: Int -> Int -> (String, Int, Int)+defaultState line col = ("", line, col)
+ Feldspar/Compiler/Backend/C/Plugin/Rule.hs view
@@ -0,0 +1,89 @@+--+-- Copyright (c) 2009-2011, 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 UndecidableInstances #-}++module Feldspar.Compiler.Backend.C.Plugin.Rule+    ( RulePlugin(..)+    ) where++import Data.Maybe+import Data.Typeable++import Feldspar.Compiler.Imperative.Representation+import Feldspar.Compiler.Imperative.Frontend+import Feldspar.Transformation+import Feldspar.Compiler.Backend.C.Options+import Feldspar.Compiler.Error++userError = handleError "Feldspar.Compiler.Backend.C.Plugin.Rule" InternalError++data RulePlugin = RulePlugin++instance Transformation RulePlugin+  where+    type From RulePlugin     = ()+    type To RulePlugin       = ()+    type Down RulePlugin     = Options+    type Up RulePlugin       = [Rule]+    type State RulePlugin    = Int++instance Plugin RulePlugin+  where+    type ExternalInfo RulePlugin = Options+    executePlugin _ externalInfo = result . transform RulePlugin (0{-initial ID-}) externalInfo++instance (DefaultTransformable RulePlugin t, Typeable1 t) => Transformable RulePlugin t where+    transform t s d orig = recurse { result = x'', up = pr1 ++ pr2 ++ pr3, state = newID2 }+      where+        recurse = defaultTransform t s d orig+        applyRule :: t () -> Int -> [Rule] -> (t (), [Rule], [Rule], Int)+        applyRule c s rs = foldl applyRuleFun (c,[],[],s) rs+          where+            applyRuleFun :: (t (), [Rule], [Rule], Int) -> Rule -> (t (), [Rule], [Rule], Int) +            applyRuleFun (cc,incomp,prop,currentID) (Rule r) = case cast r of+                Just r' -> (cc',incomp,prop ++ prop', newID)+                  where+                    (cc',prop', newID) = applyAction cc currentID (r' cc)+                    applyAction :: t () -> Int -> [Action (t ())] -> (t (), [Rule], Int)+                    applyAction ccc currentID actions = foldl applyActionFun (ccc,[],currentID) actions+                      where+                        applyActionFun :: (t (), [Rule], Int) -> Action (t ()) -> (t (), [Rule], Int)+                        applyActionFun (_, prop'', currentID) (Replace newConstr) = (newConstr, prop'', currentID)+                        applyActionFun (ccc', prop'', currentID) (Propagate pr) = (ccc', prop'' ++ [pr], currentID)+                        applyActionFun (constr, ruleList, currentID) (WithId f) +                            = applyAction constr (currentID + 1) (f currentID)+                        applyActionFun (constr, ruleList, currentID) (WithOptions f)+                            = applyAction constr currentID (f d)+                Nothing -> (cc,incomp ++ [Rule r],prop, currentID)+        (x',_,pr1,newID1) = applyRule (result recurse) (state recurse) (rules d)+        (x'',pr3,pr2,newID2) = applyRule x' newID1 (up recurse)+++instance Combine [Rule] where+    combine = (++)
Feldspar/Compiler/Backend/C/Plugin/TypeCorrector.hs view
@@ -1,3 +1,31 @@+--+-- Copyright (c) 2009-2011, ERICSSON AB+-- All rights reserved.+-- +-- Redistribution and use in source and binary forms, with or without+-- modification, are permitted provided that the following conditions are met:+-- +--     * Redistributions of source code must retain the above copyright notice, +--       this list of conditions and the following disclaimer.+--     * Redistributions in binary form must reproduce the above copyright+--       notice, this list of conditions and the following disclaimer in the+--       documentation and/or other materials provided with the distribution.+--     * Neither the name of the ERICSSON AB nor the names of its contributors+--       may be used to endorse or promote products derived from this software+--       without specific prior written permission.+-- +-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"+-- AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE+-- IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +-- DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE+-- FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+-- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR+-- SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER+-- CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,+-- OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+-- OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.+--+ {-# LANGUAGE EmptyDataDecls, TypeFamilies #-}  module Feldspar.Compiler.Backend.C.Plugin.TypeCorrector where@@ -10,8 +38,9 @@ import Feldspar.Compiler.Error  -- ===========================================================================---  == Type definition generator plugin+--  == Type corrector plugin -- ===========================================================================+-- TODO: IS THIS STILL NEEDED?   typeCorrectorError = handleError "PluginArch/TypeCorrector" InternalError @@ -30,8 +59,7 @@     type State GlobalCollector = TypeCatalog  -instance Transformable GlobalCollector Definition where-        transform t s d p@(GlobalVar v inf1 inf2) = defaultTransform t s True p+instance Transformable GlobalCollector Entity where         transform t s d p = defaultTransform t s False p  instance Transformable GlobalCollector Variable where@@ -61,8 +89,8 @@     type Up TypeCheck = [String]                -- errors     type State TypeCheck = TypeCatalog          -- local variable's types     -instance Transformable TypeCheck Definition where-        transform t s d p@(Procedure _ _ _ _ _ _) = defaultTransform t s' d' p where+instance Transformable TypeCheck Entity where+        transform t s d p@(ProcDef _ _ _ _ _ _) = defaultTransform t s' d' p where             s' = def                       -- start with an empty local variable type catalog             d' = inDecl d True             --input parameters are declarations (block will correct where it isn't good)         transform t s d p = Result p s def -- just definitions, not implementation, not need check/correct@@ -118,8 +146,8 @@     type Up TypeCorrector = ()     type State TypeCorrector = TypeCatalog    -- local variable's types     -instance Transformable TypeCorrector Definition where-    transform t s d p@(Procedure n i o _ _ _) = defaultTransform t (state tr) d p where+instance Transformable TypeCorrector Entity where+    transform t s d p@(ProcDef n i o _ _ _) = defaultTransform t (state tr) d p where         tr = defaultTransform t def d p -- start with an empty local variable type catalog     transform t s d p = Result p s def -- just definitions, not implementation, not need check/correct @@ -146,8 +174,6 @@             select'' UndefinedLen x = (True, x)             select'' x UndefinedLen = (True, x)             select'' (LiteralLen a) (LiteralLen b) = (a==b, (LiteralLen b))-            select'' (IndirectLen a) (IndirectLen b) = (a==b, (IndirectLen b))-            select'' _ _ = (False, undefined)         select' (StructType t1) (StructType t2) = (o, StructType t) where             (o,t) = select'' t1 t2             select'' [] [] = (True, [])
Feldspar/Compiler/Backend/C/Plugin/TypeDefinitionGenerator.hs view
@@ -1,3 +1,31 @@+--+-- Copyright (c) 2009-2011, ERICSSON AB+-- All rights reserved.+-- +-- Redistribution and use in source and binary forms, with or without+-- modification, are permitted provided that the following conditions are met:+-- +--     * Redistributions of source code must retain the above copyright notice, +--       this list of conditions and the following disclaimer.+--     * Redistributions in binary form must reproduce the above copyright+--       notice, this list of conditions and the following disclaimer in the+--       documentation and/or other materials provided with the distribution.+--     * Neither the name of the ERICSSON AB nor the names of its contributors+--       may be used to endorse or promote products derived from this software+--       without specific prior written permission.+-- +-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"+-- AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE+-- IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +-- DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE+-- FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+-- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR+-- SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER+-- CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,+-- OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+-- OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.+--+ {-# LANGUAGE EmptyDataDecls, TypeFamilies #-}  module Feldspar.Compiler.Backend.C.Plugin.TypeDefinitionGenerator where@@ -18,22 +46,15 @@  data TypeDefinitionGenerator = TypeDefinitionGenerator -getTypes :: Options -> Type -> [Definition ()]+getTypes :: Options -> Type -> [Entity ()] getTypes options typ = {-trace ("DEBUG: "show typ) $-} case typ of     StructType members -> concatMap (getTypes options . snd) members-                       ++ [Struct {+                       ++ [StructDef {                                structName      = toC options Declaration_pl (StructType members),                                structMembers   = map (\(name,typ) -> StructMember name typ ()) members,                                structLabel     = (),                                definitionLabel = ()                           }]-    UnionType members -> concatMap (getTypes options . snd) members-                       ++ [Union {-                               unionName       = toC options Declaration_pl (UnionType members),-                               unionMembers    = map (\(name,typ) -> UnionMember name typ ()) members,-                               unionLabel      = (),-                               definitionLabel = ()-                          }]     ArrayType len baseType -> getTypes options baseType     _ -> []     -- XXX complexType?@@ -43,13 +64,13 @@     type To TypeDefinitionGenerator = ()     type Down TypeDefinitionGenerator = Options     type Up TypeDefinitionGenerator = ()-    type State TypeDefinitionGenerator = [Definition ()]+    type State TypeDefinitionGenerator = [Entity ()]  instance Transformable TypeDefinitionGenerator Module where     transform selfpointer origState fromAbove origModule = defaultTransformationResult {         result = (result defaultTransformationResult) {-            definitions = (nub $ state defaultTransformationResult)-                       ++ (definitions $ result defaultTransformationResult)+            entities = (nub $ state defaultTransformationResult)+                     ++ (entities $ result defaultTransformationResult)         }     } where         defaultTransformationResult = defaultTransform selfpointer origState fromAbove origModule
Feldspar/Compiler/Backend/C/Plugin/VariableRoleAssigner.hs view
@@ -1,3 +1,31 @@+--+-- Copyright (c) 2009-2011, 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.Backend.C.Plugin.VariableRoleAssigner where  import Data.List@@ -20,13 +48,13 @@ instance Transformable VariableRoleAssigner Variable where         transform t s d v = Result v' () () where             v' = v { varRole = if (varName v `elem` outParametersVRA d) ||-                            (isStruct v && (varName v `elem` inParametersVRA d))+                            (isComposite v && (varName v `elem` "mem" : inParametersVRA d))                         then Pointer else Value                    , varLabel = ()                    } -instance Transformable VariableRoleAssigner Definition where-        transform t s d p@(Procedure n i o pr inf1 inf2) = defaultTransform t s d' p where+instance Transformable VariableRoleAssigner Entity where+        transform t s d p@(ProcDef n i o pr inf1 inf2) = defaultTransform t s d' p where             d' = Parameters                     { inParametersVRA = map varName i                     , outParametersVRA = map varName o@@ -38,7 +66,9 @@     executePlugin self@VariableRoleAssigner externalInfo procedure =          result $ transform self ({-state-}) (Parameters [] []) procedure -isStruct :: Variable () -> Bool-isStruct v = case varType v of-    (StructType types) -> True-    otherwise -> False+isComposite :: Variable () -> Bool+isComposite v = case varType v of+    (ArrayType _ _) -> True+    (StructType _)  -> True+    otherwise       -> False+
Feldspar/Compiler/Compiler.hs view
@@ -1,19 +1,47 @@+--+-- Copyright (c) 2009-2011, 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 where -import Data.Map import System.IO+import System.FilePath import Data.Typeable as DT+import Control.Arrow+import Control.Applicative  import Feldspar.Core.Types import Feldspar.Transformation-import qualified Feldspar.NameExtractor as Precompiler--import Feldspar.Compiler.Imperative.Representation+import qualified Feldspar.NameExtractor as NameExtractor import Feldspar.Compiler.Backend.C.Options import Feldspar.Compiler.Backend.C.Platforms import Feldspar.Compiler.Backend.C.Library import Feldspar.Compiler.Imperative.Plugin.Naming-import Feldspar.Compiler.Backend.C.Plugin.HandlePrimitives+import Feldspar.Compiler.Backend.C.Plugin.Rule import Feldspar.Compiler.Imperative.Plugin.Unroll import Feldspar.Compiler.Backend.C.Plugin.TypeDefinitionGenerator import Feldspar.Compiler.Backend.C.Plugin.VariableRoleAssigner@@ -26,157 +54,206 @@ import Feldspar.Compiler.Backend.C.CodeGeneration import Feldspar.Compiler.Imperative.FromCore -data SomeCompilable = forall a . Compilable a => SomeCompilable a+data SomeCompilable = forall a internal . Compilable a internal => SomeCompilable a     deriving (DT.Typeable)  -- ================================================================================================ --  == Compiler core -- ================================================================================================ +type Position = (Int, Int) -compileToC :: (Compilable t) =>-    CompilationMode -> t -> Precompiler.OriginalFunctionSignature -> Options -> Int -> (String, (Int, Int))-compileToC compilationMode prg originalFunctionSignature coreOptions lineNum =-    compToC ((coreOptions, Declaration_pl), lineNum) $ executePluginChain compilationMode prg originalFunctionSignature {-        Precompiler.originalFunctionName = fixFunctionName $ Precompiler.originalFunctionName originalFunctionSignature-    } coreOptions+data SplitModuleDescriptor = SplitModuleDescriptor {+    smdSource :: Module AllocationEliminatorSemanticInfo,+    smdHeader :: Module AllocationEliminatorSemanticInfo+} -compileToCWithInfos :: (Compilable t) =>-    CompilationMode -> t -> Precompiler.OriginalFunctionSignature -> Options -> Int -> (Module DebugToCSemanticInfo, (String, (Int, Int)))-compileToCWithInfos compilationMode prg originalFunctionSignature coreOptions lineNum =-    compToCWithInfos ((coreOptions, Declaration_pl), lineNum) $ executePluginChain compilationMode prg originalFunctionSignature {-        Precompiler.originalFunctionName = fixFunctionName $ Precompiler.originalFunctionName originalFunctionSignature-    } coreOptions+data CompToCCoreResult = CompToCCoreResult {+    sourceCode      :: String,+    endPosition     :: Position,+    debugModule     :: Module DebugToCSemanticInfo,+    allocationInfo  :: AllocationInfo+} -compileToCWithHeaders :: (Compilable t) =>-    CompilationMode -> t -> Precompiler.OriginalFunctionSignature -> Options -> (String, (Int, Int))-compileToCWithHeaders compilationMode prg originalFunctionSignature coreOptions =-     (headers ++ cSource, endPos) where-         (cSource, endPos) = compileToC compilationMode prg originalFunctionSignature coreOptions lineNum-         (headers, lineNum) = genHeaders coreOptions+data SplitCompToCCoreResult = SplitCompToCCoreResult {+    sctccrSource :: CompToCCoreResult,+    sctccrHeader :: CompToCCoreResult+} -compileToCWithHeaders_Infos :: (Compilable t) =>-    CompilationMode -> t -> Precompiler.OriginalFunctionSignature -> Options -> (Module DebugToCSemanticInfo, (String, (Int, Int)))-compileToCWithHeaders_Infos compilationMode prg originalFunctionSignature coreOptions =-     (debugModule, (headers ++ cSource, endPos)) where-         (debugModule, (cSource, endPos)) = compileToCWithInfos compilationMode prg originalFunctionSignature coreOptions lineNum-         (headers, lineNum) = genHeaders coreOptions+data IncludesNeeded = IncludesNeeded | NoIncludesNeeded { incneedLineNum :: Int } +moduleSplitter :: Module AllocationEliminatorSemanticInfo -> SplitModuleDescriptor+moduleSplitter m = SplitModuleDescriptor {+    smdHeader = Module ((filter belongsToHeader $ entities m) ++ (createProcDecls $ entities m)) (moduleLabel m),+    smdSource = Module (filter (not . belongsToHeader) $ entities m) (moduleLabel m)+} where+    belongsToHeader :: Entity AllocationEliminatorSemanticInfo -> Bool+    belongsToHeader (StructDef _ _ _ _) = True+    belongsToHeader (ProcDecl _ _ _ _ _) = True+    belongsToHeader _ = False+    createProcDecls :: [Entity AllocationEliminatorSemanticInfo] -> [Entity AllocationEliminatorSemanticInfo]+    createProcDecls [] = []+    createProcDecls (e:es) = convertProcDefToProcDecl e ++ createProcDecls es+    convertProcDefToProcDecl :: Entity AllocationEliminatorSemanticInfo -> [Entity AllocationEliminatorSemanticInfo]+    convertProcDefToProcDecl e = case e of+        ProcDef name inparams outparams body label1 label2 -> [ProcDecl name inparams outparams label1 label2]+        anythingelse -> [] --- ================================================================================================---  == Standalone compilation--- ================================================================================================+mergeAllocationInfos :: [AllocationInfo] -> AllocationInfo+mergeAllocationInfos = foldr plus ([],[],[]) -standaloneCompile :: (Compilable t) =>-    t -> FilePath -> FilePath -> Precompiler.OriginalFunctionSignature -> Options -> IO ()-standaloneCompile prg inputFileName outputFileName originalFunctionSignature opts =-    appendFile outputFileName $ fst $ compileToCWithHeaders Standalone prg originalFunctionSignature opts+(x1,y1,z1) `plus` (x2,y2,z2) = (x1 ++ x2, y1 ++ y2, z1 ++ z2) --- ================================================================================================---  == Interactive compilation--- ================================================================================================+separateAndCompileToCCore :: (Compilable t internal)+  => (Module AllocationEliminatorSemanticInfo+  -> [Module AllocationEliminatorSemanticInfo])+  -> CompilationMode -> t -> IncludesNeeded+  -> NameExtractor.OriginalFunctionSignature -> Options+  -> [(CompToCCoreResult, Module AllocationEliminatorSemanticInfo)]+separateAndCompileToCCore+  moduleSeparator+  compilationMode prg needed+  functionSignature coreOptions =+    pack <$> separatedModules+      where+        pack = compToCWithInfo &&& id -data PrgType = ForType | AssignType | IfType | SwitchType+        separatedModules =+          moduleSeparator $+          executePluginChain' compilationMode prg functionSignature coreOptions -getProgram :: (Int, Int) -> PrgType -> Module DebugToCSemanticInfo -> IO ()-getProgram (line, col) prgtype prg = res where-     res = case find of -                True -> putStrLn $ myShow code-                _    -> putStrLn "Not found appropriate code part!"-     (find, code) = case prgtype of-                        ForType     -> getPrgParLoop (line, col) prg-                        AssignType  -> getPrgAssign (line, col) prg-                        IfType      -> getPrgBranch (line, col) prg-                        SwitchType  -> getPrgSwitch (line, col) prg-      +        compToCWithInfo = moduleToCCore needed coreOptions -compile :: (Compilable t) => t -> FilePath -> String -> Options -> IO ()-compile prg fileName functionName opts = writeFile fileName $-    fst $ compileToCWithHeaders Interactive prg (Precompiler.OriginalFunctionSignature functionName []) opts+moduleToCCore+  :: IncludesNeeded -> Options -> Module AllocationEliminatorSemanticInfo+  -> CompToCCoreResult+moduleToCCore needed opts mdl =+  CompToCCoreResult {+    sourceCode      = includes ++ moduleSrc+  , endPosition     = endPos+  , debugModule     = dbgModule+  , allocationInfo  = extractAllocations mdl+  }+  where+    (includes, lineNum) = genInclude needed -icompile :: (Compilable t) => t -> IO ()-icompile prg = putStrLn $-    fst $ compileToCWithHeaders Interactive prg (Precompiler.OriginalFunctionSignature "test" []) defaultOptions+    (dbgModule, (moduleSrc, endPos)) =+      compToCWithInfos ((opts,Declaration_pl), lineNum) mdl -icompile' :: (Compilable t) => t -> String -> Options -> IO ()-icompile' prg functionName opts = putStrLn $-    fst $ compileToCWithHeaders Interactive prg (Precompiler.OriginalFunctionSignature functionName []) opts+    genInclude IncludesNeeded         = genIncludeLines opts Nothing+    genInclude (NoIncludesNeeded ln)  = ("", ln) -icompileWithInfos_ ::  (Compilable t) => t -> String -> Options -> (Module DebugToCSemanticInfo, (String, (Int, Int)))-icompileWithInfos_ prg functionName opts = compileToCWithHeaders_Infos Interactive prg (Precompiler.OriginalFunctionSignature functionName []) opts+    extractAllocations =+      entities              >>>+      filter isProcedure    >>>+      (procDefLabel <$>)    >>>+      mergeAllocationInfos+      where+        isProcedure (ProcDef _ _ _ _ _ _) = True+        isProcedure _ = False -genIncludeLines :: [String] -> (String, Int)-genIncludeLines []   = ("", 1)-genIncludeLines (x:xs) = ("#include " ++ x ++ "\n" ++ str, linenum + 1) where-    (str, linenum) = genIncludeLines xs+-- ===========================================================+--  ___ ... --- === ::: [ COMPILER CORE ] ::: === --- ... ___+-- ===========================================================+-- This functionality should not be duplicated. Instead, everything should call this and only do a trivial interface adaptation.+compileToCCore+  :: (Compilable t internal) => CompilationMode -> t -> Maybe String -> IncludesNeeded+  -> NameExtractor.OriginalFunctionSignature -> Options+  -> SplitCompToCCoreResult+compileToCCore compilationMode prg outputFileName includesNeeded+  originalFunctionSignature coreOptions =+    createSplit $ fst <$> separateAndCompileToCCore headerAndSource+      compilationMode prg includesNeeded originalFunctionSignature coreOptions+  where+    headerAndSource modules = [header, source]+      where (SplitModuleDescriptor header source) = moduleSplitter modules -genHeaders :: Options -> (String, Int)-genHeaders coreOptions = (str ++ "\n\n", linenum + 2) where-    (str, linenum)  = genIncludeLines (includes $ platform coreOptions)--- genHeaders coreOptions = (str ++ "#define " ++ defaultArraySizeConstantName ++ " (" ++ (show $ defaultArraySize coreOptions) ++ ")\n\n", linenum + 2) where-    -- (str, linenum)  = genIncludeLines (includes $ platform coreOptions)+    createSplit [header, source] = SplitCompToCCoreResult header source +genIncludeLinesCore :: [String] -> (String, Int)+genIncludeLinesCore []   = ("", 1)+genIncludeLinesCore (x:xs) = ("#include " ++ x ++ "\n" ++ str, linenum + 1) where+    (str, linenum) = genIncludeLinesCore xs++genIncludeLines :: Options -> Maybe String -> (String, Int)+genIncludeLines coreOptions mainHeader = (str ++ "\n\n", linenum + 2) where+    (str, linenum)  = genIncludeLinesCore $ (includes $ platform coreOptions) ++ mainHeaderCore+    mainHeaderCore = case mainHeader of+        Nothing -> []+        Just filename -> ["\"" ++ takeFileName filename ++ ".h\""]+ ------------------------ -- Predefined options -- ------------------------ -forPrg = ForType-ifPrg  = IfType-assignPrg = AssignType-switchPrg = SwitchType-- defaultOptions     = Options     { platform          = c99     , unroll            = NoUnroll     , debug             = NoDebug-    , defaultArraySize  = 16+    , memoryInfoVisible = True+    , rules             = []     }  c99PlatformOptions              = defaultOptions tic64xPlatformOptions           = defaultOptions { platform = tic64x } unrollOptions                   = defaultOptions { unroll = Unroll 8 } noPrimitiveInstructionHandling  = defaultOptions { debug = NoPrimitiveInstructionHandling }+noMemoryInformation             = defaultOptions { memoryInfoVisible = False }  -- =========================================================================== --  == Plugin system -- =========================================================================== -pluginChain :: ExternalInfoCollection -> Module () -> Module ()+pluginChain :: ExternalInfoCollection -> Module () -> Module AllocationEliminatorSemanticInfo pluginChain externalInfo     = (executePlugin AllocationEliminator ())+    . (executePlugin RulePlugin (ruleExternalInfo externalInfo))     . (executePlugin TypeDefinitionGenerator (typeDefinitionGeneratorExternalInfo externalInfo))     . (executePlugin ConstantFolding ())     . (executePlugin UnrollPlugin (unrollExternalInfo externalInfo))     . (executePlugin Precompilation (precompilationExternalInfo externalInfo))+    . (executePlugin RulePlugin (primitivesExternalInfo externalInfo))      . (executePlugin VariableRoleAssigner (variableRoleAssignerExternalInfo externalInfo))-    . (executePlugin HandlePrimitives (handlePrimitivesExternalInfo externalInfo))     . (executePlugin TypeCorrector (typeCorrectorExternalInfo externalInfo))     . (executePlugin BlockProgramHandler ())-   + data ExternalInfoCollection = ExternalInfoCollection {       precompilationExternalInfo          :: ExternalInfo Precompilation     , unrollExternalInfo                  :: ExternalInfo UnrollPlugin-    , handlePrimitivesExternalInfo        :: ExternalInfo HandlePrimitives+    , primitivesExternalInfo              :: ExternalInfo RulePlugin+    , ruleExternalInfo                    :: ExternalInfo RulePlugin     , typeDefinitionGeneratorExternalInfo :: ExternalInfo TypeDefinitionGenerator     , variableRoleAssignerExternalInfo    :: ExternalInfo VariableRoleAssigner     , typeCorrectorExternalInfo           :: ExternalInfo TypeCorrector } -executePluginChain :: (Compilable p) =>-    CompilationMode -> p -> Precompiler.OriginalFunctionSignature -> Options -> Module ()-executePluginChain compilationMode prg originalFunctionSignatureParam opt =-    (pluginChain ExternalInfoCollection {-        precompilationExternalInfo = PrecompilationExternalInfo {-            originalFunctionSignature = originalFunctionSignatureParam,-            inputParametersDescriptor = buildInParamDescriptor prg,-            numberOfFunctionArguments = numArgs prg,-            compilationMode = compilationMode-        }-        , unrollExternalInfo            = unroll opt-        , handlePrimitivesExternalInfo  = (defaultArraySize opt, debug opt, platform opt)-        , typeDefinitionGeneratorExternalInfo = opt-        , variableRoleAssignerExternalInfo = ()-        , typeCorrectorExternalInfo = False-    }) $ fromCore "PLACEHOLDER" prg+executePluginChain' :: (Compilable c internal)+  => CompilationMode -> c -> NameExtractor.OriginalFunctionSignature+  -> Options -> Module AllocationEliminatorSemanticInfo+executePluginChain' compilationMode prg originalFunctionSignatureParam opt =+  pluginChain ExternalInfoCollection {+    precompilationExternalInfo = PrecompilationExternalInfo {+        originalFunctionSignature = fixedOriginalFunctionSignature+      , inputParametersDescriptor = buildInParamDescriptor prg+      , numberOfFunctionArguments = numArgs prg+      , compilationMode           = compilationMode+      }+    , unrollExternalInfo                  = unroll opt+    , primitivesExternalInfo              = opt{ rules = platformRules $ platform opt }+    , ruleExternalInfo                    = opt+    , typeDefinitionGeneratorExternalInfo = opt+    , variableRoleAssignerExternalInfo    = ()+    , typeCorrectorExternalInfo           = False+    } $ fromCore "PLACEHOLDER" prg+  where+    ofn = NameExtractor.originalFunctionName+    errorPEI =+      (error "There is no defaultArraySize any more", debug opt, platform opt)+    fixedOriginalFunctionSignature = originalFunctionSignatureParam {+      NameExtractor.originalFunctionName =+        fixFunctionName $ ofn originalFunctionSignatureParam+    }++executePluginChain cm f sig opts =+  moduleSplitter $ executePluginChain' cm f sig opts
Feldspar/Compiler/Error.hs view
@@ -1,3 +1,31 @@+--+-- Copyright (c) 2009-2011, 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.Error where  data ErrorClass = InvariantViolation | InternalError | Warning
Feldspar/Compiler/Frontend/CommandLine/API.hs view
@@ -1,16 +1,63 @@+--+-- Copyright (c) 2009-2011, 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 Feldspar.Compiler.Frontend.CommandLine.API where +import qualified Feldspar.NameExtractor as NameExtractor+import Feldspar.Compiler.Backend.C.Options+import Feldspar.Compiler.Compiler+import Feldspar.Compiler.Imperative.FromCore import Feldspar.Compiler.Frontend.CommandLine.API.Library import Feldspar.Compiler.Backend.C.Library-import System.IO import Language.Haskell.Interpreter import qualified Data.Typeable as T+import Control.Monad +-- ====================================== System imports ==================================+import System.Directory+import System.FilePath+import System.IO+import System.Exit+import System.Environment+import System.Console.GetOpt+ data CompilationResult-	= CompilationSuccess-	| CompilationFailure-	deriving (Eq, Show, T.Typeable)+    = CompilationSuccess+    | CompilationFailure+  deriving (Eq, Show, T.Typeable) +#ifdef RELEASE+releaseMode = True+#else+releaseMode = False+#endif+   -- A general interpreter body for interpreting an expression generalInterpreterBody :: forall a . (T.Typeable (IO a))                        => String -- the expression to interpret@@ -22,18 +69,20 @@                      => String -- the module name (for example My.Module)                      -> String -- the input file name (for example "My/Module.hs")                      -> [String] -- globalImportList-                     -> Bool -- need to load global modules?                      -> Bool -- need to import global modules qualified?                      -> Interpreter (IO a) -- ^ an interpreter body                      -> IO CompilationResult-highLevelInterpreter moduleName inputFileName importList needGlobal needQualify interpreterBody = do+highLevelInterpreter moduleName inputFileName importList needQualify interpreterBody = do   actionToExecute <- runInterpreter $ do     set [ languageExtensions := [GADTs, ScopedTypeVariables, TypeSynonymInstances, StandaloneDeriving,                                  DeriveDataTypeable, FlexibleContexts, FlexibleInstances, MultiParamTypeClasses,                                  FunctionalDependencies, ExistentialQuantification, Rank2Types, TypeOperators,-                                 EmptyDataDecls, GeneralizedNewtypeDeriving, TypeFamilies]+                                 EmptyDataDecls, GeneralizedNewtypeDeriving, TypeFamilies,+                                 UnknownExtension "ImplicitPrelude"]       ]-    loadModules $ [inputFileName] ++ if needGlobal then importList else []+    -- in relesae mode, globalImportList modules are package modules and shouldn't be loaded, only imported+    -- in normal mode, we need to load them before importing them+    loadModules $ [inputFileName] ++ if not releaseMode then importList else []     setTopLevelModules [moduleName]     -- Import modules qualified to prevent name collisions with user defined entities     if needQualify@@ -52,8 +101,51 @@ printInterpreterError :: InterpreterError -> IO () printInterpreterError (WontCompile []) = return () printInterpreterError (WontCompile (x:xs)) = do-	printGhcError x-	printInterpreterError (WontCompile xs)-	where-		printGhcError (GhcError {errMsg=s}) = hPutStrLn stderr s+    printGhcError x+    printInterpreterError (WontCompile xs)+  where+    printGhcError (GhcError {errMsg=s}) = hPutStrLn stderr s printInterpreterError e = hPutStrLn stderr $ "Code generation failed: " ++ show e++handleOptions :: [OptDescr (a -> IO a)] -> a -> String -> IO (a, String)+handleOptions descriptors startOptions helpHeader = do+    args <- getArgs++    when (length args == 0) (do+        putStrLn $ usageInfo helpHeader descriptors+        exitWith ExitSuccess)++    -- Parse options, getting a list of option actions+    let (actions, nonOptions, errors) = getOpt Permute descriptors args++    when (length errors > 0) (do+        putStrLn $ concat errors+        putStrLn $ usageInfo helpHeader descriptors+        exitWith (ExitFailure 1))++    -- Here we thread startOptions through all supplied option actions+    opts <- foldl (>>=) (return startOptions) actions++    when (length nonOptions /= 1) (do+        putStrLn "ERROR: Exactly one input file expected."+        exitWith (ExitFailure 1))++    let inputFileName = replace (head nonOptions) "\\" "/" -- change it for multi-file operation++    return (opts, inputFileName)++removeFileIfPossible :: String -> IO ()+removeFileIfPossible filename = removeFile filename `Prelude.catch` (const $ return())++prepareInputFile :: String -> IO ()+prepareInputFile inputFileName = do+    removeFileIfPossible $ replaceExtension inputFileName ".hi"+    removeFileIfPossible $ replaceExtension inputFileName ".o"++standaloneCompile :: (Compilable t internal) =>+    t -> FilePath -> FilePath -> NameExtractor.OriginalFunctionSignature -> Options -> IO ()+standaloneCompile prg inputFileName outputFileName originalFunctionSignature opts = do+    appendFile (makeCFileName outputFileName) $ sourceCode $ sctccrSource compilationResult+    appendFile (makeHFileName outputFileName) $ sourceCode $ sctccrHeader compilationResult+  where+    compilationResult = compileToCCore Standalone prg (Just outputFileName) IncludesNeeded originalFunctionSignature opts
Feldspar/Compiler/Frontend/CommandLine/API/Constants.hs view
@@ -1,3 +1,31 @@+--+-- Copyright (c) 2009-2011, 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.Frontend.CommandLine.API.Constants where  globalImportList = ["Feldspar.Compiler.Compiler"]@@ -5,8 +33,4 @@ warningPrefix = "[WARNING]: " errorPrefix   = "[ERROR  ]: " -helpHeader = "Standalone Feldspar Compiler\nUsage: feldspar [options] inputfile\n" ++-         "Notes: \n" ++-         " * When no output file name is specified, the input file's name with .c extension is used\n" ++-         " * The inputfile parameter is always needed, even in single-function mode\n" ++-         "\nAvailable options: \n"+
Feldspar/Compiler/Frontend/CommandLine/API/Library.hs view
@@ -1,3 +1,31 @@+--+-- Copyright (c) 2009-2011, 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.Frontend.CommandLine.API.Library where  import qualified Feldspar.Compiler.Backend.C.Options as CoreOptions@@ -5,6 +33,8 @@  import Data.Char import Language.Haskell.Interpreter+import System.Console.ANSI+import Feldspar.Compiler.Backend.C.Library  lowerFirst :: String -> String lowerFirst (first:rest) = (toLower first : rest)@@ -34,3 +64,9 @@  iPutStr :: String -> Interpreter () iPutStr = liftIO . putStr++fancyWrite :: String -> IO ()+fancyWrite s = do+    withColor Blue $ putStr "=== [ "+    withColor Cyan $ putStr $ rpad 70 s+    withColor Blue $ putStrLn " ] ==="
Feldspar/Compiler/Frontend/CommandLine/API/Options.hs view
@@ -1,3 +1,31 @@+--+-- Copyright (c) 2009-2011, 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.Frontend.CommandLine.API.Options where  import qualified Feldspar.Compiler.Backend.C.Options as CompilerCoreOptions@@ -20,34 +48,39 @@ availablePlatformsStrRep = StandaloneLib.formatStringList $                               map (StandaloneLib.upperFirst . CompilerCoreOptions.name) availablePlatforms -data FunctionMode = SingleFunction String | MultiFunction+data StandaloneMode = SingleFunction String | MultiFunction -data Options = Options  { optSingleFunction     :: FunctionMode+data Options = Options  { optStandaloneMode     :: StandaloneMode                         , optOutputFileName     :: Maybe String                         , optCompilerMode       :: CompilerCoreOptions.Options                         }  -- | Default options startOptions :: Options-startOptions = Options  { optSingleFunction = MultiFunction+startOptions = Options  { optStandaloneMode = MultiFunction                         , optOutputFileName = Nothing                         , optCompilerMode   = CompilerCore.defaultOptions                         } +helpHeader = "Standalone Feldspar Compiler\nUsage: feldspar [options] inputfile\n" +++         "Notes: \n" +++         " * When no output file name is specified, the input file's name with .c extension is used\n" +++         " * The inputfile parameter is always needed, even in single-function mode\n" +++         "\nAvailable options: \n"+ -- | Option descriptions for getOpt optionDescriptors :: [ OptDescr (Options -> IO Options) ] optionDescriptors =     [ Option "f" ["singlefunction"]         (ReqArg-            (\arg opt -> return opt { optSingleFunction = SingleFunction arg })+            (\arg opt -> return opt { optStandaloneMode = SingleFunction arg })             "FUNCTION")         "Enables single-function compilation"-     , Option "o" ["output"]         (ReqArg             (\arg opt -> return opt { optOutputFileName = Just arg })-            "outputfile.c")-        "Overrides the file name for the generated output code"+            "outputfile")+        "Overrides the file names for the generated output code"      , Option "p" ["platform"]         (ReqArg@@ -70,16 +103,6 @@                                          { CompilerCoreOptions.debug = decodeDebug arg } })             "<level>")         "Specifies debug level (currently the only possible option is NoPrimitiveInstructionHandling)"-     , Option "a" ["defaultArraySize"]-        (ReqArg-            (\arg opt -> return opt {-                optCompilerMode = (optCompilerMode opt) {-                    CompilerCoreOptions.defaultArraySize = parseInt arg "Invalid default array size"-                }-            })-            "<size>")-        "Overrides default array size"-     , Option "h" ["help"]         (NoArg             (\_ -> do
Feldspar/Compiler/Frontend/CommandLine/Main.hs view
@@ -1,4 +1,31 @@-{-# LANGUAGE CPP #-}+--+-- Copyright (c) 2009-2011, 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 Main where -- ====================================== Feldspar imports ================================== import Feldspar.NameExtractor@@ -6,7 +33,7 @@ import qualified Feldspar.Compiler.Compiler as CompilerCore import Feldspar.Compiler.Backend.C.Options import qualified Feldspar.Compiler.Backend.C.Options as CoreOptions-import qualified Feldspar.Compiler.Frontend.CommandLine.API.Options as StandaloneOptions+import Feldspar.Compiler.Frontend.CommandLine.API.Options as StandaloneOptions import Feldspar.Compiler.Frontend.CommandLine.API.Constants import Feldspar.Compiler.Frontend.CommandLine.API.Library as StandaloneLib import Feldspar.Compiler.Backend.C.Library@@ -14,6 +41,7 @@ import Feldspar.Compiler.Imperative.Representation import Feldspar.Compiler.Backend.C.CodeGeneration import Feldspar.Compiler.Error+import Feldspar.Compiler.Backend.C.Plugin.AllocationEliminator import Feldspar.Compiler.Backend.C.Plugin.PrettyPrint -- ====================================== System imports ================================== import System.IO@@ -24,7 +52,6 @@ import System.FilePath import System.Directory import System.Environment-import System.Console.ANSI import System.Console.GetOpt -- ====================================== Control imports ================================== import Control.Monad@@ -41,55 +68,53 @@       InterpreterError InterpreterError     | InternalErrorCall String -compileFunction :: String -> String -> CoreOptions.Options -> Int -> OriginalFunctionSignature-                -> Interpreter ((String, Either (Module ()) CompilationError), Int)-compileFunction inFileName outFileName coreOptions linenum originalFunctionSignature = do+compileFunction :: String -> String -> CoreOptions.Options -> OriginalFunctionSignature+                -> Interpreter (String, Either SplitModuleDescriptor CompilationError)+compileFunction inFileName outFileName coreOptions originalFunctionSignature = do     let functionName = originalFunctionName originalFunctionSignature     (SomeCompilable prg) <- interpret ("SomeCompilable " ++ functionName) (as::SomeCompilable)-    let compilationUnit = executePluginChain Standalone prg originalFunctionSignature {-        originalFunctionName = fixFunctionName $ originalFunctionName originalFunctionSignature-    } coreOptions+    let splitModuleDescriptor = executePluginChain Standalone prg originalFunctionSignature coreOptions     -- XXX force evaluation in order to be able to catch the exceptions     -- liftIO $ evaluate $ compToC coreOptions compilationUnit -- XXX somehow not enough(?!) -- counter-example: structexamples-    result <- liftIO $ do +    result <- liftIO $ do         tempdir <- System.IO.Error.catch (getTemporaryDirectory) (\_ -> return ".")         (tempfile, temph) <- openTempFile tempdir "feldspar-temp.txt"-        let (cCode, (resultLinenum, resultCol)) = compToC ((coreOptions, Declaration_pl), linenum) compilationUnit-        Control.Exception.finally (hPutStrLn temph cCode)+        let core = compileToCCore Standalone prg (Just outFileName) IncludesNeeded originalFunctionSignature coreOptions+        Control.Exception.finally (do hPutStrLn temph $ sourceCode $ sctccrSource core+                                      hPutStrLn temph $ sourceCode $ sctccrHeader core)                                   (do hClose temph                                       removeFileIfPossible tempfile)-        return $ ((functionName, Left compilationUnit), resultLinenum)+        return $ (functionName, Left splitModuleDescriptor)     return result -compileAllFunctions :: String -> String -> CoreOptions.Options -> Int -> [OriginalFunctionSignature]-                    -> Interpreter [(String, Either (Module ()) CompilationError)]-compileAllFunctions inFileName outFileName options linenum [] = return []-compileAllFunctions inFileName outFileName options linenum (x:xs) = do+compileAllFunctions :: String -> String -> CoreOptions.Options -> [OriginalFunctionSignature]+                    -> Interpreter [(String, Either SplitModuleDescriptor CompilationError)]+compileAllFunctions inFileName outFileName options [] = return []+compileAllFunctions inFileName outFileName options (x:xs) = do     let functionName = originalFunctionName x-    (compilationUnit, resultLinenum) <- (catchError (compileFunction inFileName outFileName options linenum x)-                              (\(e::InterpreterError) -> return $ ((functionName, Right $ InterpreterError e), linenum)))+    resultCurrent <- (catchError (compileFunction inFileName outFileName options x)+                              (\(e::InterpreterError) -> return $ (functionName, Right $ InterpreterError e)))                           `Control.Monad.CatchIO.catch`-                          (\msg -> return $ ((functionName,-                                             Right $ InternalErrorCall $ errorPrefix ++ show (msg::Control.Exception.ErrorCall)),-                                             linenum))-    result <- compileAllFunctions inFileName outFileName options (resultLinenum + 1) xs-    return $ compilationUnit : result+                          (\msg -> return $ (functionName,+                                             Right $ InternalErrorCall $ errorPrefix ++ show (msg::Control.Exception.ErrorCall)))+    resultRest <- compileAllFunctions inFileName outFileName options xs+    return $ resultCurrent : resultRest  -- | Interpreter body for single-function compilation singleFunctionCompilationBody :: String -> String -> CoreOptions.Options -> OriginalFunctionSignature-                              -> Interpreter (IO CompilationResult)+                              -> Interpreter (IO ()) singleFunctionCompilationBody inFileName outFileName coreOptions originalFunctionSignature = do     liftIO $ fancyWrite $ "Compiling function " ++ (originalFunctionName originalFunctionSignature) ++ "..."     (SomeCompilable prg) <-         interpret ("SomeCompilable " ++ originalFunctionName originalFunctionSignature) (as::SomeCompilable)     liftIO $ standaloneCompile prg inFileName outFileName originalFunctionSignature coreOptions-    return $ return CompilationSuccess+    return $ return () -mergeCompilationUnits :: [Module ()] -> Module ()-mergeCompilationUnits [] = handleError "Standalone" InvariantViolation "Called mergeCompilationUnits with an empty list"-mergeCompilationUnits [x] = x-mergeCompilationUnits l@(x:xs) = Module {-    definitions = nub $ definitions x ++ (definitions $ mergeCompilationUnits xs), -- nub is in fact a "global plugin" here+mergeModules :: [Module AllocationEliminatorSemanticInfo] -> Module AllocationEliminatorSemanticInfo+mergeModules [] = handleError "Standalone" InvariantViolation "Called mergeModules with an empty list"+mergeModules [x] = x+mergeModules l@(x:xs) = Module {+    entities = nub $ entities x ++ (entities $ mergeModules xs), -- nub is in fact a "global plugin" here     moduleLabel = () } @@ -122,106 +147,74 @@ filterLefts ((_,Right _):xs) = filterLefts xs  -- | Interpreter body for multi-function compilation-multiFunctionCompilationBody :: String -> String -> CoreOptions.Options -> [OriginalFunctionSignature]-                             -> Interpreter (IO CompilationResult)+multiFunctionCompilationBody :: String -> String -> CoreOptions.Options -> [OriginalFunctionSignature] -> Interpreter (IO ()) multiFunctionCompilationBody inFileName outFileName coreOptions declarationList = do-    let (headers, linenum) = genHeaders coreOptions-    liftIO $ appendFile outFileName $ headers-    compilationUnits <- compileAllFunctions inFileName outFileName coreOptions linenum declarationList+    let (hIncludes, hLineNum) = genIncludeLines coreOptions Nothing+    let (cIncludes, cLineNum) = genIncludeLines coreOptions (Just outFileName)+    liftIO $ appendFile (makeHFileName outFileName) $ hIncludes+    liftIO $ appendFile (makeCFileName outFileName) $ cIncludes+    modules <- compileAllFunctions inFileName outFileName coreOptions declarationList     liftIO $ do-        mapM writeErrors compilationUnits+        mapM writeErrors modules         withColor Blue $ putStrLn "\n================= [ Summary of compilation results ] =================\n"-        mapM writeSummary compilationUnits-        let mergedCompilationUnits = mergeCompilationUnits $ filterLefts compilationUnits-        (appendFile outFileName $ fst $ compToC ((coreOptions, Declaration_pl), linenum) mergedCompilationUnits)-            `Control.Exception.catch`-                (\msg -> withColor Red $ putStrLn $ errorPrefix ++ show (msg::Control.Exception.ErrorCall))-    return $ return CompilationSuccess+        mapM writeSummary modules+        let mergedCModules = mergeModules $ map smdSource $ filterLefts modules+        let mergedHModules = mergeModules $ map smdHeader $ filterLefts modules+        let cCompToCResult = compToCWithInfos ((coreOptions, Declaration_pl), cLineNum) mergedCModules+        let hCompToCResult = compToCWithInfos ((coreOptions, Declaration_pl), hLineNum) mergedHModules+        (appendFile (makeCFileName outFileName) $ fst $ snd cCompToCResult) `Control.Exception.catch` errorHandler+        (appendFile (makeHFileName outFileName) $ fst $ snd hCompToCResult) `Control.Exception.catch` errorHandler+        (writeFile (makeDebugCFileName outFileName) $ show $ fst cCompToCResult) `Control.Exception.catch` errorHandler+        (writeFile (makeDebugHFileName outFileName) $ show $ fst hCompToCResult) `Control.Exception.catch` errorHandler+    return $ return ()+    where+        errorHandler = (\msg -> withColor Red $ putStrLn $ errorPrefix ++ show (msg::Control.Exception.ErrorCall))  -- | Calculates the output file name. convertOutputFileName :: String -> Maybe String -> String convertOutputFileName inputFileName maybeOutputFileName = case maybeOutputFileName of-    Nothing -> takeFileName $ replaceExtension inputFileName ".c" -- remove takeFileName to return the full path+    Nothing -> takeFileName $ dropExtension inputFileName -- remove takeFileName to return the full path     Just overriddenFileName -> overriddenFileName -removeFileIfPossible :: String -> IO ()-removeFileIfPossible filename = removeFile filename `Prelude.catch` (const $ return())--fancyWrite :: String -> IO ()-fancyWrite s = do-    withColor Blue $ putStr "=== [ "-    withColor Cyan $ putStr $ rpad 70 s-    withColor Blue $ putStrLn " ] ==="+makeBackup :: String -> IO ()+makeBackup filename = renameFile filename (filename ++ ".bak") `Prelude.catch` (const $ return())  main = do-    args <- getArgs--    when (length args == 0) (do-        putStrLn $ usageInfo helpHeader StandaloneOptions.optionDescriptors-        exitWith ExitSuccess)--    -- Parse options, getting a list of option actions-    let (actions, nonOptions, errors) = getOpt Permute StandaloneOptions.optionDescriptors args--    when (length errors > 0) (do-        putStrLn $ concat errors-        putStrLn $ usageInfo helpHeader StandaloneOptions.optionDescriptors-        exitWith (ExitFailure 1))--    -- Here we thread startOptions through all supplied option actions-    opts <- foldl (>>=) (return StandaloneOptions.startOptions) actions--    when (length nonOptions /= 1) (do-        putStrLn "ERROR: Exactly one input file expected."-        exitWith (ExitFailure 1))+    (opts, inputFileName) <- handleOptions optionDescriptors startOptions helpHeader+    let outputFileName = convertOutputFileName inputFileName (optOutputFileName opts) -    let StandaloneOptions.Options {-                  StandaloneOptions.optSingleFunction = functionMode-                , StandaloneOptions.optOutputFileName = maybeOutputFileName-                , StandaloneOptions.optCompilerMode   = compilerMode } = opts-    let inputFileName = replace (head nonOptions) "\\" "/" -- change it for multi-file operation-    let outputFileName = convertOutputFileName inputFileName maybeOutputFileName+    prepareInputFile inputFileName+    makeBackup $ makeHFileName outputFileName+    makeBackup $ makeCFileName outputFileName+    makeBackup $ makeDebugHFileName outputFileName+    makeBackup $ makeDebugCFileName outputFileName -    -- -- -- Input file preparations -- -- ---    removeFileIfPossible $ replaceExtension inputFileName ".hi"-    removeFileIfPossible $ replaceExtension inputFileName ".o"-    -- -- -- Output file preparations -- -- ---    renameFile outputFileName (outputFileName ++ ".bak") `Prelude.catch` (const $ return())-    -- -- -- </prepare> -- -- --     fileDescriptor <- openFile inputFileName ReadMode     fileContents <- hGetContents fileDescriptor -    let declarationList = getExtendedDeclarationList fileContents-    let moduleName = getModuleName fileContents+    let declarationList = getExtendedDeclarationList inputFileName fileContents+    let moduleName = getModuleName inputFileName fileContents     fancyWrite $ "Compilation target: module " ++ moduleName     fancyWrite $ "Output file: " ++ outputFileName -#ifdef RELEASE-    let needGlobal = False -- globalImportList modules are package modules and shouldn't be loaded, only imported-#else -    let needGlobal = True -- in normal mode, we need to load them before importing them-#endif-     let highLevelInterpreterWithModuleInfo body = -            highLevelInterpreter moduleName inputFileName globalImportList needGlobal False body+            highLevelInterpreter moduleName inputFileName globalImportList False body      -- C code generation-    case functionMode of-        StandaloneOptions.MultiFunction +    case optStandaloneMode opts of+        MultiFunction            | length declarationList == 0 -> putStrLn "No functions to compile."           | otherwise -> do                 fancyWrite $ "Number of functions to compile: " ++ (show $ length declarationList)                 highLevelInterpreterWithModuleInfo-                    (multiFunctionCompilationBody inputFileName outputFileName compilerMode declarationList)+                    (multiFunctionCompilationBody inputFileName outputFileName (optCompilerMode opts) declarationList)                 return ()-        StandaloneOptions.SingleFunction funName -> do+        SingleFunction funName -> do             let originalFunctionSignatureNeeded =                      case filter ((==funName).originalFunctionName) declarationList of                             [a] -> a                             []  -> error $ "Function " ++ funName ++ " not found"                             _   -> error "Unexpected error SC/01"              highLevelInterpreterWithModuleInfo-                (singleFunctionCompilationBody inputFileName outputFileName compilerMode originalFunctionSignatureNeeded)+                (singleFunctionCompilationBody inputFileName outputFileName (optCompilerMode opts) originalFunctionSignatureNeeded)             return ()--
+ Feldspar/Compiler/Frontend/Interactive/Interface.hs view
@@ -0,0 +1,94 @@+--+-- Copyright (c) 2009-2011, 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.Frontend.Interactive.Interface where
+
+import Feldspar.Compiler.Compiler
+import Feldspar.Compiler.Imperative.FromCore
+import Feldspar.Compiler.Backend.C.Options
+import qualified Feldspar.NameExtractor as NameExtractor
+import Feldspar.Compiler.Backend.C.Library
+import Feldspar.Compiler.Imperative.Representation
+import Feldspar.Compiler.Backend.C.Plugin.PrettyPrint
+import Feldspar.Compiler.Backend.C.Plugin.Locator
+
+-- ================================================================================================
+--  == Interactive compilation
+-- ================================================================================================
+
+data PrgType = ForType | AssignType | IfType
+
+forPrg = ForType
+ifPrg  = IfType
+assignPrg = AssignType
+
+getProgram :: (Int, Int) -> PrgType -> Module DebugToCSemanticInfo -> IO ()
+getProgram (line, col) prgtype prg = res where
+     res = case find of
+                True -> putStrLn $ myShow code
+                _    -> putStrLn "Not found appropriate code part!"
+     (find, code) = case prgtype of
+                        ForType     -> getPrgParLoop (line, col) prg
+                        AssignType  -> getPrgAssign (line, col) prg
+                        IfType      -> getPrgBranch (line, col) prg
+
+
+compile :: (Compilable t internal) => t -> FilePath -> String -> Options -> IO ()
+compile prg fileName functionName opts = do
+    writeFile (makeCFileName fileName) $ sourceCode $ sctccrSource compilationResult
+    writeFile (makeHFileName fileName) $ sourceCode $ sctccrHeader compilationResult
+  where
+    compilationResult = compileToCCore Interactive prg (Just fileName) IncludesNeeded
+                                       (NameExtractor.OriginalFunctionSignature functionName []) opts
+
+icompile :: (Compilable t internal) => t -> IO ()
+icompile prg = icompile' prg "test" defaultOptions
+
+icompile' :: (Compilable t internal) => t -> String -> Options -> IO ()
+icompile' prg functionName opts = do
+    putStrLn "=============== Header ================"
+    putStrLn $ sourceCode $ sctccrHeader compilationResult
+    putStrLn "=============== Source ================"
+    putStrLn $ sourceCode $ sctccrSource compilationResult
+  where
+    compilationResult = compileToCCore Interactive prg Nothing IncludesNeeded
+                                       (NameExtractor.OriginalFunctionSignature functionName []) opts
+
+info :: (Compilable t internal) => t -> IO ()
+info = flip info' defaultOptions
+
+info' :: (Compilable t internal) => t -> Options -> IO ()
+info' prg opts = print $ mergeAllocationInfos $ [ allocationInfo $ sctccrSource compilationResult
+                                                , allocationInfo $ sctccrHeader compilationResult ]
+  where
+    compilationResult = compileToCCore Interactive prg Nothing IncludesNeeded
+                                       (NameExtractor.OriginalFunctionSignature "test" []) opts
+
+icompileWithInfos :: (Compilable t internal) => t -> String -> Options -> SplitCompToCCoreResult
+icompileWithInfos prg functionName opts = compileToCCore Interactive prg Nothing IncludesNeeded
+                                                          (NameExtractor.OriginalFunctionSignature functionName []) opts
Feldspar/Compiler/Imperative/FromCore.hs view
@@ -1,576 +1,109 @@-{-# LANGUAGE OverlappingInstances, PatternGuards, UndecidableInstances #-}-module Feldspar.Compiler.Imperative.FromCore-  (-    Compilable(..)-  , numArgs-  , fromCore-  ) where--import Control.Monad.State-import Control.Monad.Writer--import Data.List-import Data.String-import Data.Bits--import qualified Feldspar.DSL.Expression as Lang-import qualified Feldspar.DSL.Lambda as Lang-import Feldspar.DSL.Lambda hiding (Value, Variable)-import Feldspar.DSL.Network-import Feldspar.Set (universal)-import qualified Feldspar.Core.Types as Lang-import Feldspar.Core.Representation hiding (variable)-import qualified Feldspar.Core.Representation as Lang-import qualified Feldspar.Core.Functions.Array as Lang-import qualified Feldspar.Core.Functions.Tuple as Lang-import Feldspar.Core.Functions.Num ()-import Feldspar.Range (Range(..),BoundedInt)-import Data.Typeable (Typeable, typeOf)--import Feldspar.Compiler.Imperative.Representation hiding (blockProgram)-import Feldspar.Compiler.Imperative.Frontend-import Feldspar.Compiler.Backend.C.CodeGeneration-import Feldspar.Compiler.Error-import Feldspar.Compiler.Backend.C.Library--type Transformer a = StateT Integer (Writer [Definition ()]) a---- | Path of a matching variable-type Path = [Int]--type MultiVar = [(Path, Lang.TypeRep)]--indexType :: Type-indexType = NumType Unsigned S32---- | Where to place the result of a single-edge-data SingleLoc a-    = Shifted (Expression (), FeldNetwork (Out ()) Lang.Length) (SingleLoc a)-        -- ^ A shifted location-    | SingleLoc-        { singleLV :: Expression ()-        , feedback :: FeldNetwork (Out ()) a-        }-          -- ^ A location represented by a 'LeftValue ()' and a corresponding-          --   expression. The expression is used for feedback.---- | Container of a SingleLoc-getSingleLV :: SingleLoc a -> Expression ()-getSingleLV (SingleLoc lv _) = lv-getSingleLV (Shifted _ sl) = getSingleLV sl---- | Where to place the result of a general program-data Location ra a-  where-    S :: { single :: SingleLoc a } -> Location (Out ()) a-    M :: { multi  :: Ident }       -> Location ra a---- | Append a path to an identifier-pathIdent :: Ident -> Path -> Ident-pathIdent ident path = concat $ intersperse "_" $ (ident :) $ map show path--toSingle :: Type -> Location (Out ()) a -> SingleLoc a-toSingle typ (S loc)   = loc-toSingle typ (M ident) = SingleLoc expr fb-  where-    expr   = varExpr $ variable ident typ-    fb     = Lang.Variable ident--getIx :: Lang.Type a-    => FeldNetwork (Out ()) [a]-    -> FeldNetwork (Out ()) Lang.Index-    -> FeldNetwork (Out ()) a-getIx a ix-    = undoEdge-    $ unData-    $ Lang.getIx (fromOutEdge universal a) (fromOutEdge universal ix)-        -- TODO Think about size--addExpr-    :: FeldNetwork (Out ()) Lang.DefaultWord-    -> FeldNetwork (Out ()) Lang.DefaultWord-    -> FeldNetwork (Out ()) Lang.DefaultWord-addExpr a b = undoEdge $ unData (fromOutEdge universal a + fromOutEdge universal b)-  -- TODO Think about size--add :: Expression () -> Expression () -> Expression ()-add a b = FunctionCall "(+)" indexType InfixOp [a,b] () ()--indexLocSingle-    :: Lang.Type a-    => [(Expression (), FeldNetwork (Out ()) Lang.Length)]  -- ^ Accumulated shifts-    -> SingleLoc [a]                       -- ^ Original location-    -> Expression ()                       -- ^ Index variable-    -> FeldNetwork (Out ()) Lang.Index     -- ^ Index expression-    -> SingleLoc a-indexLocSingle ls (Shifted l loc) ixVar ixExpr =-    indexLocSingle (l:ls) loc ixVar ixExpr-indexLocSingle ls (SingleLoc lv fb) ixVar ixExpr = SingleLoc lv' fb'-  where-    lv'     = arrayElem lv $ foldl add ixVar (map fst ls)-    ixExpr' = foldl addExpr ixExpr (map snd ls)-    fb'     = getIx fb ixExpr'---- | Sum the shifts of a shifted location-sumShifts :: SingleLoc a -> Expression ()-sumShifts (SingleLoc _ _) = createConstantExpression $ intConst 0-sumShifts (Shifted (e,_) l) = add e $ sumShifts l---- | Indexing into a location-indexLoc-    :: Lang.Type a-    => SingleLoc [a]                    -- ^ Original location-    -> Expression ()                    -- ^ Index variable-    -> FeldNetwork (Out ()) Lang.Index  -- ^ Index expression-    -> SingleLoc a-indexLoc loc ixVar ixExpr = indexLocSingle [] loc ixVar ixExpr--selectFst :: (Lang.Type a, Lang.Type b)-          => SingleLoc (a,b)-          -> SingleLoc a-selectFst (SingleLoc e fb) = SingleLoc (StructField e member () ()) fb'-  where-    member         = fst $ head $ s-    (StructType s) = typeof e-    fb'            = undoEdge $ unData $ Lang.getFst $ fromOutEdge universal fb--selectSnd :: (Lang.Type a, Lang.Type b)-          => SingleLoc (a,b)-          -> SingleLoc b-selectSnd (SingleLoc e fb) = SingleLoc (StructField e member () ()) fb'-  where-    member = fst $ head $ tail $ s-    (StructType s) = typeof e-    fb'            = undoEdge $ unData $ Lang.getSnd $ fromOutEdge universal fb--locToNode :: Location (Out ra) a -> FeldNetwork (Out ra) a-locToNode (S (SingleLoc _ fb)) = fb-locToNode (M ident)            = Lang.Variable ident-  -- TODO Ingoring shift--multiVarIn :: FeldNetwork (In ra) a -> MultiVar-multiVarIn = listEdge $ \path a -> (path, edgeType (edgeInfo a))--simpleExpr :: Expression () -> Transformer ([Program ()], Expression ())-simpleExpr expr = return ([],expr)--isComplex :: FeldNetwork (Out ra) a -> Bool-isComplex (Inject (Node Condition)    :$: _ :$: _ :$: _)       = True-isComplex (Inject (Node Parallel)     :$: _ :$: _ :$: _)       = True-isComplex (Inject (Node Sequential)   :$: _ :$: _ :$: _ :$: _) = True-isComplex (Inject (Node ForLoop)      :$: _ :$: _ :$: _)       = True-isComplex (Inject (Node (NoInline _)) :$: _ :$: _)             = True-isComplex (Inject (Node SetLength)    :$: _ :$: _)             = True-isComplex (Inject (Node Pair)         :$: _ :$: _)             = True-isComplex (Inject (Node SetIx)        :$: _ :$: _ :$: _)       = True-isComplex a = isArrayLit a--genLiteralExpression ::-    Lang.Type a => a -> Transformer ([Program ()], Expression ())-genLiteralExpression = simpleExpr . flip ConstExpr () . compileDataRep . Lang.dataRep--genVarExpression ::-    Type -> FeldNetwork (Out ()) a -> Transformer ([Program ()], Expression ())-genVarExpression typ a = simpleExpr (varExpr var)-  where-    Just ident = traceVar a-    var        = variable (pathIdent ident $ matchPath a) typ--genApplyExpression-    :: Type -> String -> FeldNetwork (In ra) a-    -> Transformer ([Program ()], Expression ())-genApplyExpression typ fun a = do-    (progs,exprs) <- liftM unzip $ sequence $ listEdge (const genExpressionIn) a-    return (concat progs, FunctionCall fun typ SimpleFun exprs () ())---- | Generate an expression that is not a literal, function call or a variable-genComplexExpression ::-    Type -> FeldNetwork (Out ()) a -> Transformer ([Program ()], Expression ())-genComplexExpression typ a = do-    ident <- newName "w"-    let var  = variable ident typ-        decl = Declaration var Nothing ()-    prog <- genNode (M ident) a-    return ([BlockProgram (block [decl] prog) ()], VarExpr var ())--genExpressionIn-    :: FeldNetwork (In ()) a-    -> Transformer ([Program ()], Expression ())-genExpressionIn a = genExpression typ (undoEdge a)-  where-    typ = compileTypeRep $ edgeType $ edgeInfo a------ | Generate an expression plus support code-genExpression-    :: Type-    -> FeldNetwork (Out ()) a-    -> Transformer ([Program ()], Expression ())--genExpression _ a@(Inject (Node (Literal lit)))-    | not (isArrayLit a) = genLiteralExpression lit--genExpression typ (Inject (Node (Function fun _)) :$: a) =-    genApplyExpression typ fun a--genExpression typ a-    | Just _ <- traceVar a = genVarExpression typ a--genExpression typ (Inject m :$: _)-    | isMatch m = localError InvariantViolation "matching on non-variable"- -genExpression typ a = genComplexExpression typ a----genDeclarations :: Ident -> MultiVar -> [Declaration ()]-    -- TODO Would be nice to have (Out ra)-genDeclarations ident vars =-    [ Declaration var Nothing ()-        | (path,typ) <- vars-        , let ident' =  pathIdent ident path-        , let var    =  variable ident' $ compileTypeRep typ-    ]--genMultiCopy :: MultiVar -> Location ra a -> Location rb a -> [Program ()]-genMultiCopy [(_,typ)] (S (SingleLoc lv _)) (M rIdent) = [copyProg lv rhs]-  where-    rhs = varExpr $ variable rIdent $ compileTypeRep typ-genMultiCopy _ (S (SingleLoc lhs _)) (S (SingleLoc rhs _)) = [copyProg lhs rhs]-genMultiCopy vars (M ident) (M rIdent) =-    [ copyProg (varExpr lVar) (varExpr rVar)-        | (path,typ)  <- vars-        , let ident'  =  pathIdent ident path-        , let rIdent' =  pathIdent rIdent path-        , let typ'    =  compileTypeRep typ-        , let lVar    =  variable ident' typ'-        , let rVar    =  variable rIdent' typ'-    ]-  -- TODO Ingoring shift-genMultiCopy [(_,typ)] (M ident) (S (SingleLoc rhs _)) = [copyProg lhs rhs]-  where-    lhs = varExpr $ variable ident $ compileTypeRep typ----- | Generate code for a 'Let' expression-genLet-    :: ([Program ()] -> FeldNetwork ra a -> Transformer b)-         -- ^ Generator for the body-    -> FeldNetwork ra a-    -> Transformer b-genLet gen (Let base :$: a :$: Lambda f) = do-    aIdent      <- newName base-    aProg       <- genNode (M aIdent) a-    let aBlock  =  block (genDeclarations aIdent (resTypes a)) aProg-        letProg =  f (Lang.Variable aIdent)-    gen [BlockProgram aBlock ()] letProg+--+-- Copyright (c) 2009-2011, 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.+-- -genNodeExpression ::-    SingleLoc a -> Type -> FeldNetwork (Out ()) a -> Transformer [Program ()]-genNodeExpression loc typ a = do-    (prog,rhs) <- genExpression typ a-    return $ prog ++ case loc of-        SingleLoc l _   -> [copyProg l rhs]-        l@(Shifted _ _) -> [copyProgPos (getSingleLV l) (sumShifts l) rhs]+{-# LANGUAGE UndecidableInstances #-} -genNodeSingle-    :: SingleLoc a-    -> Type-    -> FeldNetwork (Out ()) a-    -> Transformer [Program ()]-genNodeSingle loc _   a | isComplex a = genNode (S loc) a-genNodeSingle loc typ a               = genNodeExpression loc typ a+module Feldspar.Compiler.Imperative.FromCore where   --- | TODO network must be a 'Node' or a (nested) 'Let' resulting in a 'Node'-genNode :: forall ra a-    .  Location ra a-    -> FeldNetwork ra a  -- TODO Would be nice to have (Out ra)-    -> Transformer [Program ()]--genNode loc a | isLet a = genLet genBody a-  where-    genBody letProg body = liftM (letProg++) $ genNode loc body--genNode loc (Inject (Node Condition) :$: cond :$: t :$: e) = do-    (condProg,condExpr) <- genExpressionIn cond-    thenProg            <- genEdge loc t-    elseProg            <- genEdge loc e-    let branchProg = Branch condExpr (block [] thenProg) (block [] elseProg) () ()-    return (condProg ++ [branchProg])--genNode loc a@(Inject (Node Parallel) :$: len :$: Lambda ixf :$: cont) = do-    (lenProg,lenExpr) <- genExpressionIn len-    ixIdent           <- newName "i"-    let bodyExpr      =  ixf (Lang.Variable ixIdent)-        ixVar         =  variable ixIdent indexType-        ixExpr        =  Lang.Variable ixIdent-        loc'          =  toSingle typ loc-        locBody       =  indexLoc loc' (varExpr ixVar) ixExpr-        locCont       =  Shifted (lenExpr, undoEdge len) loc'-        setLen        =  case loc' of-            SingleLoc _ _   -> setLength (singleLV loc') lenExpr-            Shifted _ l     -> increaseLength (getSingleLV l) lenExpr-    bodyProg          <- genEdge (S locBody) bodyExpr-    contProg          <- genEdge (S locCont) cont-    return (lenProg ++ [setLen,ParLoop ixVar lenExpr 1 (block [] bodyProg) () ()] ++ contProg)-  -- TODO Should use \"default size\" for index type-  where-    [(_, Lang.ArrayType _ t)] = resTypes a-    typ                       = compileTypeRep t--genNode loc a@(Inject (Node Sequential) :$: len :$: init :$: Lambda step :$: Lambda cont) = do-    (lenProg,lenExpr) <- genExpressionIn len-    stepIdent         <- newName "x"-    let stIdent       =  stepIdent ++ "_2"-    tempIdent         <- newName "temp"-    ixIdent           <- newName "i"-    initProg          <- genEdge (M stIdent) init-    let step'         =  step (Lang.Variable ixIdent)-        stepExpr      =  shallowApply step' (Lang.Variable stIdent)-        tempVarElem   =  variable (tempIdent ++ "_1") elemTyp-        ixVar         =  variable ixIdent indexType-        ixExpr        =  Lang.Variable ixIdent-        loc'          =  toSingle arrTyp loc-        locElem       =  indexLoc loc' (varExpr ixVar) ixExpr-        locCont       =  Shifted (lenExpr, undoEdge len) loc'-        tempDeclElem  =  genDeclarations tempIdent [([1],tElem)]-        tempDeclsSt   =  genDeclarations (tempIdent ++ "_2") (multiVarIn init)-        stDecls       =  genDeclarations stIdent (multiVarIn init)-        elemCopy      =  copyProg (singleLV locElem) (varExpr tempVarElem)-        stCopy        =  genMultiCopy (multiVarIn init) (M stIdent) (M $ tempIdent ++ "_2")-        apa           =  cont (Lang.Variable stIdent)-        setLen        =  setLength (singleLV loc') lenExpr-    stepProg          <- genEdge (M tempIdent) stepExpr-    contProg          <- genEdge (S locCont) apa-    return $-      [BlockProgram (block stDecls (initProg ++ lenProg ++ [setLen, ParLoop ixVar lenExpr 1 (block (tempDeclElem++tempDeclsSt) (stepProg ++ stCopy ++ [elemCopy])) () ()] ++ contProg)) ()]-  where-    [(_, tArr@(Lang.ArrayType _ tElem))] = resTypes a-    arrTyp  = compileTypeRep tArr-    elemTyp = compileTypeRep tElem--genNode loc a@(Inject (Node ForLoop) :$: len :$: init :$: Lambda body) = do-    (lenProg,lenExpr) <- genExpressionIn len-    tempIdent         <- newName "temp"-    ixIdent           <- newName "i"-    initProg          <- genEdge loc init-    let body'         =  body (Lang.Variable ixIdent)-        bodyExpr      =  shallowApply body' (locToNode loc)-        ixVar         =  variable ixIdent indexType-        tempDecls     =  genDeclarations tempIdent (resTypes a)-    bodyProg          <- genEdge (M tempIdent) bodyExpr-    let copyProg      =  genMultiCopy (resTypes a) loc (M tempIdent)-    return [BlockProgram (block tempDecls (lenProg ++ initProg ++ [ParLoop ixVar lenExpr 1 (block [] (bodyProg ++ copyProg)) () ()])) ()]--genNode (S (Shifted _ _)) a@(Inject (Node (Literal _))) | isArrayLit a && isEmpty a = return []--genNode loc a@(Inject (Node (Literal b))) | isArrayLit a = return [initialize (getSingleLV l) (sumShifts l) v]-  where-    l = toSingle typ loc-    v = compileDataRep $ Lang.dataRep b-    typ = compileTypeRep $ Lang.typeRep' b--genNode loc a@(Inject (Node (NoInline name)) :$: Lambda body :$: x) = do-    param           <- newName "in"-    result          <- newName "out"-    prolog          <- sequence $ listEdge (const genExpressionIn) x-    let prologProgs =  concatMap fst prolog-        prologArgs  =  map (flip In () . snd) prolog-        argVars     =  genVars param  x-        resVars     =  genVars result (body $ Lang.Variable param)-        outArgs     =  map (flip Out ()) $ genLocExprs loc a--    prog            <- genEdge (M result) (body $ Lang.Variable param)--    tell [procedure name argVars resVars (block [] prog)]-    return $ prologProgs ++ [procedureCall name prologArgs outArgs]-  where-    typ = undefined-    nodeType = compileTypeRep . snd . head . resTypes--genNode (S loc) (Inject (Node SetLength) :$: len :$: (Inject (Edge edge) :$: a))-    | not (isComplex a), Just name <- traceVar a = do-        (lenProg,lenExpr) <- genExpressionIn len-        let typ     = compileTypeRep $ edgeType edge-        let arrProg = [copyProgLen (singleLV loc) (varExpr $ createVariable name typ) lenExpr]-        return $ lenProg ++ arrProg--genNode (S loc) a@(Inject (Node SetLength) :$: len :$: arr) = do-    (lenProg,lenExpr) <- genExpressionIn len-    arrProg           <- genEdge (S loc) arr-    return $ lenProg ++ arrProg ++ [setLength (singleLV loc) lenExpr]--genNode loc a@(Inject (Node SetIx) :$: ix :$: val :$: e) = do-  (ixProg,ixExpr)   <- genExpressionIn ix-  copy              <- genEdge loc e-  let-    updLoc          = indexLoc (toSingle elemType loc) ixExpr $ undoEdge ix-  update            <- genEdge (S updLoc) val-  return $ copy ++ ixProg ++ update-    where-      [(_, (Lang.ArrayType _ tElem))] = resTypes a-      elemType = compileTypeRep tElem--genNode loc a@(Inject (Node Pair) :$: x :$: y) = do-    prog1 <- genEdge (S $ selectFst $ toSingle (nodeType a) loc) x-    prog2 <- genEdge (S $ selectSnd $ toSingle (nodeType a) loc) y-    return $ prog1 ++ prog2-  where-    nodeType = compileTypeRep . snd . head . resTypes--genNode loc a@(Inject (Node (Literal _))) = genNodeSingle (toSingle (nodeType a) loc) (nodeType a) a-  where-    nodeType = compileTypeRep . snd . head . resTypes--genNode loc a@(Inject (Node (Function _ _)) :$: _) = genNodeSingle (toSingle (nodeType a) loc) (nodeType a) a-  where-    nodeType = compileTypeRep . snd . head . resTypes+import Control.Monad.RWS -genLocExprs :: Location ra a -> FeldNetwork ra a -> [Expression ()]-genLocExprs (S loc) _   = [singleLV loc]-genLocExprs (M ident) a =-   [ varExpr $ variable (pathIdent ident path) (compileTypeRep typ)-     | (path,typ) <- resTypes a-   ]+import Language.Syntactic+import Language.Syntactic.Constructs.Binding+import Language.Syntactic.Sharing.SimpleCodeMotion +import Feldspar.Core.Types+import Feldspar.Core.Interpretation+import Feldspar.Core.Constructs+import Feldspar.Core.Frontend -viewGroup2 :: FeldNetwork (In (ra,rb)) (a,b) -> (FeldNetwork (In ra) a, FeldNetwork (In rb) b)-viewGroup2 (Inject Group2 :$: a :$: b) = (a,b)-  -- TODO: Move somewhere else+import Feldspar.Compiler.Imperative.Representation (Module)+import Feldspar.Compiler.Imperative.Frontend+import Feldspar.Compiler.Imperative.FromCore.Interpretation+import Feldspar.Compiler.Imperative.FromCore.Array+import Feldspar.Compiler.Imperative.FromCore.Binding+import Feldspar.Compiler.Imperative.FromCore.Condition+import Feldspar.Compiler.Imperative.FromCore.ConditionM+import Feldspar.Compiler.Imperative.FromCore.Error+import Feldspar.Compiler.Imperative.FromCore.FFI+import Feldspar.Compiler.Imperative.FromCore.Literal+import Feldspar.Compiler.Imperative.FromCore.Loop+import Feldspar.Compiler.Imperative.FromCore.Mutable+import Feldspar.Compiler.Imperative.FromCore.Par+import Feldspar.Compiler.Imperative.FromCore.MutableToPure+import Feldspar.Compiler.Imperative.FromCore.Primitive+import Feldspar.Compiler.Imperative.FromCore.Save+import Feldspar.Compiler.Imperative.FromCore.SizeProp+import Feldspar.Compiler.Imperative.FromCore.SourceInfo+import Feldspar.Compiler.Imperative.FromCore.Tuple   -genEdgeSingle-    :: Ident-    -> Path-    -> FeldNetwork (In ()) a-    -> Transformer [Program ()]-genEdgeSingle ident path a =-    genNodeSingle (toSingle typ $ M ident') typ (undoEdge a)-  where-    ident' = pathIdent ident path-    typ    = compileTypeRep $ edgeType $ edgeInfo a---- | Generate code for a multi-edge-genEdge :: Location (Out ra) a -> FeldNetwork (In ra) a -> Transformer [Program ()]-genEdge loc a | isLet a = genLet genBody a-  where-    genBody letProg body = liftM (letProg++) $ genEdge loc body-genEdge loc (Inject (Edge edge) :$: a) = genNodeSingle (toSingle typ loc) typ a+instance Compile FeldDomain (Lambda TypeCtx :+: (Variable TypeCtx :+: FeldDomain))   where-    typ = compileTypeRep $ edgeType edge-genEdge (M ident) a = liftM concat $ sequence $ listEdge (genEdgeSingle ident) a+    compileProgSym (FeldDomain a) = compileProgSym a+    compileExprSym (FeldDomain a) = compileExprSym a --- | Generate a variable of the same type as the given single-edge-genVar :: Ident -> Path -> FeldNetwork (In ()) a -> Variable ()-genVar ident path a = variable (pathIdent ident path) typ+compileProgTop :: (Compile dom dom, Lambda TypeCtx :<: dom) =>+    String -> [Var] -> ASTF (Decor Info dom) a -> Mod+compileProgTop name args (lam :$ body)+    | Just (info, Lambda v) <- prjDecorCtx typeCtx lam+    = let ta = argType $ infoType info+          sa = defaultSize ta+          var = mkVariable (compileTypeRep ta sa) v+       in compileProgTop name (var:args) body+compileProgTop name args a = Mod defs   where-    typ = compileTypeRep $ edgeType $ edgeInfo a--genVars :: Ident -> FeldNetwork (In ra) a -> [Variable ()]-genVars ident (Let _ :$: a :$: Lambda f) =-    genVars ident (f (Lang.Variable "TODO"))-genVars ident a = listEdge (genVar ident) a----class Compilable t where-    toImperativeM-        :: String         -- ^ Name of procedure-        -> [Variable ()]  -- ^ Free variables-        -> t              -- ^ Program to compile-        -> Transformer ()--    -- | Returns a list containing the number of edges in each curried argument-    buildInParamDescriptor :: t -> [Int]--instance Syntactic a => Compilable a where-    toImperativeM procName freeVars prog = do-        ident       <- newName "out"-        body        <- genEdge (M ident) prog'-        let resVars =  genVars ident prog'-        tell [Procedure procName freeVars resVars (block [] body) () ()]-      where-        prog' = feldSharing (toEdge prog)+    ins      = reverse args+    info     = getInfo a+    outType  = compileTypeRep (infoType info) (infoSize info)+    outParam = Pointer outType "out"+    outLoc   = Ptr outType "out"+    results  = snd $ evalRWS (compileProg outLoc a) initReader initState+    body     = Seq $ block $ results+    defs     = def results ++ [ProcDf name ins [outParam] body] -    buildInParamDescriptor _ = []+class    Syntactic a FeldDomainAll => Compilable a internal | a -> internal+instance Syntactic a FeldDomainAll => Compilable a ()+  -- TODO This class should be replaced by (Syntactic a FeldDomainAll) (or a+  --      similar alias) everywhere. The second parameter is not needed. -instance (Syntactic a, Compilable t) => Compilable (a -> t) where-    toImperativeM procName freeVars prog = do-        ident <- newName "in"-        let arg  = Lang.variable universal ident-        let vars = genVars ident (toEdge arg)-        toImperativeM procName (freeVars ++ vars) (prog arg)+fromCore :: Syntactic a FeldDomainAll => String -> a -> Module ()+fromCore name+    = fromInterface+    . compileProgTop name []+    . reifyFeld N32 -    buildInParamDescriptor prog =-        countEdges (toEdge arg) : buildInParamDescriptor (prog arg)-      where-        arg = Lang.variable universal "argument"+buildInParamDescriptor :: Syntactic a FeldDomainAll => a -> [Int]+buildInParamDescriptor _ = []+  -- TODO -numArgs :: Compilable a => a -> Int+numArgs :: Syntactic a FeldDomainAll => a -> Int numArgs = length . buildInParamDescriptor -fromCore :: Compilable t => String -> t -> Module ()-fromCore procName prog = Module (execWriter $ evalStateT (toImperativeM procName [] prog) 0) ()--initialize :: Expression () -> Expression () -> Constant () -> Program ()-initialize loc shift (ArrayConst vs _ _) = createProgramSequence $-    (setLength loc $ shift `add` intConstExpr (toInteger $ length vs)) :-    (map (\(v,i) -> initialize (arrayElem loc $ shift `add` i) (intConstExpr 0) v) $-        zip vs $ map intConstExpr [0..])-initialize loc _ v = copyProg loc $ createConstantExpression v---- | Compilation of a data representation to an imperative constant-compileDataRep :: Lang.DataRep -> Constant ()-compileDataRep (Lang.BoolData x)      = BoolConst x () ()-compileDataRep (Lang.IntData x)       = IntConst x () ()-compileDataRep (Lang.FloatData x)     = FloatConst (fromRational $ toRational x) () ()-compileDataRep (Lang.ComplexData r i) = ComplexConst (compileDataRep r) (compileDataRep i) () ()-compileDataRep (Lang.ArrayData xs)    = ArrayConst (map compileDataRep xs) () ()-compileDataRep (Lang.StructData sd)   = localError InternalError "Struct constants not supported yet."---- | Compilation of a type representation to an imperative type-compileTypeRep :: Lang.TypeRep -> Type-compileTypeRep typ = case typ of-    Lang.BoolType  -> BoolType-    Lang.IntType r -> compileNumericType r-    Lang.FloatType -> FloatType-    Lang.ComplexType typ -> ComplexType (compileTypeRep typ)-    Lang.UserType userTypeName -> UserType userTypeName-    Lang.ArrayType dim elemTyp -> ArrayType (getLength dim) $ compileTypeRep elemTyp-    Lang.StructType memberTypes -> StructType $ zip (map ((defaultMemberName++).show) [1..]) $ map compileTypeRep memberTypes---- | Numeric type based on a range-compileNumericType :: (BoundedInt a, Typeable a) => Range a -> Type-compileNumericType r = NumType (intSign r) (intSize r)---- | Sign based on a range-intSign :: BoundedInt a => Range a -> Signedness-intSign r-    | isSigned (upperBound r) = Signed-    | otherwise               = Unsigned---- | Size based on a range-intSize :: (BoundedInt a, Typeable a) => Range a -> Size-intSize r = case bitSize i of-    8  -> S8-    16 -> S16-    32 -> S32-    64 -> S64-    _  -> localError InvariantViolation $ "unknown integer type: " ++ show (typeOf i)-  where-    i = upperBound r---- | Compilation of a length-getLength :: Range Lang.Length -> Length-getLength l-    | u == maxBound = UndefinedLen-    | otherwise     = LiteralLen (fromIntegral u)-  where-    u = upperBound l---- | Customized error function-localError = handleError "Backends :: C :: ConstTransformation"
+ Feldspar/Compiler/Imperative/FromCore/Array.hs view
@@ -0,0 +1,124 @@+--+-- Copyright (c) 2009-2011, 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 UndecidableInstances #-}++module Feldspar.Compiler.Imperative.FromCore.Array where++++import Control.Monad.RWS++import Language.Syntactic+import Language.Syntactic.Constructs.Binding++import Feldspar.Core.Types+import Feldspar.Core.Interpretation+import Feldspar.Core.Constructs.Array+import Feldspar.Core.Constructs.Literal++import Feldspar.Compiler.Imperative.Frontend+import Feldspar.Compiler.Imperative.FromCore.Interpretation++++instance ( Compile dom dom+         , Lambda TypeCtx :<: dom+         , Literal TypeCtx :<: dom+         , Variable TypeCtx :<: dom+         )+      => Compile Array dom+  where+    compileProgSym Parallel _ loc (len :* (lam :$ ixf) :* Nil)+        | Just (info, Lambda v) <- prjDecorCtx typeCtx lam+        = do+            let ta = argType $ infoType info+            let sa = defaultSize ta+            let ix@(Var _ name) = mkVar (compileTypeRep ta sa) v+            len' <- mkLength len+            (e, body) <- confiscateProg $ compileProg (loc :!: ix) ixf+            tellProg [For name len' 1 $ Seq body]+            tellProg [setLength loc len']++    compileProgSym Sequential _ loc (len :* st :* (lam1 :$ (lam2 :$ step)) :* Nil)+        | Just (info1, Lambda v) <- prjDecorCtx typeCtx lam1+        , Just (info2, Lambda s) <- prjDecorCtx typeCtx lam2+        = do+            let t = argType $ infoType info1+            let sz = defaultSize t+            let ta' = argType $ infoType info2+            let sa' = defaultSize ta'+            let tr' = resType $ infoType info2+            let sr' = defaultSize tr'+            let ix@(Var _ name) = mkVar (compileTypeRep t sz) v+            let stv = mkVar (compileTypeRep ta' sa') s+            len' <- mkLength len+            tmp       <- freshVar "seq" tr' sr'+            initSt    <- compileExpr st+            (e, body) <- confiscateProg $ compileProg tmp step+            tellProg [Block [ini stv initSt, def tmp] $+                      For name len' 1 $+                                    Seq (body +++                                         [loc :!: ix := (tmp :.: "member1")+                                         ,stv        := (tmp :.: "member2")+                                         ])]+            tellProg [setLength loc len']+      where def (Var ty str)   = Def  ty str+            ini (Var ty str) e = Init ty str e++    compileProgSym Append _ loc (a :* b :* Nil) = do+        a' <- compileExpr a+        b' <- compileExpr b+        let offset = Fun U32 "getLength" [a']+        tellProg [copyProg loc a']+        tellProg [copyProgPos loc offset b']++    compileProgSym SetIx info loc (arr :* i :* a :* Nil) = do+        compileProg loc arr+        i' <- compileExpr i+        compileProg (loc :!: i') a++    compileProgSym SetLength _ loc (len :* arr :* Nil) = do+        len' <- compileExpr len+        tellProg [setLength loc len']+        compileProg loc arr+      -- TODO Optimize by using copyProgLen (compare to 0.4)++    compileProgSym a info loc args = compileExprLoc a info loc args++    compileExprSym GetLength info (a :* Nil) = do+        aExpr <- compileExpr a+        return $ Fun (compileTypeRep (infoType info) (infoSize info)) "getLength" [aExpr]++    compileExprSym GetIx info (arr :* i :* Nil) = do+        a' <- compileExpr arr+        i' <- compileExpr i+        return $ a' :!: i'++    compileExprSym a info args = compileProgFresh a info args+
+ Feldspar/Compiler/Imperative/FromCore/Binding.hs view
@@ -0,0 +1,78 @@+--+-- Copyright (c) 2009-2011, 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 UndecidableInstances #-}++module Feldspar.Compiler.Imperative.FromCore.Binding where++import Control.Monad.RWS++import Language.Syntactic++import Feldspar.Core.Types+import Feldspar.Core.Interpretation+import Feldspar.Core.Constructs.Binding+import qualified Feldspar.Core.Constructs.Binding as Core++import Feldspar.Compiler.Imperative.Frontend+import Feldspar.Compiler.Imperative.FromCore.Interpretation++++instance Compile (Core.Variable TypeCtx) dom+  where+    compileExprSym (Core.Variable v) info Nil = do+        env <- ask+        case lookup v (alias env) of+          Nothing -> return $ Var (compileTypeRep (infoType info) (infoSize info)) ("v" ++ show v)+          Just e  -> return e++instance Compile (Lambda TypeCtx) dom+  where+    compileProgSym = error "Can only compile top-level Lambda"++instance (Compile dom dom, Lambda TypeCtx :<: dom) => Compile (Let TypeCtx TypeCtx) dom+  where+    compileProgSym Let _ loc (a :* (lam :$ body) :* Nil)+        | Just (info, Lambda v) <- prjDecorCtx typeCtx lam+        = do+            let ta = argType $ infoType info+            let sa = defaultSize ta+            let var = mkVar (compileTypeRep ta sa) v+            compileProg var a+            withDecl var $ compileProg loc body++    compileExprSym Let _ (a :* (lam :$ body) :* Nil)+        | Just (info, Lambda v) <- prjDecorCtx typeCtx lam+        = do+            let ta = argType $ infoType info+            let sa = defaultSize ta+            let var = mkVar (compileTypeRep ta sa) v+            compileProg var a+            withDecl var $ compileExpr body+
+ Feldspar/Compiler/Imperative/FromCore/Condition.hs view
@@ -0,0 +1,54 @@+--+-- Copyright (c) 2009-2011, 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 UndecidableInstances #-}++module Feldspar.Compiler.Imperative.FromCore.Condition where++++import Control.Monad.RWS++import Language.Syntactic++import Feldspar.Core.Types+import Feldspar.Core.Constructs.Condition++import Feldspar.Compiler.Imperative.Frontend+import Feldspar.Compiler.Imperative.FromCore.Interpretation++++instance Compile dom dom => Compile (Condition TypeCtx) dom+  where+    compileProgSym Condition _ loc (cond :* tHEN :* eLSE :* Nil) = do+        condExpr <- compileExpr cond+        (_,thenProg) <- confiscateProg $ compileProg loc tHEN+        (_,elseProg) <- confiscateProg $ compileProg loc eLSE+        tellProg [If condExpr (Seq thenProg) (Seq elseProg)]+
+ Feldspar/Compiler/Imperative/FromCore/ConditionM.hs view
@@ -0,0 +1,53 @@+--+-- Copyright (c) 2009-2011, 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 UndecidableInstances #-}++module Feldspar.Compiler.Imperative.FromCore.ConditionM where++++import Control.Monad.RWS++import Language.Syntactic++import Feldspar.Core.Types+import Feldspar.Core.Constructs.ConditionM++import Feldspar.Compiler.Imperative.Frontend+import Feldspar.Compiler.Imperative.FromCore.Interpretation++++instance Compile dom dom => Compile (ConditionM m) dom+  where+    compileProgSym ConditionM _ loc (cond :* tHEN :* eLSE :* Nil) = do+        condExpr <- compileExpr cond+        (_,thenProg) <- confiscateProg $ compileProg loc tHEN+        (_,elseProg) <- confiscateProg $ compileProg loc eLSE+        tellProg [If condExpr (Seq thenProg) (Seq elseProg)]
+ Feldspar/Compiler/Imperative/FromCore/Error.hs view
@@ -0,0 +1,61 @@+--+-- Copyright (c) 2009-2011, 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 UndecidableInstances #-}++module Feldspar.Compiler.Imperative.FromCore.Error where++++import Control.Monad.RWS++import Language.Syntactic++import Feldspar.Core.Constructs.Error++import Feldspar.Compiler.Imperative.Frontend+import Feldspar.Compiler.Imperative.FromCore.Interpretation++++instance (Compile dom dom) => Compile Error dom+  where+    compileProgSym Undefined _ loc Nil = return ()+    compileProgSym (Assert msg) _ loc (cond :* a :* Nil) = do+        condExpr <- compileExpr cond+        tellProg [Call "assert" [In condExpr]]+        when (length msg > 0) $ tellProg [Comment $ "{" ++ msg ++ "}"]+        compileProg loc a++    compileExprSym (Assert msg) _ (cond :* a :* Nil) = do+        condExpr <- compileExpr cond+        tellProg [Call "assert" [In condExpr]]+        when (length msg > 0) $ tellProg [Comment $ "{" ++ msg ++ "}"]+        compileExpr a+    compileExprSym a info args = compileProgFresh a info args+
+ Feldspar/Compiler/Imperative/FromCore/FFI.hs view
@@ -0,0 +1,46 @@+--+-- Copyright (c) 2009-2011, 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 UndecidableInstances #-}++module Feldspar.Compiler.Imperative.FromCore.FFI where++import Language.Syntactic++import Feldspar.Core.Interpretation+import Feldspar.Core.Constructs.FFI++import Feldspar.Compiler.Imperative.Frontend+import Feldspar.Compiler.Imperative.FromCore.Interpretation++instance (Compile dom dom) => Compile FFI dom+  where+    compileExprSym (ForeignImport name _) info args = do+        argExprs <- sequence $ listArgs compileExpr args+        return $ Fun (compileTypeRep (infoType info) (infoSize info)) name argExprs+
+ Feldspar/Compiler/Imperative/FromCore/Interpretation.hs view
@@ -0,0 +1,325 @@+--+-- Copyright (c) 2009-2011, 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 UndecidableInstances #-}++module Feldspar.Compiler.Imperative.FromCore.Interpretation where+++import Control.Arrow+import Control.Monad.RWS++import Language.Syntactic+import Language.Syntactic.Constructs.Binding (VarId)++import Feldspar.Range+import Feldspar.Core.Types hiding (Type)+import Feldspar.Core.Interpretation+import qualified Feldspar.Core.Constructs.Binding as Core+import qualified Feldspar.Core.Constructs.Literal as Core++import Feldspar.Compiler.Imperative.Frontend++++-- | Code generation monad+type CodeWriter = RWS Readers Writers States++data Readers = Readers { alias :: [(VarId, Expr)] -- ^ variable aliasing+                       , sourceInfo :: SourceInfo -- ^ Surrounding source info+                       }++initReader = Readers [] ""++data Writers = Writers { -- | collects code within one block+                         block :: [Prog]++                         -- | collects top level definitions+                       , def   :: [Ent]+                       }++instance Monoid Writers+  where+    mempty      = Writers { block = mempty+                          , def   = mempty+                          }+    mappend a b = Writers { block = mappend (block a) (block b)+                          , def   = mappend (def   a) (def   b)+                          }++type Task = [Prog]++data States = States { -- | the first fresh variable+                       fresh :: Integer+                     , tasks :: [Task] -- ^ suspended programs+                     }++initState = States 0 []++-- | Where to place the program result+type Location = Expr++-- | A minimal complete instance has to define either 'compileProgSym' or+-- 'compileExprSym'.+class Compile sub dom+  where+    compileProgSym+        :: sub a+        -> Info (DenResult a)+        -> Location+        -> Args (AST (Decor Info dom)) a+        -> CodeWriter ()+    compileProgSym = compileExprLoc++    compileExprSym+        :: sub a+        -> Info (DenResult a)+        -> Args (AST (Decor Info dom)) a+        -> CodeWriter Expr+    compileExprSym = compileProgFresh++instance (Compile sub1 dom, Compile sub2 dom) =>+    Compile (sub1 :+: sub2) dom+  where+    compileProgSym (InjL a) = compileProgSym a+    compileProgSym (InjR a) = compileProgSym a++    compileExprSym (InjL a) = compileExprSym a+    compileExprSym (InjR a) = compileExprSym a++++-- | Implementation of 'compileExprSym' that assigns an expression to the given+-- location.+compileExprLoc :: Compile sub dom+    => sub a+    -> Info (DenResult a)+    -> Location+    -> Args (AST (Decor Info dom)) a+    -> CodeWriter ()+compileExprLoc a info loc args = do+    expr <- compileExprSym a info args+    assign loc expr++-- | Implementation of 'compileProgSym' that generates code into a fresh+-- variable.+compileProgFresh :: Compile sub dom+    => sub a+    -> Info (DenResult a)+    -> Args (AST (Decor Info dom)) a+    -> CodeWriter Expr+compileProgFresh a info args = do+    loc <- freshVar "e" (infoType info) (infoSize info)+    withDecl loc $ compileProgSym a info loc args+    return loc++compileProgDecor :: Compile dom dom+    => Location+    -> Decor Info dom a+    -> Args (AST (Decor Info dom)) a+    -> CodeWriter ()+compileProgDecor result (Decor info a) args = do+    let src = infoSource info+    aboveSrc <- asks sourceInfo+    unless (null src || src==aboveSrc) $ tellProg [BComment src]+    local (\env -> env {sourceInfo = src}) $ compileProgSym a info result args++compileExprDecor :: Compile dom dom+    => Decor Info dom a+    -> Args (AST (Decor Info dom)) a+    -> CodeWriter Expr+compileExprDecor (Decor info a) args = do+    let src = infoSource info+    aboveSrc <- asks sourceInfo+    unless (null src || src==aboveSrc) $ tellProg [BComment src]+    local (\env -> env {sourceInfo = src}) $ compileExprSym a info args++compileProg :: Compile dom dom =>+    Location -> ASTF (Decor Info dom) a -> CodeWriter ()+compileProg result = queryNodeSimple (compileProgDecor result)++compileExpr :: Compile dom dom => ASTF (Decor Info dom) a -> CodeWriter Expr+compileExpr = queryNodeSimple compileExprDecor++++--------------------------------------------------------------------------------+-- * Utility functions+--------------------------------------------------------------------------------++compileNumType :: Signedness a -> BitWidth n -> Type+compileNumType U N8      = U8+compileNumType S N8      = I8+compileNumType U N16     = U16+compileNumType S N16     = I16+compileNumType U N32     = U32+compileNumType S N32     = I32+compileNumType U N64     = U64+compileNumType S N64     = I64+compileNumType U NNative = U32  -- TODO+compileNumType S NNative = I32  -- TODO++compileTypeRep :: TypeRep a -> Size a -> Type+compileTypeRep UnitType _                = Void+compileTypeRep BoolType _                = Boolean+compileTypeRep (IntType s n) _           = compileNumType s n+compileTypeRep FloatType _               = Floating+compileTypeRep (ComplexType t) _         = Complex (compileTypeRep t (defaultSize t))+compileTypeRep (Tup2Type a b) (sa,sb)          = Struct+        [ ("member1", compileTypeRep a sa)+        , ("member2", compileTypeRep b sb)+        ]+compileTypeRep (Tup3Type a b c) (sa,sb,sc)        = Struct+        [ ("member1", compileTypeRep a sa)+        , ("member2", compileTypeRep b sb)+        , ("member3", compileTypeRep c sc)+        ]+compileTypeRep (Tup4Type a b c d) (sa,sb,sc,sd)      = Struct+        [ ("member1", compileTypeRep a sa)+        , ("member2", compileTypeRep b sb)+        , ("member3", compileTypeRep c sc)+        , ("member4", compileTypeRep d sd)+        ]+compileTypeRep (Tup5Type a b c d e) (sa,sb,sc,sd,se)    = Struct+        [ ("member1", compileTypeRep a sa)+        , ("member2", compileTypeRep b sb)+        , ("member3", compileTypeRep c sc)+        , ("member4", compileTypeRep d sd)+        , ("member5", compileTypeRep e se)+        ]+compileTypeRep (Tup6Type a b c d e f) (sa,sb,sc,sd,se,sf)  = Struct+        [ ("member1", compileTypeRep a sa)+        , ("member2", compileTypeRep b sb)+        , ("member3", compileTypeRep c sc)+        , ("member4", compileTypeRep d sd)+        , ("member5", compileTypeRep e se)+        , ("member6", compileTypeRep f sf)+        ]+compileTypeRep (Tup7Type a b c d e f g) (sa,sb,sc,sd,se,sf,sg) = Struct+        [ ("member1", compileTypeRep a sa)+        , ("member2", compileTypeRep b sb)+        , ("member3", compileTypeRep c sc)+        , ("member4", compileTypeRep d sd)+        , ("member5", compileTypeRep e se)+        , ("member6", compileTypeRep f sf)+        , ("member7", compileTypeRep g sg)+        ]+compileTypeRep (MutType a) _            = compileTypeRep a (defaultSize a)+compileTypeRep (RefType a) _            = compileTypeRep a (defaultSize a)+compileTypeRep (ArrayType a) (rs :> es) = if unboundedLength+                                          then Array $ compileTypeRep a es+                                          else SizedArray (fromEnum $ upperBound rs) $ compileTypeRep a es+  where+    unboundedLength+        =  upperBound rs > fromIntegral (maxBound :: Int)+             -- This ensures that `fromEnum` succeeds+        || upperBound rs == maxBound+             -- This `maxBound` might be smaller than `maxBound :: Int`+compileTypeRep (MArrType a) _           = Array (compileTypeRep a (defaultSize a))+compileTypeRep (ParType a) _            = compileTypeRep a (defaultSize a)+compileTypeRep (IVarType a) _           = compileTypeRep a (defaultSize a)+compileTypeRep (FunType _ b) sz         = compileTypeRep b sz+compileTypeRep typ _                    = error $ "compileTypeRep: missing " ++ show typ  -- TODO++mkVar :: Type -> VarId -> Expr+mkVar t = Var t . ("v" ++) . show++mkVariable :: Type -> VarId -> Var+mkVariable t = Variable t . ("v" ++) . show++freshVar :: String -> TypeRep a -> Size a -> CodeWriter Expr -- TODO take just info instead of TypeRep and Size?+freshVar base t size = do+  s <- get+  let v = fresh s+  put $ s {fresh = (v + 1)}+  return $ Var (compileTypeRep t size) (base ++ show v)++tellProg :: [Prog] -> CodeWriter ()+tellProg ps = tell $ mempty {block = ps}++addTask :: Task -> CodeWriter ()+addTask t = do+    s <- get+    let ts = tasks s+    put $ s {tasks = ts ++ [t]}+    return ()++assign :: Location -> Expr -> CodeWriter ()+assign lhs rhs = tellProg [copyProg lhs rhs]++suspendProg :: CodeWriter a -> CodeWriter a+suspendProg m = do+    (a, ps) <- censor (\rec -> rec {block = []}) $ listen m+    addTask $ block ps+    return a++releaseProgs :: CodeWriter ()+releaseProgs = do+    s <- get+    let ts = tasks s+    mapM_ tellProg $ reverse ts+    put $ s {tasks = []}++-- | Like 'listen', but also prevents the program from being written in the+-- monad.+confiscateProg :: CodeWriter a -> CodeWriter (a, [Prog])+confiscateProg m+    = liftM (id *** block)+    $ censor (\rec -> rec {block = []})+    $ listen m++withDecl :: Location -> CodeWriter a -> CodeWriter a+withDecl (Var Void _) ma = ma -- don't declace void variables+withDecl (Var t name) ma = do+  (e,prog) <- confiscateProg ma+  tellProg [Block [Def t name] (Seq prog)]+  return e+  -- TODO Could probably use only censor++withDeclInit :: Location -> Expr -> CodeWriter a -> CodeWriter a+withDeclInit (Var t name) init ma = do+  (e,prog) <- confiscateProg ma+  tellProg [Block [Init t name init] (Seq prog)]+  return e+  -- TODO Needed?++withAlias :: VarId -> Expr -> CodeWriter a -> CodeWriter a+withAlias v0 expr action = do+  local (\e -> e {alias = (v0,expr) : alias e}) $ action++isVariableOrLiteral (prjDecorCtx typeCtx -> Just (_, Core.Literal l))  = True+isVariableOrLiteral (prjDecorCtx typeCtx -> Just (_, Core.Variable v)) = True+isVariableOrLiteral _                                                  = False++mkLength a | isVariableOrLiteral a = compileExpr a+           | otherwise             = do+               let lentyp = IntType U N32+               lenvar    <- freshVar "len" lentyp (defaultSize lentyp)+               withDecl lenvar $ compileProg lenvar a+               return lenvar+
+ Feldspar/Compiler/Imperative/FromCore/Literal.hs view
@@ -0,0 +1,138 @@+--+-- Copyright (c) 2009-2011, 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 UndecidableInstances #-}++module Feldspar.Compiler.Imperative.FromCore.Literal where++++import Control.Monad.RWS+import Data.Complex+import GHC.Float (float2Double)++import Language.Syntactic++import Feldspar.Core.Types+import Feldspar.Core.Interpretation+import Feldspar.Core.Constructs.Literal++import Feldspar.Range (upperBound)++import Feldspar.Compiler.Imperative.Frontend+import Feldspar.Compiler.Imperative.FromCore.Interpretation++instance Compile (Literal TypeCtx) dom+  where+    compileExprSym (Literal a) info Nil = literal (infoType info) (infoSize info) a++    compileProgSym (Literal a) info loc Nil = literalLoc loc (infoType info) (infoSize info) a++literal :: TypeRep a -> Size a -> a -> CodeWriter Expr+literal UnitType _          ()     = return $ LitI I32 0+literal BoolType _          a      = return $ boolToExpr a+literal trep@(IntType _ _) sz a    = return $ LitI (compileTypeRep trep sz) (toInteger a)+literal FloatType _         a      = return $ LitF $ float2Double a+literal (ComplexType t) sz  (r:+i) = do re <- literal t (defaultSize t) r+                                        ie <- literal t (defaultSize t) i+                                        return $ LitC re ie+literal t s a = do loc <- freshVar "x" t s+                   withDecl loc $ literalLoc loc t s a+                   return loc++literalLoc :: Location -> TypeRep a -> Size a -> a -> CodeWriter ()+literalLoc loc ty@(ArrayType t) (rs :> es) e+    = do+        tellProg [setLength loc $ LitI I32 $ toInteger $ upperBound rs]+        zipWithM_ (writeElement loc t es) (map (LitI I32) [0..]) e+  where writeElement :: Expr -> TypeRep a -> Size a -> Expr -> a -> CodeWriter ()+        writeElement loc ty sz ix e = do expr <- literal ty sz e+                                         tellProg [loc :!: ix := expr]+literalLoc loc t@(Tup2Type ta tb) (sa,sb) (a,b) =+    do aExpr <- literal ta sa a+       bExpr <- literal tb sb b+       tellProg [loc :.: "member1" := aExpr+                ,loc :.: "member2" := bExpr]+literalLoc loc t@(Tup3Type ta tb tc) (sa,sb,sc) (a,b,c) =+    do aExpr <- literal ta sa a+       bExpr <- literal tb sb b+       cExpr <- literal tc sc c+       tellProg [loc :.: "member1" := aExpr+                ,loc :.: "member2" := bExpr+                ,loc :.: "member3" := cExpr]+literalLoc loc t@(Tup4Type ta tb tc td) (sa,sb,sc,sd) (a,b,c,d) =+    do aExpr <- literal ta sa a+       bExpr <- literal tb sb b+       cExpr <- literal tc sc c+       dExpr <- literal td sd d+       tellProg [loc :.: "member1" := aExpr+                ,loc :.: "member2" := bExpr+                ,loc :.: "member3" := cExpr+                ,loc :.: "member4" := dExpr]+literalLoc loc t@(Tup5Type ta tb tc td te) (sa,sb,sc,sd,se) (a,b,c,d,e) =+    do aExpr <- literal ta sa a+       bExpr <- literal tb sb b+       cExpr <- literal tc sc c+       dExpr <- literal td sd d+       eExpr <- literal te se e+       tellProg [loc :.: "member1" := aExpr+                ,loc :.: "member2" := bExpr+                ,loc :.: "member3" := cExpr+                ,loc :.: "member4" := dExpr+                ,loc :.: "member5" := eExpr]+literalLoc loc t@(Tup6Type ta tb tc td te tf) (sa,sb,sc,sd,se,sf) (a,b,c,d,e,f) =+    do aExpr <- literal ta sa a+       bExpr <- literal tb sb b+       cExpr <- literal tc sc c+       dExpr <- literal td sd d+       eExpr <- literal te se e+       fExpr <- literal tf sf f+       tellProg [loc :.: "member1" := aExpr+                ,loc :.: "member2" := bExpr+                ,loc :.: "member3" := cExpr+                ,loc :.: "member4" := dExpr+                ,loc :.: "member5" := eExpr+                ,loc :.: "member5" := fExpr]+literalLoc loc t@(Tup7Type ta tb tc td te tf tg) (sa,sb,sc,sd,se,sf,sg) (a,b,c,d,e,f,g) =+    do aExpr <- literal ta sa a+       bExpr <- literal tb sb b+       cExpr <- literal tc sc c+       dExpr <- literal td sd d+       eExpr <- literal te se e+       fExpr <- literal tf sf f+       gExpr <- literal tg sg g+       tellProg [loc :.: "member1" := aExpr+                ,loc :.: "member2" := bExpr+                ,loc :.: "member3" := cExpr+                ,loc :.: "member4" := dExpr+                ,loc :.: "member5" := eExpr+                ,loc :.: "member5" := fExpr+                ,loc :.: "member5" := gExpr]+literalLoc loc t sz a = do rhs <- literal t sz a+                           tellProg [loc := rhs]+
+ Feldspar/Compiler/Imperative/FromCore/Loop.hs view
@@ -0,0 +1,101 @@+--+-- Copyright (c) 2009-2011, 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 UndecidableInstances #-}++module Feldspar.Compiler.Imperative.FromCore.Loop where++++import Control.Monad.RWS++import Language.Syntactic+import Language.Syntactic.Constructs.Binding++import Feldspar.Core.Types+import Feldspar.Core.Interpretation+import Feldspar.Core.Constructs.Loop hiding (For, While)+import Feldspar.Core.Constructs.Literal+import qualified Feldspar.Core.Constructs.Loop as Core++import Feldspar.Compiler.Imperative.Frontend+import Feldspar.Compiler.Imperative.FromCore.Interpretation+++instance ( Compile dom dom+         , Lambda TypeCtx :<: dom+         , Literal TypeCtx :<: dom+         , Variable TypeCtx :<: dom+         )+      => Compile Loop dom+  where+    compileProgSym ForLoop _ loc (len :* init :* (lam1 :$ (lam2 :$ ixf)) :* Nil)+        | Just (info1, Lambda ix)  <- prjDecorCtx typeCtx lam1+        , Just (info2, Lambda st)  <- prjDecorCtx typeCtx lam2+        = do+            let ixvar@(Var _ name) = mkVar (compileTypeRep (infoType info1) (infoSize info1)) ix+            let stvar              = mkVar (compileTypeRep (infoType info2) (infoSize info2)) st+            len' <- mkLength len+            compileProg loc init+            (_, body) <- withAlias st loc $ confiscateProg $ compileProg stvar ixf >> assign loc stvar+            withDecl stvar $ tellProg [For name len' 1 $ Seq body]++    compileProgSym WhileLoop _ loc (init :* (lam1 :$ cond) :* (lam2 :$ body) :* Nil)+        | Just (info1, Lambda cv) <- prjDecorCtx typeCtx lam1+        , Just (info2, Lambda cb) <- prjDecorCtx typeCtx lam2+        = do+            let stvar = mkVar (compileTypeRep (infoType info2) (infoSize info2)) cb+            compileProg loc init+            cond' <- withAlias cv loc $ compileExpr cond+            (_, body') <- withAlias cb loc $ confiscateProg $ compileProg stvar body >> assign loc stvar+            withDecl stvar $ tellProg [While Skip cond' $ Seq body']++instance ( Compile dom dom+         , Lambda TypeCtx :<: dom+         , Literal TypeCtx :<: dom+         , Variable TypeCtx :<: dom+         )+      => Compile (LoopM Mut) dom+  where+    compileProgSym Core.For _ loc (len :* (lam :$ ixf) :* Nil)+        | Just (info, Lambda v) <- prjDecorCtx typeCtx lam+        = do+            let ta = argType $ infoType info+            let sa = defaultSize ta+            let ix@(Var _ name) = mkVar (compileTypeRep ta sa) v+            len' <- mkLength len+            (e, body) <- confiscateProg $ compileProg loc ixf+            tellProg [For name len' 1 $ Seq body]++-- TODO Missing While+    compileProgSym Core.While _ loc (cond :* step :* Nil)+        = do+            cond'     <- compileExpr cond+            (_,step') <- confiscateProg $ compileProg loc step+            tellProg [While Skip cond' $ Seq step']+
+ Feldspar/Compiler/Imperative/FromCore/Mutable.hs view
@@ -0,0 +1,129 @@+--+-- Copyright (c) 2009-2011, 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 UndecidableInstances #-}++module Feldspar.Compiler.Imperative.FromCore.Mutable where++++import Control.Monad.RWS++import Language.Syntactic+import Language.Syntactic.Constructs.Binding++import Feldspar.Core.Types+import Feldspar.Core.Interpretation+import Feldspar.Core.Constructs.Mutable+import Feldspar.Core.Constructs.MutableArray+import Feldspar.Core.Constructs.MutableReference++import Feldspar.Compiler.Imperative.Frontend+import Feldspar.Compiler.Imperative.FromCore.Interpretation++++instance (Compile dom dom, Lambda TypeCtx :<: dom) => Compile (MONAD Mut) dom+  where+    compileProgSym Bind _ loc (ma :* (lam :$ body) :* Nil)+        | Just (_, Lambda v) <- prjDecorCtx typeCtx lam+        = do+            e <- compileExpr ma+            withAlias v e $ compileProg loc body++{- TODO reenable this implementation! The case above inlines too much if v is used more than once in the body+    compileProgSym Bind _ loc (ma :* (Symbol (Decor info lam) :$ body) :* Nil)+        | Just (Lambda v) <- prjCtx typeCtx lam+        = do+            let var = mkVar (compileTypeRep $ argType $ infoType info) v+            withDecl var $ do+              compileProg var ma+              compileProg loc body+-}++    compileProgSym Then _ loc (ma :* mb :* Nil) = do+        compileExpr ma+        compileProg loc mb++    compileProgSym Return info loc (a :* Nil)+        | MutType UnitType <- infoType info = return ()+        | otherwise                         = compileProg loc a++    compileProgSym When _ loc (c :* action :* Nil) = do+        c' <- compileExpr c+        (_, body) <- confiscateProg $ compileProg loc action+        tellProg [If c' (Seq body) Skip]++instance (Compile dom dom, Lambda TypeCtx :<: dom) => Compile Mutable dom+  where+    compileProgSym Run _ loc (ma :* Nil) = compileProg loc ma++    compileExprSym Run info (ma :* Nil) = compileExpr ma++instance (Compile dom dom, Lambda TypeCtx :<: dom) => Compile MutableReference dom+  where+    compileProgSym NewRef _ loc (a :* Nil) = compileProg loc a+    compileProgSym GetRef _ loc (r :* Nil) = compileProg loc r+    compileProgSym SetRef _ loc (r :* a :* Nil) = do+        var  <- compileExpr r+        compileProg var a++    compileExprSym GetRef _ (r :* Nil) = compileExpr r+    compileExprSym feat info args      = compileProgFresh feat info args++instance (Compile dom dom, Lambda TypeCtx :<: dom) => Compile MutableArray dom+  where+    compileProgSym NewArr_ _ loc (length :* Nil) = do+      len <- compileExpr length+      tellProg [Call "setLength" [In loc,In len]]++    compileProgSym NewArr _ loc (length :* a :* Nil) = do+        let ix = Var U32 "i"+        a'  <- compileExpr a+        len <- compileExpr length+        tellProg [For "i" len 1 (Seq [loc :!: ix := a'])]++    compileProgSym GetArr _ loc (arr :* i :* Nil) = do+        arr' <- compileExpr arr+        i'   <- compileExpr i+        assign loc (arr' :!: i')++    compileProgSym SetArr _ _ (arr :* i :* a :* Nil) = do+        arr' <- compileExpr arr+        i'   <- compileExpr i+        a'   <- compileExpr a+        assign (arr' :!: i') a'++    compileProgSym a info loc args = compileExprLoc a info loc args++    compileExprSym ArrLength info (arr :* Nil) = do+        a' <- compileExpr arr+        return $ Fun (compileTypeRep (infoType info) (infoSize info)) "getLength" [a']++    compileExprSym a info args = compileProgFresh a info args+
+ Feldspar/Compiler/Imperative/FromCore/MutableToPure.hs view
@@ -0,0 +1,85 @@+--+-- Copyright (c) 2009-2011, 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 UndecidableInstances #-}++module Feldspar.Compiler.Imperative.FromCore.MutableToPure where++++import Control.Monad.RWS++import Language.Syntactic+import Language.Syntactic.Constructs.Binding++import Feldspar.Core.Types+import Feldspar.Core.Interpretation+import Feldspar.Core.Constructs.MutableToPure++import Feldspar.Compiler.Imperative.Frontend hiding (Variable)+import Feldspar.Compiler.Imperative.FromCore.Interpretation++++instance ( Compile dom dom+         , Lambda TypeCtx :<: dom+         , Variable TypeCtx :<: dom+         )+      => Compile MutableToPure dom+  where+    compileProgSym WithArray _ loc (marr :* (lam :$ body) :* Nil)+        | Just (_, Variable v0)  <- prjDecorCtx typeCtx marr+        , Just (info, Lambda v1) <- prjDecorCtx typeCtx lam+        = do+            e <- compileExpr marr+            withAlias v1 e $ do+              e <- compileExpr body+              tellProg [copyProg loc e]++    compileProgSym WithArray _ loc (marr :* (lam :$ body) :* Nil)+        | Just (info, Lambda v) <- prjDecorCtx typeCtx lam+        = do+            let ta = argType $ infoType info+            let sa = defaultSize ta+            let var = mkVar (compileTypeRep ta sa) v+            withDecl var $ do+              compileProg var marr+              e <- compileExpr body+              tellProg [copyProg loc e]++    compileProgSym RunMutableArray _ loc (marr :* Nil) = compileProg loc marr++{- NOTES:++The trick of doing a copy at the end, i.e. `tellProg [copyProg loc+e]`, when compiling WithArray is important. It allows us to safely+return the pure array that is passed in as input. This is nice because+it allows us to implement `freezeArray` in terms of `withArray`.+In most cases I expect `withArray` to return a scalar as its final+result and then the copyProg is harmless.+-}
+ Feldspar/Compiler/Imperative/FromCore/Par.hs view
@@ -0,0 +1,105 @@+--+-- Copyright (c) 2009-2011, 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 UndecidableInstances #-}++module Feldspar.Compiler.Imperative.FromCore.Par where++import Language.Syntactic+import Language.Syntactic.Constructs.Monad+import Language.Syntactic.Constructs.Binding++import Feldspar.Core.Types+import Feldspar.Core.Interpretation+import Feldspar.Core.Constructs.Par++import Feldspar.Compiler.Imperative.Frontend hiding (Variable)+import Feldspar.Compiler.Imperative.FromCore.Interpretation++instance ( Compile dom dom+         , Lambda TypeCtx :<: dom+         , ParFeature :<: dom+         )+      => Compile (MONAD Par) dom+  where+    compileProgSym Bind _ loc (ma :* (lam :$ body) :* Nil)+        | Just (_, Lambda v)  <- prjDecorCtx typeCtx lam+        , Just (info, ParNew) <- prjDecor ma+        -- TODO add helper function :: Info (Par a) -> Info a+        = do+            let var = mkVar (compileTypeRep (infoType info) (infoSize info)) v+            withDecl var $ compileProg loc body++    compileProgSym Bind _ loc (ma :* (lam :$ body) :* Nil)+        | Just (_, Lambda v) <- prjDecorCtx typeCtx lam+        = do+            e <- compileExpr ma+            withAlias v e $ compileProg loc body++    compileProgSym Then _ loc (ma :* mb :* Nil) = do+        compileExpr ma+        compileProg loc mb++    compileProgSym Return info loc (a :* Nil)+        | ParType UnitType <- infoType info = return ()+        | otherwise                         = compileProg loc a++    compileProgSym When _ loc (c :* action :* Nil) = do+        c' <- compileExpr c+        (_, body) <- confiscateProg $ compileProg loc action+        tellProg [If c' (Seq body) Skip]++instance ( Compile dom dom+         , Variable TypeCtx :<: dom+         )+      => Compile ParFeature dom+  where+    compileExprSym ParGet _ (r :* Nil) = do+        releaseProgs+        compileExpr r++    compileExprSym a info args = compileProgFresh a info args++    compileProgSym ParRun _ loc (p :* Nil) = compileProg loc p++    compileProgSym ParGet _ loc (r :* Nil) = do+        releaseProgs+        compileProg loc r++    compileProgSym ParPut _ loc (r :* a :* Nil)+        | Just (info, Variable v) <- prjDecorCtx typeCtx r+        = do+            let var = mkVar (compileTypeRep (infoType info) (infoSize info)) v+            compileProg var a++    compileProgSym ParFork _ loc (p :* Nil) = do+        suspendProg $ compileProg loc p++    compileProgSym ParYield _ loc Nil = return ()++
+ Feldspar/Compiler/Imperative/FromCore/Primitive.hs view
@@ -0,0 +1,82 @@+--+-- Copyright (c) 2009-2011, 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 UndecidableInstances #-}++module Feldspar.Compiler.Imperative.FromCore.Primitive where++++import Language.Syntactic+import Language.Syntactic.Interpretation.Semantics++import Feldspar.Core.Interpretation+import Feldspar.Core.Constructs.Bits+import Feldspar.Core.Constructs.Complex+import Feldspar.Core.Constructs.Conversion+import Feldspar.Core.Constructs.Eq+import Feldspar.Core.Constructs.Floating+import Feldspar.Core.Constructs.Fractional+import Feldspar.Core.Constructs.Integral+import Feldspar.Core.Constructs.Logic+import Feldspar.Core.Constructs.Num+import Feldspar.Core.Constructs.Ord+import Feldspar.Core.Constructs.Trace++import Feldspar.Compiler.Imperative.Frontend+import Feldspar.Compiler.Imperative.FromCore.Interpretation++++-- | Converts symbols to primitive function calls+instance Compile dom dom => Compile Semantics dom+  where+    compileExprSym (Sem name _) info args = do+        argExprs <- sequence $ listArgs compileExpr args+        return $ Fun (compileTypeRep (infoType info) (infoSize info)) name argExprs++-- | Convenient implementation of 'compileExprSym' for primitive functions+compilePrim :: (Semantic expr, Compile dom dom)+    => expr a+    -> Info (DenResult a)+    -> Args (AST (Decor Info dom)) a+    -> CodeWriter Expr+compilePrim = compileExprSym . semantics++instance Compile dom dom => Compile BITS       dom where compileExprSym = compilePrim+instance Compile dom dom => Compile COMPLEX    dom where compileExprSym = compilePrim+instance Compile dom dom => Compile Conversion dom where compileExprSym = compilePrim+instance Compile dom dom => Compile EQ         dom where compileExprSym = compilePrim+instance Compile dom dom => Compile FLOATING   dom where compileExprSym = compilePrim+instance Compile dom dom => Compile FRACTIONAL dom where compileExprSym = compilePrim+instance Compile dom dom => Compile INTEGRAL   dom where compileExprSym = compilePrim+instance Compile dom dom => Compile Logic      dom where compileExprSym = compilePrim+instance Compile dom dom => Compile NUM        dom where compileExprSym = compilePrim+instance Compile dom dom => Compile ORD        dom where compileExprSym = compilePrim+instance Compile dom dom => Compile Trace      dom where compileExprSym = compilePrim+
+ Feldspar/Compiler/Imperative/FromCore/Save.hs view
@@ -0,0 +1,48 @@+--+-- Copyright (c) 2009-2011, 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 UndecidableInstances #-}++module Feldspar.Compiler.Imperative.FromCore.Save where++++import Language.Syntactic++import Feldspar.Core.Types+import Feldspar.Core.Constructs.Save++import Feldspar.Compiler.Imperative.Frontend+import Feldspar.Compiler.Imperative.FromCore.Interpretation++++instance Compile dom dom => Compile Save dom+  where+    compileProgSym Save _ loc (a :* Nil) = compileProg loc a+
+ Feldspar/Compiler/Imperative/FromCore/SizeProp.hs view
@@ -0,0 +1,51 @@+--+-- Copyright (c) 2009-2011, 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 UndecidableInstances #-}++module Feldspar.Compiler.Imperative.FromCore.SizeProp where++++import Control.Monad.RWS++import Language.Syntactic++import Feldspar.Core.Constructs.SizeProp++import Feldspar.Compiler.Imperative.Frontend+import Feldspar.Compiler.Imperative.FromCore.Interpretation++++instance Compile dom dom => Compile PropSize dom+  where+    compileProgSym (PropSize _) _ loc (_ :* b :* Nil) = compileProg loc b++    compileExprSym (PropSize _) _ (_ :* b :* Nil) = compileExpr b+
+ Feldspar/Compiler/Imperative/FromCore/SourceInfo.hs view
@@ -0,0 +1,53 @@+--+-- Copyright (c) 2009-2011, 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 UndecidableInstances #-}++module Feldspar.Compiler.Imperative.FromCore.SourceInfo where++++import Language.Syntactic++import Feldspar.Core.Types+import Feldspar.Core.Constructs.SourceInfo++import Feldspar.Compiler.Imperative.Frontend+import Feldspar.Compiler.Imperative.FromCore.Interpretation++++instance Compile dom dom => Compile (Decor SourceInfo1 (Identity TypeCtx)) dom+  where+    compileProgSym (Decor (SourceInfo1 info) Id) _ loc (a :* Nil) = do+        tellProg [BComment info]+        compileProg loc a+    compileExprSym (Decor (SourceInfo1 info) Id) _ (a :* Nil) = do+        tellProg [BComment info]+        compileExpr a+
+ Feldspar/Compiler/Imperative/FromCore/Tuple.hs view
@@ -0,0 +1,104 @@+--+-- Copyright (c) 2009-2011, 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 UndecidableInstances #-}++module Feldspar.Compiler.Imperative.FromCore.Tuple where++++import Language.Syntactic++import Feldspar.Core.Types+import Feldspar.Core.Constructs.Tuple++import Feldspar.Compiler.Imperative.Frontend+import Feldspar.Compiler.Imperative.FromCore.Interpretation++++instance Compile dom dom => Compile (Tuple TypeCtx) dom+  where+    compileProgSym Tup2 _ loc (m1 :* m2 :* Nil) = do+        compileExpr m1 >>= assign (loc :.: "member1")+        compileExpr m2 >>= assign (loc :.: "member2")+    compileProgSym Tup3 _ loc (m1 :* m2 :* m3 :* Nil) = do+        compileExpr m1 >>= assign (loc :.: "member1")+        compileExpr m2 >>= assign (loc :.: "member2")+        compileExpr m3 >>= assign (loc :.: "member3")+    compileProgSym Tup4 _ loc (m1 :* m2 :* m3 :* m4 :* Nil) = do+        compileExpr m1 >>= assign (loc :.: "member1")+        compileExpr m2 >>= assign (loc :.: "member2")+        compileExpr m3 >>= assign (loc :.: "member3")+        compileExpr m4 >>= assign (loc :.: "member4")+    compileProgSym Tup5 _ loc (m1 :* m2 :* m3 :* m4 :* m5 :* Nil) = do+        compileExpr m1 >>= assign (loc :.: "member1")+        compileExpr m2 >>= assign (loc :.: "member2")+        compileExpr m3 >>= assign (loc :.: "member3")+        compileExpr m4 >>= assign (loc :.: "member4")+        compileExpr m5 >>= assign (loc :.: "member5")+    compileProgSym Tup6 _ loc (m1 :* m2 :* m3 :* m4 :* m5 :* m6 :* Nil) = do+        compileExpr m1 >>= assign (loc :.: "member1")+        compileExpr m2 >>= assign (loc :.: "member2")+        compileExpr m3 >>= assign (loc :.: "member3")+        compileExpr m4 >>= assign (loc :.: "member4")+        compileExpr m5 >>= assign (loc :.: "member5")+        compileExpr m6 >>= assign (loc :.: "member6")+    compileProgSym Tup7 _ loc (m1 :* m2 :* m3 :* m4 :* m5 :* m6 :* m7 :* Nil) = do+        compileExpr m1 >>= assign (loc :.: "member1")+        compileExpr m2 >>= assign (loc :.: "member2")+        compileExpr m3 >>= assign (loc :.: "member3")+        compileExpr m4 >>= assign (loc :.: "member4")+        compileExpr m5 >>= assign (loc :.: "member5")+        compileExpr m6 >>= assign (loc :.: "member6")+        compileExpr m7 >>= assign (loc :.: "member7")++instance Compile dom dom => Compile (Select TypeCtx) dom+  where+    compileExprSym Sel1 _ (tup :* Nil) = do+        tupExpr <- compileExpr tup+        return $ tupExpr :.: "member1"+    compileExprSym Sel2 _ (tup :* Nil) = do+        tupExpr <- compileExpr tup+        return $ tupExpr :.: "member2"+    compileExprSym Sel3 _ (tup :* Nil) = do+        tupExpr <- compileExpr tup+        return $ tupExpr :.: "member3"+    compileExprSym Sel4 _ (tup :* Nil) = do+        tupExpr <- compileExpr tup+        return $ tupExpr :.: "member4"+    compileExprSym Sel5 _ (tup :* Nil) = do+        tupExpr <- compileExpr tup+        return $ tupExpr :.: "member5"+    compileExprSym Sel6 _ (tup :* Nil) = do+        tupExpr <- compileExpr tup+        return $ tupExpr :.: "member6"+    compileExprSym Sel7 _ (tup :* Nil) = do+        tupExpr <- compileExpr tup+        return $ tupExpr :.: "member7"+
Feldspar/Compiler/Imperative/Frontend.hs view
@@ -1,157 +1,353 @@+--+-- Copyright (c) 2009-2011, 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 ViewPatterns #-}+ module Feldspar.Compiler.Imperative.Frontend where -import Feldspar.Compiler.Imperative.Representation-import qualified Feldspar.Compiler.Imperative.Representation as Representation+import Data.List -import Feldspar.Core.Types+import Feldspar.Compiler.Imperative.Representation hiding (Type, UserType, Cast, In, Out, Variable, Block, Pointer, Comment)+import qualified Feldspar.Compiler.Imperative.Representation as AIR --- ===========================================================================---  == Program generator tools--- ===========================================================================-emptyPrg :: Program ()-emptyPrg = Representation.Empty-    { emptyLabel   = ()-    , programLabel = ()-    }+import Feldspar.Core.Types hiding (Type) -genCopy :: Expression () -> Expression () -> Program ()-genCopy lhs rhs = ProcedureCall-    { procCallName = copy-    , procCallParams =-        [ In-            { inParam = rhs-            , actParamLabel = ()-            }-        , Out-            { outParam = lhs-            , actParamLabel = ()-            }-        ]-    , procCallLabel = ()-    , programLabel = ()-    }+-- * Frontend data types -createConstantExpression c = ConstExpr-    { constExpr =  c-    , exprLabel = ()-    }+data Mod = Mod [Ent]+  deriving (Show) -createLoopVariable :: String -> Representation.Variable ()-createLoopVariable name = Representation.Variable-    { varName  = name-    , varType  = NumType Signed S32-    , varRole  = Representation.Value-    , varLabel = ()-    }+data Ent+    = StructD String [(String, Type)]+    | ProcDf String [Var] [Var] Prog+    | ProcDcl String [Var] [Var]+  deriving (Show) -createVariable :: String -> Representation.Type -> Representation.Variable ()-createVariable name typ = Representation.Variable-    { varName = name-    , varType = typ -- compileTypeRep typ-    , varRole = Representation.Value-    , varLabel = ()-    }+data Type+    = Void+    | Boolean+    | Bit+    | Floating+    | I8 | I16 | I32 | I40 | I64+    | U8 | U16 | U32 | U40 | U64+    | Complex Type+    | UserType String+    | Array Type+    | SizedArray Int Type+    | Struct [(String, Type)]+  deriving Eq -createVariableLeftValue :: String -> Representation.Type -> Expression ()-createVariableLeftValue name typ = VarExpr-    { var = createVariable name typ-    , exprLabel = ()-    }+data Expr+    = Var Type String+    | Ptr Type String+    | Tr+    | Fl+    | LitI Type Integer+    | LitF Double+    | LitC Expr Expr+    | Expr :!: Expr+    | Expr :.: String+    | Binop Type String [Expr]+    | Fun Type String [Expr]+    | Cast Type Expr+    | SizeofE Expr+    | SizeofT Type+  deriving (Show) -createProgramSequence :: [Program ()] -> Program ()-createProgramSequence programs = Sequence-    { sequenceProgs = programs-    , sequenceLabel = ()-    , programLabel = ()-    }+data Prog+    = Skip+    | BComment String+    | Comment String+    | Expr := Expr+    | Call String [Param]+    | Seq [Prog]+    | If Expr Prog Prog+    | While Prog Expr Prog+    | For String Expr Int Prog+    | Block [Def] Prog+  deriving (Show) -createDeclaration :: String -> Representation.Type -> Declaration ()-createDeclaration name typ = Declaration-    { declVar  = createVariable name typ-    , initVal = Nothing-    , declLabel = ()-    }+data Param+    = In Expr+    | Out Expr+  deriving (Show) -programToBlock :: Program () -> Block ()-programToBlock p = Block-    { locals = []-    , blockBody = p-    , blockLabel = ()-    }+data Block+    = Bl [Def] Prog+  deriving (Show) -procedure symbol inArgs outArgs block = Procedure symbol inArgs outArgs block () ()-procedureCall symbol inArgs outArgs = ProcedureCall symbol (inArgs ++ outArgs) () ()-seqLoop cond condcalcblock core = SeqLoop cond condcalcblock core () ()-condBranch cond bt be = Branch cond bt be () ()-switch cond cases = Switch cond cases () ()-switchCase pattern impl = SwitchCase pattern impl ()-parLoop index length step block = ParLoop index length step block () ()-comment isblockcomment str = Comment isblockcomment str () ()-globalVar decl = GlobalVar decl () ()+data Def+    = Init Type String Expr+    | Def Type String+  deriving (Show) -intConstExpr :: Integer -> Expression ()-intConstExpr val = ConstExpr (intConst val) ()+data Var+    = Variable Type String+    | Pointer Type String+  deriving (Show) -intConstExprConv :: Int -> Expression ()-intConstExprConv val = ConstExpr (intConstConv val) ()+-- * Conversion between representation and frontend +class Interface t where+    type Repr t+    toInterface :: Repr t -> t+    fromInterface :: t -> Repr t -intConst :: Integer -> Constant ()-intConst val = IntConst val () ()+instance Interface Mod where+    type Repr Mod = AIR.Module ()+    toInterface (Module entities ()) = Mod $ map toInterface entities+    fromInterface (Mod entities) = AIR.Module (map fromInterface entities) () -intConstConv :: Int -> Constant ()-intConstConv val = IntConst (toInteger val) () ()+instance Interface Ent where+    type Repr Ent = AIR.Entity ()+    toInterface (AIR.StructDef name members () ()) =+        StructD name (map (\(StructMember mname mtyp ())->(mname,toInterface mtyp)) members)+    toInterface (AIR.ProcDef name inparams outparams body () ()) =+        ProcDf name (map toInterface inparams) (map toInterface outparams) (toProg body)+    toInterface (AIR.ProcDecl name inparams outparams () ()) =+        ProcDcl name (map toInterface inparams) (map toInterface outparams)+    fromInterface (StructD name members) =+        AIR.StructDef name (map (\(mname,mtyp)->(StructMember mname (fromInterface mtyp) ())) members) () ()+    fromInterface (ProcDf name inparams outparams body) =+        AIR.ProcDef name (map fromInterface inparams) (map fromInterface outparams) (toBlock body) () ()+    fromInterface (ProcDcl name inparams outparams) =+        AIR.ProcDecl name (map fromInterface inparams) (map fromInterface outparams) () ()  -functionCall :: String -> Representation.Type -> [Expression ()] -> Expression ()-functionCall symbol typ args = FunctionCall symbol typ SimpleFun args () ()+instance Interface Type where+    type Repr Type = AIR.Type+    toInterface VoidType = Void+    toInterface AIR.BoolType = Boolean+    toInterface BitType = Bit+    toInterface AIR.FloatType = Floating+    toInterface (NumType Signed S8) = I8+    toInterface (NumType Signed S16) = I16+    toInterface (NumType Signed S32) = I32+    toInterface (NumType Signed S40) = I40+    toInterface (NumType Signed S64) = I64+    toInterface (NumType Unsigned S8) = U8+    toInterface (NumType Unsigned S16) = U16+    toInterface (NumType Unsigned S32) = U32+    toInterface (NumType Unsigned S40) = U40+    toInterface (NumType Unsigned S64) = U64+    toInterface (AIR.ComplexType t) = Complex $ toInterface t+    toInterface (AIR.UserType s) = UserType s+    toInterface (AIR.ArrayType (LiteralLen l) t) = SizedArray l $ toInterface t+    toInterface (AIR.ArrayType _ t) = Array $ toInterface t+    toInterface (AIR.StructType fields) = Struct $ map (\(name,t) -> (name,toInterface t)) fields+    fromInterface Void = VoidType+    fromInterface Boolean = AIR.BoolType+    fromInterface Bit = BitType+    fromInterface Floating = AIR.FloatType+    fromInterface I8 = NumType Signed S8+    fromInterface I16 = NumType Signed S16+    fromInterface I32 = NumType Signed S32+    fromInterface I40 = NumType Signed S40+    fromInterface I64 = NumType Signed S64+    fromInterface U8 = NumType Unsigned S8+    fromInterface U16 = NumType Unsigned S16+    fromInterface U32 = NumType Unsigned S32+    fromInterface U40 = NumType Unsigned S40+    fromInterface U64 = NumType Unsigned S64+    fromInterface (Complex t) = AIR.ComplexType $ fromInterface t+    fromInterface (UserType s) = AIR.UserType s+    fromInterface (Array t) = AIR.ArrayType UndefinedLen $ fromInterface t+    fromInterface (SizedArray l t) = AIR.ArrayType (LiteralLen l) $ fromInterface t+    fromInterface (Struct fields) = AIR.StructType $ map (\(name,t) -> (name,fromInterface t)) fields -arrayElem :: Expression () -> Expression () -> Expression ()-arrayElem lv ix = ArrayElem lv ix () ()+instance Interface Expr where+    type Repr Expr = Expression ()+    toInterface (VarExpr (AIR.Variable name t Value ()) ()) = Var (toInterface t) name+    toInterface (VarExpr (AIR.Variable name t AIR.Pointer ()) ()) = Ptr (toInterface t) name+    toInterface (ArrayElem arr idx () ()) = (toInterface arr) :!: (toInterface idx)+    toInterface (StructField str field () ()) = (toInterface str) :.: field+    toInterface (ConstExpr (BoolConst True () ()) ()) = Tr+    toInterface (ConstExpr (BoolConst False () ()) ()) = Fl+    toInterface (ConstExpr (IntConst x t () ()) ()) = LitI (toInterface t) x+    toInterface (ConstExpr (FloatConst x () ()) ()) = LitF x+    toInterface (ConstExpr (ComplexConst r i () ()) ()) = LitC (toInterface $ ConstExpr r ()) (toInterface $ ConstExpr i ())+    toInterface (FunctionCall (Function name t Prefix) ps () ()) = Fun (toInterface t) name $ map toInterface ps+    toInterface (FunctionCall (Function name t Infix) ps () ()) = Binop (toInterface t) name $ map toInterface ps+    toInterface (AIR.Cast t e () ()) = Cast (toInterface t) (toInterface e)+    toInterface (SizeOf (Left t) () ()) = SizeofT $ toInterface t+    toInterface (SizeOf (Right e) () ()) = SizeofE $ toInterface e+    fromInterface (Var t name) = VarExpr (AIR.Variable name (fromInterface t) Value ()) ()+    fromInterface (Ptr t name) = VarExpr (AIR.Variable name (fromInterface t) AIR.Pointer ()) ()+    fromInterface (Tr) = ConstExpr (BoolConst True () ()) ()+    fromInterface (Fl) = ConstExpr (BoolConst False () ()) ()+    fromInterface (LitI t x) = ConstExpr (IntConst x (fromInterface t) () ()) ()+    fromInterface (LitF x) = ConstExpr (FloatConst x () ()) ()+    fromInterface (LitC (fromInterface -> (ConstExpr r ())) (fromInterface -> (ConstExpr i ()))) =+        ConstExpr (ComplexConst r i () ()) ()+    fromInterface (LitC _ _) = error "Illegal LitC" -- TODO (?)+    fromInterface (Binop t name es) = FunctionCall (Function name (fromInterface t) Infix) (map fromInterface es) () ()+    fromInterface (Fun t name es) = FunctionCall (Function name (fromInterface t) Prefix) (map fromInterface es) () ()+    fromInterface (Cast t e) = AIR.Cast (fromInterface t) (fromInterface e) () ()+    fromInterface (SizeofE e) = SizeOf (Right $ fromInterface e) () ()+    fromInterface (SizeofT t) = SizeOf (Left $ fromInterface t) () ()+    fromInterface (arr :!: idx) = ArrayElem (fromInterface arr) (fromInterface idx) () ()+    fromInterface (str :.: field) = StructField (fromInterface str) field () () -blockProgram :: Block () -> Program ()-blockProgram = flip BlockProgram ()+instance Interface Prog where+    type Repr Prog = AIR.Program ()+    toInterface (Empty () ()) = Skip+    toInterface (AIR.Comment True s () ()) = BComment s+    toInterface (AIR.Comment False s () ()) = Comment s+    toInterface (Assign lhs rhs () ()) = (toInterface lhs) := (toInterface rhs)+    toInterface (ProcedureCall s ps () ()) = Call s (map toInterface ps)+    toInterface (Sequence ps () ()) = Seq (map toInterface ps)+    toInterface (Branch e b1 b2 () ()) = If (toInterface e) (toProg b1) (toProg b2)+    toInterface (SeqLoop e pe b () ()) = While (toProg pe) (toInterface e) (toProg b)+    toInterface (ParLoop v e i b () ()) = For (varName v) (toInterface e) i (toProg b)+    toInterface (BlockProgram b ()) = Block (map toInterface $ locals b) (toInterface $ blockBody b)+    fromInterface (Skip) = Empty () ()+    fromInterface (BComment s) = AIR.Comment True s () ()+    fromInterface (Comment s) = AIR.Comment False s () ()+    fromInterface (lhs := rhs) = Assign (fromInterface lhs) (fromInterface rhs) () ()+    fromInterface (Call s ps) = ProcedureCall s (map fromInterface ps) () ()+    fromInterface (Seq ps) = Sequence (map fromInterface ps) () ()+    fromInterface (If e p1 p2) = Branch (fromInterface e) (toBlock p1) (toBlock p2) () ()+    fromInterface (While pe e p) = SeqLoop (fromInterface e) (toBlock pe) (toBlock p) () ()+    fromInterface (For s e i p) = ParLoop+        (AIR.Variable s (NumType Unsigned S32) Value ()) (fromInterface e) i (toBlock p) () ()+    fromInterface (Block ds p) = BlockProgram (AIR.Block (map fromInterface ds) (fromInterface p) ()) () -declaration :: Variable () -> Maybe (Expression ()) -> Declaration ()-declaration var initval = Declaration var initval ()+instance Interface Param where+    type Repr Param = ActualParameter ()+    toInterface (AIR.In e ()) = In (toInterface e)+    toInterface (AIR.Out e ()) = Out (toInterface e)+    fromInterface (In e) = AIR.In (fromInterface e) ()+    fromInterface (Out e) = AIR.Out (fromInterface e) () -varExpr :: Variable () -> Expression ()-varExpr var = VarExpr var ()+instance Interface Def where+    type Repr Def = Declaration ()+    toInterface (Declaration v (Just e) ()) = Init (toInterface $ varType v) (varName v) (toInterface e)+    toInterface (Declaration v Nothing ()) = Def (toInterface $ varType v) (varName v)+    fromInterface (Init t s e) = Declaration (AIR.Variable s (fromInterface t) Value ()) (Just $ fromInterface e) ()+    fromInterface (Def t s) = Declaration (AIR.Variable s (fromInterface t) Value ()) Nothing () -varActualParam :: Variable () -> (Expression () -> () -> ActualParameter ()) -> ActualParameter ()-varActualParam v role = role (varExpr v) ()+instance Interface Block where+    type Repr Block = AIR.Block ()+    toInterface (AIR.Block ds p ()) = Bl (map toInterface ds) (toInterface p)+    fromInterface (Bl ds p) = AIR.Block (map fromInterface ds) (fromInterface p) () -block :: [Declaration ()] -> [Program ()] -> Block ()-block decls actions = Block decls prog ()-  where-    prog = case actions of-      [] -> Empty () ()-      _  -> Sequence (concatMap act actions) () ()+instance Interface Var where+    type Repr Var = AIR.Variable ()+    toInterface (AIR.Variable name typ Value ()) = Variable (toInterface typ) name+    toInterface (AIR.Variable name typ AIR.Pointer ()) = Pointer (toInterface typ) name+    fromInterface (Variable typ name) = AIR.Variable name (fromInterface typ) Value ()+    fromInterface (Pointer typ name) = AIR.Variable name (fromInterface typ) AIR.Pointer () -    act (Empty _ _)        = []-    act (Sequence seq _ _) = seq-    act a                  = [a]-    -    -variable :: String -> Representation.Type -> Variable ()-variable name typ = Variable name typ Value ()-  -- Using 'Value' for all variables; the correct role will be set in a later-  -- stage-    -copy :: String-copy = "copy"+toBlock :: Prog -> AIR.Block ()+toBlock (Block ds p) = AIR.Block (map fromInterface ds) (fromInterface p) ()+toBlock p = AIR.Block [] (fromInterface p) () -setLength :: Expression () -> Expression () -> Program ()-setLength arr len = procedureCall "setLength" [Out arr ()] [In len ()]+toProg :: AIR.Block () -> Prog+toProg (AIR.Block [] p ()) = toInterface p+toProg (AIR.Block ds p ()) = Block (map toInterface ds) (toInterface p) -increaseLength :: Expression () -> Expression () -> Program ()-increaseLength arr len = procedureCall "increaseLength" [Out arr ()] [In len ()]+boolToExpr :: Bool -> Expr+boolToExpr True = Tr+boolToExpr False = Fl -copyProg :: Expression () -> Expression () -> Program () -copyProg outExp inExp = ProcedureCall copy [Out outExp (), In inExp ()] () () +setLength :: Expr -> Expr -> Prog+setLength arr len = Call "setLength" [Out arr, In len] -copyProgPos :: Expression () -> Expression () -> Expression () -> Program () -copyProgPos outExp shift inExp = ProcedureCall "copyArrayPos" [Out outExp (), In shift (), In inExp ()] () () +increaseLength :: Expr -> Expr -> Prog+increaseLength arr len = Call "increaseLength" [Out arr, In len] -copyProgLen :: Expression () -> Expression () -> Expression () -> Program () -copyProgLen outExp inExp len = ProcedureCall "copyArrayLen" [Out outExp (), In inExp (), In len ()] () ()+copyProg :: Expr -> Expr -> Prog+copyProg outExp inExp = Call "copy" [Out outExp, In inExp]++copyProgPos :: Expr -> Expr -> Expr -> Prog+copyProgPos outExp shift inExp = Call "copyArrayPos" [Out outExp, In shift, In inExp]++copyProgLen :: Expr -> Expr -> Expr -> Prog+copyProgLen outExp inExp len = Call "copyArrayLen" [Out outExp, In inExp, In len]++instance Show Type+  where+    show Void       = "void"+    show Boolean    = "bool"+    show Bit        = "bit"+    show Floating   = "float"+    show I8         = "int8"+    show I16        = "int16"+    show I32        = "int32"+    show I40        = "int40"+    show I64        = "int64"+    show U8         = "uint8"+    show U16        = "uint16"+    show U32        = "uint32"+    show U40        = "uint40"+    show U64        = "uint64"+    show (Complex t)    = "complexOf_" ++ show t+    show (UserType s)   = "userType_" ++ s+    show (Array t)      = "arrayOf_" ++ show t+    show (SizedArray i t)   = "arrayOfSize_" ++ show i ++ "_" ++ show t+    show (Struct fields)    = "struct_" ++ intercalate "_" (map (\(s,t) -> s ++ "_" ++ show t) fields)++instance HasType Expr+  where+    type TypeOf Expr = Type+    typeof = toInterface . typeof . fromInterface++intWidth :: Type -> Maybe Integer+intWidth I8  = Just 8+intWidth I16 = Just 16+intWidth I32 = Just 32+intWidth I40 = Just 40+intWidth I64 = Just 64+intWidth U8  = Just 8+intWidth U16 = Just 16+intWidth U32 = Just 32+intWidth U40 = Just 40+intWidth U64 = Just 64+intWidth _   = Nothing++intSigned :: Type -> Maybe Bool+intSigned I8  = Just True+intSigned I16 = Just True+intSigned I32 = Just True+intSigned I40 = Just True+intSigned I64 = Just True+intSigned U8  = Just False+intSigned U16 = Just False+intSigned U32 = Just False+intSigned U40 = Just False+intSigned U64 = Just False+intSigned _   = Nothing++litB :: Bool -> Expr+litB True = Tr+litB False = Fl++isArray :: Type -> Bool+isArray (Array _) = True+isArray (SizedArray _ _) = True+isArray _ = False
Feldspar/Compiler/Imperative/Plugin/ConstantFolding.hs view
@@ -1,3 +1,31 @@+--+-- Copyright (c) 2009-2011, 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.Plugin.ConstantFolding where@@ -18,8 +46,8 @@     type State ConstantFolding  = ()  instance Transformable ConstantFolding Expression where-    transform t s d f@(FunctionCall _ _ _ _ _ _) = case funRole f' of-        InfixOp -> case funCallName f' of+    transform t s d f@(FunctionCall _ _ _ _) = case funMode $ function f' of+        Infix -> case funName $ function f' of             "+"     -> tr' $ elimParamIf (isConstIntN 0) True  $ result tr             "-"     -> tr' $ elimParamIf (isConstIntN 0) False $ result tr             "*"     -> tr' $ elimParamIf (isConstIntN 1) True  $ result tr@@ -29,10 +57,10 @@             tr = defaultTransform t s d f             tr' x = tr {result = x}             f' = result tr-            isConstIntN n (ConstExpr (IntConst i _ _) _) = n == i+            isConstIntN n (ConstExpr (IntConst i _ _ _) _) = n == i             isConstIntN _ _ = False -            elimParamIf pred flippable funCall@(FunctionCall _ _ InfixOp (x:xs) _ _)+            elimParamIf pred flippable funCall@(FunctionCall (Function _ _ Infix) (x:xs) _ _)                 | pred (head xs)      = x                 | flippable && pred x = head xs                 | otherwise           = funCall
Feldspar/Compiler/Imperative/Plugin/Naming.hs view
@@ -1,3 +1,31 @@+--+-- Copyright (c) 2009-2011, ERICSSON AB+-- All rights reserved.+-- +-- Redistribution and use in source and binary forms, with or without+-- modification, are permitted provided that the following conditions are met:+-- +--     * Redistributions of source code must retain the above copyright notice, +--       this list of conditions and the following disclaimer.+--     * Redistributions in binary form must reproduce the above copyright+--       notice, this list of conditions and the following disclaimer in the+--       documentation and/or other materials provided with the distribution.+--     * Neither the name of the ERICSSON AB nor the names of its contributors+--       may be used to endorse or promote products derived from this software+--       without specific prior written permission.+-- +-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"+-- AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE+-- IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +-- DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE+-- FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+-- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR+-- SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER+-- CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,+-- OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+-- OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.+--+ {-# LANGUAGE EmptyDataDecls, TypeFamilies #-}  module Feldspar.Compiler.Imperative.Plugin.Naming where@@ -37,8 +65,8 @@     type State Precompilation = ()  -instance Transformable Precompilation Definition where-        transform t s d x@(Procedure n i _ _ _ _) | n == "PLACEHOLDER" = tr { result = (result tr){ procName = n' } } where+instance Transformable Precompilation Entity where+        transform t s d x@(ProcDef n i _ _ _ _) | n == "PLACEHOLDER" = tr { result = (result tr){ procName = n' } } where             d' = d { generatedImperativeParameterNames = map varName i }             tr = defaultTransform t s d' x             n' = originalFunctionName d
Feldspar/Compiler/Imperative/Plugin/Unroll.hs view
@@ -1,3 +1,31 @@+--+-- Copyright (c) 2009-2011, 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, TypeFamilies #-}  module Feldspar.Compiler.Imperative.Plugin.Unroll where@@ -22,8 +50,8 @@ instance Annotation UnrollSemInf Module where     type Label UnrollSemInf Module = () -instance Annotation UnrollSemInf Definition where-    type Label UnrollSemInf Definition = ()+instance Annotation UnrollSemInf Entity where+    type Label UnrollSemInf Entity = ()  instance Annotation UnrollSemInf Struct where     type Label UnrollSemInf Struct = ()@@ -31,20 +59,11 @@ instance Annotation UnrollSemInf StructMember where     type Label UnrollSemInf StructMember = () -instance Annotation UnrollSemInf Union where-    type Label UnrollSemInf Union = ()--instance Annotation UnrollSemInf UnionMember where-    type Label UnrollSemInf UnionMember = ()--instance Annotation UnrollSemInf Procedure where-    type Label UnrollSemInf Procedure = ()--instance Annotation UnrollSemInf Prototype where-    type Label UnrollSemInf Prototype = ()+instance Annotation UnrollSemInf ProcDef where+    type Label UnrollSemInf ProcDef = () -instance Annotation UnrollSemInf GlobalVar where-    type Label UnrollSemInf GlobalVar = ()+instance Annotation UnrollSemInf ProcDecl where+    type Label UnrollSemInf ProcDecl = ()  instance Annotation UnrollSemInf Block where     type Label UnrollSemInf Block = ()@@ -70,18 +89,12 @@ instance Annotation UnrollSemInf Branch where     type Label UnrollSemInf Branch = () -instance Annotation UnrollSemInf Switch where-    type Label UnrollSemInf Switch = ()- instance Annotation UnrollSemInf SeqLoop where     type Label UnrollSemInf SeqLoop = ()  instance Annotation UnrollSemInf ParLoop where     type Label UnrollSemInf ParLoop = () -instance Annotation UnrollSemInf SwitchCase where-    type Label UnrollSemInf SwitchCase = ()- instance Annotation UnrollSemInf ActualParameter where     type Label UnrollSemInf ActualParameter = () @@ -106,9 +119,6 @@ instance Annotation UnrollSemInf StructField where     type Label UnrollSemInf StructField = () -instance Annotation UnrollSemInf UnionField where-    type Label UnrollSemInf UnionField = ()- instance Annotation UnrollSemInf Constant where     type Label UnrollSemInf Constant = () @@ -191,7 +201,7 @@         loopCounter = varName $ pLoopCounter $ result tr         varNames = map (\d -> getVarNameDecl d) $ locals loopCore         unrollPossible = case loopBound of-            (ConstExpr (IntConst i _ _) _) -> mod i (toInteger d) == 0+            (ConstExpr (IntConst i _ _ _) _) -> mod i (toInteger d) == 0             _                              -> False     transform t s d p = defaultTransform t s d p @@ -217,12 +227,14 @@             VarExpr n _                 | varName n == loopVar x -> tr                      { result = FunctionCall -                        { funCallName = "+"-                        , returnType = NumType Signed S32-                        , funRole = InfixOp+                        { function = Function+                            { funName = "+"+                            , returnType = NumType Signed S32+                            , funMode = Infix+                            }                         , funCallParams =                              [ result tr-                            , ConstExpr (IntConst (toInteger $ position x) () ()) ()+                            , ConstExpr (IntConst (toInteger $ position x) (NumType Signed S32) () ()) ()                             ]                         , funCallLabel = ()                         , exprLabel = ()
Feldspar/Compiler/Imperative/Representation.hs view
@@ -1,6 +1,39 @@+--+-- Copyright (c) 2009-2011, 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, UndecidableInstances, OverlappingInstances #-} module Feldspar.Compiler.Imperative.Representation where +import Data.Typeable+import qualified Data.List as List (find)++import Feldspar.Compiler.Error+ -- =============================================================================================== -- == Class defining semantic information attached to different nodes in the imperative program == -- ===============================================================================================@@ -16,75 +49,57 @@ -- =================================================  data Module t = Module-    { definitions                   :: [Definition t]+    { entities                      :: [Entity t]     , moduleLabel                   :: Label t Module     }+    deriving Typeable  deriving instance (ShowLabel t) => Show (Module t) deriving instance (EqLabel t)   => Eq (Module t)  -data Definition t-    = Struct+data Entity t+    = StructDef         { structName                :: String         , structMembers             :: [StructMember t]         , structLabel               :: Label t Struct-        , definitionLabel           :: Label t Definition-        }-    | Union-        { unionName                 :: String-        , unionMembers              :: [UnionMember t]-        , unionLabel                :: Label t Union-        , definitionLabel           :: Label t Definition+        , definitionLabel           :: Label t Entity         }-    | Procedure+    | ProcDef         { procName                  :: String         , inParams                  :: [Variable t]         , outParams                 :: [Variable t]         , procBody                  :: Block t-        , procLabel                 :: Label t Procedure-        , definitionLabel           :: Label t Definition+        , procDefLabel              :: Label t ProcDef+        , definitionLabel           :: Label t Entity         }-    | Prototype-        { protoReturnType           :: Type-        , protoName                 :: String+    | ProcDecl+        { procName                  :: String         , inParams                  :: [Variable t]         , outParams                 :: [Variable t]-        , protoLabel                :: Label t Prototype-        , definitionLabel           :: Label t Definition-        }-    | GlobalVar-        { globalVarDecl             :: Declaration t-        , globalVarDeclLabel        :: Label t GlobalVar-        , definitionLabel           :: Label t Definition+        , procDeclLabel             :: Label t ProcDecl+        , definitionLabel           :: Label t Entity         }-   +    deriving Typeable -deriving instance (ShowLabel t) => Show (Definition t)-deriving instance (EqLabel t)   => Eq (Definition t) +deriving instance (ShowLabel t) => Show (Entity t)+deriving instance (EqLabel t)   => Eq (Entity t)   data StructMember t = StructMember     { structMemberName              :: String     , structMemberType              :: Type     , structMemberLabel             :: Label t StructMember     }--data UnionMember t = UnionMember-    { unionMemberName               :: String-    , unionMemberType               :: Type-    , unionMemberLabel              :: Label t UnionMember-    }-+    deriving Typeable  deriving instance (ShowLabel t) => Show (StructMember t) deriving instance (EqLabel t)   => Eq (StructMember t)-deriving instance (ShowLabel t) => Show (UnionMember t)-deriving instance (EqLabel t)   => Eq (UnionMember t)  data Block t = Block     { locals                        :: [Declaration t]     , blockBody                     :: Program t     , blockLabel                    :: Label t Block     }+    deriving Typeable  deriving instance (ShowLabel t) => Show (Block t) deriving instance (EqLabel t)   => Eq (Block t)@@ -124,12 +139,6 @@         , branchLabel               :: Label t Branch         , programLabel              :: Label t Program         }-    | Switch-        { switchCond                :: Expression t-        , switchCases               :: [SwitchCase t]-        , switchLabel               :: Label t Switch-        , programLabel              :: Label t Program-        }     | SeqLoop         { sLoopCond                 :: Expression t         , sLoopCondCalc             :: Block t@@ -149,19 +158,11 @@         { blockProgram              :: Block t         , programLabel              :: Label t Program         }+    deriving Typeable  deriving instance (ShowLabel t) => Show (Program t) deriving instance (EqLabel t)   => Eq (Program t) -data SwitchCase t = SwitchCase-    { switchCasePattern             :: Constant t-    , switchCaseImpl                :: Block t-    , switchCaseLabel               :: Label t SwitchCase-    }--deriving instance (ShowLabel t) => Show (SwitchCase t)-deriving instance (EqLabel t)   => Eq (SwitchCase t)- data ActualParameter t     = In         { inParam                   :: Expression t@@ -171,6 +172,7 @@         { outParam                  :: Expression t         , actParamLabel             :: Label t ActualParameter         }+    deriving Typeable  deriving instance (ShowLabel t) => Show (ActualParameter t) deriving instance (EqLabel t)   => Eq (ActualParameter t)@@ -180,6 +182,7 @@     , initVal                       :: Maybe (Expression t)     , declLabel                     :: Label t Declaration     }+    deriving Typeable  deriving instance (ShowLabel t) => Show (Declaration t) deriving instance (EqLabel t)   => Eq (Declaration t)@@ -201,20 +204,12 @@         , structFieldLabel          :: Label t StructField         , exprLabel                 :: Label t Expression         }-    | UnionField-        { union                     :: Expression t-        , fieldName                 :: String-        , unionFieldLabel           :: Label t UnionField-        , exprLabel                 :: Label t Expression-        }     | ConstExpr         { constExpr                 :: Constant t         , exprLabel                 :: Label t Expression         }     | FunctionCall-        { funCallName               :: String-        , returnType                :: Type-        , funRole                   :: FunctionRole+        { function                  :: Function         , funCallParams             :: [Expression t]         , funCallLabel              :: Label t FunctionCall         , exprLabel                 :: Label t Expression@@ -230,13 +225,21 @@         , sizeOfLabel               :: Label t SizeOf         , exprLabel                 :: Label t Expression         }+    deriving Typeable  deriving instance (ShowLabel t) => Show (Expression t) deriving instance (EqLabel t)   => Eq (Expression t) +data Function = Function {+    funName                   :: String+  , returnType                :: Type+  , funMode                   :: FunctionMode+} deriving (Eq, Show)+ data Constant t     = IntConst         { intValue                  :: Integer+        , intType                   :: Type         , intConstLabel             :: Label t IntConst         , constLabel                :: Label t Constant         }@@ -250,17 +253,18 @@         , boolConstLabel            :: Label t BoolConst         , constLabel                :: Label t Constant         }-    | ArrayConst-        { arrayValues               :: [Constant t]-        , arrayConstLabel           :: Label t ArrayConst-        , constLabel                :: Label t Constant-        }+    -- | ArrayConst+        -- { arrayValues               :: [Constant t]+        -- , arrayConstLabel           :: Label t ArrayConst+        -- , constLabel                :: Label t Constant+        -- }     | ComplexConst         { realPartComplexValue       :: Constant t         , imagPartComplexValue       :: Constant t         , complexConstLabel          :: Label t ComplexConst         , constLabel                 :: Label t Constant         }+    deriving Typeable  deriving instance (ShowLabel t) => Show (Constant t) deriving instance (EqLabel t)   => Eq (Constant t)@@ -271,6 +275,7 @@     , varRole                        :: VariableRole     , varLabel                       :: Label t Variable     }+    deriving Typeable  deriving instance (ShowLabel t) => Show (Variable t) deriving instance (EqLabel t)   => Eq (Variable t)@@ -281,7 +286,6 @@  data Length =       LiteralLen Int-    | IndirectLen String     | UndefinedLen     deriving (Eq,Show) @@ -301,33 +305,75 @@     | UserType String     | ArrayType Length Type     | StructType [(String, Type)]-    | UnionType [(String, Type)]     deriving (Eq,Show) -data FunctionRole = SimpleFun | InfixOp | PrefixOp+data FunctionMode = Prefix | Infix     deriving (Eq,Show) -data VariableRole =-      Value-    | Pointer+data VariableRole = Value | Pointer     deriving (Eq,Show) +----------------------+--   Type inference --+----------------------++class HasType a where+    type TypeOf a+    typeof :: a -> TypeOf a++instance HasType (Variable t) where+    type TypeOf (Variable t) = Type+    typeof (Variable r t s _) = t    ++instance (ShowLabel t) => HasType (Constant t) where+    type TypeOf (Constant t) = Type+    typeof (IntConst _ t _ _) = t+    typeof (FloatConst _ _ _) = FloatType+    typeof (BoolConst _ _ _) = BoolType+    typeof (ComplexConst r i _ _) = ComplexType (typeof r)++instance (ShowLabel t) => HasType (Expression t) where+    type TypeOf (Expression t) = Type+    typeof (VarExpr v _) = typeof v+    typeof (ArrayElem n i _ _) = decrArrayDepth (typeof n)+      where+        decrArrayDepth :: Type -> Type+        decrArrayDepth (ArrayType _ t) = t+        decrArrayDepth t = reprError InternalError $ "Non-array variable is indexed! " ++ show t+    typeof (StructField s f _ _) = getStructFieldType f (typeof s)+      where+        getStructFieldType :: String -> Type -> Type+        getStructFieldType f (StructType l) = case List.find (\(a,_) -> a == f) l of+            Just (_,t) -> t+            Nothing -> structFieldNotFound f+        getStructFieldType f t = reprError InternalError $+            "Trying to get a struct field from not a struct typed expression\n" ++ "Field: " ++ f ++ "\nType:  " ++ show t+        structFieldNotFound f = reprError InternalError $ "Not found struct field with this name: " ++ f+    typeof (ConstExpr c _) = typeof c+    typeof (FunctionCall f p _ _) = returnType f+    typeof (Cast t e _ _) = t+    typeof (SizeOf s _ _) = NumType Signed S32++instance (ShowLabel t) => HasType (ActualParameter t) where+    type TypeOf (ActualParameter t) = Type+    typeof (In e _) = typeof e+    typeof (Out l _) = typeof l++reprError = handleError "Feldspar.Compiler.Imperative.Representation"+ -- ===================== -- == Technical types == -- =====================  data Struct t-data Union t    -data Procedure t-data Prototype t-data GlobalVar t+data ProcDef t+data ProcDecl t data Empty t data Comment t data Assign t data ProcedureCall t data Sequence t data Branch t-data Switch t data SeqLoop t data ParLoop t data FunctionCall t@@ -335,7 +381,6 @@ data SizeOf t data ArrayElem t data StructField t-data UnionField t data LeftFunCall t data IntConst t data FloatConst t@@ -348,14 +393,11 @@ -- ==========================  class ( Show (Label t Module)-      , Show (Label t Definition)+      , Show (Label t Entity)       , Show (Label t Struct)-      , Show (Label t Union)-      , Show (Label t Procedure)-      , Show (Label t Prototype)-      , Show (Label t GlobalVar)+      , Show (Label t ProcDef)+      , Show (Label t ProcDecl)       , Show (Label t StructMember)-      , Show (Label t UnionMember)       , Show (Label t Block)       , Show (Label t Program)       , Show (Label t Empty)@@ -364,10 +406,8 @@       , Show (Label t ProcedureCall)       , Show (Label t Sequence)       , Show (Label t Branch)-      , Show (Label t Switch)       , Show (Label t SeqLoop)       , Show (Label t ParLoop)-      , Show (Label t SwitchCase)       , Show (Label t ActualParameter)       , Show (Label t Declaration)       , Show (Label t Expression)@@ -376,7 +416,6 @@       , Show (Label t SizeOf)       , Show (Label t ArrayElem)       , Show (Label t StructField)-      , Show (Label t UnionField)       , Show (Label t Constant)       , Show (Label t IntConst)       , Show (Label t FloatConst)@@ -387,14 +426,11 @@       ) => ShowLabel t  instance ( Show (Label t Module)-         , Show (Label t Definition)+         , Show (Label t Entity)          , Show (Label t Struct)-         , Show (Label t Union)-         , Show (Label t Procedure)-         , Show (Label t Prototype)-         , Show (Label t GlobalVar)+         , Show (Label t ProcDef)+         , Show (Label t ProcDecl)          , Show (Label t StructMember)-         , Show (Label t UnionMember)          , Show (Label t Block)          , Show (Label t Program)          , Show (Label t Empty)@@ -403,10 +439,8 @@          , Show (Label t ProcedureCall)          , Show (Label t Sequence)          , Show (Label t Branch)-         , Show (Label t Switch)          , Show (Label t SeqLoop)          , Show (Label t ParLoop)-         , Show (Label t SwitchCase)          , Show (Label t ActualParameter)          , Show (Label t Declaration)          , Show (Label t Expression)@@ -415,7 +449,6 @@          , Show (Label t SizeOf)          , Show (Label t ArrayElem)          , Show (Label t StructField)-         , Show (Label t UnionField)          , Show (Label t Constant)          , Show (Label t IntConst)          , Show (Label t FloatConst)@@ -426,14 +459,11 @@          ) => ShowLabel t  class ( Eq (Label t Module)-      , Eq (Label t Definition)+      , Eq (Label t Entity)       , Eq (Label t Struct)-      , Eq (Label t Union)-      , Eq (Label t Procedure)-      , Eq (Label t Prototype)-      , Eq (Label t GlobalVar)+      , Eq (Label t ProcDef)+      , Eq (Label t ProcDecl)       , Eq (Label t StructMember)-      , Eq (Label t UnionMember)       , Eq (Label t Block)       , Eq (Label t Program)       , Eq (Label t Empty)@@ -442,10 +472,8 @@       , Eq (Label t ProcedureCall)       , Eq (Label t Sequence)       , Eq (Label t Branch)-      , Eq (Label t Switch)       , Eq (Label t SeqLoop)       , Eq (Label t ParLoop)-      , Eq (Label t SwitchCase)       , Eq (Label t ActualParameter)       , Eq (Label t Declaration)       , Eq (Label t Expression)@@ -453,7 +481,6 @@       , Eq (Label t Cast)       , Eq (Label t SizeOf)       , Eq (Label t StructField)-      , Eq (Label t UnionField)       , Eq (Label t ArrayElem)       , Eq (Label t Constant)       , Eq (Label t IntConst)@@ -465,14 +492,11 @@       ) => EqLabel t  instance ( Eq (Label t Module)-         , Eq (Label t Definition)+         , Eq (Label t Entity)          , Eq (Label t Struct)-         , Eq (Label t Union)-         , Eq (Label t Procedure)-         , Eq (Label t Prototype)-         , Eq (Label t GlobalVar)+         , Eq (Label t ProcDef)+         , Eq (Label t ProcDecl)          , Eq (Label t StructMember)-         , Eq (Label t UnionMember)          , Eq (Label t Block)          , Eq (Label t Program)          , Eq (Label t Empty)@@ -481,10 +505,8 @@          , Eq (Label t ProcedureCall)          , Eq (Label t Sequence)          , Eq (Label t Branch)-         , Eq (Label t Switch)          , Eq (Label t SeqLoop)          , Eq (Label t ParLoop)-         , Eq (Label t SwitchCase)          , Eq (Label t ActualParameter)          , Eq (Label t Declaration)          , Eq (Label t Expression)@@ -492,7 +514,6 @@          , Eq (Label t Cast)          , Eq (Label t SizeOf)          , Eq (Label t StructField)-         , Eq (Label t UnionField)          , Eq (Label t ArrayElem)          , Eq (Label t Constant)          , Eq (Label t IntConst)@@ -502,3 +523,49 @@          , Eq (Label t ComplexConst)          , Eq (Label t Variable)          ) => EqLabel t++-- * Set and get labels++class Labeled c where+    label       :: c t -> Label t c+    setLabel    :: c t -> Label t c -> c t++instance Labeled Module where+    label = moduleLabel+    setLabel c lab = c{ moduleLabel = lab }++instance Labeled Entity where+    label = definitionLabel+    setLabel c lab = c{ definitionLabel = lab }++instance Labeled Program where+    label = programLabel+    setLabel c lab = c{ programLabel = lab }++instance Labeled Declaration where+    label = declLabel+    setLabel c lab = c{ declLabel = lab }++instance Labeled Constant where+    label = constLabel+    setLabel c lab = c{ constLabel = lab }++instance Labeled StructMember where+    label = structMemberLabel+    setLabel c lab = c{ structMemberLabel = lab }++instance Labeled Variable where+    label = varLabel+    setLabel c lab = c{ varLabel = lab }++instance Labeled Expression where+    label = exprLabel+    setLabel c lab = c{ exprLabel = lab }++instance Labeled ActualParameter where+    label = actParamLabel+    setLabel c lab = c{ actParamLabel = lab }++instance Labeled Block where+    label = blockLabel+    setLabel c lab = c{ blockLabel = lab }
Feldspar/Compiler/Imperative/TransformationInstance.hs view
@@ -1,3 +1,31 @@+--+-- Copyright (c) 2009-2011, 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 UndecidableInstances, OverlappingInstances #-}   module Feldspar.Compiler.Imperative.TransformationInstance where@@ -19,42 +47,39 @@ -- == Transformation == -- ==================== -instance (Transformable1 t [] Definition, Conversion t Module)+instance (Transformable1 t [] Entity, Conversion t Module)     => DefaultTransformable t Module where         defaultTransform t s d (Module m inf) = Result (Module (result1 tr) $ convert inf) (state1 tr) (up1 tr) where             tr = transform1 t s d m -instance (Transformable1 t [] StructMember, Transformable1 t [] UnionMember, Transformable1 t [] Variable, Transformable t Block, Transformable t Declaration, Conversion t Definition, Conversion t Struct, Conversion t Union, Conversion t Procedure, Conversion t Prototype, Conversion t GlobalVar)-    => DefaultTransformable t Definition where-        defaultTransform t s d (Struct n m inf1 inf2) = Result (Struct n (result1 tr) (convert inf1) $ convert inf2) (state1 tr) (up1 tr) where-            tr = transform1 t s d m-        defaultTransform t s d (Union n m inf1 inf2) = Result (Union n (result1 tr) (convert inf1) $ convert inf2) (state1 tr) (up1 tr) where-            tr = transform1 t s d m-        defaultTransform t s d (Procedure n i o p inf1 inf2) = Result (Procedure n (result1 tr1) (result1 tr2) (result tr3) (convert inf1) $ convert inf2) (state tr3) (foldl combine (up1 tr1) [up1 tr2, up tr3]) where-            tr1 = transform1 t s d i-            tr2 = transform1 t (state1 tr1) d o-            tr3 = transform t (state1 tr2) d p-        defaultTransform t s d (Prototype r n i o inf1 inf2) = Result (Prototype r n (result1 tr1) (result1 tr2) (convert inf1) $ convert inf2) (state1 tr2) (combine (up1 tr1) (up1 tr2)) where-            tr1 = transform1 t s d i-            tr2 = transform1 t (state1 tr1) d o-        defaultTransform t s d (GlobalVar v inf1 inf2) = Result (GlobalVar (result tr) (convert inf1) $ convert inf2) (state tr) (up tr) where-            tr = transform t s d v+instance (Transformable1 t [] StructMember, Transformable1 t [] Variable, Transformable t Block, Transformable t Declaration, Conversion t Entity, Conversion t Struct, Conversion t ProcDef, Conversion t ProcDecl)+    => DefaultTransformable t Entity where+        defaultTransform t s d (StructDef n m inf1 inf2) =+            Result (StructDef n (result1 tr) (convert inf1) $ convert inf2) (state1 tr) (up1 tr) where+                tr = transform1 t s d m+        defaultTransform t s d (ProcDef n i o p inf1 inf2) =+            Result (ProcDef n (result1 tr1) (result1 tr2) (result tr3) (convert inf1) $ convert inf2)+                   (state tr3) (foldl combine (up1 tr1) [up1 tr2, up tr3]) where+                        tr1 = transform1 t s d i+                        tr2 = transform1 t (state1 tr1) d o+                        tr3 = transform t (state1 tr2) d p+        defaultTransform t s d (ProcDecl name inp outp inf1 inf2) =+            Result (ProcDecl name (result1 tr1) (result1 tr2) (convert inf1) (convert inf2))+                   (state1 tr2) (foldl1 combine [up1 tr1, up1 tr2]) where+                tr1 = transform1 t s d inp+                tr2 = transform1 t (state1 tr1) d outp  instance (Conversion t StructMember, Default (Up t))     => DefaultTransformable t StructMember where         defaultTransform t s d (StructMember n typ inf) = Result (StructMember n typ $ convert inf) s def -instance (Conversion t UnionMember, Default (Up t))-    => DefaultTransformable t UnionMember where-        defaultTransform t s d (UnionMember n typ inf) = Result (UnionMember n typ $ convert inf) s def- instance (Transformable1 t [] Declaration, Transformable t Program, Conversion t Block)     => DefaultTransformable t Block where         defaultTransform t s d (Block l b inf) = Result (Block (result1 tr1) (result tr2) $ convert inf) (state tr2) (combine (up1 tr1) (up tr2)) where             tr1 = transform1 t s d l             tr2 = transform t (state1 tr1) d b -instance (Transformable1 t [] Program, Transformable t Expression, Transformable1 t [] ActualParameter, Transformable t Block, Transformable t Variable, Transformable1 t [] SwitchCase, Conversion t Program, Conversion t Empty, Conversion t Comment, Conversion t Assign, Conversion t ProcedureCall, Conversion t Sequence, Conversion t Branch, Conversion t Switch, Conversion t SeqLoop, Conversion t ParLoop, Default (Up t))+instance (Transformable1 t [] Program, Transformable t Expression, Transformable1 t [] ActualParameter, Transformable t Block, Transformable t Variable, Conversion t Program, Conversion t Empty, Conversion t Comment, Conversion t Assign, Conversion t ProcedureCall, Conversion t Sequence, Conversion t Branch, Conversion t SeqLoop, Conversion t ParLoop, Default (Up t))     => DefaultTransformable t Program where         defaultTransform t s d (Empty inf1 inf2) = Result (Empty (convert inf1) $ convert inf2) s def         defaultTransform t s d (Comment b c inf1 inf2) = Result (Comment b c (convert inf1) $ convert inf2) s def@@ -69,9 +94,6 @@             tr1 = transform t s d e             tr2 = transform t (state tr1) d p1             tr3 = transform t (state tr2) d p2-        defaultTransform t s d (Switch c cs inf1 inf2) = Result (Switch (result tr1) (result1 tr2) (convert inf1) $ convert inf2) (state1 tr2) (combine (up tr1) (up1 tr2)) where-            tr1 = transform t s d c-            tr2 = transform1 t (state tr1) d cs                 defaultTransform t s d (SeqLoop v c p inf1 inf2) = Result (SeqLoop (result tr1) (result tr2) (result tr3) (convert inf1) $ convert inf2) (state tr3) (foldl combine (up tr1) [up tr2, up tr3]) where             tr1 = transform t s d v             tr2 = transform t (state tr1) d c@@ -83,12 +105,6 @@         defaultTransform t s d (BlockProgram b inf) = Result (BlockProgram (result tr) $ convert inf) (state tr) (up tr) where             tr = transform t s d b -instance (Transformable t Constant, Transformable t Block, Conversion t SwitchCase)-    => DefaultTransformable t SwitchCase where-        defaultTransform t s d (SwitchCase c b inf) = Result (SwitchCase (result tr1) (result tr2) $ convert inf) (state tr2) (combine (up tr1) (up tr2)) where-            tr1 = transform t s d c-            tr2 = transform t (state tr1) d b- instance (Transformable t Expression, Conversion t ActualParameter)     => DefaultTransformable t ActualParameter where         defaultTransform t s d (In p inf) = Result (In (result tr) $ convert inf) (state tr) (up tr) where@@ -102,7 +118,7 @@             tr1 = transform t s d v             tr2 = transform1 t (state tr1) d i -instance (Transformable t Expression, Transformable t Variable, Transformable t Constant, Transformable1 t [] Expression, Conversion t Expression, Conversion t FunctionCall, Conversion t ArrayElem, Conversion t StructField, Conversion t UnionField, Conversion t SizeOf, Conversion t Cast, Default (Up t))+instance (Transformable t Expression, Transformable t Variable, Transformable t Constant, Transformable1 t [] Expression, Conversion t Expression, Conversion t FunctionCall, Conversion t ArrayElem, Conversion t StructField, Conversion t SizeOf, Conversion t Cast, Default (Up t))     => DefaultTransformable t Expression where         defaultTransform t s d (VarExpr v inf) = Result (VarExpr (result tr) $ convert inf) (state tr) (up tr) where             tr = transform t s d v@@ -111,12 +127,11 @@             tr2 = transform t (state tr1) d i         defaultTransform t s d (StructField l n inf1 inf2) = Result (StructField (result tr) n (convert inf1) $ convert inf2) (state tr) (up tr) where             tr = transform t s d l-        defaultTransform t s d (UnionField l n inf1 inf2) = Result (UnionField (result tr) n (convert inf1) $ convert inf2) (state tr) (up tr) where-            tr = transform t s d l         defaultTransform t s d (ConstExpr c inf) = Result (ConstExpr (result tr) $ convert inf) (state tr) (up tr) where             tr = transform t s d c-        defaultTransform t s d (FunctionCall f typ rol par inf1 inf2) = Result (FunctionCall f typ rol (result1 tr) (convert inf1) $ convert inf2) (state1 tr) (up1 tr) where-            tr = transform1 t s d par+        defaultTransform t s d (FunctionCall f par inf1 inf2) = +            Result (FunctionCall f (result1 tr) (convert inf1) $ convert inf2) (state1 tr) (up1 tr) where+                tr = transform1 t s d par         defaultTransform t s d (Cast typ exp inf1 inf2) = Result (Cast typ (result tr) (convert inf1) $ convert inf2) (state tr) (up tr) where             tr = transform t s d exp         defaultTransform t s d (SizeOf par inf1 inf2) = case par of@@ -126,11 +141,11 @@  instance (Transformable t Constant, Transformable1 t [] Constant, Conversion t Constant, Conversion t IntConst, Conversion t FloatConst, Conversion t BoolConst, Conversion t ArrayConst, Conversion t ComplexConst, Default (Up t))     => DefaultTransformable t Constant where-        defaultTransform t s d (IntConst c inf1 inf2) = Result (IntConst c (convert inf1) $ convert inf2) s def+        defaultTransform t s d (IntConst c typ inf1 inf2) = Result (IntConst c typ (convert inf1) $ convert inf2) s def         defaultTransform t s d (FloatConst c inf1 inf2) = Result (FloatConst c (convert inf1) $ convert inf2) s def         defaultTransform t s d (BoolConst c inf1 inf2) = Result (BoolConst c (convert inf1) $ convert inf2) s def-        defaultTransform t s d (ArrayConst c inf1 inf2) = Result (ArrayConst (result1 tr) (convert inf1) $ convert inf2) (state1 tr) (up1 tr) where-            tr = transform1 t s d c+        -- defaultTransform t s d (ArrayConst c inf1 inf2) = Result (ArrayConst (result1 tr) (convert inf1) $ convert inf2) (state1 tr) (up1 tr) where+            -- tr = transform1 t s d c         defaultTransform t s d (ComplexConst re im inf1 inf2) = Result (ComplexConst (result tr1) (result tr2) (convert inf1) $ convert inf2) (state tr2) (combine (up tr1) $ up tr2) where             tr1 = transform t s d re             tr2 = transform t (state tr1) d im
Feldspar/NameExtractor.hs view
@@ -1,3 +1,31 @@+--+-- Copyright (c) 2009-2011, 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.NameExtractor where  import System.IO@@ -60,20 +88,23 @@  stripModuleName (ModuleName x) = x -getModuleName :: String -> String -- filecontents -> modulename-getModuleName = stripModuleName . stripModule2 . fromParseResult . customizedParse+getModuleName :: FilePath -> String -> String -- filename, filecontents -> modulename+getModuleName fileName = stripModuleName . stripModule2 . fromParseResult . customizedParse fileName  usedExtensions = glasgowExts ++ [ExplicitForall]  -- Ultimate debug function getParseOutput fileName = parseFileWithMode (defaultParseMode { extensions = usedExtensions }) fileName --- or: parseFileContentsWithMode-customizedParse = parseModuleWithMode (defaultParseMode { extensions = usedExtensions })+customizedParse fileName = parseFileContentsWithMode+  (defaultParseMode+    { extensions    = usedExtensions+    , parseFilename = fileName+    }) -getFullDeclarationListWithParameterList :: String -> [OriginalFunctionSignature]-getFullDeclarationListWithParameterList fileContents =-    map stripFunBind (stripModule $ fromParseResult $ customizedParse fileContents )+getFullDeclarationListWithParameterList :: FilePath -> String -> [OriginalFunctionSignature]+getFullDeclarationListWithParameterList fileName fileContents =+    map stripFunBind (stripModule $ fromParseResult $ customizedParse fileName fileContents )  functionNameNeeded :: String -> Bool functionNameNeeded functionName = (functionName /= neutralName)@@ -89,26 +120,28 @@ printDeclarationListWithParameterList fileName = do     handle <- openFile fileName ReadMode     fileContents <- hGetContents handle-    putStrLn $ show $ filter (functionNameNeeded . originalFunctionName) (getFullDeclarationListWithParameterList fileContents)+    putStrLn $ show $ filter (functionNameNeeded . originalFunctionName) (getFullDeclarationListWithParameterList fileName fileContents)  printParameterListOfFunction :: FilePath -> String -> IO [Maybe String] printParameterListOfFunction fileName functionName = getParameterList fileName functionName  -- The interface-getDeclarationList :: String -> [String] -- filecontents -> Stringlist-getDeclarationList = stripUnnecessary . (map originalFunctionName) . getFullDeclarationListWithParameterList+getDeclarationList :: FilePath -> String -> [String] -- filename, filecontents -> Stringlist+getDeclarationList fileName = stripUnnecessary . (map originalFunctionName) . getFullDeclarationListWithParameterList fileName -getExtendedDeclarationList :: String -> [OriginalFunctionSignature] -- filecontents -> ExtDeclList-getExtendedDeclarationList fileContents = filter (functionNameNeeded . originalFunctionName)-                                                 (getFullDeclarationListWithParameterList fileContents)+getExtendedDeclarationList :: FilePath -> String -> [OriginalFunctionSignature] -- filename, filecontents -> ExtDeclList+getExtendedDeclarationList fileName fileContents =+  filter (functionNameNeeded . originalFunctionName)+    (getFullDeclarationListWithParameterList fileName fileContents) -getParameterListOld :: String -> String -> [Maybe String]-getParameterListOld fileContents funName = originalParameterNames $ head $-    filter ((==funName) . originalFunctionName) (getExtendedDeclarationList fileContents)+getParameterListOld :: FilePath -> String -> String -> [Maybe String]+getParameterListOld fileName fileContents funName = originalParameterNames $ head $+  filter ((==funName) . originalFunctionName)+    (getExtendedDeclarationList fileName fileContents)  getParameterList :: FilePath -> String -> IO [Maybe String] getParameterList fileName funName = do     handle <- openFile fileName ReadMode     fileContents <- hGetContents handle     return $ originalParameterNames $ head $-        filter ((==funName) . originalFunctionName) (getExtendedDeclarationList fileContents)+        filter ((==funName) . originalFunctionName) (getExtendedDeclarationList fileName fileContents)
Feldspar/Transformation.hs view
@@ -1,3 +1,31 @@+--+-- Copyright (c) 2009-2011, 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, FlexibleContexts, Rank2Types #-}  module Feldspar.Transformation
Feldspar/Transformation/Framework.hs view
@@ -1,3 +1,31 @@+--+-- Copyright (c) 2009-2011, 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 OverlappingInstances, UndecidableInstances, StandaloneDeriving #-}  module Feldspar.Transformation.Framework where@@ -34,6 +62,9 @@ instance (Default a, Default b) => Default (a,b) where     def = (def, def) +instance (Default a, Default b, Default c) => Default (a,b,c) where+    def = (def, def, def)+ instance Combine () where     combine _ _ = () @@ -41,11 +72,11 @@     combine s1 s2 = s1 ++ s2  instance Combine Int where-    combine i1 i2 = i1 + i2     +    combine i1 i2 = i1 + i2 -instance (Combine a, Combine b) +instance (Combine a, Combine b)     => Combine (a,b) where-        combine (x,y) (v,w) = (combine x v, combine y w)    +        combine (x,y) (v,w) = (combine x v, combine y w)  instance Default b => Convert a b where     convert _ = def
Setup.hs view
@@ -1,3 +1,31 @@+--+-- Copyright (c) 2009-2011, 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.+--+ import Distribution.Simple  main = defaultMain
feldspar-compiler.cabal view
@@ -1,5 +1,5 @@ name:           feldspar-compiler-version:        0.4.0.2+version:        0.5.0.1 cabal-version:  >= 1.6 build-type:     Simple license:        BSD3@@ -19,12 +19,29 @@                 language both according to ANSI C and also targeted to a real                 DSP HW. category:       Compiler-tested-with:    GHC==6.12.*, GHC==7.0.2+tested-with:    GHC==7.0  library   exposed-modules:     Feldspar.Compiler.Imperative.Representation     Feldspar.Compiler.Imperative.FromCore+    Feldspar.Compiler.Imperative.FromCore.Array+    Feldspar.Compiler.Imperative.FromCore.Binding+    Feldspar.Compiler.Imperative.FromCore.Condition+    Feldspar.Compiler.Imperative.FromCore.ConditionM+    Feldspar.Compiler.Imperative.FromCore.Error+    Feldspar.Compiler.Imperative.FromCore.Interpretation+    Feldspar.Compiler.Imperative.FromCore.Literal+    Feldspar.Compiler.Imperative.FromCore.Loop+    Feldspar.Compiler.Imperative.FromCore.Mutable+    Feldspar.Compiler.Imperative.FromCore.MutableToPure+    Feldspar.Compiler.Imperative.FromCore.Par+    Feldspar.Compiler.Imperative.FromCore.Primitive+    Feldspar.Compiler.Imperative.FromCore.SizeProp+    Feldspar.Compiler.Imperative.FromCore.SourceInfo+    Feldspar.Compiler.Imperative.FromCore.Tuple+    Feldspar.Compiler.Imperative.FromCore.FFI+    Feldspar.Compiler.Imperative.FromCore.Save     Feldspar.Compiler.Imperative.Frontend     Feldspar.Compiler.Imperative.TransformationInstance     Feldspar.Compiler.Imperative.Plugin.ConstantFolding@@ -33,12 +50,12 @@     Feldspar.Compiler.Backend.C.CodeGeneration     Feldspar.Compiler.Backend.C.Plugin.PrettyPrint     Feldspar.Compiler.Backend.C.Plugin.Locator-    Feldspar.Compiler.Backend.C.Plugin.HandlePrimitives     Feldspar.Compiler.Backend.C.Plugin.BlockProgramHandler     Feldspar.Compiler.Backend.C.Plugin.TypeCorrector     Feldspar.Compiler.Backend.C.Plugin.TypeDefinitionGenerator     Feldspar.Compiler.Backend.C.Plugin.VariableRoleAssigner     Feldspar.Compiler.Backend.C.Plugin.AllocationEliminator+    Feldspar.Compiler.Backend.C.Plugin.Rule     Feldspar.Compiler.Backend.C.Library     Feldspar.Compiler.Backend.C.Options     Feldspar.Compiler.Backend.C.Platforms@@ -46,6 +63,7 @@     Feldspar.Compiler.Frontend.CommandLine.API.Constants     Feldspar.Compiler.Frontend.CommandLine.API.Options     Feldspar.Compiler.Frontend.CommandLine.API+    Feldspar.Compiler.Frontend.Interactive.Interface     Feldspar.Compiler.Compiler     Feldspar.Compiler.Error     Feldspar.Compiler@@ -54,7 +72,8 @@     Feldspar.NameExtractor    build-depends:-    feldspar-language == 0.4.*,+    feldspar-language == 0.5.*,+    ansi-terminal,     base >= 4 && < 4.4,     containers,     haskell-src-exts,@@ -63,7 +82,8 @@     hint,     MonadCatchIO-mtl,     mtl,-    process+    process,+    syntactic >= 0.8    extensions:     DeriveDataTypeable@@ -77,12 +97,21 @@     ScopedTypeVariables     StandaloneDeriving     TypeFamilies+    TypeOperators     TypeSynonymInstances     UndecidableInstances+    FunctionalDependencies+    ViewPatterns    include-dirs:     ./Feldspar/C +  c-sources:+--    ./Feldspar/C/feldspar_c99.c+--    ./Feldspar/C/feldspar_array.c++  cc-options: -std=c99 -Wall+   install-includes:     feldspar_array.h     feldspar_array.c@@ -91,13 +120,26 @@     feldspar_tic64x.h     feldspar_tic64x.c -  ghc-options: -fcontext-stack=30+  ghc-options: -fcontext-stack=100 +  cpp-options: -DRELEASE+ executable feldspar   main-is : ./Feldspar/Compiler/Frontend/CommandLine/Main.hs    build-depends:+--    feldspar-language == 0.5.*,+--    syntactic >= 0.8.*,     ansi-terminal+--    base >= 4 && < 4.4,+--    mtl,+--    hint,+--    process,+--    filepath,+--    directory,+--    containers,+--    haskell-src-exts,+--    MonadCatchIO-mtl    extensions:     CPP@@ -112,10 +154,12 @@     ScopedTypeVariables     StandaloneDeriving     TypeFamilies+    TypeOperators     TypeSynonymInstances     UndecidableInstances-+    FunctionalDependencies+    ViewPatterns -  ghc-options: -fcontext-stack=30+  ghc-options: -fcontext-stack=100    cpp-options: -DRELEASE