copilot-c99 3.8 → 3.9
raw patch · 8 files changed
+490/−232 lines, 8 filesdep ~copilot-corePVP ok
version bump matches the API change (PVP)
Dependency ranges changed: copilot-core
API changes (from Hackage documentation)
Files
- CHANGELOG +7/−0
- copilot-c99.cabal +3/−2
- src/Copilot/Compile/C99/CodeGen.hs +98/−85
- src/Copilot/Compile/C99/Compile.hs +75/−69
- src/Copilot/Compile/C99/Error.hs +20/−0
- src/Copilot/Compile/C99/External.hs +22/−20
- src/Copilot/Compile/C99/Translate.hs +259/−52
- src/Copilot/Compile/C99/Util.hs +6/−4
CHANGELOG view
@@ -1,3 +1,10 @@+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)
copilot-c99.cabal view
@@ -1,6 +1,6 @@ cabal-version : >= 1.10 name : copilot-c99-version : 3.8+version : 3.9 synopsis : A compiler for Copilot targeting C99. description : This package is a back-end from Copilot to C.@@ -50,7 +50,7 @@ , mtl >= 2.2 && < 2.3 , pretty >= 1.1 && < 1.2 - , copilot-core >= 3.8 && < 3.9+ , copilot-core >= 3.9 && < 3.10 , language-c99 >= 0.1.1 && < 0.2 , language-c99-util >= 0.1.1 && < 0.2 , language-c99-simple >= 0.1.1 && < 0.2@@ -58,6 +58,7 @@ exposed-modules : Copilot.Compile.C99 other-modules : Copilot.Compile.C99.Translate+ , Copilot.Compile.C99.Error , Copilot.Compile.C99.Util , Copilot.Compile.C99.CodeGen , Copilot.Compile.C99.External
src/Copilot/Compile/C99/CodeGen.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE GADTs #-}+{-# LANGUAGE GADTs #-} {-# LANGUAGE ScopedTypeVariables #-} -- | High-level translation of Copilot Core into C99.@@ -18,41 +18,47 @@ -- | 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+gendecln name ty = C.FunDecln Nothing cty name []+ where+ cty = C.decay $ transtype ty -- | 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+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 -- | 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 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 name cpyname ty) = decln+ where+ cty = transtype ty+ decln = C.VarDecln (Just C.Static) cty cpyname Nothing -- | Make a C buffer variable and initialise it with the stream buffer. mkbuffdecln :: Id -> Type a -> [a] -> C.Decln-mkbuffdecln sid ty xs = C.VarDecln (Just C.Static) cty name initvals where- name = streamname sid- cty = C.Array (transtype ty) (Just $ C.LitInt $ fromIntegral buffsize)- buffsize = length xs- initvals = Just $ C.InitArray $ map (C.InitExpr . constty ty) xs+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 $ 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 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@@ -68,83 +74,90 @@ -- | 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+ C.FunDef void (cSettingsStepFunctionName cSettings) [] declns stmts+ where - void = C.TypeSpec C.Void- stmts = map mkexcopy exts- ++ map mktriggercheck triggers- ++ tmpassigns- ++ bufferupdates- ++ indexupdates- (declns, tmpassigns, bufferupdates, indexupdates) =- unzip4 $ map mkupdateglobals streams+ void = C.TypeSpec C.Void+ stmts = map mkexcopy exts+ ++ map mktriggercheck triggers+ ++ tmpassigns+ ++ bufferupdates+ ++ indexupdates+ (declns, tmpassigns, bufferupdates, indexupdates) =+ unzip4 $ map mkupdateglobals streams - -- 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 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 - 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+ 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 - bufferupdate = case ty of- Array _ -> C.Expr $ memcpy dest (C.Ident tmp_var) size- 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)+ bufferupdate = case ty of+ Array _ -> C.Expr $ memcpy dest (C.Ident tmp_var) size+ 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) - indexupdate = C.Expr $ index_var C..= (incindex C..% bufflength)- where- bufflength = C.LitInt $ fromIntegral $ length buff- incindex = index_var C..+ C.LitInt 1+ indexupdate = C.Expr $ index_var C..= (incindex C..% bufflength)+ where+ bufflength = C.LitInt $ fromIntegral $ length buff+ incindex = index_var C..+ C.LitInt 1 - tmp_var = streamname sid ++ "_tmp"- buff_var = C.Ident $ streamname sid- index_var = C.Ident $ indexname sid- val = C.Funcall (C.Ident $ generatorname sid) []- cty = transtype ty+ 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 $ tysize ty- _ -> C.Ident cpyname C..= C.Ident name+ -- 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 - -- 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) []+ _ -> C.Ident cpyname C..= 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]+ -- 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) [] + -- 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] -- | 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)+mkstructdecln (Struct x) = C.TypeDecln struct+ where+ struct = C.TypeSpec $ C.StructDecln (Just $ typename x) fields+ fields = map mkfield (toValues x) - mkfield :: Value a -> C.FieldDecln- mkfield (Value ty field) = C.FieldDecln (transtype ty) (fieldname field)+ 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)+mkstructforwdecln (Struct x) = C.TypeDecln struct+ where+ struct = C.TypeSpec $ C.Struct (typename x) -- | List all types of an expression, returns items uniquely. exprtypes :: Typeable a => Expr a -> [UType]@@ -171,7 +184,7 @@ -- 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-+ ++ concatMap triggerexpr triggers+ where+ streamexpr (Stream _ _ expr ty) = UExpr ty expr+ triggerexpr (Trigger _ guard args) = UExpr Bool guard : args
src/Copilot/Compile/C99/Compile.hs view
@@ -39,9 +39,6 @@ = 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>"@@ -72,88 +69,97 @@ -- * 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+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]+ 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+ -- 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+ 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 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 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+ -- 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+ 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+ 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)+ 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+ 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+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]+ 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+ 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+ utypes = nub $ concatMap (\(UExpr _ e) -> exprtypes e) es - -- Make declarations for external variables.- mkexts :: [External] -> [C.Decln]- mkexts = map mkextdecln+ -- 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+ 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) []+ -- 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,20 @@+--------------------------------------------------------------------------------+-- Copyright © 2011 National Institute of Aerospace / Galois, Inc.+--------------------------------------------------------------------------------+{-# LANGUAGE Safe #-}++-- | Custom functions to report error messages to users.+module Copilot.Compile.C99.Error+ ( impossible )+ 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>"
src/Copilot/Compile/C99/External.hs view
@@ -26,27 +26,29 @@ -- 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 streams triggers = streamsexts `extunion` triggersexts+ where+ streamsexts = foldr extunion mempty $ map streamexts streams+ triggersexts = foldr extunion mempty $ map triggerexts 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 = concat $ map 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 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+ _ -> []
src/Copilot/Compile/C99/Translate.hs view
@@ -6,6 +6,7 @@ import Control.Monad.State import Copilot.Core+import Copilot.Compile.C99.Error (impossible) import Copilot.Compile.C99.Util import qualified Language.C99.Simple as C@@ -48,35 +49,41 @@ 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)+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.@@ -90,9 +97,10 @@ 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]+ 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@@ -112,34 +120,161 @@ transop3 op e1 e2 e3 = case op of Mux _ -> C.Cond e1 e2 e3 +-- | Translate @'Abs' e@ in Copilot Core into a C99 expression.+--+-- This function produces a portable implementation of abs in C99 that works+-- for the type given, provided that the output fits in a variable of the same+-- type (which may not be true, for example, for signed integers in the lower+-- end of their type range). If the absolute value is out of range, the+-- behavior is undefined.+--+-- PRE: The type given is a Num type (floating-point number, or a+-- signed/unsigned integer of fixed size).+transAbs :: Type a -> C.Expr -> C.Expr+transAbs ty e+ -- Abs for floats/doubles is called fabs in C99's math.h.+ | typeIsFloating ty+ = funcall (specializeMathFunName ty "fabs") [e]++ -- C99 provides multiple implementations of abs, depending on the type of+ -- the arguments. For integers, it provides C99 abs, labs, and llabs, which+ -- take, respectively, an int, a long int, and a long long int.+ --+ -- However, the code produced by Copilot uses types with fixed width (e.g.,+ -- int16_t), and there is no guarantee that, for example, 32-bit int or+ -- 64-bit int will fit in a C int (only guaranteed to be 16 bits).+ -- Consequently, this function provides a portable version of abs for signed+ -- and unsigned ints implemented using shift and xor. For example, for a+ -- value x of type int32_t, the absolute value is:+ -- (x + (x >> sizeof(int32_t)-1)) ^ (x >> sizeof(int32_t)-1))+ | otherwise+ = (e C..+ (e C..>> tyBitSizeMinus1)) C..^ (e C..>> tyBitSizeMinus1)+ where+ -- Size of an integer type in bits, minus one. It's easier to hard-code+ -- them than to try and generate the right expressions in C using sizeof.+ --+ -- PRE: the type 'ty' is a signed or unsigned integer type.+ tyBitSizeMinus1 :: C.Expr+ tyBitSizeMinus1 = case ty of+ Int8 -> C.LitInt 7+ Int16 -> C.LitInt 15+ Int32 -> C.LitInt 31+ Int64 -> C.LitInt 63+ Word8 -> C.LitInt 7+ Word16 -> C.LitInt 15+ Word32 -> C.LitInt 31+ Word64 -> C.LitInt 63+ _ -> impossible+ "transAbs"+ "copilot-c99"+ "Abs applied to unexpected types."++-- | Translate @'Sign' e@ in Copilot Core into a C99 expression.+--+-- Sign is is translated as @e > 0 ? 1 : (e < 0 ? -1 : e)@, that is:+--+-- 1. If @e@ is positive, return @1@.+--+-- 2. If @e@ is negative, return @-1@.+--+-- 3. Otherwise, return @e@. This handles the case where @e@ is @0@ when the+-- type is an integral type. If the type is a floating-point type, it also+-- handles the cases where @e@ is @-0@ or @NaN@.+--+-- This implementation is modeled after how GHC implements 'signum'+-- <https://gitlab.haskell.org/ghc/ghc/-/blob/aed98ddaf72cc38fb570d8415cac5de9d8888818/libraries/base/GHC/Float.hs#L523-L525 here>.+transSign :: Type a -> C.Expr -> C.Expr+transSign ty e = positiveCase $ negativeCase e+ where+ -- If @e@ is positive, return @1@, otherwise fall back to argument.+ --+ -- Produces the following code, where @<arg>@ is the argument to this+ -- function:+ -- @+ -- e > 0 ? 1 : <arg>+ -- @+ positiveCase :: C.Expr -- ^ Value returned if @e@ is not positive.+ -> C.Expr+ positiveCase =+ C.Cond (C.BinaryOp C.GT e (constNumTy ty 0)) (constNumTy ty 1)++ -- If @e@ is negative, return @1@, otherwise fall back to argument.+ --+ -- Produces the following code, where @<arg>@ is the argument to this+ -- function:+ -- @+ -- e < 0 ? -1 : <arg>+ -- @+ negativeCase :: C.Expr -- ^ Value returned if @e@ is not negative.+ -> C.Expr+ negativeCase =+ C.Cond (C.BinaryOp C.LT e (constNumTy ty 0)) (constNumTy ty (-1))+ -- | Transform a Copilot Core literal, based on its value and type, into a C99 -- literal. constty :: Type a -> a -> C.Expr constty ty = case ty of- Bool -> C.LitBool- Int8 -> explicitty ty . C.LitInt . fromIntegral- Int16 -> explicitty ty . C.LitInt . fromIntegral- Int32 -> explicitty ty . C.LitInt . fromIntegral- Int64 -> explicitty ty . C.LitInt . fromIntegral- Word8 -> explicitty ty . C.LitInt . fromIntegral- Word16 -> explicitty ty . C.LitInt . fromIntegral- Word32 -> explicitty ty . C.LitInt . fromIntegral- Word64 -> explicitty ty . C.LitInt . fromIntegral- Float -> explicitty ty . C.LitFloat- Double -> explicitty ty . C.LitDouble- Struct _ -> \v -> C.InitVal (transtypename ty) (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)+ 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 constfieldinit (toValues v))+ Array ty' -> \v ->+ C.InitVal (transtypename ty) (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+-- | 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.InitArray $ 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}, but language-c99+ -- does not support such syntax and does not provide a specialized+ -- initialization construct for structs).+ Struct _ -> C.InitArray $ map constfieldinit $ toValues val+ _ -> C.InitExpr $ constty ty val +-- | Transform a Copilot Core struct field into a C99 initializer.+constfieldinit :: Value a -> C.Init+constfieldinit (Value ty (Field val)) = constinit ty val++-- | Transform a Copilot Array, based on the element values and their type,+-- into a list of C99 initializer values.+constarray :: Type a -> [a] -> [C.Init]+constarray ty = map (constinit ty)+ -- | Explicitly cast a C99 value to a type. explicitty :: Type a -> C.Expr -> C.Expr explicitty ty = C.Cast (transtypename ty)@@ -158,10 +293,82 @@ 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+ 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++-- Translate a literal number of type @ty@ into a C99 literal.+--+-- PRE: The type of PRE is numeric (integer or floating-point), that+-- is, not boolean, struct or array.+constNumTy :: Type a -> Integer -> C.Expr+constNumTy ty =+ case ty of+ Float -> C.LitFloat . fromInteger+ Double -> C.LitDouble . fromInteger+ _ -> C.LitInt++-- | Provide a specialized function name in C99 for a function given the type+-- of its arguments, and its "family" name.+--+-- C99 provides multiple variants of the same conceptual function, based on the+-- types. Depending on the function, common variants exist for signed/unsigned+-- arguments, long or short types, float or double. The C99 standard uses the+-- same mechanism to name most such functions: the default variant works for+-- double, and there are additional variants for float and long double. For+-- example, the sin function operates on double, while sinf operates on float,+-- and sinl operates on long double.+--+-- This function only knows how to provide specialized names for functions in+-- math.h that provide a default version for a double argument and vary for+-- floats. It won't change the function name given if the variation is based on+-- the return type, if the function is defined elsewhere, or for other types.+specializeMathFunName :: Type a -> String -> String+specializeMathFunName ty s+ -- The following function pattern matches based on the variants available+ -- for a specific function.+ --+ -- Do not assume that a function you need implemented follows the same+ -- standard as others: check whether it is present in the standard.+ | isMathFPArgs s+ , Float <- ty+ = s ++ "f"++ | otherwise+ = s+ where+ -- True if the function family name is part of math.h and follows the+ -- standard rule of providing multiple variants for floating point numbers+ -- based on the type of their arguments.+ --+ -- Note: nan is not in this list because the names of its variants are+ -- determined by the return type.+ --+ -- For details, see:+ -- "B.11 Mathematics <math.h>" in the C99 standard+ isMathFPArgs :: String -> Bool+ isMathFPArgs = flip elem+ [ "acos", "asin", "atan", "atan2", "cos", "sin"+ , "tan", "acosh", "asinh", "atanh", "cosh", "sinh"+ , "tanh", "exp", "exp2", "expm1", "frexp", "ilogb"+ , "ldexp", "log", "log10", "log1p", "log2", "logb"+ , "modf", "scalbn", "scalbln", "cbrt", "fabs", "hypot"+ , "pow", "sqrt", "erf", "erfc", "lgamma", "tgamma"+ , "ceil", "floor", "nearbyint", "rint", "lrint", "llrint"+ , "round", "lround", "llround", "trunc", "fmod", "remainder"+ , "remquo", "copysign", "nextafter", "nexttoward", "fdim"+ , "fmax", "fmin", "fma"+ ]++-- * Auxiliary functions++-- | True if the type given is a floating point number.+typeIsFloating :: Type a -> Bool+typeIsFloating Float = True+typeIsFloating Double = True+typeIsFloating _ = False
src/Copilot/Compile/C99/Util.hs view
@@ -17,13 +17,15 @@ -- | 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..]+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+names ds = map match ds+ where+ match (C.VarDecln _ _ name _) = name -- | Turn a stream id into a suitable C variable name. streamname :: Id -> String