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

Fix Codegen

Browse source
This commit is contained in:
Martin Fredin 2023-03-27 16:21:01 +02:00
parent 22783cf817
commit db2f8cd197
1 changed files with 35 additions and 78 deletions
Download patch file Download diff file Expand all files Collapse all files

113
src/Codegen/Codegen.hs
View file

@ -17,7 +17,6 @@ import Data.Tuple.Extra (dupe, first, second)
import Debug.Trace (trace) 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 (Ident (..))
import Monomorphizer.MonomorphizerIr as MIR import Monomorphizer.MonomorphizerIr as MIR
-- | The record used as the code generator state -- | The record used as the code generator state
@ -58,13 +57,8 @@ 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
<<<<<<< HEAD
getNewVar :: CompilerState GA.Ident getNewVar :: CompilerState GA.Ident
getNewVar = GA.Ident . show <$> (increaseVarCount >> getVarCount) getNewVar = GA.Ident . show <$> (increaseVarCount >> getVarCount)
=======
getNewVar :: CompilerState Ident
getNewVar = (Ident . show) <$> (increaseVarCount >> getVarCount)
>>>>>>> da28c6d (Add bidirectional type checker, lambda lifter.)
-- | 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
@ -82,25 +76,10 @@ getFunctions bs = Map.fromList $ go bs
go (MIR.DBind (MIR.Bind id args _) : xs) = go (MIR.DBind (MIR.Bind id args _) : xs) =
(id, FunctionInfo{numArgs = length args, arguments = args}) (id, FunctionInfo{numArgs = length args, arguments = args})
: go xs : go xs
<<<<<<< HEAD
go (_ : xs) = go xs go (_ : xs) = go xs
=======
go (MIR.DData (MIR.Data n cons) : xs) =
do map
( \(Inj id xs) ->
( (coerce id, MIR.TLit (extractTypeName n))
, FunctionInfo
{ numArgs = undefined -- TODO
, arguments = createArgs (snd <$> undefined) -- TODO
}
)
)
cons
<> go xs
>>>>>>> da28c6d (Add bidirectional type checker, lambda lifter.)
createArgs :: [MIR.Type] -> [Id] createArgs :: [MIR.Type] -> [Id]
createArgs xs = fst $ foldl (\(acc, l) t -> (acc ++ [(Ident ("arg_" <> show l), t)], l + 1)) ([], 0) xs createArgs xs = fst $ foldl (\(acc, l) t -> (acc ++ [(GA.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.
@ -110,7 +89,6 @@ 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) =
<<<<<<< HEAD
fst fst
( foldl ( foldl
( \(acc, i) (Constructor id xs) -> ( \(acc, i) (Constructor id xs) ->
@ -118,17 +96,6 @@ getConstructors bs = Map.fromList $ go bs
, ConstructorInfo , ConstructorInfo
{ numArgsCI = length (init . flattenType $ xs) { numArgsCI = length (init . flattenType $ xs)
, argumentsCI = createArgs (init . flattenType $ xs) , argumentsCI = createArgs (init . flattenType $ xs)
=======
do
let (Ident n) = extractTypeName t
fst
( foldl
( \(acc, i) (Inj (Ident id) xs) ->
( ( (Ident (n <> "_" <> id), MIR.TLit (coerce n))
, ConstructorInfo
{ numArgsCI = undefined -- TODO
, argumentsCI = createArgs (snd <$> undefined) -- TODO
>>>>>>> da28c6d (Add bidirectional type checker, lambda lifter.)
, numCI = i , numCI = i
, returnTypeCI = t --last . flattenType $ xs , returnTypeCI = t --last . flattenType $ xs
} }
@ -166,30 +133,30 @@ test :: Integer -> Program
test v = test v =
Program Program
[ DataType [ DataType
(Ident "Craig") (GA.Ident "Craig")
[ Constructor (Ident "Bob") [MIR.Type (Ident "_Int")] [ Constructor (GA.Ident "Bob") [MIR.Type (GA.Ident "_Int")]
, Constructor (Ident "Betty") [MIR.Type (Ident "_Int")] , Constructor (GA.Ident "Betty") [MIR.Type (GA.Ident "_Int")]
] ]
, DataType , DataType
(Ident "Alice") (GA.Ident "Alice")
[ Constructor (Ident "Eve") [MIR.Type (Ident "_Int")] -- , [ Constructor (GA.Ident "Eve") [MIR.Type (GA.Ident "_Int")] -- ,
-- (Ident "Alice", [TInt, TInt]) -- (GA.Ident "Alice", [TInt, TInt])
] ]
, Bind (Ident "fibonacci", MIR.Type (Ident "_Int")) [(Ident "x", MIR.Type (Ident "_Int"))] (EVar ("x", MIR.Type (Ident "Craig")), MIR.Type (Ident "Craig")) , 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 (Ident "main", MIR.Type (Ident "_Int")) [] , Bind (GA.Ident "main", MIR.Type (GA.Ident "_Int")) []
-- (EApp (MIR.Type (Ident "Craig")) (EVar (Ident "Craig_Bob", MIR.Type (Ident "Craig")), MIR.Type (Ident "Craig")) (ELit (LInt v), MIR.Type (Ident "_Int")), MIR.Type (Ident "Craig"))-- (EInt 92) -- (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)
$ $
eCaseInt eCaseInt
(EApp (MIR.TLit (Ident "Craig")) (EVar (Ident "Craig_Bob", MIR.TLit (Ident "Craig")), MIR.TLit (Ident "Craig")) (ELit (LInt v), MIR.Type (Ident "_Int")), MIR.Type (Ident "Craig")) (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"))
[ injectionCons "Craig_Bob" "Craig" [CIdent (Ident "x")] (EVar (Ident "x", MIR.Type (Ident "_Int")), MIR.Type (Ident "_Int")) [ injectionCons "Craig_Bob" "Craig" [CIdent (GA.Ident "x")] (EId (GA.Ident "x", MIR.Type (GA.Ident "_Int")), MIR.Type (GA.Ident "_Int"))
, injectionCons "Craig_Betty" "Craig" [CLit (LInt 5)] (int 2) , injectionCons "Craig_Betty" "Craig" [CLit (LInt 5)] (int 2)
, Injection (CIdent (Ident "z")) (int 3) , Injection (CIdent (GA.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 (Ident x, MIR.Type (Ident y)) xs) injectionCons x y xs = Injection (CCons (GA.Ident x, MIR.Type (GA.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"))
@ -239,7 +206,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 (Ident arg_n, arg_t) -> do ( \i (GA.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
@ -255,7 +222,7 @@ compileScs [] = do
I32 I32
(VInteger i) (VInteger i)
) )
emit $ Store arg_t' (VIdent (Ident arg_n) arg_t') Ptr elemPtr emit $ Store arg_t' (VIdent (GA.Ident arg_n) arg_t') Ptr elemPtr
) )
(argumentsCI ci) (argumentsCI ci)
@ -288,13 +255,8 @@ compileScs (MIR.DData (MIR.Data typ ts) : xs) = do
let biggestVariant = 7 + maximum (sum . (\(Constructor _ fi) -> typeByteSize <$> variantTypes fi) <$> ts) let biggestVariant = 7 + maximum (sum . (\(Constructor _ fi) -> typeByteSize <$> variantTypes fi) <$> ts)
emit $ LIR.Type (Ident outer_id) [I8, Array biggestVariant I8] emit $ LIR.Type (Ident outer_id) [I8, Array biggestVariant I8]
mapM_ mapM_
<<<<<<< HEAD
( \(Constructor inner_id fi) -> do ( \(Constructor inner_id fi) -> do
emit $ LIR.Type inner_id (I8 : variantTypes fi) emit $ LIR.Type inner_id (I8 : variantTypes fi)
=======
( \(Inj (Ident inner_id) fi) -> do
emit $ LIR.Type (Ident $ outer_id <> "_" <> inner_id) (I8 : map type2LlvmType (snd <$> undefined)) -- TODO
>>>>>>> da28c6d (Add bidirectional type checker, lambda lifter.)
) )
ts ts
compileScs xs compileScs xs
@ -320,17 +282,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 (Ident "p") (Icmp LLEq I64 (VInteger 2) (VInteger 2)) , -- , SetVariable (GA.Ident "p") (Icmp LLEq I64 (VInteger 2) (VInteger 2))
-- , BrCond (VIdent (Ident "p")) (Ident "b_1") (Ident "b_2") -- , BrCond (VIdent (GA.Ident "p")) (GA.Ident "b_1") (GA.Ident "b_2")
-- , Label (Ident "b_1") -- , Label (GA.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 (Ident "end") -- , Br (GA.Ident "end")
-- , Label (Ident "b_2") -- , Label (GA.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 (Ident "end") -- , Br (GA.Ident "end")
-- , Label (Ident "end") -- , Label (GA.Ident "end")
Ret I64 (VInteger 0) Ret I64 (VInteger 0)
] ]
@ -348,7 +310,7 @@ 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.EVar name,t) = emitIdent name compileExp (MIR.EId 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)
@ -366,7 +328,7 @@ 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 = Ident $ "escape_" <> show lbl let label = GA.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
@ -379,13 +341,13 @@ emitECased t e cases = do
res <- getNewVar res <- getNewVar
emit $ SetVariable res (Load ty Ptr stackPtr) emit $ SetVariable res (Load ty Ptr stackPtr)
where where
emitCases :: LLVMType -> LLVMType -> Ident -> Ident -> LLVMValue -> Branch -> CompilerState () emitCases :: LLVMType -> LLVMType -> GA.Ident -> GA.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
cons <- gets constructors cons <- gets constructors
let r = fromJust $ Map.lookup consId cons let r = fromJust $ Map.lookup consId cons
lbl_failPos <- (\x -> Ident $ "failed_" <> show x) <$> getNewLabel lbl_failPos <- (\x -> GA.Ident $ "failed_" <> show x) <$> getNewLabel
lbl_succPos <- (\x -> Ident $ "success_" <> show x) <$> getNewLabel lbl_succPos <- (\x -> GA.Ident $ "success_" <> show x) <$> getNewLabel
consVal <- getNewVar consVal <- getNewVar
emit $ SetVariable consVal (ExtractValue rt vs 0) emit $ SetVariable consVal (ExtractValue rt vs 0)
@ -435,8 +397,8 @@ emitECased t e cases = do
(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 -> Ident $ "failed_" <> show x) <$> getNewLabel lbl_failPos <- (\x -> GA.Ident $ "failed_" <> show x) <$> getNewLabel
lbl_succPos <- (\x -> Ident $ "success_" <> show x) <$> getNewLabel lbl_succPos <- (\x -> GA.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
@ -482,13 +444,8 @@ emitApp rt e1 e2 = appEmitter e1 e2 []
appEmitter e1 e2 stack = do appEmitter e1 e2 stack = do
let newStack = e2 : stack let newStack = e2 : stack
case e1 of case e1 of
<<<<<<< HEAD
(MIR.EApp e1' e2', _) -> appEmitter e1' e2' newStack (MIR.EApp e1' e2', _) -> appEmitter e1' e2' newStack
(MIR.EId name, t) -> do (MIR.EId name, t) -> do
=======
(MIR.EApp e1' e2', t) -> appEmitter e1' e2' newStack
(MIR.EVar name, t) -> do
>>>>>>> da28c6d (Add bidirectional type checker, lambda lifter.)
args <- traverse exprToValue newStack args <- traverse exprToValue newStack
vs <- getNewVar vs <- getNewVar
funcs <- gets functions funcs <- gets functions
@ -505,7 +462,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 :: Ident -> CompilerState () emitIdent :: GA.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!"
@ -520,14 +477,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 (Ident (show varCount)) (Add t i' (VInteger 0)) emit $ SetVariable (GA.Ident (show 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 (Ident $ show v) (Add (type2LlvmType t) v1 v2) emit $ SetVariable (GA.Ident $ show 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
@ -541,7 +498,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.EVar name, t) -> do (MIR.EId 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
@ -558,7 +515,7 @@ exprToValue = \case
e -> do e -> do
compileExp e compileExp e
v <- getVarCount v <- getVarCount
pure $ VIdent (Ident $ show v) (getType e) pure $ VIdent (GA.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@(Ident name)) = case name of