-
Notifications
You must be signed in to change notification settings - Fork 2
/
Builder.hs
146 lines (119 loc) · 4.62 KB
/
Builder.hs
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecursiveDo #-}
module Codegen.Builder where
import Control.Monad.State
import Control.Monad.Fix (MonadFix)
import Control.Applicative ((<$>))
import Data.Maybe
import LLVM.AST hiding (function, alignment, Call)
import LLVM.AST.ParameterAttribute (ParameterAttribute)
import LLVM.IRBuilder.Module
import LLVM.IRBuilder.Monad
import LLVM.IRBuilder.Constant
import LLVM.IRBuilder.Instruction hiding (load, store)
import AST.Utils
import StringUtils
import Syntax
import Codegen.Primitives
import Codegen.ASTBridge
buildCodeBlock :: (MonadFix m, MonadIRBuilder m) => [TypedExpr] -> m Operand
emit :: (MonadFix m, MonadIRBuilder m) => TypedExpr -> m Operand
emit (view -> (_, TInt i)) = pure (int32 i)
emit (view -> (_, TFloat f)) = pure (double f)
emit (view -> (type_, TVar v)) = load (referenceVar type_ v)
emit def@(view -> (_, TDef _)) = allocateDef def
emit (view -> (_, TBlock codeBlock)) = buildCodeBlock codeBlock
emit (view -> (type_, TBinaryOp "=" dest object)) =
do
value <- emit object
correctedValue <- convert (typeOnly object) type_ value
(t, name) <- getTypeName
store (referenceVar t name) correctedValue
return value -- Kinda like C++ '='
where
getTypeName = case view dest of
(t, TDef n) -> allocateDef dest >> return (t, n)
(t, TVar n) -> return (t, n)
-- TODO: UnaryOp
emit (view -> (type_, TBinaryOp operator opr1 opr2)) =
do
operand1 <- emit opr1
operand2 <- emit opr2
correctedOp1 <- convert (typeOnly opr1) opType operand1
correctedOp2 <- convert (typeOnly opr2) opType operand2
(findOperation opType operator) correctedOp1 correctedOp2
where
opType = if operator `elem` cmpOps
then typeOnly opr1 -- left bias
else type_
emit (view -> (_, TCall funcName exprs)) =
do
args <- emitArgs exprs
call (makeFuncRef funcName) args
where
emitArgs (e:es) = do
arg <- emit e
args <- emitArgs es
return ((arg, []) : args)
emitArgs _ = return []
emit (view -> (type_, TIf cond blockTrue blockFalse)) = mdo
condition <- emit cond
resultPointer <- allocateT type_
condBr condition trueBranch falseBranch
trueBranch <- buildBranch "true" blockTrue resultPointer $ Just mainBr
falseBranch <- buildBranch "false" blockFalse resultPointer $ Just mainBr
(mainBr, result) <- emitExit resultPointer
return result
emit (view -> (type_, TWhile cond bodyBlock)) = mdo
resultPointer <- allocateT type_
br whileStart -- we need terminator instruction at the end of the previous block, it will be optimized away
whileStart <- block `named` "whileStart"
condition <- emit cond
condBr condition whileBody mainBr
whileBody <- buildBranch "whileBody" bodyBlock resultPointer $ Just whileStart -- after executing jump to beginning
(mainBr, result) <- emitExit resultPointer
return result
emit expr = error ("Impossible expression <" ++ show expr ++ ">")
buildBranch name codeBlock resultPointer mNext =
do
branch <- block `named` name
blockR <- buildCodeBlock codeBlock
store resultPointer blockR
case mNext of
Nothing -> pure ()
Just label -> br label
return branch
emitExit resultPointer = do
mainBr <- block `named` bodyLabel
result <- load resultPointer
return (mainBr, result)
allocArgs :: MonadIRBuilder m => [TypedExpr] -> m ()
allocArgs ((TypedExpr type_ (TDef name)) : exprs) = do
p <- allocateT type_ `named` toShort' name
store p (referenceLocal type_ $ argName name)
allocArgs exprs
allocArgs [] = pure ()
buildCodeBlock exprBlock = do
-- Steps of codegen
ops <- mapM emit exprBlock
return (last ops)
funcBodyBuilder :: (MonadFix m, MonadIRBuilder m) => [TypedExpr] -> [TypedExpr] -> ([Operand] -> m ())
funcBodyBuilder bodyTokens args = func
where
func argOperands = mdo
block `named` bodyLabel
allocArgs args -- Dirty hack because I'm stupid and can't be bothered to make it use argOperands (which is the right way)
result <- buildCodeBlock bodyTokens
ret result
buildFunction :: (MonadModuleBuilder m, MonadFix m) => ExprType -> TExpr -> m Operand
buildFunction (CallableType argsTypes retType) func@(TFunction name argsNames body) =
function (Name $ toShort' name) arguments (toLLVMType retType) funcBody
where typedArgs = [TypedExpr (argsTypes !! i) (TDef (argsNames !! i)) | i <- [0..(length argsNames - 1)]]
arguments = map argDef typedArgs
funcBody = funcBodyBuilder body typedArgs
parseTopLevel ((TypedExpr t f):exprs) = do
buildFunction t f >> pure ()
parseTopLevel exprs
parseTopLevel [] = pure ()
buildIR :: TAST -> Module
buildIR exprs = buildModule "program" $ parseTopLevel exprs