HCoop / hcoop / debian / mlton.git / blob
? search:
summary | shortlog | log | commit | commitdiff | tree
blame | history | raw | HEAD
Import Upstream version 20180207
[hcoop/debian/mlton.git] / mlton / codegen / x86-codegen / x86-allocate-registers.fun
1 (* Copyright (C) 2010 Matthew Fluet.
2 * Copyright (C) 1999-2007 Henry Cejtin, Matthew Fluet, Suresh
3 * Jagannathan, and Stephen Weeks.
4 * Copyright (C) 1997-2000 NEC Research Institute.
5 *
6 * MLton is released under a BSD-style license.
7 * See the file MLton-LICENSE for details.
8 *)
9
10 functor x86AllocateRegisters(S: X86_ALLOCATE_REGISTERS_STRUCTS) : X86_ALLOCATE_REGISTERS =
11 struct
12
13 open S
14 open x86
15
16 val tracer = x86.tracer
17 val tracerTop = x86.tracerTop
18
19 fun picRelative () =
20 (* When outputing position-independent-code (PIC), we need to keep
21 * one register pointing at a known local address. Addresses are
22 * then computed relative to this register.
23 *)
24 let
25 datatype z = datatype Control.Format.t
26 datatype z = datatype MLton.Platform.OS.t
27
28 (* If the ELF symbol is external, we already setup an indirect
29 * mov to load the address. Don't munge the symbol more.
30 *)
31 fun mungeLabelELF l =
32 case Label.toString l of s =>
33 if String.hasSuffix (s, { suffix = "@GOT" }) then l else
34 Label.fromString (s ^ "@GOTOFF")
35
36 (* !!! PIC on darwin not done yet !!! *)
37 (* It will work using %esp -> MLtonLocalBaseSymbol *)
38 fun mungeLabelDarwin l =
39 Label.fromString (Label.toString l ^ "-MLtonLocalBaseSymbol")
40 in
41 case (!Control.Target.os, !Control.positionIndependent) of
42 (* Only darwin and ELF might be using PIC *)
43 (Darwin, true) => (mungeLabelDarwin, SOME Register.esp)
44 | (_, true) => (mungeLabelELF, SOME Register.ebx)
45 | (_, false) => (fn l => l, NONE)
46 end
47
48 fun track memloc = let
49 val trackClasses
50 = ClassSet.add(ClassSet.+
51 (!x86MLton.Classes.livenessClasses,
52 !x86MLton.Classes.holdClasses),
53 x86MLton.Classes.StaticNonTemp)
54 in
55 ClassSet.contains(trackClasses, MemLoc.class memloc)
56 end
57 fun volatile memloc = let
58 val volatileClasses
59 = !x86MLton.Classes.volatileClasses
60 in
61 ClassSet.contains(volatileClasses, MemLoc.class memloc)
62 end
63
64 fun partition(l, p)
65 = let
66 val rec partition'
67 = fn ([],PS) => PS
68 | (h::t,PS) => let
69 val rec partition''
70 = fn [] => [[h]]
71 | P::PS => if List.exists(P,fn x => p(h, x))
72 then (h::P)::PS
73 else P::(partition'' PS)
74 in
75 partition'(t,partition'' PS)
76 end
77 in
78 partition'(l,[])
79 end
80
81 fun totalOrder (l, plt)
82 = let
83 val rec totalOrder'
84 = fn ([],l) => l
85 | (h::t,l) => let
86 val rec split
87 = fn (lt,t)
88 => case List.splitPrefix
89 (t, fn x => plt(x,h))
90 of (nil,t) => lt@[h]@t
91 | (lt',t) => split(lt@lt',t)
92 in
93 totalOrder'(t,split([],l))
94 end
95 in
96 totalOrder'(l,[])
97 end
98
99 val bool_lt
100 = fn (false, true) => true
101 | _ => false
102
103 val bool_gt
104 = fn (true, false) => true
105 | _ => false
106
107 fun option_lt lt
108 = fn (SOME x, SOME y) => lt (x,y)
109 | (NONE, SOME _) => true
110 | _ => false
111
112 structure Liveness =
113 struct
114
115 datatype futureMemlocTag = FLIVE
116 | FCOMMIT | FREMOVE | FDEAD
117 | FUSE | FUSEDEF | FDEF
118
119 val futureMemlocTag_toString
120 = fn FLIVE => "FLIVE"
121 | FCOMMIT => "FCOMMIT"
122 | FREMOVE => "FREMOVE"
123 | FDEAD => "FDEAD"
124 | FUSE => "FUSE"
125 | FUSEDEF => "FUSEDEF"
126 | FDEF => "FDEF"
127
128 type futureMemloc = futureMemlocTag * MemLoc.t
129
130 datatype futureMemlocPredTag = FCOMMITP | FREMOVEP | FDEADP
131 | FMCOMMITP | FMREMOVEP
132
133 val futureMemlocPredTag_toString
134 = fn FCOMMITP => "FCOMMITP"
135 | FREMOVEP => "FREMOVEP"
136 | FDEADP => "FDEADP"
137 | FMCOMMITP => "FMCOMMITP"
138 | FMREMOVEP => "FMREMOVEP"
139
140 type futureMemlocPred = futureMemlocPredTag * (MemLoc.t -> bool)
141
142 datatype future = M of futureMemloc | MP of futureMemlocPred
143
144 val future_toString
145 = fn (M (tag, memloc))
146 => concat [futureMemlocTag_toString tag, " ", MemLoc.toString memloc]
147 | (MP (tag, _))
148 => concat [futureMemlocPredTag_toString tag]
149
150
151 type hint = Register.t * MemLoc.t list * MemLocSet.t
152
153 val hint_toString
154 = fn (register, memlocs, _)
155 => concat ["{ ",
156 List.fold
157 (memlocs,
158 "",
159 fn (memloc, s) => s ^ (MemLoc.toString memloc) ^ " "),
160 "} -> ",
161 Register.toString register]
162
163 type t = {dead: MemLocSet.t,
164 commit: MemLocSet.t,
165 remove: MemLocSet.t,
166 futures: {pre: future list,
167 post: future list},
168 hint: hint list}
169
170 (*
171 fun toString {dead, commit, remove, futures = {pre, post}, hint}
172 = let
173 fun doit (name, l, toString, s)
174 = List.fold(l, s,
175 fn (x, s)
176 => concat [name, toString x, "\n", s])
177 fun doit' (name, l, toString, s)
178 = MemLocSet.fold(l, s,
179 fn (x, s)
180 => concat [name, toString x, "\n", s])
181 in
182 doit'("dead: ", dead, MemLoc.toString,
183 doit'("commit: ", commit, MemLoc.toString,
184 doit'("remove: ", remove, MemLoc.toString,
185 doit("future (pre): ", List.rev pre, future_toString,
186 doit("future (post): ", List.rev post, future_toString,
187 doit("hint: ", hint, hint_toString, ""))))))
188 end
189 *)
190
191 fun toComments {dead, commit, remove, futures = {pre, post}, hint}
192 = let
193 fun doit (name, l, toString, ac)
194 = List.fold(l, ac,
195 fn (x, ac)
196 => (Assembly.comment (concat [name, toString x]))::
197 ac)
198 fun doit' (name, l, toString, ac)
199 = MemLocSet.fold(l, ac,
200 fn (x, ac)
201 => (Assembly.comment (concat [name, toString x]))::
202 ac)
203 in
204 doit'("dead: ", dead, MemLoc.toString,
205 doit'("commit: ", commit, MemLoc.toString,
206 doit'("remove: ", remove, MemLoc.toString,
207 doit("future (pre): ", List.rev pre, future_toString,
208 doit("future (post): ", List.rev post, future_toString,
209 doit("hint: ", hint, hint_toString, []))))))
210 end
211
212
213 datatype commit = NO | COMMIT | REMOVE | DEAD
214
215 fun predict(future, memloc)
216 = let
217 val rec sawNothing
218 = fn [] => if track memloc then DEAD else REMOVE
219 | (M (tag',memloc'))::future
220 => if MemLoc.eq(memloc, memloc')
221 then case tag'
222 of FLIVE => NO
223 | FCOMMIT => sawCommit future
224 | FREMOVE => sawRemove future
225 | FDEAD => DEAD
226 | FUSE => sawUse future
227 | FUSEDEF => NO
228 | FDEF => DEAD
229 else if ((tag' = FUSEDEF) orelse (tag' = FDEF))
230 andalso
231 List.exists
232 (MemLoc.utilized memloc,
233 fn memloc'' => MemLoc.mayAlias(memloc'', memloc'))
234 then REMOVE
235 else if MemLoc.mayAlias(memloc, memloc')
236 then case tag'
237 of FUSE => sawCommit future
238 | FUSEDEF => REMOVE
239 | FDEF => REMOVE
240 | _ => sawNothing future
241 else sawNothing future
242 | (MP (tag',pred'))::future
243 => if pred' memloc
244 then case tag'
245 of FCOMMITP => sawCommit future
246 | FREMOVEP => sawRemove future
247 | FDEADP => DEAD
248 | FMCOMMITP => sawCommit future
249 | FMREMOVEP => sawRemove future
250 else sawNothing future
251 and sawCommit
252 = fn [] => REMOVE
253 | (M (tag',memloc'))::future
254 => if MemLoc.eq(memloc, memloc')
255 then case tag'
256 of FLIVE => COMMIT
257 | FCOMMIT => sawCommit future
258 | FREMOVE => REMOVE
259 | FDEAD => REMOVE
260 | FUSE => COMMIT
261 | FUSEDEF => COMMIT
262 | FDEF => REMOVE
263 else if MemLoc.mayAlias(memloc, memloc')
264 then case tag'
265 of FUSE => sawCommit future
266 | FUSEDEF => REMOVE
267 | FDEF => REMOVE
268 | _ => sawCommit future
269 else sawCommit future
270 | (MP (tag',pred'))::future
271 => if pred' memloc
272 then case tag'
273 of FCOMMITP => sawCommit future
274 | FREMOVEP => REMOVE
275 | FDEADP => REMOVE
276 | FMCOMMITP => sawCommit future
277 | FMREMOVEP => REMOVE
278 else sawCommit future
279 and sawRemove
280 = fn [] => REMOVE
281 | (M (tag',memloc'))::future
282 => if MemLoc.eq(memloc, memloc')
283 then case tag'
284 of FLIVE => REMOVE
285 | FCOMMIT => REMOVE
286 | FREMOVE => sawRemove future
287 | FDEAD => DEAD
288 | FUSE => REMOVE
289 | FUSEDEF => REMOVE
290 | FDEF => DEAD
291 else if MemLoc.mayAlias(memloc, memloc')
292 then case tag'
293 of FUSE => REMOVE
294 | FUSEDEF => REMOVE
295 | FDEF => REMOVE
296 | _ => sawRemove future
297 else sawRemove future
298 | (MP (tag',pred'))::future
299 => if pred' memloc
300 then case tag'
301 of FCOMMITP => REMOVE
302 | FREMOVEP => REMOVE
303 | FDEADP => DEAD
304 | FMCOMMITP => REMOVE
305 | FMREMOVEP => sawRemove future
306 else sawRemove future
307 and sawUse
308 = fn [] => if track memloc then NO else COMMIT
309 | (M (tag',memloc'))::future
310 => if MemLoc.eq(memloc, memloc')
311 then case tag'
312 of FLIVE => NO
313 | FCOMMIT => sawUseCommit future
314 | FREMOVE => NO
315 | FDEAD => NO
316 | FUSE => sawUse future
317 | FUSEDEF => NO
318 | FDEF => NO
319 else if MemLoc.mayAlias(memloc, memloc')
320 then case tag'
321 of FUSE => sawUseCommit future
322 | FUSEDEF => NO
323 | FDEF => NO
324 | _ => sawUse future
325 else sawUse future
326 | (MP (tag',pred'))::future
327 => if pred' memloc
328 then case tag'
329 of FCOMMITP => sawUseCommit future
330 | FREMOVEP => NO
331 | FDEADP => NO
332 | FMCOMMITP => sawUseCommit future
333 | FMREMOVEP => NO
334 else sawUse future
335 and sawUseCommit
336 = fn [] => if track memloc then NO else COMMIT
337 | (M (tag',memloc'))::future
338 => if MemLoc.eq(memloc, memloc')
339 then case tag'
340 of FLIVE => COMMIT
341 | FCOMMIT => sawUseCommit future
342 | FREMOVE => NO
343 | FDEAD => NO
344 | FUSE => COMMIT
345 | FUSEDEF => COMMIT
346 | FDEF => NO
347 else if MemLoc.mayAlias(memloc, memloc')
348 then case tag'
349 of FUSE => sawUseCommit future
350 | FUSEDEF => NO
351 | FDEF => NO
352 | _ => sawUseCommit future
353 else sawUseCommit future
354 | (MP (tag',pred'))::future
355 => if pred' memloc
356 then case tag'
357 of FCOMMITP => sawUseCommit future
358 | FREMOVEP => NO
359 | FDEADP => NO
360 | FMCOMMITP => sawUseCommit future
361 | FMREMOVEP => NO
362 else sawUseCommit future
363
364 fun check commit
365 = if List.exists
366 (MemLoc.utilized memloc,
367 fn memloc' => case predict (future, memloc')
368 of REMOVE => true
369 | DEAD => true
370 | _ => false)
371 then REMOVE
372 else commit
373
374 val default = case sawNothing future
375 of REMOVE => REMOVE
376 | DEAD => DEAD
377 | commit => check commit
378 in
379 default
380 end
381
382 val split
383 = fn (set, p)
384 => MemLocSet.fold
385 (set,
386 (MemLocSet.empty,MemLocSet.empty,MemLocSet.empty,MemLocSet.empty),
387 fn (memloc, (no, commit, remove, dead))
388 => let
389 val add = fn set => MemLocSet.add(set, memloc)
390 in
391 case p memloc
392 of NO => (add no, commit, remove, dead)
393 | COMMIT => (no, add commit, remove, dead)
394 | REMOVE => (no, commit, add remove, dead)
395 | DEAD => (no, commit, remove, add dead)
396 end)
397
398 fun liveness {uses: MemLocSet.t,
399 defs: MemLocSet.t,
400 future: future list} :
401 {dead: MemLocSet.t,
402 commit: MemLocSet.t,
403 remove: MemLocSet.t,
404 future: future list}
405 = let
406 local
407 fun doit' (memlocs, set)
408 = MemLocSet.fold
409 (memlocs,
410 set,
411 fn (memloc, set)
412 => MemLocSet.union
413 (set, MemLocSet.fromList (MemLoc.utilized memloc)))
414 in
415 val allUses
416 = doit'(defs,
417 doit'(uses,
418 uses))
419 val allDefs
420 = defs
421 end
422
423 val current
424 = MemLocSet.+(allUses, allDefs)
425 val current_usedef
426 = MemLocSet.intersect(allUses, allDefs)
427 val current_use
428 = MemLocSet.-(allUses, current_usedef)
429 val current_def
430 = MemLocSet.-(allDefs, current_usedef)
431
432 val (_,commit,remove,dead)
433 = split(current, fn memloc => predict(future, memloc))
434
435 val future
436 = let
437 fun doit(memlocs, tag, future)
438 = MemLocSet.fold
439 (memlocs,
440 future,
441 fn (memloc,future)
442 => (M (tag, memloc))::future)
443 in
444 doit(current_use, FUSE,
445 doit(current_usedef, FUSEDEF,
446 doit(current_def, FDEF,
447 future)))
448 end
449
450 val info
451 = {dead = dead,
452 commit = commit,
453 remove = remove,
454 future = future}
455 in
456 info
457 end
458
459 fun livenessInstruction {instruction: Instruction.t,
460 future: future list}
461 = let
462 val future_post = future
463
464 val {uses, defs, ...} = Instruction.uses_defs_kills instruction
465 local
466 fun doit operands
467 = List.fold
468 (operands,
469 MemLocSet.empty,
470 fn (operand, memlocs)
471 => case Operand.deMemloc operand
472 of SOME memloc => MemLocSet.add(memlocs, memloc)
473 | NONE => memlocs)
474 in
475 val uses = doit uses
476 val defs = doit defs
477 end
478
479 val {dead,commit,remove,future}
480 = liveness {uses = uses,
481 defs = defs,
482 future = future_post}
483 val future_pre = future
484
485 val info = {dead = dead,
486 commit = commit,
487 remove = remove,
488 futures = {pre = future_pre, post = future_post}}
489
490 in
491 info
492 end
493
494 fun livenessDirective {directive: Directive.t,
495 future: future list}
496 = let
497 val future_post = future
498
499 fun addLive (memlocsX, f)
500 = List.fold
501 (memlocsX,
502 future,
503 fn (X, future) => (M (FLIVE, f X))::future)
504 fun addLive' (memlocs)
505 = MemLocSet.fold
506 (memlocs,
507 future,
508 fn (memloc, future) => (M (FLIVE, memloc))::future)
509
510 val future_pre
511 = case directive
512 of Directive.Reset
513 => []
514 | Directive.Cache {caches, ...}
515 => addLive(caches, fn {memloc, ...} => memloc)
516 | Directive.FltCache {caches, ...}
517 => addLive(caches, fn {memloc, ...} => memloc)
518 | Directive.Force {commit_memlocs,
519 commit_classes,
520 remove_memlocs,
521 remove_classes,
522 dead_memlocs,
523 dead_classes,
524 ...}
525 => MemLocSet.fold
526 (commit_memlocs,
527 MemLocSet.fold
528 (remove_memlocs,
529 MemLocSet.fold
530 (dead_memlocs,
531 (MP (FCOMMITP,
532 fn memloc
533 => ClassSet.contains(commit_classes,
534 MemLoc.class memloc)))::
535 (MP (FREMOVEP,
536 fn memloc
537 => ClassSet.contains(remove_classes,
538 MemLoc.class memloc)))::
539 (MP (FDEADP,
540 fn memloc
541 => ClassSet.contains(dead_classes,
542 MemLoc.class memloc)))::
543 future,
544 fn (memloc,future) => (M (FDEAD, memloc))::future),
545 fn (memloc,future) => (M (FREMOVE, memloc))::future),
546 fn (memloc,future) => (M (FCOMMIT, memloc))::future)
547 | Directive.CCall
548 => (MP (FCOMMITP,
549 fn memloc
550 => MemLoc.Class.eq
551 (MemLoc.class memloc,
552 MemLoc.Class.CStack)))::
553 (MP (FMREMOVEP,
554 fn memloc
555 => (not (MemLoc.Class.eq
556 (MemLoc.class memloc,
557 MemLoc.Class.CStack)))
558 andalso
559 (Size.class (MemLoc.size memloc) <> Size.INT)))::
560 future
561 | Directive.Return {returns}
562 => (List.map(returns, fn {dst, ...} => M (FDEF, dst))) @ future
563 | Directive.ClearFlt
564 => (MP (FMREMOVEP,
565 fn memloc
566 => (Size.class (MemLoc.size memloc) <> Size.INT)))::
567 future
568 | Directive.SaveRegAlloc {live, ...}
569 => addLive'(live)
570 | _ => future
571
572 val info = {dead = MemLocSet.empty,
573 commit = MemLocSet.empty,
574 remove = MemLocSet.empty,
575 futures = {pre = future_pre, post = future_post}}
576 in
577 info
578 end
579
580 fun livenessAssembly {assembly: Assembly.t,
581 future: future list,
582 hint: hint list} : t
583 = let
584 fun default () = {dead = MemLocSet.empty,
585 commit = MemLocSet.empty,
586 remove = MemLocSet.empty,
587 futures = {pre = future, post = future}}
588 val {dead, commit, remove, futures}
589 = case assembly
590 of Assembly.Comment _ => default ()
591 | Assembly.Directive d
592 => livenessDirective {directive = d,
593 future = future}
594 | Assembly.Instruction i
595 => livenessInstruction {instruction = i,
596 future = future}
597 | Assembly.Label _ => default ()
598 | Assembly.PseudoOp _ => default ()
599
600 val hint' = Assembly.hints assembly
601 val hint
602 = List.fold
603 (case assembly
604 of Assembly.Directive Directive.Reset => []
605 | _ => hint,
606 List.revMap
607 (hint',
608 fn (memloc, register)
609 => (register, [memloc], MemLocSet.empty)),
610 fn ((hint_register,hint_memlocs,hint_ignore),hint)
611 => if List.exists
612 (hint,
613 fn (hint_register',_,_) => Register.coincide(hint_register,
614 hint_register'))
615 then hint
616 else let
617 val hint_memloc = hd hint_memlocs
618 in
619 if List.fold
620 (hint,
621 false,
622 fn ((_,hint_memlocs',_),b)
623 => b orelse List.contains
624 (hint_memlocs',
625 hint_memloc,
626 MemLoc.eq))
627 then hint
628 else (hint_register,
629 [hint_memloc],
630 MemLocSet.union(dead, hint_ignore))::hint
631 end)
632 val hint
633 = case assembly
634 of (Assembly.Instruction (Instruction.MOV
635 {src = Operand.MemLoc src',
636 dst = Operand.MemLoc dst',
637 ...}))
638 => List.revMap
639 (hint,
640 fn (hint_register,hint_memlocs,hint_ignore)
641 => if List.contains(hint_memlocs, dst', MemLoc.eq)
642 then (hint_register,
643 src'::hint_memlocs,
644 hint_ignore)
645 else (hint_register,hint_memlocs,hint_ignore))
646 | _ => hint
647
648 val info = {dead = dead,
649 commit = commit,
650 remove = remove,
651 futures = futures,
652 hint = hint}
653 in
654 info
655 end
656
657 fun toLiveness (assembly: Assembly.t list) : ((Assembly.t * t) list)
658 = let
659 val {assembly,...}
660 = List.foldr
661 (assembly,
662 {assembly = [], future = [], hint = []},
663 fn (asm, {assembly,future,hint})
664 => let
665 val info as {futures = {pre, ...}, hint, ...}
666 = livenessAssembly {assembly = asm,
667 future = future,
668 hint = hint}
669 in
670 {assembly = (asm,info)::assembly,
671 future = pre,
672 hint = hint}
673 end)
674 in
675 assembly
676 end
677
678 val (toLiveness,toLiveness_msg)
679 = tracer
680 "toLiveness"
681 toLiveness
682
683 fun toNoLiveness (assembly: Assembly.t list) : ((Assembly.t * t) list)
684 = List.map(assembly, fn asm => (asm,{dead = MemLocSet.empty,
685 commit = MemLocSet.empty,
686 remove = MemLocSet.empty,
687 futures = {pre = [], post = []},
688 hint = []}))
689
690 val (toNoLiveness,toNoLiveness_msg)
691 = tracer
692 "toNoLiveness"
693 toNoLiveness
694 end
695
696 structure RegisterAllocation =
697 struct
698 exception Spill
699 val spill : Int.t ref = ref 0
700 val spillLabel = Label.fromString "spill"
701 val depth : Int.t ref = ref 0
702
703 datatype commit
704 = NO
705 | COMMIT of int
706 | REMOVE of int
707 | TRYCOMMIT of int
708 | TRYREMOVE of int
709
710 val commit_toString
711 = fn NO => "NO"
712 | COMMIT i => "COMMIT " ^ (Int.toString i)
713 | REMOVE i => "REMOVE " ^ (Int.toString i)
714 | TRYCOMMIT i => "TRYCOMMIT " ^ (Int.toString i)
715 | TRYREMOVE i => "TRYREMOVE " ^ (Int.toString i)
716
717 type value = {register: Register.t,
718 memloc: MemLoc.t,
719 weight: int,
720 sync: bool,
721 commit: commit}
722
723 fun value_toString {register, memloc, weight, sync, commit}
724 = concat [Register.toString register, " ",
725 MemLoc.toString memloc, " ",
726 Int.toString weight, " ",
727 Bool.toString sync, " ",
728 commit_toString commit]
729
730 type fltvalue = {fltregister: FltRegister.t,
731 memloc: MemLoc.t,
732 weight: int,
733 sync: bool,
734 commit: commit}
735
736 fun fltvalue_toString {fltregister, memloc, weight, sync, commit}
737 = concat [FltRegister.toString fltregister, " ",
738 MemLoc.toString memloc, " ",
739 Int.toString weight, " ",
740 Bool.toString sync, " ",
741 commit_toString commit]
742
743 type t = {entries: value list,
744 reserved: Register.t list,
745 fltstack: fltvalue list}
746
747 (*
748 fun unique ({entries, fltstack, ...}: t)
749 = let
750 fun check_entries (entries: value list, res) =
751 case entries of
752 [] => res
753 | ({register, memloc, ...})::entries =>
754 check_entries
755 (entries,
756 List.foldr
757 (entries, res,
758 fn ({register = register',
759 memloc = memloc', ...}, res) =>
760 res
761 andalso (not (Register.coincide (register, register')))
762 andalso (not (MemLoc.eq (memloc, memloc')))))
763 fun check_fltstack (fltstack: fltvalue list, res) =
764 case fltstack of
765 [] => res
766 | ({fltregister, memloc, ...})::fltstack =>
767 check_fltstack
768 (fltstack,
769 List.foldr
770 (fltstack, res,
771 fn ({fltregister = fltregister',
772 memloc = memloc', ...}, res) =>
773 res
774 andalso (not (FltRegister.eq (fltregister, fltregister')))
775 andalso (not (MemLoc.eq (memloc, memloc')))))
776 in
777 check_entries(entries, true)
778 andalso
779 check_fltstack(fltstack, true)
780 end
781 *)
782
783 fun toString ({entries, reserved, fltstack}: t)
784 = let
785 fun doit (name, l, toString, ac)
786 = (name ^ "\n") ^
787 (List.fold(l, ac,
788 fn (x, ac)
789 => (toString x) ^ "\n" ^ ac))
790 in
791 doit("entries:", entries, value_toString,
792 doit("reserved:", reserved, Register.toString,
793 doit("fltstack:", fltstack, fltvalue_toString,
794 "")))
795 end
796
797 fun toComments ({entries, reserved, fltstack}: t)
798 = let
799 fun doit (name, l, toString, ac)
800 = (Assembly.comment name)::
801 (List.fold(l, ac,
802 fn (x, ac)
803 => (Assembly.comment (toString x))::
804 ac))
805 in
806 AppendList.fromList
807 (doit("entries:", entries, value_toString,
808 doit("reserved:", reserved, Register.toString,
809 doit("fltstack:", fltstack, fltvalue_toString,
810 []))))
811 end
812
813 val {get = getRA : Directive.Id.t -> {registerAllocation: t},
814 set = setRA, ...}
815 = Property.getSetOnce
816 (Directive.Id.plist,
817 Property.initRaise ("getRA", fn _ => Layout.empty))
818
819 fun empty () : t
820 = {entries = [],
821 reserved = [],
822 fltstack = []}
823
824 fun reserve' {register: Register.t,
825 registerAllocation = {entries, reserved, fltstack}: t}
826 = {assembly = AppendList.empty,
827 registerAllocation = {entries = entries,
828 reserved = register::reserved,
829 fltstack = fltstack}}
830
831 fun reserve {registers: Register.t list,
832 registerAllocation = {entries, reserved, fltstack}: t}
833 = {assembly = AppendList.empty,
834 registerAllocation = {entries = entries,
835 reserved = registers @ reserved,
836 fltstack = fltstack}}
837
838 fun unreserve' {register: Register.t,
839 registerAllocation = {entries, reserved, fltstack}: t}
840 = {assembly = AppendList.empty,
841 registerAllocation = {entries = entries,
842 reserved = List.revRemoveAll
843 (reserved,
844 fn register'
845 => Register.eq
846 (register',
847 register)),
848 fltstack = fltstack}}
849
850 fun unreserve {registers: Register.t list,
851 registerAllocation = {entries, reserved, fltstack}: t}
852 = {assembly = AppendList.empty,
853 registerAllocation = {entries = entries,
854 reserved = List.revRemoveAll
855 (reserved,
856 fn register'
857 => List.contains
858 (registers,
859 register',
860 Register.eq)),
861 fltstack = fltstack}}
862
863 fun valueMap {map,
864 registerAllocation = {entries,
865 reserved,
866 fltstack}: t}
867 = {entries = List.revMap(entries, map),
868 reserved = reserved,
869 fltstack = fltstack}
870
871 fun valueFilter {filter,
872 registerAllocation = {entries,
873 ...}: t}
874 = List.revKeepAll(entries, filter)
875
876 fun valueRegister {register,
877 registerAllocation}
878 = case valueFilter {filter = fn {register = register', ...}
879 => Register.eq(register, register'),
880 registerAllocation = registerAllocation}
881 of [] => NONE
882 | [value] => SOME value
883 | _ => Error.bug "x86AllocateRegisters.RegisterAllocation.valueRegister"
884
885 fun valuesRegister {register = Register.T {reg, ...},
886 registerAllocation = {entries,
887 ...}: t}
888 = List.revKeepAll(entries,
889 fn {register
890 = Register.T {reg = reg',
891 ...},
892 ...}
893 => reg = reg')
894
895 fun fltvalueMap {map,
896 registerAllocation = {entries,
897 reserved,
898 fltstack}: t}
899 = {entries = entries,
900 reserved = reserved,
901 fltstack = List.map(fltstack, map)}
902
903 fun fltvalueFilter {filter,
904 registerAllocation = {fltstack,
905 ...} :t}
906 = List.keepAll(fltstack, filter)
907
908 fun update {value as {register,...},
909 registerAllocation = {entries, reserved, fltstack}: t}
910 = {entries = let
911 val entries
912 = List.revRemoveAll(entries,
913 fn {register = register',...}
914 => Register.eq(register,register'))
915 in
916 value::entries
917 end,
918 reserved = reserved,
919 fltstack = fltstack}
920
921 fun fltupdate {value as {fltregister, ...},
922 registerAllocation = {entries, reserved, fltstack}: t}
923 = {entries = entries,
924 reserved = reserved,
925 fltstack = let
926 val rec fltupdate'
927 = fn [] => Error.bug "x86AllocateRegisters.RegisterAllocation.fltupdate"
928 | (value' as {fltregister = fltregister', ...})::l
929 => if FltRegister.eq(fltregister, fltregister')
930 then value::l
931 else value'::(fltupdate' l)
932 in
933 fltupdate' fltstack
934 end}
935
936 fun delete {register,
937 registerAllocation = {entries, reserved, fltstack}: t}
938 = {entries = List.revRemoveAll(entries,
939 fn {register = register',...}
940 => Register.eq(register, register')),
941 reserved = reserved,
942 fltstack = fltstack}
943 fun deletes {registers, registerAllocation: t}
944 = List.fold(registers,
945 registerAllocation,
946 fn (register, registerAllocation)
947 => delete {register = register,
948 registerAllocation = registerAllocation})
949
950 fun fltpush {value,
951 registerAllocation = {entries, reserved, fltstack}: t}
952 = {fltrename = FltRegister.push,
953 registerAllocation
954 = {entries = entries,
955 reserved = reserved,
956 fltstack = case #fltregister value
957 of FltRegister.T 0
958 => value::(List.map(fltstack,
959 fn {fltregister
960 = FltRegister.T i,
961 memloc,
962 weight,
963 sync,
964 commit}
965 => {fltregister =
966 FltRegister.T (i + 1),
967 memloc = memloc,
968 weight = weight,
969 sync = sync,
970 commit = commit}))
971 | _ => Error.bug "x86AllocateRegisters.RegisterAllocation.fltpush"}}
972
973 fun fltpop {registerAllocation = {entries, reserved, fltstack}: t}
974 = {fltrename = FltRegister.pop,
975 registerAllocation
976 = {entries = entries,
977 reserved = reserved,
978 fltstack = case fltstack
979 of [] => Error.bug "x86AllocateRegisters.RegisterAllocation.fltpop"
980 | _::fltstack
981 => List.map(fltstack,
982 fn {fltregister = FltRegister.T i,
983 memloc,
984 weight,
985 sync,
986 commit}
987 => {fltregister
988 = FltRegister.T (i - 1),
989 memloc = memloc,
990 weight = weight,
991 sync = sync,
992 commit = commit})}}
993
994 fun fltxch' {fltregister: FltRegister.t,
995 registerAllocation = {entries, reserved, fltstack}: t}
996 = let
997 val rec split
998 = fn (_ : fltvalue list, []) => Error.bug "x86AllocateRegisters.RegisterAllocation.fltxch'.split"
999 | (fltstack_pre,value::fltstack_post)
1000 => if FltRegister.eq(fltregister, #fltregister value)
1001 then (List.rev fltstack_pre, value, fltstack_post)
1002 else split (value::fltstack_pre, fltstack_post)
1003
1004 val (fltstack_pre,
1005 {fltregister = fltregister',
1006 memloc = memloc',
1007 weight = weight',
1008 sync = sync',
1009 commit = commit'},
1010 fltstack_post) = split ([], fltstack)
1011 in
1012 {fltrename = fn fltregister
1013 => if FltRegister.eq(fltregister,
1014 fltregister')
1015 then FltRegister.top
1016 else if FltRegister.eq(fltregister,
1017 FltRegister.top)
1018 then fltregister'
1019 else fltregister,
1020 registerAllocation
1021 = {entries = entries,
1022 reserved = reserved,
1023 fltstack = case fltstack_pre
1024 of [] => Error.bug "x86AllocateRegisters.RegisterAllocation.fltxch'"
1025 | ({fltregister,
1026 memloc,
1027 weight,
1028 sync,
1029 commit})::fltstack_pre
1030 => ({fltregister = fltregister,
1031 memloc = memloc',
1032 weight = weight',
1033 sync = sync',
1034 commit = commit'})::
1035 (List.concat
1036 [fltstack_pre,
1037 ({fltregister = fltregister',
1038 memloc = memloc,
1039 weight = weight,
1040 sync = sync,
1041 commit = commit})::
1042 fltstack_post])}}
1043 end
1044
1045 fun fltxch {value: fltvalue, registerAllocation: t}
1046 = fltxch' {fltregister = #fltregister value,
1047 registerAllocation = registerAllocation}
1048
1049 fun fltxch1 {registerAllocation: t}
1050 = fltxch' {fltregister = FltRegister.one,
1051 registerAllocation = registerAllocation}
1052
1053 fun allocated {memloc,
1054 registerAllocation: t}
1055 = case valueFilter {filter = fn {memloc = memloc',...}
1056 => MemLoc.eq(memloc,memloc'),
1057 registerAllocation = registerAllocation}
1058 of [] => NONE
1059 | [value] => SOME value
1060 | _ => Error.bug "x86AllocateRegisters.RegisterAllocation.allocated"
1061
1062 fun fltallocated {memloc,
1063 registerAllocation: t}
1064 = case fltvalueFilter {filter = fn {memloc = memloc',...}
1065 => MemLoc.eq(memloc,memloc'),
1066 registerAllocation = registerAllocation}
1067 of [] => NONE
1068 | [value] => SOME value
1069 | _ => Error.bug "x86AllocateRegisters.RegisterAllocation.fltallocated"
1070
1071 fun remove {memloc,
1072 registerAllocation: t}
1073 = case allocated {memloc = memloc,
1074 registerAllocation = registerAllocation}
1075 of SOME {register, ...}
1076 => delete {register = register,
1077 registerAllocation = registerAllocation}
1078 | NONE => registerAllocation
1079 fun removes {memlocs,
1080 registerAllocation: t}
1081 = List.fold(memlocs,
1082 registerAllocation,
1083 fn (memloc,registerAllocation)
1084 => remove {memloc = memloc,
1085 registerAllocation = registerAllocation})
1086
1087 local
1088 val commitPush'
1089 = fn NO => NO
1090 | COMMIT i => COMMIT (i + 1)
1091 | REMOVE i => REMOVE (i + 1)
1092 | TRYCOMMIT i => TRYCOMMIT (i + 1)
1093 | TRYREMOVE i => TRYREMOVE (i + 1)
1094
1095 val commitPop'
1096 = fn NO => NO
1097 | COMMIT i => COMMIT (i - 1)
1098 | REMOVE i => REMOVE (i - 1)
1099 | TRYCOMMIT i => TRYCOMMIT (i - 1)
1100 | TRYREMOVE i => TRYREMOVE (i - 1)
1101 in
1102 fun commitPush {registerAllocation: t}
1103 = valueMap {map = fn {register,memloc,weight,sync,commit}
1104 => {register = register,
1105 memloc = memloc,
1106 weight = weight,
1107 sync = sync,
1108 commit = commitPush' commit},
1109 registerAllocation = registerAllocation}
1110
1111 fun commitPop {registerAllocation: t}
1112 = valueMap {map = fn {register,memloc,weight,sync,commit}
1113 => {register = register,
1114 memloc = memloc,
1115 weight = weight,
1116 sync = sync,
1117 commit = commitPop' commit},
1118 registerAllocation = registerAllocation}
1119 end
1120
1121 fun savedRegisters {saves: Operand.t list,
1122 registerAllocation: t} :
1123 Register.t list
1124 = List.concatMap
1125 (saves,
1126 fn Operand.MemLoc m
1127 => (case allocated {memloc = m,
1128 registerAllocation = registerAllocation}
1129 of SOME {register, ...} => [register]
1130 | NONE => [])
1131 | Operand.Register r => [r]
1132 | Operand.Address (Address.T {base, index, ...})
1133 => (case (base, index)
1134 of (NONE, NONE ) => []
1135 | (SOME rb, NONE ) => [rb]
1136 | (NONE, SOME ro) => [ro]
1137 | (SOME rb, SOME ro) => [rb,ro])
1138 | _ => [])
1139
1140 fun supportedRegisters {supports: Operand.t list,
1141 registerAllocation: t} :
1142 Register.t list
1143 = let
1144 fun supportedRegisters' memloc
1145 = case (allocated {memloc = memloc,
1146 registerAllocation = registerAllocation},
1147 fltallocated {memloc = memloc,
1148 registerAllocation = registerAllocation})
1149 of (SOME {register, ...}, _) => [register]
1150 | (_, SOME _) => []
1151 | (NONE, NONE) => List.concatMap(MemLoc.utilized memloc,
1152 supportedRegisters')
1153 in
1154 List.concatMap
1155 (supports,
1156 fn Operand.MemLoc m => supportedRegisters' m
1157 | _ => [])
1158 end
1159
1160 fun supportedMemLocs {supports: Operand.t list,
1161 registerAllocation: t} :
1162 MemLoc.t list
1163 = let
1164 fun supportedMemLocs' memloc
1165 = case (allocated {memloc = memloc,
1166 registerAllocation = registerAllocation},
1167 fltallocated {memloc = memloc,
1168 registerAllocation = registerAllocation})
1169 of (SOME _, _) => [memloc]
1170 | (_, SOME _) => [memloc]
1171 | (NONE, NONE) => List.concatMap(MemLoc.utilized memloc,
1172 supportedMemLocs')
1173 in
1174 List.concatMap
1175 (supports,
1176 fn Operand.MemLoc m => supportedMemLocs' m
1177 | _ => [])
1178 end
1179
1180 fun fltsavedMemLocs {saves: Operand.t list,
1181 registerAllocation: t} :
1182 MemLoc.t list
1183 = List.revKeepAllMap
1184 (saves,
1185 fn Operand.MemLoc m
1186 => (case fltallocated {memloc = m,
1187 registerAllocation = registerAllocation}
1188 of SOME _ => SOME m
1189 | NONE => NONE)
1190 | _ => NONE)
1191
1192 fun fltsupportedMemLocs {supports: Operand.t list,
1193 registerAllocation: t} :
1194 MemLoc.t list
1195 = List.revKeepAllMap
1196 (supports,
1197 fn Operand.MemLoc m
1198 => (case fltallocated {memloc = m,
1199 registerAllocation = registerAllocation}
1200 of SOME _ => SOME m
1201 | NONE => NONE)
1202 | _ => NONE)
1203
1204 fun 'a spillAndReissue {info: Liveness.t,
1205 supports: Operand.t list,
1206 saves: Operand.t list,
1207 registerAllocation: t,
1208 spiller : {info: Liveness.t,
1209 supports: Operand.t list,
1210 saves: Operand.t list,
1211 registerAllocation: t} ->
1212 {assembly: Assembly.t AppendList.t,
1213 registerAllocation: t},
1214 msg : string,
1215 reissue : {assembly: Assembly.t AppendList.t,
1216 registerAllocation: t} -> 'a} : 'a
1217 = (Int.dec depth;
1218 if !depth = 0
1219 then let
1220 val _ = Int.inc depth
1221 val {assembly, registerAllocation}
1222 = spiller
1223 {info = info,
1224 supports = supports,
1225 saves = saves,
1226 registerAllocation = registerAllocation}
1227 val return
1228 = reissue {assembly = assembly,
1229 registerAllocation = registerAllocation}
1230 handle Spill
1231 => (Error.bug (concat [msg, ":reSpill"]))
1232 val _ = Int.dec depth
1233 in
1234 return
1235 end
1236 else raise Spill)
1237
1238 fun potentialRegisters ({size, force, ...}:
1239 {size: Size.t,
1240 saves: Operand.t list,
1241 force: Register.t list,
1242 registerAllocation: t}):
1243 Register.t list
1244 = case force
1245 of [] => Register.registers size
1246 | registers => List.revKeepAll(Register.registers size,
1247 fn register
1248 => List.contains(registers,
1249 register,
1250 Register.eq))
1251
1252 fun chooseRegister {info = {futures = {pre = future, ...},
1253 hint,...}: Liveness.t,
1254 memloc: MemLoc.t option,
1255 size: Size.t,
1256 supports: Operand.t list,
1257 saves: Operand.t list,
1258 force: Register.t list,
1259 registerAllocation as {reserved,...}: t} :
1260 {register: Register.t,
1261 coincide_values: value list}
1262 = let
1263 val registers = potentialRegisters {size = size,
1264 saves = saves,
1265 force = force,
1266 registerAllocation
1267 = registerAllocation}
1268
1269 val saved
1270 = savedRegisters {saves = saves,
1271 registerAllocation = registerAllocation}
1272
1273 val preserved
1274 = let
1275 fun doit(registers, preserved)
1276 = List.fold
1277 (registers,
1278 preserved,
1279 fn (register,preserved)
1280 => if List.contains(preserved,
1281 register,
1282 Register.eq)
1283 then preserved
1284 else register::preserved)
1285 in
1286 doit(saved,
1287 doit(reserved,
1288 []))
1289 end
1290
1291 val registers
1292 = List.revRemoveAll
1293 (registers,
1294 fn register'
1295 => List.exists
1296 (preserved,
1297 fn register''
1298 => Register.coincide(register',register'')))
1299
1300 val supported = supportedRegisters {supports = supports,
1301 registerAllocation
1302 = registerAllocation}
1303
1304 val values = valueFilter {filter = fn _ => true,
1305 registerAllocation = registerAllocation}
1306 val memlocs = List.revMap(values, #memloc)
1307
1308 val registers_costs
1309 = List.revMap
1310 (registers,
1311 fn register'
1312 => let
1313 val hint_cost
1314 = List.fold
1315 (hint,
1316 0,
1317 fn ((hint_register,hint_memlocs,hint_ignore),
1318 hint_cost)
1319 => if Register.eq(register',
1320 hint_register)
1321 then case memloc
1322 of SOME memloc
1323 => (case (List.contains
1324 (hint_memlocs,
1325 memloc,
1326 MemLoc.eq),
1327 MemLocSet.contains
1328 (hint_ignore,
1329 memloc))
1330 of (true, _) => hint_cost + 5
1331 | (false, true) => hint_cost
1332 | (false, false) => hint_cost - 5)
1333 | NONE => hint_cost - 5
1334 else if Register.coincide(register',
1335 hint_register)
1336 then hint_cost - 5
1337 else hint_cost)
1338
1339 val values = valuesRegister {register = register',
1340 registerAllocation
1341 = registerAllocation}
1342 val (support_cost,
1343 commit_cost,
1344 future_cost,
1345 utilized_cost,
1346 sync_cost,
1347 weight_cost)
1348 = List.fold
1349 (values,
1350 (false,false,NONE,0,true,0),
1351 fn ({register,memloc,weight,sync,commit,...},
1352 cost as (support_cost,
1353 commit_cost,
1354 future_cost,
1355 utilized_cost,
1356 sync_cost,
1357 weight_cost))
1358 => if Register.coincide(register,register')
1359 then let
1360 val support_cost'
1361 = List.contains(supported,
1362 register,
1363 Register.eq)
1364
1365 val commit_cost'
1366 = case commit
1367 of TRYREMOVE _ => false
1368 | REMOVE _ => false
1369 | _ => true
1370
1371 val future_cost'
1372 = List.index
1373 (future,
1374 fn Liveness.M (tag, memloc')
1375 => let
1376 val eq = MemLoc.eq(memloc, memloc')
1377 in
1378 case tag
1379 of Liveness.FLIVE => eq
1380 | Liveness.FUSE => eq
1381 | Liveness.FUSEDEF => eq
1382 | _ => false
1383 end
1384 | _ => false)
1385
1386 val utilized_cost'
1387 = List.fold
1388 (memlocs,
1389 0,
1390 fn (memloc',uc')
1391 => List.fold
1392 (MemLoc.utilized memloc',
1393 0,
1394 fn (memloc'',uc'')
1395 => if MemLoc.eq
1396 (memloc,
1397 memloc'')
1398 then uc'' + 1
1399 else uc'') + uc')
1400
1401 val sync_cost' = sync
1402
1403 val weight_cost' = weight
1404 in
1405 (support_cost orelse support_cost',
1406 commit_cost orelse commit_cost',
1407 case (future_cost,future_cost')
1408 of (_, NONE) => future_cost
1409 | (NONE, _) => future_cost'
1410 | (SOME f,SOME f')
1411 => SOME (Int.min(f,f')),
1412 utilized_cost + utilized_cost',
1413 sync_cost andalso sync_cost',
1414 weight_cost + weight_cost')
1415 end
1416 else cost)
1417 in
1418 (register',
1419 (support_cost,
1420 commit_cost,
1421 future_cost,
1422 hint_cost,
1423 utilized_cost,
1424 sync_cost,
1425 weight_cost))
1426 end)
1427
1428 val registers_costs_sorted
1429 = List.insertionSort
1430 (registers_costs,
1431 fn ((_,(support_c1,
1432 commit_c1,
1433 future_c1,
1434 hint_c1,
1435 utilized_c1,
1436 sync_c1,
1437 weight_c1)),
1438 (_,(support_c2,
1439 commit_c2,
1440 future_c2,
1441 hint_c2,
1442 utilized_c2,
1443 sync_c2,
1444 weight_c2)))
1445 => bool_lt(support_c1,support_c2) orelse
1446 (support_c1 = support_c2 andalso
1447 (bool_lt(commit_c1,commit_c2) orelse
1448 (commit_c1 = commit_c2 andalso
1449 (option_lt (op >) (future_c1, future_c2) orelse
1450 (future_c1 = future_c2 andalso
1451 (hint_c1 > hint_c2 orelse
1452 (hint_c1 = hint_c2 andalso
1453 (utilized_c1 < utilized_c2 orelse
1454 (utilized_c1 = utilized_c2 andalso
1455 (bool_gt(sync_c1,sync_c2) orelse
1456 (sync_c1 = sync_c2 andalso
1457 weight_c1 < weight_c2))))))))))))
1458
1459 val registers
1460 = List.map(registers_costs_sorted, #1)
1461
1462 val register
1463 = case registers
1464 of []
1465 (*
1466 => raise Spill
1467 *)
1468 => let
1469 fun listToString(ss: string list): string
1470 = "[" ^ (concat(List.separate(ss, ", "))) ^ "]"
1471
1472 val size = Size.toString size
1473 val supports
1474 = listToString(List.map(supports,Operand.toString))
1475 val saves
1476 = listToString(List.map(saves,Operand.toString))
1477 val force
1478 = listToString(List.map(force,Register.toString))
1479 val reserved
1480 = listToString(List.map(reserved,Register.toString))
1481
1482 val msg = concat["\n",
1483 "chooseRegister:\n",
1484 (toString registerAllocation),
1485 "size = ", size, "\n",
1486 "supports = ", supports, "\n",
1487 "saves = ", saves, "\n",
1488 "force = ", force, "\n",
1489 "reserved = ", reserved, "\n",
1490 "depth = ", Int.toString (!depth), "\n"]
1491
1492 val _ = print msg
1493 in
1494 print "Raising Spill in chooseRegister\n";
1495 raise Spill
1496 end
1497 | register::_ => register
1498
1499 val values = valuesRegister {register = register,
1500 registerAllocation
1501 = registerAllocation}
1502 val coincide_values
1503 = List.revKeepAll(values,
1504 fn {register = register',...}
1505 => Register.coincide(register',register))
1506 in
1507 {register = register,
1508 coincide_values = coincide_values}
1509 end
1510
1511 fun freeRegister ({info: Liveness.t,
1512 memloc: MemLoc.t option,
1513 size: Size.t,
1514 supports: Operand.t list,
1515 saves: Operand.t list,
1516 force: Register.t list,
1517 registerAllocation: t}) :
1518 {register: Register.t,
1519 assembly: Assembly.t AppendList.t,
1520 registerAllocation: t}
1521 = let
1522 val _ = Int.inc depth
1523
1524 val {register = final_register,
1525 coincide_values}
1526 = chooseRegister {info = info,
1527 memloc = memloc,
1528 size = size,
1529 supports = supports,
1530 saves = saves,
1531 force = force,
1532 registerAllocation = registerAllocation}
1533
1534 val supported = supportedMemLocs {supports = supports,
1535 registerAllocation
1536 = registerAllocation}
1537
1538 fun supportRemove memloc
1539 = let
1540 fun supportRemove' memlocs
1541 = List.concatMap
1542 (memlocs,
1543 fn memloc'
1544 => if MemLoc.eq(memloc,memloc')
1545 then []
1546 else supportRemove' (MemLoc.utilized memloc'))
1547 in
1548 List.fold
1549 (supports,
1550 [],
1551 fn (Operand.MemLoc memloc', supports)
1552 => List.concat [(supportRemove' [memloc']), supports]
1553 | (_, supports) => supports)
1554 end
1555
1556 val {assembly = assembly_support,
1557 registerAllocation}
1558 = List.fold
1559 (coincide_values,
1560 {assembly = AppendList.empty,
1561 registerAllocation = registerAllocation},
1562 fn ({memloc,...},
1563 {assembly,
1564 registerAllocation})
1565 => if List.contains(supported,
1566 memloc,
1567 MemLoc.eq)
1568 then let
1569 val supports = supportRemove memloc
1570
1571 val force
1572 = List.revRemoveAll
1573 (Register.registers (MemLoc.size memloc),
1574 fn register'
1575 => Register.coincide(final_register,
1576 register'))
1577
1578 val {assembly = assembly_register,
1579 registerAllocation,
1580 ...}
1581 = toRegisterMemLoc
1582 {memloc = memloc,
1583 info = info,
1584 size = MemLoc.size memloc,
1585 move = true,
1586 supports = supports,
1587 saves = (Operand.register
1588 final_register)::saves,
1589 force = force,
1590 registerAllocation = registerAllocation}
1591 in
1592 {assembly = AppendList.append (assembly,
1593 assembly_register),
1594 registerAllocation = registerAllocation}
1595 end
1596 else {assembly = assembly,
1597 registerAllocation = registerAllocation})
1598
1599 val registerAllocation
1600 = valueMap
1601 {map = fn value as {register,
1602 memloc,
1603 weight,
1604 sync,
1605 ...}
1606 => if Register.coincide(register,
1607 final_register)
1608 then {register = register,
1609 memloc = memloc,
1610 weight = weight,
1611 sync = sync,
1612 commit = REMOVE 0}
1613 else value,
1614 registerAllocation = registerAllocation}
1615
1616 val {assembly = assembly_commit,
1617 registerAllocation}
1618 = commitRegisters {info = info,
1619 supports = supports,
1620 saves = saves,
1621 registerAllocation = registerAllocation}
1622
1623 val _ = Int.dec depth
1624 in
1625 {register = final_register,
1626 assembly = AppendList.appends [assembly_support,
1627 assembly_commit],
1628 registerAllocation = registerAllocation}
1629 end
1630 handle Spill
1631 => spillAndReissue
1632 {info = info,
1633 supports = supports,
1634 saves = saves,
1635 registerAllocation = registerAllocation,
1636 spiller = spillRegisters,
1637 msg = "freeRegister",
1638 reissue = fn {assembly = assembly_spill,
1639 registerAllocation}
1640 => let
1641 val {register, assembly, registerAllocation}
1642 = freeRegister
1643 {info = info,
1644 memloc = memloc,
1645 size = size,
1646 supports = supports,
1647 saves = saves,
1648 force = force,
1649 registerAllocation = registerAllocation}
1650 in
1651 {register = register,
1652 assembly = AppendList.append (assembly_spill,
1653 assembly),
1654 registerAllocation = registerAllocation}
1655 end}
1656
1657 and freeFltRegister {info: Liveness.t,
1658 size: Size.t,
1659 supports: Operand.t list,
1660 saves: Operand.t list,
1661 registerAllocation: t} :
1662 {assembly: Assembly.t AppendList.t,
1663 fltrename: FltRegister.t -> FltRegister.t,
1664 registerAllocation: t}
1665 = let
1666 val info as {futures = {pre = future, ...},...} = info
1667 val values
1668 = fltvalueFilter {filter = fn _ => true,
1669 registerAllocation = registerAllocation}
1670 in
1671 if List.length values >= FltRegister.total
1672 then let
1673 val saved = fltsavedMemLocs {saves = saves,
1674 registerAllocation
1675 = registerAllocation}
1676
1677 val supported = fltsupportedMemLocs {supports = supports,
1678 registerAllocation
1679 = registerAllocation}
1680
1681 val values
1682 = List.revRemoveAll(values,
1683 fn {memloc,...}
1684 => List.contains(saved,
1685 memloc,
1686 MemLoc.eq))
1687
1688 val values_costs
1689 = List.revMap
1690 (values,
1691 fn value as {memloc,weight,sync,commit,...}
1692 => let
1693 val support_cost
1694 = List.contains(supported,
1695 memloc,
1696 MemLoc.eq)
1697
1698 val commit_cost
1699 = case commit
1700 of TRYREMOVE _ => false
1701 | REMOVE _ => false
1702 | _ => true
1703
1704 val future_cost
1705 = List.index
1706 (future,
1707 fn Liveness.M (tag, memloc')
1708 => let
1709 val eq = MemLoc.eq(memloc, memloc')
1710 in
1711 case tag
1712 of Liveness.FLIVE => eq
1713 | Liveness.FUSE => eq
1714 | Liveness.FUSEDEF => eq
1715 | _ => false
1716 end
1717 | _ => false)
1718
1719 val sync_cost = sync
1720
1721 val weight_cost = weight
1722 in
1723 (value,
1724 (support_cost,
1725 commit_cost,
1726 future_cost,
1727 sync_cost,
1728 weight_cost))
1729 end)
1730
1731 val values_costs_sorted
1732 = List.insertionSort
1733 (values_costs,
1734 fn ((_,(support_c1,
1735 commit_c1,
1736 future_c1,
1737 sync_c1,
1738 weight_c1)),
1739 (_,(support_c2,
1740 commit_c2,
1741 future_c2,
1742 sync_c2,
1743 weight_c2)))
1744 => bool_lt(support_c1,support_c2) orelse
1745 (support_c1 = support_c2 andalso
1746 (bool_lt(commit_c1,commit_c2) orelse
1747 (commit_c1 = commit_c2 andalso
1748 (option_lt (op >)
1749 (future_c1, future_c2) orelse
1750 (future_c1 = future_c2 andalso
1751 (bool_gt(sync_c1,sync_c2) orelse
1752 (sync_c1 = sync_c2 andalso
1753 weight_c1 < weight_c2))))))))
1754
1755 val values = List.map(values_costs_sorted, #1)
1756 in
1757 case values
1758 of [] => Error.bug "x86AllocateRegisters.RegisterAllocation.freeFltRegister"
1759 | {fltregister,
1760 memloc,
1761 weight,
1762 sync,
1763 ...}::_
1764 => let
1765 val registerAllocation
1766 = fltupdate {value = {fltregister = fltregister,
1767 memloc = memloc,
1768 weight = weight,
1769 sync = sync,
1770 commit = REMOVE 0},
1771 registerAllocation
1772 = registerAllocation}
1773
1774 val {assembly = assembly_commit,
1775 fltrename = fltrename_commit,
1776 registerAllocation}
1777 = commitFltRegisters {info = info,
1778 supports = supports,
1779 saves = saves,
1780 registerAllocation
1781 = registerAllocation}
1782 in
1783 {assembly = assembly_commit,
1784 fltrename = fltrename_commit,
1785 registerAllocation = registerAllocation}
1786 end
1787 end
1788 else {assembly = AppendList.empty,
1789 fltrename = FltRegister.id,
1790 registerAllocation = registerAllocation}
1791 end
1792 handle Spill
1793 => spillAndReissue
1794 {info = info,
1795 supports = supports,
1796 saves = saves,
1797 registerAllocation = registerAllocation,
1798 spiller = spillRegisters,
1799 msg = "freeFltRegisters",
1800 reissue = fn {assembly = assembly_spill,
1801 registerAllocation}
1802 => let
1803 val {assembly, fltrename, registerAllocation}
1804 = freeFltRegister
1805 {info = info,
1806 size = size,
1807 supports = supports,
1808 saves = saves,
1809 registerAllocation = registerAllocation}
1810 in
1811 {assembly = AppendList.append (assembly_spill,
1812 assembly),
1813 fltrename = fltrename,
1814 registerAllocation = registerAllocation}
1815 end}
1816
1817 and commitRegisters {info: Liveness.t,
1818 supports: Operand.t list,
1819 saves: Operand.t list,
1820 registerAllocation as {reserved,...}: t} :
1821 {assembly: Assembly.t AppendList.t,
1822 registerAllocation: t}
1823 = let
1824 val _ = Int.inc depth
1825 val commit_values
1826 = valueFilter {filter = fn {commit = COMMIT 0, ...} => true
1827 | {commit = REMOVE 0, ...} => true
1828 | {commit = TRYCOMMIT 0, ...} => true
1829 | {commit = TRYREMOVE 0, ...} => true
1830 | _ => false,
1831 registerAllocation = registerAllocation}
1832
1833 val commit_memlocs = List.revMap(commit_values, #memloc)
1834
1835 val commit_memlocs
1836 = totalOrder
1837 (commit_memlocs,
1838 fn (memloc1,memloc2)
1839 => List.contains(MemLoc.utilized memloc1,
1840 memloc2,
1841 MemLoc.eq))
1842
1843 val {assembly = assembly_commit,
1844 registerAllocation}
1845 = List.fold
1846 (commit_memlocs,
1847 {assembly = AppendList.empty,
1848 registerAllocation = registerAllocation},
1849 fn (memloc,
1850 {assembly,
1851 registerAllocation})
1852 => (case allocated {memloc = memloc,
1853 registerAllocation
1854 = registerAllocation}
1855 of NONE => {assembly = assembly,
1856 registerAllocation = registerAllocation}
1857 | SOME ({register,
1858 memloc,
1859 weight,
1860 sync,
1861 commit})
1862 => let
1863 fun doCommitFalse ()
1864 = let
1865 val registerAllocation
1866 = update {value = {register = register,
1867 memloc = memloc,
1868 weight = weight,
1869 sync = true,
1870 commit = NO},
1871 registerAllocation
1872 = registerAllocation}
1873
1874 val registerAllocation
1875 = commitPush {registerAllocation
1876 = registerAllocation}
1877
1878 val commit_saves
1879 = List.removeDuplicates
1880 ((Operand.register register)::saves,
1881 Operand.eq)
1882
1883 val size = Register.size register
1884 val {address,
1885 assembly = assembly_address,
1886 registerAllocation}
1887 = toAddressMemLoc {memloc = memloc,
1888 info = info,
1889 size = size,
1890 supports = supports,
1891 saves = commit_saves,
1892 registerAllocation
1893 = registerAllocation}
1894
1895 val registerAllocation
1896 = commitPop {registerAllocation
1897 = registerAllocation}
1898 in
1899 {assembly
1900 = AppendList.appends
1901 [assembly,
1902 assembly_address,
1903 AppendList.single
1904 (Assembly.instruction_mov
1905 {dst = Operand.Address address,
1906 src = Operand.Register register,
1907 size = size})],
1908 registerAllocation = registerAllocation}
1909 end
1910
1911 fun doCommitTrue ()
1912 = let
1913 val registerAllocation
1914 = update {value = {register = register,
1915 memloc = memloc,
1916 weight = weight,
1917 sync = true,
1918 commit = NO},
1919 registerAllocation
1920 = registerAllocation}
1921 in
1922 {assembly = assembly,
1923 registerAllocation = registerAllocation}
1924 end
1925
1926 fun doRemoveFalse ()
1927 = let
1928 val registerAllocation
1929 = update {value = {register = register,
1930 memloc = memloc,
1931 weight = weight,
1932 sync = true,
1933 commit = NO},
1934 registerAllocation
1935 = registerAllocation}
1936
1937 val registerAllocation
1938 = commitPush {registerAllocation
1939 = registerAllocation}
1940
1941 val commit_saves
1942 = List.removeDuplicates
1943 ((Operand.register register)::saves,
1944 Operand.eq)
1945
1946 val size = Register.size register
1947 val {address,
1948 assembly = assembly_address,
1949 registerAllocation}
1950 = toAddressMemLoc {memloc = memloc,
1951 info = info,
1952 size = size,
1953 supports = supports,
1954 saves = commit_saves,
1955 registerAllocation
1956 = registerAllocation}
1957
1958 val registerAllocation
1959 = commitPop {registerAllocation
1960 = registerAllocation}
1961
1962 val registerAllocation
1963 = if List.contains
1964 (reserved,
1965 register,
1966 Register.eq)
1967 then registerAllocation
1968 else remove {memloc = memloc,
1969 registerAllocation
1970 = registerAllocation}
1971 in
1972 {assembly
1973 = AppendList.appends
1974 [assembly,
1975 assembly_address,
1976 AppendList.single
1977 (Assembly.instruction_mov
1978 {dst = Operand.Address address,
1979 src = Operand.Register register,
1980 size = size})],
1981 registerAllocation = registerAllocation}
1982 end
1983
1984 fun doRemoveTrue ()
1985 = let
1986 val registerAllocation
1987 = update {value = {register = register,
1988 memloc = memloc,
1989 weight = weight,
1990 sync = true,
1991 commit = NO},
1992 registerAllocation
1993 = registerAllocation}
1994
1995 val registerAllocation
1996 = if List.contains
1997 (reserved,
1998 register,
1999 Register.eq)
2000 then registerAllocation
2001 else remove {memloc = memloc,
2002 registerAllocation
2003 = registerAllocation}
2004 in
2005 {assembly = assembly,
2006 registerAllocation = registerAllocation}
2007 end
2008 in
2009 case (commit,sync)
2010 of (COMMIT 0, false) => doCommitFalse ()
2011 | (COMMIT 0, true) => doCommitTrue ()
2012 | (REMOVE 0, false) => doRemoveFalse ()
2013 | (REMOVE 0, true) => doRemoveTrue ()
2014 | (TRYCOMMIT 0, false) => doCommitFalse ()
2015 | (TRYCOMMIT 0, true) => doCommitTrue ()
2016 | (TRYREMOVE 0, false) => doRemoveFalse ()
2017 | (TRYREMOVE 0, true) => doRemoveTrue ()
2018 | _
2019 => Error.bug "x86AllocateRegisters.RegisterAllocation.commitRegisters"
2020 end))
2021 val _ = Int.dec depth
2022 in
2023 {assembly = assembly_commit,
2024 registerAllocation = registerAllocation}
2025 end
2026 handle Spill
2027 => spillAndReissue
2028 {info = info,
2029 supports = supports,
2030 saves = saves,
2031 registerAllocation = registerAllocation,
2032 spiller = spillRegisters,
2033 msg = "commitRegisters",
2034 reissue = fn {assembly = assembly_spill,
2035 registerAllocation}
2036 => let
2037 val {assembly, registerAllocation}
2038 = commitRegisters
2039 {info = info,
2040 supports = supports,
2041 saves = saves,
2042 registerAllocation = registerAllocation}
2043 in
2044 {assembly = AppendList.append (assembly_spill,
2045 assembly),
2046 registerAllocation = registerAllocation}
2047 end}
2048
2049 and commitFltRegisters {info: Liveness.t,
2050 supports: Operand.t list,
2051 saves: Operand.t list,
2052 registerAllocation: t} :
2053 {assembly: Assembly.t AppendList.t,
2054 fltrename: FltRegister.t -> FltRegister.t,
2055 registerAllocation: t}
2056 = let
2057 val _ = Int.inc depth
2058 val commit_values
2059 = fltvalueFilter {filter
2060 = fn {commit = COMMIT 0, ...} => true
2061 | {commit = REMOVE 0, ...} => true
2062 | {commit = TRYCOMMIT 0, ...} => true
2063 | {commit = TRYREMOVE 0, ...} => true
2064 | _ => false,
2065 registerAllocation = registerAllocation}
2066
2067 val {assembly = assembly_commit,
2068 fltrename = fltrename_commit,
2069 registerAllocation}
2070 = List.fold
2071 (commit_values,
2072 {assembly = AppendList.empty,
2073 fltrename = FltRegister.id,
2074 registerAllocation = registerAllocation},
2075 fn ({fltregister,
2076 memloc,
2077 weight,
2078 sync,
2079 commit},
2080 {assembly, fltrename, registerAllocation})
2081 => let
2082 fun doCommitFalse ()
2083 = let
2084 val fltregister = fltrename fltregister
2085 val {assembly = assembly_xch,
2086 fltrename = fltrename_xch,
2087 registerAllocation}
2088 = if FltRegister.eq(fltregister,
2089 FltRegister.top)
2090 then {assembly = AppendList.empty,
2091 fltrename = FltRegister.id,
2092 registerAllocation
2093 = registerAllocation}
2094 else let
2095 val {fltrename = fltrename_xch,
2096 registerAllocation}
2097 = fltxch'
2098 {fltregister = fltregister,
2099 registerAllocation
2100 = registerAllocation}
2101 in
2102 {assembly
2103 = AppendList.single
2104 (Assembly.instruction_fxch
2105 {src = Operand.fltregister
2106 fltregister}),
2107 fltrename = fltrename_xch,
2108 registerAllocation
2109 = registerAllocation}
2110 end
2111
2112 val size = MemLoc.size memloc
2113
2114 val {address,
2115 assembly = assembly_address,
2116 registerAllocation}
2117 = toAddressMemLoc {memloc = memloc,
2118 info = info,
2119 size = size,
2120 supports = supports,
2121 saves = saves,
2122 registerAllocation
2123 = registerAllocation}
2124
2125 val registerAllocation
2126 = fltupdate {value
2127 = {fltregister = FltRegister.top,
2128 memloc = memloc,
2129 weight = weight,
2130 sync = true,
2131 commit = NO},
2132 registerAllocation
2133 = registerAllocation}
2134 in
2135 {assembly
2136 = AppendList.appends
2137 [assembly,
2138 assembly_xch,
2139 assembly_address,
2140 case Size.class size
2141 of Size.FLT
2142 => AppendList.single
2143 (Assembly.instruction_fst
2144 {dst = Operand.Address address,
2145 size = size,
2146 pop = false})
2147 | Size.FPI
2148 => AppendList.single
2149 (Assembly.instruction_fist
2150 {dst = Operand.Address address,
2151 size = size,
2152 pop = false})
2153 | _ => Error.bug "x86AllocateRegisters.RegisterAllocation.commitFltRegisters"],
2154 fltrename
2155 = fltrename_xch o fltrename,
2156 registerAllocation = registerAllocation}
2157 end
2158
2159 fun doCommitTrue ()
2160 = let
2161 val fltregister = fltrename fltregister
2162 val registerAllocation
2163 = fltupdate
2164 {value = {fltregister = fltregister,
2165 memloc = memloc,
2166 weight = weight,
2167 sync = true,
2168 commit = NO},
2169 registerAllocation = registerAllocation}
2170 in
2171 {assembly = assembly,
2172 fltrename = fltrename,
2173 registerAllocation = registerAllocation}
2174 end
2175
2176 fun doRemoveFalse ()
2177 = let
2178 val fltregister = fltrename fltregister
2179 val {assembly = assembly_xch,
2180 fltrename = fltrename_xch,
2181 registerAllocation}
2182 = if FltRegister.eq(fltregister,
2183 FltRegister.top)
2184 then {assembly = AppendList.empty,
2185 fltrename = FltRegister.id,
2186 registerAllocation
2187 = registerAllocation}
2188 else let
2189 val {fltrename = fltrename_xch,
2190 registerAllocation}
2191 = fltxch'
2192 {fltregister = fltregister,
2193 registerAllocation
2194 = registerAllocation}
2195 in
2196 {assembly
2197 = AppendList.single
2198 (Assembly.instruction_fxch
2199 {src = Operand.fltregister
2200 fltregister}),
2201 fltrename = fltrename_xch,
2202 registerAllocation
2203 = registerAllocation}
2204 end
2205
2206 val size = MemLoc.size memloc
2207
2208 val {address,
2209 assembly = assembly_address,
2210 registerAllocation}
2211 = toAddressMemLoc {memloc = memloc,
2212 info = info,
2213 size = size,
2214 supports = supports,
2215 saves = saves,
2216 registerAllocation
2217 = registerAllocation}
2218
2219 val {fltrename = fltrename_pop,
2220 registerAllocation}
2221 = fltpop
2222 {registerAllocation = registerAllocation}
2223 in
2224 {assembly
2225 = AppendList.appends
2226 [assembly,
2227 assembly_xch,
2228 assembly_address,
2229 case Size.class size
2230 of Size.FLT
2231 => AppendList.single
2232 (Assembly.instruction_fst
2233 {dst = Operand.Address address,
2234 size = size,
2235 pop = true})
2236 | Size.FPI
2237 => AppendList.single
2238 (Assembly.instruction_fist
2239 {dst = Operand.Address address,
2240 size = size,
2241 pop = true})
2242 | _ => Error.bug "x86AllocateRegisters.RegisterAllocation.commitFltRegisters"],
2243 fltrename
2244 = fltrename_pop o fltrename_xch o fltrename,
2245 registerAllocation = registerAllocation}
2246 end
2247
2248 fun doRemoveTrue ()
2249 = let
2250 val fltregister = fltrename fltregister
2251 val {assembly = assembly_xch,
2252 fltrename = fltrename_xch,
2253 registerAllocation}
2254 = if FltRegister.eq(fltregister,
2255 FltRegister.top)
2256 then {assembly = AppendList.empty,
2257 fltrename = FltRegister.id,
2258 registerAllocation
2259 = registerAllocation}
2260 else let
2261 val {fltrename = fltrename_xch,
2262 registerAllocation}
2263 = fltxch'
2264 {fltregister = fltregister,
2265 registerAllocation
2266 = registerAllocation}
2267 in
2268 {assembly
2269 = AppendList.single
2270 (Assembly.instruction_fxch
2271 {src = Operand.fltregister
2272 fltregister}),
2273 fltrename = fltrename_xch,
2274 registerAllocation
2275 = registerAllocation}
2276 end
2277
2278 val {fltrename = fltrename_pop,
2279 registerAllocation}
2280 = fltpop {registerAllocation
2281 = registerAllocation}
2282
2283 val size = MemLoc.size memloc
2284 in
2285 {assembly
2286 = AppendList.appends
2287 [assembly,
2288 assembly_xch,
2289 case Size.class size
2290 of Size.FLT
2291 => AppendList.single
2292 (Assembly.instruction_fst
2293 {dst = Operand.fltregister
2294 FltRegister.top,
2295 size = size,
2296 pop = true})
2297 | Size.FPI
2298 => AppendList.single
2299 (Assembly.instruction_fst
2300 {dst = Operand.fltregister
2301 FltRegister.top,
2302 size = Size.DBLE,
2303 pop = true})
2304 | _ => Error.bug "x86AllocateRegisters.RegisterAllocation.commitFltRegisters"],
2305 fltrename = fltrename_pop o fltrename_xch o fltrename,
2306 registerAllocation = registerAllocation}
2307 end
2308
2309 fun doNothing ()
2310 = {assembly = assembly,
2311 fltrename = fltrename,
2312 registerAllocation = registerAllocation}
2313 in
2314 case (commit,sync)
2315 of (COMMIT 0, false) => doCommitFalse ()
2316 | (COMMIT 0, true) => doCommitTrue ()
2317 | (REMOVE 0, false) => doRemoveFalse ()
2318 | (REMOVE 0, true) => doRemoveTrue ()
2319 | (TRYCOMMIT 0, false)
2320 => if FltRegister.eq(fltrename fltregister,
2321 FltRegister.top)
2322 then doCommitFalse ()
2323 else doNothing ()
2324 | (TRYCOMMIT 0, true)
2325 => if FltRegister.eq(fltrename fltregister,
2326 FltRegister.top)
2327 then doCommitTrue ()
2328 else doNothing ()
2329 | (TRYREMOVE 0, false)
2330 => if FltRegister.eq(fltrename fltregister,
2331 FltRegister.top)
2332 then doRemoveFalse ()
2333 else doNothing ()
2334 | (TRYREMOVE 0, true)
2335 => if FltRegister.eq(fltrename fltregister,
2336 FltRegister.top)
2337 then doRemoveTrue ()
2338 else doNothing ()
2339 | _ => Error.bug "x86AllocateRegisters.RegisterAllocation.commitFltRegisters"
2340 end)
2341
2342 val _ = Int.dec depth
2343 in
2344 {assembly = assembly_commit,
2345 fltrename = fltrename_commit,
2346 registerAllocation = registerAllocation}
2347 end
2348 handle Spill
2349 => spillAndReissue
2350 {info = info,
2351 supports = supports,
2352 saves = saves,
2353 registerAllocation = registerAllocation,
2354 spiller = spillRegisters,
2355 msg = "commitFltRegisters",
2356 reissue = fn {assembly = assembly_spill,
2357 registerAllocation}
2358 => let
2359 val {assembly, fltrename, registerAllocation}
2360 = commitFltRegisters
2361 {info = info,
2362 supports = supports,
2363 saves = saves,
2364 registerAllocation = registerAllocation}
2365 in
2366 {assembly = AppendList.append (assembly_spill,
2367 assembly),
2368 fltrename = fltrename,
2369 registerAllocation = registerAllocation}
2370 end}
2371
2372 and spillRegisters {info: Liveness.t,
2373 supports: Operand.t list,
2374 saves: Operand.t list,
2375 registerAllocation} :
2376 {assembly: Assembly.t AppendList.t,
2377 registerAllocation: t}
2378 = let
2379 val _ = Int.inc depth
2380 val spillStart = !spill
2381
2382 val {reserved, ...} = registerAllocation
2383 val {assembly = assembly_unreserve,
2384 registerAllocation}
2385 = List.fold
2386 (reserved,
2387 {assembly = AppendList.empty,
2388 registerAllocation = registerAllocation},
2389 fn (register,
2390 {assembly, registerAllocation})
2391 => let
2392 val {assembly = assembly_unreserve,
2393 registerAllocation}
2394 = unreserve'
2395 {register = register,
2396 registerAllocation = registerAllocation}
2397 in
2398 {assembly = AppendList.append (assembly,
2399 assembly_unreserve),
2400 registerAllocation = registerAllocation}
2401 end)
2402
2403 val saved = savedRegisters {saves = saves,
2404 registerAllocation = registerAllocation}
2405
2406 val saved = List.fold
2407 (reserved,
2408 saved,
2409 fn (register,saved)
2410 => if List.contains(saved,register,Register.eq)
2411 then saved
2412 else register::saved)
2413
2414 val saves = valueFilter
2415 {filter = fn {register, ...}
2416 => List.contains(saved,
2417 register,
2418 Register.eq),
2419 registerAllocation = registerAllocation}
2420
2421 val all = valueFilter
2422 {filter = fn _ => true,
2423 registerAllocation = registerAllocation}
2424
2425 (* partition the values in the register file
2426 * by their base register.
2427 *)
2428 val groups = partition (all,
2429 fn ({register = Register.T {reg = reg1, ...},...},
2430 {register = Register.T {reg = reg2, ...},...})
2431 => reg1 = reg2)
2432
2433 (* order the groups by number of registers used
2434 *)
2435 val groups
2436 = List.insertionSort
2437 (groups,
2438 fn (g1,g2) => (List.length g1) < (List.length g2))
2439
2440 (* choose four registers to spill
2441 *)
2442 val spills
2443 = case groups
2444 of g1::g2::g3::g4::_ => List.concat [g1,g2,g3,g4]
2445 | _ => Error.bug "x86AllocateRegisters.RegisterAllocation.spillRegisters"
2446
2447 (* totally order the spills by utilization
2448 *)
2449 val spills
2450 = totalOrder
2451 (spills,
2452 fn ({memloc = memloc1, ...},
2453 {memloc = memloc2, ...})
2454 => List.contains(MemLoc.utilized memloc2,
2455 memloc1,
2456 MemLoc.eq))
2457
2458 fun mkReplacer (spillMap : (value * MemLoc.t) list)
2459 = fn memloc'
2460 => case List.peek(spillMap, fn ({memloc,...},_)
2461 => MemLoc.eq(memloc,memloc'))
2462 of SOME (_,spillMemloc) => spillMemloc
2463 | NONE => memloc'
2464
2465 (* associate each spilled value with a spill slot
2466 *)
2467 val (spillMap, spillEnd)
2468 = List.fold
2469 (spills,
2470 ([], spillStart),
2471 fn (value as {memloc, ...},
2472 (spillMap, spillEnd))
2473 => let
2474 val spillMemLoc
2475 = MemLoc.imm {base = Immediate.label spillLabel,
2476 index = Immediate.int spillEnd,
2477 scale = x86MLton.wordScale,
2478 size = MemLoc.size memloc,
2479 class = x86MLton.Classes.Temp}
2480 in
2481 ((value,spillMemLoc)::spillMap,
2482 spillEnd + 1)
2483 end)
2484
2485 val replacer = mkReplacer spillMap
2486
2487 (* commit everything in the register file;
2488 * also replace all memlocs that are spilled with their spill slot
2489 *)
2490 val registerAllocation
2491 = valueMap {map = fn {register, memloc, weight, sync, commit}
2492 => if List.exists
2493 (spillMap,
2494 fn ({memloc = memloc',...},_)
2495 => MemLoc.eq(memloc,memloc'))
2496 then {register = register,
2497 memloc = MemLoc.replace replacer memloc,
2498 weight = weight,
2499 sync = false,
2500 commit = NO}
2501 else {register = register,
2502 memloc = MemLoc.replace replacer memloc,
2503 weight = weight,
2504 sync = sync,
2505 commit = case commit
2506 of NO => COMMIT 0
2507 | COMMIT _ => COMMIT 0
2508 | TRYCOMMIT _ => COMMIT 0
2509 | REMOVE _ => REMOVE 0
2510 | TRYREMOVE _ => REMOVE 0},
2511 registerAllocation = registerAllocation}
2512
2513 (* update next available spill slot for cascading spills *)
2514 val _ = spill := spillEnd
2515 (* commit everything;
2516 * since the spilt memlocs look like they are spill slots,
2517 * they can all be committed to memory without any additional
2518 * registers.
2519 *)
2520 val {assembly = assembly_commit1,
2521 registerAllocation = registerAllocation}
2522 = commitRegisters
2523 {info = info,
2524 supports = [],
2525 saves = [],
2526 registerAllocation = registerAllocation}
2527
2528 (* unspill; as we pull values in, we update the memloc to what it
2529 * looks under the pending unspills, and then replace any occurences
2530 * of the spill slot with the updated memloc;
2531 * by the time we are done, everything should be mapped back to
2532 * its original form.
2533 *)
2534 val {assembly = assembly_unspill,
2535 registerAllocation = registerAllocation}
2536 = let
2537 val rec doit
2538 = fn ([],{assembly,registerAllocation})
2539 => {assembly = assembly,
2540 registerAllocation = registerAllocation}
2541 | (({memloc, weight, sync, commit, ...},
2542 spillMemLoc)::spillMap,
2543 {assembly, registerAllocation})
2544 => let
2545 val replacer = mkReplacer spillMap
2546 val memloc' = MemLoc.replace replacer memloc
2547
2548 val {register,
2549 assembly = assembly_unspill,
2550 registerAllocation}
2551 = toRegisterMemLoc
2552 {memloc = spillMemLoc,
2553 info = info,
2554 size = MemLoc.size memloc,
2555 move = true,
2556 supports = [],
2557 saves = [],
2558 force = [],
2559 registerAllocation = registerAllocation}
2560 val registerAllocation
2561 = update {value = {register = register,
2562 memloc = memloc',
2563 weight = weight,
2564 sync = sync,
2565 commit
2566 = case commit
2567 of NO => COMMIT 0
2568 | COMMIT _ => COMMIT 0
2569 | TRYCOMMIT _ => COMMIT 0
2570 | REMOVE _ => REMOVE 0
2571 | TRYREMOVE _ => REMOVE 0},
2572 registerAllocation = registerAllocation}
2573
2574 val registerAllocation
2575 = valueMap
2576 {map = fn {register,
2577 memloc,
2578 weight,
2579 sync,
2580 commit}
2581 => {register = register,
2582 memloc = MemLoc.replace
2583 (fn memloc'' => if MemLoc.eq
2584 (memloc'',
2585 spillMemLoc)
2586 then memloc'
2587 else memloc'')
2588 memloc,
2589 weight = weight,
2590 sync = sync,
2591 commit = commit},
2592 registerAllocation = registerAllocation}
2593
2594 in
2595 doit(spillMap,
2596 {assembly = AppendList.append (assembly,
2597 assembly_unspill),
2598 registerAllocation = registerAllocation})
2599 end
2600 in
2601 doit(spillMap,
2602 {assembly = AppendList.empty,
2603 registerAllocation = registerAllocation})
2604 end
2605 (* everything is unspilled *)
2606 val _ = spill := spillStart
2607
2608 (* commit all the memlocs that got spilled.
2609 *)
2610 val {assembly = assembly_commit2,
2611 registerAllocation = registerAllocation}
2612 = commitRegisters
2613 {info = info,
2614 supports = [],
2615 saves = [],
2616 registerAllocation = registerAllocation}
2617 val _ = spill := spillStart
2618
2619 (* restore the saved operands to their previous locations.
2620 *)
2621 val {assembly = assembly_restore,
2622 registerAllocation}
2623 = List.fold
2624 (saves,
2625 {assembly = AppendList.empty,
2626 registerAllocation = registerAllocation},
2627 fn ({register, memloc, weight, commit, ...},
2628 {assembly, registerAllocation})
2629 => let
2630 val {assembly = assembly_register,
2631 registerAllocation,
2632 ...}
2633 = toRegisterMemLoc
2634 {memloc = memloc,
2635 info = info,
2636 size = Register.size register,
2637 move = true,
2638 supports = supports,
2639 saves = [],
2640 force = [register],
2641 registerAllocation = registerAllocation}
2642 val registerAllocation
2643 = update {value = {register = register,
2644 memloc = memloc,
2645 weight = weight,
2646 sync = true,
2647 commit = commit},
2648 registerAllocation = registerAllocation}
2649 val {assembly = assembly_reserve,
2650 registerAllocation}
2651 = reserve' {register = register,
2652 registerAllocation = registerAllocation}
2653 in
2654 {assembly = AppendList.appends [assembly,
2655 assembly_register,
2656 assembly_reserve],
2657 registerAllocation = registerAllocation}
2658 end)
2659 val {assembly = assembly_unreserve',
2660 registerAllocation}
2661 = List.fold
2662 (saved,
2663 {assembly = AppendList.empty,
2664 registerAllocation = registerAllocation},
2665 fn (register,
2666 {assembly, registerAllocation})
2667 => let
2668 val {assembly = assembly_unreserve',
2669 registerAllocation}
2670 = unreserve'
2671 {register = register,
2672 registerAllocation = registerAllocation}
2673 in
2674 {assembly = AppendList.append (assembly,
2675 assembly_unreserve'),
2676 registerAllocation = registerAllocation}
2677 end)
2678 val {assembly = assembly_reserve,
2679 registerAllocation}
2680 = List.fold
2681 (reserved,
2682 {assembly = AppendList.empty,
2683 registerAllocation = registerAllocation},
2684 fn (register,
2685 {assembly, registerAllocation})
2686 => let
2687 val {assembly = assembly_reserve,
2688 registerAllocation}
2689 = reserve'
2690 {register = register,
2691 registerAllocation = registerAllocation}
2692 in
2693 {assembly = AppendList.append (assembly,
2694 assembly_reserve),
2695 registerAllocation = registerAllocation}
2696 end)
2697
2698 val _ = Int.dec depth
2699 in
2700 {assembly = AppendList.appends [assembly_unreserve,
2701 assembly_commit1,
2702 assembly_unspill,
2703 assembly_commit2,
2704 assembly_restore,
2705 assembly_unreserve',
2706 assembly_reserve],
2707 registerAllocation = registerAllocation}
2708 end
2709
2710 and toRegisterMemLoc {memloc: MemLoc.t,
2711 info: Liveness.t,
2712 size: Size.t,
2713 move: bool,
2714 supports: Operand.t list,
2715 saves: Operand.t list,
2716 force: Register.t list,
2717 registerAllocation: t} :
2718 {register: Register.t,
2719 assembly: Assembly.t AppendList.t,
2720 registerAllocation: t}
2721 = (Int.inc depth;
2722 (case allocated {memloc = memloc,
2723 registerAllocation = registerAllocation}
2724 of SOME {register,memloc,weight,sync,commit}
2725 => let
2726 val registers
2727 = potentialRegisters {size = size,
2728 saves = saves,
2729 force = force,
2730 registerAllocation
2731 = registerAllocation}
2732 in
2733 if List.contains(registers, register, Register.eq)
2734 then {register = register,
2735 assembly = AppendList.empty,
2736 registerAllocation = registerAllocation}
2737 else let
2738 val {register = final_register,
2739 coincide_values}
2740 = chooseRegister
2741 {info = info,
2742 memloc = SOME memloc,
2743 size = size,
2744 supports = supports,
2745 saves = (Operand.register register)::saves,
2746 force = force,
2747 registerAllocation = registerAllocation}
2748
2749 val {memloc,
2750 sync,
2751 registerAllocation}
2752 = if List.contains(saves,
2753 Operand.register final_register,
2754 Operand.eq)
2755 orelse
2756 List.contains(saves,
2757 Operand.memloc memloc,
2758 Operand.eq)
2759 then {memloc
2760 = MemLoc.imm
2761 {base = Immediate.label
2762 (Label.fromString "BUG"),
2763 index = Immediate.zero,
2764 scale = Scale.One,
2765 size = MemLoc.size memloc,
2766 class = MemLoc.Class.Temp},
2767 sync = true,
2768 registerAllocation
2769 = registerAllocation}
2770 else {memloc = memloc,
2771 sync = sync,
2772 registerAllocation
2773 = delete {register = register,
2774 registerAllocation
2775 = registerAllocation}}
2776 in
2777 case coincide_values
2778 of []
2779 => if move
2780 then let
2781 val registerAllocation
2782 = update {value
2783 = {register
2784 = final_register,
2785 memloc = memloc,
2786 weight = weight,
2787 sync = sync,
2788 commit = commit},
2789 registerAllocation
2790 = registerAllocation}
2791 in
2792 {register = final_register,
2793 assembly
2794 = AppendList.single
2795 (Assembly.instruction_mov
2796 {src = Operand.register register,
2797 dst = Operand.register
2798 final_register,
2799 size = size}),
2800 registerAllocation
2801 = registerAllocation}
2802 end
2803 else let
2804 val registerAllocation
2805 = update {value
2806 = {register
2807 = final_register,
2808 memloc = memloc,
2809 weight = weight,
2810 sync = true,
2811 commit = commit},
2812 registerAllocation
2813 = registerAllocation}
2814 in
2815 {register = final_register,
2816 assembly = AppendList.empty,
2817 registerAllocation
2818 = registerAllocation}
2819 end
2820 | [{register = register',
2821 memloc = memloc',
2822 weight = weight',
2823 sync = sync',
2824 commit = commit'}]
2825 => if Register.eq(register',final_register)
2826 then let
2827 val registerAllocation
2828 = delete {register
2829 = register',
2830 registerAllocation
2831 = registerAllocation}
2832 val registerAllocation
2833 = update {value
2834 = {register
2835 = register,
2836 memloc = memloc',
2837 weight = weight',
2838 sync = sync',
2839 commit = commit'},
2840 registerAllocation
2841 = registerAllocation}
2842 in
2843 if move
2844 then let
2845 val registerAllocation
2846 = update
2847 {value
2848 = {register
2849 = final_register,
2850 memloc = memloc,
2851 weight = weight,
2852 sync = sync,
2853 commit = commit},
2854 registerAllocation
2855 = registerAllocation}
2856 in
2857 {register = final_register,
2858 assembly
2859 = AppendList.single
2860 (Assembly.instruction_xchg
2861 {src = Operand.register
2862 register,
2863 dst = Operand.register
2864 final_register,
2865 size = size}),
2866 registerAllocation
2867 = registerAllocation}
2868 end
2869 else let
2870 val registerAllocation
2871 = update
2872 {value
2873 = {register
2874 = final_register,
2875 memloc = memloc,
2876 weight = weight,
2877 sync = true,
2878 commit = commit},
2879 registerAllocation
2880 = registerAllocation}
2881 in
2882 {register = final_register,
2883 assembly
2884 = AppendList.single
2885 (Assembly.instruction_mov
2886 {src = Operand.register
2887 final_register,
2888 dst = Operand.register
2889 register,
2890 size = size}),
2891 registerAllocation
2892 = registerAllocation}
2893 end
2894 end
2895 else let
2896 val {register = final_register,
2897 assembly = assembly_register,
2898 registerAllocation}
2899 = freeRegister
2900 {info = info,
2901 memloc = SOME memloc,
2902 size = size,
2903 supports = supports,
2904 saves = (Operand.register
2905 register)::saves,
2906 force = force,
2907 registerAllocation
2908 = registerAllocation}
2909 val registerAllocation
2910 = remove
2911 {memloc = memloc,
2912 registerAllocation
2913 = registerAllocation}
2914 in
2915 if move
2916 then let
2917 val registerAllocation
2918 = update
2919 {value
2920 = {register
2921 = final_register,
2922 memloc = memloc,
2923 weight = weight,
2924 sync = sync,
2925 commit = commit},
2926 registerAllocation
2927 = registerAllocation}
2928 in
2929 {register = final_register,
2930 assembly
2931 = AppendList.appends
2932 [assembly_register,
2933 AppendList.single
2934 (Assembly.instruction_mov
2935 {src = Operand.register
2936 register,
2937 dst = Operand.register
2938 final_register,
2939 size = size})],
2940 registerAllocation
2941 = registerAllocation}
2942 end
2943 else let
2944 val registerAllocation
2945 = update
2946 {value
2947 = {register
2948 = final_register,
2949 memloc = memloc,
2950 weight = weight,
2951 sync = true,
2952 commit = commit},
2953 registerAllocation
2954 = registerAllocation}
2955 in
2956 {register = final_register,
2957 assembly
2958 = assembly_register,
2959 registerAllocation
2960 = registerAllocation}
2961 end
2962 end
2963 | _
2964 => let
2965 val {register = final_register,
2966 assembly = assembly_register,
2967 registerAllocation}
2968 = freeRegister {info = info,
2969 memloc = SOME memloc,
2970 size = size,
2971 supports = supports,
2972 saves = (Operand.register
2973 register)::saves,
2974 force = force,
2975 registerAllocation
2976 = registerAllocation}
2977 val registerAllocation
2978 = remove {memloc = memloc,
2979 registerAllocation
2980 = registerAllocation}
2981 in
2982 if move
2983 then let
2984 val registerAllocation
2985 = update {value
2986 = {register
2987 = final_register,
2988 memloc = memloc,
2989 weight = weight,
2990 sync = sync,
2991 commit = commit},
2992 registerAllocation
2993 = registerAllocation}
2994 in
2995 {register = final_register,
2996 assembly
2997 = AppendList.appends
2998 [assembly_register,
2999 AppendList.single
3000 (Assembly.instruction_mov
3001 {src = Operand.register
3002 register,
3003 dst = Operand.register
3004 final_register,
3005 size = size})],
3006 registerAllocation
3007 = registerAllocation}
3008 end
3009 else let
3010 val registerAllocation
3011 = update {value
3012 = {register
3013 = final_register,
3014 memloc = memloc,
3015 weight = weight,
3016 sync = true,
3017 commit = commit},
3018 registerAllocation
3019 = registerAllocation}
3020 in
3021 {register = final_register,
3022 assembly
3023 = assembly_register,
3024 registerAllocation
3025 = registerAllocation}
3026 end
3027 end
3028 end
3029
3030 end
3031 | NONE
3032 => if move
3033 then case MemLoc.size memloc
3034 of Size.BYTE
3035 => let
3036 val {register = register',
3037 assembly = assembly_register,
3038 registerAllocation}
3039 = freeRegister
3040 {info = info,
3041 memloc = SOME memloc,
3042 size = size,
3043 supports = (Operand.memloc memloc)::
3044 supports,
3045 saves = saves,
3046 force = [],
3047 registerAllocation
3048 = registerAllocation}
3049
3050 val {address,
3051 assembly = assembly_address,
3052 registerAllocation}
3053 = toAddressMemLoc
3054 {memloc = memloc,
3055 info = info,
3056 size = size,
3057 supports = supports,
3058 saves = (Operand.register register')::
3059 saves,
3060 registerAllocation = registerAllocation}
3061
3062
3063 val registerAllocation
3064 = remove
3065 {memloc = memloc,
3066 registerAllocation = registerAllocation}
3067
3068 val registerAllocation
3069 = update
3070 {value = {register = register',
3071 memloc = memloc,
3072 weight = 1024,
3073 sync = true,
3074 commit = NO},
3075 registerAllocation = registerAllocation}
3076
3077 val {register,
3078 assembly = assembly_force,
3079 registerAllocation}
3080 = toRegisterMemLoc
3081 {memloc = memloc,
3082 info = info,
3083 size = size,
3084 move = move,
3085 supports = supports,
3086 saves = saves,
3087 force = force,
3088 registerAllocation = registerAllocation}
3089
3090 in
3091 {register = register,
3092 assembly
3093 = AppendList.appends
3094 [assembly_register,
3095 assembly_address,
3096 AppendList.single
3097 (Assembly.instruction_mov
3098 {dst = Operand.register register',
3099 src = Operand.address address,
3100 size = size}),
3101 assembly_force],
3102 registerAllocation = registerAllocation}
3103 end
3104 | _
3105 => let
3106 val {address,
3107 assembly = assembly_address,
3108 registerAllocation}
3109 = toAddressMemLoc
3110 {memloc = memloc,
3111 info = info,
3112 size = size,
3113 supports = supports,
3114 saves = saves,
3115 registerAllocation = registerAllocation}
3116
3117 val saves'
3118 = case address
3119 of Address.T {base = SOME base',
3120 index = SOME index',
3121 ...}
3122 => (Operand.register base')::
3123 (Operand.register index')::saves
3124 | Address.T {base = SOME base',
3125 ...}
3126 => (Operand.register base')::saves
3127 | Address.T {index = SOME index',
3128 ...}
3129 => (Operand.register index')::saves
3130 | _ => saves
3131
3132 val {register = register',
3133 assembly = assembly_register,
3134 registerAllocation}
3135 = freeRegister
3136 {info = info,
3137 memloc = SOME memloc,
3138 size = size,
3139 supports = supports,
3140 saves = saves',
3141 force = [],
3142 registerAllocation = registerAllocation}
3143
3144 val registerAllocation
3145 = remove
3146 {memloc = memloc,
3147 registerAllocation = registerAllocation}
3148
3149 val registerAllocation
3150 = update
3151 {value = {register = register',
3152 memloc = memloc,
3153 weight = 1024,
3154 sync = true,
3155 commit = NO},
3156 registerAllocation = registerAllocation}
3157
3158 val {register,
3159 assembly = assembly_force,
3160 registerAllocation}
3161 = toRegisterMemLoc
3162 {memloc = memloc,
3163 info = info,
3164 size = size,
3165 move = move,
3166 supports = supports,
3167 saves = saves,
3168 force = force,
3169 registerAllocation = registerAllocation}
3170
3171 in
3172 {register = register,
3173 assembly
3174 = AppendList.appends
3175 [assembly_address,
3176 assembly_register,
3177 AppendList.single
3178 (Assembly.instruction_mov
3179 {dst = Operand.register register',
3180 src = Operand.address address,
3181 size = size}),
3182 assembly_force],
3183 registerAllocation = registerAllocation}
3184 end
3185 else let
3186 val {register,
3187 assembly = assembly_register,
3188 registerAllocation}
3189 = freeRegister {info = info,
3190 memloc = SOME memloc,
3191 size = size,
3192 supports = supports,
3193 saves = saves,
3194 force = force,
3195 registerAllocation
3196 = registerAllocation}
3197 val registerAllocation
3198 = remove {memloc = memloc,
3199 registerAllocation = registerAllocation}
3200
3201 val registerAllocation
3202 = update {value = {register = register,
3203 memloc = memloc,
3204 weight = 1024,
3205 sync = true,
3206 commit = NO},
3207 registerAllocation = registerAllocation}
3208 in
3209 {register = register,
3210 assembly = assembly_register,
3211 registerAllocation = registerAllocation}
3212 end)
3213 before (Int.dec depth))
3214 handle Spill
3215 => spillAndReissue
3216 {info = info,
3217 supports = supports,
3218 saves = saves,
3219 registerAllocation = registerAllocation,
3220 spiller = spillRegisters,
3221 msg = "toRegisterMemLoc",
3222 reissue = fn {assembly = assembly_spill,
3223 registerAllocation}
3224 => let
3225 val {register, assembly, registerAllocation}
3226 = toRegisterMemLoc
3227 {memloc = memloc,
3228 info = info,
3229 size = size,
3230 move = move,
3231 supports = supports,
3232 saves = saves,
3233 force = force,
3234 registerAllocation = registerAllocation}
3235 in
3236 {register = register,
3237 assembly = AppendList.append (assembly_spill,
3238 assembly),
3239 registerAllocation = registerAllocation}
3240 end}
3241
3242 and toFltRegisterMemLoc {memloc: MemLoc.t,
3243 info: Liveness.t,
3244 size: Size.t,
3245 move: bool,
3246 supports: Operand.t list,
3247 saves: Operand.t list,
3248 top: bool option,
3249 registerAllocation: t} :
3250 {fltregister: FltRegister.t,
3251 assembly: Assembly.t AppendList.t,
3252 fltrename : FltRegister.t -> FltRegister.t,
3253 registerAllocation: t}
3254 = (Int.inc depth;
3255 (case fltallocated {memloc = memloc,
3256 registerAllocation = registerAllocation}
3257 of SOME (value as {fltregister,memloc,weight,sync,commit})
3258 => (case (FltRegister.eq(fltregister, FltRegister.top),
3259 top)
3260 of (true, NONE)
3261 => let
3262 val {fltrename = fltrename_pop,
3263 registerAllocation}
3264 = fltpop {registerAllocation
3265 = registerAllocation}
3266 val assembly_pop
3267 = AppendList.single
3268 (Assembly.instruction_fst
3269 {dst = Operand.fltregister FltRegister.top,
3270 size = size,
3271 pop = true})
3272
3273 val {registerAllocation,
3274 ...}
3275 = fltpush {value = {fltregister = FltRegister.top,
3276 memloc = memloc,
3277 weight = weight,
3278 sync = sync,
3279 commit = commit},
3280 registerAllocation = registerAllocation}
3281 in
3282 {fltregister = FltRegister.top,
3283 assembly = assembly_pop,
3284 fltrename = fltrename_pop,
3285 registerAllocation = registerAllocation}
3286 end
3287 | (false, NONE)
3288 => let
3289 val {fltrename = fltrename_xch,
3290 registerAllocation}
3291 = fltxch {value = value,
3292 registerAllocation
3293 = registerAllocation}
3294 val assembly_xch
3295 = AppendList.single
3296 (Assembly.instruction_fxch
3297 {src = Operand.fltregister fltregister})
3298
3299 val {fltrename = fltrename_pop,
3300 registerAllocation}
3301 = fltpop {registerAllocation
3302 = registerAllocation}
3303 val assembly_pop
3304 = AppendList.single
3305 (Assembly.instruction_fst
3306 {dst = Operand.fltregister FltRegister.top,
3307 size = size,
3308 pop = true})
3309
3310 val {registerAllocation,
3311 ...}
3312 = fltpush {value = {fltregister = FltRegister.top,
3313 memloc = memloc,
3314 weight = weight,
3315 sync = sync,
3316 commit = commit},
3317 registerAllocation = registerAllocation}
3318 in
3319 {fltregister = FltRegister.top,
3320 assembly = AppendList.append (assembly_xch,
3321 assembly_pop),
3322 fltrename = fltrename_pop o fltrename_xch,
3323 registerAllocation = registerAllocation}
3324 end
3325 | (false, SOME true)
3326 => let
3327 val {fltrename = fltrename_xch,
3328 registerAllocation}
3329 = fltxch {value = value,
3330 registerAllocation
3331 = registerAllocation}
3332 val assembly_xch
3333 = AppendList.single
3334 (Assembly.instruction_fxch
3335 {src = Operand.fltregister fltregister})
3336 in
3337 {fltregister = FltRegister.top,
3338 assembly = assembly_xch,
3339 fltrename = fltrename_xch,
3340 registerAllocation = registerAllocation}
3341 end
3342 | (_, SOME _)
3343 => {fltregister = fltregister,
3344 assembly = AppendList.empty,
3345 fltrename = FltRegister.id,
3346 registerAllocation = registerAllocation})
3347 | NONE
3348 => (case (top, move)
3349 of (NONE, _)
3350 => let
3351 val {assembly = assembly_free,
3352 fltrename = fltrename_free,
3353 registerAllocation
3354 = registerAllocation}
3355 = freeFltRegister {info = info,
3356 size = size,
3357 supports = supports,
3358 saves = saves,
3359 registerAllocation
3360 = registerAllocation}
3361
3362 val {registerAllocation,
3363 ...}
3364 = fltpush {value = {fltregister = FltRegister.top,
3365 memloc = memloc,
3366 weight = 1024,
3367 sync = true,
3368 commit = NO},
3369 registerAllocation = registerAllocation}
3370 in
3371 {fltregister = FltRegister.top,
3372 assembly = assembly_free,
3373 fltrename = fltrename_free,
3374 registerAllocation = registerAllocation}
3375 end
3376 | (SOME _, true)
3377 => let
3378 val {assembly = assembly_free,
3379 fltrename = fltrename_free,
3380 registerAllocation
3381 = registerAllocation}
3382 = freeFltRegister {info = info,
3383 size = size,
3384 supports = supports,
3385 saves = saves,
3386 registerAllocation
3387 = registerAllocation}
3388
3389 val {address,
3390 assembly = assembly_address,
3391 registerAllocation}
3392 = toAddressMemLoc {memloc = memloc,
3393 info = info,
3394 size = size,
3395 supports = supports,
3396 saves = saves,
3397 registerAllocation
3398 = registerAllocation}
3399
3400 val {fltrename = fltrename_push,
3401 registerAllocation}
3402 = fltpush {value = {fltregister = FltRegister.top,
3403 memloc = memloc,
3404 weight = 1024,
3405 sync = true,
3406 commit = NO},
3407 registerAllocation = registerAllocation}
3408
3409 val assembly_load
3410 = case Size.class size
3411 of Size.FLT
3412 => AppendList.single
3413 (Assembly.instruction_fld
3414 {src = Operand.address address,
3415 size = size})
3416 | Size.FPI
3417 => AppendList.single
3418 (Assembly.instruction_fild
3419 {src = Operand.address address,
3420 size = size})
3421 | _
3422 => Error.bug "x86AllocateRegisters.RegisterAllocation.toFltRegisterMemLoc: size"
3423 in
3424 {fltregister = FltRegister.top,
3425 assembly = AppendList.appends
3426 [assembly_free,
3427 assembly_address,
3428 assembly_load],
3429 fltrename = fltrename_push o fltrename_free,
3430 registerAllocation = registerAllocation}
3431 end
3432 | (SOME _, false)
3433 => Error.bug "x86AllocateRegisters.RegisterAllocation.toFltRegisterMemLoc: (top, move)"))
3434 before (Int.dec depth))
3435 handle Spill
3436 => spillAndReissue
3437 {info = info,
3438 supports = supports,
3439 saves = saves,
3440 registerAllocation = registerAllocation,
3441 spiller = spillRegisters,
3442 msg = "toFltRegisterMemLoc",
3443 reissue = fn {assembly = assembly_spill,
3444 registerAllocation}
3445 => let
3446 val {fltregister, assembly,
3447 fltrename, registerAllocation}
3448 = toFltRegisterMemLoc
3449 {memloc = memloc,
3450 info = info,
3451 size = size,
3452 move = move,
3453 supports = supports,
3454 saves = saves,
3455 top = top,
3456 registerAllocation = registerAllocation}
3457 in
3458 {fltregister = fltregister,
3459 assembly = AppendList.append (assembly_spill,
3460 assembly),
3461 fltrename = fltrename,
3462 registerAllocation = registerAllocation}
3463 end}
3464
3465 and toAddressMemLoc {memloc: MemLoc.t,
3466 info: Liveness.t,
3467 size: Size.t,
3468 supports: Operand.t list,
3469 saves: Operand.t list,
3470 registerAllocation: t} :
3471 {address: Address.t,
3472 assembly: Assembly.t AppendList.t,
3473 registerAllocation: t}
3474 = (Int.inc depth;
3475 (let
3476 val MemLoc.U {immBase, memBase, immIndex, memIndex, scale, ...}
3477 = MemLoc.destruct memloc
3478
3479 (* If PIC, find labels with RBX-relative addressing.
3480 * It's bigger and slower, so only use it if we must.
3481 *)
3482 val (mungeLabel, base) = picRelative ()
3483
3484 val disp
3485 = case (immBase, immIndex) of
3486 (NONE, NONE) => Immediate.zero
3487 | (SOME immBase, NONE)
3488 => (case Immediate.destruct immBase of
3489 Immediate.Word _ => immBase
3490 | Immediate.Label l =>
3491 Immediate.label (mungeLabel l)
3492 | Immediate.LabelPlusWord (l, w) =>
3493 Immediate.labelPlusWord (mungeLabel l, w))
3494 | (NONE, SOME immIndex)
3495 => (case Immediate.destruct immIndex of
3496 Immediate.Word _ => immIndex
3497 | _ => Error.bug "x86AllocateRegisters.RegisterAllocation.toAddressMemLoc:indexLabel")
3498 | (SOME immBase, SOME immIndex)
3499 => (case (Immediate.destruct immBase, Immediate.destruct immIndex) of
3500 (Immediate.Label l1, Immediate.Word w2) =>
3501 Immediate.labelPlusWord (mungeLabel l1, w2)
3502 | (Immediate.LabelPlusWord (l1, w1), Immediate.Word w2) =>
3503 Immediate.labelPlusWord (mungeLabel l1, WordX.add (w1, w2))
3504 | _ => Error.bug "x86AllocateRegisters.RegisterAllocation.toAddressMemLoc:disp")
3505
3506 val {register = register_base,
3507 assembly = assembly_base,
3508 registerAllocation}
3509 = case (Immediate.destruct disp, memBase) of
3510 (Immediate.Word _, NONE)
3511 => {register = NONE,
3512 assembly = AppendList.empty,
3513 registerAllocation = registerAllocation}
3514 | (Immediate.Word _, SOME memBase) (* no label, no PIC *)
3515 => let
3516 val {register, assembly, registerAllocation}
3517 = toRegisterMemLoc
3518 {memloc = memBase,
3519 info = info,
3520 size = MemLoc.size memBase,
3521 move = true,
3522 supports
3523 = case memIndex
3524 of NONE => supports
3525 | SOME memIndex
3526 => (Operand.memloc memIndex)::
3527 supports,
3528 saves = saves,
3529 force = Register.baseRegisters,
3530 registerAllocation = registerAllocation}
3531 in
3532 {register = SOME register,
3533 assembly = assembly,
3534 registerAllocation = registerAllocation}
3535 end
3536 | (_, SOME _) (* label & memBase? bad input *)
3537 => Error.bug "x86AllocateRegisters.RegisterAllocation.toAddressMemLoc:base*2"
3538 | (_, NONE) (* label only -> use PIC if needed *)
3539 => {register = base,
3540 assembly = AppendList.empty,
3541 registerAllocation = registerAllocation}
3542
3543 val {register = register_index,
3544 assembly = assembly_index,
3545 registerAllocation}
3546 = case memIndex
3547 of NONE => {register = NONE,
3548 assembly = AppendList.empty,
3549 registerAllocation = registerAllocation}
3550 | SOME memIndex
3551 => let
3552 val {register, assembly, registerAllocation}
3553 = toRegisterMemLoc
3554 {memloc = memIndex,
3555 info = info,
3556 size = MemLoc.size memIndex,
3557 move = true,
3558 supports = supports,
3559 saves
3560 = case (memBase, register_base)
3561 of (NONE, _) => saves
3562 | (SOME memBase, SOME register_base)
3563 => (Operand.memloc memBase)::
3564 (Operand.register register_base)::
3565 saves
3566 | _ => Error.bug "x86AllocateRegisters.RegisterAllocation.toAddressMemLoc",
3567 force = Register.indexRegisters,
3568 registerAllocation = registerAllocation}
3569 in
3570 {register = SOME register,
3571 assembly = assembly,
3572 registerAllocation = registerAllocation}
3573 end
3574 in
3575 {address = Address.T {disp = SOME disp,
3576 base = register_base,
3577 index = register_index,
3578 scale = case memIndex
3579 of SOME _ => SOME scale
3580 | NONE => NONE},
3581 assembly = AppendList.append (assembly_base,
3582 assembly_index),
3583 registerAllocation = registerAllocation}
3584 end)
3585
3586 (*
3587 (case MemLoc.destruct memloc
3588 of MemLoc.U {base = MemLoc.Imm base, index = MemLoc.Imm index,
3589 scale, size, ...}
3590 => let
3591 val disp'
3592 = if Immediate.eq(index, Immediate.const_int 0)
3593 then NONE
3594 else SOME (Immediate.binexp
3595 {oper = Immediate.Multiplication,
3596 exp1 = index,
3597 exp2 = Scale.toImmediate scale})
3598 val disp
3599 = case disp'
3600 of NONE => SOME base
3601 | SOME disp' => SOME (Immediate.binexp
3602 {oper = Immediate.Addition,
3603 exp1 = base,
3604 exp2 = disp'})
3605 in
3606 {address = Address.T {disp = disp,
3607 base = NONE,
3608 index = NONE,
3609 scale = NONE},
3610 assembly = AppendList.empty,
3611 registerAllocation = registerAllocation}
3612 end
3613 | MemLoc.U {base = MemLoc.Imm base, index = MemLoc.Mem index,
3614 scale, size, ...}
3615 => let
3616 val disp = SOME base
3617
3618 val {register = register_index,
3619 assembly = assembly_index,
3620 registerAllocation}
3621 = toRegisterMemLoc {memloc = index,
3622 info = info,
3623 size = MemLoc.size index,
3624 move = true,
3625 supports = supports,
3626 saves = saves,
3627 force = Register.indexRegisters,
3628 registerAllocation
3629 = registerAllocation}
3630 in
3631 {address = Address.T {disp = disp,
3632 base = NONE,
3633 index = SOME register_index,
3634 scale = SOME scale},
3635 assembly = assembly_index,
3636 registerAllocation = registerAllocation}
3637 end
3638 | MemLoc.U {base = MemLoc.Mem base, index = MemLoc.Imm index,
3639 scale, size, ...}
3640 => let
3641 val disp
3642 = if Immediate.eq(index, Immediate.const_int 0)
3643 then NONE
3644 else SOME (Immediate.binexp
3645 {oper = Immediate.Multiplication,
3646 exp1 = index,
3647 exp2 = Scale.toImmediate scale})
3648
3649 val {register = register_base,
3650 assembly = assembly_base,
3651 registerAllocation}
3652 = toRegisterMemLoc {memloc = base,
3653 info = info,
3654 size = MemLoc.size base,
3655 move = true,
3656 supports = supports,
3657 saves = saves,
3658 force = Register.baseRegisters,
3659 registerAllocation
3660 = registerAllocation}
3661 in
3662 {address = Address.T {disp = disp,
3663 base = SOME register_base,
3664 index = NONE,
3665 scale = NONE},
3666 assembly = assembly_base,
3667 registerAllocation = registerAllocation}
3668 end
3669 | MemLoc.U {base = MemLoc.Mem base, index = MemLoc.Mem index,
3670 scale, size, ...}
3671 => let
3672 val {register = register_base,
3673 assembly = assembly_base,
3674 registerAllocation}
3675 = toRegisterMemLoc {memloc = base,
3676 info = info,
3677 size = MemLoc.size base,
3678 move = true,
3679 supports
3680 = (Operand.memloc index)::supports,
3681 saves = saves,
3682 force = Register.baseRegisters,
3683 registerAllocation
3684 = registerAllocation}
3685
3686 val {register = register_index,
3687 assembly = assembly_index,
3688 registerAllocation}
3689 = toRegisterMemLoc {memloc = index,
3690 info = info,
3691 size = MemLoc.size index,
3692 move = true,
3693 supports = supports,
3694 saves = (Operand.memloc base)::
3695 (Operand.register
3696 register_base)::
3697 saves,
3698 force = Register.indexRegisters,
3699 registerAllocation
3700 = registerAllocation}
3701 in
3702 {address = Address.T {disp = NONE,
3703 base = SOME register_base,
3704 index = SOME register_index,
3705 scale = SOME scale},
3706 assembly = AppendList.append (assembly_base,
3707 assembly_index),
3708 registerAllocation = registerAllocation}
3709 end)
3710 *)
3711 before (Int.dec depth))
3712 handle Spill
3713 => spillAndReissue
3714 {info = info,
3715 supports = supports,
3716 saves = saves,
3717 registerAllocation = registerAllocation,
3718 spiller = spillRegisters,
3719 msg = "toAddressMemLoc",
3720 reissue = fn {assembly = assembly_spill,
3721 registerAllocation}
3722 => let
3723 val {address, assembly, registerAllocation}
3724 = toAddressMemLoc
3725 {memloc = memloc,
3726 info = info,
3727 size = size,
3728 supports = supports,
3729 saves = saves,
3730 registerAllocation = registerAllocation}
3731 in
3732 {address = address,
3733 assembly = AppendList.append (assembly_spill,
3734 assembly),
3735 registerAllocation = registerAllocation}
3736 end}
3737
3738 and toRegisterImmediate {immediate: Immediate.t,
3739 info: Liveness.t,
3740 size: Size.t,
3741 supports: Operand.t list,
3742 saves: Operand.t list,
3743 force: Register.t list,
3744 registerAllocation: t} :
3745 {register: Register.t,
3746 assembly: Assembly.t AppendList.t,
3747 registerAllocation: t}
3748 = let
3749 val _ = Int.inc depth
3750 val {register = final_register, assembly, registerAllocation}
3751 = freeRegister {info = info,
3752 memloc = NONE,
3753 size = size,
3754 supports = supports,
3755 saves = saves,
3756 force = force,
3757 registerAllocation = registerAllocation}
3758 val _ = Int.dec depth
3759 val (mungeLabel, base) = picRelative ()
3760 val instruction
3761 = case Immediate.destruct immediate of
3762 Immediate.Word _ =>
3763 Assembly.instruction_mov
3764 {dst = Operand.Register final_register,
3765 src = Operand.Immediate immediate,
3766 size = size}
3767 | Immediate.Label l =>
3768 Assembly.instruction_lea
3769 {dst = Operand.Register final_register,
3770 src = Operand.Address
3771 (Address.T { disp = SOME (Immediate.label
3772 (mungeLabel l)),
3773 base = base,
3774 index = NONE, scale = NONE }),
3775 size = size}
3776 | Immediate.LabelPlusWord (l, w) =>
3777 Assembly.instruction_lea
3778 {dst = Operand.Register final_register,
3779 src = Operand.Address
3780 (Address.T { disp = SOME (Immediate.labelPlusWord
3781 (mungeLabel l, w)),
3782 base = base,
3783 index = NONE, scale = NONE }),
3784 size = size}
3785 in
3786 {register = final_register,
3787 assembly = AppendList.appends
3788 [assembly,
3789 AppendList.single instruction],
3790 registerAllocation = registerAllocation}
3791 end
3792 handle Spill
3793 => spillAndReissue
3794 {info = info,
3795 supports = supports,
3796 saves = saves,
3797 registerAllocation = registerAllocation,
3798 spiller = spillRegisters,
3799 msg = "toRegisterImmediate",
3800 reissue = fn {assembly = assembly_spill,
3801 registerAllocation}
3802 => let
3803 val {register, assembly, registerAllocation}
3804 = toRegisterImmediate
3805 {immediate = immediate,
3806 info = info,
3807 size = size,
3808 supports = supports,
3809 saves = saves,
3810 force = force,
3811 registerAllocation = registerAllocation}
3812 in
3813 {register = register,
3814 assembly = AppendList.append (assembly_spill,
3815 assembly),
3816 registerAllocation = registerAllocation}
3817 end}
3818
3819 fun pre {uses: Operand.t list,
3820 defs: Operand.t list,
3821 kills: Operand.t list,
3822 info as {dead,
3823 remove,
3824 ...}: Liveness.t,
3825 registerAllocation: t} :
3826 {assembly: Assembly.t AppendList.t,
3827 registerAllocation: t}
3828 = let
3829 val ra = registerAllocation
3830
3831 val dead_memlocs = dead
3832 val remove_memlocs = remove
3833
3834 val (allUses, allDefs, allKills)
3835 = let
3836 fun doit operands
3837 = List.fold
3838 (operands,
3839 MemLocSet.empty,
3840 fn (operand,set)
3841 => case Operand.deMemloc operand
3842 of SOME memloc
3843 => MemLocSet.add(set, memloc)
3844 | NONE => set)
3845
3846 val uses = doit uses
3847 val defs = doit defs
3848 val kills = doit kills
3849
3850 fun doit' (memlocs, set)
3851 = MemLocSet.fold
3852 (memlocs,
3853 set,
3854 fn (memloc, set)
3855 => MemLocSet.union
3856 (set,
3857 MemLocSet.fromList (MemLoc.utilized memloc)))
3858 val allUses
3859 = doit'(uses,
3860 doit'(defs,
3861 uses))
3862 val allDefs = defs
3863 val allKills = kills
3864 in
3865 (allUses, allDefs, allKills)
3866 end
3867
3868 val allDest = MemLocSet.unions
3869 [allDefs, allKills, dead_memlocs, remove_memlocs]
3870 val allKeep = MemLocSet.unions
3871 [allUses, allDefs, allKills]
3872
3873 val registerAllocation
3874 = fltvalueMap
3875 {map = fn {fltregister,
3876 memloc,
3877 weight,
3878 sync,
3879 commit}
3880 => let
3881 val must_commit0
3882 = (MemLocSet.exists
3883 (allDefs,
3884 fn memloc'
3885 => not (MemLoc.eq(memloc', memloc))
3886 andalso (MemLoc.mayAlias(memloc', memloc))))
3887 val must_commit1
3888 = (MemLocSet.exists
3889 (allUses,
3890 fn memloc'
3891 => not (MemLoc.eq(memloc', memloc))
3892 andalso (MemLoc.mayAlias(memloc', memloc))))
3893 val must_commit2
3894 = (List.exists
3895 (MemLoc.utilized memloc,
3896 fn memloc
3897 => MemLocSet.contains (allDest, memloc)))
3898 val must_commit3
3899 = (MemLocSet.contains
3900 (MemLocSet.-(allKills, dead_memlocs), memloc))
3901 val sync
3902 = if volatile memloc
3903 then true
3904 else sync
3905 val commit
3906 = if volatile memloc
3907 then REMOVE 0
3908 else if must_commit3
3909 then COMMIT 0
3910 else if must_commit2
3911 then if MemLocSet.contains
3912 (allKeep, memloc)
3913 then COMMIT 0
3914 else REMOVE 0
3915 else if must_commit1 orelse must_commit0
3916 then case commit
3917 of TRYREMOVE _ => REMOVE 0
3918 | REMOVE _ => REMOVE 0
3919 | _ => COMMIT 0
3920 else commit
3921 in
3922 {fltregister = fltregister,
3923 memloc = memloc,
3924 weight = weight,
3925 sync = sync,
3926 commit = commit}
3927 end,
3928 registerAllocation = registerAllocation}
3929
3930 val {assembly = assembly_commit_fltregisters,
3931 registerAllocation,
3932 ...}
3933 = commitFltRegisters {info = info,
3934 supports = [],
3935 saves = [],
3936 registerAllocation = registerAllocation}
3937
3938 val registerAllocation
3939 = valueMap
3940 {map = fn {register,
3941 memloc,
3942 weight,
3943 sync,
3944 commit}
3945 => let
3946 val must_commit0
3947 = (MemLocSet.exists
3948 (allDefs,
3949 fn memloc'
3950 => not (MemLoc.eq(memloc', memloc))
3951 andalso (MemLoc.mayAlias(memloc', memloc))))
3952 val must_commit1
3953 = (MemLocSet.exists
3954 (allUses,
3955 fn memloc'
3956 => not (MemLoc.eq(memloc', memloc))
3957 andalso (MemLoc.mayAlias(memloc', memloc))))
3958 val must_commit2
3959 = (List.exists
3960 (MemLoc.utilized memloc,
3961 fn memloc
3962 => MemLocSet.contains (allDest, memloc)))
3963 val must_commit3
3964 = (MemLocSet.contains
3965 (MemLocSet.-(allKills, dead_memlocs), memloc))
3966 val sync
3967 = if volatile memloc
3968 then true
3969 else sync
3970 val commit
3971 = if volatile memloc
3972 then REMOVE 0
3973 else if MemLocSet.contains(allDefs, memloc)
3974 then if must_commit1 orelse must_commit0
3975 then case commit
3976 of TRYREMOVE _ => REMOVE 0
3977 | REMOVE _ => REMOVE 0
3978 | _ => COMMIT 0
3979 else commit
3980 else if must_commit3
3981 then COMMIT 0
3982 else if must_commit2
3983 then if MemLocSet.contains
3984 (allKeep, memloc)
3985 then COMMIT 0
3986 else REMOVE 0
3987 else if must_commit1 orelse must_commit0
3988 then case commit
3989 of TRYREMOVE _ => REMOVE 0
3990 | REMOVE _ => REMOVE 0
3991 | _ => COMMIT 0
3992 else commit
3993 in
3994 {register = register,
3995 memloc = memloc,
3996 weight = weight,
3997 sync = sync,
3998 commit = commit}
3999 end,
4000 registerAllocation = registerAllocation}
4001
4002 val {assembly = assembly_commit_registers,
4003 registerAllocation}
4004 = commitRegisters {info = info,
4005 supports = [],
4006 saves = [],
4007 registerAllocation = registerAllocation}
4008 in
4009 {assembly = AppendList.appends
4010 [if !Control.Native.commented > 3
4011 then AppendList.cons
4012 ((Assembly.comment "pre begin:"),
4013 (toComments ra))
4014 else AppendList.empty,
4015 assembly_commit_fltregisters,
4016 assembly_commit_registers,
4017 if !Control.Native.commented > 3
4018 then AppendList.cons
4019 ((Assembly.comment "pre end:"),
4020 (toComments registerAllocation))
4021 else AppendList.empty],
4022 registerAllocation = registerAllocation}
4023 end
4024
4025 val (pre, pre_msg)
4026 = tracer
4027 "pre"
4028 pre
4029
4030 fun post {uses: Operand.t list,
4031 final_uses: Operand.t list,
4032 defs: Operand.t list,
4033 final_defs: Operand.t list,
4034 kills: Operand.t list,
4035 info as {dead,
4036 commit,
4037 remove,
4038 ...}: Liveness.t,
4039 registerAllocation: t} :
4040 {assembly: Assembly.t AppendList.t,
4041 registerAllocation: t}
4042 = let
4043 val ra = registerAllocation
4044
4045 val (final_uses_registers,
4046 final_defs_registers,
4047 final_uses_fltregisters,
4048 final_defs_fltregisters)
4049 = let
4050 fun doit(operands, (final_registers, final_fltregisters))
4051 = List.fold
4052 (operands,
4053 (final_registers, final_fltregisters),
4054 fn (operand, (final_registers, final_fltregisters))
4055 => case (Operand.deRegister operand,
4056 Operand.deFltregister operand)
4057 of (SOME register, _)
4058 => if List.contains(final_registers,
4059 register,
4060 Register.eq)
4061 then (final_registers,
4062 final_fltregisters)
4063 else (register::final_registers,
4064 final_fltregisters)
4065 | (_, SOME fltregister)
4066 => if List.contains(final_fltregisters,
4067 fltregister,
4068 FltRegister.eq)
4069 then (final_registers,
4070 final_fltregisters)
4071 else (final_registers,
4072 fltregister::final_fltregisters)
4073 | _ => (final_registers, final_fltregisters))
4074 val (final_uses_registers, final_uses_fltregisters)
4075 = doit(final_uses, ([], []))
4076 val (final_defs_registers, final_defs_fltregisters)
4077 = doit(final_defs, ([], []))
4078 in
4079 (final_uses_registers,
4080 final_defs_registers,
4081 final_uses_fltregisters,
4082 final_defs_fltregisters)
4083 end
4084
4085 val dead_memlocs = dead
4086 val commit_memlocs = commit
4087 val remove_memlocs = remove
4088
4089 val (_, allDefs, allKills)
4090 = let
4091 fun doit operands
4092 = List.fold
4093 (operands,
4094 MemLocSet.empty,
4095 fn (operand,set)
4096 => case Operand.deMemloc operand
4097 of SOME memloc
4098 => MemLocSet.add(set, memloc)
4099 | NONE => set)
4100
4101 val uses = doit uses
4102 val defs = doit defs
4103 val kills = doit kills
4104
4105 fun doit' (memlocs, set)
4106 = MemLocSet.fold
4107 (memlocs,
4108 set,
4109 fn (memloc, set)
4110 => MemLocSet.union
4111 (set,
4112 MemLocSet.fromList (MemLoc.utilized memloc)))
4113 val allUses
4114 = doit'(uses,
4115 doit'(defs,
4116 uses))
4117 val allDefs = defs
4118 val allKills = kills
4119 in
4120 (allUses, allDefs, allKills)
4121 end
4122
4123 val allDest = MemLocSet.unions
4124 [allDefs, allKills, dead_memlocs, remove_memlocs]
4125
4126 val registerAllocation
4127 = fltvalueMap
4128 {map = fn {fltregister,
4129 memloc,
4130 weight,
4131 sync,
4132 commit}
4133 => if volatile memloc
4134 then let
4135 val isDst
4136 = List.contains
4137 (final_defs_fltregisters,
4138 fltregister,
4139 FltRegister.eq)
4140 val isDef = isDst
4141 in
4142 {fltregister = fltregister,
4143 memloc = memloc,
4144 sync = sync andalso (not isDef),
4145 weight = weight - 500,
4146 commit = REMOVE 0}
4147 end
4148 else if MemLocSet.contains
4149 (dead_memlocs, memloc)
4150 then {fltregister = fltregister,
4151 memloc = memloc,
4152 sync = true,
4153 weight = weight - 500,
4154 commit = TRYREMOVE 0}
4155 else let
4156 val isSrc
4157 = List.contains
4158 (final_uses_fltregisters,
4159 fltregister,
4160 FltRegister.eq)
4161
4162 val isDst
4163 = List.contains
4164 (final_defs_fltregisters,
4165 fltregister,
4166 FltRegister.eq)
4167
4168 val isDef = isDst
4169 in
4170 {fltregister = fltregister,
4171 memloc = memloc,
4172 weight = weight - 5
4173 + (if isSrc
4174 then 5
4175 else 0)
4176 + (if isDst
4177 then 10
4178 else 0),
4179 sync = sync andalso (not isDef),
4180 commit = if !Control.Native.IEEEFP
4181 andalso
4182 not (sync andalso (not isDef))
4183 then REMOVE 0
4184 else if List.exists
4185 (MemLoc.utilized memloc,
4186 fn memloc'
4187 => MemLocSet.contains
4188 (allDest, memloc'))
4189 then REMOVE 0
4190 else if MemLocSet.contains
4191 (remove_memlocs,
4192 memloc)
4193 then TRYREMOVE 0
4194 else if MemLocSet.contains
4195 (commit_memlocs,
4196 memloc)
4197 then TRYCOMMIT 0
4198 else commit}
4199 end,
4200 registerAllocation = registerAllocation}
4201
4202 val {assembly = assembly_commit_fltregisters,
4203 registerAllocation,
4204 ...}
4205 = commitFltRegisters {info = info,
4206 supports = [],
4207 saves = [],
4208 registerAllocation = registerAllocation}
4209
4210 val registerAllocation
4211 = valueMap
4212 {map = fn value as {register,
4213 memloc,
4214 weight,
4215 sync,
4216 commit}
4217 => if volatile memloc
4218 then let
4219 val isDst
4220 = List.contains
4221 (final_defs_registers,
4222 register,
4223 Register.eq)
4224 val isDef = isDst
4225 in
4226 {register = register,
4227 memloc = memloc,
4228 sync = sync andalso (not isDef),
4229 weight = weight - 500,
4230 commit = REMOVE 0}
4231 end
4232 else if MemLocSet.contains
4233 (dead_memlocs, memloc)
4234 then value
4235 else let
4236 val isSrc
4237 = List.contains
4238 (final_uses_registers,
4239 register,
4240 Register.eq)
4241
4242 val isDst
4243 = List.contains
4244 (final_defs_registers,
4245 register,
4246 Register.eq)
4247
4248 val isDef = isDst
4249 in
4250 {register = register,
4251 memloc = memloc,
4252 weight = weight - 5
4253 + (if isSrc
4254 then 5
4255 else 0)
4256 + (if isDst
4257 then 10
4258 else 0),
4259 sync = sync andalso (not isDef),
4260 commit = if List.exists
4261 (MemLoc.utilized memloc,
4262 fn memloc'
4263 => MemLocSet.contains
4264 (allDest, memloc'))
4265 then REMOVE 0
4266 else if MemLocSet.contains
4267 (remove_memlocs,
4268 memloc)
4269 then TRYREMOVE 0
4270 else if MemLocSet.contains
4271 (commit_memlocs,
4272 memloc)
4273 then TRYCOMMIT 0
4274 else commit}
4275 end,
4276 registerAllocation = registerAllocation}
4277
4278 val {assembly = assembly_commit_registers,
4279 registerAllocation}
4280 = commitRegisters {info = info,
4281 supports = [],
4282 saves = [],
4283 registerAllocation = registerAllocation}
4284
4285 val registerAllocation
4286 = valueMap
4287 {map = fn value as {register,
4288 memloc,
4289 weight,
4290 ...}
4291 => if MemLocSet.contains
4292 (dead_memlocs, memloc)
4293 then {register = register,
4294 memloc = memloc,
4295 sync = true,
4296 weight = weight,
4297 commit = REMOVE 0}
4298 else value,
4299 registerAllocation = registerAllocation}
4300
4301 val {assembly = assembly_dead_registers,
4302 registerAllocation}
4303 = commitRegisters {info = info,
4304 supports = [],
4305 saves = [],
4306 registerAllocation = registerAllocation}
4307 in
4308 {assembly = AppendList.appends
4309 [if !Control.Native.commented > 3
4310 then AppendList.cons
4311 ((Assembly.comment "post begin:"),
4312 (toComments ra))
4313 else AppendList.empty,
4314 assembly_commit_fltregisters,
4315 assembly_commit_registers,
4316 assembly_dead_registers,
4317 if !Control.Native.commented > 3
4318 then AppendList.cons
4319 ((Assembly.comment "post end:"),
4320 (toComments registerAllocation))
4321 else AppendList.empty],
4322 registerAllocation = registerAllocation}
4323 end
4324
4325 val (post, post_msg)
4326 = tracer
4327 "post"
4328 post
4329
4330 fun allocateOperand {operand: Operand.t,
4331 options = {register: bool,
4332 immediate: bool,
4333 label: bool,
4334 address: bool},
4335 info as {dead,
4336 remove,
4337 ...}: Liveness.t,
4338 size: Size.t,
4339 move: bool,
4340 supports: Operand.t list,
4341 saves: Operand.t list,
4342 force: Register.t list,
4343 registerAllocation: t} :
4344 {operand: Operand.t,
4345 assembly: Assembly.t AppendList.t,
4346 registerAllocation: t}
4347 = case operand
4348 of Operand.Immediate i
4349 => if immediate andalso
4350 (let
4351 val (_, picBase) = picRelative ()
4352 val pic = picBase <> NONE
4353 val hasLabel =
4354 case Immediate.destruct i of
4355 Immediate.Word _ => false
4356 | _ => true
4357 in
4358 not (pic andalso hasLabel)
4359 end)
4360 then {operand = operand,
4361 assembly = AppendList.empty,
4362 registerAllocation = registerAllocation}
4363 else if register
4364 then let
4365 val {register,
4366 assembly,
4367 registerAllocation}
4368 = toRegisterImmediate {immediate = i,
4369 info = info,
4370 size = size,
4371 supports = supports,
4372 saves = saves,
4373 force = force,
4374 registerAllocation
4375 = registerAllocation}
4376 in
4377 {operand = Operand.register register,
4378 assembly = assembly,
4379 registerAllocation = registerAllocation}
4380 end
4381 else if address
4382 then let
4383 val (mungeLabel, picBase) = picRelative ()
4384 val label = mungeLabel (Label.fromString "raTemp1")
4385 val address
4386 = Address.T
4387 {disp = SOME (Immediate.label label),
4388 base = picBase,
4389 index = NONE,
4390 scale = NONE}
4391 in
4392 {operand = Operand.address address,
4393 assembly = AppendList.single
4394 (Assembly.instruction_mov
4395 {src = Operand.immediate i,
4396 dst = Operand.address address,
4397 size = size}),
4398 registerAllocation = registerAllocation}
4399 end
4400 else Error.bug "x86AllocateRegisters.RegisterAllocation.allocateOperand: operand:Immediate"
4401 | Operand.Label l
4402 => if label
4403 then {operand = operand,
4404 assembly = AppendList.empty,
4405 registerAllocation = registerAllocation}
4406 else if immediate
4407 then {operand = Operand.immediate_label l,
4408 assembly = AppendList.empty,
4409 registerAllocation = registerAllocation}
4410 else if register
4411 then let
4412 val {register,
4413 assembly,
4414 registerAllocation}
4415 = toRegisterImmediate {immediate
4416 = Immediate.label l,
4417 info = info,
4418 size = size,
4419 supports = supports,
4420 saves = saves,
4421 force = force,
4422 registerAllocation
4423 = registerAllocation}
4424 in
4425 {operand = Operand.register register,
4426 assembly = assembly,
4427 registerAllocation = registerAllocation}
4428 end
4429 else Error.bug "x86AllocateRegisters.RegisterAllocation.allocateOperand: operand:Label"
4430 | Operand.MemLoc m
4431 => let
4432 fun toRegisterMemLoc' ()
4433 = let
4434 val {register,
4435 assembly,
4436 registerAllocation}
4437 = toRegisterMemLoc
4438 {memloc = m,
4439 info = info,
4440 size = size,
4441 move = move,
4442 supports = supports,
4443 saves = saves,
4444 force = force,
4445 registerAllocation = registerAllocation}
4446 in
4447 {operand = Operand.Register register,
4448 assembly = assembly,
4449 registerAllocation = registerAllocation}
4450 end
4451 fun toAddressMemLoc' ()
4452 = let
4453 val {address,
4454 assembly,
4455 registerAllocation}
4456 = toAddressMemLoc
4457 {memloc = m,
4458 info = info,
4459 size = size,
4460 supports = supports,
4461 saves = saves,
4462 registerAllocation
4463 = registerAllocation}
4464 in
4465 {operand = Operand.Address address,
4466 assembly = assembly,
4467 registerAllocation = registerAllocation}
4468 end
4469 fun toAddressMemLocRemove' ()
4470 = let
4471 val registerAllocation
4472 = valueMap {map
4473 = fn value as {register,
4474 memloc,
4475 weight,
4476 sync,
4477 ...}
4478 => if MemLoc.eq(memloc, m)
4479 then {register = register,
4480 memloc = memloc,
4481 weight = weight,
4482 sync = sync,
4483 commit = REMOVE 0}
4484 else value,
4485 registerAllocation = registerAllocation}
4486
4487 val {assembly = assembly_commit,
4488 registerAllocation}
4489 = commitRegisters {info = info,
4490 supports = supports,
4491 saves = saves,
4492 registerAllocation
4493 = registerAllocation}
4494
4495 val {address, assembly, registerAllocation}
4496 = toAddressMemLoc {memloc = m,
4497 info = info,
4498 size = size,
4499 supports = supports,
4500 saves = saves,
4501 registerAllocation
4502 = registerAllocation}
4503 in
4504 {operand = Operand.Address address,
4505 assembly = AppendList.append (assembly_commit,
4506 assembly),
4507 registerAllocation = registerAllocation}
4508 end
4509 in
4510 if register andalso address
4511 then case allocated {memloc = m,
4512 registerAllocation
4513 = registerAllocation}
4514 of NONE
4515 => if MemLocSet.contains(dead, m)
4516 orelse
4517 MemLocSet.contains(remove, m)
4518 then toAddressMemLoc' ()
4519 else toRegisterMemLoc' ()
4520 | SOME _
4521 => toRegisterMemLoc' ()
4522 else if register
4523 then toRegisterMemLoc' ()
4524 else if address
4525 then toAddressMemLocRemove' ()
4526 else Error.bug "x86AllocateRegisters.RegisterAllocation.allocateOperand: operand:MemLoc"
4527 end
4528 | _ => Error.bug "x86AllocateRegisters.RegisterAllocation.allocateOperand: operand"
4529
4530 val (allocateOperand, allocateOperand_msg)
4531 = tracer
4532 "allocateOperand"
4533 allocateOperand
4534
4535 fun allocateFltOperand {operand: Operand.t,
4536 options = {fltregister: bool,
4537 address: bool},
4538 info as {dead,
4539 remove,
4540 ...}: Liveness.t,
4541 size: Size.t,
4542 move: bool,
4543 supports: Operand.t list,
4544 saves: Operand.t list,
4545 top: bool option,
4546 registerAllocation: t} :
4547 {operand: Operand.t,
4548 assembly: Assembly.t AppendList.t,
4549 fltrename: FltRegister.t -> FltRegister.t,
4550 registerAllocation: t}
4551 = case operand
4552 of Operand.MemLoc m
4553 => if fltregister andalso address
4554 then case fltallocated {memloc = m,
4555 registerAllocation
4556 = registerAllocation}
4557 of NONE
4558 => if MemLocSet.contains(dead, m)
4559 orelse
4560 MemLocSet.contains(remove, m)
4561 then let
4562 val {address,
4563 assembly,
4564 registerAllocation}
4565 = toAddressMemLoc
4566 {memloc = m,
4567 info = info,
4568 size = size,
4569 supports = supports,
4570 saves = saves,
4571 registerAllocation
4572 = registerAllocation}
4573 in
4574 {operand = Operand.Address address,
4575 assembly = assembly,
4576 fltrename = FltRegister.id,
4577 registerAllocation = registerAllocation}
4578 end
4579 else let
4580 val {fltregister,
4581 assembly,
4582 fltrename,
4583 registerAllocation}
4584 = toFltRegisterMemLoc
4585 {memloc = m,
4586 info = info,
4587 size = size,
4588 move = move,
4589 supports = supports,
4590 saves = saves,
4591 top = top,
4592 registerAllocation
4593 = registerAllocation}
4594 in
4595 {operand
4596 = Operand.FltRegister fltregister,
4597 assembly = assembly,
4598 fltrename = fltrename,
4599 registerAllocation = registerAllocation}
4600 end
4601 | SOME _
4602 => let
4603 val {fltregister,
4604 assembly,
4605 fltrename,
4606 registerAllocation}
4607 = toFltRegisterMemLoc {memloc = m,
4608 info = info,
4609 size = size,
4610 move = move,
4611 supports = supports,
4612 saves = saves,
4613 top = top,
4614 registerAllocation
4615 = registerAllocation}
4616 in
4617 {operand = Operand.FltRegister fltregister,
4618 assembly = assembly,
4619 fltrename = fltrename,
4620 registerAllocation = registerAllocation}
4621 end
4622 else if fltregister
4623 then let
4624 val {fltregister,
4625 assembly,
4626 fltrename,
4627 registerAllocation}
4628 = toFltRegisterMemLoc {memloc = m,
4629 info = info,
4630 size = size,
4631 move = move,
4632 supports = supports,
4633 saves = saves,
4634 top = top,
4635 registerAllocation
4636 = registerAllocation}
4637 in
4638 {operand = Operand.FltRegister fltregister,
4639 assembly = assembly,
4640 fltrename = fltrename,
4641 registerAllocation = registerAllocation}
4642 end
4643 else if address
4644 then let
4645 val registerAllocation
4646 = fltvalueMap {map
4647 = fn value as {fltregister,
4648 memloc,
4649 weight,
4650 sync,
4651 ...}
4652 => if MemLoc.eq(memloc, m)
4653 then {fltregister
4654 = fltregister,
4655 memloc = memloc,
4656 weight = weight,
4657 sync = sync,
4658 commit = REMOVE 0}
4659 else value,
4660 registerAllocation
4661 = registerAllocation}
4662
4663 val {assembly = assembly_commit,
4664 fltrename = fltrename_commit,
4665 registerAllocation}
4666 = commitFltRegisters {info = info,
4667 supports = supports,
4668 saves = saves,
4669 registerAllocation
4670 = registerAllocation}
4671
4672 val {address,
4673 assembly = assembly_address,
4674 registerAllocation}
4675 = toAddressMemLoc {memloc = m,
4676 info = info,
4677 size = size,
4678 supports = supports,
4679 saves = saves,
4680 registerAllocation
4681 = registerAllocation}
4682 in
4683 {operand = Operand.Address address,
4684 assembly = AppendList.append (assembly_commit,
4685 assembly_address),
4686 fltrename = fltrename_commit,
4687 registerAllocation = registerAllocation}
4688 end
4689 else Error.bug "x86AllocateRegisters.RegisterAllocation.allocateFltOperand: operand:MemLoc"
4690 | _ => Error.bug "x86AllocateRegisters.RegisterAllocation.allocateFltOperand: operand"
4691
4692 val (allocateFltOperand, allocateFltOperand_msg)
4693 = tracer
4694 "allocateFltOperand"
4695 allocateFltOperand
4696
4697 local
4698 fun allocateFltStackOperands' {fltregister_top: FltRegister.t,
4699 fltregister_one: FltRegister.t,
4700 registerAllocation: t} :
4701 {assembly: Assembly.t AppendList.t,
4702 fltrename: FltRegister.t -> FltRegister.t,
4703 registerAllocation: t}
4704 = case (fltregister_top, fltregister_one)
4705 of (FltRegister.T 0, FltRegister.T 1)
4706 => {assembly = AppendList.empty,
4707 fltrename = FltRegister.id,
4708 registerAllocation = registerAllocation}
4709 | (FltRegister.T 1, FltRegister.T 0)
4710 => let
4711 val {fltrename = fltrename,
4712 registerAllocation}
4713 = fltxch1 {registerAllocation = registerAllocation}
4714 in
4715 {assembly = AppendList.single
4716 (Assembly.instruction_fxch
4717 {src = Operand.fltregister
4718 (FltRegister.T 1)}),
4719 fltrename = fltrename,
4720 registerAllocation = registerAllocation}
4721 end
4722 | (FltRegister.T 0, FltRegister.T j)
4723 => let
4724 val {fltrename = fltrename,
4725 registerAllocation}
4726 = fltxch1 {registerAllocation = registerAllocation}
4727
4728 val {fltrename = fltrename',
4729 registerAllocation}
4730 = fltxch' {fltregister = FltRegister.T j,
4731 registerAllocation = registerAllocation}
4732
4733 val {fltrename = fltrename'',
4734 registerAllocation}
4735 = fltxch1 {registerAllocation = registerAllocation}
4736 in
4737 {assembly = AppendList.fromList
4738 [Assembly.instruction_fxch
4739 {src = Operand.fltregister
4740 (FltRegister.T 1)},
4741 Assembly.instruction_fxch
4742 {src = Operand.fltregister
4743 (FltRegister.T j)},
4744 Assembly.instruction_fxch
4745 {src = Operand.fltregister
4746 (FltRegister.T 1)}],
4747 fltrename = fltrename'' o fltrename' o fltrename,
4748 registerAllocation = registerAllocation}
4749 end
4750 | (FltRegister.T 1, FltRegister.T j)
4751 => let
4752 val {fltrename = fltrename,
4753 registerAllocation}
4754 = fltxch' {fltregister = FltRegister.T j,
4755 registerAllocation = registerAllocation}
4756
4757 val {fltrename = fltrename',
4758 registerAllocation}
4759 = fltxch1 {registerAllocation = registerAllocation}
4760 in
4761 {assembly = AppendList.fromList
4762 [Assembly.instruction_fxch
4763 {src = Operand.fltregister
4764 (FltRegister.T j)},
4765 Assembly.instruction_fxch
4766 {src = Operand.fltregister
4767 (FltRegister.T 1)}],
4768 fltrename = fltrename' o fltrename,
4769 registerAllocation = registerAllocation}
4770 end
4771 | (FltRegister.T i, FltRegister.T 1)
4772 => let
4773 val {fltrename = fltrename,
4774 registerAllocation}
4775 = fltxch' {fltregister = FltRegister.T i,
4776 registerAllocation = registerAllocation}
4777 in
4778 {assembly = AppendList.single
4779 (Assembly.instruction_fxch
4780 {src = Operand.fltregister
4781 (FltRegister.T i)}),
4782 fltrename = fltrename,
4783 registerAllocation = registerAllocation}
4784 end
4785 | (FltRegister.T i, FltRegister.T 0)
4786 => let
4787 val {fltrename = fltrename,
4788 registerAllocation}
4789 = fltxch1 {registerAllocation = registerAllocation}
4790
4791 val {fltrename = fltrename',
4792 registerAllocation}
4793 = fltxch' {fltregister = FltRegister.T i,
4794 registerAllocation = registerAllocation}
4795 in
4796 {assembly = AppendList.fromList
4797 [Assembly.instruction_fxch
4798 {src = Operand.fltregister
4799 (FltRegister.T 1)},
4800 Assembly.instruction_fxch
4801 {src = Operand.fltregister
4802 (FltRegister.T i)}],
4803 fltrename = fltrename' o fltrename,
4804 registerAllocation = registerAllocation}
4805 end
4806 | (FltRegister.T i, FltRegister.T j)
4807 => let
4808 val {fltrename = fltrename,
4809 registerAllocation}
4810 = fltxch' {fltregister = FltRegister.T j,
4811 registerAllocation = registerAllocation}
4812
4813 val {fltrename = fltrename',
4814 registerAllocation}
4815 = fltxch1 {registerAllocation = registerAllocation}
4816
4817 val {fltrename = fltrename'',
4818 registerAllocation}
4819 = fltxch' {fltregister = FltRegister.T i,
4820 registerAllocation = registerAllocation}
4821 in
4822 {assembly = AppendList.fromList
4823 [Assembly.instruction_fxch
4824 {src = Operand.fltregister
4825 (FltRegister.T j)},
4826 Assembly.instruction_fxch
4827 {src = Operand.fltregister
4828 (FltRegister.T 1)},
4829 Assembly.instruction_fxch
4830 {src = Operand.fltregister
4831 (FltRegister.T i)}],
4832 fltrename = fltrename'' o fltrename' o fltrename,
4833 registerAllocation = registerAllocation}
4834 end
4835 in
4836 fun allocateFltStackOperands {operand_top: Operand.t,
4837 size_top: Size.t,
4838 move_top: bool,
4839 operand_one: Operand.t,
4840 move_one: bool,
4841 size_one: Size.t,
4842 info: Liveness.t,
4843 supports: Operand.t list,
4844 saves: Operand.t list,
4845 registerAllocation: t} :
4846 {operand_top: Operand.t,
4847 operand_one: Operand.t,
4848 assembly: Assembly.t AppendList.t,
4849 fltrename: FltRegister.t -> FltRegister.t,
4850 registerAllocation: t}
4851 = if Operand.eq(operand_top, operand_one)
4852 then let
4853 val {assembly = assembly_free,
4854 fltrename = fltrename_free,
4855 registerAllocation}
4856 = freeFltRegister {info = info,
4857 size = size_top,
4858 supports = operand_top::supports,
4859 saves = saves,
4860 registerAllocation
4861 = registerAllocation}
4862
4863 val {assembly = assembly_allocate_top_one,
4864 fltrename = fltrename_allocate_top_one,
4865 registerAllocation,
4866 ...}
4867 = allocateFltOperand
4868 {operand = operand_top,
4869 options = {fltregister = true,
4870 address = false},
4871 info = info,
4872 size = size_top,
4873 move = move_top,
4874 supports = supports,
4875 saves = saves,
4876 top = SOME true,
4877 registerAllocation
4878 = registerAllocation}
4879
4880 val temp
4881 = MemLoc.imm
4882 {base = Immediate.label (Label.fromString "raTemp2"),
4883 index = Immediate.zero,
4884 scale = Scale.Eight,
4885 size = Size.DBLE,
4886 class = MemLoc.Class.Temp}
4887
4888 val {fltrename = fltrename_push,
4889 registerAllocation}
4890 = fltpush {value = {fltregister = FltRegister.top,
4891 memloc = temp,
4892 weight = 0,
4893 sync = true,
4894 commit = NO},
4895 registerAllocation = registerAllocation}
4896 in
4897 {operand_top = Operand.FltRegister FltRegister.top,
4898 operand_one = Operand.FltRegister FltRegister.one,
4899 assembly = AppendList.appends
4900 [assembly_free,
4901 assembly_allocate_top_one,
4902 AppendList.single
4903 (Assembly.instruction_fld
4904 {src = Operand.FltRegister FltRegister.top,
4905 size = size_top})],
4906 fltrename = fltrename_push o
4907 fltrename_allocate_top_one o
4908 fltrename_free,
4909 registerAllocation = registerAllocation}
4910 end
4911 else let
4912 val {operand = operand_allocate_one,
4913 assembly = assembly_allocate_one,
4914 fltrename = fltrename_allocate_one,
4915 registerAllocation}
4916 = case operand_one
4917 of (Operand.MemLoc memloc_one)
4918 => (case fltallocated {memloc = memloc_one,
4919 registerAllocation
4920 = registerAllocation}
4921 of SOME value_one
4922 => {operand = Operand.FltRegister
4923 (#fltregister value_one),
4924 assembly = AppendList.empty,
4925 fltrename = FltRegister.id,
4926 registerAllocation
4927 = registerAllocation}
4928 | NONE
4929 => allocateFltOperand
4930 {operand = operand_one,
4931 options = {fltregister = true,
4932 address = false},
4933 info = info,
4934 size = size_one,
4935 move = move_one,
4936 supports = supports,
4937 saves = operand_top::saves,
4938 top = SOME true,
4939 registerAllocation
4940 = registerAllocation})
4941 | _ => allocateFltOperand
4942 {operand = operand_one,
4943 options = {fltregister = true,
4944 address = false},
4945 info = info,
4946 size = size_one,
4947 move = move_one,
4948 supports = supports,
4949 saves = operand_top::saves,
4950 top = SOME true,
4951 registerAllocation = registerAllocation}
4952
4953 val {operand = operand_allocate_top,
4954 assembly = assembly_allocate_top,
4955 fltrename = fltrename_allocate_top,
4956 registerAllocation}
4957 = case operand_top
4958 of (Operand.MemLoc memloc_top)
4959 => (case fltallocated {memloc = memloc_top,
4960 registerAllocation
4961 = registerAllocation}
4962 of SOME value_top
4963 => {operand = Operand.FltRegister
4964 (#fltregister value_top),
4965 assembly = AppendList.empty,
4966 fltrename = FltRegister.id,
4967 registerAllocation
4968 = registerAllocation}
4969 | NONE
4970 => allocateFltOperand
4971 {operand = operand_top,
4972 options = {fltregister = true,
4973 address = false},
4974 info = info,
4975 size = size_top,
4976 move = move_top,
4977 supports = supports,
4978 saves = operand_top::saves,
4979 top = SOME true,
4980 registerAllocation
4981 = registerAllocation})
4982 | _ => allocateFltOperand
4983 {operand = operand_top,
4984 options = {fltregister = true,
4985 address = false},
4986 info = info,
4987 size = size_top,
4988 move = move_top,
4989 supports = supports,
4990 saves = operand_top::saves,
4991 top = SOME true,
4992 registerAllocation = registerAllocation}
4993
4994 val fltregister_one
4995 = case operand_allocate_one
4996 of Operand.FltRegister f => f
4997 | _ => Error.bug "x86AllocateRegisters.RegisterAllocation.allocateFltStackOperand: one"
4998 val fltregister_one = fltrename_allocate_top fltregister_one
4999
5000 val fltregister_top
5001 = case operand_allocate_top
5002 of Operand.FltRegister f => f
5003 | _ => Error.bug "x86AllocateRegisters.RegisterAllocation.allocateFltStackOperand: top"
5004
5005 val {assembly,
5006 fltrename,
5007 registerAllocation}
5008 = allocateFltStackOperands'
5009 {fltregister_top = fltregister_top,
5010 fltregister_one = fltregister_one,
5011 registerAllocation = registerAllocation}
5012 in
5013 {operand_top = Operand.FltRegister FltRegister.top,
5014 operand_one = Operand.FltRegister FltRegister.one,
5015 assembly = AppendList.appends
5016 [assembly_allocate_one,
5017 assembly_allocate_top,
5018 assembly],
5019 fltrename = fltrename o
5020 fltrename_allocate_top o
5021 fltrename_allocate_one,
5022 registerAllocation = registerAllocation}
5023 end
5024 end
5025
5026 val (allocateFltStackOperands, allocateFltStackOperands_msg)
5027 = tracer
5028 "allocateFltStackOperands"
5029 allocateFltStackOperands
5030
5031 fun fltrenameLift fltrename
5032 = fn Operand.FltRegister f
5033 => Operand.FltRegister (fltrename f)
5034 | operand => operand
5035
5036 (* Implementation of directives. *)
5037
5038 fun assume {assumes : {register: Register.t,
5039 memloc: MemLoc.t,
5040 weight: int,
5041 sync: bool,
5042 reserve: bool} list,
5043 info = _,
5044 registerAllocation}
5045 = let
5046 val {assembly,
5047 registerAllocation}
5048 = List.foldr
5049 (assumes,
5050 {assembly = AppendList.empty,
5051 registerAllocation = registerAllocation},
5052 fn ({register,
5053 memloc,
5054 weight,
5055 sync,
5056 reserve},
5057 {assembly, registerAllocation})
5058 => let
5059 val registerAllocation
5060 = update
5061 {value = {register = register,
5062 memloc = memloc,
5063 weight = weight,
5064 sync = sync,
5065 commit = NO},
5066 registerAllocation = registerAllocation}
5067
5068 val {assembly = assembly_reserve,
5069 registerAllocation}
5070 = if reserve
5071 then reserve' {register = register,
5072 registerAllocation = registerAllocation}
5073 else unreserve' {register = register,
5074 registerAllocation = registerAllocation}
5075 in
5076 {assembly = AppendList.append (assembly,
5077 assembly_reserve),
5078 registerAllocation = registerAllocation}
5079 end)
5080 in
5081 {assembly = assembly,
5082 registerAllocation = registerAllocation}
5083 end
5084
5085 fun fltassume {assumes : {memloc: MemLoc.t,
5086 weight: int,
5087 sync: bool} list,
5088 info = _,
5089 registerAllocation = {entries,
5090 reserved,
5091 ...} : t}
5092 = let
5093 val registerAllocation
5094 = {entries = entries,
5095 reserved = reserved,
5096 fltstack = []}
5097
5098 val {assembly,
5099 registerAllocation}
5100 = List.foldr
5101 (assumes,
5102 {assembly = AppendList.empty,
5103 registerAllocation = registerAllocation},
5104 fn ({memloc,
5105 weight,
5106 sync},
5107 {assembly, registerAllocation})
5108 => let
5109 val {registerAllocation, ...}
5110 = fltpush {value = {fltregister = FltRegister.top,
5111 memloc = memloc,
5112 weight = weight,
5113 sync = sync,
5114 commit = NO},
5115 registerAllocation = registerAllocation}
5116 in
5117 {assembly = assembly,
5118 registerAllocation = registerAllocation}
5119 end)
5120 in
5121 {assembly = assembly,
5122 registerAllocation = registerAllocation}
5123 end
5124
5125 fun cache {caches: {register: Register.t,
5126 memloc: MemLoc.t,
5127 reserve: bool} list,
5128 info,
5129 registerAllocation}
5130 = let
5131 val supports
5132 = List.revMap
5133 (caches,
5134 fn {memloc, ...} => Operand.memloc memloc)
5135
5136 datatype u = None | Reg of Register.t | Mem of MemLoc.t
5137
5138 fun computeEdges' {reg,
5139 registerAllocation}
5140 = List.revMap
5141 (Register.coincident' reg,
5142 fn register'
5143 => let
5144 val (from, m)
5145 = case List.peek
5146 (caches,
5147 fn {register, ...}
5148 => Register.eq(register, register'))
5149 of NONE => (None, NONE)
5150 | SOME {memloc, ...}
5151 => (case allocated {memloc = memloc,
5152 registerAllocation
5153 = registerAllocation}
5154 of NONE
5155 => (Mem memloc, SOME memloc)
5156 | SOME {register, ...}
5157 => (Reg register, SOME memloc))
5158
5159 val to
5160 = case valueRegister
5161 {register = register',
5162 registerAllocation = registerAllocation}
5163 of NONE => None
5164 | SOME {memloc = memloc', ...}
5165 => (case List.peek
5166 (caches,
5167 fn {memloc, ...}
5168 => MemLoc.eq(memloc, memloc'))
5169 of NONE => None
5170 | SOME {register, ...} => Reg register)
5171 in
5172 (from, m, register', to)
5173 end)
5174
5175 fun computeEdges {registerAllocation}
5176 = List.revMap
5177 (Register.allReg,
5178 fn reg
5179 => (reg, computeEdges' {reg = reg,
5180 registerAllocation = registerAllocation}))
5181
5182 fun doitSelf {edges,
5183 saves,
5184 assembly,
5185 registerAllocation}
5186 = let
5187 val {yes = self, no = edges}
5188 = List.partition
5189 (edges,
5190 fn (_, edges')
5191 => List.forall
5192 (edges',
5193 fn (Reg rf, _, r, Reg rt)
5194 => Register.eq(rf, r) andalso
5195 Register.eq(r, rt)
5196 | _ => false))
5197 in
5198 if not (List.isEmpty self)
5199 then let
5200 val saves_self
5201 = List.fold
5202 (self,
5203 [],
5204 fn ((_, edges'), saves)
5205 => List.fold
5206 (edges',
5207 saves,
5208 fn ((_,_,r,_), saves)
5209 => (Operand.register r)::saves))
5210 in
5211 doit {edges = edges,
5212 saves = saves_self @ saves,
5213 assembly = assembly,
5214 registerAllocation = registerAllocation}
5215 end
5216 else doitEasy {edges = edges,
5217 saves = saves,
5218 assembly = assembly,
5219 registerAllocation = registerAllocation}
5220 end
5221
5222 and doitEasy {edges,
5223 saves,
5224 assembly,
5225 registerAllocation}
5226 = let
5227 val {easy}
5228 = List.fold
5229 (edges,
5230 {easy = NONE},
5231 fn ((_, edges'), {easy = NONE})
5232 => let
5233 val {easy}
5234 = List.fold
5235 (edges',
5236 {easy = NONE},
5237 fn ((Reg _, SOME m, r, None),
5238 {easy = NONE})
5239 => {easy = SOME (m, r)}
5240 | (_, {easy})
5241 => {easy = easy})
5242 in
5243 {easy = easy}
5244 end
5245 | ((_, _), {easy})
5246 => {easy = easy})
5247 in
5248 case easy
5249 of SOME (m, r)
5250 => let
5251 val {assembly = assembly_register,
5252 registerAllocation,
5253 ...}
5254 = toRegisterMemLoc
5255 {memloc = m,
5256 info = info,
5257 size = MemLoc.size m,
5258 move = true,
5259 supports = supports,
5260 saves = saves,
5261 force = [r],
5262 registerAllocation = registerAllocation}
5263
5264 val edges = computeEdges
5265 {registerAllocation = registerAllocation}
5266 in
5267 doit {edges = edges,
5268 saves = [],
5269 assembly = AppendList.append
5270 (assembly, assembly_register),
5271 registerAllocation = registerAllocation}
5272 end
5273 | NONE => doitHard {edges = edges,
5274 saves = saves,
5275 assembly = assembly,
5276 registerAllocation = registerAllocation}
5277 end
5278
5279 and doitHard {edges,
5280 saves,
5281 assembly,
5282 registerAllocation}
5283 = let
5284 val {hard}
5285 = List.fold
5286 (edges,
5287 {hard = NONE},
5288 fn ((_, edges'), {hard = NONE})
5289 => let
5290 val {hard}
5291 = List.fold
5292 (edges',
5293 {hard = NONE},
5294 fn ((Mem _, SOME m, r, None),
5295 {hard = NONE})
5296 => {hard = SOME (m, r)}
5297 | (_, {hard})
5298 => {hard = hard})
5299 in
5300 {hard = hard}
5301 end
5302 | ((_, _), {hard})
5303 => {hard = hard})
5304 in
5305 case hard
5306 of SOME (m, r)
5307 => let
5308 val {assembly = assembly_register,
5309 registerAllocation,
5310 ...}
5311 = toRegisterMemLoc
5312 {memloc = m,
5313 info = info,
5314 size = MemLoc.size m,
5315 move = true,
5316 supports = supports,
5317 saves = saves,
5318 force = [r],
5319 registerAllocation = registerAllocation}
5320
5321 val edges = computeEdges
5322 {registerAllocation = registerAllocation}
5323 in
5324 doit {edges = edges,
5325 saves = [],
5326 assembly = AppendList.append
5327 (assembly, assembly_register),
5328 registerAllocation = registerAllocation}
5329 end
5330 | NONE => doitCycle {edges = edges,
5331 saves = saves,
5332 assembly = assembly,
5333 registerAllocation = registerAllocation}
5334 end
5335
5336 and doitCycle {edges,
5337 saves,
5338 assembly,
5339 registerAllocation = registerAllocation}
5340 = let
5341 val {cycle}
5342 = List.fold
5343 (edges,
5344 {cycle = NONE},
5345 fn ((_, edges'), {cycle = NONE})
5346 => let
5347 val {cycle}
5348 = List.fold
5349 (edges',
5350 {cycle = NONE},
5351 fn ((Reg _, SOME m, r, Reg _),
5352 {cycle = NONE})
5353 => {cycle = SOME (m, r)}
5354 | (_, {cycle})
5355 => {cycle = cycle})
5356 in
5357 {cycle = cycle}
5358 end
5359 | ((_, _), {cycle})
5360 => {cycle = cycle})
5361 in
5362 case cycle
5363 of SOME (m, r)
5364 => let
5365 val {assembly = assembly_register,
5366 registerAllocation,
5367 ...}
5368 = toRegisterMemLoc
5369 {memloc = m,
5370 info = info,
5371 size = MemLoc.size m,
5372 move = true,
5373 supports = supports,
5374 saves = saves,
5375 force = [r],
5376 registerAllocation = registerAllocation}
5377
5378 val edges = computeEdges
5379 {registerAllocation = registerAllocation}
5380 in
5381 doit {edges = edges,
5382 saves = [],
5383 assembly = AppendList.append
5384 (assembly, assembly_register),
5385 registerAllocation = registerAllocation}
5386 end
5387 | NONE => doitCycle {edges = edges,
5388 saves = saves,
5389 assembly = assembly,
5390 registerAllocation = registerAllocation}
5391 end
5392
5393 and doit {edges,
5394 saves,
5395 assembly,
5396 registerAllocation}
5397 = let
5398 val edges
5399 = List.fold
5400 (edges,
5401 [],
5402 fn ((reg, edges'), edges)
5403 => let
5404 val edges'
5405 = List.revRemoveAll
5406 (edges',
5407 fn (None, _, _, None) => true
5408 | _ => false)
5409 in
5410 if List.isEmpty edges'
5411 then edges
5412 else (reg, edges')::edges
5413 end)
5414 in
5415 if List.isEmpty edges
5416 then {assembly = assembly,
5417 registerAllocation = registerAllocation}
5418 else doitSelf {edges = edges,
5419 saves = saves,
5420 assembly = assembly,
5421 registerAllocation = registerAllocation}
5422 end
5423
5424 val {assembly = assembly_force,
5425 registerAllocation}
5426 = doit {edges = computeEdges {registerAllocation = registerAllocation},
5427 saves = [],
5428 assembly = AppendList.empty,
5429 registerAllocation = registerAllocation}
5430
5431 val {assembly = assembly_reserve,
5432 registerAllocation}
5433 = reserve {registers = List.revKeepAllMap
5434 (caches,
5435 fn {register, reserve, ...}
5436 => if reserve
5437 then SOME register
5438 else NONE),
5439 registerAllocation = registerAllocation}
5440
5441 in
5442 {assembly = AppendList.append(assembly_force, assembly_reserve),
5443 registerAllocation = registerAllocation}
5444 end
5445
5446 (*
5447 fun cache {caches : {register: Register.t,
5448 memloc: MemLoc.t,
5449 reserve: bool} list,
5450 info,
5451 registerAllocation}
5452 = let
5453 val supports
5454 = List.map
5455 (caches,
5456 fn {memloc, ...} => Operand.memloc memloc)
5457
5458 val {assembly,
5459 registerAllocation,
5460 ...}
5461 = List.foldr
5462 (caches,
5463 {assembly = AppendList.empty,
5464 registerAllocation = registerAllocation,
5465 saves = []},
5466 fn (cache as {register,
5467 memloc,
5468 reserve},
5469 {assembly,
5470 registerAllocation,
5471 saves})
5472 => let
5473 val {register,
5474 assembly = assembly_register,
5475 registerAllocation}
5476 = toRegisterMemLoc
5477 {memloc = memloc,
5478 info = info,
5479 size = MemLoc.size memloc,
5480 move = true,
5481 supports = supports,
5482 saves = saves,
5483 force = [register],
5484 registerAllocation = registerAllocation}
5485
5486 val {assembly = assembly_reserve,
5487 registerAllocation}
5488 = if reserve
5489 then reserve' {register = register,
5490 registerAllocation = registerAllocation}
5491 else {assembly = AppendList.empty,
5492 registerAllocation = registerAllocation}
5493 in
5494 {assembly = AppendList.appends [assembly,
5495 assembly_register,
5496 assembly_reserve],
5497 registerAllocation = registerAllocation,
5498 saves = (Operand.memloc memloc)::saves}
5499 end)
5500 in
5501 {assembly = assembly,
5502 registerAllocation = registerAllocation}
5503 end
5504 *)
5505
5506 fun fltcache {caches : {memloc: MemLoc.t} list,
5507 info,
5508 registerAllocation}
5509 = let
5510 val supports
5511 = List.revMap
5512 (caches,
5513 fn {memloc, ...} => Operand.memloc memloc)
5514
5515 val {assembly = assembly_load,
5516 registerAllocation,
5517 ...}
5518 = List.foldr
5519 (caches,
5520 {assembly = AppendList.empty,
5521 registerAllocation = registerAllocation,
5522 saves = []},
5523 fn ({memloc: MemLoc.t},
5524 {assembly,
5525 registerAllocation,
5526 saves})
5527 => let
5528 val {assembly = assembly_fltregister,
5529 registerAllocation,
5530 ...}
5531 = toFltRegisterMemLoc
5532 {memloc = memloc,
5533 info = info,
5534 size = MemLoc.size memloc,
5535 move = true,
5536 supports = supports,
5537 saves = saves,
5538 top = SOME false,
5539 registerAllocation = registerAllocation}
5540 in
5541 {assembly = AppendList.append (assembly,
5542 assembly_fltregister),
5543 registerAllocation = registerAllocation,
5544 saves = (Operand.memloc memloc)::saves}
5545 end)
5546
5547 val (num_caches,
5548 dest_caches)
5549 = List.fold
5550 (caches,
5551 (0,[]),
5552 fn ({memloc},
5553 (num_caches, dest_caches))
5554 => (num_caches + 1,
5555 {memloc = memloc,
5556 fltregister = FltRegister.T num_caches}::dest_caches))
5557
5558 fun check {assembly, registerAllocation}
5559 = let
5560 val {fltstack, ...} = registerAllocation
5561 val disp = (List.length fltstack) - num_caches
5562
5563 val dest
5564 = fn (FltRegister.T i) => FltRegister.T (i + disp)
5565
5566 val rec check'
5567 = fn [] => {assembly = assembly,
5568 registerAllocation = registerAllocation}
5569 | ({fltregister,
5570 memloc,
5571 ...}: fltvalue)::fltstack
5572 => (case List.peek
5573 (dest_caches,
5574 fn {memloc = memloc', ...}
5575 => MemLoc.eq(memloc, memloc'))
5576 of SOME {fltregister = fltregister', ...}
5577 => let
5578 val fltregister' = dest fltregister'
5579 in
5580 if FltRegister.eq
5581 (fltregister,
5582 fltregister')
5583 then check' fltstack
5584 else let
5585 val fltregister''
5586 = if FltRegister.eq
5587 (fltregister,
5588 FltRegister.top)
5589 then fltregister'
5590 else fltregister
5591
5592 val {registerAllocation,
5593 ...}
5594 = fltxch'
5595 {fltregister = fltregister'',
5596 registerAllocation
5597 = registerAllocation}
5598
5599 val assembly_xch
5600 = AppendList.single
5601 (Assembly.instruction_fxch
5602 {src = Operand.fltregister
5603 fltregister''})
5604 in
5605 check
5606 {assembly
5607 = AppendList.append (assembly,
5608 assembly_xch),
5609 registerAllocation = registerAllocation}
5610 end
5611 end
5612 | NONE
5613 => let
5614 val registerAllocation
5615 = fltvalueMap
5616 {map = fn value as {fltregister,
5617 memloc,
5618 weight,
5619 sync,
5620 ...}
5621 => if FltRegister.eq
5622 (fltregister,
5623 FltRegister.top)
5624 then {fltregister = fltregister,
5625 memloc = memloc,
5626 weight = weight,
5627 sync = sync,
5628 commit = REMOVE 0}
5629 else value,
5630 registerAllocation = registerAllocation}
5631
5632 val {assembly = assembly_commit,
5633 registerAllocation,
5634 ...}
5635 = commitFltRegisters
5636 {info = info,
5637 supports = supports,
5638 saves = [],
5639 registerAllocation
5640 = registerAllocation}
5641 in
5642 check {assembly
5643 = AppendList.append (assembly,
5644 assembly_commit),
5645 registerAllocation = registerAllocation}
5646 end)
5647 in
5648 check' fltstack
5649 end
5650
5651 val {assembly = assembly_shuffle,
5652 registerAllocation}
5653 = check {assembly = AppendList.empty,
5654 registerAllocation = registerAllocation}
5655 in
5656 {assembly = AppendList.appends [assembly_load,
5657 assembly_shuffle],
5658 registerAllocation = registerAllocation}
5659 end
5660
5661
5662 fun reset ({...}: {registerAllocation: t})
5663 = {assembly = AppendList.empty,
5664 registerAllocation = empty ()}
5665
5666 fun force {commit_memlocs: MemLocSet.t,
5667 commit_classes: ClassSet.t,
5668 remove_memlocs: MemLocSet.t,
5669 remove_classes: ClassSet.t,
5670 dead_memlocs: MemLocSet.t,
5671 dead_classes: ClassSet.t,
5672 info: Liveness.t,
5673 registerAllocation: t}
5674 = let
5675 val toCommit
5676 = fn TRYREMOVE _ => REMOVE 0
5677 | REMOVE _ => REMOVE 0
5678 | _ => COMMIT 0
5679 val toRemove
5680 = fn _ => REMOVE 0
5681
5682 val shouldCommit
5683 = fn memloc => (MemLocSet.contains(commit_memlocs,
5684 memloc)
5685 orelse
5686 ClassSet.contains(commit_classes,
5687 MemLoc.class memloc))
5688 val shouldRemove
5689 = fn memloc => (MemLocSet.contains(remove_memlocs,
5690 memloc)
5691 orelse
5692 ClassSet.contains(remove_classes,
5693 MemLoc.class memloc))
5694 val shouldDead
5695 = fn memloc => (MemLocSet.contains(dead_memlocs,
5696 memloc)
5697 orelse
5698 ClassSet.contains(dead_classes,
5699 MemLoc.class memloc))
5700
5701 val registerAllocation
5702 = fltvalueMap {map
5703 = fn value as {fltregister,
5704 memloc,
5705 weight,
5706 sync,
5707 commit}
5708 => case (shouldCommit memloc,
5709 shouldRemove memloc,
5710 shouldDead memloc)
5711 of (true,false,false)
5712 => {fltregister = fltregister,
5713 memloc = memloc,
5714 weight = weight,
5715 sync = sync,
5716 commit = toCommit commit}
5717 | (false,true,false)
5718 => {fltregister = fltregister,
5719 memloc = memloc,
5720 weight = weight,
5721 sync = sync,
5722 commit = toRemove commit}
5723 | (false,false,true)
5724 => {fltregister = fltregister,
5725 memloc = memloc,
5726 weight = weight,
5727 sync = true,
5728 commit = toRemove commit}
5729 | (false,false,false)
5730 => if List.exists
5731 (MemLoc.utilized memloc,
5732 fn memloc' => shouldDead memloc')
5733 then {fltregister = fltregister,
5734 memloc = memloc,
5735 weight = weight,
5736 sync = sync,
5737 commit = toRemove commit}
5738 else if List.exists
5739 (MemLoc.utilized memloc,
5740 fn memloc' => shouldRemove memloc')
5741 then {fltregister = fltregister,
5742 memloc = memloc,
5743 weight = weight,
5744 sync = sync,
5745 commit = toCommit commit}
5746 else value
5747 | _ => Error.bug "x86AllocateRegisters.RegisterAllocation.force",
5748 registerAllocation = registerAllocation}
5749
5750 val {assembly = assembly_commit_fltregisters,
5751 registerAllocation,
5752 ...}
5753 = commitFltRegisters {info = info,
5754 supports = [],
5755 saves = [],
5756 registerAllocation
5757 = registerAllocation}
5758
5759 val registerAllocation
5760 = valueMap {map
5761 = fn value as {register,
5762 memloc,
5763 weight,
5764 sync,
5765 commit}
5766 => case (shouldCommit memloc,
5767 shouldRemove memloc,
5768 shouldDead memloc)
5769 of (true,false,false)
5770 => {register = register,
5771 memloc = memloc,
5772 weight = weight,
5773 sync = sync,
5774 commit = toCommit commit}
5775 | (false,true,false)
5776 => {register = register,
5777 memloc = memloc,
5778 weight = weight,
5779 sync = sync,
5780 commit = toRemove commit}
5781 | (false,false,true)
5782 => value
5783 | (false,false,false)
5784 => if List.exists
5785 (MemLoc.utilized memloc,
5786 fn memloc' => shouldDead memloc')
5787 then {register = register,
5788 memloc = memloc,
5789 weight = weight,
5790 sync = sync,
5791 commit = toRemove commit}
5792 else if List.exists
5793 (MemLoc.utilized memloc,
5794 fn memloc' => shouldRemove memloc')
5795 then {register = register,
5796 memloc = memloc,
5797 weight = weight,
5798 sync = sync,
5799 commit = toCommit commit}
5800 else value
5801 | _ => Error.bug "x86AllocateRegisters.RegisterAllocation.force",
5802 registerAllocation = registerAllocation}
5803
5804 val {assembly = assembly_commit_registers,
5805 registerAllocation}
5806 = commitRegisters {info = info,
5807 supports = [],
5808 saves = [],
5809 registerAllocation
5810 = registerAllocation}
5811
5812 val registerAllocation
5813 = valueMap {map
5814 = fn value as {register,
5815 memloc,
5816 weight,
5817 commit,
5818 ...}
5819 => if shouldDead memloc
5820 then {register = register,
5821 memloc = memloc,
5822 weight = weight,
5823 sync = true,
5824 commit = toRemove commit}
5825 else value,
5826 registerAllocation = registerAllocation}
5827
5828 val {assembly = assembly_dead_registers,
5829 registerAllocation}
5830 = commitRegisters {info = info,
5831 supports = [],
5832 saves = [],
5833 registerAllocation
5834 = registerAllocation}
5835 in
5836 {assembly = AppendList.appends
5837 [assembly_commit_fltregisters,
5838 assembly_commit_registers,
5839 assembly_dead_registers],
5840 registerAllocation = registerAllocation}
5841 end
5842
5843 fun ccall {info: Liveness.t,
5844 registerAllocation: t}
5845 = let
5846 val cstaticClasses = !x86MLton.Classes.cstaticClasses
5847
5848 val {reserved = reservedStart, ...} = registerAllocation
5849
5850 val {assembly = assembly_reserve,
5851 registerAllocation}
5852 = List.fold
5853 (Register.callerSaveRegisters,
5854 {assembly = AppendList.empty,
5855 registerAllocation = registerAllocation},
5856 fn (register, {assembly, registerAllocation})
5857 => let
5858 val {assembly = assembly_reserve,
5859 registerAllocation}
5860 = reserve' {register = register,
5861 registerAllocation = registerAllocation}
5862 in
5863 {assembly = AppendList.append (assembly,
5864 assembly_reserve),
5865 registerAllocation = registerAllocation}
5866 end)
5867
5868 val availCalleeSaveRegisters =
5869 List.keepAll
5870 (Register.calleeSaveRegisters,
5871 fn calleeSaveReg =>
5872 List.forall
5873 (#reserved registerAllocation,
5874 fn reservedReg =>
5875 not (Register.coincide (reservedReg, calleeSaveReg))))
5876
5877 val {assembly = assembly_shuffle,
5878 registerAllocation, ...}
5879 = if !Control.Native.shuffle then
5880 List.fold
5881 (valueFilter {filter = fn {register, ...}
5882 => List.contains
5883 (Register.callerSaveRegisters,
5884 register,
5885 Register.eq)
5886 andalso
5887 List.exists
5888 (availCalleeSaveRegisters,
5889 fn calleeSaveReg =>
5890 Size.eq (Register.size register,
5891 Register.size calleeSaveReg)),
5892 registerAllocation = registerAllocation},
5893 {assembly = AppendList.empty,
5894 registerAllocation = registerAllocation},
5895 fn ({memloc, ...}, {assembly, registerAllocation})
5896 => let
5897 val {assembly = assembly_shuffle,
5898 registerAllocation, ...}
5899 = allocateOperand {operand = Operand.memloc memloc,
5900 options = {register = true,
5901 immediate = false,
5902 label = false,
5903 address = true},
5904 info = info,
5905 size = MemLoc.size memloc,
5906 move = true,
5907 supports = [],
5908 saves = [],
5909 force = Register.calleeSaveRegisters,
5910 registerAllocation
5911 = registerAllocation}
5912 in
5913 {assembly = AppendList.append (assembly,
5914 assembly_shuffle),
5915 registerAllocation = registerAllocation}
5916 end)
5917 else {assembly = AppendList.empty,
5918 registerAllocation = registerAllocation}
5919
5920 val registerAllocation
5921 = valueMap {map = fn value as {register,
5922 memloc,
5923 weight,
5924 sync,
5925 ...}
5926 => if List.contains
5927 (Register.callerSaveRegisters,
5928 register,
5929 Register.eq)
5930 orelse
5931 ClassSet.contains
5932 (cstaticClasses,
5933 MemLoc.class memloc)
5934 then {register = register,
5935 memloc = memloc,
5936 weight = weight,
5937 sync = sync,
5938 commit = REMOVE 0}
5939 else value,
5940 registerAllocation = registerAllocation}
5941
5942 val registerAllocation
5943 = fltvalueMap {map = fn {fltregister,
5944 memloc,
5945 weight,
5946 sync,
5947 ...}
5948 => {fltregister = fltregister,
5949 memloc = memloc,
5950 weight = weight,
5951 sync = sync,
5952 commit = REMOVE 0},
5953 registerAllocation = registerAllocation}
5954
5955 val {assembly = assembly_commit_fltregisters,
5956 registerAllocation, ...}
5957 = commitFltRegisters {info = info,
5958 supports = [],
5959 saves = [],
5960 registerAllocation = registerAllocation}
5961
5962 val {assembly = assembly_commit_registers,
5963 registerAllocation}
5964 = commitRegisters {info = info,
5965 supports = [],
5966 saves = [],
5967 registerAllocation = registerAllocation}
5968
5969 val {assembly = assembly_unreserve,
5970 registerAllocation}
5971 = List.fold
5972 (List.removeAll
5973 (Register.callerSaveRegisters,
5974 fn register => List.contains(reservedStart, register, Register.eq)),
5975 {assembly = AppendList.empty,
5976 registerAllocation = registerAllocation},
5977 fn (register, {assembly, registerAllocation})
5978 => let
5979 val {assembly = assembly_unreserve,
5980 registerAllocation}
5981 = unreserve' {register = register,
5982 registerAllocation = registerAllocation}
5983 in
5984 {assembly = AppendList.append (assembly,
5985 assembly_unreserve),
5986 registerAllocation = registerAllocation}
5987 end)
5988
5989 val registerAllocation
5990 = deletes {registers = Register.callerSaveRegisters,
5991 registerAllocation = registerAllocation}
5992 in
5993 {assembly = AppendList.appends
5994 [assembly_reserve,
5995 assembly_shuffle,
5996 assembly_commit_fltregisters,
5997 assembly_commit_registers,
5998 assembly_unreserve],
5999 registerAllocation = registerAllocation}
6000 end
6001
6002 fun return {returns: {src: Operand.t, dst: MemLoc.t} list,
6003 info: Liveness.t,
6004 registerAllocation: t} =
6005 let
6006 val killed_values =
6007 valueFilter {filter = fn {memloc, ...} =>
6008 List.exists
6009 (returns, fn {dst = return_memloc, ...} =>
6010 List.exists(MemLoc.utilized memloc,
6011 fn memloc' =>
6012 MemLoc.eq(memloc', return_memloc))
6013 orelse
6014 MemLoc.mayAlias(return_memloc, memloc)),
6015 registerAllocation = registerAllocation}
6016 val killed_memlocs = List.revMap(killed_values, #memloc)
6017
6018 val registerAllocation =
6019 removes {memlocs = killed_memlocs,
6020 registerAllocation = registerAllocation}
6021
6022 val registerAllocation =
6023 List.fold
6024 (returns, registerAllocation, fn ({src = operand,
6025 dst = return_memloc}, registerAllocation) =>
6026 case operand of
6027 Operand.Register return_register =>
6028 update {value = {register = return_register,
6029 memloc = return_memloc,
6030 weight = 1024,
6031 sync = false,
6032 commit = NO},
6033 registerAllocation = registerAllocation}
6034 | Operand.FltRegister return_register =>
6035 #registerAllocation
6036 (fltpush {value = {fltregister = return_register,
6037 memloc = return_memloc,
6038 weight = 1024,
6039 sync = false,
6040 commit = NO},
6041 registerAllocation = registerAllocation})
6042 | _ => Error.bug "x86AllocateRegisters.RegisterAllocation.return")
6043
6044 val (final_defs, defs) =
6045 List.fold
6046 (returns, ([],[]), fn ({src,dst},(final_defs,defs)) =>
6047 (src::final_defs,(Operand.memloc dst)::defs))
6048 val {assembly = assembly_post,
6049 registerAllocation}
6050 = post {uses = [],
6051 final_uses = [],
6052 defs = defs,
6053 final_defs = final_defs,
6054 kills = [],
6055 info = info,
6056 registerAllocation = registerAllocation}
6057 in
6058 {assembly = assembly_post,
6059 registerAllocation = registerAllocation}
6060 end
6061
6062 (*
6063 fun return {memloc = return_memloc,
6064 info: Liveness.t,
6065 registerAllocation: t}
6066 = let
6067 val killed_values
6068 = valueFilter {filter = fn value as {memloc,...}
6069 => List.exists
6070 (MemLoc.utilized memloc,
6071 fn memloc'
6072 => MemLoc.eq(memloc',
6073 return_memloc))
6074 orelse
6075 MemLoc.mayAlias(return_memloc,
6076 memloc),
6077 registerAllocation = registerAllocation}
6078 val killed_memlocs = List.revMap(killed_values, #memloc)
6079
6080 val registerAllocation
6081 = removes {memlocs = killed_memlocs,
6082 registerAllocation = registerAllocation}
6083
6084 val return_register = Register.return (MemLoc.size return_memloc)
6085 val registerAllocation
6086 = update
6087 {value = {register = return_register,
6088 memloc = return_memloc,
6089 weight = 1024,
6090 sync = false,
6091 commit = NO},
6092 registerAllocation = registerAllocation}
6093
6094 val {assembly = assembly_post,
6095 registerAllocation}
6096 = post {uses = [],
6097 final_uses = [],
6098 defs = [Operand.memloc return_memloc],
6099 final_defs = [Operand.register return_register],
6100 kills = [],
6101 info = info,
6102 registerAllocation = registerAllocation}
6103 in
6104 {assembly = assembly_post,
6105 registerAllocation = registerAllocation}
6106 end
6107
6108 fun fltreturn {memloc = return_memloc,
6109 info: Liveness.t,
6110 registerAllocation: t}
6111 = let
6112 val return_register = FltRegister.return
6113
6114 val {fltrename = fltrename_push,
6115 registerAllocation}
6116 = fltpush
6117 {value = {fltregister = return_register,
6118 memloc = return_memloc,
6119 weight = 1024,
6120 sync = false,
6121 commit = NO},
6122 registerAllocation = registerAllocation}
6123
6124 val {assembly = assembly_post,
6125 registerAllocation}
6126 = post {uses = [],
6127 final_uses = [],
6128 defs = [Operand.memloc return_memloc],
6129 final_defs = [Operand.fltregister return_register],
6130 kills = [],
6131 info = info,
6132 registerAllocation = registerAllocation}
6133
6134 in
6135 {assembly = assembly_post,
6136 registerAllocation = registerAllocation}
6137 end
6138 *)
6139
6140 fun clearflt {info: Liveness.t,
6141 registerAllocation: t}
6142 = let
6143 val registerAllocation
6144 = fltvalueMap {map = fn {fltregister,
6145 memloc,
6146 weight,
6147 sync,
6148 ...}
6149 => {fltregister = fltregister,
6150 memloc = memloc,
6151 weight = weight,
6152 sync = sync,
6153 commit = REMOVE 0},
6154 registerAllocation = registerAllocation}
6155
6156 val {assembly = assembly_commit_fltregisters,
6157 registerAllocation,
6158 ...}
6159 = commitFltRegisters {info = info,
6160 supports = [],
6161 saves = [],
6162 registerAllocation = registerAllocation}
6163 in
6164 {assembly = assembly_commit_fltregisters,
6165 registerAllocation = registerAllocation}
6166 end
6167
6168 fun saveregalloc ({id, registerAllocation, ...}:
6169 {live: MemLocSet.t,
6170 id: Directive.Id.t,
6171 info: Liveness.t,
6172 registerAllocation: t})
6173 = let
6174 val _ = setRA(id, {registerAllocation = registerAllocation})
6175 in
6176 {assembly = if !Control.Native.commented > 2
6177 then (toComments registerAllocation)
6178 else AppendList.empty,
6179 registerAllocation = registerAllocation}
6180 end
6181
6182 fun restoreregalloc ({live, id, info, ...}:
6183 {live: MemLocSet.t,
6184 id: Directive.Id.t,
6185 info: Liveness.t,
6186 registerAllocation: t})
6187 = let
6188 val {registerAllocation} = getRA id
6189
6190 fun dump memloc
6191 = (track memloc) andalso
6192 not (MemLocSet.contains(live,memloc))
6193
6194 val registerAllocation
6195 = fltvalueMap
6196 {map = fn value as {fltregister,
6197 memloc,
6198 weight,
6199 sync,
6200 ...}
6201 => if dump memloc
6202 then {fltregister = fltregister,
6203 memloc = memloc,
6204 weight = weight,
6205 sync = true,
6206 commit = TRYREMOVE 0}
6207 else if List.exists(MemLoc.utilized memloc, dump)
6208 then {fltregister = fltregister,
6209 memloc = memloc,
6210 weight = weight,
6211 sync = sync,
6212 commit = TRYREMOVE 0}
6213 else value,
6214 registerAllocation = registerAllocation}
6215
6216 val {assembly = assembly_commit_fltregisters,
6217 registerAllocation,
6218 ...}
6219 = commitFltRegisters {info = info,
6220 supports = [],
6221 saves = [],
6222 registerAllocation = registerAllocation}
6223
6224 val registerAllocation
6225 = valueMap
6226 {map = fn value as {register,
6227 memloc,
6228 weight,
6229 sync,
6230 ...}
6231 => if dump memloc
6232 then {register = register,
6233 memloc = memloc,
6234 weight = weight,
6235 sync = true,
6236 commit = TRYREMOVE 0}
6237 else if List.exists(MemLoc.utilized memloc, dump)
6238 then {register = register,
6239 memloc = memloc,
6240 weight = weight,
6241 sync = sync,
6242 commit = TRYREMOVE 0}
6243 else value,
6244 registerAllocation = registerAllocation}
6245
6246 val {assembly = assembly_commit_registers,
6247 registerAllocation,
6248 ...}
6249 = commitRegisters {info = info,
6250 supports = [],
6251 saves = [],
6252 registerAllocation = registerAllocation}
6253 in
6254 {assembly = AppendList.append (assembly_commit_fltregisters,
6255 assembly_commit_registers),
6256 registerAllocation = registerAllocation}
6257 end
6258 end
6259
6260 structure Instruction =
6261 struct
6262 structure RA = RegisterAllocation
6263 open Instruction
6264
6265 (*
6266 * Require src/dst operands as follows:
6267 *
6268 * dst
6269 * reg imm lab add
6270 * reg X X
6271 * src imm X X
6272 * lab
6273 * add X
6274 *)
6275 fun allocateSrcDst {src: Operand.t,
6276 dst: Operand.t,
6277 move_dst: bool,
6278 size: Size.t,
6279 info as {dead, remove, ...}: Liveness.t,
6280 registerAllocation: RegisterAllocation.t}
6281 = if Operand.eq(src, dst)
6282 then let
6283 val {operand = final_src_dst,
6284 assembly = assembly_src_dst,
6285 registerAllocation}
6286 = RA.allocateOperand
6287 {operand = src,
6288 options = {register = true,
6289 immediate = false,
6290 label = false,
6291 address = false},
6292 info = info,
6293 size = size,
6294 move = true,
6295 supports = [],
6296 saves = [],
6297 force = [],
6298 registerAllocation
6299 = registerAllocation}
6300 in
6301 {final_src = final_src_dst,
6302 final_dst = final_src_dst,
6303 assembly_src_dst = assembly_src_dst,
6304 registerAllocation = registerAllocation}
6305 end
6306 else case (src, dst)
6307 of (Operand.MemLoc _,
6308 Operand.MemLoc memloc_dst)
6309 => if MemLocSet.contains(dead,
6310 memloc_dst)
6311 orelse
6312 MemLocSet.contains(remove,
6313 memloc_dst)
6314 then let
6315 val {operand = final_dst,
6316 assembly = assembly_dst,
6317 registerAllocation}
6318 = RA.allocateOperand
6319 {operand = dst,
6320 options = {register = true,
6321 immediate = false,
6322 label = false,
6323 address = true},
6324 info = info,
6325 size = size,
6326 move = move_dst,
6327 supports = [src],
6328 saves = [],
6329 force = [],
6330 registerAllocation
6331 = registerAllocation}
6332
6333 val options_src
6334 = case final_dst
6335 of Operand.Register _
6336 => {register = true,
6337 immediate = true,
6338 label = false,
6339 address = true}
6340 | _
6341 => {register = true,
6342 immediate = true,
6343 label = false,
6344 address = false}
6345
6346 val {operand = final_src,
6347 assembly = assembly_src,
6348 registerAllocation}
6349 = RA.allocateOperand
6350 {operand = src,
6351 options = options_src,
6352 info = info,
6353 size = size,
6354 move = true,
6355 supports = [],
6356 saves = [dst,final_dst],
6357 force = [],
6358 registerAllocation
6359 = registerAllocation}
6360 in
6361 {final_src = final_src,
6362 final_dst = final_dst,
6363 assembly_src_dst
6364 = AppendList.appends
6365 [assembly_dst,
6366 assembly_src],
6367 registerAllocation = registerAllocation}
6368 end
6369 else let
6370 val {operand = final_src,
6371 assembly = assembly_src,
6372 registerAllocation}
6373 = RA.allocateOperand
6374 {operand = src,
6375 options = {register = true,
6376 immediate = true,
6377 label = false,
6378 address = true},
6379 info = info,
6380 size = size,
6381 move = true,
6382 supports = [dst],
6383 saves = [],
6384 force = [],
6385 registerAllocation
6386 = registerAllocation}
6387
6388 val {operand = final_dst,
6389 assembly = assembly_dst,
6390 registerAllocation}
6391 = RA.allocateOperand
6392 {operand = dst,
6393 options = {register = true,
6394 immediate = false,
6395 label = false,
6396 address = false},
6397 info = info,
6398 size = size,
6399 move = move_dst,
6400 supports = [],
6401 saves = [src,final_src],
6402 force = [],
6403 registerAllocation
6404 = registerAllocation}
6405 in
6406 {final_src = final_src,
6407 final_dst = final_dst,
6408 assembly_src_dst
6409 = AppendList.appends
6410 [assembly_src,
6411 assembly_dst],
6412 registerAllocation = registerAllocation}
6413 end
6414 | (_,
6415 Operand.MemLoc memloc_dst)
6416 => let
6417 val {operand = final_src,
6418 assembly = assembly_src,
6419 registerAllocation}
6420 = RA.allocateOperand
6421 {operand = src,
6422 options = {register = true,
6423 immediate = true,
6424 label = false,
6425 address = false},
6426 info = info,
6427 size = size,
6428 move = true,
6429 supports = [dst],
6430 saves = [],
6431 force = [],
6432 registerAllocation
6433 = registerAllocation}
6434
6435 fun default ()
6436 = RA.allocateOperand
6437 {operand = dst,
6438 options = {register = true,
6439 immediate = false,
6440 label = false,
6441 address = true},
6442 info = info,
6443 size = size,
6444 move = move_dst,
6445 supports = [],
6446 saves = [src,final_src],
6447 force = [],
6448 registerAllocation
6449 = registerAllocation}
6450
6451 val {operand = final_dst,
6452 assembly = assembly_dst,
6453 registerAllocation}
6454 = if MemLocSet.contains(dead,
6455 memloc_dst)
6456 orelse
6457 MemLocSet.contains(remove,
6458 memloc_dst)
6459 then case RA.allocated
6460 {memloc = memloc_dst,
6461 registerAllocation = registerAllocation}
6462 of SOME {register, sync, ...}
6463 => if sync
6464 then let
6465 val registerAllocation
6466 = RA.delete
6467 {register = register,
6468 registerAllocation
6469 = registerAllocation}
6470 in
6471 RA.allocateOperand
6472 {operand = dst,
6473 options = {register = false,
6474 immediate = false,
6475 label = false,
6476 address = true},
6477 info = info,
6478 size = size,
6479 move = move_dst,
6480 supports = [],
6481 saves = [src,final_src],
6482 force = [],
6483 registerAllocation
6484 = registerAllocation}
6485 end
6486 else default ()
6487 | NONE => default ()
6488 else default ()
6489 in
6490 {final_src = final_src,
6491 final_dst = final_dst,
6492 assembly_src_dst
6493 = AppendList.appends
6494 [assembly_src,
6495 assembly_dst],
6496 registerAllocation = registerAllocation}
6497 end
6498 | _ => Error.bug "x86AllocateRegisters.Instruction.allocateSrcDst"
6499
6500 (*
6501 * Require src1/src2 operands as follows:
6502 *
6503 * src2
6504 * reg imm lab add
6505 * reg X X X
6506 * src1 imm
6507 * lab
6508 * add X X
6509 *)
6510 fun allocateSrc1Src2 {src1: Operand.t,
6511 src2: Operand.t,
6512 size: Size.t,
6513 info: Liveness.t,
6514 registerAllocation: RegisterAllocation.t}
6515 = if Operand.eq(src1, src2)
6516 then let
6517 val {operand = final_src1_src2,
6518 assembly = assembly_src1_src2,
6519 registerAllocation}
6520 = RA.allocateOperand
6521 {operand = src1,
6522 options = {register = true,
6523 immediate = false,
6524 label = false,
6525 address = false},
6526 info = info,
6527 size = size,
6528 move = true,
6529 supports = [],
6530 saves = [],
6531 force = [],
6532 registerAllocation
6533 = registerAllocation}
6534 in
6535 {final_src1 = final_src1_src2,
6536 final_src2 = final_src1_src2,
6537 assembly_src1_src2 = assembly_src1_src2,
6538 registerAllocation = registerAllocation}
6539 end
6540 else let
6541 val {operand = final_src1,
6542 assembly = assembly_src1,
6543 registerAllocation}
6544 = RA.allocateOperand
6545 {operand = src1,
6546 options = {register = true,
6547 immediate = false,
6548 label = false,
6549 address = true},
6550 info = info,
6551 size = size,
6552 move = true,
6553 supports = [src2],
6554 saves = [],
6555 force = [],
6556 registerAllocation
6557 = registerAllocation}
6558
6559 val options_src2
6560 = case final_src1
6561 of Operand.Register _
6562 => {register = true,
6563 immediate = true,
6564 label = false,
6565 address = true}
6566 | _
6567 => {register = true,
6568 immediate = true,
6569 label = false,
6570 address = false}
6571
6572 val {operand = final_src2,
6573 assembly = assembly_src2,
6574 registerAllocation}
6575 = RA.allocateOperand
6576 {operand = src2,
6577 options = options_src2,
6578 info = info,
6579 size = size,
6580 move = true,
6581 supports = [],
6582 saves = [src1,final_src1],
6583 force = [],
6584 registerAllocation
6585 = registerAllocation}
6586 in
6587 {final_src1 = final_src1,
6588 final_src2 = final_src2,
6589 assembly_src1_src2
6590 = AppendList.appends
6591 [assembly_src1,
6592 assembly_src2],
6593 registerAllocation = registerAllocation}
6594 end
6595
6596 fun pfmov {instruction, info as {dead, remove, ...},
6597 registerAllocation,
6598 src, dst, srcsize, dstsize} =
6599 let
6600 fun default ()
6601 = let
6602 val {uses,defs,kills}
6603 = Instruction.uses_defs_kills instruction
6604 val {assembly = assembly_pre,
6605 registerAllocation}
6606 = RA.pre {uses = uses,
6607 defs = defs,
6608 kills = kills,
6609 info = info,
6610 registerAllocation = registerAllocation}
6611
6612 val {operand = final_src,
6613 assembly = assembly_src,
6614 registerAllocation,
6615 ...}
6616 = RA.allocateFltOperand
6617 {operand = src,
6618 options = {fltregister = true,
6619 address = true},
6620 info = info,
6621 size = srcsize,
6622 move = true,
6623 supports = [dst],
6624 saves = [],
6625 top = SOME false,
6626 registerAllocation
6627 = registerAllocation}
6628
6629 val {assembly = assembly_dst,
6630 fltrename = fltrename_dst,
6631 registerAllocation,
6632 ...}
6633 = RA.allocateFltOperand
6634 {operand = dst,
6635 options = {fltregister = true,
6636 address = false},
6637 info = info,
6638 size = dstsize,
6639 move = false,
6640 supports = [],
6641 saves = [src,final_src],
6642 top = NONE,
6643 registerAllocation
6644 = registerAllocation}
6645
6646 val final_src = (RA.fltrenameLift fltrename_dst) final_src
6647
6648 val instruction
6649 = Instruction.FLD
6650 {src = final_src,
6651 size = srcsize}
6652
6653 val {uses = final_uses,
6654 defs = final_defs,
6655 ...}
6656 = Instruction.uses_defs_kills instruction
6657
6658 val {assembly = assembly_post,
6659 registerAllocation}
6660 = RA.post {uses = uses,
6661 final_uses = final_uses,
6662 defs = defs,
6663 final_defs = final_defs,
6664 kills = kills,
6665 info = info,
6666 registerAllocation = registerAllocation}
6667 in
6668 {assembly
6669 = AppendList.appends
6670 [assembly_pre,
6671 assembly_src,
6672 assembly_dst,
6673 AppendList.single
6674 (Assembly.instruction instruction),
6675 assembly_post],
6676 registerAllocation = registerAllocation}
6677 end
6678
6679 fun default' ()
6680 = let
6681 val {uses,defs,kills}
6682 = Instruction.uses_defs_kills instruction
6683 val {assembly = assembly_pre,
6684 registerAllocation}
6685 = RA.pre {uses = uses,
6686 defs = defs,
6687 kills = kills,
6688 info = info,
6689 registerAllocation = registerAllocation}
6690
6691 val {operand = final_src,
6692 assembly = assembly_src,
6693 registerAllocation,
6694 ...}
6695 = RA.allocateFltOperand
6696 {operand = src,
6697 options = {fltregister = true,
6698 address = false},
6699 info = info,
6700 size = srcsize,
6701 move = true,
6702 supports = [dst],
6703 saves = [],
6704 top = SOME true,
6705 registerAllocation = registerAllocation}
6706
6707 val {operand = final_dst,
6708 assembly = assembly_dst,
6709 registerAllocation,
6710 ...}
6711 = RA.allocateFltOperand
6712 {operand = dst,
6713 options = {fltregister = false,
6714 address = true},
6715 info = info,
6716 size = dstsize,
6717 move = false,
6718 supports = [],
6719 saves = [src,final_src],
6720 top = SOME false,
6721 registerAllocation = registerAllocation}
6722
6723 val instruction
6724 = Instruction.FST
6725 {dst = final_dst,
6726 size = dstsize,
6727 pop = true}
6728
6729 val {fltrename = fltrename_pop,
6730 registerAllocation}
6731 = RA.fltpop {registerAllocation = registerAllocation}
6732
6733 val {uses = final_uses,
6734 defs = final_defs,
6735 ...}
6736 = Instruction.uses_defs_kills instruction
6737
6738 val final_uses
6739 = List.revMap(final_uses, RA.fltrenameLift fltrename_pop)
6740 val final_defs
6741 = List.revMap(final_defs, RA.fltrenameLift fltrename_pop)
6742
6743 val {assembly = assembly_post,
6744 registerAllocation}
6745 = RA.post {uses = uses,
6746 final_uses = final_uses,
6747 defs = defs,
6748 final_defs = final_defs,
6749 kills = kills,
6750 info = info,
6751 registerAllocation = registerAllocation}
6752 in
6753 {assembly
6754 = AppendList.appends
6755 [assembly_pre,
6756 assembly_src,
6757 assembly_dst,
6758 AppendList.single
6759 (Assembly.instruction instruction),
6760 assembly_post],
6761 registerAllocation = registerAllocation}
6762 end
6763 in
6764 case (src,dst)
6765 of (Operand.MemLoc memloc_src,
6766 Operand.MemLoc memloc_dst)
6767 => (case (RA.fltallocated {memloc = memloc_src,
6768 registerAllocation
6769 = registerAllocation},
6770 RA.fltallocated {memloc = memloc_dst,
6771 registerAllocation
6772 = registerAllocation})
6773 of (SOME {fltregister = fltregister_src,
6774 sync = sync_src,
6775 commit = commit_src,
6776 ...},
6777 NONE)
6778 => if MemLocSet.contains(dead,memloc_src)
6779 orelse
6780 (MemLocSet.contains(remove,memloc_src)
6781 andalso
6782 sync_src)
6783 then if MemLocSet.contains(remove,
6784 memloc_dst)
6785 then default' ()
6786 else let
6787 val registerAllocation
6788 = RA.fltupdate
6789 {value = {fltregister
6790 = fltregister_src,
6791 memloc
6792 = memloc_dst,
6793 weight = 1024,
6794 sync = false,
6795 commit
6796 = commit_src},
6797 registerAllocation
6798 = registerAllocation}
6799
6800 val {uses,defs,kills}
6801 = Instruction.uses_defs_kills
6802 instruction
6803 val {assembly = assembly_pre,
6804 registerAllocation}
6805 = RA.pre
6806 {uses = uses,
6807 defs = defs,
6808 kills = kills,
6809 info = info,
6810 registerAllocation
6811 = registerAllocation}
6812
6813 val final_uses = []
6814 val final_defs
6815 = [Operand.fltregister
6816 fltregister_src]
6817
6818 val {assembly = assembly_post,
6819 registerAllocation}
6820 = RA.post
6821 {uses = uses,
6822 final_uses = final_uses,
6823 defs = defs,
6824 final_defs = final_defs,
6825 kills = kills,
6826 info = info,
6827 registerAllocation
6828 = registerAllocation}
6829 in
6830 {assembly
6831 = AppendList.appends
6832 [assembly_pre,
6833 assembly_post],
6834 registerAllocation
6835 = registerAllocation}
6836 end
6837 else default ()
6838 | _ => default ())
6839 | _ => default ()
6840 end
6841
6842
6843 fun removable {memloc,
6844 info = {dead, remove, ...}: Liveness.t,
6845 registerAllocation}
6846 = MemLocSet.contains(dead,
6847 memloc)
6848 orelse
6849 (MemLocSet.contains(remove,
6850 memloc)
6851 andalso
6852 (case RA.fltallocated {memloc = memloc,
6853 registerAllocation = registerAllocation}
6854 of SOME {sync,...} => sync
6855 | NONE => true))
6856
6857 fun allocateRegisters {instruction: t,
6858 info as {dead, remove, ...}: Liveness.t,
6859 registerAllocation: RegisterAllocation.t}
6860 = case instruction
6861 of NOP
6862 (* No operation; p. 496 *)
6863 => let
6864 val {uses,defs,kills}
6865 = Instruction.uses_defs_kills instruction
6866 val {assembly = assembly_pre,
6867 registerAllocation}
6868 = RA.pre {uses = uses,
6869 defs = defs,
6870 kills = kills,
6871 info = info,
6872 registerAllocation = registerAllocation}
6873
6874 val instruction
6875 = Instruction.NOP
6876
6877 val {uses = final_uses,
6878 defs = final_defs,
6879 ...}
6880 = Instruction.uses_defs_kills instruction
6881
6882 val {assembly = assembly_post,
6883 registerAllocation}
6884 = RA.post {uses = uses,
6885 final_uses = final_uses,
6886 defs = defs,
6887 final_defs = final_defs,
6888 kills = kills,
6889 info = info,
6890 registerAllocation = registerAllocation}
6891 in
6892 {assembly
6893 = AppendList.appends
6894 [assembly_pre,
6895 AppendList.single (Assembly.instruction instruction),
6896 assembly_post],
6897 registerAllocation = registerAllocation}
6898 end
6899 | HLT
6900 (* Halt; p. 331 *)
6901 => let
6902 val {uses,defs,kills}
6903 = Instruction.uses_defs_kills instruction
6904 val {assembly = assembly_pre,
6905 registerAllocation}
6906 = RA.pre {uses = uses,
6907 defs = defs,
6908 kills = kills,
6909 info = info,
6910 registerAllocation = registerAllocation}
6911
6912 val instruction
6913 = Instruction.HLT
6914
6915 val {uses = final_uses,
6916 defs = final_defs,
6917 ...}
6918 = Instruction.uses_defs_kills instruction
6919
6920 val {assembly = assembly_post,
6921 registerAllocation}
6922 = RA.post {uses = uses,
6923 final_uses = final_uses,
6924 defs = defs,
6925 final_defs = final_defs,
6926 kills = kills,
6927 info = info,
6928 registerAllocation = registerAllocation}
6929 in
6930 {assembly
6931 = AppendList.appends
6932 [assembly_pre,
6933 AppendList.single (Assembly.instruction instruction),
6934 assembly_post],
6935 registerAllocation = registerAllocation}
6936 end
6937 | BinAL {oper, src, dst, size}
6938 (* Integer binary arithmetic(w/o mult & div)/logic instructions.
6939 * Require src/dst operands as follows:
6940 *
6941 * dst
6942 * reg imm lab add
6943 * reg X X
6944 * src imm X X
6945 * lab
6946 * add X
6947 *)
6948 => let
6949 val {uses,defs,kills}
6950 = Instruction.uses_defs_kills instruction
6951 val {assembly = assembly_pre,
6952 registerAllocation}
6953 = RA.pre {uses = uses,
6954 defs = defs,
6955 kills = kills,
6956 info = info,
6957 registerAllocation = registerAllocation}
6958
6959 fun default ()
6960 = let
6961 val {final_src,
6962 final_dst,
6963 assembly_src_dst,
6964 registerAllocation}
6965 = allocateSrcDst {src = src,
6966 dst = dst,
6967 move_dst = true,
6968 size = size,
6969 info = info,
6970 registerAllocation = registerAllocation}
6971
6972 val instruction
6973 = Instruction.BinAL
6974 {oper = oper,
6975 src = final_src,
6976 dst = final_dst,
6977 size = size}
6978
6979 val {uses = final_uses,
6980 defs = final_defs,
6981 ...}
6982 = Instruction.uses_defs_kills instruction
6983
6984 val {assembly = assembly_post,
6985 registerAllocation}
6986 = RA.post {uses = uses,
6987 final_uses = final_uses,
6988 defs = defs,
6989 final_defs = final_defs,
6990 kills = kills,
6991 info = info,
6992 registerAllocation = registerAllocation}
6993 in
6994 {assembly
6995 = AppendList.appends
6996 [assembly_pre,
6997 assembly_src_dst,
6998 AppendList.single
6999 (Assembly.instruction instruction),
7000 assembly_post],
7001 registerAllocation = registerAllocation}
7002 end
7003 in
7004 default ()
7005 end
7006 | pMD {oper, dst, src, size}
7007 (* Integer multiplication and division.
7008 * Require src operand as follows:
7009 *
7010 * src
7011 * reg imm lab add
7012 * X X
7013 *)
7014 => let
7015 val {uses,defs,kills}
7016 = Instruction.uses_defs_kills instruction
7017 val {assembly = assembly_pre,
7018 registerAllocation}
7019 = RA.pre {uses = uses,
7020 defs = defs,
7021 kills = kills,
7022 info = info,
7023 registerAllocation = registerAllocation}
7024
7025 val (hi,lo)
7026 = case size
7027 of Size.BYTE
7028 => (Register.T {reg = Register.EAX, part = Register.H},
7029 Register.T {reg = Register.EAX, part = Register.L})
7030 | Size.WORD
7031 => (Register.T {reg = Register.EDX, part = Register.X},
7032 Register.T {reg = Register.EAX, part = Register.X})
7033 | Size.LONG
7034 => (Register.T {reg = Register.EDX, part = Register.E},
7035 Register.T {reg = Register.EAX, part = Register.E})
7036 | _ => Error.bug "x86AllocateRegisters.Instruction.allocateRegisters: pMD, size"
7037
7038 val {assembly = assembly_clear,
7039 registerAllocation,
7040 ...}
7041 = RA.freeRegister
7042 {info = info,
7043 memloc = NONE,
7044 size = size,
7045 supports = [src,dst],
7046 saves = [],
7047 force = [hi],
7048 registerAllocation = registerAllocation}
7049
7050 val registerAllocation
7051 = RA.delete {register = hi,
7052 registerAllocation = registerAllocation}
7053
7054 val {final_src,
7055 assembly_src_dst,
7056 registerAllocation,
7057 ...}
7058 = if Operand.eq(src, dst)
7059 then let
7060 val {operand = final_src_dst,
7061 assembly = assembly_src_dst,
7062 registerAllocation = registerAllocation}
7063 = RA.allocateOperand
7064 {operand = dst,
7065 options = {register = true,
7066 immediate = false,
7067 label = false,
7068 address = false},
7069 info = info,
7070 size = size,
7071 move = true,
7072 supports = [],
7073 saves = [Operand.register hi],
7074 force = [lo],
7075 registerAllocation
7076 = registerAllocation}
7077 in
7078 {final_src = final_src_dst,
7079 final_dst = final_src_dst,
7080 assembly_src_dst = assembly_src_dst,
7081 registerAllocation = registerAllocation}
7082 end
7083 else let
7084 val {operand = final_dst,
7085 assembly = assembly_dst,
7086 registerAllocation = registerAllocation}
7087 = RA.allocateOperand
7088 {operand = dst,
7089 options = {register = true,
7090 immediate = false,
7091 label = false,
7092 address = false},
7093 info = info,
7094 size = size,
7095 move = true,
7096 supports = [src],
7097 saves = [Operand.register hi],
7098 force = [lo],
7099 registerAllocation
7100 = registerAllocation}
7101
7102 val force_src
7103 = List.revKeepAll
7104 (Register.registers size,
7105 fn r => not (Register.eq(r, hi) orelse
7106 Register.eq(r, lo)))
7107
7108 val {operand = final_src,
7109 assembly = assembly_src,
7110 registerAllocation}
7111 = RA.allocateOperand
7112 {operand = src,
7113 options = {register = true,
7114 immediate = false,
7115 label = false,
7116 address = true},
7117 info = info,
7118 size = size,
7119 move = true,
7120 supports = [],
7121 saves = [Operand.register hi,
7122 dst,final_dst],
7123 force = force_src,
7124 registerAllocation
7125 = registerAllocation}
7126 in
7127 {final_src = final_src,
7128 final_dst = final_dst,
7129 assembly_src_dst
7130 = AppendList.appends
7131 [assembly_dst,
7132 assembly_src],
7133 registerAllocation = registerAllocation}
7134 end
7135
7136 val oper'
7137 = case oper
7138 of Instruction.IMUL => Instruction.IMUL
7139 | Instruction.MUL => Instruction.MUL
7140 | Instruction.IDIV => Instruction.IDIV
7141 | Instruction.DIV => Instruction.DIV
7142 | Instruction.IMOD => Instruction.IDIV
7143 | Instruction.MOD => Instruction.DIV
7144
7145 val registerAllocation
7146 = if oper = Instruction.IMOD orelse
7147 oper = Instruction.MOD
7148 then case RA.valuesRegister {register = lo,
7149 registerAllocation
7150 = registerAllocation}
7151 of [{memloc,
7152 weight,
7153 sync,
7154 commit,
7155 ...}]
7156 => let
7157 val registerAllocation
7158 = RA.delete {register = lo,
7159 registerAllocation
7160 = registerAllocation}
7161
7162 val registerAllocation
7163 = RA.update {value = {register = hi,
7164 memloc = memloc,
7165 weight = weight,
7166 sync = sync,
7167 commit = commit},
7168 registerAllocation
7169 = registerAllocation}
7170 in
7171 registerAllocation
7172 end
7173 | _ => Error.bug "x86AllocateRegisters.Instruction.allocateRegisters: pMD, lo"
7174 else registerAllocation
7175
7176 val instruction
7177 = Instruction.MD
7178 {oper = oper',
7179 src = final_src,
7180 size = size}
7181
7182 val {uses = final_uses,
7183 defs = final_defs,
7184 ...}
7185 = Instruction.uses_defs_kills instruction
7186
7187 val {assembly = assembly_post,
7188 registerAllocation}
7189 = RA.post {uses = uses,
7190 final_uses = final_uses,
7191 defs = defs,
7192 final_defs = final_defs,
7193 kills = kills,
7194 info = info,
7195 registerAllocation = registerAllocation}
7196 in
7197 {assembly
7198 = AppendList.appends
7199 [assembly_pre,
7200 assembly_clear,
7201 assembly_src_dst,
7202 (if oper = Instruction.IDIV orelse
7203 oper = Instruction.IMOD
7204 then AppendList.single
7205 (Assembly.instruction_cx
7206 {size = size})
7207 else if oper = Instruction.DIV orelse
7208 oper = Instruction.MOD
7209 then AppendList.single
7210 (Assembly.instruction_binal
7211 {oper = Instruction.XOR,
7212 dst = Operand.register hi,
7213 src = Operand.register hi,
7214 size = size})
7215 else AppendList.empty),
7216 AppendList.single
7217 (Assembly.instruction instruction),
7218 assembly_post],
7219 registerAllocation = registerAllocation}
7220 end
7221 | IMUL2 {src, dst, size}
7222 (* Integer signed/unsigned multiplication (two operand form).
7223 * Require src/dst operands as follows:
7224 *
7225 * dst
7226 * reg imm lab add
7227 * reg X
7228 * src imm X
7229 * lab
7230 * add X
7231 *)
7232 => let
7233 val {uses,defs,kills}
7234 = Instruction.uses_defs_kills instruction
7235 val {assembly = assembly_pre,
7236 registerAllocation}
7237 = RA.pre {uses = uses,
7238 defs = defs,
7239 kills = kills,
7240 info = info,
7241 registerAllocation = registerAllocation}
7242
7243 val {final_src,
7244 final_dst,
7245 assembly_src_dst,
7246 registerAllocation}
7247 = if Operand.eq(src, dst)
7248 then let
7249 val {operand = final_src_dst,
7250 assembly = assembly_src_dst,
7251 registerAllocation}
7252 = RA.allocateOperand
7253 {operand = src,
7254 options = {register = true,
7255 immediate = false,
7256 label = false,
7257 address = false},
7258 info = info,
7259 size = size,
7260 move = true,
7261 supports = [],
7262 saves = [],
7263 force = [],
7264 registerAllocation
7265 = registerAllocation}
7266 in
7267 {final_src = final_src_dst,
7268 final_dst = final_src_dst,
7269 assembly_src_dst = assembly_src_dst,
7270 registerAllocation = registerAllocation}
7271 end
7272 else let
7273 val {operand = final_dst,
7274 assembly = assembly_dst,
7275 registerAllocation}
7276 = RA.allocateOperand
7277 {operand = dst,
7278 options = {register = true,
7279 immediate = false,
7280 label = false,
7281 address = false},
7282 info = info,
7283 size = size,
7284 move = true,
7285 supports = [src],
7286 saves = [],
7287 force = [],
7288 registerAllocation
7289 = registerAllocation}
7290
7291 val {operand = final_src,
7292 assembly = assembly_src,
7293 registerAllocation}
7294 = RA.allocateOperand
7295 {operand = src,
7296 options = {register = true,
7297 immediate = true,
7298 label = false,
7299 address = false},
7300 info = info,
7301 size = size,
7302 move = true,
7303 supports = [],
7304 saves = [dst,final_dst],
7305 force = [],
7306 registerAllocation
7307 = registerAllocation}
7308 in
7309 {final_src = final_src,
7310 final_dst = final_dst,
7311 assembly_src_dst
7312 = AppendList.appends
7313 [assembly_dst,
7314 assembly_src],
7315 registerAllocation = registerAllocation}
7316 end
7317
7318 val instruction
7319 = Instruction.IMUL2
7320 {src = final_src,
7321 dst = final_dst,
7322 size = size}
7323
7324 val {uses = final_uses,
7325 defs = final_defs,
7326 ...}
7327 = Instruction.uses_defs_kills instruction
7328
7329 val {assembly = assembly_post,
7330 registerAllocation}
7331 = RA.post {uses = uses,
7332 final_uses = final_uses,
7333 defs = defs,
7334 final_defs = final_defs,
7335 kills = kills,
7336 info = info,
7337 registerAllocation = registerAllocation}
7338 in
7339 {assembly
7340 = AppendList.appends
7341 [assembly_pre,
7342 assembly_src_dst,
7343 AppendList.single
7344 (Assembly.instruction instruction),
7345 assembly_post],
7346 registerAllocation = registerAllocation}
7347 end
7348 | UnAL {oper, dst, size}
7349 (* Integer unary arithmetic/logic instructions.
7350 * Require dst operand as follows:
7351 *
7352 * dst
7353 * reg imm lab add
7354 * X X
7355 *)
7356 => let
7357 val {uses,defs,kills}
7358 = Instruction.uses_defs_kills instruction
7359 val {assembly = assembly_pre,
7360 registerAllocation}
7361 = RA.pre {uses = uses,
7362 defs = defs,
7363 kills = kills,
7364 info = info,
7365 registerAllocation = registerAllocation}
7366
7367 val {operand = final_dst,
7368 assembly = assembly_dst,
7369 registerAllocation = registerAllocation}
7370 = RA.allocateOperand {operand = dst,
7371 options = {register = true,
7372 immediate = false,
7373 label = false,
7374 address = true},
7375 info = info,
7376 size = size,
7377 move = true,
7378 supports = [],
7379 saves = [],
7380 force = [],
7381 registerAllocation
7382 = registerAllocation}
7383
7384 val instruction
7385 = Instruction.UnAL
7386 {oper = oper,
7387 dst = final_dst,
7388 size = size}
7389
7390 val {uses = final_uses,
7391 defs = final_defs,
7392 ...}
7393 = Instruction.uses_defs_kills instruction
7394
7395 val {assembly = assembly_post,
7396 registerAllocation}
7397 = RA.post {uses = uses,
7398 final_uses = final_uses,
7399 defs = defs,
7400 final_defs = final_defs,
7401 kills = kills,
7402 info = info,
7403 registerAllocation = registerAllocation}
7404 in
7405 {assembly
7406 = AppendList.appends
7407 [assembly_pre,
7408 assembly_dst,
7409 AppendList.single
7410 (Assembly.instruction instruction),
7411 assembly_post],
7412 registerAllocation = registerAllocation}
7413 end
7414 | SRAL {oper, count, dst, size}
7415 (* Integer shift/rotate arithmetic/logic instructions.
7416 * Require count operand as follows:
7417 *
7418 * count
7419 * reg imm lab add
7420 * * X
7421 * * only register %cl
7422 *
7423 * Require dst operand as follows:
7424 *
7425 * dst
7426 * reg imm lab add
7427 * X X
7428 *)
7429 => let
7430 val {uses,defs,kills}
7431 = Instruction.uses_defs_kills instruction
7432 val {assembly = assembly_pre,
7433 registerAllocation}
7434 = RA.pre {uses = uses,
7435 defs = defs,
7436 kills = kills,
7437 info = info,
7438 registerAllocation = registerAllocation}
7439
7440 val {final_count,
7441 assembly_count,
7442 final_dst,
7443 assembly_dst,
7444 registerAllocation}
7445 = if Operand.eq(count,dst)
7446 then let
7447 val {operand = final_count,
7448 assembly = assembly_count,
7449 registerAllocation}
7450 = RA.allocateOperand
7451 {operand = count,
7452 options = {register = true,
7453 immediate = false,
7454 label = false,
7455 address = false},
7456 info = info,
7457 size = size,
7458 move = true,
7459 supports = [],
7460 saves = [],
7461 force
7462 = [Register.T {reg = Register.ECX,
7463 part = Register.L},
7464 Register.T {reg = Register.ECX,
7465 part = Register.X},
7466 Register.T {reg = Register.ECX,
7467 part = Register.E}],
7468 registerAllocation
7469 = registerAllocation}
7470
7471 val final_dst = final_count
7472 val assembly_dst = AppendList.empty
7473 in
7474 {final_count = final_count,
7475 assembly_count = assembly_count,
7476 final_dst = final_dst,
7477 assembly_dst = assembly_dst,
7478 registerAllocation = registerAllocation}
7479 end
7480 else let
7481 val count_size = case Operand.size count
7482 of NONE => Size.BYTE
7483 | SOME size => size
7484
7485 val {operand = final_count,
7486 assembly = assembly_count,
7487 registerAllocation}
7488 = RA.allocateOperand
7489 {operand = count,
7490 options = {register = true,
7491 immediate = true,
7492 label = false,
7493 address = false},
7494 info = info,
7495 size = count_size,
7496 move = true,
7497 supports = [dst],
7498 saves = [],
7499 force
7500 = [Register.T {reg = Register.ECX,
7501 part = Register.L},
7502 Register.T {reg = Register.ECX,
7503 part = Register.X},
7504 Register.T {reg = Register.ECX,
7505 part = Register.E}],
7506 registerAllocation
7507 = registerAllocation}
7508
7509 val {operand = final_dst,
7510 assembly = assembly_dst,
7511 registerAllocation = registerAllocation}
7512 = RA.allocateOperand
7513 {operand = dst,
7514 options = {register = true,
7515 immediate = false,
7516 label = false,
7517 address = true},
7518 info = info,
7519 size = size,
7520 move = true,
7521 supports = [],
7522 saves = [count,final_count],
7523 force = [],
7524 registerAllocation
7525 = registerAllocation}
7526 in
7527 {final_count = final_count,
7528 assembly_count = assembly_count,
7529 final_dst = final_dst,
7530 assembly_dst = assembly_dst,
7531 registerAllocation = registerAllocation}
7532 end
7533
7534 val final_count
7535 = case final_count
7536 of Operand.Register _
7537 => Operand.register
7538 (Register.T {reg = Register.ECX,
7539 part = Register.L})
7540 | _ => final_count
7541
7542 val instruction
7543 = Instruction.SRAL
7544 {oper = oper,
7545 count = final_count,
7546 dst = final_dst,
7547 size = size}
7548
7549 val {uses = final_uses,
7550 defs = final_defs,
7551 ...}
7552 = Instruction.uses_defs_kills instruction
7553
7554 val {assembly = assembly_post,
7555 registerAllocation}
7556 = RA.post {uses = uses,
7557 final_uses = final_uses,
7558 defs = defs,
7559 final_defs = final_defs,
7560 kills = kills,
7561 info = info,
7562 registerAllocation = registerAllocation}
7563 in
7564 {assembly
7565 = AppendList.appends
7566 [assembly_pre,
7567 assembly_count,
7568 assembly_dst,
7569 AppendList.single
7570 (Assembly.instruction instruction),
7571 assembly_post],
7572 registerAllocation = registerAllocation}
7573 end
7574 | CMP {src2, src1, size}
7575 (* Arithmetic compare; p. 116
7576 * Require src1/src2 operands as follows:
7577 *
7578 * src2
7579 * reg imm lab add
7580 * reg X X X
7581 * src1 imm
7582 * lab
7583 * add X X
7584 *)
7585 => let
7586 val {uses,defs,kills}
7587 = Instruction.uses_defs_kills instruction
7588 val {assembly = assembly_pre,
7589 registerAllocation}
7590 = RA.pre {uses = uses,
7591 defs = defs,
7592 kills = kills,
7593 info = info,
7594 registerAllocation = registerAllocation}
7595
7596 val {final_src1,
7597 final_src2,
7598 assembly_src1_src2,
7599 registerAllocation}
7600 = allocateSrc1Src2
7601 {src1 = src1,
7602 src2 = src2,
7603 size = size,
7604 info = info,
7605 registerAllocation = registerAllocation}
7606
7607 val instruction
7608 = Instruction.CMP
7609 {src1 = final_src1,
7610 src2 = final_src2,
7611 size = size}
7612
7613 val {uses = final_uses,
7614 defs = final_defs,
7615 ...}
7616 = Instruction.uses_defs_kills instruction
7617
7618 val {assembly = assembly_post,
7619 registerAllocation}
7620 = RA.post {uses = uses,
7621 final_uses = final_uses,
7622 defs = defs,
7623 final_defs = final_defs,
7624 kills = kills,
7625 info = info,
7626 registerAllocation = registerAllocation}
7627 in
7628 {assembly
7629 = AppendList.appends
7630 [assembly_pre,
7631 assembly_src1_src2,
7632 AppendList.single
7633 (Assembly.instruction instruction),
7634 assembly_post],
7635 registerAllocation = registerAllocation}
7636 end
7637 | TEST {src2, src1, size}
7638 (* Logical compare; p. 728
7639 * Require src1/src2 operands as follows:
7640 *
7641 * src2
7642 * reg imm lab add
7643 * reg X X X
7644 * src1 imm
7645 * lab
7646 * add X X
7647 *)
7648 => let
7649 val {uses,defs,kills}
7650 = Instruction.uses_defs_kills instruction
7651 val {assembly = assembly_pre,
7652 registerAllocation}
7653 = RA.pre {uses = uses,
7654 defs = defs,
7655 kills = kills,
7656 info = info,
7657 registerAllocation = registerAllocation}
7658
7659 val {final_src1,
7660 final_src2,
7661 assembly_src1_src2,
7662 registerAllocation}
7663 = allocateSrc1Src2
7664 {src1 = src1,
7665 src2 = src2,
7666 size = size,
7667 info = info,
7668 registerAllocation = registerAllocation}
7669
7670 val instruction
7671 = Instruction.TEST
7672 {src1 = final_src1,
7673 src2 = final_src2,
7674 size = size}
7675
7676 val {uses = final_uses,
7677 defs = final_defs,
7678 ...}
7679 = Instruction.uses_defs_kills instruction
7680
7681 val {assembly = assembly_post,
7682 registerAllocation}
7683 = RA.post {uses = uses,
7684 final_uses = final_uses,
7685 defs = defs,
7686 final_defs = final_defs,
7687 kills = kills,
7688 info = info,
7689 registerAllocation = registerAllocation}
7690 in
7691 {assembly
7692 = AppendList.appends
7693 [assembly_pre,
7694 assembly_src1_src2,
7695 AppendList.single
7696 (Assembly.instruction instruction),
7697 assembly_post],
7698 registerAllocation = registerAllocation}
7699 end
7700 | SETcc {condition, dst, size}
7701 (* Set byte on condition; p. 672
7702 * Require dst operand as follows:
7703 *
7704 * dst
7705 * reg imm lab add
7706 * * X
7707 * * only byte registers
7708 *)
7709 => let
7710 val {uses,defs,kills}
7711 = Instruction.uses_defs_kills instruction
7712 val {assembly = assembly_pre,
7713 registerAllocation}
7714 = RA.pre {uses = uses,
7715 defs = defs,
7716 kills = kills,
7717 info = info,
7718 registerAllocation = registerAllocation}
7719
7720 val {operand = final_dst,
7721 assembly = assembly_dst,
7722 registerAllocation = registerAllocation}
7723 = RA.allocateOperand
7724 {operand = dst,
7725 options = {register = true,
7726 immediate = false,
7727 label = false,
7728 address = false},
7729 info = info,
7730 size = size,
7731 move = false,
7732 supports = [],
7733 saves = [],
7734 force = Register.withLowPart (size, Size.BYTE),
7735 registerAllocation = registerAllocation}
7736
7737 val temp_dst
7738 = case final_dst
7739 of Operand.Register r
7740 => let
7741 val register
7742 = Register.lowPartOf (r, Size.BYTE)
7743 in
7744 Operand.register register
7745 end
7746 | _ => Error.bug "x86AllocateRegisters.Instruction.allocateRegisters: SETcc, temp_reg"
7747
7748 val {uses = final_uses,
7749 defs = final_defs,
7750 ...}
7751 = Instruction.uses_defs_kills
7752 (Instruction.SETcc {condition = condition,
7753 dst = final_dst,
7754 size = size})
7755
7756 val {assembly = assembly_post,
7757 registerAllocation}
7758 = RA.post {uses = uses,
7759 final_uses = final_uses,
7760 defs = defs,
7761 final_defs = final_defs,
7762 kills = kills,
7763 info = info,
7764 registerAllocation = registerAllocation}
7765 in
7766 {assembly
7767 = AppendList.appends
7768 [assembly_pre,
7769 assembly_dst,
7770 AppendList.single
7771 (Assembly.instruction_setcc
7772 {condition = condition,
7773 dst = temp_dst,
7774 size = Size.BYTE}),
7775 if size = Size.BYTE
7776 then if Operand.eq (final_dst, temp_dst)
7777 then AppendList.empty
7778 else AppendList.single
7779 (Assembly.instruction_mov
7780 {dst = final_dst,
7781 src = temp_dst,
7782 size = Size.BYTE})
7783 else AppendList.single
7784 (Assembly.instruction_movx
7785 {oper = Instruction.MOVZX,
7786 dst = final_dst,
7787 src = temp_dst,
7788 dstsize = size,
7789 srcsize = Size.BYTE}),
7790 assembly_post],
7791 registerAllocation = registerAllocation}
7792 end
7793 | JMP {target, absolute}
7794 (* Jump; p. 373
7795 * Require target operand as follows:
7796 *
7797 * target
7798 * reg imm lab add
7799 * X X X X
7800 *)
7801 => let
7802 val {uses,defs,kills}
7803 = Instruction.uses_defs_kills instruction
7804 val {assembly = assembly_pre,
7805 registerAllocation}
7806 = RA.pre {uses = uses,
7807 defs = defs,
7808 kills = kills,
7809 info = info,
7810 registerAllocation = registerAllocation}
7811
7812 val {operand = final_target,
7813 assembly = assembly_target,
7814 registerAllocation = registerAllocation}
7815 = RA.allocateOperand {operand = target,
7816 options = {register = false,
7817 immediate = true,
7818 label = true,
7819 address = true},
7820 info = info,
7821 size = Size.LONG,
7822 move = true,
7823 supports = [],
7824 saves = [],
7825 force = [],
7826 registerAllocation
7827 = registerAllocation}
7828
7829 val instruction
7830 = Instruction.JMP
7831 {target = final_target,
7832 absolute = absolute}
7833
7834 val {uses = final_uses,
7835 defs = final_defs,
7836 ...}
7837 = Instruction.uses_defs_kills instruction
7838
7839 val {assembly = assembly_post,
7840 registerAllocation}
7841 = RA.post {uses = uses,
7842 final_uses = final_uses,
7843 defs = defs,
7844 final_defs = final_defs,
7845 kills = kills,
7846 info = info,
7847 registerAllocation = registerAllocation}
7848 in
7849 {assembly
7850 = AppendList.appends
7851 [assembly_pre,
7852 assembly_target,
7853 AppendList.single
7854 (Assembly.instruction instruction),
7855 assembly_post],
7856 registerAllocation = registerAllocation}
7857 end
7858 | Jcc {condition, target}
7859 (* Jump if condition is met; p. 369
7860 * Require target operand as follows:
7861 *
7862 * target
7863 * reg imm lab add
7864 * X X
7865 *)
7866 => let
7867 val {uses,defs,kills}
7868 = Instruction.uses_defs_kills instruction
7869 val {assembly = assembly_pre,
7870 registerAllocation}
7871 = RA.pre {uses = uses,
7872 defs = defs,
7873 kills = kills,
7874 info = info,
7875 registerAllocation = registerAllocation}
7876
7877 val {operand = final_target,
7878 assembly = assembly_target,
7879 registerAllocation = registerAllocation}
7880 = RA.allocateOperand {operand = target,
7881 options = {register = false,
7882 immediate = true,
7883 label = true,
7884 address = false},
7885 info = info,
7886 size = Size.LONG,
7887 move = true,
7888 supports = [],
7889 saves = [],
7890 force = [],
7891 registerAllocation
7892 = registerAllocation}
7893
7894 val instruction
7895 = Instruction.Jcc
7896 {condition = condition,
7897 target = final_target}
7898
7899 val {uses = final_uses,
7900 defs = final_defs,
7901 ...}
7902 = Instruction.uses_defs_kills instruction
7903
7904 val {assembly = assembly_post,
7905 registerAllocation}
7906 = RA.post {uses = uses,
7907 final_uses = final_uses,
7908 defs = defs,
7909 final_defs = final_defs,
7910 kills = kills,
7911 info = info,
7912 registerAllocation = registerAllocation}
7913 in
7914 {assembly
7915 = AppendList.appends
7916 [assembly_pre,
7917 assembly_target,
7918 AppendList.single
7919 (Assembly.instruction instruction),
7920 assembly_post],
7921 registerAllocation = registerAllocation}
7922 end
7923 | CALL {target, absolute}
7924 (* Call procedure; p. 93
7925 * Require target operand as follows:
7926 *
7927 * target
7928 * reg imm lab add
7929 * X X X X
7930 *)
7931 => let
7932 val {uses,defs,kills}
7933 = Instruction.uses_defs_kills instruction
7934 val {assembly = assembly_pre,
7935 registerAllocation}
7936 = RA.pre {uses = uses,
7937 defs = defs,
7938 kills = kills,
7939 info = info,
7940 registerAllocation = registerAllocation}
7941
7942 val {operand = final_target,
7943 assembly = assembly_target,
7944 registerAllocation = registerAllocation}
7945 = RA.allocateOperand {operand = target,
7946 options = {register = true,
7947 immediate = true,
7948 label = true,
7949 address = true},
7950 info = info,
7951 size = Size.LONG,
7952 move = true,
7953 supports = [],
7954 saves = [],
7955 force = [],
7956 registerAllocation
7957 = registerAllocation}
7958
7959 val instruction
7960 = Instruction.CALL
7961 {target = final_target,
7962 absolute = absolute}
7963
7964 val {uses = final_uses,
7965 defs = final_defs,
7966 ...}
7967 = Instruction.uses_defs_kills instruction
7968
7969 val {assembly = assembly_post,
7970 registerAllocation}
7971 = RA.post {uses = uses,
7972 final_uses = final_uses,
7973 defs = defs,
7974 final_defs = final_defs,
7975 kills = kills,
7976 info = info,
7977 registerAllocation = registerAllocation}
7978 in
7979 {assembly
7980 = AppendList.appends
7981 [assembly_pre,
7982 assembly_target,
7983 AppendList.single
7984 (Assembly.instruction instruction),
7985 assembly_post],
7986 registerAllocation = registerAllocation}
7987 end
7988 | RET {src = SOME src}
7989 (* Return from procedure; p. 648
7990 * Require optional src operand as follows:
7991 *
7992 * src
7993 * reg imm lab add
7994 * X
7995 *)
7996 => let
7997 val {uses,defs,kills}
7998 = Instruction.uses_defs_kills instruction
7999 val {assembly = assembly_pre,
8000 registerAllocation}
8001 = RA.pre {uses = uses,
8002 defs = defs,
8003 kills = kills,
8004 info = info,
8005 registerAllocation = registerAllocation}
8006
8007 val {operand = final_src,
8008 assembly = assembly_src,
8009 registerAllocation = registerAllocation}
8010 = RA.allocateOperand {operand = src,
8011 options = {register = false,
8012 immediate = true,
8013 label = false,
8014 address = false},
8015 info = info,
8016 size = Size.LONG,
8017 move = true,
8018 supports = [],
8019 saves = [],
8020 force = [],
8021 registerAllocation
8022 = registerAllocation}
8023
8024 val instruction
8025 = Instruction.RET
8026 {src = SOME final_src}
8027
8028 val {uses = final_uses,
8029 defs = final_defs,
8030 ...}
8031 = Instruction.uses_defs_kills instruction
8032
8033 val {assembly = assembly_post,
8034 registerAllocation}
8035 = RA.post {uses = uses,
8036 final_uses = final_uses,
8037 defs = defs,
8038 final_defs = final_defs,
8039 kills = kills,
8040 info = info,
8041 registerAllocation = registerAllocation}
8042 in
8043 {assembly
8044 = AppendList.appends
8045 [assembly_pre,
8046 assembly_src,
8047 AppendList.single
8048 (Assembly.instruction instruction),
8049 assembly_post],
8050 registerAllocation = registerAllocation}
8051 end
8052 | RET {src = NONE}
8053 => let
8054 val {uses,defs,kills}
8055 = Instruction.uses_defs_kills instruction
8056 val {assembly = assembly_pre,
8057 registerAllocation}
8058 = RA.pre {uses = uses,
8059 defs = defs,
8060 kills = kills,
8061 info = info,
8062 registerAllocation = registerAllocation}
8063
8064 val instruction
8065 = Instruction.RET
8066 {src = NONE}
8067
8068 val {uses = final_uses,
8069 defs = final_defs,
8070 ...}
8071 = Instruction.uses_defs_kills instruction
8072
8073 val {assembly = assembly_post,
8074 registerAllocation}
8075 = RA.post {uses = uses,
8076 final_uses = final_uses,
8077 defs = defs,
8078 final_defs = final_defs,
8079 kills = kills,
8080 info = info,
8081 registerAllocation = registerAllocation}
8082 in
8083 {assembly
8084 = AppendList.appends
8085 [assembly_pre,
8086 AppendList.single
8087 (Assembly.instruction instruction),
8088 assembly_post],
8089 registerAllocation = registerAllocation}
8090 end
8091 | MOV {src, dst, size}
8092 (* Move; p. 442
8093 * Require src/dst operands as follows:
8094 *
8095 * dst
8096 * reg imm lab add
8097 * reg X X
8098 * src imm X X
8099 * lab
8100 * add X
8101 *)
8102 => let
8103 val {uses,defs,kills}
8104 = Instruction.uses_defs_kills instruction
8105 val {assembly = assembly_pre,
8106 registerAllocation}
8107 = RA.pre {uses = uses,
8108 defs = defs,
8109 kills = kills,
8110 info = info,
8111 registerAllocation = registerAllocation}
8112
8113 fun default ()
8114 = let
8115 val {final_src,
8116 final_dst,
8117 assembly_src_dst,
8118 registerAllocation}
8119 = allocateSrcDst
8120 {src = src,
8121 dst = dst,
8122 move_dst = false,
8123 size = size,
8124 info = info,
8125 registerAllocation = registerAllocation}
8126
8127 val isConst0 = Immediate.isZero
8128
8129 (* special case moving 0 to a register
8130 *)
8131 val instruction
8132 = case (final_src, final_dst)
8133 of (Operand.Immediate immediate,
8134 Operand.Register _)
8135 => if isConst0 immediate
8136 then Instruction.BinAL
8137 {oper = XOR,
8138 src = final_dst,
8139 dst = final_dst,
8140 size = size}
8141 else Instruction.MOV
8142 {src = final_src,
8143 dst = final_dst,
8144 size = size}
8145 | _ => Instruction.MOV
8146 {src = final_src,
8147 dst = final_dst,
8148 size = size}
8149
8150 val {uses = final_uses,
8151 defs = final_defs,
8152 ...}
8153 = Instruction.uses_defs_kills instruction
8154
8155 val {assembly = assembly_post,
8156 registerAllocation}
8157 = RA.post {uses = uses,
8158 final_uses = final_uses,
8159 defs = defs,
8160 final_defs = final_defs,
8161 kills = kills,
8162 info = info,
8163 registerAllocation = registerAllocation}
8164 in
8165 {assembly
8166 = AppendList.appends
8167 [assembly_pre,
8168 assembly_src_dst,
8169 AppendList.single
8170 (Assembly.instruction instruction),
8171 assembly_post],
8172 registerAllocation = registerAllocation}
8173 end
8174
8175 fun default' ({register = register_src,
8176 commit = commit_src,
8177 ...} : RegisterAllocation.value,
8178 memloc_dst)
8179 = let
8180 val registerAllocation
8181 = RA.remove
8182 {memloc = memloc_dst,
8183 registerAllocation = registerAllocation}
8184
8185 val registerAllocation
8186 = RA.update
8187 {value = {register = register_src,
8188 memloc = memloc_dst,
8189 weight = 1024,
8190 sync = false,
8191 commit = commit_src},
8192 registerAllocation = registerAllocation}
8193
8194 val final_uses = []
8195 val final_defs
8196 = [Operand.register register_src]
8197
8198 val {assembly = assembly_post,
8199 registerAllocation}
8200 = RA.post {uses = uses,
8201 final_uses = final_uses,
8202 defs = defs,
8203 final_defs = final_defs,
8204 kills = kills,
8205 info = info,
8206 registerAllocation = registerAllocation}
8207 in
8208 {assembly
8209 = AppendList.appends [assembly_pre,
8210 assembly_post],
8211 registerAllocation = registerAllocation}
8212 end
8213
8214 fun default'' (memloc_dst)
8215 = let
8216 val registerAllocation
8217 = RA.remove
8218 {memloc = memloc_dst,
8219 registerAllocation = registerAllocation}
8220
8221 val {final_src,
8222 final_dst,
8223 assembly_src_dst,
8224 registerAllocation}
8225 = allocateSrcDst
8226 {src = src,
8227 dst = dst,
8228 move_dst = false,
8229 size = size,
8230 info = info,
8231 registerAllocation = registerAllocation}
8232
8233 val instruction
8234 = Instruction.MOV
8235 {src = final_src,
8236 dst = final_dst,
8237 size = size}
8238
8239 val {uses = final_uses,
8240 defs = final_defs,
8241 ...}
8242 = Instruction.uses_defs_kills instruction
8243
8244 val {assembly = assembly_post,
8245 registerAllocation}
8246 = RA.post {uses = uses,
8247 final_uses = final_uses,
8248 defs = defs,
8249 final_defs = final_defs,
8250 kills = kills,
8251 info = info,
8252 registerAllocation = registerAllocation}
8253 in
8254 {assembly
8255 = AppendList.appends
8256 [assembly_pre,
8257 assembly_src_dst,
8258 AppendList.single
8259 (Assembly.instruction instruction),
8260 assembly_post],
8261 registerAllocation = registerAllocation}
8262 end
8263
8264 val memloc_src = Operand.deMemloc src
8265 val value_src
8266 = case memloc_src
8267 of NONE => NONE
8268 | SOME memloc_src
8269 => RA.allocated {memloc = memloc_src,
8270 registerAllocation
8271 = registerAllocation}
8272 val memloc_dst = Operand.deMemloc dst
8273 in
8274 case memloc_dst
8275 of SOME memloc_dst
8276 => if MemLocSet.contains(remove,memloc_dst)
8277 then (case memloc_src
8278 of SOME memloc_src
8279 => if List.contains
8280 (memloc_src::(MemLoc.utilized memloc_src),
8281 memloc_dst,
8282 MemLoc.eq)
8283 then default ()
8284 else default'' memloc_dst
8285 | NONE => default'' memloc_dst)
8286 else (case value_src
8287 of SOME (value_src as {memloc = memloc_src,
8288 sync = sync_src, ...})
8289 => if MemLocSet.contains(dead,memloc_src)
8290 orelse
8291 (MemLocSet.contains(remove,memloc_src)
8292 andalso
8293 sync_src)
8294 then default' (value_src, memloc_dst)
8295 else default ()
8296 | NONE => default ())
8297 | NONE => default ()
8298 end
8299 | CMOVcc {condition, src, dst, size}
8300 (* Conditional move; p. 112
8301 * Require src/dst operands as follows:
8302 *
8303 * dst
8304 * reg imm lab add
8305 * reg X
8306 * src imm
8307 * lab
8308 * add X
8309 *)
8310 => let
8311 val {uses,defs,kills}
8312 = Instruction.uses_defs_kills instruction
8313 val {assembly = assembly_pre,
8314 registerAllocation}
8315 = RA.pre {uses = uses,
8316 defs = defs,
8317 kills = kills,
8318 info = info,
8319 registerAllocation = registerAllocation}
8320
8321 val {operand = final_src,
8322 assembly = assembly_src,
8323 registerAllocation}
8324 = RA.allocateOperand {operand = src,
8325 options = {register = true,
8326 immediate = false,
8327 label = false,
8328 address = true},
8329 info = info,
8330 size = size,
8331 move = true,
8332 supports = [dst],
8333 saves = [],
8334 force = [],
8335 registerAllocation
8336 = registerAllocation}
8337
8338 val {operand = final_dst,
8339 assembly = assembly_dst,
8340 registerAllocation = registerAllocation}
8341 = RA.allocateOperand {operand = dst,
8342 options = {register = true,
8343 immediate = false,
8344 label = false,
8345 address = false},
8346 info = info,
8347 size = size,
8348 move = false,
8349 supports = [],
8350 saves = [src,final_src],
8351 force = [],
8352 registerAllocation
8353 = registerAllocation}
8354
8355 val instruction
8356 = Instruction.CMOVcc
8357 {condition = condition,
8358 src = final_src,
8359 dst = final_dst,
8360 size = size}
8361
8362 val {uses = final_uses,
8363 defs = final_defs,
8364 ...}
8365 = Instruction.uses_defs_kills instruction
8366
8367 val {assembly = assembly_post,
8368 registerAllocation}
8369 = RA.post {uses = uses,
8370 final_uses = final_uses,
8371 defs = defs,
8372 final_defs = final_defs,
8373 kills = kills,
8374 info = info,
8375 registerAllocation = registerAllocation}
8376 in
8377 {assembly
8378 = AppendList.appends
8379 [assembly_pre,
8380 assembly_src,
8381 assembly_dst,
8382 AppendList.single
8383 (Assembly.instruction instruction),
8384 assembly_post],
8385 registerAllocation = registerAllocation}
8386 end
8387 | XCHG {src, dst, size}
8388 (* Exchange register/memory with register; p. 754
8389 * Require src/dst operands as follows:
8390 *
8391 * dst
8392 * reg imm lab add
8393 * reg X X
8394 * src imm
8395 * lab
8396 * add X
8397 *)
8398 => let
8399 val {uses,defs,kills}
8400 = Instruction.uses_defs_kills instruction
8401 val {assembly = assembly_pre,
8402 registerAllocation}
8403 = RA.pre {uses = uses,
8404 defs = defs,
8405 kills = kills,
8406 info = info,
8407 registerAllocation = registerAllocation}
8408
8409 val {final_src,
8410 final_dst,
8411 assembly_src_dst,
8412 registerAllocation}
8413 = allocateSrcDst {src = src,
8414 dst = dst,
8415 move_dst = true,
8416 size = size,
8417 info = info,
8418 registerAllocation = registerAllocation}
8419
8420 val instruction
8421 = Instruction.XCHG
8422 {src = final_src,
8423 dst = final_dst,
8424 size = size}
8425
8426 val {uses = final_uses,
8427 defs = final_defs,
8428 ...}
8429 = Instruction.uses_defs_kills instruction
8430
8431 val {assembly = assembly_post,
8432 registerAllocation}
8433 = RA.post {uses = uses,
8434 final_uses = final_uses,
8435 defs = defs,
8436 final_defs = final_defs,
8437 kills = kills,
8438 info = info,
8439 registerAllocation = registerAllocation}
8440 in
8441 {assembly
8442 = AppendList.appends
8443 [assembly_pre,
8444 assembly_src_dst,
8445 AppendList.single
8446 (Assembly.instruction instruction),
8447 assembly_post],
8448 registerAllocation = registerAllocation}
8449 end
8450 | pPUSH {src, base, size}
8451 (* Pseudo push a value onto the stack; p. 621
8452 * Require src operand as follows:
8453 *
8454 * src
8455 * reg imm lab add
8456 * * X X
8457 * * only word or long registers
8458 *
8459 * base
8460 * reg imm lab add
8461 * *
8462 * * only %esp
8463 *)
8464 => let
8465 val {uses,defs,kills}
8466 = Instruction.uses_defs_kills instruction
8467 val {assembly = assembly_pre,
8468 registerAllocation}
8469 = RA.pre {uses = uses,
8470 defs = defs,
8471 kills = kills,
8472 info = info,
8473 registerAllocation = registerAllocation}
8474
8475 val {assembly = assembly_base,
8476 registerAllocation,
8477 ...}
8478 = RA.allocateOperand {operand = base,
8479 options = {register = true,
8480 immediate = false,
8481 label = false,
8482 address = false},
8483 info = info,
8484 size = Size.LONG,
8485 move = true,
8486 supports = [src],
8487 saves = [],
8488 force = [Register.esp],
8489 registerAllocation
8490 = registerAllocation}
8491
8492 val options
8493 = case size
8494 of Size.WORD
8495 => {register = true,
8496 immediate = true,
8497 label = false,
8498 address = true}
8499 | Size.LONG
8500 => {register = true,
8501 immediate = true,
8502 label = false,
8503 address = true}
8504 | _
8505 => {register = false,
8506 immediate = true,
8507 label = false,
8508 address = true}
8509
8510 val {operand = final_src,
8511 assembly = assembly_src,
8512 registerAllocation}
8513 = RA.allocateOperand {operand = src,
8514 options = options,
8515 info = info,
8516 size = size,
8517 move = true,
8518 supports = [],
8519 saves = [],
8520 force = [],
8521 registerAllocation
8522 = registerAllocation}
8523
8524 val instruction
8525 = Instruction.PUSH
8526 {src = final_src,
8527 size = size}
8528
8529 val {uses = final_uses,
8530 defs = final_defs,
8531 ...}
8532 = Instruction.uses_defs_kills instruction
8533
8534 val {assembly = assembly_post,
8535 registerAllocation}
8536 = RA.post {uses = uses,
8537 final_uses = final_uses,
8538 defs = defs,
8539 final_defs = final_defs,
8540 kills = kills,
8541 info = info,
8542 registerAllocation = registerAllocation}
8543 in
8544 {assembly
8545 = AppendList.appends
8546 [assembly_pre,
8547 assembly_base,
8548 assembly_src,
8549 AppendList.single
8550 (Assembly.instruction instruction),
8551 assembly_post],
8552 registerAllocation = registerAllocation}
8553 end
8554 | pPOP {dst, base, size}
8555 (* Pseudo pop a value from the stack; p. 571
8556 * Require dst operand as follows:
8557 *
8558 * dst
8559 * reg imm lab add
8560 * * X
8561 * * only word or long registers
8562 * base
8563 * reg imm lab add
8564 * *
8565 * * only %esp
8566 *)
8567 => let
8568 val {uses,defs,kills}
8569 = Instruction.uses_defs_kills instruction
8570 val {assembly = assembly_pre,
8571 registerAllocation}
8572 = RA.pre {uses = uses,
8573 defs = defs,
8574 kills = kills,
8575 info = info,
8576 registerAllocation = registerAllocation}
8577
8578 val {assembly = assembly_base,
8579 registerAllocation,
8580 ...}
8581 = RA.allocateOperand {operand = base,
8582 options = {register = true,
8583 immediate = false,
8584 label = false,
8585 address = false},
8586 info = info,
8587 size = Size.LONG,
8588 move = true,
8589 supports = [dst],
8590 saves = [],
8591 force = [Register.esp],
8592 registerAllocation
8593 = registerAllocation}
8594
8595 val options
8596 = case size
8597 of Size.WORD
8598 => {register = true,
8599 immediate = false,
8600 label = false,
8601 address = true}
8602 | Size.LONG
8603 => {register = true,
8604 immediate = false,
8605 label = false,
8606 address = true}
8607 | _
8608 => {register = false,
8609 immediate = false,
8610 label = false,
8611 address = true}
8612
8613 val {operand = final_dst,
8614 assembly = assembly_dst,
8615 registerAllocation}
8616 = RA.allocateOperand {operand = dst,
8617 options = options,
8618 info = info,
8619 size = size,
8620 move = false,
8621 supports = [],
8622 saves = [],
8623 force = [],
8624 registerAllocation
8625 = registerAllocation}
8626
8627 val instruction
8628 = Instruction.POP
8629 {dst = final_dst,
8630 size = size}
8631
8632 val {uses = final_uses,
8633 defs = final_defs,
8634 ...}
8635 = Instruction.uses_defs_kills instruction
8636
8637 val {assembly = assembly_post,
8638 registerAllocation}
8639 = RA.post {uses = uses,
8640 final_uses = final_uses,
8641 defs = defs,
8642 final_defs = final_defs,
8643 kills = kills,
8644 info = info,
8645 registerAllocation = registerAllocation}
8646 in
8647 {assembly
8648 = AppendList.appends
8649 [assembly_pre,
8650 assembly_base,
8651 assembly_dst,
8652 AppendList.single
8653 (Assembly.instruction instruction),
8654 assembly_post],
8655 registerAllocation = registerAllocation}
8656 end
8657 | MOVX {oper, src, dst, srcsize, dstsize}
8658 (* Move with extention.
8659 * Require src/dst operands as follows:
8660 *
8661 * dst
8662 * reg imm lab add
8663 * reg X
8664 * src imm
8665 * lab
8666 * add X
8667 *)
8668 => let
8669 val {uses,defs,kills}
8670 = Instruction.uses_defs_kills instruction
8671 val {assembly = assembly_pre,
8672 registerAllocation}
8673 = RA.pre {uses = uses,
8674 defs = defs,
8675 kills = kills,
8676 info = info,
8677 registerAllocation = registerAllocation}
8678
8679 val {operand = final_src,
8680 assembly = assembly_src,
8681 registerAllocation}
8682 = RA.allocateOperand {operand = src,
8683 options = {register = true,
8684 immediate = false,
8685 label = false,
8686 address = true},
8687 info = info,
8688 size = srcsize,
8689 move = true,
8690 supports = [dst],
8691 saves = [],
8692 force = [],
8693 registerAllocation
8694 = registerAllocation}
8695
8696 val {operand = final_dst,
8697 assembly = assembly_dst,
8698 registerAllocation = registerAllocation}
8699 = RA.allocateOperand {operand = dst,
8700 options = {register = true,
8701 immediate = false,
8702 label = false,
8703 address = false},
8704 info = info,
8705 size = dstsize,
8706 move = false,
8707 supports = [],
8708 saves = [src,final_src],
8709 force = [],
8710 registerAllocation
8711 = registerAllocation}
8712
8713 val instruction
8714 = Instruction.MOVX
8715 {oper = oper,
8716 src = final_src,
8717 dst = final_dst,
8718 srcsize = srcsize,
8719 dstsize = dstsize}
8720
8721 val {uses = final_uses,
8722 defs = final_defs,
8723 ...}
8724 = Instruction.uses_defs_kills instruction
8725
8726 val {assembly = assembly_post,
8727 registerAllocation}
8728 = RA.post {uses = uses,
8729 final_uses = final_uses,
8730 defs = defs,
8731 final_defs = final_defs,
8732 kills = kills,
8733 info = info,
8734 registerAllocation = registerAllocation}
8735 in
8736 {assembly
8737 = AppendList.appends
8738 [assembly_pre,
8739 assembly_src,
8740 assembly_dst,
8741 AppendList.single
8742 (Assembly.instruction instruction),
8743 assembly_post],
8744 registerAllocation = registerAllocation}
8745 end
8746 | XVOM {src, dst, srcsize, dstsize}
8747 (* Move with contraction.
8748 * Require src/dst operands as follows:
8749 *
8750 * dst
8751 * reg imm lab add
8752 * reg X X
8753 * src imm
8754 * lab
8755 * add
8756 *)
8757 => let
8758 val {uses,defs,kills}
8759 = Instruction.uses_defs_kills instruction
8760 val {assembly = assembly_pre,
8761 registerAllocation}
8762 = RA.pre {uses = uses,
8763 defs = defs,
8764 kills = kills,
8765 info = info,
8766 registerAllocation = registerAllocation}
8767
8768 val {operand = final_src,
8769 assembly = assembly_src,
8770 registerAllocation}
8771 = RA.allocateOperand {operand = src,
8772 options = {register = true,
8773 immediate = false,
8774 label = false,
8775 address = false},
8776 info = info,
8777 size = srcsize,
8778 move = true,
8779 supports = [dst],
8780 saves = [],
8781 force
8782 = Register.withLowPart (srcsize,
8783 dstsize),
8784 registerAllocation
8785 = registerAllocation}
8786
8787 val {operand = final_dst,
8788 assembly = assembly_dst,
8789 registerAllocation = registerAllocation}
8790 = RA.allocateOperand {operand = dst,
8791 options = {register = true,
8792 immediate = false,
8793 label = false,
8794 address = true},
8795 info = info,
8796 size = dstsize,
8797 move = false,
8798 supports = [],
8799 saves = [src,final_src],
8800 force = [],
8801 registerAllocation
8802 = registerAllocation}
8803
8804 val {uses = final_uses,
8805 defs = final_defs,
8806 ...}
8807 = Instruction.uses_defs_kills
8808 (Instruction.XVOM
8809 {src = final_src,
8810 dst = final_dst,
8811 srcsize = srcsize,
8812 dstsize = dstsize})
8813
8814 val temp_reg
8815 = case final_src
8816 of Operand.Register r
8817 => Register.lowPartOf (r, dstsize)
8818 | _
8819 => Error.bug "x86AllocateRegisters.Instruction.allocateRegisters: XVOM, temp_reg"
8820
8821 val instruction
8822 = Instruction.MOV
8823 {src = Operand.register temp_reg,
8824 dst = final_dst,
8825 size = dstsize}
8826
8827 val {assembly = assembly_post,
8828 registerAllocation}
8829 = RA.post {uses = uses,
8830 final_uses = final_uses,
8831 defs = defs,
8832 final_defs = final_defs,
8833 kills = kills,
8834 info = info,
8835 registerAllocation = registerAllocation}
8836 in
8837 {assembly
8838 = AppendList.appends
8839 [assembly_pre,
8840 assembly_src,
8841 assembly_dst,
8842 AppendList.single
8843 (Assembly.instruction instruction),
8844 assembly_post],
8845 registerAllocation = registerAllocation}
8846 end
8847 | LEA {src, dst, size}
8848 (* Load effective address; p. 393
8849 * Require src/dst operands as follows:
8850 *
8851 * dst
8852 * reg imm lab add
8853 * reg
8854 * src imm
8855 * lab
8856 * add X
8857 *)
8858 => let
8859 val {uses,defs,kills}
8860 = Instruction.uses_defs_kills instruction
8861 val {assembly = assembly_pre,
8862 registerAllocation}
8863 = RA.pre {uses = uses,
8864 defs = defs,
8865 kills = kills,
8866 info = info,
8867 registerAllocation = registerAllocation}
8868
8869 val {operand = final_src,
8870 assembly = assembly_src,
8871 registerAllocation}
8872 = RA.allocateOperand {operand = src,
8873 options = {register = false,
8874 immediate = false,
8875 label = false,
8876 address = true},
8877 info = info,
8878 size = size,
8879 move = true,
8880 supports = [dst],
8881 saves = [],
8882 force = [],
8883 registerAllocation
8884 = registerAllocation}
8885
8886 val {operand = final_dst,
8887 assembly = assembly_dst,
8888 registerAllocation = registerAllocation}
8889 = RA.allocateOperand {operand = dst,
8890 options = {register = true,
8891 immediate = false,
8892 label = false,
8893 address = false},
8894 info = info,
8895 size = size,
8896 move = false,
8897 supports = [],
8898 saves = [src,final_src],
8899 force = [],
8900 registerAllocation
8901 = registerAllocation}
8902
8903 val instruction
8904 = Instruction.LEA
8905 {src = final_src,
8906 dst = final_dst,
8907 size = size}
8908
8909 val {uses = final_uses,
8910 defs = final_defs,
8911 ...}
8912 = Instruction.uses_defs_kills instruction
8913
8914 val {assembly = assembly_post,
8915 registerAllocation}
8916 = RA.post {uses = uses,
8917 final_uses = final_uses,
8918 defs = defs,
8919 final_defs = final_defs,
8920 kills = kills,
8921 info = info,
8922 registerAllocation = registerAllocation}
8923 in
8924 {assembly
8925 = AppendList.appends
8926 [assembly_pre,
8927 assembly_src,
8928 assembly_dst,
8929 AppendList.single
8930 (Assembly.instruction instruction),
8931 assembly_post],
8932 registerAllocation = registerAllocation}
8933 end
8934 | pFMOV {src, dst, size} => pfmov {instruction = instruction, info = info,
8935 registerAllocation = registerAllocation,
8936 src = src, dst = dst,
8937 srcsize = size, dstsize = size}
8938 | pFMOVX {src, dst, srcsize, dstsize} => pfmov {instruction = instruction, info = info,
8939 registerAllocation = registerAllocation,
8940 src = src, dst = dst,
8941 srcsize = srcsize, dstsize = dstsize}
8942 | pFXVOM {src, dst, srcsize, dstsize} => pfmov {instruction = instruction, info = info,
8943 registerAllocation = registerAllocation,
8944 src = src, dst = dst,
8945 srcsize = srcsize, dstsize = dstsize}
8946 | pFLDC {oper, dst, size}
8947 (* Pseudo floating-point load constant.
8948 *)
8949 => let
8950 val {uses,defs,kills}
8951 = Instruction.uses_defs_kills instruction
8952 val {assembly = assembly_pre,
8953 registerAllocation}
8954 = RA.pre {uses = uses,
8955 defs = defs,
8956 kills = kills,
8957 info = info,
8958 registerAllocation = registerAllocation}
8959
8960 val {assembly = assembly_dst,
8961 registerAllocation,
8962 ...}
8963 = RA.allocateFltOperand {operand = dst,
8964 options = {fltregister = true,
8965 address = false},
8966 info = info,
8967 size = size,
8968 move = false,
8969 supports = [],
8970 saves = [],
8971 top = NONE,
8972 registerAllocation
8973 = registerAllocation}
8974
8975 val instruction
8976 = Instruction.FLDC
8977 {oper = oper}
8978
8979 val {uses = final_uses,
8980 defs = final_defs,
8981 ...}
8982 = Instruction.uses_defs_kills instruction
8983
8984 val {assembly = assembly_post,
8985 registerAllocation}
8986 = RA.post {uses = uses,
8987 final_uses = final_uses,
8988 defs = defs,
8989 final_defs = final_defs,
8990 kills = kills,
8991 info = info,
8992 registerAllocation = registerAllocation}
8993 in
8994 {assembly
8995 = AppendList.appends
8996 [assembly_pre,
8997 assembly_dst,
8998 AppendList.single
8999 (Assembly.instruction instruction),
9000 assembly_post],
9001 registerAllocation = registerAllocation}
9002 end
9003 | pFMOVFI {src, dst, srcsize, dstsize}
9004 (* Pseudo floating-point from integer.
9005 *)
9006 => let
9007 val {uses,defs,kills}
9008 = Instruction.uses_defs_kills instruction
9009 val {assembly = assembly_pre,
9010 registerAllocation}
9011 = RA.pre {uses = uses,
9012 defs = defs,
9013 kills = kills,
9014 info = info,
9015 registerAllocation = registerAllocation}
9016
9017 val {operand = final_src,
9018 assembly = assembly_src,
9019 registerAllocation}
9020 = RA.allocateOperand {operand = src,
9021 options = {register = false,
9022 immediate = false,
9023 label = false,
9024 address = true},
9025 info = info,
9026 size = srcsize,
9027 move = true,
9028 supports = [dst],
9029 saves = [],
9030 force = [],
9031 registerAllocation
9032 = registerAllocation}
9033
9034 val {assembly = assembly_dst,
9035 registerAllocation,
9036 ...}
9037 = RA.allocateFltOperand {operand = dst,
9038 options = {fltregister = true,
9039 address = false},
9040 info = info,
9041 size = dstsize,
9042 move = false,
9043 supports = [],
9044 saves = [src,final_src],
9045 top = NONE,
9046 registerAllocation
9047 = registerAllocation}
9048
9049 val instruction
9050 = Instruction.FILD
9051 {src = final_src,
9052 size = Size.toFPI srcsize}
9053
9054 val {uses = final_uses,
9055 defs = final_defs,
9056 ...}
9057 = Instruction.uses_defs_kills instruction
9058
9059 val {assembly = assembly_post,
9060 registerAllocation}
9061 = RA.post {uses = uses,
9062 final_uses = final_uses,
9063 defs = defs,
9064 final_defs = final_defs,
9065 kills = kills,
9066 info = info,
9067 registerAllocation = registerAllocation}
9068 in
9069 {assembly
9070 = AppendList.appends
9071 [assembly_pre,
9072 assembly_src,
9073 assembly_dst,
9074 AppendList.single
9075 (Assembly.instruction instruction),
9076 assembly_post],
9077 registerAllocation = registerAllocation}
9078 end
9079 | pFMOVTI {src, dst, srcsize, dstsize}
9080 (* Pseudo floating-point to integer.
9081 *)
9082 => let
9083 val {uses,defs,kills}
9084 = Instruction.uses_defs_kills instruction
9085 val {assembly = assembly_pre,
9086 registerAllocation}
9087 = RA.pre {uses = uses,
9088 defs = defs,
9089 kills = kills,
9090 info = info,
9091 registerAllocation = registerAllocation}
9092
9093 fun default ()
9094 = let
9095 val {operand = final_src,
9096 assembly = assembly_src,
9097 registerAllocation,
9098 ...}
9099 = RA.allocateFltOperand
9100 {operand = src,
9101 options = {fltregister = true,
9102 address = false},
9103 info = info,
9104 size = srcsize,
9105 move = true,
9106 supports = [dst],
9107 saves = [],
9108 top = SOME true,
9109 registerAllocation = registerAllocation}
9110
9111 val {operand = final_dst,
9112 assembly = assembly_dst,
9113 registerAllocation}
9114 = RA.allocateOperand
9115 {operand = dst,
9116 options = {register = false,
9117 immediate = false,
9118 label = false,
9119 address = true},
9120 info = info,
9121 size = dstsize,
9122 move = false,
9123 supports = [],
9124 saves = [src,final_src],
9125 force = [],
9126 registerAllocation = registerAllocation}
9127
9128 val instruction
9129 = Instruction.FIST
9130 {dst = final_dst,
9131 size = Size.toFPI dstsize,
9132 pop = false}
9133
9134 val {uses = final_uses,
9135 defs = final_defs,
9136 ...}
9137 = Instruction.uses_defs_kills instruction
9138
9139 val {assembly = assembly_post,
9140 registerAllocation}
9141 = RA.post {uses = uses,
9142 final_uses = final_uses,
9143 defs = defs,
9144 final_defs = final_defs,
9145 kills = kills,
9146 info = info,
9147 registerAllocation = registerAllocation}
9148 in
9149 {assembly
9150 = AppendList.appends
9151 [assembly_pre,
9152 assembly_src,
9153 assembly_dst,
9154 AppendList.single
9155 (Assembly.instruction instruction),
9156 assembly_post],
9157 registerAllocation = registerAllocation}
9158 end
9159
9160 fun default' ()
9161 = let
9162 val {operand = final_src,
9163 assembly = assembly_src,
9164 registerAllocation,
9165 ...}
9166 = RA.allocateFltOperand
9167 {operand = src,
9168 options = {fltregister = true,
9169 address = false},
9170 info = info,
9171 size = srcsize,
9172 move = true,
9173 supports = [dst],
9174 saves = [],
9175 top = SOME true,
9176 registerAllocation = registerAllocation}
9177
9178 val {operand = final_dst,
9179 assembly = assembly_dst,
9180 registerAllocation,
9181 ...}
9182 = RA.allocateFltOperand
9183 {operand = dst,
9184 options = {fltregister = false,
9185 address = true},
9186 info = info,
9187 size = dstsize,
9188 move = false,
9189 supports = [],
9190 saves = [src,final_src],
9191 top = SOME false,
9192 registerAllocation = registerAllocation}
9193
9194 val instruction
9195 = Instruction.FIST
9196 {dst = final_dst,
9197 size = Size.toFPI dstsize,
9198 pop = true}
9199
9200 val {fltrename = fltrename_pop,
9201 registerAllocation}
9202 = RA.fltpop {registerAllocation = registerAllocation}
9203
9204 val {uses = final_uses,
9205 defs = final_defs,
9206 ...}
9207 = Instruction.uses_defs_kills instruction
9208
9209 val final_uses
9210 = List.revMap(final_uses, RA.fltrenameLift fltrename_pop)
9211 val final_defs
9212 = List.revMap(final_defs, RA.fltrenameLift fltrename_pop)
9213
9214 val {assembly = assembly_post,
9215 registerAllocation}
9216 = RA.post {uses = uses,
9217 final_uses = final_uses,
9218 defs = defs,
9219 final_defs = final_defs,
9220 kills = kills,
9221 info = info,
9222 registerAllocation
9223 = registerAllocation}
9224 in
9225 {assembly
9226 = AppendList.appends
9227 [assembly_pre,
9228 assembly_src,
9229 assembly_dst,
9230 AppendList.single
9231 (Assembly.instruction instruction),
9232 assembly_post],
9233 registerAllocation = registerAllocation}
9234 end
9235 in
9236 case src
9237 of Operand.MemLoc memloc_src
9238 => if removable {memloc = memloc_src,
9239 info = info,
9240 registerAllocation
9241 = registerAllocation}
9242 then default' ()
9243 else default ()
9244 | _ => default ()
9245 end
9246 | pFCOM {src1, src2, size}
9247 (* Floating-point compare real; p. 220
9248 * Require src operand as follows:
9249 *
9250 * src
9251 * fltreg add
9252 * * X
9253 * * only st(1) if pop and pop'
9254 *
9255 * Require size modifier class as follows: FLT(SNGL,DBLE)
9256 *)
9257 => let
9258 val {uses,defs,kills}
9259 = Instruction.uses_defs_kills instruction
9260 val {assembly = assembly_pre,
9261 registerAllocation}
9262 = RA.pre {uses = uses,
9263 defs = defs,
9264 kills = kills,
9265 info = info,
9266 registerAllocation = registerAllocation}
9267
9268 val {final_src2,
9269 assembly_src1_src2,
9270 pop,
9271 pop',
9272 registerAllocation,
9273 ...}
9274 = if Operand.eq(src1,src2)
9275 then let
9276 fun default b
9277 = let
9278 val {operand = final_src1_src2,
9279 assembly = assembly_src1_src2,
9280 fltrename = fltrename_src1_src2,
9281 registerAllocation}
9282 = RA.allocateFltOperand
9283 {operand = src1,
9284 options = {fltregister = true,
9285 address = false},
9286 info = info,
9287 size = size,
9288 move = true,
9289 supports = [],
9290 saves = [],
9291 top = SOME true,
9292 registerAllocation
9293 = registerAllocation}
9294 in
9295 {final_src1 = final_src1_src2,
9296 final_src2 = final_src1_src2,
9297 assembly_src1_src2 = assembly_src1_src2,
9298 fltrename_src1_src2 = fltrename_src1_src2,
9299 pop = b,
9300 pop' = false,
9301 registerAllocation = registerAllocation}
9302 end
9303 in
9304 case src1
9305 of Operand.MemLoc memloc_src1
9306 => if removable {memloc = memloc_src1,
9307 info = info,
9308 registerAllocation
9309 = registerAllocation}
9310 then default true
9311 else default false
9312 | _ => default false
9313 end
9314 else let
9315 fun default b
9316 = let
9317 val {operand = final_src2,
9318 assembly = assembly_src2,
9319 fltrename = fltrename_src2,
9320 registerAllocation}
9321 = RA.allocateFltOperand
9322 {operand = src2,
9323 options = {fltregister = true,
9324 address = true},
9325 info = info,
9326 size = size,
9327 move = true,
9328 supports = [src1],
9329 saves = [],
9330 top = SOME false,
9331 registerAllocation
9332 = registerAllocation}
9333
9334 val {operand = final_src1,
9335 assembly = assembly_src1,
9336 fltrename = fltrename_src1,
9337 registerAllocation}
9338 = RA.allocateFltOperand
9339 {operand = src1,
9340 options = {fltregister = true,
9341 address = false},
9342 info = info,
9343 size = size,
9344 move = true,
9345 supports = [],
9346 saves = [src2,final_src2],
9347 top = SOME true,
9348 registerAllocation
9349 = registerAllocation}
9350
9351 val final_src2
9352 = (RA.fltrenameLift fltrename_src1) final_src2
9353 in
9354 {final_src1 = final_src1,
9355 final_src2 = final_src2,
9356 assembly_src1_src2
9357 = AppendList.appends
9358 [assembly_src2,
9359 assembly_src1],
9360 fltrename_src1_src2 = fltrename_src1 o
9361 fltrename_src2,
9362 pop = b,
9363 pop' = false,
9364 registerAllocation = registerAllocation}
9365 end
9366
9367 fun default' ()
9368 = let
9369 val {operand_top = final_src1,
9370 operand_one = final_src2,
9371 assembly = assembly_src1_src2,
9372 fltrename = fltrename_src1_src2,
9373 registerAllocation}
9374 = RA.allocateFltStackOperands
9375 {operand_top = src1,
9376 move_top = true,
9377 size_top = size,
9378 operand_one = src2,
9379 move_one = true,
9380 size_one = size,
9381 info = info,
9382 supports = [],
9383 saves = [],
9384 registerAllocation
9385 = registerAllocation}
9386 in
9387 {final_src1 = final_src1,
9388 final_src2 = final_src2,
9389 assembly_src1_src2 = assembly_src1_src2,
9390 fltrename_src1_src2 = fltrename_src1_src2,
9391 pop = true,
9392 pop' = true,
9393 registerAllocation = registerAllocation}
9394 end
9395 in
9396 case (src1,src2)
9397 of (Operand.MemLoc memloc_src1,
9398 Operand.MemLoc memloc_src2)
9399 => if removable {memloc = memloc_src1,
9400 info = info,
9401 registerAllocation
9402 = registerAllocation}
9403 then if removable
9404 {memloc = memloc_src2,
9405 info = info,
9406 registerAllocation
9407 = registerAllocation}
9408 then default' ()
9409 else default true
9410 else default false
9411 | (Operand.MemLoc memloc_src1, _)
9412 => if removable {memloc = memloc_src1,
9413 info = info,
9414 registerAllocation
9415 = registerAllocation}
9416 then default true
9417 else default false
9418 | _ => default false
9419 end
9420
9421 val instruction
9422 = Instruction.FCOM
9423 {src = final_src2,
9424 size = size,
9425 pop = pop,
9426 pop' = pop'}
9427
9428 val {fltrename = fltrename_pop,
9429 registerAllocation}
9430 = if pop
9431 then if pop'
9432 then let
9433 val {fltrename = fltrename_pop,
9434 registerAllocation}
9435 = RA.fltpop {registerAllocation
9436 = registerAllocation}
9437 val {fltrename = fltrename_pop',
9438 registerAllocation}
9439 = RA.fltpop {registerAllocation
9440 = registerAllocation}
9441 in
9442 {fltrename = fltrename_pop' o fltrename_pop,
9443 registerAllocation= registerAllocation}
9444 end
9445 else let
9446 val {fltrename = fltrename_pop,
9447 registerAllocation}
9448 = RA.fltpop {registerAllocation
9449 = registerAllocation}
9450 in
9451 {fltrename = fltrename_pop,
9452 registerAllocation = registerAllocation}
9453 end
9454 else {fltrename = FltRegister.id,
9455 registerAllocation = registerAllocation}
9456
9457 val {uses = final_uses,
9458 defs = final_defs,
9459 ...}
9460 = Instruction.uses_defs_kills instruction
9461
9462 val final_uses
9463 = List.revMap(final_uses, RA.fltrenameLift fltrename_pop)
9464 val final_defs
9465 = List.revMap(final_defs, RA.fltrenameLift fltrename_pop)
9466
9467 val {assembly = assembly_post,
9468 registerAllocation}
9469 = RA.post {uses = uses,
9470 final_uses = final_uses,
9471 defs = defs,
9472 final_defs = final_defs,
9473 kills = kills,
9474 info = info,
9475 registerAllocation = registerAllocation}
9476 in
9477 {assembly
9478 = AppendList.appends
9479 [assembly_pre,
9480 assembly_src1_src2,
9481 AppendList.single
9482 (Assembly.instruction instruction),
9483 assembly_post],
9484 registerAllocation = registerAllocation}
9485 end
9486 | pFUCOM {src1, src2, size}
9487 (* Floating-point unordered compare real; p. 307
9488 * Require src operand as follows:
9489 *
9490 * src
9491 * fltreg add
9492 * *
9493 * * only st(1) if pop and pop'
9494 *)
9495 => let
9496 val {uses,defs,kills}
9497 = Instruction.uses_defs_kills instruction
9498 val {assembly = assembly_pre,
9499 registerAllocation}
9500 = RA.pre {uses = uses,
9501 defs = defs,
9502 kills = kills,
9503 info = info,
9504 registerAllocation = registerAllocation}
9505
9506 val {final_src2,
9507 assembly_src1_src2,
9508 pop,
9509 pop',
9510 registerAllocation,
9511 ...}
9512 = if Operand.eq(src1,src2)
9513 then let
9514 fun default b
9515 = let
9516 val {operand = final_src1_src2,
9517 assembly = assembly_src1_src2,
9518 fltrename = fltrename_src1_src2,
9519 registerAllocation}
9520 = RA.allocateFltOperand
9521 {operand = src1,
9522 options = {fltregister = true,
9523 address = false},
9524 info = info,
9525 size = size,
9526 move = true,
9527 supports = [],
9528 saves = [],
9529 top = SOME true,
9530 registerAllocation
9531 = registerAllocation}
9532 in
9533 {final_src1 = final_src1_src2,
9534 final_src2 = final_src1_src2,
9535 assembly_src1_src2 = assembly_src1_src2,
9536 fltrename_src1_src2 = fltrename_src1_src2,
9537 pop = b,
9538 pop' = false,
9539 registerAllocation = registerAllocation}
9540 end
9541 in
9542 case src1
9543 of Operand.MemLoc memloc_src1
9544 => if removable {memloc = memloc_src1,
9545 info = info,
9546 registerAllocation
9547 = registerAllocation}
9548 then default true
9549 else default false
9550 | _ => default false
9551 end
9552 else let
9553 fun default b
9554 = let
9555 val {operand = final_src2,
9556 assembly = assembly_src2,
9557 fltrename = fltrename_src2,
9558 registerAllocation}
9559 = RA.allocateFltOperand
9560 {operand = src2,
9561 options = {fltregister = true,
9562 address = false},
9563 info = info,
9564 size = size,
9565 move = true,
9566 supports = [src1],
9567 saves = [],
9568 top = SOME false,
9569 registerAllocation
9570 = registerAllocation}
9571
9572 val {operand = final_src1,
9573 assembly = assembly_src1,
9574 fltrename = fltrename_src1,
9575 registerAllocation}
9576 = RA.allocateFltOperand
9577 {operand = src1,
9578 options = {fltregister = true,
9579 address = false},
9580 info = info,
9581 size = size,
9582 move = true,
9583 supports = [],
9584 saves = [src2,final_src2],
9585 top = SOME true,
9586 registerAllocation
9587 = registerAllocation}
9588
9589 val final_src2
9590 = (RA.fltrenameLift fltrename_src1) final_src2
9591 in
9592 {final_src1 = final_src1,
9593 final_src2 = final_src2,
9594 assembly_src1_src2
9595 = AppendList.appends
9596 [assembly_src2,
9597 assembly_src1],
9598 fltrename_src1_src2 = fltrename_src1 o
9599 fltrename_src2,
9600 pop = b,
9601 pop' = false,
9602 registerAllocation = registerAllocation}
9603 end
9604 in
9605 case (src1,src2)
9606 of (Operand.MemLoc memloc_src1,
9607 Operand.MemLoc memloc_src2)
9608 => let
9609 fun default' ()
9610 = case RA.fltallocated
9611 {memloc = memloc_src2,
9612 registerAllocation
9613 = registerAllocation}
9614 of SOME _
9615 => let
9616 val {operand_top
9617 = final_src1,
9618 operand_one
9619 = final_src2,
9620 assembly
9621 = assembly_src1_src2,
9622 fltrename
9623 = fltrename_src1_src2,
9624 registerAllocation}
9625 = RA.allocateFltStackOperands
9626 {operand_top = src1,
9627 move_top = true,
9628 size_top = size,
9629 operand_one = src2,
9630 move_one = true,
9631 size_one = size,
9632 info = info,
9633 supports = [],
9634 saves = [],
9635 registerAllocation
9636 = registerAllocation}
9637 in
9638 {final_src1 = final_src1,
9639 final_src2 = final_src2,
9640 assembly_src1_src2
9641 = assembly_src1_src2,
9642 fltrename_src1_src2
9643 = fltrename_src1_src2,
9644 pop = true,
9645 pop' = true,
9646 registerAllocation
9647 = registerAllocation}
9648 end
9649 | NONE
9650 => default true
9651 in
9652 if removable
9653 {memloc = memloc_src1,
9654 info = info,
9655 registerAllocation
9656 = registerAllocation}
9657 then if removable
9658 {memloc = memloc_src2,
9659 info = info,
9660 registerAllocation
9661 = registerAllocation}
9662 then default' ()
9663 else default true
9664 else default false
9665 end
9666 | (Operand.MemLoc memloc_src1, _)
9667 => if removable {memloc = memloc_src1,
9668 info = info,
9669 registerAllocation
9670 = registerAllocation}
9671 then default true
9672 else default false
9673 | _ => default false
9674 end
9675
9676 val instruction
9677 = Instruction.FUCOM
9678 {src = final_src2,
9679 pop = pop,
9680 pop' = pop'}
9681
9682 val {fltrename = fltrename_pop,
9683 registerAllocation}
9684 = if pop
9685 then if pop'
9686 then let
9687 val {fltrename = fltrename_pop,
9688 registerAllocation}
9689 = RA.fltpop {registerAllocation
9690 = registerAllocation}
9691 val {fltrename = fltrename_pop',
9692 registerAllocation}
9693 = RA.fltpop {registerAllocation
9694 = registerAllocation}
9695 in
9696 {fltrename = fltrename_pop' o fltrename_pop,
9697 registerAllocation= registerAllocation}
9698 end
9699 else let
9700 val {fltrename = fltrename_pop,
9701 registerAllocation}
9702 = RA.fltpop {registerAllocation
9703 = registerAllocation}
9704 in
9705 {fltrename = fltrename_pop,
9706 registerAllocation = registerAllocation}
9707 end
9708 else {fltrename = FltRegister.id,
9709 registerAllocation = registerAllocation}
9710
9711 val {uses = final_uses,
9712 defs = final_defs,
9713 ...}
9714 = Instruction.uses_defs_kills instruction
9715
9716 val final_uses
9717 = List.revMap(final_uses, RA.fltrenameLift fltrename_pop)
9718 val final_defs
9719 = List.revMap(final_defs, RA.fltrenameLift fltrename_pop)
9720
9721 val {assembly = assembly_post,
9722 registerAllocation}
9723 = RA.post {uses = uses,
9724 final_uses = final_uses,
9725 defs = defs,
9726 final_defs = final_defs,
9727 kills = kills,
9728 info = info,
9729 registerAllocation = registerAllocation}
9730 in
9731 {assembly
9732 = AppendList.appends
9733 [assembly_pre,
9734 assembly_src1_src2,
9735 AppendList.single
9736 (Assembly.instruction instruction),
9737 assembly_post],
9738 registerAllocation = registerAllocation}
9739 end
9740 | pFBinA {oper, src, dst, size}
9741 (* Floating-point binary arithmetic instructions.
9742 * Require src operand as follows:
9743 *
9744 * src
9745 * fltreg add
9746 * * X
9747 * * only st(0) if pop
9748 *
9749 * Require dst operand as follows:
9750 *
9751 * dst
9752 * fltreg add
9753 * *
9754 * * only st(0) if src add
9755 *
9756 * * one of src,dst must be st(0)
9757 *
9758 * Require size modifier class as follows: FLT
9759 *)
9760 => let
9761 val {uses,defs,kills}
9762 = Instruction.uses_defs_kills instruction
9763 val {assembly = assembly_pre,
9764 registerAllocation}
9765 = RA.pre {uses = uses,
9766 defs = defs,
9767 kills = kills,
9768 info = info,
9769 registerAllocation = registerAllocation}
9770
9771 val {final_src,
9772 final_dst,
9773 assembly_src_dst,
9774 oper,
9775 pop,
9776 registerAllocation,
9777 ...}
9778 = if Operand.eq(src,dst)
9779 then let
9780 val {operand = final_src_dst,
9781 assembly = assembly_src_dst,
9782 fltrename = fltrename_src_dst,
9783 registerAllocation}
9784 = RA.allocateFltOperand
9785 {operand = dst,
9786 options = {fltregister = true,
9787 address = false},
9788 info = info,
9789 size = size,
9790 move = true,
9791 supports = [],
9792 saves = [],
9793 top = SOME true,
9794 registerAllocation
9795 = registerAllocation}
9796 in
9797 {final_src = final_src_dst,
9798 final_dst = final_src_dst,
9799 assembly_src_dst = assembly_src_dst,
9800 fltrename_src_dst = fltrename_src_dst,
9801 oper = oper,
9802 pop = false,
9803 registerAllocation = registerAllocation}
9804 end
9805 else let
9806 fun default ()
9807 = let
9808 val {operand = final_src,
9809 assembly = assembly_src,
9810 fltrename = fltrename_src,
9811 registerAllocation}
9812 = RA.allocateFltOperand
9813 {operand = src,
9814 options = {fltregister = true,
9815 address = true},
9816 info = info,
9817 size = size,
9818 move = true,
9819 supports = [dst],
9820 saves = [],
9821 top = SOME false,
9822 registerAllocation
9823 = registerAllocation}
9824
9825 val {operand = final_dst,
9826 assembly = assembly_dst,
9827 fltrename = fltrename_dst,
9828 registerAllocation}
9829 = case final_src
9830 of Operand.Address _
9831 => RA.allocateFltOperand
9832 {operand = dst,
9833 options = {fltregister = true,
9834 address = false},
9835 info = info,
9836 size = size,
9837 move = true,
9838 supports = [],
9839 saves = [src,final_src],
9840 top = SOME true,
9841 registerAllocation
9842 = registerAllocation}
9843 | Operand.FltRegister f
9844 => if FltRegister.eq
9845 (f, FltRegister.top)
9846 then RA.allocateFltOperand
9847 {operand = dst,
9848 options
9849 = {fltregister = true,
9850 address = false},
9851 info = info,
9852 size = size,
9853 move = true,
9854 supports = [],
9855 saves = [src,final_src],
9856 top = SOME false,
9857 registerAllocation
9858 = registerAllocation}
9859 else RA.allocateFltOperand
9860 {operand = dst,
9861 options
9862 = {fltregister = true,
9863 address = false},
9864 info = info,
9865 size = size,
9866 move = true,
9867 supports = [],
9868 saves = [src,final_src],
9869 top = SOME true,
9870 registerAllocation
9871 = registerAllocation}
9872 | _
9873 => Error.bug
9874 "x86AllocateRegisters.Instruction.allocateRegisters: pFBinA, final_src"
9875
9876 val final_src
9877 = (RA.fltrenameLift fltrename_dst) final_src
9878 in
9879 {final_src = final_src,
9880 final_dst = final_dst,
9881 assembly_src_dst
9882 = AppendList.appends
9883 [assembly_src,
9884 assembly_dst],
9885 fltrename_src_dst = fltrename_dst o
9886 fltrename_src,
9887 oper = oper,
9888 pop = false,
9889 registerAllocation = registerAllocation}
9890 end
9891
9892 fun default' ()
9893 = let
9894 val {operand = final_dst,
9895 assembly = assembly_dst,
9896 fltrename = fltrename_dst,
9897 registerAllocation}
9898 = RA.allocateFltOperand
9899 {operand = dst,
9900 options = {fltregister = true,
9901 address = false},
9902 info = info,
9903 size = size,
9904 move = true,
9905 supports = [src],
9906 saves = [],
9907 top = SOME false,
9908 registerAllocation
9909 = registerAllocation}
9910
9911 val {operand = final_src,
9912 assembly = assembly_src,
9913 fltrename = fltrename_src,
9914 registerAllocation}
9915 = RA.allocateFltOperand
9916 {operand = src,
9917 options = {fltregister = true,
9918 address = false},
9919 info = info,
9920 size = size,
9921 move = true,
9922 supports = [],
9923 saves = [dst,final_dst],
9924 top = SOME true,
9925 registerAllocation
9926 = registerAllocation}
9927
9928 val final_dst
9929 = (RA.fltrenameLift fltrename_src) final_dst
9930 in
9931 {final_src = final_src,
9932 final_dst = final_dst,
9933 assembly_src_dst
9934 = AppendList.appends
9935 [assembly_dst,
9936 assembly_src],
9937 fltrename_src_dst = fltrename_src o
9938 fltrename_dst,
9939 oper = oper,
9940 pop = true,
9941 registerAllocation = registerAllocation}
9942 end
9943
9944 fun default'' value_dst
9945 = let
9946 val {operand = final_dst,
9947 assembly = assembly_dst,
9948 fltrename = fltrename_dst,
9949 registerAllocation}
9950 = RA.allocateFltOperand
9951 {operand = dst,
9952 options = {fltregister = true,
9953 address = false},
9954 info = info,
9955 size = size,
9956 move = true,
9957 supports = [src],
9958 saves = [],
9959 top = SOME true,
9960 registerAllocation
9961 = registerAllocation}
9962
9963 val {operand = final_src,
9964 assembly = assembly_src,
9965 fltrename = fltrename_src,
9966 registerAllocation}
9967 = RA.allocateFltOperand
9968 {operand = src,
9969 options = {fltregister = true,
9970 address = false},
9971 info = info,
9972 size = size,
9973 move = true,
9974 supports = [],
9975 saves = [dst,final_dst],
9976 top = SOME false,
9977 registerAllocation
9978 = registerAllocation}
9979
9980 val final_dst
9981 = (RA.fltrenameLift fltrename_src) final_dst
9982
9983 val {memloc = memloc_dst,
9984 weight = weight_dst,
9985 sync = sync_dst,
9986 commit = commit_dst,
9987 ...} : RegisterAllocation.fltvalue
9988 = value_dst
9989
9990 val fltregister_src
9991 = case Operand.deFltregister final_src
9992 of SOME fltregister => fltregister
9993 | NONE
9994 => Error.bug "x86AllocateRegisters.Instruction.allocateRegisters: pFBinA, final_src"
9995
9996 val registerAllocation
9997 = RA.fltupdate
9998 {value
9999 = {fltregister = fltregister_src,
10000 memloc = memloc_dst,
10001 weight = weight_dst,
10002 sync = sync_dst,
10003 commit = commit_dst},
10004 registerAllocation
10005 = registerAllocation}
10006 in
10007 {final_src = final_dst,
10008 final_dst = final_src,
10009 assembly_src_dst
10010 = AppendList.appends
10011 [assembly_dst,
10012 assembly_src],
10013 fltrename_src_dst = fltrename_src o
10014 fltrename_dst,
10015 oper = Instruction.fbina_reverse oper,
10016 pop = true,
10017 registerAllocation = registerAllocation}
10018 end
10019
10020 fun default''' memloc_dst
10021 = let
10022 val {operand = final_dst,
10023 assembly = assembly_dst,
10024 fltrename = fltrename_dst,
10025 registerAllocation}
10026 = RA.allocateFltOperand
10027 {operand = dst,
10028 options = {fltregister = false,
10029 address = true},
10030 info = info,
10031 size = size,
10032 move = true,
10033 supports = [src],
10034 saves = [],
10035 top = SOME false,
10036 registerAllocation
10037 = registerAllocation}
10038
10039 val {operand = final_src,
10040 assembly = assembly_src,
10041 fltrename = fltrename_src,
10042 registerAllocation}
10043 = RA.allocateFltOperand
10044 {operand = src,
10045 options = {fltregister = true,
10046 address = false},
10047 info = info,
10048 size = size,
10049 move = true,
10050 supports = [],
10051 saves = [dst,final_dst],
10052 top = SOME true,
10053 registerAllocation
10054 = registerAllocation}
10055
10056 val final_dst
10057 = (RA.fltrenameLift fltrename_src) final_dst
10058
10059 val {fltrename = fltrename_pop,
10060 registerAllocation}
10061 = RA.fltpop
10062 {registerAllocation
10063 = registerAllocation}
10064
10065 val {fltrename = fltrename_push,
10066 registerAllocation}
10067 = RA.fltpush
10068 {value
10069 = {fltregister = FltRegister.top,
10070 memloc = memloc_dst,
10071 weight = 1024,
10072 sync = false,
10073 commit = RA.NO},
10074 registerAllocation
10075 = registerAllocation}
10076 in
10077 {final_src = final_dst,
10078 final_dst = final_src,
10079 assembly_src_dst
10080 = AppendList.appends
10081 [assembly_dst,
10082 assembly_src],
10083 fltrename_src_dst = fltrename_push o
10084 fltrename_pop o
10085 fltrename_src o
10086 fltrename_dst,
10087 oper = Instruction.fbina_reverse oper,
10088 pop = false,
10089 registerAllocation = registerAllocation}
10090 end
10091 in
10092 case (src,dst)
10093 of (Operand.MemLoc memloc_src,
10094 Operand.MemLoc memloc_dst)
10095 => (case (RA.fltallocated
10096 {memloc = memloc_src,
10097 registerAllocation
10098 = registerAllocation},
10099 RA.fltallocated
10100 {memloc = memloc_dst,
10101 registerAllocation
10102 = registerAllocation})
10103 of (SOME ({sync = sync_src,
10104 ...}),
10105 SOME (value_dst as
10106 {fltregister
10107 = fltregister_dst,
10108 ...}))
10109 => if MemLocSet.contains(dead,
10110 memloc_src)
10111 orelse
10112 (MemLocSet.contains(remove,
10113 memloc_src)
10114 andalso
10115 sync_src)
10116 then if FltRegister.eq
10117 (fltregister_dst,
10118 FltRegister.top)
10119 then default'' value_dst
10120 else default' ()
10121 else default ()
10122 | (SOME {sync = sync_src,...},
10123 NONE)
10124 => if MemLocSet.contains(dead,
10125 memloc_src)
10126 orelse
10127 (MemLocSet.contains(remove,
10128 memloc_src)
10129 andalso
10130 sync_src)
10131 then default''' memloc_dst
10132 else default ()
10133 | _ => default ())
10134 | (Operand.MemLoc memloc_src, _)
10135 => (case RA.fltallocated
10136 {memloc = memloc_src,
10137 registerAllocation
10138 = registerAllocation}
10139 of SOME {sync = sync_src,...}
10140 => if MemLocSet.contains(dead,
10141 memloc_src)
10142 orelse
10143 (MemLocSet.contains(remove,
10144 memloc_src)
10145 andalso
10146 sync_src)
10147 then default' ()
10148 else default ()
10149 | _ => default ())
10150 | _ => default ()
10151 end
10152
10153 val oper
10154 = if Operand.eq(final_src,
10155 Operand.fltregister FltRegister.top)
10156 andalso isSome (Operand.deFltregister final_dst)
10157 then fbina_reverse oper
10158 else oper
10159
10160 val instruction
10161 = Instruction.FBinA
10162 {oper = oper,
10163 src = final_src,
10164 dst = final_dst,
10165 size = size,
10166 pop = pop}
10167
10168 val {fltrename = fltrename_pop,
10169 registerAllocation}
10170 = if pop
10171 then let
10172 val {fltrename = fltrename_pop,
10173 registerAllocation}
10174 = RA.fltpop {registerAllocation
10175 = registerAllocation}
10176 in
10177 {fltrename = fltrename_pop,
10178 registerAllocation = registerAllocation}
10179 end
10180 else {fltrename = FltRegister.id,
10181 registerAllocation = registerAllocation}
10182
10183 val {uses = final_uses,
10184 defs = final_defs,
10185 ...}
10186 = Instruction.uses_defs_kills instruction
10187
10188 val final_uses
10189 = List.revMap(final_uses, RA.fltrenameLift fltrename_pop)
10190 val final_defs
10191 = List.revMap(final_defs, RA.fltrenameLift fltrename_pop)
10192
10193 val {assembly = assembly_post,
10194 registerAllocation}
10195 = RA.post {uses = uses,
10196 final_uses = final_uses,
10197 defs = defs,
10198 final_defs = final_defs,
10199 kills = kills,
10200 info = info,
10201 registerAllocation = registerAllocation}
10202
10203 in
10204 {assembly
10205 = AppendList.appends
10206 [assembly_pre,
10207 assembly_src_dst,
10208 AppendList.single
10209 (Assembly.instruction instruction),
10210 assembly_post],
10211 registerAllocation = registerAllocation}
10212 end
10213 | pFUnA {oper, dst, size}
10214 (* Floating-point unary arithmetic instructions.
10215 * Require src operand as follows:
10216 *
10217 * src
10218 * fltreg add
10219 * *
10220 * * only st(0)
10221 *
10222 * Require size modifier class as follows: FLT
10223 *)
10224 => let
10225 val {uses,defs,kills}
10226 = Instruction.uses_defs_kills instruction
10227 val {assembly = assembly_pre,
10228 registerAllocation}
10229 = RA.pre {uses = uses,
10230 defs = defs,
10231 kills = kills,
10232 info = info,
10233 registerAllocation = registerAllocation}
10234
10235 val {assembly = assembly_dst,
10236 registerAllocation,
10237 ...}
10238 = RA.allocateFltOperand {operand = dst,
10239 options = {fltregister = true,
10240 address = false},
10241 info = info,
10242 size = size,
10243 move = true,
10244 supports = [],
10245 saves = [],
10246 top = SOME true,
10247 registerAllocation
10248 = registerAllocation}
10249
10250 val instruction
10251 = Instruction.FUnA
10252 {oper = oper}
10253
10254 val {uses = final_uses,
10255 defs = final_defs,
10256 ...}
10257 = Instruction.uses_defs_kills instruction
10258
10259 val {assembly = assembly_post,
10260 registerAllocation}
10261 = RA.post {uses = uses,
10262 final_uses = final_uses,
10263 defs = defs,
10264 final_defs = final_defs,
10265 kills = kills,
10266 info = info,
10267 registerAllocation = registerAllocation}
10268 in
10269 {assembly
10270 = AppendList.appends
10271 [assembly_pre,
10272 assembly_dst,
10273 AppendList.single
10274 (Assembly.instruction instruction),
10275 assembly_post],
10276 registerAllocation = registerAllocation}
10277 end
10278 | pFPTAN {dst, size}
10279 (* Floating-point partial tangent instruction.
10280 * Require src operand as follows:
10281 *
10282 * src
10283 * fltreg add
10284 * *
10285 * * only st(0)
10286 *
10287 * Require size modifier class as follows: FLT
10288 * Automatically pushes 1.0 onto stack.
10289 *)
10290 => let
10291 val {uses,defs,kills}
10292 = Instruction.uses_defs_kills instruction
10293 val {assembly = assembly_pre,
10294 registerAllocation}
10295 = RA.pre {uses = uses,
10296 defs = defs,
10297 kills = kills,
10298 info = info,
10299 registerAllocation = registerAllocation}
10300
10301 val {assembly = assembly_free,
10302 registerAllocation,
10303 ...}
10304 = RA.freeFltRegister
10305 {info = info,
10306 size = Size.DBLE,
10307 supports = [dst],
10308 saves = [],
10309 registerAllocation = registerAllocation}
10310
10311 val {assembly = assembly_dst,
10312 registerAllocation,
10313 ...}
10314 = RA.allocateFltOperand {operand = dst,
10315 options = {fltregister = true,
10316 address = false},
10317 info = info,
10318 size = size,
10319 move = true,
10320 supports = [],
10321 saves = [],
10322 top = SOME true,
10323 registerAllocation
10324 = registerAllocation}
10325
10326 val instruction
10327 = Instruction.FPTAN
10328
10329 val {uses = final_uses,
10330 defs = final_defs,
10331 ...}
10332 = Instruction.uses_defs_kills instruction
10333
10334 val {assembly = assembly_post,
10335 registerAllocation}
10336 = RA.post {uses = uses,
10337 final_uses = final_uses,
10338 defs = defs,
10339 final_defs = final_defs,
10340 kills = kills,
10341 info = info,
10342 registerAllocation = registerAllocation}
10343 in
10344 {assembly
10345 = AppendList.appends
10346 [assembly_pre,
10347 assembly_free,
10348 assembly_dst,
10349 AppendList.single
10350 (Assembly.instruction instruction),
10351 AppendList.single
10352 (Assembly.instruction_fst
10353 {dst = Operand.fltregister FltRegister.top,
10354 size = Size.DBLE,
10355 pop = true}),
10356 assembly_post],
10357 registerAllocation = registerAllocation}
10358 end
10359 | pFBinAS {oper, src, dst, size}
10360 (* Floating-point binary arithmetic stack instructions.
10361 * Require src operand as follows:
10362 *
10363 * src
10364 * fltreg add
10365 * *
10366 * * only st(1)
10367 *
10368 * Require dst operand as follows:
10369 *
10370 * dst
10371 * fltreg add
10372 * *
10373 * * only st(0)
10374 *
10375 * Require size modifier class as follows: FLT
10376 *)
10377 => let
10378 val {uses,defs,kills}
10379 = Instruction.uses_defs_kills instruction
10380 val {assembly = assembly_pre,
10381 registerAllocation}
10382 = RA.pre {uses = uses,
10383 defs = defs,
10384 kills = kills,
10385 info = info,
10386 registerAllocation = registerAllocation}
10387
10388 val {assembly = assembly_dst_src,
10389 registerAllocation,
10390 ...}
10391 = RA.allocateFltStackOperands
10392 {operand_top = dst,
10393 move_top = true,
10394 size_top = size,
10395 operand_one = src,
10396 move_one = true,
10397 size_one = size,
10398 info = info,
10399 supports = [],
10400 saves = [],
10401 registerAllocation = registerAllocation}
10402
10403 val instruction
10404 = Instruction.FBinAS
10405 {oper = oper}
10406
10407 val {uses = final_uses,
10408 defs = final_defs,
10409 ...}
10410 = Instruction.uses_defs_kills instruction
10411
10412 val {assembly = assembly_post,
10413 registerAllocation}
10414 = RA.post {uses = uses,
10415 final_uses = final_uses,
10416 defs = defs,
10417 final_defs = final_defs,
10418 kills = kills,
10419 info = info,
10420 registerAllocation = registerAllocation}
10421 in
10422 {assembly
10423 = AppendList.appends
10424 [assembly_pre,
10425 assembly_dst_src,
10426 AppendList.single
10427 (Assembly.instruction instruction),
10428 assembly_post],
10429 registerAllocation = registerAllocation}
10430 end
10431 | pFBinASP {oper, src, dst, size}
10432 (* Floating-point binary arithmetic stack pop instructions.
10433 * Require src operand as follows:
10434 *
10435 * src
10436 * fltreg add
10437 * *
10438 * * only st(0)
10439 *
10440 * Require dst operand as follows:
10441 *
10442 * dst
10443 * fltreg add
10444 * *
10445 * * only st(1)
10446 *
10447 * Require size modifier class as follows: FLT
10448 *)
10449 => let
10450 val {uses,defs,kills}
10451 = Instruction.uses_defs_kills instruction
10452 val {assembly = assembly_pre,
10453 registerAllocation}
10454 = RA.pre {uses = uses,
10455 defs = defs,
10456 kills = kills,
10457 info = info,
10458 registerAllocation = registerAllocation}
10459
10460 val {assembly = assembly_src_dst,
10461 registerAllocation, ...}
10462 = RA.allocateFltStackOperands
10463 {operand_top = src,
10464 move_top = true,
10465 size_top = size,
10466 operand_one = dst,
10467 move_one = true,
10468 size_one = size,
10469 info = info,
10470 supports = [],
10471 saves = [],
10472 registerAllocation = registerAllocation}
10473
10474 val instruction
10475 = Instruction.FBinASP
10476 {oper = oper}
10477
10478 val {fltrename = fltrename_pop,
10479 registerAllocation}
10480 = RA.fltpop {registerAllocation = registerAllocation}
10481
10482 val {uses = final_uses,
10483 defs = final_defs,
10484 ...}
10485 = Instruction.uses_defs_kills instruction
10486
10487 val final_uses
10488 = List.revMap(final_uses, RA.fltrenameLift fltrename_pop)
10489 val final_defs
10490 = List.revMap(final_defs, RA.fltrenameLift fltrename_pop)
10491
10492 val {assembly = assembly_post,
10493 registerAllocation}
10494 = RA.post {uses = uses,
10495 final_uses = final_uses,
10496 defs = defs,
10497 final_defs = final_defs,
10498 kills = kills,
10499 info = info,
10500 registerAllocation = registerAllocation}
10501 in
10502 {assembly
10503 = AppendList.appends
10504 [assembly_pre,
10505 assembly_src_dst,
10506 AppendList.single
10507 (Assembly.instruction instruction),
10508 assembly_post],
10509 registerAllocation = registerAllocation}
10510 end
10511 | FLDCW {src}
10512 (* Floating-point load control word; p. 252
10513 * Require src operand as follows:
10514 *
10515 * dst
10516 * reg imm lab add
10517 * X
10518 *)
10519 => let
10520 val {uses,defs,kills}
10521 = Instruction.uses_defs_kills instruction
10522 val {assembly = assembly_pre,
10523 registerAllocation}
10524 = RA.pre {uses = uses,
10525 defs = defs,
10526 kills = kills,
10527 info = info,
10528 registerAllocation = registerAllocation}
10529
10530 val {operand = final_src,
10531 assembly = assembly_src,
10532 registerAllocation}
10533 = RA.allocateOperand {operand = src,
10534 options = {register = false,
10535 immediate = false,
10536 label = false,
10537 address = true},
10538 info = info,
10539 size = Size.WORD,
10540 move = false,
10541 supports = [],
10542 saves = [],
10543 force = [],
10544 registerAllocation
10545 = registerAllocation}
10546
10547 val instruction
10548 = Instruction.FLDCW
10549 {src = final_src}
10550
10551 val {uses = final_uses,
10552 defs = final_defs,
10553 ...}
10554 = Instruction.uses_defs_kills instruction
10555
10556 val {assembly = assembly_post,
10557 registerAllocation}
10558 = RA.post {uses = uses,
10559 final_uses = final_uses,
10560 defs = defs,
10561 final_defs = final_defs,
10562 kills = kills,
10563 info = info,
10564 registerAllocation = registerAllocation}
10565 in
10566 {assembly
10567 = AppendList.appends
10568 [assembly_pre,
10569 assembly_src,
10570 AppendList.single
10571 (Assembly.instruction instruction),
10572 assembly_post],
10573 registerAllocation = registerAllocation}
10574 end
10575 | FSTCW {dst, check}
10576 (* Floating-point store control word; p. 289
10577 * Require dst operand as follows:
10578 *
10579 * dst
10580 * reg imm lab add
10581 * X
10582 *)
10583 => let
10584 val {uses,defs,kills}
10585 = Instruction.uses_defs_kills instruction
10586 val {assembly = assembly_pre,
10587 registerAllocation}
10588 = RA.pre {uses = uses,
10589 defs = defs,
10590 kills = kills,
10591 info = info,
10592 registerAllocation = registerAllocation}
10593
10594 val {operand = final_dst,
10595 assembly = assembly_dst,
10596 registerAllocation}
10597 = RA.allocateOperand {operand = dst,
10598 options = {register = false,
10599 immediate = false,
10600 label = false,
10601 address = true},
10602 info = info,
10603 size = Size.WORD,
10604 move = false,
10605 supports = [],
10606 saves = [],
10607 force = [],
10608 registerAllocation
10609 = registerAllocation}
10610
10611 val instruction
10612 = Instruction.FSTCW
10613 {dst = final_dst,
10614 check = check}
10615
10616 val {uses = final_uses,
10617 defs = final_defs,
10618 ...}
10619 = Instruction.uses_defs_kills instruction
10620
10621 val {assembly = assembly_post,
10622 registerAllocation}
10623 = RA.post {uses = uses,
10624 final_uses = final_uses,
10625 defs = defs,
10626 final_defs = final_defs,
10627 kills = kills,
10628 info = info,
10629 registerAllocation = registerAllocation}
10630 in
10631 {assembly
10632 = AppendList.appends
10633 [assembly_pre,
10634 assembly_dst,
10635 AppendList.single
10636 (Assembly.instruction instruction),
10637 assembly_post],
10638 registerAllocation = registerAllocation}
10639 end
10640 | FSTSW {dst, check}
10641 (* Floating-point store status word; p. 294
10642 * Require dst operand as follows:
10643 *
10644 * dst
10645 * reg imm lab add
10646 * * X
10647 * * only register %ax
10648 *)
10649 => let
10650 val {uses,defs,kills}
10651 = Instruction.uses_defs_kills instruction
10652 val {assembly = assembly_pre,
10653 registerAllocation}
10654 = RA.pre {uses = uses,
10655 defs = defs,
10656 kills = kills,
10657 info = info,
10658 registerAllocation = registerAllocation}
10659
10660 val {operand = final_dst,
10661 assembly = assembly_dst,
10662 registerAllocation}
10663 = RA.allocateOperand {operand = dst,
10664 options = {register = true,
10665 immediate = false,
10666 label = false,
10667 address = false},
10668 info = info,
10669 size = Size.WORD,
10670 move = false,
10671 supports = [],
10672 saves = [],
10673 force = [Register.T
10674 {reg = Register.EAX,
10675 part = Register.X}],
10676 registerAllocation
10677 = registerAllocation}
10678
10679 val instruction
10680 = Instruction.FSTSW
10681 {dst = final_dst,
10682 check = check}
10683
10684 val {uses = final_uses,
10685 defs = final_defs,
10686 ...}
10687 = Instruction.uses_defs_kills instruction
10688
10689 val {assembly = assembly_post,
10690 registerAllocation}
10691 = RA.post {uses = uses,
10692 final_uses = final_uses,
10693 defs = defs,
10694 final_defs = final_defs,
10695 kills = kills,
10696 info = info,
10697 registerAllocation = registerAllocation}
10698 in
10699 {assembly
10700 = AppendList.appends
10701 [assembly_pre,
10702 assembly_dst,
10703 AppendList.single
10704 (Assembly.instruction instruction),
10705 assembly_post],
10706 registerAllocation = registerAllocation}
10707 end
10708 | _ => Error.bug "x86AllocateRegisters.Instruction.allocateRegisters: unimplemented"
10709
10710 val (allocateRegisters, allocateRegisters_msg)
10711 = tracer
10712 "Instruction.allocateRegisters"
10713 allocateRegisters
10714 end
10715
10716 structure Directive =
10717 struct
10718 open Directive
10719
10720 fun allocateRegisters {directive, info, registerAllocation}
10721 = let
10722 val {assembly, registerAllocation}
10723 = case directive
10724 of Assume {assumes}
10725 => RegisterAllocation.assume
10726 {assumes = assumes,
10727 info = info,
10728 registerAllocation = registerAllocation}
10729 | FltAssume {assumes}
10730 => RegisterAllocation.fltassume
10731 {assumes = assumes,
10732 info = info,
10733 registerAllocation = registerAllocation}
10734 | Cache {caches}
10735 => RegisterAllocation.cache
10736 {caches = caches,
10737 info = info,
10738 registerAllocation = registerAllocation}
10739 | FltCache {caches}
10740 => RegisterAllocation.fltcache
10741 {caches = caches,
10742 info = info,
10743 registerAllocation = registerAllocation}
10744 | Reset
10745 => RegisterAllocation.reset
10746 {registerAllocation = registerAllocation}
10747 | Force {commit_memlocs, commit_classes,
10748 remove_memlocs, remove_classes,
10749 dead_memlocs, dead_classes}
10750 => RegisterAllocation.force
10751 {commit_memlocs = commit_memlocs,
10752 commit_classes = commit_classes,
10753 remove_memlocs = remove_memlocs,
10754 remove_classes = remove_classes,
10755 dead_memlocs = dead_memlocs,
10756 dead_classes = dead_classes,
10757 info = info,
10758 registerAllocation = registerAllocation}
10759 | CCall
10760 => RegisterAllocation.ccall
10761 {info = info,
10762 registerAllocation = registerAllocation}
10763 | Return {returns}
10764 => RegisterAllocation.return
10765 {returns = returns,
10766 info = info,
10767 registerAllocation = registerAllocation}
10768 | Reserve {registers}
10769 => RegisterAllocation.reserve
10770 {registers = registers,
10771 registerAllocation = registerAllocation}
10772 | Unreserve {registers}
10773 => RegisterAllocation.unreserve
10774 {registers = registers,
10775 registerAllocation = registerAllocation}
10776 | ClearFlt
10777 => RegisterAllocation.clearflt
10778 {info = info,
10779 registerAllocation = registerAllocation}
10780 | SaveRegAlloc {live, id}
10781 => RegisterAllocation.saveregalloc
10782 {live = live,
10783 id = id,
10784 info = info,
10785 registerAllocation = registerAllocation}
10786 | RestoreRegAlloc {live, id}
10787 => RegisterAllocation.restoreregalloc
10788 {live = live,
10789 id = id,
10790 info = info,
10791 registerAllocation = registerAllocation}
10792 in
10793 {assembly = assembly,
10794 registerAllocation = registerAllocation}
10795 end
10796
10797 val (allocateRegisters, allocateRegisters_msg)
10798 = tracer
10799 "Directive.allocateRegisters"
10800 allocateRegisters
10801 end
10802
10803 structure Assembly =
10804 struct
10805 open Assembly
10806
10807 fun allocateRegisters {assembly: (t * Liveness.t) list,
10808 registerAllocation: RegisterAllocation.t}
10809 = let
10810 val {assembly, registerAllocation}
10811 = List.fold
10812 (assembly,
10813 {assembly = AppendList.empty,
10814 registerAllocation = registerAllocation},
10815 fn ((Comment s,_), {assembly, registerAllocation})
10816 => {assembly = AppendList.snoc
10817 (assembly,
10818 Comment s),
10819 registerAllocation = registerAllocation}
10820 | ((Directive d,info), {assembly, registerAllocation})
10821 => let
10822 val {assembly = assembly',
10823 registerAllocation}
10824 = Directive.allocateRegisters
10825 {directive = d,
10826 info = info,
10827 registerAllocation = registerAllocation}
10828
10829 val assembly''
10830 = AppendList.appends
10831 [if !Control.Native.commented > 1
10832 then AppendList.fromList
10833 [Assembly.comment
10834 (String.make (60, #"*")),
10835 (Assembly.comment
10836 (Directive.toString d))]
10837 else AppendList.empty,
10838 if !Control.Native.commented > 4
10839 then AppendList.fromList
10840 (Liveness.toComments info)
10841 else AppendList.empty,
10842 assembly',
10843 if !Control.Native.commented > 5
10844 then (RegisterAllocation.toComments
10845 registerAllocation)
10846 else AppendList.empty]
10847 in
10848 {assembly = AppendList.append
10849 (assembly,
10850 assembly''),
10851 registerAllocation = registerAllocation}
10852 end
10853 | ((PseudoOp p,_), {assembly, registerAllocation})
10854 => {assembly = AppendList.snoc
10855 (assembly,
10856 PseudoOp p),
10857 registerAllocation = registerAllocation}
10858 | ((Label l,_), {assembly, registerAllocation})
10859 => {assembly = AppendList.snoc
10860 (assembly,
10861 Label l),
10862 registerAllocation = registerAllocation}
10863 | ((Instruction i,info), {assembly, registerAllocation})
10864 => let
10865 val {assembly = assembly',
10866 registerAllocation}
10867 = Instruction.allocateRegisters
10868 {instruction = i,
10869 info = info,
10870 registerAllocation = registerAllocation}
10871
10872 val assembly''
10873 = AppendList.appends
10874 [if !Control.Native.commented > 1
10875 then AppendList.fromList
10876 [Assembly.comment
10877 (String.make (60, #"*")),
10878 (Assembly.comment
10879 (Instruction.toString i))]
10880 else AppendList.empty,
10881 if !Control.Native.commented > 4
10882 then AppendList.fromList
10883 (Liveness.toComments info)
10884 else AppendList.empty,
10885 assembly',
10886 if !Control.Native.commented > 5
10887 then (RegisterAllocation.toComments
10888 registerAllocation)
10889 else AppendList.empty]
10890 in
10891 {assembly = AppendList.append
10892 (assembly,
10893 assembly''),
10894 registerAllocation = registerAllocation}
10895 end)
10896
10897 val assembly = AppendList.toList assembly
10898 val assembly = if !Control.Native.commented > 1
10899 then (Assembly.comment
10900 (String.make (60, #"&"))::
10901 Assembly.comment
10902 (String.make (60, #"&"))::
10903 assembly)
10904 else assembly
10905 in
10906 {assembly = assembly,
10907 registerAllocation = registerAllocation}
10908 end
10909
10910 val (allocateRegisters, allocateRegisters_msg)
10911 = tracer
10912 "Assembly.allocateRegisters"
10913 allocateRegisters
10914 end
10915
10916 fun allocateRegisters {assembly : Assembly.t list list,
10917 liveness : bool} :
10918 Assembly.t list list
10919 = let
10920 val {get = getInfo : Label.t -> Label.t option,
10921 set = setInfo, ...}
10922 = Property.getSetOnce
10923 (Label.plist,
10924 Property.initConst NONE)
10925
10926 fun unroll label
10927 = case getInfo label
10928 of NONE => label
10929 | SOME label' => unroll label'
10930
10931 val assembly
10932 = List.fold
10933 (assembly,
10934 [],
10935 fn (assembly,assembly')
10936 => let
10937 val assembly
10938 = if liveness
10939 then Liveness.toLiveness assembly
10940 else Liveness.toNoLiveness assembly
10941
10942 val {assembly, ...}
10943 = Assembly.allocateRegisters
10944 {assembly = assembly,
10945 registerAllocation
10946 = RegisterAllocation.empty ()}
10947
10948 val rec doit
10949 = fn (Assembly.Comment _)::assembly
10950 => doit assembly
10951 | (Assembly.PseudoOp (PseudoOp.P2align _))::assembly
10952 => doit' (assembly, [])
10953 | _ => false
10954 and doit'
10955 = fn ((Assembly.Comment _)::assembly, labels)
10956 => doit' (assembly, labels)
10957 | ((Assembly.PseudoOp (PseudoOp.Local _))::assembly, labels)
10958 => doit' (assembly, labels)
10959 | ((Assembly.Label l)::assembly, labels)
10960 => doit' (assembly, l::labels)
10961 | (assembly, labels) => doit'' (assembly, labels)
10962 and doit''
10963 = fn ((Assembly.Comment _)::assembly, labels)
10964 => doit'' (assembly, labels)
10965 | ((Assembly.Instruction
10966 (Instruction.JMP
10967 {target = Operand.Label label,
10968 absolute = false}))::assembly, labels)
10969 => doit''' (assembly, labels, label)
10970 | _ => false
10971 and doit'''
10972 = fn ([], labels, label)
10973 => let
10974 val label' = unroll label
10975 in
10976 if List.contains(labels, label', Label.equals)
10977 then false
10978 else (List.foreach
10979 (labels,
10980 fn label'' => setInfo(label'', SOME label'));
10981 true)
10982 end
10983 | ((Assembly.Comment _)::assembly, labels, label)
10984 => doit''' (assembly, labels, label)
10985 | _ => false
10986 in
10987 if doit assembly
10988 then assembly'
10989 else assembly::assembly'
10990 end)
10991
10992 fun replacer _ oper
10993 = (case (Operand.deImmediate oper, Operand.deLabel oper)
10994 of (SOME immediate, _)
10995 => (case Immediate.deLabel immediate
10996 of SOME label => Operand.immediate_label (unroll label)
10997 | NONE => oper)
10998 | (_, SOME label) => Operand.label (unroll label)
10999 | _ => oper)
11000
11001 val assembly
11002 = List.fold
11003 (assembly,
11004 [],
11005 fn (assembly,assembly')
11006 => (List.map(assembly, Assembly.replace replacer))::assembly')
11007 in
11008 assembly
11009 end
11010
11011 val (allocateRegisters, allocateRegisters_msg)
11012 = tracerTop
11013 "allocateRegisters"
11014 allocateRegisters
11015
11016 fun allocateRegisters_totals ()
11017 = (allocateRegisters_msg ();
11018 Control.indent ();
11019 Liveness.toLiveness_msg ();
11020 Liveness.toNoLiveness_msg ();
11021 Assembly.allocateRegisters_msg ();
11022 Control.indent ();
11023 Instruction.allocateRegisters_msg ();
11024 Control.indent ();
11025 RegisterAllocation.pre_msg ();
11026 RegisterAllocation.post_msg ();
11027 RegisterAllocation.allocateOperand_msg ();
11028 RegisterAllocation.allocateFltOperand_msg ();
11029 RegisterAllocation.allocateFltStackOperands_msg ();
11030 Control.unindent ();
11031 Directive.allocateRegisters_msg ();
11032 Control.unindent ();
11033 Control.unindent())
11034 end
mlton packaging