diff --git a/src/Codegen/Codegen.hs b/src/Codegen/Codegen.hs index 60135a7..be92a35 100644 --- a/src/Codegen/Codegen.hs +++ b/src/Codegen/Codegen.hs @@ -21,7 +21,7 @@ import TypeChecker.TypeCheckerIr (Ident (..)) generateCode :: MIR.Program -> Bool -> Err String generateCode (MIR.Program scs) addGc = do let tree = filter (not . detectPrelude) (sortBy lowData scs) - let codegen = initCodeGenerator tree + let codegen = initCodeGenerator addGc tree llvmIrToString . instructions <$> execStateT (compileScs tree) codegen detectPrelude :: Def -> Bool diff --git a/src/Codegen/CompilerState.hs b/src/Codegen/CompilerState.hs index 114a651..1379d2f 100644 --- a/src/Codegen/CompilerState.hs +++ b/src/Codegen/CompilerState.hs @@ -22,6 +22,7 @@ data CodeGenerator = CodeGenerator , constructors :: Map TIR.Ident ConstructorInfo , variableCount :: Integer , labelCount :: Integer + , gcEnabled :: Bool } -- | A state type synonym @@ -115,15 +116,16 @@ getTypes bs = Map.fromList $ go bs variantTypes fi = init $ map type2LlvmType (flattenType fi) biggestVariant ts = 8 + maximum (sum . (\(Inj _ fi) -> typeByteSize <$> variantTypes fi) <$> ts) -initCodeGenerator :: [MIR.Def] -> CodeGenerator -initCodeGenerator scs = +initCodeGenerator :: Bool -> [MIR.Def] -> CodeGenerator +initCodeGenerator addGc scs = CodeGenerator - { instructions = defaultStart + { instructions = defaultStart <> if addGc then gcStart else [] , functions = getFunctions scs , constructors = getConstructors scs , customTypes = getTypes scs , variableCount = 0 , labelCount = 0 + , gcEnabled = addGc } defaultStart :: [LLVMIr] @@ -135,7 +137,11 @@ defaultStart = , UnsafeRaw "declare i32 @printf(ptr noalias nocapture, ...)\n" , UnsafeRaw "declare i32 @exit(i32 noundef)\n" , UnsafeRaw "declare ptr @malloc(i32 noundef)\n" - , UnsafeRaw "declare external void @cheap_init()\n" + ] + +gcStart :: [LLVMIr] +gcStart = + [ UnsafeRaw "declare external void @cheap_init()\n" , UnsafeRaw "declare external ptr @cheap_alloc(i64)\n" , UnsafeRaw "declare external void @cheap_dispose()\n" , UnsafeRaw "declare external ptr @cheap_the()\n" diff --git a/src/Codegen/Emits.hs b/src/Codegen/Emits.hs index c851374..66cad6e 100644 --- a/src/Codegen/Emits.hs +++ b/src/Codegen/Emits.hs @@ -77,7 +77,8 @@ compileScs [] = do Just s -> do emit $ Comment "Malloc and store" heapPtr <- getNewVar - emit $ SetVariable heapPtr (Malloca s) + useGc <- gets gcEnabled + emit $ SetVariable heapPtr (if useGc then GcMalloc s else Malloc s) emit $ Store arg_t' (VIdent (TIR.Ident arg_n) arg_t') Ptr heapPtr emit $ Store (Ref arg_t') (VIdent heapPtr arg_t') Ptr elemPtr Nothing -> do @@ -103,10 +104,11 @@ compileScs (MIR.DBind (MIR.Bind (name, t) args exp) : xs) = do emit . Comment $ show name <> ": " <> show exp let args' = map (second type2LlvmType) args emit $ Define FastCC t_return name args' - when (name == "main") (mapM_ emit firstMainContent) + useGc <- gets gcEnabled + when (name == "main") (mapM_ emit (firstMainContent useGc)) functionBody <- exprToValue exp if name == "main" - then mapM_ emit $ lastMainContent functionBody + then mapM_ emit $ lastMainContent useGc functionBody else emit $ Ret t_return functionBody emit DefineEnd modify $ \s -> s{variableCount = 0} @@ -126,20 +128,26 @@ compileScs (MIR.DData (MIR.Data typ ts) : xs) = do ts compileScs xs -firstMainContent :: [LLVMIr] -firstMainContent = +firstMainContent :: Bool -> [LLVMIr] +firstMainContent True = [ UnsafeRaw "%prof = call ptr @cheap_the()\n" , UnsafeRaw "call void @cheap_set_profiler(ptr %prof, i1 true)\n" , UnsafeRaw "call void @cheap_init()\n" ] +firstMainContent False = [] -lastMainContent :: LLVMValue -> [LLVMIr] -lastMainContent var = +lastMainContent :: Bool -> LLVMValue -> [LLVMIr] +lastMainContent True var = [ UnsafeRaw $ "call i32 (ptr, ...) @printf(ptr noundef @.str, i64 noundef " <> toIr var <> ")\n" , UnsafeRaw "call void @cheap_dispose()\n" , Ret I64 (VInteger 0) ] +lastMainContent False var = + [ UnsafeRaw $ + "call i32 (ptr, ...) @printf(ptr noundef @.str, i64 noundef " <> toIr var <> ")\n" + , Ret I64 (VInteger 0) + ] compileExp :: ExpT -> CompilerState () compileExp (MIR.ELit lit, _t) = emitLit lit @@ -175,7 +183,8 @@ emitECased t e cases = do -- emit $ Label crashLbl var_num <- getVarCount emit . UnsafeRaw $ "call i32 (ptr, ...) @printf(ptr noundef @.non_exhaustive_patterns, i64 noundef " <> show var_num <> ", i64 noundef 6)\n" - emit . UnsafeRaw $ "call void @cheap_dispose()\n" + useGc <- gets gcEnabled + when useGc (emit . UnsafeRaw $ "call void @cheap_dispose()\n") emit . UnsafeRaw $ "call i32 @exit(i32 noundef 1)\n" mapM_ (const increaseVarCount) [0 .. 1] emit $ Br label diff --git a/src/Codegen/LlvmIr.hs b/src/Codegen/LlvmIr.hs index ac9432a..cc77cf9 100644 --- a/src/Codegen/LlvmIr.hs +++ b/src/Codegen/LlvmIr.hs @@ -133,7 +133,8 @@ data LLVMIr | Bitcast LLVMType LLVMValue LLVMType | Ret LLVMType LLVMValue | Comment String - | Malloca Integer + | Malloc Integer + | GcMalloc Integer | UnsafeRaw String -- This should generally be avoided, and proper -- instructions should be used in its place deriving (Show, Eq, Ord) @@ -223,7 +224,10 @@ llvmIrToString = go 0 , ")\n" ] (Alloca t) -> unwords ["alloca", toIr t, "\n"] - (Malloca t) -> + (Malloc t) -> + concat + [ "call ptr @malloc(i64 ", show t, ")\n"] + (GcMalloc t) -> concat [ "call ptr @cheap_alloc(i64 ", show t, ")\n"] (Store t1 val t2 (Ident id2)) -> diff --git a/src/Compiler.hs b/src/Compiler.hs index 12f36b0..72598cb 100644 --- a/src/Compiler.hs +++ b/src/Compiler.hs @@ -10,8 +10,19 @@ import System.Process.Extra ( optimize :: String -> IO String optimize = readCreateProcess (shell "opt --O3 --tailcallopt -S") -compileClang :: String -> IO String -compileClang = +compileClang :: Bool -> String -> IO String +compileClang False = + readCreateProcess . shell $ + unwords + [ "clang++" -- , "-Lsrc/GC/lib/", "-l:libgcoll.a" + , "-fno-rtti" + , "-x" + , "ir" -- , "-Lsrc/GC/lib -l:gcoll.a" + , "-o" + , "output/hello_world" + , "-" + ] +compileClang True = readCreateProcess . shell $ unwords [ "clang++" -- , "-Lsrc/GC/lib/", "-l:libgcoll.a" @@ -30,4 +41,4 @@ compileClang = ] compile :: String -> Bool -> IO String -compile s addGc = optimize s >>= compileClang +compile s addGc = optimize s >>= compileClang addGc