The code generator can now compile without the GC.
This commit is contained in:
parent
f9d28028b5
commit
de03a2cc34
5 changed files with 48 additions and 18 deletions
|
|
@ -21,7 +21,7 @@ import TypeChecker.TypeCheckerIr (Ident (..))
|
||||||
generateCode :: MIR.Program -> Bool -> Err String
|
generateCode :: MIR.Program -> Bool -> Err String
|
||||||
generateCode (MIR.Program scs) addGc = do
|
generateCode (MIR.Program scs) addGc = do
|
||||||
let tree = filter (not . detectPrelude) (sortBy lowData scs)
|
let tree = filter (not . detectPrelude) (sortBy lowData scs)
|
||||||
let codegen = initCodeGenerator tree
|
let codegen = initCodeGenerator addGc tree
|
||||||
llvmIrToString . instructions <$> execStateT (compileScs tree) codegen
|
llvmIrToString . instructions <$> execStateT (compileScs tree) codegen
|
||||||
|
|
||||||
detectPrelude :: Def -> Bool
|
detectPrelude :: Def -> Bool
|
||||||
|
|
|
||||||
|
|
@ -22,6 +22,7 @@ data CodeGenerator = CodeGenerator
|
||||||
, constructors :: Map TIR.Ident ConstructorInfo
|
, constructors :: Map TIR.Ident ConstructorInfo
|
||||||
, variableCount :: Integer
|
, variableCount :: Integer
|
||||||
, labelCount :: Integer
|
, labelCount :: Integer
|
||||||
|
, gcEnabled :: Bool
|
||||||
}
|
}
|
||||||
|
|
||||||
-- | A state type synonym
|
-- | A state type synonym
|
||||||
|
|
@ -115,15 +116,16 @@ getTypes bs = Map.fromList $ go bs
|
||||||
variantTypes fi = init $ map type2LlvmType (flattenType fi)
|
variantTypes fi = init $ map type2LlvmType (flattenType fi)
|
||||||
biggestVariant ts = 8 + maximum (sum . (\(Inj _ fi) -> typeByteSize <$> variantTypes fi) <$> ts)
|
biggestVariant ts = 8 + maximum (sum . (\(Inj _ fi) -> typeByteSize <$> variantTypes fi) <$> ts)
|
||||||
|
|
||||||
initCodeGenerator :: [MIR.Def] -> CodeGenerator
|
initCodeGenerator :: Bool -> [MIR.Def] -> CodeGenerator
|
||||||
initCodeGenerator scs =
|
initCodeGenerator addGc scs =
|
||||||
CodeGenerator
|
CodeGenerator
|
||||||
{ instructions = defaultStart
|
{ instructions = defaultStart <> if addGc then gcStart else []
|
||||||
, functions = getFunctions scs
|
, functions = getFunctions scs
|
||||||
, constructors = getConstructors scs
|
, constructors = getConstructors scs
|
||||||
, customTypes = getTypes scs
|
, customTypes = getTypes scs
|
||||||
, variableCount = 0
|
, variableCount = 0
|
||||||
, labelCount = 0
|
, labelCount = 0
|
||||||
|
, gcEnabled = addGc
|
||||||
}
|
}
|
||||||
|
|
||||||
defaultStart :: [LLVMIr]
|
defaultStart :: [LLVMIr]
|
||||||
|
|
@ -135,7 +137,11 @@ defaultStart =
|
||||||
, UnsafeRaw "declare i32 @printf(ptr noalias nocapture, ...)\n"
|
, UnsafeRaw "declare i32 @printf(ptr noalias nocapture, ...)\n"
|
||||||
, UnsafeRaw "declare i32 @exit(i32 noundef)\n"
|
, UnsafeRaw "declare i32 @exit(i32 noundef)\n"
|
||||||
, UnsafeRaw "declare ptr @malloc(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 ptr @cheap_alloc(i64)\n"
|
||||||
, UnsafeRaw "declare external void @cheap_dispose()\n"
|
, UnsafeRaw "declare external void @cheap_dispose()\n"
|
||||||
, UnsafeRaw "declare external ptr @cheap_the()\n"
|
, UnsafeRaw "declare external ptr @cheap_the()\n"
|
||||||
|
|
|
||||||
|
|
@ -77,7 +77,8 @@ compileScs [] = do
|
||||||
Just s -> do
|
Just s -> do
|
||||||
emit $ Comment "Malloc and store"
|
emit $ Comment "Malloc and store"
|
||||||
heapPtr <- getNewVar
|
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 arg_t' (VIdent (TIR.Ident arg_n) arg_t') Ptr heapPtr
|
||||||
emit $ Store (Ref arg_t') (VIdent heapPtr arg_t') Ptr elemPtr
|
emit $ Store (Ref arg_t') (VIdent heapPtr arg_t') Ptr elemPtr
|
||||||
Nothing -> do
|
Nothing -> do
|
||||||
|
|
@ -103,10 +104,11 @@ compileScs (MIR.DBind (MIR.Bind (name, t) args exp) : xs) = do
|
||||||
emit . Comment $ show name <> ": " <> show exp
|
emit . Comment $ show name <> ": " <> show exp
|
||||||
let args' = map (second type2LlvmType) args
|
let args' = map (second type2LlvmType) args
|
||||||
emit $ Define FastCC t_return name 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
|
functionBody <- exprToValue exp
|
||||||
if name == "main"
|
if name == "main"
|
||||||
then mapM_ emit $ lastMainContent functionBody
|
then mapM_ emit $ lastMainContent useGc functionBody
|
||||||
else emit $ Ret t_return functionBody
|
else emit $ Ret t_return functionBody
|
||||||
emit DefineEnd
|
emit DefineEnd
|
||||||
modify $ \s -> s{variableCount = 0}
|
modify $ \s -> s{variableCount = 0}
|
||||||
|
|
@ -126,20 +128,26 @@ compileScs (MIR.DData (MIR.Data typ ts) : xs) = do
|
||||||
ts
|
ts
|
||||||
compileScs xs
|
compileScs xs
|
||||||
|
|
||||||
firstMainContent :: [LLVMIr]
|
firstMainContent :: Bool -> [LLVMIr]
|
||||||
firstMainContent =
|
firstMainContent True =
|
||||||
[ UnsafeRaw "%prof = call ptr @cheap_the()\n"
|
[ UnsafeRaw "%prof = call ptr @cheap_the()\n"
|
||||||
, UnsafeRaw "call void @cheap_set_profiler(ptr %prof, i1 true)\n"
|
, UnsafeRaw "call void @cheap_set_profiler(ptr %prof, i1 true)\n"
|
||||||
, UnsafeRaw "call void @cheap_init()\n"
|
, UnsafeRaw "call void @cheap_init()\n"
|
||||||
]
|
]
|
||||||
|
firstMainContent False = []
|
||||||
|
|
||||||
lastMainContent :: LLVMValue -> [LLVMIr]
|
lastMainContent :: Bool -> LLVMValue -> [LLVMIr]
|
||||||
lastMainContent var =
|
lastMainContent True var =
|
||||||
[ UnsafeRaw $
|
[ UnsafeRaw $
|
||||||
"call i32 (ptr, ...) @printf(ptr noundef @.str, i64 noundef " <> toIr var <> ")\n"
|
"call i32 (ptr, ...) @printf(ptr noundef @.str, i64 noundef " <> toIr var <> ")\n"
|
||||||
, UnsafeRaw "call void @cheap_dispose()\n"
|
, UnsafeRaw "call void @cheap_dispose()\n"
|
||||||
, Ret I64 (VInteger 0)
|
, 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 :: ExpT -> CompilerState ()
|
||||||
compileExp (MIR.ELit lit, _t) = emitLit lit
|
compileExp (MIR.ELit lit, _t) = emitLit lit
|
||||||
|
|
@ -175,7 +183,8 @@ emitECased t e cases = do
|
||||||
-- emit $ Label crashLbl
|
-- emit $ Label crashLbl
|
||||||
var_num <- getVarCount
|
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 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"
|
emit . UnsafeRaw $ "call i32 @exit(i32 noundef 1)\n"
|
||||||
mapM_ (const increaseVarCount) [0 .. 1]
|
mapM_ (const increaseVarCount) [0 .. 1]
|
||||||
emit $ Br label
|
emit $ Br label
|
||||||
|
|
|
||||||
|
|
@ -133,7 +133,8 @@ data LLVMIr
|
||||||
| Bitcast LLVMType LLVMValue LLVMType
|
| Bitcast LLVMType LLVMValue LLVMType
|
||||||
| Ret LLVMType LLVMValue
|
| Ret LLVMType LLVMValue
|
||||||
| Comment String
|
| Comment String
|
||||||
| Malloca Integer
|
| Malloc Integer
|
||||||
|
| GcMalloc Integer
|
||||||
| UnsafeRaw String -- This should generally be avoided, and proper
|
| UnsafeRaw String -- This should generally be avoided, and proper
|
||||||
-- instructions should be used in its place
|
-- instructions should be used in its place
|
||||||
deriving (Show, Eq, Ord)
|
deriving (Show, Eq, Ord)
|
||||||
|
|
@ -223,7 +224,10 @@ llvmIrToString = go 0
|
||||||
, ")\n"
|
, ")\n"
|
||||||
]
|
]
|
||||||
(Alloca t) -> unwords ["alloca", toIr t, "\n"]
|
(Alloca t) -> unwords ["alloca", toIr t, "\n"]
|
||||||
(Malloca t) ->
|
(Malloc t) ->
|
||||||
|
concat
|
||||||
|
[ "call ptr @malloc(i64 ", show t, ")\n"]
|
||||||
|
(GcMalloc t) ->
|
||||||
concat
|
concat
|
||||||
[ "call ptr @cheap_alloc(i64 ", show t, ")\n"]
|
[ "call ptr @cheap_alloc(i64 ", show t, ")\n"]
|
||||||
(Store t1 val t2 (Ident id2)) ->
|
(Store t1 val t2 (Ident id2)) ->
|
||||||
|
|
|
||||||
|
|
@ -10,8 +10,19 @@ import System.Process.Extra (
|
||||||
optimize :: String -> IO String
|
optimize :: String -> IO String
|
||||||
optimize = readCreateProcess (shell "opt --O3 --tailcallopt -S")
|
optimize = readCreateProcess (shell "opt --O3 --tailcallopt -S")
|
||||||
|
|
||||||
compileClang :: String -> IO String
|
compileClang :: Bool -> String -> IO String
|
||||||
compileClang =
|
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 $
|
readCreateProcess . shell $
|
||||||
unwords
|
unwords
|
||||||
[ "clang++" -- , "-Lsrc/GC/lib/", "-l:libgcoll.a"
|
[ "clang++" -- , "-Lsrc/GC/lib/", "-l:libgcoll.a"
|
||||||
|
|
@ -30,4 +41,4 @@ compileClang =
|
||||||
]
|
]
|
||||||
|
|
||||||
compile :: String -> Bool -> IO String
|
compile :: String -> Bool -> IO String
|
||||||
compile s addGc = optimize s >>= compileClang
|
compile s addGc = optimize s >>= compileClang addGc
|
||||||
|
|
|
||||||
Loading…
Add table
Add a link
Reference in a new issue