Got most of the codegenerator working.
This commit is contained in:
Samuel Hammersberg
parent
32f8a3e8a9
commit
3f618e77f9
1 changed files with 41 additions and 48 deletions
|
|
@ -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
|
||||||
|
|
|
||||||
Loading…
Add table
Add a link
Reference in a new issue