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

Got some more stuff working.

Browse source
This commit is contained in:
Samuel Hammersberg 2023-03-24 13:55:06 +01:00
parent f4163bbb7d
commit 50bea83a18
3 changed files with 338 additions and 328 deletions
Download patch file Download diff file Expand all files Collapse all files

624
src/Codegen/Codegen.hs
View file

@ -1,9 +1,22 @@
{-# LANGUAGE LambdaCase #-} {-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-} {-# 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 -- | The record used as the code generator state
data CodeGenerator = CodeGenerator data CodeGenerator = CodeGenerator
@ -14,45 +27,42 @@ data CodeGenerator = CodeGenerator
, labelCount :: Integer , labelCount :: Integer
} }
---- | The record used as the code generator state -- | A state type synonym
-- data CodeGenerator = CodeGenerator type CompilerState a = StateT CodeGenerator Err a
-- { instructions :: [LLVMIr]
-- , functions :: Map MIR.Id FunctionInfo
-- , constructors :: Map Ident ConstructorInfo
-- , variableCount :: Integer
-- , labelCount :: Integer
-- }
---- | A state type synonym data FunctionInfo = FunctionInfo
-- type CompilerState a = StateT CodeGenerator Err a { numArgs :: Int
, arguments :: [Id]
}
deriving (Show)
data ConstructorInfo = ConstructorInfo
{ numArgsCI :: Int
, argumentsCI :: [Id]
, numCI :: Integer
}
deriving (Show)
-- data FunctionInfo = FunctionInfo -- | Adds a instruction to the CodeGenerator state
-- { numArgs :: Int emit :: LLVMIr -> CompilerState ()
-- , arguments :: [Id] emit l = modify $ \t -> t{instructions = Auxiliary.snoc l $ instructions t}
-- }
-- deriving (Show)
-- data ConstructorInfo = ConstructorInfo
-- { numArgsCI :: Int
-- , argumentsCI :: [Id]
-- , numCI :: Integer
-- }
-- deriving (Show)
---- | Adds a instruction to the CodeGenerator state -- | Increases the variable counter in the CodeGenerator state
-- emit :: LLVMIr -> CompilerState () increaseVarCount :: CompilerState ()
-- emit l = modify $ \t -> t{instructions = Auxiliary.snoc l $ instructions t} increaseVarCount = modify $ \t -> t{variableCount = variableCount t + 1}
---- | Increases the variable counter in the CodeGenerator state -- | Returns the variable count from the CodeGenerator state
-- increaseVarCount :: CompilerState () getVarCount :: CompilerState Integer
-- increaseVarCount = modify $ \t -> t{variableCount = variableCount t + 1} getVarCount = gets variableCount
---- | Returns the variable count from the CodeGenerator state -- | Increases the variable count and returns it from the CodeGenerator state
-- getVarCount :: CompilerState Integer getNewVar :: CompilerState GA.Ident
-- getVarCount = gets variableCount getNewVar = (GA.Ident . show) <$> (increaseVarCount >> getVarCount)
---- | Increases the variable count and returns it from the CodeGenerator state -- | Increses the label count and returns a label from the CodeGenerator state
-- getNewVar :: CompilerState GA.Ident getNewLabel :: CompilerState Integer
-- getNewVar = (GA.Ident . show) <$> (increaseVarCount >> getVarCount) getNewLabel = do
modify (\t -> t{labelCount = labelCount t + 1})
gets labelCount
{- | 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.
@ -64,41 +74,21 @@ 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
go (MIR.DData (MIR.Constructor n cons) : xs) = go (MIR.DData (MIR.Data n cons) : xs) =
do map do map
( \(id, xs) -> ( \(Constructor id xs) ->
( (coerce id, MIR.TLit (coerce n)) ( (coerce id, MIR.TLit (extractTypeName n))
, FunctionInfo , FunctionInfo
{ numArgs = length (flattenType xs) { numArgs = length xs
, arguments = createArgs (flattenType xs) , arguments = createArgs (snd <$> xs)
} }
) )
) )
cons cons
<> go xs <> go xs
-- {- | Produces a map of functions infos from a list of binds, createArgs :: [MIR.Type] -> [Id]
-- which contains useful data for code generation. createArgs xs = fst $ foldl (\(acc, l) t -> (acc ++ [(GA.Ident ("arg_" <> show l), t)], l + 1)) ([], 0) xs
---}
-- 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-}
{- | 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.
@ -107,15 +97,16 @@ getConstructors :: [MIR.Def] -> Map MIR.Id ConstructorInfo
getConstructors bs = Map.fromList $ go bs getConstructors bs = Map.fromList $ go bs
where where
go [] = [] go [] = []
go (MIR.DData (MIR.Constructor (GA.UIdent n) cons) : xs) = go (MIR.DData (MIR.Data t cons) : xs) =
do do
let (GA.Ident n) = extractTypeName t
fst fst
( foldl ( foldl
( \(acc, i) (GA.UIdent id, xs) -> ( \(acc, i) (Constructor (GA.UIdent id) xs) ->
( ( (GA.Ident (n <> "_" <> id), MIR.TLit (coerce n)) ( ( (GA.Ident (n <> "_" <> id), MIR.TLit (coerce n))
, ConstructorInfo , ConstructorInfo
{ numArgsCI = length (flattenType xs) { numArgsCI = length xs
, argumentsCI = createArgs (flattenType xs) , argumentsCI = createArgs (snd <$> xs)
, numCI = i , numCI = i
} }
) )
@ -129,53 +120,66 @@ getConstructors bs = Map.fromList $ go bs
<> go xs <> go xs
go (_ : xs) = go xs go (_ : xs) = go xs
-- {- | Produces a map of functions infos from a list of binds, initCodeGenerator :: [MIR.Def] -> CodeGenerator
-- which contains useful data for code generation. initCodeGenerator scs =
---} CodeGenerator
-- getConstructors :: [MIR.Def] -> Map Ident ConstructorInfo { instructions = defaultStart
-- getConstructors bs = Map.fromList $ go bs , functions = getFunctions scs
-- where , constructors = getConstructors scs
-- go [] = [] , variableCount = 0
-- go (MIR.DData (MIR.Constructor n cons) : xs) = undefined , labelCount = 0
-- {-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 = run :: Err String -> IO ()
-- CodeGenerator run s = do
-- { instructions = defaultStart let s' = case s of
-- , functions = getFunctions scs Right s -> s
-- , constructors = getConstructors scs Left _ -> error "yo"
-- , variableCount = 0 writeFile "output/llvm.ll" s'
-- , labelCount = 0 putStrLn . trim =<< readCreateProcess (shell "lli") s'
-- }
-- {- test :: Integer -> Program
-- run :: Err String -> IO () test v =
-- run s = do Program
-- let s' = case s of [ DataType
-- Right s -> s (GA.Ident "Craig")
-- Left _ -> error "yo" [ Constructor (GA.Ident "Bob") [MIR.Type (GA.Ident "_Int")]
-- writeFile "output/llvm.ll" s' , Constructor (GA.Ident "Betty") [MIR.Type (GA.Ident "_Int")]
-- putStrLn . trim =<< readCreateProcess (shell "lli") s' ]
, 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 :: [MIR.Def] -> CompilerState ()
compileScs [] = do compileScs [] = do
@ -256,61 +260,61 @@ compileScs (MIR.DBind (MIR.Bind (name, _t) args exp) : xs) = do
emit DefineEnd emit DefineEnd
modify $ \s -> s{variableCount = 0} modify $ \s -> s{variableCount = 0}
compileScs xs compileScs xs
compileScs (MIR.DData (MIR.Constructor (GA.UIdent outer_id) ts) : xs) = do compileScs (MIR.DData (MIR.Data typ ts) : xs) = do
let types = BI.second flattenType <$> ts let (Ident outer_id) = extractTypeName typ
let biggestVariant = maximum $ sum . map (typeByteSize . type2LlvmType) <$> (snd <$> types) let biggestVariant = maximum $ sum <$> (\(Constructor _ t) -> typeByteSize . type2LlvmType . snd <$> t) <$> ts
emit $ LIR.Type (coerce outer_id) [I8, Array biggestVariant I8] emit $ LIR.Type (coerce outer_id) [I8, Array biggestVariant I8]
mapM_ mapM_
( \(GA.UIdent inner_id, fi) -> do ( \(Constructor (GA.UIdent inner_id) fi) -> do
emit $ LIR.Type (GA.Ident $ outer_id <> "_" <> inner_id) (I8 : map type2LlvmType fi) emit $ LIR.Type (GA.Ident $ outer_id <> "_" <> inner_id) (I8 : map type2LlvmType (snd <$> fi))
) )
types ts
compileScs xs compileScs xs
-- mainContent :: LLVMValue -> [LLVMIr] mainContent :: LLVMValue -> [LLVMIr]
-- mainContent var = mainContent var =
-- [ UnsafeRaw $ [ UnsafeRaw $
-- -- "%2 = alloca %Craig\n" <> -- "%2 = alloca %Craig\n" <>
-- -- " store %Craig %1, ptr %2\n" <> -- " store %Craig %1, ptr %2\n" <>
-- -- " %3 = bitcast %Craig* %2 to i72*\n" <> -- " %3 = bitcast %Craig* %2 to i72*\n" <>
-- -- " %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 (GA.Ident "p") (Icmp LLEq I64 (VInteger 2) (VInteger 2))
-- -- , BrCond (VIdent (GA.Ident "p")) (GA.Ident "b_1") (GA.Ident "b_2") -- , BrCond (VIdent (GA.Ident "p")) (GA.Ident "b_1") (GA.Ident "b_2")
-- -- , Label (GA.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 (GA.Ident "end") -- , Br (GA.Ident "end")
-- -- , Label (GA.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 (GA.Ident "end") -- , Br (GA.Ident "end")
-- -- , Label (GA.Ident "end") -- , Label (GA.Ident "end")
-- Ret I64 (VInteger 0) Ret I64 (VInteger 0)
-- ] ]
-- defaultStart :: [LLVMIr] defaultStart :: [LLVMIr]
-- defaultStart = 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\"%x\n\", align 1\n" , UnsafeRaw "@.str = private unnamed_addr constant [3 x i8] c\"%x\n\", align 1\n"
-- , UnsafeRaw "declare i32 @printf(ptr noalias nocapture, ...)\n" , UnsafeRaw "declare i32 @printf(ptr noalias nocapture, ...)\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.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)
-- compileExp (MIR.ECase e cs,t) = emitECased t e (map (t,) cs) compileExp (MIR.ECase e cs,t) = emitECased t e (map (t,) cs)
---- go (EMul e1 e2) = emitMul e1 e2 -- go (EMul e1 e2) = emitMul e1 e2
---- go (EDiv e1 e2) = emitDiv e1 e2 -- go (EDiv e1 e2) = emitDiv e1 e2
---- go (EMod e1 e2) = emitMod e1 e2 -- go (EMod e1 e2) = emitMod e1 e2
--- aux functions --- --- aux functions ---
emitECased :: MIR.Type -> ExpT -> [(MIR.Type, Injection)] -> CompilerState () emitECased :: MIR.Type -> ExpT -> [(MIR.Type, Injection)] -> CompilerState ()
@ -333,89 +337,89 @@ emitECased t e cases = do
cons <- gets constructors cons <- gets constructors
let r = fromJust $ Map.lookup (coerce consId, t) cons let r = fromJust $ Map.lookup (coerce consId, t) cons
-- lbl_failPos <- (\x -> GA.Ident $ "failed_" <> show x) <$> getNewLabel lbl_failPos <- (\x -> GA.Ident $ "failed_" <> show x) <$> getNewLabel
-- lbl_succPos <- (\x -> GA.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)
-- consCheck <- getNewVar consCheck <- getNewVar
-- emit $ SetVariable consCheck (Icmp LLEq I8 (VIdent consVal I8) (VInteger $ numCI r)) emit $ SetVariable consCheck (Icmp LLEq I8 (VIdent consVal I8) (VInteger $ numCI r))
-- emit $ BrCond (VIdent consCheck ty) lbl_succPos lbl_failPos emit $ BrCond (VIdent consCheck ty) lbl_succPos lbl_failPos
-- emit $ Label lbl_succPos emit $ Label lbl_succPos
-- castPtr <- getNewVar castPtr <- getNewVar
-- castedPtr <- getNewVar castedPtr <- getNewVar
-- casted <- getNewVar casted <- getNewVar
-- emit $ SetVariable castPtr (Alloca rt) emit $ SetVariable castPtr (Alloca rt)
-- emit $ Store rt vs Ptr castPtr emit $ Store rt vs Ptr castPtr
-- emit $ SetVariable castedPtr (Bitcast Ptr (VIdent castPtr Ptr) Ptr) emit $ SetVariable castedPtr (Bitcast Ptr (VIdent castPtr Ptr) Ptr)
-- emit $ SetVariable casted (Load (CustomType (coerce consId)) Ptr castedPtr) emit $ SetVariable casted (Load (CustomType (coerce consId)) Ptr castedPtr)
-- val <- exprToValue exp val <- exprToValue exp
-- -- enumerateOneM_ -- enumerateOneM_
-- -- (\i c -> do -- (\i c -> do
-- -- case c of -- case c of
-- -- CIdent x -> do -- CIdent x -> do
-- -- emit . Comment $ "ident " <> show x -- emit . Comment $ "ident " <> show x
-- -- emit $ SetVariable x (ExtractValue (CustomType (fst consId)) (VIdent casted Ptr) i) -- emit $ SetVariable x (ExtractValue (CustomType (fst consId)) (VIdent casted Ptr) i)
-- -- emit $ Store ty val Ptr stackPtr -- emit $ Store ty val Ptr stackPtr
-- -- CCons x cs -> error "nested constructor" -- CCons x cs -> error "nested constructor"
-- -- CLit l -> do -- CLit l -> do
-- -- testVar <- getNewVar -- testVar <- getNewVar
-- -- emit $ SetVariable testVar (ExtractValue (CustomType (fst consId)) (VIdent casted Ptr) i) -- emit $ SetVariable testVar (ExtractValue (CustomType (fst consId)) (VIdent casted Ptr) i)
-- -- case l of -- case l of
-- -- LInt l -> emit $ Icmp LLEq I64 (VIdent testVar Ptr) (VInteger l) -- LInt l -> emit $ Icmp LLEq I64 (VIdent testVar Ptr) (VInteger l)
-- -- LChar c -> emit $ Icmp LLEq I8 (VIdent testVar Ptr) (VChar c) -- LChar c -> emit $ Icmp LLEq I8 (VIdent testVar Ptr) (VChar c)
-- -- CCatch -> emit . Comment $ "Catch all" -- CCatch -> emit . Comment $ "Catch all"
-- -- emit . Comment $ "return this " <> toIr val -- emit . Comment $ "return this " <> toIr val
-- -- emit . Comment . show $ c -- emit . Comment . show $ c
-- -- emit . Comment . show $ i -- emit . Comment . show $ i
-- -- ) -- )
-- -- cs -- cs
-- -- emit $ Store ty val Ptr stackPtr -- emit $ Store ty val Ptr stackPtr
-- emit $ Br label emit $ Br label
-- emit $ Label lbl_failPos emit $ Label lbl_failPos
-- emitCases rt ty label stackPtr vs (Injection (MIR.InitLit i, _) exp) = do emitCases rt ty label stackPtr vs (Injection (MIR.InitLit i, _) exp) = do
-- let i' = case i of let i' = case i of
-- GA.LInt i -> VInteger i GA.LInt i -> VInteger i
-- GA.LChar i -> VChar i GA.LChar i -> VChar i
-- ns <- getNewVar ns <- getNewVar
-- lbl_failPos <- (\x -> GA.Ident $ "failed_" <> show x) <$> getNewLabel lbl_failPos <- (\x -> GA.Ident $ "failed_" <> show x) <$> getNewLabel
-- lbl_succPos <- (\x -> GA.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
-- val <- exprToValue exp val <- exprToValue exp
-- emit $ Store ty val Ptr stackPtr emit $ Store ty val Ptr stackPtr
-- emit $ Br label emit $ Br label
-- emit $ Label lbl_failPos emit $ Label lbl_failPos
---- emitCases rt ty label stackPtr vs (Injection (MIR.CIdent id) exp) = do -- emitCases rt ty label stackPtr vs (Injection (MIR.CIdent id) exp) = do
---- -- //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 -- increaseVarCount
---- val <- exprToValue (fst exp) -- val <- exprToValue (fst exp)
---- emit $ Store ty val Ptr stackPtr -- emit $ Store ty val Ptr stackPtr
---- emit $ Br label -- emit $ Br label
-- emitCases _ ty label stackPtr _ (Injection (MIR.InitCatch, _) exp) = do emitCases _ ty label stackPtr _ (Injection (MIR.InitCatch, _) exp) = do
-- val <- exprToValue exp val <- exprToValue exp
-- emit $ Store ty val Ptr stackPtr emit $ Store ty val Ptr stackPtr
-- emit $ Br label emit $ Br label
----emitLet :: Bind -> Exp -> CompilerState () --emitLet :: Bind -> Exp -> CompilerState ()
-- emitLet xs e = do emitLet xs e = do
-- emit $ emit $
-- Comment $ Comment $
-- concat concat
-- [ "ELet (" [ "ELet ("
-- , show xs , show xs
-- , " = " , " = "
-- , show e , show e
-- , ") is not implemented!" , ") is not implemented!"
-- ] ]
emitApp :: MIR.Type -> ExpT -> ExpT -> CompilerState () emitApp :: MIR.Type -> ExpT -> ExpT -> CompilerState ()
emitApp t e1 e2 = appEmitter e1 e2 [] emitApp t e1 e2 = appEmitter e1 e2 []
@ -440,60 +444,60 @@ emitApp t 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 :: 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!"
-- emit $ Variable id emit $ Variable id
-- emit $ UnsafeRaw "\n" emit $ UnsafeRaw "\n"
-- emitLit :: MIR.Lit -> CompilerState () emitLit :: MIR.Lit -> CompilerState ()
-- emitLit i = do emitLit i = do
-- -- !!this should never happen!! -- !!this should never happen!!
-- let (i', t) = case i of let (i', t) = case i of
-- (MIR.LInt i'') -> (VInteger i'', I64) (MIR.LInt i'') -> (VInteger i'', I64)
-- (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 (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 (GA.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
-- v1 <- exprToValue e1 v1 <- exprToValue e1
-- v2 <- exprToValue e2 v2 <- exprToValue e2
-- v <- getNewVar v <- getNewVar
-- emit $ SetVariable v (Sub (type2LlvmType t) v1 v2) emit $ SetVariable v (Sub (type2LlvmType t) v1 v2)
-- exprToValue :: ExpT -> CompilerState LLVMValue exprToValue :: ExpT -> CompilerState LLVMValue
-- exprToValue = \case 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.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
-- if numArgs fi == 0 if numArgs fi == 0
-- then do then do
-- vc <- getNewVar vc <- getNewVar
-- emit $ emit $
-- SetVariable SetVariable
-- vc vc
-- (Call FastCC (type2LlvmType t) Global name []) (Call FastCC (type2LlvmType t) Global name [])
-- pure $ VIdent vc (type2LlvmType t) pure $ VIdent vc (type2LlvmType t)
-- else pure $ VFunction name Global (type2LlvmType t) else pure $ VFunction name Global (type2LlvmType t)
-- Nothing -> pure $ VIdent name (type2LlvmType t) Nothing -> pure $ VIdent name (type2LlvmType t)
-- e -> do e -> do
-- compileExp e compileExp e
-- v <- getVarCount v <- getVarCount
-- pure $ VIdent (GA.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
@ -507,26 +511,32 @@ type2LlvmType (MIR.TFun t xs) = do
function2LLVMType (TFun t xs) s = function2LLVMType xs (type2LlvmType t : s) function2LLVMType (TFun t xs) s = function2LLVMType xs (type2LlvmType t : s)
function2LLVMType x s = (type2LlvmType x, s) function2LLVMType x s = (type2LlvmType x, s)
-- getType :: ExpT -> LLVMType getType :: ExpT -> LLVMType
-- getType (_, t) = type2LlvmType t getType (_, t) = type2LlvmType t
-- valueGetType :: LLVMValue -> LLVMType extractTypeName :: MIR.Type -> Ident
-- valueGetType (VInteger _) = I64 extractTypeName (MIR.TLit id) = id
-- valueGetType (VChar _) = I8 extractTypeName (MIR.TFun t xs) = let (Ident i) = extractTypeName t
-- valueGetType (VIdent _ t) = t (Ident is) = extractTypeName xs
-- valueGetType (VConstant s) = Array (fromIntegral $ length s) I8 in Ident $ i <> "_$_" <> is
-- valueGetType (VFunction _ _ t) = t
-- typeByteSize :: LLVMType -> Integer valueGetType :: LLVMValue -> LLVMType
-- typeByteSize I1 = 1 valueGetType (VInteger _) = I64
-- typeByteSize I8 = 1 valueGetType (VChar _) = I8
-- typeByteSize I32 = 4 valueGetType (VIdent _ t) = t
-- typeByteSize I64 = 8 valueGetType (VConstant s) = Array (fromIntegral $ length s) I8
-- typeByteSize Ptr = 8 valueGetType (VFunction _ _ t) = t
-- 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 () typeByteSize :: LLVMType -> Integer
-- enumerateOneM_ f = foldM_ (\i a -> f i a >> pure (i + 1)) 1 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

32
src/Monomorphizer/Monomorphizer.hs
View file

@ -2,13 +2,13 @@
module Monomorphizer.Monomorphizer (monomorphize) where module Monomorphizer.Monomorphizer (monomorphize) where
import Data.Coerce (coerce) import Data.Coerce (coerce)
import Grammar.Abs (Constructor (..), Ident (..)) import Grammar.Abs (Constructor (..), Ident (..))
import Unsafe.Coerce (unsafeCoerce) import Unsafe.Coerce (unsafeCoerce)
import Grammar.Abs qualified as GA import qualified Grammar.Abs as GA
import Monomorphizer.MonomorphizerIr qualified as M import qualified Monomorphizer.MonomorphizerIr as M
import TypeChecker.TypeCheckerIr qualified as T import qualified TypeChecker.TypeCheckerIr as T
monomorphize :: T.Program -> M.Program monomorphize :: T.Program -> M.Program
monomorphize (T.Program ds) = M.Program $ monoDefs ds monomorphize (T.Program ds) = M.Program $ monoDefs ds
@ -18,7 +18,7 @@ monoDefs = map monoDef
monoDef :: T.Def -> M.Def monoDef :: T.Def -> M.Def
monoDef (T.DBind bind) = M.DBind $ monoBind bind 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 -> M.Bind
monoBind (T.Bind name args (e, t)) = M.Bind (monoId name) (map monoId args) (monoExpr e, monoType t) 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) T.ECase expt injs -> M.ECase (monoexpt expt) (monoInjs injs)
monoAbsType :: GA.Type -> M.Type monoAbsType :: GA.Type -> M.Type
monoAbsType (GA.TLit u) = M.TLit (coerce u) monoAbsType (GA.TLit u) = M.TLit (coerce u)
monoAbsType (GA.TVar _v) = error "NOT POLYMORHPIC TYPES" monoAbsType (GA.TVar _v) = error "NOT POLYMORHPIC TYPES"
monoAbsType (GA.TAll _v _t) = error "NOT ALL 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.TFun t1 t2) = M.TFun (monoAbsType t1) (monoAbsType t2)
monoAbsType (GA.TIndexed _) = error "NOT INDEXED TYPES"
monoType :: T.Type -> M.Type 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.TVar (T.MkTVar i)) = error "NOT POLYMORPHIC TYPES"
monoType (T.TLit i) = M.TLit i monoType (T.TLit i) = M.TLit i
monoType (T.TFun t1 t2) = M.TFun (monoType t1) (monoType t2) monoType (T.TFun t1 t2) = M.TFun (monoType t1) (monoType t2)
monoType (T.TData _ _) = error "Not sure what this is" monoType (T.TData _ _) = error "Not sure what this is"
monoexpt :: T.ExpT -> M.ExpT monoexpt :: T.ExpT -> M.ExpT
monoexpt (e, t) = (monoExpr e, monoType t) monoexpt (e, t) = (monoExpr e, monoType t)
@ -55,7 +55,7 @@ monoId :: T.Id -> M.Id
monoId (n, t) = (n, monoType t) monoId (n, t) = (n, monoType t)
monoLit :: T.Lit -> M.Lit 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 monoLit (T.LChar c) = M.LChar c
monoInjs :: [T.Inj] -> [M.Injection] monoInjs :: [T.Inj] -> [M.Injection]

10
src/Monomorphizer/MonomorphizerIr.hs
View file

@ -1,8 +1,8 @@
module Monomorphizer.MonomorphizerIr (module Monomorphizer.MonomorphizerIr, module RE, module GA) where module Monomorphizer.MonomorphizerIr (module Monomorphizer.MonomorphizerIr, module RE, module GA) where
import Grammar.Abs (Ident (..), Init (..), UIdent) import Grammar.Abs (Ident (..), Init (..), UIdent)
import Grammar.Abs qualified as GA (Ident (..), Init (..)) import qualified Grammar.Abs as GA (Ident (..), Init (..))
import TypeChecker.TypeCheckerIr qualified as RE import qualified TypeChecker.TypeCheckerIr as RE
type Id = (Ident, Type) type Id = (Ident, Type)
@ -12,7 +12,7 @@ newtype Program = Program [Def]
data Def = DBind Bind | DData Data data Def = DBind Bind | DData Data
deriving (Show, Ord, Eq) deriving (Show, Ord, Eq)
data Data = Data Type Constructor data Data = Data Type [Constructor]
deriving (Show, Ord, Eq) deriving (Show, Ord, Eq)
data Bind = Bind Id [Id] ExpT data Bind = Bind Id [Id] ExpT
@ -45,4 +45,4 @@ data Type = TLit Ident | TFun Type Type
flattenType :: Type -> [Type] flattenType :: Type -> [Type]
flattenType (TFun t1 t2) = t1 : flattenType t2 flattenType (TFun t1 t2) = t1 : flattenType t2
flattenType x = [x] flattenType x = [x]