~jojo/Carth

4ee407babc363d1fa4b526984359b99d411d6860 — JoJo 1 year, 5 months ago 2d38bc1
Run with MCJIT with `carth run`
10 files changed, 183 insertions(+), 68 deletions(-)

M TODO.org
M app/GetConfig.hs
M app/Main.hs
M examples/hello-world.carth
M foreign-core/Cargo.toml
M package.yaml
M src/Compile.hs
A src/Conf.hs
D src/Config.hs
M src/Monomorphize.hs
M TODO.org => TODO.org +14 -0
@@ 431,3 431,17 @@ the fix etc:
  I think it could be done purely and independently from rest of codegen. Would be more clean.
* NEXT Refactor Codegen
  It's getting big, complex, and unwieldy. Probably buggy as well.
* NEXT Use GADTs in Infer
* NEXT Have a look at LLVM.IRBuilder
  Might simplify my Codegen

  https://hackage.haskell.org/package/llvm-hs-pure-9.0.0/docs/LLVM-IRBuilder-Module.html#v:function

* NEXT Add basic repl
  Add a basic repl based on the MCJIT. Something very similar to
  http://www.stephendiehl.com/llvm/.

  Could maybe be the starting point for an on-demand architechture?
  Would probably require some memoization mechanism so that we don't
  unnecessarily check, monomorphise, and compile stuff we don't need
  to.

M app/GetConfig.hs => app/GetConfig.hs +63 -23
@@ 1,8 1,8 @@
{-# LANGUAGE TupleSections, TemplateHaskell #-}
{-# LANGUAGE TupleSections, TemplateHaskell, RankNTypes #-}

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

import System.Console.GetOpt
import System.Environment


@@ 12,23 12,28 @@ import Data.List
import Data.Function
import Control.Monad

import Config
import Conf
import Prebaked


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


@@ 45,57 50,92 @@ usageSubs = unlines
    , ""
    , "Available subcommands are:"
    , "  c, compile       Compile a source file"
    , "  r, run           JIT run a source file"
    , "     version       Show version information"
    , ""
    , "See `carth help SUBCOMMAND` for help on a specific subcommand"
    ]

compileCfg :: [String] -> IO Config
compileCfg :: [String] -> IO Conf
compileCfg args = do
    let (fs, extras, errs) = getOpt Permute compileOpts args
    when (not (null errs)) $ putStrLn (concat errs) *> usageCompile
    inf <- case extras of
        f : [] -> pure f
        _ : es -> do
            putStrLn ("Unexpected extra arguments: " ++ intercalate ", " es)
            exitFailure
        [] -> putStrLn "Missing input source file" *> usageCompile
    (fs, inf) <- get args compileOpts 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 }
    let defaultCfg = CompileConfig
            { cInfile = inf
            , cOutfile = outf
            , cCompiler = "cc"
            , cDebug = False
            }
        cfg = foldl (&) defaultCfg fs
    pure cfg
    pure (CompileConf cfg)

runCfg :: [String] -> IO Conf
runCfg args = do
    (fs, inf) <- get args runOpts usageRun
    let defaultCfg = RunConfig { rInfile = inf, rDebug = False }
        cfg = foldl (&) defaultCfg fs
    pure (RunConf cfg)

get
    :: [String]
    -> [OptDescr (cfg -> cfg)]
    -> (forall a . IO a)
    -> IO ([cfg -> cfg], FilePath)
get args opts usage = do
    let (fs, extras, errs) = getOpt Permute opts args
    when (not (null errs)) $ putStrLn (concat errs) *> usage
    inf <- case extras of
        f : [] -> pure f
        _ : es -> do
            putStrLn ("Unexpected extra arguments: " ++ intercalate ", " es)
            usage
        [] -> putStrLn "Missing input source file" *> usage
    pure (fs, inf)

usageCompile :: IO a
usageCompile = do
    putStrLn $ unlines
        [ "Carth compiler"
        [ "Carth compile"
        , "Compile a Carth program to an executable"
        , ""
        , usageInfo "Usage: carth c [OPTIONS] SOURCE-FILE" compileOpts
        ]
    exitFailure

compileOpts :: [OptDescr (Config -> Config)]
usageRun :: IO a
usageRun = do
    putStrLn $ unlines
        [ "Carth run"
        , "JIT run Carth program"
        , ""
        , usageInfo "Usage: carth r [OPTIONS] SOURCE-FILE" runOpts
        ]
    exitFailure

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

runOpts :: [OptDescr (RunConfig -> RunConfig)]
runOpts =
    [Option [] ["debug"] (NoArg (\c -> c { rDebug = True })) "Enable debugging"]

printVersion :: IO ()
printVersion = do
    let (major, minor, patch) = version

M app/Main.hs => app/Main.hs +25 -5
@@ 11,24 11,45 @@ import qualified TypeErr
import qualified Parsed
import qualified Checked
import Check
import Conf
import GetConfig
import Compile
import Monomorphize
import qualified Monomorphic
import qualified Parse
import EnvVars

main :: IO ()
main = compileFile =<< getConfig
main = getConfig >>= \case
    CompileConf cfg -> compileFile cfg
    RunConf cfg -> runFile cfg

compileFile :: Config -> IO ()
compileFile :: CompileConfig -> IO ()
compileFile cfg = do
    let (d, f) = (debug cfg, infile cfg)
    let f = cInfile cfg
    putStrLn ("   Compiling " ++ f ++ "")
    putStrLn ("     Environment variables:")
    lp <- lookupEnv "LIBRARY_PATH"
    mp <- modulePaths
    putStrLn ("       library path = " ++ show lp)
    putStrLn ("       module paths = " ++ show mp)
    mon <- frontend (cDebug cfg) f
    compile f cfg mon
    putStrLn ""

runFile :: RunConfig -> IO ()
runFile cfg = do
    let f = rInfile cfg
    putStrLn ("   Running " ++ f ++ "")
    putStrLn ("     Environment variables:")
    mp <- modulePaths
    putStrLn ("       module paths = " ++ show mp)
    mon <- frontend (rDebug cfg) f
    run f cfg mon
    putStrLn ""

frontend :: Bool -> FilePath -> IO Monomorphic.Program
frontend d f = do
    putStrLn ("   Parsing")
    ast <- parse f
    when d $ writeFile ".dbg.parsed" (pretty ast)


@@ 38,8 59,7 @@ compileFile cfg = do
    putStrLn ("   Monomorphizing")
    let mon = monomorphize ann
    when d $ writeFile ".dbg.mono" (show mon)
    compile f cfg mon
    putStrLn ""
    pure mon

parse :: FilePath -> IO Parsed.Program
parse f = Parse.parse f >>= \case

M examples/hello-world.carth => examples/hello-world.carth +1 -0
@@ 1,4 1,5 @@
(import std)


(define (main unit)
  (display (str-append "Hello, world!" "\n")))

M foreign-core/Cargo.toml => foreign-core/Cargo.toml +1 -1
@@ 11,4 11,4 @@ license = "AGPL-3.0-or-later"
[dependencies]

[lib]
crate-type = ["staticlib"]
\ No newline at end of file
crate-type = ["staticlib", "cdylib"]
\ No newline at end of file

M package.yaml => package.yaml +4 -0
@@ 52,6 52,10 @@ library:
  - -Wno-missed-specialisations
  - -Wno-all-missed-specialisations
  - -Wno-unticked-promoted-constructors
  extra-libraries:
  - carth_foreign_core
  # - dl
  # - pthread

executables:
  carth:

M src/Compile.hs => src/Compile.hs +58 -29
@@ 1,41 1,64 @@
module Compile (compile) where
{-# LANGUAGE ForeignFunctionInterface, OverloadedStrings, LambdaCase #-}

module Compile (compile, run) where

import Control.Monad
import LLVM.Context
import LLVM.Module
import LLVM.Target
import LLVM.Analysis
import System.FilePath
import System.Process
import LLVM.ExecutionEngine
import qualified LLVM.AST as LLAST
import qualified LLVM.Relocation as Reloc
import qualified LLVM.CodeModel as CodeModel
import qualified LLVM.CodeGenOpt as CodeGenOpt
import Control.Monad
import System.FilePath
import System.Process
import System.Exit
import Data.Int
import Data.Functor
import Foreign.Ptr
import Prelude hiding (mod)

import Config
import Conf
import qualified Monomorphic
import Codegen


compile :: FilePath -> CompileConfig -> Monomorphic.Program -> IO ()
compile = handleProgram (const compileModule) cDebug

run :: FilePath -> RunConfig -> Monomorphic.Program -> IO ()
run = handleProgram (\ctx _ _ -> mcJitModule ctx) rDebug

-- TODO: CodeGenOpt level
compile :: FilePath -> Config -> Monomorphic.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 -> Config -> Module -> IO ()
compileModule t cfg m = do
    putStrLn ("   Assembling LLVM")
    let exefile = outfile cfg
handleProgram
    :: (Context -> TargetMachine -> config -> Module -> IO ())
    -> (config -> Bool)
    -> FilePath
    -> config
    -> Monomorphic.Program
    -> IO ()
handleProgram f debug file cfg pgm = withContext $ \ctx ->
    withHostTargetMachinePIC $ \tm -> do
        layout <- getTargetMachineDataLayout tm
        putStrLn ("   Generating LLVM")
        let amod = codegen layout file pgm
        withModuleFromAST ctx amod $ \mod -> do
            putStrLn ("   Assembling LLVM")
            when (debug cfg) $ writeLLVMAssemblyToFile' ".dbg.ll" mod
            putStrLn ("   Verifying LLVM")
            verify mod
            f ctx tm cfg mod

compileModule :: TargetMachine -> CompileConfig -> Module -> IO ()
compileModule tm cfg mod = do
    let exefile = cOutfile cfg
        ofile = replaceExtension exefile "o"
    when (debug cfg) $ writeLLVMAssemblyToFile' ".dbg.ll" m
    putStrLn ("   Verifying LLVM")
    verify m
    writeObjectToFile t (File ofile) m
    writeObjectToFile tm (File ofile) mod
    putStrLn ("   Linking")
    callProcess
        (cc cfg)
        (cCompiler cfg)
        [ "-o"
        , exefile
        , ofile


@@ 44,14 67,20 @@ compileModule t cfg m = do
        , "-lpthread"
        ]

-- | `writeLLVMAssemblyToFile` doesn't clear file contents before writing, so
--   this is a workaround.
--
--   If the file was previously 100 lines of data, and the new LLVM-assembly is
--   70 lines, the first 70 lines will be overwritten, but the remaining 30 will
--   be the same as in the old file, which will cause errors if we try to
--   compile it manually. So we have to clear file contents first manually if we
--   want these dumps to be useful for debugging.
foreign import ccall "dynamic"
  mkMain :: FunPtr (IO Int32) -> IO Int32

mcJitModule :: Context -> Module -> IO ()
mcJitModule ctx mod = do
    putStrLn "   Running with MCJIT"
    withMCJIT ctx Nothing Nothing Nothing Nothing $ \engine ->
        withModuleInEngine engine mod $ \execMod ->
            getFunction execMod (LLAST.Name "main") >>= \case
                Just mainAddr -> mkMain (castFunPtr mainAddr) $> ()
                Nothing -> putStrLn "Error getting main" >> exitFailure

-- | `writeLLVMAssemblyToFile` doesn't clear file contents before writing,
--   so this is a workaround.
writeLLVMAssemblyToFile' :: FilePath -> Module -> IO ()
writeLLVMAssemblyToFile' f m = do
    writeFile f ""

A src/Conf.hs => src/Conf.hs +16 -0
@@ 0,0 1,16 @@
module Conf (Conf(..), CompileConfig(..), RunConfig(..)) where

data Conf
    = CompileConf CompileConfig
    | RunConf RunConfig

data CompileConfig = CompileConfig
    { cInfile :: FilePath
    , cOutfile :: FilePath
    -- | Path to C compiler to use for linking and compiling ".c" files
    , cCompiler :: FilePath
    , cDebug :: Bool }

data RunConfig = RunConfig
    { rInfile :: FilePath
    , rDebug :: Bool }

D src/Config.hs => src/Config.hs +0 -9
@@ 1,9 0,0 @@
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
    }

M src/Monomorphize.hs => src/Monomorphize.hs +1 -1
@@ 52,7 52,7 @@ evalMono :: Mono a -> a
evalMono ma = runReader (evalStateT ma initInsts) initEnv

initInsts :: Insts
initInsts = Insts Map.empty Set.empty
initInsts = Insts Map.empty (Set.singleton ("Str", []))

initEnv :: Env
initEnv = Env { _envDefs = Map.empty, _tvBinds = Map.empty }