From 50bea83a186548adf7df9989dc7e1f2767045c5c Mon Sep 17 00:00:00 2001 From: Samuel Hammersberg Date: Fri, 24 Mar 2023 13:55:06 +0100 Subject: [PATCH] Got some more stuff working. --- src/Codegen/Codegen.hs | 624 ++++++++++++++------------- src/Monomorphizer/Monomorphizer.hs | 32 +- src/Monomorphizer/MonomorphizerIr.hs | 10 +- 3 files changed, 338 insertions(+), 328 deletions(-) diff --git a/src/Codegen/Codegen.hs b/src/Codegen/Codegen.hs index f8da93e..4e95102 100644 --- a/src/Codegen/Codegen.hs +++ b/src/Codegen/Codegen.hs @@ -1,9 +1,22 @@ -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} -module Codegen.Codegen where +module Codegen.Codegen (generateCode) where --- module Codegen.Codegen (generateCode) where +import Auxiliary (snoc) +import Codegen.LlvmIr as LIR +import Control.Applicative ((<|>)) +import Control.Monad.State (StateT, execStateT, foldM_, + gets, modify) +import qualified Data.Bifunctor as BI +import Data.Coerce (coerce) +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Maybe (fromJust, fromMaybe) +import Data.Tuple.Extra (dupe, first, second) +import qualified Grammar.Abs as GA +import Grammar.ErrM (Err) +import Monomorphizer.MonomorphizerIr as MIR -- | The record used as the code generator state data CodeGenerator = CodeGenerator @@ -14,45 +27,42 @@ data CodeGenerator = CodeGenerator , labelCount :: Integer } ----- | The record used as the code generator state --- data CodeGenerator = CodeGenerator --- { instructions :: [LLVMIr] --- , functions :: Map MIR.Id FunctionInfo --- , constructors :: Map Ident ConstructorInfo --- , variableCount :: Integer --- , labelCount :: Integer --- } +-- | A state type synonym +type CompilerState a = StateT CodeGenerator Err a ----- | A state type synonym --- type CompilerState a = StateT CodeGenerator Err a +data FunctionInfo = FunctionInfo + { numArgs :: Int + , arguments :: [Id] + } + deriving (Show) +data ConstructorInfo = ConstructorInfo + { numArgsCI :: Int + , argumentsCI :: [Id] + , numCI :: Integer + } + deriving (Show) --- data FunctionInfo = FunctionInfo --- { numArgs :: Int --- , arguments :: [Id] --- } --- deriving (Show) --- data ConstructorInfo = ConstructorInfo --- { numArgsCI :: Int --- , argumentsCI :: [Id] --- , numCI :: Integer --- } --- deriving (Show) +-- | Adds a instruction to the CodeGenerator state +emit :: LLVMIr -> CompilerState () +emit l = modify $ \t -> t{instructions = Auxiliary.snoc l $ instructions t} ----- | Adds a instruction to the CodeGenerator state --- emit :: LLVMIr -> CompilerState () --- emit l = modify $ \t -> t{instructions = Auxiliary.snoc l $ instructions t} +-- | Increases the variable counter in the CodeGenerator state +increaseVarCount :: CompilerState () +increaseVarCount = modify $ \t -> t{variableCount = variableCount t + 1} ----- | Increases the variable counter in the CodeGenerator state --- increaseVarCount :: CompilerState () --- increaseVarCount = modify $ \t -> t{variableCount = variableCount t + 1} +-- | Returns the variable count from the CodeGenerator state +getVarCount :: CompilerState Integer +getVarCount = gets variableCount ----- | Returns the variable count from the CodeGenerator state --- getVarCount :: CompilerState Integer --- getVarCount = gets variableCount +-- | Increases the variable count and returns it from the CodeGenerator state +getNewVar :: CompilerState GA.Ident +getNewVar = (GA.Ident . show) <$> (increaseVarCount >> getVarCount) ----- | Increases the variable count and returns it from the CodeGenerator state --- getNewVar :: CompilerState GA.Ident --- getNewVar = (GA.Ident . show) <$> (increaseVarCount >> getVarCount) +-- | Increses the label count and returns a label from the CodeGenerator state +getNewLabel :: CompilerState Integer +getNewLabel = do + modify (\t -> t{labelCount = labelCount t + 1}) + gets labelCount {- | Produces a map of functions infos from a list of binds, which contains useful data for code generation. @@ -64,41 +74,21 @@ getFunctions bs = Map.fromList $ go bs go (MIR.DBind (MIR.Bind id args _) : xs) = (id, FunctionInfo{numArgs = length args, arguments = args}) : go xs - go (MIR.DData (MIR.Constructor n cons) : xs) = + go (MIR.DData (MIR.Data n cons) : xs) = do map - ( \(id, xs) -> - ( (coerce id, MIR.TLit (coerce n)) + ( \(Constructor id xs) -> + ( (coerce id, MIR.TLit (extractTypeName n)) , FunctionInfo - { numArgs = length (flattenType xs) - , arguments = createArgs (flattenType xs) + { numArgs = length xs + , arguments = createArgs (snd <$> xs) } ) ) cons <> go xs --- {- | Produces a map of functions infos from a list of binds, --- which contains useful data for code generation. ----} --- getFunctions :: [MIR.Def] -> Map Id FunctionInfo --- getFunctions bs = Map.fromList $ go bs --- where --- go [] = [] --- go (MIR.DBind (MIR.Bind id args _) : xs) = --- (id, FunctionInfo{numArgs = length args, arguments = args}) --- : go xs --- go (MIR.DData (MIR.Constructor n cons) : xs) = undefined --- {-do map --- ( \(Constructor id xs) -> --- ( (id, MIR.TLit n) --- , FunctionInfo --- { numArgs = length xs --- , arguments = createArgs xs --- } --- ) --- ) --- cons --- <> go xs-} +createArgs :: [MIR.Type] -> [Id] +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, which contains useful data for code generation. @@ -107,15 +97,16 @@ getConstructors :: [MIR.Def] -> Map MIR.Id ConstructorInfo getConstructors bs = Map.fromList $ go bs where go [] = [] - go (MIR.DData (MIR.Constructor (GA.UIdent n) cons) : xs) = + go (MIR.DData (MIR.Data t cons) : xs) = do + let (GA.Ident n) = extractTypeName t fst ( foldl - ( \(acc, i) (GA.UIdent id, xs) -> + ( \(acc, i) (Constructor (GA.UIdent id) xs) -> ( ( (GA.Ident (n <> "_" <> id), MIR.TLit (coerce n)) , ConstructorInfo - { numArgsCI = length (flattenType xs) - , argumentsCI = createArgs (flattenType xs) + { numArgsCI = length xs + , argumentsCI = createArgs (snd <$> xs) , numCI = i } ) @@ -129,53 +120,66 @@ getConstructors bs = Map.fromList $ go bs <> go xs go (_ : xs) = go xs --- {- | Produces a map of functions infos from a list of binds, --- which contains useful data for code generation. ----} --- getConstructors :: [MIR.Def] -> Map Ident ConstructorInfo --- getConstructors bs = Map.fromList $ go bs --- where --- go [] = [] --- go (MIR.DData (MIR.Constructor n cons) : xs) = undefined --- {-do --- fst --- ( foldl --- ( \(acc, i) (GA.Constructor (GA.Ident id) xs) -> --- ( ( (GA.Ident (n <> "_" <> id), MIR.TLit (GA.Ident n)) --- , ConstructorInfo --- { numArgsCI = length xs --- , argumentsCI = createArgs xs --- , numCI = i --- } --- ) --- : acc --- , i + 1 --- ) --- ) --- ([], 0) --- cons --- ) --- <> go xs-} --- go (_ : xs) = go xs +initCodeGenerator :: [MIR.Def] -> CodeGenerator +initCodeGenerator scs = + CodeGenerator + { instructions = defaultStart + , functions = getFunctions scs + , constructors = getConstructors scs + , variableCount = 0 + , labelCount = 0 + } --- initCodeGenerator :: [MIR.Def] -> CodeGenerator --- initCodeGenerator scs = --- CodeGenerator --- { instructions = defaultStart --- , functions = getFunctions scs --- , constructors = getConstructors scs --- , variableCount = 0 --- , labelCount = 0 --- } +{- +run :: Err String -> IO () +run s = do + let s' = case s of + Right s -> s + Left _ -> error "yo" + writeFile "output/llvm.ll" s' + putStrLn . trim =<< readCreateProcess (shell "lli") s' --- {- --- run :: Err String -> IO () --- run s = do --- let s' = case s of --- Right s -> s --- Left _ -> error "yo" --- writeFile "output/llvm.ll" s' --- putStrLn . trim =<< readCreateProcess (shell "lli") s' +test :: Integer -> Program +test v = + Program + [ DataType + (GA.Ident "Craig") + [ Constructor (GA.Ident "Bob") [MIR.Type (GA.Ident "_Int")] + , Constructor (GA.Ident "Betty") [MIR.Type (GA.Ident "_Int")] + ] + , DataType + (GA.Ident "Alice") + [ Constructor (GA.Ident "Eve") [MIR.Type (GA.Ident "_Int")] -- , + -- (GA.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 (GA.Ident "main", MIR.Type (GA.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) + $ + 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")) + [ 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) + , Injection (CIdent (GA.Ident "z")) (int 3) + , -- , injectionInt 5 (int 6) + injectionCatchAll (int 10) + ] + ] + where + injectionCons x y xs = Injection (CCons (GA.Ident x, MIR.Type (GA.Ident y)) xs) + injectionInt x = Injection (CLit (LInt x)) + injectionCatchAll = Injection CatchAll + eCaseInt x xs = (ECase (MIR.TLit (MIR.Ident "_Int")) x xs, MIR.TLit (MIR.Ident "_Int")) + int x = (ELit (LInt x), MIR.TLit (MIR.Ident "_Int")) +-} +{- | Compiles an AST and produces a LLVM Ir string. + An easy way to actually "compile" this output is to + Simply pipe it to LLI +-} +generateCode :: MIR.Program -> Err String +generateCode (MIR.Program scs) = do + let codegen = initCodeGenerator scs + llvmIrToString . instructions <$> execStateT (compileScs scs) codegen compileScs :: [MIR.Def] -> CompilerState () compileScs [] = do @@ -256,61 +260,61 @@ compileScs (MIR.DBind (MIR.Bind (name, _t) args exp) : xs) = do emit DefineEnd modify $ \s -> s{variableCount = 0} compileScs xs -compileScs (MIR.DData (MIR.Constructor (GA.UIdent outer_id) ts) : xs) = do - let types = BI.second flattenType <$> ts - let biggestVariant = maximum $ sum . map (typeByteSize . type2LlvmType) <$> (snd <$> types) +compileScs (MIR.DData (MIR.Data typ ts) : xs) = do + let (Ident outer_id) = extractTypeName typ + let biggestVariant = maximum $ sum <$> (\(Constructor _ t) -> typeByteSize . type2LlvmType . snd <$> t) <$> ts emit $ LIR.Type (coerce outer_id) [I8, Array biggestVariant I8] mapM_ - ( \(GA.UIdent inner_id, fi) -> do - emit $ LIR.Type (GA.Ident $ outer_id <> "_" <> inner_id) (I8 : map type2LlvmType fi) + ( \(Constructor (GA.UIdent inner_id) fi) -> do + emit $ LIR.Type (GA.Ident $ outer_id <> "_" <> inner_id) (I8 : map type2LlvmType (snd <$> fi)) ) - types + ts compileScs xs --- mainContent :: LLVMValue -> [LLVMIr] --- mainContent var = --- [ UnsafeRaw $ --- -- "%2 = alloca %Craig\n" <> --- -- " store %Craig %1, ptr %2\n" <> --- -- " %3 = bitcast %Craig* %2 to i72*\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, i64 noundef " <> toIr var <> ")\n" --- , -- , SetVariable (GA.Ident "p") (Icmp LLEq I64 (VInteger 2) (VInteger 2)) --- -- , BrCond (VIdent (GA.Ident "p")) (GA.Ident "b_1") (GA.Ident "b_2") --- -- , Label (GA.Ident "b_1") --- -- , UnsafeRaw --- -- "call i32 (ptr, ...) @printf(ptr noundef @.str, i64 noundef 1)\n" --- -- , Br (GA.Ident "end") --- -- , Label (GA.Ident "b_2") --- -- , UnsafeRaw --- -- "call i32 (ptr, ...) @printf(ptr noundef @.str, i64 noundef 2)\n" --- -- , Br (GA.Ident "end") --- -- , Label (GA.Ident "end") --- Ret I64 (VInteger 0) --- ] +mainContent :: LLVMValue -> [LLVMIr] +mainContent var = + [ UnsafeRaw $ + -- "%2 = alloca %Craig\n" <> + -- " store %Craig %1, ptr %2\n" <> + -- " %3 = bitcast %Craig* %2 to i72*\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, i64 noundef " <> toIr var <> ")\n" + , -- , SetVariable (GA.Ident "p") (Icmp LLEq I64 (VInteger 2) (VInteger 2)) + -- , BrCond (VIdent (GA.Ident "p")) (GA.Ident "b_1") (GA.Ident "b_2") + -- , Label (GA.Ident "b_1") + -- , UnsafeRaw + -- "call i32 (ptr, ...) @printf(ptr noundef @.str, i64 noundef 1)\n" + -- , Br (GA.Ident "end") + -- , Label (GA.Ident "b_2") + -- , UnsafeRaw + -- "call i32 (ptr, ...) @printf(ptr noundef @.str, i64 noundef 2)\n" + -- , Br (GA.Ident "end") + -- , Label (GA.Ident "end") + Ret I64 (VInteger 0) + ] --- defaultStart :: [LLVMIr] --- defaultStart = --- [ 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 "@.str = private unnamed_addr constant [3 x i8] c\"%x\n\", align 1\n" --- , UnsafeRaw "declare i32 @printf(ptr noalias nocapture, ...)\n" --- ] +defaultStart :: [LLVMIr] +defaultStart = + [ 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 "@.str = private unnamed_addr constant [3 x i8] c\"%x\n\", align 1\n" + , UnsafeRaw "declare i32 @printf(ptr noalias nocapture, ...)\n" + ] --- compileExp :: ExpT -> CompilerState () --- compileExp (MIR.ELit lit,t) = emitLit lit --- compileExp (MIR.EAdd e1 e2,t) = emitAdd t e1 e2 ----- compileExp (ESub t e1 e2) = emitSub t e1 e2 --- compileExp (MIR.EId name,t) = emitIdent name --- compileExp (MIR.EApp e1 e2,t) = emitApp t e1 e2 ----- compileExp (EAbs t ti e) = emitAbs t ti e --- compileExp (MIR.ELet binds e,t) = undefined -- emitLet binds (fst e) --- compileExp (MIR.ECase e cs,t) = emitECased t e (map (t,) cs) +compileExp :: ExpT -> CompilerState () +compileExp (MIR.ELit lit,t) = emitLit lit +compileExp (MIR.EAdd e1 e2,t) = emitAdd t e1 e2 +-- compileExp (ESub t e1 e2) = emitSub t e1 e2 +compileExp (MIR.EId name,t) = emitIdent name +compileExp (MIR.EApp e1 e2,t) = emitApp t e1 e2 +-- compileExp (EAbs t ti e) = emitAbs t ti e +compileExp (MIR.ELet binds e,t) = undefined -- emitLet binds (fst e) +compileExp (MIR.ECase e cs,t) = emitECased t e (map (t,) cs) ----- go (EMul e1 e2) = emitMul e1 e2 ----- go (EDiv e1 e2) = emitDiv e1 e2 ----- go (EMod e1 e2) = emitMod e1 e2 +-- go (EMul e1 e2) = emitMul e1 e2 +-- go (EDiv e1 e2) = emitDiv e1 e2 +-- go (EMod e1 e2) = emitMod e1 e2 --- aux functions --- emitECased :: MIR.Type -> ExpT -> [(MIR.Type, Injection)] -> CompilerState () @@ -333,89 +337,89 @@ emitECased t e cases = do cons <- gets constructors let r = fromJust $ Map.lookup (coerce consId, t) cons --- lbl_failPos <- (\x -> GA.Ident $ "failed_" <> show x) <$> getNewLabel --- lbl_succPos <- (\x -> GA.Ident $ "success_" <> show x) <$> getNewLabel + lbl_failPos <- (\x -> GA.Ident $ "failed_" <> show x) <$> getNewLabel + lbl_succPos <- (\x -> GA.Ident $ "success_" <> show x) <$> getNewLabel --- consVal <- getNewVar --- emit $ SetVariable consVal (ExtractValue rt vs 0) + consVal <- getNewVar + emit $ SetVariable consVal (ExtractValue rt vs 0) --- consCheck <- getNewVar --- emit $ SetVariable consCheck (Icmp LLEq I8 (VIdent consVal I8) (VInteger $ numCI r)) --- emit $ BrCond (VIdent consCheck ty) lbl_succPos lbl_failPos --- emit $ Label lbl_succPos + consCheck <- getNewVar + emit $ SetVariable consCheck (Icmp LLEq I8 (VIdent consVal I8) (VInteger $ numCI r)) + emit $ BrCond (VIdent consCheck ty) lbl_succPos lbl_failPos + emit $ Label lbl_succPos --- castPtr <- getNewVar --- castedPtr <- getNewVar --- casted <- getNewVar --- emit $ SetVariable castPtr (Alloca rt) --- emit $ Store rt vs Ptr castPtr --- emit $ SetVariable castedPtr (Bitcast Ptr (VIdent castPtr Ptr) Ptr) --- emit $ SetVariable casted (Load (CustomType (coerce consId)) Ptr castedPtr) + castPtr <- getNewVar + castedPtr <- getNewVar + casted <- getNewVar + emit $ SetVariable castPtr (Alloca rt) + emit $ Store rt vs Ptr castPtr + emit $ SetVariable castedPtr (Bitcast Ptr (VIdent castPtr Ptr) Ptr) + emit $ SetVariable casted (Load (CustomType (coerce consId)) Ptr castedPtr) --- val <- exprToValue exp --- -- enumerateOneM_ --- -- (\i c -> do --- -- case c of --- -- CIdent x -> do --- -- emit . Comment $ "ident " <> show x --- -- emit $ SetVariable x (ExtractValue (CustomType (fst consId)) (VIdent casted Ptr) i) --- -- emit $ Store ty val Ptr stackPtr --- -- CCons x cs -> error "nested constructor" --- -- CLit l -> do --- -- testVar <- getNewVar --- -- emit $ SetVariable testVar (ExtractValue (CustomType (fst consId)) (VIdent casted Ptr) i) --- -- case l of --- -- LInt l -> emit $ Icmp LLEq I64 (VIdent testVar Ptr) (VInteger l) --- -- LChar c -> emit $ Icmp LLEq I8 (VIdent testVar Ptr) (VChar c) --- -- CCatch -> emit . Comment $ "Catch all" --- -- emit . Comment $ "return this " <> toIr val --- -- emit . Comment . show $ c --- -- emit . Comment . show $ i --- -- ) --- -- cs --- -- emit $ Store ty val Ptr stackPtr --- emit $ Br label --- emit $ Label lbl_failPos --- emitCases rt ty label stackPtr vs (Injection (MIR.InitLit i, _) exp) = do --- let i' = case i of --- GA.LInt i -> VInteger i --- GA.LChar i -> VChar i --- ns <- getNewVar --- lbl_failPos <- (\x -> GA.Ident $ "failed_" <> show x) <$> getNewLabel --- lbl_succPos <- (\x -> GA.Ident $ "success_" <> show x) <$> getNewLabel --- emit $ SetVariable ns (Icmp LLEq ty vs i') --- emit $ BrCond (VIdent ns ty) lbl_succPos lbl_failPos --- emit $ Label lbl_succPos --- val <- exprToValue exp --- emit $ Store ty val Ptr stackPtr --- emit $ Br label --- emit $ Label lbl_failPos ----- emitCases rt ty label stackPtr vs (Injection (MIR.CIdent id) exp) = do ----- -- //TODO this is pretty disgusting and would heavily benefit from a rewrite ----- valPtr <- getNewVar ----- emit $ SetVariable valPtr (Alloca rt) ----- emit $ Store rt vs Ptr valPtr ----- emit $ SetVariable id (Load rt Ptr valPtr) ----- increaseVarCount ----- val <- exprToValue (fst exp) ----- emit $ Store ty val Ptr stackPtr ----- emit $ Br label --- emitCases _ ty label stackPtr _ (Injection (MIR.InitCatch, _) exp) = do --- val <- exprToValue exp --- emit $ Store ty val Ptr stackPtr --- emit $ Br label + val <- exprToValue exp + -- enumerateOneM_ + -- (\i c -> do + -- case c of + -- CIdent x -> do + -- emit . Comment $ "ident " <> show x + -- emit $ SetVariable x (ExtractValue (CustomType (fst consId)) (VIdent casted Ptr) i) + -- emit $ Store ty val Ptr stackPtr + -- CCons x cs -> error "nested constructor" + -- CLit l -> do + -- testVar <- getNewVar + -- emit $ SetVariable testVar (ExtractValue (CustomType (fst consId)) (VIdent casted Ptr) i) + -- case l of + -- LInt l -> emit $ Icmp LLEq I64 (VIdent testVar Ptr) (VInteger l) + -- LChar c -> emit $ Icmp LLEq I8 (VIdent testVar Ptr) (VChar c) + -- CCatch -> emit . Comment $ "Catch all" + -- emit . Comment $ "return this " <> toIr val + -- emit . Comment . show $ c + -- emit . Comment . show $ i + -- ) + -- cs + -- emit $ Store ty val Ptr stackPtr + emit $ Br label + emit $ Label lbl_failPos + emitCases rt ty label stackPtr vs (Injection (MIR.InitLit i, _) exp) = do + let i' = case i of + GA.LInt i -> VInteger i + GA.LChar i -> VChar i + ns <- getNewVar + lbl_failPos <- (\x -> GA.Ident $ "failed_" <> show x) <$> getNewLabel + lbl_succPos <- (\x -> GA.Ident $ "success_" <> show x) <$> getNewLabel + emit $ SetVariable ns (Icmp LLEq ty vs i') + emit $ BrCond (VIdent ns ty) lbl_succPos lbl_failPos + emit $ Label lbl_succPos + val <- exprToValue exp + emit $ Store ty val Ptr stackPtr + emit $ Br label + emit $ Label lbl_failPos +-- emitCases rt ty label stackPtr vs (Injection (MIR.CIdent id) exp) = do +-- -- //TODO this is pretty disgusting and would heavily benefit from a rewrite +-- valPtr <- getNewVar +-- emit $ SetVariable valPtr (Alloca rt) +-- emit $ Store rt vs Ptr valPtr +-- emit $ SetVariable id (Load rt Ptr valPtr) +-- increaseVarCount +-- val <- exprToValue (fst exp) +-- emit $ Store ty val Ptr stackPtr +-- emit $ Br label + emitCases _ ty label stackPtr _ (Injection (MIR.InitCatch, _) exp) = do + val <- exprToValue exp + emit $ Store ty val Ptr stackPtr + emit $ Br label -----emitLet :: Bind -> Exp -> CompilerState () --- emitLet xs e = do --- emit $ --- Comment $ --- concat --- [ "ELet (" --- , show xs --- , " = " --- , show e --- , ") is not implemented!" --- ] +--emitLet :: Bind -> Exp -> CompilerState () +emitLet xs e = do + emit $ + Comment $ + concat + [ "ELet (" + , show xs + , " = " + , show e + , ") is not implemented!" + ] emitApp :: MIR.Type -> ExpT -> ExpT -> CompilerState () emitApp t e1 e2 = appEmitter e1 e2 [] @@ -440,60 +444,60 @@ emitApp t e1 e2 = appEmitter e1 e2 [] emit $ SetVariable vs call x -> error $ "The unspeakable happened: " <> show x --- emitIdent :: GA.Ident -> CompilerState () --- emitIdent id = do --- -- !!this should never happen!! --- emit $ Comment "This should not have happened!" --- emit $ Variable id --- emit $ UnsafeRaw "\n" +emitIdent :: GA.Ident -> CompilerState () +emitIdent id = do + -- !!this should never happen!! + emit $ Comment "This should not have happened!" + emit $ Variable id + emit $ UnsafeRaw "\n" --- emitLit :: MIR.Lit -> CompilerState () --- emitLit i = do --- -- !!this should never happen!! --- let (i', t) = case i of --- (MIR.LInt i'') -> (VInteger i'', I64) --- (MIR.LChar i'') -> (VChar i'', I8) --- varCount <- getNewVar --- emit $ Comment "This should not have happened!" --- emit $ SetVariable (GA.Ident (show varCount)) (Add t i' (VInteger 0)) +emitLit :: MIR.Lit -> CompilerState () +emitLit i = do + -- !!this should never happen!! + let (i', t) = case i of + (MIR.LInt i'') -> (VInteger i'', I64) + (MIR.LChar i'') -> (VChar i'', I8) + varCount <- getNewVar + emit $ Comment "This should not have happened!" + emit $ SetVariable (GA.Ident (show varCount)) (Add t i' (VInteger 0)) --- emitAdd :: MIR.Type -> ExpT -> ExpT -> CompilerState () --- emitAdd t e1 e2 = do --- v1 <- exprToValue e1 --- v2 <- exprToValue e2 --- v <- getNewVar --- emit $ SetVariable (GA.Ident $ show v) (Add (type2LlvmType t) v1 v2) +emitAdd :: MIR.Type -> ExpT -> ExpT -> CompilerState () +emitAdd t e1 e2 = do + v1 <- exprToValue e1 + v2 <- exprToValue e2 + v <- getNewVar + emit $ SetVariable (GA.Ident $ show v) (Add (type2LlvmType t) v1 v2) --- emitSub :: MIR.Type -> ExpT -> ExpT -> CompilerState () --- emitSub t e1 e2 = do --- v1 <- exprToValue e1 --- v2 <- exprToValue e2 --- v <- getNewVar --- emit $ SetVariable v (Sub (type2LlvmType t) v1 v2) +emitSub :: MIR.Type -> ExpT -> ExpT -> CompilerState () +emitSub t e1 e2 = do + v1 <- exprToValue e1 + v2 <- exprToValue e2 + v <- getNewVar + emit $ SetVariable v (Sub (type2LlvmType t) v1 v2) --- exprToValue :: ExpT -> CompilerState LLVMValue --- exprToValue = \case --- (MIR.ELit i, t) -> pure $ case i of --- (MIR.LInt i) -> VInteger i --- (MIR.LChar i) -> VChar i --- (MIR.EId name, t) -> do --- funcs <- gets functions --- case Map.lookup (name, t) funcs of --- Just fi -> do --- if numArgs fi == 0 --- then do --- vc <- getNewVar --- emit $ --- SetVariable --- vc --- (Call FastCC (type2LlvmType t) Global name []) --- pure $ VIdent vc (type2LlvmType t) --- else pure $ VFunction name Global (type2LlvmType t) --- Nothing -> pure $ VIdent name (type2LlvmType t) --- e -> do --- compileExp e --- v <- getVarCount --- pure $ VIdent (GA.Ident $ show v) (getType e) +exprToValue :: ExpT -> CompilerState LLVMValue +exprToValue = \case + (MIR.ELit i, t) -> pure $ case i of + (MIR.LInt i) -> VInteger i + (MIR.LChar i) -> VChar i + (MIR.EId name, t) -> do + funcs <- gets functions + case Map.lookup (name, t) funcs of + Just fi -> do + if numArgs fi == 0 + then do + vc <- getNewVar + emit $ + SetVariable + vc + (Call FastCC (type2LlvmType t) Global name []) + pure $ VIdent vc (type2LlvmType t) + else pure $ VFunction name Global (type2LlvmType t) + Nothing -> pure $ VIdent name (type2LlvmType t) + e -> do + compileExp e + v <- getVarCount + pure $ VIdent (GA.Ident $ show v) (getType e) type2LlvmType :: MIR.Type -> LLVMType type2LlvmType (MIR.TLit id@(Ident name)) = case name of @@ -507,26 +511,32 @@ type2LlvmType (MIR.TFun t xs) = do function2LLVMType (TFun t xs) s = function2LLVMType xs (type2LlvmType t : s) function2LLVMType x s = (type2LlvmType x, s) --- getType :: ExpT -> LLVMType --- getType (_, t) = type2LlvmType t +getType :: ExpT -> LLVMType +getType (_, t) = type2LlvmType t --- valueGetType :: LLVMValue -> LLVMType --- valueGetType (VInteger _) = I64 --- valueGetType (VChar _) = I8 --- valueGetType (VIdent _ t) = t --- valueGetType (VConstant s) = Array (fromIntegral $ length s) I8 --- valueGetType (VFunction _ _ t) = t +extractTypeName :: MIR.Type -> Ident +extractTypeName (MIR.TLit id) = id +extractTypeName (MIR.TFun t xs) = let (Ident i) = extractTypeName t + (Ident is) = extractTypeName xs + in Ident $ i <> "_$_" <> is --- typeByteSize :: LLVMType -> Integer --- typeByteSize I1 = 1 --- typeByteSize I8 = 1 --- typeByteSize I32 = 4 --- typeByteSize I64 = 8 --- typeByteSize Ptr = 8 --- typeByteSize (Ref _) = 8 --- typeByteSize (Function _ _) = 8 --- typeByteSize (Array n t) = n * typeByteSize t --- typeByteSize (CustomType _) = 8 +valueGetType :: LLVMValue -> LLVMType +valueGetType (VInteger _) = I64 +valueGetType (VChar _) = I8 +valueGetType (VIdent _ t) = t +valueGetType (VConstant s) = Array (fromIntegral $ length s) I8 +valueGetType (VFunction _ _ t) = t --- enumerateOneM_ :: Monad m => (Integer -> a -> m b) -> [a] -> m () --- enumerateOneM_ f = foldM_ (\i a -> f i a >> pure (i + 1)) 1 +typeByteSize :: LLVMType -> Integer +typeByteSize I1 = 1 +typeByteSize I8 = 1 +typeByteSize I32 = 4 +typeByteSize I64 = 8 +typeByteSize Ptr = 8 +typeByteSize (Ref _) = 8 +typeByteSize (Function _ _) = 8 +typeByteSize (Array n t) = n * typeByteSize t +typeByteSize (CustomType _) = 8 + +enumerateOneM_ :: Monad m => (Integer -> a -> m b) -> [a] -> m () +enumerateOneM_ f = foldM_ (\i a -> f i a >> pure (i + 1)) 1 diff --git a/src/Monomorphizer/Monomorphizer.hs b/src/Monomorphizer/Monomorphizer.hs index 104c318..a4b92e1 100644 --- a/src/Monomorphizer/Monomorphizer.hs +++ b/src/Monomorphizer/Monomorphizer.hs @@ -2,13 +2,13 @@ module Monomorphizer.Monomorphizer (monomorphize) where -import Data.Coerce (coerce) -import Grammar.Abs (Constructor (..), Ident (..)) -import Unsafe.Coerce (unsafeCoerce) +import Data.Coerce (coerce) +import Grammar.Abs (Constructor (..), Ident (..)) +import Unsafe.Coerce (unsafeCoerce) -import Grammar.Abs qualified as GA -import Monomorphizer.MonomorphizerIr qualified as M -import TypeChecker.TypeCheckerIr qualified as T +import qualified Grammar.Abs as GA +import qualified Monomorphizer.MonomorphizerIr as M +import qualified TypeChecker.TypeCheckerIr as T monomorphize :: T.Program -> M.Program monomorphize (T.Program ds) = M.Program $ monoDefs ds @@ -18,7 +18,7 @@ monoDefs = map monoDef monoDef :: T.Def -> M.Def monoDef (T.DBind bind) = M.DBind $ monoBind bind -monoDef (T.DData d) = M.DData $ unsafeCoerce d +monoDef (T.DData d) = M.DData $ unsafeCoerce d monoBind :: T.Bind -> M.Bind monoBind (T.Bind name args (e, t)) = M.Bind (monoId name) (map monoId args) (monoExpr e, monoType t) @@ -34,19 +34,19 @@ monoExpr = \case T.ECase expt injs -> M.ECase (monoexpt expt) (monoInjs injs) monoAbsType :: GA.Type -> M.Type -monoAbsType (GA.TLit u) = M.TLit (coerce u) -monoAbsType (GA.TVar _v) = error "NOT POLYMORHPIC TYPES" +monoAbsType (GA.TLit u) = M.TLit (coerce u) +monoAbsType (GA.TVar _v) = error "NOT POLYMORHPIC TYPES" monoAbsType (GA.TAll _v _t) = error "NOT ALL TYPES" -monoAbsType (GA.TData _ i) = error "NOT INDEXED TYPES" -monoAbsType (GA.TEVar _v) = error "I DONT KNOW WHAT THIS IS" +monoAbsType (GA.TEVar _v) = error "I DONT KNOW WHAT THIS IS" monoAbsType (GA.TFun t1 t2) = M.TFun (monoAbsType t1) (monoAbsType t2) +monoAbsType (GA.TIndexed _) = error "NOT INDEXED TYPES" monoType :: T.Type -> M.Type -monoType (T.TAll _ t) = monoType t +monoType (T.TAll _ t) = monoType t monoType (T.TVar (T.MkTVar i)) = error "NOT POLYMORPHIC TYPES" -monoType (T.TLit i) = M.TLit i -monoType (T.TFun t1 t2) = M.TFun (monoType t1) (monoType t2) -monoType (T.TData _ _) = error "Not sure what this is" +monoType (T.TLit i) = M.TLit i +monoType (T.TFun t1 t2) = M.TFun (monoType t1) (monoType t2) +monoType (T.TData _ _) = error "Not sure what this is" monoexpt :: T.ExpT -> M.ExpT monoexpt (e, t) = (monoExpr e, monoType t) @@ -55,7 +55,7 @@ monoId :: T.Id -> M.Id monoId (n, t) = (n, monoType t) monoLit :: T.Lit -> M.Lit -monoLit (T.LInt i) = M.LInt i +monoLit (T.LInt i) = M.LInt i monoLit (T.LChar c) = M.LChar c monoInjs :: [T.Inj] -> [M.Injection] diff --git a/src/Monomorphizer/MonomorphizerIr.hs b/src/Monomorphizer/MonomorphizerIr.hs index 07263a1..4d71363 100644 --- a/src/Monomorphizer/MonomorphizerIr.hs +++ b/src/Monomorphizer/MonomorphizerIr.hs @@ -1,8 +1,8 @@ module Monomorphizer.MonomorphizerIr (module Monomorphizer.MonomorphizerIr, module RE, module GA) where -import Grammar.Abs (Ident (..), Init (..), UIdent) -import Grammar.Abs qualified as GA (Ident (..), Init (..)) -import TypeChecker.TypeCheckerIr qualified as RE +import Grammar.Abs (Ident (..), Init (..), UIdent) +import qualified Grammar.Abs as GA (Ident (..), Init (..)) +import qualified TypeChecker.TypeCheckerIr as RE type Id = (Ident, Type) @@ -12,7 +12,7 @@ newtype Program = Program [Def] data Def = DBind Bind | DData Data deriving (Show, Ord, Eq) -data Data = Data Type Constructor +data Data = Data Type [Constructor] deriving (Show, Ord, Eq) data Bind = Bind Id [Id] ExpT @@ -45,4 +45,4 @@ data Type = TLit Ident | TFun Type Type flattenType :: Type -> [Type] flattenType (TFun t1 t2) = t1 : flattenType t2 -flattenType x = [x] +flattenType x = [x]