-
Notifications
You must be signed in to change notification settings - Fork 22
/
Copy pathcanon.sml
183 lines (158 loc) · 6.17 KB
/
canon.sml
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
signature CANON =
sig
val linearize : Tree.stm -> Tree.stm list
(* From an arbitrary Tree statement, produce a list of cleaned trees
satisfying the following properties:
1. No SEQ's or ESEQ's
2. The parent of every CALL is an EXP(..) or a MOVE(TEMP t,..)
*)
val basicBlocks : Tree.stm list -> (Tree.stm list list * Tree.label)
(* From a list of cleaned trees, produce a list of
basic blocks satisfying the following properties:
1. and 2. as above;
3. Every block begins with a LABEL;
4. A LABEL appears only at the beginning of a block;
5. Any JUMP or CJUMP is the last stm in a block;
6. Every block ends with a JUMP or CJUMP;
Also produce the "label" to which control will be passed
upon exit.
*)
val traceSchedule : Tree.stm list list * Tree.label -> Tree.stm list
(* From a list of basic blocks satisfying properties 1-6,
along with an "exit" label,
produce a list of stms such that:
1. and 2. as above;
7. Every CJUMP(_,t,f) is immediately followed by LABEL f.
The blocks are reordered to satisfy property 7; also
in this reordering as many JUMP(T.NAME(lab)) statements
as possible are eliminated by falling through into T.LABEL(lab).
*)
end
structure Canon : CANON =
struct
structure T = Tree
fun linearize(stm0: T.stm) : T.stm list =
let
infix %
fun (T.EXP(T.CONST _)) % x = x
| x % (T.EXP(T.CONST _)) = x
| x % y = T.SEQ(x,y)
fun commute(T.EXP(T.CONST _), _) = true
| commute(_, T.NAME _) = true
| commute(_, T.CONST _) = true
| commute _ = false
val nop = T.EXP(T.CONST 0)
fun reorder ((e as T.CALL _ )::rest) =
let val t = Temp.newtemp()
in reorder(T.ESEQ(T.MOVE(T.TEMP t, e), T.TEMP t) :: rest)
end
| reorder (a::rest) =
let val (stms,e) = do_exp a
val (stms',el) = reorder rest
in if commute(stms',e)
then (stms % stms',e::el)
else let val t = Temp.newtemp()
in (stms % T.MOVE(T.TEMP t, e) % stms', T.TEMP t :: el)
end
end
| reorder nil = (nop,nil)
and reorder_exp(el,build) = let val (stms,el') = reorder el
in (stms, build el')
end
and reorder_stm(el,build) = let val (stms,el') = reorder (el)
in stms % build(el')
end
and do_stm(T.SEQ(a,b)) =
do_stm a % do_stm b
| do_stm(T.JUMP(e,labs)) =
reorder_stm([e],fn [e] => T.JUMP(e,labs))
| do_stm(T.CJUMP(p,a,b,t,f)) =
reorder_stm([a,b], fn[a,b]=> T.CJUMP(p,a,b,t,f))
| do_stm(T.MOVE(T.TEMP t,T.CALL(e,el))) =
reorder_stm(e::el,fn e::el => T.MOVE(T.TEMP t,T.CALL(e,el)))
| do_stm(T.MOVE(T.TEMP t,b)) =
reorder_stm([b],fn[b]=>T.MOVE(T.TEMP t,b))
| do_stm(T.MOVE(T.MEM e,b)) =
reorder_stm([e,b],fn[e,b]=>T.MOVE(T.MEM e,b))
| do_stm(T.MOVE(T.ESEQ(s,e),b)) =
do_stm(T.SEQ(s,T.MOVE(e,b)))
| do_stm(T.EXP(T.CALL(e,el))) =
reorder_stm(e::el,fn e::el => T.EXP(T.CALL(e,el)))
| do_stm(T.EXP e) =
reorder_stm([e],fn[e]=>T.EXP e)
| do_stm s = reorder_stm([],fn[]=>s)
and do_exp(T.BINOP(p,a,b)) =
reorder_exp([a,b], fn[a,b]=>T.BINOP(p,a,b))
| do_exp(T.MEM(a)) =
reorder_exp([a], fn[a]=>T.MEM(a))
| do_exp(T.ESEQ(s,e)) =
let val stms = do_stm s
val (stms',e) = do_exp e
in (stms%stms',e)
end
| do_exp(T.CALL(e,el)) =
reorder_exp(e::el, fn e::el => T.CALL(e,el))
| do_exp e = reorder_exp([],fn[]=>e)
(* linear gets rid of the top-level SEQ's, producing a list *)
fun linear(T.SEQ(a,b),l) = linear(a,linear(b,l))
| linear(s,l) = s::l
in (* body of linearize *)
linear(do_stm stm0, nil)
end
type block = T.stm list
(* Take list of statements and make basic blocks satisfying conditions
3 and 4 above, in addition to the extra condition that
every block ends with a JUMP or CJUMP *)
fun basicBlocks stms =
let val done = Temp.newlabel()
fun blocks((head as T.LABEL _) :: tail, blist) =
let fun next((s as (T.JUMP _))::rest, thisblock) =
endblock(rest, s::thisblock)
| next((s as (T.CJUMP _))::rest, thisblock) =
endblock(rest,s::thisblock)
| next(stms as (T.LABEL lab :: _), thisblock) =
next(T.JUMP(T.NAME lab,[lab]) :: stms, thisblock)
| next(s::rest, thisblock) = next(rest, s::thisblock)
| next(nil, thisblock) =
next([T.JUMP(T.NAME done, [done])], thisblock)
and endblock(stms, thisblock) =
blocks(stms, rev thisblock :: blist)
in next(tail, [head])
end
| blocks(nil, blist) = rev blist
| blocks(stms, blist) = blocks(T.LABEL(Temp.newlabel())::stms, blist)
in (blocks(stms,nil), done)
end
fun enterblock(b as (T.LABEL s :: _), table) = Symbol.enter(table,s,b)
| enterblock(_, table) = table
fun splitlast([x]) = (nil,x)
| splitlast(h::t) = let val (t',last) = splitlast t in (h::t', last) end
fun trace(table,b as (T.LABEL lab :: _),rest) =
let val table = Symbol.enter(table, lab, nil)
in case splitlast b
of (most,T.JUMP(T.NAME lab, _)) =>
(case Symbol.look(table, lab)
of SOME(b' as _::_) => most @ trace(table, b', rest)
| _ => b @ getnext(table,rest))
| (most,T.CJUMP(opr,x,y,t,f)) =>
(case (Symbol.look(table,t), Symbol.look(table,f))
of (_, SOME(b' as _::_)) => b @ trace(table, b', rest)
| (SOME(b' as _::_), _) =>
most @ [T.CJUMP(T.notRel opr,x,y,f,t)]
@ trace(table, b', rest)
| _ => let val f' = Temp.newlabel()
in most @ [T.CJUMP(opr,x,y,t,f'),
T.LABEL f', T.JUMP(T.NAME f,[f])]
@ getnext(table,rest)
end)
| (most, T.JUMP _) => b @ getnext(table,rest)
end
and getnext(table,(b as (T.LABEL lab::_))::rest) =
(case Symbol.look(table, lab)
of SOME(_::_) => trace(table,b,rest)
| _ => getnext(table,rest))
| getnext(table,nil) = nil
fun traceSchedule(blocks,done) =
getnext(foldr enterblock Symbol.empty blocks, blocks)
@ [T.LABEL done]
end