-
Notifications
You must be signed in to change notification settings - Fork 1
/
traceschedule.sml
91 lines (82 loc) · 2.77 KB
/
traceschedule.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
(* traceschedule.sml
*
* Trace-scheduling basic blocks.
* This code is based on Andrew Appel's book "Modern Compiler
* Implementation in ML".
*
* Copyright (c) 2005 by Matthias Blume ([email protected])
*)
structure TraceSchedule : sig
val schedule : BBTree.cluster -> TraceTree.entrytrace
end = struct
structure L = Label
structure M = L.Map
structure B = BBTree
structure T = TraceTree
type label = Label.label
fun bug m = ErrorMsg.impossible ("TraceSchedule: " ^ m)
fun schedule { entryblocks, labelblocks } =
let fun adde ((vl, (l, b), eh), m) = M.insert (m, l, (SOME (vl,eh), b))
fun addl ((l, b), m) = M.insert (m, l, (NONE, b))
val table = foldl addl (foldl adde M.empty entryblocks) labelblocks
fun findjt (table, l) =
case M.find (table, l) of
NONE => NONE
| SOME (NONE, b) => SOME b
| SOME (SOME _, _) => bug "(c)jump to entry point"
fun mktrace (table, (l, b), q) =
let val table = #1 (M.remove (table, l))
fun build (B.JUMP l') =
(case findjt (table, l') of
NONE => T.JUMP (l', more (table, q))
| SOME b' =>
T.LABEL (mktrace (table, (l', b'), q)))
| build (B.TCALL (e, el)) =
T.TCALL (e, el, more (table, q))
| build (B.RETURN e) =
T.RETURN (e, more (table, q))
| build (B.CJUMP (r, e1, e2, t, f)) =
(case findjt (table, f) of
NONE =>
(case findjt (table, t) of
NONE =>
T.CJUMP (r, e1, e2, t,
(Label.new NONE,
T.JUMP (f, more (table, q))))
| SOME b' =>
T.CJUMP (TreeOps.notRel r, e1, e2, f,
mktrace (table, (t, b'), q)))
| SOME b' =>
T.CJUMP (r, e1, e2, t,
mktrace (table, (f, b'), t :: q)))
| build (B.MOVE (le, e, b')) =
T.MOVE (le, e, build b')
| build (B.CALL (lel, e, el, b')) =
T.CALL (lel, e, el, build b')
| build (B.DOEXP (e, b')) =
T.DOEXP (e, build b')
| build (B.DOCALL (e, el, b')) =
T.DOCALL (e, el, build b')
| build (B.GCTEST (e, b')) =
T.GCTEST (e, build b')
| build (B.ALLOCWRITE (e, b')) =
T.ALLOCWRITE (e, build b')
| build (B.ALLOCCOPY (frombase, len, b')) =
T.ALLOCCOPY (frombase, len, build b')
in (l, build b)
end
and more (_, []) = T.END
| more (table, l :: rest) =
case M.find (table, l) of
SOME (SOME (vl, eh), b) =>
T.ENTRY (vl, mktrace (table, (l, b), rest), eh)
| SOME (NONE, b) =>
T.JTARGET (mktrace (table, (l, b), rest))
| NONE =>
more (table, rest)
in case entryblocks of
(vl, eb, eh) :: ebs =>
(vl, mktrace (table, eb, map (#1 o #2) ebs), eh)
| _ => bug "no entry block"
end
end