1 (* Copyright (C) 2009,2011,2014,2017 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.
6 * MLton is released under a BSD-style license.
7 * See the file MLton-LICENSE for details.
10 functor SsaToRssa (S: SSA_TO_RSSA_STRUCTS): SSA_TO_RSSA =
16 datatype z = datatype WordSize.prim
29 structure GCField = GCField
36 type t = Type.t Prim.t
42 open Type.BuiltInCFunction
44 type t = Type.t CFunction.t
49 val gcState = CPointer
52 val thread = CPointer (* CHECK; thread (= objptr) would be better? *)
55 datatype z = datatype Convention.t
56 datatype z = datatype SymbolScope.t
57 datatype z = datatype Target.t
59 val copyCurrentThread = fn () =>
60 T {args = Vector.new1 (Type.gcState ()),
62 kind = Kind.Runtime {bytesNeeded = NONE,
63 ensuresBytesFree = false,
65 maySwitchThreads = false,
66 modifiesFrontier = true,
68 writesStackTop = true},
69 prototype = (Vector.new1 CType.gcState, NONE),
71 symbolScope = Private,
72 target = Direct "GC_copyCurrentThread"}
74 (* CHECK; thread as objptr *)
75 val copyThread = fn () =>
76 T {args = Vector.new2 (Type.gcState (), Type.thread ()),
78 kind = Kind.Runtime {bytesNeeded = NONE,
79 ensuresBytesFree = false,
81 maySwitchThreads = false,
82 modifiesFrontier = true,
84 writesStackTop = true},
88 (Vector.new2 (CPointer, CPointer), SOME CPointer)
90 return = Type.thread (),
91 symbolScope = Private,
92 target = Direct "GC_copyThread"}
95 T {args = Vector.new2 (Type.gcState (), Type.cint ()),
97 kind = Kind.Runtime {bytesNeeded = NONE,
98 ensuresBytesFree = false,
100 maySwitchThreads = false,
101 modifiesFrontier = true,
102 readsStackTop = true,
103 writesStackTop = true},
104 prototype = (Vector.new2 (CType.gcState, CType.cint ()), NONE),
106 symbolScope = Private,
107 target = Direct "MLton_halt"}
109 fun gcArrayAllocate {return} =
110 T {args = Vector.new4 (Type.gcState (),
113 Type.objptrHeader ()),
115 kind = Kind.Runtime {bytesNeeded = NONE,
116 ensuresBytesFree = true,
118 maySwitchThreads = false,
119 modifiesFrontier = true,
120 readsStackTop = true,
121 writesStackTop = true},
122 prototype = (Vector.new4 (CType.gcState,
125 CType.objptrHeader ()),
128 symbolScope = Private,
129 target = Direct "GC_arrayAllocate"}
131 fun gcArrayCopy (dt, st) =
132 T {args = Vector.new6 (Type.gcState (),
139 kind = Kind.Runtime {bytesNeeded = NONE,
140 ensuresBytesFree = true,
142 maySwitchThreads = false,
143 modifiesFrontier = true,
144 readsStackTop = true,
145 writesStackTop = true},
146 prototype = (Vector.new6 (CType.gcState,
154 symbolScope = Private,
155 target = Direct "GC_arrayCopy"}
157 val returnToC = fn () =>
158 T {args = Vector.new0 (),
160 kind = Kind.Runtime {bytesNeeded = NONE,
161 ensuresBytesFree = false,
163 maySwitchThreads = true,
164 modifiesFrontier = true,
165 readsStackTop = true,
166 writesStackTop = true},
167 prototype = (Vector.new0 (), NONE),
169 symbolScope = Private,
170 target = Direct "Thread_returnToC"}
172 (* CHECK; thread as objptr *)
173 val threadSwitchTo = fn () =>
174 T {args = Vector.new3 (Type.gcState (), Type.thread (), Type.csize ()),
176 kind = Kind.Runtime {bytesNeeded = NONE,
177 ensuresBytesFree = true,
179 maySwitchThreads = true,
180 modifiesFrontier = true,
181 readsStackTop = true,
182 writesStackTop = true},
183 prototype = (Vector.new3 (CType.gcState,
188 symbolScope = Private,
189 target = Direct "GC_switchToThread"}
191 (* CHECK; weak as objptr *)
192 fun weakCanGet {arg} =
193 T {args = Vector.new2 (Type.gcState (), arg),
195 kind = Kind.Runtime {bytesNeeded = NONE,
196 ensuresBytesFree = false,
198 maySwitchThreads = false,
199 modifiesFrontier = false,
200 readsStackTop = false,
201 writesStackTop = false},
202 prototype = (Vector.new2 (CType.gcState, CType.cpointer),
205 symbolScope = Private,
206 target = Direct "GC_weakCanGet"}
208 (* CHECK; weak as objptr *)
209 fun weakGet {arg, return} =
210 T {args = Vector.new2 (Type.gcState (), arg),
212 kind = Kind.Runtime {bytesNeeded = NONE,
213 ensuresBytesFree = false,
215 maySwitchThreads = false,
216 modifiesFrontier = false,
217 readsStackTop = false,
218 writesStackTop = false},
219 prototype = (Vector.new2 (CType.gcState, CType.cpointer),
220 SOME CType.cpointer),
222 symbolScope = Private,
223 target = Direct "GC_weakGet"}
225 (* CHECK; weak as objptr *)
226 fun weakNew {arg, return} =
227 T {args = Vector.new3 (Type.gcState (), Type.objptrHeader (), arg),
229 kind = Kind.Runtime {bytesNeeded = NONE,
230 ensuresBytesFree = false,
232 maySwitchThreads = false,
233 modifiesFrontier = true,
234 readsStackTop = true,
235 writesStackTop = true},
236 prototype = (Vector.new3 (CType.gcState,
237 CType.objptrHeader (),
239 SOME (CType.cpointer)),
241 symbolScope = Private,
242 target = Direct "GC_weakNew"}
244 val worldSave = fn () =>
245 T {args = Vector.new2 (Type.gcState (), Type.string ()),
247 kind = Kind.Runtime {bytesNeeded = NONE,
248 ensuresBytesFree = false,
250 maySwitchThreads = false,
251 modifiesFrontier = true,
252 readsStackTop = true,
253 writesStackTop = true},
254 prototype = (Vector.new2 (CType.gcState, CType.cpointer), NONE),
256 symbolScope = Private,
257 target = Direct "GC_saveWorld"}
259 (* CHECK; share with objptr *)
261 T {args = Vector.new2 (Type.gcState (), t),
263 kind = Kind.Runtime {bytesNeeded = NONE,
264 ensuresBytesFree = false,
265 mayGC = true, (* MLton.share works by tracing an object.
266 * Make sure all the GC invariants are true,
267 * because tracing might encounter the current
270 maySwitchThreads = false,
271 modifiesFrontier = true, (* actually, just readsFrontier *)
272 readsStackTop = true,
273 writesStackTop = true},
274 prototype = (Vector.new2 (CType.gcState, CType.cpointer), NONE),
276 symbolScope = Private,
277 target = Direct "GC_share"}
279 (* CHECK; size with objptr *)
281 T {args = Vector.new2 (Type.gcState (), t),
283 kind = Kind.Runtime {bytesNeeded = NONE,
284 ensuresBytesFree = false,
285 mayGC = true, (* MLton.size works by tracing an object.
286 * Make sure all the GC invariants are true,
287 * because tracing might encounter the current
290 maySwitchThreads = false,
291 modifiesFrontier = true,
292 readsStackTop = true,
293 writesStackTop = true},
294 prototype = (Vector.new2 (CType.gcState, CType.cpointer),
295 SOME (CType.csize ())),
296 return = Type.csize (),
297 symbolScope = Private,
298 target = Direct "GC_size"}
300 fun amAllocationProfiling () =
301 Control.ProfileAlloc = !Control.profile
302 val intInfBinary = fn name =>
303 CFunction.T {args = Vector.new4 (Type.gcState (),
308 kind = CFunction.Kind.Runtime {bytesNeeded = SOME 3,
309 ensuresBytesFree = false,
311 maySwitchThreads = false,
312 modifiesFrontier = true,
313 readsStackTop = amAllocationProfiling (),
314 writesStackTop = false},
315 prototype = (Vector.new4 (CType.gcState,
320 return = Type.intInf (),
321 symbolScope = Private,
322 target = Direct (Prim.Name.toString name)}
323 val intInfCompare = fn name =>
324 (* CHECK; cint would be better? *)
325 CFunction.T {args = Vector.new3 (Type.gcState (),
329 kind = CFunction.Kind.Runtime {bytesNeeded = NONE,
330 ensuresBytesFree = false,
332 maySwitchThreads = false,
333 modifiesFrontier = false,
334 readsStackTop = false,
335 writesStackTop = false},
336 prototype = (Vector.new3 (CType.gcState,
339 SOME CType.compareRes),
340 return = Type.compareRes,
341 symbolScope = Private,
342 target = Direct (Prim.Name.toString name)}
343 val intInfShift = fn name =>
344 CFunction.T {args = Vector.new4 (Type.gcState (),
349 kind = CFunction.Kind.Runtime {bytesNeeded = SOME 3,
350 ensuresBytesFree = false,
352 maySwitchThreads = false,
353 modifiesFrontier = true,
354 readsStackTop = amAllocationProfiling (),
355 writesStackTop = false},
356 prototype = (Vector.new4 (CType.gcState,
361 return = Type.intInf (),
362 symbolScope = Private,
363 target = Direct (Prim.Name.toString name)}
364 val intInfToString = fn name =>
365 (* CHECK; cint would be better? *)
366 CFunction.T {args = Vector.new4 (Type.gcState (),
368 Type.word WordSize.word32,
371 kind = CFunction.Kind.Runtime {bytesNeeded = SOME 3,
372 ensuresBytesFree = false,
374 maySwitchThreads = false,
375 modifiesFrontier = true,
376 readsStackTop = amAllocationProfiling (),
377 writesStackTop = false},
378 prototype = (Vector.new4 (CType.gcState,
383 return = Type.string (),
384 symbolScope = Private,
385 target = Direct (Prim.Name.toString name)}
386 val intInfUnary = fn name =>
387 CFunction.T {args = Vector.new3 (Type.gcState (),
391 kind = CFunction.Kind.Runtime {bytesNeeded = SOME 2,
392 ensuresBytesFree = false,
394 maySwitchThreads = false,
395 modifiesFrontier = true,
396 readsStackTop = amAllocationProfiling (),
397 writesStackTop = false},
398 prototype = (Vector.new3 (CType.gcState,
402 return = Type.intInf (),
403 symbolScope = Private,
404 target = Direct (Prim.Name.toString name)}
413 fun cFunctionRaise (n: t): CFunction.t =
415 datatype z = datatype CFunction.Convention.t
416 datatype z = datatype CFunction.SymbolScope.t
417 datatype z = datatype CFunction.Target.t
418 val name = toString n
421 val vanilla = CFunction.vanilla
422 fun wordCType (s, sg) = CType.word (s, sg)
423 fun realCType s = CType.real s
424 fun coerce (t1, ct1, t2, ct2) =
425 vanilla {args = Vector.new1 t1,
427 prototype = (Vector.new1 ct1, SOME ct2),
433 val ct = CType.real s
435 vanilla {args = Vector.new (n, t),
437 prototype = (Vector.new (n, ct), SOME ct),
441 val realBinary = make 2
442 val realTernary = make 3
443 val realUnary = make 1
449 vanilla {args = Vector.new2 (t, t),
454 (Vector.new2 (t, t), SOME CType.bool)
462 val ct = CType.word (s, sg)
464 vanilla {args = Vector.new (n, t),
466 prototype = (Vector.new (n, ct), SOME ct),
469 fun makeOverflows n (s, sg) =
472 val ct = CType.word (s, sg)
474 vanilla {args = Vector.new (n, t),
475 name = name ^ "Overflows",
476 prototype = (Vector.new (n, ct), SOME CType.bool),
480 val wordBinary = make 2
481 val wordBinaryOverflows = makeOverflows 2
482 val wordUnary = make 1
483 val wordUnaryOverflows = makeOverflows 1
485 fun wordCompare (s, sg) =
488 val ct = CType.word (s, sg)
490 vanilla {args = Vector.new2 (t, t),
492 prototype = (Vector.new2 (ct, ct), SOME CType.bool),
495 fun wordShift (s, sg) =
498 val ct = CType.word (s, sg)
500 vanilla {args = Vector.new2 (t, Type.shiftArg),
502 prototype = (Vector.new2 (ct, CType.shiftArg), SOME ct),
507 MLton_bug => CFunction.bug ()
508 | Real_Math_acos s => realUnary s
509 | Real_Math_asin s => realUnary s
510 | Real_Math_atan s => realUnary s
511 | Real_Math_atan2 s => realBinary s
512 | Real_Math_cos s => realUnary s
513 | Real_Math_exp s => realUnary s
514 | Real_Math_ln s => realUnary s
515 | Real_Math_log10 s => realUnary s
516 | Real_Math_sin s => realUnary s
517 | Real_Math_sqrt s => realUnary s
518 | Real_Math_tan s => realUnary s
519 | Real_abs s => realUnary s
520 | Real_add s => realBinary s
521 | Real_castToWord (s1, s2) =>
522 coerce (real s1, realCType s1,
523 word s2, wordCType (s2, {signed = false}))
524 | Real_div s => realBinary s
525 | Real_equal s => realCompare s
529 val ct = CType.real s
531 vanilla {args = Vector.new2 (t, Type.cint ()),
533 prototype = (Vector.new2 (ct, CType.cint ()),
537 | Real_le s => realCompare s
538 | Real_lt s => realCompare s
539 | Real_mul s => realBinary s
540 | Real_muladd s => realTernary s
541 | Real_mulsub s => realTernary s
542 | Real_neg s => realUnary s
543 | Real_qequal s => realCompare s
544 | Real_rndToReal (s1, s2) =>
545 coerce (real s1, realCType s1, real s2, realCType s2)
546 | Real_rndToWord (s1, s2, sg) =>
547 coerce (real s1, realCType s1,
548 word s2, wordCType (s2, sg))
549 | Real_round s => realUnary s
550 | Real_sub s => realBinary s
551 | Thread_returnToC => CFunction.returnToC ()
552 | Word_add s => wordBinary (s, {signed = false})
553 | Word_addCheck (s, sg) => wordBinaryOverflows (s, sg)
554 | Word_andb s => wordBinary (s, {signed = false})
555 | Word_castToReal (s1, s2) =>
556 coerce (word s1, wordCType (s1, {signed = false}),
557 real s2, realCType s2)
558 | Word_equal s => wordCompare (s, {signed = false})
559 | Word_extdToWord (s1, s2, sg) =>
560 coerce (word s1, wordCType (s1, sg),
561 word s2, wordCType (s2, {signed = false}))
562 | Word_lshift s => wordShift (s, {signed = false})
563 | Word_lt z => wordCompare z
564 | Word_mul z => wordBinary z
565 | Word_mulCheck (s, sg) => wordBinaryOverflows (s, sg)
566 | Word_neg s => wordUnary (s, {signed = true})
567 | Word_negCheck s => wordUnaryOverflows (s, {signed = true})
568 | Word_notb s => wordUnary (s, {signed = false})
569 | Word_orb s => wordBinary (s, {signed = false})
570 | Word_quot z => wordBinary z
571 | Word_rem z => wordBinary z
572 | Word_rndToReal (s1, s2, sg) =>
573 coerce (word s1, wordCType (s1, sg),
574 real s2, realCType s2)
575 | Word_xorb s => wordBinary (s, {signed = false})
576 | Word_rol s => wordShift (s, {signed = false})
577 | Word_ror s => wordShift (s, {signed = false})
578 | Word_rshift z => wordShift z
579 | Word_sub s => wordBinary (s, {signed = false})
580 | Word_subCheck (s, sg) => wordBinaryOverflows (s, sg)
581 | _ => Error.bug "SsaToRssa.Name.cFunctionRaise"
584 fun cFunction n = SOME (cFunctionRaise n) handle _ => NONE
587 datatype z = datatype Operand.t
588 datatype z = datatype Statement.t
589 datatype z = datatype Transfer.t
591 structure PackedRepresentation = PackedRepresentation (structure Rssa = Rssa
598 fun scale (ty: t): Scale.t =
599 case Scale.fromBytes (bytes ty) of
600 NONE => Error.bug "SsaToRssa.Type.scale"
604 val cardSizeLog2 : IntInf.t = 8 (* must agree with CARD_SIZE_LOG2 in gc.c *)
606 fun updateCard (addr: Operand.t): Statement.t list =
608 val index = Var.newNoname ()
609 (* CHECK; WordSize.objptr or WordSize.cpointer? *)
610 val sz = WordSize.objptr ()
611 val indexTy = Type.word sz
612 val cardElemSize = WordSize.fromBits Bits.inByte
614 [PrimApp {args = (Vector.new2
615 (Operand.cast (addr, Type.bits (WordSize.bits sz)),
617 (WordX.fromIntInf (cardSizeLog2, WordSize.shiftArg)))),
618 dst = SOME (index, indexTy),
619 prim = Prim.wordRshift (sz, {signed = false})},
620 Move {dst = (ArrayOffset
621 {base = Runtime GCField.CardMapAbsolute,
622 index = Var {ty = indexTy, var = index},
625 ty = Type.word cardElemSize}),
626 src = Operand.word (WordX.one cardElemSize)}]
629 fun convertWordSize (ws: WordSize.t): WordSize.t =
630 WordSize.roundUpToPrim ws
632 fun convertWordX (w: WordX.t): WordX.t =
633 WordX.resize (w, convertWordSize (WordX.size w))
635 fun convert (program as S.Program.T {functions, globals, main, ...},
636 {codegenImplementsPrim: Rssa.Type.t Rssa.Prim.t -> bool}): Rssa.Program.t =
638 val {diagnostic, genCase, object, objectTypes, select, toRtype, update} =
639 PackedRepresentation.compute program
640 val objectTypes = Vector.concat [ObjectType.basic (), objectTypes]
643 (objectTypes, fn (i, (opt, _)) => ObjptrTycon.setIndex (opt, i))
644 val objectTypes = Vector.map (objectTypes, #2)
645 val () = diagnostic ()
647 val newObjectTypes = ref []
649 val h = HashSet.new {hash = fn {bits, ...} =>
652 fun allocRawOpt width =
653 (#opt o HashSet.lookupOrInsert)
654 (h, Bits.toWord width,
655 fn {bits, ...} => Bits.equals (bits, width),
658 val rawElt = Type.bits width
659 val rawTy = ObjectType.Array {elt = rawElt, hasIdentity = true}
660 val rawOpt = ObjptrTycon.new ()
663 (rawOpt, Vector.length objectTypes + HashSet.size h)
665 List.push (newObjectTypes, rawTy)
667 {bits = width, opt = rawOpt}
671 val {get = varInfo: Var.t -> {ty: S.Type.t},
672 set = setVarInfo, ...} =
673 Property.getSetOnce (Var.plist,
674 Property.initRaise ("varInfo", Var.layout))
676 Trace.trace2 ("SsaToRssa.setVarInfo",
677 Var.layout, S.Type.layout o #ty, Unit.layout)
679 val varType = #ty o varInfo
680 fun varOp (x: Var.t): Operand.t =
681 Var {var = x, ty = valOf (toRtype (varType x))}
683 Trace.trace ("SsaToRssa.varOp", Var.layout, Operand.layout) varOp
684 fun varOps xs = Vector.map (xs, varOp)
685 val extraBlocks = ref []
686 fun newBlock {args, kind,
687 statements: Statement.t vector,
688 transfer: Transfer.t}: Label.t =
690 val l = Label.newNoname ()
691 val _ = List.push (extraBlocks,
692 Block.T {args = args,
695 statements = statements,
696 transfer = transfer})
700 val {get = labelInfo: (Label.t ->
701 {args: (Var.t * S.Type.t) vector,
702 cont: (Handler.t * Label.t) list ref,
703 handler: Label.t option ref}),
704 set = setLabelInfo, ...} =
705 Property.getSetOnce (Label.plist,
706 Property.initRaise ("label info", Label.layout))
707 fun translateCase ({test: Var.t,
709 default: Label.t option})
710 : Statement.t list * Transfer.t =
713 (case (Vector.length cases, default) of
714 (0, NONE) => ([], Transfer.bug ())
716 (case S.Type.dest (varType test) of
717 S.Type.Datatype tycon =>
719 val test = fn () => varOp test
722 (cases, fn (con, dst) =>
727 (#args (labelInfo dst), false, fn ((_,ty),b) =>
728 b orelse isSome (toRtype ty))})
729 val (ss, t, blocks) =
730 genCase {cases = cases,
735 extraBlocks := blocks @ !extraBlocks
739 | _ => Error.bug "SsaToRssa.translateCase: strange type"))
740 | S.Cases.Word (s, cases) =>
744 (Vector.map (cases, fn (w, l) => (convertWordX w, l)),
745 fn ((w, _), (w', _)) => WordX.le (w, w', {signed = false}))
752 size = convertWordSize s,
755 fun eta (l: Label.t, kind: Kind.t): Label.t =
757 val {args, ...} = labelInfo l
758 val args = Vector.keepAllMap (args, fn (x, t) =>
759 Option.map (toRtype t, fn t =>
765 Block.T {args = args,
768 statements = Vector.new0 (),
769 transfer = (Transfer.Goto
771 args = Vector.map (args, fn (var, ty) =>
777 fun labelHandler (l: Label.t): Label.t =
779 val {handler, ...} = labelInfo l
784 val l' = eta (l, Kind.Handler)
785 val _ = handler := SOME l'
791 fun labelCont (l: Label.t, h: Handler.t): Label.t =
793 val {cont, ...} = labelInfo l
794 datatype z = datatype Handler.t
796 case List.peek (!cont, fn (h', _) => Handler.equals (h, h')) of
800 val l' = eta (l, Kind.Cont {handler = h})
801 val _ = List.push (cont, (h, l'))
807 Trace.trace2 ("SsaToRssa.labelCont",
808 Label.layout, Handler.layout, Label.layout)
810 fun vos (xs: Var.t vector) =
811 Vector.keepAllMap (xs, fn x =>
812 Option.map (toRtype (varType x), fn _ =>
814 fun bogus (t: Type.t): Operand.t =
815 case Type.deReal t of
816 NONE => Operand.cast (Operand.word (Type.bogusWord t), t)
817 | SOME s => Operand.Const (Const.real (RealX.zero s))
822 Prim.Name.MLton_installSignalHandler => true
824 fun translateFormals v =
825 Vector.keepAllMap (v, fn (x, t) =>
826 Option.map (toRtype t, fn t => (x, t)))
827 fun translatePrim p =
832 fun translateTransfer (t: S.Transfer.t): (Statement.t list *
835 S.Transfer.Arith {args, overflow, prim, success, ty} =>
837 val prim = translatePrim prim
838 val ty = valOf (toRtype ty)
839 val res = Var.newNoname ()
842 {args = Vector.new0 (),
844 statements = Vector.new0 (),
845 transfer = (Transfer.Goto
848 (Var {var = res, ty = ty}))})}
850 if codegenImplementsPrim prim
852 Transfer.Arith {dst = res,
856 success = noOverflow,
860 datatype z = datatype Prim.Name.t
861 fun doOperCheckCF (operCheck) =
864 case Name.cFunction operCheck of
867 (concat ["SsaToRssa.translateTransfer: ",
868 "unimplemented arith:",
869 Name.toString operCheck])
870 | SOME operCheckCF => operCheckCF
873 val checkRes = Var.newNoname ()
876 {args = Vector.new1 (checkRes, Type.bool),
877 kind = Kind.CReturn {func = operCheckCF},
878 statements = Vector.new0 (),
879 transfer = (Transfer.ifBool
880 (Var {var = checkRes,
882 {falsee = noOverflow,
889 return = SOME afterOperCheck}
891 fun doOperCF (oper, operCheck) =
894 case Name.cFunction oper of
897 (concat ["SsaToRssa.translateTransfer: ",
898 "unimplemented arith:",
900 | SOME operCF => operCF
903 {args = Vector.new1 (res, ty),
904 kind = Kind.CReturn {func = operCF},
905 statements = Vector.new0 (),
906 transfer = doOperCheckCF operCheck}
911 return = SOME afterOper}
915 {dst = SOME (res, ty),
918 fun doit (prim, operCheck) =
919 if codegenImplementsPrim prim
920 then (doPrim prim, doOperCheckCF operCheck)
921 else ([], doOperCF (Prim.name prim, operCheck))
923 case Prim.name prim of
924 Word_addCheck (s, sg) =>
925 doit (Prim.wordAdd s,
926 Word_addCheck (s, sg))
927 | Word_mulCheck (s, sg) =>
928 doit (Prim.wordMul (s, sg),
929 Word_mulCheck (s, sg))
931 doit (Prim.wordNeg s,
933 | Word_subCheck (s, sg) =>
934 doit (Prim.wordSub s,
935 Word_subCheck (s, sg))
936 | _ => Error.bug (concat ["SsaToRssa.translateTransfer: ",
938 Name.toString (Prim.name prim)])
941 | S.Transfer.Bug => ([], Transfer.bug ())
942 | S.Transfer.Call {func, args, return} =>
944 datatype z = datatype S.Return.t
948 | NonTail {cont, handler} =>
950 datatype z = datatype S.Handler.t
953 Caller => Handler.Caller
954 | Dead => Handler.Dead
955 | Handle l => Handler.Handle (labelHandler l)
957 Return.NonTail {cont = labelCont (cont, handler),
960 | Tail => Return.Tail
962 ([], Transfer.Call {func = func,
966 | S.Transfer.Case r => translateCase r
967 | S.Transfer.Goto {dst, args} =>
968 ([], Transfer.Goto {dst = dst, args = vos args})
969 | S.Transfer.Raise xs => ([], Transfer.Raise (vos xs))
970 | S.Transfer.Return xs => ([], Transfer.Return (vos xs))
971 | S.Transfer.Runtime {args, prim, return} =>
973 datatype z = datatype Prim.Name.t
975 case Prim.name prim of
979 {args = Vector.concat [Vector.new1 GCState,
981 func = CFunction.halt (),
983 | Thread_copyCurrent =>
985 val func = CFunction.copyCurrentThread ()
987 newBlock {args = Vector.new0 (),
988 kind = Kind.CReturn {func = func},
989 statements = Vector.new0 (),
990 transfer = (Goto {args = Vector.new0 (),
995 {args = Vector.concat [Vector.new1 GCState,
1000 | _ => Error.bug (concat
1001 ["SsaToRssa.translateTransfer: ",
1002 "strange Runtime prim: ",
1003 Prim.toString prim])
1005 fun translateStatementsTransfer (statements, ss, transfer) =
1007 fun loop (i, ss, t): Statement.t vector * Transfer.t =
1009 then (Vector.fromList ss, t)
1012 fun none () = loop (i - 1, ss, t)
1013 fun add s = loop (i - 1, s :: ss, t)
1014 fun add2 (s1, s2) = loop (i - 1, s1 :: s2 :: ss, t)
1015 fun adds ss' = loop (i - 1, ss' @ ss, t)
1016 val s = Vector.sub (statements, i)
1019 S.Statement.Profile e => add (Statement.Profile e)
1020 | S.Statement.Update {base, offset, value} =>
1021 (case toRtype (varType value) of
1025 val baseOp = Base.map (base, varOp)
1029 baseTy = varType (Base.object base),
1031 value = varOp value}
1033 if !Control.markCards
1034 andalso Type.isObjptr t
1036 updateCard (Base.object baseOp)
1042 | S.Statement.Bind {exp, ty, var} =>
1044 fun split (args, kind,
1045 ss: Statement.t list,
1046 make: Label.t -> Statement.t list * Transfer.t) =
1048 val l = newBlock {args = args,
1050 statements = Vector.fromList ss,
1052 val (ss, t) = make l
1056 fun maybeMove (f: Type.t -> Operand.t) =
1060 add (Bind {dst = (valOf var, ty),
1063 fun move (src: Operand.t) = maybeMove (fn _ => src)
1071 maybeMove (fn ty => Operand.cast (Const c, ty))
1073 case Const.IntInfRep.fromIntInf i of
1074 Const.IntInfRep.Big v =>
1075 doit (Const.WordVector v)
1076 | Const.IntInfRep.Small w =>
1079 | Const.Word w => move (Const (Const.Word (convertWordX w)))
1080 | _ => move (Const c))
1081 | S.Exp.Inject {variant, ...} =>
1082 if isSome (toRtype ty)
1083 then move (varOp variant)
1085 | S.Exp.Object {args, con} =>
1089 adds (object {args = args,
1091 dst = (valOf var, dstTy),
1094 | S.Exp.PrimApp {args, prim} =>
1096 val prim = translatePrim prim
1097 fun arg i = Vector.sub (args, i)
1098 fun a i = varOp (arg i)
1100 move (Operand.cast (a 0, valOf (toRtype ty)))
1101 fun ifIsWeakPointer (ty: S.Type.t, yes, no) =
1102 case S.Type.dest ty of
1110 | _ => Error.bug "SsaToRssa.ifIsWeakPointer"
1111 fun arrayOrVectorLength () =
1114 offset = Runtime.arrayLengthOffset (),
1115 ty = Type.seqIndex ()})
1118 val ty = Type.word s
1120 move (ArrayOffset {base = a 0,
1122 offset = Bytes.zero,
1123 scale = Type.scale ty,
1129 Option.map (toRtype (varType x), fn t =>
1133 add (PrimApp {dst = dst (),
1135 args = varOps args})
1136 datatype z = datatype Prim.Name.t
1137 fun bumpAtomicState n =
1139 val atomicState = Runtime GCField.AtomicState
1140 val res = Var.newNoname ()
1141 val resTy = Operand.ty atomicState
1144 {args = (Vector.new2
1149 WordSize.word32))))),
1150 dst = SOME (res, resTy),
1151 prim = Prim.wordAdd WordSize.word32},
1154 src = Var {ty = resTy, var = res}}]
1156 fun ccall {args: Operand.t vector,
1157 func: CFunction.t} =
1161 NONE => Vector.new0 ()
1162 | SOME (x, t) => Vector.new1 (x, t)
1165 (formals, Kind.CReturn {func = func}, ss,
1168 Transfer.CCall {args = args,
1172 fun simpleCCall (f: CFunction.t) =
1173 ccall {args = vos args,
1175 fun simpleCCallWithGCState (f: CFunction.t) =
1176 ccall {args = Vector.concat
1177 [Vector.new1 GCState,
1180 fun arrayAlloc (numElts: Operand.t, opt) =
1182 val result = valOf (toRtype ty)
1184 Vector.new4 (GCState,
1189 CFunction.gcArrayAllocate
1192 ccall {args = args, func = func}
1194 fun cpointerGet () =
1196 ArrayOffset {base = a 0,
1198 offset = Bytes.zero,
1199 scale = Type.scale ty,
1201 fun cpointerSet () =
1204 val ty = Operand.ty src
1206 add (Move {dst = ArrayOffset {base = a 0,
1208 offset = Bytes.zero,
1209 scale = Type.scale ty,
1213 fun codegenOrC (p: Prim.t) =
1217 if codegenImplementsPrim p
1219 else (case Name.cFunction n of
1221 Error.bug (concat ["SsaToRssa.codegenOrC: ",
1222 "unimplemented prim:",
1224 | SOME f => simpleCCall f)
1226 datatype z = datatype Prim.Name.t
1228 case Prim.name prim of
1229 Array_alloc {raw} =>
1231 val allocOpt = fn () =>
1233 val result = valOf (toRtype ty)
1235 case Type.deObjptr result of
1236 NONE => Error.bug "SsaToRssa.translateStatementsTransfer: PrimApp,Array_alloc"
1241 val allocRawOpt = fn () =>
1243 val result = valOf (toRtype ty)
1245 case Type.deObjptr result of
1246 NONE => Error.bug "SsaToRssa.translateStatementsTransfer: PrimApp,Array_allocRaw"
1247 | SOME arrOpt => arrOpt
1249 Vector.sub (objectTypes, ObjptrTycon.index arrOpt)
1252 ObjectType.Array {elt, ...} => elt
1253 | _ => Error.bug "SsaToRssa.translateStatementsTransfer: PrimApp,Array_allocRaw"
1254 val rawOpt = allocRawOpt (Type.width arrElt)
1259 arrayAlloc (a 0, if raw then allocRawOpt () else allocOpt ())
1261 | Array_copyArray => simpleCCallWithGCState (CFunction.gcArrayCopy (Operand.ty (a 0), Operand.ty (a 2)))
1262 | Array_copyVector => simpleCCallWithGCState (CFunction.gcArrayCopy (Operand.ty (a 0), Operand.ty (a 2)))
1263 | Array_length => arrayOrVectorLength ()
1267 val arrTy = valOf (toRtype ty)
1269 case Type.deObjptr arrTy of
1270 NONE => Error.bug "SsaToRssa.translateStatementsTransfer: PrimApp,Array_toArray"
1271 | SOME arrOpt => arrOpt
1277 offset = Runtime.headerOffset (),
1278 ty = Type.objptrHeader ()}),
1279 src = ObjptrTycon arrOpt},
1280 Bind {dst = (valOf var, arrTy),
1282 src = Operand.cast (rawarr, arrTy)})
1287 val vecTy = valOf (toRtype ty)
1289 case Type.deObjptr vecTy of
1290 NONE => Error.bug "SsaToRssa.translateStatementsTransfer: PrimApp,Array_toVector"
1291 | SOME vecOpt => vecOpt
1297 offset = Runtime.headerOffset (),
1298 ty = Type.objptrHeader ()}),
1299 src = ObjptrTycon vecOpt},
1300 Bind {dst = (valOf var, vecTy),
1302 src = Operand.cast (array, vecTy)})
1307 val arrayTy = varType (arg 0)
1310 case S.Type.deVectorOpt arrayTy of
1311 NONE => Error.bug "SsaToRssa.translateStatementsTransfer: PrimApp,Array_uninit"
1312 | SOME eltTys => eltTys
1314 (Vector.toList o Vector.keepAllMapi)
1315 (S.Prod.dest eltTys, fn (offset, {elt, ...}) =>
1319 if not (Type.isObjptr elt)
1321 else (SOME o update)
1322 {base = Base.VectorSub
1329 adds (List.concat sss)
1331 | Array_uninitIsNop =>
1333 val arrayTy = varType (arg 0)
1335 case S.Type.deVectorOpt arrayTy of
1336 NONE => Error.bug "SsaToRssa.translateStatementsTransfer: PrimApp,Array_uninitIsNop"
1337 | SOME eltTys => eltTys
1340 (S.Prod.dest eltTys, fn {elt, ...} =>
1343 | SOME elt => not (Type.isObjptr elt))
1345 move (Operand.bool isNop)
1347 | CPointer_getCPointer => cpointerGet ()
1348 | CPointer_getObjptr => cpointerGet ()
1349 | CPointer_getReal _ => cpointerGet ()
1350 | CPointer_getWord _ => cpointerGet ()
1351 | CPointer_setCPointer => cpointerSet ()
1352 | CPointer_setObjptr => cpointerSet ()
1353 | CPointer_setReal _ => cpointerSet ()
1354 | CPointer_setWord _ => cpointerSet ()
1355 | FFI f => simpleCCall f
1358 {args = (Vector.new3
1360 Operand.zero (WordSize.csize ()),
1361 Operand.bool true)),
1362 func = (CFunction.gc
1363 {maySwitchThreads = handlesSignals})}
1365 simpleCCallWithGCState
1366 (CFunction.intInfBinary IntInf_add)
1368 simpleCCallWithGCState
1369 (CFunction.intInfBinary IntInf_andb)
1371 simpleCCallWithGCState
1372 (CFunction.intInfShift IntInf_arshift)
1374 simpleCCallWithGCState
1375 (CFunction.intInfCompare IntInf_compare)
1377 simpleCCallWithGCState
1378 (CFunction.intInfBinary IntInf_gcd)
1380 simpleCCallWithGCState
1381 (CFunction.intInfShift IntInf_lshift)
1383 simpleCCallWithGCState
1384 (CFunction.intInfBinary IntInf_mul)
1386 simpleCCallWithGCState
1387 (CFunction.intInfUnary IntInf_neg)
1389 simpleCCallWithGCState
1390 (CFunction.intInfUnary IntInf_notb)
1392 simpleCCallWithGCState
1393 (CFunction.intInfBinary IntInf_orb)
1395 simpleCCallWithGCState
1396 (CFunction.intInfBinary IntInf_quot)
1398 simpleCCallWithGCState
1399 (CFunction.intInfBinary IntInf_rem)
1401 simpleCCallWithGCState
1402 (CFunction.intInfBinary IntInf_sub)
1403 | IntInf_toString =>
1404 simpleCCallWithGCState
1405 (CFunction.intInfToString IntInf_toString)
1406 | IntInf_toVector => cast ()
1407 | IntInf_toWord => cast ()
1409 simpleCCallWithGCState
1410 (CFunction.intInfBinary IntInf_xorb)
1414 | SOME t => move (bogus t))
1416 (case toRtype (varType (arg 0)) of
1417 NONE => move (Operand.bool true)
1421 (WordSize.fromBits (Type.width t))))
1422 | MLton_installSignalHandler => none ()
1424 (case toRtype (varType (arg 0)) of
1427 if not (Type.isObjptr t)
1430 simpleCCallWithGCState
1431 (CFunction.share (Operand.ty (a 0))))
1433 (case toRtype (varType (arg 0)) of
1434 NONE => move (Operand.word (WordX.zero (WordSize.csize ())))
1436 if not (Type.isObjptr t)
1437 then move (Operand.word (WordX.zero (WordSize.csize ())))
1439 simpleCCallWithGCState
1440 (CFunction.size (Operand.ty (a 0))))
1445 if isSome (toRtype (varType a))
1446 then Vector.new1 (varOp a)
1449 add (PrimApp {args = args,
1453 | Thread_atomicBegin =>
1454 (* gcState.atomicState++;
1455 * if (gcState.signalsInfo.signalIsPending)
1456 * gcState.limit = gcState.limitPlusSlop - LIMIT_SLOP;
1459 (Vector.new0 (), Kind.Jump, ss,
1462 datatype z = datatype GCField.t
1463 val tmp = Var.newNoname ()
1464 val size = WordSize.cpointer ()
1465 val ty = Type.cpointer ()
1469 {args = (Vector.new2
1470 (Runtime LimitPlusSlop,
1474 (Bytes.toInt Runtime.limitSlop),
1476 dst = SOME (tmp, ty),
1477 prim = Prim.cpointerSub},
1479 {dst = Runtime Limit,
1480 src = Var {ty = ty, var = tmp}})
1481 val signalIsPending =
1483 {args = Vector.new0 (),
1485 statements = statements,
1486 transfer = (Transfer.Goto
1487 {args = Vector.new0 (),
1494 (Runtime SignalIsPending,
1496 truee = signalIsPending})
1498 Transfer.Goto {args = Vector.new0 (),
1501 | Thread_atomicEnd =>
1502 (* gcState.atomicState--;
1503 * if (gcState.signalsInfo.signalIsPending
1504 * and 0 == gcState.atomicState)
1508 (Vector.new0 (), Kind.Jump, ss,
1511 datatype z = datatype GCField.t
1513 CFunction.gc {maySwitchThreads = true}
1514 val returnFromHandler =
1516 {args = Vector.new0 (),
1517 kind = Kind.CReturn {func = func},
1518 statements = Vector.new0 (),
1520 Goto {args = Vector.new0 (),
1525 Operand.zero (WordSize.csize ()),
1527 val switchToHandler =
1529 {args = Vector.new0 (),
1531 statements = Vector.new0 (),
1536 return = SOME returnFromHandler}}
1537 val testAtomicState =
1539 {args = Vector.new0 (),
1541 statements = Vector.new0 (),
1544 (Runtime AtomicState,
1546 truee = switchToHandler})}
1548 (bumpAtomicState ~1,
1552 (Runtime SignalIsPending,
1554 truee = testAtomicState})
1556 Transfer.Goto {args = Vector.new0 (),
1559 | Thread_atomicState =>
1560 move (Runtime GCField.AtomicState)
1562 simpleCCallWithGCState
1563 (CFunction.copyThread ())
1564 | Thread_switchTo =>
1565 ccall {args = (Vector.new3
1569 func = CFunction.threadSwitchTo ()}
1570 | Vector_length => arrayOrVectorLength ()
1575 simpleCCallWithGCState
1576 (CFunction.weakCanGet
1577 {arg = Operand.ty (a 0)}),
1578 fn () => move (Operand.bool false))
1583 simpleCCallWithGCState
1585 {arg = Operand.ty (a 0),
1587 fn () => (case toRtype ty of
1589 | SOME t => move (bogus t)))
1595 val result = valOf (toRtype ty)
1598 (case Type.deObjptr result of
1599 NONE => Error.bug "SsaToRssa.translateStatementsTransfer: PrimApp,Weak_new"
1602 CFunction.weakNew {arg = t,
1605 ccall {args = (Vector.concat
1613 codegenOrC (Prim.wordEqual
1614 (WordSize.roundUpToPrim s))
1615 | Word_toIntInf => cast ()
1616 | Word_extdToWord (s1, s2, {signed}) =>
1617 if WordSize.equals (s1, s2)
1623 andalso Bits.< (WordSize.bits s1,
1625 val s1 = WordSize.roundUpToPrim s1
1626 val s2 = WordSize.roundUpToPrim s2
1628 if WordSize.equals (s1, s2)
1632 (Prim.wordExtdToWord
1633 (s1, s2, {signed = signed}))
1635 | WordVector_toIntInf => cast ()
1636 | WordArray_subWord {eleSize, ...} =>
1638 | WordArray_updateWord {eleSize, ...} =>
1640 val ty = Type.word eleSize
1642 add (Move {dst = (ArrayOffset
1645 offset = Bytes.zero,
1646 scale = Type.scale ty,
1650 | WordVector_subWord {eleSize, ...} =>
1653 simpleCCallWithGCState
1654 (CFunction.worldSave ())
1655 | _ => codegenOrC prim
1657 | S.Exp.Select {base, offset} =>
1666 {base = Base.map (base, varOp),
1667 baseTy = varType (Base.object base),
1673 | SOME _ => move (varOp y))
1677 loop (Vector.length statements - 1, ss, transfer)
1679 fun translateBlock (S.Block.T {label, args, statements, transfer}) =
1681 val (ss, t) = translateTransfer transfer
1682 val (ss, t) = translateStatementsTransfer (statements, ss, t)
1684 Block.T {args = translateFormals args,
1690 fun translateFunction (f: S.Function.t): Function.t =
1693 S.Function.foreachVar (f, fn (x, t) => setVarInfo (x, {ty = t}))
1694 val {args, blocks, name, raises, returns, start, ...} =
1698 (blocks, fn S.Block.T {label, args, ...} =>
1699 setLabelInfo (label, {args = args,
1701 handler = ref NONE}))
1702 val blocks = Vector.map (blocks, translateBlock)
1703 val blocks = Vector.concat [Vector.fromList (!extraBlocks), blocks]
1704 val _ = extraBlocks := []
1705 fun transTypes (ts : S.Type.t vector option)
1706 : Type.t vector option =
1707 Option.map (ts, fn ts => Vector.keepAllMap (ts, toRtype))
1709 Function.new {args = translateFormals args,
1712 raises = transTypes raises,
1713 returns = transTypes returns,
1718 val start = Label.newNoname ()
1719 val bug = Label.newNoname ()
1724 {args = Vector.new0 (),
1725 blocks = (Vector.new2
1728 args = Vector.new0 (),
1729 statements = globals,
1730 transfer = (S.Transfer.Call
1731 {args = Vector.new0 (),
1736 handler = S.Handler.Dead}})},
1739 args = Vector.new0 (),
1740 statements = Vector.new0 (),
1741 transfer = S.Transfer.Bug})),
1742 mayInline = false, (* doesn't matter *)
1743 name = Func.newNoname (),
1749 val functions = List.revMap (functions, translateFunction)
1750 val p = Program.T {functions = functions,
1751 handlesSignals = handlesSignals,
1753 objectTypes = Vector.concat [objectTypes, Vector.fromListRev (!newObjectTypes)]}
1754 val _ = Program.clear p