~jojo/Carth

8495cf0d0ab8e74ed513d1045404b8a9fa8f63aa — JoJo 1 year, 10 months ago 283eb48
Add --debug flag to write debug files (e.g. .dbg.ll)
4 files changed, 57 insertions(+), 52 deletions(-)

R app/{Config.hs => GetConfig.hs}
M app/Main.hs
M src/Compile.hs
A src/Config.hs
R app/Config.hs => app/GetConfig.hs +26 -16
@@ 1,33 1,33 @@
{-# LANGUAGE TupleSections #-}

-- | Read all the different kinds of configurtion options for Carth. Command
--    line options, config files, environment variables, etc.
module Config (getConfig, ModeConfig) where
--   line options, config files, environment variables, etc.
module GetConfig (getConfig, Config(..)) where

import System.Console.GetOpt
import System.Environment
import System.Exit
import System.FilePath
import Data.List
import Data.Function
import Control.Monad

import Compile
import Config


type ModeConfig = (FilePath, CompileConfig)

getConfig :: IO ModeConfig
getConfig :: IO Config
getConfig = do
    as <- getArgs
    let subCompile a = a == "c" || a == "compile"
    case as of
        a : as' | a == "c" || a == "compile" -> compileCfg as'
        a : as' | subCompile a -> compileCfg as'
        a : _ | a == "-h" || a == "--help" -> do
            putStrLn usageSubs
            exitFailure
        "help" : [] -> do
            putStrLn usageSubs
            exitFailure
        "help" : a : _ | a == "c" || a == "compile" -> usageCompile
        "help" : a : _ | subCompile a -> usageCompile
        a : _ -> do
            putStrLn ("Error: `" ++ a ++ "` is not a valid subcommand\n")
            putStrLn usageSubs


@@ 47,17 47,26 @@ usageSubs = unlines
    , "See `carth help SUBCOMMAND` for help on a specific subcommand"
    ]

compileCfg :: [String] -> IO ModeConfig
compileCfg :: [String] -> IO Config
compileCfg args = do
    let (fs, extras, errs) = getOpt Permute compileOpts args
    when (not (null errs)) $ putStrLn (concat errs) *> usageCompile
    let cfg = foldl (&) defaultCompileConfig fs
    case extras of
        infile : [] -> pure (infile, cfg)
    inf <- case extras of
        f : [] -> pure f
        _ : es -> do
            putStrLn ("Unexpected extra arguments: " ++ intercalate ", " es)
            exitFailure
        [] -> putStrLn "Missing input source file" *> usageCompile
    let outf = dropExtension inf
    when (inf == outf) $ do
        putStrLn
            $ ("Error: Input file \"" ++ inf ++ "\" ")
            ++ "would be overwritten by the generated executable"
        exitFailure
    let defaultCfg =
            Config { infile = inf, outfile = outf, cc = "cc", debug = False }
        cfg = foldl (&) defaultCfg fs
    pure cfg

usageCompile :: IO a
usageCompile = do


@@ 69,16 78,17 @@ usageCompile = do
        ]
    exitFailure

compileOpts :: [OptDescr (CompileConfig -> CompileConfig)]
compileOpts :: [OptDescr (Config -> Config)]
compileOpts =
    [ Option
        []
        ["cc"]
        (ReqArg (\cc' cfg -> cfg { cc = cc' }) "PROGRAM")
        "C compiler to use for linking and compiling C files"
        (ReqArg (\cc' c -> c { cc = cc' }) "PROGRAM")
        "C compiler to use for linking"
    , Option
        ['o']
        ["outfile"]
        (ReqArg (\f cfg -> cfg { outfile = Just f }) "FILE")
        (ReqArg (\f c -> c { outfile = f }) "FILE")
        "Output filepath"
    , Option [] ["debug"] (NoArg (\c -> c { debug = True })) "Enable debugging"
    ]

M app/Main.hs => app/Main.hs +12 -15
@@ 2,26 2,26 @@

module Main (main) where

import Data.Functor
import System.Environment
import Control.Monad

import Misc
import qualified TypeErr
import qualified Ast
import qualified DesugaredAst
import qualified MonoAst
import Check
import Config
import GetConfig
import Compile
import Mono
import qualified Parse
import EnvVars

main :: IO ()
main = uncurry compileFile =<< getConfig
main = compileFile =<< getConfig

compileFile :: FilePath -> CompileConfig -> IO ()
compileFile f cfg = do
compileFile :: Config -> IO ()
compileFile cfg = do
    let (d, f) = (debug cfg, infile cfg)
    putStrLn ("   Compiling " ++ f ++ "")
    putStrLn ("     Environment variables:")
    lp <- lookupEnv "LIBRARY_PATH"


@@ 30,17 30,20 @@ compileFile f cfg = do
    putStrLn ("       module paths = " ++ show mp)
    putStrLn ("   Parsing")
    ast <- parse f
    when d $ writeFile ".dbg.parsed" (pretty ast)
    putStrLn ("   Typechecking")
    ann <- typecheck' f ast
    when d $ writeFile ".dbg.checked" (show ann)
    putStrLn ("   Monomorphizing")
    mon <- monomorphize' ann
    let mon = monomorphize ann
    when d $ writeFile ".dbg.mono" (show mon)
    compile f cfg mon
    putStrLn ""

parse :: FilePath -> IO Ast.Program
parse f = Parse.parse f >>= \case
    Left e -> putStrLn (formatParseErr e) >> abort f
    Right p -> writeFile ".dbg.out.parsed" (pretty p) $> p
    Right p -> pure p
  where
    formatParseErr e =
        let ss = lines e in (unlines ((head ss ++ " Error:") : tail ss))


@@ 48,10 51,4 @@ parse f = Parse.parse f >>= \case
typecheck' :: FilePath -> Ast.Program -> IO DesugaredAst.Program
typecheck' f p = case typecheck p of
    Left e -> TypeErr.printErr e >> abort f
    Right p -> writeFile ".dbg.out.checked" (show p) $> p

monomorphize' :: DesugaredAst.Program -> IO MonoAst.Program
monomorphize' p = do
    let p' = monomorphize p
    writeFile ".dbg.out.mono" (show p')
    pure p'
    Right p -> pure p

M src/Compile.hs => src/Compile.hs +10 -21
@@ 1,53 1,42 @@
module Compile (compile, CompileConfig(..), defaultCompileConfig) where
module Compile (compile) where

import Control.Monad
import LLVM.Context
import LLVM.Module
import LLVM.Target
import LLVM.Analysis
import Data.Maybe
import System.FilePath
import System.Process
import qualified LLVM.Relocation as Reloc
import qualified LLVM.CodeModel as CodeModel
import qualified LLVM.CodeGenOpt as CodeGenOpt

import Config
import qualified MonoAst
import Codegen

-- | Configuration for LLVM compilation and CC linking
data CompileConfig = CompileConfig
    -- | Path to C compiler to use for linking and compiling ".c" files
    { cc :: FilePath
    -- | Filepath to write the output item to. If none is supplied, a default
    --   name of "out" with the appropriate extension will be used.
    , outfile :: Maybe FilePath }

defaultCompileConfig :: CompileConfig
defaultCompileConfig = CompileConfig { cc = "cc", outfile = Nothing }

-- TODO: Verify w LLVM.Analysis.verify :: Module -> IO ()
-- TODO: CodeGenOpt level
compile :: FilePath -> CompileConfig -> MonoAst.Program -> IO ()
compile :: FilePath -> Config -> MonoAst.Program -> IO ()
compile f cfg pgm = withContext $ \c -> withHostTargetMachinePIC $ \t -> do
    layout <- getTargetMachineDataLayout t
    putStrLn ("   Generating LLVM")
    let mod' = codegen layout f pgm
    withModuleFromAST c mod' (compileModule t cfg)

compileModule :: TargetMachine -> CompileConfig -> Module -> IO ()
compileModule :: TargetMachine -> Config -> Module -> IO ()
compileModule t cfg m = do
    putStrLn ("   Compiling LLVM")
    let binfile = fromMaybe "out" (outfile cfg)
        llfile = replaceExtension binfile "ll"
        ofile = replaceExtension binfile "o"
    writeLLVMAssemblyToFile' (".dbg." ++ llfile) m
    putStrLn ("   Assembling LLVM")
    let exefile = outfile cfg
        ofile = replaceExtension exefile "o"
    when (debug cfg) $ writeLLVMAssemblyToFile' ".dbg.ll" m
    verify m
    writeObjectToFile t (File ofile) m
    putStrLn ("   Linking")
    callProcess
        (cc cfg)
        [ "-o"
        , binfile
        , exefile
        , ofile
        , "-l:libcarth_foreign_core.a"
        , "-ldl"

A src/Config.hs => src/Config.hs +9 -0
@@ 0,0 1,9 @@
module Config (Config(..)) where

data Config = Config
    { infile :: FilePath
    , outfile :: FilePath
    -- | Path to C compiler to use for linking and compiling ".c" files
    , cc :: FilePath
    , debug :: Bool
    }