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

Started updating the Code Generator to the new monomorphizer tree.

Browse source
This commit is contained in:
Samuel Hammersberg 2023-03-21 09:39:05 +01:00
parent 350cd3b0e9
commit bbf7a47e74
7 changed files with 753 additions and 706 deletions
Download patch file Download diff file Expand all files Collapse all files

2
Grammar.cf
View file

@ -13,7 +13,7 @@ Data. Data ::= "data" Constr "where" "{" [Constructor] "}" ;
Constructor. Constructor ::= Ident ":" Type ; Constructor. Constructor ::= Ident ":" Type ;
separator nonempty Constructor "" ; separator nonempty Constructor "" ;
TMono. Type1 ::= "_" Ident ; TMono. Type1 ::= Ident ;
TPol. Type1 ::= "'" Ident ; TPol. Type1 ::= "'" Ident ;
TConstr. Type1 ::= Constr ; TConstr. Type1 ::= Constr ;
TArr. Type ::= Type1 "->" Type ; TArr. Type ::= Type1 "->" Type ;

2
language.cabal
View file

@ -37,6 +37,8 @@ executable language
Renamer.Renamer Renamer.Renamer
TypeChecker.TypeChecker TypeChecker.TypeChecker
TypeChecker.TypeCheckerIr TypeChecker.TypeCheckerIr
Monomorphizer.Monomorphizer
Monomorphizer.MonomorphizerIr
-- Interpreter -- Interpreter
Codegen.Codegen Codegen.Codegen
Codegen.LlvmIr Codegen.LlvmIr

45
sample-programs/basic-1
View file

@ -1,26 +1,29 @@
posMul : _Int -> _Int -> _Int; posMul : _Int -> _Int -> _Int;
posMul a b = case b of { posMul a b = a + b; {-case b of {
0 => 0; 0 => 0;
_ => a + posMul a (b - 1) _ => a + posMul a (b - 1)
}; };-}
facc : _Int -> _Int;
facc a = case a of {
1 => 1;
_ => posMul a (facc (a - 1))
};
minimization : (_Int -> _Int) -> _Int -> _Int;
minimization p x = case p x of {
1 => x;
_ => minimization p (x + 1)
};
checkFac : _Int -> _Int;
checkFac x = case facc x of {
0 => 1;
_ => 0
};
main : _Int; main : _Int;
main = minimization checkFac 1 main = posMul 5 10;
--
-- facc : _Int -> _Int;
-- facc a = case a of {
-- 1 => 1;
-- _ => posMul a (facc (a - 1))
-- };
--
-- minimization : (_Int -> _Int) -> _Int -> _Int;
-- minimization p x = case p x of {
-- 1 => x;
-- _ => minimization p (x + 1)
-- };
--
-- checkFac : _Int -> _Int;
-- checkFac x = case facc x of {
-- 0 => 1;
-- _ => 0
-- };
--
-- main : _Int;
-- main = minimization checkFac 1

859
src/Codegen/Codegen.hs
View file

@ -1,409 +1,415 @@
module Codegen.Codegen where {-# LANGUAGE LambdaCase #-}
-- {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-}
-- {-# LANGUAGE OverloadedStrings #-}
-- module Codegen.Codegen (generateCode) where
-- module Codegen.Codegen (generateCode) where import Auxiliary (snoc)
-- import Codegen.LlvmIr (CallingConvention (..),
-- import Auxiliary (snoc) LLVMComp (..), LLVMIr (..),
-- import Codegen.LlvmIr (CallingConvention (..), LLVMType (..), LLVMValue (..),
-- LLVMComp (..), LLVMIr (..), Visibility (..), llvmIrToString)
-- LLVMType (..), LLVMValue (..), import Codegen.LlvmIr as LIR
-- Visibility (..), llvmIrToString) import Control.Monad.State (StateT, execStateT, foldM_,
-- import Control.Monad.State (StateT, execStateT, foldM_, gets, gets, modify)
-- modify) import qualified Data.Bifunctor as BI
-- import qualified Data.Bifunctor as BI import Data.List.Extra (trim)
-- import Data.List.Extra (trim) import Data.Map (Map)
-- import Data.Map (Map) import qualified Data.Map as Map
-- import qualified Data.Map as Map import Data.Tuple.Extra (dupe, first, second)
-- import Data.Tuple.Extra (dupe, first, second) import qualified Grammar.Abs as GA
-- import qualified Grammar.Abs as GA import Grammar.ErrM (Err)
-- import Grammar.ErrM (Err) import Monomorphizer.MonomorphizerIr as MIR
-- import System.Process.Extra (readCreateProcess, shell) import System.Process.Extra (readCreateProcess, shell)
-- import TypeChecker.TypeCheckerIr (Bind (..), Case (..), Exp (..), Id, -- | The record used as the code generator state
-- Ident (..), Program (..), Type (..)) data CodeGenerator = CodeGenerator
-- -- | The record used as the code generator state { instructions :: [LLVMIr]
-- data CodeGenerator = CodeGenerator , functions :: Map Id FunctionInfo
-- { instructions :: [LLVMIr] , constructors :: Map Id ConstructorInfo
-- , functions :: Map Id FunctionInfo , variableCount :: Integer
-- , constructors :: Map Id ConstructorInfo , labelCount :: Integer
-- , variableCount :: Integer }
-- , labelCount :: Integer
-- } -- | A state type synonym
-- type CompilerState a = StateT CodeGenerator Err a
-- -- | A state type synonym
-- type CompilerState a = StateT CodeGenerator Err a data FunctionInfo = FunctionInfo
-- { numArgs :: Int
-- data FunctionInfo = FunctionInfo , arguments :: [Id]
-- { numArgs :: Int }
-- , arguments :: [Id] data ConstructorInfo = ConstructorInfo
-- } { numArgsCI :: Int
-- data ConstructorInfo = ConstructorInfo , argumentsCI :: [Id]
-- { numArgsCI :: Int , numCI :: Integer
-- , argumentsCI :: [Id] }
-- , numCI :: Integer
-- }
-- -- | Adds a instruction to the CodeGenerator state
-- emit :: LLVMIr -> CompilerState ()
-- -- | Adds a instruction to the CodeGenerator state emit l = modify $ \t -> t { instructions = Auxiliary.snoc l $ instructions t }
-- emit :: LLVMIr -> CompilerState ()
-- emit l = modify $ \t -> t { instructions = Auxiliary.snoc l $ instructions t } -- | Increases the variable counter in the CodeGenerator state
-- increaseVarCount :: CompilerState ()
-- -- | Increases the variable counter in the CodeGenerator state increaseVarCount = modify $ \t -> t { variableCount = variableCount t + 1 }
-- increaseVarCount :: CompilerState ()
-- increaseVarCount = modify $ \t -> t { variableCount = variableCount t + 1 } -- | Returns the variable count from the CodeGenerator state
-- getVarCount :: CompilerState Integer
-- -- | Returns the variable count from the CodeGenerator state getVarCount = gets variableCount
-- getVarCount :: CompilerState Integer
-- getVarCount = gets variableCount -- | Increases the variable count and returns it from the CodeGenerator state
-- getNewVar :: CompilerState Integer
-- -- | Increases the variable count and returns it from the CodeGenerator state getNewVar = increaseVarCount >> getVarCount
-- getNewVar :: CompilerState Integer
-- getNewVar = increaseVarCount >> getVarCount -- | Increses the label count and returns a label from the CodeGenerator state
-- getNewLabel :: CompilerState Integer
-- -- | Increses the label count and returns a label from the CodeGenerator state getNewLabel = do
-- getNewLabel :: CompilerState Integer modify (\t -> t{labelCount = labelCount t + 1})
-- getNewLabel = do gets labelCount
-- modify (\t -> t{labelCount = labelCount t + 1})
-- gets labelCount -- | Produces a map of functions infos from a list of binds,
-- -- which contains useful data for code generation.
-- -- | Produces a map of functions infos from a list of binds, getFunctions :: [Bind] -> Map Id FunctionInfo
-- -- which contains useful data for code generation. getFunctions bs = Map.fromList $ go bs
-- getFunctions :: [Bind] -> Map Id FunctionInfo where
-- getFunctions bs = Map.fromList $ go bs go [] = []
-- where go (Bind id args _ : xs) =
-- go [] = [] (id, FunctionInfo { numArgs=length args, arguments=args })
-- go (Bind id args _ : xs) = : go xs
-- (id, FunctionInfo { numArgs=length args, arguments=args }) go (DataType n cons : xs) = do
-- : go xs map (\(Constructor id xs) -> ((id, MIR.Type n), FunctionInfo {
-- go (DataStructure n cons : xs) = do numArgs=length xs, arguments=createArgs xs
-- map (\(id, xs) -> ((id, TPol n), FunctionInfo { })) cons
-- numArgs=length xs, arguments=createArgs xs <> go xs
-- })) cons
-- <> go xs createArgs :: [Type] -> [Id]
-- createArgs xs = fst $ foldl (\(acc, l) t -> (acc ++ [(GA.Ident ("arg_" <> show l) , t)],l+1)) ([], 0) xs
-- createArgs :: [Type] -> [Id]
-- createArgs xs = fst $ foldl (\(acc, l) t -> (acc ++ [(Ident ("arg_" <> show l) , t)],l+1)) ([], 0) xs -- | Produces a map of functions infos from a list of binds,
-- -- which contains useful data for code generation.
-- -- | Produces a map of functions infos from a list of binds, getConstructors :: [Bind] -> Map Id ConstructorInfo
-- -- which contains useful data for code generation. getConstructors bs = Map.fromList $ go bs
-- getConstructors :: [Bind] -> Map Id ConstructorInfo where
-- getConstructors bs = Map.fromList $ go bs go [] = []
-- where go (DataType (GA.Ident n) cons : xs) = do
-- go [] = [] fst (foldl (\(acc,i) (Constructor (GA.Ident id) xs) -> (((GA.Ident (n <> "_" <> id), MIR.Type (GA.Ident n)), ConstructorInfo {
-- go (DataStructure (Ident n) cons : xs) = do numArgsCI=length xs,
-- fst (foldl (\(acc,i) (Ident id, xs) -> (((Ident (n <> "_" <> id), TPol (Ident n)), ConstructorInfo { argumentsCI=createArgs xs,
-- numArgsCI=length xs, numCI=i
-- argumentsCI=createArgs xs, }) : acc, i+1)) ([],0) cons)
-- numCI=i <> go xs
-- }) : acc, i+1)) ([],0) cons) go (_: xs) = go xs
-- <> go xs
-- go (_: xs) = go xs initCodeGenerator :: [Bind] -> CodeGenerator
-- initCodeGenerator scs = CodeGenerator { instructions = defaultStart
-- initCodeGenerator :: [Bind] -> CodeGenerator , functions = getFunctions scs
-- initCodeGenerator scs = CodeGenerator { instructions = defaultStart , constructors = getConstructors scs
-- , functions = getFunctions scs , variableCount = 0
-- , constructors = getConstructors scs , labelCount = 0
-- , variableCount = 0 }
-- , labelCount = 0
-- } run :: Err String -> IO ()
-- run s = do
-- run :: Err String -> IO () let s' = case s of
-- run s = do Right s -> s
-- let s' = case s of Left _ -> error "yo"
-- Right s -> s writeFile "output/llvm.ll" s'
-- Left _ -> error "yo" putStrLn . trim =<< readCreateProcess (shell "lli") s'
-- writeFile "output/llvm.ll" s'
-- putStrLn . trim =<< readCreateProcess (shell "lli") s' test :: Integer -> Program
-- test v = Program [
-- test :: Integer -> Program DataType (GA.Ident "Craig") [
-- test v = Program [ Constructor (GA.Ident "Bob") [MIR.Type (GA.Ident "_Int")]--,
-- DataStructure (Ident "Craig") [ --(GA.Ident "Alice", [TInt, TInt])
-- (Ident "Bob", [TInt])--, ],
-- --(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")) []
-- Bind (Ident "fibonacci", TInt) [(Ident "x", TInt)] (EId ("x",TInt)), (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)
-- Bind (Ident "main", TInt) [] ( ]
-- EApp (TPol "Craig") (EId (Ident "Craig_Bob", TPol "Craig")) (EInt v) -- (EInt 92)
-- ) {- | Compiles an AST and produces a LLVM Ir string.
-- ] An easy way to actually "compile" this output is to
-- Simply pipe it to LLI
-- {- | Compiles an AST and produces a LLVM Ir string. -}
-- An easy way to actually "compile" this output is to generateCode :: Program -> Err String
-- Simply pipe it to LLI generateCode (Program scs) = do
-- -} let codegen = initCodeGenerator scs
-- generateCode :: Program -> Err String llvmIrToString . instructions <$> execStateT (compileScs scs) codegen
-- generateCode (Program scs) = do
-- let codegen = initCodeGenerator scs compileScs :: [Bind] -> CompilerState ()
-- llvmIrToString . instructions <$> execStateT (compileScs scs) codegen compileScs [] = do
-- -- as a last step create all the constructors
-- compileScs :: [Bind] -> CompilerState () c <- gets (Map.toList . constructors)
-- compileScs [] = do mapM_ (\((id, t), ci) -> do
-- -- as a last step create all the constructors let t' = type2LlvmType t
-- c <- gets (Map.toList . constructors) let x = BI.second type2LlvmType <$> argumentsCI ci
-- mapM_ (\((id, t), ci) -> do emit $ Define FastCC t' id x
-- let t' = type2LlvmType t top <- GA.Ident . show <$> getNewVar
-- let x = BI.second type2LlvmType <$> argumentsCI ci ptr <- GA.Ident . show <$> getNewVar
-- emit $ Define FastCC t' id x -- allocated the primary type
-- top <- Ident . show <$> getNewVar emit $ SetVariable top (Alloca t')
-- ptr <- Ident . show <$> getNewVar
-- -- allocated the primary type -- set the first byte to the index of the constructor
-- emit $ SetVariable top (Alloca t') emit $ SetVariable ptr $
-- GetElementPtrInbounds t' (Ref t')
-- -- set the first byte to the index of the constructor (VIdent top I8) I32 (VInteger 0) I32 (VInteger 0)
-- emit $ SetVariable ptr $ emit $ Store I8 (VInteger $ numCI ci ) (Ref I8) ptr
-- GetElementPtrInbounds t' (Ref t')
-- (VIdent top I8) I32 (VInteger 0) I32 (VInteger 0) -- get a pointer of the correct type
-- emit $ Store I8 (VInteger $ numCI ci ) (Ref I8) ptr ptr' <- GA.Ident . show <$> getNewVar
-- emit $ SetVariable ptr' (Bitcast (Ref t') ptr (Ref $ CustomType id))
-- -- get a pointer of the correct type
-- ptr' <- Ident . show <$> getNewVar
-- emit $ SetVariable ptr' (Bitcast (Ref t') ptr (Ref $ CustomType id))
--
-- --emit $ UnsafeRaw "\n"
--
-- foldM_ (\i (Ident arg_n, arg_t)-> do
-- let arg_t' = type2LlvmType arg_t
-- emit $ Comment (show arg_t' <>" "<> arg_n <> " " <> show i )
-- elemPtr <- Ident . show <$> getNewVar
-- emit $ SetVariable elemPtr (
-- GetElementPtrInbounds (CustomType id) (Ref (CustomType id))
-- (VIdent ptr' Ptr) I32
-- (VInteger 0) I32 (VInteger i))
-- emit $ Store arg_t' (VIdent (Ident arg_n) arg_t') Ptr elemPtr
-- -- %2 = getelementptr inbounds %Foo_AInteger, %Foo_AInteger* %1, i32 0, i32 1
-- -- store i32 42, i32* %2
-- pure $ i + 1-- + typeByteSize arg_t'
-- ) 1 (argumentsCI ci)
--
-- --emit $ UnsafeRaw "\n"
--
-- -- load and return the constructed value
-- load <- Ident . show <$> getNewVar
-- emit $ SetVariable load (Load t' Ptr top)
-- emit $ Ret t' (VIdent load t')
-- emit DefineEnd
--
-- modify $ \s -> s { variableCount = 0 }
-- ) c
-- compileScs (Bind (name, _t) args exp : xs) = do
--emit $ UnsafeRaw "\n" --emit $ UnsafeRaw "\n"
-- emit . Comment $ show name <> ": " <> show exp
-- let args' = map (second type2LlvmType) args foldM_ (\i (GA.Ident arg_n, arg_t)-> do
-- emit $ Define FastCC I64 {-(type2LlvmType t_return)-} name args' let arg_t' = type2LlvmType arg_t
-- functionBody <- exprToValue exp emit $ Comment (show arg_t' <>" "<> arg_n <> " " <> show i )
-- if name == "main" elemPtr <- GA.Ident . show <$> getNewVar
-- then mapM_ emit $ mainContent functionBody emit $ SetVariable elemPtr (
-- else emit $ Ret I64 functionBody GetElementPtrInbounds (CustomType id) (Ref (CustomType id))
-- emit DefineEnd (VIdent ptr' Ptr) I32
-- modify $ \s -> s { variableCount = 0 } (VInteger 0) I32 (VInteger i))
-- compileScs xs emit $ Store arg_t' (VIdent (GA.Ident arg_n) arg_t') Ptr elemPtr
-- compileScs (DataStructure id@(Ident outer_id) ts : xs) = do -- %2 = getelementptr inbounds %Foo_AInteger, %Foo_AInteger* %1, i32 0, i32 1
-- let biggest_variant = maximum ((\(_, t) -> sum $ typeByteSize . type2LlvmType <$> t) <$> ts) -- store i32 42, i32* %2
-- emit $ Type id [I8, Array biggest_variant I8] pure $ i + 1-- + typeByteSize arg_t'
-- mapM_ (\(Ident inner_id, fi) -> do ) 1 (argumentsCI ci)
-- emit $ Type (Ident $ outer_id <> "_" <> inner_id) (I8 : map type2LlvmType fi)
-- ) ts --emit $ UnsafeRaw "\n"
-- compileScs xs
-- -- load and return the constructed value
-- -- where load <- GA.Ident . show <$> getNewVar
-- -- _t_return = snd $ partitionType (length args) t emit $ SetVariable load (Load t' Ptr top)
-- emit $ Ret t' (VIdent load t')
-- mainContent :: LLVMValue -> [LLVMIr] emit DefineEnd
-- mainContent var =
-- [ UnsafeRaw $ modify $ \s -> s { variableCount = 0 }
-- "call i32 (ptr, ...) @printf(ptr noundef @.str, i64 noundef " <> show var <> ")\n" ) c
-- , -- , SetVariable (Ident "p") (Icmp LLEq I64 (VInteger 2) (VInteger 2)) compileScs (Bind (name, _t) args exp : xs) = do
-- -- , BrCond (VIdent (Ident "p")) (Ident "b_1") (Ident "b_2") emit $ UnsafeRaw "\n"
-- -- , Label (Ident "b_1") emit . Comment $ show name <> ": " <> show exp
-- -- , UnsafeRaw let args' = map (second type2LlvmType) args
-- -- "call i32 (ptr, ...) @printf(ptr noundef @.str, i64 noundef 1)\n" emit $ Define FastCC I64 {-(type2LlvmType t_return)-} name args'
-- -- , Br (Ident "end") functionBody <- exprToValue (fst exp)
-- -- , Label (Ident "b_2") if name == "main"
-- -- , UnsafeRaw then mapM_ emit $ mainContent functionBody
-- -- "call i32 (ptr, ...) @printf(ptr noundef @.str, i64 noundef 2)\n" else emit $ Ret I64 functionBody
-- -- , Br (Ident "end") emit DefineEnd
-- -- , Label (Ident "end") modify $ \s -> s { variableCount = 0 }
-- Ret I64 (VInteger 0) compileScs xs
-- ] compileScs (DataType id@(GA.Ident outer_id) ts : xs) = do
-- let biggest_variant = maximum ((\(Constructor _ t) -> sum $ typeByteSize . type2LlvmType <$> t) <$> ts)
-- defaultStart :: [LLVMIr] emit $ LIR.Type id [I8, Array biggest_variant I8]
-- defaultStart = [ UnsafeRaw "target triple = \"x86_64-pc-linux-gnu\"\n" mapM_ (\(Constructor (GA.Ident inner_id) fi) -> do
-- , UnsafeRaw "target datalayout = \"e-m:o-i64:64-f80:128-n8:16:32:64-S128\"\n" emit $ LIR.Type (GA.Ident $ outer_id <> "_" <> inner_id) (I8 : map type2LlvmType fi)
-- , UnsafeRaw "@.str = private unnamed_addr constant [3 x i8] c\"%i\n\", align 1\n" ) ts
-- , UnsafeRaw "declare i32 @printf(ptr noalias nocapture, ...)\n" compileScs xs
-- ]
-- -- where
-- compileExp :: Exp -> CompilerState () -- _t_return = snd $ partitionType (length args) t
-- compileExp (EInt int) = emitInt int
-- compileExp (EAdd t e1 e2) = emitAdd t e1 e2 mainContent :: LLVMValue -> [LLVMIr]
mainContent var =
[ UnsafeRaw $
"call i32 (ptr, ...) @printf(ptr noundef @.str, i64 noundef " <> show var <> ")\n"
, -- , SetVariable (GA.Ident "p") (Icmp LLEq I64 (VInteger 2) (VInteger 2))
-- , BrCond (VIdent (GA.Ident "p")) (GA.Ident "b_1") (GA.Ident "b_2")
-- , Label (GA.Ident "b_1")
-- , UnsafeRaw
-- "call i32 (ptr, ...) @printf(ptr noundef @.str, i64 noundef 1)\n"
-- , Br (GA.Ident "end")
-- , Label (GA.Ident "b_2")
-- , UnsafeRaw
-- "call i32 (ptr, ...) @printf(ptr noundef @.str, i64 noundef 2)\n"
-- , Br (GA.Ident "end")
-- , Label (GA.Ident "end")
Ret I64 (VInteger 0)
]
defaultStart :: [LLVMIr]
defaultStart = [ 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 "@.str = private unnamed_addr constant [3 x i8] c\"%i\n\", align 1\n"
, UnsafeRaw "declare i32 @printf(ptr noalias nocapture, ...)\n"
]
compileExp :: Exp -> CompilerState ()
compileExp (ELit lit) = emitLit lit
compileExp (EAdd t e1 e2) = emitAdd t (fst e1) (fst 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 (EId (name, _)) = emitIdent name
-- compileExp (EApp t e1 e2) = emitApp t e1 e2 compileExp (EApp t e1 e2) = emitApp t (fst e1) (fst e2)
--compileExp (EAbs t ti e) = emitAbs t ti e --compileExp (EAbs t ti e) = emitAbs t ti e
-- compileExp (ELet binds e) = emitLet binds e compileExp (ELet _ binds e) = undefined emitLet binds (fst e)
-- compileExp (ECase t e cs) = emitECased t e cs compileExp (ECase t e cs) = emitECased t (fst 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 ---
emitECased :: Type -> Exp -> [(Type, Injection)] -> CompilerState ()
emitECased t e cases = do
let cs = snd <$> cases
let ty = type2LlvmType t
vs <- exprToValue e
lbl <- getNewLabel
let label = GA.Ident $ "escape_" <> show lbl
stackPtr <- getNewVar
emit $ SetVariable (GA.Ident $ show stackPtr) (Alloca ty)
mapM_ (emitCases ty label stackPtr vs) cs
emit $ Label label
res <- getNewVar
emit $ SetVariable (GA.Ident $ show res) (Load ty Ptr (GA.Ident $ show stackPtr))
where
emitCases :: LLVMType -> GA.Ident -> Integer -> LLVMValue -> Injection -> CompilerState ()
emitCases ty label stackPtr vs (Injection (MIR.CLit i) exp) = do
let i' = case i of
LInt i -> VInteger i
LChar i -> VChar i
ns <- getNewVar
lbl_failPos <- (\x -> GA.Ident $ "failed_" <> show x) <$> getNewLabel
lbl_succPos <- (\x -> GA.Ident $ "success_" <> show x) <$> getNewLabel
emit $ SetVariable (GA.Ident $ show ns) (Icmp LLEq ty vs i')
emit $ BrCond (VIdent (GA.Ident $ show ns) ty) lbl_succPos lbl_failPos
emit $ Label lbl_succPos
val <- exprToValue (fst exp)
emit $ Store ty val Ptr (GA.Ident . show $ stackPtr)
emit $ Br label
emit $ Label lbl_failPos
emitCases ty label stackPtr _ (Injection MIR.CatchAll exp) = do
val <- exprToValue (fst exp)
emit $ Store ty val Ptr (GA.Ident . show $ stackPtr)
emit $ Br label
emitAbs :: Type -> Id -> Exp -> CompilerState ()
emitAbs _t tid e = do
emit . Comment $
"Lambda escaped previous stages: \\" <> show tid <> " . " <> show e
emitLet :: Bind -> Exp -> CompilerState ()
emitLet xs e = do
emit $
Comment $
concat
[ "ELet ("
, show xs
, " = "
, show e
, ") is not implemented!"
]
emitApp :: Type -> Exp -> Exp -> CompilerState ()
emitApp t e1 e2 = appEmitter t e1 e2 []
where
appEmitter :: Type -> Exp -> Exp -> [Exp] -> CompilerState ()
appEmitter t e1 e2 stack = do
let newStack = e2 : stack
case e1 of
EApp _ (e1', _) (e2', _) -> appEmitter t e1' e2' newStack
EId id@(GA.Ident name,_ ) -> do
args <- traverse exprToValue newStack
vs <- getNewVar
funcs <- gets functions
let visibility = maybe Local (const Global) $ Map.lookup id funcs
args' = map (first valueGetType . dupe) args
call = Call FastCC (type2LlvmType t) visibility (GA.Ident name) args'
emit $ SetVariable (GA.Ident $ show vs) call
x -> do
emit . Comment $ "The unspeakable happened: "
emit . Comment $ show x
emitIdent :: GA.Ident -> CompilerState ()
emitIdent id = do
-- !!this should never happen!!
emit $ Comment "This should not have happened!"
emit $ Variable id
emit $ UnsafeRaw "\n"
emitLit :: Lit -> CompilerState ()
emitLit i = do
-- !!this should never happen!!
let (i',t) = case i of
(LInt i'') -> (VInteger i'',I64)
(LChar i'') -> (VChar i'', I8)
varCount <- getNewVar
emit $ Comment "This should not have happened!"
emit $ SetVariable (GA.Ident (show varCount)) (Add t i' (VInteger 0))
emitAdd :: Type -> Exp -> Exp -> CompilerState ()
emitAdd t e1 e2 = do
v1 <- exprToValue e1
v2 <- exprToValue e2
v <- getNewVar
emit $ SetVariable (GA.Ident $ show v) (Add (type2LlvmType t) v1 v2)
emitSub :: Type -> Exp -> Exp -> CompilerState ()
emitSub t e1 e2 = do
v1 <- exprToValue e1
v2 <- exprToValue e2
v <- getNewVar
emit $ SetVariable (GA.Ident $ show v) (Sub (type2LlvmType t) v1 v2)
-- emitMul :: Exp -> Exp -> CompilerState ()
-- emitMul e1 e2 = do
-- (v1,v2) <- binExprToValues e1 e2
-- increaseVarCount
-- v <- gets variableCount
-- emit $ SetVariable $ GA.Ident $ show v
-- emit $ Mul I64 v1 v2
-- emitMod :: Exp -> Exp -> CompilerState ()
-- emitMod e1 e2 = do
-- -- `let m a b = rem (abs $ b + a) b`
-- (v1,v2) <- binExprToValues e1 e2
-- increaseVarCount
-- vadd <- gets variableCount
-- emit $ SetVariable $ GA.Ident $ show vadd
-- emit $ Add I64 v1 v2
-- --
-- --- aux functions --- -- increaseVarCount
-- emitECased :: Type -> Exp -> [(Type, Case)] -> CompilerState () -- vabs <- gets variableCount
-- emitECased t e cases = do -- emit $ SetVariable $ GA.Ident $ show vabs
-- let cs = snd <$> cases -- emit $ Call I64 (GA.Ident "llvm.abs.i64")
-- let ty = type2LlvmType t -- [ (I64, VIdent (GA.Ident $ show vadd))
-- vs <- exprToValue e -- , (I1, VInteger 1)
-- lbl <- getNewLabel
-- let label = Ident $ "escape_" <> show lbl
-- stackPtr <- getNewVar
-- emit $ SetVariable (Ident $ show stackPtr) (Alloca ty)
-- mapM_ (emitCases ty label stackPtr vs) cs
-- emit $ Label label
-- res <- getNewVar
-- emit $ SetVariable (Ident $ show res) (Load ty Ptr (Ident $ show stackPtr))
-- where
-- emitCases :: LLVMType -> Ident -> Integer -> LLVMValue -> Case -> CompilerState ()
-- emitCases ty label stackPtr vs (Case (GA.CInt i) exp) = do
-- ns <- getNewVar
-- lbl_failPos <- (\x -> Ident $ "failed_" <> show x) <$> getNewLabel
-- lbl_succPos <- (\x -> Ident $ "success_" <> show x) <$> getNewLabel
-- emit $ SetVariable (Ident $ show ns) (Icmp LLEq ty vs (VInteger i))
-- emit $ BrCond (VIdent (Ident $ show ns) ty) lbl_succPos lbl_failPos
-- emit $ Label lbl_succPos
-- val <- exprToValue exp
-- emit $ Store ty val Ptr (Ident . show $ stackPtr)
-- emit $ Br label
-- emit $ Label lbl_failPos
-- emitCases ty label stackPtr _ (Case GA.CatchAll exp) = do
-- val <- exprToValue exp
-- emit $ Store ty val Ptr (Ident . show $ stackPtr)
-- emit $ Br label
--
--
-- emitAbs :: Type -> Id -> Exp -> CompilerState ()
-- emitAbs _t tid e = do
-- emit . Comment $
-- "Lambda escaped previous stages: \\" <> show tid <> " . " <> show e
-- emitLet :: Bind -> Exp -> CompilerState ()
-- emitLet xs e = do
-- emit $
-- Comment $
-- concat
-- [ "ELet ("
-- , show xs
-- , " = "
-- , show e
-- , ") is not implemented!"
-- ] -- ]
-- -- increaseVarCount
-- emitApp :: Type -> Exp -> Exp -> CompilerState () -- v <- gets variableCount
-- emitApp t e1 e2 = appEmitter t e1 e2 [] -- emit $ SetVariable $ GA.Ident $ show v
-- where -- emit $ Srem I64 (VIdent (GA.Ident $ show vabs)) v2
-- appEmitter :: Type -> Exp -> Exp -> [Exp] -> CompilerState ()
-- appEmitter t e1 e2 stack = do -- emitDiv :: Exp -> Exp -> CompilerState ()
-- let newStack = e2 : stack -- emitDiv e1 e2 = do
-- case e1 of -- (v1,v2) <- binExprToValues e1 e2
-- EApp _ e1' e2' -> appEmitter t e1' e2' newStack -- increaseVarCount
-- EId id@(name, _) -> do -- v <- gets variableCount
-- args <- traverse exprToValue newStack -- emit $ SetVariable $ GA.Ident $ show v
-- vs <- getNewVar -- emit $ Div I64 v1 v2
-- funcs <- gets functions
-- let visibility = maybe Local (const Global) $ Map.lookup id funcs exprToValue :: Exp -> CompilerState LLVMValue
-- args' = map (first valueGetType . dupe) args exprToValue = \case
-- call = Call FastCC (type2LlvmType t) visibility name args' ELit i -> pure $ case i of
-- emit $ SetVariable (Ident $ show vs) call (LInt i) -> VInteger i
-- x -> do (LChar i) -> VChar i
-- emit . Comment $ "The unspeakable happened: " EId id@(name, t) -> do
-- emit . Comment $ show x funcs <- gets functions
-- case Map.lookup id funcs of
-- emitIdent :: Ident -> CompilerState () Just fi -> do
-- emitIdent id = do if numArgs fi == 0
-- -- !!this should never happen!! then do
-- emit $ Comment "This should not have happened!" vc <- getNewVar
-- emit $ Variable id emit $ SetVariable (GA.Ident $ show vc)
-- emit $ UnsafeRaw "\n" (Call FastCC (type2LlvmType t) Global name [])
-- pure $ VIdent (GA.Ident $ show vc) (type2LlvmType t)
-- emitInt :: Integer -> CompilerState () else pure $ VFunction name Global (type2LlvmType t)
-- emitInt i = do Nothing -> pure $ VIdent name (type2LlvmType t)
-- -- !!this should never happen!! e -> do
-- varCount <- getNewVar compileExp e
-- emit $ Comment "This should not have happened!" v <- getVarCount
-- emit $ SetVariable (Ident (show varCount)) (Add I64 (VInteger i) (VInteger 0)) pure $ VIdent (GA.Ident $ show v) (getType e)
--
-- emitAdd :: Type -> Exp -> Exp -> CompilerState () type2LlvmType :: Type -> LLVMType
-- emitAdd t e1 e2 = do type2LlvmType (MIR.Type (GA.Ident t)) = case t of
-- v1 <- exprToValue e1 "_Int" -> I64
-- v2 <- exprToValue e2 t -> CustomType (GA.Ident t)
-- v <- getNewVar
-- emit $ SetVariable (Ident $ show v) (Add (type2LlvmType t) v1 v2)
--
-- emitSub :: Type -> Exp -> Exp -> CompilerState ()
-- emitSub t e1 e2 = do
-- v1 <- exprToValue e1
-- v2 <- exprToValue e2
-- v <- getNewVar
-- emit $ SetVariable (Ident $ show v) (Sub (type2LlvmType t) v1 v2)
--
-- -- emitMul :: Exp -> Exp -> CompilerState ()
-- -- emitMul e1 e2 = do
-- -- (v1,v2) <- binExprToValues e1 e2
-- -- increaseVarCount
-- -- v <- gets variableCount
-- -- emit $ SetVariable $ Ident $ show v
-- -- emit $ Mul I64 v1 v2
--
-- -- emitMod :: Exp -> Exp -> CompilerState ()
-- -- emitMod e1 e2 = do
-- -- -- `let m a b = rem (abs $ b + a) b`
-- -- (v1,v2) <- binExprToValues e1 e2
-- -- increaseVarCount
-- -- vadd <- gets variableCount
-- -- emit $ SetVariable $ Ident $ show vadd
-- -- emit $ Add I64 v1 v2
-- --
-- -- increaseVarCount
-- -- vabs <- gets variableCount
-- -- emit $ SetVariable $ Ident $ show vabs
-- -- emit $ Call I64 (Ident "llvm.abs.i64")
-- -- [ (I64, VIdent (Ident $ show vadd))
-- -- , (I1, VInteger 1)
-- -- ]
-- -- increaseVarCount
-- -- v <- gets variableCount
-- -- emit $ SetVariable $ Ident $ show v
-- -- emit $ Srem I64 (VIdent (Ident $ show vabs)) v2
--
-- -- emitDiv :: Exp -> Exp -> CompilerState ()
-- -- emitDiv e1 e2 = do
-- -- (v1,v2) <- binExprToValues e1 e2
-- -- increaseVarCount
-- -- v <- gets variableCount
-- -- emit $ SetVariable $ Ident $ show v
-- -- emit $ Div I64 v1 v2
--
-- exprToValue :: Exp -> CompilerState LLVMValue
-- exprToValue = \case
-- EInt i -> pure $ VInteger i
--
-- EId id@(name, t) -> do
-- funcs <- gets functions
-- case Map.lookup id funcs of
-- Just fi -> do
-- if numArgs fi == 0
-- then do
-- vc <- getNewVar
-- emit $ SetVariable (Ident $ show vc)
-- (Call FastCC (type2LlvmType t) Global name [])
-- pure $ VIdent (Ident $ show vc) (type2LlvmType t)
-- else pure $ VFunction name Global (type2LlvmType t)
-- Nothing -> pure $ VIdent name (type2LlvmType t)
--
-- e -> do
-- compileExp e
-- v <- getVarCount
-- pure $ VIdent (Ident $ show v) (getType e)
--
-- type2LlvmType :: Type -> LLVMType
-- type2LlvmType = \case
-- TInt -> I64 -- TInt -> I64
-- TFun t xs -> do -- TFun t xs -> do
-- let (t', xs') = function2LLVMType xs [type2LlvmType t] -- let (t', xs') = function2LLVMType xs [type2LlvmType t]
@ -413,31 +419,30 @@ module Codegen.Codegen 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 :: Exp -> LLVMType getType :: Exp -> LLVMType
-- getType (EInt _) = I64 getType (ELit l) = I64
-- getType (EAdd t _ _) = type2LlvmType t getType (EAdd t _ _) = type2LlvmType t
--getType (ESub t _ _) = type2LlvmType t --getType (ESub t _ _) = type2LlvmType t
-- getType (EId (_, t)) = type2LlvmType t getType (EId (_, t)) = type2LlvmType t
-- getType (EApp t _ _) = type2LlvmType t getType (EApp t _ _) = type2LlvmType t
--getType (EAbs t _ _) = type2LlvmType t --getType (EAbs t _ _) = type2LlvmType t
-- getType (ELet _ e) = getType e getType (ELet (_, t) _ e) = type2LlvmType t
-- getType (ECase t _ _) = type2LlvmType t getType (ECase t _ _) = type2LlvmType t
--
-- valueGetType :: LLVMValue -> LLVMType valueGetType :: LLVMValue -> LLVMType
-- valueGetType (VInteger _) = I64 valueGetType (VInteger _) = I64
-- 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
--

482
src/Codegen/LlvmIr.hs
View file

@ -1,241 +1,241 @@
module Codegen.LlvmIr where {-# LANGUAGE LambdaCase #-}
-- {-# LANGUAGE LambdaCase #-}
-- module Codegen.LlvmIr (
-- module Codegen.LlvmIr ( LLVMType (..),
-- LLVMType (..), LLVMIr (..),
-- LLVMIr (..), llvmIrToString,
-- llvmIrToString, LLVMValue (..),
-- LLVMValue (..), LLVMComp (..),
-- LLVMComp (..), Visibility (..),
-- Visibility (..), CallingConvention (..)
-- CallingConvention (..) ) where
-- ) where
-- import Data.List (intercalate)
-- import Data.List (intercalate) import Grammar.Abs (Ident (..))
-- import TypeChecker.TypeCheckerIr
-- data CallingConvention = TailCC | FastCC | CCC | ColdCC
-- data CallingConvention = TailCC | FastCC | CCC | ColdCC instance Show CallingConvention where
-- instance Show CallingConvention where show :: CallingConvention -> String
-- show :: CallingConvention -> String show TailCC = "tailcc"
-- show TailCC = "tailcc" show FastCC = "fastcc"
-- show FastCC = "fastcc" show CCC = "ccc"
-- show CCC = "ccc" show ColdCC = "coldcc"
-- show ColdCC = "coldcc"
-- -- | A datatype which represents some basic LLVM types
-- -- | A datatype which represents some basic LLVM types data LLVMType
-- data LLVMType = I1
-- = I1 | I8
-- | I8 | I32
-- | I32 | I64
-- | I64 | Ptr
-- | Ptr | Ref LLVMType
-- | Ref LLVMType | Function LLVMType [LLVMType]
-- | Function LLVMType [LLVMType] | Array Integer LLVMType
-- | Array Integer LLVMType | CustomType Ident
-- | CustomType Ident
-- instance Show LLVMType where
-- instance Show LLVMType where show :: LLVMType -> String
-- show :: LLVMType -> String show = \case
-- show = \case I1 -> "i1"
-- I1 -> "i1" I8 -> "i8"
-- I8 -> "i8" I32 -> "i32"
-- I32 -> "i32" I64 -> "i64"
-- I64 -> "i64" Ptr -> "ptr"
-- Ptr -> "ptr" Ref ty -> show ty <> "*"
-- Ref ty -> show ty <> "*" Function t xs -> show t <> " (" <> intercalate ", " (map show xs) <> ")*"
-- Function t xs -> show t <> " (" <> intercalate ", " (map show xs) <> ")*" Array n ty -> concat ["[", show n, " x ", show ty, "]"]
-- Array n ty -> concat ["[", show n, " x ", show ty, "]"] CustomType (Ident ty) -> "%" <> ty
-- CustomType (Ident ty) -> "%" <> ty
-- data LLVMComp
-- data LLVMComp = LLEq
-- = LLEq | LLNe
-- | LLNe | LLUgt
-- | LLUgt | LLUge
-- | LLUge | LLUlt
-- | LLUlt | LLUle
-- | LLUle | LLSgt
-- | LLSgt | LLSge
-- | LLSge | LLSlt
-- | LLSlt | LLSle
-- | LLSle instance Show LLVMComp where
-- instance Show LLVMComp where show :: LLVMComp -> String
-- show :: LLVMComp -> String show = \case
-- show = \case LLEq -> "eq"
-- LLEq -> "eq" LLNe -> "ne"
-- LLNe -> "ne" LLUgt -> "ugt"
-- LLUgt -> "ugt" LLUge -> "uge"
-- LLUge -> "uge" LLUlt -> "ult"
-- LLUlt -> "ult" LLUle -> "ule"
-- LLUle -> "ule" LLSgt -> "sgt"
-- LLSgt -> "sgt" LLSge -> "sge"
-- LLSge -> "sge" LLSlt -> "slt"
-- LLSlt -> "slt" LLSle -> "sle"
-- LLSle -> "sle"
-- data Visibility = Local | Global
-- data Visibility = Local | Global instance Show Visibility where
-- instance Show Visibility where show :: Visibility -> String
-- show :: Visibility -> String show Local = "%"
-- show Local = "%" show Global = "@"
-- show Global = "@"
-- -- | Represents a LLVM "value", as in an integer, a register variable,
-- -- | Represents a LLVM "value", as in an integer, a register variable, -- or a string contstant
-- -- or a string contstant data LLVMValue
-- data LLVMValue = VInteger Integer
-- = VInteger Integer | VChar Char
-- | VIdent Ident LLVMType | VIdent Ident LLVMType
-- | VConstant String | VConstant String
-- | VFunction Ident Visibility LLVMType | VFunction Ident Visibility LLVMType
--
-- instance Show LLVMValue where instance Show LLVMValue where
-- show :: LLVMValue -> String show :: LLVMValue -> String
-- show v = case v of show v = case v of
-- VInteger i -> show i VInteger i -> show i
-- VIdent (Ident n) _ -> "%" <> n VChar i -> show i
-- VFunction (Ident n) vis _ -> show vis <> n VIdent (Ident n) _ -> "%" <> n
-- VConstant s -> "c" <> show s VFunction (Ident n) vis _ -> show vis <> n
-- VConstant s -> "c" <> show s
-- type Params = [(Ident, LLVMType)]
-- type Args = [(LLVMType, LLVMValue)] type Params = [(Ident, LLVMType)]
-- type Args = [(LLVMType, LLVMValue)]
-- -- | A datatype which represents different instructions in LLVM
-- data LLVMIr -- | A datatype which represents different instructions in LLVM
-- = Type Ident [LLVMType] data LLVMIr
-- | Define CallingConvention LLVMType Ident Params = Type Ident [LLVMType]
-- | DefineEnd | Define CallingConvention LLVMType Ident Params
-- | Declare LLVMType Ident Params | DefineEnd
-- | SetVariable Ident LLVMIr | Declare LLVMType Ident Params
-- | Variable Ident | SetVariable Ident LLVMIr
-- | GetElementPtrInbounds LLVMType LLVMType LLVMValue LLVMType LLVMValue LLVMType LLVMValue | Variable Ident
-- | Add LLVMType LLVMValue LLVMValue | GetElementPtrInbounds LLVMType LLVMType LLVMValue LLVMType LLVMValue LLVMType LLVMValue
-- | Sub LLVMType LLVMValue LLVMValue | Add LLVMType LLVMValue LLVMValue
-- | Div LLVMType LLVMValue LLVMValue | Sub LLVMType LLVMValue LLVMValue
-- | Mul LLVMType LLVMValue LLVMValue | Div LLVMType LLVMValue LLVMValue
-- | Srem LLVMType LLVMValue LLVMValue | Mul LLVMType LLVMValue LLVMValue
-- | Icmp LLVMComp LLVMType LLVMValue LLVMValue | Srem LLVMType LLVMValue LLVMValue
-- | Br Ident | Icmp LLVMComp LLVMType LLVMValue LLVMValue
-- | BrCond LLVMValue Ident Ident | Br Ident
-- | Label Ident | BrCond LLVMValue Ident Ident
-- | Call CallingConvention LLVMType Visibility Ident Args | Label Ident
-- | Alloca LLVMType | Call CallingConvention LLVMType Visibility Ident Args
-- | Store LLVMType LLVMValue LLVMType Ident | Alloca LLVMType
-- | Load LLVMType LLVMType Ident | Store LLVMType LLVMValue LLVMType Ident
-- | Bitcast LLVMType Ident LLVMType | Load LLVMType LLVMType Ident
-- | Ret LLVMType LLVMValue | Bitcast LLVMType Ident LLVMType
-- | Comment String | Ret LLVMType LLVMValue
-- | UnsafeRaw String -- This should generally be avoided, and proper | Comment String
-- -- instructions should be used in its place | UnsafeRaw String -- This should generally be avoided, and proper
-- deriving (Show) -- instructions should be used in its place
-- deriving (Show)
-- -- | Converts a list of LLVMIr instructions to a string
-- llvmIrToString :: [LLVMIr] -> String -- | Converts a list of LLVMIr instructions to a string
-- llvmIrToString = go 0 llvmIrToString :: [LLVMIr] -> String
-- where llvmIrToString = go 0
-- go :: Int -> [LLVMIr] -> String where
-- go _ [] = mempty go :: Int -> [LLVMIr] -> String
-- go i (x : xs) = do go _ [] = mempty
-- let (i', n) = case x of go i (x : xs) = do
-- Define{} -> (i + 1, 0) let (i', n) = case x of
-- DefineEnd -> (i - 1, 0) Define{} -> (i + 1, 0)
-- _ -> (i, i) DefineEnd -> (i - 1, 0)
-- insToString n x <> go i' xs _ -> (i, i)
-- insToString n x <> go i' xs
-- {- | Converts a LLVM inststruction to a String, allowing for printing etc. {- | Converts a LLVM inststruction to a String, allowing for printing etc.
-- The integer represents the indentation The integer represents the indentation
-- -} -}
-- {- FOURMOLU_DISABLE -} {- FOURMOLU_DISABLE -}
-- insToString :: Int -> LLVMIr -> String insToString :: Int -> LLVMIr -> String
-- insToString i l = insToString i l =
-- replicate i '\t' <> case l of replicate i '\t' <> case l of
-- (GetElementPtrInbounds t1 t2 p t3 v1 t4 v2) -> do (GetElementPtrInbounds t1 t2 p t3 v1 t4 v2) -> do
-- -- getelementptr inbounds %Foo, %Foo* %x, i32 0, i32 0 -- getelementptr inbounds %Foo, %Foo* %x, i32 0, i32 0
-- concat concat
-- [ "getelementptr inbounds ", show t1, ", " , show t2 [ "getelementptr inbounds ", show t1, ", " , show t2
-- , " ", show p, ", ", show t3, " ", show v1, , " ", show p, ", ", show t3, " ", show v1,
-- ", ", show t4, " ", show v2, "\n" ] ", ", show t4, " ", show v2, "\n" ]
-- (Type (Ident n) types) -> (Type (Ident n) types) ->
-- concat concat
-- [ "%", n, " = type { " [ "%", n, " = type { "
-- , intercalate ", " (map show types) , intercalate ", " (map show types)
-- , " }\n" , " }\n"
-- ] ]
-- (Define c t (Ident i) params) -> (Define c t (Ident i) params) ->
-- concat concat
-- [ "define ", show c, " ", show t, " @", i [ "define ", show c, " ", show t, " @", i
-- , "(", intercalate ", " (map (\(Ident y, x) -> unwords [show x, "%" <> y]) params) , "(", intercalate ", " (map (\(Ident y, x) -> unwords [show x, "%" <> y]) params)
-- , ") {\n" , ") {\n"
-- ] ]
-- DefineEnd -> "}\n" DefineEnd -> "}\n"
-- (Declare _t (Ident _i) _params) -> undefined (Declare _t (Ident _i) _params) -> undefined
-- (SetVariable (Ident i) ir) -> concat ["%", i, " = ", insToString 0 ir] (SetVariable (Ident i) ir) -> concat ["%", i, " = ", insToString 0 ir]
-- (Add t v1 v2) -> (Add t v1 v2) ->
-- concat concat
-- [ "add ", show t, " ", show v1 [ "add ", show t, " ", show v1
-- , ", ", show v2, "\n" , ", ", show v2, "\n"
-- ] ]
-- (Sub t v1 v2) -> (Sub t v1 v2) ->
-- concat concat
-- [ "sub ", show t, " ", show v1, ", " [ "sub ", show t, " ", show v1, ", "
-- , show v2, "\n" , show v2, "\n"
-- ] ]
-- (Div t v1 v2) -> (Div t v1 v2) ->
-- concat concat
-- [ "sdiv ", show t, " ", show v1, ", " [ "sdiv ", show t, " ", show v1, ", "
-- , show v2, "\n" , show v2, "\n"
-- ] ]
-- (Mul t v1 v2) -> (Mul t v1 v2) ->
-- concat concat
-- [ "mul ", show t, " ", show v1 [ "mul ", show t, " ", show v1
-- , ", ", show v2, "\n" , ", ", show v2, "\n"
-- ] ]
-- (Srem t v1 v2) -> (Srem t v1 v2) ->
-- concat concat
-- [ "srem ", show t, " ", show v1, ", " [ "srem ", show t, " ", show v1, ", "
-- , show v2, "\n" , show v2, "\n"
-- ] ]
-- (Call c t vis (Ident i) arg) -> (Call c t vis (Ident i) arg) ->
-- concat concat
-- [ "call ", show c, " ", show t, " ", show vis, i, "(" [ "call ", show c, " ", show t, " ", show vis, i, "("
-- , intercalate ", " $ Prelude.map (\(x, y) -> show x <> " " <> show y) arg , intercalate ", " $ Prelude.map (\(x, y) -> show x <> " " <> show y) arg
-- , ")\n" , ")\n"
-- ] ]
-- (Alloca t) -> unwords ["alloca", show t, "\n"] (Alloca t) -> unwords ["alloca", show t, "\n"]
-- (Store t1 val t2 (Ident id2)) -> (Store t1 val t2 (Ident id2)) ->
-- concat concat
-- [ "store ", show t1, " ", show val [ "store ", show t1, " ", show val
-- , ", ", show t2 , " %", id2, "\n" , ", ", show t2 , " %", id2, "\n"
-- ] ]
-- (Load t1 t2 (Ident addr)) -> (Load t1 t2 (Ident addr)) ->
-- concat concat
-- [ "load ", show t1, ", " [ "load ", show t1, ", "
-- , show t2, " %", addr, "\n" , show t2, " %", addr, "\n"
-- ] ]
-- (Bitcast t1 (Ident i) t2) -> (Bitcast t1 (Ident i) t2) ->
-- concat concat
-- [ "bitcast ", show t1, " %" [ "bitcast ", show t1, " %"
-- , i, " to ", show t2, "\n" , i, " to ", show t2, "\n"
-- ] ]
-- (Icmp comp t v1 v2) -> (Icmp comp t v1 v2) ->
-- concat concat
-- [ "icmp ", show comp, " ", show t [ "icmp ", show comp, " ", show t
-- , " ", show v1, ", ", show v2, "\n" , " ", show v1, ", ", show v2, "\n"
-- ] ]
-- (Ret t v) -> (Ret t v) ->
-- concat concat
-- [ "ret ", show t, " " [ "ret ", show t, " "
-- , show v, "\n" , show v, "\n"
-- ] ]
-- (UnsafeRaw s) -> s (UnsafeRaw s) -> s
-- (Label (Ident s)) -> "\n" <> lblPfx <> s <> ":\n" (Label (Ident s)) -> "\n" <> lblPfx <> s <> ":\n"
-- (Br (Ident s)) -> "br label %" <> lblPfx <> s <> "\n" (Br (Ident s)) -> "br label %" <> lblPfx <> s <> "\n"
-- (BrCond val (Ident s1) (Ident s2)) -> (BrCond val (Ident s1) (Ident s2)) ->
-- concat concat
-- [ "br i1 ", show val, ", ", "label %" [ "br i1 ", show val, ", ", "label %"
-- , lblPfx, s1, ", ", "label %", lblPfx, s2, "\n" , lblPfx, s1, ", ", "label %", lblPfx, s2, "\n"
-- ] ]
-- (Comment s) -> "; " <> s <> "\n" (Comment s) -> "; " <> s <> "\n"
-- (Variable (Ident id)) -> "%" <> id (Variable (Ident id)) -> "%" <> id
-- {- FOURMOLU_ENABLE -} {- FOURMOLU_ENABLE -}
--
-- lblPfx :: String lblPfx :: String
-- lblPfx = "lbl_" lblPfx = "lbl_"
--

1
src/Monomorphizer/Monomorphizer.hs Normal file
View file

@ -0,0 +1 @@
module Monomorphizer.Monomorphizer where

36
src/Monomorphizer/MonomorphizerIr.hs Normal file
View file

@ -0,0 +1,36 @@
module Monomorphizer.MonomorphizerIr where
import Grammar.Abs (Ident)
newtype Program = Program [Bind]
deriving (Show, Ord, Eq)
data Bind = Bind Id [Id] ExpT | DataType Ident [Constructor]
deriving (Show, Ord, Eq)
data Exp
= EId Id
| ELit Lit
| ELet Id ExpT ExpT
| EApp Type ExpT ExpT
| EAdd Type ExpT ExpT
| ECase Type ExpT [Injection]
deriving (Show, Ord, Eq)
data Injection = Injection Case ExpT
deriving (Show, Ord, Eq)
data Case = CLit Lit | CatchAll
deriving (Show, Ord, Eq)
data Constructor = Constructor Ident [Type]
deriving (Show, Ord, Eq)
type Id = (Ident, Type)
type ExpT = (Exp, Type)
data Lit = LInt Integer
| LChar Char
deriving (Show, Ord, Eq)
newtype Type = Type Ident
deriving (Show, Ord, Eq)