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

Got most of the codegenerator working.

Browse source
This commit is contained in:
Samuel Hammersberg 2023-03-24 11:55:05 +01:00
parent 32f8a3e8a9
commit 3f618e77f9
1 changed files with 41 additions and 48 deletions
Download patch file Download diff file Expand all files Collapse all files

89
src/Codegen/Codegen.hs
View file

@ -22,7 +22,7 @@ import Monomorphizer.MonomorphizerIr as MIR
data CodeGenerator = CodeGenerator data CodeGenerator = CodeGenerator
{ instructions :: [LLVMIr] { instructions :: [LLVMIr]
, functions :: Map MIR.Id FunctionInfo , functions :: Map MIR.Id FunctionInfo
, constructors :: Map Ident ConstructorInfo , constructors :: Map MIR.Id ConstructorInfo
, variableCount :: Integer , variableCount :: Integer
, labelCount :: Integer , labelCount :: Integer
} }
@ -74,18 +74,18 @@ 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) = undefined go (MIR.DData (MIR.Constructor n cons) : xs) =
{-do map do map
( \(Constructor id xs) -> ( \(id, xs) ->
( (id, MIR.TLit n) ( (coerce id, MIR.TLit (coerce n))
, FunctionInfo , FunctionInfo
{ numArgs = length xs { numArgs = length (flattenType xs)
, arguments = createArgs xs , arguments = createArgs (flattenType xs)
} }
) )
) )
cons cons
<> go xs-} <> go xs
createArgs :: [MIR.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
@ -93,19 +93,19 @@ createArgs xs = fst $ foldl (\(acc, l) t -> (acc ++ [(GA.Ident ("arg_" <> show l
{- | 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 :: [MIR.Def] -> Map Ident ConstructorInfo 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 n cons) : xs) = undefined go (MIR.DData (MIR.Constructor (GA.UIdent n) cons) : xs) =
{-do do
fst fst
( foldl ( foldl
( \(acc, i) (GA.Constructor (GA.Ident id) xs) -> ( \(acc, i) (GA.UIdent id, xs) ->
( ( (GA.Ident (n <> "_" <> id), MIR.TLit (GA.Ident n)) ( ( (GA.Ident (n <> "_" <> id), MIR.TLit (coerce n))
, ConstructorInfo , ConstructorInfo
{ numArgsCI = length xs { numArgsCI = length (flattenType xs)
, argumentsCI = createArgs xs , argumentsCI = createArgs (flattenType xs)
, numCI = i , numCI = i
} }
) )
@ -116,7 +116,7 @@ getConstructors bs = Map.fromList $ go bs
([], 0) ([], 0)
cons cons
) )
<> go xs-} <> go xs
go (_ : xs) = go xs go (_ : xs) = go xs
initCodeGenerator :: [MIR.Def] -> CodeGenerator initCodeGenerator :: [MIR.Def] -> CodeGenerator
@ -182,10 +182,9 @@ generateCode (MIR.Program scs) = do
compileScs :: [MIR.Def] -> 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
@ -247,7 +246,7 @@ 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
emit $ UnsafeRaw "\n" emit $ UnsafeRaw "\n"
emit . Comment $ show name <> ": " <> show exp emit . Comment $ show name <> ": " <> show exp
@ -260,19 +259,16 @@ 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 outer_id ts) : xs) = do compileScs (MIR.DData (MIR.Constructor (GA.UIdent outer_id) ts) : xs) = do
undefined let types = BI.second flattenType <$> ts
-- let biggestVariant = maximum ((\(Constructor _ t) -> sum $ typeByteSize . type2LlvmType <$> t) <$> ts) let biggestVariant = maximum $ sum . map (typeByteSize . type2LlvmType) <$> (snd <$> types)
-- emit $ LIR.Type outer_id [I8, Array biggestVariant I8] emit $ LIR.Type (coerce outer_id) [I8, Array biggestVariant I8]
-- mapM_ mapM_
-- ( \(GA.Constructor (GA.UIdent inner_id) fi) -> do ( \(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 fi)
-- ) )
-- ts types
-- compileScs xs compileScs xs
-- where
-- _t_return = snd $ partitionType (length args) t
mainContent :: LLVMValue -> [LLVMIr] mainContent :: LLVMValue -> [LLVMIr]
mainContent var = mainContent var =
@ -336,9 +332,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.InitConstructor consId cs, _t) 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 (coerce consId) 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
@ -439,7 +435,7 @@ emitApp t e1 e2 = appEmitter e1 e2 []
consts <- gets constructors consts <- gets constructors
let visibility = let visibility =
fromMaybe Local $ fromMaybe Local $
Global <$ Map.lookup name consts Global <$ Map.lookup (name, t) 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
@ -503,19 +499,16 @@ exprToValue = \case
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 = undefined {-(MIR.Type (GA.Ident t)) = case t of type2LlvmType (MIR.TLit id@(Ident name)) = case name of
"_Int" -> I64 "Int" -> I64
t -> CustomType (GA.Ident t)-} _ -> CustomType id
type2LlvmType (MIR.TFun t xs) = do
-- TInt -> I64 let (t', xs') = function2LLVMType xs [type2LlvmType t]
-- TFun t xs -> do Function t' xs'
-- let (t', xs') = function2LLVMType xs [type2LlvmType t] where
-- Function t' xs' function2LLVMType :: Type -> [LLVMType] -> (LLVMType, [LLVMType])
-- TPol t -> CustomType t function2LLVMType (TFun t xs) s = function2LLVMType xs (type2LlvmType t : s)
-- where function2LLVMType x s = (type2LlvmType x, s)
-- function2LLVMType :: Type -> [LLVMType] -> (LLVMType, [LLVMType])
-- function2LLVMType (TFun t xs) s = function2LLVMType xs (type2LlvmType t : s)
-- function2LLVMType x s = (type2LlvmType x, s)
getType :: ExpT -> LLVMType getType :: ExpT -> LLVMType
getType (_, t) = type2LlvmType t getType (_, t) = type2LlvmType t