module Ivory.Compile.C.CmdlineFrontend
( compile
, compileWith
, runCompiler
, runCompilerWith
, Opts(..), parseOpts, printUsage
, initialOpts
, compileUnits
, outputCompiler
) where
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.Artifact
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 Control.Monad (when)
import Data.List (foldl')
import Data.Maybe (catMaybes, mapMaybe)
import System.Directory (createDirectoryIfMissing)
import System.Environment (getArgs)
import System.FilePath (addExtension, (</>))
compile :: [Module] -> [Located Artifact] -> IO ()
compile = compileWith
compileWith :: [Module] -> [Located Artifact] -> IO ()
compileWith ms as = do
args <- getArgs
opts <- parseOpts args
runCompilerWith ms as opts
runCompiler :: [Module] -> [Located Artifact] -> Opts -> IO ()
runCompiler ms as os = runCompilerWith ms as os
runCompilerWith :: [Module] -> [Located Artifact] -> Opts -> IO ()
runCompilerWith modules artifacts opts = do
cmodules <- compileUnits modules opts
if outProcSyms opts
then C.outputProcSyms modules
else outputCompiler cmodules artifacts opts
outputCompiler :: [C.CompileUnits] -> [Located Artifact] -> Opts -> IO ()
outputCompiler cmodules artifacts opts
| Nothing <- outDir opts
= stdoutmodules cmodules
| otherwise
= outputmodules opts cmodules artifacts
stdoutmodules :: [C.CompileUnits] -> IO ()
stdoutmodules cmodules =
mapM_ (putStrLn . C.showModule) cmodules
outputmodules :: Opts -> [C.CompileUnits] -> [Located Artifact] -> IO ()
outputmodules opts cmodules user_artifacts = do
let Just srcdir = outDir opts
let incldir = hdrDir srcdir
let rootdir = rootDir srcdir
createDirectoryIfMissing True rootdir
createDirectoryIfMissing True srcdir
createDirectoryIfMissing True incldir
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
runArtifactCompiler artifacts rootdir srcdir incldir
where
hdrDir dir =
case outHdrDir opts of
Nothing -> dir
Just d -> d
rootDir dir =
case outArtDir opts of
Nothing -> dir
Just d -> d
output :: FilePath -> FilePath -> (C.CompileUnits -> String)
-> C.CompileUnits
-> IO ()
output dir ext render m = outputHelper fout (render m)
where fout = addExtension (dir </> (C.unitName m)) ext
renderHeader cu = C.renderHdr (C.headers cu) (C.unitName cu)
renderSource cu = C.renderSrc (C.sources cu)
outputHelper :: FilePath -> String -> IO ()
outputHelper fname contents = case verbose opts of
False -> out
True -> do
putStr ("Writing to file " ++ fname ++ "...")
out
putStrLn " Done"
where
out = writeFile fname contents
compileUnits ::[Module] -> Opts -> IO [C.CompileUnits]
compileUnits modules opts = do
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!")
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!")
return (mkCUnits modules opts)
mkCUnits :: [Module] -> Opts -> [C.CompileUnits]
mkCUnits modules opts = cmodules
where
cmodules = map (C.compileModule (otherHdr opts)) optModules
optModules = map (C.runOpt passes) modules
cfPass = mkPass constFold O.constFold
ofPass = mkPass overflow O.overflowFold
dzPass = mkPass divZero O.divZeroFold
fpPass = mkPass fpCheck O.fpFold
ixPass = mkPass ixCheck O.ixFold
bsPass = mkPass bitShiftCheck O.bitShiftFold
locPass = mkPass (not . srcLocs) dropSrcLocs
mkPass passOpt pass = if passOpt opts then pass else id
passes e = foldl' (flip ($)) e
[ O.cseFold
, locPass
, cfPass
, ofPass, dzPass, fpPass, ixPass, bsPass
, cfPass
]
runArtifactCompiler :: [Located Artifact] -> FilePath -> FilePath -> FilePath
-> IO ()
runArtifactCompiler las root_dir src_dir incl_dir = do
mes <- sequence
[ case la of
Root a -> putArtifact root_dir a
Src a -> putArtifact src_dir a
Incl a -> putArtifact incl_dir a
| la <- las ]
case catMaybes mes of
[] -> return ()
errs -> error (unlines errs)
runtimeHeaders :: [Located Artifact]
runtimeHeaders = map a [ "ivory.h", "ivory_asserts.h", "ivory_templates.h" ]
where a f = Incl $ artifactCabalFile P.getDataDir ("runtime/" ++ f)
warnCollisions :: [C.CompileUnits]
-> [Located Artifact]
-> FilePath
-> FilePath
-> FilePath
-> IO ()
warnCollisions ms as rootpath spath ipath = case dupes of
[] -> return ()
_ -> putStrLn $ intercalate "\n\t" $
["**** Warning: the following files will be written multiple times during codegen! ****"]
++ dupes
where
cnames = [ spath </> (C.unitName m ++ ".c") | m <- ms ]
hnames = [ ipath </> (C.unitName m ++ ".h") | m <- ms ]
anames = [ case la of
Root a -> rootpath </> artifactFileName a
Src a -> spath </> artifactFileName a
Incl a -> ipath </> artifactFileName a
| la <- as ]
allnames = cnames ++ hnames ++ anames
dupes = allnames \\ (nub allnames)
dropSrcLocs :: I.Proc -> I.Proc
dropSrcLocs p = p { I.procBody = dropSrcLocsBlock (I.procBody p) }
where
dropSrcLocsBlock = mapMaybe go
go stmt = case stmt of
I.IfTE b t f -> Just $ I.IfTE b (dropSrcLocsBlock t)
(dropSrcLocsBlock f)
I.Loop m v e i b -> Just $ I.Loop m v e i (dropSrcLocsBlock b)
I.Forever b -> Just $ I.Forever (dropSrcLocsBlock b)
I.Comment (I.SourcePos _) -> Nothing
_ -> Just stmt