aboutsummaryrefslogtreecommitdiff
path: root/BuildIR.hs
blob: 665dd330d5a76a83e62b8af1c70071ab0de35120 (plain)
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
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
{-# LANGUAGE DeriveFunctor, GeneralizedNewtypeDeriving #-}

module BuildIR(buildIR) where

import Control.Monad.Except
import Control.Monad.State.Strict
import Data.Char
import Data.List
import qualified Data.Map.Strict as Map
import Data.Maybe

import AST
import Defs
import Intermediate
import Pretty
import TypeRules


type Scope = Map.Map Name (Ref, Type)

data BuildState = BuildState
    { nextId :: Id,
      scopeStack :: [Scope],
      currentBlock :: Id,
      blockMap :: Map.Map Id BB }

initBuildState :: BuildState
initBuildState = BuildState
    { nextId = 0,
      scopeStack = [],
      currentBlock = undefined,
      blockMap = Map.empty }

newtype BuildM a = BuildM {unBuildM :: StateT BuildState (Except String) a}
  deriving (Functor, Applicative, Monad, MonadState BuildState, MonadError String)

genId :: BuildM Id
genId = state $ \s -> (nextId s, s {nextId = nextId s + 1})

genTemp :: Size -> BuildM Ref
genTemp sz = liftM (Temp sz) genId

newBlock :: BuildM Id
newBlock = do
    i <- genId
    let block = BB i [] ITermNone
    modify $ \s -> s {currentBlock = i, blockMap = Map.insert i block (blockMap s)}
    return i

newBlockNoSwitch :: BuildM Id
newBlockNoSwitch = do
    i <- genId
    let block = BB i [] ITermNone
    modify $ \s -> s {blockMap = Map.insert i block (blockMap s)}
    return i

addIns :: IRIns -> BuildM ()
addIns ins =
    modify $ \s -> s {
        blockMap = Map.adjust bbAddIns (currentBlock s) (blockMap s)}
  where
    bbAddIns :: BB -> BB
    bbAddIns (BB bid inss term) = BB bid (inss ++ [ins]) term

setTerm :: IRTerm -> BuildM ()
setTerm term =
    modify $ \s -> s {
        blockMap = Map.adjust bbSetTerm (currentBlock s) (blockMap s)}
  where
    bbSetTerm :: BB -> BB
    bbSetTerm (BB bid inss oldterm) = case oldterm of
        ITermNone -> BB bid inss term
        _ -> error "setTerm: oldterm /= ITermNone"

clearBlockMap :: BuildM ()
clearBlockMap = modify $ \s -> s {currentBlock = undefined, blockMap = Map.empty}

getAllBlocks :: BuildM [BB]
getAllBlocks = liftM Map.elems (gets blockMap)

switchBlock :: Id -> BuildM ()
switchBlock bid = modify $ \s -> s {currentBlock = bid}

withScope :: BuildM a -> BuildM a
withScope act = do
    modify $ \s -> s {scopeStack = Map.empty : scopeStack s}
    res <- act
    modify $ \s -> s {scopeStack = tail (scopeStack s)}
    return res

modifyScope :: (Scope -> Scope) -> BuildM ()
modifyScope f =
    modify $ \s -> s {scopeStack = f (head (scopeStack s)) : tail (scopeStack s)}

scopeInsert :: Name -> Ref -> Type -> BuildM ()
scopeInsert n ref t = modifyScope $ Map.insert n (ref, t)

findVar :: Name -> BuildM (Maybe (Int, (Ref, Type)))
findVar n = do
    stk <- gets scopeStack
    let results = map (Map.lookup n) stk
    return $ fmap (\idx -> (idx, fromJust (results !! idx))) $
        findIndex isJust results


buildIR :: Program -> Error IRProgram
buildIR (Program vars funcs) =
    runExcept $ evalStateT (unBuildM result) initBuildState
  where
    goDFunc :: DFunc -> BuildM IRFunc
    goDFunc (DFunc rt n al bl) = do
        clearBlockMap 
        firstid <- newBlock
        lastid <- newBlockNoSwitch
        withScope $ do
            forM_ al $ \(at, an) -> scopeInsert an (Argument (sizeof at) an) at
            convertBlock bl lastid
        switchBlock lastid
        setTerm IRet
        bblist <- getAllBlocks
        return $ IRFunc rt n al bblist firstid

    result :: BuildM IRProgram
    result = do
        withScope $ do
            mapM_ (\(DVar t n _) -> scopeInsert n (Global (sizeof t) n) t) vars
            IRProgram vars <$> mapM goDFunc funcs

convertBlock :: Block -> Id -> BuildM ()
convertBlock (Block sts) nextnext = do
    withScope $ forM_ sts $ \st -> do
        endid <- newBlockNoSwitch
        convertStatement st endid
        switchBlock endid
    setTerm $ IJmp nextnext

convertStatement :: Statement -> Id -> BuildM ()
convertStatement (SDecl t n e) nextnext = do
    endid <- newBlockNoSwitch
    ref <- convertExpression e endid
    varref <- genTemp (sizeof t)
    scopeInsert n varref t
    switchBlock endid
    addIns $ IMov varref ref
    setTerm $ IJmp nextnext
convertStatement (SAs ae e) nextnext = do
    bl2 <- newBlockNoSwitch
    eref <- convertExpression e bl2
    switchBlock bl2
    convertAsExpression ae eref nextnext
convertStatement (SIf c b1 b2) nextnext = do
    cend <- newBlockNoSwitch
    blThen <- newBlockNoSwitch
    blElse <- newBlockNoSwitch

    cref <- convertExpression c cend
    switchBlock cend
    setTerm $ IJcc CNeq cref (Constant (refSize cref) 0) blThen blElse
    switchBlock blThen
    convertBlock b1 nextnext
    switchBlock blElse
    convertBlock b2 nextnext
convertStatement (SWhile c b) nextnext = do
    cond <- newBlockNoSwitch
    setTerm $ IJmp cond
    cend <- newBlockNoSwitch
    body <- newBlockNoSwitch
    bodyend <- newBlockNoSwitch

    switchBlock cond
    cref <- convertExpression c cend
    switchBlock cend
    setTerm $ IJcc CNeq cref (Constant (refSize cref) 0) body nextnext
    switchBlock body
    convertBlock b bodyend
    switchBlock bodyend
    setTerm $ IJmp cond
convertStatement (SReturn Nothing) _ = do
    setTerm IRet
convertStatement (SReturn (Just e)) _ = do
    bl <- newBlockNoSwitch
    ref <- convertExpression e bl
    switchBlock bl
    setTerm $ IRetr ref
convertStatement (SExpr e) nextnext = do
    void $ convertExpression e nextnext

convertExpression :: Expression -> Id -> BuildM Ref
convertExpression (ELit (LInt n) _) nextnext = do
    ref <- genTemp (sizeof TInt)
    addIns $ IMov ref (Constant (sizeof TInt) (fromInteger n))
    setTerm $ IJmp nextnext
    return ref
convertExpression (ELit (LChar c) _) nextnext = do
    ref <- genTemp (sizeof TChar)
    addIns $ IMov ref (Constant (sizeof TChar) (fromIntegral $ ord c))
    setTerm $ IJmp nextnext
    return ref
convertExpression (ELit (LVar n) _) nextnext = do
    mres <- findVar n
    case mres of
        Just (_, (r, t)) -> do
            ref <- genTemp (sizeof t)
            addIns $ IMov ref r
            setTerm $ IJmp nextnext
            return ref
        Nothing -> throwError $ "Undefined variable '" ++ n ++ "' referenced"
convertExpression (ELit (LCall n al) mrt) nextnext = do
    refs <- withScope $ forM al $ \arg -> do
        endid <- newBlockNoSwitch
        r <- convertExpression arg endid
        switchBlock endid
        return r
    destref <- case mrt of
        Nothing -> do
            addIns $ ICall n refs
            return $ Temp 0 (-1)
        Just typ -> do
            r <- genTemp (sizeof typ)
            addIns $ ICallr r n refs
            return r
    setTerm $ IJmp nextnext
    return destref
convertExpression (EBin BOAnd e1 e2 _) nextnext = do
    destref <- genTemp (sizeof TInt)
    bl2 <- newBlockNoSwitch
    blTryR <- newBlockNoSwitch
    bl3 <- newBlockNoSwitch
    blNope <- newBlockNoSwitch
    blYes <- newBlockNoSwitch

    ref1 <- convertExpression e1 bl2

    switchBlock bl2
    setTerm $ IJcc CNeq ref1 (Constant (refSize ref1) 0) blTryR blNope

    switchBlock blTryR
    ref2 <- convertExpression e2 bl3

    switchBlock bl3
    setTerm $ IJcc CNeq ref2 (Constant (refSize ref2) 0) blYes blNope

    switchBlock blYes
    addIns $ IMov destref (Constant (refSize destref) 1)
    setTerm $ IJmp nextnext

    switchBlock blNope
    addIns $ IMov destref (Constant (refSize destref) 0)
    setTerm $ IJmp nextnext

    return destref
convertExpression (EBin bo e1 e2 _) nextnext = do
    bl2 <- newBlockNoSwitch
    ref1 <- convertExpression e1 bl2
    switchBlock bl2
    bl3 <- newBlockNoSwitch
    ref2 <- convertExpression e2 bl3
    switchBlock bl3
    ref <- genTemp (sizeof $ fromJust $ retTypeBO bo (fromJust $ typeof e1) (fromJust $ typeof e2))
    case bo of
        BOAdd -> addIns $ IAri AAdd ref ref1 ref2
        BOSub -> addIns $ IAri ASub ref ref1 ref2
        BOMul -> addIns $ IAri AMul ref ref1 ref2
        BODiv -> addIns $ IAri ADiv ref ref1 ref2
        BOMod -> addIns $ IAri AMod ref ref1 ref2
        BOEq -> addIns $ IAri AEq ref ref1 ref2
        BONeq -> addIns $ IAri ANeq ref ref1 ref2
        BOGt -> addIns $ IAri AGt ref ref1 ref2
        BOLt -> addIns $ IAri ALt ref ref1 ref2
        BOGeq -> addIns $ IAri AGeq ref ref1 ref2
        BOLeq -> addIns $ IAri ALeq ref ref1 ref2
        BOPow -> error $ "Pow operator not implemented"
        BOAnd -> undefined
        BOOr -> undefined
    setTerm $ IJmp nextnext
    return ref
convertExpression (EUn UONot e mt) nextnext =
    convertExpression (EBin BOEq e (ELit (LInt 0) (typeof e)) mt) nextnext
convertExpression (EUn UONeg e mt) nextnext =
    convertExpression (EBin BOSub (ELit (LInt 0) (typeof e)) e mt) nextnext
convertExpression (ESubscript arr sub t) nextnext = do
    let elemsz = sizeof $ fromJust t
    bl2 <- newBlockNoSwitch
    arrref <- convertExpression arr bl2
    switchBlock bl2
    bl3 <- newBlockNoSwitch
    subref <- convertExpression sub bl3
    switchBlock bl3
    offref <- genTemp (refSize subref)
    off8ref <- genTemp (refSize subref)
    elemptr <- genTemp (refSize arrref)
    addIns $ IAri AMul offref subref (Constant (refSize subref) (fromIntegral elemsz))
    addIns $ IAri AAdd off8ref offref (Constant (refSize subref) (fromIntegral $ sizeof TInt))
    addIns $ IAri AAdd elemptr arrref off8ref
    ref <- genTemp elemsz
    addIns $ ILoad ref elemptr
    setTerm $ IJmp nextnext
    return ref
convertExpression (ECast dt e) nextnext = do
    let typ = case typeof e of
                  Nothing -> error $ "Cast subject " ++ show e ++ " has Nothing type"
                  Just t -> t
    when (not $ isIntegralType typ && isIntegralType dt) $
        error $ "convertExpression: unimplemented cast from " ++ pretty typ ++ " to " ++ pretty dt
    ref <- genTemp (sizeof dt)
    bl <- newBlockNoSwitch
    eref <- convertExpression e bl
    switchBlock bl
    addIns $ IResize ref eref
    setTerm $ IJmp nextnext
    return ref
convertExpression (ENew t sze) nextnext = do
    when (not $ isBasicType t) $
        throwError $ "Array element type in 'new' expression is not a basic type (" ++ pretty t ++ ")"
    bl2 <- newBlockNoSwitch
    szref <- convertExpression sze bl2
    switchBlock bl2
    ref <- genTemp (sizeof $ TArr t Nothing)
    argref' <- genTemp (sizeof TInt)
    argref <- genTemp (sizeof TInt)
    addIns $ IAri AMul argref' szref (Constant (sizeof TInt) (fromIntegral $ sizeof t))
    addIns $ IAri AAdd argref argref' (Constant (sizeof TInt) (fromIntegral $ sizeof TInt))
    addIns $ ICallr ref "_builtin_malloc" [argref]
    addIns $ IStore ref szref
    setTerm $ IJmp nextnext
    return ref

convertAsExpression :: AsExpression -> Ref -> Id -> BuildM ()
convertAsExpression (AEVar n _) valueref nextnext = do
    mres <- findVar n
    vref <- case mres of
                Just (_, (r, _)) -> return r
                Nothing -> throwError $ "Undefined variable '" ++ n ++ "'" ++
                                        " used in assignment expression"
    addIns $ IMov vref valueref
    setTerm $ IJmp nextnext
convertAsExpression (AESubscript ae2 expr mrt) valueref nextnext = do
    let elemsz = sizeof $ fromJust mrt
    ae2ref <- goLoad ae2
    bl2 <- newBlockNoSwitch
    subref <- convertExpression expr bl2
    switchBlock bl2
    offref' <- genTemp (sizeof TInt)
    offref <- genTemp (sizeof TInt)
    elemptr <- genTemp (sizeof TInt)
    -- TODO: do bounds checking
    addIns $ IAri AMul offref' subref (Constant (sizeof TInt) (fromIntegral elemsz))
    addIns $ IAri AAdd offref offref' (Constant (sizeof TInt) (fromIntegral $ sizeof TInt))
    addIns $ IAri AAdd elemptr ae2ref offref
    addIns $ IStore elemptr valueref
    setTerm $ IJmp nextnext
  where
    goLoad :: AsExpression -> BuildM Ref
    goLoad (AEVar n _) = do
        mres <- findVar n
        (vref, t) <- case mres of
                        Just (_, (r, t)) -> return (r, t)
                        Nothing -> throwError $ "Undefined variable '" ++ n ++ "'" ++
                                                " used in assignment expression"
        ref <- genTemp (sizeof t)
        addIns $ IMov ref vref
        return ref
    goLoad (AESubscript ae expr' _) = do
        let elemsz = sizeof $ fromJust $ typeof ae
        ref <- goLoad ae
        bl2 <- newBlockNoSwitch
        eref <- convertExpression expr' bl2
        switchBlock bl2
        offref' <- genTemp (sizeof TInt)
        offref <- genTemp (sizeof TInt)
        elemptr <- genTemp (sizeof TInt)
        -- TODO: do bounds checking
        addIns $ IAri AMul offref' eref (Constant (sizeof TInt) (fromIntegral elemsz))
        addIns $ IAri AAdd offref offref' (Constant (sizeof TInt) (fromIntegral $ sizeof TInt))
        addIns $ IAri AAdd elemptr ref offref
        dstref <- genTemp elemsz
        addIns $ ILoad dstref elemptr
        return dstref