diff --git a/CHANGELOG b/CHANGELOG --- a/CHANGELOG +++ b/CHANGELOG @@ -1,3 +1,7 @@ +2023-09-07 + * Version bump (3.16.1). (#455) + * Clean code. (#453) + 2023-07-07 * Version bump (3.16). (#448) * Introduce testing infrastructure. (#413) diff --git a/copilot-c99.cabal b/copilot-c99.cabal --- a/copilot-c99.cabal +++ b/copilot-c99.cabal @@ -1,6 +1,6 @@ cabal-version : >= 1.10 name : copilot-c99 -version : 3.16 +version : 3.16.1 synopsis : A compiler for Copilot targeting C99. description : This package is a back-end from Copilot to C. @@ -45,15 +45,16 @@ , mtl >= 2.2 && < 2.4 , pretty >= 1.1 && < 1.2 - , copilot-core >= 3.16 && < 3.17 - , language-c99 >= 0.2.0 && < 0.3 - , language-c99-simple >= 0.2.2 && < 0.3 + , copilot-core >= 3.16.1 && < 3.17 + , language-c99 >= 0.2.0 && < 0.3 + , language-c99-simple >= 0.2.2 && < 0.3 exposed-modules : Copilot.Compile.C99 - other-modules : Copilot.Compile.C99.Translate + other-modules : Copilot.Compile.C99.Expr + , Copilot.Compile.C99.Type , Copilot.Compile.C99.Error - , Copilot.Compile.C99.Util + , Copilot.Compile.C99.Name , Copilot.Compile.C99.CodeGen , Copilot.Compile.C99.External , Copilot.Compile.C99.Compile diff --git a/src/Copilot/Compile/C99.hs b/src/Copilot/Compile/C99.hs --- a/src/Copilot/Compile/C99.hs +++ b/src/Copilot/Compile/C99.hs @@ -6,5 +6,6 @@ , mkDefaultCSettings ) where -import Copilot.Compile.C99.Compile -import Copilot.Compile.C99.Settings +-- Internal imports +import Copilot.Compile.C99.Compile ( compile, compileWith ) +import Copilot.Compile.C99.Settings ( CSettings (..), mkDefaultCSettings ) diff --git a/src/Copilot/Compile/C99/CodeGen.hs b/src/Copilot/Compile/C99/CodeGen.hs --- a/src/Copilot/Compile/C99/CodeGen.hs +++ b/src/Copilot/Compile/C99/CodeGen.hs @@ -1,162 +1,212 @@ -{-# LANGUAGE GADTs #-} -{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE GADTs #-} -- | High-level translation of Copilot Core into C99. -module Copilot.Compile.C99.CodeGen where +module Copilot.Compile.C99.CodeGen + ( + -- * Externs + mkExtCpyDecln + , mkExtDecln -import Control.Monad.State (runState) -import Data.List (union, unzip4) -import qualified Data.List.NonEmpty as NonEmpty -import Data.Typeable (Typeable) + -- * Type declarations + , mkStructDecln + , mkStructForwDecln + -- * Ring buffers + , mkBuffDecln + , mkIndexDecln + , mkAccessDecln + + -- * Stream generators + , mkGenFun + , mkGenFunArray + + -- * Monitor processing + , mkStep + ) + where + +-- External imports +import Control.Monad.State ( runState ) +import Data.List ( unzip4 ) +import qualified Data.List.NonEmpty as NonEmpty import qualified Language.C99.Simple as C -import Copilot.Core -import Copilot.Compile.C99.Error (impossible) -import Copilot.Compile.C99.Util -import Copilot.Compile.C99.External -import Copilot.Compile.C99.Settings -import Copilot.Compile.C99.Translate +-- Internal imports: Copilot +import Copilot.Core ( Expr (..), Id, Stream (..), Struct (..), Trigger (..), + Type (..), UExpr (..), Value (..), fieldname, tysize ) --- | Write a declaration for a generator function. -gendecln :: String -> Type a -> C.Decln -gendecln name ty = C.FunDecln Nothing cty name [] +-- Internal imports +import Copilot.Compile.C99.Error ( impossible ) +import Copilot.Compile.C99.Expr ( constArray, transExpr ) +import Copilot.Compile.C99.External ( External (..) ) +import Copilot.Compile.C99.Name ( argNames, argTempNames, generatorName, + guardName, indexName, streamAccessorName, + streamName ) +import Copilot.Compile.C99.Settings ( CSettings, cSettingsStepFunctionName ) +import Copilot.Compile.C99.Type ( transType ) + +-- * Externs + +-- | Make a extern declaration of a variable. +mkExtDecln :: External -> C.Decln +mkExtDecln (External name _ ty) = decln where - cty = C.decay $ transtype ty + decln = C.VarDecln (Just C.Extern) cTy name Nothing + cTy = transType ty +-- | Make a declaration for a copy of an external variable. +mkExtCpyDecln :: External -> C.Decln +mkExtCpyDecln (External _name cpyName ty) = decln + where + decln = C.VarDecln (Just C.Static) cTy cpyName Nothing + cTy = transType ty + +-- * Type declarations + +-- | Write a struct declaration based on its definition. +mkStructDecln :: Struct a => Type a -> C.Decln +mkStructDecln (Struct x) = C.TypeDecln struct + where + struct = C.TypeSpec $ C.StructDecln (Just $ typename x) fields + fields = NonEmpty.fromList $ map mkField (toValues x) + + mkField :: Value a -> C.FieldDecln + mkField (Value ty field) = C.FieldDecln (transType ty) (fieldname field) + +-- | Write a forward struct declaration. +mkStructForwDecln :: Struct a => Type a -> C.Decln +mkStructForwDecln (Struct x) = C.TypeDecln struct + where + struct = C.TypeSpec $ C.Struct (typename x) + +-- * Ring buffers + +-- | Make a C buffer variable and initialise it with the stream buffer. +mkBuffDecln :: Id -> Type a -> [a] -> C.Decln +mkBuffDecln sId ty xs = C.VarDecln (Just C.Static) cTy name initVals + where + name = streamName sId + cTy = C.Array (transType ty) (Just $ C.LitInt $ fromIntegral buffSize) + buffSize = length xs + initVals = Just $ C.InitList $ constArray ty xs + +-- | Make a C index variable and initialise it to 0. +mkIndexDecln :: Id -> C.Decln +mkIndexDecln sId = C.VarDecln (Just C.Static) cTy name initVal + where + name = indexName sId + cTy = C.TypeSpec $ C.TypedefName "size_t" + initVal = Just $ C.InitExpr $ C.LitInt 0 + +-- | Define an accessor functions for the ring buffer associated with a stream. +mkAccessDecln :: Id -> Type a -> [a] -> C.FunDef +mkAccessDecln sId ty xs = C.FunDef cTy name params [] [C.Return (Just expr)] + where + cTy = C.decay $ transType ty + name = streamAccessorName sId + buffLength = C.LitInt $ fromIntegral $ length xs + params = [C.Param (C.TypeSpec $ C.TypedefName "size_t") "x"] + index = (C.Ident (indexName sId) C..+ C.Ident "x") C..% buffLength + expr = C.Index (C.Ident (streamName sId)) index + +-- * Stream generators + -- | Write a generator function for a stream. -genfun :: String -> Expr a -> Type a -> C.FunDef -genfun name expr ty = C.FunDef cty name [] cvars [C.Return $ Just cexpr] +mkGenFun :: String -> Expr a -> Type a -> C.FunDef +mkGenFun name expr ty = C.FunDef cTy name [] cVars [C.Return $ Just cExpr] where - cty = C.decay $ transtype ty - (cexpr, cvars) = runState (transexpr expr) mempty + cTy = C.decay $ transType ty + (cExpr, cVars) = runState (transExpr expr) mempty -- | Write a generator function for a stream that returns an array. -genFunArray :: String -> String -> Expr a -> Type a -> C.FunDef -genFunArray name nameArg expr ty@(Array _) = +mkGenFunArray :: String -> String -> Expr a -> Type a -> C.FunDef +mkGenFunArray name nameArg expr ty@(Array _) = C.FunDef funType name [ outputParam ] varDecls stmts where funType = C.TypeSpec C.Void -- The output value is an array outputParam = C.Param cArrayType nameArg - cArrayType = transtype ty + cArrayType = transType ty -- Output value, and any variable declarations needed - (cexpr, varDecls) = runState (transexpr expr) mempty + (cExpr, varDecls) = runState (transExpr expr) mempty -- Copy expression to output argument - stmts = [ C.Expr $ memcpy (C.Ident nameArg) cexpr size ] + stmts = [ C.Expr $ memcpy (C.Ident nameArg) cExpr size ] size = C.LitInt (fromIntegral $ tysize ty) C..* C.SizeOfType (C.TypeName $ tyElemName ty) -genFunArray name nameArg expr _ = - impossible "genFunArray" "copilot-c99" - --- | Make a extern declaration of a variable. -mkextdecln :: External -> C.Decln -mkextdecln (External name _ ty) = decln - where - decln = C.VarDecln (Just C.Extern) cty name Nothing - cty = transtype ty - --- | Make a declaration for a copy of an external variable. -mkextcpydecln :: External -> C.Decln -mkextcpydecln (External name cpyname ty) = decln - where - cty = transtype ty - decln = C.VarDecln (Just C.Static) cty cpyname Nothing - --- | Make a C buffer variable and initialise it with the stream buffer. -mkbuffdecln :: Id -> Type a -> [a] -> C.Decln -mkbuffdecln sid ty xs = C.VarDecln (Just C.Static) cty name initvals - where - name = streamname sid - cty = C.Array (transtype ty) (Just $ C.LitInt $ fromIntegral buffsize) - buffsize = length xs - initvals = Just $ C.InitList $ constarray ty xs - --- | Make a C index variable and initialise it to 0. -mkindexdecln :: Id -> C.Decln -mkindexdecln sid = C.VarDecln (Just C.Static) cty name initval - where - name = indexname sid - cty = C.TypeSpec $ C.TypedefName "size_t" - initval = Just $ C.InitExpr $ C.LitInt 0 +mkGenFunArray _name _nameArg _expr _ty = + impossible "mkGenFunArray" "copilot-c99" --- | Define an accessor functions for the ring buffer associated with a stream -mkaccessdecln :: Id -> Type a -> [a] -> C.FunDef -mkaccessdecln sid ty xs = C.FunDef cty name params [] [C.Return (Just expr)] - where - cty = C.decay $ transtype ty - name = streamaccessorname sid - bufflength = C.LitInt $ fromIntegral $ length xs - params = [C.Param (C.TypeSpec $ C.TypedefName "size_t") "x"] - index = (C.Ident (indexname sid) C..+ C.Ident "x") C..% bufflength - expr = C.Index (C.Ident (streamname sid)) index +-- * Monitor processing --- | Writes the step function, that updates all streams. -mkstep :: CSettings -> [Stream] -> [Trigger] -> [External] -> C.FunDef -mkstep cSettings streams triggers exts = +-- | Define the step function that updates all streams. +mkStep :: CSettings -> [Stream] -> [Trigger] -> [External] -> C.FunDef +mkStep cSettings streams triggers exts = C.FunDef void (cSettingsStepFunctionName cSettings) [] declns stmts where - void = C.TypeSpec C.Void - stmts = map mkexcopy exts - ++ triggerStmts - ++ tmpassigns - ++ bufferupdates - ++ indexupdates + declns = streamDeclns ++ concat triggerDeclns - (streamDeclns, tmpassigns, bufferupdates, indexupdates) = - unzip4 $ map mkupdateglobals streams + + stmts = map mkExCopy exts + ++ triggerStmts + ++ tmpAssigns + ++ bufferUpdates + ++ indexUpdates + + (streamDeclns, tmpAssigns, bufferUpdates, indexUpdates) = + unzip4 $ map mkUpdateGlobals streams (triggerDeclns, triggerStmts) = - unzip $ map mktriggercheck triggers + unzip $ map mkTriggerCheck triggers -- Write code to update global stream buffers and index. - mkupdateglobals :: Stream -> (C.Decln, C.Stmt, C.Stmt, C.Stmt) - mkupdateglobals (Stream sid buff expr ty) = - (tmpdecln, tmpassign, bufferupdate, indexupdate) + mkUpdateGlobals :: Stream -> (C.Decln, C.Stmt, C.Stmt, C.Stmt) + mkUpdateGlobals (Stream sId buff _expr ty) = + (tmpDecln, tmpAssign, bufferUpdate, indexUpdate) where - tmpdecln = C.VarDecln Nothing cty tmp_var Nothing + tmpDecln = C.VarDecln Nothing cTy tmpVar Nothing - tmpassign = case ty of - Array _ -> C.Expr $ C.Funcall (C.Ident $ generatorname sid) - [ C.Ident tmp_var ] - _ -> C.Expr $ C.Ident tmp_var C..= val + tmpAssign = case ty of + Array _ -> C.Expr $ C.Funcall (C.Ident $ generatorName sId) + [ C.Ident tmpVar ] + _ -> C.Expr $ C.Ident tmpVar C..= val - bufferupdate = case ty of - Array _ -> C.Expr $ memcpy dest (C.Ident tmp_var) size + bufferUpdate = case ty of + Array _ -> C.Expr $ memcpy dest (C.Ident tmpVar) size where - dest = C.Index buff_var index_var - size = C.LitInt (fromIntegral $ tysize ty) - C..* C.SizeOfType (C.TypeName (tyElemName ty)) + dest = C.Index buffVar indexVar + size = C.LitInt + (fromIntegral $ tysize ty) + C..* C.SizeOfType (C.TypeName (tyElemName ty)) _ -> C.Expr $ - C.Index buff_var index_var C..= (C.Ident tmp_var) + C.Index buffVar indexVar C..= C.Ident tmpVar - indexupdate = C.Expr $ index_var C..= (incindex C..% bufflength) + indexUpdate = C.Expr $ indexVar C..= (incIndex C..% buffLength) where - bufflength = C.LitInt $ fromIntegral $ length buff - incindex = index_var C..+ C.LitInt 1 + buffLength = C.LitInt $ fromIntegral $ length buff + incIndex = indexVar C..+ C.LitInt 1 - tmp_var = streamname sid ++ "_tmp" - buff_var = C.Ident $ streamname sid - index_var = C.Ident $ indexname sid - val = C.Funcall (C.Ident $ generatorname sid) [] - cty = transtype ty + tmpVar = streamName sId ++ "_tmp" + buffVar = C.Ident $ streamName sId + indexVar = C.Ident $ indexName sId + val = C.Funcall (C.Ident $ generatorName sId) [] + cTy = transType ty -- Make code that copies an external variable to its local one. - mkexcopy :: External -> C.Stmt - mkexcopy (External name cpyname ty) = C.Expr $ case ty of - Array _ -> memcpy exvar locvar size + mkExCopy :: External -> C.Stmt + mkExCopy (External name cpyName ty) = C.Expr $ case ty of + Array _ -> memcpy exVar locVar size where - exvar = C.Ident cpyname - locvar = C.Ident name + exVar = C.Ident cpyName + locVar = C.Ident name size = C.LitInt (fromIntegral $ tysize ty) C..* C.SizeOfType (C.TypeName (tyElemName ty)) - _ -> C.Ident cpyname C..= C.Ident name + _ -> C.Ident cpyName C..= C.Ident name -- Make if-statement to check the guard, call the handler if necessary. -- This returns two things: @@ -192,15 +242,20 @@ -- 2. Assigning a struct to a temporary variable defensively ensures that -- any modifications that the handler called makes to the struct argument -- will not affect the internals of the monitoring code. - mktriggercheck :: Trigger -> ([C.Decln], C.Stmt) - mktriggercheck (Trigger name guard args) = - (aTmpDeclns, ifStmt) + mkTriggerCheck :: Trigger -> ([C.Decln], C.Stmt) + mkTriggerCheck (Trigger name _guard args) = + (aTmpDeclns, triggerCheckStmt) where - aTmpDeclns = zipWith (\tmpVar arg -> - C.VarDecln Nothing (tempType arg) tmpVar Nothing) - aTempNames - args + aTmpDeclns :: [C.Decln] + aTmpDeclns = zipWith declare args aTempNames where + declare :: UExpr -> C.Ident -> C.Decln + declare arg tmpVar = + C.VarDecln Nothing (tempType arg) tmpVar Nothing + + -- Type of the temporary variable used to store values of the type + -- of a given expression. + tempType :: UExpr -> C.Type tempType (UExpr { uExprType = ty }) = case ty of -- If a temporary variable is being used to store an array, @@ -209,83 +264,50 @@ -- the `arg` function will return a pointer, not an array, and -- C doesn't make it easy to cast directly from an array to a -- pointer. - Array ty' -> C.Ptr $ transtype ty' - _ -> transtype ty - - aTempNames = take (length args) (argTempNames name) - - ifStmt = C.If guard' firetrigger - - guard' = C.Funcall (C.Ident $ guardname name) [] + Array ty' -> C.Ptr $ transType ty' + _ -> transType ty - -- The body of the if-statement. This consists of statements that assign - -- the values of the temporary variables, following by a final statement - -- that passes the temporary variables to the handler function. - firetrigger = map C.Expr argAssigns ++ - [C.Expr $ C.Funcall (C.Ident name) - (zipWith passArg aTempNames args)] + triggerCheckStmt :: C.Stmt + triggerCheckStmt = C.If guard' fireTrigger where - passArg aTempName (UExpr { uExprType = ty }) = - case ty of - -- Special case for Struct to pass reference to temporary - -- struct variable to handler. (See the comments for - -- mktriggercheck for details.) - Struct _ -> C.UnaryOp C.Ref $ C.Ident aTempName - _ -> C.Ident aTempName - - argAssigns = zipWith (\aTempName arg -> - C.AssignOp C.Assign (C.Ident aTempName) arg) - aTempNames - args' - args' = take (length args) (map argcall (argnames name)) - argcall name = C.Funcall (C.Ident name) [] - - --- | Write a struct declaration based on its definition. -mkstructdecln :: Struct a => Type a -> C.Decln -mkstructdecln (Struct x) = C.TypeDecln struct - where - struct = C.TypeSpec $ C.StructDecln (Just $ typename x) fields - fields = NonEmpty.fromList $ map mkfield (toValues x) + guard' = C.Funcall (C.Ident $ guardName name) [] - mkfield :: Value a -> C.FieldDecln - mkfield (Value ty field) = C.FieldDecln (transtype ty) (fieldname field) + -- The body of the if-statement. This consists of statements that + -- assign the values of the temporary variables, following by a + -- final statement that passes the temporary variables to the + -- handler function. + fireTrigger = map C.Expr argAssigns + ++ [C.Expr $ + C.Funcall (C.Ident name) + (zipWith passArg aTempNames args)] + where + -- List of assignments of values of temporary variables. + argAssigns :: [C.Expr] + argAssigns = zipWith assign aTempNames args' --- | Write a forward struct declaration. -mkstructforwdecln :: Struct a => Type a -> C.Decln -mkstructforwdecln (Struct x) = C.TypeDecln struct - where - struct = C.TypeSpec $ C.Struct (typename x) + assign :: C.Ident -> C.Expr -> C.Expr + assign aTempName = C.AssignOp C.Assign (C.Ident aTempName) --- | List all types of an expression, returns items uniquely. -exprtypes :: Typeable a => Expr a -> [UType] -exprtypes e = case e of - Const ty _ -> typetypes ty - Local ty1 ty2 _ e1 e2 -> typetypes ty1 `union` typetypes ty2 - `union` exprtypes e1 `union` exprtypes e2 - Var ty _ -> typetypes ty - Drop ty _ _ -> typetypes ty - ExternVar ty _ _ -> typetypes ty - Op1 _ e1 -> exprtypes e1 - Op2 _ e1 e2 -> exprtypes e1 `union` exprtypes e2 - Op3 _ e1 e2 e3 -> exprtypes e1 `union` exprtypes e2 `union` exprtypes e3 - Label ty _ _ -> typetypes ty + args' = take (length args) (map argCall (argNames name)) + argCall name' = C.Funcall (C.Ident name') [] --- | List all types of a type, returns items uniquely. -typetypes :: Typeable a => Type a -> [UType] -typetypes ty = case ty of - Array ty' -> typetypes ty' `union` [UType ty] - Struct x -> concatMap (\(Value ty' _) -> typetypes ty') (toValues x) `union` [UType ty] - _ -> [UType ty] + -- Build an expression to pass a temporary variable as argument + -- to a trigger handler. + -- + -- We need to pass a reference to the variable in some cases, + -- so we also need the type of the expression, which is enclosed + -- in the second argument, an UExpr. + passArg :: String -> UExpr -> C.Expr + passArg aTempName (UExpr { uExprType = ty }) = + case ty of + -- Special case for Struct to pass reference to temporary + -- struct variable to handler. (See the comments for + -- mktriggercheck for details.) + Struct _ -> C.UnaryOp C.Ref $ C.Ident aTempName + _ -> C.Ident aTempName --- | Collect all expression of a list of streams and triggers and wrap them --- into an UEXpr. -gatherexprs :: [Stream] -> [Trigger] -> [UExpr] -gatherexprs streams triggers = map streamexpr streams - ++ concatMap triggerexpr triggers - where - streamexpr (Stream _ _ expr ty) = UExpr ty expr - triggerexpr (Trigger _ guard args) = UExpr Bool guard : args + aTempNames :: [String] + aTempNames = take (length args) (argTempNames name) -- * Auxiliary functions @@ -301,4 +323,4 @@ tyElemName :: Type a -> C.Type tyElemName ty = case ty of Array ty' -> tyElemName ty' - _ -> transtype ty + _ -> transType ty diff --git a/src/Copilot/Compile/C99/Compile.hs b/src/Copilot/Compile/C99/Compile.hs --- a/src/Copilot/Compile/C99/Compile.hs +++ b/src/Copilot/Compile/C99/Compile.hs @@ -5,24 +5,36 @@ , compileWith ) where -import Text.PrettyPrint (render) -import Data.List (nub) -import Data.Maybe (catMaybes) -import System.Directory (createDirectoryIfMissing) -import System.Exit (exitFailure) -import System.FilePath (()) -import System.IO (hPutStrLn, stderr) - -import Language.C99.Pretty (pretty) +-- External imports +import Data.List ( nub, union ) +import Data.Maybe ( mapMaybe ) +import Data.Typeable ( Typeable ) +import Language.C99.Pretty ( pretty ) import qualified Language.C99.Simple as C +import System.Directory ( createDirectoryIfMissing ) +import System.Exit ( exitFailure ) +import System.FilePath ( () ) +import System.IO ( hPutStrLn, stderr ) +import Text.PrettyPrint ( render ) -import Copilot.Core -import Copilot.Compile.C99.Util -import Copilot.Compile.C99.External -import Copilot.Compile.C99.Settings -import Copilot.Compile.C99.Translate -import Copilot.Compile.C99.CodeGen +-- Internal imports: Copilot +import Copilot.Core ( Expr (..), Spec (..), Stream (..), Struct (..), + Trigger (..), Type (..), UExpr (..), UType (..), + Value (..) ) +-- Internal imports +import Copilot.Compile.C99.CodeGen ( mkAccessDecln, mkBuffDecln, mkExtCpyDecln, + mkExtDecln, mkGenFun, mkGenFunArray, + mkIndexDecln, mkStep, mkStructDecln, + mkStructForwDecln ) +import Copilot.Compile.C99.External ( External, gatherExts ) +import Copilot.Compile.C99.Name ( argNames, generatorName, + generatorOutputArgName, guardName ) +import Copilot.Compile.C99.Settings ( CSettings, cSettingsOutputDirectory, + cSettingsStepFunctionName, + mkDefaultCSettings ) +import Copilot.Compile.C99.Type ( transType ) + -- | Compile a specification to a .h and a .c file. -- -- The first argument is the settings for the C code generated. @@ -37,11 +49,11 @@ exitFailure | otherwise - = do let cfile = render $ pretty $ C.translate $ compilec cSettings spec - hfile = render $ pretty $ C.translate $ compileh cSettings spec + = do let cFile = render $ pretty $ C.translate $ compileC cSettings spec + hFile = render $ pretty $ C.translate $ compileH cSettings spec typeDeclnsFile = safeCRender $ compileTypeDeclns cSettings spec - cmacros = unlines [ "#include " + cMacros = unlines [ "#include " , "#include " , "#include " , "#include " @@ -54,8 +66,8 @@ let dir = cSettingsOutputDirectory cSettings createDirectoryIfMissing True dir - writeFile (dir prefix ++ ".c") $ cmacros ++ cfile - writeFile (dir prefix ++ ".h") hfile + writeFile (dir prefix ++ ".c") $ cMacros ++ cFile + writeFile (dir prefix ++ ".h") hFile writeFile (dir prefix ++ "_types.h") typeDeclnsFile -- | Compile a specification to a .h and a .c file. @@ -72,99 +84,103 @@ -- * Declarations of global buffers and indices. -- * Generator functions for streams, guards and trigger arguments. -- * Declaration of the @step()@ function. -compilec :: CSettings -> Spec -> C.TransUnit -compilec cSettings spec = C.TransUnit declns funs +compileC :: CSettings -> Spec -> C.TransUnit +compileC cSettings spec = C.TransUnit declns funs where + declns = mkExts exts + ++ mkGlobals streams + + funs = mkGenFuns streams triggers + ++ [mkStep cSettings streams triggers exts] + streams = specStreams spec triggers = specTriggers spec - exts = gatherexts streams triggers - - declns = mkexts exts ++ mkglobals streams - funs = genfuns streams triggers ++ [mkstep cSettings streams triggers exts] + exts = gatherExts streams triggers -- Make declarations for copies of external variables. - mkexts :: [External] -> [C.Decln] - mkexts exts = map mkextcpydecln exts + mkExts :: [External] -> [C.Decln] + mkExts = map mkExtCpyDecln -- Make buffer and index declarations for streams. - mkglobals :: [Stream] -> [C.Decln] - mkglobals streams = map buffdecln streams ++ map indexdecln streams + mkGlobals :: [Stream] -> [C.Decln] + mkGlobals streamList = map buffDecln streamList + ++ map indexDecln streamList where - buffdecln (Stream sid buff _ ty) = mkbuffdecln sid ty buff - indexdecln (Stream sid _ _ _ ) = mkindexdecln sid + buffDecln (Stream sId buff _ ty) = mkBuffDecln sId ty buff + indexDecln (Stream sId _ _ _ ) = mkIndexDecln sId -- Make generator functions, including trigger arguments. - genfuns :: [Stream] -> [Trigger] -> [C.FunDef] - genfuns streams triggers = map accessdecln streams - ++ map streamgen streams - ++ concatMap triggergen triggers + mkGenFuns :: [Stream] -> [Trigger] -> [C.FunDef] + mkGenFuns streamList triggerList = map accessDecln streamList + ++ map streamGen streamList + ++ concatMap triggerGen triggerList where - - accessdecln :: Stream -> C.FunDef - accessdecln (Stream sid buff _ ty) = mkaccessdecln sid ty buff + accessDecln :: Stream -> C.FunDef + accessDecln (Stream sId buff _ ty) = mkAccessDecln sId ty buff - streamgen :: Stream -> C.FunDef - streamgen (Stream sid _ expr ty@(Array _)) = - genFunArray (generatorname sid) (generatorOutputArgName sid) expr ty - streamgen (Stream sid _ expr ty) = genfun (generatorname sid) expr ty + streamGen :: Stream -> C.FunDef + streamGen (Stream sId _ expr ty@(Array _)) = + mkGenFunArray (generatorName sId) (generatorOutputArgName sId) expr ty + streamGen (Stream sId _ expr ty) = mkGenFun (generatorName sId) expr ty - triggergen :: Trigger -> [C.FunDef] - triggergen (Trigger name guard args) = guarddef : argdefs + triggerGen :: Trigger -> [C.FunDef] + triggerGen (Trigger name guard args) = guardDef : argDefs where - guarddef = genfun (guardname name) guard Bool - argdefs = map arggen (zip (argnames name) args) + guardDef = mkGenFun (guardName name) guard Bool + argDefs = zipWith argGen (argNames name) args - arggen :: (String, UExpr) -> C.FunDef - arggen (argname, UExpr ty expr) = genfun argname expr ty + argGen :: String -> UExpr -> C.FunDef + argGen argName (UExpr ty expr) = mkGenFun argName expr ty -- | Generate the .h file from a 'Spec'. -compileh :: CSettings -> Spec -> C.TransUnit -compileh cSettings spec = C.TransUnit declns [] +compileH :: CSettings -> Spec -> C.TransUnit +compileH cSettings spec = C.TransUnit declns [] where + declns = mkStructForwDeclns exprs + ++ mkExts exts + ++ extFunDeclns triggers + ++ [stepDecln] + + exprs = gatherExprs streams triggers + exts = gatherExts streams triggers streams = specStreams spec triggers = specTriggers spec - exts = gatherexts streams triggers - exprs = gatherexprs streams triggers - declns = mkstructforwdeclns exprs - ++ mkexts exts - ++ extfundeclns triggers - ++ [stepdecln] - - mkstructforwdeclns :: [UExpr] -> [C.Decln] - mkstructforwdeclns es = catMaybes $ map mkdecln utypes + mkStructForwDeclns :: [UExpr] -> [C.Decln] + mkStructForwDeclns es = mapMaybe mkDecln uTypes where - mkdecln (UType ty) = case ty of - Struct x -> Just $ mkstructforwdecln ty + mkDecln (UType ty) = case ty of + Struct _ -> Just $ mkStructForwDecln ty _ -> Nothing - utypes = nub $ concatMap (\(UExpr _ e) -> exprtypes e) es + uTypes = nub $ concatMap (\(UExpr _ e) -> exprTypes e) es -- Make declarations for external variables. - mkexts :: [External] -> [C.Decln] - mkexts = map mkextdecln + mkExts :: [External] -> [C.Decln] + mkExts = map mkExtDecln - extfundeclns :: [Trigger] -> [C.Decln] - extfundeclns triggers = map extfundecln triggers + extFunDeclns :: [Trigger] -> [C.Decln] + extFunDeclns = map extFunDecln where - extfundecln :: Trigger -> C.Decln - extfundecln (Trigger name _ args) = C.FunDecln Nothing cty name params + extFunDecln :: Trigger -> C.Decln + extFunDecln (Trigger name _ args) = C.FunDecln Nothing cTy name params where - cty = C.TypeSpec C.Void - params = map mkparam $ zip (argnames name) args - mkparam (name, UExpr ty _) = C.Param (mkParamTy ty) name + cTy = C.TypeSpec C.Void + params = zipWith mkParam (argNames name) args + mkParam paramName (UExpr ty _) = C.Param (mkParamTy ty) paramName + -- Special case for Struct, to pass struct arguments by reference. -- Arrays are also passed by reference, but using C's array type -- does that automatically. mkParamTy ty = case ty of - Struct _ -> C.Ptr (transtype ty) - _ -> transtype ty + Struct _ -> C.Ptr (transType ty) + _ -> transType ty -- Declaration for the step function. - stepdecln :: C.Decln - stepdecln = C.FunDecln Nothing (C.TypeSpec C.Void) + stepDecln :: C.Decln + stepDecln = C.FunDecln Nothing (C.TypeSpec C.Void) (cSettingsStepFunctionName cSettings) [] -- | Generate a C translation unit that contains all type declarations needed @@ -174,18 +190,18 @@ where declns = mkTypeDeclns exprs - exprs = gatherexprs streams triggers + exprs = gatherExprs streams triggers streams = specStreams spec triggers = specTriggers spec -- Generate type declarations. mkTypeDeclns :: [UExpr] -> [C.Decln] - mkTypeDeclns es = catMaybes $ map mkTypeDecln uTypes + mkTypeDeclns es = mapMaybe mkTypeDecln uTypes where - uTypes = nub $ concatMap (\(UExpr _ e) -> exprtypes e) es + uTypes = nub $ concatMap (\(UExpr _ e) -> exprTypes e) es mkTypeDecln (UType ty) = case ty of - Struct _ -> Just $ mkstructdecln ty + Struct _ -> Just $ mkStructDecln ty _ -> Nothing -- * Auxiliary definitions @@ -195,3 +211,37 @@ safeCRender :: C.TransUnit -> String safeCRender (C.TransUnit [] []) = "" safeCRender transUnit = render $ pretty $ C.translate transUnit + +-- ** Obtain information from Copilot Core Exprs and Types. + +-- | List all types of an expression, returns items uniquely. +exprTypes :: Typeable a => Expr a -> [UType] +exprTypes e = case e of + Const ty _ -> typeTypes ty + Local ty1 ty2 _ e1 e2 -> typeTypes ty1 `union` typeTypes ty2 + `union` exprTypes e1 `union` exprTypes e2 + Var ty _ -> typeTypes ty + Drop ty _ _ -> typeTypes ty + ExternVar ty _ _ -> typeTypes ty + Op1 _ e1 -> exprTypes e1 + Op2 _ e1 e2 -> exprTypes e1 `union` exprTypes e2 + Op3 _ e1 e2 e3 -> exprTypes e1 `union` exprTypes e2 + `union` exprTypes e3 + Label ty _ _ -> typeTypes ty + +-- | List all types of a type, returns items uniquely. +typeTypes :: Typeable a => Type a -> [UType] +typeTypes ty = case ty of + Array ty' -> typeTypes ty' `union` [UType ty] + Struct x -> concatMap (\(Value ty' _) -> typeTypes ty') (toValues x) + `union` [UType ty] + _ -> [UType ty] + +-- | Collect all expression of a list of streams and triggers and wrap them +-- into an UEXpr. +gatherExprs :: [Stream] -> [Trigger] -> [UExpr] +gatherExprs streams triggers = map streamUExpr streams + ++ concatMap triggerUExpr triggers + where + streamUExpr (Stream _ _ expr ty) = UExpr ty expr + triggerUExpr (Trigger _ guard args) = UExpr Bool guard : args diff --git a/src/Copilot/Compile/C99/Error.hs b/src/Copilot/Compile/C99/Error.hs --- a/src/Copilot/Compile/C99/Error.hs +++ b/src/Copilot/Compile/C99/Error.hs @@ -1,9 +1,9 @@ --------------------------------------------------------------------------------- --- Copyright © 2011 National Institute of Aerospace / Galois, Inc. --------------------------------------------------------------------------------- {-# LANGUAGE Safe #-} --- | Custom functions to report error messages to users. +-- | +-- Copyright: (c) 2011 National Institute of Aerospace / Galois, Inc. +-- +-- Custom functions to report error messages to users. module Copilot.Compile.C99.Error ( impossible ) where diff --git a/src/Copilot/Compile/C99/Expr.hs b/src/Copilot/Compile/C99/Expr.hs new file mode 100644 --- /dev/null +++ b/src/Copilot/Compile/C99/Expr.hs @@ -0,0 +1,377 @@ +{-# LANGUAGE GADTs #-} + +-- | Translate Copilot Core expressions and operators to C99. +module Copilot.Compile.C99.Expr + ( transExpr + , constArray + ) + where + +-- External imports +import Control.Monad.State ( State, modify ) +import qualified Data.List.NonEmpty as NonEmpty +import qualified Language.C99.Simple as C + +-- Internal imports: Copilot +import Copilot.Core ( Expr (..), Field (..), Op1 (..), Op2 (..), Op3 (..), + Type (..), Value (..), accessorname, arrayelems, + toValues ) + +-- Internal imports +import Copilot.Compile.C99.Error ( impossible ) +import Copilot.Compile.C99.Name ( exCpyName, streamAccessorName ) +import Copilot.Compile.C99.Type ( transLocalVarDeclType, transTypeName ) + +-- | Translates a Copilot Core expression into a C99 expression. +transExpr :: Expr a -> State FunEnv C.Expr +transExpr (Const ty x) = return $ constTy ty x + +transExpr (Local ty1 _ name e1 e2) = do + e1' <- transExpr e1 + let cTy1 = transLocalVarDeclType ty1 + initExpr = Just $ C.InitExpr e1' + + -- Add new decl to the tail of the fun env + modify (++ [C.VarDecln Nothing cTy1 name initExpr]) + + transExpr e2 + +transExpr (Var _ n) = return $ C.Ident n + +transExpr (Drop _ amount sId) = do + let accessVar = streamAccessorName sId + index = C.LitInt (fromIntegral amount) + return $ funCall accessVar [index] + +transExpr (ExternVar _ name _) = return $ C.Ident (exCpyName name) + +transExpr (Label _ _ e) = transExpr e -- ignore label + +transExpr (Op1 op e) = do + e' <- transExpr e + return $ transOp1 op e' + +transExpr (Op2 op e1 e2) = do + e1' <- transExpr e1 + e2' <- transExpr e2 + return $ transOp2 op e1' e2' + +transExpr (Op3 op e1 e2 e3) = do + e1' <- transExpr e1 + e2' <- transExpr e2 + e3' <- transExpr e3 + return $ transOp3 op e1' e2' e3' + +-- | Translates a Copilot unary operator and its argument into a C99 +-- expression. +transOp1 :: Op1 a b -> C.Expr -> C.Expr +transOp1 op e = + -- There are three types of ways in which a function in Copilot Core can be + -- translated into C: + -- + -- 1) Direct translation (perfect 1-to-1 mapping) + -- 2) Type-directed translation (1-to-many mapping, choice based on type) + -- 3) Desugaring/complex (expands to complex expression) + case op of + Not -> (C..!) e + Abs ty -> transAbs ty e + Sign ty -> transSign ty e + Recip ty -> constNumTy ty 1 C../ e + Acos ty -> funCall (specializeMathFunName ty "acos") [e] + Asin ty -> funCall (specializeMathFunName ty "asin") [e] + Atan ty -> funCall (specializeMathFunName ty "atan") [e] + Cos ty -> funCall (specializeMathFunName ty "cos") [e] + Sin ty -> funCall (specializeMathFunName ty "sin") [e] + Tan ty -> funCall (specializeMathFunName ty "tan") [e] + Acosh ty -> funCall (specializeMathFunName ty "acosh") [e] + Asinh ty -> funCall (specializeMathFunName ty "asinh") [e] + Atanh ty -> funCall (specializeMathFunName ty "atanh") [e] + Cosh ty -> funCall (specializeMathFunName ty "cosh") [e] + Sinh ty -> funCall (specializeMathFunName ty "sinh") [e] + Tanh ty -> funCall (specializeMathFunName ty "tanh") [e] + Exp ty -> funCall (specializeMathFunName ty "exp") [e] + Log ty -> funCall (specializeMathFunName ty "log") [e] + Sqrt ty -> funCall (specializeMathFunName ty "sqrt") [e] + Ceiling ty -> funCall (specializeMathFunName ty "ceil") [e] + Floor ty -> funCall (specializeMathFunName ty "floor") [e] + BwNot _ -> (C..~) e + Cast _ ty -> C.Cast (transTypeName ty) e + GetField (Struct _) _ f -> C.Dot e (accessorname f) + +-- | Translates a Copilot binary operator and its arguments into a C99 +-- expression. +transOp2 :: Op2 a b c -> C.Expr -> C.Expr -> C.Expr +transOp2 op e1 e2 = case op of + And -> e1 C..&& e2 + Or -> e1 C..|| e2 + Add _ -> e1 C..+ e2 + Sub _ -> e1 C..- e2 + Mul _ -> e1 C..* e2 + Mod _ -> e1 C..% e2 + Div _ -> e1 C../ e2 + Fdiv _ -> e1 C../ e2 + Pow ty -> funCall (specializeMathFunName ty "pow") [e1, e2] + Logb ty -> funCall (specializeMathFunName ty "log") [e2] C../ + funCall (specializeMathFunName ty "log") [e1] + Atan2 ty -> funCall (specializeMathFunName ty "atan2") [e1, e2] + Eq _ -> e1 C..== e2 + Ne _ -> e1 C..!= e2 + Le _ -> e1 C..<= e2 + Ge _ -> e1 C..>= e2 + Lt _ -> e1 C..< e2 + Gt _ -> e1 C..> e2 + BwAnd _ -> e1 C..& e2 + BwOr _ -> e1 C..| e2 + BwXor _ -> e1 C..^ e2 + BwShiftL _ _ -> e1 C..<< e2 + BwShiftR _ _ -> e1 C..>> e2 + Index _ -> C.Index e1 e2 + +-- | Translates a Copilot ternary operator and its arguments into a C99 +-- expression. +transOp3 :: Op3 a b c d -> C.Expr -> C.Expr -> C.Expr -> C.Expr +transOp3 op e1 e2 e3 = case op of + Mux _ -> C.Cond e1 e2 e3 + +-- | Translate @'Abs' e@ in Copilot Core into a C99 expression. +-- +-- This function produces a portable implementation of abs in C99 that works +-- for the type given, provided that the output fits in a variable of the same +-- type (which may not be true, for example, for signed integers in the lower +-- end of their type range). If the absolute value is out of range, the +-- behavior is undefined. +-- +-- PRE: The type given is a Num type (floating-point number, or a +-- signed/unsigned integer of fixed size). +transAbs :: Type a -> C.Expr -> C.Expr +transAbs ty e + -- Abs for floats/doubles is called fabs in C99's math.h. + | typeIsFloating ty + = funCall (specializeMathFunName ty "fabs") [e] + + -- C99 provides multiple implementations of abs, depending on the type of + -- the arguments. For integers, it provides C99 abs, labs, and llabs, which + -- take, respectively, an int, a long int, and a long long int. + -- + -- However, the code produced by Copilot uses types with fixed width (e.g., + -- int16_t), and there is no guarantee that, for example, 32-bit int or + -- 64-bit int will fit in a C int (only guaranteed to be 16 bits). + -- Consequently, this function provides a portable version of abs for signed + -- and unsigned ints implemented using shift and xor. For example, for a + -- value x of type int32_t, the absolute value is: + -- (x + (x >> sizeof(int32_t)-1)) ^ (x >> sizeof(int32_t)-1)) + | otherwise + = (e C..+ (e C..>> tyBitSizeMinus1)) C..^ (e C..>> tyBitSizeMinus1) + where + -- Size of an integer type in bits, minus one. It's easier to hard-code + -- them than to try and generate the right expressions in C using sizeof. + -- + -- PRE: the type 'ty' is a signed or unsigned integer type. + tyBitSizeMinus1 :: C.Expr + tyBitSizeMinus1 = case ty of + Int8 -> C.LitInt 7 + Int16 -> C.LitInt 15 + Int32 -> C.LitInt 31 + Int64 -> C.LitInt 63 + Word8 -> C.LitInt 7 + Word16 -> C.LitInt 15 + Word32 -> C.LitInt 31 + Word64 -> C.LitInt 63 + _ -> impossible + "transAbs" + "copilot-c99" + "Abs applied to unexpected types." + +-- | Translate @'Sign' e@ in Copilot Core into a C99 expression. +-- +-- Sign is is translated as @e > 0 ? 1 : (e < 0 ? -1 : e)@, that is: +-- +-- 1. If @e@ is positive, return @1@. +-- +-- 2. If @e@ is negative, return @-1@. +-- +-- 3. Otherwise, return @e@. This handles the case where @e@ is @0@ when the +-- type is an integral type. If the type is a floating-point type, it also +-- handles the cases where @e@ is @-0@ or @NaN@. +-- +-- This implementation is modeled after how GHC implements 'signum' +-- . +transSign :: Type a -> C.Expr -> C.Expr +transSign ty e = positiveCase $ negativeCase e + where + -- If @e@ is positive, return @1@, otherwise fall back to argument. + -- + -- Produces the following code, where @@ is the argument to this + -- function: + -- @ + -- e > 0 ? 1 : + -- @ + positiveCase :: C.Expr -- ^ Value returned if @e@ is not positive. + -> C.Expr + positiveCase = + C.Cond (C.BinaryOp C.GT e (constNumTy ty 0)) (constNumTy ty 1) + + -- If @e@ is negative, return @1@, otherwise fall back to argument. + -- + -- Produces the following code, where @@ is the argument to this + -- function: + -- @ + -- e < 0 ? -1 : + -- @ + negativeCase :: C.Expr -- ^ Value returned if @e@ is not negative. + -> C.Expr + negativeCase = + C.Cond (C.BinaryOp C.LT e (constNumTy ty 0)) (constNumTy ty (-1)) + +-- | Transform a Copilot Core literal, based on its value and type, into a C99 +-- literal. +constTy :: Type a -> a -> C.Expr +constTy ty = case ty of + Bool -> C.LitBool + Int8 -> explicitTy ty . C.LitInt . fromIntegral + Int16 -> explicitTy ty . C.LitInt . fromIntegral + Int32 -> explicitTy ty . C.LitInt . fromIntegral + Int64 -> explicitTy ty . C.LitInt . fromIntegral + Word8 -> explicitTy ty . C.LitInt . fromIntegral + Word16 -> explicitTy ty . C.LitInt . fromIntegral + Word32 -> explicitTy ty . C.LitInt . fromIntegral + Word64 -> explicitTy ty . C.LitInt . fromIntegral + Float -> explicitTy ty . C.LitFloat + Double -> explicitTy ty . C.LitDouble + Struct _ -> C.InitVal (transTypeName ty) . constStruct . toValues + Array ty' -> C.InitVal (transTypeName ty) . constArray ty' . arrayelems + +-- | Transform a Copilot Core literal, based on its value and type, into a C99 +-- initializer. +constInit :: Type a -> a -> C.Init +constInit ty val = case ty of + -- We include two special cases for Struct and Array to avoid using constTy + -- on them. + -- + -- In the default case (i.e., InitExpr (constTy ty val)), constant + -- initializations are explicitly cast. However, doing so 1) may result in + -- incorrect values for arrays, and 2) will be considered a non-constant + -- expression in the case of arrays and structs, and thus not allowed as the + -- initialization value for a global variable. + -- + -- In particular, wrt. (1), for example, the nested array: + -- [[0, 1], [2, 3]] :: Array 2 (Array 2 Int32) + -- + -- with explicit casts, will be initialized in C as: + -- { (int32_t[2]){(int32_t)(0), (int32_t)(1)}, + -- (int32_t[2]){(int32_t)(2), (int32_t)(3)} } + -- + -- Due to the additional (int32_t[2]) casts, a C compiler will interpret the + -- whole expression as an array of two int32_t's (as opposed to a nested + -- array). This can either lead to compile-time errors (if you're lucky) or + -- incorrect runtime semantics (if you're unlucky). + Array ty' -> C.InitList $ constArray ty' $ arrayelems val + + -- We use InitArray to initialize a struct because the syntax used for + -- initializing arrays and structs is compatible. For instance, {1, 2} works + -- both for initializing an int array of length 2 as well as a struct with + -- two int fields, although the two expressions are conceptually different + -- (structs can also be initialized as { .a = 1, .b = 2}. + Struct _ -> C.InitList $ constStruct (toValues val) + _ -> C.InitExpr $ constTy ty val + +-- | Transform a Copilot Core struct field into a C99 initializer. +constFieldInit :: Value a -> C.InitItem +constFieldInit (Value ty (Field val)) = C.InitItem Nothing $ constInit ty val + +-- | Transform a Copilot Struct, based on the struct fields, into a list of C99 +-- initializer values. +constStruct :: [Value a] -> NonEmpty.NonEmpty C.InitItem +constStruct val = NonEmpty.fromList $ map constFieldInit val + +-- | Transform a Copilot Array, based on the element values and their type, +-- into a list of C99 initializer values. +constArray :: Type a -> [a] -> NonEmpty.NonEmpty C.InitItem +constArray ty = + NonEmpty.fromList . map (C.InitItem Nothing . constInit ty) + +-- | Explicitly cast a C99 value to a type. +explicitTy :: Type a -> C.Expr -> C.Expr +explicitTy ty = C.Cast (transTypeName ty) + +-- Translate a literal number of type @ty@ into a C99 literal. +-- +-- PRE: The type of PRE is numeric (integer or floating-point), that +-- is, not boolean, struct or array. +constNumTy :: Type a -> Integer -> C.Expr +constNumTy ty = + case ty of + Float -> C.LitFloat . fromInteger + Double -> C.LitDouble . fromInteger + _ -> C.LitInt + +-- | Provide a specialized function name in C99 for a function given the type +-- of its arguments, and its "family" name. +-- +-- C99 provides multiple variants of the same conceptual function, based on the +-- types. Depending on the function, common variants exist for signed/unsigned +-- arguments, long or short types, float or double. The C99 standard uses the +-- same mechanism to name most such functions: the default variant works for +-- double, and there are additional variants for float and long double. For +-- example, the sin function operates on double, while sinf operates on float, +-- and sinl operates on long double. +-- +-- This function only knows how to provide specialized names for functions in +-- math.h that provide a default version for a double argument and vary for +-- floats. It won't change the function name given if the variation is based on +-- the return type, if the function is defined elsewhere, or for other types. +specializeMathFunName :: Type a -> String -> String +specializeMathFunName ty s + -- The following function pattern matches based on the variants available + -- for a specific function. + -- + -- Do not assume that a function you need implemented follows the same + -- standard as others: check whether it is present in the standard. + | isMathFPArgs s + , Float <- ty + = s ++ "f" + + | otherwise + = s + where + -- True if the function family name is part of math.h and follows the + -- standard rule of providing multiple variants for floating point numbers + -- based on the type of their arguments. + -- + -- Note: nan is not in this list because the names of its variants are + -- determined by the return type. + -- + -- For details, see: + -- "B.11 Mathematics " in the C99 standard + isMathFPArgs :: String -> Bool + isMathFPArgs = flip elem + [ "acos", "asin", "atan", "atan2", "cos", "sin" + , "tan", "acosh", "asinh", "atanh", "cosh", "sinh" + , "tanh", "exp", "exp2", "expm1", "frexp", "ilogb" + , "ldexp", "log", "log10", "log1p", "log2", "logb" + , "modf", "scalbn", "scalbln", "cbrt", "fabs", "hypot" + , "pow", "sqrt", "erf", "erfc", "lgamma", "tgamma" + , "ceil", "floor", "nearbyint", "rint", "lrint", "llrint" + , "round", "lround", "llround", "trunc", "fmod", "remainder" + , "remquo", "copysign", "nextafter", "nexttoward", "fdim" + , "fmax", "fmin", "fma" + ] + +-- * Auxiliary functions + +-- | True if the type given is a floating point number. +typeIsFloating :: Type a -> Bool +typeIsFloating Float = True +typeIsFloating Double = True +typeIsFloating _ = False + +-- | Auxiliary type used to collect all the declarations of all the variables +-- used in a function to be generated, since variable declarations are always +-- listed first at the top of the function body. +type FunEnv = [C.Decln] + +-- | Define a C expression that calls a function with arguments. +funCall :: C.Ident -- ^ Function name + -> [C.Expr] -- ^ Arguments + -> C.Expr +funCall name = C.Funcall (C.Ident name) diff --git a/src/Copilot/Compile/C99/External.hs b/src/Copilot/Compile/C99/External.hs --- a/src/Copilot/Compile/C99/External.hs +++ b/src/Copilot/Compile/C99/External.hs @@ -2,53 +2,61 @@ -- | Represent information about externs needed in the generation of C99 code -- for stream declarations and triggers. -module Copilot.Compile.C99.External where +module Copilot.Compile.C99.External + ( External(..) + , gatherExts + ) + where +-- External imports import Data.List (unionBy) -import Copilot.Core -import Copilot.Compile.C99.Util +-- Internal imports: Copilot +import Copilot.Core ( Expr (..), Stream (..), Trigger (..), Type, UExpr (..) ) +-- Internal imports +import Copilot.Compile.C99.Name ( exCpyName ) + -- | Representation of external variables. data External = forall a. External - { extname :: String - , extcpyname :: String - , exttype :: Type a + { extName :: String + , extCpyName :: String + , extType :: Type a } --- | Union over lists of External, we solely base the equality on the --- extname's. -extunion :: [External] -> [External] -> [External] -extunion = unionBy (\a b -> extname a == extname b) - -- | Collect all external variables from the streams and triggers. -- -- Although Copilot specifications can contain also properties and theorems, -- the C99 backend currently only generates code for streams and triggers. -gatherexts :: [Stream] -> [Trigger] -> [External] -gatherexts streams triggers = streamsexts `extunion` triggersexts +gatherExts :: [Stream] -> [Trigger] -> [External] +gatherExts streams triggers = streamsExts `extUnion` triggersExts where - streamsexts = foldr extunion mempty $ map streamexts streams - triggersexts = foldr extunion mempty $ map triggerexts triggers + streamsExts = foldr (extUnion . streamExts) mempty streams + triggersExts = foldr (extUnion . triggerExts) mempty triggers - streamexts :: Stream -> [External] - streamexts (Stream _ _ expr _) = exprexts expr + streamExts :: Stream -> [External] + streamExts (Stream _ _ expr _) = exprExts expr - triggerexts :: Trigger -> [External] - triggerexts (Trigger _ guard args) = guardexts `extunion` argexts + triggerExts :: Trigger -> [External] + triggerExts (Trigger _ guard args) = guardExts `extUnion` argExts where - guardexts = exprexts guard - argexts = concat $ map uexprexts args + guardExts = exprExts guard + argExts = concatMap uExprExts args - uexprexts :: UExpr -> [External] - uexprexts (UExpr _ expr) = exprexts expr + uExprExts :: UExpr -> [External] + uExprExts (UExpr _ expr) = exprExts expr - exprexts :: Expr a -> [External] - exprexts expr = let rec = exprexts in case expr of - Local _ _ _ e1 e2 -> rec e1 `extunion` rec e2 - ExternVar ty name _ -> [External name (excpyname name) ty] - Op1 _ e -> rec e - Op2 _ e1 e2 -> rec e1 `extunion` rec e2 - Op3 _ e1 e2 e3 -> rec e1 `extunion` rec e2 `extunion` rec e3 - Label _ _ e -> rec e - _ -> [] + exprExts :: Expr a -> [External] + exprExts (Local _ _ _ e1 e2) = exprExts e1 `extUnion` exprExts e2 + exprExts (ExternVar ty name _) = [External name (exCpyName name) ty] + exprExts (Op1 _ e) = exprExts e + exprExts (Op2 _ e1 e2) = exprExts e1 `extUnion` exprExts e2 + exprExts (Op3 _ e1 e2 e3) = exprExts e1 `extUnion` exprExts e2 + `extUnion` exprExts e3 + exprExts (Label _ _ e) = exprExts e + exprExts _ = [] + + -- | Union over lists of External, we solely base the equality on the + -- extName's. + extUnion :: [External] -> [External] -> [External] + extUnion = unionBy (\a b -> extName a == extName b) diff --git a/src/Copilot/Compile/C99/Name.hs b/src/Copilot/Compile/C99/Name.hs new file mode 100644 --- /dev/null +++ b/src/Copilot/Compile/C99/Name.hs @@ -0,0 +1,61 @@ +-- | Naming of variables and functions in C. +module Copilot.Compile.C99.Name + ( argNames + , argTempNames + , exCpyName + , generatorName + , generatorOutputArgName + , guardName + , indexName + , streamAccessorName + , streamName + ) + where + +-- External imports: Copilot +import Copilot.Core (Id) + +-- | Turn a stream id into a suitable C variable name. +streamName :: Id -> String +streamName sId = "s" ++ show sId + +-- | Turn a stream id into the global varname for indices. +indexName :: Id -> String +indexName sId = streamName sId ++ "_idx" + +-- | Turn a stream id into the name of its accessor function +streamAccessorName :: Id -> String +streamAccessorName sId = streamName sId ++ "_get" + +-- | Add a postfix for copies of external variables the name. +exCpyName :: String -> String +exCpyName name = name ++ "_cpy" + +-- | Turn stream id into name of its generator function. +generatorName :: Id -> String +generatorName sId = streamName sId ++ "_gen" + +-- | Turn stream id into name of its output argument array. +generatorOutputArgName :: Id -> String +generatorOutputArgName sId = streamName sId ++ "_output" + +-- | Turn the name of a trigger into a guard generator. +guardName :: String -> String +guardName name = name ++ "_guard" + +-- | Turn a trigger name into a trigger argument name. +argName :: String -> Int -> String +argName name n = name ++ "_arg" ++ show n + +-- | Turn a handler function name into a name for a temporary variable for a +-- handler argument. +argTempName :: String -> Int -> String +argTempName name n = name ++ "_arg_temp" ++ show n + +-- | Enumerate all argument names based on trigger name. +argNames :: String -> [String] +argNames base = map (argName base) [0..] + +-- | Enumerate all temporary variable names based on handler function name. +argTempNames :: String -> [String] +argTempNames base = map (argTempName base) [0..] diff --git a/src/Copilot/Compile/C99/Settings.hs b/src/Copilot/Compile/C99/Settings.hs --- a/src/Copilot/Compile/C99/Settings.hs +++ b/src/Copilot/Compile/C99/Settings.hs @@ -1,5 +1,9 @@ -- | Settings used by the code generator to customize the code. -module Copilot.Compile.C99.Settings where +module Copilot.Compile.C99.Settings + ( CSettings(..) + , mkDefaultCSettings + ) + where -- | Settings used to customize the code generated. data CSettings = CSettings diff --git a/src/Copilot/Compile/C99/Translate.hs b/src/Copilot/Compile/C99/Translate.hs deleted file mode 100644 --- a/src/Copilot/Compile/C99/Translate.hs +++ /dev/null @@ -1,389 +0,0 @@ -{-# LANGUAGE GADTs #-} - --- | Translate Copilot Core expressions and operators to C99. -module Copilot.Compile.C99.Translate where - -import Control.Monad.State -import qualified Data.List.NonEmpty as NonEmpty - -import Copilot.Core -import Copilot.Compile.C99.Error (impossible) -import Copilot.Compile.C99.Util - -import qualified Language.C99.Simple as C - --- | Translates a Copilot Core expression into a C99 expression. -transexpr :: Expr a -> State FunEnv C.Expr -transexpr (Const ty x) = return $ constty ty x - -transexpr (Local ty1 _ name e1 e2) = do - e1' <- transexpr e1 - let cty1 = transLocalVarDeclType ty1 - init = Just $ C.InitExpr e1' - statetell [C.VarDecln Nothing cty1 name init] - - transexpr e2 - -transexpr (Var _ n) = return $ C.Ident n - -transexpr (Drop _ amount sid) = do - let accessvar = streamaccessorname sid - index = C.LitInt (fromIntegral amount) - return $ funcall accessvar [index] - -transexpr (ExternVar _ name _) = return $ C.Ident (excpyname name) - -transexpr (Label _ _ e) = transexpr e -- ignore label - -transexpr (Op1 op e) = do - e' <- transexpr e - return $ transop1 op e' - -transexpr (Op2 op e1 e2) = do - e1' <- transexpr e1 - e2' <- transexpr e2 - return $ transop2 op e1' e2' - -transexpr (Op3 op e1 e2 e3) = do - e1' <- transexpr e1 - e2' <- transexpr e2 - e3' <- transexpr e3 - return $ transop3 op e1' e2' e3' - --- | Translates a Copilot unary operator and its argument into a C99 --- expression. -transop1 :: Op1 a b -> C.Expr -> C.Expr -transop1 op e = - -- There are three types of ways in which a function in Copilot Core can be - -- translated into C: - -- - -- 1) Direct translation (perfect 1-to-1 mapping) - -- 2) Type-directed translation (1-to-many mapping, choice based on type) - -- 3) Desugaring/complex (expands to complex expression) - case op of - Not -> (C..!) e - Abs ty -> transAbs ty e - Sign ty -> transSign ty e - Recip ty -> (constNumTy ty 1) C../ e - Acos ty -> funcall (specializeMathFunName ty "acos") [e] - Asin ty -> funcall (specializeMathFunName ty "asin") [e] - Atan ty -> funcall (specializeMathFunName ty "atan") [e] - Cos ty -> funcall (specializeMathFunName ty "cos") [e] - Sin ty -> funcall (specializeMathFunName ty "sin") [e] - Tan ty -> funcall (specializeMathFunName ty "tan") [e] - Acosh ty -> funcall (specializeMathFunName ty "acosh") [e] - Asinh ty -> funcall (specializeMathFunName ty "asinh") [e] - Atanh ty -> funcall (specializeMathFunName ty "atanh") [e] - Cosh ty -> funcall (specializeMathFunName ty "cosh") [e] - Sinh ty -> funcall (specializeMathFunName ty "sinh") [e] - Tanh ty -> funcall (specializeMathFunName ty "tanh") [e] - Exp ty -> funcall (specializeMathFunName ty "exp") [e] - Log ty -> funcall (specializeMathFunName ty "log") [e] - Sqrt ty -> funcall (specializeMathFunName ty "sqrt") [e] - Ceiling ty -> funcall (specializeMathFunName ty "ceil") [e] - Floor ty -> funcall (specializeMathFunName ty "floor") [e] - BwNot _ -> (C..~) e - Cast _ ty -> C.Cast (transtypename ty) e - GetField (Struct _) _ f -> C.Dot e (accessorname f) - --- | Translates a Copilot binary operator and its arguments into a C99 --- expression. -transop2 :: Op2 a b c -> C.Expr -> C.Expr -> C.Expr -transop2 op e1 e2 = case op of - And -> e1 C..&& e2 - Or -> e1 C..|| e2 - Add _ -> e1 C..+ e2 - Sub _ -> e1 C..- e2 - Mul _ -> e1 C..* e2 - Mod _ -> e1 C..% e2 - Div _ -> e1 C../ e2 - Fdiv _ -> e1 C../ e2 - Pow ty -> funcall (specializeMathFunName ty "pow") [e1, e2] - Logb ty -> funcall (specializeMathFunName ty "log") [e2] C../ - funcall (specializeMathFunName ty "log") [e1] - Atan2 ty -> funcall (specializeMathFunName ty "atan2") [e1, e2] - Eq _ -> e1 C..== e2 - Ne _ -> e1 C..!= e2 - Le _ -> e1 C..<= e2 - Ge _ -> e1 C..>= e2 - Lt _ -> e1 C..< e2 - Gt _ -> e1 C..> e2 - BwAnd _ -> e1 C..& e2 - BwOr _ -> e1 C..| e2 - BwXor _ -> e1 C..^ e2 - BwShiftL _ _ -> e1 C..<< e2 - BwShiftR _ _ -> e1 C..>> e2 - Index _ -> C.Index e1 e2 - --- | Translates a Copilot ternary operator and its arguments into a C99 --- expression. -transop3 :: Op3 a b c d -> C.Expr -> C.Expr -> C.Expr -> C.Expr -transop3 op e1 e2 e3 = case op of - Mux _ -> C.Cond e1 e2 e3 - --- | Translate @'Abs' e@ in Copilot Core into a C99 expression. --- --- This function produces a portable implementation of abs in C99 that works --- for the type given, provided that the output fits in a variable of the same --- type (which may not be true, for example, for signed integers in the lower --- end of their type range). If the absolute value is out of range, the --- behavior is undefined. --- --- PRE: The type given is a Num type (floating-point number, or a --- signed/unsigned integer of fixed size). -transAbs :: Type a -> C.Expr -> C.Expr -transAbs ty e - -- Abs for floats/doubles is called fabs in C99's math.h. - | typeIsFloating ty - = funcall (specializeMathFunName ty "fabs") [e] - - -- C99 provides multiple implementations of abs, depending on the type of - -- the arguments. For integers, it provides C99 abs, labs, and llabs, which - -- take, respectively, an int, a long int, and a long long int. - -- - -- However, the code produced by Copilot uses types with fixed width (e.g., - -- int16_t), and there is no guarantee that, for example, 32-bit int or - -- 64-bit int will fit in a C int (only guaranteed to be 16 bits). - -- Consequently, this function provides a portable version of abs for signed - -- and unsigned ints implemented using shift and xor. For example, for a - -- value x of type int32_t, the absolute value is: - -- (x + (x >> sizeof(int32_t)-1)) ^ (x >> sizeof(int32_t)-1)) - | otherwise - = (e C..+ (e C..>> tyBitSizeMinus1)) C..^ (e C..>> tyBitSizeMinus1) - where - -- Size of an integer type in bits, minus one. It's easier to hard-code - -- them than to try and generate the right expressions in C using sizeof. - -- - -- PRE: the type 'ty' is a signed or unsigned integer type. - tyBitSizeMinus1 :: C.Expr - tyBitSizeMinus1 = case ty of - Int8 -> C.LitInt 7 - Int16 -> C.LitInt 15 - Int32 -> C.LitInt 31 - Int64 -> C.LitInt 63 - Word8 -> C.LitInt 7 - Word16 -> C.LitInt 15 - Word32 -> C.LitInt 31 - Word64 -> C.LitInt 63 - _ -> impossible - "transAbs" - "copilot-c99" - "Abs applied to unexpected types." - --- | Translate @'Sign' e@ in Copilot Core into a C99 expression. --- --- Sign is is translated as @e > 0 ? 1 : (e < 0 ? -1 : e)@, that is: --- --- 1. If @e@ is positive, return @1@. --- --- 2. If @e@ is negative, return @-1@. --- --- 3. Otherwise, return @e@. This handles the case where @e@ is @0@ when the --- type is an integral type. If the type is a floating-point type, it also --- handles the cases where @e@ is @-0@ or @NaN@. --- --- This implementation is modeled after how GHC implements 'signum' --- . -transSign :: Type a -> C.Expr -> C.Expr -transSign ty e = positiveCase $ negativeCase e - where - -- If @e@ is positive, return @1@, otherwise fall back to argument. - -- - -- Produces the following code, where @@ is the argument to this - -- function: - -- @ - -- e > 0 ? 1 : - -- @ - positiveCase :: C.Expr -- ^ Value returned if @e@ is not positive. - -> C.Expr - positiveCase = - C.Cond (C.BinaryOp C.GT e (constNumTy ty 0)) (constNumTy ty 1) - - -- If @e@ is negative, return @1@, otherwise fall back to argument. - -- - -- Produces the following code, where @@ is the argument to this - -- function: - -- @ - -- e < 0 ? -1 : - -- @ - negativeCase :: C.Expr -- ^ Value returned if @e@ is not negative. - -> C.Expr - negativeCase = - C.Cond (C.BinaryOp C.LT e (constNumTy ty 0)) (constNumTy ty (-1)) - --- | Transform a Copilot Core literal, based on its value and type, into a C99 --- literal. -constty :: Type a -> a -> C.Expr -constty ty = case ty of - Bool -> C.LitBool - Int8 -> explicitty ty . C.LitInt . fromIntegral - Int16 -> explicitty ty . C.LitInt . fromIntegral - Int32 -> explicitty ty . C.LitInt . fromIntegral - Int64 -> explicitty ty . C.LitInt . fromIntegral - Word8 -> explicitty ty . C.LitInt . fromIntegral - Word16 -> explicitty ty . C.LitInt . fromIntegral - Word32 -> explicitty ty . C.LitInt . fromIntegral - Word64 -> explicitty ty . C.LitInt . fromIntegral - Float -> explicitty ty . C.LitFloat - Double -> explicitty ty . C.LitDouble - Struct _ -> \v -> - C.InitVal (transtypename ty) (constStruct (toValues v)) - Array ty' -> \v -> - C.InitVal (transtypename ty) (constarray ty' (arrayelems v)) - --- | Transform a Copilot Core literal, based on its value and type, into a C99 --- initializer. -constinit :: Type a -> a -> C.Init -constinit ty val = case ty of - -- We include two special cases for Struct and Array to avoid using constty - -- on them. - -- - -- In the default case (i.e., InitExpr (constty ty val)), constant - -- initializations are explicitly cast. However, doing so 1) may result in - -- incorrect values for arrays, and 2) will be considered a non-constant - -- expression in the case of arrays and structs, and thus not allowed as the - -- initialization value for a global variable. - -- - -- In particular, wrt. (1), for example, the nested array: - -- [[0, 1], [2, 3]] :: Array 2 (Array 2 Int32) - -- - -- with explicit casts, will be initialized in C as: - -- { (int32_t[2]){(int32_t)(0), (int32_t)(1)}, - -- (int32_t[2]){(int32_t)(2), (int32_t)(3)} } - -- - -- Due to the additional (int32_t[2]) casts, a C compiler will interpret the - -- whole expression as an array of two int32_t's (as opposed to a nested - -- array). This can either lead to compile-time errors (if you're lucky) or - -- incorrect runtime semantics (if you're unlucky). - Array ty' -> C.InitList $ constarray ty' $ arrayelems val - - -- We use InitArray to initialize a struct because the syntax used for - -- initializing arrays and structs is compatible. For instance, {1, 2} works - -- both for initializing an int array of length 2 as well as a struct with - -- two int fields, although the two expressions are conceptually different - -- (structs can also be initialized as { .a = 1, .b = 2}. - Struct _ -> C.InitList $ constStruct (toValues val) - _ -> C.InitExpr $ constty ty val - --- | Transform a Copilot Core struct field into a C99 initializer. -constfieldinit :: Value a -> C.InitItem -constfieldinit (Value ty (Field val)) = C.InitItem Nothing $ constinit ty val - --- | Transform a Copilot Struct, based on the struct fields, into a list of C99 --- initializer values. -constStruct :: [Value a] -> NonEmpty.NonEmpty C.InitItem -constStruct val = NonEmpty.fromList $ map constfieldinit val - --- | Transform a Copilot Array, based on the element values and their type, --- into a list of C99 initializer values. -constarray :: Type a -> [a] -> NonEmpty.NonEmpty C.InitItem -constarray ty = - NonEmpty.fromList . map (C.InitItem Nothing . constinit ty) - --- | Explicitly cast a C99 value to a type. -explicitty :: Type a -> C.Expr -> C.Expr -explicitty ty = C.Cast (transtypename ty) - --- | Translate a Copilot type to a C99 type. -transtype :: Type a -> C.Type -transtype ty = case ty of - Bool -> C.TypeSpec $ C.TypedefName "bool" - Int8 -> C.TypeSpec $ C.TypedefName "int8_t" - Int16 -> C.TypeSpec $ C.TypedefName "int16_t" - Int32 -> C.TypeSpec $ C.TypedefName "int32_t" - Int64 -> C.TypeSpec $ C.TypedefName "int64_t" - Word8 -> C.TypeSpec $ C.TypedefName "uint8_t" - Word16 -> C.TypeSpec $ C.TypedefName "uint16_t" - Word32 -> C.TypeSpec $ C.TypedefName "uint32_t" - Word64 -> C.TypeSpec $ C.TypedefName "uint64_t" - Float -> C.TypeSpec C.Float - Double -> C.TypeSpec C.Double - Array ty' -> C.Array (transtype ty') length - where - length = Just $ C.LitInt $ fromIntegral $ tylength ty - Struct s -> C.TypeSpec $ C.Struct (typename s) - --- | Translate a Copilot type to a valid (local) variable declaration C99 type. --- --- If the type denotes an array, translate it to a pointer to whatever the --- array holds. This special case is needed when the type is used for a local --- variable declaration. We treat global variables differently (we generate --- list initializers). -transLocalVarDeclType :: Type a -> C.Type -transLocalVarDeclType (Array ty') = C.Ptr $ transtype ty' -transLocalVarDeclType ty = transtype ty - --- | Translate a Copilot type intro a C typename -transtypename :: Type a -> C.TypeName -transtypename ty = C.TypeName $ transtype ty - --- Translate a literal number of type @ty@ into a C99 literal. --- --- PRE: The type of PRE is numeric (integer or floating-point), that --- is, not boolean, struct or array. -constNumTy :: Type a -> Integer -> C.Expr -constNumTy ty = - case ty of - Float -> C.LitFloat . fromInteger - Double -> C.LitDouble . fromInteger - _ -> C.LitInt - --- | Provide a specialized function name in C99 for a function given the type --- of its arguments, and its "family" name. --- --- C99 provides multiple variants of the same conceptual function, based on the --- types. Depending on the function, common variants exist for signed/unsigned --- arguments, long or short types, float or double. The C99 standard uses the --- same mechanism to name most such functions: the default variant works for --- double, and there are additional variants for float and long double. For --- example, the sin function operates on double, while sinf operates on float, --- and sinl operates on long double. --- --- This function only knows how to provide specialized names for functions in --- math.h that provide a default version for a double argument and vary for --- floats. It won't change the function name given if the variation is based on --- the return type, if the function is defined elsewhere, or for other types. -specializeMathFunName :: Type a -> String -> String -specializeMathFunName ty s - -- The following function pattern matches based on the variants available - -- for a specific function. - -- - -- Do not assume that a function you need implemented follows the same - -- standard as others: check whether it is present in the standard. - | isMathFPArgs s - , Float <- ty - = s ++ "f" - - | otherwise - = s - where - -- True if the function family name is part of math.h and follows the - -- standard rule of providing multiple variants for floating point numbers - -- based on the type of their arguments. - -- - -- Note: nan is not in this list because the names of its variants are - -- determined by the return type. - -- - -- For details, see: - -- "B.11 Mathematics " in the C99 standard - isMathFPArgs :: String -> Bool - isMathFPArgs = flip elem - [ "acos", "asin", "atan", "atan2", "cos", "sin" - , "tan", "acosh", "asinh", "atanh", "cosh", "sinh" - , "tanh", "exp", "exp2", "expm1", "frexp", "ilogb" - , "ldexp", "log", "log10", "log1p", "log2", "logb" - , "modf", "scalbn", "scalbln", "cbrt", "fabs", "hypot" - , "pow", "sqrt", "erf", "erfc", "lgamma", "tgamma" - , "ceil", "floor", "nearbyint", "rint", "lrint", "llrint" - , "round", "lround", "llround", "trunc", "fmod", "remainder" - , "remquo", "copysign", "nextafter", "nexttoward", "fdim" - , "fmax", "fmin", "fma" - ] - --- * Auxiliary functions - --- | True if the type given is a floating point number. -typeIsFloating :: Type a -> Bool -typeIsFloating Float = True -typeIsFloating Double = True -typeIsFloating _ = False diff --git a/src/Copilot/Compile/C99/Type.hs b/src/Copilot/Compile/C99/Type.hs new file mode 100644 --- /dev/null +++ b/src/Copilot/Compile/C99/Type.hs @@ -0,0 +1,48 @@ +{-# LANGUAGE GADTs #-} + +-- | Translate Copilot Core expressions and operators to C99. +module Copilot.Compile.C99.Type + ( transType + , transLocalVarDeclType + , transTypeName + ) + where + +-- External imports +import qualified Language.C99.Simple as C + +-- Internal imports: Copilot +import Copilot.Core ( Type (..), tylength, typename ) + +-- | Translate a Copilot type to a C99 type. +transType :: Type a -> C.Type +transType ty = case ty of + Bool -> C.TypeSpec $ C.TypedefName "bool" + Int8 -> C.TypeSpec $ C.TypedefName "int8_t" + Int16 -> C.TypeSpec $ C.TypedefName "int16_t" + Int32 -> C.TypeSpec $ C.TypedefName "int32_t" + Int64 -> C.TypeSpec $ C.TypedefName "int64_t" + Word8 -> C.TypeSpec $ C.TypedefName "uint8_t" + Word16 -> C.TypeSpec $ C.TypedefName "uint16_t" + Word32 -> C.TypeSpec $ C.TypedefName "uint32_t" + Word64 -> C.TypeSpec $ C.TypedefName "uint64_t" + Float -> C.TypeSpec C.Float + Double -> C.TypeSpec C.Double + Array ty' -> C.Array (transType ty') len + where + len = Just $ C.LitInt $ fromIntegral $ tylength ty + Struct s -> C.TypeSpec $ C.Struct (typename s) + +-- | Translate a Copilot type to a valid (local) variable declaration C99 type. +-- +-- If the type denotes an array, translate it to a pointer to whatever the +-- array holds. This special case is needed when the type is used for a local +-- variable declaration. We treat global variables differently (we generate +-- list initializers). +transLocalVarDeclType :: Type a -> C.Type +transLocalVarDeclType (Array ty') = C.Ptr $ transType ty' +transLocalVarDeclType ty = transType ty + +-- | Translate a Copilot type intro a C typename +transTypeName :: Type a -> C.TypeName +transTypeName ty = C.TypeName $ transType ty diff --git a/src/Copilot/Compile/C99/Util.hs b/src/Copilot/Compile/C99/Util.hs deleted file mode 100644 --- a/src/Copilot/Compile/C99/Util.hs +++ /dev/null @@ -1,77 +0,0 @@ --- | Auxiliary helper functions to generate C99 code. -module Copilot.Compile.C99.Util where - -import Control.Monad.State - -import Copilot.Core (Id) -import qualified Language.C99.Simple.AST as C - --- | Auxiliary type used to collect all the declarations of all the variables --- used in a function to be generated, since variable declarations are always --- listed first at the top of the function body. -type FunEnv = [C.Decln] - --- | `tell` equivalent for `State`. -statetell :: Monoid m => m -> State m () -statetell m = modify ((flip mappend) m) - --- | Generate fresh variable name based on a given one. -fresh :: String -> [String] -> String -fresh name used = head $ dropWhile (flip elem used) (name:freshnames) - where - freshnames = (name ++).show <$> [0..] - --- | Collect all the names from a list of C99 declarations. -names :: [C.Decln] -> [String] -names ds = map match ds - where - match (C.VarDecln _ _ name _) = name - --- | Turn a stream id into a suitable C variable name. -streamname :: Id -> String -streamname sid = "s" ++ show sid - --- | Turn a stream id into the global varname for indices. -indexname :: Id -> String -indexname sid = streamname sid ++ "_idx" - --- | Turn a stream id into the name of its accessor function -streamaccessorname :: Id -> String -streamaccessorname sid = streamname sid ++ "_get" - --- | Add a postfix for copies of external variables the name. -excpyname :: String -> String -excpyname name = name ++ "_cpy" - --- | Turn stream id into name of its generator function. -generatorname :: Id -> String -generatorname sid = streamname sid ++ "_gen" - --- | Turn stream id into name of its output argument array. -generatorOutputArgName :: Id -> String -generatorOutputArgName sid = streamname sid ++ "_output" - --- | Turn the name of a trigger into a guard generator. -guardname :: String -> String -guardname name = name ++ "_guard" - --- | Turn a trigger name into a an trigger argument name. -argname :: String -> Int -> String -argname name n = name ++ "_arg" ++ show n - --- | Turn a handler function name into a name for a temporary variable for a --- handler argument. -argTempName :: String -> Int -> String -argTempName name n = name ++ "_arg_temp" ++ show n - --- | Enumerate all argument names based on trigger name. -argnames :: String -> [String] -argnames base = [aname | n <- [0..], let aname = argname base n] - --- | Enumerate all temporary variable names based on handler function name. -argTempNames :: String -> [String] -argTempNames base = map (argTempName base) [0..] - --- | Define a C expression that calls a function with arguments. -funcall :: C.Ident -> [C.Expr] -> C.Expr -funcall name args = C.Funcall (C.Ident name) args