feldspar-compiler-0.2.1: Feldspar/Compiler/Imperative/CodeGeneration.hs
{-
- Copyright (c) 2009-2010, 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.Imperative.CodeGeneration where
import Feldspar.Compiler.Imperative.Representation
import Feldspar.Compiler.Imperative.Semantics
import Feldspar.Compiler.Error
import qualified Data.List as List (last)
------------------------
-- C code generation --
------------------------
codeGenerationError = handleError "CodeGeneration"
data Place =
Declaration_pl
--value of var, need type, type array-style
--declare variables
| MainParameter_pl
--value of var need type, type pointer-style
--main fun parameters
| ValueNeed_pl
--value of var, not need type -
--in Expressions
| AddressNeed_pl
--access of var, not need type -
--output of fun
| FunctionCallIn_pl
--value of var, not need type - SPEC ARRAY FORMAT
--input of fun
deriving (Eq,Show)
compToC :: ToC a => a -> String
compToC = toC Declaration_pl
class ToC a where
toC :: Place -> a -> String
instance ToC Size where
toC _ S8 = "char"
toC _ S16 = "short"
toC _ S32 = "int"
toC _ S64 = "long long"
instance ToC Signedness where
toC _ ImpSigned = "signed"
toC _ ImpUnsigned = "unsigned"
instance ToC Type where
toC _ BoolType = "int"
toC _ FloatType = "float"
toC p (Numeric s t) = listprint id " " [toC p s, toC p t]
--arraytype handled in variable
instance ToC (Variable PrettyPrintSemanticInfo) where
toC p a@(Variable (VariableData r t n) _) = show_variable r p t n NoRestrict
show_variable :: VariableRole -> Place -> Type -> String -> IsRestrict -> String
show_variable r p t n restr = listprint (id) " " [variableType, show_name r p t n ++ arrLn] --concat [addSpace $ variableType, show_name r p t n, arrLn]
where
(variableType,arrLn) = show_type p t restr
show_type :: Place -> Type -> IsRestrict -> (String,String)
show_type MainParameter_pl (ImpArrayType s t@(ImpArrayType s2 t2)) restr = decl_matr_type s t2 s2 restr
show_type Declaration_pl (ImpArrayType s t) restr = decl_arr_type t s ("","")
show_type MainParameter_pl (ImpArrayType s t) restr = decl_arr_type_0 t s restr
show_type Declaration_pl t _ = (toC p t,"")
show_type MainParameter_pl t _ = (toC p t,"")
show_type _ _ _ = ("","")
decl_arr_type_0 :: Type -> Length -> IsRestrict -> (String,String)
decl_arr_type_0 t s Restrict = ((toC Declaration_pl t) ++ " * const restrict", "")
decl_arr_type_0 t s _ = ((toC Declaration_pl t) ++ " *", "")
decl_matr_type :: Length -> Type -> Length -> IsRestrict -> (String,String)
decl_matr_type mb t2 s2 Restrict = decl_arr_type t2 s2 (" (* const restrict", ")")
decl_matr_type mb t2 s2 _ = decl_arr_type t2 s2 (" (*", ")")
decl_arr_type :: Type -> Length -> (String,String) -> (String,String)
decl_arr_type (ImpArrayType s2 t2) mb (st1,st2) = decl_arr_type t2 s2 (st1,st2 ++ (show_brackets mb))
decl_arr_type t mb (st1,st2) = ((toC Declaration_pl t) ++ st1, st2 ++ show_brackets mb)
show_brackets :: Length -> String
show_brackets Undefined = codeGenerationError InternalError $ "Unattended unknown array size"
show_brackets (Norm i) = concat["[",show i,"]"]
show_brackets (Defined i) = concat["[", show i, defaultArraySizeWarning, "]"]
defaultArraySizeWarning :: String
defaultArraySizeWarning = " /* WARNING: Default size used!! */"
show_name :: VariableRole -> Place-> Type -> String -> String
show_name _ FunctionCallIn_pl t@(ImpArrayType _ _) n = concat["&(",n,genIndex t,")"]
show_name _ AddressNeed_pl t@(ImpArrayType _ _) n = concat["&(",n,genIndex t,")"]
show_name _ _ (ImpArrayType _ _) n = n
show_name Value place t n
| place == AddressNeed_pl = "&" ++ n
| otherwise = n
show_name FunOut place t n
| place == AddressNeed_pl = n
| place == Declaration_pl = codeGenerationError InternalError $ "You can't declare output variable of the function"
| place == MainParameter_pl = "* " ++ n
| List.last n == ']' = n
| otherwise = "(* " ++ n ++ ")"
genIndex :: Type -> String
genIndex (ImpArrayType _ t) = "[0]" ++ genIndex t
genIndex _ = ""
instance ToC (Constant PrettyPrintSemanticInfo) where
toC _ (IntConstant i) = show (intConstantValue i)
toC _ (FloatConstant i) = show (floatConstantValue i) ++ "f"
toC _ (BoolConstant (BoolConstantType True _)) = "1"
toC _ (BoolConstant (BoolConstantType False _)) = "0"
toC p a@(ArrayConstant l) = "{" ++ (toCArray p a) ++ "}"
toCArray :: Place -> Constant PrettyPrintSemanticInfo -> String
toCArray p (ArrayConstant l) = listprint (toCArray p) "," (arrayConstantValue l)
toCArray p i = toC p i
instance ToC (LeftValue PrettyPrintSemanticInfo) where
toC p (VariableLeftValue (VariableInLeftValue v _)) = toC p v
toC p (ArrayElemReferenceLeftValue leftArrayElemReference) = toC p $ insertIndex (arrayName $ arrayElemReferenceData leftArrayElemReference) where
insertIndex :: LeftValue PrettyPrintSemanticInfo -> LeftValue PrettyPrintSemanticInfo
insertIndex (VariableLeftValue (VariableInLeftValue variable semInf)) = VariableLeftValue $ VariableInLeftValue
(variable {
variableData = (variableData variable) {
variableType = decrArrayDepth (variableType $ variableData variable),
variableName = (concat[variableName $ variableData variable,"[",
toC ValueNeed_pl (arrayIndex $ arrayElemReferenceData leftArrayElemReference), "]"])
}
}) semInf
insertIndex (ArrayElemReferenceLeftValue leftArrayElemReference) =
ArrayElemReferenceLeftValue $ leftArrayElemReference {
arrayElemReferenceData = ArrayElemReferenceData (insertIndex (arrayName $ arrayElemReferenceData leftArrayElemReference))
(arrayIndex $ arrayElemReferenceData leftArrayElemReference)
}
instance ToC (ActualParameter PrettyPrintSemanticInfo) where
toC p (InputActualParameter (InputActualParameterType e _)) = toC FunctionCallIn_pl e
toC p (OutputActualParameter (OutputActualParameterType l _)) = toC AddressNeed_pl l
instance ToC (Expression PrettyPrintSemanticInfo) where
toC p (LeftValueExpression (LeftValueInExpression lv _)) = toC p lv
toC p (ConstantExpression c) = toC p c
toC p (FunctionCallExpression (FunctionCall (FunctionCallData InfixOp _ f [a,b]) _)) = concat["(",toC p a," ",f," ",toC p b,")"]
toC p (FunctionCallExpression (FunctionCall (FunctionCallData _ t f x) _)) = concat [f,"(",listprint (toC p) ", " x,")"]
instance ToC (Procedure PrettyPrintSemanticInfo) where
toC p (Procedure n il ol pr semInf) = concat ["void ",n,"(",param,")\n{\n",prog,"}\n"]
where
param = listprint (toC MainParameter_pl) ", " (il ++ ol)
prog = ind (toC Declaration_pl) pr
instance ToC (Block PrettyPrintSemanticInfo) where
toC p (Block (BlockData d pr) semInf) = listprint id "\n" [decl,toC p pr]
where
decl = concat $ map (\a->toC Declaration_pl a ++ ";\n") d
instance ToC (FormalParameter PrettyPrintSemanticInfo) where
toC p (FormalParameter v restr) = (helper p v restr)
where
helper :: Place -> Variable PrettyPrintSemanticInfo -> IsRestrict -> String
helper MainParameter_pl (Variable (VariableData r t n) _) restr
= show_variable r MainParameter_pl t n restr
helper _ (Variable (VariableData r t n) _) restr
= show_variable r Declaration_pl t n restr
instance ToC (LocalDeclaration PrettyPrintSemanticInfo) where
toC p (LocalDeclaration (LocalDeclarationData v i) isDefArrSize) = (helper p v i)
where
helper :: Place -> Variable PrettyPrintSemanticInfo -> (Maybe (Expression PrettyPrintSemanticInfo)) -> String
helper MainParameter_pl v i = concat [toC MainParameter_pl v,init i]
helper _ v i = concat [toC Declaration_pl v,init i]
init :: Maybe (Expression PrettyPrintSemanticInfo) -> String
init Nothing = ""
init (Just e) = " = " ++ toC ValueNeed_pl e
instance ToC (Instruction PrettyPrintSemanticInfo) where
toC p (AssignmentInstruction assignment) =
concat [toC ValueNeed_pl (assignmentLhs $ assignmentData assignment)," = ",toC ValueNeed_pl (assignmentRhs $ assignmentData assignment),";\n"]
toC p (ProcedureCallInstruction procedureCall) =
concat [nameOfProcedureToCall $ procedureCallData procedureCall,"(",
listprint (toC p) ", " (actualParametersOfProcedureToCall $ procedureCallData procedureCall),");\n"]
-- TODO ProcedureCall.actualParameters procedureCall -----> External helper functions !!!
instance ToC (Program PrettyPrintSemanticInfo) where
toC p (Program (EmptyProgram (Empty i)) seminf) = ""
toC p (Program (PrimitiveProgram (Primitive i seminf)) psi) = toC p i
toC p (Program (SequenceProgram (Sequence ps _)) psi) = listprint (toC p) "" ps
toC p (Program (BranchProgram (Branch (BranchData con tPrg ePrg) _)) psi)
= concat ["if(",toC ValueNeed_pl con,")\n{\n", ind (toC p) tPrg,"}\nelse\n{\n",ind (toC p) ePrg,"}\n"]
toC p (Program (SequentialLoopProgram (SequentialLoop (SequentialLoopData condVar condCalc loopBody) _)) psi) = concat["{\n",ind id whereBody,"}\n"]
where
whereBody = concat [toC p condCalc,"while(",toC ValueNeed_pl condVar,")\n",
"{\n",ind (toC p) loopBody,ind (toC p) (blockInstructions $ blockData condCalc),"}\n"]
toC p (Program (ParallelLoopProgram (ParallelLoop (ParallelLoopData v num step prg) _)) psi) = concat ["{\n",ind id for_seq,"}\n"]
where
for_seq = concat [toC Declaration_pl v,";\nfor(",for_init,for_test,for_inc,")\n{\n",ind (toC p) prg,"}\n"]
for_init = concat [toC ValueNeed_pl v," = 0; "]
for_test = concat [toC ValueNeed_pl v," < ",toC ValueNeed_pl num,"; "]
for_inc = concat [toC ValueNeed_pl v," += ",show step]
instance ToC a => ToC (Maybe a) where
toC p Nothing = ""
toC p (Just a) = toC p a
instance (ToC a) => ToC [a] where
toC p xs = listprint (toC p) "\n" xs
----------------------
-- Type --
----------------------
class HasType a where
typeof :: a -> Type
instance (SemanticInfo t) => HasType (Variable t) where
typeof (Variable (VariableData r t s) _) = t
instance (SemanticInfo t) => HasType (LeftValue t) where
typeof (VariableLeftValue (VariableInLeftValue v _)) = typeof v
typeof (ArrayElemReferenceLeftValue arrayElemReference) =
decrArrayDepth (typeof (arrayName $ arrayElemReferenceData arrayElemReference))
instance (SemanticInfo t) => HasType (Constant t) where
typeof (IntConstant _) = Numeric ImpSigned S32
typeof (FloatConstant _) = FloatType
typeof (BoolConstant _) = BoolType
typeof arr@(ArrayConstant l) = ImpArrayType (Norm $ length innerConstList) elemtype
where
elemtype = case innerConstList of
[] -> codeGenerationError InternalError $ "Const array with 0 elements: " ++ show arr
_ -> checktype (typeof $ head innerConstList) (map typeof innerConstList)
innerConstList = arrayConstantValue l
checktype :: Type -> [Type] -> Type
checktype t [] = t
checktype t (x:xs)
| t == x = checktype t xs
| otherwise = codeGenerationError InternalError $ "Different element types in constant array: " ++ show arr
instance (SemanticInfo t) => HasType (Expression t) where
typeof (LeftValueExpression lve) = typeof $ leftValueExpressionContents lve
typeof (ConstantExpression c) = typeof c
typeof (FunctionCallExpression functionCallExpression) = typeOfFunctionToCall $ functionCallData functionCallExpression
instance (SemanticInfo t) => HasType (ActualParameter t) where
typeof (InputActualParameter (InputActualParameterType e _)) = typeof e
typeof (OutputActualParameter (OutputActualParameterType l _)) = typeof l
----------------------
-- Helper functions --
----------------------
ind :: (a-> String) -> a -> String
ind f x = unlines $ map (\a -> " " ++ a) $ lines $ f x
listprint :: (a->String) -> String -> [a] -> String
listprint f s xs = listprint' s $ filter (\a -> a /= "")$ map f xs where
listprint' _ [] = ""
listprint' _ [x] = x
listprint' s (x:y:xs) = x ++ s ++ listprint' s (y:xs)
parameterToExpression :: (SemanticInfo t) => ActualParameter t -> Expression t
parameterToExpression (InputActualParameter (InputActualParameterType e _)) = e
parameterToExpression (OutputActualParameter (OutputActualParameterType lv _)) =
LeftValueExpression $ LeftValueInExpression lv undefined -- TODO undefined
decrArrayDepth :: Type -> Type
decrArrayDepth (ImpArrayType _ t) = t
decrArrayDepth _ = codeGenerationError InternalError $ "A variable is indexed, but not array!"
simpleType :: Type -> Bool
simpleType BoolType = True
simpleType (Numeric _ _) = True
simpleType FloatType = True
simpleType (ImpArrayType _ _) = False
toLeftValue :: (SemanticInfo t) => Expression t -> LeftValue t
toLeftValue (LeftValueExpression (LeftValueInExpression lv _)) = lv
toLeftValue e = codeGenerationError InternalError $ show e ++ " is not a left value."
contains :: (SemanticInfo t) => String -> Expression t -> Bool
contains n (LeftValueExpression (LeftValueInExpression lv _)) = contains' n lv where
contains' n (VariableLeftValue
(VariableInLeftValue (Variable (VariableData _ _ n' ) _) _)
) = n == n'
contains' n (ArrayElemReferenceLeftValue arrayElemReference) = contains' n (arrayName $ arrayElemReferenceData arrayElemReference) ||
contains n (arrayIndex $ arrayElemReferenceData arrayElemReference)
contains _ (ConstantExpression _) = False
contains n (FunctionCallExpression functionCallExpression) =
any (contains n) (actualParametersOfFunctionToCall $ functionCallData functionCallExpression)
getVarName :: (SemanticInfo t) => LeftValue t -> String
getVarName (VariableLeftValue (VariableInLeftValue ( Variable (VariableData _ _ n) _ ) _ )) = n
getVarName (ArrayElemReferenceLeftValue arrayElemReference) = getVarName (arrayName $ arrayElemReferenceData arrayElemReference)