summaryrefslogtreecommitdiff
path: root/Intermediate.hs
blob: 6a11bf068e3dc6b9ac8547c8bf14a8867b40ec83 (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
module Intermediate where

import Data.List
import qualified Data.Map.Strict as Map
import Data.Maybe

import AST
import Util


data IRProgram =
    IRProgram [BB]
              (Map.Map Name GlobFuncDef)
              [Value]  -- data table

data GlobFuncDef =
    GlobFuncDef Int  -- BB id of implementation
                Int  -- number of arguments
                [Name]  -- closure slots

data BB = BB Int [Instruction] Terminator

type Instruction = (Ref, InsCode)

data Ref
    = RConst Int
    | RTemp Int
    | RSClo Name  -- static closure object of a function
    | RNone
  deriving (Eq, Ord)

data InsCode
    = IAssign Ref
    | IParam Int  -- first param is self-recurse link
    | IClosure Int
    | IData Int
    | ICallC Ref [Ref]
    | IAllocClo Name [Ref]
    | IDiscard Ref
  deriving Eq

data Terminator
    = IBr Ref Int Int
    | IJmp Int
    | IRet Ref
    | ITailC Ref [Ref]
    | IExit
    | IUnknown
  deriving Eq


bidOf :: BB -> Int
bidOf (BB i _ _) = i

inssOf :: BB -> [Instruction]
inssOf (BB _ i _) = i

termOf :: BB -> Terminator
termOf (BB _ _ t) = t

class AllRefs a where
    allRefs :: a -> [Ref]

instance AllRefs BB where
    allRefs (BB _ inss term) =
        sortUniq $ concatMap (allRefs . snd) inss ++ allRefs term

instance AllRefs InsCode where
    allRefs (IAssign r) = [r]
    allRefs (IParam _) = []
    allRefs (IClosure _) = []
    allRefs (IData _) = []
    allRefs (ICallC r rs) = sortUniq (r : rs)
    allRefs (IAllocClo _ rs) = sortUniq rs
    allRefs (IDiscard r) = [r]

instance AllRefs Terminator where
    allRefs (IBr r _ _) = [r]
    allRefs (IJmp _) = []
    allRefs (IRet r) = [r]
    allRefs (ITailC r rs) = sortUniq (r : rs)
    allRefs IExit = []
    allRefs IUnknown = []

outEdges :: BB -> [Int]
outEdges (BB _ _ term) = outEdgesT term

outEdgesT :: Terminator -> [Int]
outEdgesT (IBr _ a b) = [a, b]
outEdgesT (IJmp a) = [a]
outEdgesT (IRet _) = []
outEdgesT (ITailC _ _) = []
outEdgesT IExit = []
outEdgesT IUnknown = []


instance Show IRProgram where
    show (IRProgram bbs gfds datas) = intercalate "\n" $
        ["IRPROGRAM", "Data Table:"] ++ map (("- " ++) . show) datas ++
        ["Global functions:"] ++ map (\(n, gfd) -> "- " ++ n ++ ": " ++ show gfd) (Map.assocs gfds) ++
        ["Blocks:"] ++ [intercalate "\n" (map (genericShowBB bbannot icshow termshow) bbs)]
      where
        annotate s "" = s
        annotate s a = s ++ "   ; " ++ a
        refAnnot rs = intercalate ", " . catMaybes $
                        [case Map.lookup name gfds of
                             Nothing -> Nothing
                             Just (GlobFuncDef i _ _) -> Just (name ++ " = BB " ++ show i)
                        | RSClo name <- nub rs]
        safeIndex l i = if 0 <= i && i < length l then Just (l !! i) else Nothing
        icshow ins@(IData n) = annotate (show ins) (maybe "??" show (datas `safeIndex` n))
        icshow ins = annotate (show ins) (refAnnot (allRefs ins))
        termshow term = annotate (show term) (refAnnot (allRefs term))
        bidToName = Map.fromList [(bid, n) | (n, GlobFuncDef bid _ _) <- Map.assocs gfds]
        bbannot bid = maybe "" ("entry point of " ++) (Map.lookup bid bidToName)

instance Show GlobFuncDef where
    show (GlobFuncDef bbid na []) = "BB " ++ show bbid ++ " (" ++ show na ++ ")"
    show (GlobFuncDef bbid na cs) =
        "BB " ++ show bbid ++ " (" ++ show na ++ ") (closure slots: " ++ intercalate ", " cs ++ ")"

instance Show BB where
    show = genericShowBB (const "") show show

instance Show Ref where
    show (RConst n) = show n
    show (RTemp n) = "t" ++ show n
    show (RSClo name) = "SC(\"" ++ name ++ "\")"
    show RNone = "<<NONE>>"

instance Show InsCode where
    show (IAssign r) = "assign " ++ show r
    show (IParam n) = "param " ++ show n
    show (IClosure n) = "closure " ++ show n
    show (IData n) = "data " ++ show n
    show (ICallC r as) = "callc " ++ show r ++ " " ++ show as
    show (IAllocClo name vs) = "alloc-closure \"" ++ name ++ "\" " ++ show vs
    show (IDiscard r) = "discard " ++ show r

instance Show Terminator where
    show (IBr r b1 b2) = "br " ++ show r ++ " " ++ show b1 ++ " " ++ show b2
    show (IJmp b) = "jmp " ++ show b
    show (IRet r) = "ret " ++ show r
    show (ITailC r as) = "tailc " ++ show r ++ " " ++ show as
    show IExit = "exit"
    show IUnknown = "<<UNKNOWN>>"

genericShowBB :: (Int -> String) -> (InsCode -> String) -> (Terminator -> String) -> BB -> String
genericShowBB bbannot icshow termshow (BB i inss term) =
    "BB " ++ show i ++ (case bbannot i of { "" -> "" ; s -> "   ; " ++ s }) ++
    concatMap (\(r, ic) -> case r of
        RNone -> "\n  " ++ icshow ic
        _ -> "\n  " ++ show r ++ " <- " ++ icshow ic) inss ++
    "\n  " ++ termshow term