443 lines
18 KiB
Haskell
443 lines
18 KiB
Haskell
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
|
|
--
|