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 | (* | |
10 | * Some of this doesn't make sense if we track the liveness of the GCHold class. | |
11 | * Need to update the enque'' of returns, handlers of NonTail and Runtime | |
12 | * so they reflect what happens at these transfers; (i.e., stackTop and frontier | |
13 | * are defed on return from NonTail). | |
14 | *) | |
15 | ||
16 | functor x86LiveTransfers(S: X86_LIVE_TRANSFERS_STRUCTS) : X86_LIVE_TRANSFERS = | |
17 | struct | |
18 | open S | |
19 | open x86 | |
20 | ||
21 | local | |
22 | open Runtime | |
23 | in | |
24 | structure CFunction = CFunction | |
25 | end | |
26 | ||
27 | structure LiveSet = x86Liveness.LiveSet | |
28 | structure LiveInfo = x86Liveness.LiveInfo | |
29 | open x86JumpInfo | |
30 | open x86LoopInfo | |
31 | ||
32 | fun take (l, n) | |
33 | = let | |
34 | val rec take' | |
35 | = fn ([], _, ac) => List.rev ac | |
36 | | (_, 0 : Int.t, ac) => List.rev ac | |
37 | | (h::t, i, ac) => take' (t, i - 1, h::ac) | |
38 | in | |
39 | take' (l, n, []) | |
40 | end | |
41 | ||
42 | val track = x86Liveness.track | |
43 | ||
44 | val tracerTop = x86.tracerTop | |
45 | ||
46 | fun temp_uses_defs {uses : Operand.t list, | |
47 | defs : Operand.t list} | |
48 | = let | |
49 | val baseUses | |
50 | = List.fold | |
51 | (uses, | |
52 | MemLocSet.empty, | |
53 | fn (operand, baseUses) | |
54 | => case Operand.deMemloc operand | |
55 | of SOME memloc => if x86Liveness.track memloc | |
56 | then MemLocSet.add(baseUses, memloc) | |
57 | else baseUses | |
58 | | NONE => baseUses) | |
59 | ||
60 | val tempUses | |
61 | = let | |
62 | fun doit (operands, tempUses) | |
63 | = List.fold | |
64 | (operands, | |
65 | tempUses, | |
66 | fn (operand, tempUses) | |
67 | => case Operand.deMemloc operand | |
68 | of SOME memloc | |
69 | => List.fold(MemLoc.utilized memloc, | |
70 | tempUses, | |
71 | fn (memloc, tempUses) | |
72 | => if x86Liveness.track memloc | |
73 | then MemLocSet.add(tempUses, memloc) | |
74 | else tempUses) | |
75 | | NONE => tempUses) | |
76 | in | |
77 | doit(defs, | |
78 | doit(uses, | |
79 | baseUses)) | |
80 | end | |
81 | ||
82 | val baseDefs | |
83 | = List.fold | |
84 | (defs, | |
85 | MemLocSet.empty, | |
86 | fn (operand, baseDefs) | |
87 | => case Operand.deMemloc operand | |
88 | of SOME memloc => if x86Liveness.track memloc | |
89 | then MemLocSet.add(baseDefs, memloc) | |
90 | else baseDefs | |
91 | | NONE => baseDefs) | |
92 | val tempDefs = baseDefs | |
93 | in | |
94 | {uses = tempUses, | |
95 | defs = tempDefs} | |
96 | end | |
97 | ||
98 | datatype t = T of {get: Label.t -> | |
99 | ((MemLoc.t * Register.t * bool) list * | |
100 | (MemLoc.t * bool) list), | |
101 | set: Label.t * | |
102 | ((MemLoc.t * Register.t * bool) list * | |
103 | (MemLoc.t * bool) list) -> unit} | |
104 | ||
105 | local | |
106 | ||
107 | in | |
108 | structure I' = struct | |
109 | open Int | |
110 | fun sign x = if x = 0 | |
111 | then 0 | |
112 | else if x > 0 | |
113 | then 1 | |
114 | else ~1 | |
115 | end | |
116 | structure I = | |
117 | struct | |
118 | datatype t = NegInfinity | |
119 | | Finite of I'.t | |
120 | | PosInfinity | |
121 | val toString | |
122 | = fn NegInfinity => "-inf" | |
123 | | Finite n => I'.toString n | |
124 | | PosInfinity => "+inf" | |
125 | val zero = Finite (I'.zero) | |
126 | ||
127 | fun NegInfinity < NegInfinity = false | |
128 | | NegInfinity < _ = true | |
129 | | (Finite _) < NegInfinity = false | |
130 | | (Finite x) < (Finite y) = I'.<(x,y) | |
131 | | (Finite _) < PosInfinity = true | |
132 | | PosInfinity < _ = false | |
133 | ||
134 | fun NegInfinity + PosInfinity = zero | |
135 | | NegInfinity + _ = NegInfinity | |
136 | | (Finite _) + NegInfinity = NegInfinity | |
137 | | (Finite x) + (Finite y) | |
138 | = ((Finite (I'.+(x,y))) handle Overflow => if x > 0 | |
139 | then PosInfinity | |
140 | else NegInfinity) | |
141 | | (Finite _) + PosInfinity = PosInfinity | |
142 | | PosInfinity + NegInfinity = zero | |
143 | | PosInfinity + _ = PosInfinity | |
144 | ||
145 | fun NegInfinity * NegInfinity = PosInfinity | |
146 | | NegInfinity * (Finite x) | |
147 | = (case I'.sign x | |
148 | of ~1 => PosInfinity | |
149 | | 0 => zero | |
150 | | _ => NegInfinity) | |
151 | | NegInfinity * PosInfinity = NegInfinity | |
152 | | (Finite x) * NegInfinity | |
153 | = (case I'.sign x | |
154 | of ~1 => PosInfinity | |
155 | | 0 => zero | |
156 | | _ => NegInfinity) | |
157 | | (Finite x) * (Finite y) | |
158 | = ((Finite (I'.*(x, y))) handle Overflow => (case (I'.sign x, I'.sign y) | |
159 | of (~1, ~1) => PosInfinity | |
160 | | (1, ~1) => NegInfinity | |
161 | | (~1, 1) => NegInfinity | |
162 | | _ => PosInfinity)) | |
163 | | (Finite x) * PosInfinity | |
164 | = (case I'.sign x | |
165 | of ~1 => NegInfinity | |
166 | | 0 => zero | |
167 | | _ => PosInfinity) | |
168 | | PosInfinity * NegInfinity = NegInfinity | |
169 | | PosInfinity * (Finite x) | |
170 | = (case I'.sign x | |
171 | of ~1 => NegInfinity | |
172 | | 0 => zero | |
173 | | _ => PosInfinity) | |
174 | | PosInfinity * PosInfinity = PosInfinity | |
175 | end | |
176 | end | |
177 | ||
178 | fun computeLiveTransfers {chunk = Chunk.T {blocks,...}, | |
179 | transferRegs : Entry.t -> Register.t list, | |
180 | transferFltRegs : Entry.t -> Int.t, | |
181 | liveInfo : x86Liveness.LiveInfo.t, | |
182 | jumpInfo : x86JumpInfo.t, | |
183 | loopInfo : x86LoopInfo.t} | |
184 | = let | |
185 | val (useLF, useB, sync) | |
186 | = case !Control.Native.liveTransfer | |
187 | of 1 => (false, false, false) | |
188 | | 2 => (false, false, true) | |
189 | | 3 => (false, true, false) | |
190 | | 4 => (false, true, true) | |
191 | | 5 => (true, false, false) | |
192 | | 6 => (true, false, true) | |
193 | | 7 => (true, true, false) | |
194 | | _ => (true, true, true) | |
195 | ||
196 | val cutoff = !Control.Native.cutoff | |
197 | datatype u = Position of I.t | Length of I'.t | |
198 | ||
199 | val {get = getInfo : | |
200 | Label.t -> | |
201 | {block: Block.t, | |
202 | pred: Label.t list ref, | |
203 | succ: Label.t list ref, | |
204 | live: {memloc: MemLoc.t, | |
205 | distanceF': u option ref, | |
206 | distanceF: (I.t * Label.t option) option ref, | |
207 | distanceB': u option ref, | |
208 | distanceB: (I.t * Label.t option) option ref} vector, | |
209 | liveTransfers: ((MemLoc.t * Register.t * bool ref) list * | |
210 | (MemLoc.t * bool ref) list) option ref, | |
211 | defed: MemLocSet.t option ref}, | |
212 | set = setInfo, | |
213 | destroy = destInfo} | |
214 | = Property.destGetSetOnce | |
215 | (Label.plist, | |
216 | Property.initRaise ("x86LiveTransfers:getInfo", Label.layout)) | |
217 | ||
218 | val (labels, funcs) | |
219 | = List.fold | |
220 | (blocks, | |
221 | ([], []), | |
222 | fn (block as Block.T {entry, transfer, ...}, (labels, funcs)) | |
223 | => let | |
224 | val label = Entry.label entry | |
225 | val succ = Transfer.nearTargets transfer | |
226 | val live = LiveInfo.getLive(liveInfo, label) | |
227 | val live = List.fold | |
228 | (succ, | |
229 | live, | |
230 | fn (label, live) | |
231 | => LiveSet.+(live, LiveInfo.getLive(liveInfo, label))) | |
232 | val live = LiveSet.toList live | |
233 | val _ | |
234 | = setInfo(label, | |
235 | {block = block, | |
236 | pred = ref [], | |
237 | succ = ref succ, | |
238 | live = Vector.fromListMap | |
239 | (live, | |
240 | fn memloc | |
241 | => {memloc = memloc, | |
242 | distanceF' = ref NONE, | |
243 | distanceF = ref NONE, | |
244 | distanceB' = ref NONE, | |
245 | distanceB = ref NONE}), | |
246 | liveTransfers = ref NONE, | |
247 | defed = ref NONE}) | |
248 | val labels = label::labels | |
249 | val funcs = case entry | |
250 | of Entry.Func _ => label::funcs | |
251 | | _ => funcs | |
252 | in | |
253 | (labels, funcs) | |
254 | end) | |
255 | ||
256 | val labels = Vector.fromList labels | |
257 | val funcs = Vector.fromList funcs | |
258 | ||
259 | val _ | |
260 | = Vector.foreach | |
261 | (labels, | |
262 | fn label | |
263 | => let | |
264 | val {block, ...} = getInfo label | |
265 | fun doit target | |
266 | = let | |
267 | val {pred = pred', ...} = getInfo target | |
268 | in | |
269 | List.push (pred', label) | |
270 | end | |
271 | val Block.T {transfer, ...} = block | |
272 | datatype z = datatype Transfer.t | |
273 | in | |
274 | case transfer | |
275 | of Goto {target, ...} | |
276 | => doit target | |
277 | | Iff {truee, falsee, ...} | |
278 | => (doit truee; | |
279 | doit falsee) | |
280 | | Switch {cases, default, ...} | |
281 | => (doit default; | |
282 | Transfer.Cases.foreach(cases, doit o #2)) | |
283 | | Tail {...} | |
284 | => () | |
285 | | NonTail {return, handler, ...} | |
286 | => (doit return; | |
287 | case handler | |
288 | of SOME handler => doit handler | |
289 | | NONE => ()) | |
290 | | Return {...} | |
291 | => () | |
292 | | Raise {...} | |
293 | => () | |
294 | | CCall {return, ...} | |
295 | => Option.app (return, doit) | |
296 | end) | |
297 | ||
298 | val _ | |
299 | = Vector.foreach | |
300 | (labels, | |
301 | fn label | |
302 | => let | |
303 | val {block, live, ...} = getInfo label | |
304 | val Block.T {entry, statements, transfer, ...} = block | |
305 | ||
306 | val l | |
307 | = List.fold | |
308 | (statements, | |
309 | I'.two, | |
310 | fn (Assembly.Comment _, l) => l | |
311 | | (_, l) => I'.+(l, I'.one)) | |
312 | ||
313 | fun pos ([], n, m) | |
314 | = let | |
315 | val {uses, defs, ...} | |
316 | = Transfer.uses_defs_kills transfer | |
317 | val {uses,defs} | |
318 | = temp_uses_defs {uses = uses, | |
319 | defs = defs} | |
320 | in | |
321 | Vector.foreach | |
322 | (live, | |
323 | fn {memloc, distanceF' as ref NONE, ...} | |
324 | => if MemLocSet.contains(uses,memloc) | |
325 | then distanceF' := SOME (Position (I.Finite n)) | |
326 | else distanceF' := SOME (Length l) | |
327 | | _ => ()); | |
328 | Vector.foreach | |
329 | (live, | |
330 | fn {memloc, distanceB', ...} | |
331 | => if MemLocSet.contains(uses,memloc) | |
332 | orelse | |
333 | MemLocSet.contains(defs,memloc) | |
334 | then distanceB' := SOME (Position (I.Finite m)) | |
335 | else ()) | |
336 | end | |
337 | | pos ((Assembly.Comment _)::assembly,n,m) | |
338 | = pos (assembly,n,m) | |
339 | | pos (asm::assembly,n,m) | |
340 | = let | |
341 | val {uses,defs,...} | |
342 | = Assembly.uses_defs_kills asm | |
343 | val {uses,defs} | |
344 | = temp_uses_defs {uses = uses, | |
345 | defs = defs} | |
346 | in | |
347 | Vector.foreach | |
348 | (live, | |
349 | fn {memloc, distanceF' as ref NONE, ...} | |
350 | => if MemLocSet.contains(uses,memloc) | |
351 | then distanceF' := SOME (Position (I.Finite n)) | |
352 | else () | |
353 | | _ => ()); | |
354 | Vector.foreach | |
355 | (live, | |
356 | fn {memloc, distanceB', ...} | |
357 | => if MemLocSet.contains(uses,memloc) | |
358 | orelse | |
359 | MemLocSet.contains(defs,memloc) | |
360 | then distanceB' := SOME (Position (I.Finite m)) | |
361 | else ()); | |
362 | pos(assembly, I'.+(n, I'.one), I'.-(m, I'.one)) | |
363 | end | |
364 | in | |
365 | let | |
366 | val n = I'.zero | |
367 | val m = I'.-(l, I'.one) | |
368 | val {uses,defs,...} | |
369 | = Entry.uses_defs_kills entry | |
370 | val {uses,defs} | |
371 | = temp_uses_defs {uses = uses, | |
372 | defs = defs} | |
373 | in | |
374 | Vector.foreach | |
375 | (live, | |
376 | fn {memloc, distanceF' as ref NONE, ...} | |
377 | => if MemLocSet.contains(uses,memloc) | |
378 | then distanceF' := SOME (Position (I.Finite n)) | |
379 | else () | |
380 | | _ => ()); | |
381 | Vector.foreach | |
382 | (live, | |
383 | fn {memloc, distanceB', ...} | |
384 | => if MemLocSet.contains(uses,memloc) | |
385 | orelse | |
386 | MemLocSet.contains(defs,memloc) | |
387 | then distanceB' := SOME (Position (I.Finite m)) | |
388 | else distanceB' := SOME (Length l)); | |
389 | pos(statements, I'.+(n, I'.one), I'.-(m, I'.one)) | |
390 | end | |
391 | end) | |
392 | ||
393 | fun get_distanceF {temp: MemLoc.t, | |
394 | label: Label.t} | |
395 | = let | |
396 | val {block, succ, live, ...} = getInfo label | |
397 | val Block.T {transfer, ...} = block | |
398 | in | |
399 | case Vector.peek | |
400 | (live, | |
401 | fn {memloc, ...} => MemLoc.eq(temp, memloc)) | |
402 | of SOME {distanceF = ref (SOME (df, dfl)), ...} | |
403 | => (df, dfl) | |
404 | | SOME {distanceF', distanceF, ...} | |
405 | => (case valOf (!distanceF') | |
406 | of Position n => (distanceF := SOME (n, SOME label); | |
407 | (n, SOME label)) | |
408 | | Length n | |
409 | => let | |
410 | val loopLabels = getLoopLabels (loopInfo, label) | |
411 | val _ = distanceF := SOME (I.PosInfinity, NONE) | |
412 | fun default () | |
413 | = let | |
414 | val n = I.Finite n | |
415 | val (min, minl) | |
416 | = List.fold | |
417 | (!succ, | |
418 | (I.PosInfinity, NONE), | |
419 | fn (label, (min, minl)) | |
420 | => let | |
421 | val (n', l') | |
422 | = get_distanceF {temp = temp, | |
423 | label = label} | |
424 | val n' = I.+(n, n') | |
425 | val n'' | |
426 | = case (l', useLF) | |
427 | of (NONE, _) => n' | |
428 | | (_, false) => n' | |
429 | | (SOME l', true) | |
430 | => if List.contains | |
431 | (loopLabels, | |
432 | l', Label.equals) | |
433 | then n' | |
434 | else I.*(I.Finite 5, n') | |
435 | in | |
436 | if I.<(n'', min) | |
437 | then (n', l') | |
438 | else (min, minl) | |
439 | end) | |
440 | in | |
441 | (min, minl) | |
442 | end | |
443 | ||
444 | datatype z = datatype Transfer.t | |
445 | val (n, l) | |
446 | = case transfer | |
447 | of Tail _ => (I.PosInfinity, NONE) | |
448 | | NonTail _ => (I.PosInfinity, NONE) | |
449 | | Return _ => (I.PosInfinity, NONE) | |
450 | | Raise _ => (I.PosInfinity, NONE) | |
451 | | CCall {func, ...} | |
452 | => if CFunction.maySwitchThreads func | |
453 | orelse Size.class (MemLoc.size temp) <> Size.INT | |
454 | then (I.PosInfinity, NONE) | |
455 | else default () | |
456 | | _ => default () | |
457 | in | |
458 | distanceF := SOME (n, l) ; (n, l) | |
459 | end) | |
460 | | _ => (I.PosInfinity, NONE) | |
461 | end | |
462 | ||
463 | fun get_distanceB {temp: MemLoc.t, | |
464 | label: Label.t} | |
465 | = let | |
466 | val {block, pred, live, ...} = getInfo label | |
467 | val Block.T {entry, ...} = block | |
468 | in | |
469 | case Vector.peek | |
470 | (live, | |
471 | fn {memloc, ...} => MemLoc.eq(temp, memloc)) | |
472 | of SOME {distanceB = ref (SOME (db, dbl)), ...} | |
473 | => (db, dbl) | |
474 | | SOME {distanceB, ...} | |
475 | => let | |
476 | val loopLabels = getLoopLabels(loopInfo, label) | |
477 | val _ = distanceB := SOME (I.PosInfinity, NONE) | |
478 | fun default () | |
479 | = List.fold | |
480 | (!pred, | |
481 | (I.PosInfinity, NONE), | |
482 | fn (label, (min, minl)) | |
483 | => let | |
484 | val {live, ...} = getInfo label | |
485 | in | |
486 | case Vector.peek | |
487 | (live, | |
488 | fn {memloc, ...} => MemLoc.eq(temp, memloc)) | |
489 | of SOME {distanceB', ...} | |
490 | => (case valOf(!distanceB') | |
491 | of Position n | |
492 | => if I.<(n, min) | |
493 | then (n, SOME label) | |
494 | else (min, minl) | |
495 | | Length n | |
496 | => let | |
497 | val n = I.Finite n | |
498 | val (n', l') | |
499 | = get_distanceB {temp = temp, | |
500 | label = label} | |
501 | val n' = I.+(n, n') | |
502 | val n'' | |
503 | = case (l', useLF) | |
504 | of (NONE, _) => n' | |
505 | | (_, false) => n' | |
506 | | (SOME l', true) | |
507 | => if List.contains | |
508 | (loopLabels, | |
509 | l', Label.equals) | |
510 | then n' | |
511 | else I.*(I.Finite 5, n') | |
512 | in | |
513 | if I.<(n'', min) | |
514 | then (n', l') | |
515 | else (min, minl) | |
516 | end) | |
517 | | _ => (min, minl) | |
518 | end) | |
519 | ||
520 | datatype z = datatype Entry.t | |
521 | val (n, l) | |
522 | = case entry | |
523 | of Func {...} => (I.PosInfinity, NONE) | |
524 | | Cont {...} => (I.PosInfinity, NONE) | |
525 | | Handler {...} => (I.PosInfinity, NONE) | |
526 | | CReturn {func, ...} | |
527 | => if (CFunction.maySwitchThreads func | |
528 | orelse Size.class (MemLoc.size temp) <> Size.INT) | |
529 | then (I.PosInfinity, NONE) | |
530 | else default () | |
531 | | _ => default () | |
532 | in | |
533 | distanceB := SOME (n, l) ; (n, l) | |
534 | end | |
535 | | _ => (I.PosInfinity, NONE) | |
536 | end | |
537 | ||
538 | local | |
539 | val queue = ref (Queue.empty ()) | |
540 | in | |
541 | fun enque x = queue := Queue.enque(!queue, x) | |
542 | fun deque () = | |
543 | case Queue.deque (!queue) of | |
544 | NONE => NONE | |
545 | | SOME (queue', x) => (queue := queue'; SOME x) | |
546 | end | |
547 | ||
548 | fun doit {label, hints} | |
549 | = let | |
550 | val {block as Block.T {entry, ...}, | |
551 | live = liveData, liveTransfers, ...} = getInfo label | |
552 | in | |
553 | case !liveTransfers | |
554 | of SOME _ => () | |
555 | | NONE | |
556 | => let | |
557 | val loopLabels = getLoopLabels(loopInfo, label) | |
558 | val Block.T {transfer, ...} = block | |
559 | ||
560 | val (regHints, fltregHints) = hints | |
561 | ||
562 | val live = LiveSet.toList(LiveInfo.getLive(liveInfo, label)) | |
563 | ||
564 | val _ | |
565 | = if true then () | |
566 | else | |
567 | (print (Label.toString label); | |
568 | print "\nloopLabels: "; | |
569 | print (List.toString Label.toString loopLabels); | |
570 | print "\nliveData:\n"; | |
571 | Vector.foreach | |
572 | (liveData, | |
573 | fn {memloc, distanceF', distanceB', ...} => | |
574 | (print (MemLoc.toString memloc); | |
575 | print ": "; | |
576 | case !distanceF' of | |
577 | NONE => print "?" | |
578 | | SOME (Position i) => (print "Pos "; print (I.toString i)) | |
579 | | SOME (Length i) => (print "Len "; print (I'.toString i)); | |
580 | print " "; | |
581 | case !distanceB' of | |
582 | NONE => print "?" | |
583 | | SOME (Position i) => (print "Pos "; print (I.toString i)) | |
584 | | SOME (Length i) => (print "Len "; print (I'.toString i)); | |
585 | print "\n")); | |
586 | print "regHints:\n"; | |
587 | List.foreach | |
588 | (regHints, | |
589 | fn (memloc,register,sync) => | |
590 | (print (MemLoc.toString memloc); | |
591 | print ": "; | |
592 | print (Register.toString register); | |
593 | print ": "; | |
594 | print (Bool.toString (!sync)); | |
595 | print "\n")); | |
596 | print "fltregHints:\n"; | |
597 | List.foreach | |
598 | (fltregHints, | |
599 | fn (memloc,sync) => | |
600 | (print (MemLoc.toString memloc); | |
601 | print ": "; | |
602 | print (Bool.toString (!sync)); | |
603 | print "\n")); | |
604 | print "live:\n"; | |
605 | List.foreach | |
606 | (live, | |
607 | fn memloc | |
608 | => (print (MemLoc.toString memloc); | |
609 | print "\n")); | |
610 | print "distance_F:\n"; | |
611 | List.foreach | |
612 | (live, | |
613 | fn memloc | |
614 | => (print (MemLoc.toString memloc); | |
615 | print ": "; | |
616 | let | |
617 | val (n, l) = get_distanceF {temp = memloc, | |
618 | label = label} | |
619 | in | |
620 | print (I.toString n); | |
621 | print " "; | |
622 | print (Option.toString Label.toString l) | |
623 | end; | |
624 | print "\n")); | |
625 | print "distance_B:\n"; | |
626 | List.foreach | |
627 | (live, | |
628 | fn memloc | |
629 | => (print (MemLoc.toString memloc); | |
630 | print ": "; | |
631 | let | |
632 | val (n, l) = get_distanceB {temp = memloc, | |
633 | label = label} | |
634 | in | |
635 | print (I.toString n); | |
636 | print " "; | |
637 | print (Option.toString Label.toString l) | |
638 | end; | |
639 | print "\n"))) | |
640 | ||
641 | val live | |
642 | = if not useB | |
643 | then List.keepAllMap | |
644 | (live, | |
645 | fn memloc | |
646 | => case get_distanceF {temp = memloc, | |
647 | label = label} | |
648 | of (I.Finite n, SOME l) | |
649 | => if n < cutoff | |
650 | then if useLF | |
651 | then if List.contains | |
652 | (loopLabels, | |
653 | l, Label.equals) | |
654 | then SOME (memloc, n) | |
655 | else SOME (memloc, n * 5) | |
656 | else SOME (memloc, n) | |
657 | else NONE | |
658 | | (I.PosInfinity, _) | |
659 | => NONE | |
660 | | _ | |
661 | => Error.bug | |
662 | "x86LiveTransfers.computeLiveTransfers.live: get_distanceF") | |
663 | else List.keepAllMap | |
664 | (live, | |
665 | fn memloc | |
666 | => case (get_distanceB {temp = memloc, | |
667 | label = label}, | |
668 | get_distanceF {temp = memloc, | |
669 | label = label}) | |
670 | of ((I.PosInfinity, _), _) | |
671 | => NONE | |
672 | | (_, (I.PosInfinity, _)) | |
673 | => NONE | |
674 | | ((I.Finite n, SOME nl), | |
675 | (I.Finite m, SOME ml)) | |
676 | => if (n + m) < cutoff | |
677 | then if useLF | |
678 | then case (List.contains | |
679 | (loopLabels, | |
680 | nl, Label.equals), | |
681 | List.contains | |
682 | (loopLabels, | |
683 | ml, Label.equals)) | |
684 | of (true, true) | |
685 | => SOME (memloc, n + m) | |
686 | | (true, false) | |
687 | => SOME (memloc, | |
688 | n + 5 * m) | |
689 | | (false, true) | |
690 | => SOME (memloc, | |
691 | 5 * n + m) | |
692 | | (false, false) | |
693 | => SOME (memloc, | |
694 | 5 * n + 5 * m) | |
695 | else SOME (memloc, n + m) | |
696 | else NONE | |
697 | | _ | |
698 | => Error.bug | |
699 | "x86LiveTransfers.computeLiveTransfers.live: get_distanceB") | |
700 | ||
701 | (* List.partition will reverse the lists. | |
702 | * So sort in increasing order. | |
703 | *) | |
704 | val live | |
705 | = List.insertionSort | |
706 | (live, fn ((_,n1),(_,n2)) => I'.>(n1, n2)) | |
707 | ||
708 | val _ | |
709 | = if true then () else | |
710 | (print "live:\n"; | |
711 | List.foreach | |
712 | (live, | |
713 | fn (memloc,n) | |
714 | => (print (MemLoc.toString memloc); | |
715 | print ": "; | |
716 | print (I'.toString n); | |
717 | print "\n"))) | |
718 | ||
719 | val {yes = liveRegs, no = liveFltRegs} | |
720 | = List.partition | |
721 | (live, | |
722 | fn (memloc,_) | |
723 | => Size.class (MemLoc.size memloc) = Size.INT) | |
724 | ||
725 | val liveRegs | |
726 | = List.map | |
727 | (liveRegs, | |
728 | fn (memloc,weight) | |
729 | => case List.peek | |
730 | (regHints, | |
731 | fn (memloc',_,_) | |
732 | => MemLoc.eq(memloc,memloc')) | |
733 | of SOME (_,register',_) | |
734 | => (memloc,weight,SOME register') | |
735 | | NONE | |
736 | => (memloc,weight,NONE)) | |
737 | ||
738 | val rec doitRegs | |
739 | = fn ([],_,liveTransfers) => liveTransfers | |
740 | | (_,[],liveTransfers) => liveTransfers | |
741 | | (transferRegs, | |
742 | (memloc,_,register)::live, | |
743 | liveTransfers) | |
744 | => let | |
745 | fun finish register | |
746 | = let | |
747 | val transferRegs | |
748 | = List.removeAll | |
749 | (transferRegs, | |
750 | fn register' | |
751 | => Register.coincide(register, | |
752 | register')) | |
753 | in | |
754 | doitRegs | |
755 | (transferRegs, | |
756 | live, | |
757 | (memloc,register,ref true)::liveTransfers) | |
758 | end | |
759 | ||
760 | fun default () | |
761 | = let | |
762 | val size = MemLoc.size memloc | |
763 | val transferRegs' | |
764 | = List.keepAllMap | |
765 | (transferRegs, | |
766 | fn register | |
767 | => if Size.eq | |
768 | (size, | |
769 | Register.size register) | |
770 | then SOME | |
771 | (register, | |
772 | List.index | |
773 | (live, | |
774 | fn (_,_,SOME register') | |
775 | => Register.eq | |
776 | (register, | |
777 | register') | |
778 | | (_,_,NONE) => false)) | |
779 | else NONE) | |
780 | val transferRegs' | |
781 | = List.insertionSort | |
782 | (transferRegs', | |
783 | fn ((_,SOME index1),(_,SOME index2)) | |
784 | => Int.>(index1, index2) | |
785 | | ((_, NONE),_) | |
786 | => true | |
787 | | (_, (_, NONE)) | |
788 | => false) | |
789 | in | |
790 | case transferRegs' | |
791 | of nil | |
792 | => doitRegs (transferRegs, | |
793 | live, | |
794 | liveTransfers) | |
795 | | (register,_)::_ | |
796 | => finish register | |
797 | end | |
798 | in | |
799 | case register | |
800 | of SOME register | |
801 | => if List.contains(transferRegs, | |
802 | register, | |
803 | Register.eq) | |
804 | then finish register | |
805 | else default () | |
806 | | NONE => default () | |
807 | end | |
808 | ||
809 | val liveRegsTransfers = doitRegs(transferRegs entry, liveRegs, []) | |
810 | ||
811 | ||
812 | val liveFltRegs = take(liveFltRegs, transferFltRegs entry) | |
813 | val liveFltRegsTransfers | |
814 | = List.map(liveFltRegs, fn (memloc, _) => (memloc, ref true)) | |
815 | ||
816 | ||
817 | val _ = liveTransfers := SOME (liveRegsTransfers, | |
818 | liveFltRegsTransfers) | |
819 | ||
820 | (* | |
821 | val _ | |
822 | = (print "liveRegsTransfers:\n"; | |
823 | List.foreach | |
824 | (liveRegsTransfers, | |
825 | fn (memloc,register,sync) => | |
826 | (print (MemLoc.toString memloc); | |
827 | print ": "; | |
828 | print (Register.toString register); | |
829 | print ": "; | |
830 | print (Bool.toString (!sync)); | |
831 | print "\n")); | |
832 | print "liveFltRegsTransfers:\n"; | |
833 | List.foreach | |
834 | (liveFltRegsTransfers, | |
835 | fn (memloc,sync) => | |
836 | (print (MemLoc.toString memloc); | |
837 | print ": "; | |
838 | print (Bool.toString (!sync)); | |
839 | print "\n")); | |
840 | print "") | |
841 | *) | |
842 | ||
843 | fun doit' label = enque {label = label, | |
844 | hints = (liveRegsTransfers, | |
845 | liveFltRegsTransfers)} | |
846 | fun doit'' label = enque {label = label, | |
847 | hints = ([],[])} | |
848 | fun doit''' func label = | |
849 | let | |
850 | val hints = | |
851 | List.fold | |
852 | (Operand.cReturnTemps (CFunction.return func), | |
853 | ([],[]), | |
854 | fn ({src, dst}, (regHints, fltregHints)) => | |
855 | case src of | |
856 | Operand.Register reg => | |
857 | ((dst, reg, ref true) :: regHints, | |
858 | fltregHints) | |
859 | | Operand.FltRegister _ => | |
860 | (regHints, | |
861 | (dst, ref true) :: fltregHints) | |
862 | | _ => (regHints, fltregHints)) | |
863 | in | |
864 | enque {hints = hints, | |
865 | label = label} | |
866 | end | |
867 | datatype z = datatype Transfer.t | |
868 | in | |
869 | case transfer | |
870 | of Goto {target, ...} | |
871 | => (doit' target) | |
872 | | Iff {truee, falsee, ...} | |
873 | => (doit' truee; | |
874 | doit' falsee) | |
875 | | Switch {cases, default, ...} | |
876 | => (doit' default; | |
877 | Transfer.Cases.foreach(cases, doit' o #2)) | |
878 | | Tail {...} | |
879 | => () | |
880 | | NonTail {return, handler, ...} | |
881 | => (doit'' return; | |
882 | case handler | |
883 | of SOME handler => doit'' handler | |
884 | | NONE => ()) | |
885 | | Return {...} | |
886 | => () | |
887 | | Raise {...} | |
888 | => () | |
889 | | CCall {func, return, ...} | |
890 | => if CFunction.maySwitchThreads func | |
891 | then Option.app (return, doit'') | |
892 | else Option.app (return, doit''' func) | |
893 | end | |
894 | end | |
895 | ||
896 | val _ = Vector.foreach | |
897 | (funcs, | |
898 | fn label => enque {label = label, hints = ([],[])}) | |
899 | ||
900 | fun loop () | |
901 | = (case deque () | |
902 | of NONE => () | |
903 | | SOME {label, hints} | |
904 | => (doit {label = label, hints = hints}; | |
905 | loop ())) | |
906 | val _ = loop () | |
907 | ||
908 | fun doit {label, defed = defed'} | |
909 | = let | |
910 | ||
911 | val {block, liveTransfers, defed, ...} = getInfo label | |
912 | val (liveRegs, liveFltRegs) = valOf (!liveTransfers) | |
913 | ||
914 | val defed' | |
915 | = case getNear(jumpInfo, label) | |
916 | of None => MemLocSet.empty | |
917 | | Count 0 => MemLocSet.empty | |
918 | | Count 1 => defed' | |
919 | | Count _ | |
920 | => MemLocSet.subset | |
921 | (defed', | |
922 | fn memloc | |
923 | => List.exists | |
924 | (liveRegs, | |
925 | fn (memloc',_,_) => MemLoc.eq(memloc', memloc)) | |
926 | orelse | |
927 | List.exists | |
928 | (liveFltRegs, | |
929 | fn (memloc',_) => MemLoc.eq(memloc', memloc))) | |
930 | ||
931 | fun default defed'' | |
932 | = let | |
933 | val Block.T {entry, statements, transfer, ...} = block | |
934 | ||
935 | val _ = List.foreach | |
936 | (liveRegs, | |
937 | fn (memloc,_,sync) | |
938 | => if MemLocSet.contains(defed', memloc) | |
939 | then sync := false | |
940 | else ()) | |
941 | val _ = List.foreach | |
942 | (liveFltRegs, | |
943 | fn (memloc,sync) | |
944 | => if MemLocSet.contains(defed', memloc) | |
945 | then sync := false | |
946 | else ()) | |
947 | ||
948 | val defed' = MemLocSet.+(defed'', defed') | |
949 | val _ = defed := SOME defed' | |
950 | ||
951 | fun doit' (defed', defs) | |
952 | = List.fold | |
953 | (defs, | |
954 | defed', | |
955 | fn (def,defed') | |
956 | => case Operand.deMemloc def | |
957 | of SOME def => if track def | |
958 | then MemLocSet.add(defed', def) | |
959 | else defed' | |
960 | | NONE => defed') | |
961 | ||
962 | val {defs, ...} = Entry.uses_defs_kills entry | |
963 | val defed' = doit' (defed', defs) | |
964 | ||
965 | val defed' | |
966 | = List.fold | |
967 | (statements, | |
968 | defed', | |
969 | fn (asm,defed') | |
970 | => let | |
971 | val {defs, ...} = Assembly.uses_defs_kills asm | |
972 | in | |
973 | doit' (defed', defs) | |
974 | end) | |
975 | ||
976 | val {defs, ...} = Transfer.uses_defs_kills transfer | |
977 | val defed' = doit' (defed', defs) | |
978 | ||
979 | fun doit' label = doit {label = label, | |
980 | defed = defed'} | |
981 | fun doit'' label = doit {label = label, | |
982 | defed = MemLocSet.empty} | |
983 | ||
984 | datatype z = datatype Transfer.t | |
985 | in | |
986 | case transfer | |
987 | of Goto {target, ...} | |
988 | => (doit' target) | |
989 | | Iff {truee, falsee, ...} | |
990 | => (doit' truee; | |
991 | doit' falsee) | |
992 | | Switch {cases, default, ...} | |
993 | => (Transfer.Cases.foreach(cases, doit' o #2); | |
994 | doit' default) | |
995 | | Tail {...} | |
996 | => () | |
997 | | NonTail {return, handler, ...} | |
998 | => (doit'' return; | |
999 | case handler | |
1000 | of SOME handler => doit'' handler | |
1001 | | NONE => ()) | |
1002 | | Return {...} | |
1003 | => () | |
1004 | | Raise {...} | |
1005 | => () | |
1006 | | CCall {func, return, ...} | |
1007 | => if CFunction.maySwitchThreads func | |
1008 | then Option.app (return, doit'') | |
1009 | else Option.app (return, doit') | |
1010 | end | |
1011 | in | |
1012 | case !defed | |
1013 | of NONE => default MemLocSet.empty | |
1014 | | SOME defed => if MemLocSet.<=(defed',defed) | |
1015 | then () | |
1016 | else default defed | |
1017 | end | |
1018 | ||
1019 | val _ = Vector.foreach | |
1020 | (funcs, | |
1021 | fn label => doit {label = label, | |
1022 | defed = MemLocSet.empty}) | |
1023 | ||
1024 | val {get = getLiveTransfers : | |
1025 | Label.t -> ((MemLoc.t * Register.t * bool) list * | |
1026 | (MemLoc.t * bool) list), | |
1027 | set = setLiveTransfers, ...} | |
1028 | = Property.getSet | |
1029 | (Label.plist, | |
1030 | Property.initRaise ("x86LiveTransfers:getLiveTransfers", Label.layout)) | |
1031 | ||
1032 | val _ = Vector.foreach | |
1033 | (labels, | |
1034 | fn label | |
1035 | => let | |
1036 | val {liveTransfers, ...} = getInfo label | |
1037 | val (liveRegs, liveFltRegs) = valOf (!liveTransfers) | |
1038 | val (liveRegs, liveFltRegs) | |
1039 | = if sync | |
1040 | then (List.map | |
1041 | (liveRegs, | |
1042 | fn (memloc,reg, sync) => (memloc, reg, !sync)), | |
1043 | List.map | |
1044 | (liveFltRegs, | |
1045 | fn (memloc, sync) => (memloc, !sync))) | |
1046 | else (List.map | |
1047 | (liveRegs, | |
1048 | fn (memloc,reg, _) => (memloc, reg, false)), | |
1049 | List.map | |
1050 | (liveFltRegs, | |
1051 | fn (memloc, _) => (memloc, false))) | |
1052 | in | |
1053 | setLiveTransfers(label, (liveRegs, liveFltRegs)) | |
1054 | end) | |
1055 | ||
1056 | val _ = destInfo () | |
1057 | in | |
1058 | T {get = getLiveTransfers, | |
1059 | set = setLiveTransfers} | |
1060 | end | |
1061 | ||
1062 | ||
1063 | val computeLiveTransfers | |
1064 | = fn {chunk, transferRegs, transferFltRegs, liveInfo, jumpInfo, loopInfo} | |
1065 | => if !Control.Native.liveTransfer > 0 | |
1066 | then computeLiveTransfers {chunk = chunk, | |
1067 | transferRegs = transferRegs, | |
1068 | transferFltRegs = transferFltRegs, | |
1069 | liveInfo = liveInfo, | |
1070 | jumpInfo = jumpInfo, | |
1071 | loopInfo = loopInfo} | |
1072 | else let | |
1073 | val {get = getLiveTransfers, | |
1074 | set = setLiveTransfers, ...} | |
1075 | = Property.getSetOnce(Label.plist, | |
1076 | Property.initConst ([], [])) | |
1077 | in | |
1078 | T {get = getLiveTransfers, | |
1079 | set = setLiveTransfers} | |
1080 | end | |
1081 | ||
1082 | val (computeLiveTransfers : {chunk : Chunk.t, | |
1083 | transferRegs : Entry.t -> Register.t list, | |
1084 | transferFltRegs : Entry.t -> Int.t, | |
1085 | liveInfo : LiveInfo.t, | |
1086 | jumpInfo : x86JumpInfo.t, | |
1087 | loopInfo : x86LoopInfo.t} -> t, | |
1088 | computeLiveTransfers_msg) | |
1089 | = tracerTop | |
1090 | "computeLiveTransfers" | |
1091 | computeLiveTransfers | |
1092 | ||
1093 | fun computeLiveTransfers_totals () | |
1094 | = (computeLiveTransfers_msg ()) | |
1095 | ||
1096 | fun getLiveTransfers (T {get, ...}, label) = get label | |
1097 | ||
1098 | fun setLiveTransfersEmpty (T {set, ...}, label) = set(label, ([], [])) | |
1099 | end |