Started updating the Code Generator to the new monomorphizer tree.
This commit is contained in:
Samuel Hammersberg
parent
350cd3b0e9
commit
bbf7a47e74
7 changed files with 753 additions and 706 deletions
|
|
@ -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 ;
|
||||||
|
|
|
||||||
|
|
@ -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
|
||||||
|
|
|
||||||
|
|
@ -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
|
||||||
|
|
@ -1,443 +1,448 @@
|
||||||
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 $ UnsafeRaw "\n"
|
||||||
-- emit $ SetVariable ptr' (Bitcast (Ref t') ptr (Ref $ CustomType id))
|
|
||||||
--
|
foldM_ (\i (GA.Ident arg_n, arg_t)-> do
|
||||||
-- --emit $ UnsafeRaw "\n"
|
let arg_t' = type2LlvmType arg_t
|
||||||
--
|
emit $ Comment (show arg_t' <>" "<> arg_n <> " " <> show i )
|
||||||
-- foldM_ (\i (Ident arg_n, arg_t)-> do
|
elemPtr <- GA.Ident . show <$> getNewVar
|
||||||
-- let arg_t' = type2LlvmType arg_t
|
emit $ SetVariable elemPtr (
|
||||||
-- emit $ Comment (show arg_t' <>" "<> arg_n <> " " <> show i )
|
GetElementPtrInbounds (CustomType id) (Ref (CustomType id))
|
||||||
-- elemPtr <- Ident . show <$> getNewVar
|
(VIdent ptr' Ptr) I32
|
||||||
-- emit $ SetVariable elemPtr (
|
(VInteger 0) I32 (VInteger i))
|
||||||
-- GetElementPtrInbounds (CustomType id) (Ref (CustomType id))
|
emit $ Store arg_t' (VIdent (GA.Ident arg_n) arg_t') Ptr elemPtr
|
||||||
-- (VIdent ptr' Ptr) I32
|
-- %2 = getelementptr inbounds %Foo_AInteger, %Foo_AInteger* %1, i32 0, i32 1
|
||||||
-- (VInteger 0) I32 (VInteger i))
|
-- store i32 42, i32* %2
|
||||||
-- emit $ Store arg_t' (VIdent (Ident arg_n) arg_t') Ptr elemPtr
|
pure $ i + 1-- + typeByteSize arg_t'
|
||||||
-- -- %2 = getelementptr inbounds %Foo_AInteger, %Foo_AInteger* %1, i32 0, i32 1
|
) 1 (argumentsCI ci)
|
||||||
-- -- store i32 42, i32* %2
|
|
||||||
-- pure $ i + 1-- + typeByteSize arg_t'
|
--emit $ UnsafeRaw "\n"
|
||||||
-- ) 1 (argumentsCI ci)
|
|
||||||
--
|
-- load and return the constructed value
|
||||||
-- --emit $ UnsafeRaw "\n"
|
load <- GA.Ident . show <$> getNewVar
|
||||||
--
|
emit $ SetVariable load (Load t' Ptr top)
|
||||||
-- -- load and return the constructed value
|
emit $ Ret t' (VIdent load t')
|
||||||
-- load <- Ident . show <$> getNewVar
|
emit DefineEnd
|
||||||
-- emit $ SetVariable load (Load t' Ptr top)
|
|
||||||
-- emit $ Ret t' (VIdent load t')
|
modify $ \s -> s { variableCount = 0 }
|
||||||
-- emit DefineEnd
|
) c
|
||||||
--
|
compileScs (Bind (name, _t) args exp : xs) = do
|
||||||
-- modify $ \s -> s { variableCount = 0 }
|
emit $ UnsafeRaw "\n"
|
||||||
-- ) c
|
emit . Comment $ show name <> ": " <> show exp
|
||||||
-- compileScs (Bind (name, _t) args exp : xs) = do
|
let args' = map (second type2LlvmType) args
|
||||||
-- emit $ UnsafeRaw "\n"
|
emit $ Define FastCC I64 {-(type2LlvmType t_return)-} name args'
|
||||||
-- emit . Comment $ show name <> ": " <> show exp
|
functionBody <- exprToValue (fst exp)
|
||||||
-- let args' = map (second type2LlvmType) args
|
if name == "main"
|
||||||
-- emit $ Define FastCC I64 {-(type2LlvmType t_return)-} name args'
|
then mapM_ emit $ mainContent functionBody
|
||||||
-- functionBody <- exprToValue exp
|
else emit $ Ret I64 functionBody
|
||||||
-- if name == "main"
|
emit DefineEnd
|
||||||
-- then mapM_ emit $ mainContent functionBody
|
modify $ \s -> s { variableCount = 0 }
|
||||||
-- else emit $ Ret I64 functionBody
|
compileScs xs
|
||||||
-- emit DefineEnd
|
compileScs (DataType id@(GA.Ident outer_id) ts : xs) = do
|
||||||
-- modify $ \s -> s { variableCount = 0 }
|
let biggest_variant = maximum ((\(Constructor _ t) -> sum $ typeByteSize . type2LlvmType <$> t) <$> ts)
|
||||||
-- compileScs xs
|
emit $ LIR.Type id [I8, Array biggest_variant I8]
|
||||||
-- compileScs (DataStructure id@(Ident outer_id) ts : xs) = do
|
mapM_ (\(Constructor (GA.Ident inner_id) fi) -> do
|
||||||
-- let biggest_variant = maximum ((\(_, t) -> sum $ typeByteSize . type2LlvmType <$> t) <$> ts)
|
emit $ LIR.Type (GA.Ident $ outer_id <> "_" <> inner_id) (I8 : map type2LlvmType fi)
|
||||||
-- emit $ Type id [I8, Array biggest_variant I8]
|
) ts
|
||||||
-- mapM_ (\(Ident inner_id, fi) -> do
|
compileScs xs
|
||||||
-- emit $ Type (Ident $ outer_id <> "_" <> inner_id) (I8 : map type2LlvmType fi)
|
|
||||||
-- ) ts
|
-- where
|
||||||
-- compileScs xs
|
-- _t_return = snd $ partitionType (length args) t
|
||||||
--
|
|
||||||
-- -- where
|
mainContent :: LLVMValue -> [LLVMIr]
|
||||||
-- -- _t_return = snd $ partitionType (length args) t
|
mainContent var =
|
||||||
--
|
[ UnsafeRaw $
|
||||||
-- mainContent :: LLVMValue -> [LLVMIr]
|
"call i32 (ptr, ...) @printf(ptr noundef @.str, i64 noundef " <> show var <> ")\n"
|
||||||
-- mainContent var =
|
, -- , SetVariable (GA.Ident "p") (Icmp LLEq I64 (VInteger 2) (VInteger 2))
|
||||||
-- [ UnsafeRaw $
|
-- , BrCond (VIdent (GA.Ident "p")) (GA.Ident "b_1") (GA.Ident "b_2")
|
||||||
-- "call i32 (ptr, ...) @printf(ptr noundef @.str, i64 noundef " <> show var <> ")\n"
|
-- , Label (GA.Ident "b_1")
|
||||||
-- , -- , SetVariable (Ident "p") (Icmp LLEq I64 (VInteger 2) (VInteger 2))
|
-- , UnsafeRaw
|
||||||
-- -- , BrCond (VIdent (Ident "p")) (Ident "b_1") (Ident "b_2")
|
-- "call i32 (ptr, ...) @printf(ptr noundef @.str, i64 noundef 1)\n"
|
||||||
-- -- , Label (Ident "b_1")
|
-- , Br (GA.Ident "end")
|
||||||
-- -- , UnsafeRaw
|
-- , Label (GA.Ident "b_2")
|
||||||
-- -- "call i32 (ptr, ...) @printf(ptr noundef @.str, i64 noundef 1)\n"
|
-- , UnsafeRaw
|
||||||
-- -- , Br (Ident "end")
|
-- "call i32 (ptr, ...) @printf(ptr noundef @.str, i64 noundef 2)\n"
|
||||||
-- -- , Label (Ident "b_2")
|
-- , Br (GA.Ident "end")
|
||||||
-- -- , UnsafeRaw
|
-- , Label (GA.Ident "end")
|
||||||
-- -- "call i32 (ptr, ...) @printf(ptr noundef @.str, i64 noundef 2)\n"
|
Ret I64 (VInteger 0)
|
||||||
-- -- , 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"
|
||||||
-- defaultStart :: [LLVMIr]
|
, UnsafeRaw "@.str = private unnamed_addr constant [3 x i8] c\"%i\n\", align 1\n"
|
||||||
-- defaultStart = [ UnsafeRaw "target triple = \"x86_64-pc-linux-gnu\"\n"
|
, UnsafeRaw "declare i32 @printf(ptr noalias nocapture, ...)\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 :: Exp -> CompilerState ()
|
--compileExp (ESub t e1 e2) = emitSub t e1 e2
|
||||||
-- compileExp (EInt int) = emitInt int
|
compileExp (EId (name, _)) = emitIdent name
|
||||||
-- compileExp (EAdd t e1 e2) = emitAdd t e1 e2
|
compileExp (EApp t e1 e2) = emitApp t (fst e1) (fst e2)
|
||||||
-- compileExp (ESub t e1 e2) = emitSub t e1 e2
|
--compileExp (EAbs t ti e) = emitAbs t ti e
|
||||||
-- compileExp (EId (name, _)) = emitIdent name
|
compileExp (ELet _ binds e) = undefined emitLet binds (fst e)
|
||||||
-- compileExp (EApp t e1 e2) = emitApp t e1 e2
|
compileExp (ECase t e cs) = emitECased t (fst e) (map (t,) cs)
|
||||||
-- compileExp (EAbs t ti e) = emitAbs t ti e
|
-- go (EMul e1 e2) = emitMul e1 e2
|
||||||
-- compileExp (ELet binds e) = emitLet binds e
|
-- go (EDiv e1 e2) = emitDiv e1 e2
|
||||||
-- compileExp (ECase t e cs) = emitECased t e cs
|
-- go (EMod e1 e2) = emitMod e1 e2
|
||||||
-- -- go (EMul e1 e2) = emitMul e1 e2
|
|
||||||
-- -- go (EDiv e1 e2) = emitDiv e1 e2
|
--- aux functions ---
|
||||||
-- -- go (EMod e1 e2) = emitMod e1 e2
|
emitECased :: Type -> Exp -> [(Type, Injection)] -> CompilerState ()
|
||||||
--
|
emitECased t e cases = do
|
||||||
-- --- aux functions ---
|
let cs = snd <$> cases
|
||||||
-- emitECased :: Type -> Exp -> [(Type, Case)] -> CompilerState ()
|
let ty = type2LlvmType t
|
||||||
-- emitECased t e cases = do
|
vs <- exprToValue e
|
||||||
-- let cs = snd <$> cases
|
lbl <- getNewLabel
|
||||||
-- let ty = type2LlvmType t
|
let label = GA.Ident $ "escape_" <> show lbl
|
||||||
-- vs <- exprToValue e
|
stackPtr <- getNewVar
|
||||||
-- lbl <- getNewLabel
|
emit $ SetVariable (GA.Ident $ show stackPtr) (Alloca ty)
|
||||||
-- let label = Ident $ "escape_" <> show lbl
|
mapM_ (emitCases ty label stackPtr vs) cs
|
||||||
-- stackPtr <- getNewVar
|
emit $ Label label
|
||||||
-- emit $ SetVariable (Ident $ show stackPtr) (Alloca ty)
|
res <- getNewVar
|
||||||
-- mapM_ (emitCases ty label stackPtr vs) cs
|
emit $ SetVariable (GA.Ident $ show res) (Load ty Ptr (GA.Ident $ show stackPtr))
|
||||||
-- emit $ Label label
|
where
|
||||||
-- res <- getNewVar
|
emitCases :: LLVMType -> GA.Ident -> Integer -> LLVMValue -> Injection -> CompilerState ()
|
||||||
-- emit $ SetVariable (Ident $ show res) (Load ty Ptr (Ident $ show stackPtr))
|
emitCases ty label stackPtr vs (Injection (MIR.CLit i) exp) = do
|
||||||
-- where
|
let i' = case i of
|
||||||
-- emitCases :: LLVMType -> Ident -> Integer -> LLVMValue -> Case -> CompilerState ()
|
LInt i -> VInteger i
|
||||||
-- emitCases ty label stackPtr vs (Case (GA.CInt i) exp) = do
|
LChar i -> VChar i
|
||||||
-- ns <- getNewVar
|
ns <- getNewVar
|
||||||
-- lbl_failPos <- (\x -> Ident $ "failed_" <> show x) <$> getNewLabel
|
lbl_failPos <- (\x -> GA.Ident $ "failed_" <> show x) <$> getNewLabel
|
||||||
-- lbl_succPos <- (\x -> Ident $ "success_" <> show x) <$> getNewLabel
|
lbl_succPos <- (\x -> GA.Ident $ "success_" <> show x) <$> getNewLabel
|
||||||
-- emit $ SetVariable (Ident $ show ns) (Icmp LLEq ty vs (VInteger i))
|
emit $ SetVariable (GA.Ident $ show ns) (Icmp LLEq ty vs i')
|
||||||
-- emit $ BrCond (VIdent (Ident $ show ns) ty) lbl_succPos lbl_failPos
|
emit $ BrCond (VIdent (GA.Ident $ show ns) ty) lbl_succPos lbl_failPos
|
||||||
-- emit $ Label lbl_succPos
|
emit $ Label lbl_succPos
|
||||||
-- val <- exprToValue exp
|
val <- exprToValue (fst exp)
|
||||||
-- emit $ Store ty val Ptr (Ident . show $ stackPtr)
|
emit $ Store ty val Ptr (GA.Ident . show $ stackPtr)
|
||||||
-- emit $ Br label
|
emit $ Br label
|
||||||
-- emit $ Label lbl_failPos
|
emit $ Label lbl_failPos
|
||||||
-- emitCases ty label stackPtr _ (Case GA.CatchAll exp) = do
|
emitCases ty label stackPtr _ (Injection MIR.CatchAll exp) = do
|
||||||
-- val <- exprToValue exp
|
val <- exprToValue (fst exp)
|
||||||
-- emit $ Store ty val Ptr (Ident . show $ stackPtr)
|
emit $ Store ty val Ptr (GA.Ident . show $ stackPtr)
|
||||||
-- emit $ Br label
|
emit $ Br label
|
||||||
--
|
|
||||||
--
|
|
||||||
-- emitAbs :: Type -> Id -> Exp -> CompilerState ()
|
emitAbs :: Type -> Id -> Exp -> CompilerState ()
|
||||||
-- emitAbs _t tid e = do
|
emitAbs _t tid e = do
|
||||||
-- emit . Comment $
|
emit . Comment $
|
||||||
-- "Lambda escaped previous stages: \\" <> show tid <> " . " <> show e
|
"Lambda escaped previous stages: \\" <> show tid <> " . " <> show e
|
||||||
-- emitLet :: Bind -> Exp -> CompilerState ()
|
emitLet :: Bind -> Exp -> CompilerState ()
|
||||||
-- emitLet xs e = do
|
emitLet xs e = do
|
||||||
-- emit $
|
emit $
|
||||||
-- Comment $
|
Comment $
|
||||||
-- concat
|
concat
|
||||||
-- [ "ELet ("
|
[ "ELet ("
|
||||||
-- , show xs
|
, show xs
|
||||||
-- , " = "
|
, " = "
|
||||||
-- , show e
|
, show e
|
||||||
-- , ") is not implemented!"
|
, ") is not implemented!"
|
||||||
-- ]
|
]
|
||||||
--
|
|
||||||
-- emitApp :: Type -> Exp -> Exp -> CompilerState ()
|
emitApp :: Type -> Exp -> Exp -> CompilerState ()
|
||||||
-- emitApp t e1 e2 = appEmitter t e1 e2 []
|
emitApp t e1 e2 = appEmitter t e1 e2 []
|
||||||
-- where
|
where
|
||||||
-- appEmitter :: Type -> Exp -> Exp -> [Exp] -> CompilerState ()
|
appEmitter :: Type -> Exp -> Exp -> [Exp] -> CompilerState ()
|
||||||
-- appEmitter t e1 e2 stack = do
|
appEmitter t e1 e2 stack = do
|
||||||
-- let newStack = e2 : stack
|
let newStack = e2 : stack
|
||||||
-- case e1 of
|
case e1 of
|
||||||
-- EApp _ e1' e2' -> appEmitter t e1' e2' newStack
|
EApp _ (e1', _) (e2', _) -> appEmitter t e1' e2' newStack
|
||||||
-- EId id@(name, _) -> do
|
EId id@(GA.Ident name,_ ) -> do
|
||||||
-- args <- traverse exprToValue newStack
|
args <- traverse exprToValue newStack
|
||||||
-- vs <- getNewVar
|
vs <- getNewVar
|
||||||
-- funcs <- gets functions
|
funcs <- gets functions
|
||||||
-- let visibility = maybe Local (const Global) $ Map.lookup id funcs
|
let visibility = maybe Local (const Global) $ Map.lookup id funcs
|
||||||
-- args' = map (first valueGetType . dupe) args
|
args' = map (first valueGetType . dupe) args
|
||||||
-- call = Call FastCC (type2LlvmType t) visibility name args'
|
call = Call FastCC (type2LlvmType t) visibility (GA.Ident name) args'
|
||||||
-- emit $ SetVariable (Ident $ show vs) call
|
emit $ SetVariable (GA.Ident $ show vs) call
|
||||||
-- x -> do
|
x -> do
|
||||||
-- emit . Comment $ "The unspeakable happened: "
|
emit . Comment $ "The unspeakable happened: "
|
||||||
-- emit . Comment $ show x
|
emit . Comment $ show x
|
||||||
--
|
|
||||||
-- emitIdent :: Ident -> CompilerState ()
|
emitIdent :: GA.Ident -> CompilerState ()
|
||||||
-- emitIdent id = do
|
emitIdent id = do
|
||||||
-- -- !!this should never happen!!
|
-- !!this should never happen!!
|
||||||
-- emit $ Comment "This should not have happened!"
|
emit $ Comment "This should not have happened!"
|
||||||
-- emit $ Variable id
|
emit $ Variable id
|
||||||
-- emit $ UnsafeRaw "\n"
|
emit $ UnsafeRaw "\n"
|
||||||
--
|
|
||||||
-- emitInt :: Integer -> CompilerState ()
|
emitLit :: Lit -> CompilerState ()
|
||||||
-- emitInt i = do
|
emitLit i = do
|
||||||
-- -- !!this should never happen!!
|
-- !!this should never happen!!
|
||||||
-- varCount <- getNewVar
|
let (i',t) = case i of
|
||||||
-- emit $ Comment "This should not have happened!"
|
(LInt i'') -> (VInteger i'',I64)
|
||||||
-- emit $ SetVariable (Ident (show varCount)) (Add I64 (VInteger i) (VInteger 0))
|
(LChar i'') -> (VChar i'', I8)
|
||||||
--
|
varCount <- getNewVar
|
||||||
-- emitAdd :: Type -> Exp -> Exp -> CompilerState ()
|
emit $ Comment "This should not have happened!"
|
||||||
-- emitAdd t e1 e2 = do
|
emit $ SetVariable (GA.Ident (show varCount)) (Add t i' (VInteger 0))
|
||||||
-- v1 <- exprToValue e1
|
|
||||||
-- v2 <- exprToValue e2
|
|
||||||
-- v <- getNewVar
|
emitAdd :: Type -> Exp -> Exp -> CompilerState ()
|
||||||
-- emit $ SetVariable (Ident $ show v) (Add (type2LlvmType t) v1 v2)
|
emitAdd t e1 e2 = do
|
||||||
--
|
v1 <- exprToValue e1
|
||||||
-- emitSub :: Type -> Exp -> Exp -> CompilerState ()
|
v2 <- exprToValue e2
|
||||||
-- emitSub t e1 e2 = do
|
v <- getNewVar
|
||||||
-- v1 <- exprToValue e1
|
emit $ SetVariable (GA.Ident $ show v) (Add (type2LlvmType t) v1 v2)
|
||||||
-- v2 <- exprToValue e2
|
|
||||||
-- v <- getNewVar
|
emitSub :: Type -> Exp -> Exp -> CompilerState ()
|
||||||
-- emit $ SetVariable (Ident $ show v) (Sub (type2LlvmType t) v1 v2)
|
emitSub t e1 e2 = do
|
||||||
--
|
v1 <- exprToValue e1
|
||||||
-- -- emitMul :: Exp -> Exp -> CompilerState ()
|
v2 <- exprToValue e2
|
||||||
-- -- emitMul e1 e2 = do
|
v <- getNewVar
|
||||||
-- -- (v1,v2) <- binExprToValues e1 e2
|
emit $ SetVariable (GA.Ident $ show v) (Sub (type2LlvmType t) v1 v2)
|
||||||
-- -- increaseVarCount
|
|
||||||
-- -- v <- gets variableCount
|
-- emitMul :: Exp -> Exp -> CompilerState ()
|
||||||
-- -- emit $ SetVariable $ Ident $ show v
|
-- emitMul e1 e2 = do
|
||||||
-- -- emit $ Mul I64 v1 v2
|
-- (v1,v2) <- binExprToValues e1 e2
|
||||||
--
|
-- increaseVarCount
|
||||||
-- -- emitMod :: Exp -> Exp -> CompilerState ()
|
-- v <- gets variableCount
|
||||||
-- -- emitMod e1 e2 = do
|
-- emit $ SetVariable $ GA.Ident $ show v
|
||||||
-- -- -- `let m a b = rem (abs $ b + a) b`
|
-- emit $ Mul I64 v1 v2
|
||||||
-- -- (v1,v2) <- binExprToValues e1 e2
|
|
||||||
-- -- increaseVarCount
|
-- emitMod :: Exp -> Exp -> CompilerState ()
|
||||||
-- -- vadd <- gets variableCount
|
-- emitMod e1 e2 = do
|
||||||
-- -- emit $ SetVariable $ Ident $ show vadd
|
-- -- `let m a b = rem (abs $ b + a) b`
|
||||||
-- -- emit $ Add I64 v1 v2
|
-- (v1,v2) <- binExprToValues e1 e2
|
||||||
-- --
|
-- increaseVarCount
|
||||||
-- -- increaseVarCount
|
-- vadd <- gets variableCount
|
||||||
-- -- vabs <- gets variableCount
|
-- emit $ SetVariable $ GA.Ident $ show vadd
|
||||||
-- -- emit $ SetVariable $ Ident $ show vabs
|
-- emit $ Add I64 v1 v2
|
||||||
-- -- emit $ Call I64 (Ident "llvm.abs.i64")
|
--
|
||||||
-- -- [ (I64, VIdent (Ident $ show vadd))
|
-- increaseVarCount
|
||||||
-- -- , (I1, VInteger 1)
|
-- vabs <- gets variableCount
|
||||||
-- -- ]
|
-- emit $ SetVariable $ GA.Ident $ show vabs
|
||||||
-- -- increaseVarCount
|
-- emit $ Call I64 (GA.Ident "llvm.abs.i64")
|
||||||
-- -- v <- gets variableCount
|
-- [ (I64, VIdent (GA.Ident $ show vadd))
|
||||||
-- -- emit $ SetVariable $ Ident $ show v
|
-- , (I1, VInteger 1)
|
||||||
-- -- emit $ Srem I64 (VIdent (Ident $ show vabs)) v2
|
-- ]
|
||||||
--
|
-- increaseVarCount
|
||||||
-- -- emitDiv :: Exp -> Exp -> CompilerState ()
|
-- v <- gets variableCount
|
||||||
-- -- emitDiv e1 e2 = do
|
-- emit $ SetVariable $ GA.Ident $ show v
|
||||||
-- -- (v1,v2) <- binExprToValues e1 e2
|
-- emit $ Srem I64 (VIdent (GA.Ident $ show vabs)) v2
|
||||||
-- -- increaseVarCount
|
|
||||||
-- -- v <- gets variableCount
|
-- emitDiv :: Exp -> Exp -> CompilerState ()
|
||||||
-- -- emit $ SetVariable $ Ident $ show v
|
-- emitDiv e1 e2 = do
|
||||||
-- -- emit $ Div I64 v1 v2
|
-- (v1,v2) <- binExprToValues e1 e2
|
||||||
--
|
-- increaseVarCount
|
||||||
-- exprToValue :: Exp -> CompilerState LLVMValue
|
-- v <- gets variableCount
|
||||||
-- exprToValue = \case
|
-- emit $ SetVariable $ GA.Ident $ show v
|
||||||
-- EInt i -> pure $ VInteger i
|
-- emit $ Div I64 v1 v2
|
||||||
--
|
|
||||||
-- EId id@(name, t) -> do
|
exprToValue :: Exp -> CompilerState LLVMValue
|
||||||
-- funcs <- gets functions
|
exprToValue = \case
|
||||||
-- case Map.lookup id funcs of
|
ELit i -> pure $ case i of
|
||||||
-- Just fi -> do
|
(LInt i) -> VInteger i
|
||||||
-- if numArgs fi == 0
|
(LChar i) -> VChar i
|
||||||
-- then do
|
EId id@(name, t) -> do
|
||||||
-- vc <- getNewVar
|
funcs <- gets functions
|
||||||
-- emit $ SetVariable (Ident $ show vc)
|
case Map.lookup id funcs of
|
||||||
-- (Call FastCC (type2LlvmType t) Global name [])
|
Just fi -> do
|
||||||
-- pure $ VIdent (Ident $ show vc) (type2LlvmType t)
|
if numArgs fi == 0
|
||||||
-- else pure $ VFunction name Global (type2LlvmType t)
|
then do
|
||||||
-- Nothing -> pure $ VIdent name (type2LlvmType t)
|
vc <- getNewVar
|
||||||
--
|
emit $ SetVariable (GA.Ident $ show vc)
|
||||||
-- e -> do
|
(Call FastCC (type2LlvmType t) Global name [])
|
||||||
-- compileExp e
|
pure $ VIdent (GA.Ident $ show vc) (type2LlvmType t)
|
||||||
-- v <- getVarCount
|
else pure $ VFunction name Global (type2LlvmType t)
|
||||||
-- pure $ VIdent (Ident $ show v) (getType e)
|
Nothing -> pure $ VIdent name (type2LlvmType t)
|
||||||
--
|
e -> do
|
||||||
-- type2LlvmType :: Type -> LLVMType
|
compileExp e
|
||||||
-- type2LlvmType = \case
|
v <- getVarCount
|
||||||
-- TInt -> I64
|
pure $ VIdent (GA.Ident $ show v) (getType e)
|
||||||
-- TFun t xs -> do
|
|
||||||
-- let (t', xs') = function2LLVMType xs [type2LlvmType t]
|
type2LlvmType :: Type -> LLVMType
|
||||||
-- Function t' xs'
|
type2LlvmType (MIR.Type (GA.Ident t)) = case t of
|
||||||
-- TPol t -> CustomType t
|
"_Int" -> I64
|
||||||
-- where
|
t -> CustomType (GA.Ident t)
|
||||||
-- function2LLVMType :: Type -> [LLVMType] -> (LLVMType, [LLVMType])
|
-- TInt -> I64
|
||||||
-- function2LLVMType (TFun t xs) s = function2LLVMType xs (type2LlvmType t : s)
|
-- TFun t xs -> do
|
||||||
-- function2LLVMType x s = (type2LlvmType x, s)
|
-- let (t', xs') = function2LLVMType xs [type2LlvmType t]
|
||||||
--
|
-- Function t' xs'
|
||||||
-- getType :: Exp -> LLVMType
|
-- TPol t -> CustomType t
|
||||||
-- getType (EInt _) = I64
|
--where
|
||||||
-- getType (EAdd t _ _) = type2LlvmType t
|
-- function2LLVMType :: Type -> [LLVMType] -> (LLVMType, [LLVMType])
|
||||||
-- getType (ESub t _ _) = type2LlvmType t
|
-- function2LLVMType (TFun t xs) s = function2LLVMType xs (type2LlvmType t : s)
|
||||||
-- getType (EId (_, t)) = type2LlvmType t
|
-- function2LLVMType x s = (type2LlvmType x, s)
|
||||||
-- getType (EApp t _ _) = type2LlvmType t
|
|
||||||
-- getType (EAbs t _ _) = type2LlvmType t
|
getType :: Exp -> LLVMType
|
||||||
-- getType (ELet _ e) = getType e
|
getType (ELit l) = I64
|
||||||
-- getType (ECase t _ _) = type2LlvmType t
|
getType (EAdd t _ _) = type2LlvmType t
|
||||||
--
|
--getType (ESub t _ _) = type2LlvmType t
|
||||||
-- valueGetType :: LLVMValue -> LLVMType
|
getType (EId (_, t)) = type2LlvmType t
|
||||||
-- valueGetType (VInteger _) = I64
|
getType (EApp t _ _) = type2LlvmType t
|
||||||
-- valueGetType (VIdent _ t) = t
|
--getType (EAbs t _ _) = type2LlvmType t
|
||||||
-- valueGetType (VConstant s) = Array (fromIntegral $ length s) I8
|
getType (ELet (_, t) _ e) = type2LlvmType t
|
||||||
-- valueGetType (VFunction _ _ t) = t
|
getType (ECase t _ _) = type2LlvmType t
|
||||||
--
|
|
||||||
-- typeByteSize :: LLVMType -> Integer
|
valueGetType :: LLVMValue -> LLVMType
|
||||||
-- typeByteSize I1 = 1
|
valueGetType (VInteger _) = I64
|
||||||
-- typeByteSize I8 = 1
|
valueGetType (VIdent _ t) = t
|
||||||
-- typeByteSize I32 = 4
|
valueGetType (VConstant s) = Array (fromIntegral $ length s) I8
|
||||||
-- typeByteSize I64 = 8
|
valueGetType (VFunction _ _ t) = t
|
||||||
-- typeByteSize Ptr = 8
|
|
||||||
-- typeByteSize (Ref _) = 8
|
typeByteSize :: LLVMType -> Integer
|
||||||
-- typeByteSize (Function _ _) = 8
|
typeByteSize I1 = 1
|
||||||
-- typeByteSize (Array n t) = n * typeByteSize t
|
typeByteSize I8 = 1
|
||||||
-- typeByteSize (CustomType _) = 8
|
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
|
||||||
|
|
|
||||||
|
|
@ -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
1
src/Monomorphizer/Monomorphizer.hs
Normal file
|
|
@ -0,0 +1 @@
|
||||||
|
module Monomorphizer.Monomorphizer where
|
||||||
36
src/Monomorphizer/MonomorphizerIr.hs
Normal file
36
src/Monomorphizer/MonomorphizerIr.hs
Normal 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)
|
||||||
Loading…
Add table
Add a link
Reference in a new issue