packages feed

copilot-c99 3.7 → 4.8

raw patch · 18 files changed

Files

CHANGELOG view
@@ -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)
copilot-c99.cabal view
@@ -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
src/Copilot/Compile/C99.hs view
@@ -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 )
src/Copilot/Compile/C99/CodeGen.hs view
@@ -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
src/Copilot/Compile/C99/Compile.hs view
@@ -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 <stdint.h>"+                             , "#include <stdbool.h>"+                             , "#include <string.h>"+                             , "#include <stdlib.h>"+                             , "#include <math.h>"+                             , ""+                             , "#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
− src/Copilot/Compile/C99/Compile/Internal.hs 
@@ -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 <stdint.h>"-                             , "#include <stdbool.h>"-                             , "#include <string.h>"-                             , "#include <stdlib.h>"-                             , "#include <math.h>"-                             , ""-                             , "#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) []
+ src/Copilot/Compile/C99/Error.hs view
@@ -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 <ivan.perezdominguez@nasa.gov>"++-- | 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"
+ src/Copilot/Compile/C99/Expr.hs view
@@ -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'+-- <https://gitlab.haskell.org/ghc/ghc/-/blob/aed98ddaf72cc38fb570d8415cac5de9d8888818/libraries/base/GHC/Float.hs#L523-L525 here>.+transSign :: Type a -> C.Expr -> C.Expr+transSign ty e = positiveCase $ negativeCase e+  where+    -- If @e@ is positive, return @1@, otherwise fall back to argument.+    --+    -- Produces the following code, where @<arg>@ is the argument to this+    -- function:+    -- @+    -- e > 0 ? 1 : <arg>+    -- @+    positiveCase :: C.Expr  -- ^ Value returned if @e@ is not positive.+                 -> C.Expr+    positiveCase =+      C.Cond (C.BinaryOp C.GT e (constNumTy ty 0)) (constNumTy ty 1)++    -- If @e@ is negative, return @1@, otherwise fall back to argument.+    --+    -- Produces the following code, where @<arg>@ is the argument to this+    -- function:+    -- @+    -- e < 0 ? -1 : <arg>+    -- @+    negativeCase :: C.Expr  -- ^ Value returned if @e@ is not negative.+                 -> C.Expr+    negativeCase =+      C.Cond (C.BinaryOp C.LT e (constNumTy ty 0)) (constNumTy ty (-1))++-- | Transform a Copilot Core literal, based on its value and type, into a C99+-- literal.+constTy :: Type a -> a -> C.Expr+constTy ty = case ty of+  Bool      -> C.LitBool+  Int8      -> explicitTy ty . C.LitInt . fromIntegral+  Int16     -> explicitTy ty . C.LitInt . fromIntegral+  Int32     -> explicitTy ty . C.LitInt . fromIntegral+  Int64     -> explicitTy ty . C.LitInt . fromIntegral+  Word8     -> explicitTy ty . C.LitInt . fromIntegral+  Word16    -> explicitTy ty . C.LitInt . fromIntegral+  Word32    -> explicitTy ty . C.LitInt . fromIntegral+  Word64    -> explicitTy ty . C.LitInt . fromIntegral+  Float     -> explicitTy ty . C.LitFloat+  Double    -> explicitTy ty . C.LitDouble+  Struct _  -> C.InitVal (transTypeName ty) . constStruct . toValues+  Array ty' -> C.InitVal (transTypeName ty) . constArray ty' . arrayElems++-- | Transform a Copilot Core literal, based on its value and type, into a C99+-- initializer.+constInit :: Type a -> a -> C.Init+constInit ty val = case ty of+  -- We include two special cases for Struct and Array to avoid using constTy+  -- on them.+  --+  -- In the default case (i.e., InitExpr (constTy ty val)), constant+  -- initializations are explicitly cast. However, doing so 1) may result in+  -- incorrect values for arrays, and 2) will be considered a non-constant+  -- expression in the case of arrays and structs, and thus not allowed as the+  -- initialization value for a global variable.+  --+  -- In particular, wrt. (1), for example, the nested array:+  --   [[0, 1], [2, 3]] :: Array 2 (Array 2 Int32)+  --+  -- with explicit casts, will be initialized in C as:+  --   { (int32_t[2]){(int32_t)(0), (int32_t)(1)},+  --     (int32_t[2]){(int32_t)(2), (int32_t)(3)} }+  --+  -- Due to the additional (int32_t[2]) casts, a C compiler will interpret the+  -- whole expression as an array of two int32_t's (as opposed to a nested+  -- array). This can either lead to compile-time errors (if you're lucky) or+  -- incorrect runtime semantics (if you're unlucky).+  Array ty' -> C.InitList $ constArray ty' $ arrayElems val++  -- We use InitArray to initialize a struct because the syntax used for+  -- initializing arrays and structs is compatible. For instance, {1, 2} works+  -- both for initializing an int array of length 2 as well as a struct with+  -- two int fields, although the two expressions are conceptually different+  -- (structs can also be initialized as { .a = 1, .b = 2}.+  Struct _  -> C.InitList $ constStruct (toValues val)+  _         -> C.InitExpr $ constTy ty val++-- | Transform a Copilot Core struct field into a C99 initializer.+constFieldInit :: Value a -> C.InitItem+constFieldInit (Value ty (Field val)) = C.InitItem Nothing $ constInit ty val++-- | Transform a Copilot Struct, based on the struct fields, into a list of C99+-- initializer values.+--+-- 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 <math.h>" in the C99 standard+    isMathFPArgs :: String -> Bool+    isMathFPArgs = flip elem+       [ "acos",   "asin",     "atan",      "atan2",      "cos",    "sin"+       , "tan",    "acosh",    "asinh",     "atanh",      "cosh",   "sinh"+       , "tanh",   "exp",      "exp2",      "expm1",      "frexp",  "ilogb"+       , "ldexp",  "log",      "log10",     "log1p",      "log2",   "logb"+       , "modf",   "scalbn",   "scalbln",   "cbrt",       "fabs",   "hypot"+       , "pow",    "sqrt",     "erf",       "erfc",       "lgamma", "tgamma"+       , "ceil",   "floor",    "nearbyint", "rint",       "lrint",  "llrint"+       , "round",  "lround",   "llround",   "trunc",      "fmod",   "remainder"+       , "remquo", "copysign", "nextafter", "nexttoward", "fdim"+       , "fmax",   "fmin",     "fma"+       ]++-- * Auxiliary functions++-- | True if the type given is a floating point number.+typeIsFloating :: Type a -> Bool+typeIsFloating Float  = True+typeIsFloating Double = True+typeIsFloating _      = False++-- | Auxiliary type used to collect all the declarations of all the variables+-- used in a function to be generated, since variable declarations are always+-- listed first at the top of the function body.+type FunEnv = (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
src/Copilot/Compile/C99/External.hs view
@@ -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)
+ src/Copilot/Compile/C99/Name.hs view
@@ -0,0 +1,61 @@+-- | Naming of variables and functions in C.+module Copilot.Compile.C99.Name+    ( argNames+    , argTempNames+    , exCpyName+    , generatorName+    , generatorOutputArgName+    , guardName+    , indexName+    , streamAccessorName+    , streamName+    )+  where++-- External imports: Copilot+import Copilot.Core (Id)++-- | Turn a stream id into a suitable C variable name.+streamName :: Id -> String+streamName sId = "s" ++ show sId++-- | Turn a stream id into the global varname for indices.+indexName :: Id -> String+indexName sId = streamName sId ++ "_idx"++-- | Turn a stream id into the name of its accessor function+streamAccessorName :: Id -> String+streamAccessorName sId = streamName sId ++ "_get"++-- | Add a postfix for copies of external variables the name.+exCpyName :: String -> String+exCpyName name = name ++ "_cpy"++-- | Turn stream id into name of its generator function.+generatorName :: Id -> String+generatorName sId = streamName sId ++ "_gen"++-- | Turn stream id into name of its output argument array.+generatorOutputArgName :: Id -> String+generatorOutputArgName sId = streamName sId ++ "_output"++-- | Turn the name of a trigger into a guard generator.+guardName :: String -> String+guardName name = name ++ "_guard"++-- | Turn a trigger name into a trigger argument name.+argName :: String -> Int -> String+argName name n = name ++ "_arg" ++ show n++-- | Turn a handler function name into a name for a temporary variable for a+-- handler argument.+argTempName :: String -> Int -> String+argTempName name n = name ++ "_arg_temp" ++ show n++-- | Enumerate all argument names based on trigger name.+argNames :: String -> [String]+argNames base = map (argName base) [0..]++-- | Enumerate all temporary variable names based on handler function name.+argTempNames :: String -> [String]+argTempNames base = map (argTempName base) [0..]
+ src/Copilot/Compile/C99/Representation.hs view
@@ -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
src/Copilot/Compile/C99/Settings.hs view
@@ -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" "."
− src/Copilot/Compile/C99/Settings/Internal.hs 
@@ -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" "."
− src/Copilot/Compile/C99/Translate.hs 
@@ -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
+ src/Copilot/Compile/C99/Type.hs view
@@ -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
− src/Copilot/Compile/C99/Util.hs 
@@ -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
+ tests/Main.hs view
@@ -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+  ]
+ tests/Test/Copilot/Compile/C99.hs view
@@ -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 <stdio.h>"+    , "#include <stdint.h>"+    , "#include <stdbool.h>"+    , "#include <string.h>"+    , "#include <inttypes.h>"+    , "#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