diff --git a/Feldspar/C/feldspar_array.c b/Feldspar/C/feldspar_array.c --- a/Feldspar/C/feldspar_array.c +++ b/Feldspar/C/feldspar_array.c @@ -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 - -/* 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 +#include /* 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; } diff --git a/Feldspar/C/feldspar_array.h b/Feldspar/C/feldspar_array.h --- a/Feldspar/C/feldspar_array.h +++ b/Feldspar/C/feldspar_array.h @@ -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 +#include +#include +#include + +// 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 diff --git a/Feldspar/C/feldspar_c99.c b/Feldspar/C/feldspar_c99.c --- a/Feldspar/C/feldspar_c99.c +++ b/Feldspar/C/feldspar_c99.c @@ -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 @@ -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 */ diff --git a/Feldspar/C/feldspar_c99.h b/Feldspar/C/feldspar_c99.h --- a/Feldspar/C/feldspar_c99.h +++ b/Feldspar/C/feldspar_c99.h @@ -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 + +#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 ); diff --git a/Feldspar/C/feldspar_tic64x.c b/Feldspar/C/feldspar_tic64x.c --- a/Feldspar/C/feldspar_tic64x.c +++ b/Feldspar/C/feldspar_tic64x.c @@ -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 diff --git a/Feldspar/C/feldspar_tic64x.h b/Feldspar/C/feldspar_tic64x.h --- a/Feldspar/C/feldspar_tic64x.h +++ b/Feldspar/C/feldspar_tic64x.h @@ -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 diff --git a/Feldspar/Compiler.hs b/Feldspar/Compiler.hs --- a/Feldspar/Compiler.hs +++ b/Feldspar/Compiler.hs @@ -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) diff --git a/Feldspar/Compiler/Backend/C/CodeGeneration.hs b/Feldspar/Compiler/Backend/C/CodeGeneration.hs --- a/Feldspar/Compiler/Backend/C/CodeGeneration.hs +++ b/Feldspar/Compiler/Backend/C/CodeGeneration.hs @@ -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 diff --git a/Feldspar/Compiler/Backend/C/Library.hs b/Feldspar/Compiler/Backend/C/Library.hs --- a/Feldspar/Compiler/Backend/C/Library.hs +++ b/Feldspar/Compiler/Backend/C/Library.hs @@ -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 diff --git a/Feldspar/Compiler/Backend/C/Options.hs b/Feldspar/Compiler/Backend/C/Options.hs --- a/Feldspar/Compiler/Backend/C/Options.hs +++ b/Feldspar/Compiler/Backend/C/Options.hs @@ -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 _ = "<>" - -type TransformPrim - = FeldPrimDesc - -> [Expression ()] - -> Type - -> PrgDesc - -instance Eq TransformPrim where - (==) _ _ = True - -instance Show TransformPrim where - show _ = "<>" - - -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 diff --git a/Feldspar/Compiler/Backend/C/Platforms.hs b/Feldspar/Compiler/Backend/C/Platforms.hs --- a/Feldspar/Compiler/Backend/C/Platforms.hs +++ b/Feldspar/Compiler/Backend/C/Platforms.hs @@ -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\"", "", "", "", ""], + includes = ["\"feldspar_c99.h\"", "\"feldspar_array.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\"", "", "", ""], + 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" diff --git a/Feldspar/Compiler/Backend/C/Plugin/AllocationEliminator.hs b/Feldspar/Compiler/Backend/C/Plugin/AllocationEliminator.hs --- a/Feldspar/Compiler/Backend/C/Plugin/AllocationEliminator.hs +++ b/Feldspar/Compiler/Backend/C/Plugin/AllocationEliminator.hs @@ -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 diff --git a/Feldspar/Compiler/Backend/C/Plugin/BlockProgramHandler.hs b/Feldspar/Compiler/Backend/C/Plugin/BlockProgramHandler.hs --- a/Feldspar/Compiler/Backend/C/Plugin/BlockProgramHandler.hs +++ b/Feldspar/Compiler/Backend/C/Plugin/BlockProgramHandler.hs @@ -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 diff --git a/Feldspar/Compiler/Backend/C/Plugin/HandlePrimitives.hs b/Feldspar/Compiler/Backend/C/Plugin/HandlePrimitives.hs deleted file mode 100644 --- a/Feldspar/Compiler/Backend/C/Plugin/HandlePrimitives.hs +++ /dev/null @@ -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 () - diff --git a/Feldspar/Compiler/Backend/C/Plugin/Locator.hs b/Feldspar/Compiler/Backend/C/Plugin/Locator.hs --- a/Feldspar/Compiler/Backend/C/Plugin/Locator.hs +++ b/Feldspar/Compiler/Backend/C/Plugin/Locator.hs @@ -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 ------------------------------------------------- diff --git a/Feldspar/Compiler/Backend/C/Plugin/PrettyPrint.hs b/Feldspar/Compiler/Backend/C/Plugin/PrettyPrint.hs --- a/Feldspar/Compiler/Backend/C/Plugin/PrettyPrint.hs +++ b/Feldspar/Compiler/Backend/C/Plugin/PrettyPrint.hs @@ -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 \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) diff --git a/Feldspar/Compiler/Backend/C/Plugin/Rule.hs b/Feldspar/Compiler/Backend/C/Plugin/Rule.hs new file mode 100644 --- /dev/null +++ b/Feldspar/Compiler/Backend/C/Plugin/Rule.hs @@ -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 = (++) diff --git a/Feldspar/Compiler/Backend/C/Plugin/TypeCorrector.hs b/Feldspar/Compiler/Backend/C/Plugin/TypeCorrector.hs --- a/Feldspar/Compiler/Backend/C/Plugin/TypeCorrector.hs +++ b/Feldspar/Compiler/Backend/C/Plugin/TypeCorrector.hs @@ -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, []) diff --git a/Feldspar/Compiler/Backend/C/Plugin/TypeDefinitionGenerator.hs b/Feldspar/Compiler/Backend/C/Plugin/TypeDefinitionGenerator.hs --- a/Feldspar/Compiler/Backend/C/Plugin/TypeDefinitionGenerator.hs +++ b/Feldspar/Compiler/Backend/C/Plugin/TypeDefinitionGenerator.hs @@ -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 diff --git a/Feldspar/Compiler/Backend/C/Plugin/VariableRoleAssigner.hs b/Feldspar/Compiler/Backend/C/Plugin/VariableRoleAssigner.hs --- a/Feldspar/Compiler/Backend/C/Plugin/VariableRoleAssigner.hs +++ b/Feldspar/Compiler/Backend/C/Plugin/VariableRoleAssigner.hs @@ -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 + diff --git a/Feldspar/Compiler/Compiler.hs b/Feldspar/Compiler/Compiler.hs --- a/Feldspar/Compiler/Compiler.hs +++ b/Feldspar/Compiler/Compiler.hs @@ -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 diff --git a/Feldspar/Compiler/Error.hs b/Feldspar/Compiler/Error.hs --- a/Feldspar/Compiler/Error.hs +++ b/Feldspar/Compiler/Error.hs @@ -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 diff --git a/Feldspar/Compiler/Frontend/CommandLine/API.hs b/Feldspar/Compiler/Frontend/CommandLine/API.hs --- a/Feldspar/Compiler/Frontend/CommandLine/API.hs +++ b/Feldspar/Compiler/Frontend/CommandLine/API.hs @@ -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 diff --git a/Feldspar/Compiler/Frontend/CommandLine/API/Constants.hs b/Feldspar/Compiler/Frontend/CommandLine/API/Constants.hs --- a/Feldspar/Compiler/Frontend/CommandLine/API/Constants.hs +++ b/Feldspar/Compiler/Frontend/CommandLine/API/Constants.hs @@ -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" + diff --git a/Feldspar/Compiler/Frontend/CommandLine/API/Library.hs b/Feldspar/Compiler/Frontend/CommandLine/API/Library.hs --- a/Feldspar/Compiler/Frontend/CommandLine/API/Library.hs +++ b/Feldspar/Compiler/Frontend/CommandLine/API/Library.hs @@ -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 " ] ===" diff --git a/Feldspar/Compiler/Frontend/CommandLine/API/Options.hs b/Feldspar/Compiler/Frontend/CommandLine/API/Options.hs --- a/Feldspar/Compiler/Frontend/CommandLine/API/Options.hs +++ b/Feldspar/Compiler/Frontend/CommandLine/API/Options.hs @@ -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 } }) "") "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" - } - }) - "") - "Overrides default array size" - , Option "h" ["help"] (NoArg (\_ -> do diff --git a/Feldspar/Compiler/Frontend/CommandLine/Main.hs b/Feldspar/Compiler/Frontend/CommandLine/Main.hs --- a/Feldspar/Compiler/Frontend/CommandLine/Main.hs +++ b/Feldspar/Compiler/Frontend/CommandLine/Main.hs @@ -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()) - -- -- -- -- -- -- 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 () - - diff --git a/Feldspar/Compiler/Frontend/Interactive/Interface.hs b/Feldspar/Compiler/Frontend/Interactive/Interface.hs new file mode 100644 --- /dev/null +++ b/Feldspar/Compiler/Frontend/Interactive/Interface.hs @@ -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 diff --git a/Feldspar/Compiler/Imperative/FromCore.hs b/Feldspar/Compiler/Imperative/FromCore.hs --- a/Feldspar/Compiler/Imperative/FromCore.hs +++ b/Feldspar/Compiler/Imperative/FromCore.hs @@ -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" diff --git a/Feldspar/Compiler/Imperative/FromCore/Array.hs b/Feldspar/Compiler/Imperative/FromCore/Array.hs new file mode 100644 --- /dev/null +++ b/Feldspar/Compiler/Imperative/FromCore/Array.hs @@ -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 + diff --git a/Feldspar/Compiler/Imperative/FromCore/Binding.hs b/Feldspar/Compiler/Imperative/FromCore/Binding.hs new file mode 100644 --- /dev/null +++ b/Feldspar/Compiler/Imperative/FromCore/Binding.hs @@ -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 + diff --git a/Feldspar/Compiler/Imperative/FromCore/Condition.hs b/Feldspar/Compiler/Imperative/FromCore/Condition.hs new file mode 100644 --- /dev/null +++ b/Feldspar/Compiler/Imperative/FromCore/Condition.hs @@ -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)] + diff --git a/Feldspar/Compiler/Imperative/FromCore/ConditionM.hs b/Feldspar/Compiler/Imperative/FromCore/ConditionM.hs new file mode 100644 --- /dev/null +++ b/Feldspar/Compiler/Imperative/FromCore/ConditionM.hs @@ -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)] diff --git a/Feldspar/Compiler/Imperative/FromCore/Error.hs b/Feldspar/Compiler/Imperative/FromCore/Error.hs new file mode 100644 --- /dev/null +++ b/Feldspar/Compiler/Imperative/FromCore/Error.hs @@ -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 + diff --git a/Feldspar/Compiler/Imperative/FromCore/FFI.hs b/Feldspar/Compiler/Imperative/FromCore/FFI.hs new file mode 100644 --- /dev/null +++ b/Feldspar/Compiler/Imperative/FromCore/FFI.hs @@ -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 + diff --git a/Feldspar/Compiler/Imperative/FromCore/Interpretation.hs b/Feldspar/Compiler/Imperative/FromCore/Interpretation.hs new file mode 100644 --- /dev/null +++ b/Feldspar/Compiler/Imperative/FromCore/Interpretation.hs @@ -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 + diff --git a/Feldspar/Compiler/Imperative/FromCore/Literal.hs b/Feldspar/Compiler/Imperative/FromCore/Literal.hs new file mode 100644 --- /dev/null +++ b/Feldspar/Compiler/Imperative/FromCore/Literal.hs @@ -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] + diff --git a/Feldspar/Compiler/Imperative/FromCore/Loop.hs b/Feldspar/Compiler/Imperative/FromCore/Loop.hs new file mode 100644 --- /dev/null +++ b/Feldspar/Compiler/Imperative/FromCore/Loop.hs @@ -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'] + diff --git a/Feldspar/Compiler/Imperative/FromCore/Mutable.hs b/Feldspar/Compiler/Imperative/FromCore/Mutable.hs new file mode 100644 --- /dev/null +++ b/Feldspar/Compiler/Imperative/FromCore/Mutable.hs @@ -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 + diff --git a/Feldspar/Compiler/Imperative/FromCore/MutableToPure.hs b/Feldspar/Compiler/Imperative/FromCore/MutableToPure.hs new file mode 100644 --- /dev/null +++ b/Feldspar/Compiler/Imperative/FromCore/MutableToPure.hs @@ -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. +-} diff --git a/Feldspar/Compiler/Imperative/FromCore/Par.hs b/Feldspar/Compiler/Imperative/FromCore/Par.hs new file mode 100644 --- /dev/null +++ b/Feldspar/Compiler/Imperative/FromCore/Par.hs @@ -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 () + + diff --git a/Feldspar/Compiler/Imperative/FromCore/Primitive.hs b/Feldspar/Compiler/Imperative/FromCore/Primitive.hs new file mode 100644 --- /dev/null +++ b/Feldspar/Compiler/Imperative/FromCore/Primitive.hs @@ -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 + diff --git a/Feldspar/Compiler/Imperative/FromCore/Save.hs b/Feldspar/Compiler/Imperative/FromCore/Save.hs new file mode 100644 --- /dev/null +++ b/Feldspar/Compiler/Imperative/FromCore/Save.hs @@ -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 + diff --git a/Feldspar/Compiler/Imperative/FromCore/SizeProp.hs b/Feldspar/Compiler/Imperative/FromCore/SizeProp.hs new file mode 100644 --- /dev/null +++ b/Feldspar/Compiler/Imperative/FromCore/SizeProp.hs @@ -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 + diff --git a/Feldspar/Compiler/Imperative/FromCore/SourceInfo.hs b/Feldspar/Compiler/Imperative/FromCore/SourceInfo.hs new file mode 100644 --- /dev/null +++ b/Feldspar/Compiler/Imperative/FromCore/SourceInfo.hs @@ -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 + diff --git a/Feldspar/Compiler/Imperative/FromCore/Tuple.hs b/Feldspar/Compiler/Imperative/FromCore/Tuple.hs new file mode 100644 --- /dev/null +++ b/Feldspar/Compiler/Imperative/FromCore/Tuple.hs @@ -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" + diff --git a/Feldspar/Compiler/Imperative/Frontend.hs b/Feldspar/Compiler/Imperative/Frontend.hs --- a/Feldspar/Compiler/Imperative/Frontend.hs +++ b/Feldspar/Compiler/Imperative/Frontend.hs @@ -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 diff --git a/Feldspar/Compiler/Imperative/Plugin/ConstantFolding.hs b/Feldspar/Compiler/Imperative/Plugin/ConstantFolding.hs --- a/Feldspar/Compiler/Imperative/Plugin/ConstantFolding.hs +++ b/Feldspar/Compiler/Imperative/Plugin/ConstantFolding.hs @@ -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 diff --git a/Feldspar/Compiler/Imperative/Plugin/Naming.hs b/Feldspar/Compiler/Imperative/Plugin/Naming.hs --- a/Feldspar/Compiler/Imperative/Plugin/Naming.hs +++ b/Feldspar/Compiler/Imperative/Plugin/Naming.hs @@ -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 diff --git a/Feldspar/Compiler/Imperative/Plugin/Unroll.hs b/Feldspar/Compiler/Imperative/Plugin/Unroll.hs --- a/Feldspar/Compiler/Imperative/Plugin/Unroll.hs +++ b/Feldspar/Compiler/Imperative/Plugin/Unroll.hs @@ -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 = () diff --git a/Feldspar/Compiler/Imperative/Representation.hs b/Feldspar/Compiler/Imperative/Representation.hs --- a/Feldspar/Compiler/Imperative/Representation.hs +++ b/Feldspar/Compiler/Imperative/Representation.hs @@ -1,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 } diff --git a/Feldspar/Compiler/Imperative/TransformationInstance.hs b/Feldspar/Compiler/Imperative/TransformationInstance.hs --- a/Feldspar/Compiler/Imperative/TransformationInstance.hs +++ b/Feldspar/Compiler/Imperative/TransformationInstance.hs @@ -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 diff --git a/Feldspar/NameExtractor.hs b/Feldspar/NameExtractor.hs --- a/Feldspar/NameExtractor.hs +++ b/Feldspar/NameExtractor.hs @@ -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) diff --git a/Feldspar/Transformation.hs b/Feldspar/Transformation.hs --- a/Feldspar/Transformation.hs +++ b/Feldspar/Transformation.hs @@ -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 diff --git a/Feldspar/Transformation/Framework.hs b/Feldspar/Transformation/Framework.hs --- a/Feldspar/Transformation/Framework.hs +++ b/Feldspar/Transformation/Framework.hs @@ -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 diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -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 diff --git a/feldspar-compiler.cabal b/feldspar-compiler.cabal --- a/feldspar-compiler.cabal +++ b/feldspar-compiler.cabal @@ -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