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
|
