diff --git a/CHANGELOG b/CHANGELOG --- a/CHANGELOG +++ b/CHANGELOG @@ -1,3 +1,118 @@ +2026-07-07 + * Version bump (4.8). (#745) + +2026-05-07 + * Version bump (4.7.1). (#730) + +2026-03-07 + * Version bump (4.7). (#714) + * Raise error when compiling empty arrays or structs. (#695) + +2026-01-07 + * Version bump (4.6.1). (#705) + +2025-11-07 + * Version bump (4.6). (#679) + +2025-09-07 + * Version bump (4.5.1). (#666) + +2025-07-07 + * Version bump (4.5). (#642) + +2025-05-07 + * Version bump (4.4). (#618) + +2025-03-07 + * Version bump (4.3). (#604) + +2025-01-07 + * Version bump (4.2). (#577) + * Remove uses of Copilot.Core.Expr.UExpr.uExprType. (#565) + * Allow using same trigger name in multiple declarations. (#296) + * Bump upper version constraint on filepath. (#570) + +2024-11-07 + * Version bump (4.1). (#561) + * Standardize changelog format. (#550) + +2024-09-07 + * Version bump (4.0). (#532) + * Add support for array updates. (#36) + +2024-07-07 + * Version bump (3.20). (#522) + * Add support for struct field updates. (#520) + +2024-05-07 + * Version bump (3.19.1). (#512) + +2024-03-07 + * Version bump (3.19). (#504) + +2024-01-07 + * Version bump (3.18.1). (#493) + +2024-01-07 + * Version bump (3.18). (#487) + * Change return type of main generated for tests. (#468) + * Print constants in tests using portable suffixes. (#471) + * Pass output arrays as arguments to trigger argument functions. (#431) + * Compliance with MISRA C 2023 / MISRA C 2012. (#472) + +2023-11-07 + * Version bump (3.17). (#466) + * Replace uses of deprecated functions. (#457) + +2023-09-07 + * Version bump (3.16.1). (#455) + * Clean code. (#453) + +2023-07-07 + * Version bump (3.16). (#448) + * Introduce testing infrastructure. (#413) + +2023-05-07 + * Version bump (3.15). (#438) + +2023-03-07 + * Version bump (3.14). (#422) + +2023-01-07 + * Version bump (3.13). (#406) + * Declare local array variables in generated guards as pointers. (#401) + * Use pointer to pass output array as argument to generators. (#386) + +2022-11-07 + * Version bump (3.12). (#389) + * Removed deprecated flag from cabal file. (#380) + * Generate type declarations in separate header file. (#373) + +2022-09-07 + * Version bump (3.11). (#376) + * Update to support language-c99-0.2.0. (#371) + * Fix error handling buffers in generated code for 'step'. (#314) + +2022-07-07 + * Version bump (3.10). (#356) + * Remove unnecessary dependencies from Cabal package. (#323) + * Remove duplicated compiler option. (#328) + * Pass structs by reference, not value, in handlers. (#305) + * Relax version bounds of dependencies. (#335) + * Update repo info in cabal file. (#333) + +2022-05-06 + * Version bump (3.9). (#320) + * Compliance with style guide (partial). (#316) + * Translate math operations taking type into account. (#263) + * Fix issue with delays of streams of structs or arrays. (#276) + * Fix issue in C99 implementation of signum. (#278) + +2022-03-07 + * Version bump (3.8). (#298) + * Hide internal modules deprecated in Copilot 3.5. (#289) + * Mark package as uncurated to avoid modification. (#288) + 2022-01-07 * Version bump (3.7). (#287) * Guard against empty specs. (#274) @@ -34,31 +149,31 @@ * Completed the documentation. (#171) 2020-12-06 - * Version bump (3.2). - * Implemented arrays in test driver (#176). - * Fixed nested array initialisation bug (#173). - * Fixed length of buffer allocation for n-dimensional arrays (#174). - * Fixed printing of long ints in test suite (#177). - * Fixed printing of unsigned ints in test suite (#177). - * Fixed '-Wsequence-point' warnings from GCC (#179). - * Split Property.hs (#180). - * Removed 'Test' from module paths (#181). - * Made compiletest take compiler options as an argument (#182). - * Fixed problem with property and empty string in driver CSV (#183). - * Added comma to output of driver to match the interpreter (#184). - * Implemented basic quickcheck based testing (#185). + * Version bump (3.2). (#65) + * Implemented arrays in test driver. (#176) + * Fixed nested array initialisation bug. (#173) + * Fixed length of buffer allocation for n-dimensional arrays. (#174) + * Fixed printing of long ints in test suite. (#177) + * Fixed printing of unsigned ints in test suite. (#177) + * Fixed '-Wsequence-point' warnings from GCC. (#179) + * Split Property.hs. (#180) + * Removed 'Test' from module paths. (#181) + * Made compiletest take compiler options as an argument. (#182) + * Fixed problem with property and empty string in driver CSV. (#183) + * Added comma to output of driver to match the interpreter. (#184) + * Implemented basic quickcheck based testing. (#185) 2020-03-30 - * Version bump (3.1.2) + * Version bump (3.1.2). (#187) * Fixed bug where stream buffers are updated too soon. (#188) * Updated description of cabal package. (#192) 2019-12-23 - * Version bump (3.1.1). - * Fixed bug with constant structs and arrays.(#200). + * Version bump (3.1.1). (#191) + * Fixed bug with constant structs and arrays. (#200) 2019-11-22 - * Version bump (3.1). - * Remove ExternFun (#207). - * Fix bug in code generation for local expression (#198). - * Implement code generation for labels (trivially) (#199). + * Version bump (3.1). (#46) + * Remove ExternFun. (#207) + * Fix bug in code generation for local expression. (#198) + * Implement code generation for labels (trivially). (#199) 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.7 +version : 4.8 synopsis : A compiler for Copilot targeting C99. description : This package is a back-end from Copilot to C. @@ -27,39 +27,71 @@ , Alwyn Goodloe , Ivan Perez +x-curation: uncurated + source-repository head type: git - location: git://github.com/Copilot-Language/copilot.git - subdir: lib/copilot-c99 + location: https://github.com/Copilot-Language/copilot.git + subdir: copilot-c99 library default-language : Haskell2010 hs-source-dirs : src - -- The following -Wno-deprecations is temprary and related to issue - -- https://github.com/Copilot-Language/copilot/issues/237 - -- It should be removed in a future version, when this library hides - -- internal modules. - ghc-options : -Wall -fwarn-tabs -Wno-deprecations + ghc-options : -Wall build-depends : base >= 4.9 && < 5 - , containers >= 0.4 && < 0.7 , directory >= 1.3 && < 1.4 - , filepath >= 1.4 && < 1.5 - , mtl >= 2.2 && < 2.3 + , filepath >= 1.4 && < 1.6 + , mtl >= 2.2 && < 2.4 , pretty >= 1.1 && < 1.2 - , copilot-core >= 3.7 && < 3.8 - , language-c99 >= 0.1.1 && < 0.2 - , language-c99-util >= 0.1.1 && < 0.2 - , language-c99-simple >= 0.1.1 && < 0.2 + , copilot-core >= 4.8 && < 4.9 + , language-c99 >= 0.2.0 && < 0.3 + , language-c99-simple >= 0.3 && < 0.4 exposed-modules : Copilot.Compile.C99 - , Copilot.Compile.C99.Translate - , Copilot.Compile.C99.Util - , Copilot.Compile.C99.CodeGen - , Copilot.Compile.C99.External - , Copilot.Compile.C99.Compile - , Copilot.Compile.C99.Settings - other-modules : Copilot.Compile.C99.Compile.Internal - , Copilot.Compile.C99.Settings.Internal + other-modules : Copilot.Compile.C99.Expr + , Copilot.Compile.C99.Type + , Copilot.Compile.C99.Error + , Copilot.Compile.C99.Name + , Copilot.Compile.C99.CodeGen + , Copilot.Compile.C99.External + , Copilot.Compile.C99.Compile + , Copilot.Compile.C99.Settings + , Copilot.Compile.C99.Representation + +test-suite unit-tests + type: + exitcode-stdio-1.0 + + main-is: + Main.hs + + other-modules: + Test.Copilot.Compile.C99 + + build-depends: + base + , directory + , HUnit + , QuickCheck + , pretty + , process + , random + , test-framework + , test-framework-hunit + , test-framework-quickcheck2 + , unix + + , copilot-core + , copilot-c99 + + hs-source-dirs: + tests + + default-language: + Haskell2010 + + ghc-options: + -Wall 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.Internal -import Copilot.Compile.C99.Settings.Internal +-- 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,179 +1,347 @@ {-# LANGUAGE GADTs #-} -{-# LANGUAGE ScopedTypeVariables #-} -- | High-level translation of Copilot Core into C99. module Copilot.Compile.C99.CodeGen - {-# DEPRECATED "This module will be hidden in future versions." #-} - where + ( + -- * Externs + mkExtCpyDecln + , mkExtDecln -import Control.Monad.State (runState) -import Data.List (union, unzip4) -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.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, typeSize ) --- | Write a declaration for a generator function. -gendecln :: String -> Type a -> C.Decln -gendecln name ty = C.FunDecln Nothing cty name [] where - cty = C.decay $ transtype ty +-- 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 ) +import Copilot.Compile.C99.Representation ( UniqueTrigger (..) ) --- | 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] where - cty = C.decay $ transtype ty - (cexpr, cvars) = runState (transexpr expr) mempty +-- * Externs -- | 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 +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 +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.InitArray $ map (C.InitExpr . constty ty) xs +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 +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)] +-- | 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 static cTy name params [] [C.Return (Just expr)] where - cty = C.decay $ transtype ty - name = streamaccessorname sid - bufflength = C.LitInt $ fromIntegral $ length xs + static = Just C.Static + cTy = C.decay $ transType ty + name = streamAccessorName sId + + -- We cast the buffer length to a size_t to make sure that there are no + -- implicit conversions. This is a requirement for compliance with MISRA C + -- (Rule 10.4). + buffLength = C.Cast sizeT $ C.LitInt $ fromIntegral $ length xs + sizeT = C.TypeName $ C.TypeSpec $ C.TypedefName "size_t" 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 + index = (C.Ident (indexName sId) C..+ C.Ident "x") C..% buffLength + expr = C.Index (C.Ident (streamName sId)) index --- | Writes 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 +-- * Stream generators - void = C.TypeSpec C.Void - stmts = map mkexcopy exts - ++ map mktriggercheck triggers - ++ tmpassigns - ++ bufferupdates - ++ indexupdates - (declns, tmpassigns, bufferupdates, indexupdates) = - unzip4 $ map mkupdateglobals streams +-- | Write a generator function for a stream. +mkGenFun :: String -> Expr a -> Type a -> C.FunDef +mkGenFun name expr ty = + C.FunDef static cTy name [] cVars stmts + where + static = Just C.Static + cTy = C.decay $ transType ty + (cExpr, state') = runState (transExpr expr) (0, mempty, mempty) + (_, cVars, stmts') = state' + stmts = stmts' ++ [C.Return $ Just cExpr] - -- 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) - where - tmpdecln = C.VarDecln Nothing cty tmp_var Nothing +-- | Write a generator function for a stream that returns an array. +mkGenFunArray :: String -> String -> Expr a -> Type a -> C.FunDef +mkGenFunArray name nameArg expr ty@(Array _) = + C.FunDef static funType name [ outputParam ] varDecls stmts + where + static = Just C.Static + funType = C.TypeSpec C.Void - tmpassign = case ty of - Array _ -> C.Expr $ memcpy (C.Ident tmp_var) val size - where - size = C.LitInt $ fromIntegral $ tysize ty - _ -> C.Expr $ C.Ident tmp_var C..= val + -- The output value is an array + outputParam = C.Param cArrayType nameArg + cArrayType = transType ty - bufferupdate = case ty of - Array _ -> C.Expr $ memcpy dest (C.Ident tmp_var) size + -- Statements to execute as part of the generator. They include statements + -- related to calculating the values of intermediate expressions, and + -- statements related to copying the final value to the destination array. + stmts = stmts' ++ [ copyStmt ] + + -- Output value, variable declarations needed, and other statements that + -- must be executed to calculate intermediate values. + (cExpr, state') = runState (transExpr expr) (0, mempty, mempty) + (_, varDecls, stmts') = state' + + -- Copy expression to output argument. + copyStmt = C.Expr $ memcpy (C.Ident nameArg) cExpr size + size = C.LitInt (fromIntegral $ typeSize ty) + C..* C.SizeOfType (C.TypeName $ tyElemName ty) + +mkGenFunArray _name _nameArg _expr _ty = + impossible "mkGenFunArray" "copilot-c99" + +-- * Monitor processing + +-- | Define the step function that updates all streams. +mkStep :: CSettings -> [Stream] -> [UniqueTrigger] -> [External] -> C.FunDef +mkStep cSettings streams triggers exts = + C.FunDef Nothing void (cSettingsStepFunctionName cSettings) [] declns stmts + where + void = C.TypeSpec C.Void + + declns = streamDeclns + ++ concat triggerDeclns + + stmts = map mkExCopy exts + ++ triggerStmts + ++ tmpAssigns + ++ bufferUpdates + ++ indexUpdates + + (streamDeclns, tmpAssigns, bufferUpdates, indexUpdates) = + unzip4 $ map mkUpdateGlobals streams + (triggerDeclns, triggerStmts) = + unzip $ map mkTriggerCheck triggers + + -- Update the value of a variable with the result of calling a function that + -- generates the next value in a stream expression. If the type of the + -- variable is an array, then we cannot perform a direct C assignment, so + -- we instead pass the variable as an output array to the function. + updateVar :: C.Ident -> C.Ident -> Type a -> C.Expr + updateVar varName genName (Array _) = + C.Funcall (C.Ident genName) [C.Ident varName] + updateVar varName genName _ = + C.AssignOp C.Assign (C.Ident varName) (C.Funcall (C.Ident genName) []) + + -- 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) + where + tmpDecln = C.VarDecln Nothing cTy tmpVar Nothing + + tmpAssign = C.Expr $ updateVar tmpVar (generatorName sId) ty + + bufferUpdate = case ty of + Array _ -> C.Expr $ memcpy dest (C.Ident tmpVar) size + where + dest = C.Index buffVar indexVar + size = C.LitInt + (fromIntegral $ typeSize ty) + C..* C.SizeOfType (C.TypeName (tyElemName ty)) + _ -> C.Expr $ + C.Index buffVar indexVar C..= C.Ident tmpVar + + indexUpdate = C.Expr $ indexVar C..= (incIndex C..% buffLength) where - dest = C.Index buff_var index_var - size = C.LitInt $ fromIntegral $ tysize ty - _ -> C.Expr $ C.Index buff_var index_var C..= (C.Ident tmp_var) + -- We cast the buffer length and the literal one to a size_t to + -- make sure that there are no implicit conversions. This is a + -- requirement for compliance with MISRA C (Rule 10.4). + buffLength = C.Cast sizeT $ C.LitInt $ fromIntegral $ length buff + incIndex = indexVar C..+ C.Cast sizeT (C.LitInt 1) + sizeT = C.TypeName $ C.TypeSpec $ C.TypedefName "size_t" - indexupdate = C.Expr $ index_var C..= (incindex C..% bufflength) - where - bufflength = C.LitInt $ fromIntegral $ length buff - incindex = index_var C..+ C.LitInt 1 + tmpVar = streamName sId ++ "_tmp" + buffVar = C.Ident $ streamName sId + indexVar = C.Ident $ indexName sId + cTy = transType ty - 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 + -- 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 + where + exVar = C.Ident cpyName + locVar = C.Ident name + size = C.LitInt (fromIntegral $ typeSize ty) + C..* C.SizeOfType (C.TypeName (tyElemName 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 where - exvar = C.Ident cpyname - locvar = C.Ident name - size = C.LitInt $ fromIntegral $ tysize ty - _ -> C.Ident cpyname C..= C.Ident name + _ -> C.Ident cpyName C..= C.Ident name - -- Make if-statement to check the guard, call the trigger if necessary. - mktriggercheck :: Trigger -> C.Stmt - mktriggercheck (Trigger name guard args) = C.If guard' firetrigger where - guard' = C.Funcall (C.Ident $ guardname name) [] - firetrigger = [C.Expr $ C.Funcall (C.Ident name) args'] where - args' = take (length args) (map argcall (argnames name)) - argcall name = C.Funcall (C.Ident name) [] + -- Make if-statement to check the guard, call the handler if necessary. + -- This returns two things: + -- + -- * A list of Declns for temporary variables, one for each argument that + -- the handler function accepts. For example, if a handler function takes + -- three arguments, the list of Declns might look something like this: + -- + -- @ + -- int8_t handler_arg_temp0; + -- int16_t handler_arg_temp1; + -- struct s handler_arg_temp2; + -- @ + -- + -- * A Stmt representing the if-statement. Continuing the example above, + -- the if-statement would look something like this: + -- + -- @ + -- if (handler_guard()) { + -- handler_arg_temp0 = handler_arg0(); + -- handler_arg_temp1 = handler_arg1(); + -- handler_arg_temp2 = handler_arg2(); + -- handler(handler_arg_temp0, handler_arg_temp1, &handler_arg_temp2); + -- } + -- @ + -- + -- We create temporary variables because: + -- + -- 1. We want to pass structs by reference intead of by value. To this end, + -- we use C's & operator to obtain a reference to a temporary variable + -- of a struct type and pass that to the handler function. + -- + -- 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 :: UniqueTrigger -> ([C.Decln], C.Stmt) + mkTriggerCheck (UniqueTrigger uniqueName (Trigger name _guard args)) = + (aTmpDeclns, triggerCheckStmt) + where + aTmpDeclns :: [C.Decln] + aTmpDeclns = zipWith declare args aTempNames + where + declare :: UExpr -> C.Ident -> C.Decln + declare (UExpr ty _) tmpVar = + C.VarDecln Nothing (transType ty) tmpVar Nothing - -- Write a call to the memcpy function. - memcpy :: C.Expr -> C.Expr -> C.Expr -> C.Expr - memcpy dest src size = C.Funcall (C.Ident "memcpy") [dest, src, size] + triggerCheckStmt :: C.Stmt + triggerCheckStmt = C.If guard' fireTrigger + where + guard' = C.Funcall (C.Ident $ guardName uniqueName) [] + -- 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. + -- Note that we call 'name' here instead of 'uniqueName', as 'name' + -- is the name of the actual external 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 = zipWith3 assign aTempNames aArgNames args --- | 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 = map mkfield (toValues x) + assign :: C.Ident -> C.Ident -> UExpr -> C.Expr + assign aTempName aArgName (UExpr ty _) = + updateVar aTempName aArgName ty - mkfield :: Value a -> C.FieldDecln - mkfield (Value ty field) = C.FieldDecln (transtype ty) (fieldname field) + aArgNames :: [C.Ident] + aArgNames = take (length args) (argNames uniqueName) --- | 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) + -- 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 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 --- | 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 + aTempNames :: [String] + aTempNames = take (length args) (argTempNames uniqueName) --- | 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] +-- * Auxiliary functions --- | 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 +-- Write a call to the memcpy function. +memcpy :: C.Expr -> C.Expr -> C.Expr -> C.Expr +memcpy dest src size = C.Funcall (C.Ident "memcpy") [dest, src, size] +-- Translate a Copilot type to a C99 type, handling arrays especially. +-- +-- If the given type is an array (including multi-dimensional arrays), the +-- type is that of the elements in the array. Otherwise, it is just the +-- equivalent representation of the given type in C. +tyElemName :: Type a -> C.Type +tyElemName ty = case ty of + Array ty' -> tyElemName 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 @@ -1,11 +1,310 @@ +{-# LANGUAGE GADTs #-} -- | Compile Copilot specifications to C99 code. module Copilot.Compile.C99.Compile - {-# DEPRECATED "This module will be hidden in future versions." #-} ( compile , compileWith - , CSettings(..) - , mkDefaultCSettings ) where -import Copilot.Compile.C99.Compile.Internal -import Copilot.Compile.C99.Settings.Internal +-- External imports +import Data.List ( nub, nubBy, union ) +import Data.Maybe ( mapMaybe ) +import Data.Type.Equality ( testEquality, (:~:)(Refl) ) +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 ) + +-- 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 ) +import Copilot.Compile.C99.Representation ( UniqueTrigger (..), + mkUniqueTriggers ) + +-- | Compile a specification to a .h and a .c file. +-- +-- The first argument is the settings for the C code generated. +-- +-- The second argument is used as prefix for the .h and .c files generated. +compileWith :: CSettings -> String -> Spec -> IO () +compileWith cSettings prefix spec + | null triggers + = do hPutStrLn stderr $ + "Copilot error: attempt at compiling empty specification.\n" + ++ "You must define at least one trigger to generate C monitors." + exitFailure + + | incompatibleTriggers triggers + = do hPutStrLn stderr $ + "Copilot error: attempt at compiling specification with conflicting " + ++ "trigger definitions.\n" + ++ "Multiple triggers have the same name, but different argument " + ++ "types.\n" + exitFailure + + | otherwise + = 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 " + , "#include " + , "#include " + , "#include " + , "#include " + , "" + , "#include \"" ++ prefix ++ "_types.h\"" + , "#include \"" ++ prefix ++ ".h\"" + , "" + ] + + let dir = cSettingsOutputDirectory cSettings + createDirectoryIfMissing True dir + writeFile (dir prefix ++ ".c") $ cMacros ++ cFile + writeFile (dir prefix ++ ".h") hFile + writeFile (dir prefix ++ "_types.h") typeDeclnsFile + where + triggers = specTriggers spec + + -- Check that two triggers do no conflict, that is: if their names are + -- equal, the types of their arguments should be equal as well. + incompatibleTriggers :: [Trigger] -> Bool + incompatibleTriggers = pairwiseAny conflict + where + conflict :: Trigger -> Trigger -> Bool + conflict t1@(Trigger name1 _ _) t2@(Trigger name2 _ _) = + name1 == name2 && not (compareTrigger t1 t2) + + -- True if the function holds for any pair of elements. We assume that + -- the function is commutative. + pairwiseAny :: (a -> a -> Bool) -> [a] -> Bool + pairwiseAny _ [] = False + pairwiseAny _ (_:[]) = False + pairwiseAny f (x:xs) = any (f x) xs || pairwiseAny f xs + +-- | Compile a specification to a .h and a .c file. +-- +-- The first argument is used as prefix for the .h and .c files generated. +compile :: String -> Spec -> IO () +compile = compileWith mkDefaultCSettings + +-- | Generate the .c file from a 'Spec'. +-- +-- The generated C file has the following structure: +-- +-- * Include .h file. +-- * 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 + where + declns = mkExts exts + ++ mkGlobals streams + + funs = mkGenFuns streams uniqueTriggers + ++ [mkStep cSettings streams uniqueTriggers exts] + + streams = specStreams spec + triggers = specTriggers spec + uniqueTriggers = mkUniqueTriggers triggers + exts = gatherExts streams triggers + + -- Make declarations for copies of external variables. + mkExts :: [External] -> [C.Decln] + mkExts = map mkExtCpyDecln + + -- Make buffer and index declarations for 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 + + -- Make generator functions, including trigger arguments. + mkGenFuns :: [Stream] -> [UniqueTrigger] -> [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 + + streamGen :: Stream -> C.FunDef + streamGen (Stream sId _ expr ty) = + exprGen (generatorName sId) (generatorOutputArgName sId) expr ty + + triggerGen :: UniqueTrigger -> [C.FunDef] + triggerGen (UniqueTrigger uniqueName (Trigger _name guard args)) = guardDef : argDefs + where + guardDef = mkGenFun (guardName uniqueName) guard Bool + argDefs = zipWith argGen (argNames uniqueName) args + + argGen :: String -> UExpr -> C.FunDef + argGen argName (UExpr ty expr) = + exprGen argName (argName ++ "_output") expr ty + + -- Create a function that calculates the current value generated by an + -- expression `expr` of type `ty`. The generator treats arrays + -- specially, and the function takes an output array as a parameter. + -- The second identifier `outputArrName` is not used if `expr` is not an + -- array. + exprGen :: C.Ident -> C.Ident -> Expr a -> Type a -> C.FunDef + exprGen funName outputArrName expr ty@(Array _) = + mkGenFunArray funName outputArrName expr ty + exprGen funName _ expr ty = + mkGenFun funName expr ty + +-- | Generate the .h file from a 'Spec'. +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 + + -- Remove duplicates due to multiple guards for the same trigger. + triggers = nubBy compareTrigger (specTriggers spec) + + mkStructForwDeclns :: [UExpr] -> [C.Decln] + mkStructForwDeclns es = mapMaybe mkDecln uTypes + where + mkDecln (UType ty) = case ty of + Struct _ -> Just $ mkStructForwDecln ty + _ -> Nothing + + uTypes = nub $ concatMap (\(UExpr _ e) -> exprTypes e) es + + -- Make declarations for external variables. + mkExts :: [External] -> [C.Decln] + mkExts = map mkExtDecln + + extFunDeclns :: [Trigger] -> [C.Decln] + extFunDeclns = map extFunDecln + where + extFunDecln :: Trigger -> C.Decln + extFunDecln (Trigger name _ args) = C.FunDecln Nothing cTy name params + where + 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 + + -- Declaration for the step function. + stepDecln :: C.Decln + stepDecln = C.FunDecln Nothing (C.TypeSpec C.Void) + (cSettingsStepFunctionName cSettings) [] + +-- | Generate a C translation unit that contains all type declarations needed +-- by the Copilot specification. +compileTypeDeclns :: CSettings -> Spec -> C.TransUnit +compileTypeDeclns _cSettings spec = C.TransUnit declns [] + where + declns = mkTypeDeclns exprs + + exprs = gatherExprs streams triggers + streams = specStreams spec + triggers = specTriggers spec + + -- Generate type declarations. + mkTypeDeclns :: [UExpr] -> [C.Decln] + mkTypeDeclns es = mapMaybe mkTypeDecln uTypes + where + uTypes = nub $ concatMap (\(UExpr _ e) -> exprTypes e) es + + mkTypeDecln (UType ty) = case ty of + Struct _ -> Just $ mkStructDecln ty + _ -> Nothing + +-- * Auxiliary definitions + +-- | Render a C.TransUnit to a String, accounting for the case in which the +-- translation unit is empty. +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 + +-- | We consider triggers to be equal, if their names match and the number and +-- types of arguments. +compareTrigger :: Trigger -> Trigger -> Bool +compareTrigger (Trigger name1 _ args1) (Trigger name2 _ args2) + = name1 == name2 && compareArguments args1 args2 + + where + compareArguments :: [UExpr] -> [UExpr] -> Bool + compareArguments [] [] = True + compareArguments [] _ = False + compareArguments _ [] = False + compareArguments (x:xs) (y:ys) = compareUExpr x y && compareArguments xs ys + + compareUExpr :: UExpr -> UExpr -> Bool + compareUExpr (UExpr ty1 _) (UExpr ty2 _) + | Just Refl <- testEquality ty1 ty2 = True + | otherwise = False diff --git a/src/Copilot/Compile/C99/Compile/Internal.hs b/src/Copilot/Compile/C99/Compile/Internal.hs deleted file mode 100644 --- a/src/Copilot/Compile/C99/Compile/Internal.hs +++ /dev/null @@ -1,159 +0,0 @@ --- | Compile Copilot specifications to C99 code. -module Copilot.Compile.C99.Compile.Internal - ( compile - , 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) -import qualified Language.C99.Simple as C - -import Copilot.Core -import Copilot.Compile.C99.Util -import Copilot.Compile.C99.External -import Copilot.Compile.C99.Settings.Internal -import Copilot.Compile.C99.Translate -import Copilot.Compile.C99.CodeGen - --- | Compile a specification to a .h and a .c file. --- --- The first argument is the settings for the C code generated. --- --- The second argument is used as prefix for the .h and .c files generated. -compileWith :: CSettings -> String -> Spec -> IO () -compileWith cSettings prefix spec - | null (specTriggers spec) - = do hPutStrLn stderr $ - "Copilot error: attempt at compiling empty specification.\n" - ++ "You must define at least one trigger to generate C monitors." - exitFailure - - | otherwise - = do let cfile = render $ pretty $ C.translate $ compilec cSettings spec - hfile = render $ pretty $ C.translate $ compileh cSettings spec - - -- TODO: find a nicer solution using annotated AST's - -- Should figure out exactly which headers are needed, based on what - -- is used. - cmacros = unlines [ "#include " - , "#include " - , "#include " - , "#include " - , "#include " - , "" - , "#include \"" ++ prefix ++ ".h\"" - , "" - ] - - let dir = cSettingsOutputDirectory cSettings - createDirectoryIfMissing True dir - writeFile (dir prefix ++ ".c") $ cmacros ++ cfile - writeFile (dir prefix ++ ".h") hfile - --- | Compile a specification to a .h and a .c file. --- --- The first argument is used as prefix for the .h and .c files generated. -compile :: String -> Spec -> IO () -compile = compileWith mkDefaultCSettings - --- | Generate the .c file from a 'Spec'. --- --- The generated C file has the following structure: --- --- * Include .h file. --- * 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 where - streams = specStreams spec - triggers = specTriggers spec - exts = gatherexts streams triggers - exprs = gatherexprs streams triggers - - declns = mkstructdeclns exprs ++ mkexts exts ++ mkglobals streams - funs = genfuns streams triggers ++ [mkstep cSettings streams triggers exts] - - -- Write struct datatypes - mkstructdeclns :: [UExpr] -> [C.Decln] - mkstructdeclns es = catMaybes $ map mkdecln utypes where - mkdecln (UType ty) = case ty of - Struct x -> Just $ mkstructdecln ty - _ -> Nothing - - utypes = nub $ concatMap (\(UExpr _ e) -> exprtypes e) es - - -- Make declarations for copies of external variables. - mkexts :: [External] -> [C.Decln] - mkexts exts = map mkextcpydecln exts - - -- Make buffer and index declarations for streams. - mkglobals :: [Stream] -> [C.Decln] - mkglobals streams = map buffdecln streams ++ map indexdecln streams where - 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 where - - accessdecln :: Stream -> C.FunDef - accessdecln (Stream sid buff _ ty) = mkaccessdecln sid ty buff - - streamgen :: Stream -> C.FunDef - streamgen (Stream sid _ expr ty) = genfun (generatorname sid) expr ty - - 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) - - arggen :: (String, UExpr) -> C.FunDef - arggen (argname, UExpr ty expr) = genfun argname expr ty - --- | Generate the .h file from a 'Spec'. -compileh :: CSettings -> Spec -> C.TransUnit -compileh cSettings spec = C.TransUnit declns [] where - 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 where - mkdecln (UType ty) = case ty of - Struct x -> Just $ mkstructforwdecln ty - _ -> Nothing - - utypes = nub $ concatMap (\(UExpr _ e) -> exprtypes e) es - - -- Make declarations for external variables. - mkexts :: [External] -> [C.Decln] - mkexts = map mkextdecln - - extfundeclns :: [Trigger] -> [C.Decln] - extfundeclns triggers = map extfundecln triggers where - 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 (transtype ty) name - - -- Declaration for the step function. - stepdecln :: C.Decln - stepdecln = C.FunDecln Nothing (C.TypeSpec C.Void) - (cSettingsStepFunctionName cSettings) [] diff --git a/src/Copilot/Compile/C99/Error.hs b/src/Copilot/Compile/C99/Error.hs new file mode 100644 --- /dev/null +++ b/src/Copilot/Compile/C99/Error.hs @@ -0,0 +1,37 @@ +{-# LANGUAGE Safe #-} + +-- | +-- Copyright: (c) 2011 National Institute of Aerospace / Galois, Inc. +-- +-- Custom functions to report error messages to users. +module Copilot.Compile.C99.Error + ( impossible + , errorEmptyStruct + , errorZeroLengthArray + ) + where + +-- | Report an error due to a bug in Copilot. +impossible :: String -- ^ Name of the function in which the error was detected. + -> String -- ^ Name of the package in which the function is located. + -> a +impossible function package = + error $ "Impossible error in function " + ++ function ++ ", in package " ++ package + ++ ". Please file an issue at " + ++ "https://github.com/Copilot-Language/copilot/issues" + ++ " or email the maintainers at " + +-- | Report an error when attempting to compile a zero-length array to C99. +-- C99 does not support zero-length arrays, so Copilot cannot compile +-- specifications that use them. +errorZeroLengthArray :: a +errorZeroLengthArray = + error "copilot-c99: Cannot compile zero-length arrays to C99.\n" + +-- | Report an error when attempting to compile an empty struct to C99. +-- C99 does not support empty structs, so Copilot cannot compile +-- specifications that use them. +errorEmptyStruct :: a +errorEmptyStruct = + error "copilot-c99: Cannot compile empty structs to C99.\n" 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,490 @@ +{-# 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, get, modify ) +import qualified Data.List.NonEmpty as NonEmpty +import qualified Language.C99.Simple as C + +-- Internal imports: Copilot +import Copilot.Core ( Array, Expr (..), Field (..), Op1 (..), Op2 (..), + Op3 (..), Type (..), Value (..), accessorName, + arrayElems, toValues, typeLength, typeSize ) + +-- Internal imports +import Copilot.Compile.C99.Error ( impossible, errorEmptyStruct, errorZeroLengthArray ) +import Copilot.Compile.C99.Name ( exCpyName, streamAccessorName ) +import Copilot.Compile.C99.Type ( transLocalVarDeclType, transType, + 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 (\(i, x, y) + -> (i, x ++ [C.VarDecln Nothing cTy1 name initExpr], y) + ) + + 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 (UpdateField ty1@(Struct _) ty2 f) e1 e2) = do + -- Translating a struct update Op requires initializing a variable to the + -- "old" value, updating the field, and returning the new value. + e1' <- transExpr e1 + e2' <- transExpr e2 + + -- Variable to hold the updated struct + (i, _, _) <- get + let varName = "_v" ++ show i + modify (\(i, x, y) -> (i + 1, x, y)) + + -- Add new var decl + let initDecl = C.VarDecln Nothing cTy1 varName Nothing + cTy1 = transLocalVarDeclType ty1 + modify (\(i, x, y) -> (i, x ++ [initDecl], y)) + + -- Initialize the var to the same value as the original struct + let initStmt = C.Expr + $ C.AssignOp + C.Assign + (C.Ident varName) + e1' + + -- Update field f with given value e2. + let updateStmt = case ty2 of + Array _ -> C.Expr $ memcpy dest e2' size + where + dest = C.Dot (C.Ident varName) (accessorName f) + size = C.LitInt + (fromIntegral $ typeSize ty2) + C..* C.SizeOfType (C.TypeName (tyElemName ty2)) + + _ -> C.Expr + $ C.AssignOp + C.Assign + (C.Dot (C.Ident varName) (accessorName f)) + e2' + + modify (\(i, x, y) -> (i, x, y ++ [ initStmt, updateStmt ])) + + return $ C.Ident varName + +transExpr (Op2 op e1 e2) = do + e1' <- transExpr e1 + e2' <- transExpr e2 + return $ transOp2 op e1' e2' + +transExpr e@(Op3 (UpdateArray arrTy@(Array ty2)) e1 e2 e3) = do + e1' <- transExpr e1 + e2' <- transExpr e2 + e3' <- transExpr e3 + + -- Variable to hold the updated array + (i, _, _) <- get + let varName = "_v" ++ show i + modify (\(i, x, y) -> (i + 1, x, y)) + + -- Add new var decl + let initDecl = C.VarDecln Nothing cTy1 varName Nothing + cTy1 = transType arrTy + modify (\(i, x, y) -> (i, x ++ [initDecl], y)) + + let size :: Type (Array n t) -> C.Expr + size arrTy@(Array ty) = C.LitInt (fromIntegral $ typeLength arrTy) + C..* C.SizeOfType (C.TypeName $ transType ty) + + -- Initialize the var to the same value as the original array + let initStmt = C.Expr $ memcpy (C.Ident varName) e1' (size arrTy) + + -- Update element of array + let updateStmt = case ty2 of + Array _ -> C.Expr $ memcpy dest e3' size + where + dest = C.Index (C.Ident varName) e2' + size = C.LitInt + (fromIntegral $ typeSize ty2) + C..* C.SizeOfType (C.TypeName (tyElemName ty2)) + + _ -> C.Expr + $ C.AssignOp + C.Assign + (C.Index (C.Ident varName) e2') + e3' + + modify (\(i, x, y) -> (i, x, y ++ [ initStmt, updateStmt ])) + + return $ C.Ident varName + +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. +-- +-- PRE: op is not a struct update operation (i.e., 'UpdateField'). +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 + UpdateField _ _ _ -> impossible "transOp2" "copilot-c99" + +-- | 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 + UpdateArray _ -> impossible "transOp3" "copilot-c99" + +-- | 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. +-- +-- Raises an error if the struct is empty, as C99 does not support structs with +-- no fields. +constStruct :: [Value a] -> NonEmpty.NonEmpty C.InitItem +constStruct val = case val of + [] -> errorEmptyStruct + _ -> NonEmpty.fromList $ map constFieldInit val + +-- | Transform a Copilot Array, based on the element values and their type, +-- into a list of C99 initializer values. +-- +-- Raises an error if the array is empty, as C99 does not support zero-length +-- arrays. +constArray :: Type a -> [a] -> NonEmpty.NonEmpty C.InitItem +constArray ty xs = case xs of + [] -> errorZeroLengthArray + _ -> NonEmpty.fromList $ map (C.InitItem Nothing . constInit ty) xs + +-- | 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 = (Int, [C.Decln], [C.Stmt]) + +-- | 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) + +-- Write a call to the memcpy function. +memcpy :: C.Expr -> C.Expr -> C.Expr -> C.Expr +memcpy dest src size = C.Funcall (C.Ident "memcpy") [dest, src, size] + +-- Translate a Copilot type to a C99 type, handling arrays especially. +-- +-- If the given type is an array (including multi-dimensional arrays), the +-- type is that of the elements in the array. Otherwise, it is just the +-- equivalent representation of the given type in C. +tyElemName :: Type a -> C.Type +tyElemName ty = case ty of + Array ty' -> tyElemName ty' + _ -> transType ty 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 @@ -3,52 +3,60 @@ -- | Represent information about externs needed in the generation of C99 code -- for stream declarations and triggers. module Copilot.Compile.C99.External - {-# DEPRECATED "This module will be hidden in future versions." #-} + ( 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 where - streamsexts = foldr extunion mempty $ map streamexts streams - triggersexts = foldr extunion mempty $ map triggerexts triggers +gatherExts :: [Stream] -> [Trigger] -> [External] +gatherExts streams triggers = streamsExts `extUnion` triggersExts + where + 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 where - guardexts = exprexts guard - argexts = concat $ map uexprexts args + triggerExts :: Trigger -> [External] + triggerExts (Trigger _ guard args) = guardExts `extUnion` argExts + where + 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/Representation.hs b/src/Copilot/Compile/C99/Representation.hs new file mode 100644 --- /dev/null +++ b/src/Copilot/Compile/C99/Representation.hs @@ -0,0 +1,21 @@ +-- | C99 backend specific versions of selected `Copilot.Core` datatypes. +module Copilot.Compile.C99.Representation + ( UniqueTrigger (..) + , UniqueTriggerId + , mkUniqueTriggers + ) + where + +import Copilot.Core ( Trigger (..) ) + +-- | Internal unique name for a trigger. +type UniqueTriggerId = String + +-- | A `Copilot.Core.Trigger` with an unique name. +data UniqueTrigger = UniqueTrigger UniqueTriggerId Trigger + +-- | Given a list of triggers, make their names unique. +mkUniqueTriggers :: [Trigger] -> [UniqueTrigger] +mkUniqueTriggers ts = zipWith mkUnique ts [0..] + where + mkUnique t@(Trigger name _ _) n = UniqueTrigger (name ++ "_" ++ show n) t 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,8 +1,16 @@ -- | Settings used by the code generator to customize the code. module Copilot.Compile.C99.Settings - {-# DEPRECATED "This module will be hidden in future versions." #-} - (module Copilot.Compile.C99.Settings.Internal) - where + ( CSettings(..) + , mkDefaultCSettings + ) + where -import Copilot.Compile.C99.Settings.Internal +-- | Settings used to customize the code generated. +data CSettings = CSettings + { cSettingsStepFunctionName :: String + , cSettingsOutputDirectory :: FilePath + } +-- | Default settings with a step function called @step@. +mkDefaultCSettings :: CSettings +mkDefaultCSettings = CSettings "step" "." diff --git a/src/Copilot/Compile/C99/Settings/Internal.hs b/src/Copilot/Compile/C99/Settings/Internal.hs deleted file mode 100644 --- a/src/Copilot/Compile/C99/Settings/Internal.hs +++ /dev/null @@ -1,12 +0,0 @@ --- | Settings used by the code generator to customize the code. -module Copilot.Compile.C99.Settings.Internal where - --- | Settings used to customize the code generated. -data CSettings = CSettings - { cSettingsStepFunctionName :: String - , cSettingsOutputDirectory :: FilePath - } - --- | Default settings with a step function called @step@. -mkDefaultCSettings :: CSettings -mkDefaultCSettings = CSettings "step" "." 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,169 +0,0 @@ -{-# LANGUAGE GADTs #-} - --- | Translate Copilot Core expressions and operators to C99. -module Copilot.Compile.C99.Translate - {-# DEPRECATED "This module will be hidden in future versions." #-} - where - -import Control.Monad.State - -import Copilot.Core -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 = transtype 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 = case op of - Not -> (C..!) e - Abs _ -> funcall "abs" [e] - Sign _ -> funcall "copysign" [C.LitDouble 1.0, e] - Recip _ -> C.LitDouble 1.0 C../ e - Exp _ -> funcall "exp" [e] - Sqrt _ -> funcall "sqrt" [e] - Log _ -> funcall "log" [e] - Sin _ -> funcall "sin" [e] - Tan _ -> funcall "tan" [e] - Cos _ -> funcall "cos" [e] - Asin _ -> funcall "asin" [e] - Atan _ -> funcall "atan" [e] - Acos _ -> funcall "acos" [e] - Sinh _ -> funcall "sinh" [e] - Tanh _ -> funcall "tanh" [e] - Cosh _ -> funcall "cosh" [e] - Asinh _ -> funcall "asinh" [e] - Atanh _ -> funcall "atanh" [e] - Acosh _ -> funcall "acosh" [e] - Ceiling _ -> funcall "ceil" [e] - Floor _ -> funcall "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 _ -> funcall "pow" [e1, e2] - Logb _ -> funcall "log" [e2] C../ funcall "log" [e1] - Atan2 _ -> funcall "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 - --- | 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) (map fieldinit (toValues v)) - where - fieldinit (Value ty (Field val)) = C.InitExpr $ constty ty val - Array ty' -> \v -> C.InitVal (transtypename ty) (vals v) - where - vals v = constarray ty' (arrayelems v) - - constarray :: Type a -> [a] -> [C.Init] - constarray ty xs = case ty of - Array ty' -> constarray ty' (concatMap arrayelems xs) - _ -> map (C.InitExpr . constty ty) xs - - --- | 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 intro a C typename -transtypename :: Type a -> C.TypeName -transtypename ty = C.TypeName $ transtype ty 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,52 @@ +{-# 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 ( Struct (..), Type (..), typeLength, + typeName ) +import Copilot.Compile.C99.Error ( errorEmptyStruct, errorZeroLengthArray ) + +-- | 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' | typeLength ty == 0 -> errorZeroLengthArray + | otherwise -> C.Array (transType ty') len + where + len = Just $ C.LitInt $ fromIntegral $ typeLength ty + Struct s | null (toValues s) -> errorEmptyStruct + | otherwise -> 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,64 +0,0 @@ --- | Auxiliary helper functions to generate C99 code. -module Copilot.Compile.C99.Util - {-# DEPRECATED "This module will be hidden in future versions." #-} - 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 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 - --- | Enumerate all argument names based on trigger name. -argnames :: String -> [String] -argnames base = [aname | n <- [0..], let aname = argname base n] - --- | 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 diff --git a/tests/Main.hs b/tests/Main.hs new file mode 100644 --- /dev/null +++ b/tests/Main.hs @@ -0,0 +1,18 @@ +-- | Test copilot-c99. +module Main where + +-- External imports +import Test.Framework (Test, defaultMain) + +-- Internal library modules being tested +import qualified Test.Copilot.Compile.C99 + +-- | Run all unit tests on copilot-c99. +main :: IO () +main = defaultMain tests + +-- | All unit tests in copilot-c99. +tests :: [Test.Framework.Test] +tests = + [ Test.Copilot.Compile.C99.tests + ] diff --git a/tests/Test/Copilot/Compile/C99.hs b/tests/Test/Copilot/Compile/C99.hs new file mode 100644 --- /dev/null +++ b/tests/Test/Copilot/Compile/C99.hs @@ -0,0 +1,1042 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE ScopedTypeVariables #-} +-- | Test copilot-c99:Copilot.Compile.C99. +module Test.Copilot.Compile.C99 + ( tests ) + where + +-- External imports +import Control.Arrow ((&&&)) +import Control.Exception (ErrorCall (..), IOException, catch, + try) +import Control.Monad (unless, when) +import Data.Bits (Bits, complement) +import Data.List (intercalate, isSubsequenceOf) +import Data.Type.Equality (testEquality) +import Data.Typeable (Proxy (..), (:~:) (Refl)) +import GHC.TypeLits (KnownNat, natVal) +import System.Directory (doesFileExist, + getTemporaryDirectory, + removeDirectory, removeFile, + setCurrentDirectory) +import System.IO (hPutStrLn, stderr) +import System.Posix.Temp (mkdtemp) +import System.Process (callProcess, readProcess) +import System.Random (Random) +import Test.Framework (Test, testGroup) +import Test.Framework.Providers.HUnit (testCase) +import Test.Framework.Providers.QuickCheck2 (testProperty) +import Test.HUnit (Assertion, assertFailure) +import Test.QuickCheck (Arbitrary, Gen, Property, + arbitrary, choose, elements, + forAll, forAllBlind, frequency, + getPositive, ioProperty, oneof, + vectorOf, (.&&.)) +import Test.QuickCheck.Gen (chooseAny, chooseBoundedIntegral) + +-- External imports: Copilot +import Copilot.Core hiding (Property) +import Copilot.Core.Type.Array (array) + +-- External imports: Modules being tested +import Copilot.Compile.C99 (cSettingsOutputDirectory, compile, compileWith, + mkDefaultCSettings) + +-- * Constants + +-- | All unit tests for copilot-core:Copilot.Core.Type. +tests :: Test.Framework.Test +tests = + testGroup "Copilot.Compile.C99" + [ testProperty "Compile specification" testCompile + , testProperty "Compile specification in custom dir" testCompileCustomDir + , testProperty "Run specification" testRun + , testProperty "Run and compare results" testRunCompare + , testCase "Reject empty arrays and structs" testRejectEmpties + ] + +-- * Individual tests + +-- | Test compiling a spec. +testCompile :: Property +testCompile = ioProperty $ do + tmpDir <- getTemporaryDirectory + setCurrentDirectory tmpDir + + testDir <- mkdtemp "copilot_test_" + setCurrentDirectory testDir + + compile "copilot_test" spec + r <- compileC "copilot_test" + + -- Remove file produced by GCC + removeFile "copilot_test.o" + + -- Remove files produced by Copilot + removeFile "copilot_test.c" + removeFile "copilot_test.h" + removeFile "copilot_test_types.h" + + setCurrentDirectory tmpDir + removeDirectory testDir + + return r + + where + + spec = Spec streams observers triggers properties + + streams = [ Stream 0 [1] (Const Int8 1) Int8] + observers = [] + triggers = [ Trigger function guard args ] + properties = [] + + function = "func" + + guard = Const Bool True + + args = [] + +-- | Test compiling a spec in a custom directory. +testCompileCustomDir :: Property +testCompileCustomDir = ioProperty $ do + tmpDir <- getTemporaryDirectory + setCurrentDirectory tmpDir + + testDir <- mkdtemp "copilot_test_" + + compileWith (mkDefaultCSettings { cSettingsOutputDirectory = testDir }) + "copilot_test" + spec + + setCurrentDirectory testDir + r <- compileC "copilot_test" + + -- Remove file produced by GCC + removeFile "copilot_test.o" + + -- Remove files produced by Copilot + removeFile "copilot_test.c" + removeFile "copilot_test.h" + removeFile "copilot_test_types.h" + + setCurrentDirectory tmpDir + removeDirectory testDir + + return r + + where + + spec = Spec streams observers triggers properties + + streams = [ Stream 0 [1] (Const Int8 1) Int8] + observers = [] + triggers = [ Trigger function guard args ] + properties = [] + + function = "nop" + + guard = Const Bool True + + args = [] + +data Empty = Empty + +instance Struct Empty where + typeName _ = "" + toValues _ = [] + +instance Typed Empty where + typeOf = Struct Empty + +-- | Test that compiling a spec with an empty array or struct raises an error. +-- C99 does not support zero-length arrays or structs without fields, so Copilot +-- should report an error during compilation. +testRejectEmpties :: Assertion +testRejectEmpties = do + tmpDir <- getTemporaryDirectory + setCurrentDirectory tmpDir + + r1 <- try (compile "copilot_test" $ spec t1) :: IO (Either ErrorCall ()) + unless (isErrZeroArray r1) $ assertFailure "Const zero-length array" + + r2 <- try (compile "copilot_test" $ spec t2) :: IO (Either ErrorCall ()) + unless (isErrZeroArray r2) $ assertFailure "Extern zero-length array" + + r3 <- try (compile "copilot_test" $ spec t3) :: IO (Either ErrorCall ()) + unless (isErrEmptyStruct r3) $ assertFailure "Const empty struct" + + r4 <- try (compile "copilot_test" $ spec t4) :: IO (Either ErrorCall ()) + unless (isErrEmptyStruct r4) $ assertFailure "Extern empty struct" + + where + + spec a = Spec streams observers (triggers a) properties + + streams = [] + observers = [] + triggers a = [ Trigger "trig" (Const Bool True) a ] + properties = [] + + t1 = [ UExpr arrTy (Const arrTy (array [])) ] + t2 = [ UExpr arrTy (ExternVar arrTy "arrs" Nothing) ] + t3 = [ UExpr structTy (Const structTy Empty) ] + t4 = [ UExpr structTy (ExternVar structTy "structs" Nothing) ] + + arrTy :: Type (Array 0 Bool) + arrTy = Array Bool + + structTy :: Type Empty + structTy = Struct Empty + + isErrZeroArray :: Either ErrorCall a -> Bool + isErrZeroArray e = case e of + Left (ErrorCall msg) -> "zero-length array" `isSubsequenceOf` msg + _ -> False + + isErrEmptyStruct :: Either ErrorCall a -> Bool + isErrEmptyStruct e = case e of + Left (ErrorCall msg) -> "empty struct" `isSubsequenceOf` msg + _ -> False + +-- | Test compiling a spec and running the resulting program. +-- +-- The actual behavior is ignored. +testRun :: Property +testRun = ioProperty $ do + tmpDir <- getTemporaryDirectory + setCurrentDirectory tmpDir + + testDir <- mkdtemp "copilot_test_" + setCurrentDirectory testDir + + compile "copilot_test" spec + r <- compileC "copilot_test" + + let cProgram = unlines + [ "#include \"copilot_test.h\"" + , "" + , "void nop () {" + , "}" + , "" + , "int main () {" + , " step();" + , "}" + ] + + writeFile "main.c" cProgram + + -- Compile a main program + r2 <- compileExecutable "main" [ "copilot_test.o" ] + callProcess "./main" [] + + -- Remove file produced by GCC + removeFile "copilot_test.o" + removeFile "main" + + -- Remove files produced "by hand" + removeFile "main.c" + + -- Remove files produced by Copilot + removeFile "copilot_test.c" + removeFile "copilot_test.h" + removeFile "copilot_test_types.h" + + setCurrentDirectory tmpDir + removeDirectory testDir + + return $ r && r2 + + where + + spec = Spec streams observers triggers properties + + streams = [ Stream 0 [1] (Const Int8 1) Int8] + observers = [] + triggers = [ Trigger function guard args ] + properties = [] + + function = "nop" + + guard = Const Bool True + + args = [] + +-- | Test running compiled spec and comparing the results to the +-- expectation. +testRunCompare :: Property +testRunCompare = + testRunCompare1 (arbitraryOpIntegralBool :: Gen (TestCase1 Int8 Bool)) + .&&. testRunCompare1 (arbitraryOpIntegralBool :: Gen (TestCase1 Int16 Bool)) + .&&. testRunCompare1 (arbitraryOpIntegralBool :: Gen (TestCase1 Int32 Bool)) + .&&. testRunCompare1 (arbitraryOpIntegralBool :: Gen (TestCase1 Int64 Bool)) + .&&. testRunCompare1 (arbitraryOpIntegralBool :: Gen (TestCase1 Word8 Bool)) + .&&. testRunCompare1 (arbitraryOpIntegralBool :: Gen (TestCase1 Word16 Bool)) + .&&. testRunCompare1 (arbitraryOpIntegralBool :: Gen (TestCase1 Word32 Bool)) + .&&. testRunCompare1 (arbitraryOpIntegralBool :: Gen (TestCase1 Word64 Bool)) + .&&. testRunCompare1 (arbitraryOpFloatingBool :: Gen (TestCase1 Float Bool)) + .&&. testRunCompare1 (arbitraryOpFloatingBool :: Gen (TestCase1 Double Bool)) + .&&. testRunCompare2 (arbitraryArrayNum :: Gen (TestCase2 (Array 2 Int8) Word32 Int8)) + .&&. testRunCompare2 (arbitraryArrayNum :: Gen (TestCase2 (Array 2 Int16) Word32 Int16)) + +-- * Random generators + +-- ** Random function generators + +-- | Generator of functions that produce booleans. +arbitraryOpBool :: Typed a => Gen (Fun a Bool, [a] -> [Bool]) +arbitraryOpBool = + frequency + [ (5, arbitraryOp1Any) + , (5, funCompose1 <$> arbitraryOp1Bool <*> arbitraryOpBool) + , (2, funCompose2 <$> arbitraryOp2Bool <*> arbitraryOpBool <*> arbitraryOpBool) + , (1, funCompose2 <$> arbitraryOp2Eq <*> arbitraryOpBool <*> arbitraryOpBool) + , (1, funCompose2 <$> arbitraryOp2Ord <*> arbitraryOpBool <*> arbitraryOpBool) + ] + +-- | Generator of functions that take Bits and produce booleans. +arbitraryOpBoolBits :: (Typed a, Bits a) => Gen (Fun a Bool, [a] -> [Bool]) +arbitraryOpBoolBits = + frequency + [ (1, funCompose2 <$> arbitraryOp2Eq <*> arbitraryOpBits <*> arbitraryOpBits) + ] + +-- | Generator of functions that take Nums and produce booleans. +arbitaryOpBoolOrdEqNum :: (Typed a, Eq a, Ord a, Num a) + => Gen (Fun a Bool, [a] -> [Bool]) +arbitaryOpBoolOrdEqNum = + frequency + [ (1, funCompose2 <$> arbitraryOp2Eq <*> arbitraryOpNum <*> arbitraryOpNum) + , (1, funCompose2 <$> arbitraryOp2Ord <*> arbitraryOpNum <*> arbitraryOpNum) + ] + +-- | Generator of functions that take Floating point numbers and produce +-- booleans. +arbitraryOpBoolEqNumFloat :: (Typed t, Eq t, Num t, Floating t) + => Gen (Fun t Bool, [t] -> [Bool]) +arbitraryOpBoolEqNumFloat = + frequency + [ (1, funCompose2 <$> arbitraryOp2Eq <*> arbitraryOpNum <*> arbitraryOpFloat) + , (1, funCompose2 <$> arbitraryOp2Eq <*> arbitraryOpFloat <*> arbitraryOpNum) + ] + +-- | Generator of functions that take and produce Bits. +arbitraryOpBits :: (Bits t, Typed t) + => Gen (Fun t t, [t] -> [t]) +arbitraryOpBits = elements + [ (Op1 (BwNot typeOf), fmap complement) + ] + +-- | Generator of functions that take and produce Nums. +arbitraryOpNum :: (Typed t, Num t) => Gen (Fun t t, [t] -> [t]) +arbitraryOpNum = elements + [ (Op1 (Abs typeOf), fmap abs) + , (Op1 (Sign typeOf), fmap signum) + ] + +-- | Generator of functions that take an arrays and indicates and produce +-- elements from the array. +arbitraryArrayIx :: forall t n . (Typed t, KnownNat n, Num t) + => Gen ( Fun2 (Array n t) Word32 t + , [Array n t] -> [Word32] -> [t] + ) +arbitraryArrayIx = return + (Op2 (Index typeOf), zipWith (\x y -> arrayElems x !! fromIntegral y)) + +-- | Generator of functions on Floating point numbers. +arbitraryOpFloat :: (Floating t, Typed t) => Gen (Fun t t, [t] -> [t]) +arbitraryOpFloat = elements + [ (Op1 (Exp typeOf), fmap exp) + , (Op1 (Sqrt typeOf), fmap sqrt) + , (Op1 (Log typeOf), fmap log) + , (Op1 (Sin typeOf), fmap sin) + , (Op1 (Tan typeOf), fmap tan) + , (Op1 (Cos typeOf), fmap cos) + , (Op1 (Asin typeOf), fmap asin) + , (Op1 (Atan typeOf), fmap atan) + , (Op1 (Acos typeOf), fmap acos) + , (Op1 (Sinh typeOf), fmap sinh) + , (Op1 (Tanh typeOf), fmap tanh) + , (Op1 (Cosh typeOf), fmap cosh) + , (Op1 (Asinh typeOf), fmap asinh) + , (Op1 (Atanh typeOf), fmap atanh) + , (Op1 (Acosh typeOf), fmap acosh) + ] + +-- | Generator of functions on that produce elements of any type. +arbitraryOp1Any :: forall a b + . (Arbitrary b, Typed a, Typed b) + => Gen (Fun a b, [a] -> [b]) +arbitraryOp1Any = oneof $ + [ (\v -> (\_ -> Const typeOf v, fmap (const v))) <$> arbitrary ] + ++ + rest + where + rest | Just Refl <- testEquality t1 t2 + = [return (id, id)] + | otherwise + = [] + + t1 :: Type a + t1 = typeOf + + t2 :: Type b + t2 = typeOf + +-- | Generator of functions on Booleans. +arbitraryOp1Bool :: Gen (Fun Bool Bool, [Bool] -> [Bool]) +arbitraryOp1Bool = elements + [ (Op1 Not, fmap not) + ] + +-- | Generator of binary functions on Booleans. +arbitraryOp2Bool :: Gen (Fun2 Bool Bool Bool, [Bool] -> [Bool] -> [Bool]) +arbitraryOp2Bool = elements + [ (Op2 And, zipWith (&&)) + , (Op2 Or, zipWith (||)) + ] + +-- | Generator of binary functions that take two Eq elements of the same type +-- and return a Bool. +arbitraryOp2Eq :: (Typed t, Eq t) + => Gen (Fun2 t t Bool, [t] -> [t] -> [Bool]) +arbitraryOp2Eq = elements + [ (Op2 (Eq typeOf), zipWith (==)) + , (Op2 (Ne typeOf), zipWith (/=)) + ] + +-- | Generator of binary functions that take two Ord elements of the same type +-- and return a Bool. +arbitraryOp2Ord :: (Typed t, Ord t) + => Gen (Fun2 t t Bool, [t] -> [t] -> [Bool]) +arbitraryOp2Ord = elements + [ (Op2 (Le typeOf), zipWith (<=)) + , (Op2 (Lt typeOf), zipWith (<)) + , (Op2 (Ge typeOf), zipWith (>=)) + , (Op2 (Gt typeOf), zipWith (>)) + ] + +-- ** Random data generators + +-- | Random array generator. +arbitraryArray :: forall n t . (KnownNat n, Random t) => Gen (Array n t) +arbitraryArray = array <$> vectorOf len chooseAny + where + len :: Int + len = fromIntegral $ natVal (Proxy :: Proxy n) + +-- ** Random test case generators + +-- | Generator for test cases on integral numbers that produce booleans. +arbitraryOpIntegralBool :: (Typed t, Bounded t, Integral t, Bits t) + => Gen (TestCase1 t Bool) +arbitraryOpIntegralBool = frequency + [ (5, mkTestCase1 + arbitraryOpBool + (chooseBoundedIntegral (minBound, maxBound))) + + , (2, mkTestCase1 + arbitraryOpBoolBits + (chooseBoundedIntegral (minBound, maxBound))) + + -- we need to use +1 because certain operations overflow the number + , (2, mkTestCase1 + arbitaryOpBoolOrdEqNum + (chooseBoundedIntegral (minBound + 1, maxBound))) + ] + +-- | Generator for test cases on floating-point numbers that produce booleans. +arbitraryOpFloatingBool :: (Random t, Typed t, Floating t, Eq t) + => Gen (TestCase1 t Bool) +arbitraryOpFloatingBool = oneof + [ mkTestCase1 arbitraryOpBoolEqNumFloat chooseAny + ] + +-- | Generator for test cases on Arrays selection producing values of the +-- array. +arbitraryArrayNum :: forall n a + . (KnownNat n, Num a, Random a, Typed a) + => Gen (TestCase2 (Array n a) Word32 a) +arbitraryArrayNum = oneof + [ mkTestCase2 arbitraryArrayIx arbitraryArray gen + ] + where + gen :: Gen Word32 + gen = choose (0, len - 1) + + len :: Word32 + len = fromIntegral $ natVal (Proxy :: Proxy n) + +-- * Semantics + +-- ** Functions + +-- | Unary Copilot function. +type Fun a b = Expr a -> Expr b + +-- | Binary Copilot function. +type Fun2 a b c = Expr a -> Expr b -> Expr c + +-- | Compose functions, paired with the Haskell functions that define their +-- idealized meaning. +funCompose1 :: (Fun b c, [b] -> [c]) + -> (Fun a b, [a] -> [b]) + -> (Fun a c, [a] -> [c]) +funCompose1 (f1, g1) (f2, g2) = (f1 . f2, g1 . g2) + +-- | Compose a binary function, with two functions, one for each argument. +funCompose2 :: (Fun2 b c d, [b] -> [c] -> [d]) + -> (Fun a b, [a] -> [b]) + -> (Fun a c, [a] -> [c]) + -> (Fun a d, [a] -> [d]) +funCompose2 (f1, g1) (f2, g2) (f3, g3) = + (uncurry f1 . (f2 &&& f3), uncurry g1 . (g2 &&& g3)) + +-- ** Test cases + +-- | Test case specification for specs with one input variable and one output. +data TestCase1 a b = TestCase1 + { wrapTC1Expr :: Spec + -- ^ Specification containing a trigger an extern of type 'a' and a trigger + -- with an argument of type 'b'. + + , wrapTC1Fun :: [a] -> [b] + -- ^ Function expected to function in the same way as the Spec being + -- tested. + + , wrapTC1CopInp :: (String -> String, String, String, Gen a) + -- ^ Input specification. + -- + -- - The first element is a function that prints the variable declaration + -- in C. + -- + -- - The second element obtains a C expression that calculates the size of + -- the variable in C. + -- + -- - The third contains the variable name in C. + -- + -- - The latter contains a randomized generator for values of the given + -- type. + + , wrapTC1CopOut :: (String, String) + -- ^ Output specification. + -- + -- The first element of the tuple contains the type of the output in C. + -- + -- The second element of the tuple is the formatting string when printing + -- values of the given kind. + } + +-- | Test case specification for specs with two input variables and one output. +data TestCase2 a b c = TestCase2 + { wrapTC2Expr :: Spec + -- ^ Specification containing a trigger an extern of type 'a' and a trigger + -- with an argument of type 'b'. + + , wrapTC2Fun :: [a] -> [b] -> [c] + -- ^ Function expected to function in the same way as the Spec being + -- tested. + + , wrapTC2CopInp1 :: (String -> String, String, String, Gen a) + -- ^ Input specification for the first input. + -- + -- - The first element is a function that prints the variable declaration + -- in C. + -- + -- - The second element obtains a C expression that calculates the size of + -- the variable in C. + -- + -- - The third contains the variable name in C. + -- + -- - The latter contains a randomized generator for values of the given + -- type. + + , wrapTC2CopInp2 :: (String -> String, String, String, Gen b) + -- ^ Input specification for the second input. + -- + -- - The first element is a function that prints the variable declaration + -- in C. + -- + -- - The second element obtains a C expression that calculates the size of + -- the variable in C. + -- + -- - The third contains the variable name in C. + -- + -- - The latter contains a randomized generator for values of the given + -- type. + + , wrapTC2CopOut :: (String, String) + -- ^ Output specification. + -- + -- The first element of the tuple contains the type of the output in C. + -- + -- The second element of the tuple is the formatting string when printing + -- values of the given kind. + } + +-- | Generate test cases for expressions that behave like unary functions. +mkTestCase1 :: (Typed a, Typed b) + => Gen (Fun a b, [a] -> [b]) + -> Gen a + -> Gen (TestCase1 a b) +mkTestCase1 genO gen = do + (copilotF, semF) <- genO + + let spec = alwaysTriggerArg1 (UExpr t2 appliedOp) + appliedOp = copilotF (ExternVar t1 varName Nothing) + + return $ + TestCase1 + spec + semF + ( varDeclC t1, sizeC t1, varName, gen ) + ( typeC t2, formatC t2) + + where + + t1 = typeOf + t2 = typeOf + + varName = "input" + +-- | Generate test cases for expressions that behave like binary functions. +mkTestCase2 :: (Typed a, Typed b, Typed c) + => Gen (Fun2 a b c, [a] -> [b] -> [c]) + -> Gen a + -> Gen b + -> Gen (TestCase2 a b c) +mkTestCase2 genO genA genB = do + (copilotF, semF) <- genO + + let spec = alwaysTriggerArg1 (UExpr t3 appliedOp) + appliedOp = copilotF (ExternVar t1 varName1 Nothing) + (ExternVar t2 varName2 Nothing) + + return $ + TestCase2 + spec + semF + ( varDeclC t1, sizeC t1, varName1, genA ) + ( varDeclC t2, sizeC t2, varName2, genB ) + ( typeC t3, formatC t3) + + where + + t1 = typeOf + t2 = typeOf + t3 = typeOf + + varName1 = "input1" + varName2 = "input2" + +-- | Test running a compiled C program and comparing the results. +testRunCompare1 :: (Show a, CShow a, ReadableFromC b, Eq b) + => Gen (TestCase1 a b) -> Property +testRunCompare1 ops = + forAllBlind ops $ \testCase -> + let (TestCase1 copilotSpec haskellFun inputVar outputVar) = testCase + (cTypeInput, size, cInputName, gen) = inputVar + + in forAll (getPositive <$> arbitrary) $ \len -> + + forAll (vectorOf len gen) $ \nums -> do + + let inputs = [ (cTypeInput, size, fmap cshow nums, cInputName) ] + outputs = haskellFun nums + + testRunCompareArg inputs len outputs copilotSpec outputVar + +-- | Test running a compiled C program and comparing the results. +testRunCompare2 :: (Show a1, CShow a1, Show a2, CShow a2, ReadableFromC b, Eq b) + => Gen (TestCase2 a1 a2 b) -> Property +testRunCompare2 ops = + forAllBlind ops $ \testCase -> + let (TestCase2 copilotSpec haskellFun inputVar1 inputVar2 outputVar) = + testCase + + (cTypeInput1, size1, cInputName1, gen1) = inputVar1 + (cTypeInput2, size2, cInputName2, gen2) = inputVar2 + + in forAll (getPositive <$> arbitrary) $ \len -> + forAll (vectorOf len gen1) $ \nums1 -> + forAll (vectorOf len gen2) $ \nums2 -> do + let inputs = [ (cTypeInput1, size1, fmap cshow nums1, cInputName1) + , (cTypeInput2, size2, fmap cshow nums2, cInputName2) + ] + + outputs = haskellFun nums1 nums2 + + testRunCompareArg inputs len outputs copilotSpec outputVar + +-- | Test running a compiled C program and comparing the results, when the +-- program produces one output as an argument to a trigger that always fires. +-- +-- PRE: all lists (second argument) of inputs have the length given as second +-- argument. +-- +-- PRE: the monitoring code this is linked against uses the function +-- @printBack@ with exactly one argument to pass the results. +testRunCompareArg :: (ReadableFromC b, Eq b) + => [(String -> String, String, [String], String)] + -> Int + -> [b] + -> Spec + -> (String, String) + -> Property +testRunCompareArg inputs numInputs nums spec outputVar = + ioProperty $ do + tmpDir <- getTemporaryDirectory + setCurrentDirectory tmpDir + + -- Operate in temporary directory + testDir <- mkdtemp "copilot_test_" + setCurrentDirectory testDir + + -- Produce copilot monitoring code + compile "copilot_test" spec + r <- compileC "copilot_test" + + -- Produce wrapper program + let cProgram = testRunCompareArgCProgram inputs numInputs outputVar + writeFile "main.c" cProgram + + -- Compile main program + r2 <- compileExecutable "main" [ "copilot_test.o" ] + + -- Print result so far (for debugging purposes only) + print r2 + print testDir + + -- Run program and compare result + out <- readProcess "./main" [] "" + let outNums = readFromC <$> lines out + comparison = outNums == nums + + -- Only clean up if the test succeeded; otherwise, we want to inspect it. + when comparison $ do + -- Remove file produced by GCC + removeFile "copilot_test.o" + removeFile "main" + + -- Remove files produced "by hand" + removeFile "main.c" + + -- Remove files produced by Copilot + removeFile "copilot_test.c" + removeFile "copilot_test.h" + removeFile "copilot_test_types.h" + + -- Remove temporary directory + setCurrentDirectory tmpDir + removeDirectory testDir + + return $ r && r2 && comparison + +-- | Return a wrapper C program that runs a loop for a number of iterations, +-- putting values in global variables at every step, running the monitors, and +-- publishing the results of any outputs. +testRunCompareArgCProgram + :: [(String -> String, String, [String], String)] + -> Int + -> (String, String) + -> String +testRunCompareArgCProgram inputs numSteps outputVar = unlines $ + [ "#include " + , "#include " + , "#include " + , "#include " + , "#include " + , "#include \"copilot_test.h\"" + , "" + ] + ++ varDecls ++ + [ "" + , "void printBack (" ++ cTypeRes ++ " num) {" + , " printf(\"" ++ cStr ++ "\\n\", num);" + , "}" + , "" + , "int main () {" + , " int i = 0;" + , " for (i = 0; i < " ++ maxInputsName ++ "; i++) {" + ] + ++ inputUpdates ++ + [ "" + , " step();" + , " }" + , " return 0;" + , "}" + ] + + where + + varDecls :: [String] + varDecls = + [ "int " ++ maxInputsName ++ " = " ++ show numSteps ++ ";" ] + ++ inputVarDecls + + inputVarDecls :: [String] + inputVarDecls = + concatMap + (\(ctypeF, _size, varName, arrVar, arrVals) -> + + let inputsStr = intercalate ", " (arrVals :: [String]) + + in [ ctypeF (arrVar ++ "[]") ++ " = {" ++ inputsStr ++ "};" + , "" + , ctypeF varName ++ ";" + ] + ) + vars + + inputUpdates :: [String] + inputUpdates = concatMap (\(_ctype, size, varName, arrVar, _arrVals) -> + [ " memcpy(&" ++ varName ++ ", &" ++ arrVar ++ "[i], " ++ size ++ ");" + ]) + vars + + (cTypeRes, cStr) = outputVar + + vars = map oneInput inputs + oneInput (cTypeInput, size, inputVals, cInputName) = + (cTypeInput, size, inputVarName, inputArrVarName, inputVals) + where + inputVarName = cInputName + inputArrVarName = cInputName ++ "_s" + + maxInputsName = "MAX_STEPS" + +-- * Auxiliary functions + +-- ** Specs handling + +-- | Build a 'Spec' that triggers at every step, passing the given expression +-- as argument, and execution a function 'printBack'. +alwaysTriggerArg1 :: UExpr -> Spec +alwaysTriggerArg1 = triggerArg1 (Const Bool True) + + where + + -- | Build a 'Spec' that triggers based on a given boolean stream, passing + -- the given expression as argument, and execution a function 'printBack'. + triggerArg1 :: Expr Bool -> UExpr -> Spec + triggerArg1 guard expr = Spec streams observers triggers properties + + where + + streams = [] + observers = [] + properties = [] + + triggers = [ Trigger function guard args ] + function = "printBack" + args = [ expr ] + +-- ** Compilation of C programs + +-- | Compile a C file given its basename. +compileC :: String -> IO Bool +compileC baseName = do + result <- catch (do callProcess "gcc" [ "-c", baseName ++ ".c" ] + return True + ) + (\e -> do + hPutStrLn stderr $ + "copilot-c99: error: compileC: cannot compile " + ++ baseName ++ ".c with gcc" + hPutStrLn stderr $ + "copilot-c99: exception: " ++ show (e :: IOException) + return False + ) + if result + then doesFileExist $ baseName ++ ".o" + else return False + +-- | Compile a C file into an executable, given its basename and files to link +-- with it. +compileExecutable :: String -> [String] -> IO Bool +compileExecutable baseName linked = do + result <- catch (do callProcess "gcc" $ [ baseName ++ ".c" ] + ++ linked + ++ [ "-lm" ] + ++ [ "-o", baseName ] + return True + ) + (\e -> do + hPutStrLn stderr $ + "copilot-c99: error: compileExecutable: cannot compile " + ++ baseName ++ ".c with gcc" + hPutStrLn stderr $ + "copilot-c99: exception: " ++ show (e :: IOException) + return False + ) + if result + then doesFileExist baseName + else return False + +-- ** Interfacing between Haskell and C + +-- | C formatting string that can be used to print values of a given type. +formatC :: Typed a => Type a -> String +formatC Bool = "%d" +formatC Int8 = "%d" +formatC Int16 = "%d" +formatC Int32 = "%d" +formatC Int64 = "%ld" +formatC Word8 = "%d" +formatC Word16 = "%d" +formatC Word32 = "%d" +formatC Word64 = "%ld" +formatC Float = "%f" +formatC Double = "%lf" +formatC _ = error + "copilot-c99 (test): Printing of arrays and structs is not yet supported." + +-- | C type used to store values of a given type. +typeC :: Typed a => Type a -> String +typeC Bool = "bool" +typeC Int8 = "int8_t" +typeC Int16 = "int16_t" +typeC Int32 = "int32_t" +typeC Int64 = "int64_t" +typeC Word8 = "uint8_t" +typeC Word16 = "uint16_t" +typeC Word32 = "uint32_t" +typeC Word64 = "uint64_t" +typeC Float = "float" +typeC Double = "double" +typeC (Array tE) = typeC tE ++ "[]" +typeC _ = error + "copilot-c99 (test): Input variables of type struct are not yet supported." + +-- | C variable declaration for values of a given type. +varDeclC :: Typed a => Type a -> String -> String +varDeclC Bool v = "bool " ++ v +varDeclC Int8 v = "int8_t " ++ v +varDeclC Int16 v = "int16_t " ++ v +varDeclC Int32 v = "int32_t " ++ v +varDeclC Int64 v = "int64_t " ++ v +varDeclC Word8 v = "uint8_t " ++ v +varDeclC Word16 v = "uint16_t " ++ v +varDeclC Word32 v = "uint32_t " ++ v +varDeclC Word64 v = "uint64_t " ++ v +varDeclC Float v = "float " ++ v +varDeclC Double v = "double " ++ v +varDeclC t@(Array tE) v = + typeC tE ++ " " ++ v ++ "[" ++ show (typeLength t) ++ "]" +varDeclC _ _ = error + "copilot-c99 (test): Input variables of type struct are not yet supported." + +-- | Expression that calculates the size of a variable of a given type. +sizeC :: Typed a => Type a -> String +sizeC Bool = "sizeof(bool)" +sizeC Int8 = "sizeof(int8_t)" +sizeC Int16 = "sizeof(int16_t)" +sizeC Int32 = "sizeof(int32_t)" +sizeC Int64 = "sizeof(int64_t)" +sizeC Word8 = "sizeof(uint8_t)" +sizeC Word16 = "sizeof(uint16_t)" +sizeC Word32 = "sizeof(uint32_t)" +sizeC Word64 = "sizeof(uint64_t)" +sizeC Float = "sizeof(float)" +sizeC Double = "sizeof(double)" +sizeC t@(Array tE) = show (typeLength t) ++ "* sizeof(" ++ typeC tE ++ ")" +sizeC _ = error + "copilot-c99 (test): Input variables of type struct are not yet supported." + +-- | Show a value of a given type in C. +class CShow s where + cshow :: s -> String + +instance CShow Int8 where + -- Use a macro to ensure that any necessary suffixes are added to the number. + -- We choose this macro instead of specifically adding a suffix for reasons + -- of portability. + cshow x = "INT8_C(" ++ show x ++ ")" + +instance CShow Int16 where + -- Use a macro to ensure that any necessary suffixes are added to the number. + -- We choose this macro instead of specifically adding a suffix for reasons + -- of portability. + cshow x = "INT16_C(" ++ show x ++ ")" + +instance CShow Int32 where + -- Use a macro to ensure that any necessary suffixes are added to the number. + -- We choose this macro instead of specifically adding a suffix for reasons + -- of portability. + cshow x = "INT32_C(" ++ show x ++ ")" + +instance CShow Int64 where + -- Use a macro to ensure that any necessary suffixes are added to the number. + -- We choose this macro instead of specifically adding a suffix for reasons + -- of portability. + cshow x = "INT64_C(" ++ show x ++ ")" + +instance CShow Word8 where + -- Use a macro to ensure that any necessary suffixes are added to the number. + -- We choose this macro instead of specifically adding a suffix for reasons + -- of portability. + cshow x = "UINT8_C(" ++ show x ++ ")" + +instance CShow Word16 where + -- Use a macro to ensure that any necessary suffixes are added to the number. + -- We choose this macro instead of specifically adding a suffix for reasons + -- of portability. + cshow x = "UINT16_C(" ++ show x ++ ")" + +instance CShow Word32 where + -- Use a macro to ensure that any necessary suffixes are added to the number. + -- We choose this macro instead of specifically adding a suffix for reasons + -- of portability. + cshow x = "UINT32_C(" ++ show x ++ ")" + +instance CShow Word64 where + -- Use a macro to ensure that any necessary suffixes are added to the number. + -- We choose this macro instead of specifically adding a suffix for reasons + -- of portability. + cshow x = "UINT64_C(" ++ show x ++ ")" + +instance CShow Float where + cshow = show + +instance CShow Double where + cshow = show + +instance CShow Bool where + cshow True = "true" + cshow False = "false" + +instance CShow t => CShow (Array n t) where + cshow a = intercalate "," $ map cshow $ arrayElems a + +-- | Read a value of a given type in C. +class ReadableFromC a where + readFromC :: String -> a + +instance ReadableFromC Bool where + readFromC "0" = False + readFromC _ = True + +instance ReadableFromC Int8 where + readFromC = read + +instance ReadableFromC Int16 where + readFromC = read + +instance ReadableFromC Int32 where + readFromC = read + +instance ReadableFromC Int64 where + readFromC = read + +instance ReadableFromC Word8 where + readFromC = read + +instance ReadableFromC Word16 where + readFromC = read + +instance ReadableFromC Word32 where + readFromC = read + +instance ReadableFromC Word64 where + readFromC = read