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

No more warnings, but everything to do with datatypes is outcommented.

Browse source
This commit is contained in:
Samuel Hammersberg 2023-03-23 21:35:52 +01:00
parent 6cbc83c5d9
commit 75fa232e21
4 changed files with 172 additions and 193 deletions
Download patch file Download diff file Expand all files Collapse all files

316
src/Codegen/Codegen.hs
View file

@ -1,59 +1,44 @@
{-# LANGUAGE LambdaCase #-} {-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
module Codegen.Codegen (generateCode) where module Codegen.Codegen (generateCode) where
import Auxiliary (snoc) import Auxiliary (snoc)
import Codegen.LlvmIr ( import Codegen.LlvmIr as LIR
CallingConvention (..), import Control.Applicative ((<|>))
LLVMComp (..), import Control.Monad.State (StateT, execStateT, foldM_,
LLVMIr (..), gets, modify)
LLVMType (..), import qualified Data.Bifunctor as BI
LLVMValue (..), import Data.Coerce (coerce)
Visibility (..), import Data.Map (Map)
llvmIrToString, import qualified Data.Map as Map
) import Data.Maybe (fromJust, fromMaybe)
import Codegen.LlvmIr as LIR import Data.Tuple.Extra (dupe, first, second)
import Control.Applicative ((<|>)) import qualified Grammar.Abs as GA
import Control.Monad.State ( import Grammar.ErrM (Err)
StateT, import Monomorphizer.MonomorphizerIr as MIR
execStateT,
foldM_,
gets,
modify,
)
import Data.Bifunctor qualified as BI
import Data.List.Extra (trim)
import Data.Map (Map)
import Data.Map qualified as Map
import Data.Maybe (fromJust, fromMaybe)
import Data.Tuple.Extra (dupe, first, second)
import Grammar.Abs qualified as GA
import Grammar.ErrM (Err)
import Monomorphizer.MonomorphizerIr as MIR
import System.Process.Extra (readCreateProcess, shell)
-- | 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 Id FunctionInfo , functions :: Map MIR.Id FunctionInfo
, constructors :: Map Id ConstructorInfo , constructors :: Map Ident ConstructorInfo
, variableCount :: Integer , variableCount :: Integer
, labelCount :: Integer , labelCount :: Integer
} }
-- | A state type synonym -- | A state type synonym
type CompilerState a = StateT CodeGenerator Err a type CompilerState a = StateT CodeGenerator Err a
data FunctionInfo = FunctionInfo data FunctionInfo = FunctionInfo
{ numArgs :: Int { numArgs :: Int
, arguments :: [Id] , arguments :: [Id]
} }
deriving (Show) deriving (Show)
data ConstructorInfo = ConstructorInfo data ConstructorInfo = ConstructorInfo
{ numArgsCI :: Int { numArgsCI :: Int
, argumentsCI :: [Id] , argumentsCI :: [Id]
, numCI :: Integer , numCI :: Integer
} }
deriving (Show) deriving (Show)
@ -82,18 +67,17 @@ getNewLabel = do
{- | 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.
-} -}
getFunctions :: [Bind] -> Map Id FunctionInfo getFunctions :: [MIR.Def] -> Map Id FunctionInfo
getFunctions bs = Map.fromList $ go bs getFunctions bs = Map.fromList $ go bs
where where
go [] = [] go [] = []
go (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 (DataType n cons : xs) = go (MIR.DData (MIR.Data n cons) : xs) = undefined
do {-do map
map
( \(Constructor id xs) -> ( \(Constructor id xs) ->
( (id, MIR.Type n) ( (id, MIR.TLit n)
, FunctionInfo , FunctionInfo
{ numArgs = length xs { numArgs = length xs
, arguments = createArgs xs , arguments = createArgs xs
@ -101,24 +85,24 @@ getFunctions bs = Map.fromList $ go bs
) )
) )
cons cons
<> go xs <> go xs-}
createArgs :: [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 ++ [(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.
-} -}
getConstructors :: [Bind] -> Map Id ConstructorInfo getConstructors :: [MIR.Def] -> Map Ident ConstructorInfo
getConstructors bs = Map.fromList $ go bs getConstructors bs = Map.fromList $ go bs
where where
go [] = [] go [] = []
go (DataType (GA.Ident n) cons : xs) = go (MIR.DData (MIR.Data n cons) : xs) = undefined
do {-do
fst fst
( foldl ( foldl
( \(acc, i) (Constructor (GA.Ident id) xs) -> ( \(acc, i) (GA.Constructor (GA.Ident id) xs) ->
( ( (GA.Ident (n <> "_" <> id), MIR.Type (GA.Ident n)) ( ( (GA.Ident (n <> "_" <> id), MIR.TLit (GA.Ident n))
, ConstructorInfo , ConstructorInfo
{ numArgsCI = length xs { numArgsCI = length xs
, argumentsCI = createArgs xs , argumentsCI = createArgs xs
@ -132,10 +116,10 @@ getConstructors bs = Map.fromList $ go bs
([], 0) ([], 0)
cons cons
) )
<> go xs <> go xs-}
go (_ : xs) = go xs go (_ : xs) = go xs
initCodeGenerator :: [Bind] -> CodeGenerator initCodeGenerator :: [MIR.Def] -> CodeGenerator
initCodeGenerator scs = initCodeGenerator scs =
CodeGenerator CodeGenerator
{ instructions = defaultStart { instructions = defaultStart
@ -145,11 +129,12 @@ initCodeGenerator scs =
, labelCount = 0 , labelCount = 0
} }
{-
run :: Err String -> IO () run :: Err String -> IO ()
run s = do run s = do
let s' = case s of let s' = case s of
Right s -> s Right s -> s
Left _ -> error "yo" Left _ -> error "yo"
writeFile "output/llvm.ll" s' writeFile "output/llvm.ll" s'
putStrLn . trim =<< readCreateProcess (shell "lli") s' putStrLn . trim =<< readCreateProcess (shell "lli") s'
@ -171,7 +156,7 @@ test v =
-- (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 (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.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")) (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_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 (GA.Ident "z")) (int 3) , Injection (CIdent (GA.Ident "z")) (int 3)
@ -183,23 +168,24 @@ test v =
injectionCons x y xs = Injection (CCons (GA.Ident x, MIR.Type (GA.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.Type "_Int") x xs, MIR.Type "_Int") eCaseInt x xs = (ECase (MIR.TLit (MIR.Ident "_Int")) x xs, MIR.TLit (MIR.Ident "_Int"))
int x = (ELit (LInt x), MIR.Type "_Int") int x = (ELit (LInt x), MIR.TLit (MIR.Ident "_Int"))
-}
{- | Compiles an AST and produces a LLVM Ir string. {- | Compiles an AST and produces a LLVM Ir string.
An easy way to actually "compile" this output is to An easy way to actually "compile" this output is to
Simply pipe it to LLI Simply pipe it to LLI
-} -}
generateCode :: Program -> Err String generateCode :: MIR.Program -> Err String
generateCode (Program scs) = do generateCode (MIR.Program scs) = do
let codegen = initCodeGenerator scs let codegen = initCodeGenerator scs
llvmIrToString . instructions <$> execStateT (compileScs scs) codegen llvmIrToString . instructions <$> execStateT (compileScs scs) codegen
compileScs :: [Bind] -> CompilerState () compileScs :: [MIR.Def] -> CompilerState ()
compileScs [] = do compileScs [] = do
undefined
-- as a last step create all the constructors -- as a last step create all the constructors
-- //TODO maybe merge this with the data type match? -- //TODO maybe merge this with the data type match?
c <- gets (Map.toList . constructors) {-c <- gets (Map.toList . constructors)
mapM_ mapM_
( \((id, t), ci) -> do ( \((id, t), ci) -> do
let t' = type2LlvmType t let t' = type2LlvmType t
@ -261,28 +247,29 @@ compileScs [] = do
modify $ \s -> s{variableCount = 0} modify $ \s -> s{variableCount = 0}
) )
c c-}
compileScs (Bind (name, _t) args exp : xs) = do compileScs (MIR.DBind (MIR.Bind (name, _t) args exp) : xs) = do
emit $ UnsafeRaw "\n" emit $ UnsafeRaw "\n"
emit . Comment $ show name <> ": " <> show exp emit . Comment $ show name <> ": " <> show exp
let args' = map (second type2LlvmType) args let args' = map (second type2LlvmType) args
emit $ Define FastCC I64 {-(type2LlvmType t_return)-} name args' emit $ Define FastCC I64 {-(type2LlvmType t_return)-} name args'
functionBody <- exprToValue (fst exp) functionBody <- exprToValue exp
if name == "main" if name == "main"
then mapM_ emit $ mainContent functionBody then mapM_ emit $ mainContent functionBody
else emit $ Ret I64 functionBody else emit $ Ret I64 functionBody
emit DefineEnd emit DefineEnd
modify $ \s -> s{variableCount = 0} modify $ \s -> s{variableCount = 0}
compileScs xs compileScs xs
compileScs (DataType id@(GA.Ident outer_id) ts : xs) = do compileScs (MIR.DData (MIR.Data outer_id ts) : xs) = do
let biggestVariant = maximum ((\(Constructor _ t) -> sum $ typeByteSize . type2LlvmType <$> t) <$> ts) undefined
emit $ LIR.Type id [I8, Array biggestVariant I8] -- let biggestVariant = maximum ((\(Constructor _ t) -> sum $ typeByteSize . type2LlvmType <$> t) <$> ts)
mapM_ -- emit $ LIR.Type outer_id [I8, Array biggestVariant I8]
( \(Constructor (GA.Ident inner_id) fi) -> do -- mapM_
emit $ LIR.Type (GA.Ident $ outer_id <> "_" <> inner_id) (I8 : map type2LlvmType fi) -- ( \(GA.Constructor (GA.UIdent inner_id) fi) -> do
) -- emit $ LIR.Type (GA.Ident $ outer_id <> "_" <> inner_id) (I8 : map type2LlvmType fi)
ts -- )
compileScs xs -- ts
-- compileScs xs
-- where -- where
-- _t_return = snd $ partitionType (length args) t -- _t_return = snd $ partitionType (length args) t
@ -318,27 +305,27 @@ defaultStart =
, UnsafeRaw "declare i32 @printf(ptr noalias nocapture, ...)\n" , UnsafeRaw "declare i32 @printf(ptr noalias nocapture, ...)\n"
] ]
compileExp :: Exp -> CompilerState () compileExp :: ExpT -> CompilerState ()
compileExp (ELit lit) = emitLit lit compileExp (MIR.ELit lit,t) = emitLit lit
compileExp (EAdd t e1 e2) = emitAdd t (fst e1) (fst 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 (EId (name, _)) = emitIdent name compileExp (MIR.EId name,t) = emitIdent name
compileExp (EApp t e1 e2) = emitApp t (fst e1) (fst 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 (ELet _ binds e) = undefined emitLet binds (fst e) compileExp (MIR.ELet binds e,t) = undefined -- emitLet binds (fst e)
compileExp (ECase t e cs) = 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 :: Type -> ExpT -> [(Type, Injection)] -> CompilerState () emitECased :: MIR.Type -> ExpT -> [(MIR.Type, Injection)] -> CompilerState ()
emitECased t e cases = do emitECased t e cases = do
let cs = snd <$> cases let cs = snd <$> cases
let ty = type2LlvmType t let ty = type2LlvmType t
let rt = type2LlvmType (snd e) let rt = type2LlvmType (snd e)
vs <- exprToValue (fst e) vs <- exprToValue e
lbl <- getNewLabel lbl <- getNewLabel
let label = GA.Ident $ "escape_" <> show lbl let label = GA.Ident $ "escape_" <> show lbl
stackPtr <- getNewVar stackPtr <- getNewVar
@ -349,9 +336,9 @@ emitECased t e cases = do
emit $ SetVariable res (Load ty Ptr stackPtr) emit $ SetVariable res (Load ty Ptr stackPtr)
where where
emitCases :: LLVMType -> LLVMType -> GA.Ident -> GA.Ident -> LLVMValue -> Injection -> CompilerState () emitCases :: LLVMType -> LLVMType -> GA.Ident -> GA.Ident -> LLVMValue -> Injection -> CompilerState ()
emitCases rt ty label stackPtr vs (Injection (MIR.CCons consId cs) exp) = do emitCases rt ty label stackPtr vs (Injection (MIR.InitConstructor consId cs, _t) exp) = do
cons <- gets constructors cons <- gets constructors
let r = fromJust $ Map.lookup consId cons let r = fromJust $ Map.lookup (coerce consId) 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
@ -370,62 +357,62 @@ 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 castedPtr (Bitcast Ptr (VIdent castPtr Ptr) Ptr) emit $ SetVariable castedPtr (Bitcast Ptr (VIdent castPtr Ptr) Ptr)
emit $ SetVariable casted (Load (CustomType (fst consId)) Ptr castedPtr) emit $ SetVariable casted (Load (CustomType (coerce consId)) Ptr castedPtr)
val <- exprToValue (fst 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)
CatchAll -> 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.CLit 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
LInt i -> VInteger i GA.LInt i -> VInteger i
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 (fst 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.CatchAll exp) = do emitCases _ ty label stackPtr _ (Injection (MIR.InitCatch, _) exp) = do
val <- exprToValue (fst 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 $
@ -437,26 +424,26 @@ emitLet xs e = do
, ") is not implemented!" , ") is not implemented!"
] ]
emitApp :: Type -> Exp -> Exp -> CompilerState () emitApp :: MIR.Type -> ExpT -> ExpT -> CompilerState ()
emitApp t e1 e2 = appEmitter t e1 e2 [] emitApp t e1 e2 = appEmitter e1 e2 []
where where
appEmitter :: Type -> Exp -> Exp -> [Exp] -> CompilerState () appEmitter :: ExpT -> ExpT -> [ExpT] -> CompilerState ()
appEmitter t e1 e2 stack = do appEmitter e1 e2 stack = do
let newStack = e2 : stack let newStack = e2 : stack
case e1 of case e1 of
EApp _ (e1', _) (e2', _) -> appEmitter t e1' e2' newStack (MIR.EApp e1' e2', t) -> appEmitter e1' e2' newStack
EId id@(GA.Ident name, _) -> do (MIR.EId name, t) -> do
args <- traverse exprToValue newStack args <- traverse exprToValue newStack
vs <- getNewVar vs <- getNewVar
funcs <- gets functions funcs <- gets functions
consts <- gets constructors consts <- gets constructors
let visibility = let visibility =
fromMaybe Local $ fromMaybe Local $
Global <$ Map.lookup id consts Global <$ Map.lookup name consts
<|> Global <$ Map.lookup id funcs <|> Global <$ Map.lookup (name,t) funcs
-- this piece of code could probably be improved, i.e remove the double `const Global` -- this piece of code could probably be improved, i.e remove the double `const Global`
args' = map (first valueGetType . dupe) args args' = map (first valueGetType . dupe) args
call = Call FastCC (type2LlvmType t) visibility (GA.Ident name) args' call = Call FastCC (type2LlvmType t) visibility name args'
emit $ SetVariable vs call emit $ SetVariable vs call
x -> error $ "The unspeakable happened: " <> show x x -> error $ "The unspeakable happened: " <> show x
@ -467,38 +454,38 @@ emitIdent id = do
emit $ Variable id emit $ Variable id
emit $ UnsafeRaw "\n" emit $ UnsafeRaw "\n"
emitLit :: 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
(LInt i'') -> (VInteger i'', I64) (MIR.LInt i'') -> (VInteger i'', I64)
(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 :: Type -> Exp -> Exp -> 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 :: Type -> Exp -> Exp -> 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 :: Exp -> CompilerState LLVMValue exprToValue :: ExpT -> CompilerState LLVMValue
exprToValue = \case exprToValue = \case
ELit i -> pure $ case i of (MIR.ELit i, t) -> pure $ case i of
(LInt i) -> VInteger i (MIR.LInt i) -> VInteger i
(LChar i) -> VChar i (MIR.LChar i) -> VChar i
EId id@(name, t) -> do (MIR.EId name, t) -> do
funcs <- gets functions funcs <- gets functions
case Map.lookup id 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
@ -515,10 +502,10 @@ exprToValue = \case
v <- getVarCount v <- getVarCount
pure $ VIdent (GA.Ident $ show v) (getType e) pure $ VIdent (GA.Ident $ show v) (getType e)
type2LlvmType :: Type -> LLVMType type2LlvmType :: MIR.Type -> LLVMType
type2LlvmType (MIR.Type (GA.Ident t)) = case t of type2LlvmType = undefined {-(MIR.Type (GA.Ident t)) = case t of
"_Int" -> I64 "_Int" -> I64
t -> CustomType (GA.Ident t) t -> CustomType (GA.Ident t)-}
-- TInt -> I64 -- TInt -> I64
-- TFun t xs -> do -- TFun t xs -> do
@ -530,32 +517,25 @@ type2LlvmType (MIR.Type (GA.Ident t)) = case t of
-- 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 :: Exp -> LLVMType getType :: ExpT -> LLVMType
getType (ELit l) = I64 getType (_, t) = type2LlvmType t
getType (EAdd t _ _) = type2LlvmType t
-- getType (ESub t _ _) = type2LlvmType t
getType (EId (_, t)) = type2LlvmType t
getType (EApp t _ _) = type2LlvmType t
-- getType (EAbs t _ _) = type2LlvmType t
getType (ELet (_, t) _ e) = type2LlvmType t
getType (ECase t _ _) = type2LlvmType t
valueGetType :: LLVMValue -> LLVMType valueGetType :: LLVMValue -> LLVMType
valueGetType (VInteger _) = I64 valueGetType (VInteger _) = I64
valueGetType (VChar _) = I8 valueGetType (VChar _) = I8
valueGetType (VIdent _ t) = t valueGetType (VIdent _ t) = t
valueGetType (VConstant s) = Array (fromIntegral $ length s) I8 valueGetType (VConstant s) = Array (fromIntegral $ length s) I8
valueGetType (VFunction _ _ t) = t valueGetType (VFunction _ _ t) = t
typeByteSize :: LLVMType -> Integer typeByteSize :: LLVMType -> Integer
typeByteSize I1 = 1 typeByteSize I1 = 1
typeByteSize I8 = 1 typeByteSize I8 = 1
typeByteSize I32 = 4 typeByteSize I32 = 4
typeByteSize I64 = 8 typeByteSize I64 = 8
typeByteSize Ptr = 8 typeByteSize Ptr = 8
typeByteSize (Ref _) = 8 typeByteSize (Ref _) = 8
typeByteSize (Function _ _) = 8 typeByteSize (Function _ _) = 8
typeByteSize (Array n t) = n * typeByteSize t typeByteSize (Array n t) = n * typeByteSize t
typeByteSize (CustomType _) = 8 typeByteSize (CustomType _) = 8
enumerateOneM_ :: Monad m => (Integer -> a -> m b) -> [a] -> m () enumerateOneM_ :: Monad m => (Integer -> a -> m b) -> [a] -> m ()

39
src/Main.hs
View file

@ -2,29 +2,26 @@
module Main where module Main where
import Codegen.Codegen (generateCode) import Codegen.Codegen (generateCode)
import GHC.IO.Handle.Text (hPutStrLn) import GHC.IO.Handle.Text (hPutStrLn)
import Grammar.ErrM (Err) import Grammar.ErrM (Err)
import Grammar.Par (myLexer, pProgram) import Grammar.Par (myLexer, pProgram)
import Grammar.Print (printTree) import Grammar.Print (printTree)
import Monomorphizer.Monomorphizer (monomorphize) import Monomorphizer.Monomorphizer (monomorphize)
import Control.Monad (when) import Control.Monad (when)
import Data.List.Extra (isSuffixOf) import Data.List.Extra (isSuffixOf)
import Renamer.Renamer (rename) import Renamer.Renamer (rename)
import System.Directory ( import System.Directory (createDirectory, doesPathExist,
createDirectory, getDirectoryContents,
doesPathExist, removeDirectoryRecursive,
getDirectoryContents, setCurrentDirectory)
removeDirectoryRecursive, import System.Environment (getArgs)
setCurrentDirectory, import System.Exit (exitFailure, exitSuccess)
) import System.IO (stderr)
import System.Environment (getArgs) import System.Process.Extra (spawnCommand, waitForProcess)
import System.Exit (exitFailure, exitSuccess) import TypeChecker.TypeChecker (typecheck)
import System.IO (stderr)
import System.Process.Extra (spawnCommand, waitForProcess)
import TypeChecker.TypeChecker (typecheck)
main :: IO () main :: IO ()
main = main =

4
src/Monomorphizer/Monomorphizer.hs
View file

@ -18,7 +18,7 @@ monoDef (T.DBind bind) = DBind $ monoBind bind
monoDef (T.DData d) = DData d monoDef (T.DData d) = DData d
monoBind :: T.Bind -> Bind monoBind :: T.Bind -> Bind
monoBind (T.Bind name args (e, t)) = Bind name args (monoExpr e, monoType t) monoBind (T.Bind name args (e, t)) = Bind (monoId name) (map monoId args) (monoExpr e, monoType t)
monoExpr :: T.Exp -> M.Exp monoExpr :: T.Exp -> M.Exp
monoExpr = \case monoExpr = \case
@ -40,7 +40,7 @@ monoexpt :: T.ExpT -> M.ExpT
monoexpt (e, t) = (monoExpr e, monoType t) monoexpt (e, t) = (monoExpr e, monoType t)
monoId :: T.Id -> Id monoId :: T.Id -> Id
monoId = id monoId (n,t) = (n, monoType t)
monoLit :: T.Lit -> Lit monoLit :: T.Lit -> Lit
monoLit (T.LInt i) = LInt i monoLit (T.LInt i) = LInt i

6
src/Monomorphizer/MonomorphizerIr.hs
View file

@ -3,8 +3,10 @@ module Monomorphizer.MonomorphizerIr (module Monomorphizer.MonomorphizerIr, modu
import Grammar.Abs (Data (..), Ident (..), Init (..)) import Grammar.Abs (Data (..), Ident (..), Init (..))
import qualified Grammar.Abs as GA (Data (..), Ident (..), import qualified Grammar.Abs as GA (Data (..), Ident (..),
Init (..)) Init (..))
import qualified TypeChecker.TypeCheckerIr as RE (Id, Indexed) import qualified TypeChecker.TypeCheckerIr as RE (Indexed)
import TypeChecker.TypeCheckerIr (Id, Indexed) import TypeChecker.TypeCheckerIr (Indexed)
type Id = (Ident, Type)
newtype Program = Program [Def] newtype Program = Program [Def]
deriving (Show, Ord, Eq) deriving (Show, Ord, Eq)