copilot-c99 3.16 → 3.16.1
raw patch · 13 files changed
+888/−778 lines, 13 filesdep ~copilot-corePVP ok
version bump matches the API change (PVP)
Dependency ranges changed: copilot-core
API changes (from Hackage documentation)
Files
- CHANGELOG +4/−0
- copilot-c99.cabal +7/−6
- src/Copilot/Compile/C99.hs +3/−2
- src/Copilot/Compile/C99/CodeGen.hs +209/−187
- src/Copilot/Compile/C99/Compile.hs +130/−80
- src/Copilot/Compile/C99/Error.hs +4/−4
- src/Copilot/Compile/C99/Expr.hs +377/−0
- src/Copilot/Compile/C99/External.hs +40/−32
- src/Copilot/Compile/C99/Name.hs +61/−0
- src/Copilot/Compile/C99/Settings.hs +5/−1
- src/Copilot/Compile/C99/Translate.hs +0/−389
- src/Copilot/Compile/C99/Type.hs +48/−0
- src/Copilot/Compile/C99/Util.hs +0/−77
CHANGELOG view
@@ -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)
copilot-c99.cabal view
@@ -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
src/Copilot/Compile/C99.hs view
@@ -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 )
src/Copilot/Compile/C99/CodeGen.hs view
@@ -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
src/Copilot/Compile/C99/Compile.hs view
@@ -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 <stdint.h>"+ cMacros = unlines [ "#include <stdint.h>" , "#include <stdbool.h>" , "#include <string.h>" , "#include <stdlib.h>"@@ -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
src/Copilot/Compile/C99/Error.hs view
@@ -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
+ src/Copilot/Compile/C99/Expr.hs view
@@ -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'+-- <https://gitlab.haskell.org/ghc/ghc/-/blob/aed98ddaf72cc38fb570d8415cac5de9d8888818/libraries/base/GHC/Float.hs#L523-L525 here>.+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 @<arg>@ is the argument to this+ -- function:+ -- @+ -- e > 0 ? 1 : <arg>+ -- @+ 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 @<arg>@ is the argument to this+ -- function:+ -- @+ -- e < 0 ? -1 : <arg>+ -- @+ 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 <math.h>" 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)
src/Copilot/Compile/C99/External.hs view
@@ -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)
+ src/Copilot/Compile/C99/Name.hs view
@@ -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..]
src/Copilot/Compile/C99/Settings.hs view
@@ -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
− src/Copilot/Compile/C99/Translate.hs
@@ -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'--- <https://gitlab.haskell.org/ghc/ghc/-/blob/aed98ddaf72cc38fb570d8415cac5de9d8888818/libraries/base/GHC/Float.hs#L523-L525 here>.-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 @<arg>@ is the argument to this- -- function:- -- @- -- e > 0 ? 1 : <arg>- -- @- 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 @<arg>@ is the argument to this- -- function:- -- @- -- e < 0 ? -1 : <arg>- -- @- 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 <math.h>" 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
+ src/Copilot/Compile/C99/Type.hs view
@@ -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
− src/Copilot/Compile/C99/Util.hs
@@ -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