HCoop / hcoop / debian / mlton.git / blob
? search:
summary | shortlog | log | commit | commitdiff | tree
blame | history | raw | HEAD
Import Upstream version 20180207
[hcoop/debian/mlton.git] / mlton / codegen / amd64-codegen / amd64-generate-transfers.fun
1 (* Copyright (C) 2009 Matthew Fluet.
2 * Copyright (C) 1999-2008 Henry Cejtin, Matthew Fluet, Suresh
3 * Jagannathan, and Stephen Weeks.
4 * Copyright (C) 1997-2000 NEC Research Institute.
5 *
6 * MLton is released under a BSD-style license.
7 * See the file MLton-LICENSE for details.
8 *)
9
10 functor amd64GenerateTransfers(S: AMD64_GENERATE_TRANSFERS_STRUCTS): AMD64_GENERATE_TRANSFERS =
11 struct
12
13 open S
14 open amd64
15 open amd64JumpInfo
16 open amd64LoopInfo
17 open amd64Liveness
18 open LiveInfo
19 open Liveness
20
21 local
22 open Runtime
23 in
24 structure CFunction = CFunction
25 end
26
27 val ones : int * WordSize.t -> WordX.t
28 = fn (i, ws) => (WordX.notb o WordX.lshift)
29 (WordX.allOnes ws,
30 WordX.fromIntInf (IntInf.fromInt i, ws))
31
32 val tracerTop = amd64.tracerTop
33
34 structure amd64LiveTransfers
35 = amd64LiveTransfers(structure amd64 = amd64
36 structure amd64Liveness = amd64Liveness
37 structure amd64JumpInfo = amd64JumpInfo
38 structure amd64LoopInfo = amd64LoopInfo)
39
40 val pointerSize = amd64MLton.pointerSize
41 val wordSize = amd64MLton.wordSize
42
43 val normalRegs =
44 let
45 val transferRegs
46 =
47 (*
48 Register.rax::
49 Register.eax::
50 Register.al::
51 *)
52 Register.rbx::
53 Register.ebx::
54 Register.bl::
55 Register.rcx::
56 Register.ecx::
57 Register.cl::
58 Register.rdx::
59 Register.edx::
60 Register.dl::
61 Register.rdi::
62 Register.rsi::
63 (*
64 Register.rsp::
65 Register.rbp::
66 *)
67 Register.r8::
68 Register.r8w::
69 Register.r9::
70 Register.r9w::
71 Register.r10::
72 Register.r10w::
73 Register.r11::
74 Register.r11w::
75 (*
76 Register.r12::
77 Register.r12w::
78 *)
79 Register.r13::
80 Register.r13w::
81 Register.r14::
82 Register.r14w::
83 Register.r15::
84 Register.r15w::
85 nil
86
87 val transferXmmRegs =
88 XmmRegister.xmm1D::
89 XmmRegister.xmm1S::
90 XmmRegister.xmm2D::
91 XmmRegister.xmm2S::
92 XmmRegister.xmm3D::
93 XmmRegister.xmm3S::
94 XmmRegister.xmm4D::
95 XmmRegister.xmm4S::
96 XmmRegister.xmm5D::
97 XmmRegister.xmm5S::
98 XmmRegister.xmm6D::
99 XmmRegister.xmm6S::
100 XmmRegister.xmm7D::
101 XmmRegister.xmm7S::
102 nil
103 in
104 {frontierReg = Register.r12,
105 stackTopReg = Register.rbp,
106 transferRegs = fn Entry.Jump _ => transferRegs
107 | Entry.CReturn _ => Register.rax::Register.eax::Register.al::transferRegs
108 | _ => [],
109 transferXmmRegs = fn Entry.Jump _ => transferXmmRegs
110 | Entry.CReturn _ => XmmRegister.xmm0D::XmmRegister.xmm0S::transferXmmRegs
111 | _ => []}
112 end
113
114 val reserveRspRegs =
115 let
116 val transferRegs
117 =
118 (*
119 Register.rax::
120 Register.eax::
121 Register.al::
122 *)
123 Register.rbx::
124 Register.ebx::
125 Register.bl::
126 Register.rcx::
127 Register.ecx::
128 Register.cl::
129 Register.rdx::
130 Register.edx::
131 Register.dl::
132 Register.rdi::
133 Register.rsi::
134 (*
135 Register.rsp::
136 Register.rbp::
137 *)
138 Register.r8::
139 Register.r8w::
140 Register.r9::
141 Register.r9w::
142 Register.r10::
143 Register.r10w::
144 Register.r11::
145 Register.r11w::
146 (*
147 Register.r12::
148 Register.r12w::
149 *)
150 Register.r13::
151 Register.r13w::
152 Register.r14::
153 Register.r14w::
154 Register.r15::
155 Register.r15w::
156 nil
157
158 val transferXmmRegs =
159 XmmRegister.xmm8D::
160 XmmRegister.xmm8S::
161 XmmRegister.xmm9D::
162 XmmRegister.xmm9S::
163 XmmRegister.xmm10D::
164 XmmRegister.xmm10S::
165 XmmRegister.xmm11D::
166 XmmRegister.xmm11S::
167 XmmRegister.xmm12D::
168 XmmRegister.xmm12S::
169 XmmRegister.xmm13D::
170 XmmRegister.xmm13S::
171 XmmRegister.xmm14D::
172 XmmRegister.xmm14S::
173 nil
174 in
175 {frontierReg = Register.r12,
176 stackTopReg = Register.rbp,
177 transferRegs = fn Entry.Jump _ => transferRegs
178 | Entry.CReturn _ => Register.rax::Register.eax::Register.al::transferRegs
179 | _ => [],
180 transferXmmRegs = fn Entry.Jump _ => transferXmmRegs
181 | Entry.CReturn _ => XmmRegister.xmm0D::XmmRegister.xmm0S::transferXmmRegs
182 | _ => []}
183 end
184
185 val indexReg = amd64.Register.rax
186
187 val stackTop = amd64MLton.gcState_stackTopContents
188 val frontier = amd64MLton.gcState_frontierContents
189
190 datatype gef = GEF of {generate : gef ->
191 {label : Label.t,
192 falling : bool,
193 unique : bool} ->
194 Assembly.t AppendList.t,
195 effect : gef ->
196 {label : Label.t,
197 transfer : Transfer.t} ->
198 Assembly.t AppendList.t,
199 fall : gef ->
200 {label : Label.t,
201 live : LiveSet.t} ->
202 Assembly.t AppendList.t}
203
204 fun generateTransfers {chunk as Chunk.T {data, blocks, ...},
205 optimize: int,
206 newProfileLabel: amd64.ProfileLabel.t -> amd64.ProfileLabel.t,
207 liveInfo : amd64Liveness.LiveInfo.t,
208 jumpInfo : amd64JumpInfo.t,
209 reserveRsp: bool}
210 = let
211 val {frontierReg, stackTopReg, transferRegs, transferXmmRegs} =
212 if reserveRsp
213 then reserveRspRegs
214 else normalRegs
215 val allClasses = !amd64MLton.Classes.allClasses
216 val livenessClasses = !amd64MLton.Classes.livenessClasses
217 val livenessClasses = ClassSet.+(livenessClasses,
218 ClassSet.fromList
219 [amd64MLton.Classes.StaticNonTemp,
220 amd64MLton.Classes.CArg])
221 val nonlivenessClasses = ClassSet.-(allClasses, livenessClasses)
222 val holdClasses = !amd64MLton.Classes.holdClasses
223 val farflushClasses = ClassSet.-(nonlivenessClasses, holdClasses)
224 val nearflushClasses = ClassSet.-(nonlivenessClasses, holdClasses)
225 val runtimeClasses = !amd64MLton.Classes.runtimeClasses
226 val cstaticClasses = !amd64MLton.Classes.cstaticClasses
227 val heapClasses = !amd64MLton.Classes.heapClasses
228 val ccallflushClasses = ClassSet.+(cstaticClasses, heapClasses)
229
230 fun removeHoldMemLocs memlocs
231 = MemLocSet.subset
232 (memlocs,
233 fn m => not (ClassSet.contains(holdClasses, MemLoc.class m)))
234
235 val stackAssume = {register = stackTopReg,
236 memloc = stackTop (),
237 weight = 1024,
238 sync = false,
239 reserve = false}
240 val frontierAssume = {register = frontierReg,
241 memloc = frontier (),
242 weight = 2048,
243 sync = false,
244 reserve = false}
245 val cStackAssume = {register = Register.rsp,
246 memloc = amd64MLton.c_stackPContents,
247 weight = 2048, (* ??? *)
248 sync = false,
249 reserve = true}
250
251 fun blockAssumes l =
252 let
253 val l = frontierAssume :: stackAssume :: l
254 in
255 Assembly.directive_assume {assumes = if reserveRsp
256 then cStackAssume :: l
257 else l}
258 end
259
260 fun runtimeTransfer live setup trans
261 = AppendList.appends
262 [AppendList.single
263 (Assembly.directive_force
264 {commit_memlocs = removeHoldMemLocs live,
265 commit_classes = ClassSet.empty,
266 remove_memlocs = MemLocSet.empty,
267 remove_classes = ClassSet.empty,
268 dead_memlocs = MemLocSet.empty,
269 dead_classes = ClassSet.empty}),
270 setup,
271 AppendList.fromList
272 [(Assembly.directive_force
273 {commit_memlocs = MemLocSet.empty,
274 commit_classes = farflushClasses,
275 remove_memlocs = MemLocSet.empty,
276 remove_classes = ClassSet.empty,
277 dead_memlocs = MemLocSet.empty,
278 dead_classes = ClassSet.empty})],
279 trans]
280
281 fun farEntry l = AppendList.cons (blockAssumes [], l)
282
283 fun farTransfer live setup trans
284 = AppendList.appends
285 [AppendList.single
286 (Assembly.directive_force
287 {commit_memlocs = removeHoldMemLocs live,
288 commit_classes = ClassSet.empty,
289 remove_memlocs = MemLocSet.empty,
290 remove_classes = ClassSet.empty,
291 dead_memlocs = MemLocSet.empty,
292 dead_classes = ClassSet.empty}),
293 setup,
294 AppendList.fromList
295 [(Assembly.directive_cache
296 {caches = [{register = stackTopReg,
297 memloc = stackTop (),
298 reserve = true},
299 {register = frontierReg,
300 memloc = frontier (),
301 reserve = true}]}),
302 (Assembly.directive_xmmcache
303 {caches = []}),
304 (Assembly.directive_force
305 {commit_memlocs = MemLocSet.empty,
306 commit_classes = farflushClasses,
307 remove_memlocs = MemLocSet.empty,
308 remove_classes = ClassSet.empty,
309 dead_memlocs = MemLocSet.empty,
310 dead_classes = ClassSet.empty})],
311 trans]
312
313 val profileStackTopCommit' =
314 amd64.Assembly.directive_force
315 {commit_memlocs = MemLocSet.singleton (stackTop ()),
316 commit_classes = ClassSet.empty,
317 remove_memlocs = MemLocSet.empty,
318 remove_classes = ClassSet.empty,
319 dead_memlocs = MemLocSet.empty,
320 dead_classes = ClassSet.empty}
321 val profileStackTopCommit =
322 if !Control.profile <> Control.ProfileNone
323 then AppendList.single profileStackTopCommit'
324 else AppendList.empty
325
326 val _
327 = Assert.assert
328 ("amd64GenerateTransfers.verifyLiveInfo",
329 fn () => amd64Liveness.LiveInfo.verifyLiveInfo {chunk = chunk,
330 liveInfo = liveInfo})
331 val _
332 = Assert.assert
333 ("amd64GenerateTransfers.verifyJumpInfo",
334 fn () => amd64JumpInfo.verifyJumpInfo {chunk = chunk,
335 jumpInfo = jumpInfo})
336
337 val _
338 = Assert.assert
339 ("amd64GenerateTransfers.verifyEntryTransfer",
340 fn () => amd64EntryTransfer.verifyEntryTransfer {chunk = chunk})
341
342 local
343 val {get: Label.t -> {block:Block.t},
344 set,
345 destroy}
346 = Property.destGetSetOnce
347 (Label.plist, Property.initRaise ("gotoInfo", Label.layout))
348
349 val labels
350 = List.fold
351 (blocks, [],
352 fn (block as Block.T {entry, ...}, labels)
353 => let
354 val label = Entry.label entry
355 in
356 set(label, {block = block}) ;
357 label::labels
358 end)
359
360 fun loop labels
361 = let
362 val (labels, b)
363 = List.fold
364 (labels, ([], false),
365 fn (label, (labels, b))
366 => case amd64JumpInfo.getNear (jumpInfo, label)
367 of amd64JumpInfo.Count 0
368 => let
369 val {block = Block.T {transfer, ...}}
370 = get label
371 in
372 List.foreach
373 (Transfer.nearTargets transfer,
374 fn label
375 => amd64JumpInfo.decNear (jumpInfo, label));
376 (labels, true)
377 end
378 | _ => (label::labels, b))
379 in
380 if b
381 then loop labels
382 else List.map (labels, #block o get)
383 end
384 val blocks = loop labels
385
386 val _ = destroy ()
387 in
388 val chunk = Chunk.T {data = data, blocks = blocks}
389 end
390
391 val loopInfo
392 = amd64LoopInfo.createLoopInfo {chunk = chunk, farLoops = false}
393 val isLoopHeader
394 = fn label => isLoopHeader(loopInfo, label)
395 handle _ => false
396
397 val liveTransfers
398 = amd64LiveTransfers.computeLiveTransfers
399 {chunk = chunk,
400 transferRegs = transferRegs,
401 transferXmmRegs = transferXmmRegs,
402 liveInfo = liveInfo,
403 jumpInfo = jumpInfo,
404 loopInfo = loopInfo}
405
406 val getLiveRegsTransfers
407 = #1 o amd64LiveTransfers.getLiveTransfers
408 val getLiveXmmRegsTransfers
409 = #2 o amd64LiveTransfers.getLiveTransfers
410
411 val {get = getLayoutInfo : Label.t -> Block.t option,
412 set = setLayoutInfo,
413 destroy = destLayoutInfo}
414 = Property.destGetSet(Label.plist,
415 Property.initRaise ("layoutInfo", Label.layout))
416 val _
417 = List.foreach
418 (blocks,
419 fn block as Block.T {entry, ...}
420 => let
421 val label = Entry.label entry
422 in
423 setLayoutInfo(label, SOME block)
424 end)
425
426 val {get = getProfileLabel : Label.t -> ProfileLabel.t option,
427 set = setProfileLabel,
428 destroy = destProfileLabel}
429 = Property.destGetSetOnce
430 (Label.plist,
431 Property.initRaise ("profileLabel", Label.layout))
432 val _
433 = List.foreach
434 (blocks,
435 fn Block.T {entry, profileLabel, ...}
436 => let
437 val label = Entry.label entry
438 in
439 setProfileLabel(label, profileLabel)
440 end)
441
442 local
443 val stack = ref []
444 val queue = ref (Queue.empty ())
445 in
446 fun enque x = queue := Queue.enque(!queue, x)
447 fun push x = stack := x::(!stack)
448
449 fun deque () = (case (!stack)
450 of [] => (case Queue.deque(!queue)
451 of NONE => NONE
452 | SOME(queue', x) => (queue := queue';
453 SOME x))
454 | x::stack' => (stack := stack';
455 SOME x))
456 end
457
458 fun pushCompensationBlock {label, id}
459 = let
460 val label' = Label.new label
461 val live = getLive(liveInfo, label)
462 val profileLabel = getProfileLabel label
463 val profileLabel' = Option.map (profileLabel, newProfileLabel)
464 val block
465 = Block.T {entry = Entry.jump {label = label'},
466 profileLabel = profileLabel',
467 statements
468 = (Assembly.directive_restoreregalloc
469 {live = MemLocSet.add
470 (MemLocSet.add
471 (LiveSet.toMemLocSet live,
472 stackTop ()),
473 frontier ()),
474 id = id})::
475 nil,
476 transfer = Transfer.goto {target = label}}
477 in
478 setLive(liveInfo, label', live);
479 setProfileLabel(label', profileLabel');
480 incNear(jumpInfo, label');
481 Assert.assert("amd64GenerateTransfers.pushCompensationBlock",
482 fn () => getNear(jumpInfo, label') = Count 1);
483 amd64LiveTransfers.setLiveTransfersEmpty(liveTransfers, label');
484 setLayoutInfo(label', SOME block);
485 push label';
486 label'
487 end
488
489 val c_stackP = amd64MLton.c_stackPContentsOperand
490
491 fun cacheRsp () =
492 if reserveRsp
493 then AppendList.empty
494 else
495 AppendList.single
496 ((* explicit cache in case there are no args *)
497 Assembly.directive_cache
498 {caches = [{register = Register.rsp,
499 memloc = valOf (Operand.deMemloc c_stackP),
500 reserve = true}]})
501
502 fun unreserveRsp () =
503 if reserveRsp
504 then AppendList.empty
505 else AppendList.single (Assembly.directive_unreserve
506 {registers = [Register.rsp]})
507
508 datatype z = datatype Entry.t
509 datatype z = datatype Transfer.t
510 fun generateAll (gef as GEF {effect,...})
511 {label, falling, unique} :
512 Assembly.t AppendList.t
513 = (case getLayoutInfo label
514 of NONE => AppendList.empty
515 | SOME (Block.T {entry, profileLabel, statements, transfer})
516 => let
517 val _ = setLayoutInfo(label, NONE)
518 (*
519 val isLoopHeader = fn _ => false
520 *)
521 fun near label =
522 let
523 val align =
524 if isLoopHeader label handle _ => false
525 then
526 AppendList.single
527 (Assembly.pseudoop_p2align
528 (Immediate.int 4,
529 NONE,
530 SOME (Immediate.int 7)))
531 else if falling
532 then AppendList.empty
533 else
534 AppendList.single
535 (Assembly.pseudoop_p2align
536 (Immediate.int 4,
537 NONE,
538 NONE))
539 val assumes =
540 if falling andalso unique
541 then AppendList.empty
542 else
543 (* near entry & live transfer assumptions *)
544 AppendList.fromList
545 [(blockAssumes
546 (List.map
547 (getLiveRegsTransfers
548 (liveTransfers, label),
549 fn (memloc,register,sync)
550 => {register = register,
551 memloc = memloc,
552 sync = sync,
553 weight = 1024,
554 reserve = false}))),
555 (Assembly.directive_xmmassume
556 {assumes
557 = (List.map
558 (getLiveXmmRegsTransfers
559 (liveTransfers, label),
560 fn (memloc,register,sync)
561 => {register = register,
562 memloc = memloc,
563 sync = sync,
564 weight = 1024,
565 reserve = false}))})]
566 in
567 AppendList.appends
568 [align,
569 AppendList.single
570 (Assembly.label label),
571 AppendList.fromList
572 (ProfileLabel.toAssemblyOpt profileLabel),
573 assumes]
574 end
575 val pre
576 = case entry
577 of Jump {label}
578 => near label
579 | CReturn {dsts, frameInfo, func, label}
580 => let
581 fun getReturn () =
582 if Vector.isEmpty dsts
583 then AppendList.empty
584 else let
585 val srcs =
586 Vector.fromList
587 (List.map
588 (Operand.cReturnTemps
589 (CFunction.return func),
590 #dst))
591 in
592 (AppendList.fromList o Vector.fold2)
593 (dsts, srcs, [], fn ((dst,dstsize),src,stmts) =>
594 case Size.class dstsize of
595 Size.INT =>
596 (amd64.Assembly.instruction_mov
597 {dst = dst,
598 src = Operand.memloc src,
599 size = dstsize})::stmts
600 | Size.FLT =>
601 (amd64.Assembly.instruction_sse_movs
602 {dst = dst,
603 src = Operand.memloc src,
604 size = dstsize})::stmts)
605 end
606 in
607 case frameInfo of
608 SOME fi =>
609 let
610 val FrameInfo.T {size, frameLayoutsIndex}
611 = fi
612 val finish
613 = AppendList.appends
614 [let
615 val stackTop
616 = amd64MLton.gcState_stackTopContentsOperand ()
617 val bytes
618 = amd64.Operand.immediate_int (~ size)
619 in
620 AppendList.cons
621 ((* stackTop += bytes *)
622 amd64.Assembly.instruction_binal
623 {oper = amd64.Instruction.ADD,
624 dst = stackTop,
625 src = bytes,
626 size = pointerSize},
627 profileStackTopCommit)
628 end,
629 (* assignTo dst *)
630 getReturn ()]
631 in
632 AppendList.appends
633 [AppendList.fromList
634 [Assembly.pseudoop_p2align
635 (Immediate.int 4, NONE, NONE),
636 Assembly.pseudoop_long
637 [Immediate.int frameLayoutsIndex],
638 Assembly.label label],
639 AppendList.fromList
640 (ProfileLabel.toAssemblyOpt profileLabel),
641 if CFunction.maySwitchThreads func
642 then (* entry from far assumptions *)
643 farEntry finish
644 else (* near entry & live transfer assumptions *)
645 AppendList.append
646 (AppendList.fromList
647 [(blockAssumes
648 (List.map
649 (getLiveRegsTransfers
650 (liveTransfers, label),
651 fn (memloc,register,sync)
652 => {register = register,
653 memloc = memloc,
654 sync = sync,
655 weight = 1024,
656 reserve = false}))),
657 (Assembly.directive_xmmassume
658 {assumes
659 = (List.map
660 (getLiveXmmRegsTransfers
661 (liveTransfers, label),
662 fn (memloc,register,sync)
663 => {register = register,
664 memloc = memloc,
665 sync = sync,
666 weight = 1024,
667 reserve = false}))})],
668 finish)]
669 end
670 | NONE =>
671 AppendList.append (near label, getReturn ())
672 end
673 | Func {label,...}
674 => AppendList.appends
675 [AppendList.fromList
676 [Assembly.pseudoop_p2align
677 (Immediate.int 4, NONE, NONE),
678 Assembly.pseudoop_global label,
679 Assembly.pseudoop_hidden label,
680 Assembly.label label],
681 AppendList.fromList
682 (ProfileLabel.toAssemblyOpt profileLabel),
683 (* entry from far assumptions *)
684 (farEntry AppendList.empty)]
685 | Cont {label,
686 frameInfo = FrameInfo.T {size,
687 frameLayoutsIndex},
688 ...}
689 =>
690 AppendList.appends
691 [AppendList.fromList
692 [Assembly.pseudoop_p2align
693 (Immediate.int 4, NONE, NONE),
694 Assembly.pseudoop_long
695 [Immediate.int frameLayoutsIndex],
696 Assembly.label label],
697 AppendList.fromList
698 (ProfileLabel.toAssemblyOpt profileLabel),
699 (* entry from far assumptions *)
700 (farEntry
701 (let
702 val stackTop
703 = amd64MLton.gcState_stackTopContentsOperand ()
704 val bytes
705 = amd64.Operand.immediate_int (~ size)
706 in
707 AppendList.cons
708 ((* stackTop += bytes *)
709 amd64.Assembly.instruction_binal
710 {oper = amd64.Instruction.ADD,
711 dst = stackTop,
712 src = bytes,
713 size = pointerSize},
714 profileStackTopCommit)
715 end))]
716 | Handler {frameInfo = (FrameInfo.T
717 {frameLayoutsIndex, size}),
718 label,
719 ...}
720 => AppendList.appends
721 [AppendList.fromList
722 [Assembly.pseudoop_p2align
723 (Immediate.int 4, NONE, NONE),
724 Assembly.pseudoop_long
725 [Immediate.int frameLayoutsIndex],
726 Assembly.label label],
727 AppendList.fromList
728 (ProfileLabel.toAssemblyOpt profileLabel),
729 (* entry from far assumptions *)
730 (farEntry
731 (let
732 val stackTop
733 = amd64MLton.gcState_stackTopContentsOperand ()
734 val bytes
735 = amd64.Operand.immediate_int (~ size)
736 in
737 AppendList.cons
738 ((* stackTop += bytes *)
739 amd64.Assembly.instruction_binal
740 {oper = amd64.Instruction.ADD,
741 dst = stackTop,
742 src = bytes,
743 size = pointerSize},
744 profileStackTopCommit)
745 end))]
746 val pre
747 = AppendList.appends
748 [if !Control.Native.commented > 1
749 then AppendList.single
750 (Assembly.comment (Entry.toString entry))
751 else AppendList.empty,
752 if !Control.Native.commented > 2
753 then AppendList.single
754 (Assembly.comment
755 (LiveSet.fold
756 (getLive(liveInfo, label),
757 "",
758 fn (memloc, s)
759 => concat [s,
760 MemLoc.toString memloc,
761 " "])))
762 else AppendList.empty,
763 pre]
764
765 val (statements,_)
766 = List.foldr
767 (statements,
768 ([],
769 Liveness.liveIn
770 (livenessTransfer {transfer = transfer,
771 liveInfo = liveInfo})),
772 fn (assembly,(statements,live))
773 => let
774 val Liveness.T {liveIn,dead, ...}
775 = livenessAssembly {assembly = assembly,
776 live = live}
777 in
778 (if LiveSet.isEmpty dead
779 then assembly::statements
780 else assembly::
781 (Assembly.directive_force
782 {commit_memlocs = MemLocSet.empty,
783 commit_classes = ClassSet.empty,
784 remove_memlocs = MemLocSet.empty,
785 remove_classes = ClassSet.empty,
786 dead_memlocs = LiveSet.toMemLocSet dead,
787 dead_classes = ClassSet.empty})::
788 statements,
789 liveIn)
790 end)
791
792 val statements = AppendList.fromList statements
793
794 val transfer = effect gef {label = label,
795 transfer = transfer}
796 in
797 AppendList.appends
798 [pre,
799 statements,
800 transfer]
801 end)
802
803 and effectDefault (gef as GEF {fall,...})
804 {label, transfer} : Assembly.t AppendList.t
805 = AppendList.append
806 (if !Control.Native.commented > 1
807 then AppendList.single
808 (Assembly.comment
809 (Transfer.toString transfer))
810 else AppendList.empty,
811 case transfer
812 of Goto {target}
813 => fall gef
814 {label = target,
815 live = getLive(liveInfo, target)}
816 | Iff {condition, truee, falsee}
817 => let
818 val condition_neg
819 = Instruction.condition_negate condition
820
821 val truee_live
822 = getLive(liveInfo, truee)
823 val truee_live_length
824 = LiveSet.size truee_live
825
826 val falsee_live
827 = getLive(liveInfo, falsee)
828 val falsee_live_length
829 = LiveSet.size falsee_live
830
831 fun fall_truee ()
832 = let
833 val id = Directive.Id.new ()
834 val falsee'
835 = pushCompensationBlock {label = falsee,
836 id = id};
837 in
838 AppendList.append
839 (AppendList.fromList
840 [Assembly.directive_force
841 {commit_memlocs = MemLocSet.empty,
842 commit_classes = nearflushClasses,
843 remove_memlocs = MemLocSet.empty,
844 remove_classes = ClassSet.empty,
845 dead_memlocs = MemLocSet.empty,
846 dead_classes = ClassSet.empty},
847 Assembly.instruction_jcc
848 {condition = condition_neg,
849 target = Operand.label falsee'},
850 Assembly.directive_saveregalloc
851 {live = MemLocSet.add
852 (MemLocSet.add
853 (LiveSet.toMemLocSet falsee_live,
854 stackTop ()),
855 frontier ()),
856 id = id}],
857 (fall gef
858 {label = truee,
859 live = truee_live}))
860 end
861
862 fun fall_falsee ()
863 = let
864 val id = Directive.Id.new ()
865 val truee' = pushCompensationBlock {label = truee,
866 id = id};
867 in
868 AppendList.append
869 (AppendList.fromList
870 [Assembly.directive_force
871 {commit_memlocs = MemLocSet.empty,
872 commit_classes = nearflushClasses,
873 remove_memlocs = MemLocSet.empty,
874 remove_classes = ClassSet.empty,
875 dead_memlocs = MemLocSet.empty,
876 dead_classes = ClassSet.empty},
877 Assembly.instruction_jcc
878 {condition = condition,
879 target = Operand.label truee'},
880 Assembly.directive_saveregalloc
881 {live = MemLocSet.add
882 (MemLocSet.add
883 (LiveSet.toMemLocSet truee_live,
884 stackTop ()),
885 frontier ()),
886 id = id}],
887 (fall gef
888 {label = falsee,
889 live = falsee_live}))
890 end
891 in
892 case (getLayoutInfo truee,
893 getLayoutInfo falsee)
894 of (NONE, SOME _) => fall_falsee ()
895 | (SOME _, NONE) => fall_truee ()
896 | _
897 => let
898 fun default' ()
899 = if truee_live_length <= falsee_live_length
900 then fall_falsee ()
901 else fall_truee ()
902
903 fun default ()
904 = case (getNear(jumpInfo, truee),
905 getNear(jumpInfo, falsee))
906 of (Count 1, Count 1) => default' ()
907 | (Count 1, _) => fall_truee ()
908 | (_, Count 1) => fall_falsee ()
909 | _ => default' ()
910 in
911 case (getLoopDistance(loopInfo, label, truee),
912 getLoopDistance(loopInfo, label, falsee))
913 of (NONE, NONE) => default ()
914 | (SOME _, NONE) => fall_truee ()
915 | (NONE, SOME _) => fall_falsee ()
916 | (SOME dtruee, SOME dfalsee)
917 => (case Int.compare(dtruee, dfalsee)
918 of EQUAL => default ()
919 | LESS => fall_falsee ()
920 | GREATER => fall_truee ())
921 end
922 end
923 | Switch {test, cases, default}
924 => let
925 val Liveness.T {dead, ...}
926 = livenessTransfer {transfer = transfer,
927 liveInfo = liveInfo}
928
929 val size
930 = case Operand.size test
931 of SOME size => size
932 | NONE => Size.QUAD
933
934 val default_live
935 = getLive(liveInfo, default)
936
937 val cases
938 = Transfer.Cases.mapToList
939 (cases,
940 fn (k, target)
941 => let
942 val target_live
943 = getLive(liveInfo, target)
944 val id = Directive.Id.new ()
945 val target' = pushCompensationBlock
946 {label = target,
947 id = id}
948 in
949 AppendList.fromList
950 [Assembly.instruction_cmp
951 {src1 = test,
952 src2 = Operand.immediate_word k,
953 size = size},
954 Assembly.instruction_jcc
955 {condition = Instruction.E,
956 target = Operand.label target'},
957 Assembly.directive_saveregalloc
958 {live = MemLocSet.add
959 (MemLocSet.add
960 (LiveSet.toMemLocSet target_live,
961 stackTop ()),
962 frontier ()),
963 id = id}]
964 end)
965 in
966 AppendList.appends
967 [AppendList.single
968 (Assembly.directive_force
969 {commit_memlocs = MemLocSet.empty,
970 commit_classes = nearflushClasses,
971 remove_memlocs = MemLocSet.empty,
972 remove_classes = ClassSet.empty,
973 dead_memlocs = MemLocSet.empty,
974 dead_classes = ClassSet.empty}),
975 AppendList.appends cases,
976 if LiveSet.isEmpty dead
977 then AppendList.empty
978 else AppendList.single
979 (Assembly.directive_force
980 {commit_memlocs = MemLocSet.empty,
981 commit_classes = ClassSet.empty,
982 remove_memlocs = MemLocSet.empty,
983 remove_classes = ClassSet.empty,
984 dead_memlocs = LiveSet.toMemLocSet dead,
985 dead_classes = ClassSet.empty}),
986 (fall gef
987 {label = default,
988 live = default_live})]
989 end
990 | Tail {target, live}
991 => (* flushing at far transfer *)
992 (farTransfer live
993 AppendList.empty
994 (AppendList.single
995 (Assembly.instruction_jmp
996 {target = Operand.label target,
997 absolute = false})))
998 | NonTail {target, live, return, handler, size}
999 => let
1000 val _ = enque return
1001 val _ = case handler
1002 of SOME handler => enque handler
1003 | NONE => ()
1004
1005 val stackTopTemp
1006 = amd64MLton.stackTopTempContentsOperand ()
1007 val stackTopTempMinusWordDeref'
1008 = amd64MLton.stackTopTempMinusWordDeref ()
1009 val stackTopTempMinusWordDeref
1010 = amd64MLton.stackTopTempMinusWordDerefOperand ()
1011 val stackTop
1012 = amd64MLton.gcState_stackTopContentsOperand ()
1013 val stackTopMinusWordDeref'
1014 = amd64MLton.gcState_stackTopMinusWordDeref ()
1015 val stackTopMinusWordDeref
1016 = amd64MLton.gcState_stackTopMinusWordDerefOperand ()
1017 val bytes
1018 = amd64.Operand.immediate_int size
1019
1020 val liveReturn = amd64Liveness.LiveInfo.getLive(liveInfo, return)
1021 val liveHandler
1022 = case handler
1023 of SOME handler
1024 => amd64Liveness.LiveInfo.getLive(liveInfo, handler)
1025 | _ => LiveSet.empty
1026 val live = MemLocSet.unions [live,
1027 LiveSet.toMemLocSet liveReturn,
1028 LiveSet.toMemLocSet liveHandler]
1029 in
1030 (* flushing at far transfer *)
1031 (farTransfer live
1032 (if !Control.profile <> Control.ProfileNone
1033 then (AppendList.fromList
1034 [(* stackTopTemp = stackTop + bytes *)
1035 amd64.Assembly.instruction_mov
1036 {dst = stackTopTemp,
1037 src = stackTop,
1038 size = pointerSize},
1039 amd64.Assembly.instruction_binal
1040 {oper = amd64.Instruction.ADD,
1041 dst = stackTopTemp,
1042 src = bytes,
1043 size = pointerSize},
1044 (* *(stackTopTemp - WORD_SIZE) = return *)
1045 amd64.Assembly.instruction_lea
1046 {dst = stackTopTempMinusWordDeref,
1047 src = Operand.memloc_label return,
1048 size = pointerSize},
1049 amd64.Assembly.directive_force
1050 {commit_memlocs = MemLocSet.singleton stackTopTempMinusWordDeref',
1051 commit_classes = ClassSet.empty,
1052 remove_memlocs = MemLocSet.empty,
1053 remove_classes = ClassSet.empty,
1054 dead_memlocs = MemLocSet.empty,
1055 dead_classes = ClassSet.empty},
1056 (* stackTop = stackTopTemp *)
1057 amd64.Assembly.instruction_mov
1058 {dst = stackTop,
1059 src = stackTopTemp,
1060 size = pointerSize},
1061 profileStackTopCommit'])
1062 else (AppendList.fromList
1063 [(* stackTop += bytes *)
1064 amd64.Assembly.instruction_binal
1065 {oper = amd64.Instruction.ADD,
1066 dst = stackTop,
1067 src = bytes,
1068 size = pointerSize},
1069 (* *(stackTop - WORD_SIZE) = return *)
1070 amd64.Assembly.instruction_lea
1071 {dst = stackTopMinusWordDeref,
1072 src = Operand.memloc_label return,
1073 size = pointerSize},
1074 amd64.Assembly.directive_force
1075 {commit_memlocs = MemLocSet.singleton stackTopMinusWordDeref',
1076 commit_classes = ClassSet.empty,
1077 remove_memlocs = MemLocSet.empty,
1078 remove_classes = ClassSet.empty,
1079 dead_memlocs = MemLocSet.empty,
1080 dead_classes = ClassSet.empty}]))
1081 (AppendList.single
1082 (Assembly.instruction_jmp
1083 {target = Operand.label target,
1084 absolute = false})))
1085 end
1086 | Return {live}
1087 => let
1088 val stackTopMinusWordDeref
1089 = amd64MLton.gcState_stackTopMinusWordDerefOperand ()
1090 in
1091 (* flushing at far transfer *)
1092 (farTransfer live
1093 AppendList.empty
1094 (AppendList.single
1095 (* jmp *(stackTop - WORD_SIZE) *)
1096 (amd64.Assembly.instruction_jmp
1097 {target = stackTopMinusWordDeref,
1098 absolute = true})))
1099 end
1100 | Raise {live}
1101 => let
1102 val exnStack
1103 = amd64MLton.gcState_exnStackContentsOperand ()
1104 val stackTopTemp
1105 = amd64MLton.stackTopTempContentsOperand ()
1106 val stackTop
1107 = amd64MLton.gcState_stackTopContentsOperand ()
1108 val stackBottom
1109 = amd64MLton.gcState_stackBottomContentsOperand ()
1110 in
1111 (* flushing at far transfer *)
1112 (farTransfer live
1113 (if !Control.profile <> Control.ProfileNone
1114 then (AppendList.fromList
1115 [(* stackTopTemp = stackBottom + exnStack *)
1116 amd64.Assembly.instruction_mov
1117 {dst = stackTopTemp,
1118 src = stackBottom,
1119 size = pointerSize},
1120 amd64.Assembly.instruction_binal
1121 {oper = amd64.Instruction.ADD,
1122 dst = stackTopTemp,
1123 src = exnStack,
1124 size = pointerSize},
1125 (* stackTop = stackTopTemp *)
1126 amd64.Assembly.instruction_mov
1127 {dst = stackTop,
1128 src = stackTopTemp,
1129 size = pointerSize},
1130 profileStackTopCommit'])
1131 else (AppendList.fromList
1132 [(* stackTop = stackBottom + exnStack *)
1133 amd64.Assembly.instruction_mov
1134 {dst = stackTop,
1135 src = stackBottom,
1136 size = pointerSize},
1137 amd64.Assembly.instruction_binal
1138 {oper = amd64.Instruction.ADD,
1139 dst = stackTop,
1140 src = exnStack,
1141 size = pointerSize}]))
1142 (AppendList.single
1143 (* jmp *(stackTop - WORD_SIZE) *)
1144 (amd64.Assembly.instruction_jmp
1145 {target = amd64MLton.gcState_stackTopMinusWordDerefOperand (),
1146 absolute = true})))
1147 end
1148 | CCall {args, frameInfo, func, return}
1149 => let
1150 datatype z = datatype CFunction.Convention.t
1151 datatype z = datatype CFunction.SymbolScope.t
1152 datatype z = datatype CFunction.Target.t
1153 val CFunction.T {convention=_,
1154 return = returnTy,
1155 symbolScope,
1156 target, ...} = func
1157 val stackTopMinusWordDeref
1158 = amd64MLton.gcState_stackTopMinusWordDerefOperand ()
1159 val Liveness.T {dead, ...}
1160 = livenessTransfer {transfer = transfer,
1161 liveInfo = liveInfo}
1162 val c_stackP = amd64MLton.c_stackPContentsOperand
1163 val c_stackPDerefWord = amd64MLton.c_stackPDerefWordOperand
1164 val c_stackPDerefFloat = amd64MLton.c_stackPDerefFloatOperand
1165 val c_stackPDerefDouble = amd64MLton.c_stackPDerefDoubleOperand
1166 val applyFFTempFun = amd64MLton.applyFFTempFunContentsOperand
1167 val applyFFTempRegArg = amd64MLton.applyFFTempRegArgContents
1168 val applyFFTempXmmRegArg = amd64MLton.applyFFTempXmmRegArgContents
1169 val (fptrArg, args) =
1170 case target of
1171 Direct _ => (AppendList.empty, args)
1172 | Indirect =>
1173 let
1174 val (fptrArg, args) =
1175 case args of
1176 fptrArg::args => (fptrArg, args)
1177 | _ => Error.bug "amd64GenerateTransfers.generateAll: CCall"
1178 in
1179 (AppendList.single
1180 (Assembly.instruction_mov
1181 {src = #1 fptrArg,
1182 dst = applyFFTempFun,
1183 size = #2 fptrArg}),
1184 args)
1185 end
1186 val win64 = case !Control.Target.os of
1187 MLton.Platform.OS.Cygwin => true
1188 | MLton.Platform.OS.MinGW => true
1189 | _ => false
1190 val (setup_args,
1191 (reg_args, xmmreg_args),
1192 size_stack_args, _)
1193 = List.fold
1194 (args, (AppendList.empty,
1195 ([],[]),0,
1196 (if win64
1197 then [Register.rcx,Register.rdx,
1198 Register.r8,Register.r9]
1199 else [Register.rdi,Register.rsi,Register.rdx,
1200 Register.rcx,Register.r8,Register.r9],
1201 if win64
1202 then [(XmmRegister.xmm0D,XmmRegister.xmm0S),
1203 (XmmRegister.xmm1D,XmmRegister.xmm1S),
1204 (XmmRegister.xmm2D,XmmRegister.xmm2S),
1205 (XmmRegister.xmm3D,XmmRegister.xmm3S)]
1206 else [(XmmRegister.xmm0D,XmmRegister.xmm0S),
1207 (XmmRegister.xmm1D,XmmRegister.xmm1S),
1208 (XmmRegister.xmm2D,XmmRegister.xmm2S),
1209 (XmmRegister.xmm3D,XmmRegister.xmm3S),
1210 (XmmRegister.xmm4D,XmmRegister.xmm4S),
1211 (XmmRegister.xmm5D,XmmRegister.xmm5S),
1212 (XmmRegister.xmm6D,XmmRegister.xmm6S),
1213 (XmmRegister.xmm7D,XmmRegister.xmm7S)])),
1214 fn ((arg, size),
1215 (setup_args,
1216 (reg_args, xmmreg_args),
1217 size_stack_args,
1218 (regs, xmmregs))) =>
1219 let
1220 fun prune [] = []
1221 | prune (x::r) = if win64 then r else (x::r)
1222 val (setup_arg,
1223 (reg_args, xmmreg_args),
1224 size_stack_arg,
1225 (regs, xmmregs)) =
1226 if Size.eq (size, Size.DBLE)
1227 orelse Size.eq (size, Size.SNGL)
1228 then (case xmmregs of
1229 xmmreg::xmmregs =>
1230 let
1231 val i = List.length xmmregs
1232 val mem = applyFFTempXmmRegArg (size, i)
1233 val xmmreg =
1234 if Size.eq (size, Size.DBLE)
1235 then #1 xmmreg
1236 else #2 xmmreg
1237 in
1238 (AppendList.fromList
1239 [Assembly.instruction_sse_movs
1240 {src = arg,
1241 dst = Operand.memloc mem,
1242 size = size},
1243 Assembly.directive_xmmcache
1244 {caches = [{register = xmmreg,
1245 memloc = mem,
1246 reserve = true}]}],
1247 (reg_args,
1248 (mem, xmmreg)::xmmreg_args),
1249 0,
1250 (prune regs, xmmregs))
1251 end
1252 | [] =>
1253 (AppendList.fromList
1254 [Assembly.instruction_binal
1255 {oper = Instruction.SUB,
1256 dst = c_stackP,
1257 src = Operand.immediate_int 8,
1258 size = pointerSize},
1259 Assembly.instruction_sse_movs
1260 {src = arg,
1261 dst = if Size.eq (size, Size.DBLE)
1262 then c_stackPDerefDouble
1263 else c_stackPDerefFloat,
1264 size = size}],
1265 (reg_args, xmmreg_args),
1266 8,
1267 (regs, xmmregs)))
1268 else if Size.eq (size, Size.BYTE)
1269 orelse Size.eq (size, Size.WORD)
1270 orelse Size.eq (size, Size.LONG)
1271 orelse Size.eq (size, Size.QUAD)
1272 then (case regs of
1273 reg::regs =>
1274 let
1275 val i = List.length regs
1276 val mem = applyFFTempRegArg i
1277 in
1278 (AppendList.fromList
1279 [if Size.lt (size, Size.QUAD)
1280 then Assembly.instruction_movx
1281 {oper = Instruction.MOVZX,
1282 src = arg,
1283 dst = Operand.memloc mem,
1284 srcsize = size,
1285 dstsize = wordSize}
1286 else Assembly.instruction_mov
1287 {src = arg,
1288 dst = Operand.memloc mem,
1289 size = size},
1290 Assembly.directive_cache
1291 {caches = [{register = reg,
1292 memloc = mem,
1293 reserve = true}]}],
1294 ((mem,reg)::reg_args,
1295 xmmreg_args),
1296 0,
1297 (regs, prune xmmregs))
1298 end
1299 | [] =>
1300 (AppendList.fromList
1301 [Assembly.instruction_binal
1302 {oper = Instruction.SUB,
1303 dst = c_stackP,
1304 src = Operand.immediate_int 8,
1305 size = pointerSize},
1306 if Size.lt (size, Size.QUAD)
1307 then Assembly.instruction_movx
1308 {oper = Instruction.MOVZX,
1309 src = arg,
1310 dst = c_stackPDerefWord,
1311 srcsize = size,
1312 dstsize = wordSize}
1313 else Assembly.instruction_mov
1314 {src = arg,
1315 dst = c_stackPDerefWord,
1316 size = size}],
1317 (reg_args, xmmreg_args),
1318 8,
1319 (regs, xmmregs)))
1320 else Error.bug "amd64GenerateTransfers.generateAll: CCall"
1321 in
1322 (AppendList.append (setup_arg, setup_args),
1323 (reg_args, xmmreg_args),
1324 size_stack_arg + size_stack_args,
1325 (regs, xmmregs))
1326 end)
1327 val (setup_args, size_stack_args) =
1328 let
1329 val space = 16 - (size_stack_args mod 16)
1330 in
1331 if space = 16
1332 then (setup_args, size_stack_args)
1333 else (AppendList.append
1334 (AppendList.single
1335 (Assembly.instruction_binal
1336 {oper = Instruction.SUB,
1337 dst = c_stackP,
1338 src = Operand.immediate_int space,
1339 size = pointerSize}),
1340 setup_args),
1341 size_stack_args + space)
1342 end
1343 (* Allocate shadow space *)
1344 val (setup_args, size_stack_args) =
1345 if win64
1346 then (AppendList.append
1347 (setup_args,
1348 AppendList.single
1349 (Assembly.instruction_binal
1350 {oper = Instruction.SUB,
1351 dst = c_stackP,
1352 src = Operand.immediate_int 32,
1353 size = pointerSize})),
1354 size_stack_args + 32)
1355 else (setup_args, size_stack_args)
1356 (* SysV ABI AMD64 requires %rax set to the number
1357 * of xmms registers passed for varags functions;
1358 * since %rax is caller-save, we conservatively
1359 * set %rax for all functions (not just varargs).
1360 *)
1361 val (reg_args, setup_args) =
1362 if not win64
1363 then let
1364 val mem = applyFFTempRegArg 8
1365 val reg = Register.rax
1366 in
1367 ((mem,reg) :: reg_args,
1368 AppendList.append
1369 (setup_args,
1370 AppendList.fromList
1371 [Assembly.instruction_mov
1372 {src = Operand.immediate_int (List.length xmmreg_args),
1373 dst = Operand.memloc mem,
1374 size = Size.QUAD},
1375 Assembly.directive_cache
1376 {caches = [{register = reg,
1377 memloc = mem,
1378 reserve = true}]}]))
1379 end
1380 else (reg_args, setup_args)
1381 (*
1382 val reserve_args =
1383 AppendList.fromList
1384 [amd64.Assembly.directive_xmmcache
1385 {caches = List.map
1386 (xmmreg_args, fn (mem,reg) =>
1387 {register = reg, memloc = mem,
1388 reserve = true})},
1389 amd64.Assembly.directive_cache
1390 {caches = List.map
1391 (reg_args, fn (mem,reg) =>
1392 {register = reg, memloc = mem,
1393 reserve = true})}]
1394 *)
1395 val flush =
1396 case frameInfo of
1397 SOME (FrameInfo.T {size, ...}) =>
1398 (* Entering runtime *)
1399 let
1400 val return = valOf return
1401 val _ = enque return
1402
1403 val stackTopTemp
1404 = amd64MLton.stackTopTempContentsOperand ()
1405 val stackTopTempMinusWordDeref'
1406 = amd64MLton.stackTopTempMinusWordDeref ()
1407 val stackTopTempMinusWordDeref
1408 = amd64MLton.stackTopTempMinusWordDerefOperand ()
1409 val stackTop
1410 = amd64MLton.gcState_stackTopContentsOperand ()
1411 val stackTopMinusWordDeref'
1412 = amd64MLton.gcState_stackTopMinusWordDeref ()
1413 val stackTopMinusWordDeref
1414 = amd64MLton.gcState_stackTopMinusWordDerefOperand ()
1415 val bytes = amd64.Operand.immediate_int size
1416
1417 val live =
1418 amd64Liveness.LiveInfo.getLive(liveInfo, return)
1419 val {defs, ...} = Transfer.uses_defs_kills transfer
1420 val live =
1421 List.fold
1422 (defs,
1423 live,
1424 fn (oper,live) =>
1425 case Operand.deMemloc oper of
1426 SOME memloc => LiveSet.remove (live, memloc)
1427 | NONE => live)
1428 in
1429 (runtimeTransfer (LiveSet.toMemLocSet live)
1430 (if !Control.profile <> Control.ProfileNone
1431 then (AppendList.fromList
1432 [(* stackTopTemp = stackTop + bytes *)
1433 amd64.Assembly.instruction_mov
1434 {dst = stackTopTemp,
1435 src = stackTop,
1436 size = pointerSize},
1437 amd64.Assembly.instruction_binal
1438 {oper = amd64.Instruction.ADD,
1439 dst = stackTopTemp,
1440 src = bytes,
1441 size = pointerSize},
1442 (* *(stackTopTemp - WORD_SIZE) = return *)
1443 amd64.Assembly.instruction_lea
1444 {dst = stackTopTempMinusWordDeref,
1445 src = Operand.memloc_label return,
1446 size = pointerSize},
1447 amd64.Assembly.directive_force
1448 {commit_memlocs = MemLocSet.singleton stackTopTempMinusWordDeref',
1449 commit_classes = ClassSet.empty,
1450 remove_memlocs = MemLocSet.empty,
1451 remove_classes = ClassSet.empty,
1452 dead_memlocs = MemLocSet.empty,
1453 dead_classes = ClassSet.empty},
1454 (* stackTop = stackTopTemp *)
1455 amd64.Assembly.instruction_mov
1456 {dst = stackTop,
1457 src = stackTopTemp,
1458 size = pointerSize},
1459 profileStackTopCommit'])
1460 else (AppendList.fromList
1461 [(* stackTop += bytes *)
1462 amd64.Assembly.instruction_binal
1463 {oper = amd64.Instruction.ADD,
1464 dst = stackTop,
1465 src = bytes,
1466 size = pointerSize},
1467 (* *(stackTop - WORD_SIZE) = return *)
1468 amd64.Assembly.instruction_lea
1469 {dst = stackTopMinusWordDeref,
1470 src = Operand.memloc_label return,
1471 size = pointerSize},
1472 amd64.Assembly.directive_force
1473 {commit_memlocs = MemLocSet.singleton stackTopMinusWordDeref',
1474 commit_classes = ClassSet.empty,
1475 remove_memlocs = MemLocSet.empty,
1476 remove_classes = ClassSet.empty,
1477 dead_memlocs = MemLocSet.empty,
1478 dead_classes = ClassSet.empty}]))
1479 (AppendList.single
1480 (Assembly.directive_force
1481 {commit_memlocs = LiveSet.toMemLocSet live,
1482 commit_classes = runtimeClasses,
1483 remove_memlocs = MemLocSet.empty,
1484 remove_classes = ClassSet.empty,
1485 dead_memlocs = MemLocSet.empty,
1486 dead_classes = ClassSet.empty})))
1487 end
1488 | NONE =>
1489 AppendList.single
1490 (Assembly.directive_force
1491 {commit_memlocs = let
1492 val s = MemLocSet.empty
1493 val s = if CFunction.modifiesFrontier func
1494 then MemLocSet.add
1495 (s, frontier ())
1496 else s
1497 val s = if CFunction.readsStackTop func
1498 then MemLocSet.add
1499 (s, stackTop ())
1500 else s
1501 in
1502 s
1503 end,
1504 commit_classes = ccallflushClasses,
1505 remove_memlocs = MemLocSet.empty,
1506 remove_classes = ClassSet.empty,
1507 dead_memlocs = LiveSet.toMemLocSet dead,
1508 dead_classes = ClassSet.empty})
1509 val call =
1510 case target of
1511 Direct name =>
1512 let
1513 datatype z = datatype MLton.Platform.OS.t
1514 datatype z = datatype Control.Format.t
1515
1516 val label = fn () => Label.fromString name
1517
1518 (* how to access imported functions: *)
1519 (* Windows rewrites the symbol __imp__name *)
1520 val coff = fn () => Label.fromString ("_imp__" ^ name)
1521 val macho = fn () => label () (* @PLT is implicit *)
1522 val elf = fn () => Label.fromString (name ^ "@PLT")
1523
1524 val importLabel = fn () =>
1525 case !Control.Target.os of
1526 Cygwin => coff ()
1527 | Darwin => macho ()
1528 | MinGW => coff ()
1529 | _ => elf ()
1530
1531 val direct = fn () =>
1532 AppendList.fromList
1533 [Assembly.directive_ccall (),
1534 Assembly.instruction_call
1535 {target = Operand.label (label ()),
1536 absolute = false}]
1537
1538 val plt = fn () =>
1539 AppendList.fromList
1540 [Assembly.directive_ccall (),
1541 Assembly.instruction_call
1542 {target = Operand.label (importLabel ()),
1543 absolute = false}]
1544
1545 val indirect = fn () =>
1546 AppendList.fromList
1547 [Assembly.directive_ccall (),
1548 Assembly.instruction_call
1549 {target = Operand.memloc_label (importLabel ()),
1550 absolute = true}]
1551 in
1552 case (symbolScope,
1553 !Control.Target.os,
1554 !Control.positionIndependent) of
1555 (* Private functions can be easily reached
1556 * with a direct (rip-relative) call.
1557 *)
1558 (Private, _, _) => direct ()
1559 (* Call at the point of definition. *)
1560 | (Public, MinGW, _) => direct ()
1561 | (Public, Cygwin, _) => direct ()
1562 | (Public, Darwin, _) => direct ()
1563 (* ELF requires PLT even for public fns. *)
1564 | (Public, _, true) => plt ()
1565 | (Public, _, false) => direct ()
1566 (* Windows always does indirect calls to
1567 * imported functions. The importLabel has
1568 * the function address written to it.
1569 *)
1570 | (External, MinGW, _) => indirect ()
1571 | (External, Cygwin, _) => indirect ()
1572 | (External, Darwin, _) => plt ()
1573 (* ELF systems (and darwin too) create
1574 * procedure lookup tables (PLT) which
1575 * proxy the call to libraries. The PLT
1576 * does not contain an address, but instead
1577 * a stub function. Often the PLT is auto-
1578 * matically created. This applies to all
1579 * darwin-x86_64 function calls and calls
1580 * made from an ELF executable.
1581 *)
1582 | (External, _, true) => plt ()
1583 | (External, _, false) => direct ()
1584 end
1585 | Indirect =>
1586 AppendList.fromList
1587 [Assembly.directive_ccall (),
1588 Assembly.instruction_call
1589 {target = applyFFTempFun,
1590 absolute = true}]
1591 val unreserve_args =
1592 AppendList.fromList
1593 [amd64.Assembly.directive_xmmunreserve
1594 {registers = List.map (xmmreg_args, #2)},
1595 amd64.Assembly.directive_unreserve
1596 {registers = List.map (reg_args, #2)}]
1597 val kill
1598 = if isSome frameInfo
1599 then AppendList.single
1600 (Assembly.directive_force
1601 {commit_memlocs = MemLocSet.empty,
1602 commit_classes = ClassSet.empty,
1603 remove_memlocs = MemLocSet.empty,
1604 remove_classes = ClassSet.empty,
1605 dead_memlocs = MemLocSet.empty,
1606 dead_classes = runtimeClasses})
1607 else AppendList.single
1608 (Assembly.directive_force
1609 {commit_memlocs = MemLocSet.empty,
1610 commit_classes = ClassSet.empty,
1611 remove_memlocs = MemLocSet.empty,
1612 remove_classes = ClassSet.empty,
1613 dead_memlocs = let
1614 val s = MemLocSet.empty
1615 val s = if CFunction.modifiesFrontier func
1616 then MemLocSet.add
1617 (s, frontier ())
1618 else s
1619 val s = if CFunction.writesStackTop func
1620 then MemLocSet.add
1621 (s, stackTop ())
1622 else s
1623 in
1624 s
1625 end,
1626 dead_classes = ccallflushClasses})
1627 val getResult =
1628 AppendList.single
1629 (Assembly.directive_return
1630 {returns = Operand.cReturnTemps returnTy})
1631 val fixCStack =
1632 if size_stack_args > 0
1633 then (AppendList.single
1634 (Assembly.instruction_binal
1635 {oper = Instruction.ADD,
1636 dst = c_stackP,
1637 src = Operand.immediate_int size_stack_args,
1638 size = pointerSize}))
1639 else AppendList.empty
1640 val continue
1641 = if CFunction.maySwitchThreads func
1642 then (* Returning from runtime *)
1643 (farTransfer MemLocSet.empty
1644 AppendList.empty
1645 (AppendList.single
1646 (* jmp *(stackTop - WORD_SIZE) *)
1647 (amd64.Assembly.instruction_jmp
1648 {target = stackTopMinusWordDeref,
1649 absolute = true})))
1650 else case return
1651 of NONE => AppendList.empty
1652 | SOME l => (if isSome frameInfo
1653 then (* Don't need to trampoline,
1654 * since didn't switch threads,
1655 * but can't fall because
1656 * frame layout data is prefixed
1657 * to l's code; use fallNone
1658 * to force a jmp with near
1659 * jump assumptions.
1660 *)
1661 fallNone
1662 else fall)
1663 gef
1664 {label = l,
1665 live = getLive (liveInfo, l)}
1666 in
1667 AppendList.appends
1668 [cacheRsp (),
1669 fptrArg,
1670 setup_args,
1671 (*reserve_args,*)
1672 flush,
1673 call,
1674 unreserve_args,
1675 kill,
1676 getResult,
1677 fixCStack,
1678 unreserveRsp (),
1679 continue]
1680 end)
1681
1682 and effectJumpTable (gef as GEF {...})
1683 {label, transfer} : Assembly.t AppendList.t
1684 = case transfer
1685 of Switch {test, cases, default}
1686 => let
1687 val ws =
1688 case Operand.size test of
1689 SOME Size.BYTE => WordSize.word8
1690 | SOME Size.WORD => WordSize.word16
1691 | SOME Size.LONG => WordSize.word32
1692 | SOME Size.QUAD => WordSize.word64
1693 | _ => Error.bug "amd64GenerateTransfers.effectJumpTable: Switch"
1694
1695 val zero = WordX.zero ws
1696 val one = WordX.one ws
1697 val two = WordX.add (one, one)
1698 fun even w = WordX.isZero (WordX.mod (w, two, {signed = false}))
1699 fun incFn w = WordX.add (w, one)
1700 fun decFn w = WordX.sub (w, one)
1701 fun halfFn w = WordX.div (w, two, {signed = false})
1702 fun ltFn (w1, w2) = WordX.lt (w1, w2, {signed = false})
1703 val min = WordX.min (ws, {signed = false})
1704 fun minFn (w1, w2) = if WordX.lt (w1, w2, {signed = false})
1705 then w1
1706 else w2
1707 val max = WordX.max (ws, {signed = false})
1708 fun maxFn (w1, w2) = if WordX.gt (w1, w2, {signed = false})
1709 then w1
1710 else w2
1711 fun range (w1, w2) = WordX.sub (w2, w1)
1712
1713 val Liveness.T {dead, ...}
1714 = livenessTransfer {transfer = transfer,
1715 liveInfo = liveInfo}
1716
1717 fun reduce(cases)
1718 = let
1719 fun reduce' cases
1720 = let
1721 val (minK,maxK,length,
1722 allEven,allOdd)
1723 = List.fold
1724 (cases,
1725 (max, min, 0,
1726 true, true),
1727 fn ((k,_),
1728 (minK,maxK,length,
1729 allEven,allOdd))
1730 => let
1731 val isEven = even k
1732 in
1733 (minFn(k,minK),
1734 maxFn(k,maxK),
1735 length + 1,
1736 allEven andalso isEven,
1737 allOdd andalso not isEven)
1738 end)
1739 in
1740 if length > 1 andalso
1741 (allEven orelse allOdd)
1742 then let
1743 val f = if allOdd
1744 then halfFn o decFn
1745 else halfFn
1746 val cases'
1747 = List.map
1748 (cases,
1749 fn (k,target)
1750 => (f k, target))
1751
1752 val (cases'',
1753 minK'', maxK'', length'',
1754 shift'', mask'')
1755 = reduce' cases'
1756
1757 val shift' = 1 + shift''
1758 val mask'
1759 = WordX.orb
1760 (WordX.lshift(mask'', WordX.one WordSize.word64),
1761 if allOdd
1762 then WordX.one WordSize.word64
1763 else WordX.zero WordSize.word64)
1764 in
1765 (cases'',
1766 minK'', maxK'', length'',
1767 shift', mask')
1768 end
1769 else (cases,
1770 minK, maxK, length,
1771 0, WordX.zero WordSize.word64)
1772 end
1773 in
1774 reduce' cases
1775 end
1776
1777 fun doitTable(cases,
1778 minK, _, rangeK, shift, mask)
1779 = let
1780 val jump_table_label
1781 = Label.newString "jumpTable"
1782
1783 val idT = Directive.Id.new ()
1784 val defaultT =
1785 Promise.delay
1786 (fn () =>
1787 let
1788 val _ = incNear(jumpInfo, default)
1789 in
1790 pushCompensationBlock
1791 {label = default,
1792 id = idT}
1793 end)
1794
1795 val rec filler
1796 = fn ([],_) => []
1797 | (cases as (i,target)::cases',j)
1798 => if WordX.equals (i, j)
1799 then let
1800 val target'
1801 = pushCompensationBlock
1802 {label = target,
1803 id = idT}
1804 in
1805 (Immediate.label target')::
1806 (filler(cases', incFn j))
1807 end
1808 else (Immediate.label
1809 (Promise.force defaultT))::
1810 (filler(cases, incFn j))
1811
1812 val jump_table = filler (cases, minK)
1813
1814 val idD = Directive.Id.new ()
1815 val defaultD = pushCompensationBlock
1816 {label = default,
1817 id = idD}
1818
1819 val default_live = getLive(liveInfo, default)
1820 val live
1821 = List.fold
1822 (cases,
1823 default_live,
1824 fn ((_,target), live)
1825 => LiveSet.+(live, getLive(liveInfo, target)))
1826
1827 val indexTemp
1828 = MemLoc.imm
1829 {base = Immediate.label (Label.fromString "indexTemp"),
1830 index = Immediate.zero,
1831 scale = Scale.Eight,
1832 size = Size.QUAD,
1833 class = MemLoc.Class.Temp}
1834 val checkTemp
1835 = MemLoc.imm
1836 {base = Immediate.label (Label.fromString "checkTemp"),
1837 index = Immediate.zero,
1838 scale = Scale.Eight,
1839 size = Size.QUAD,
1840 class = MemLoc.Class.Temp}
1841 val address
1842 = MemLoc.basic
1843 {base = Immediate.label jump_table_label,
1844 index = indexTemp,
1845 scale = Scale.Eight,
1846 size = Size.QUAD,
1847 class = MemLoc.Class.Code}
1848
1849 val size
1850 = case Operand.size test
1851 of SOME size => size
1852 | NONE => Size.QUAD
1853 val indexTemp' = indexTemp
1854 val indexTemp = Operand.memloc indexTemp
1855 val checkTemp' = checkTemp
1856 val checkTemp = Operand.memloc checkTemp
1857 val address = Operand.memloc address
1858 in
1859 AppendList.appends
1860 [if Size.lt(size, Size.QUAD)
1861 then AppendList.single
1862 (Assembly.instruction_movx
1863 {oper = Instruction.MOVZX,
1864 src = test,
1865 srcsize = size,
1866 dst = indexTemp,
1867 dstsize = Size.QUAD})
1868 else AppendList.single
1869 (Assembly.instruction_mov
1870 {src = test,
1871 dst = indexTemp,
1872 size = Size.QUAD}),
1873 if LiveSet.isEmpty dead
1874 then AppendList.empty
1875 else AppendList.single
1876 (Assembly.directive_force
1877 {commit_memlocs = MemLocSet.empty,
1878 commit_classes = ClassSet.empty,
1879 remove_memlocs = MemLocSet.empty,
1880 remove_classes = ClassSet.empty,
1881 dead_memlocs = LiveSet.toMemLocSet dead,
1882 dead_classes = ClassSet.empty}),
1883 if shift > 0
1884 then let
1885 val idC = Directive.Id.new ()
1886 val defaultC = pushCompensationBlock
1887 {label = default,
1888 id = idC}
1889 val _ = incNear(jumpInfo, default)
1890 in
1891 AppendList.appends
1892 [AppendList.fromList
1893 [Assembly.instruction_mov
1894 {src = indexTemp,
1895 dst = checkTemp,
1896 size = Size.QUAD},
1897 Assembly.instruction_binal
1898 {oper = Instruction.AND,
1899 src = Operand.immediate_word
1900 (ones (shift, WordSize.word64)),
1901 dst = checkTemp,
1902 size = Size.QUAD}],
1903 if WordX.isZero mask
1904 then AppendList.empty
1905 else AppendList.single
1906 (Assembly.instruction_binal
1907 {oper = Instruction.SUB,
1908 src = Operand.immediate_word mask,
1909 dst = checkTemp,
1910 size = Size.QUAD}),
1911 AppendList.fromList
1912 [Assembly.directive_force
1913 {commit_memlocs = MemLocSet.empty,
1914 commit_classes = nearflushClasses,
1915 remove_memlocs = MemLocSet.empty,
1916 remove_classes = ClassSet.empty,
1917 dead_memlocs = MemLocSet.singleton checkTemp',
1918 dead_classes = ClassSet.empty},
1919 Assembly.instruction_jcc
1920 {condition = Instruction.NZ,
1921 target = Operand.label defaultC},
1922 Assembly.directive_saveregalloc
1923 {id = idC,
1924 live = MemLocSet.add
1925 (MemLocSet.add
1926 (LiveSet.toMemLocSet default_live,
1927 stackTop ()),
1928 frontier ())},
1929 Assembly.instruction_sral
1930 {oper = Instruction.SAR,
1931 count = Operand.immediate_int shift,
1932 dst = indexTemp,
1933 size = Size.QUAD}]]
1934 end
1935 else AppendList.empty,
1936 if WordX.equals (minK, zero)
1937 then AppendList.empty
1938 else AppendList.single
1939 (Assembly.instruction_binal
1940 {oper = Instruction.SUB,
1941 src = Operand.immediate_word minK,
1942 dst = indexTemp,
1943 size = Size.QUAD}),
1944 AppendList.fromList
1945 [Assembly.directive_force
1946 {commit_memlocs = MemLocSet.empty,
1947 commit_classes = nearflushClasses,
1948 remove_memlocs = MemLocSet.empty,
1949 remove_classes = ClassSet.empty,
1950 dead_memlocs = MemLocSet.empty,
1951 dead_classes = ClassSet.empty},
1952 Assembly.directive_cache
1953 {caches = [{register = indexReg,
1954 memloc = indexTemp',
1955 reserve = false}]},
1956 Assembly.instruction_cmp
1957 {src1 = indexTemp,
1958 src2 = Operand.immediate_word rangeK,
1959 size = Size.QUAD},
1960 Assembly.instruction_jcc
1961 {condition = Instruction.A,
1962 target = Operand.label defaultD},
1963 Assembly.directive_saveregalloc
1964 {id = idD,
1965 live = MemLocSet.add
1966 (MemLocSet.add
1967 (LiveSet.toMemLocSet default_live,
1968 stackTop ()),
1969 frontier ())},
1970 Assembly.instruction_jmp
1971 {target = address,
1972 absolute = true},
1973 Assembly.directive_saveregalloc
1974 {id = idT,
1975 live = MemLocSet.add
1976 (MemLocSet.add
1977 (LiveSet.toMemLocSet live,
1978 stackTop ()),
1979 frontier ())},
1980 Assembly.directive_force
1981 {commit_memlocs = MemLocSet.empty,
1982 commit_classes = ClassSet.empty,
1983 remove_memlocs = MemLocSet.empty,
1984 remove_classes = ClassSet.empty,
1985 dead_memlocs = MemLocSet.singleton indexTemp',
1986 dead_classes = ClassSet.empty}],
1987 AppendList.fromList
1988 [Assembly.pseudoop_data (),
1989 Assembly.pseudoop_p2align
1990 (Immediate.int 4, NONE, NONE),
1991 Assembly.label jump_table_label,
1992 Assembly.pseudoop_quad jump_table,
1993 Assembly.pseudoop_text ()]]
1994 end
1995
1996 fun doit(cases)
1997 = let
1998 val (cases,
1999 minK, maxK, length,
2000 shift, mask)
2001 = reduce(cases)
2002
2003 val rangeK
2004 = range(minK,maxK)
2005 in
2006 if length >= 8
2007 andalso
2008 WordX.lt (WordX.div(rangeK,two,{signed=false}),
2009 WordX.fromIntInf (IntInf.fromInt length, ws),
2010 {signed = false})
2011 then let
2012 val cases
2013 = List.insertionSort
2014 (cases,
2015 fn ((k,_),(k',_))
2016 => ltFn(k,k'))
2017 in
2018 doitTable(cases,
2019 minK, maxK, rangeK,
2020 shift, mask)
2021 end
2022 else effectDefault gef
2023 {label = label,
2024 transfer = transfer}
2025 end
2026 in
2027 case cases
2028 of Transfer.Cases.Word cases
2029 => doit cases
2030 end
2031 | _ => effectDefault gef
2032 {label = label,
2033 transfer = transfer}
2034
2035 and fallNone (GEF {...})
2036 {label, live} : Assembly.t AppendList.t
2037 = let
2038 val liveRegsTransfer = getLiveRegsTransfers
2039 (liveTransfers, label)
2040 val liveXmmRegsTransfer = getLiveXmmRegsTransfers
2041 (liveTransfers, label)
2042
2043 val live
2044 = List.fold
2045 (liveRegsTransfer,
2046 live,
2047 fn ((memloc,_,_),live)
2048 => LiveSet.remove(live,memloc))
2049 val live
2050 = List.fold
2051 (liveXmmRegsTransfer,
2052 live,
2053 fn ((memloc,_,_),live)
2054 => LiveSet.remove(live,memloc))
2055
2056 fun default ()
2057 = AppendList.fromList
2058 ((* flushing at near transfer *)
2059 (Assembly.directive_cache
2060 {caches = [{register = stackTopReg,
2061 memloc = stackTop (),
2062 reserve = true},
2063 {register = frontierReg,
2064 memloc = frontier (),
2065 reserve = true}]})::
2066 (Assembly.directive_xmmcache
2067 {caches
2068 = List.map
2069 (liveXmmRegsTransfer,
2070 fn (temp,register,_)
2071 => {register = register,
2072 memloc = temp,
2073 reserve = true})})::
2074 (Assembly.directive_cache
2075 {caches
2076 = List.map
2077 (liveRegsTransfer,
2078 fn (temp,register,_)
2079 => {register = register,
2080 memloc = temp,
2081 reserve = true})})::
2082 (Assembly.directive_force
2083 {commit_memlocs = LiveSet.toMemLocSet live,
2084 commit_classes = nearflushClasses,
2085 remove_memlocs = MemLocSet.empty,
2086 remove_classes = ClassSet.empty,
2087 dead_memlocs = MemLocSet.empty,
2088 dead_classes = ClassSet.empty})::
2089 (Assembly.instruction_jmp
2090 {target = Operand.label label,
2091 absolute = false})::
2092 (Assembly.directive_unreserve
2093 {registers
2094 = (stackTopReg)::
2095 (frontierReg)::
2096 (List.map
2097 (liveRegsTransfer,
2098 fn (_,register,_)
2099 => register))})::
2100 (Assembly.directive_xmmunreserve
2101 {registers
2102 = (List.map
2103 (liveXmmRegsTransfer,
2104 fn (_,register,_)
2105 => register))})::
2106 nil)
2107 in
2108 case getLayoutInfo label
2109 of NONE
2110 => default ()
2111 | SOME (Block.T {...})
2112 => (push label;
2113 default ())
2114 end
2115
2116 and fallDefault (gef as GEF {generate,...})
2117 {label, live} : Assembly.t AppendList.t
2118 = let
2119 datatype z = datatype amd64JumpInfo.status
2120 val liveRegsTransfer = getLiveRegsTransfers
2121 (liveTransfers, label)
2122 val liveXmmRegsTransfer = getLiveXmmRegsTransfers
2123 (liveTransfers, label)
2124
2125 val live
2126 = List.fold
2127 (liveRegsTransfer,
2128 live,
2129 fn ((memloc,_,_),live)
2130 => LiveSet.remove(live,memloc))
2131 val live
2132 = List.fold
2133 (liveXmmRegsTransfer,
2134 live,
2135 fn ((memloc,_,_),live)
2136 => LiveSet.remove(live,memloc))
2137
2138 fun default jmp
2139 = AppendList.appends
2140 [AppendList.fromList
2141 [(* flushing at near transfer *)
2142 (Assembly.directive_cache
2143 {caches = [{register = stackTopReg,
2144 memloc = stackTop (),
2145 reserve = true},
2146 {register = frontierReg,
2147 memloc = frontier (),
2148 reserve = true}]}),
2149 (Assembly.directive_cache
2150 {caches
2151 = List.map
2152 (liveRegsTransfer,
2153 fn (temp,register,_)
2154 => {register = register,
2155 memloc = temp,
2156 reserve = true})}),
2157 (Assembly.directive_xmmcache
2158 {caches
2159 = List.map
2160 (liveXmmRegsTransfer,
2161 fn (temp,register,_)
2162 => {register = register,
2163 memloc = temp,
2164 reserve = true})}),
2165 (Assembly.directive_force
2166 {commit_memlocs = LiveSet.toMemLocSet live,
2167 commit_classes = nearflushClasses,
2168 remove_memlocs = MemLocSet.empty,
2169 remove_classes = ClassSet.empty,
2170 dead_memlocs = MemLocSet.empty,
2171 dead_classes = ClassSet.empty})],
2172 if jmp
2173 then AppendList.single
2174 (Assembly.instruction_jmp
2175 {target = Operand.label label,
2176 absolute = false})
2177 else AppendList.empty,
2178 AppendList.fromList
2179 [(Assembly.directive_unreserve
2180 {registers
2181 = (stackTopReg)::
2182 (frontierReg)::
2183 (List.map
2184 (liveRegsTransfer,
2185 fn (_,register,_)
2186 => register))}),
2187 (Assembly.directive_xmmunreserve
2188 {registers
2189 = (List.map
2190 (liveXmmRegsTransfer,
2191 fn (_,register,_)
2192 => register))})]]
2193 in
2194 case getLayoutInfo label
2195 of NONE
2196 => default true
2197 | SOME (Block.T {...})
2198 => (case getNear(jumpInfo, label)
2199 of Count 1
2200 => generate gef
2201 {label = label,
2202 falling = true,
2203 unique = true}
2204 | _ => AppendList.append
2205 (default false,
2206 AppendList.cons
2207 (Assembly.directive_reset (),
2208 (generate gef
2209 {label = label,
2210 falling = true,
2211 unique = false}))))
2212 end
2213
2214 fun make {generate, effect, fall}
2215 = generate (GEF {generate = generate,
2216 effect = effect,
2217 fall = fall})
2218
2219 val generate
2220 = case optimize
2221 of 0 => make {generate = generateAll,
2222 effect = effectDefault,
2223 fall = fallNone}
2224 | _ => make {generate = generateAll,
2225 effect = effectJumpTable,
2226 fall = fallDefault}
2227
2228 val _ = List.foreach
2229 (blocks,
2230 fn Block.T {entry, ...}
2231 => (case entry
2232 of Func {label, ...} => enque label
2233 | _ => ()))
2234 fun doit () : Assembly.t list list
2235 = (case deque ()
2236 of NONE => []
2237 | SOME label
2238 => (case AppendList.toList (generate {label = label,
2239 falling = false,
2240 unique = false})
2241 of [] => doit ()
2242 | block => block::(doit ())))
2243 val assembly = doit ()
2244 val _ = destLayoutInfo ()
2245 val _ = destProfileLabel ()
2246
2247 val assembly = [Assembly.pseudoop_text ()]::assembly
2248 val assembly =
2249 if List.isEmpty data
2250 then assembly
2251 else data::assembly
2252 in
2253 assembly
2254 end
2255
2256 val (generateTransfers, generateTransfers_msg)
2257 = tracerTop
2258 "generateTransfers"
2259 generateTransfers
2260
2261 fun generateTransfers_totals ()
2262 = (generateTransfers_msg ();
2263 Control.indent ();
2264 amd64Liveness.LiveInfo.verifyLiveInfo_msg ();
2265 amd64JumpInfo.verifyJumpInfo_msg ();
2266 amd64EntryTransfer.verifyEntryTransfer_msg ();
2267 amd64LoopInfo.createLoopInfo_msg ();
2268 amd64LiveTransfers.computeLiveTransfers_totals ();
2269 Control.unindent ())
2270 end
mlton packaging