Started importing Sebastian's new typechecker.
This commit is contained in:
Samuel Hammersberg
parent
d5dd7896d8
commit
350cd3b0e9
9 changed files with 1611 additions and 1346 deletions
|
|
@ -1,441 +1,443 @@
|
|||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
module Codegen.Codegen (generateCode) where
|
||||
|
||||
import Auxiliary (snoc)
|
||||
import Codegen.LlvmIr (CallingConvention (..),
|
||||
LLVMComp (..), LLVMIr (..),
|
||||
LLVMType (..), LLVMValue (..),
|
||||
Visibility (..), llvmIrToString)
|
||||
import Control.Monad.State (StateT, execStateT, foldM_, gets,
|
||||
modify)
|
||||
import qualified Data.Bifunctor as BI
|
||||
import Data.List.Extra (trim)
|
||||
import Data.Map (Map)
|
||||
import qualified Data.Map as Map
|
||||
import Data.Tuple.Extra (dupe, first, second)
|
||||
import qualified Grammar.Abs as GA
|
||||
import Grammar.ErrM (Err)
|
||||
import System.Process.Extra (readCreateProcess, shell)
|
||||
import TypeChecker.TypeCheckerIr (Bind (..), Case (..), Exp (..), Id,
|
||||
Ident (..), Program (..), Type (..))
|
||||
-- | The record used as the code generator state
|
||||
data CodeGenerator = CodeGenerator
|
||||
{ instructions :: [LLVMIr]
|
||||
, functions :: Map Id FunctionInfo
|
||||
, constructors :: Map Id ConstructorInfo
|
||||
, variableCount :: Integer
|
||||
, labelCount :: Integer
|
||||
}
|
||||
|
||||
-- | A state type synonym
|
||||
type CompilerState a = StateT CodeGenerator Err a
|
||||
|
||||
data FunctionInfo = FunctionInfo
|
||||
{ numArgs :: Int
|
||||
, arguments :: [Id]
|
||||
}
|
||||
data ConstructorInfo = ConstructorInfo
|
||||
{ numArgsCI :: Int
|
||||
, argumentsCI :: [Id]
|
||||
, numCI :: Integer
|
||||
}
|
||||
|
||||
|
||||
-- | Adds a instruction to the CodeGenerator state
|
||||
emit :: LLVMIr -> CompilerState ()
|
||||
emit l = modify $ \t -> t { instructions = Auxiliary.snoc l $ instructions t }
|
||||
|
||||
-- | Increases the variable counter in the CodeGenerator state
|
||||
increaseVarCount :: CompilerState ()
|
||||
increaseVarCount = modify $ \t -> t { variableCount = variableCount t + 1 }
|
||||
|
||||
-- | Returns the variable count from the CodeGenerator state
|
||||
getVarCount :: CompilerState Integer
|
||||
getVarCount = gets variableCount
|
||||
|
||||
-- | Increases the variable count and returns it from the CodeGenerator state
|
||||
getNewVar :: CompilerState Integer
|
||||
getNewVar = increaseVarCount >> getVarCount
|
||||
|
||||
-- | Increses the label count and returns a label from the CodeGenerator state
|
||||
getNewLabel :: CompilerState Integer
|
||||
getNewLabel = do
|
||||
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.
|
||||
getFunctions :: [Bind] -> Map Id FunctionInfo
|
||||
getFunctions bs = Map.fromList $ go bs
|
||||
where
|
||||
go [] = []
|
||||
go (Bind id args _ : xs) =
|
||||
(id, FunctionInfo { numArgs=length args, arguments=args })
|
||||
: go xs
|
||||
go (DataStructure n cons : xs) = do
|
||||
map (\(id, xs) -> ((id, TPol n), FunctionInfo {
|
||||
numArgs=length xs, arguments=createArgs xs
|
||||
})) cons
|
||||
<> go 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.
|
||||
getConstructors :: [Bind] -> Map Id ConstructorInfo
|
||||
getConstructors bs = Map.fromList $ go bs
|
||||
where
|
||||
go [] = []
|
||||
go (DataStructure (Ident n) cons : xs) = do
|
||||
fst (foldl (\(acc,i) (Ident id, xs) -> (((Ident (n <> "_" <> id), TPol (Ident n)), ConstructorInfo {
|
||||
numArgsCI=length xs,
|
||||
argumentsCI=createArgs xs,
|
||||
numCI=i
|
||||
}) : acc, i+1)) ([],0) cons)
|
||||
<> go xs
|
||||
go (_: xs) = go xs
|
||||
|
||||
initCodeGenerator :: [Bind] -> CodeGenerator
|
||||
initCodeGenerator scs = CodeGenerator { instructions = defaultStart
|
||||
, functions = getFunctions scs
|
||||
, constructors = getConstructors scs
|
||||
, variableCount = 0
|
||||
, labelCount = 0
|
||||
}
|
||||
|
||||
run :: Err String -> IO ()
|
||||
run s = do
|
||||
let s' = case s of
|
||||
Right s -> s
|
||||
Left _ -> error "yo"
|
||||
writeFile "output/llvm.ll" s'
|
||||
putStrLn . trim =<< readCreateProcess (shell "lli") s'
|
||||
|
||||
test :: Integer -> Program
|
||||
test v = Program [
|
||||
DataStructure (Ident "Craig") [
|
||||
(Ident "Bob", [TInt])--,
|
||||
--(Ident "Alice", [TInt, TInt])
|
||||
],
|
||||
Bind (Ident "fibonacci", TInt) [(Ident "x", TInt)] (EId ("x",TInt)),
|
||||
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
|
||||
-}
|
||||
generateCode :: Program -> Err String
|
||||
generateCode (Program scs) = do
|
||||
let codegen = initCodeGenerator scs
|
||||
llvmIrToString . instructions <$> execStateT (compileScs scs) codegen
|
||||
|
||||
compileScs :: [Bind] -> CompilerState ()
|
||||
compileScs [] = do
|
||||
-- as a last step create all the constructors
|
||||
c <- gets (Map.toList . constructors)
|
||||
mapM_ (\((id, t), ci) -> do
|
||||
let t' = type2LlvmType t
|
||||
let x = BI.second type2LlvmType <$> argumentsCI ci
|
||||
emit $ Define FastCC t' id x
|
||||
top <- Ident . show <$> getNewVar
|
||||
ptr <- Ident . show <$> getNewVar
|
||||
-- allocated the primary type
|
||||
emit $ SetVariable top (Alloca t')
|
||||
|
||||
-- set the first byte to the index of the constructor
|
||||
emit $ SetVariable ptr $
|
||||
GetElementPtrInbounds t' (Ref t')
|
||||
(VIdent top I8) I32 (VInteger 0) I32 (VInteger 0)
|
||||
emit $ Store I8 (VInteger $ numCI ci ) (Ref I8) ptr
|
||||
|
||||
-- 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 . Comment $ show name <> ": " <> show exp
|
||||
let args' = map (second type2LlvmType) args
|
||||
emit $ Define FastCC I64 {-(type2LlvmType t_return)-} name args'
|
||||
functionBody <- exprToValue exp
|
||||
if name == "main"
|
||||
then mapM_ emit $ mainContent functionBody
|
||||
else emit $ Ret I64 functionBody
|
||||
emit DefineEnd
|
||||
modify $ \s -> s { variableCount = 0 }
|
||||
compileScs xs
|
||||
compileScs (DataStructure id@(Ident outer_id) ts : xs) = do
|
||||
let biggest_variant = maximum ((\(_, t) -> sum $ typeByteSize . type2LlvmType <$> t) <$> ts)
|
||||
emit $ Type id [I8, Array biggest_variant I8]
|
||||
mapM_ (\(Ident inner_id, fi) -> do
|
||||
emit $ Type (Ident $ outer_id <> "_" <> inner_id) (I8 : map type2LlvmType fi)
|
||||
) ts
|
||||
compileScs xs
|
||||
|
||||
-- where
|
||||
-- _t_return = snd $ partitionType (length args) t
|
||||
|
||||
mainContent :: LLVMValue -> [LLVMIr]
|
||||
mainContent var =
|
||||
[ UnsafeRaw $
|
||||
"call i32 (ptr, ...) @printf(ptr noundef @.str, i64 noundef " <> show var <> ")\n"
|
||||
, -- , SetVariable (Ident "p") (Icmp LLEq I64 (VInteger 2) (VInteger 2))
|
||||
-- , BrCond (VIdent (Ident "p")) (Ident "b_1") (Ident "b_2")
|
||||
-- , Label (Ident "b_1")
|
||||
-- , UnsafeRaw
|
||||
-- "call i32 (ptr, ...) @printf(ptr noundef @.str, i64 noundef 1)\n"
|
||||
-- , Br (Ident "end")
|
||||
-- , Label (Ident "b_2")
|
||||
-- , UnsafeRaw
|
||||
-- "call i32 (ptr, ...) @printf(ptr noundef @.str, i64 noundef 2)\n"
|
||||
-- , Br (Ident "end")
|
||||
-- , Label (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 (EInt int) = emitInt int
|
||||
compileExp (EAdd t e1 e2) = emitAdd t e1 e2
|
||||
compileExp (ESub t e1 e2) = emitSub t e1 e2
|
||||
compileExp (EId (name, _)) = emitIdent name
|
||||
compileExp (EApp t e1 e2) = emitApp t e1 e2
|
||||
compileExp (EAbs t ti e) = emitAbs t ti e
|
||||
compileExp (ELet binds e) = emitLet binds e
|
||||
compileExp (ECase t e cs) = emitECased t e cs
|
||||
-- go (EMul e1 e2) = emitMul e1 e2
|
||||
-- go (EDiv e1 e2) = emitDiv e1 e2
|
||||
-- go (EMod e1 e2) = emitMod e1 e2
|
||||
|
||||
--- aux functions ---
|
||||
emitECased :: Type -> Exp -> [(Type, Case)] -> CompilerState ()
|
||||
emitECased t e cases = do
|
||||
let cs = snd <$> cases
|
||||
let ty = type2LlvmType t
|
||||
vs <- exprToValue e
|
||||
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!"
|
||||
]
|
||||
|
||||
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@(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 name args'
|
||||
emit $ SetVariable (Ident $ show vs) call
|
||||
x -> do
|
||||
emit . Comment $ "The unspeakable happened: "
|
||||
emit . Comment $ show x
|
||||
|
||||
emitIdent :: Ident -> CompilerState ()
|
||||
emitIdent id = do
|
||||
-- !!this should never happen!!
|
||||
emit $ Comment "This should not have happened!"
|
||||
emit $ Variable id
|
||||
emit $ UnsafeRaw "\n"
|
||||
|
||||
emitInt :: Integer -> CompilerState ()
|
||||
emitInt i = do
|
||||
-- !!this should never happen!!
|
||||
varCount <- getNewVar
|
||||
emit $ Comment "This should not have happened!"
|
||||
emit $ SetVariable (Ident (show varCount)) (Add I64 (VInteger i) (VInteger 0))
|
||||
|
||||
emitAdd :: Type -> Exp -> Exp -> CompilerState ()
|
||||
emitAdd t e1 e2 = do
|
||||
v1 <- exprToValue e1
|
||||
v2 <- exprToValue e2
|
||||
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
|
||||
module Codegen.Codegen where
|
||||
-- {-# LANGUAGE LambdaCase #-}
|
||||
-- {-# LANGUAGE OverloadedStrings #-}
|
||||
--
|
||||
-- module Codegen.Codegen (generateCode) where
|
||||
--
|
||||
-- import Auxiliary (snoc)
|
||||
-- import Codegen.LlvmIr (CallingConvention (..),
|
||||
-- LLVMComp (..), LLVMIr (..),
|
||||
-- LLVMType (..), LLVMValue (..),
|
||||
-- Visibility (..), llvmIrToString)
|
||||
-- import Control.Monad.State (StateT, execStateT, foldM_, gets,
|
||||
-- modify)
|
||||
-- import qualified Data.Bifunctor as BI
|
||||
-- import Data.List.Extra (trim)
|
||||
-- import Data.Map (Map)
|
||||
-- import qualified Data.Map as Map
|
||||
-- import Data.Tuple.Extra (dupe, first, second)
|
||||
-- import qualified Grammar.Abs as GA
|
||||
-- import Grammar.ErrM (Err)
|
||||
-- import System.Process.Extra (readCreateProcess, shell)
|
||||
-- import TypeChecker.TypeCheckerIr (Bind (..), Case (..), Exp (..), Id,
|
||||
-- Ident (..), Program (..), Type (..))
|
||||
-- -- | The record used as the code generator state
|
||||
-- data CodeGenerator = CodeGenerator
|
||||
-- { instructions :: [LLVMIr]
|
||||
-- , functions :: Map Id FunctionInfo
|
||||
-- , constructors :: Map Id ConstructorInfo
|
||||
-- , variableCount :: Integer
|
||||
-- , labelCount :: Integer
|
||||
-- }
|
||||
--
|
||||
-- -- | A state type synonym
|
||||
-- type CompilerState a = StateT CodeGenerator Err a
|
||||
--
|
||||
-- data FunctionInfo = FunctionInfo
|
||||
-- { numArgs :: Int
|
||||
-- , arguments :: [Id]
|
||||
-- }
|
||||
-- data ConstructorInfo = ConstructorInfo
|
||||
-- { numArgsCI :: Int
|
||||
-- , argumentsCI :: [Id]
|
||||
-- , numCI :: Integer
|
||||
-- }
|
||||
--
|
||||
--
|
||||
-- -- | Adds a instruction to the CodeGenerator state
|
||||
-- emit :: LLVMIr -> CompilerState ()
|
||||
-- emit l = modify $ \t -> t { instructions = Auxiliary.snoc l $ instructions t }
|
||||
--
|
||||
-- -- | Increases the variable counter in the CodeGenerator state
|
||||
-- increaseVarCount :: CompilerState ()
|
||||
-- increaseVarCount = modify $ \t -> t { variableCount = variableCount t + 1 }
|
||||
--
|
||||
-- -- | Returns the variable count from the CodeGenerator state
|
||||
-- getVarCount :: CompilerState Integer
|
||||
-- getVarCount = gets variableCount
|
||||
--
|
||||
-- -- | Increases the variable count and returns it from the CodeGenerator state
|
||||
-- getNewVar :: CompilerState Integer
|
||||
-- getNewVar = increaseVarCount >> getVarCount
|
||||
--
|
||||
-- -- | Increses the label count and returns a label from the CodeGenerator state
|
||||
-- getNewLabel :: CompilerState Integer
|
||||
-- getNewLabel = do
|
||||
-- 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.
|
||||
-- getFunctions :: [Bind] -> Map Id FunctionInfo
|
||||
-- getFunctions bs = Map.fromList $ go bs
|
||||
-- where
|
||||
-- go [] = []
|
||||
-- go (Bind id args _ : xs) =
|
||||
-- (id, FunctionInfo { numArgs=length args, arguments=args })
|
||||
-- : go xs
|
||||
-- go (DataStructure n cons : xs) = do
|
||||
-- map (\(id, xs) -> ((id, TPol n), FunctionInfo {
|
||||
-- numArgs=length xs, arguments=createArgs xs
|
||||
-- })) cons
|
||||
-- <> go 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.
|
||||
-- getConstructors :: [Bind] -> Map Id ConstructorInfo
|
||||
-- getConstructors bs = Map.fromList $ go bs
|
||||
-- where
|
||||
-- go [] = []
|
||||
-- go (DataStructure (Ident n) cons : xs) = do
|
||||
-- fst (foldl (\(acc,i) (Ident id, xs) -> (((Ident (n <> "_" <> id), TPol (Ident n)), ConstructorInfo {
|
||||
-- numArgsCI=length xs,
|
||||
-- argumentsCI=createArgs xs,
|
||||
-- numCI=i
|
||||
-- }) : acc, i+1)) ([],0) cons)
|
||||
-- <> go xs
|
||||
-- go (_: xs) = go xs
|
||||
--
|
||||
-- initCodeGenerator :: [Bind] -> CodeGenerator
|
||||
-- initCodeGenerator scs = CodeGenerator { instructions = defaultStart
|
||||
-- , functions = getFunctions scs
|
||||
-- , constructors = getConstructors scs
|
||||
-- , variableCount = 0
|
||||
-- , labelCount = 0
|
||||
-- }
|
||||
--
|
||||
-- run :: Err String -> IO ()
|
||||
-- run s = do
|
||||
-- let s' = case s of
|
||||
-- Right s -> s
|
||||
-- Left _ -> error "yo"
|
||||
-- writeFile "output/llvm.ll" s'
|
||||
-- putStrLn . trim =<< readCreateProcess (shell "lli") s'
|
||||
--
|
||||
-- test :: Integer -> Program
|
||||
-- test v = Program [
|
||||
-- DataStructure (Ident "Craig") [
|
||||
-- (Ident "Bob", [TInt])--,
|
||||
-- --(Ident "Alice", [TInt, TInt])
|
||||
-- ],
|
||||
-- Bind (Ident "fibonacci", TInt) [(Ident "x", TInt)] (EId ("x",TInt)),
|
||||
-- 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
|
||||
-- -}
|
||||
-- generateCode :: Program -> Err String
|
||||
-- generateCode (Program scs) = do
|
||||
-- let codegen = initCodeGenerator scs
|
||||
-- llvmIrToString . instructions <$> execStateT (compileScs scs) codegen
|
||||
--
|
||||
-- compileScs :: [Bind] -> CompilerState ()
|
||||
-- compileScs [] = do
|
||||
-- -- as a last step create all the constructors
|
||||
-- c <- gets (Map.toList . constructors)
|
||||
-- mapM_ (\((id, t), ci) -> do
|
||||
-- let t' = type2LlvmType t
|
||||
-- let x = BI.second type2LlvmType <$> argumentsCI ci
|
||||
-- emit $ Define FastCC t' id x
|
||||
-- top <- Ident . show <$> getNewVar
|
||||
-- ptr <- Ident . show <$> getNewVar
|
||||
-- -- allocated the primary type
|
||||
-- emit $ SetVariable top (Alloca t')
|
||||
--
|
||||
-- -- set the first byte to the index of the constructor
|
||||
-- emit $ SetVariable ptr $
|
||||
-- GetElementPtrInbounds t' (Ref t')
|
||||
-- (VIdent top I8) I32 (VInteger 0) I32 (VInteger 0)
|
||||
-- emit $ Store I8 (VInteger $ numCI ci ) (Ref I8) ptr
|
||||
--
|
||||
-- -- 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 . Comment $ show name <> ": " <> show exp
|
||||
-- let args' = map (second type2LlvmType) args
|
||||
-- emit $ Define FastCC I64 {-(type2LlvmType t_return)-} name args'
|
||||
-- functionBody <- exprToValue exp
|
||||
-- if name == "main"
|
||||
-- then mapM_ emit $ mainContent functionBody
|
||||
-- else emit $ Ret I64 functionBody
|
||||
-- emit DefineEnd
|
||||
-- modify $ \s -> s { variableCount = 0 }
|
||||
-- compileScs xs
|
||||
-- compileScs (DataStructure id@(Ident outer_id) ts : xs) = do
|
||||
-- let biggest_variant = maximum ((\(_, t) -> sum $ typeByteSize . type2LlvmType <$> t) <$> ts)
|
||||
-- emit $ Type id [I8, Array biggest_variant I8]
|
||||
-- mapM_ (\(Ident inner_id, fi) -> do
|
||||
-- emit $ Type (Ident $ outer_id <> "_" <> inner_id) (I8 : map type2LlvmType fi)
|
||||
-- ) ts
|
||||
-- compileScs xs
|
||||
--
|
||||
-- -- where
|
||||
-- -- _t_return = snd $ partitionType (length args) t
|
||||
--
|
||||
-- mainContent :: LLVMValue -> [LLVMIr]
|
||||
-- mainContent var =
|
||||
-- [ UnsafeRaw $
|
||||
-- "call i32 (ptr, ...) @printf(ptr noundef @.str, i64 noundef " <> show var <> ")\n"
|
||||
-- , -- , SetVariable (Ident "p") (Icmp LLEq I64 (VInteger 2) (VInteger 2))
|
||||
-- -- , BrCond (VIdent (Ident "p")) (Ident "b_1") (Ident "b_2")
|
||||
-- -- , Label (Ident "b_1")
|
||||
-- -- , UnsafeRaw
|
||||
-- -- "call i32 (ptr, ...) @printf(ptr noundef @.str, i64 noundef 1)\n"
|
||||
-- -- , Br (Ident "end")
|
||||
-- -- , Label (Ident "b_2")
|
||||
-- -- , UnsafeRaw
|
||||
-- -- "call i32 (ptr, ...) @printf(ptr noundef @.str, i64 noundef 2)\n"
|
||||
-- -- , Br (Ident "end")
|
||||
-- -- , Label (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 (EInt int) = emitInt int
|
||||
-- compileExp (EAdd t e1 e2) = emitAdd t e1 e2
|
||||
-- compileExp (ESub t e1 e2) = emitSub t e1 e2
|
||||
-- compileExp (EId (name, _)) = emitIdent name
|
||||
-- compileExp (EApp t e1 e2) = emitApp t e1 e2
|
||||
-- compileExp (EAbs t ti e) = emitAbs t ti e
|
||||
-- compileExp (ELet binds e) = emitLet binds e
|
||||
-- compileExp (ECase t e cs) = emitECased t e cs
|
||||
-- -- go (EMul e1 e2) = emitMul e1 e2
|
||||
-- -- go (EDiv e1 e2) = emitDiv e1 e2
|
||||
-- -- go (EMod e1 e2) = emitMod e1 e2
|
||||
--
|
||||
-- --- aux functions ---
|
||||
-- emitECased :: Type -> Exp -> [(Type, Case)] -> CompilerState ()
|
||||
-- emitECased t e cases = do
|
||||
-- let cs = snd <$> cases
|
||||
-- let ty = type2LlvmType t
|
||||
-- vs <- exprToValue e
|
||||
-- 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!"
|
||||
-- ]
|
||||
--
|
||||
-- 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@(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 name args'
|
||||
-- emit $ SetVariable (Ident $ show vs) call
|
||||
-- x -> do
|
||||
-- emit . Comment $ "The unspeakable happened: "
|
||||
-- emit . Comment $ show x
|
||||
--
|
||||
-- emitIdent :: Ident -> CompilerState ()
|
||||
-- emitIdent id = do
|
||||
-- -- !!this should never happen!!
|
||||
-- emit $ Comment "This should not have happened!"
|
||||
-- emit $ Variable id
|
||||
-- emit $ UnsafeRaw "\n"
|
||||
--
|
||||
-- emitInt :: Integer -> CompilerState ()
|
||||
-- emitInt i = do
|
||||
-- -- !!this should never happen!!
|
||||
-- varCount <- getNewVar
|
||||
-- emit $ Comment "This should not have happened!"
|
||||
-- emit $ SetVariable (Ident (show varCount)) (Add I64 (VInteger i) (VInteger 0))
|
||||
--
|
||||
-- emitAdd :: Type -> Exp -> Exp -> CompilerState ()
|
||||
-- emitAdd t e1 e2 = do
|
||||
-- v1 <- exprToValue e1
|
||||
-- v2 <- exprToValue e2
|
||||
-- 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
|
||||
-- TFun t xs -> do
|
||||
-- let (t', xs') = function2LLVMType xs [type2LlvmType t]
|
||||
-- Function t' xs'
|
||||
-- TPol t -> CustomType t
|
||||
-- where
|
||||
-- function2LLVMType :: Type -> [LLVMType] -> (LLVMType, [LLVMType])
|
||||
-- function2LLVMType (TFun t xs) s = function2LLVMType xs (type2LlvmType t : s)
|
||||
-- function2LLVMType x s = (type2LlvmType x, s)
|
||||
--
|
||||
-- getType :: Exp -> LLVMType
|
||||
-- getType (EInt _) = I64
|
||||
-- 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 _ e) = getType e
|
||||
-- getType (ECase t _ _) = type2LlvmType t
|
||||
--
|
||||
-- valueGetType :: LLVMValue -> LLVMType
|
||||
-- valueGetType (VInteger _) = I64
|
||||
-- valueGetType (VIdent _ t) = t
|
||||
-- valueGetType (VConstant s) = Array (fromIntegral $ length s) I8
|
||||
-- valueGetType (VFunction _ _ t) = t
|
||||
--
|
||||
-- typeByteSize :: LLVMType -> Integer
|
||||
-- typeByteSize I1 = 1
|
||||
-- typeByteSize I8 = 1
|
||||
-- typeByteSize I32 = 4
|
||||
-- typeByteSize I64 = 8
|
||||
-- typeByteSize Ptr = 8
|
||||
-- typeByteSize (Ref _) = 8
|
||||
-- typeByteSize (Function _ _) = 8
|
||||
-- typeByteSize (Array n t) = n * typeByteSize t
|
||||
-- typeByteSize (CustomType _) = 8
|
||||
--
|
||||
-- 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
|
||||
TFun t xs -> do
|
||||
let (t', xs') = function2LLVMType xs [type2LlvmType t]
|
||||
Function t' xs'
|
||||
TPol t -> CustomType t
|
||||
where
|
||||
function2LLVMType :: Type -> [LLVMType] -> (LLVMType, [LLVMType])
|
||||
function2LLVMType (TFun t xs) s = function2LLVMType xs (type2LlvmType t : s)
|
||||
function2LLVMType x s = (type2LlvmType x, s)
|
||||
|
||||
getType :: Exp -> LLVMType
|
||||
getType (EInt _) = I64
|
||||
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 _ e) = getType e
|
||||
getType (ECase t _ _) = type2LlvmType t
|
||||
|
||||
valueGetType :: LLVMValue -> LLVMType
|
||||
valueGetType (VInteger _) = I64
|
||||
valueGetType (VIdent _ t) = t
|
||||
valueGetType (VConstant s) = Array (fromIntegral $ length s) I8
|
||||
valueGetType (VFunction _ _ t) = t
|
||||
|
||||
typeByteSize :: LLVMType -> Integer
|
||||
typeByteSize I1 = 1
|
||||
typeByteSize I8 = 1
|
||||
typeByteSize I32 = 4
|
||||
typeByteSize I64 = 8
|
||||
typeByteSize Ptr = 8
|
||||
typeByteSize (Ref _) = 8
|
||||
typeByteSize (Function _ _) = 8
|
||||
typeByteSize (Array n t) = n * typeByteSize t
|
||||
typeByteSize (CustomType _) = 8
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue