ivory-backend-c 0.1.0.3 → 0.1.0.4
raw patch · 7 files changed
+265/−255 lines, 7 filesdep ~basedep ~ivorydep ~ivory-artifact
Dependency ranges changed: base, ivory, ivory-artifact, ivory-opts, language-c-quote, template-haskell
Files
- ivory-backend-c.cabal +6/−6
- runtime/ivory.h +2/−2
- src/Ivory/Compile/C/CmdlineFrontend.hs +41/−63
- src/Ivory/Compile/C/CmdlineFrontend/Options.hs +35/−38
- src/Ivory/Compile/C/Gen.hs +114/−98
- src/Ivory/Compile/C/Modules.hs +36/−33
- src/Ivory/Compile/C/Types.hs +31/−15
ivory-backend-c.cabal view
@@ -2,13 +2,13 @@ -- see http://haskell.org/cabal/users-guide/ name: ivory-backend-c-version: 0.1.0.3+version: 0.1.0.4 author: Galois, Inc. maintainer: leepike@galois.com category: Language synopsis: Ivory C backend. description: Ivory compiler, to a subset of C99.-homepage: http://smaccmpilot.org/languages/ivory-introduction.html+homepage: http://ivorylang.org build-type: Simple cabal-version: >= 1.10 data-files: runtime/ivory.h,@@ -19,7 +19,7 @@ source-repository this type: git location: https://github.com/GaloisInc/ivory- tag: hackage-backend-0103+ tag: hackage-0.1.0.4 library exposed-modules: Ivory.Compile.C,@@ -31,13 +31,13 @@ Ivory.Compile.C.CmdlineFrontend.Options other-modules: Paths_ivory_backend_c - build-depends: base >= 4.6 && < 5,+ build-depends: base >= 4.7 && < 5, base-compat,- language-c-quote >= 0.10.0,+ language-c-quote >= 0.11.0.0, srcloc, mainland-pretty >= 0.2.5, monadLib >= 3.7,- template-haskell >= 2.8,+ template-haskell >= 2.8 && <2.11, bytestring >= 0.10, directory, filepath,
runtime/ivory.h view
@@ -9,8 +9,8 @@ #include "ivory_asserts.h" #include "ivory_templates.h" -#define FOREVER true-#define FOREVER_INC+#define IFOREVER true+#define IFOREVER_INC // ----------------------------------------
src/Ivory/Compile/C/CmdlineFrontend.hs view
@@ -1,4 +1,3 @@- module Ivory.Compile.C.CmdlineFrontend ( compile , compileWith@@ -10,32 +9,33 @@ , outputCompiler ) where -import Data.List (nub, (\\), intercalate)-import qualified Paths_ivory_backend_c as P-import qualified Ivory.Compile.C as C+import Data.List (intercalate, nub,+ (\\))+import qualified Ivory.Compile.C as C+import qualified Paths_ivory_backend_c as P import Ivory.Compile.C.CmdlineFrontend.Options -import Ivory.Language import Ivory.Artifact-import Ivory.Language.Syntax.AST as I-import qualified Ivory.Opts.BitShift as O-import qualified Ivory.Opts.ConstFold as O-import qualified Ivory.Opts.CSE as O-import qualified Ivory.Opts.Overflow as O-import qualified Ivory.Opts.DivZero as O-import qualified Ivory.Opts.Index as O-import qualified Ivory.Opts.FP as O-import qualified Ivory.Opts.SanityCheck as S-import qualified Ivory.Opts.TypeCheck as T+import Ivory.Language+import Ivory.Language.Syntax.AST as I+import qualified Ivory.Opts.BitShift as O+import qualified Ivory.Opts.ConstFold as O+import qualified Ivory.Opts.CSE as O+import qualified Ivory.Opts.DivZero as O+import qualified Ivory.Opts.FP as O+import qualified Ivory.Opts.Index as O+import qualified Ivory.Opts.Overflow as O+import qualified Ivory.Opts.SanityCheck as S+import qualified Ivory.Opts.TypeCheck as T -import Data.Maybe (mapMaybe, catMaybes)-import Control.Monad (when)-import Data.List (foldl')-import System.Directory (createDirectoryIfMissing)-import System.Environment (getArgs)-import System.FilePath (addExtension,(</>))+import Control.Monad (when)+import Data.List (foldl')+import Data.Maybe (catMaybes, mapMaybe)+import System.Directory (createDirectoryIfMissing)+import System.Environment (getArgs)+import System.FilePath (addExtension, (</>)) -- Code Generation Front End --------------------------------------------------- @@ -51,9 +51,8 @@ runCompiler :: [Module] -> [Located Artifact] -> Opts -> IO () runCompiler ms as os = runCompilerWith ms as os --- | Main compile function plus domain-specific type-checking that can't be--- embedded in the Haskell type-system. Type-checker also emits warnings.-runCompilerWith ::[Module] -> [Located Artifact] -> Opts -> IO ()+-- | Main compile function.+runCompilerWith :: [Module] -> [Located Artifact] -> Opts -> IO () runCompilerWith modules artifacts opts = do cmodules <- compileUnits modules opts if outProcSyms opts@@ -80,7 +79,9 @@ createDirectoryIfMissing True rootdir createDirectoryIfMissing True srcdir createDirectoryIfMissing True incldir- let artifacts = runtimeHeaders ++ user_artifacts+ let oh h = Incl (artifactFile h (return h)) : user_artifacts+ let user_artifacts' = maybe user_artifacts oh (otherHdr opts)+ let artifacts = runtimeHeaders ++ user_artifacts' warnCollisions cmodules artifacts rootdir srcdir incldir mapM_ (output srcdir ".c" renderSource) cmodules mapM_ (output incldir ".h" renderHeader) cmodules@@ -119,51 +120,28 @@ -- | Compile, type-check, and optimize modules, but don't generate C files. compileUnits ::[Module] -> Opts -> IO [C.CompileUnits] compileUnits modules opts = do- let (bs, msgs) = concatRes (map tcMod modules)- putStrLn msgs- when (scErrors opts) $ do- let (bs', msgs') = concatRes (map scMod modules)- when bs' $ do- putStrLn msgs'- error "Sanity-check failed!"- when (tcErrors opts && bs) (error "There were type-checking errors.")- return (mkCUnits modules opts)- where- concatRes :: [(Bool, String)] -> (Bool, String)- concatRes r = let (bs, strs) = unzip r in- (or bs, concat strs) - scMod :: I.Module -> (Bool, String)- scMod m = (S.existErrors res, S.render msg)- where- res = S.sanityCheck modules m- msg = S.showErrors (I.modName m) res-- tcMod :: I.Module -> (Bool, String)- tcMod m = concatRes reses-- where- showWarnings = tcWarnings opts-- allProcs vs = I.public vs ++ I.private vs+ when (tcErrors opts) $ do+ let ts = map T.typeCheck modules+ let anyTs = or (map T.existErrors ts)+ let b = tcWarnings opts+ mapM_ (T.showTyChkModule b) ts+ when anyTs (error "Type-checking failed!") - reses :: [(Bool, String)]- reses = map tcProc (allProcs (I.modProcs m))+ when (scErrors opts) $ do+ let ds = S.dupDefs modules+ S.showDupDefs ds+ let ss = S.sanityCheck modules+ mapM_ S.showSanityChkModule ss+ let anySs = or (map S.existErrors ss)+ when anySs (error "Sanity-check failed!") - tcProc :: I.Proc -> (Bool, String)- tcProc p = ( T.existErrors tc- , errs ++ if showWarnings then warnings else []- )- where- tc = T.typeCheck p- res f = unlines $ f (I.procSym p) tc- warnings = res T.showWarnings- errs = res T.showErrors+ return (mkCUnits modules opts) mkCUnits :: [Module] -> Opts -> [C.CompileUnits] mkCUnits modules opts = cmodules where- cmodules = map C.compileModule optModules+ cmodules = map (C.compileModule (otherHdr opts)) optModules optModules = map (C.runOpt passes) modules cfPass = mkPass constFold O.constFold
src/Ivory/Compile/C/CmdlineFrontend/Options.hs view
@@ -1,13 +1,13 @@ module Ivory.Compile.C.CmdlineFrontend.Options where -import Prelude ()-import Prelude.Compat+import Prelude ()+import Prelude.Compat -import System.Console.GetOpt- (ArgOrder(Permute),OptDescr(..),ArgDescr(..),getOpt,usageInfo)+import System.Console.GetOpt (ArgDescr (..), ArgOrder (Permute),+ OptDescr (..), getOpt, usageInfo) -import System.Environment (getProgName)-import System.Exit (exitFailure,exitSuccess)+import System.Environment (getProgName)+import System.Exit (exitFailure, exitSuccess) -- Option Parsing -------------------------------------------------------------- @@ -45,34 +45,36 @@ -- Command Line Options -------------------------------------------------------- data Opts = Opts- { outDir :: Maybe FilePath+ { outDir :: Maybe FilePath -- ^ output directory for all files (or standard out).- , outHdrDir :: Maybe FilePath+ , outHdrDir :: Maybe FilePath -- ^ if set, output directory for headers. Otherwise, use @outDir@.- , outArtDir :: Maybe FilePath+ , outArtDir :: Maybe FilePath -- ^ if set, output directory for artifacts. Otherwise, use @outDir@.+ , otherHdr :: Maybe String+ -- ^ In special circumstances, an implementation may not fully implement libc (e.g., if `math.h` does not include `isnan`). In these cases, another header can be added to every Ivory-generated source using the flag. -- optimization passes- , constFold :: Bool- , overflow :: Bool- , divZero :: Bool- , ixCheck :: Bool- , fpCheck :: Bool- , outProcSyms :: Bool+ , constFold :: Bool+ , overflow :: Bool+ , divZero :: Bool+ , ixCheck :: Bool+ , fpCheck :: Bool+ , outProcSyms :: Bool , bitShiftCheck :: Bool -- CFG stuff- , cfg :: Bool- , cfgDotDir :: FilePath- , cfgProc :: [String]+ , cfg :: Bool+ , cfgDotDir :: FilePath+ , cfgProc :: [String] -- debugging- , verbose :: Bool- , srcLocs :: Bool+ , verbose :: Bool+ , srcLocs :: Bool -- Typechecking- , tcWarnings :: Bool- , tcErrors :: Bool- , scErrors :: Bool+ , tcWarnings :: Bool+ , tcErrors :: Bool+ , scErrors :: Bool - , help :: Bool+ , help :: Bool } deriving (Show) initialOpts :: Opts@@ -80,6 +82,7 @@ { outDir = Nothing , outHdrDir = Nothing , outArtDir = Nothing+ , otherHdr = Nothing -- optimization/safety passes , constFold = False@@ -97,7 +100,7 @@ -- debugging , verbose = False , srcLocs = False- , tcWarnings = False+ , tcWarnings = True , tcErrors = True , scErrors = True , help = False@@ -115,6 +118,9 @@ setArtDir :: String -> OptParser Opts setArtDir str = success (\opts -> opts { outArtDir = Just str }) +setOtherHdr :: String -> OptParser Opts+setOtherHdr h = success (\opts -> opts { otherHdr = Just h })+ setConstFold :: OptParser Opts setConstFold = success (\opts -> opts { constFold = True }) @@ -167,10 +173,12 @@ options = [ Option "" ["std-out"] (NoArg setStdOut) "print to stdout only"- , Option "" ["src-dir"] (ReqArg setOutDir "PATH") "output directory for source files"-+ , Option "" ["hdr-dir"] (ReqArg setHdrDir "PATH")+ "output directory for header files"+ , Option "" ["other-hdr"] (ReqArg setOtherHdr "HEADER")+ "Additional headers to include in generated files" , Option "" ["const-fold"] (NoArg setConstFold) "enable the constant folding pass" , Option "" ["overflow"] (NoArg setOverflow)@@ -183,39 +191,28 @@ "generate assertions checking for NaN and Infinitiy." , Option "" ["bitshift-check"] (NoArg setBitShiftCheck) "generate assertions checking for bit-shift overflow."- , Option "" ["out-proc-syms"] (NoArg setProcSyms) "dump out the modules' function symbols"- , Option "" ["cfg"] (NoArg setCfg) "Output control-flow graph and max stack usage."- , Option "" ["cfg-dot-dir"] (ReqArg setCfgDotDir "PATH") "output directory for CFG Graphviz file" , Option "" ["cfg-proc"] (ReqArg addCfgProc "NAME") "entry function(s) for CFG computation."- , Option "" ["verbose"] (NoArg setVerbose) "verbose debugging output"- , Option "" ["srclocs"] (NoArg setSrcLocs) "output source locations from the Ivory code"- , Option "" ["tc-warnings"] (NoArg setWarnings) "show type-check warnings"- , Option "" ["tc-errors"] (NoArg $ setErrors True) "Abort on type-check errors (default)"- , Option "" ["no-tc-errors"] (NoArg $ setErrors False) "Treat type-check errors as warnings"- , Option "" ["sanity-check"] (NoArg $ setSanityCheck True) "Enable sanity-check"- , Option "" ["no-sanity-check"] (NoArg $ setSanityCheck False) "Disable sanity-check"- , Option "h" ["help"] (NoArg setHelp) "display this message" ]
src/Ivory/Compile/C/Gen.hs view
@@ -1,26 +1,26 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE PackageImports #-}-{-# LANGUAGE QuasiQuotes #-}-{-# LANGUAGE CPP #-}+{-# LANGUAGE QuasiQuotes #-} -- | Ivory backend targeting language-c-quote. module Ivory.Compile.C.Gen where -import qualified "language-c-quote" Language.C.Syntax as C-import Language.C.Quote.GCC+import Language.C.Quote.GCC+import qualified "language-c-quote" Language.C.Syntax as C -import qualified Ivory.Language.Array as I-import qualified Ivory.Language.Syntax as I-import Ivory.Language.Syntax.Concrete.Pretty-import qualified Ivory.Language.Proc as P+import qualified Ivory.Language.Array as I+import qualified Ivory.Language.Proc as P+import qualified Ivory.Language.Syntax as I+import Ivory.Language.Syntax.Concrete.Pretty -import Ivory.Compile.C.Types-import Ivory.Compile.C.Prop+import Ivory.Compile.C.Prop+import Ivory.Compile.C.Types -import Prelude hiding (exp, abs, signum)-import Data.List (foldl')+import Data.List (foldl')+import Prelude hiding (abs, exp, signum) -import Data.Loc (noLoc)+import Data.Loc (noLoc) data Visibility = Public | Private deriving (Show, Eq) @@ -135,55 +135,44 @@ -------------------------------------------------------------------------------- -- Types --- | Type conversion outside of an casting context. This converts arrays to--- arrays, and carrays to pointers.-toType :: I.Type -> C.Type-toType = toTypeCxt arrIxTy- where- -- Invariant: ty is wrapped in a Ref, ConstRef, or Ptr.- arrIxTy t = case t of- I.TyArr len t'- -> [cty| $ty:(toTypeCxt arrIxTy t')[$uint:len] |]- I.TyCArray t'- -> [cty| $ty:(toTypeCxt arrIxTy t') * |]- _ -> [cty| $ty:(toTypeCxt arrIxTy t ) * |]+-- | Make C type, and decay array types into pointers (e.g., `x[2][3]` decays+-- into `(*x)[3]`).+toTypeDecay :: I.Type -> C.Type+toTypeDecay = toType' True --- | Type conversion in the context of a cast, converting all arrays/carrays to--- pointers.-toTypeCast :: I.Type -> C.Type-toTypeCast = toTypeCxt arrIxTy- where- -- Invariant: ty is wrapped in a Ref, ConstRef, or Ptr.- arrIxTy t = case t of- I.TyArr _len t'- -> [cty| $ty:(toTypeCxt arrIxTy t') * |]- I.TyCArray t'- -> [cty| $ty:(toTypeCxt arrIxTy t') * |]- _ -> [cty| $ty:(toTypeCxt arrIxTy t ) * |]+-- | Make C type, but don't decay array types (default).+toType :: I.Type -> C.Type+toType = toType' False -- | C type conversion, with a special case for references and pointers.-toTypeCxt :: (I.Type -> C.Type) -> I.Type -> C.Type-toTypeCxt arrCase = convert+toType' :: Bool -> I.Type -> C.Type+toType' b ty = case ty of+ I.TyVoid -> [cty| void |]+ I.TyChar -> [cty| char |]+ I.TyInt i -> intSize i+ I.TyWord w -> wordSize w+ I.TyIndex _ -> toType I.ixRep+ I.TyBool -> [cty| typename bool |]+ I.TyFloat -> [cty| float |]+ I.TyDouble -> [cty| double |]+ I.TyStruct nm -> [cty| struct $id:nm |]+ I.TyConstRef t -> [cty| const $ty:(arrCase t) |]+ I.TyCArray t -> [cty| $ty:(toType t) * |]+ I.TyArr len t -> [cty| $ty:(toType t)[$uint:len] |]+ I.TyProc retTy argTys ->+ [cty| $ty:(toType retTy) (*)+ ($params:(map (toParam . toType) argTys)) |]+ I.TyOpaque -> error "Opaque type is not implementable."+ I.TyRef t -> arrCase t+ I.TyPtr t -> arrCase t where- convert ty = case ty of- I.TyVoid -> [cty| void |]- I.TyChar -> [cty| char |]- I.TyInt i -> intSize i- I.TyWord w -> wordSize w- I.TyIndex _ -> convert I.ixRep- I.TyBool -> [cty| typename bool |]- I.TyFloat -> [cty| float |]- I.TyDouble -> [cty| double |]- I.TyStruct nm -> [cty| struct $id:nm |]- I.TyConstRef t -> [cty| const $ty:(arrCase t) |]- I.TyRef t -> arrCase t- I.TyPtr t -> arrCase t- I.TyCArray t -> [cty| $ty:(convert t) * |]- I.TyArr len t -> [cty| $ty:(convert t)[$uint:len] |]- I.TyProc retTy argTys ->- [cty| $ty:(convert retTy) (*)- ($params:(map (toParam . convert) argTys)) |]- I.TyOpaque -> error "Opaque type is not implementable."+ arrCase t = case t of+ I.TyArr len t'+ -> if b then [cty| $ty:(toType t') * |]+ else [cty| $ty:(toType t')[$uint:len] |]+ I.TyCArray t'+ -> [cty| $ty:(toType t') * |]+ _ -> [cty| $ty:(toType t) * |] intSize :: I.IntSize -> C.Type intSize I.Int8 = [cty| typename int8_t |]@@ -219,10 +208,12 @@ let toBody' = toBody ens in case stmt of -- t is the ref type.- I.Assign t v exp ->- [C.BlockDecl [cdecl| $ty:(toTypeCast t) $id:(toVar v)+ I.Assign t v exp+ ->+ [C.BlockDecl [cdecl| $ty:(toTypeDecay t) $id:(toVar v) = $exp:(toExpr t exp); |]]- I.IfTE exp blk0 blk1 ->+ I.IfTE exp blk0 blk1+ -> let ifBd = concatMap toBody' blk0 in let elseBd = concatMap toBody' blk1 in if null elseBd@@ -231,23 +222,33 @@ else [C.BlockStm [cstm| if($exp:(toExpr I.TyBool exp)) { $items:ifBd } else { $items:elseBd } |]]- I.Return exp ->+ I.Return exp+ -> map (toEnsure $ I.tValue exp) ens ++ [C.BlockStm [cstm| return $exp:(typedRet exp); |]]- I.ReturnVoid -> [C.BlockStm [cstm| return; |]]+ I.ReturnVoid+ -> [C.BlockStm [cstm| return; |]] -- t is the referenced type. Should only be able to deref a stored value. -- We replicate some of the type deconstruction in parsing expressions to -- optimize away *& constructions on dereferncing structs and indexes into -- arrays.- I.Deref t var exp -> [C.BlockDecl- [cdecl| $ty:(toType t) $id:(toVar var) = $exp:(derefExp (toExpr (I.TyRef t) exp)); |]]+ I.Deref t var exp+ ->+ [C.BlockDecl [cdecl| $ty:(toType t) $id:(toVar var) =+ $exp:(derefExp (toExpr (I.TyRef t) exp)); |]] - I.Local t var inits -> [C.BlockDecl- [cdecl| $ty:(toType t) $id:(toVar var)- = $init:(toInit inits); |]]+ I.Local t var inits+ -> [C.BlockDecl $+ case inits of+ I.InitStruct []+ -> [cdecl| $ty:(toType t) $id:(toVar var); |]+ _ -> [cdecl| $ty:(toType t) $id:(toVar var)+ = $init:(toInit inits); |]+ ] -- Can't do a static check since we have local let bindings.- I.RefCopy t vto vfrom ->+ I.RefCopy t vto vfrom+ -> [C.BlockStm $ case t of I.TyArr{} -> [cstm| if( $exp:toRef != $exp:fromRef) {@@ -260,22 +261,32 @@ toRef = toExpr (I.TyRef t) vto fromRef = toExpr (I.TyRef t) vfrom + I.RefZero t ref+ ->+ [C.BlockStm [cstm| memset( $exp:(toExpr (I.TyRef t) ref), 0x0,+ sizeof($ty:(toType t)) ); |] ]+ -- Should only be a reference (not a pointer).- I.AllocRef t l r -> [C.BlockDecl- [cdecl| $ty:(toType (I.TyRef rty)) $id:(toVar l) = $exp:rhs; |]]+ I.AllocRef t l r+ -> [C.BlockDecl+ [cdecl| $ty:(toTypeDecay (I.TyRef t)) $id:(toVar l) = $exp:rhs; |]] where name = toName r- (rhs,rty) = case t of- I.TyArr _ t' -> ([cexp| $id:name |], t')- I.TyCArray t' -> ([cexp| $id:name |], t')- _ -> ([cexp| &($id:name) |], t)- I.Assert exp -> [C.BlockStm+ rhs = case t of+ I.TyArr _ _ -> [cexp| $id:name |]+ I.TyCArray _ -> [cexp| $id:name |]+ _ -> [cexp| &($id:name) |]+ I.Assert exp+ -> [C.BlockStm [cstm| ASSERTS($exp:(toExpr I.TyBool exp)); |]]- I.CompilerAssert exp -> [C.BlockStm+ I.CompilerAssert exp+ -> [C.BlockStm [cstm| COMPILER_ASSERTS($exp:(toExpr I.TyBool exp)); |]]- I.Assume exp -> [C.BlockStm+ I.Assume exp+ -> [C.BlockStm [cstm| ASSUMES($exp:(toExpr I.TyBool exp)); |]]- I.Call t mVar sym args ->+ I.Call t mVar sym args+ -> case mVar of Nothing -> -- Just call the fuction. [C.BlockStm [cstm| $id:(toName sym)($args:(map go args)); |]]@@ -288,7 +299,8 @@ , I.tValue = v } = toExpr t' v -- Assume that ty is a signed and sufficiently big (int).- I.Loop _ var start incr blk ->+ I.Loop _ var start incr blk+ -> let loopBd = concatMap toBody' blk in [C.BlockStm [cstm| for( $ty:(toType ty) $id:(toVar var) = $exp:(toExpr ty start);@@ -306,23 +318,27 @@ ( [cexp| $id:ix >= $exp:(toExpr ty to) |] , [cexp| $id:ix-- |] ) - I.Forever blk ->+ I.Forever blk+ -> let foreverBd = concatMap toBody' blk foreverDecl = C.BlockDecl [cdecl| int forever_loop __attribute__((unused)); |] loop = C.BlockStm [cstm| for( forever_loop = 0- ; FOREVER- ; FOREVER_INC ) { $items:foreverBd } |]+ ; IFOREVER+ ; IFOREVER_INC ) { $items:foreverBd } |] decAndLoop = [ foreverDecl, loop ] in [ C.BlockStm [cstm| { $items:decAndLoop } |] ] - I.Break -> [C.BlockStm [cstm| break; |]]- I.Store t ptr exp -> [C.BlockStm+ I.Break+ -> [C.BlockStm [cstm| break; |]]+ I.Store t ptr exp+ -> [C.BlockStm [cstm| $exp:(derefExp (toExpr (I.TyRef t) ptr)) = $exp:(toExpr t exp); |]]-- I.Comment (I.UserComment c) -> [C.BlockStm+ I.Comment (I.UserComment c)+ -> [C.BlockStm [cstm| $comment:("/* " ++ c ++ " */"); |]]- I.Comment (I.SourcePos src) -> [C.BlockStm+ I.Comment (I.SourcePos src)+ -> [C.BlockStm [cstm| $comment:("/* " ++ prettyPrint (pretty src) ++ " */"); |]] -- | Return statement. typedRet :: I.Typed I.Expr -> C.Exp@@ -334,10 +350,10 @@ toInit :: I.Init -> C.Initializer toInit i = case i of- I.InitZero -> [cinit|{$inits:([])}|] -- {}- I.InitExpr ty e -> [cinit|$exp:(toExpr ty e)|]- I.InitArray is -> [cinit|{$inits:([ toInit j | j <- is ])}|]- I.InitStruct fs ->+ I.InitZero -> [cinit|{$inits:([])}|] -- {}+ I.InitExpr ty e -> [cinit|$exp:(toExpr ty e)|]+ I.InitArray is _ -> [cinit|{$inits:([ toInit j | j <- is ])}|]+ I.InitStruct fs -> C.CompoundInitializer [ (Just (fieldDes f), toInit j) | (f,j) <- fs ] noLoc fieldDes :: String -> C.Designation@@ -361,7 +377,7 @@ toExpr t (I.ExpLit lit) = case lit of -- XXX hack: should make type-correct literals.- I.LitInteger i -> [cexp| ($ty:(toTypeCast t))$id:fromInt |]+ I.LitInteger i -> [cexp| ($ty:(toType t))$id:fromInt |] where fromInt = case t of I.TyWord _ -> show i ++ "U" I.TyInt _ -> show i@@ -378,7 +394,7 @@ I.LitDouble d -> [cexp| $id:(show d) |] ---------------------------------------- toExpr t (I.ExpOp op args) =- [cexp| ($ty:(toTypeCast t)) $exp:(toExpOp t op args) |]+ [cexp| ($ty:(toTypeDecay t)) $exp:(toExpOp t op args) |] ---------------------------------------- toExpr _ (I.ExpSym sym) = [cexp| $id:sym |] ----------------------------------------@@ -405,7 +421,7 @@ [cexp| ($exp:(toExpr (constr at) a) [$exp:(toExpr ti i)]) |] ---------------------------------------- toExpr tTo (I.ExpSafeCast tFrom e) =- [cexp| ($ty:(toTypeCast tTo))$exp:(toExpr tFrom e) |]+ [cexp| ($ty:(toTypeDecay tTo))$exp:(toExpr tFrom e) |] ---------------------------------------- toExpr _ (I.ExpToIx e maxSz) = [cexp| $exp:(toExpr I.ixRep e ) % $exp:maxSz |]@@ -448,7 +464,7 @@ _ -> err err = error $ "unexpected type " ++ show ty ++ " in ExpMaxMin." -----------------------------------------toExpr ty (I.ExpSizeOf ty') = [cexp| ($ty:(toTypeCast ty)) sizeof($ty:(toType ty')) |]+toExpr ty (I.ExpSizeOf ty') = [cexp| ($ty:(toTypeDecay ty)) sizeof($ty:(toType ty')) |] ---------------------------------------- exp0 :: [C.Exp] -> C.Exp@@ -536,10 +552,10 @@ -- float operations -- XXX this needs to add a dependency on <math.h> I.ExpIsNan ety -> let xs = mkArgs ety args in- [cexp| ($ty:(toTypeCast I.TyBool)) (isnan($exp:(exp0 xs))) |]+ [cexp| ($ty:(toTypeDecay I.TyBool)) (isnan($exp:(exp0 xs))) |] -- isinf returns -1 for negative infinity and 1 for positive infinity. I.ExpIsInf ety -> let xs = mkArgs ety args in- [cexp| ($ty:(toTypeCast I.TyBool)) (isinf($exp:(exp0 xs))) |]+ [cexp| ($ty:(toTypeDecay I.TyBool)) (isinf($exp:(exp0 xs))) |] I.ExpRoundF -> floatingUnary ty "round" args I.ExpCeilF -> floatingUnary ty "ceil" args I.ExpFloorF -> floatingUnary ty "floor" args
src/Ivory/Compile/C/Modules.hs view
@@ -1,26 +1,26 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE QuasiQuotes #-}-{-# LANGUAGE CPP #-} module Ivory.Compile.C.Modules where -import Paths_ivory_backend_c (version)+import Paths_ivory_backend_c (version) -import Prelude ()-import Prelude.Compat+import Prelude ()+import Prelude.Compat -import Text.PrettyPrint.Mainland+import Text.PrettyPrint.Mainland import qualified Ivory.Language.Syntax.AST as I -import Ivory.Compile.C.Gen-import Ivory.Compile.C.Types+import Ivory.Compile.C.Gen+import Ivory.Compile.C.Types -import Data.Char (toUpper)-import Data.Version (showVersion)-import qualified Data.Set as S-import Control.Monad (unless)-import System.FilePath.Posix ((<.>)) -- Always use posix convention in C code-import MonadLib (put,runM)+import Control.Monad (unless, when)+import Data.Char (toUpper)+import Data.Maybe (fromJust, isJust)+import Data.Version (showVersion)+import MonadLib (put, runM)+import System.FilePath.Posix ((<.>)) -------------------------------------------------------------------------------- @@ -32,7 +32,7 @@ where lbl l = "// module " ++ unitName m ++ " " ++ l ++ ":\n" mk _ (_,[]) = []- mk str (incls,units) = str : pp (map includeDef (S.toList incls) ++ units)+ mk str (incls,units) = str : pp (mkDefs (incls, units)) pp = map (pretty maxWidth . ppr) --------------------------------------------------------------------------------@@ -52,13 +52,13 @@ guardedHeader = stack [ topComments , topGuard , topExternC- , ppr (defs s)+ , ppr (mkDefs s) , botExternC , botGuard ] topGuard = text "#ifndef" <+> guardName </> text "#define" <+> guardName- botGuard = text "#endif" <+> text "/*" <+> guardName <+> text "*/"+ botGuard = text "#endif" <+> text "/*" <+> guardName <+> text "*/\n" unitname' = map (\c -> if c == '-' then '_' else c) unitname guardName = text "__" <> text (toUpper <$> unitname') <> text "_H__" topExternC = stack $ text <$> [ "#ifdef __cplusplus"@@ -67,14 +67,12 @@ botExternC = stack $ text <$> [ "#ifdef __cplusplus" , "}" , "#endif"]- defs (incls,us) = map includeDef (S.toList incls) ++ us renderSrc :: (Includes, Sources) -> String renderSrc s = displayS (render maxWidth srcdoc) "" where- srcdoc = topComments </> out- defs (incls,us) = map includeDef (S.toList incls) ++ us- out = stack $ punctuate line $ map ppr $ defs s+ srcdoc = topComments </> out </> text ""+ out = stack $ punctuate line $ map ppr $ mkDefs s -------------------------------------------------------------------------------- @@ -89,17 +87,17 @@ -------------------------------------------------------------------------------- -- | Compile a module.-compileModule :: I.Module -> CompileUnits-compileModule I.Module { I.modName = nm- , I.modDepends = deps- , I.modHeaders = hdrs- , I.modImports = imports- , I.modExterns = externs- , I.modProcs = procs- , I.modStructs = structs- , I.modAreas = areas- , I.modAreaImports = ais- }+compileModule :: Maybe String -> I.Module -> CompileUnits+compileModule hdr I.Module { I.modName = nm+ , I.modDepends = deps+ , I.modHeaders = hdrs+ , I.modImports = imports+ , I.modExterns = externs+ , I.modProcs = procs+ , I.modStructs = structs+ , I.modAreas = areas+ , I.modAreaImports = ais+ } = CompileUnits { unitName = nm , sources = sources res@@ -119,9 +117,11 @@ comp0 :: Compile comp0 = do putHdrInc (LocalInclude "ivory.h")+ when (isJust hdr)+ (putHdrInc (LocalInclude (fromJust hdr))) -- module names don't have a .h on the end- mapM_ (putHdrInc . LocalInclude . ((<.> "h"))) (S.toList deps)- mapM_ (putHdrInc . LocalInclude) (S.toList hdrs)+ mapM_ (putHdrInc . LocalInclude . ((<.> "h"))) deps+ mapM_ (putHdrInc . LocalInclude) hdrs mapM_ (compileStruct Public) (I.public structs) mapM_ (compileStruct Private) (I.private structs) mapM_ fromImport imports@@ -162,3 +162,6 @@ -- generated C more readable. maxWidth :: Int maxWidth = 400++mkDefs :: ([Include], Sources) -> Sources+mkDefs (incls, defs) = map includeDef incls ++ defs
src/Ivory/Compile/C/Types.hs view
@@ -1,18 +1,19 @@-{-# LANGUAGE PackageImports #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE PackageImports #-}+{-# LANGUAGE QuasiQuotes #-} module Ivory.Compile.C.Types where -import Prelude ()-import Prelude.Compat+import Prelude ()+import Prelude.Compat -import Language.C.Quote.GCC-import qualified "language-c-quote" Language.C.Syntax as C+import Data.List (nub) -import MonadLib (WriterT,Id,put)-import qualified Data.Set as S+import Language.C.Quote.GCC+import qualified "language-c-quote" Language.C.Syntax as C +import MonadLib (Id, WriterT, put, runM)+ -------------------------------------------------------------------------------- data Include@@ -25,7 +26,7 @@ SysInclude file -> [cedecl| $esc:("#include <" ++ file ++ ">") |] LocalInclude file -> [cedecl| $esc:("#include \"" ++ file ++ "\"") |] -type Includes = S.Set Include+type Includes = [Include] type Sources = [C.Definition] data CompileUnits = CompileUnits@@ -38,8 +39,10 @@ mempty = CompileUnits mempty mempty mempty (CompileUnits n0 s0 h0) `mappend` (CompileUnits n1 s1 h1) = CompileUnits (n0 `mappend` n1)- (s0 `mappend` s1)- (h0 `mappend` h1)+ (go (s0 `mappend` s1))+ (go (h0 `mappend` h1))+ where+ go (i,s) = (nub i, nub s) -------------------------------------------------------------------------------- @@ -49,18 +52,31 @@ type Compile = CompileM () +-- | Run the monad and nub the lists. (We have lists here rather than sets since+-- we do not want to reorder headers. Sometimes a user wants headers to be+-- included in exactly the correct order, since in some (bad!) build+-- environments, includes depend on previous includes and aren't+-- self-sufficient.+runResult :: CompileM a -> CompileUnits+runResult c =+ let cu = snd (runM (unCompile c)) in+ let go (i,s) = (nub i, s) in+ cu { sources = go (sources cu)+ , headers = go (headers cu)+ }+ -------------------------------------------------------------------------------- putSrc :: C.Definition -> Compile-putSrc def = Compile (put mempty { sources = (S.empty,[def]) })+putSrc def = Compile (put mempty { sources = ([],[def]) }) putSrcInc :: Include -> Compile-putSrcInc inc = Compile (put mempty { sources = (S.fromList [inc],[]) })+putSrcInc inc = Compile (put mempty { sources = ([inc],[]) }) putHdrSrc :: C.Definition -> Compile-putHdrSrc hdr = Compile (put mempty { headers = (S.empty,[hdr]) })+putHdrSrc hdr = Compile (put mempty { headers = ([],[hdr]) }) putHdrInc :: Include -> Compile-putHdrInc inc = Compile (put mempty { headers = (S.fromList [inc],[]) })+putHdrInc inc = Compile (put mempty { headers = ([inc],[]) }) --------------------------------------------------------------------------------