Commit | Line | Data |
---|---|---|
7f918cf1 CE |
1 | (* Copyright (C) 1999-2006 Henry Cejtin, Matthew Fluet, Suresh |
2 | * Jagannathan, and Stephen Weeks. | |
3 | * Copyright (C) 1997-2000 NEC Research Institute. | |
4 | * | |
5 | * MLton is released under a BSD-style license. | |
6 | * See the file MLton-LICENSE for details. | |
7 | *) | |
8 | ||
9 | functor x86LoopInfo(S: X86_LOOP_INFO_STRUCTS) : X86_LOOP_INFO = | |
10 | struct | |
11 | open S | |
12 | open x86 | |
13 | ||
14 | structure Graph = DirectedGraph | |
15 | structure Node = Graph.Node | |
16 | structure LoopForest = Graph.LoopForest | |
17 | ||
18 | val tracer = x86.tracer | |
19 | ||
20 | datatype t = T of {getLoopInfo : Label.t -> | |
21 | {loopHeader: bool, | |
22 | loopLabels: Label.t list, | |
23 | loopPath: int list}} | |
24 | ||
25 | fun createLoopInfo {chunk = Chunk.T {blocks, ...}, farLoops} | |
26 | = let | |
27 | val G = Graph.new () | |
28 | ||
29 | val {get = getNodeInfo : unit Node.t -> Label.t, | |
30 | set = setNodeInfo, ...} | |
31 | = Property.getSetOnce | |
32 | (Node.plist, | |
33 | Property.initRaise ("x86LoopInfo:getNodeInfo", Node.layout)) | |
34 | ||
35 | val {get = getInfo : Label.t -> unit Node.t, | |
36 | destroy = destInfo} | |
37 | = Property.destGet | |
38 | (Label.plist, | |
39 | Property.initFun (fn l => let | |
40 | val n = Graph.newNode G | |
41 | val _ = setNodeInfo(n, l) | |
42 | in | |
43 | n | |
44 | end)) | |
45 | ||
46 | val {get = getLoopInfo : | |
47 | Label.t -> | |
48 | {loopHeader: bool, | |
49 | loopLabels: Label.t list, | |
50 | loopPath: int list}, | |
51 | set = setLoopInfo, ...} | |
52 | = Property.getSetOnce | |
53 | (Label.plist, | |
54 | Property.initRaise ("x86LoopInfo:getLoopInfo", Label.layout)) | |
55 | ||
56 | val rootLabel = Label.newString "root" | |
57 | val root = getInfo rootLabel | |
58 | ||
59 | fun addEdge edge | |
60 | = ignore (Graph.addEdge (G, edge)) | |
61 | ||
62 | val _ | |
63 | = List.foreach | |
64 | (blocks, | |
65 | fn Block.T {entry, transfer, ...} | |
66 | => let | |
67 | val label = Entry.label entry | |
68 | val node = getInfo label | |
69 | ||
70 | fun doit' target | |
71 | = let | |
72 | val node' = getInfo target | |
73 | in | |
74 | addEdge {from = node, to = node'} | |
75 | end | |
76 | fun doit'' target | |
77 | = let | |
78 | val node' = getInfo target | |
79 | in | |
80 | if farLoops | |
81 | then addEdge {from = node, to = node'} | |
82 | else addEdge {from = root, to = node'} | |
83 | end | |
84 | ||
85 | datatype z = datatype Transfer.t | |
86 | in | |
87 | if Entry.isFunc entry | |
88 | then addEdge {from = root, to = node} | |
89 | else () ; | |
90 | case transfer | |
91 | of Goto {target, ...} | |
92 | => doit' target | |
93 | | Iff {truee, falsee, ...} | |
94 | => (doit' truee; | |
95 | doit' falsee) | |
96 | | Switch {cases, default, ...} | |
97 | => (doit' default; | |
98 | Transfer.Cases.foreach(cases, doit' o #2)) | |
99 | | Tail {...} | |
100 | => () | |
101 | | NonTail {return, handler, ...} | |
102 | => (doit'' return; | |
103 | case handler | |
104 | of SOME handler => doit'' handler | |
105 | | NONE => ()) | |
106 | | Return {...} | |
107 | => () | |
108 | | Raise {...} | |
109 | => () | |
110 | | CCall {return, func, ...} | |
111 | => Option.app (return, if CFunction.mayGC func | |
112 | then doit'' | |
113 | else doit') | |
114 | end) | |
115 | val _ = destInfo () | |
116 | ||
117 | val lf = Graph.loopForestSteensgaard (G, {root = root}) | |
118 | ||
119 | fun doit (f: unit LoopForest.t, | |
120 | headers, | |
121 | path) | |
122 | = let | |
123 | val {loops, notInLoop} = LoopForest.dest f | |
124 | val notInLoop = Vector.toListMap (notInLoop, getNodeInfo) | |
125 | val path' = List.rev path | |
126 | in | |
127 | List.foreach | |
128 | (notInLoop, fn l => | |
129 | setLoopInfo | |
130 | (l, {loopHeader = Vector.contains (headers, l, Label.equals), | |
131 | loopLabels = notInLoop, | |
132 | loopPath = path'})) ; | |
133 | Vector.foreachi | |
134 | (loops, fn (i,{headers, child}) => | |
135 | doit (child, | |
136 | Vector.map (headers, getNodeInfo), | |
137 | i::path)) | |
138 | end | |
139 | val _ = doit (lf, Vector.new0 (), []) | |
140 | in | |
141 | T {getLoopInfo = getLoopInfo} | |
142 | end | |
143 | ||
144 | val (createLoopInfo, createLoopInfo_msg) | |
145 | = tracer | |
146 | "createLoopInfo" | |
147 | createLoopInfo | |
148 | ||
149 | fun getLoopDistance (T {getLoopInfo, ...}, from, to) | |
150 | = (case (#loopPath (getLoopInfo from), #loopPath (getLoopInfo to)) | |
151 | of ([], _) => NONE | |
152 | | (_, []) => NONE | |
153 | | (pfrom, pto) | |
154 | => let | |
155 | val rec check | |
156 | = fn ([], pto) => SOME (List.length pto) | |
157 | | (pfrom, []) => SOME (~(List.length pfrom)) | |
158 | | (f::pfrom,t::pto) | |
159 | => if f = t | |
160 | then check (pfrom, pto) | |
161 | else NONE | |
162 | in | |
163 | check (pfrom, pto) | |
164 | end) | |
165 | fun getLoopLabels (T {getLoopInfo, ...}, label) = #loopLabels (getLoopInfo label) | |
166 | fun isLoopHeader (T {getLoopInfo, ...}, l) = #loopHeader (getLoopInfo l) | |
167 | end |