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

Fixed wrongly typed functions in the code generator.

Browse source
This commit is contained in:
Samuel Hammersberg 2023-03-28 17:37:29 +02:00
parent e87e2d3870
commit 230a205965
2 changed files with 135 additions and 105 deletions
Download patch file Download diff file Expand all files Collapse all files

235
src/Codegen/Codegen.hs
View file

@ -1,49 +1,55 @@
{-# 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 as LIR import Codegen.LlvmIr as LIR
import Control.Applicative ((<|>)) import Control.Applicative ((<|>))
import Control.Monad (when) import Control.Monad (when)
import Control.Monad.State (StateT, execStateT, foldM_, import Control.Monad.State (
gets, modify) StateT,
import qualified Data.Bifunctor as BI execStateT,
import Data.Char (ord) foldM_,
import Data.Coerce (coerce) gets,
import Data.Map (Map) modify,
import qualified Data.Map as Map )
import Data.Maybe (fromJust, fromMaybe) import Data.Bifunctor qualified as BI
import Data.Set (Set) import Data.Char (ord)
import qualified Data.Set as Set import Data.Coerce (coerce)
import Data.Tuple.Extra (dupe, first, second) import Data.Map (Map)
import Grammar.ErrM (Err) import Data.Map qualified as Map
import Monomorphizer.MonomorphizerIr as MIR import Data.Maybe (fromJust, fromMaybe)
import qualified TypeChecker.TypeCheckerIr as TIR import Data.Set (Set)
import Data.Set qualified as Set
import Data.Tuple.Extra (dupe, first, second)
import Debug.Trace (trace)
import Grammar.ErrM (Err)
import Monomorphizer.MonomorphizerIr as MIR
import TypeChecker.TypeCheckerIr qualified as TIR
-- | The record used as the code generator state -- | The record used as the code generator state
data CodeGenerator = CodeGenerator data CodeGenerator = CodeGenerator
{ instructions :: [LLVMIr] { instructions :: [LLVMIr]
, functions :: Map MIR.Id FunctionInfo , functions :: Map MIR.Id FunctionInfo
, customTypes :: Set LLVMType , customTypes :: Set LLVMType
, constructors :: Map TIR.Ident ConstructorInfo , constructors :: Map TIR.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
, returnTypeCI :: MIR.Type , returnTypeCI :: MIR.Type
} }
deriving (Show) deriving (Show)
@ -55,7 +61,7 @@ emit l = modify $ \t -> t{instructions = Auxiliary.snoc l $ instructions t}
-- | Increases the variable counter in the CodeGenerator state -- | Increases the variable counter in the CodeGenerator state
increaseVarCount :: CompilerState () increaseVarCount :: CompilerState ()
increaseVarCount = do increaseVarCount = do
gets variableCount >>= \s -> emit.Comment $ "increase: " <> show (s + 1) gets variableCount >>= \s -> emit . Comment $ "increase: " <> show (s + 1)
modify $ \t -> t{variableCount = variableCount t + 1} modify $ \t -> t{variableCount = variableCount t + 1}
-- | Returns the variable count from the CodeGenerator state -- | Returns the variable count from the CodeGenerator state
@ -94,23 +100,34 @@ getConstructors :: [MIR.Def] -> Map TIR.Ident ConstructorInfo
getConstructors bs = Map.fromList $ go bs getConstructors bs = Map.fromList $ go bs
where where
go [] = [] go [] = []
go (MIR.DData (MIR.Data t cons) : xs) = fst go (MIR.DData (MIR.Data t cons) : xs) =
(foldl (\(acc, i) (Inj id xs) -> fst
(( id, ConstructorInfo ( foldl
{ numArgsCI = length (init . flattenType $ xs) ( \(acc, i) (Inj id xs) ->
, argumentsCI = createArgs (init . flattenType $ xs) ( ( id
, numCI = i , ConstructorInfo
, returnTypeCI = t --last . flattenType $ xs { numArgsCI = length (init . flattenType $ xs)
} , argumentsCI = createArgs (init . flattenType $ xs)
) : acc, i + 1)) ([], 0) cons) <> go xs , numCI = i
, returnTypeCI = t -- last . flattenType $ xs
}
)
: acc
, i + 1
)
)
([], 0)
cons
)
<> go xs
go (_ : xs) = go xs go (_ : xs) = go xs
getTypes :: [MIR.Def] -> Set LLVMType getTypes :: [MIR.Def] -> Set LLVMType
getTypes bs = Set.fromList $ go bs getTypes bs = Set.fromList $ go bs
where where
go [] = [] go [] = []
go (MIR.DData (MIR.Data t _) : xs) = type2LlvmType t : go xs go (MIR.DData (MIR.Data t _) : xs) = type2LlvmType t : go xs
go (_:xs) = go xs go (_ : xs) = go xs
initCodeGenerator :: [MIR.Def] -> CodeGenerator initCodeGenerator :: [MIR.Def] -> CodeGenerator
initCodeGenerator scs = initCodeGenerator scs =
@ -165,6 +182,7 @@ test v =
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"))
int x = (ELit (LInt x), MIR.TLit (MIR.Ident "_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
@ -172,7 +190,7 @@ test v =
generateCode :: MIR.Program -> Err String generateCode :: MIR.Program -> Err String
generateCode (MIR.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 (trace (show scs) scs)) codegen
compileScs :: [MIR.Def] -> CompilerState () compileScs :: [MIR.Def] -> CompilerState ()
compileScs [] = do compileScs [] = do
@ -240,16 +258,17 @@ compileScs [] = do
modify $ \s -> s{variableCount = 0} modify $ \s -> s{variableCount = 0}
) )
c c
compileScs (MIR.DBind (MIR.Bind (name, _t) args exp) : xs) = do compileScs (MIR.DBind (MIR.Bind (name, t) args exp) : xs) = do
let t_return = type2LlvmType . last . flattenType $ t
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 t_return name args'
when (name == "main") (mapM_ emit firstMainContent) when (name == "main") (mapM_ emit firstMainContent)
functionBody <- exprToValue exp functionBody <- exprToValue exp
if name == "main" if name == "main"
then mapM_ emit $ lastMainContent functionBody then mapM_ emit $ lastMainContent functionBody
else emit $ Ret I64 functionBody else emit $ Ret t_return functionBody
emit DefineEnd emit DefineEnd
modify $ \s -> s{variableCount = 0} modify $ \s -> s{variableCount = 0}
compileScs xs compileScs xs
@ -267,8 +286,10 @@ compileScs (MIR.DData (MIR.Data typ ts) : xs) = do
firstMainContent :: [LLVMIr] firstMainContent :: [LLVMIr]
firstMainContent = firstMainContent =
[ UnsafeRaw "call void @_ZN2GC4Heap4initEv()\n" []
]
-- UnsafeRaw "call void @_ZN2GC4Heap4initEv()\n"
lastMainContent :: LLVMValue -> [LLVMIr] lastMainContent :: LLVMValue -> [LLVMIr]
lastMainContent var = lastMainContent var =
[ UnsafeRaw $ [ UnsafeRaw $
@ -284,20 +305,21 @@ defaultStart =
, UnsafeRaw "@.non_exhaustive_patterns = private unnamed_addr constant [41 x i8] c\"Non-exhaustive patterns in case at %i:%i\n\"\n" , UnsafeRaw "@.non_exhaustive_patterns = private unnamed_addr constant [41 x i8] c\"Non-exhaustive patterns in case at %i:%i\n\"\n"
, UnsafeRaw "declare i32 @printf(ptr noalias nocapture, ...)\n" , UnsafeRaw "declare i32 @printf(ptr noalias nocapture, ...)\n"
, UnsafeRaw "declare i32 @exit(i32 noundef)\n" , UnsafeRaw "declare i32 @exit(i32 noundef)\n"
, UnsafeRaw "declare i32 @_ZN2GC4Heap4initEv()\n" , UnsafeRaw "declare ptr @malloc(i32 noundef)\n"
, UnsafeRaw "declare i32 @_ZN2GC4Heap5allocEm()\n" , UnsafeRaw "declare void @_ZN2GC4Heap4initEv()\n"
, UnsafeRaw "declare i32 @_ZN2GC4Heap7disposeEv()\n" , UnsafeRaw "declare void @_ZN2GC4Heap5allocEm()\n"
, UnsafeRaw "declare void @_ZN2GC4Heap7disposeEv()\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.EVar name, t) = emitIdent name compileExp (MIR.EVar name, t) = emitIdent name
compileExp (MIR.EApp e1 e2,t) = emitApp t e1 e2 compileExp (MIR.EApp e1 e2, t) = emitApp t e1 e2
-- compileExp (EAbs t ti e) = emitAbs t ti e -- compileExp (EAbs t ti e) = emitAbs t ti e
compileExp (MIR.ELet binds e,t) = undefined -- emitLet binds (fst e) compileExp (MIR.ELet binds e, t) = undefined -- emitLet binds (fst e)
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
@ -319,7 +341,7 @@ emitECased t e cases = do
-- emit $ Label crashLbl -- emit $ Label crashLbl
emit . UnsafeRaw $ "call i32 (ptr, ...) @printf(ptr noundef @.non_exhaustive_patterns, i64 noundef 6, i64 noundef 6)\n" emit . UnsafeRaw $ "call i32 (ptr, ...) @printf(ptr noundef @.non_exhaustive_patterns, i64 noundef 6, i64 noundef 6)\n"
emit . UnsafeRaw $ "call i32 @exit(i32 noundef 1)\n" emit . UnsafeRaw $ "call i32 @exit(i32 noundef 1)\n"
mapM_ (const increaseVarCount) [0..1] mapM_ (const increaseVarCount) [0 .. 1]
emit $ Br label emit $ Br label
emit $ Label label emit $ Label label
res <- getNewVar res <- getNewVar
@ -349,28 +371,28 @@ emitECased t e cases = do
emit $ SetVariable casted (Load (CustomType (coerce consId)) Ptr castPtr) emit $ SetVariable casted (Load (CustomType (coerce consId)) Ptr castPtr)
val <- exprToValue exp val <- exprToValue exp
enumerateOneM_ enumerateOneM_
(\i c -> do ( \i c -> do
case c of case c of
PVar x -> do PVar x -> do
emit . Comment $ "ident " <> show x emit . Comment $ "ident " <> show x
emit $ SetVariable (fst x) (ExtractValue (CustomType (coerce consId)) (VIdent casted Ptr) i) emit $ SetVariable (fst x) (ExtractValue (CustomType (coerce consId)) (VIdent casted Ptr) i)
PLit (l, t) -> undefined PLit (l, t) -> undefined
PInj id ps -> undefined PInj id ps -> undefined
PCatch -> pure() PCatch -> pure ()
PEnum id -> undefined PEnum id -> undefined
--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"
) )
cs cs
emit $ Store ty val Ptr stackPtr emit $ Store ty val Ptr stackPtr
@ -379,7 +401,7 @@ emitECased t e cases = do
emitCases rt ty label stackPtr vs (Branch (MIR.PLit i, _) exp) = do emitCases rt ty label stackPtr vs (Branch (MIR.PLit i, _) exp) = do
emit $ Comment "Plit" emit $ Comment "Plit"
let i' = case i of let i' = case i of
(MIR.LInt i, _) -> VInteger i (MIR.LInt i, _) -> VInteger i
(MIR.LChar i, _) -> VChar (ord i) (MIR.LChar i, _) -> VChar (ord i)
ns <- getNewVar ns <- getNewVar
lbl_failPos <- (\x -> TIR.Ident $ "failed_" <> show x) <$> getNewLabel lbl_failPos <- (\x -> TIR.Ident $ "failed_" <> show x) <$> getNewLabel
@ -391,7 +413,7 @@ emitECased t e cases = do
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 (Branch (MIR.PVar (id,_), _) exp) = do emitCases rt ty label stackPtr vs (Branch (MIR.PVar (id, _), _) exp) = do
emit $ Comment "Pvar" emit $ Comment "Pvar"
-- //TODO this is pretty disgusting and would heavily benefit from a rewrite -- //TODO this is pretty disgusting and would heavily benefit from a rewrite
valPtr <- getNewVar valPtr <- getNewVar
@ -418,7 +440,7 @@ emitECased t e cases = do
lbl_failPos <- (\x -> TIR.Ident $ "failed_" <> show x) <$> getNewLabel lbl_failPos <- (\x -> TIR.Ident $ "failed_" <> show x) <$> getNewLabel
emit $ Label lbl_failPos emit $ Label lbl_failPos
--emitLet :: Bind -> Exp -> CompilerState () -- emitLet :: Bind -> Exp -> CompilerState ()
emitLet xs e = do emitLet xs e = do
emit $ emit $
Comment $ Comment $
@ -446,8 +468,7 @@ emitApp rt e1 e2 = appEmitter e1 e2 []
let visibility = let visibility =
fromMaybe Local $ fromMaybe Local $
Global <$ Map.lookup name consts Global <$ Map.lookup name consts
<|> <|> Global <$ Map.lookup (name, t) 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 rt) visibility name args' call = Call FastCC (type2LlvmType rt) visibility name args'
@ -466,7 +487,7 @@ 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 $ ord i'', I8) (MIR.LChar i'') -> (VChar $ ord i'', I8)
varCount <- getNewVar varCount <- getNewVar
emit $ Comment "This should not have happened!" emit $ Comment "This should not have happened!"
@ -489,16 +510,20 @@ emitSub t e1 e2 = do
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 $ ord i (MIR.LChar i) -> VChar $ ord i
(MIR.EVar name, t) -> do (MIR.EVar name, t) -> do
funcs <- gets functions funcs <- gets functions
cons <- gets constructors cons <- gets constructors
let res = Map.lookup (name, t) funcs let res =
<|> Map.lookup (name, t) funcs
(\c -> FunctionInfo { numArgs = numArgsCI c <|> ( \c ->
, arguments = argumentsCI c} ) FunctionInfo
<$> Map.lookup name cons { numArgs = numArgsCI c
, arguments = argumentsCI c
}
)
<$> Map.lookup name cons
case res of case res of
Just fi -> do Just fi -> do
if numArgs fi == 0 if numArgs fi == 0
@ -519,40 +544,42 @@ exprToValue = \case
type2LlvmType :: MIR.Type -> LLVMType type2LlvmType :: MIR.Type -> LLVMType
type2LlvmType (MIR.TLit id@(TIR.Ident name)) = case name of type2LlvmType (MIR.TLit id@(TIR.Ident name)) = case name of
"Int" -> I64 "Int" -> I64
_ -> CustomType id "Char" -> I8
type2LlvmType (MIR.TFun t xs) = do _ -> CustomType id
type2LlvmType (MIR.TFun t xs) = do
let (t', xs') = function2LLVMType xs [type2LlvmType t] let (t', xs') = function2LLVMType xs [type2LlvmType t]
Function t' xs' Function t' xs'
where where
function2LLVMType :: Type -> [LLVMType] -> (LLVMType, [LLVMType]) function2LLVMType :: Type -> [LLVMType] -> (LLVMType, [LLVMType])
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
extractTypeName :: MIR.Type -> TIR.Ident extractTypeName :: MIR.Type -> TIR.Ident
extractTypeName (MIR.TLit id) = id extractTypeName (MIR.TLit id) = id
extractTypeName (MIR.TFun t xs) = let (TIR.Ident i) = extractTypeName t extractTypeName (MIR.TFun t xs) =
(TIR.Ident is) = extractTypeName xs let (TIR.Ident i) = extractTypeName t
in TIR.Ident $ i <> "_$_" <> is (TIR.Ident is) = extractTypeName xs
in TIR.Ident $ i <> "_$_" <> is
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 ()

5
src/Compiler.hs
View file

@ -16,7 +16,10 @@ optimize :: String -> IO String
optimize = readCreateProcess (shell "opt --O3 -S") optimize = readCreateProcess (shell "opt --O3 -S")
compileClang :: String -> IO String compileClang :: String -> IO String
compileClang = readCreateProcess (shell "clang -x ir -o output/hello_world -") compileClang = readCreateProcess . shell
$ unwords ["clang++"--, "-Lsrc/GC/lib/", "-l:libgcoll.a"
, "-fno-exceptions -x", "ir" ,"-o" ,"output/hello_world"
, "-"]
compile :: String -> IO String compile :: String -> IO String
compile s = optimize s >>= compileClang compile s = optimize s >>= compileClang