HCoop / hcoop / debian / mlton.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
Import Upstream version 20180207
[hcoop/debian/mlton.git] / mlton / codegen / x86-codegen / x86-simplify.fun
CommitLineData
7f918cf1
CE		 1(* Copyright (C) 1999-2008 Henry Cejtin, Matthew Fluet, Suresh
2 * Jagannathan, and Stephen Weeks.
3 * Copyright (C) 1997-2000 NEC Research Institute.
4 *
5 * MLton is released under a BSD-style license.
6 * See the file MLton-LICENSE for details.
7 *)
8
9functor x86Simplify(S: X86_SIMPLIFY_STRUCTS): X86_SIMPLIFY =
10struct
11
12 open S
13 open x86
14
15 val tracer = x86.tracer
16 val tracerTop = x86.tracerTop
17
18 structure PeepholeBlock =
19 struct
20 structure Peephole
21 = Peephole(type entry_type = Entry.t
22 type profileLabel_type = ProfileLabel.t option
23 type statement_type = Assembly.t
24 type transfer_type = Transfer.t
25 datatype block = datatype Block.t)
26 open Peephole
27
28 fun make_callback_msg name
29 = let
30 val count = ref 0
31 val total = ref 0
32 val callback = fn true => (Int.inc count; Int.inc total)
33 | false => Int.inc total
34 val msg = fn () => Control.messageStr
35 (Control.Detail,
36 concat [name,
37 ": ", Int.toString (!count),
38 " / ", Int.toString (!total)])
39 in
40 (callback,msg)
41 end
42
43 val isComment : statement_type -> bool
44 = fn Assembly.Comment _
45 => true
46 | _ => false
47
48 local
49 val isInstructionMOV : statement_type -> bool
50 = fn Assembly.Instruction (Instruction.MOV _)
51 => true
52 | _ => false
53
54 val isInstructionBinALMD : statement_type -> bool
55 = fn Assembly.Instruction (Instruction.BinAL _)
56 => true
57 | Assembly.Instruction (Instruction.pMD _)
58 => true
59 | Assembly.Instruction (Instruction.IMUL2 _)
60 => true
61 | _ => false
62
63 val template : template
64 = {start = EmptyOrNonEmpty,
65 statements = [One isInstructionMOV,
66 All isComment,
67 One isInstructionBinALMD],
68 finish = EmptyOrNonEmpty,
69 transfer = fn _ => true}
70
71 val rewriter : rewriter
72 = fn {entry,
73 profileLabel,
74 start,
75 statements =
76 [[Assembly.Instruction (Instruction.MOV
77 {src = src1,
78 dst = dst1,
79 size = size1})],
80 comments,
81 [Assembly.Instruction (Instruction.BinAL
82 {oper = oper2,
83 src = src2,
84 dst = dst2,
85 size = size2})]],
86 finish,
87 transfer}
88 => if Size.eq(size1, size2) andalso
89 Operand.eq(dst1, dst2) andalso
90 Operand.eq(src1, src2)
91 then let
92 val statements
93 = (Assembly.instruction_mov
94 {src = src1,
95 dst = dst1,
96 size = size1})::
97 (Assembly.instruction_binal
98 {oper = oper2,
99 src = dst1,
100 dst = dst2,
101 size = size1})::
102 finish
103
104 val statements
105 = List.fold(start,
106 List.concat [comments,
107 statements],
108 op ::)
109 in
110 SOME (Block.T
111 {entry = entry,
112 profileLabel = profileLabel,
113 statements = statements,
114 transfer = transfer})
115 end
116 else NONE
117 | {entry,
118 profileLabel,
119 start,
120 statements =
121 [[Assembly.Instruction (Instruction.MOV
122 {src = src1,
123 dst = dst1,
124 size = size1})],
125 comments,
126 [Assembly.Instruction (Instruction.pMD
127 {oper = oper2,
128 src = src2,
129 dst = dst2,
130 size = size2})]],
131 finish,
132 transfer}
133 => if Size.eq(size1, size2) andalso
134 Operand.eq(dst1, dst2) andalso
135 Operand.eq(src1, src2)
136 then let
137 val statements
138 = (Assembly.instruction_mov
139 {src = src1,
140 dst = dst1,
141 size = size1})::
142 (Assembly.instruction_pmd
143 {oper = oper2,
144 src = dst1,
145 dst = dst2,
146 size = size1})::
147 finish
148
149 val statements
150 = List.fold(start,
151 List.concat [comments,
152 statements],
153 op ::)
154 in
155 SOME (Block.T
156 {entry = entry,
157 profileLabel = profileLabel,
158 statements = statements,
159 transfer = transfer})
160 end
161 else NONE
162 | {entry,
163 profileLabel,
164 start,
165 statements =
166 [[Assembly.Instruction (Instruction.MOV
167 {src = src1,
168 dst = dst1,
169 size = size1})],
170 comments,
171 [Assembly.Instruction (Instruction.IMUL2
172 {src = src2,
173 dst = dst2,
174 size = size2})]],
175 finish,
176 transfer}
177 => if Size.eq(size1, size2) andalso
178 Operand.eq(dst1, dst2) andalso
179 Operand.eq(src1, src2)
180 then let
181 val statements
182 = (Assembly.instruction_mov
183 {src = src1,
184 dst = dst1,
185 size = size1})::
186 (Assembly.instruction_imul2
187 {src = dst1,
188 dst = dst2,
189 size = size1})::
190 finish
191
192 val statements
193 = List.fold(start,
194 List.concat [comments,
195 statements],
196 op ::)
197 in
198 SOME (Block.T
199 {entry = entry,
200 profileLabel = profileLabel,
201 statements = statements,
202 transfer = transfer})
203 end
204 else NONE
205 | _ => Error.bug "x86Simplify.PeepholeBlock: elimBinALMDDouble"
206
207 val (callback,elimBinALMDDouble_msg)
208 = make_callback_msg "elimBinALMDDouble"
209 in
210 val elimBinALMDDouble : optimization
211 = {template = template,
212 rewriter = rewriter,
213 callback = callback}
214 val elimBinALMDDouble_msg = elimBinALMDDouble_msg
215 end
216
217 local
218 val isInstructionFMOV : statement_type -> bool
219 = fn Assembly.Instruction (Instruction.pFMOV _)
220 => true
221 | _ => false
222
223 val isInstructionFBinA : statement_type -> bool
224 = fn Assembly.Instruction (Instruction.pFBinA _)
225 => true
226 | Assembly.Instruction (Instruction.pFBinAS _)
227 => true
228 | Assembly.Instruction (Instruction.pFBinASP _)
229 => true
230 | _ => false
231
232 val template : template
233 = {start = EmptyOrNonEmpty,
234 statements = [One isInstructionFMOV,
235 All isComment,
236 One isInstructionFBinA],
237 finish = EmptyOrNonEmpty,
238 transfer = fn _ => true}
239
240 val rewriter : rewriter
241 = fn {entry,
242 profileLabel,
243 start,
244 statements =
245 [[Assembly.Instruction (Instruction.pFMOV
246 {src = src1,
247 dst = dst1,
248 size = size1})],
249 comments,
250 [Assembly.Instruction (Instruction.pFBinA
251 {oper = oper2,
252 src = src2,
253 dst = dst2,
254 size = size2})]],
255 finish,
256 transfer}
257 => if Size.eq(size1, size2) andalso
258 Operand.eq(dst1, dst2) andalso
259 Operand.eq(src1, src2)
260 then let
261 val statements
262 = (Assembly.instruction_pfmov
263 {src = src1,
264 dst = dst1,
265 size = size1})::
266 (Assembly.instruction_pfbina
267 {oper = oper2,
268 src = dst1,
269 dst = dst2,
270 size = size1})::
271 finish
272
273 val statements
274 = List.fold(start,
275 List.concat [comments,
276 statements],
277 op ::)
278 in
279 SOME (Block.T
280 {entry = entry,
281 profileLabel = profileLabel,
282 statements = statements,
283 transfer = transfer})
284 end
285 else NONE
286 | {entry,
287 profileLabel,
288 start,
289 statements =
290 [[Assembly.Instruction (Instruction.pFMOV
291 {src = src1,
292 dst = dst1,
293 size = size1})],
294 comments,
295 [Assembly.Instruction (Instruction.pFBinAS
296 {oper = oper2,
297 src = src2,
298 dst = dst2,
299 size = size2})]],
300 finish,
301 transfer}
302 => if Size.eq(size1, size2) andalso
303 Operand.eq(dst1, dst2) andalso
304 Operand.eq(src1, src2)
305 then let
306 val statements
307 = (Assembly.instruction_pfmov
308 {src = src1,
309 dst = dst1,
310 size = size1})::
311 (Assembly.instruction_pfbinas
312 {oper = oper2,
313 src = dst1,
314 dst = dst2,
315 size = size1})::
316 finish
317
318 val statements
319 = List.fold(start,
320 List.concat [comments,
321 statements],
322 op ::)
323 in
324 SOME (Block.T
325 {entry = entry,
326 profileLabel = profileLabel,
327 statements = statements,
328 transfer = transfer})
329 end
330 else NONE
331 | {entry,
332 profileLabel,
333 start,
334 statements =
335 [[Assembly.Instruction (Instruction.pFMOV
336 {src = src1,
337 dst = dst1,
338 size = size1})],
339 comments,
340 [Assembly.Instruction (Instruction.pFBinASP
341 {oper = oper2,
342 src = src2,
343 dst = dst2,
344 size = size2})]],
345 finish,
346 transfer}
347 => if Size.eq(size1, size2) andalso
348 Operand.eq(dst1, dst2) andalso
349 Operand.eq(src1, src2)
350 then let
351 val statements
352 = (Assembly.instruction_pfmov
353 {src = src1,
354 dst = dst1,
355 size = size1})::
356 (Assembly.instruction_pfbinasp
357 {oper = oper2,
358 src = dst1,
359 dst = dst2,
360 size = size1})::
361 finish
362
363 val statements
364 = List.fold(start,
365 List.concat [comments,
366 statements],
367 op ::)
368 in
369 SOME (Block.T
370 {entry = entry,
371 profileLabel = profileLabel,
372 statements = statements,
373 transfer = transfer})
374 end
375 else NONE
376 | _ => Error.bug "x86Simplify.PeepholeBlock: elimFltBinADouble"
377
378 val (callback,elimFltBinADouble_msg)
379 = make_callback_msg "elimFltBinADouble"
380 in
381 val elimFltBinADouble : optimization
382 = {template = template,
383 rewriter = rewriter,
384 callback = callback}
385 val elimFltBinADouble_msg = elimFltBinADouble_msg
386 end
387
388 local
389 val isInstructionMOV_srcImmediate : statement_type -> bool
390 = fn Assembly.Instruction (Instruction.MOV
391 {src = Operand.Immediate _,
392 ...})
393 => true
394 | _ => false
395
396 val isInstructionBinALMD_operCommute : statement_type -> bool
397 = fn Assembly.Instruction (Instruction.BinAL
398 {oper, src, dst, ...})
399 => ((oper = Instruction.ADD)
400 orelse
401 (oper = Instruction.ADC)
402 orelse
403 (oper = Instruction.AND)
404 orelse
405 (oper = Instruction.OR)
406 orelse
407 (oper = Instruction.XOR))
408 andalso
409 (case (Operand.deMemloc src,
410 Operand.deMemloc dst)
411 of (SOME src, SOME dst)
412 => not (List.exists
413 (src::(MemLoc.utilized src),
414 fn memloc => MemLoc.mayAlias(memloc, dst)))
415 | _ => true)
416 | Assembly.Instruction (Instruction.pMD
417 {oper, src, dst, ...})
418 => ((oper = Instruction.IMUL)
419 orelse
420 (oper = Instruction.MUL))
421 andalso
422 (case (Operand.deMemloc src,
423 Operand.deMemloc dst)
424 of (SOME src, SOME dst)
425 => not (List.exists
426 (src::(MemLoc.utilized src),
427 fn memloc => MemLoc.mayAlias(memloc, dst)))
428 | _ => true)
429 | Assembly.Instruction (Instruction.IMUL2
430 {src, dst, ...})
431 => (case (Operand.deMemloc src,
432 Operand.deMemloc dst)
433 of (SOME src, SOME dst)
434 => not (List.exists
435 (src::(MemLoc.utilized src),
436 fn memloc => MemLoc.mayAlias(memloc, dst)))
437 | _ => true)
438 | _ => false
439
440 val template : template
441 = {start = EmptyOrNonEmpty,
442 statements = [One isInstructionMOV_srcImmediate,
443 All isComment,
444 One isInstructionBinALMD_operCommute],
445 finish = EmptyOrNonEmpty,
446 transfer = fn _ => true}
447
448 val rewriter : rewriter
449 = fn {entry,
450 profileLabel,
451 start,
452 statements =
453 [[Assembly.Instruction (Instruction.MOV
454 {src = src1,
455 dst = dst1,
456 size = size1})],
457 comments,
458 [Assembly.Instruction (Instruction.BinAL
459 {oper = oper2,
460 src = src2,
461 dst = dst2,
462 size = size2})]],
463 finish,
464 transfer}
465 => if Size.eq(size1, size2) andalso
466 Operand.eq(dst1, dst2)
467 then case (src1, src2)
468 of (Operand.Immediate _, Operand.Immediate _)
469 => NONE
470 | (Operand.Immediate _, _)
471 => let
472 val statements
473 = (Assembly.instruction_mov
474 {src = src2,
475 dst = dst1,
476 size = size1})::
477 (Assembly.instruction_binal
478 {oper = oper2,
479 src = src1,
480 dst = dst2,
481 size = size2})::
482 finish
483
484 val statements
485 = List.fold(start,
486 List.concat [comments,
487 statements],
488 op ::)
489 in
490 SOME (Block.T
491 {entry = entry,
492 profileLabel = profileLabel,
493 statements = statements,
494 transfer = transfer})
495 end
496 | _ => NONE
497 else NONE
498 | {entry,
499 profileLabel,
500 start,
501 statements =
502 [[Assembly.Instruction (Instruction.MOV
503 {src = src1,
504 dst = dst1,
505 size = size1})],
506 comments,
507 [Assembly.Instruction (Instruction.pMD
508 {oper = oper2,
509 src = src2,
510 dst = dst2,
511 size = size2})]],
512 finish,
513 transfer}
514 => if Size.eq(size1, size2) andalso
515 Operand.eq(dst1, dst2)
516 then case (src1, src2)
517 of (Operand.Immediate _, Operand.Immediate _)
518 => NONE
519 | (Operand.Immediate _, _)
520 => let
521 val statements
522 = (Assembly.instruction_mov
523 {src = src2,
524 dst = dst1,
525 size = size1})::
526 (Assembly.instruction_pmd
527 {oper = oper2,
528 src = src1,
529 dst = dst2,
530 size = size2})::
531 finish
532
533 val statements
534 = List.fold(start,
535 List.concat [comments,
536 statements],
537 op ::)
538 in
539 SOME (Block.T
540 {entry = entry,
541 profileLabel = profileLabel,
542 statements = statements,
543 transfer = transfer})
544 end
545 | _ => NONE
546 else NONE
547 | {entry,
548 profileLabel,
549 start,
550 statements =
551 [[Assembly.Instruction (Instruction.MOV
552 {src = src1,
553 dst = dst1,
554 size = size1})],
555 comments,
556 [Assembly.Instruction (Instruction.IMUL2
557 {src = src2,
558 dst = dst2,
559 size = size2})]],
560 finish,
561 transfer}
562 => if Size.eq(size1, size2) andalso
563 Operand.eq(dst1, dst2)
564 then case (src1, src2)
565 of (Operand.Immediate _, Operand.Immediate _)
566 => NONE
567 | (Operand.Immediate _, _)
568 => let
569 val statements
570 = (Assembly.instruction_mov
571 {src = src2,
572 dst = dst1,
573 size = size1})::
574 (Assembly.instruction_imul2
575 {src = src1,
576 dst = dst2,
577 size = size2})::
578 finish
579
580 val statements
581 = List.fold(start,
582 List.concat [comments,
583 statements],
584 op ::)
585 in
586 SOME (Block.T
587 {entry = entry,
588 profileLabel = profileLabel,
589 statements = statements,
590 transfer = transfer})
591 end
592 | _ => NONE
593 else NONE
594 | _ => Error.bug "x86Simplify.PeepholeBlock: commuteBinALMD"
595
596 val (callback,commuteBinALMD_msg)
597 = make_callback_msg "commuteBinALMD"
598 in
599 val commuteBinALMD : optimization
600 = {template = template,
601 rewriter = rewriter,
602 callback = callback}
603 val commuteBinALMD_msg = commuteBinALMD_msg
604 end
605
606 local
607 val getImmediate1
608 = fn Immediate.Word w => if WordX.isOne w
609 then SOME false
610 else if WordX.isNegOne w
611 then SOME true
612 else NONE
613 | _ => NONE
614
615 val isInstructionADDorSUB_srcImmediate1 : statement_type -> bool
616 = fn Assembly.Instruction (Instruction.BinAL
617 {oper,
618 src = Operand.Immediate immediate,
619 ...})
620 => (case oper
621 of Instruction.ADD => true
622 | Instruction.SUB => true
623 | _ => false)
624 andalso
625 isSome (getImmediate1 (Immediate.destruct immediate))
626 | _ => false
627
628 val template : template
629 = {start = EmptyOrNonEmpty,
630 statements = [One isInstructionADDorSUB_srcImmediate1],
631 finish = EmptyOrNonEmpty,
632 transfer = fn _ => true}
633
634 val rewriter : rewriter
635 = fn {entry,
636 profileLabel,
637 start,
638 statements =
639 [[Assembly.Instruction (Instruction.BinAL
640 {oper,
641 src = Operand.Immediate immediate,
642 dst,
643 size})]],
644 finish,
645 transfer}
646 => if (case List.fold
647 (finish, (false, false), fn (asm, (b, b')) =>
648 case asm
649 of Assembly.Comment _ => (b, b')
650 | Assembly.Instruction
651 (Instruction.BinAL
652 {oper = Instruction.ADC, ...})
653 => (true, if b then b' else true)
654 | Assembly.Instruction
655 (Instruction.BinAL
656 {oper = Instruction.SBB, ...})
657 => (true, if b then b' else true)
658 | Assembly.Instruction
659 (Instruction.SETcc
660 {condition = Instruction.C, ...})
661 => (true, if b then b' else true)
662 | Assembly.Instruction
663 (Instruction.SETcc
664 {condition = Instruction.NC, ...})
665 => (true, if b then b' else true)
666 | _ => (true, b'))
667 of (_, true) => true
668 | (false, _) => (case transfer
669 of Transfer.Iff
670 {condition = Instruction.C, ...} => true
671 | Transfer.Iff
672 {condition = Instruction.NC, ...} => true
673 | _ => false)
674 | _ => false)
675 then NONE
676 else let
677 val oper
678 = case (oper, getImmediate1 (Immediate.destruct immediate))
679 of (Instruction.ADD, SOME false) => Instruction.INC
680 | (Instruction.ADD, SOME true ) => Instruction.DEC
681 | (Instruction.SUB, SOME false) => Instruction.DEC
682 | (Instruction.SUB, SOME true ) => Instruction.INC
683 | _ => Error.bug "x86Simplify.PeeholeBlock: elimAddSub1:oper"
684
685 val statements
686 = (Assembly.instruction_unal
687 {oper = oper,
688 dst = dst,
689 size = size})::
690 finish
691
692 val statements
693 = List.fold(start,
694 statements,
695 op ::)
696 in
697 SOME (Block.T
698 {entry = entry,
699 profileLabel = profileLabel,
700 statements = statements,
701 transfer = transfer})
702 end
703 | _ => Error.bug "x86Simplify.PeeholeBlock: elimAddSub1"
704
705 val (callback,elimAddSub1_msg)
706 = make_callback_msg "elimAddSub1"
707 in
708 val elimAddSub1: optimization
709 = {template = template,
710 rewriter = rewriter,
711 callback = callback}
712 val elimAddSub1_msg = elimAddSub1_msg
713 end
714
715 local
716 val rec log2'
717 = fn (w : WordX.t, i : int) =>
718 if WordX.isZero w then NONE
719 else if WordX.isOne (WordX.andb (w, WordX.one (WordX.size w)))
720 then if WordX.isOne w
721 then SOME (i, false)
722 else if WordX.isNegOne w
723 then SOME (i, true)
724 else NONE
725 else log2' (WordX.rshift (w, WordX.one (WordX.size w), {signed = true}), i + 1)
726 fun log2 w = log2' (w, 0 : int)
727 fun divTemp size
728 = MemLoc.imm {base = Immediate.label (Label.fromString "divTemp"),
729 index = Immediate.zero,
730 scale = Scale.Four,
731 size = size,
732 class = MemLoc.Class.Temp}
733
734 val isImmediatePow2
735 = fn Immediate.Word w => isSome (log2 w)
736 | _ => false
737
738 val getImmediateLog2
739 = fn Immediate.Word w => log2 w
740 | _ => NONE
741
742 val isInstructionMULorDIV_srcImmediatePow2 : statement_type -> bool
743 = fn Assembly.Instruction (Instruction.pMD
744 {oper,
745 src = Operand.Immediate immediate,
746 ...})
747 => (case oper
748 of Instruction.IMUL => true
749 | Instruction.MUL => true
750 | Instruction.IDIV => true
751 | Instruction.DIV => true
752 | _ => false)
753 andalso
754 isImmediatePow2 (Immediate.destruct immediate)
755 | Assembly.Instruction (Instruction.IMUL2
756 {src = Operand.Immediate immediate,
757 ...})
758 => isImmediatePow2 (Immediate.destruct immediate)
759 | _ => false
760
761 val template : template
762 = {start = EmptyOrNonEmpty,
763 statements
764 = [One isInstructionMULorDIV_srcImmediatePow2,
765 All isComment],
766 finish = EmptyOrNonEmpty,
767 transfer = fn _ => true}
768
769 val rewriter : rewriter
770 = fn {entry,
771 profileLabel,
772 start,
773 statements =
774 [[Assembly.Instruction (Instruction.pMD
775 {oper = Instruction.IMUL,
776 src = Operand.Immediate immediate,
777 dst,
778 size})],
779 comments],
780 finish = [],
781 transfer as Transfer.Iff {condition,
782 truee,
783 falsee}}
784 => (case getImmediateLog2 (Immediate.destruct immediate)
785 of NONE => Error.bug "x86Simplify.PeeholeBlock: elimMDPow2:getImmediateLog2"
786 | SOME (0,false)
787 => let
788 val transfer
789 = case condition
790 of Instruction.O
791 => Transfer.Goto {target = falsee}
792 | Instruction.NO
793 => Transfer.Goto {target = truee}
794 | _ => Error.bug "x86Simplify.PeeholeBlock: elimMDPow2:transfer"
795
796 val statements
797 = List.fold(start,
798 comments,
799 op ::)
800 in
801 SOME (Block.T
802 {entry = entry,
803 profileLabel = profileLabel,
804 statements = statements,
805 transfer = transfer})
806 end
807 | SOME (0,true)
808 => let
809 val statements
810 = List.fold
811 (start,
812 (Assembly.instruction_unal
813 {oper = Instruction.NEG,
814 dst = dst,
815 size = size})::
816 comments,
817 op ::)
818 in
819 SOME (Block.T
820 {entry = entry,
821 profileLabel = profileLabel,
822 statements = statements,
823 transfer = transfer})
824 end
825 | SOME (1,b)
826 => let
827 val statements
828 = List.fold
829 (start,
830 (fn l
831 => if b
832 then (Assembly.instruction_unal
833 {oper = Instruction.NEG,
834 dst = dst,
835 size = size})::
836 l
837 else l)
838 ((Assembly.instruction_binal
839 {oper = Instruction.ADD,
840 src = dst,
841 dst = dst,
842 size = size})::
843 comments),
844 op ::)
845 in
846 SOME (Block.T
847 {entry = entry,
848 profileLabel = profileLabel,
849 statements = statements,
850 transfer = transfer})
851 end
852 | _ => NONE)
853 | {entry,
854 profileLabel,
855 start,
856 statements =
857 [[Assembly.Instruction (Instruction.pMD
858 {oper = Instruction.IMUL,
859 src = Operand.Immediate immediate,
860 dst,
861 size})],
862 comments],
863 finish,
864 transfer}
865 => (case getImmediateLog2 (Immediate.destruct immediate)
866 of NONE => Error.bug "x86Simplify.PeeholeBlock: elimMDPow2:getImmediateLog2"
867 | SOME (0,false)
868 => SOME (Block.T
869 {entry = entry,
870 profileLabel = profileLabel,
871 statements = List.fold(start,
872 List.concat [comments, finish],
873 op ::),
874 transfer = transfer})
875 | SOME (0,true)
876 => let
877 val statements
878 = (Assembly.instruction_unal
879 {oper = Instruction.NEG,
880 dst = dst,
881 size = size})::
882 (List.concat [comments, finish])
883
884 val statements
885 = List.fold(start,
886 statements,
887 op ::)
888 in
889 SOME (Block.T
890 {entry = entry,
891 profileLabel = profileLabel,
892 statements = statements,
893 transfer = transfer})
894 end
895 | SOME (1,b)
896 => let
897 val statements
898 = List.fold
899 (start,
900 (fn l
901 => if b
902 then (Assembly.instruction_unal
903 {oper = Instruction.NEG,
904 dst = dst,
905 size = size})::
906 l
907 else l)
908 ((Assembly.instruction_binal
909 {oper = Instruction.ADD,
910 src = dst,
911 dst = dst,
912 size = size})::
913 (List.concat [comments, finish])),
914 op ::)
915 in
916 SOME (Block.T
917 {entry = entry,
918 profileLabel = profileLabel,
919 statements = statements,
920 transfer = transfer})
921 end
922 | SOME (i,b)
923 => if i < (8 * Size.toBytes size)
924 then let
925 val statements
926 = (fn l
927 => (Assembly.instruction_sral
928 {oper = Instruction.SAL,
929 count = Operand.immediate_int i,
930 dst = dst,
931 size = size})::
932 (if b
933 then (Assembly.instruction_unal
934 {oper = Instruction.NEG,
935 dst = dst,
936 size = size})::
937 l
938 else l))
939 (List.concat [comments, finish])
940
941 val statements
942 = List.fold(start,
943 statements,
944 op ::)
945 in
946 SOME (Block.T
947 {entry = entry,
948 profileLabel = profileLabel,
949 statements = statements,
950 transfer = transfer})
951 end
952 else NONE)
953 | {entry,
954 profileLabel,
955 start,
956 statements =
957 [[Assembly.Instruction (Instruction.pMD
958 {oper = Instruction.MUL,
959 src = Operand.Immediate immediate,
960 dst,
961 size})],
962 comments],
963 finish,
964 transfer}
965 => (case getImmediateLog2 (Immediate.destruct immediate)
966 of NONE => Error.bug "x86Simplify.PeeholeBlock: elimMDPow2:getImmediateLog2"
967 | SOME (0,false)
968 => SOME (Block.T
969 {entry = entry,
970 profileLabel = profileLabel,
971 statements = List.fold(start,
972 List.concat [comments, finish],
973 op ::),
974 transfer = transfer})
975 | SOME (i,false)
976 => if i < (8 * Size.toBytes size)
977 then let
978 val statements
979 = (Assembly.instruction_sral
980 {oper = Instruction.SAL,
981 count = Operand.immediate_int i,
982 dst = dst,
983 size = size})::
984 (List.concat [comments, finish])
985
986 val statements
987 = List.fold(start,
988 statements,
989 op ::)
990 in
991 SOME (Block.T
992 {entry = entry,
993 profileLabel = profileLabel,
994 statements = statements,
995 transfer = transfer})
996 end
997 else NONE
998 | SOME (_,true)
999 => NONE)
1000 | {entry,
1001 profileLabel,
1002 start,
1003 statements =
1004 [[Assembly.Instruction (Instruction.pMD
1005 {oper = Instruction.IDIV,
1006 src = Operand.Immediate immediate,
1007 dst,
1008 size})],
1009 comments],
1010 finish,
1011 transfer}
1012 => (case getImmediateLog2 (Immediate.destruct immediate)
1013 of NONE => Error.bug "x86Simplify.PeeholeBlock: elimMDPow2:getImmediateLog2"
1014 | SOME (0,false)
1015 => SOME (Block.T
1016 {entry = entry,
1017 profileLabel = profileLabel,
1018 statements = List.fold(start,
1019 List.concat [comments, finish],
1020 op ::),
1021 transfer = transfer})
1022 | SOME (0,true)
1023 => let
1024 val statements
1025 = (Assembly.instruction_unal
1026 {oper = Instruction.NEG,
1027 dst = dst,
1028 size = size})::
1029 (List.concat [comments, finish])
1030
1031 val statements
1032 = List.fold(start,
1033 statements,
1034 op ::)
1035 in
1036 SOME (Block.T
1037 {entry = entry,
1038 profileLabel = profileLabel,
1039 statements = statements,
1040 transfer = transfer})
1041 end
1042 | SOME (i,b)
1043 => if i < (8 * Size.toBytes size)
1044 then let
1045 val divTemp = Operand.MemLoc (divTemp size)
1046 val width = 8 * Size.toBytes size
1047
1048 val statements
1049 = ((fn l
1050 => (Assembly.instruction_mov
1051 {src = dst,
1052 dst = divTemp,
1053 size = size})::
1054 l) o
1055 (fn l
1056 => if i > 1
1057 then (Assembly.instruction_sral
1058 {oper = Instruction.SAR,
1059 dst = divTemp,
1060 count
1061 = Operand.immediate_int
1062 (i - 1),
1063 size = size})::
1064 l
1065 else l) o
1066 (fn l
1067 => if i < width
1068 then (Assembly.instruction_sral
1069 {oper = Instruction.SHR,
1070 dst = divTemp,
1071 count
1072 = Operand.immediate_int
1073 (width - i),
1074 size = size})::
1075 l
1076 else l) o
1077 (fn l
1078 => (Assembly.instruction_binal
1079 {oper = Instruction.ADD,
1080 src = divTemp,
1081 dst = dst,
1082 size = size})::
1083 (Assembly.instruction_sral
1084 {oper = Instruction.SAR,
1085 count = Operand.immediate_int i,
1086 dst = dst,
1087 size = size})::
1088 l) o
1089 (fn l
1090 => if b
1091 then (Assembly.instruction_unal
1092 {oper = Instruction.NEG,
1093 dst = dst,
1094 size = size})::
1095 l
1096 else l))
1097 (List.concat [comments, finish])
1098
1099 val statements
1100 = List.fold(start,
1101 statements,
1102 op ::)
1103 in
1104 SOME (Block.T
1105 {entry = entry,
1106 profileLabel = profileLabel,
1107 statements = statements,
1108 transfer = transfer})
1109 end
1110 else NONE)
1111 | {entry,
1112 profileLabel,
1113 start,
1114 statements =
1115 [[Assembly.Instruction (Instruction.pMD
1116 {oper = Instruction.DIV,
1117 src = Operand.Immediate immediate,
1118 dst,
1119 size})],
1120 comments],
1121 finish,
1122 transfer}
1123 => (case getImmediateLog2 (Immediate.destruct immediate)
1124 of NONE => Error.bug "x86Simplify.PeeholeBlock: elimMDPow2:getImmediateLog2"
1125 | SOME (0,false)
1126 => SOME (Block.T
1127 {entry = entry,
1128 profileLabel = profileLabel,
1129 statements = List.fold(start,
1130 List.concat [comments, finish],
1131 op ::),
1132 transfer = transfer})
1133 | SOME (i,false)
1134 => if i < (8 * Size.toBytes size)
1135 then let
1136 val statements
1137 = (Assembly.instruction_sral
1138 {oper = Instruction.SHR,
1139 count = Operand.immediate_int i,
1140 dst = dst,
1141 size = size})::
1142 (List.concat [comments, finish])
1143
1144 val statements
1145 = List.fold(start,
1146 statements,
1147 op ::)
1148 in
1149 SOME (Block.T
1150 {entry = entry,
1151 profileLabel = profileLabel,
1152 statements = statements,
1153 transfer = transfer})
1154 end
1155 else NONE
1156 | SOME (_,true) => NONE)
1157 | {entry,
1158 profileLabel,
1159 start,
1160 statements =
1161 [[Assembly.Instruction (Instruction.IMUL2
1162 {src = Operand.Immediate immediate,
1163 dst,
1164 size})],
1165 comments],
1166 finish = [],
1167 transfer as Transfer.Iff {condition,
1168 truee,
1169 falsee}}
1170 => (case getImmediateLog2 (Immediate.destruct immediate)
1171 of NONE => Error.bug "x86Simplify.PeeholeBlock: elimMDPow2:getImmediateLog2"
1172 | SOME (0,false)
1173 => let
1174 val transfer
1175 = case condition
1176 of Instruction.O
1177 => Transfer.Goto {target = falsee}
1178 | Instruction.NO
1179 => Transfer.Goto {target = truee}
1180 | _ => Error.bug "x86Simplify.PeeholeBlock: elimMDPow2:transfer"
1181
1182 val statements
1183 = List.fold(start,
1184 comments,
1185 op ::)
1186 in
1187 SOME (Block.T
1188 {entry = entry,
1189 profileLabel = profileLabel,
1190 statements = statements,
1191 transfer = transfer})
1192 end
1193 | SOME (0,true)
1194 => let
1195 val statements
1196 = List.fold
1197 (start,
1198 (Assembly.instruction_unal
1199 {oper = Instruction.NEG,
1200 dst = dst,
1201 size = size})::
1202 comments,
1203 op ::)
1204 in
1205 SOME (Block.T
1206 {entry = entry,
1207 profileLabel = profileLabel,
1208 statements = statements,
1209 transfer = transfer})
1210 end
1211 | SOME (1,b)
1212 => let
1213 val statements
1214 = List.fold
1215 (start,
1216 (fn l
1217 => if b
1218 then (Assembly.instruction_unal
1219 {oper = Instruction.NEG,
1220 dst = dst,
1221 size = size})::
1222 l
1223 else l)
1224 ((Assembly.instruction_binal
1225 {oper = Instruction.ADD,
1226 src = dst,
1227 dst = dst,
1228 size = size})::
1229 comments),
1230 op ::)
1231 in
1232 SOME (Block.T
1233 {entry = entry,
1234 profileLabel = profileLabel,
1235 statements = statements,
1236 transfer = transfer})
1237 end
1238 | _ => NONE)
1239 | {entry,
1240 profileLabel,
1241 start,
1242 statements =
1243 [[Assembly.Instruction (Instruction.IMUL2
1244 {src = Operand.Immediate immediate,
1245 dst,
1246 size})],
1247 comments],
1248 finish,
1249 transfer}
1250 => (case getImmediateLog2 (Immediate.destruct immediate)
1251 of NONE => Error.bug "x86Simplify.PeeholeBlock: elimMDPow2:getImmediateLog2"
1252 | SOME (0,false)
1253 => SOME (Block.T
1254 {entry = entry,
1255 profileLabel = profileLabel,
1256 statements = List.fold(start,
1257 List.concat [comments, finish],
1258 op ::),
1259 transfer = transfer})
1260 | SOME (0,true)
1261 => let
1262 val statements
1263 = (Assembly.instruction_unal
1264 {oper = Instruction.NEG,
1265 dst = dst,
1266 size = size})::
1267 (List.concat [comments, finish])
1268
1269 val statements
1270 = List.fold(start,
1271 statements,
1272 op ::)
1273 in
1274 SOME (Block.T
1275 {entry = entry,
1276 profileLabel = profileLabel,
1277 statements = statements,
1278 transfer = transfer})
1279 end
1280 | SOME (1,b)
1281 => let
1282 val statements
1283 = List.fold
1284 (start,
1285 (fn l
1286 => if b
1287 then (Assembly.instruction_unal
1288 {oper = Instruction.NEG,
1289 dst = dst,
1290 size = size})::
1291 l
1292 else l)
1293 ((Assembly.instruction_binal
1294 {oper = Instruction.ADD,
1295 src = dst,
1296 dst = dst,
1297 size = size})::
1298 (List.concat [comments, finish])),
1299 op ::)
1300 in
1301 SOME (Block.T
1302 {entry = entry,
1303 profileLabel = profileLabel,
1304 statements = statements,
1305 transfer = transfer})
1306 end
1307 | SOME (i,b)
1308 => if i < (8 * Size.toBytes size)
1309 then let
1310 val statements
1311 = (fn l
1312 => (Assembly.instruction_sral
1313 {oper = Instruction.SAL,
1314 count = Operand.immediate_int i,
1315 dst = dst,
1316 size = size})::
1317 (if b
1318 then (Assembly.instruction_unal
1319 {oper = Instruction.NEG,
1320 dst = dst,
1321 size = size})::
1322 l
1323 else l))
1324 (List.concat [comments, finish])
1325
1326 val statements
1327 = List.fold(start,
1328 statements,
1329 op ::)
1330 in
1331 SOME (Block.T
1332 {entry = entry,
1333 profileLabel = profileLabel,
1334 statements = statements,
1335 transfer = transfer})
1336 end
1337 else NONE)
1338 | _ => Error.bug "x86Simplify.PeeholeBlock: elimMDPow2"
1339
1340 val (callback,elimMDPow2_msg)
1341 = make_callback_msg "elimMDPow2"
1342 in
1343 val elimMDPow2 : optimization
1344 = {template = template,
1345 rewriter = rewriter,
1346 callback = callback}
1347 val elimMDPow2_msg = elimMDPow2_msg
1348 end
1349
1350 local
1351 val isInstructionCMPorTEST : statement_type -> bool
1352 = fn Assembly.Instruction (Instruction.CMP _)
1353 => true
1354 | Assembly.Instruction (Instruction.TEST _)
1355 => true
1356 | _ => false
1357
1358 val isInstructionMOV : statement_type -> bool
1359 = fn Assembly.Instruction (Instruction.MOV _)
1360 => true
1361 | _ => false
1362
1363 val isInstructionSETcc : statement_type -> bool
1364 = fn Assembly.Instruction (Instruction.SETcc _)
1365 => true
1366 | _ => false
1367
1368 val isInstruction : statement_type -> bool
1369 = fn Assembly.Instruction _
1370 => true
1371 | _ => false
1372
1373 val isTransfer_Iff : transfer_type -> bool
1374 = fn Transfer.Iff _
1375 => true
1376 | _ => false
1377
1378 val template
1379 = {start = EmptyOrNonEmpty,
1380 statements = [One isInstructionCMPorTEST,
1381 All isComment],
1382 finish = EmptyOrNonEmpty,
1383 transfer = fn _ => true}
1384
1385 val rewriter
1386 = fn {entry,
1387 profileLabel,
1388 start,
1389 statements =
1390 [[Assembly.Instruction _],
1391 comments],
1392 finish,
1393 transfer}
1394 => let
1395 val rec scan
1396 = fn [] => not (isTransfer_Iff transfer)
1397 | asm::statements
1398 => if isComment asm
1399 orelse
1400 isInstructionMOV asm
1401 then scan statements
1402 else if isInstructionSETcc asm
1403 then false
1404 else if isInstruction asm
1405 then true
1406 else false
1407 in
1408 if scan finish
1409 then let
1410 val statements
1411 = List.fold(start,
1412 List.concat [comments, finish],
1413 op ::)
1414 in
1415 SOME (Block.T {entry = entry,
1416 profileLabel = profileLabel,
1417 statements = statements,
1418 transfer = transfer})
1419 end
1420 else NONE
1421 end
1422 | _ => Error.bug "x86Simplify.PeeholeBlock: elimCMPTEST"
1423
1424 val (callback,elimCMPTEST_msg)
1425 = make_callback_msg "elimCMPTEST"
1426 in
1427 val elimCMPTEST : optimization
1428 = {template = template,
1429 rewriter = rewriter,
1430 callback = callback}
1431 val elimCMPTEST_msg = elimCMPTEST_msg
1432 end
1433
1434 local
1435 val isInstructionCMP_srcImmediate0
1436 = fn Assembly.Instruction (Instruction.CMP
1437 {src1 = Operand.Immediate immediate,
1438 ...})
1439 => Immediate.isZero immediate
1440 | Assembly.Instruction (Instruction.CMP
1441 {src2 = Operand.Immediate immediate,
1442 ...})
1443 => Immediate.isZero immediate
1444 | _ => false
1445
1446 val isTransfer_Iff_E_NE
1447 = fn Transfer.Iff {condition, ...}
1448 => condition = Instruction.E
1449 orelse
1450 condition = Instruction.NE
1451 | _ => false
1452
1453 val template
1454 = {start = EmptyOrNonEmpty,
1455 statements = [One isInstructionCMP_srcImmediate0,
1456 All isComment],
1457 finish = Empty,
1458 transfer = isTransfer_Iff_E_NE}
1459
1460 val rewriter
1461 = fn {entry,
1462 profileLabel,
1463 start,
1464 statements =
1465 [[Assembly.Instruction
1466 (Instruction.CMP {src1, src2, size})],
1467 comments],
1468 finish = [],
1469 transfer = Transfer.Iff {condition, truee, falsee}}
1470 => let
1471 val condition
1472 = case condition
1473 of Instruction.E => Instruction.Z
1474 | Instruction.NE => Instruction.NZ
1475 | _ => Error.bug "x86Simplify.PeeholeBlock: elimCMP0:condition"
1476
1477 val src
1478 = case (Operand.deImmediate src1,
1479 Operand.deImmediate src2)
1480 of (SOME _, NONE) => src2
1481 | (NONE, SOME _) => src1
1482 | (SOME immediate1, SOME _)
1483 => if Immediate.isZero immediate1
1484 then src2
1485 else src1
1486 | _ => Error.bug "x86Simplify.PeeholeBlock: elimCMP0:src"
1487
1488 val statements
1489 = List.fold(start,
1490 (Assembly.instruction_test
1491 {src1 = src,
1492 src2 = src,
1493 size = size})::
1494 comments,
1495 op ::)
1496
1497 val transfer
1498 = Transfer.Iff {condition = condition,
1499 truee = truee,
1500 falsee = falsee}
1501 in
1502 SOME (Block.T {entry = entry,
1503 profileLabel = profileLabel,
1504 statements = statements,
1505 transfer = transfer})
1506 end
1507 | _ => Error.bug "x86Simplify.PeeholeBlock: elimCMP0"
1508
1509 val (callback,elimCMP0_msg)
1510 = make_callback_msg "elimCMP0"
1511 in
1512 val elimCMP0 : optimization
1513 = {template = template,
1514 rewriter = rewriter,
1515 callback = callback}
1516 val elimCMP0_msg = elimCMP0_msg
1517 end
1518
1519 local
1520 val isInstructionAL_setZF
1521 = fn Assembly.Instruction (Instruction.BinAL _)
1522 => true
1523 | Assembly.Instruction (Instruction.UnAL {oper, ...})
1524 => (case oper
1525 of Instruction.NOT => false
1526 | _ => true)
1527 | Assembly.Instruction (Instruction.SRAL {oper, ...})
1528 => (case oper
1529 of Instruction.ROL => false
1530 | Instruction.RCL => false
1531 | Instruction.ROR => false
1532 | Instruction.RCR => false
1533 | _ => true)
1534 | _ => false
1535
1536 val isInstructionTEST_eqSrcs
1537 = fn Assembly.Instruction (Instruction.TEST {src1, src2, ...})
1538 => Operand.eq(src1, src2)
1539 | _ => false
1540
1541 val isTransfer_Iff_Z_NZ
1542 = fn Transfer.Iff {condition, ...}
1543 => condition = Instruction.Z
1544 orelse
1545 condition = Instruction.NZ
1546 | _ => false
1547
1548 val template
1549 = {start = EmptyOrNonEmpty,
1550 statements = [One isInstructionAL_setZF,
1551 All isComment,
1552 One isInstructionTEST_eqSrcs,
1553 All isComment],
1554 finish = Empty,
1555 transfer = isTransfer_Iff_Z_NZ}
1556
1557 val rewriter
1558 = fn {entry,
1559 profileLabel,
1560 start,
1561 statements =
1562 [[Assembly.Instruction instruction],
1563 comments1,
1564 [Assembly.Instruction
1565 (Instruction.TEST {src1, ...})],
1566 comments2],
1567 finish = [],
1568 transfer as Transfer.Iff {...}}
1569 => let
1570 val dst
1571 = case instruction
1572 of Instruction.BinAL {dst, ...} => dst
1573 | Instruction.UnAL {dst, ...} => dst
1574 | Instruction.SRAL {dst, ...} => dst
1575 | _ => Error.bug "x86Simplify.PeeholeBlock: elimALTEST:dst"
1576 in
1577 if Operand.eq(dst,src1)
1578 then let
1579 val statements
1580 = List.fold
1581 (start,
1582 (Assembly.instruction instruction)::
1583 (List.concat [comments1, comments2]),
1584 op ::)
1585 in
1586 SOME (Block.T {entry = entry,
1587 profileLabel = profileLabel,
1588 statements = statements,
1589 transfer = transfer})
1590 end
1591 else NONE
1592 end
1593 | _ => Error.bug "x86Simplify.PeeholeBlock: elimALTEST"
1594
1595 val (callback,elimALTEST_msg)
1596 = make_callback_msg "elimALTEST"
1597 in
1598 val elimALTEST : optimization
1599 = {template = template,
1600 rewriter = rewriter,
1601 callback = callback}
1602 val elimALTEST_msg = elimALTEST_msg
1603 end
1604
1605 local
1606 val optimizations_pre
1607 = commuteBinALMD::
1608(* elimBinAL0L:: *)
1609(* elimBinAL0R:: *)
1610 elimAddSub1::
1611 elimMDPow2::
1612 elimCMPTEST::
1613 nil
1614 val optimizations_pre_msg
1615 = commuteBinALMD_msg::
1616(* elimBinAL0L_msg:: *)
1617(* elimBinAL0R_msg:: *)
1618 elimAddSub1_msg::
1619 elimMDPow2_msg::
1620 nil
1621
1622 val optimizations_post
1623 = elimBinALMDDouble::
1624 elimFltBinADouble::
1625 elimCMPTEST::
1626 elimCMP0::
1627 elimALTEST::
1628 nil
1629 val optimizations_post_msg
1630 = elimBinALMDDouble_msg::
1631 elimFltBinADouble_msg::
1632 elimCMPTEST_msg::
1633 elimCMP0_msg::
1634 elimALTEST_msg::
1635 nil
1636 in
1637 val peepholeBlock_pre
1638 = fn block => (peepholeBlock {optimizations = optimizations_pre,
1639 block = block})
1640 val (peepholeBlock_pre, peepholeBlock_pre_msg)
1641 = tracer
1642 "peepholeBlock_pre"
1643 peepholeBlock_pre
1644
1645 val peepholeBlock_pre_msg
1646 = fn () => (peepholeBlock_pre_msg ();
1647 Control.indent ();
1648 List.foreach(optimizations_pre_msg, fn msg => msg ());
1649 Control.unindent ())
1650
1651 val peepholeBlock_post
1652 = fn block => (peepholeBlock {optimizations = optimizations_post,
1653 block = block})
1654 val (peepholeBlock_post, peepholeBlock_post_msg)
1655 = tracer
1656 "peepholeBlock_post"
1657 peepholeBlock_post
1658
1659 val peepholeBlock_post_msg
1660 = fn () => (peepholeBlock_post_msg ();
1661 Control.indent ();
1662 List.foreach(optimizations_post_msg, fn msg => msg ());
1663 Control.unindent ())
1664 end
1665
1666 val (callback_elimIff,elimIff_msg)
1667 = make_callback_msg "elimIff"
1668 fun makeElimIff {jumpInfo : x86JumpInfo.t} :
1669 optimization
1670 = let
1671 val isTransferIff_eqTargets
1672 = fn Transfer.Iff {truee, falsee, ...}
1673 => Label.equals(truee, falsee)
1674 | _ => false
1675
1676 val template
1677 = {start = EmptyOrNonEmpty,
1678 statements = [],
1679 finish = Empty,
1680 transfer = isTransferIff_eqTargets}
1681
1682 val rewriter
1683 = fn {entry,
1684 profileLabel,
1685 start,
1686 statements = [],
1687 finish = [],
1688 transfer = Transfer.Iff {truee, falsee, ...}}
1689 => let
1690 val _ = x86JumpInfo.decNear(jumpInfo, falsee)
1691
1692 val statements
1693 = List.fold(start,
1694 [],
1695 op ::)
1696
1697 val transfer = Transfer.goto {target = truee}
1698 in
1699 SOME (Block.T {entry = entry,
1700 profileLabel = profileLabel,
1701 statements = statements,
1702 transfer = transfer})
1703 end
1704 | _ => Error.bug "x86Simplify.PeeholeBlock: elimIff"
1705 in
1706 {template = template,
1707 rewriter = rewriter,
1708 callback = callback_elimIff}
1709 end
1710
1711 val (callback_elimSwitchTest,elimSwitchTest_msg)
1712 = make_callback_msg "elimSwitchTest"
1713 fun makeElimSwitchTest {jumpInfo : x86JumpInfo.t} :
1714 optimization
1715 = let
1716 val isTransferSwitch_testImmediateEval
1717 = fn Transfer.Switch {test = Operand.Immediate immediate, ...}
1718 => isSome (Immediate.eval immediate)
1719 | _ => false
1720
1721 val template
1722 = {start = Empty,
1723 statements = [All (fn _ => true)],
1724 finish = Empty,
1725 transfer = isTransferSwitch_testImmediateEval}
1726
1727 val rewriter
1728 = fn {entry,
1729 profileLabel,
1730 start = [],
1731 statements = [statements'],
1732 finish = [],
1733 transfer =
1734 Transfer.Switch {test = Operand.Immediate immediate,
1735 cases,
1736 default}}
1737 => let
1738 val statements = statements'
1739 val test = valOf (Immediate.eval immediate)
1740 val cases
1741 = Transfer.Cases.keepAll
1742 (cases,
1743 fn (w,target)
1744 => (x86JumpInfo.decNear(jumpInfo, target);
1745 WordX.equals (w, test)))
1746
1747 val transfer
1748 = if Transfer.Cases.isEmpty cases
1749 then Transfer.goto {target = default}
1750 else if Transfer.Cases.isSingle cases
1751 then let
1752 val _ = x86JumpInfo.decNear
1753 (jumpInfo, default)
1754
1755 val target
1756 = Transfer.Cases.extract
1757 (cases, #2)
1758 val _ = x86JumpInfo.incNear
1759 (jumpInfo, target)
1760 in
1761 Transfer.goto {target = target}
1762 end
1763 else Error.bug "x86Simplify.PeeholeBlock: elimSwitchTest:transfer"
1764 in
1765 SOME (Block.T {entry = entry,
1766 profileLabel = profileLabel,
1767 statements = statements,
1768 transfer = transfer})
1769 end
1770 | _ => Error.bug "x86Simplify.PeeholeBlock: elimSwitchTest"
1771 in
1772 {template = template,
1773 rewriter = rewriter,
1774 callback = callback_elimSwitchTest}
1775 end
1776
1777 val (callback_elimSwitchCases,elimSwitchCases_msg)
1778 = make_callback_msg "elimSwitchCases"
1779 fun makeElimSwitchCases {jumpInfo : x86JumpInfo.t} :
1780 optimization
1781 = let
1782 val isTransferSwitch_casesDefault
1783 = fn Transfer.Switch {cases, default, ...}
1784 => let
1785 val n = Transfer.Cases.count
1786 (cases,
1787 fn target => Label.equals(target, default))
1788 in
1789 n > 0
1790 end
1791 | _ => false
1792
1793 val template
1794 = {start = Empty,
1795 statements = [All (fn _ => true)],
1796 finish = Empty,
1797 transfer = isTransferSwitch_casesDefault}
1798
1799 val rewriter
1800 = fn {entry,
1801 profileLabel,
1802 start = [],
1803 statements = [statements'],
1804 finish = [],
1805 transfer = Transfer.Switch {test, cases, default}}
1806 => let
1807 val statements = statements'
1808 val cases
1809 = Transfer.Cases.keepAll
1810 (cases,
1811 fn (_,target) => if Label.equals(target, default)
1812 then (x86JumpInfo.decNear
1813 (jumpInfo, target);
1814 false)
1815 else true)
1816
1817 val (statements, transfer)
1818 = if Transfer.Cases.isEmpty cases
1819 then (statements,
1820 Transfer.goto {target = default})
1821 else if Transfer.Cases.isSingle cases
1822 then let
1823 val (k,target)
1824 = Transfer.Cases.extract
1825 (cases,
1826 fn (w,target) =>
1827 (Immediate.word w, target))
1828 val size
1829 = case Operand.size test
1830 of SOME size => size
1831 | NONE => Size.LONG
1832 in
1833 (List.concat
1834 [statements,
1835 [Assembly.instruction_cmp
1836 {src1 = test,
1837 src2 = Operand.immediate k,
1838 size = size}]],
1839 Transfer.iff {condition = Instruction.E,
1840 truee = target,
1841 falsee = default})
1842 end
1843 else (statements,
1844 Transfer.switch {test = test,
1845 cases = cases,
1846 default = default})
1847 in
1848 SOME (Block.T {entry = entry,
1849 profileLabel = profileLabel,
1850 statements = statements,
1851 transfer = transfer})
1852 end
1853 | _ => Error.bug "x86Simplify.PeeholeBlock: elimSwitchCases"
1854 in
1855 {template = template,
1856 rewriter = rewriter,
1857 callback = callback_elimSwitchCases}
1858 end
1859 end
1860
1861 structure ElimGoto =
1862 struct
1863 fun elimSimpleGoto {chunk = Chunk.T {data, blocks, ...},
1864 delProfileLabel : x86.ProfileLabel.t -> unit,
1865 jumpInfo : x86JumpInfo.t}
1866 = let
1867 val {get: Label.t -> Label.t option,
1868 set: Label.t * Label.t option -> unit,
1869 destroy}
1870 = Property.destGetSet(Label.plist, Property.initConst NONE)
1871 val changed = ref false
1872
1873 val labels
1874 = List.keepAllMap
1875 (blocks,
1876 fn Block.T {entry = Entry.Jump {label},
1877 profileLabel,
1878 statements,
1879 transfer = Transfer.Goto {target}}
1880 => if List.forall(statements,
1881 fn Assembly.Comment _ => true
1882 | _ => false)
1883(*
1884 andalso
1885 not (Label.equals(label, target))
1886*)
1887 then (Option.app(profileLabel, delProfileLabel);
1888 set(label, SOME target);
1889 SOME label)
1890 else NONE
1891 | _ => NONE)
1892
1893 fun loop ()
1894 = if List.fold(labels,
1895 false,
1896 fn (label,b)
1897 => case get label
1898 of NONE => b
1899 | SOME target
1900 => (case get target
1901 of NONE => b
1902 | SOME target'
1903 => if Label.equals(label, target')
1904 then (set(label, NONE);
1905 b)
1906 else (set(label, SOME target');
1907 true)))
1908 then loop ()
1909 else ()
1910
1911 val _ = loop ()
1912
1913 fun update target
1914 = case get target
1915 of SOME target'
1916 => (changed := true;
1917 x86JumpInfo.decNear(jumpInfo, target);
1918 x86JumpInfo.incNear(jumpInfo, target');
1919 target')
1920 | NONE => target
1921
1922 val elimSimpleGoto'
1923 = fn Transfer.Goto {target}
1924 => Transfer.Goto {target = update target}
1925 | Transfer.Iff {condition, truee, falsee}
1926 => Transfer.Iff {condition = condition,
1927 truee = update truee,
1928 falsee = update falsee}
1929 | Transfer.Switch {test, cases, default}
1930 => Transfer.Switch {test = test,
1931 cases = Transfer.Cases.map
1932 (cases, update o #2),
1933 default = update default}
1934 | transfer => transfer
1935
1936 val blocks
1937 = List.map
1938 (blocks,
1939 fn Block.T {entry, profileLabel, statements, transfer}
1940 => Block.T {entry = entry,
1941 profileLabel = profileLabel,
1942 statements = statements,
1943 transfer = elimSimpleGoto' transfer})
1944
1945 val blocks
1946 = List.removeAll
1947 (blocks,
1948 fn Block.T {entry,...}
1949 => (case get (Entry.label entry)
1950 of SOME label' => (changed := true;
1951 x86JumpInfo.decNear(jumpInfo,
1952 label');
1953 true)
1954 | NONE => false))
1955
1956 val _ = destroy ()
1957 in
1958 {chunk = Chunk.T {data = data, blocks = blocks},
1959 changed = !changed}
1960 end
1961
1962 val (elimSimpleGoto,elimSimpleGoto_msg)
1963 = tracer
1964 "elimSimpleGoto"
1965 elimSimpleGoto
1966
1967 fun elimComplexGoto {chunk = Chunk.T {data, blocks, ...},
1968 jumpInfo : x86JumpInfo.t}
1969 = let
1970 datatype z = datatype x86JumpInfo.status
1971
1972 val {get: Label.t -> Block.t option,
1973 set: Label.t * Block.t option -> unit,
1974 destroy}
1975 = Property.destGetSet(Label.plist, Property.initConst NONE)
1976
1977 val labels
1978 = List.keepAllMap
1979 (blocks,
1980 fn block as Block.T {entry = Entry.Jump {label},...}
1981 => if x86JumpInfo.getNear(jumpInfo, label) = Count 1
1982 then (set(label, SOME block); SOME label)
1983 else NONE
1984 | _ => NONE)
1985
1986 fun loop ()
1987 = if List.fold
1988 (labels,
1989 false,
1990 fn (label,b)
1991 => case get label
1992 of SOME (Block.T
1993 {entry,
1994 profileLabel,
1995 statements,
1996 transfer = Transfer.Goto {target}})
1997 => (if Label.equals(label,target)
1998 then b
1999 else (case get target
2000 of NONE => b
2001 | SOME (Block.T
2002 {entry = entry',
2003 profileLabel = profileLabel',
2004 statements = statements',
2005 transfer = transfer'})
2006 => (set(label,
2007 SOME (Block.T
2008 {entry = entry,
2009 profileLabel = profileLabel,
2010 statements
2011 = List.concat
2012 [statements,
2013 [Assembly.Label
2014 (Entry.label entry')],
2015 ProfileLabel.toAssemblyOpt
2016 profileLabel',
2017 statements'],
2018 transfer
2019 = transfer'}));
2020 true)))
2021 | _ => b)
2022 then loop ()
2023 else ()
2024
2025 val _ = loop ()
2026
2027 val changed = ref false
2028 val elimComplexGoto'
2029 = fn block as Block.T {entry,
2030 profileLabel,
2031 statements,
2032 transfer = Transfer.Goto {target}}
2033 => if Label.equals(Entry.label entry,target)
2034 then block
2035 else (case get target
2036 of NONE => block
2037 | SOME (Block.T {entry = entry',
2038 profileLabel = profileLabel',
2039 statements = statements',
2040 transfer = transfer'})
2041 => let
2042 val _ = changed := true
2043 val _ = x86JumpInfo.decNear
2044 (jumpInfo,
2045 Entry.label entry')
2046 val _ = List.foreach
2047 (Transfer.nearTargets transfer',
2048 fn target
2049 => x86JumpInfo.incNear
2050 (jumpInfo, target))
2051
2052 val block
2053 = Block.T {entry = entry,
2054 profileLabel = profileLabel,
2055 statements
2056 = List.concat
2057 [statements,
2058 [Assembly.label
2059 (Entry.label entry')],
2060 ProfileLabel.toAssemblyOpt
2061 profileLabel',
2062 statements'],
2063 transfer = transfer'}
2064 in
2065 block
2066 end)
2067 | block => block
2068
2069 val blocks
2070 = List.map(blocks, elimComplexGoto')
2071
2072 val _ = destroy ()
2073 in
2074 {chunk = Chunk.T {data = data, blocks = blocks},
2075 changed = !changed}
2076 end
2077
2078 val (elimComplexGoto, elimComplexGoto_msg)
2079 = tracer
2080 "elimComplexGoto"
2081 elimComplexGoto
2082
2083 fun elimBlocks {chunk = Chunk.T {data, blocks, ...},
2084 jumpInfo : x86JumpInfo.t}
2085 = let
2086 val {get = getIsBlock,
2087 set = setIsBlock,
2088 destroy = destroyIsBlock}
2089 = Property.destGetSetOnce
2090 (Label.plist, Property.initConst false)
2091
2092 val {get: Label.t -> {block: Block.t,
2093 reach: bool ref},
2094 set,
2095 destroy}
2096 = Property.destGetSetOnce
2097 (Label.plist, Property.initRaise ("gotoInfo", Label.layout))
2098
2099 val (labels, funcs)
2100 = List.fold
2101 (blocks, ([], []),
2102 fn (block as Block.T {entry, ...}, (labels, funcs))
2103 => let
2104 val label = Entry.label entry
2105 in
2106 setIsBlock(label, true);
2107 set(label, {block = block,
2108 reach = ref false}) ;
2109 case entry
2110 of Entry.Func _ => (label::labels, label::funcs)
2111 | _ => (label::labels, funcs)
2112 end)
2113
2114 fun loop label
2115 = let
2116 val {block = Block.T {transfer, ...}, reach} = get label
2117 in
2118 if !reach
2119 then ()
2120 else (reach := true ;
2121 List.foreach (Transfer.nearTargets transfer, loop))
2122 end
2123 val _ = List.foreach (funcs, loop)
2124
2125 fun check oper
2126 = case (Operand.deImmediate oper, Operand.deLabel oper)
2127 of (SOME immediate, _)
2128 => (case Immediate.deLabel immediate
2129 of SOME label => if getIsBlock label
2130 then ! (#reach (get label))
2131 else true
2132 | NONE => true)
2133 | (_, SOME label) => if getIsBlock label
2134 then ! (#reach (get label))
2135 else true
2136 | _ => true
2137
2138 val changed = ref false
2139 val blocks
2140 = List.keepAllMap
2141 (labels,
2142 fn label
2143 => let
2144 val {block = Block.T {entry,
2145 profileLabel,
2146 statements,
2147 transfer},
2148 reach} = get label
2149 in
2150 if !reach
2151 then SOME
2152 (Block.T
2153 {entry = entry,
2154 profileLabel = profileLabel,
2155 statements
2156 = List.keepAll
2157 (statements,
2158 fn Assembly.Instruction i
2159 => (case #srcs (Instruction.srcs_dsts i)
2160 of NONE => true
2161 | SOME srcs
2162 => List.forall(srcs, check))
2163 | _ => true),
2164 transfer = transfer})
2165 else (changed := true ;
2166 List.foreach
2167 (Transfer.nearTargets transfer,
2168 fn label => x86JumpInfo.decNear (jumpInfo, label));
2169 NONE)
2170 end)
2171
2172 val _ = destroy ()
2173 val _ = destroyIsBlock ()
2174 in
2175 {chunk = Chunk.T {data = data, blocks = blocks},
2176 changed = !changed}
2177 end
2178
2179 val (elimBlocks, elimBlocks_msg)
2180 = tracer
2181 "elimBlocks"
2182 elimBlocks
2183
2184 fun elimGoto {chunk : Chunk.t,
2185 delProfileLabel: x86.ProfileLabel.t -> unit,
2186 jumpInfo : x86JumpInfo.t}
2187 = let
2188 val elimIff
2189 = PeepholeBlock.makeElimIff {jumpInfo = jumpInfo}
2190 val elimSwitchTest
2191 = PeepholeBlock.makeElimSwitchTest {jumpInfo = jumpInfo}
2192 val elimSwitchCases
2193 = PeepholeBlock.makeElimSwitchCases {jumpInfo = jumpInfo}
2194
2195 fun loop {chunk, changed}
2196 = let
2197 val {chunk,
2198 changed = changed_elimSimpleGoto}
2199 = elimSimpleGoto {chunk = chunk,
2200 delProfileLabel = delProfileLabel,
2201 jumpInfo = jumpInfo}
2202
2203 val Chunk.T {data, blocks, ...} = chunk
2204
2205 val {blocks,
2206 changed = changed_peepholeBlocks}
2207 = PeepholeBlock.peepholeBlocks
2208 {blocks = blocks,
2209 optimizations = [elimIff,
2210 elimSwitchTest,
2211 elimSwitchCases]}
2212
2213 val chunk = Chunk.T {data = data, blocks = blocks}
2214 in
2215 if changed_elimSimpleGoto orelse changed_peepholeBlocks
2216 then loop {chunk = chunk, changed = true}
2217 else {chunk = chunk, changed = changed}
2218 end
2219
2220 val {chunk,
2221 changed = changed_loop}
2222 = loop {chunk = chunk, changed = false}
2223
2224 val {chunk,
2225 changed = changed_elimComplexGoto}
2226 = elimComplexGoto {chunk = chunk,
2227 jumpInfo = jumpInfo}
2228
2229 val {chunk,
2230 changed = changed_elimBlocks}
2231 = elimBlocks {chunk = chunk,
2232 jumpInfo = jumpInfo}
2233 in
2234 {chunk = chunk,
2235 changed = changed_loop
2236 orelse changed_elimComplexGoto
2237 orelse changed_elimBlocks}
2238 end
2239
2240 val (elimGoto, elimGoto_msg)
2241 = tracer
2242 "elimGoto"
2243 elimGoto
2244
2245 val elimGoto_msg
2246 = fn () => (elimGoto_msg ();
2247 Control.indent ();
2248 PeepholeBlock.elimIff_msg ();
2249 PeepholeBlock.elimSwitchTest_msg ();
2250 PeepholeBlock.elimSwitchCases_msg ();
2251 elimSimpleGoto_msg ();
2252 elimComplexGoto_msg ();
2253 elimBlocks_msg ();
2254 Control.unindent ())
2255 end
2256
2257 structure MoveHoistLivenessBlock =
2258 struct
2259 structure LiveSet = x86Liveness.LiveSet
2260 structure Liveness = x86Liveness.Liveness
2261 structure LivenessBlock = x86Liveness.LivenessBlock
2262
2263 fun moveHoist {block = LivenessBlock.T
2264 {entry, profileLabel, statements, transfer}}
2265 = let
2266 val {transfer,live}
2267 = LivenessBlock.reLivenessTransfer {transfer = transfer}
2268
2269 val {statements, changed, moves, live}
2270 = List.foldr
2271 (statements,
2272 {statements = [],
2273 changed = false,
2274 moves = [],
2275 live = live},
2276 fn ((asm: Assembly.t, Liveness.T {dead,...}),
2277 {statements: (Assembly.t * Liveness.t) list,
2278 changed : bool,
2279 moves,
2280 live: x86Liveness.LiveSet.t})
2281 => let
2282 fun default ()
2283 = let
2284 val {uses,defs,...} = Assembly.uses_defs_kills asm
2285
2286 val baseUses
2287 = List.fold
2288 (uses,
2289 [],
2290 fn (operand,baseUses)
2291 => case Operand.deMemloc operand
2292 of SOME memloc
2293 => if List.contains
2294 (baseUses,
2295 memloc,
2296 MemLoc.eq)
2297 then baseUses
2298 else memloc::baseUses
2299 | NONE => baseUses)
2300 val baseDefs
2301 = List.fold
2302 (defs,
2303 [],
2304 fn (operand,baseDefs)
2305 => case Operand.deMemloc operand
2306 of SOME memloc
2307 => if List.contains
2308 (baseDefs,
2309 memloc,
2310 MemLoc.eq)
2311 then baseDefs
2312 else memloc::baseDefs
2313 | NONE => baseDefs)
2314
2315 val allUses
2316 = let
2317 fun doit(memlocs,allUses)
2318 = List.fold
2319 (memlocs,
2320 allUses,
2321 fn (memloc,allUses)
2322 => List.fold
2323 (MemLoc.utilized memloc,
2324 allUses,
2325 fn (memloc,allUses)
2326 => if List.contains
2327 (allUses,
2328 memloc,
2329 MemLoc.eq)
2330 then allUses
2331 else memloc::allUses))
2332 in
2333 doit(baseDefs,
2334 doit(baseUses,
2335 baseUses))
2336 end
2337 val allDefs = baseDefs
2338
2339 val {forces,
2340 moves,
2341 ...}
2342 = List.fold
2343 (moves,
2344 {forces = [],
2345 moves = [],
2346 allUses = allUses,
2347 allDefs = allDefs},
2348 fn (move as {src,dst,...},
2349 {forces,
2350 moves,
2351 allUses,
2352 allDefs})
2353 => let
2354 val utilized_src
2355 = MemLoc.utilized src
2356 val utilized_dst
2357 = MemLoc.utilized dst
2358 in
2359 if List.exists
2360 (allDefs,
2361 fn memloc'
2362 => List.exists
2363 (src::utilized_src,
2364 fn memloc''
2365 => MemLoc.mayAlias
2366 (memloc', memloc'')))
2367 orelse
2368 List.exists
2369 (allDefs,
2370 fn memloc'
2371 => List.exists
2372 (dst::utilized_dst,
2373 fn memloc''
2374 => MemLoc.mayAlias
2375 (memloc', memloc'')))
2376 orelse
2377 List.exists
2378 (allUses,
2379 fn memloc'
2380 => MemLoc.mayAlias
2381 (memloc',dst)
2382 orelse
2383 MemLoc.mayAlias
2384 (memloc',src))
2385 then {forces = move::forces,
2386 moves = moves,
2387 allUses
2388 = src::(List.concat
2389 [utilized_src,
2390 utilized_dst,
2391 allUses]),
2392 allDefs
2393 = dst::allDefs}
2394 else {forces = forces,
2395 moves = move::moves,
2396 allUses = allUses,
2397 allDefs = allDefs}
2398 end)
2399
2400 val moves
2401 = List.revMap
2402 (moves,
2403 fn {src,dst,size,age}
2404 => {src = src,
2405 dst = dst,
2406 size = size,
2407 age = age + 1})
2408
2409 val statements_forces
2410 = List.revMap
2411 (forces,
2412 fn {src,dst,size,...}
2413 => (case Size.class size
2414 of Size.INT
2415 => Assembly.instruction_mov
2416 {src = Operand.memloc src,
2417 dst = Operand.memloc dst,
2418 size = size}
2419 | _
2420 => Assembly.instruction_pfmov
2421 {src = Operand.memloc src,
2422 dst = Operand.memloc dst,
2423 size = size}))
2424
2425 val {statements = statements_asm_forces,
2426 live}
2427 = LivenessBlock.toLivenessStatements
2428 {statements = asm::statements_forces,
2429 live = live}
2430 in
2431 {statements
2432 = List.concat
2433 [statements_asm_forces,
2434 statements],
2435 changed
2436 = changed
2437 orelse
2438 List.exists(forces,
2439 fn {age,...}
2440 => age <> 0),
2441 moves = moves,
2442 live = live}
2443 end
2444 in
2445 case asm
2446 of Assembly.Instruction
2447 (Instruction.MOV
2448 {src = Operand.MemLoc memloc_src,
2449 dst = Operand.MemLoc memloc_dst,
2450 size})
2451 => if LiveSet.contains(dead,
2452 memloc_src)
2453 orelse
2454 List.exists(moves,
2455 fn {src,...}
2456 => MemLoc.eq(memloc_src,src))
2457 then {statements = statements,
2458 changed = changed,
2459 moves = {src = memloc_src,
2460 dst = memloc_dst,
2461 size = size,
2462 age = 0}::moves,
2463 live = live}
2464 else default ()
2465 | Assembly.Instruction
2466 (Instruction.pFMOV
2467 {src = Operand.MemLoc memloc_src,
2468 dst = Operand.MemLoc memloc_dst,
2469 size})
2470 => if LiveSet.contains(dead,
2471 memloc_src)
2472 orelse
2473 List.exists(moves,
2474 fn {src,...}
2475 => MemLoc.eq(memloc_src,src))
2476 then {statements = statements,
2477 changed = changed,
2478 moves = {src = memloc_src,
2479 dst = memloc_dst,
2480 size = size,
2481 age = 0}::moves,
2482 live = live}
2483 else default ()
2484 | _ => default ()
2485 end)
2486
2487 val forces = moves
2488 val statements_forces
2489 = List.map
2490 (forces,
2491 fn {src,dst,size,...}
2492 => (case Size.class size
2493 of Size.INT
2494 => Assembly.instruction_mov
2495 {src = Operand.memloc src,
2496 dst = Operand.memloc dst,
2497 size = size}
2498 | _
2499 => Assembly.instruction_pfmov
2500 {src = Operand.memloc src,
2501 dst = Operand.memloc dst,
2502 size = size}))
2503 val {statements = statements_forces,
2504 ...}
2505 = LivenessBlock.toLivenessStatements
2506 {statements = statements_forces,
2507 live = live}
2508 val statements = List.concat [statements_forces,
2509 statements]
2510 val changed = changed
2511 orelse
2512 List.exists(forces,
2513 fn {age,...}
2514 => age <> 0)
2515 val block = LivenessBlock.T {entry = entry,
2516 profileLabel = profileLabel,
2517 statements = statements,
2518 transfer = transfer}
2519 in
2520 {block = block,
2521 changed = changed}
2522 end
2523
2524 val moveHoist
2525 = fn {block} => (moveHoist {block = block})
2526
2527 val (moveHoist:
2528 {block: LivenessBlock.t} ->
2529 {block: LivenessBlock.t,
2530 changed: bool},
2531 moveHoist_msg)
2532 = tracer
2533 "moveHoist"
2534 moveHoist
2535 end
2536
2537 structure CopyPropagateLivenessBlock =
2538 struct
2539 structure LiveSet = x86Liveness.LiveSet
2540 structure LiveInfo = x86Liveness.LiveInfo
2541 structure Liveness = x86Liveness.Liveness
2542 structure LivenessBlock = x86Liveness.LivenessBlock
2543
2544 fun copyPropagate' {src,
2545 dst as Operand.MemLoc memloc_dst,
2546 pblock = {statements, transfer},
2547 liveInfo}
2548 = let
2549 val changed = ref 0
2550 val (all,replacer)
2551 = case src
2552 of Operand.MemLoc memloc_src
2553 => let
2554 val all
2555 = let
2556 fun doit (memlocs, all)
2557 = List.fold
2558 (memlocs,
2559 all,
2560 fn (memloc,all)
2561 => if List.contains(all,
2562 memloc,
2563 MemLoc.eq)
2564 then all
2565 else memloc::all)
2566 in
2567 doit(memloc_dst::(MemLoc.utilized memloc_dst),
2568 doit(memloc_src::(MemLoc.utilized memloc_src),
2569 []))
2570 end
2571
2572 fun replacer' memloc
2573 = if MemLoc.eq(memloc,memloc_dst)
2574 then (changed := !changed + 1;
2575 memloc_src)
2576 else memloc
2577
2578 val replacer
2579 = fn {use,def} => fn operand
2580 => case Operand.deMemloc operand
2581 of SOME memloc
2582 => if (use andalso not def)
2583 orelse
2584 (not (MemLoc.eq(memloc, memloc_dst)))
2585 then Operand.memloc
2586 (MemLoc.replace replacer' memloc)
2587 else operand
2588 | _ => operand
2589 in
2590 (all, replacer)
2591 end
2592 | _
2593 => let
2594 val all
2595 = let
2596 fun doit (memlocs, all)
2597 = List.fold
2598 (memlocs,
2599 all,
2600 fn (memloc,all)
2601 => if List.contains(all,
2602 memloc,
2603 MemLoc.eq)
2604 then all
2605 else memloc::all)
2606 in
2607 doit(memloc_dst::(MemLoc.utilized memloc_dst),
2608 [])
2609 end
2610
2611 val replacer
2612 = fn {use,def}
2613 => fn operand
2614 => if use andalso not def
2615 then if Operand.eq(operand,dst)
2616 then (changed := !changed + 1;
2617 src)
2618 else operand
2619 else operand
2620 in
2621 (all, replacer)
2622 end
2623
2624 val (transfer,_) = transfer
2625
2626 fun doit (statements : (Assembly.t * Liveness.t) list)
2627 = let
2628 fun uses_defs {uses, defs}
2629 = let
2630 local
2631 fun doit operands
2632 = List.fold
2633 (operands,
2634 [],
2635 fn (operand,memlocs)
2636 => case Operand.deMemloc operand
2637 of SOME memloc
2638 => if List.contains(memlocs,
2639 memloc,
2640 MemLoc.eq)
2641 then memlocs
2642 else memloc::memlocs
2643 | NONE => memlocs)
2644
2645 fun doit'(memlocs,uses)
2646 = List.fold
2647 (memlocs,
2648 uses,
2649 fn (memloc,uses)
2650 => if List.contains(uses,
2651 memloc,
2652 MemLoc.eq)
2653 then uses
2654 else memloc::uses)
2655 fun doit''(memlocs,uses)
2656 = List.fold
2657 (memlocs,
2658 uses,
2659 fn (memloc,uses)
2660 => doit'(MemLoc.utilized memloc, uses))
2661 in
2662 val uses = doit uses
2663 val defs = doit defs
2664 val uses = doit''(defs,
2665 doit''(uses,
2666 uses))
2667 end
2668 in
2669 {uses = uses, defs = defs}
2670 end
2671 in
2672 case statements
2673 of []
2674 => let
2675 val transfer = Transfer.replace replacer transfer
2676 val {uses,defs,...} = Transfer.uses_defs_kills transfer
2677
2678 val {uses, defs} = uses_defs {uses = uses, defs = defs}
2679 in
2680 if not (List.contains(uses,
2681 memloc_dst,
2682 MemLoc.eq))
2683 andalso
2684 not (MemLocSet.contains(Transfer.live transfer,
2685 memloc_dst))
2686 then if List.forall
2687 (all,
2688 fn memloc
2689 => List.forall
2690 (defs,
2691 fn memloc'
2692 => not (MemLoc.mayAlias(memloc,
2693 memloc'))))
2694 then SOME {statements = [],
2695 transfer = transfer}
2696 else NONE
2697 else NONE
2698 end
2699 | (asm, Liveness.T {dead, ...}) :: statements
2700 => let
2701 val asm = Assembly.replace replacer asm
2702 val {uses,defs,...} = Assembly.uses_defs_kills asm
2703
2704 val {uses, defs} = uses_defs {uses = uses, defs = defs}
2705 in
2706 if not (List.contains(uses,
2707 memloc_dst,
2708 MemLoc.eq))
2709 then if LiveSet.contains(dead,memloc_dst)
2710 then let
2711 val statements
2712 = List.map (statements, #1)
2713 in
2714 SOME {statements = asm::statements,
2715 transfer = transfer}
2716 end
2717 else if List.forall
2718 (all,
2719 fn memloc
2720 => List.forall
2721 (defs,
2722 fn memloc'
2723 => not (MemLoc.mayAlias(memloc,
2724 memloc'))))
2725 then case doit statements
2726 of NONE => NONE
2727 | SOME {statements,
2728 transfer}
2729 => SOME {statements = asm::statements,
2730 transfer = transfer}
2731 else NONE
2732 else NONE
2733 end
2734 end
2735 in
2736 case doit statements
2737 of NONE => NONE
2738 | SOME {statements, transfer}
2739 => let
2740 val {transfer, live}
2741 = LivenessBlock.toLivenessTransfer
2742 {transfer = transfer,
2743 liveInfo = liveInfo}
2744 val {statements, ...}
2745 = LivenessBlock.toLivenessStatements
2746 {statements = statements,
2747 live = live}
2748 in
2749 SOME {pblock = {statements = statements,
2750 transfer = transfer},
2751 changed = !changed > 0}
2752 end
2753 end
2754 | copyPropagate' _ = Error.bug "x86Simplify.PeeholeBlock: copyPropagate'"
2755
2756
2757 fun copyPropagate {block = LivenessBlock.T
2758 {entry, profileLabel, statements, transfer},
2759 liveInfo}
2760 = let
2761 val {pblock = {statements,transfer},changed}
2762 = List.foldr
2763 (statements,
2764 {pblock = {statements = [],
2765 transfer = transfer},
2766 changed = false},
2767 fn ((asm as Assembly.Instruction
2768 (Instruction.MOV
2769 {src,
2770 dst as Operand.MemLoc memloc_dst,
2771 ...}),
2772 info: Liveness.t),
2773 {pblock as {statements, transfer},
2774 changed})
2775 => let
2776 val pblock' = {statements = (asm,info)::statements,
2777 transfer = transfer}
2778 in
2779 if x86Liveness.track memloc_dst
2780 andalso
2781 (List.fold
2782 (statements,
2783 false,
2784 fn ((_, Liveness.T {dead,...}),b)
2785 => b orelse LiveSet.contains(dead,memloc_dst))
2786 orelse
2787 LiveSet.contains(Liveness.dead(#2(transfer)),memloc_dst))
2788 then case copyPropagate' {src = src,
2789 dst = dst,
2790 pblock = pblock,
2791 liveInfo = liveInfo}
2792 of NONE => {pblock = pblock',
2793 changed = changed}
2794 | SOME {pblock,
2795 changed = changed'}
2796 => {pblock = pblock,
2797 changed = changed orelse changed'}
2798 else {pblock = pblock',
2799 changed = changed}
2800 end
2801 | ((asm as Assembly.Instruction
2802 (Instruction.pFMOV
2803 {src,
2804 dst as Operand.MemLoc memloc_dst,
2805 ...}),
2806 info),
2807 {pblock as {statements, transfer},
2808 changed})
2809 => let
2810 val pblock' = {statements = (asm,info)::statements,
2811 transfer = transfer}
2812 in
2813 if x86Liveness.track memloc_dst
2814 andalso
2815 (List.fold
2816 (statements,
2817 false,
2818 fn ((_, Liveness.T {dead,...}),b)
2819 => b orelse LiveSet.contains(dead,memloc_dst))
2820 orelse
2821 LiveSet.contains(Liveness.dead (#2 transfer),
2822 memloc_dst))
2823 then case copyPropagate' {src = src,
2824 dst = dst,
2825 pblock = pblock,
2826 liveInfo = liveInfo}
2827 of NONE => {pblock = pblock',
2828 changed = changed}
2829 | SOME {pblock,
2830 changed = changed'}
2831 => {pblock = pblock,
2832 changed = changed orelse changed'}
2833 else {pblock = pblock',
2834 changed = changed}
2835 end
2836 | ((asm,info),
2837 {pblock = {statements, transfer},
2838 changed})
2839 => {pblock = {statements = (asm,info)::statements,
2840 transfer = transfer},
2841 changed = changed})
2842 in
2843 {block = LivenessBlock.T {entry = entry,
2844 profileLabel = profileLabel,
2845 statements = statements,
2846 transfer = transfer},
2847 changed = changed}
2848 end
2849
2850 val copyPropagate
2851 = fn {block, liveInfo}
2852 => (copyPropagate {block = block, liveInfo = liveInfo})
2853
2854 val (copyPropagate :
2855 {block: LivenessBlock.t,
2856 liveInfo: LiveInfo.t} ->
2857 {block: LivenessBlock.t,
2858 changed: bool},
2859 copyPropagate_msg)
2860 = tracer
2861 "copyPropagate"
2862 copyPropagate
2863
2864 val copyPropagate =
2865 fn arg as {block as LivenessBlock.T {statements, ...}, ...} =>
2866 if List.length statements <= !Control.Native.copyPropCutoff
2867 then copyPropagate arg
2868 else {block = block, changed = false}
2869 end
2870
2871 structure PeepholeLivenessBlock =
2872 struct
2873 structure LiveSet = x86Liveness.LiveSet
2874 structure Liveness = x86Liveness.Liveness
2875 structure LivenessBlock = x86Liveness.LivenessBlock
2876
2877 structure Peephole
2878 = Peephole(type entry_type = Entry.t * Liveness.t
2879 type profileLabel_type = ProfileLabel.t option
2880 type statement_type = Assembly.t * Liveness.t
2881 type transfer_type = Transfer.t * Liveness.t
2882 datatype block = datatype LivenessBlock.t)
2883 open Peephole
2884
2885 fun make_callback_msg name
2886 = let
2887 val count = ref 0
2888 val total = ref 0
2889 val callback = fn true => (Int.inc count; Int.inc total)
2890 | false => Int.inc total
2891 val msg = fn () => Control.messageStr
2892 (Control.Detail,
2893 concat [name,
2894 ": ", Int.toString (!count),
2895 " / ", Int.toString (!total)])
2896 in
2897 (callback,msg)
2898 end
2899
2900 val isComment : statement_type -> bool
2901 = fn (Assembly.Comment _, _) => true
2902 | _ => false
2903
2904 local
2905 val isInstruction_dstsTemp_dstsDead : statement_type -> bool
2906 = fn (Assembly.Instruction instruction,
2907 Liveness.T {dead,...})
2908 => let
2909 val {dsts,...} = Instruction.srcs_dsts instruction
2910 in
2911 case dsts
2912 of NONE => false
2913 | SOME dsts => List.forall
2914 (dsts,
2915 fn Operand.MemLoc memloc
2916 => x86Liveness.track memloc
2917 andalso
2918 LiveSet.contains(dead,memloc)
2919 | _ => false)
2920 end
2921 | _ => false
2922
2923 val template : template
2924 = {start = EmptyOrNonEmpty,
2925 statements = [One isInstruction_dstsTemp_dstsDead],
2926 finish = EmptyOrNonEmpty,
2927 transfer = fn _ => true}
2928
2929 val rewriter : rewriter
2930 = fn {entry,
2931 profileLabel,
2932 start,
2933 statements =
2934 [[(Assembly.Instruction _,
2935 Liveness.T {liveOut,...})]],
2936 finish,
2937 transfer}
2938 => if (case List.fold
2939 (finish, (false, false), fn ((asm, _), (b, b')) =>
2940 case asm
2941 of Assembly.Comment _ => (b, b')
2942 | Assembly.Instruction
2943 (Instruction.SETcc _)
2944 => (true, if b then b' else true)
2945 | _ => (true, b'))
2946 of (_, true) => true
2947 | (false, _) => (case #1 transfer
2948 of Transfer.Iff _ => true
2949 | _ => false)
2950 | _ => false)
2951 then NONE
2952 else let
2953 val {statements, live}
2954 = LivenessBlock.reLivenessStatements
2955 {statements = List.rev start,
2956 live = liveOut}
2957
2958 val {entry, ...}
2959 = LivenessBlock.reLivenessEntry
2960 {entry = entry,
2961 live = live}
2962
2963 val statements
2964 = List.concat [statements, finish]
2965 in
2966 SOME (LivenessBlock.T
2967 {entry = entry,
2968 profileLabel = profileLabel,
2969 statements = statements,
2970 transfer = transfer})
2971 end
2972 | _ => Error.bug "x86Simplify.PeeholeBlock: elimDeadDsts"
2973
2974 val (callback,elimDeadDsts_msg)
2975 = make_callback_msg "elimDeadDsts"
2976 in
2977 val elimDeadDsts : optimization
2978 = {template = template,
2979 rewriter = rewriter,
2980 callback = callback}
2981 val elimDeadDsts_msg = elimDeadDsts_msg
2982 end
2983
2984 local
2985 val isInstructionMOV_dstTemp : statement_type -> bool
2986 = fn (Assembly.Instruction (Instruction.MOV
2987 {dst = Operand.MemLoc memloc,...}),
2988 _)
2989 => x86Liveness.track memloc
2990 | _ => false
2991
2992 val isInstructionAL_dstTemp : statement_type -> bool
2993 = fn (Assembly.Instruction (Instruction.BinAL
2994 {dst = Operand.MemLoc memloc,...}),
2995 _)
2996 => x86Liveness.track memloc
2997 | (Assembly.Instruction (Instruction.pMD
2998 {dst = Operand.MemLoc memloc,...}),
2999
3000 _)
3001 => x86Liveness.track memloc
3002 | (Assembly.Instruction (Instruction.IMUL2
3003 {dst = Operand.MemLoc memloc,...}),
3004
3005 _)
3006 => x86Liveness.track memloc
3007 | (Assembly.Instruction (Instruction.UnAL
3008 {dst = Operand.MemLoc memloc,...}),
3009
3010 _)
3011 => x86Liveness.track memloc
3012 | (Assembly.Instruction (Instruction.SRAL
3013 {dst = Operand.MemLoc memloc,...}),
3014
3015 _)
3016 => x86Liveness.track memloc
3017 | _ => false
3018
3019 val isInstructionMOV_srcTemp_srcDead : statement_type -> bool
3020 = fn (Assembly.Instruction (Instruction.MOV
3021 {src = Operand.MemLoc memloc,...}),
3022 Liveness.T {dead,...})
3023 => x86Liveness.track memloc
3024 andalso
3025 LiveSet.contains(dead, memloc)
3026 | _ => false
3027
3028 val template : template
3029 = {start = EmptyOrNonEmpty,
3030 statements = [One isInstructionMOV_dstTemp,
3031 All (fn asm
3032 => (isComment asm)
3033 orelse
3034 (isInstructionAL_dstTemp asm)),
3035 One isInstructionMOV_srcTemp_srcDead],
3036 finish = EmptyOrNonEmpty,
3037 transfer = fn _ => true}
3038
3039 val rewriter : rewriter
3040 = fn {entry,
3041 profileLabel,
3042 start,
3043 statements =
3044 [[(Assembly.Instruction (Instruction.MOV
3045 {src = src1,
3046 dst = dst1 as Operand.MemLoc memloc1,
3047 size = size1}),
3048 _)],
3049 statements',
3050 [(Assembly.Instruction (Instruction.MOV
3051 {src = Operand.MemLoc memloc2,
3052 dst = dst2,
3053 size = size2}),
3054 Liveness.T {liveOut = liveOut2,...})]],
3055 finish,
3056 transfer}
3057 => if Size.eq(size1,size2) andalso
3058 MemLoc.eq(memloc1,memloc2) andalso
3059 List.forall
3060 (statements',
3061 fn (Assembly.Comment _, _) => true
3062 | (Assembly.Instruction (Instruction.BinAL
3063 {src,
3064 dst = Operand.MemLoc memloc,
3065 size,
3066 ...}),
3067 _)
3068 => Size.eq(size1,size) andalso
3069 MemLoc.eq(memloc1,memloc) andalso
3070 (case (src,dst2)
3071 of (Operand.MemLoc memloc_src,
3072 Operand.MemLoc memloc_dst2)
3073 => List.forall
3074 (memloc_src::(MemLoc.utilized memloc_src),
3075 fn memloc'
3076 => not (MemLoc.mayAlias(memloc_dst2,memloc')))
3077 | (Operand.Immediate _, _) => true
3078 | _ => false)
3079 | (Assembly.Instruction (Instruction.pMD
3080 {src,
3081 dst = Operand.MemLoc memloc,
3082 size,
3083 ...}),
3084 _)
3085 => Size.eq(size1,size) andalso
3086 MemLoc.eq(memloc1,memloc) andalso
3087 (case (src,dst2)
3088 of (Operand.MemLoc memloc_src,
3089 Operand.MemLoc memloc_dst2)
3090 => List.forall
3091 (memloc_src::(MemLoc.utilized memloc_src),
3092 fn memloc'
3093 => not (MemLoc.mayAlias(memloc_dst2,memloc')))
3094 | (Operand.Immediate _, _) => true
3095 | _ => false)
3096 | (Assembly.Instruction (Instruction.IMUL2
3097 {src,
3098 dst = Operand.MemLoc memloc,
3099 size}),
3100 _)
3101 => Size.eq(size1,size) andalso
3102 MemLoc.eq(memloc1,memloc) andalso
3103 (case (src,dst2)
3104 of (Operand.MemLoc memloc_src,
3105 Operand.MemLoc memloc_dst2)
3106 => List.forall
3107 (memloc_src::(MemLoc.utilized memloc_src),
3108 fn memloc'
3109 => not (MemLoc.mayAlias(memloc_dst2,memloc')))
3110 | (Operand.Immediate _, _) => true
3111 | _ => false)
3112 | (Assembly.Instruction (Instruction.UnAL
3113 {dst = Operand.MemLoc memloc,
3114 size,
3115 ...}),
3116 _)
3117 => Size.eq(size1,size) andalso
3118 MemLoc.eq(memloc1,memloc)
3119 | (Assembly.Instruction (Instruction.SRAL
3120 {count,
3121 dst = Operand.MemLoc memloc,
3122 size,
3123 ...}),
3124 _)
3125 => Size.eq(size1,size) andalso
3126 MemLoc.eq(memloc1,memloc) andalso
3127 (case (count,dst2)
3128 of (Operand.MemLoc memloc_count,
3129 Operand.MemLoc memloc_dst2)
3130 => List.forall
3131 (memloc_count::(MemLoc.utilized memloc_count),
3132 fn memloc'
3133 => not (MemLoc.mayAlias(memloc_dst2,memloc')))
3134 | (Operand.Immediate _, _) => true
3135 | _ => false)
3136 | _ => Error.bug "x86Simplify.PeeholeBlock: elimALCopy")
3137 then let
3138 val statements
3139 = List.map
3140 (statements',
3141 fn (asm,_)
3142 => Assembly.replace
3143 (fn {...}
3144 => fn operand
3145 => if Operand.eq(operand,dst1)
3146 then dst2
3147 else operand)
3148 asm)
3149
3150 val {statements, ...}
3151 = LivenessBlock.toLivenessStatements
3152 {statements
3153 = (Assembly.instruction_mov
3154 {src = src1,
3155 dst = dst2,
3156 size = size1})::statements,
3157 live = liveOut2}
3158
3159 val statements
3160 = List.fold(start,
3161 List.concat [statements,
3162 finish],
3163 op ::)
3164 in
3165 SOME (LivenessBlock.T
3166 {entry = entry,
3167 profileLabel = profileLabel,
3168 statements = statements,
3169 transfer = transfer})
3170 end
3171 else NONE
3172 | _ => Error.bug "x86Simplify.PeeholeBlock: elimALCopy"
3173
3174 val (callback,elimALCopy_msg)
3175 = make_callback_msg "elimALCopy"
3176 in
3177 val elimALCopy : optimization
3178 = {template = template,
3179 rewriter = rewriter,
3180 callback = callback}
3181 val elimALCopy_msg = elimALCopy_msg
3182 end
3183
3184 local
3185 val isInstructionMOV_eqSrcDst : statement_type -> bool
3186 = fn (Assembly.Instruction (Instruction.MOV
3187 {dst = Operand.MemLoc memloc1,
3188 src = Operand.MemLoc memloc2,...}),
3189 _)
3190 => MemLoc.eq(memloc1,memloc2)
3191 | _ => false
3192
3193 val template : template
3194 = {start = EmptyOrNonEmpty,
3195 statements = [One isInstructionMOV_eqSrcDst],
3196 finish = EmptyOrNonEmpty,
3197 transfer = fn _ => true}
3198
3199 val rewriter : rewriter
3200 = fn {entry,
3201 profileLabel,
3202 start,
3203 statements =
3204 [[(Assembly.Instruction (Instruction.MOV
3205 {src = Operand.MemLoc memloc, ...}),
3206 Liveness.T {liveOut,...})]],
3207 finish,
3208 transfer}
3209 => if List.exists (MemLoc.utilized memloc, x86Liveness.track)
3210 then let
3211 val {statements, live} =
3212 LivenessBlock.reLivenessStatements
3213 {statements = List.rev start,
3214 live = liveOut}
3215 val {entry, ...} =
3216 LivenessBlock.reLivenessEntry
3217 {entry = entry,
3218 live = live}
3219 val statements =
3220 List.concat [statements, finish]
3221 in
3222 SOME (LivenessBlock.T
3223 {entry = entry,
3224 profileLabel = profileLabel,
3225 statements = statements,
3226 transfer = transfer})
3227 end
3228 else let
3229 val statements =
3230 List.fold(start, finish, op ::)
3231 in
3232 SOME (LivenessBlock.T
3233 {entry = entry,
3234 profileLabel = profileLabel,
3235 statements = statements,
3236 transfer = transfer})
3237 end
3238 | _ => Error.bug "x86Simplify.PeeholeBlock: elimSelfMove"
3239
3240 val (callback,elimSelfMove_msg)
3241 = make_callback_msg "elimSelfMove"
3242 in
3243 val elimSelfMove : optimization
3244 = {template = template,
3245 rewriter = rewriter,
3246 callback = callback}
3247 val elimSelfMove_msg = elimSelfMove_msg
3248 end
3249
3250 local
3251 val isInstructionMOV_dstMemloc : statement_type -> bool
3252 = fn (Assembly.Instruction (Instruction.MOV
3253 {dst = Operand.MemLoc _,...}),
3254 _)
3255 => true
3256 | _ => false
3257
3258 val isInstructionBinALMD_dstMemloc_operCommute : statement_type -> bool
3259 = fn (Assembly.Instruction (Instruction.BinAL
3260 {oper,
3261 dst = Operand.MemLoc _,...}),
3262 _)
3263 => (oper = Instruction.ADD)
3264 orelse
3265 (oper = Instruction.ADC)
3266 orelse
3267 (oper = Instruction.AND)
3268 orelse
3269 (oper = Instruction.OR)
3270 orelse
3271 (oper = Instruction.XOR)
3272 | (Assembly.Instruction (Instruction.pMD
3273 {oper,
3274 dst = Operand.MemLoc _,...}),
3275 _)
3276 => (oper = Instruction.IMUL)
3277 orelse
3278 (oper = Instruction.MUL)
3279 | (Assembly.Instruction (Instruction.IMUL2
3280 {dst = Operand.MemLoc _,...}),
3281 _)
3282 => true
3283 | _ => false
3284
3285 val template : template
3286 = {start = EmptyOrNonEmpty,
3287 statements = [One isInstructionMOV_dstMemloc,
3288 All isComment,
3289 One isInstructionBinALMD_dstMemloc_operCommute],
3290 finish = EmptyOrNonEmpty,
3291 transfer = fn _ => true}
3292
3293 val rewriter : rewriter
3294 = fn {entry,
3295 profileLabel,
3296 start,
3297 statements =
3298 [[(Assembly.Instruction (Instruction.MOV
3299 {src = src1,
3300 dst
3301 = dst1 as Operand.MemLoc memloc_dst1,
3302 size = size1}),
3303 Liveness.T {dead = dead1,...})],
3304 comments,
3305 [(Assembly.Instruction (Instruction.BinAL
3306 {oper = oper2,
3307 src = src2,
3308 dst
3309 = dst2 as Operand.MemLoc _,
3310 size = size2}),
3311 Liveness.T {dead = dead2,
3312 liveOut = liveOut2, ...})]],
3313 finish,
3314 transfer}
3315 => if Size.eq(size1,size2) andalso
3316 Operand.eq(dst1,dst2) andalso
3317 not (Operand.eq(src1,src2)) andalso
3318 (case (src1,src2)
3319 of (Operand.MemLoc memloc_src1,
3320 Operand.MemLoc memloc_src2)
3321 => LiveSet.contains(dead2,
3322 memloc_src2)
3323 andalso
3324 not (LiveSet.contains(dead1,
3325 memloc_src1))
3326 | (_, Operand.MemLoc memloc_src2)
3327 => LiveSet.contains(dead2,
3328 memloc_src2)
3329 | _ => false) andalso
3330 (case src1
3331 of Operand.MemLoc memloc_src1
3332 => not (List.exists
3333 (memloc_src1::(MemLoc.utilized memloc_src1),
3334 fn memloc'
3335 => MemLoc.mayAlias(memloc',memloc_dst1)))
3336 | _ => true) andalso
3337 (case src2
3338 of Operand.MemLoc memloc_src2
3339 => not (List.exists
3340 (memloc_src2::(MemLoc.utilized memloc_src2),
3341 fn memloc'
3342 => MemLoc.mayAlias(memloc',memloc_dst1)))
3343 | _ => true)
3344 then let
3345 val statements
3346 = (Assembly.instruction_mov
3347 {src = src2,
3348 dst = dst1,
3349 size = size1})::
3350 (List.concat
3351 [List.map(comments, #1),
3352 [Assembly.instruction_binal
3353 {oper = oper2,
3354 src = src1,
3355 dst = dst2,
3356 size = size2}]])
3357
3358 val {statements, ...}
3359 = LivenessBlock.toLivenessStatements
3360 {statements = statements,
3361 live = liveOut2}
3362
3363 val statements
3364 = List.fold(start,
3365 List.concat [statements,
3366 finish],
3367 op ::)
3368 in
3369 SOME (LivenessBlock.T
3370 {entry = entry,
3371 profileLabel = profileLabel,
3372 statements = statements,
3373 transfer = transfer})
3374 end
3375 else NONE
3376 | {entry,
3377 profileLabel,
3378 start,
3379 statements =
3380 [[(Assembly.Instruction (Instruction.MOV
3381 {src = src1,
3382 dst
3383 = dst1 as Operand.MemLoc memloc_dst1,
3384 size = size1}),
3385 Liveness.T {dead = dead1,...})],
3386 comments,
3387 [(Assembly.Instruction (Instruction.pMD
3388 {oper = oper2,
3389 src = src2,
3390 dst
3391 = dst2 as Operand.MemLoc _,
3392 size = size2}),
3393 Liveness.T {dead = dead2,
3394 liveOut = liveOut2,...})]],
3395 finish,
3396 transfer}
3397 => if Size.eq(size1,size2) andalso
3398 Operand.eq(dst1,dst2) andalso
3399 not (Operand.eq(src1,src2)) andalso
3400 (case (src1,src2)
3401 of (Operand.MemLoc memloc_src1,
3402 Operand.MemLoc memloc_src2)
3403 => LiveSet.contains(dead2,
3404 memloc_src2)
3405 andalso
3406 not (LiveSet.contains(dead1,
3407 memloc_src1))
3408 | (_, Operand.MemLoc memloc_src2)
3409 => LiveSet.contains(dead2,
3410 memloc_src2)
3411 | _ => false) andalso
3412 (case src1
3413 of Operand.MemLoc memloc_src1
3414 => not (List.exists
3415 (memloc_src1::(MemLoc.utilized memloc_src1),
3416 fn memloc'
3417 => MemLoc.mayAlias(memloc',memloc_dst1)))
3418 | _ => true) andalso
3419 (case src2
3420 of Operand.MemLoc memloc_src2
3421 => not (List.exists
3422 (memloc_src2::(MemLoc.utilized memloc_src2),
3423 fn memloc'
3424 => MemLoc.mayAlias(memloc',memloc_dst1)))
3425 | _ => true)
3426 then let
3427 val statements
3428 = (Assembly.instruction_mov
3429 {src = src2,
3430 dst = dst1,
3431 size = size1})::
3432 (List.concat
3433 [List.map(comments, #1),
3434 [Assembly.instruction_pmd
3435 {oper = oper2,
3436 src = src1,
3437 dst = dst2,
3438 size = size2}]])
3439
3440 val {statements, ...}
3441 = LivenessBlock.toLivenessStatements
3442 {statements = statements,
3443 live = liveOut2}
3444
3445 val statements
3446 = List.fold(start,
3447 List.concat [statements,
3448 finish],
3449 op ::)
3450 in
3451 SOME (LivenessBlock.T
3452 {entry = entry,
3453 profileLabel = profileLabel,
3454 statements = statements,
3455 transfer = transfer})
3456 end
3457 else NONE
3458 | {entry,
3459 profileLabel,
3460 start,
3461 statements =
3462 [[(Assembly.Instruction (Instruction.MOV
3463 {src = src1,
3464 dst
3465 = dst1 as Operand.MemLoc memloc_dst1,
3466 size = size1}),
3467 Liveness.T {dead = dead1,...})],
3468 comments,
3469 [(Assembly.Instruction (Instruction.IMUL2
3470 {src = src2,
3471 dst
3472 = dst2 as Operand.MemLoc _,
3473 size = size2}),
3474 Liveness.T {dead = dead2,
3475 liveOut = liveOut2,...})]],
3476 finish,
3477 transfer}
3478 => if Size.eq(size1,size2) andalso
3479 Operand.eq(dst1,dst2) andalso
3480 not (Operand.eq(src1,src2)) andalso
3481 (case (src1,src2)
3482 of (Operand.MemLoc memloc_src1,
3483 Operand.MemLoc memloc_src2)
3484 => LiveSet.contains(dead2,
3485 memloc_src2)
3486 andalso
3487 not (LiveSet.contains(dead1,
3488 memloc_src1))
3489 | (_, Operand.MemLoc memloc_src2)
3490 => LiveSet.contains(dead2,
3491 memloc_src2)
3492 | _ => false) andalso
3493 (case src1
3494 of Operand.MemLoc memloc_src1
3495 => not (List.exists
3496 (memloc_src1::(MemLoc.utilized memloc_src1),
3497 fn memloc'
3498 => MemLoc.mayAlias(memloc',memloc_dst1)))
3499 | _ => true) andalso
3500 (case src2
3501 of Operand.MemLoc memloc_src2
3502 => not (List.exists
3503 (memloc_src2::(MemLoc.utilized memloc_src2),
3504 fn memloc'
3505 => MemLoc.mayAlias(memloc',memloc_dst1)))
3506 | _ => true)
3507 then let
3508 val statements
3509 = (Assembly.instruction_mov
3510 {src = src2,
3511 dst = dst1,
3512 size = size1})::
3513 (List.concat
3514 [List.map(comments, #1),
3515 [Assembly.instruction_imul2
3516 {src = src1,
3517 dst = dst2,
3518 size = size2}]])
3519
3520 val {statements, ...}
3521 = LivenessBlock.toLivenessStatements
3522 {statements = statements,
3523 live = liveOut2}
3524
3525 val statements
3526 = List.fold(start,
3527 List.concat [statements,
3528 finish],
3529 op ::)
3530 in
3531 SOME (LivenessBlock.T
3532 {entry = entry,
3533 profileLabel = profileLabel,
3534 statements = statements,
3535 transfer = transfer})
3536 end
3537 else NONE
3538 | _ => Error.bug "x86Simplify.PeeholeBlock: commuteBinALMD"
3539
3540 val (callback,commuteBinALMD_msg)
3541 = make_callback_msg "commuteBinALMD"
3542 in
3543 val commuteBinALMD : optimization
3544 = {template = template,
3545 rewriter = rewriter,
3546 callback = callback}
3547 val commuteBinALMD_msg = commuteBinALMD_msg
3548 end
3549
3550 local
3551 val isInstructionFMOV_dstTemp : statement_type -> bool
3552 = fn (Assembly.Instruction (Instruction.pFMOV
3553 {dst = Operand.MemLoc memloc,...}),
3554 _)
3555 => x86Liveness.track memloc
3556 | _ => false
3557
3558 val isInstructionFltA_dstTemp : statement_type -> bool
3559 = fn (Assembly.Instruction (Instruction.pFBinA
3560 {dst = Operand.MemLoc memloc,...}),
3561 _)
3562 => x86Liveness.track memloc
3563 | (Assembly.Instruction (Instruction.pFUnA
3564 {dst = Operand.MemLoc memloc,...}),
3565
3566 _)
3567 => x86Liveness.track memloc
3568 | (Assembly.Instruction (Instruction.pFPTAN
3569 {dst = Operand.MemLoc memloc,...}),
3570
3571 _)
3572 => x86Liveness.track memloc
3573 | (Assembly.Instruction (Instruction.pFBinAS
3574 {dst = Operand.MemLoc memloc,...}),
3575 _)
3576 => x86Liveness.track memloc
3577 | (Assembly.Instruction (Instruction.pFBinASP
3578 {dst = Operand.MemLoc memloc,...}),
3579 _)
3580 => x86Liveness.track memloc
3581 | _ => false
3582
3583 val isInstructionFMOV_srcTemp_srcDead : statement_type -> bool
3584 = fn (Assembly.Instruction (Instruction.pFMOV
3585 {src = Operand.MemLoc memloc,...}),
3586 Liveness.T {dead,...})
3587 => x86Liveness.track memloc
3588 andalso
3589 LiveSet.contains(dead, memloc)
3590 | _ => false
3591
3592 val template : template
3593 = {start = EmptyOrNonEmpty,
3594 statements = [One isInstructionFMOV_dstTemp,
3595 All (fn asm
3596 => (isComment asm)
3597 orelse
3598 (isInstructionFltA_dstTemp asm)),
3599 One isInstructionFMOV_srcTemp_srcDead],
3600 finish = EmptyOrNonEmpty,
3601 transfer = fn _ => true}
3602
3603 val rewriter : rewriter
3604 = fn {entry,
3605 profileLabel,
3606 start,
3607 statements =
3608 [[(Assembly.Instruction (Instruction.pFMOV
3609 {src = src1,
3610 dst = dst1 as Operand.MemLoc memloc1,
3611 size = size1}),
3612 _)],
3613 statements',
3614 [(Assembly.Instruction (Instruction.pFMOV
3615 {src = Operand.MemLoc memloc2,
3616 dst = dst2,
3617 size = size2}),
3618 Liveness.T {liveOut = liveOut2,...})]],
3619 finish,
3620 transfer}
3621 => if Size.eq(size1,size2) andalso
3622 MemLoc.eq(memloc1,memloc2) andalso
3623 List.forall
3624 (statements',
3625 fn (Assembly.Comment _, _) => true
3626 | (Assembly.Instruction (Instruction.pFBinA
3627 {src,
3628 dst = Operand.MemLoc memloc,
3629 size,
3630 ...}),
3631 _)
3632 => Size.eq(size1,size) andalso
3633 MemLoc.eq(memloc1,memloc) andalso
3634 (case (src,dst2)
3635 of (Operand.MemLoc memloc_src,
3636 Operand.MemLoc memloc_dst2)
3637 => List.forall
3638 (memloc_src::(MemLoc.utilized memloc_src),
3639 fn memloc'
3640 => not (MemLoc.mayAlias(memloc_dst2,memloc')))
3641 | (Operand.Immediate _, _) => true
3642 | _ => false)
3643 | (Assembly.Instruction (Instruction.pFUnA
3644 {dst = Operand.MemLoc memloc,
3645 size,
3646 ...}),
3647 _)
3648 => Size.eq(size1,size) andalso
3649 MemLoc.eq(memloc1,memloc)
3650 | (Assembly.Instruction (Instruction.pFPTAN
3651 {dst = Operand.MemLoc memloc,
3652 size}),
3653 _)
3654 => Size.eq(size1,size) andalso
3655 MemLoc.eq(memloc1,memloc)
3656 | (Assembly.Instruction (Instruction.pFBinAS
3657 {src,
3658 dst = Operand.MemLoc memloc,
3659 size,
3660 ...}),
3661 _)
3662 => Size.eq(size1,size) andalso
3663 MemLoc.eq(memloc1,memloc) andalso
3664 (case (src,dst2)
3665 of (Operand.MemLoc memloc_src,
3666 Operand.MemLoc memloc_dst2)
3667 => List.forall
3668 (memloc_src::(MemLoc.utilized memloc_src),
3669 fn memloc'
3670 => not (MemLoc.mayAlias(memloc_dst2,memloc')))
3671 | (Operand.Immediate _, _) => true
3672 | _ => false)
3673 | (Assembly.Instruction (Instruction.pFBinASP
3674 {src,
3675 dst = Operand.MemLoc memloc,
3676 size,
3677 ...}),
3678 _)
3679 => Size.eq(size1,size) andalso
3680 MemLoc.eq(memloc1,memloc) andalso
3681 (case (src,dst2)
3682 of (Operand.MemLoc memloc_src,
3683 Operand.MemLoc memloc_dst2)
3684 => List.forall
3685 (memloc_src::(MemLoc.utilized memloc_src),
3686 fn memloc'
3687 => not (MemLoc.mayAlias(memloc_dst2,memloc')))
3688 | (Operand.Immediate _, _) => true
3689 | _ => false)
3690 | _ => Error.bug "x86Simplify.PeeholeBlock: elimFltACopy")
3691 then let
3692 val statements
3693 = List.map
3694 (statements',
3695 fn (asm,_)
3696 => Assembly.replace
3697 (fn {...}
3698 => fn operand
3699 => if Operand.eq(operand,dst1)
3700 then dst2
3701 else operand)
3702 asm)
3703
3704 val {statements, ...}
3705 = LivenessBlock.toLivenessStatements
3706 {statements
3707 = (Assembly.instruction_pfmov
3708 {src = src1,
3709 dst = dst2,
3710 size = size1})::statements,
3711 live = liveOut2}
3712
3713 val statements
3714 = List.fold(start,
3715 List.concat [statements,
3716 finish],
3717 op ::)
3718 in
3719 SOME (LivenessBlock.T
3720 {entry = entry,
3721 profileLabel = profileLabel,
3722 statements = statements,
3723 transfer = transfer})
3724 end
3725 else NONE
3726 | _ => Error.bug "x86Simplify.PeeholeBlock: elimFltACopy"
3727
3728 val (callback,elimFltACopy_msg)
3729 = make_callback_msg "elimFltACopy"
3730 in
3731 val elimFltACopy : optimization
3732 = {template = template,
3733 rewriter = rewriter,
3734 callback = callback}
3735 val elimFltACopy_msg = elimFltACopy_msg
3736 end
3737
3738 local
3739 val isInstructionFMOV_eqSrcDst : statement_type -> bool
3740 = fn (Assembly.Instruction (Instruction.pFMOV
3741 {dst = Operand.MemLoc memloc1,
3742 src = Operand.MemLoc memloc2,...}),
3743 _)
3744 => MemLoc.eq(memloc1,memloc2)
3745 | _ => false
3746
3747 val template : template
3748 = {start = EmptyOrNonEmpty,
3749 statements = [One isInstructionFMOV_eqSrcDst],
3750 finish = EmptyOrNonEmpty,
3751 transfer = fn _ => true}
3752
3753 val rewriter : rewriter
3754 = fn {entry,
3755 profileLabel,
3756 start,
3757 statements =
3758 [[(Assembly.Instruction (Instruction.pFMOV
3759 {...}),
3760 _)]],
3761 finish,
3762 transfer}
3763 => let
3764 val statements
3765 = List.fold
3766 (start,
3767 finish,
3768 op ::)
3769 in
3770 SOME (LivenessBlock.T
3771 {entry = entry,
3772 profileLabel = profileLabel,
3773 statements = statements,
3774 transfer = transfer})
3775 end
3776 | _ => Error.bug "x86Simplify.PeeholeBlock: elimFltSelfMove"
3777
3778 val (callback,elimFltSelfMove_msg)
3779 = make_callback_msg "elimFltSelfMove"
3780 in
3781 val elimFltSelfMove : optimization
3782 = {template = template,
3783 rewriter = rewriter,
3784 callback = callback}
3785 val elimFltSelfMove_msg = elimFltSelfMove_msg
3786 end
3787
3788 local
3789 val isInstructionFMOV_dstMemloc : statement_type -> bool
3790 = fn (Assembly.Instruction (Instruction.pFMOV
3791 {dst = Operand.MemLoc _,...}),
3792 _)
3793 => true
3794 | _ => false
3795
3796 val isInstructionFltBinA_dstMemloc : statement_type -> bool
3797 = fn (Assembly.Instruction (Instruction.pFBinA
3798 {dst = Operand.MemLoc _,...}),
3799 _)
3800 => true
3801 | _ => false
3802
3803 val template : template
3804 = {start = EmptyOrNonEmpty,
3805 statements = [One isInstructionFMOV_dstMemloc,
3806 All isComment,
3807 One isInstructionFltBinA_dstMemloc],
3808 finish = EmptyOrNonEmpty,
3809 transfer = fn _ => true}
3810
3811 val rewriter : rewriter
3812 = fn {entry,
3813 profileLabel,
3814 start,
3815 statements =
3816 [[(Assembly.Instruction (Instruction.pFMOV
3817 {src = src1,
3818 dst
3819 = dst1 as Operand.MemLoc memloc_dst1,
3820 size = size1}),
3821 Liveness.T {dead = dead1,...})],
3822 comments,
3823 [(Assembly.Instruction (Instruction.pFBinA
3824 {oper = oper2,
3825 src = src2,
3826 dst
3827 = dst2 as Operand.MemLoc _,
3828 size = size2}),
3829 Liveness.T {dead = dead2,
3830 liveOut = liveOut2,...})]],
3831 finish,
3832 transfer}
3833 => if Size.eq(size1,size2) andalso
3834 Operand.eq(dst1,dst2) andalso
3835 not (Operand.eq(src1, src2)) andalso
3836 (case (src1,src2)
3837 of (Operand.MemLoc memloc_src1,
3838 Operand.MemLoc memloc_src2)
3839 => LiveSet.contains(dead2,
3840 memloc_src2)
3841 andalso
3842 not (LiveSet.contains(dead1,
3843 memloc_src1))
3844 | (_, Operand.MemLoc memloc_src2)
3845 => LiveSet.contains(dead2,
3846 memloc_src2)
3847 | _ => false) andalso
3848 (case src1
3849 of Operand.MemLoc memloc_src1
3850 => not (List.exists
3851 (memloc_src1::(MemLoc.utilized memloc_src1),
3852 fn memloc'
3853 => MemLoc.mayAlias(memloc',memloc_dst1)))
3854 | _ => true) andalso
3855 (case src2
3856 of Operand.MemLoc memloc_src2
3857 => not (List.exists
3858 (memloc_src2::(MemLoc.utilized memloc_src2),
3859 fn memloc'
3860 => MemLoc.mayAlias(memloc',memloc_dst1)))
3861 | _ => true)
3862 then let
3863 val statements
3864 = (Assembly.instruction_pfmov
3865 {src = src2,
3866 dst = dst1,
3867 size = size1})::
3868 (List.concat
3869 [List.map(comments, #1),
3870 [Assembly.instruction_pfbina
3871 {oper = Instruction.fbina_reverse oper2,
3872 src = src1,
3873 dst = dst2,
3874 size = size2}]])
3875
3876 val {statements, ...}
3877 = LivenessBlock.toLivenessStatements
3878 {statements = statements,
3879 live = liveOut2}
3880
3881 val statements
3882 = List.fold(start,
3883 List.concat [statements,
3884 finish],
3885 op ::)
3886 in
3887 SOME (LivenessBlock.T
3888 {entry = entry,
3889 profileLabel = profileLabel,
3890 statements = statements,
3891 transfer = transfer})
3892 end
3893 else NONE
3894 | _ => Error.bug "x86Simplify.PeeholeBlock: commuteFltBinA"
3895
3896 val (callback,commuteFltBinA_msg)
3897 = make_callback_msg "commuteFltBinA"
3898 in
3899 val commuteFltBinA : optimization
3900 = {template = template,
3901 rewriter = rewriter,
3902 callback = callback}
3903 val commuteFltBinA_msg = commuteFltBinA_msg
3904 end
3905
3906 local
3907 val isInstructionSETcc : statement_type -> bool
3908 = fn (Assembly.Instruction (Instruction.SETcc
3909 {...}),
3910 _)
3911 => true
3912 | _ => false
3913
3914 val isInstructionTEST_eqSrcs : statement_type -> bool
3915 = fn (Assembly.Instruction (Instruction.TEST
3916 {src1 = Operand.MemLoc memloc1,
3917 src2 = Operand.MemLoc memloc2,...}),
3918 Liveness.T {...})
3919 => MemLoc.eq(memloc1, memloc2)
3920 | _ => false
3921
3922 val isIff_conditionZorNZ : transfer_type -> bool
3923 = fn (Transfer.Iff {condition,...},
3924 _)
3925 => (case condition
3926 of Instruction.Z => true
3927 | Instruction.NZ => true
3928 | _ => false)
3929 | _ => false
3930
3931 val template : template
3932 = {start = EmptyOrNonEmpty,
3933 statements = [One isInstructionSETcc,
3934 All isComment,
3935 One isInstructionTEST_eqSrcs,
3936 All isComment],
3937 finish = Empty,
3938 transfer = isIff_conditionZorNZ}
3939
3940 val rewriter : rewriter
3941 = fn {entry,
3942 profileLabel,
3943 start,
3944 statements =
3945 [[(statement as
3946 Assembly.Instruction (Instruction.SETcc
3947 {condition = condition1,
3948 dst
3949 = Operand.MemLoc memloc1,
3950 ...}),
3951 _)],
3952 comments1,
3953 [(Assembly.Instruction (Instruction.TEST
3954 {src1
3955 = Operand.MemLoc memloc12,
3956 ...}),
3957 Liveness.T {dead, ...})],
3958 comments2],
3959 finish = [],
3960 transfer =
3961 (Transfer.Iff {condition, truee, falsee},
3962 infoT as _)}
3963 => if MemLoc.eq(memloc1,memloc12)
3964 then let
3965 val condition
3966 = case condition
3967 of Instruction.Z
3968 => Instruction.condition_negate condition1
3969 | Instruction.NZ => condition1
3970 | _ => Error.bug "x86Simplify.PeeholeBlock: conditionalJump:condition"
3971
3972 val transfer
3973 = (Transfer.iff {condition = condition,
3974 truee = truee,
3975 falsee = falsee},
3976 infoT)
3977
3978 val {transfer,live}
3979 = LivenessBlock.reLivenessTransfer
3980 {transfer = transfer}
3981
3982 val statements
3983 = List.concat
3984 [List.map(comments1, #1),
3985 List.map(comments2, #1)]
3986 val statements
3987 = if x86Liveness.track memloc1 andalso
3988 LiveSet.contains(dead, memloc1)
3989 then statements
3990 else statement::statements
3991
3992 val {statements, ...}
3993 = LivenessBlock.toLivenessStatements
3994 {statements = statements,
3995 live = live}
3996
3997 val statements
3998 = List.fold(start,
3999 statements,
4000 op ::)
4001
4002 val live
4003 = case statements
4004 of (_, Liveness.T {liveIn,...})::_ => liveIn
4005 | _ => Error.bug "x86Simplify.PeeholeBlock: conditionalJump:live"
4006
4007 val {entry, ...}
4008 = LivenessBlock.reLivenessEntry
4009 {entry = entry,
4010 live = live}
4011 in
4012 SOME (LivenessBlock.T
4013 {entry = entry,
4014 profileLabel = profileLabel,
4015 statements = statements,
4016 transfer = transfer})
4017 end
4018 else NONE
4019 | _ => Error.bug "x86Simplify.PeeholeBlock: conditionalJump"
4020
4021 val (callback,conditionalJump_msg)
4022 = make_callback_msg "conditionalJump"
4023 in
4024 val conditionalJump : optimization
4025 = {template = template,
4026 rewriter = rewriter,
4027 callback = callback}
4028 val conditionalJump_msg = conditionalJump_msg
4029 end
4030
4031 local
4032 val {template, rewriter, ...} = elimDeadDsts
4033 val (callback,elimDeadDsts_minor_msg)
4034 = make_callback_msg "elimDeadDsts_minor"
4035 in
4036 val elimDeadDsts_minor : optimization
4037 = {template = template,
4038 rewriter = rewriter,
4039 callback = callback}
4040 val elimDeadDsts_minor_msg = elimDeadDsts_minor_msg
4041 end
4042
4043 local
4044 val {template, rewriter, ...} = elimSelfMove
4045 val (callback,elimSelfMove_minor_msg)
4046 = make_callback_msg "elimSelfMove_minor"
4047 in
4048 val elimSelfMove_minor : optimization
4049 = {template = template,
4050 rewriter = rewriter,
4051 callback = callback}
4052 val elimSelfMove_minor_msg = elimSelfMove_minor_msg
4053 end
4054
4055 local
4056 val {template, rewriter, ...} = elimFltSelfMove
4057 val (callback,elimFltSelfMove_minor_msg)
4058 = make_callback_msg "elimFltSelfMove_minor"
4059 in
4060 val elimFltSelfMove_minor : optimization
4061 = {template = template,
4062 rewriter = rewriter,
4063 callback = callback}
4064 val elimFltSelfMove_minor_msg = elimFltSelfMove_minor_msg
4065 end
4066
4067 local
4068 val optimizations
4069 = elimALCopy::
4070 elimFltACopy::
4071 elimDeadDsts::
4072 elimSelfMove::
4073 elimFltSelfMove::
4074 commuteBinALMD::
4075 commuteFltBinA::
4076 conditionalJump::
4077 nil
4078 val optimizations_msg
4079 = elimALCopy_msg::
4080 elimFltACopy_msg::
4081 elimDeadDsts_msg::
4082 elimSelfMove_msg::
4083 elimFltSelfMove_msg::
4084 commuteBinALMD_msg::
4085 commuteFltBinA_msg::
4086 conditionalJump_msg::
4087 nil
4088
4089 val optimizations_minor
4090 = elimDeadDsts_minor::
4091 elimSelfMove_minor::
4092 elimFltSelfMove_minor::
4093 nil
4094 val optimizations_minor_msg
4095 = elimDeadDsts_minor_msg::
4096 elimSelfMove_minor_msg::
4097 elimFltSelfMove_minor_msg::
4098 nil
4099 in
4100 val peepholeLivenessBlock
4101 = fn block => (peepholeBlock {optimizations = optimizations,
4102 block = block})
4103
4104 val (peepholeLivenessBlock, peepholeLivenessBlock_msg)
4105 = tracer
4106 "peepholeLivenessBlock"
4107 peepholeLivenessBlock
4108
4109 val peepholeLivenessBlock_msg
4110 = fn () => (peepholeLivenessBlock_msg ();
4111 Control.indent ();
4112 List.foreach(optimizations_msg, fn msg => msg ());
4113 Control.unindent ())
4114
4115 val peepholeLivenessBlock_minor
4116 = fn block => (peepholeBlock {optimizations = optimizations_minor,
4117 block = block})
4118
4119 val (peepholeLivenessBlock_minor, peepholeLivenessBlock_minor_msg)
4120 = tracer
4121 "peepholeLivenessBlock_minor"
4122 peepholeLivenessBlock_minor
4123
4124 val peepholeLivenessBlock_minor_msg
4125 = fn () => (peepholeLivenessBlock_minor_msg ();
4126 Control.indent ();
4127 List.foreach(optimizations_minor_msg, fn msg => msg ());
4128 Control.unindent ())
4129 end
4130 end
4131
4132 fun simplify {chunk : Chunk.t,
4133 optimize : int,
4134 delProfileLabel : x86.ProfileLabel.t -> unit,
4135 liveInfo : x86Liveness.LiveInfo.t,
4136 jumpInfo : x86JumpInfo.t} :
4137 Chunk.t
4138 = let
4139(*
4140 fun changedChunk_msg
4141 {chunk as Chunk.T {blocks, ...}, changed, msg}
4142 = (print ("finished " ^ msg ^ "\n"))
4143 fun changedBlock_msg
4144 {block as Block.T {entry, ...}, changed, msg}
4145 = (print ("finished " ^ msg ^ "\n"))
4146 fun changedLivenessBlock_msg
4147 {block as x86Liveness.LivenessBlock.T {entry, ...}, changed, msg}
4148 = if changed then (print ("finished " ^ msg ^ "\n")) else ()
4149*)
4150
4151 fun changedChunk_msg
4152 {chunk = Chunk.T {blocks, ...}, changed, msg}
4153 = if not changed then () else
4154 (print (String.make (60, #"*"));
4155 print "\n";
4156 print msg;
4157 print "\n";
4158 List.foreach(blocks,
4159 fn b as Block.T {entry, ...}
4160 => (print (concat
4161 ["liveIn: ",
4162 (concat o List.separate)
4163 (List.map
4164 (x86Liveness.LiveSet.toList
4165 (x86Liveness.LiveInfo.getLive
4166 (liveInfo, Entry.label entry)),
4167 fn memloc => MemLoc.toString memloc),
4168 "\n "),
4169 "\n"]);
4170 x86.Block.printBlock b)))
4171
4172 fun changedBlock_msg
4173 {block as Block.T {entry, ...}, changed, msg}
4174 = if not changed then () else
4175 (print (String.make (60, #"*"));
4176 print "\n";
4177 print msg;
4178 print "\n";
4179 (print (concat
4180 ["liveIn: ",
4181 (concat o List.separate)
4182 (List.map
4183 (x86Liveness.LiveSet.toList
4184 (x86Liveness.LiveInfo.getLive
4185 (liveInfo, Entry.label entry)),
4186 fn memloc => MemLoc.toString memloc),
4187 "\n "),
4188 "\n"]);
4189 x86.Block.printBlock block))
4190
4191 fun changedLivenessBlock_msg
4192 {block as x86Liveness.LivenessBlock.T {entry, ...}, changed, msg}
4193 = if not changed then () else
4194 (print (String.make (60, #"*"));
4195 print "\n";
4196 print msg;
4197 print "\n";
4198 (print (concat
4199 ["liveIn: ",
4200 (concat o List.separate)
4201 (List.map
4202 (x86Liveness.LiveSet.toList
4203 (x86Liveness.LiveInfo.getLive
4204 (liveInfo, Entry.label (#1 entry))),
4205 fn memloc => MemLoc.toString memloc),
4206 "\n "),
4207 "\n"]);
4208 x86Liveness.LivenessBlock.printBlock block))
4209
4210 val debug = false
4211 val changedChunk_msg : {chunk : Chunk.t, changed: bool, msg: string} -> unit =
4212 if debug then changedChunk_msg else (fn _ => ())
4213 val changedBlock_msg : {block : Block.t, changed: bool, msg: string} -> unit =
4214 if debug then changedBlock_msg else (fn _ => ())
4215 val changedLivenessBlock_msg : {block : x86Liveness.LivenessBlock.t, changed: bool, msg: string} -> unit =
4216 if debug then changedLivenessBlock_msg else (fn _ => ())
4217
4218 fun checkLivenessBlock
4219 {block, block', msg}
4220 = Assert.assert
4221 ("x86Simplify.checkLivenessBlock: " ^ msg,
4222 fn () => if x86Liveness.LivenessBlock.verifyLivenessBlock
4223 {block = block,
4224 liveInfo = liveInfo}
4225 then true
4226 else (print ("pre: " ^ msg);
4227 x86Liveness.LivenessBlock.printBlock block;
4228 print (String.make(60, #"*"));
4229 print ("\n");
4230 print ("post: " ^ msg);
4231 x86Liveness.LivenessBlock.printBlock block';
4232 print (String.make(60, #"*"));
4233 print ("\n");
4234 false))
4235
4236 (*********************************************************************)
4237 (* simplify *)
4238 (*********************************************************************)
4239
4240 val _ = changedChunk_msg
4241 {chunk = chunk,
4242 changed = false,
4243 msg = "simplify:"}
4244
4245 (*********************************************************************)
4246 (* completeLiveInfo *)
4247 (*********************************************************************)
4248 val _ = x86Liveness.LiveInfo.completeLiveInfo
4249 {chunk = chunk,
4250 liveInfo = liveInfo,
4251 pass = "pre"}
4252
4253 val _ = changedChunk_msg
4254 {chunk = chunk,
4255 changed = false,
4256 msg = "completeLiveInfo (pre):"}
4257
4258 (*********************************************************************)
4259 (* completeJumpInfo *)
4260 (*********************************************************************)
4261 val _ = x86JumpInfo.completeJumpInfo
4262 {chunk = chunk,
4263 jumpInfo = jumpInfo}
4264
4265 val _
4266 = Assert.assert
4267 ("x86Simplify.verifyEntryTransfer",
4268 fn () => x86EntryTransfer.verifyEntryTransfer
4269 {chunk = chunk})
4270
4271 (*********************************************************************)
4272 (* optimizer *)
4273 (*********************************************************************)
4274 fun optimizer chunk
4275 = let
4276 val chunk = chunk
4277 val changed = false
4278
4279 (**************************************************************)
4280 (* elimGoto *)
4281 (**************************************************************)
4282 val {chunk = chunk',
4283 changed = changed'}
4284 = ElimGoto.elimGoto {chunk = chunk,
4285 delProfileLabel = delProfileLabel,
4286 jumpInfo = jumpInfo}
4287
4288 val _
4289 = Assert.assert
4290 ("x86Simplify.verifyJumpInfo",
4291 fn () => x86JumpInfo.verifyJumpInfo
4292 {chunk = chunk',
4293 jumpInfo = jumpInfo})
4294
4295 val _
4296 = Assert.assert
4297 ("x86Simplify.verifyEntryTransfer",
4298 fn () => x86EntryTransfer.verifyEntryTransfer
4299 {chunk = chunk'})
4300
4301 val _ = changedChunk_msg
4302 {chunk = chunk,
4303 changed = changed',
4304 msg = "ElimGoto.elimGoto:"}
4305 val chunk = chunk'
4306 val changed = changed orelse changed'
4307
4308 (**************************************************************)
4309 (* peepholeBlock/moveHoist/peepholeLivenessBlock/copyPropagate*)
4310 (**************************************************************)
4311 val Chunk.T {data, blocks} = chunk
4312 val {blocks = blocks',
4313 changed = changed'}
4314 = List.fold
4315 (blocks,
4316 {blocks = [], changed = false},
4317 fn (block, {blocks, changed})
4318 => let
4319 val _ = changedBlock_msg
4320 {block = block,
4321 changed = false,
4322 msg = "peepholeBlock/moveHoist/peepholeLivenessBlock/copyPropagate"}
4323 (***************************************************)
4324 (* peepholeBlock_pre *)
4325 (***************************************************)
4326 val {block = block',
4327 changed = changed'}
4328 = PeepholeBlock.peepholeBlock_pre block
4329
4330 val _ = changedBlock_msg
4331 {block = block',
4332 changed = changed',
4333 msg = "PeepholeBlock.peepholeBlock_pre"}
4334 val block = block'
4335 val changed = changed orelse changed'
4336
4337 (***************************************************)
4338 (* toLivenessBlock *)
4339 (***************************************************)
4340 val block'
4341 = x86Liveness.LivenessBlock.toLivenessBlock
4342 {block = block,
4343 liveInfo = liveInfo}
4344
4345 val block = block'
4346 val _ = changedLivenessBlock_msg
4347 {block = block',
4348 changed = false,
4349 msg = "x86Liveness.LivenessBlock.toLivenessBlock"}
4350
4351 (***************************************************)
4352 (* moveHoist *)
4353 (***************************************************)
4354 val {block = block',
4355 changed = changed'}
4356 = if !Control.Native.moveHoist
4357 then MoveHoistLivenessBlock.moveHoist
4358 {block = block}
4359 else {block = block,
4360 changed = false}
4361
4362 val _ = checkLivenessBlock
4363 {block = block,
4364 block' = block',
4365 msg = "MoveHoistLivenessBlock.moveHoist"}
4366
4367 val _ = changedLivenessBlock_msg
4368 {block = block',
4369 changed = changed',
4370 msg = "MoveHoistLivenessBlock.moveHoist"}
4371 val block = block'
4372 val changed = changed orelse changed'
4373
4374 (***************************************************)
4375 (* peepholeLivenessBlock *)
4376 (***************************************************)
4377 val {block = block',
4378 changed = changed'}
4379 = PeepholeLivenessBlock.peepholeLivenessBlock block
4380
4381 val _ = checkLivenessBlock
4382 {block = block,
4383 block' = block',
4384 msg = "PeepholeLivenessBlock.peepholeLivenessBlock"}
4385
4386 val _ = changedLivenessBlock_msg
4387 {block = block',
4388 changed = changed',
4389 msg = "PeepholeLivenessBlock.peepholeLivenessBlock"}
4390 val block = block'
4391 val changed = changed orelse changed'
4392
4393 (***************************************************)
4394 (* copyPropagate *)
4395 (***************************************************)
4396 val {block = block',
4397 changed = changed'}
4398 = if !Control.Native.copyProp
4399 then CopyPropagateLivenessBlock.copyPropagate
4400 {block = block,
4401 liveInfo = liveInfo}
4402 else {block = block,
4403 changed = false}
4404
4405 val _ = checkLivenessBlock
4406 {block = block,
4407 block' = block',
4408 msg = "CopyPropagateLivenessBlock.copyPropagate"}
4409
4410 val _ = changedLivenessBlock_msg
4411 {block = block',
4412 changed = changed',
4413 msg = "CopyPropagateLivenessBlock.copyPropagate"}
4414 val block = block'
4415 val changed = changed orelse changed'
4416
4417 (***************************************************)
4418 (* peepholeLivenessBlock_minor *)
4419 (***************************************************)
4420 val {block = block',
4421 changed = changed'}
4422 = PeepholeLivenessBlock.peepholeLivenessBlock_minor block
4423
4424 val _ = checkLivenessBlock
4425 {block = block,
4426 block' = block',
4427 msg = "PeepholeLivenessBlock.peepholeLivenessBlock_minor"}
4428
4429 val _ = changedLivenessBlock_msg
4430 {block = block',
4431 changed = changed',
4432 msg = "PeepholeLivenessBlock.peepholeLivenessBlock_minor"}
4433 val block = block'
4434 val changed = changed orelse changed'
4435
4436 (***************************************************)
4437 (* toBlock *)
4438 (***************************************************)
4439 val block'
4440 = x86Liveness.LivenessBlock.toBlock {block = block}
4441
4442 val _ = changedBlock_msg
4443 {block = block',
4444 changed = false,
4445 msg = "x86Liveness.LivenessBlock.toBlock"}
4446 val block = block'
4447
4448 (***************************************************)
4449 (* peepholeBlock_post *)
4450 (***************************************************)
4451 val {block = block',
4452 changed = changed'}
4453 = PeepholeBlock.peepholeBlock_post block
4454
4455 val _ = changedBlock_msg
4456 {block = block',
4457 changed = changed',
4458 msg = "PeepholeBlock.peepholeBlock_post"}
4459 val block = block'
4460 val changed = changed orelse changed'
4461 in
4462 {blocks = block::blocks,
4463 changed = changed}
4464 end)
4465 val chunk' = Chunk.T {data = data, blocks = blocks'}
4466
4467 val _ = changedChunk_msg
4468 {chunk = chunk',
4469 changed = changed',
4470 msg = "peepholeBlock/moveHoist/peepholeLivenessBlock/copyPropagate"}
4471 val chunk = chunk'
4472 val changed = changed orelse changed'
4473
4474 (**************************************************************)
4475 (* completeLiveInfo *)
4476 (**************************************************************)
4477 val _
4478 = x86Liveness.LiveInfo.completeLiveInfo
4479 {chunk = chunk,
4480 liveInfo = liveInfo,
4481 pass = "post"}
4482
4483 val _ = changedChunk_msg
4484 {chunk = chunk,
4485 changed = false,
4486 msg = "completeLiveInfo (post):"}
4487 in
4488 {chunk = chunk,
4489 changed = changed}
4490 end
4491
4492 (*********************************************************************)
4493 (* optimizer_loop *)
4494 (*********************************************************************)
4495 fun optimizer_loop chunk
4496 = let
4497 fun loop {chunk, changed}
4498 = let
4499 val {chunk, changed = changed'}
4500 = optimizer chunk
4501 in
4502 if changed'
4503 then loop {chunk = chunk,
4504 changed = true}
4505 else {chunk = chunk,
4506 changed = changed}
4507 end
4508
4509 val {chunk, changed}
4510 = loop {chunk = chunk, changed = false}
4511 in
4512 {chunk = chunk,
4513 changed = changed}
4514 end
4515
4516
4517 (*********************************************************************)
4518 (* chunk *)
4519 (*********************************************************************)
4520 val {chunk, ...}
4521 = case optimize
4522 of 0 => {chunk = chunk, changed = false}
4523 | 1 => optimizer chunk
4524 | _ => optimizer_loop chunk
4525 in
4526 chunk
4527 end
4528
4529 val (simplify, simplify_msg)
4530 = tracerTop
4531 "simplify"
4532 simplify
4533
4534 fun simplify_totals ()
4535 = (simplify_msg ();
4536 Control.indent ();
4537 x86Liveness.LiveInfo.completeLiveInfo_msg ();
4538 x86JumpInfo.completeJumpInfo_msg ();
4539 ElimGoto.elimGoto_msg ();
4540 x86JumpInfo.verifyJumpInfo_msg ();
4541 x86EntryTransfer.verifyEntryTransfer_msg ();
4542 PeepholeBlock.peepholeBlock_pre_msg ();
4543 x86Liveness.LivenessBlock.toLivenessBlock_msg ();
4544 MoveHoistLivenessBlock.moveHoist_msg ();
4545 PeepholeLivenessBlock.peepholeLivenessBlock_msg ();
4546 CopyPropagateLivenessBlock.copyPropagate_msg ();
4547 PeepholeLivenessBlock.peepholeLivenessBlock_minor_msg ();
4548 x86Liveness.LivenessBlock.verifyLivenessBlock_msg ();
4549 x86Liveness.LivenessBlock.toBlock_msg ();
4550 PeepholeBlock.peepholeBlock_post_msg ();
4551 Control.unindent ())
4552end
mlton packaging