Rakarake/churf
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Fixed the dependency on the Grammar Ident.

Browse source
This commit is contained in:
Samuel Hammersberg 2023-03-27 16:31:30 +02:00
parent db2f8cd197
commit 72f4f26078
2 changed files with 73 additions and 69 deletions
Download patch file Download diff file Expand all files Collapse all files

122
src/Codegen/Codegen.hs
View file

@ -18,12 +18,13 @@ import Debug.Trace (trace)
import qualified Grammar.Abs as GA import qualified Grammar.Abs as GA
import Grammar.ErrM (Err) import Grammar.ErrM (Err)
import Monomorphizer.MonomorphizerIr as MIR import Monomorphizer.MonomorphizerIr as MIR
import qualified TypeChecker.TypeCheckerIr as TIR
-- | The record used as the code generator state -- | The record used as the code generator state
data CodeGenerator = CodeGenerator data CodeGenerator = CodeGenerator
{ instructions :: [LLVMIr] { instructions :: [LLVMIr]
, functions :: Map MIR.Id FunctionInfo , functions :: Map MIR.Id FunctionInfo
, constructors :: Map GA.Ident ConstructorInfo , constructors :: Map TIR.Ident ConstructorInfo
, variableCount :: Integer , variableCount :: Integer
, labelCount :: Integer , labelCount :: Integer
} }
@ -50,15 +51,15 @@ emit l = modify $ \t -> t{instructions = Auxiliary.snoc l $ instructions t}
-- | Increases the variable counter in the CodeGenerator state -- | Increases the variable counter in the CodeGenerator state
increaseVarCount :: CompilerState () increaseVarCount :: CompilerState ()
increaseVarCount = modify $ \t -> t{variableCount = variableCount t + 1} increaseVarCount = (emit $ Comment "increase") >> (modify $ \t -> t{variableCount = variableCount t + 1})
-- | Returns the variable count from the CodeGenerator state -- | Returns the variable count from the CodeGenerator state
getVarCount :: CompilerState Integer getVarCount :: CompilerState Integer
getVarCount = gets variableCount getVarCount = gets variableCount
-- | Increases the variable count and returns it from the CodeGenerator state -- | Increases the variable count and returns it from the CodeGenerator state
getNewVar :: CompilerState GA.Ident getNewVar :: CompilerState TIR.Ident
getNewVar = GA.Ident . show <$> (increaseVarCount >> getVarCount) getNewVar = TIR.Ident . show <$> (increaseVarCount >> getVarCount)
-- | Increses the label count and returns a label from the CodeGenerator state -- | Increses the label count and returns a label from the CodeGenerator state
getNewLabel :: CompilerState Integer getNewLabel :: CompilerState Integer
@ -79,19 +80,19 @@ getFunctions bs = Map.fromList $ go bs
go (_ : xs) = go xs go (_ : xs) = go xs
createArgs :: [MIR.Type] -> [Id] createArgs :: [MIR.Type] -> [Id]
createArgs xs = fst $ foldl (\(acc, l) t -> (acc ++ [(GA.Ident ("arg_" <> show l), t)], l + 1)) ([], 0) xs createArgs xs = fst $ foldl (\(acc, l) t -> (acc ++ [(TIR.Ident ("arg_" <> show l), t)], l + 1)) ([], 0) xs
{- | Produces a map of functions infos from a list of binds, {- | Produces a map of functions infos from a list of binds,
which contains useful data for code generation. which contains useful data for code generation.
-} -}
getConstructors :: [MIR.Def] -> Map GA.Ident ConstructorInfo getConstructors :: [MIR.Def] -> Map TIR.Ident ConstructorInfo
getConstructors bs = Map.fromList $ go bs getConstructors bs = Map.fromList $ go bs
where where
go [] = [] go [] = []
go (MIR.DData (MIR.Data t cons) : xs) = go (MIR.DData (MIR.Data t cons) : xs) =
fst fst
( foldl ( foldl
( \(acc, i) (Constructor id xs) -> ( \(acc, i) (Inj id xs) ->
( ( id ( ( id
, ConstructorInfo , ConstructorInfo
{ numArgsCI = length (init . flattenType $ xs) { numArgsCI = length (init . flattenType $ xs)
@ -133,30 +134,30 @@ test :: Integer -> Program
test v = test v =
Program Program
[ DataType [ DataType
(GA.Ident "Craig") (TIR.Ident "Craig")
[ Constructor (GA.Ident "Bob") [MIR.Type (GA.Ident "_Int")] [ Constructor (TIR.Ident "Bob") [MIR.Type (TIR.Ident "_Int")]
, Constructor (GA.Ident "Betty") [MIR.Type (GA.Ident "_Int")] , Constructor (TIR.Ident "Betty") [MIR.Type (TIR.Ident "_Int")]
] ]
, DataType , DataType
(GA.Ident "Alice") (TIR.Ident "Alice")
[ Constructor (GA.Ident "Eve") [MIR.Type (GA.Ident "_Int")] -- , [ Constructor (TIR.Ident "Eve") [MIR.Type (TIR.Ident "_Int")] -- ,
-- (GA.Ident "Alice", [TInt, TInt]) -- (TIR.Ident "Alice", [TInt, TInt])
] ]
, Bind (GA.Ident "fibonacci", MIR.Type (GA.Ident "_Int")) [(GA.Ident "x", MIR.Type (GA.Ident "_Int"))] (EId ("x", MIR.Type (GA.Ident "Craig")), MIR.Type (GA.Ident "Craig")) , Bind (TIR.Ident "fibonacci", MIR.Type (TIR.Ident "_Int")) [(TIR.Ident "x", MIR.Type (TIR.Ident "_Int"))] (EId ("x", MIR.Type (TIR.Ident "Craig")), MIR.Type (TIR.Ident "Craig"))
, Bind (GA.Ident "main", MIR.Type (GA.Ident "_Int")) [] , Bind (TIR.Ident "main", MIR.Type (TIR.Ident "_Int")) []
-- (EApp (MIR.Type (GA.Ident "Craig")) (EId (GA.Ident "Craig_Bob", MIR.Type (GA.Ident "Craig")), MIR.Type (GA.Ident "Craig")) (ELit (LInt v), MIR.Type (GA.Ident "_Int")), MIR.Type (GA.Ident "Craig"))-- (EInt 92) -- (EApp (MIR.Type (TIR.Ident "Craig")) (EId (TIR.Ident "Craig_Bob", MIR.Type (TIR.Ident "Craig")), MIR.Type (TIR.Ident "Craig")) (ELit (LInt v), MIR.Type (TIR.Ident "_Int")), MIR.Type (TIR.Ident "Craig"))-- (EInt 92)
$ $
eCaseInt eCaseInt
(EApp (MIR.TLit (GA.Ident "Craig")) (EId (GA.Ident "Craig_Bob", MIR.TLit (GA.Ident "Craig")), MIR.TLit (GA.Ident "Craig")) (ELit (LInt v), MIR.Type (GA.Ident "_Int")), MIR.Type (GA.Ident "Craig")) (EApp (MIR.TLit (TIR.Ident "Craig")) (EId (TIR.Ident "Craig_Bob", MIR.TLit (TIR.Ident "Craig")), MIR.TLit (TIR.Ident "Craig")) (ELit (LInt v), MIR.Type (TIR.Ident "_Int")), MIR.Type (TIR.Ident "Craig"))
[ injectionCons "Craig_Bob" "Craig" [CIdent (GA.Ident "x")] (EId (GA.Ident "x", MIR.Type (GA.Ident "_Int")), MIR.Type (GA.Ident "_Int")) [ injectionCons "Craig_Bob" "Craig" [CIdent (TIR.Ident "x")] (EId (TIR.Ident "x", MIR.Type (TIR.Ident "_Int")), MIR.Type (TIR.Ident "_Int"))
, injectionCons "Craig_Betty" "Craig" [CLit (LInt 5)] (int 2) , injectionCons "Craig_Betty" "Craig" [CLit (LInt 5)] (int 2)
, Injection (CIdent (GA.Ident "z")) (int 3) , Injection (CIdent (TIR.Ident "z")) (int 3)
, -- , injectionInt 5 (int 6) , -- , injectionInt 5 (int 6)
injectionCatchAll (int 10) injectionCatchAll (int 10)
] ]
] ]
where where
injectionCons x y xs = Injection (CCons (GA.Ident x, MIR.Type (GA.Ident y)) xs) injectionCons x y xs = Injection (CCons (TIR.Ident x, MIR.Type (TIR.Ident y)) xs)
injectionInt x = Injection (CLit (LInt x)) injectionInt x = Injection (CLit (LInt x))
injectionCatchAll = Injection CatchAll injectionCatchAll = Injection CatchAll
eCaseInt x xs = (ECase (MIR.TLit (MIR.Ident "_Int")) x xs, MIR.TLit (MIR.Ident "_Int")) eCaseInt x xs = (ECase (MIR.TLit (MIR.Ident "_Int")) x xs, MIR.TLit (MIR.Ident "_Int"))
@ -206,7 +207,7 @@ compileScs [] = do
emit $ SetVariable ptr' (Bitcast (Ref t') (VIdent top Ptr) (Ref $ CustomType id)) emit $ SetVariable ptr' (Bitcast (Ref t') (VIdent top Ptr) (Ref $ CustomType id))
enumerateOneM_ enumerateOneM_
( \i (GA.Ident arg_n, arg_t) -> do ( \i (TIR.Ident arg_n, arg_t) -> do
let arg_t' = type2LlvmType arg_t let arg_t' = type2LlvmType arg_t
emit $ Comment (toIr arg_t' <> " " <> arg_n <> " " <> show i) emit $ Comment (toIr arg_t' <> " " <> arg_n <> " " <> show i)
elemPtr <- getNewVar elemPtr <- getNewVar
@ -222,7 +223,7 @@ compileScs [] = do
I32 I32
(VInteger i) (VInteger i)
) )
emit $ Store arg_t' (VIdent (GA.Ident arg_n) arg_t') Ptr elemPtr emit $ Store arg_t' (VIdent (TIR.Ident arg_n) arg_t') Ptr elemPtr
) )
(argumentsCI ci) (argumentsCI ci)
@ -250,12 +251,12 @@ compileScs (MIR.DBind (MIR.Bind (name, _t) args exp) : xs) = do
modify $ \s -> s{variableCount = 0} modify $ \s -> s{variableCount = 0}
compileScs xs compileScs xs
compileScs (MIR.DData (MIR.Data typ ts) : xs) = do compileScs (MIR.DData (MIR.Data typ ts) : xs) = do
let (Ident outer_id) = extractTypeName typ let (TIR.Ident outer_id) = extractTypeName typ
let variantTypes fi = init $ map type2LlvmType (flattenType fi) let variantTypes fi = init $ map type2LlvmType (flattenType fi)
let biggestVariant = 7 + maximum (sum . (\(Constructor _ fi) -> typeByteSize <$> variantTypes fi) <$> ts) let biggestVariant = 7 + maximum (sum . (\(Inj _ fi) -> typeByteSize <$> variantTypes fi) <$> ts)
emit $ LIR.Type (Ident outer_id) [I8, Array biggestVariant I8] emit $ LIR.Type (TIR.Ident outer_id) [I8, Array biggestVariant I8]
mapM_ mapM_
( \(Constructor inner_id fi) -> do ( \(Inj inner_id fi) -> do
emit $ LIR.Type inner_id (I8 : variantTypes fi) emit $ LIR.Type inner_id (I8 : variantTypes fi)
) )
ts ts
@ -282,17 +283,17 @@ mainContent var =
-- " %4 = load i72, ptr %3\n" <> -- " %4 = load i72, ptr %3\n" <>
-- " call i32 (ptr, ...) @printf(ptr noundef @.str, i72 noundef %4)\n" -- " call i32 (ptr, ...) @printf(ptr noundef @.str, i72 noundef %4)\n"
"call i32 (ptr, ...) @printf(ptr noundef @.str, i64 noundef " <> toIr var <> ")\n" "call i32 (ptr, ...) @printf(ptr noundef @.str, i64 noundef " <> toIr var <> ")\n"
, -- , SetVariable (GA.Ident "p") (Icmp LLEq I64 (VInteger 2) (VInteger 2)) , -- , SetVariable (TIR.Ident "p") (Icmp LLEq I64 (VInteger 2) (VInteger 2))
-- , BrCond (VIdent (GA.Ident "p")) (GA.Ident "b_1") (GA.Ident "b_2") -- , BrCond (VIdent (TIR.Ident "p")) (TIR.Ident "b_1") (TIR.Ident "b_2")
-- , Label (GA.Ident "b_1") -- , Label (TIR.Ident "b_1")
-- , UnsafeRaw -- , UnsafeRaw
-- "call i32 (ptr, ...) @printf(ptr noundef @.str, i64 noundef 1)\n" -- "call i32 (ptr, ...) @printf(ptr noundef @.str, i64 noundef 1)\n"
-- , Br (GA.Ident "end") -- , Br (TIR.Ident "end")
-- , Label (GA.Ident "b_2") -- , Label (TIR.Ident "b_2")
-- , UnsafeRaw -- , UnsafeRaw
-- "call i32 (ptr, ...) @printf(ptr noundef @.str, i64 noundef 2)\n" -- "call i32 (ptr, ...) @printf(ptr noundef @.str, i64 noundef 2)\n"
-- , Br (GA.Ident "end") -- , Br (TIR.Ident "end")
-- , Label (GA.Ident "end") -- , Label (TIR.Ident "end")
Ret I64 (VInteger 0) Ret I64 (VInteger 0)
] ]
@ -301,16 +302,16 @@ defaultStart =
[ UnsafeRaw "target triple = \"x86_64-pc-linux-gnu\"\n" [ UnsafeRaw "target triple = \"x86_64-pc-linux-gnu\"\n"
, UnsafeRaw "target datalayout = \"e-m:o-i64:64-f80:128-n8:16:32:64-S128\"\n" , UnsafeRaw "target datalayout = \"e-m:o-i64:64-f80:128-n8:16:32:64-S128\"\n"
, UnsafeRaw "@.str = private unnamed_addr constant [3 x i8] c\"%i\n\", align 1\n" , UnsafeRaw "@.str = private unnamed_addr constant [3 x i8] c\"%i\n\", align 1\n"
, UnsafeRaw "@.non_exhaustive_patterns = private unnamed_addr constant [41 x i8] c\"Non-exhaustive patterns in case at %i:%i\n\"" , UnsafeRaw "@.non_exhaustive_patterns = private unnamed_addr constant [41 x i8] c\"Non-exhaustive patterns in case at %i:%i\n\"\n"
, UnsafeRaw "declare i32 @printf(ptr noalias nocapture, ...)\n" , UnsafeRaw "declare i32 @printf(ptr noalias nocapture, ...)\n"
, UnsafeRaw "declare i32 @exit(i32)\n" , UnsafeRaw "declare i32 @exit(i32 noundef)\n"
] ]
compileExp :: ExpT -> CompilerState () compileExp :: ExpT -> CompilerState ()
compileExp (MIR.ELit lit,t) = emitLit lit compileExp (MIR.ELit lit,t) = emitLit lit
compileExp (MIR.EAdd e1 e2,t) = emitAdd t e1 e2 compileExp (MIR.EAdd e1 e2,t) = emitAdd t e1 e2
-- compileExp (ESub t e1 e2) = emitSub t e1 e2 -- compileExp (ESub t e1 e2) = emitSub t e1 e2
compileExp (MIR.EId name,t) = emitIdent name compileExp (MIR.EVar name, t) = emitIdent name
compileExp (MIR.EApp e1 e2,t) = emitApp t e1 e2 compileExp (MIR.EApp e1 e2,t) = emitApp t e1 e2
-- compileExp (EAbs t ti e) = emitAbs t ti e -- compileExp (EAbs t ti e) = emitAbs t ti e
compileExp (MIR.ELet binds e,t) = undefined -- emitLet binds (fst e) compileExp (MIR.ELet binds e,t) = undefined -- emitLet binds (fst e)
@ -328,26 +329,28 @@ emitECased t e cases = do
let rt = type2LlvmType (snd e) let rt = type2LlvmType (snd e)
vs <- exprToValue e vs <- exprToValue e
lbl <- getNewLabel lbl <- getNewLabel
let label = GA.Ident $ "escape_" <> show lbl let label = TIR.Ident $ "escape_" <> show lbl
stackPtr <- getNewVar stackPtr <- getNewVar
emit $ SetVariable stackPtr (Alloca ty) emit $ SetVariable stackPtr (Alloca ty)
mapM_ (emitCases rt ty label stackPtr vs) cs mapM_ (emitCases rt ty label stackPtr vs) cs
crashLbl <- TIR.Ident . ("crash_" <>) . show <$> getNewLabel
emit $ Label crashLbl
emit . UnsafeRaw $ "call i32 (ptr, ...) @printf(ptr noundef @.non_exhaustive_patterns, i64 noundef 6, i64 noundef 6)\n" emit . UnsafeRaw $ "call i32 (ptr, ...) @printf(ptr noundef @.non_exhaustive_patterns, i64 noundef 6, i64 noundef 6)\n"
emit . UnsafeRaw $ "call i32 @exit(i32 1)\n" emit . UnsafeRaw $ "call i32 @exit(i32 noundef 1)\n"
emit . UnsafeRaw $ "unreachable\n" mapM_ (const increaseVarCount) [0..1]
increaseVarCount >> increaseVarCount >> increaseVarCount
emit $ Br label emit $ Br label
emit $ Label label emit $ Label label
res <- getNewVar res <- getNewVar
emit $ SetVariable res (Load ty Ptr stackPtr) emit $ SetVariable res (Load ty Ptr stackPtr)
where where
emitCases :: LLVMType -> LLVMType -> GA.Ident -> GA.Ident -> LLVMValue -> Branch -> CompilerState () emitCases :: LLVMType -> LLVMType -> TIR.Ident -> TIR.Ident -> LLVMValue -> Branch -> CompilerState ()
emitCases rt ty label stackPtr vs (Branch (MIR.PInj consId cs, t) exp) = do emitCases rt ty label stackPtr vs (Branch (MIR.PInj consId cs, t) exp) = do
emit $ Comment "Inj"
cons <- gets constructors cons <- gets constructors
let r = fromJust $ Map.lookup consId cons let r = fromJust $ Map.lookup consId cons
lbl_failPos <- (\x -> GA.Ident $ "failed_" <> show x) <$> getNewLabel lbl_failPos <- (\x -> TIR.Ident $ "failed_" <> show x) <$> getNewLabel
lbl_succPos <- (\x -> GA.Ident $ "success_" <> show x) <$> getNewLabel lbl_succPos <- (\x -> TIR.Ident $ "success_" <> show x) <$> getNewLabel
consVal <- getNewVar consVal <- getNewVar
emit $ SetVariable consVal (ExtractValue rt vs 0) emit $ SetVariable consVal (ExtractValue rt vs 0)
@ -362,7 +365,6 @@ emitECased t e cases = do
emit $ SetVariable castPtr (Alloca rt) emit $ SetVariable castPtr (Alloca rt)
emit $ Store rt vs Ptr castPtr emit $ Store rt vs Ptr castPtr
emit $ SetVariable casted (Load (CustomType (coerce consId)) Ptr castPtr) emit $ SetVariable casted (Load (CustomType (coerce consId)) Ptr castPtr)
val <- exprToValue exp val <- exprToValue exp
enumerateOneM_ enumerateOneM_
(\i c -> do (\i c -> do
@ -393,12 +395,13 @@ emitECased t e cases = do
emit $ Br label emit $ Br label
emit $ Label lbl_failPos emit $ Label lbl_failPos
emitCases rt ty label stackPtr vs (Branch (MIR.PLit i, _) exp) = do emitCases rt ty label stackPtr vs (Branch (MIR.PLit i, _) exp) = do
emit $ Comment "Plit"
let i' = case i of let i' = case i of
(MIR.LInt i, _) -> VInteger i (MIR.LInt i, _) -> VInteger i
(MIR.LChar i, _) -> VChar i (MIR.LChar i, _) -> VChar i
ns <- getNewVar ns <- getNewVar
lbl_failPos <- (\x -> GA.Ident $ "failed_" <> show x) <$> getNewLabel lbl_failPos <- (\x -> TIR.Ident $ "failed_" <> show x) <$> getNewLabel
lbl_succPos <- (\x -> GA.Ident $ "success_" <> show x) <$> getNewLabel lbl_succPos <- (\x -> TIR.Ident $ "success_" <> show x) <$> getNewLabel
emit $ SetVariable ns (Icmp LLEq ty vs i') emit $ SetVariable ns (Icmp LLEq ty vs i')
emit $ BrCond (VIdent ns ty) lbl_succPos lbl_failPos emit $ BrCond (VIdent ns ty) lbl_succPos lbl_failPos
emit $ Label lbl_succPos emit $ Label lbl_succPos
@ -407,20 +410,22 @@ emitECased t e cases = do
emit $ Br label emit $ Br label
emit $ Label lbl_failPos emit $ Label lbl_failPos
emitCases rt ty label stackPtr vs (Branch (MIR.PVar (id,_), _) exp) = do emitCases rt ty label stackPtr vs (Branch (MIR.PVar (id,_), _) exp) = do
emit $ Comment "Pvar"
-- //TODO this is pretty disgusting and would heavily benefit from a rewrite -- //TODO this is pretty disgusting and would heavily benefit from a rewrite
valPtr <- getNewVar valPtr <- getNewVar
emit $ SetVariable valPtr (Alloca rt) emit $ SetVariable valPtr (Alloca rt)
emit $ Store rt vs Ptr valPtr emit $ Store rt vs Ptr valPtr
emit $ SetVariable id (Load rt Ptr valPtr) emit $ SetVariable id (Load rt Ptr valPtr)
increaseVarCount
val <- exprToValue exp val <- exprToValue exp
emit $ Store ty val Ptr stackPtr emit $ Store ty val Ptr stackPtr
emit $ Br label emit $ Br label
emitCases rt ty label stackPtr vs (Branch (MIR.PEnum id, _) exp) = do emitCases rt ty label stackPtr vs (Branch (MIR.PEnum id, _) exp) = do
emit $ Comment "Penum"
val <- exprToValue exp val <- exprToValue exp
emit $ Store ty val Ptr stackPtr emit $ Store ty val Ptr stackPtr
emit $ Br label emit $ Br label
emitCases _ ty label stackPtr _ (Branch (MIR.PCatch, _) exp) = do emitCases _ ty label stackPtr _ (Branch (MIR.PCatch, _) exp) = do
emit $ Comment "Pcatch"
val <- exprToValue exp val <- exprToValue exp
emit $ Store ty val Ptr stackPtr emit $ Store ty val Ptr stackPtr
emit $ Br label emit $ Br label
@ -445,7 +450,7 @@ emitApp rt e1 e2 = appEmitter e1 e2 []
let newStack = e2 : stack let newStack = e2 : stack
case e1 of case e1 of
(MIR.EApp e1' e2', _) -> appEmitter e1' e2' newStack (MIR.EApp e1' e2', _) -> appEmitter e1' e2' newStack
(MIR.EId name, t) -> do (MIR.EVar name, t) -> do
args <- traverse exprToValue newStack args <- traverse exprToValue newStack
vs <- getNewVar vs <- getNewVar
funcs <- gets functions funcs <- gets functions
@ -462,7 +467,7 @@ emitApp rt e1 e2 = appEmitter e1 e2 []
emit $ SetVariable vs call emit $ SetVariable vs call
x -> error $ "The unspeakable happened: " <> show x x -> error $ "The unspeakable happened: " <> show x
emitIdent :: GA.Ident -> CompilerState () emitIdent :: TIR.Ident -> CompilerState ()
emitIdent id = do emitIdent id = do
-- !!this should never happen!! -- !!this should never happen!!
emit $ Comment "This should not have happened!" emit $ Comment "This should not have happened!"
@ -477,14 +482,14 @@ emitLit i = do
(MIR.LChar i'') -> (VChar i'', I8) (MIR.LChar i'') -> (VChar i'', I8)
varCount <- getNewVar varCount <- getNewVar
emit $ Comment "This should not have happened!" emit $ Comment "This should not have happened!"
emit $ SetVariable (GA.Ident (show varCount)) (Add t i' (VInteger 0)) emit $ SetVariable varCount (Add t i' (VInteger 0))
emitAdd :: MIR.Type -> ExpT -> ExpT -> CompilerState () emitAdd :: MIR.Type -> ExpT -> ExpT -> CompilerState ()
emitAdd t e1 e2 = do emitAdd t e1 e2 = do
v1 <- exprToValue e1 v1 <- exprToValue e1
v2 <- exprToValue e2 v2 <- exprToValue e2
v <- getNewVar v <- getNewVar
emit $ SetVariable (GA.Ident $ show v) (Add (type2LlvmType t) v1 v2) emit $ SetVariable v (Add (type2LlvmType t) v1 v2)
emitSub :: MIR.Type -> ExpT -> ExpT -> CompilerState () emitSub :: MIR.Type -> ExpT -> ExpT -> CompilerState ()
emitSub t e1 e2 = do emitSub t e1 e2 = do
@ -498,7 +503,7 @@ exprToValue = \case
(MIR.ELit i, t) -> pure $ case i of (MIR.ELit i, t) -> pure $ case i of
(MIR.LInt i) -> VInteger i (MIR.LInt i) -> VInteger i
(MIR.LChar i) -> VChar i (MIR.LChar i) -> VChar i
(MIR.EId name, t) -> do (MIR.EVar name, t) -> do
funcs <- gets functions funcs <- gets functions
case Map.lookup (name, t) funcs of case Map.lookup (name, t) funcs of
Just fi -> do Just fi -> do
@ -515,10 +520,10 @@ exprToValue = \case
e -> do e -> do
compileExp e compileExp e
v <- getVarCount v <- getVarCount
pure $ VIdent (GA.Ident $ show v) (getType e) pure $ VIdent (TIR.Ident $ show v) (getType e)
type2LlvmType :: MIR.Type -> LLVMType type2LlvmType :: MIR.Type -> LLVMType
type2LlvmType (MIR.TLit id@(Ident name)) = case name of type2LlvmType (MIR.TLit id@(TIR.Ident name)) = case name of
"Int" -> I64 "Int" -> I64
_ -> CustomType id _ -> CustomType id
type2LlvmType (MIR.TFun t xs) = do type2LlvmType (MIR.TFun t xs) = do
@ -532,11 +537,11 @@ type2LlvmType (MIR.TFun t xs) = do
getType :: ExpT -> LLVMType getType :: ExpT -> LLVMType
getType (_, t) = type2LlvmType t getType (_, t) = type2LlvmType t
extractTypeName :: MIR.Type -> Ident extractTypeName :: MIR.Type -> TIR.Ident
extractTypeName (MIR.TLit id) = id extractTypeName (MIR.TLit id) = id
extractTypeName (MIR.TFun t xs) = let (Ident i) = extractTypeName t extractTypeName (MIR.TFun t xs) = let (TIR.Ident i) = extractTypeName t
(Ident is) = extractTypeName xs (TIR.Ident is) = extractTypeName xs
in Ident $ i <> "_$_" <> is in TIR.Ident $ i <> "_$_" <> is
valueGetType :: LLVMValue -> LLVMType valueGetType :: LLVMValue -> LLVMType
valueGetType (VInteger _) = I64 valueGetType (VInteger _) = I64
@ -558,4 +563,3 @@ typeByteSize (CustomType _) = 8
enumerateOneM_ :: Monad m => (Integer -> a -> m b) -> [a] -> m () enumerateOneM_ :: Monad m => (Integer -> a -> m b) -> [a] -> m ()
enumerateOneM_ f = foldM_ (\i a -> f i a >> pure (i + 1)) 1 enumerateOneM_ f = foldM_ (\i a -> f i a >> pure (i + 1)) 1

16
src/Monomorphizer/MonomorphizerIr.hs
View file

@ -1,9 +1,9 @@
module Monomorphizer.MonomorphizerIr (module Monomorphizer.MonomorphizerIr, module GA) where module Monomorphizer.MonomorphizerIr (module Monomorphizer.MonomorphizerIr, module GA) where
import Grammar.Abs (Ident (..))
import qualified Grammar.Abs as GA (Ident (..)) import qualified Grammar.Abs as GA (Ident (..))
import qualified TypeChecker.TypeCheckerIr as TIR (Ident (..))
type Id = (Ident, Type) type Id = (TIR.Ident, Type)
newtype Program = Program [Def] newtype Program = Program [Def]
deriving (Show, Ord, Eq) deriving (Show, Ord, Eq)
@ -18,7 +18,7 @@ data Bind = Bind Id [Id] ExpT
deriving (Show, Ord, Eq) deriving (Show, Ord, Eq)
data Exp data Exp
= EVar Ident = EVar TIR.Ident
| ELit Lit | ELit Lit
| ELet Bind ExpT | ELet Bind ExpT
| EApp ExpT ExpT | EApp ExpT ExpT
@ -26,8 +26,8 @@ data Exp
| ECase ExpT [Branch] | ECase ExpT [Branch]
deriving (Show, Ord, Eq) deriving (Show, Ord, Eq)
data Pattern = PVar Id | PLit (Lit, Type) | PInj Ident [Pattern] data Pattern = PVar Id | PLit (Lit, Type) | PInj TIR.Ident [Pattern]
| PCatch | PEnum Ident | PCatch | PEnum TIR.Ident
deriving (Eq, Ord, Show) deriving (Eq, Ord, Show)
data Branch = Branch (Pattern, Type) ExpT data Branch = Branch (Pattern, Type) ExpT
@ -35,15 +35,15 @@ data Branch = Branch (Pattern, Type) ExpT
type ExpT = (Exp, Type) type ExpT = (Exp, Type)
data Inj = Inj Ident Type data Inj = Inj TIR.Ident Type
deriving (Show, Ord, Eq) deriving (Show, Ord, Eq)
data Lit data Lit
= LInt Integer = LInt Integer
| LChar Character | LChar Char
deriving (Show, Ord, Eq) deriving (Show, Ord, Eq)
data Type = TLit Ident | TFun Type Type data Type = TLit TIR.Ident | TFun Type Type
deriving (Show, Ord, Eq) deriving (Show, Ord, Eq)
flattenType :: Type -> [Type] flattenType :: Type -> [Type]