diff --git a/CHANGELOG b/CHANGELOG --- a/CHANGELOG +++ b/CHANGELOG @@ -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) diff --git a/copilot-c99.cabal b/copilot-c99.cabal --- a/copilot-c99.cabal +++ b/copilot-c99.cabal @@ -1,6 +1,6 @@ cabal-version : >= 1.10 name : copilot-c99 -version : 3.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 diff --git a/src/Copilot/Compile/C99/CodeGen.hs b/src/Copilot/Compile/C99/CodeGen.hs --- a/src/Copilot/Compile/C99/CodeGen.hs +++ b/src/Copilot/Compile/C99/CodeGen.hs @@ -1,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 diff --git a/src/Copilot/Compile/C99/Compile.hs b/src/Copilot/Compile/C99/Compile.hs --- a/src/Copilot/Compile/C99/Compile.hs +++ b/src/Copilot/Compile/C99/Compile.hs @@ -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 " , "#include " , "#include " @@ -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) [] diff --git a/src/Copilot/Compile/C99/Error.hs b/src/Copilot/Compile/C99/Error.hs new file mode 100644 --- /dev/null +++ b/src/Copilot/Compile/C99/Error.hs @@ -0,0 +1,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 " diff --git a/src/Copilot/Compile/C99/External.hs b/src/Copilot/Compile/C99/External.hs --- a/src/Copilot/Compile/C99/External.hs +++ b/src/Copilot/Compile/C99/External.hs @@ -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 + _ -> [] diff --git a/src/Copilot/Compile/C99/Translate.hs b/src/Copilot/Compile/C99/Translate.hs --- a/src/Copilot/Compile/C99/Translate.hs +++ b/src/Copilot/Compile/C99/Translate.hs @@ -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' +-- . +transSign :: Type a -> C.Expr -> C.Expr +transSign ty e = positiveCase $ negativeCase e + where + -- If @e@ is positive, return @1@, otherwise fall back to argument. + -- + -- Produces the following code, where @@ is the argument to this + -- function: + -- @ + -- e > 0 ? 1 : + -- @ + positiveCase :: C.Expr -- ^ Value returned if @e@ is not positive. + -> C.Expr + positiveCase = + C.Cond (C.BinaryOp C.GT e (constNumTy ty 0)) (constNumTy ty 1) + + -- If @e@ is negative, return @1@, otherwise fall back to argument. + -- + -- Produces the following code, where @@ is the argument to this + -- function: + -- @ + -- e < 0 ? -1 : + -- @ + negativeCase :: C.Expr -- ^ Value returned if @e@ is not negative. + -> C.Expr + negativeCase = + C.Cond (C.BinaryOp C.LT e (constNumTy ty 0)) (constNumTy ty (-1)) + -- | Transform a Copilot Core literal, based on its value and type, into a C99 -- literal. constty :: Type a -> a -> C.Expr constty ty = case ty of - Bool -> C.LitBool - Int8 -> explicitty ty . C.LitInt . fromIntegral - Int16 -> explicitty ty . C.LitInt . fromIntegral - Int32 -> explicitty ty . C.LitInt . fromIntegral - Int64 -> explicitty ty . C.LitInt . fromIntegral - Word8 -> explicitty ty . C.LitInt . fromIntegral - Word16 -> explicitty ty . C.LitInt . fromIntegral - Word32 -> explicitty ty . C.LitInt . fromIntegral - Word64 -> explicitty ty . C.LitInt . fromIntegral - Float -> explicitty ty . C.LitFloat - Double -> explicitty ty . C.LitDouble - Struct _ -> \v -> C.InitVal (transtypename ty) (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 " in the C99 standard + isMathFPArgs :: String -> Bool + isMathFPArgs = flip elem + [ "acos", "asin", "atan", "atan2", "cos", "sin" + , "tan", "acosh", "asinh", "atanh", "cosh", "sinh" + , "tanh", "exp", "exp2", "expm1", "frexp", "ilogb" + , "ldexp", "log", "log10", "log1p", "log2", "logb" + , "modf", "scalbn", "scalbln", "cbrt", "fabs", "hypot" + , "pow", "sqrt", "erf", "erfc", "lgamma", "tgamma" + , "ceil", "floor", "nearbyint", "rint", "lrint", "llrint" + , "round", "lround", "llround", "trunc", "fmod", "remainder" + , "remquo", "copysign", "nextafter", "nexttoward", "fdim" + , "fmax", "fmin", "fma" + ] + +-- * Auxiliary functions + +-- | True if the type given is a floating point number. +typeIsFloating :: Type a -> Bool +typeIsFloating Float = True +typeIsFloating Double = True +typeIsFloating _ = False diff --git a/src/Copilot/Compile/C99/Util.hs b/src/Copilot/Compile/C99/Util.hs --- a/src/Copilot/Compile/C99/Util.hs +++ b/src/Copilot/Compile/C99/Util.hs @@ -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