diff --git a/ivory-backend-c.cabal b/ivory-backend-c.cabal --- a/ivory-backend-c.cabal +++ b/ivory-backend-c.cabal @@ -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, diff --git a/runtime/ivory.h b/runtime/ivory.h --- a/runtime/ivory.h +++ b/runtime/ivory.h @@ -9,8 +9,8 @@ #include "ivory_asserts.h" #include "ivory_templates.h" -#define FOREVER true -#define FOREVER_INC +#define IFOREVER true +#define IFOREVER_INC // ---------------------------------------- diff --git a/src/Ivory/Compile/C/CmdlineFrontend.hs b/src/Ivory/Compile/C/CmdlineFrontend.hs --- a/src/Ivory/Compile/C/CmdlineFrontend.hs +++ b/src/Ivory/Compile/C/CmdlineFrontend.hs @@ -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 diff --git a/src/Ivory/Compile/C/CmdlineFrontend/Options.hs b/src/Ivory/Compile/C/CmdlineFrontend/Options.hs --- a/src/Ivory/Compile/C/CmdlineFrontend/Options.hs +++ b/src/Ivory/Compile/C/CmdlineFrontend/Options.hs @@ -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" ] diff --git a/src/Ivory/Compile/C/Gen.hs b/src/Ivory/Compile/C/Gen.hs --- a/src/Ivory/Compile/C/Gen.hs +++ b/src/Ivory/Compile/C/Gen.hs @@ -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 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 diff --git a/src/Ivory/Compile/C/Modules.hs b/src/Ivory/Compile/C/Modules.hs --- a/src/Ivory/Compile/C/Modules.hs +++ b/src/Ivory/Compile/C/Modules.hs @@ -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 diff --git a/src/Ivory/Compile/C/Types.hs b/src/Ivory/Compile/C/Types.hs --- a/src/Ivory/Compile/C/Types.hs +++ b/src/Ivory/Compile/C/Types.hs @@ -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],[]) }) --------------------------------------------------------------------------------