1 (* Copyright (C) 2016-2017 Matthew Fluet.
2 * Copyright (C) 1999-2007 Henry Cejtin, Matthew Fluet, Suresh
3 * Jagannathan, and Stephen Weeks.
4 * Copyright (C) 1997-2000 NEC Research Institute.
6 * MLton is released under a BSD-style license.
7 * See the file MLton-LICENSE for details.
10 (* Has a special case to make sure that true is represented as 1
11 * and false is represented as 0.
14 functor PackedRepresentation (S: REPRESENTATION_STRUCTS): REPRESENTATION =
22 structure Block = Block
24 structure Label = Label
25 structure ObjectType = ObjectType
26 structure Operand = Operand
27 structure ObjptrTycon = ObjptrTycon
29 structure RealSize = RealSize
30 structure Runtime = Runtime
31 structure Scale = Scale
32 structure Statement = Statement
33 structure Switch = Switch
34 structure Transfer = Transfer
37 structure WordSize = WordSize
38 structure WordX = WordX
46 structure ObjectCon = ObjectCon
48 structure Tycon = Tycon
51 datatype z = datatype Operand.t
52 datatype z = datatype Statement.t
53 datatype z = datatype Transfer.t
60 fun mkPadToCheck (t: t, mk): (Bits.t * (unit -> t) -> t) =
63 fun check (b', continue) =
66 val pad = zero (Bits.- (b', b))
70 else if Bits.equals (b, b')
76 fun mkPadToPrim (t: t, mk): t =
78 val check = mkPadToCheck (t, mk)
80 check (Bits.zero, fn () =>
81 check (Bits.inWord8, fn () =>
82 check (Bits.inWord16, fn () =>
83 check (Bits.inWord32, fn () =>
84 check (Bits.inWord64, fn () =>
85 Error.bug "PackedRepresentation.Type.mkPadToPrim")))))
87 fun mkPadToWidth (t: t, b': Bits.t, mk): t =
89 val check = mkPadToCheck (t, mk)
92 Error.bug "PackedRepresentation.Type.mkPadToWidth")
94 fun mk (t, pad) = seq (Vector.new2 (t, pad))
95 fun mkLow (t, pad) = seq (Vector.new2 (pad, t))
97 fun padToPrim (t: t): t = mkPadToPrim (t, mk)
98 fun padToPrimLow (t: t): t = mkPadToPrim (t, mkLow)
99 fun padToWidth (t: t, b: Bits.t): t = mkPadToWidth (t, b, mk)
100 fun padToWidthLow (t: t, b: Bits.t): t = mkPadToWidth (t, b, mkLow)
105 ("PackedRepresentation.Type.padToPrim", layout, layout)
109 ("PackedRepresentation.Type.padToPrimLow", layout, layout)
113 ("PackedRepresentation.Type.padToWidth", layout, Bits.layout, layout)
117 ("PackedRepresentation.Type.padToWidthLow", layout, Bits.layout, layout)
126 | Objptr of {endsIn00: bool}
128 datatype t = T of {rep: rep,
131 fun layout (T {rep, ty}) =
137 NonObjptr => str "NonObjptr"
138 | Objptr {endsIn00} =>
140 record [("endsIn00", Bool.layout endsIn00)]]),
141 ("ty", Type.layout ty)]
145 fun make f (T r) = f r
151 fun equals (r, r') = Type.equals (ty r, ty r')
155 ("PackedRepresentation.Rep.equals", layout, layout, Bool.layout)
158 fun nonObjptr ty = T {rep = NonObjptr,
161 val bool = nonObjptr Type.bool
163 val width = Type.width o ty
165 val unit = T {rep = NonObjptr,
168 fun isObjptr (T {rep, ...}) =
173 fun isObjptrEndingIn00 (T {rep, ...}) =
175 Objptr {endsIn00} => endsIn00
178 fun padToWidth (r as T {rep, ty}, width: Bits.t) =
179 if Bits.equals (Type.width ty, width)
185 ty = Type.padToWidth (ty, width)}
186 | Objptr _ => Error.bug "PackedRepresentation.Rep.padToWidth"
188 fun padToWidthLow (r as T {rep, ty}, width: Bits.t) =
189 if Bits.equals (Type.width ty, width)
195 ty = Type.padToWidthLow (ty, width)}
196 | Objptr _ => Error.bug "PackedRepresentation.Rep.padToWidth"
199 structure Statement =
204 fun make prim (z1: Operand.t, z2: Operand.t) =
206 val ty = Operand.ty z1
207 val tmp = Var.newNoname ()
209 (PrimApp {args = Vector.new2 (z1, z2),
210 dst = SOME (tmp, ty),
211 prim = prim (WordSize.fromBits (Type.width ty))},
212 Var {ty = ty, var = tmp})
215 val andb = make Prim.wordAndb
216 val lshift = make Prim.wordLshift
217 val orb = make Prim.wordOrb
218 val rshift = make (fn s => Prim.wordRshift (s, {signed = false}))
224 (* WordRep describes the representation of (some of) the components in a
226 * Components are stored from lowest to highest, just like in Type.seq.
227 * The width of the rep must be less than the width of an objptr.
228 * The sum of the widths of the component reps must be equal to the
231 datatype t = T of {components: {index: int,
235 fun layout (T {components, rep}) =
239 record [("components",
240 Vector.layout (fn {index, rep} =>
241 record [("index", Int.layout index),
242 ("rep", Rep.layout rep)])
244 ("rep", Rep.layout rep)]
248 fun make f (T r) = f r
253 val unit = T {components = Vector.new0 (),
256 fun equals (wr, wr') = Rep.equals (rep wr, rep wr')
258 fun make {components, rep} =
259 if Bits.<= (Rep.width rep, Control.Target.Size.objptr ())
260 andalso Bits.equals (Vector.fold (components, Bits.zero,
261 fn ({rep, ...}, ac) =>
262 Bits.+ (ac, Rep.width rep)),
264 then T {components = components,
266 else Error.bug "PackedRepresentation.WordRep.make"
270 ("PackedRepresentation.WordRep.make",
275 fun padToWidth (T {components, rep}, b: Bits.t): t =
277 val newRep = Rep.padToWidth (rep, b)
278 val padBits = Bits.- (Rep.width newRep, Rep.width rep)
281 rep = Rep.nonObjptr (Type.bits padBits)}
284 [components, Vector.new1 newComponent]
286 make {components = newComponents,
289 fun padToWidthLow (T {components, rep}, b: Bits.t): t =
291 val newRep = Rep.padToWidthLow (rep, b)
292 val padBits = Bits.- (Rep.width newRep, Rep.width rep)
295 rep = Rep.nonObjptr (Type.bits padBits)}
298 [Vector.new1 newComponent, components]
300 make {components = newComponents,
304 fun tuple (T {components, ...},
305 {dst = (dstVar, dstTy): Var.t * Type.t,
306 src: {index: int} -> Operand.t}): Statement.t list =
308 val bits = Type.width dstTy
309 val (accOpt,_,statements) =
311 (components, (NONE,Bits.zero,[]),
312 fn ({index, rep, ...}, (accOpt,shift,statements)) =>
314 then (accOpt, Bits.+ (shift, Rep.width rep), statements)
317 val (src, ss) = Statement.resize (src {index = index},
321 if Bits.equals (shift, Bits.zero)
328 (WordX.fromIntInf (Bits.toIntInf shift,
338 val (s, acc) = Statement.orb (src, acc)
343 (SOME acc, Bits.+ (shift, Rep.width rep), ss :: statements)
349 [Bind {dst = (dstVar, dstTy),
354 List.fold (statements, [], fn (ss, ac) => List.fold (ss, ac, op ::))
359 ("PackedRepresentation.WordRep.tuple",
360 layout o #1, List.layout Statement.layout)
364 structure Component =
367 Direct of {index: int,
376 Direct {index, rep} =>
378 record [("index", Int.layout index),
379 ("rep", Rep.layout rep)]]
381 seq [str "Word ", WordRep.layout wr]
384 val rep: t -> Rep.t =
385 fn Direct {rep, ...} => rep
386 | Word wr => WordRep.rep wr
388 val ty = Rep.ty o rep
390 val unit = Word WordRep.unit
392 val equals: t * t -> bool =
395 (Direct {rep = r, ...}, Direct {rep = r', ...}) => Rep.equals (r, r')
396 | (Word wr, Word wr') => WordRep.equals (wr, wr')
400 fun mkPadToWidth (c: t, b: Bits.t, repPadToWidth, wordRepPadToWidth): t =
402 Direct {index, rep} =>
403 Direct {index = index,
404 rep = repPadToWidth (rep, b)}
405 | Word r => Word (wordRepPadToWidth (r, b))
407 fun padToWidth (c, b) =
408 mkPadToWidth (c, b, Rep.padToWidth, WordRep.padToWidth)
409 fun padToWidthLow (c, b) =
410 mkPadToWidth (c, b, Rep.padToWidthLow, WordRep.padToWidthLow)
414 fun mkPadToPrim (c: t, typePadToPrim, padToWidth) =
417 val ty' = typePadToPrim ty
419 if Type.equals (ty, ty')
421 else padToWidth (c, Type.width ty')
424 fun padToPrim c = mkPadToPrim (c, Type.padToPrim, padToWidth)
425 fun padToPrimLow c = mkPadToPrim (c, Type.padToPrimLow, padToWidthLow)
428 fun tuple (c: t, {dst: Var.t * Type.t,
429 src: {index: int} -> Operand.t})
432 Direct {index, ...} =>
435 Statement.resize (src {index = index}, #2 dst)
437 ss @ [Bind {dst = dst,
441 | Word wr => WordRep.tuple (wr, {dst = dst, src = src})
445 ("PackedRepresentation.Component.tuple",
447 fn {dst = (dst, _), ...} => Var.layout dst,
448 List.layout Statement.layout)
454 datatype t = T of {shift: Bits.t,
457 fun layout (T {shift, ty}) =
461 record [("shift", Bits.layout shift),
462 ("ty", Type.layout ty)]
465 val lshift: t * Bits.t -> t =
466 fn (T {shift, ty}, b) =>
467 T {shift = Bits.+ (shift, b),
470 fun select (T {shift, ty},
472 src: Operand.t}): Statement.t list =
480 WordX.fromIntInf (Bits.toIntInf shift, WordSize.shiftArg)
481 val (s, tmp) = Statement.rshift (src, Operand.word shift)
485 val w = Type.width ty
486 val sz = WordSize.fromBits w
487 val w' = Type.width dstTy
488 val sz' = WordSize.fromBits w'
489 val (src, ss2) = Statement.resize (src, dstTy)
491 if Bits.equals (w, w')
492 (* orelse Type.isZero (Type.dropPrefix (Operand.ty src,
498 val mask = WordX.resize (WordX.max (sz, {signed = false}), sz')
499 val (s, src) = Statement.andb (src, Operand.word mask)
504 ss1 @ ss2 @ ss3 @ [Bind {dst = (dst, dstTy),
511 ("PackedRepresentation.Unpack.select",
513 fn {dst = (dst, _), src} =>
514 Layout.record [("dst", Var.layout dst),
515 ("src", Operand.layout src)],
516 List.layout Statement.layout)
519 fun update (T {shift, ty},
521 component: Operand.t}): Operand.t * Statement.t list =
524 WordX.fromIntInf (Bits.toIntInf shift, WordSize.shiftArg)
525 val chunkTy = Operand.ty chunk
526 val chunkWidth = Type.width chunkTy
531 (WordX.resize (WordX.allOnes (WordSize.fromBits (Type.width ty)),
532 WordSize.fromBits chunkWidth),
534 val (s1, chunk) = Statement.andb (chunk, mask)
535 val (component, s2) = Statement.resize (component, chunkTy)
536 val (s3, component) = Statement.lshift (component, Operand.word shift)
537 val (s4, result) = Statement.orb (chunk, component)
539 (result, [s1] @ s2 @ [s3, s4])
544 ("PackedRepresentation.Unpack.update",
546 fn {chunk, component} =>
547 Layout.record [("chunk", Operand.layout chunk),
548 ("component", Operand.layout component)],
549 Layout.tuple2 (Operand.layout,
550 List.layout Statement.layout))
558 fun toOperand {base: Operand.t t,
559 eltWidth: Bytes.t option,
561 ty: Type.t}: Operand.t * Statement.t list =
564 (Offset {base = base,
568 | VectorSub {index, vector} =>
572 NONE => Error.bug "PackedRepresentation.Base.toOperand: eltWidth"
575 case Scale.fromBytes eltWidth of
578 val seqIndexSize = WordSize.seqIndex ()
579 val seqIndexTy = Type.word seqIndexSize
580 val prod = Var.newNoname ()
582 PrimApp {args = (Vector.new2
586 (Bytes.toIntInf eltWidth,
588 dst = SOME (prod, seqIndexTy),
593 (ArrayOffset {base = vector,
594 index = Var {var = prod, ty = seqIndexTy},
601 (ArrayOffset {base = vector,
614 | Direct of {ty: Type.t}
615 | Indirect of {offset: Bytes.t,
617 | IndirectUnpack of {offset: Bytes.t,
628 | Direct {ty} => seq [str "Direct ",
629 record [("ty", Type.layout ty)]]
630 | Indirect {offset, ty} =>
631 seq [str "Indirect ",
632 record [("offset", Bytes.layout offset),
633 ("ty", Type.layout ty)]]
634 | IndirectUnpack {offset, rest, ty} =>
635 seq [str "IndirectUnpack ",
636 record [("offset", Bytes.layout offset),
637 ("rest", Unpack.layout rest),
638 ("ty", Type.layout ty)]]
639 | Unpack u => seq [str "Unpack ", Unpack.layout u]
642 val lshift: t * Bits.t -> t =
646 | Direct {ty} => Unpack (Unpack.T {shift = b, ty = ty})
647 | Unpack u => Unpack (Unpack.lshift (u, b))
648 | _ => Error.bug "PackedRepresentation.Select.lshift"
650 fun select (s: t, {base: Operand.t Base.t,
652 eltWidth: Bytes.t option}): Statement.t list =
656 val (dst, dstTy) = dst
657 val (src, ss') = Statement.resize (src, dstTy)
659 ss @ ss' @ [Bind {dst = (dst, dstTy),
666 | Direct _ => move (Base.object base, [])
667 | Indirect {offset, ty} =>
668 move (Base.toOperand {base = base,
672 | IndirectUnpack {offset, rest, ty} =>
674 val tmpVar = Var.newNoname ()
675 val tmpOp = Var {ty = ty, var = tmpVar}
677 Base.toOperand {base = base,
682 ss @ (Bind {dst = (tmpVar, ty),
685 :: Unpack.select (rest, {dst = dst, src = tmpOp}))
688 Unpack.select (u, {dst = dst, src = Base.object base})
693 ("PackedRepresentation.Select.select",
694 layout o #1, List.layout Statement.layout)
697 fun update (s: t, {base: Operand.t Base.t,
698 eltWidth: Bytes.t option,
699 value: Operand.t}): Statement.t list =
701 Indirect {offset, ty} =>
704 Base.toOperand {base = base,
709 ss @ [Move {dst = dst, src = value}]
711 | IndirectUnpack {offset, rest, ty} =>
714 Base.toOperand {base = base,
718 val (newChunk, ss') =
719 Unpack.update (rest, {chunk = chunk,
722 ss @ ss' @ [Move {dst = chunk, src = newChunk}]
724 | _ => Error.bug "PackedRepresentation.Select.update: non-indirect"
728 ("PackedRepresentation.Select.update",
729 layout o #1, List.layout Statement.layout)
735 datatype t = T of {orig: S.Type.t,
736 select: Select.t} vector
738 fun layout (T v) = Vector.layout (Select.layout o #select) v
740 val empty = T (Vector.new0 ())
743 T (Vector.map (v, fn {orig, select} =>
747 fun select (T v, {base: Operand.t Base.t,
749 eltWidth: Bytes.t option,
750 offset: int}): Statement.t list =
751 Select.select (#select (Vector.sub (v, offset)),
752 {base = base, eltWidth = eltWidth, dst = dst})
754 fun update (T v, {base, eltWidth, offset, value}) =
755 Select.update (#select (Vector.sub (v, offset)),
756 {base = base, eltWidth = eltWidth, value = value})
758 fun lshift (T v, b: Bits.t) =
759 T (Vector.map (v, fn {orig, select} =>
761 select = Select.lshift (select, b)}))
764 structure ObjptrRep =
766 datatype t = T of {components: {component: Component.t,
767 offset: Bytes.t} vector,
768 componentsTy: Type.t,
771 tycon: ObjptrTycon.t}
773 fun layout (T {components, componentsTy, selects, ty, tycon}) =
779 Vector.layout (fn {component, offset} =>
780 record [("component", Component.layout component),
781 ("offset", Bytes.layout offset)])
783 ("componentsTy", Type.layout componentsTy),
784 ("selects", Selects.layout selects),
785 ("ty", Type.layout ty),
786 ("tycon", ObjptrTycon.layout tycon)]
790 fun make f (T r) = f r
792 val componentsTy = make #componentsTy
796 fun equals (T {tycon = c, ...}, T {tycon = c', ...}) =
797 ObjptrTycon.equals (c, c')
799 fun rep (T {ty, ...}) =
800 Rep.T {rep = Rep.Objptr {endsIn00 = true},
803 fun make {components, isVector, selects, tycon} =
807 (components, Bytes.zero, fn ({component = c, ...}, ac) =>
808 Bytes.+ (ac, Type.bytes (Component.ty c)))
809 val padBytes: Bytes.t =
813 case !Control.align of
814 Control.Align4 => width
817 (components, fn {component = c, ...} =>
818 (case Type.deReal (Component.ty c) of
821 RealSize.equals (s, RealSize.R64))
823 (case Type.deWord (Component.ty c) of
826 WordSize.equals (s, WordSize.word64))
828 (Type.isObjptr (Component.ty c)
829 andalso WordSize.equals (WordSize.objptr (),
831 then Bytes.alignWord64 width
834 Bytes.- (alignWidth, width)
837 (* Note that with Align8 and objptrSize == 64bits,
838 * the following ensures that objptrs will be
841 val width' = Bytes.+ (width, Runtime.normalMetaDataSize ())
843 case !Control.align of
844 Control.Align4 => Bytes.alignWord32 width'
845 | Control.Align8 => Bytes.alignWord64 width'
846 val alignWidth = Bytes.- (alignWidth', Runtime.normalMetaDataSize ())
848 Bytes.- (alignWidth, width)
850 val (components, selects) =
851 if Bytes.isZero padBytes
852 then (components, selects)
854 (* Need to insert a pad before the first objptr. *)
856 val {no = nonObjptrs, yes = objptrs} =
858 (components, fn {component = c, ...} =>
859 Rep.isObjptr (Component.rep c))
861 if Vector.isEmpty objptrs
863 else #offset (Vector.first objptrs)
865 (#1 o Vector.unfoldi)
866 ((Bytes.toInt padBytes) div (Bytes.toInt Bytes.inWord32),
869 ({component = (Component.padToWidth
870 (Component.unit, Bits.inWord32)),
872 Bytes.+ (padOffset, Bytes.inWord32)))
874 Vector.map (objptrs, fn {component = c, offset} =>
876 offset = Bytes.+ (offset, padBytes)})
878 Vector.concat [nonObjptrs, pad, objptrs]
883 Select.Indirect {offset, ty} =>
884 if Bytes.>= (offset, padOffset)
887 {offset = Bytes.+ (offset, padBytes),
892 (components, selects)
895 Type.seq (Vector.map (components, Component.ty o #component))
897 T {components = components,
898 componentsTy = componentsTy,
900 ty = Type.objptr tycon,
909 ("PackedRepresentation.ObjptrRep.make",
910 fn {components, isVector, selects, tycon} =>
913 Vector.layout (fn {component, offset} =>
914 record [("component", Component.layout component),
915 ("offset", Bytes.layout offset)])
917 ("isVector", Bool.layout isVector),
918 ("selects", Selects.layout selects),
919 ("tycon", ObjptrTycon.layout tycon)],
924 fun box (component: Component.t, opt: ObjptrTycon.t, selects: Selects.t) =
930 datatype z = datatype Select.t
934 | Direct {ty} => Indirect {offset = Bytes.zero, ty = ty}
935 | Unpack u => IndirectUnpack {offset = Bytes.zero,
937 ty = Component.ty component}
938 | _ => Error.bug "PackedRepresentation.ObjptrRep.box: cannot lift selects"
941 make {components = Vector.new1 {component = component,
942 offset = Bytes.zero},
948 fun tuple (T {components, componentsTy, ty, tycon, ...},
950 src: {index: int} -> Operand.t}) =
952 val object = Var {ty = ty, var = dst}
955 (components, [], fn ({component, offset}, ac) =>
957 val tmpVar = Var.newNoname ()
958 val tmpTy = Component.ty component
960 Component.tuple (component,
961 {dst = (tmpVar, tmpTy), src = src})
963 if List.isEmpty statements
966 @ (Move {dst = Offset {base = object,
969 src = Var {ty = tmpTy, var = tmpVar}}
973 Object {dst = (dst, ty),
974 header = Runtime.typeIndexToHeader (ObjptrTycon.index tycon),
975 size = Bytes.+ (Type.bytes componentsTy, Runtime.normalMetaDataSize ())}
981 ("PackedRepresentation.ObjptrRep.tuple",
982 layout, Var.layout o #dst, List.layout Statement.layout)
989 Direct of {component: Component.t,
991 | Indirect of ObjptrRep.t
998 Direct {component, selects} =>
1000 record [("component", Component.layout component),
1001 ("selects", Selects.layout selects)]]
1003 seq [str "Indirect ", ObjptrRep.layout pr]
1006 val unit = Direct {component = Component.unit,
1007 selects = Selects.empty}
1009 val equals: t * t -> bool =
1012 (Direct {component = c, ...}, Direct {component = c', ...}) =>
1013 Component.equals (c, c')
1014 | (Indirect pr, Indirect pr') => ObjptrRep.equals (pr, pr')
1017 fun rep (tr: t): Rep.t =
1019 Direct {component, ...} => Component.rep component
1020 | Indirect p => ObjptrRep.rep p
1022 val ty = Rep.ty o rep
1024 fun selects (tr: t): Selects.t =
1026 Direct {selects, ...} => selects
1027 | Indirect (ObjptrRep.T {selects, ...}) => selects
1030 {dst: Var.t * Type.t,
1031 src: {index: int} -> Operand.t}): Statement.t list =
1033 Direct {component = c, ...} =>
1034 Component.tuple (c, {dst = dst, src = src})
1036 ObjptrRep.tuple (pr, {dst = #1 dst, src = src})
1040 ("PackedRepresentation.TupleRep.tuple",
1041 layout, Var.layout o #1 o #dst, List.layout Statement.layout)
1044 (* TupleRep.make decides how to layout a sequence of types in an object,
1045 * or in the case of a vector, in a vector element.
1046 * Vectors are treated slightly specially because we don't require element
1047 * widths to be a multiple of the word32 size.
1048 * At the front of the object, we place all the word64s, followed by
1049 * all the word32s. Then, we pack in all the types that are smaller than a
1050 * word32. This is done by packing in a sequence of words, greedily,
1051 * starting with the largest type and moving to the smallest. We pad to
1052 * ensure that a value never crosses a word32 boundary. Finally, if there
1053 * are any objptrs, they go at the end of the object.
1055 * There is some extra logic here to specially represent (boxed)
1056 * tuples that are entirely comprised of primitive types. The
1057 * primary motivation is that "word8 ref" and "word16 ref" are
1058 * FFI types, and must have representations that are compatible
1059 * with C. In particular, on a big-endian platform, such
1060 * sub-word32 components must be at the low byte offset (but
1061 * high bit offset) of the containing word32.
1063 fun make (objptrTycon: ObjptrTycon.t,
1064 rs: {isMutable: bool,
1066 ty: S.Type.t} vector,
1068 isVector: bool}): t =
1070 val objptrs = ref []
1071 val numObjptrs = ref 0
1072 val word64s = ref []
1073 val numWord64s = ref 0
1074 val word32s = ref []
1075 val numWord32s = ref 0
1076 val subword32s = Array.array (Bits.toInt Bits.inWord32, [])
1077 val widthSubword32s = ref 0
1078 val hasNonPrim = ref false
1081 (rs, fn (i, {rep, ...}) =>
1083 fun addDirect (l, n) =
1084 (List.push (l, {component = Component.Direct {index = i,
1088 fun addSubword32 b =
1091 {index = i, rep = rep} :: Array.sub (subword32s, b))
1092 ; widthSubword32s := !widthSubword32s + b)
1097 val b = Bits.toInt (Rep.width rep)
1101 | 8 => addSubword32 b
1102 | 16 => addSubword32 b
1103 | 32 => addDirect (word32s, numWord32s)
1104 | 64 => addDirect (word64s, numWord64s)
1105 | _ => (addSubword32 b
1106 ; hasNonPrim := true)
1108 | Rep.Objptr _ => addDirect (objptrs, numObjptrs)
1110 val selects = Array.array (Vector.length rs, Select.None)
1111 val hasNonPrim = !hasNonPrim
1113 !numObjptrs + !numWord64s + !numWord32s +
1115 val widthSubword32s = !widthSubword32s
1117 Int.quot (widthSubword32s, 32)
1118 + Int.min (1, Int.rem (widthSubword32s, 32))
1122 orelse Vector.exists (rs, #isMutable)
1123 orelse numComponents > 1
1124 val padToPrim = isVector andalso 1 = numComponents
1125 val isBigEndian = Control.Target.bigEndian ()
1126 fun byteShiftToByteOffset (compSz: Bytes.t, tySz: Bytes.t, shift: Bytes.t) =
1129 else Bytes.- (compSz, Bytes.+ (tySz, shift))
1130 fun simple (l, tyWidth: Bytes.t, offset: Bytes.t, components) =
1132 (l, (offset, components),
1133 fn ({component, index}, (offset, ac)) =>
1134 (Bytes.+ (offset, tyWidth),
1136 val ty = Component.ty component
1141 then Select.Indirect {offset = offset, ty = ty}
1142 else Select.Direct {ty = ty})
1144 {component = component,
1145 offset = offset} :: ac
1147 val offset = Bytes.zero
1149 val (offset, components) =
1150 simple (!word64s, Bytes.inWord64, offset, components)
1151 val (offset, components) =
1152 simple (!word32s, Bytes.inWord32, offset, components)
1153 (* j is the maximum index <= remainingWidth at which an
1154 * element of subword32s may be nonempty.
1156 fun getSubword32Components (j: int,
1157 remainingWidth: Bits.t,
1160 then Vector.fromListRev components
1163 val elts = Array.sub (subword32s, j)
1166 [] => getSubword32Components (j - 1, remainingWidth, components)
1167 | {index, rep} :: elts =>
1169 val () = Array.update (subword32s, j, elts)
1170 val remainingWidth = Bits.- (remainingWidth, Rep.width rep)
1172 getSubword32Components
1173 (Bits.toInt remainingWidth,
1175 {index = index, rep = rep} :: components)
1178 (* max is the maximum index at which an element of
1179 * subword32s may be nonempty.
1181 fun makeSubword32s (max: int, offset: Bytes.t, ac) =
1185 if List.isEmpty (Array.sub (subword32s, max))
1186 then makeSubword32s (max - 1, offset, ac)
1190 getSubword32Components (max, Bits.inWord32, [])
1192 Type.seq (Vector.map (components, Rep.ty o #rep))
1194 (Component.Word o WordRep.T)
1195 {components = components,
1196 rep = Rep.T {rep = Rep.NonObjptr,
1198 val (component, componentTy) =
1201 then (Component.padToPrim component,
1202 Type.padToPrim componentTy)
1203 else (Component.padToWidth (component, Bits.inWord32),
1204 Type.padToWidth (componentTy, Bits.inWord32))
1205 else (component, componentTy)
1208 (components, Bits.zero,
1209 fn ({index, rep}, shift) =>
1211 val repTy = Rep.ty rep
1212 val repTyWidth = Type.width repTy
1213 val repWidth = Rep.width rep
1214 val unpack = Unpack.T {shift = shift,
1216 fun getByteOffset () =
1219 byteShiftToByteOffset
1220 (Type.bytes componentTy,
1221 Bits.toBytes repTyWidth,
1222 Bits.toBytes shift))
1225 then if ((Bits.isWord8Aligned shift
1226 andalso (Bits.equals
1230 (Bits.isWord16Aligned shift
1231 andalso (Bits.equals
1234 then (Select.Indirect
1235 {offset = getByteOffset (),
1237 else (Select.IndirectUnpack
1241 else Select.Unpack unpack
1244 (selects, index, select)
1246 Bits.+ (shift, repWidth)
1248 val ac = {component = component,
1249 offset = offset} :: ac
1253 (* Either the width of the word rep component
1254 * is 32 bits, or this is the only
1255 * component, so offset doesn't matter.
1257 Bytes.+ (offset, Bytes.inWord32),
1260 fun makeSubword32sAllPrims (max: int, offset: Bytes.t, ac) =
1261 (* hasNonPrim = false, needsBox = true *)
1265 if List.isEmpty (Array.sub (subword32s, max))
1266 then makeSubword32sAllPrims (max - 1, offset, ac)
1269 val origComponents =
1270 getSubword32Components (max, Bits.inWord32, [])
1273 then Vector.rev origComponents
1276 Type.seq (Vector.map (components, Rep.ty o #rep))
1278 (Component.Word o WordRep.T)
1279 {components = components,
1280 rep = Rep.T {rep = Rep.NonObjptr,
1285 then Component.padToPrimLow component
1286 else Component.padToPrim component
1288 then Component.padToWidthLow (component, Bits.inWord32)
1289 else Component.padToWidth (component, Bits.inWord32)
1292 (origComponents, offset,
1293 fn ({index, rep}, offset) =>
1302 Bytes.+ (offset, Bits.toBytes (Rep.width rep))
1304 val ac = {component = component,
1305 offset = offset} :: ac
1307 makeSubword32sAllPrims
1309 (* Either the width of the word rep component
1310 * is 32 bits, or this is the only
1311 * component, so offset doesn't matter.
1313 Bytes.+ (offset, Bytes.inWord32),
1316 val (offset, components) =
1317 if (not hasNonPrim) andalso needsBox
1318 then makeSubword32sAllPrims (Array.length subword32s - 1, offset, components)
1319 else makeSubword32s (Array.length subword32s - 1, offset, components)
1320 val (_, components) =
1321 simple (!objptrs, Runtime.objptrSize (), offset, components)
1322 val components = Vector.fromListRev components
1326 ("PackedRepresentation.TupleRep.make", fn () =>
1327 numComponents = Vector.length components)
1330 Selects.T (Vector.tabulate
1331 (Array.length selects, fn i =>
1332 {orig = #ty (Vector.sub (rs, i)),
1333 select = Array.sub (selects, i)}))
1336 then Indirect (ObjptrRep.make {components = components,
1337 isVector = isVector,
1338 selects = getSelects,
1339 tycon = objptrTycon})
1340 else if numComponents = 0
1342 else Direct {component = #component (Vector.first components),
1343 selects = getSelects}
1347 ("PackedRepresentation.TupleRep.make",
1349 Vector.layout (fn {isMutable, rep, ty} =>
1350 Layout.record [("isMutable", Bool.layout isMutable),
1351 ("rep", Rep.layout rep),
1352 ("ty", S.Type.layout ty)]),
1353 fn {forceBox, isVector} =>
1354 Layout.record [("forceBox", Bool.layout forceBox),
1355 ("isVector", Bool.layout isVector)],
1364 ShiftAndTag of {component: Component.t,
1367 ty: Type.t (* alread padded to prim *)}
1368 | Tag of {tag: WordX.t,
1370 | Tuple of TupleRep.t
1376 fn ShiftAndTag {component, selects, tag, ty} =>
1377 seq [str "ShiftAndTag ",
1378 record [("component", Component.layout component),
1379 ("selects", Selects.layout selects),
1380 ("tag", WordX.layout tag),
1381 ("ty", Type.layout ty)]]
1382 | Tag {tag, ...} => seq [str "Tag ", WordX.layout tag]
1383 | Tuple tr => TupleRep.layout tr
1386 val equals: t * t -> bool =
1387 fn (ShiftAndTag {component = c1, tag = t1, ...},
1388 ShiftAndTag {component = c2, tag = t2, ...}) =>
1389 Component.equals (c1, c2) andalso WordX.equals (t1, t2)
1390 | (Tag {tag = t1, ty = ty1}, Tag {tag = t2, ty = ty2}) =>
1391 WordX.equals (t1, t2) andalso Type.equals (ty1, ty2)
1392 | (Tuple tr1, Tuple tr2) => TupleRep.equals (tr1, tr2)
1395 val rep: t -> Rep.t =
1396 fn ShiftAndTag {ty, ...} => Rep.nonObjptr ty
1397 | Tag {ty, ...} => Rep.nonObjptr ty
1398 | Tuple tr => TupleRep.rep tr
1400 val box = Tuple o TupleRep.Indirect
1405 val tag = WordX.fromIntInf (i, WordSize.bool)
1407 Tag {tag = tag, ty = Type.ofWordX tag}
1414 val unit = Tuple TupleRep.unit
1416 fun conApp (r: t, {dst: Var.t * Type.t,
1417 src: {index: int} -> Operand.t}): Statement.t list =
1419 ShiftAndTag {component, tag, ...} =>
1421 val (dstVar, dstTy) = dst
1422 val shift = Operand.word (WordX.fromIntInf
1427 val tmpVar = Var.newNoname ()
1429 Type.padToWidth (Component.ty component, Type.width dstTy)
1430 val tmp = Var {ty = tmpTy, var = tmpVar}
1432 Component.tuple (component, {dst = (tmpVar, tmpTy),
1434 val (s1, tmp) = Statement.lshift (tmp, shift)
1435 val mask = Operand.word (WordX.resize
1440 val (s2, tmp) = Statement.orb (tmp, mask)
1441 val s3 = Bind {dst = (dstVar, dstTy),
1445 component @ [s1, s2, s3]
1449 val (dstVar, dstTy) = dst
1450 val src = Operand.word (WordX.resize
1453 (Type.width dstTy)))
1455 [Bind {dst = (dstVar, dstTy),
1459 | Tuple tr => TupleRep.tuple (tr, {dst = dst, src = src})
1463 ("PackedRepresentation.ConRep.conApp",
1464 layout o #1, List.layout Statement.layout)
1472 val extra: t list ref = ref []
1474 fun getExtra () = !extra before extra := []
1476 fun new {statements: Statement.t vector,
1477 transfer: Transfer.t}: Label.t =
1479 val l = Label.newNoname ()
1480 val _ = List.push (extra,
1481 Block.T {args = Vector.new0 (),
1484 statements = statements,
1485 transfer = transfer})
1493 type t = {con: Con.t, dst: Label.t, dstHasArg: bool} vector
1495 fun layout (v: t): Layout.t =
1497 (fn {con, dst, dstHasArg} =>
1498 Layout.record [("con", Con.layout con),
1499 ("dst", Label.layout dst),
1500 ("dstHasArg", Bool.layout dstHasArg)])
1506 (* 1 < Vector.length variants *)
1507 datatype t = T of {rep: Rep.t,
1508 variants: {con: Con.t,
1509 objptr: ObjptrRep.t} vector}
1511 fun layout (T {rep, variants}) =
1515 record [("rep", Rep.layout rep),
1518 (fn {con, objptr} =>
1519 record [("con", Con.layout con),
1520 ("objptr", ObjptrRep.layout objptr)])
1525 fun make f (T r) = f r
1530 val ty = Rep.ty o rep
1532 fun make {rep, variants}: t =
1534 variants = variants}
1536 fun genCase (T {variants, ...},
1538 conRep: Con.t -> ConRep.t,
1539 default: Label.t option,
1541 : Statement.t list * Transfer.t =
1545 (cases, fn {con, dst, dstHasArg} =>
1547 ConRep.Tuple (TupleRep.Indirect (ObjptrRep.T {ty, tycon, ...})) =>
1548 SOME (WordX.fromIntInf (Int.toIntInf (ObjptrTycon.index tycon),
1549 WordSize.objptrHeader ()),
1551 {statements = Vector.new0 (),
1552 transfer = Goto {args = if dstHasArg
1554 (Operand.cast (test, ty)))
1555 else Vector.new0 (),
1559 if Vector.length variants = Vector.length cases
1563 QuickSort.sortVector (cases, fn ((w, _), (w', _)) =>
1564 WordX.le (w, w', {signed = false}))
1565 val shift = Operand.word (WordX.one WordSize.shiftArg)
1567 Statement.rshift (Offset {base = test,
1568 offset = Runtime.headerOffset (),
1569 ty = Type.objptrHeader ()},
1572 ([s], Switch (Switch.T {cases = cases,
1574 size = WordSize.objptrHeader (),
1581 datatype t = T of {isEnum: bool,
1584 variants: Con.t vector}
1586 fun layout (T {isEnum, rep, tagBits, variants}) =
1590 record [("isEnum", Bool.layout isEnum),
1591 ("rep", Rep.layout rep),
1592 ("tagBits", Bits.layout tagBits),
1593 ("variants", Vector.layout Con.layout variants)]
1597 fun make f (T r) = f r
1606 variants = Vector.new2 (Con.falsee, Con.truee)}
1608 fun genCase (T {isEnum, tagBits, variants, ...},
1610 conRep: Con.t -> ConRep.t,
1612 notSmall: Label.t option,
1613 smallDefault: Label.t option,
1615 : Statement.t list * Transfer.t =
1617 val tagSize = WordSize.fromBits tagBits
1618 val testBits = Type.width (Operand.ty test)
1619 val testSize = WordSize.fromBits testBits
1622 (cases, fn {con, dst, dstHasArg} =>
1624 ConRep.ShiftAndTag {tag, ty, ...} =>
1626 val test = Operand.cast (test, Type.padToWidth (ty, testBits))
1627 val (test, ss) = Statement.resize (test, ty)
1629 Goto {args = if dstHasArg
1630 then Vector.new1 test
1631 else Vector.new0 (),
1634 SOME (WordX.resize (tag, testSize),
1635 Block.new {statements = Vector.fromList ss,
1636 transfer = transfer})
1638 | ConRep.Tag {tag, ...} =>
1641 Goto {args = if dstHasArg
1642 then Vector.new1 test
1643 else Vector.new0 (),
1646 SOME (WordX.resize (tag, testSize),
1647 Block.new {statements = Vector.new0 (),
1648 transfer = transfer})
1651 val cases = QuickSort.sortVector (cases, fn ((w, _), (w', _)) =>
1652 WordX.le (w, w', {signed = false}))
1655 then Operand.cast (test, Type.bits testBits)
1663 Operand.word (WordX.resize
1664 (WordX.max (tagSize, {signed = false}),
1666 val (s, tagOp) = Statement.andb (tagOp, mask)
1671 if Vector.length variants = Vector.length cases
1674 case (notSmall, smallDefault) of
1675 (NONE, _) => smallDefault
1676 | (_, NONE) => notSmall
1677 | (SOME notSmall, SOME smallDefault) =>
1681 (Operand.cast (test, Type.bits testBits),
1682 Operand.word (WordX.fromIntInf (3, testSize)))
1686 {cases = Vector.new1 (WordX.zero testSize,
1688 default = SOME smallDefault,
1692 SOME (Block.new {statements = Vector.new1 s,
1696 Switch (Switch.T {cases = cases,
1706 ("PackedRepresentation.Small.genCase",
1707 fn (s, {test, ...}) =>
1708 Layout.tuple [layout s,
1709 Layout.record [("test", Operand.layout test)]],
1710 Layout.tuple2 (List.layout Statement.layout, Transfer.layout))
1714 structure TyconRep =
1718 tupleRep: TupleRep.t}
1719 | Objptrs of Objptrs.t
1721 | SmallAndBox of {box: {con: Con.t,
1722 objptr: ObjptrRep.t},
1725 | SmallAndObjptr of {objptr: {component: Component.t,
1729 | SmallAndObjptrs of {objptrs: Objptrs.t,
1734 fun layout (r: t): Layout.t =
1739 One {con, tupleRep} =>
1741 record [("con", Con.layout con),
1742 ("tupleRep", TupleRep.layout tupleRep)]]
1744 seq [str "Objptrs ", Objptrs.layout ps]
1746 seq [str "Small ", Small.layout s]
1747 | SmallAndBox {box = {con, objptr}, rep, small} =>
1748 seq [str "SmallAndBox ",
1750 record [("con", Con.layout con),
1751 ("objptr", ObjptrRep.layout objptr)]),
1752 ("rep", Rep.layout rep),
1753 ("small", Small.layout small)]]
1754 | SmallAndObjptr {objptr = {component, con}, rep, small} =>
1755 seq [str "SmallAndObjptr ",
1758 record [("component", Component.layout component),
1759 ("con", Con.layout con)]),
1760 ("rep", Rep.layout rep),
1761 ("small", Small.layout small)]]
1762 | SmallAndObjptrs {objptrs, rep, small} =>
1763 seq [str "SmallAndObjptrs ",
1764 record [("objptrs", Objptrs.layout objptrs),
1765 ("rep", Rep.layout rep),
1766 ("small", Small.layout small)]]
1767 | Unit => str "Unit"
1770 val bool = Small Small.bool
1774 val rep: t -> Rep.t =
1775 fn One {tupleRep, ...} => TupleRep.rep tupleRep
1776 | Objptrs p => Objptrs.rep p
1777 | Small s => Small.rep s
1778 | SmallAndBox {rep, ...} => rep
1779 | SmallAndObjptr {rep, ...} => rep
1780 | SmallAndObjptrs {rep, ...} => rep
1783 fun equals (r, r') = Rep.equals (rep r, rep r')
1785 val objptrBytes = Runtime.objptrSize
1786 val objptrBits = Promise.lazy (fn () => Bytes.toBits (objptrBytes ()))
1787 val objptrBitsAsInt = Promise.lazy (fn () => Bits.toInt (objptrBits ()))
1792 (fn () => Array.tabulate (objptrBitsAsInt () + 1, fn i =>
1794 (* If there is an objptr, then multiply the number of tags by
1795 * 3/4 to remove all the tags that have 00 as their low bits.
1799 (fn () => Array.tabulate (objptrBitsAsInt () + 1, fn i =>
1800 (Array.sub (aWithout (), i) * 3) div 4))
1802 fun numTagsAvailable {tagBits: int, withObjptr: bool} =
1804 val a = if withObjptr then aWith () else aWithout ()
1806 Array.sub (a, tagBits)
1809 val numTagsAvailable =
1811 ("PackedRepresentation.TyconRep.numTagsAvailable",
1812 fn {tagBits, withObjptr} =>
1813 Layout.record [("tagBits", Int.layout tagBits),
1814 ("withObjptr", Bool.layout withObjptr)],
1818 fun tagBitsNeeded {numVariants: int, withObjptr: bool}: Bits.t =
1820 val numVariants = Int.toIntInf numVariants
1821 val a = if withObjptr then aWith () else aWithout ()
1823 case (BinarySearch.smallest
1824 (a, fn numTags => numVariants <= numTags)) of
1825 NONE => Error.bug "PackedRepresentation.TyconRep.tagBitsNeeded"
1826 | SOME i => Bits.fromInt i
1831 ("PackedRepresentation.TyconRep.tagBitsNeeded",
1832 fn {numVariants, withObjptr} =>
1833 Layout.record [("numVariants", Int.layout numVariants),
1834 ("withObjptr", Bool.layout withObjptr)],
1839 fun make (variants: {args: {isMutable: bool,
1841 ty: S.Type.t} vector,
1843 objptrTycon: ObjptrTycon.t} vector)
1844 : t * {con: Con.t, rep: ConRep.t} vector =
1845 if 0 = Vector.length variants
1846 then (Unit, Vector.new0 ())
1847 else if 1 = Vector.length variants
1850 val {args, con, objptrTycon} = Vector.sub (variants, 0)
1852 TupleRep.make (objptrTycon, args,
1855 val conRep = ConRep.Tuple tupleRep
1857 (One {con = con, tupleRep = tupleRep},
1858 Vector.new1 {con = con, rep = conRep})
1860 else if (2 = Vector.length variants
1862 val c = #con (Vector.first variants)
1864 Con.equals (c, Con.falsee)
1865 orelse Con.equals (c, Con.truee)
1867 then (bool, Vector.new2 ({con = Con.falsee, rep = ConRep.falsee},
1868 {con = Con.truee, rep = ConRep.truee}))
1871 val numSmall : IntInf.t ref = ref 0
1872 val small = Array.array (objptrBitsAsInt (), [])
1876 (variants, fn {args, con, objptrTycon} =>
1879 TupleRep.make (objptrTycon, args,
1885 objptrTycon = objptrTycon,
1887 val Rep.T {rep, ty} = TupleRep.rep tr
1892 val i = Bits.toInt (Type.width ty)
1894 if i >= objptrBitsAsInt ()
1898 val {component, selects} =
1900 TupleRep.Direct z => z
1901 | TupleRep.Indirect _ =>
1902 Error.bug "PackedRepresentation.TyconRep.make: small Indirect"
1903 val () = IntInf.inc numSmall
1907 {component = component,
1909 objptrTycon = objptrTycon,
1911 :: Array.sub (small, i))
1916 | Rep.Objptr _ => makeBig ()
1919 val numSmall = !numSmall
1920 fun noLargerThan (i, ac) =
1925 List.fold (Array.sub (small, i), ac, op ::)))
1926 (* Box as few things as possible so that the number of tags available
1927 * is >= the number of unboxed variants.
1929 fun loop (maxSmallWidth: int,
1932 numSmall: IntInf.t) =
1934 then (maxSmallWidth, forced, [])
1937 val vs = Array.sub (small, maxSmallWidth)
1940 then loop (maxSmallWidth - 1, forced,
1941 withObjptr, numSmall)
1946 {tagBits = objptrBitsAsInt () - maxSmallWidth,
1947 withObjptr = withObjptr}
1949 if numSmall <= numTags
1951 (* There are enough tag bits available. *)
1954 noLargerThan (maxSmallWidth - 1, vs))
1957 val z = Int.toIntInf (List.length vs)
1958 val remaining = numSmall - z
1960 if remaining <= numTags
1967 (numSmall - numTags))
1970 List.append (front, forced),
1971 noLargerThan (maxSmallWidth - 1,
1974 else loop (maxSmallWidth - 1,
1981 val (maxSmallWidth, forced, small) =
1982 loop (objptrBitsAsInt () - 1, [],
1983 not (List.isEmpty big),
1985 val maxSmallWidth = Bits.fromInt maxSmallWidth
1986 val withObjptr = not (List.isEmpty big andalso List.isEmpty forced)
1987 (* ShiftAndTag all the small. *)
1988 val (small: Small.t option, smallReps) =
1990 val numSmall = List.length small
1993 then (NONE, Vector.new0 ())
1997 tagBitsNeeded {numVariants = numSmall,
1998 withObjptr = withObjptr}
2000 fun getTag (): IntInf.t =
2004 if withObjptr andalso
2005 0w0 = Word.andb (w, 0w3)
2008 val () = r := w + 0w1
2014 (small, fn {component, con, selects, ...} =>
2018 (getTag (), WordSize.fromBits tagBits)
2019 val isUnit = Type.isUnit (Component.ty component)
2021 Component.padToWidth
2022 (component, maxSmallWidth)
2023 val selects = Selects.lshift (selects, tagBits)
2028 Component.ty component))
2031 then Type.resize (ty, objptrBits ())
2032 else Type.padToPrim ty
2034 {component = component,
2041 val ty = Type.sum (Vector.map (small, #ty))
2042 val rep = Rep.T {rep = Rep.NonObjptr, ty = ty}
2045 (small, fn {component, con, isUnit, selects, tag, ty,
2049 then ConRep.Tag {tag = tag, ty = ty}
2050 else (ConRep.ShiftAndTag
2051 {component = component,
2057 (reps, fn {rep, ...} =>
2059 ConRep.Tag _ => true
2062 (SOME (Small.T {isEnum = isEnum,
2065 variants = Vector.map (reps, #con)}),
2069 fun makeSmallObjptr {component, con, objptrTycon, selects} =
2071 objptr = (ObjptrRep.box
2072 (Component.padToWidth (component, objptrBits ()),
2073 objptrTycon, selects))}
2074 fun makeBigObjptr {con, objptrTycon, tupleRep} =
2078 TupleRep.Direct {component, selects} =>
2079 ObjptrRep.box (component, objptrTycon, selects)
2080 | TupleRep.Indirect p => p
2082 {con = con, objptr = objptr}
2084 fun sumWithSmall (r: Rep.t): Rep.t =
2085 Rep.T {rep = Rep.Objptr {endsIn00 = false},
2086 ty = Type.sum (Vector.new2
2088 Rep.ty (Small.rep (valOf small))))}
2093 [Vector.fromListMap (forced, makeSmallObjptr),
2094 Vector.fromListMap (big, makeBigObjptr)]
2096 if 1 = Vector.length objptrs
2099 val objptr = Vector.first objptrs
2100 val small = valOf small
2102 sumWithSmall (ObjptrRep.rep (#objptr objptr))
2104 SmallAndBox {box = objptr,
2112 (Vector.map (objptrs, ObjptrRep.ty o #objptr))
2115 {rep = Rep.T {rep = Rep.Objptr {endsIn00 = true},
2120 NONE => Objptrs objptrs
2124 rep = sumWithSmall (Objptrs.rep objptrs),
2129 Vector.map (objptrs, fn {con, objptr} =>
2131 rep = ConRep.box objptr}))
2133 val (sumRep, objptrReps) =
2134 case (forced, big) of
2135 ([], []) => (Small (valOf small), Vector.new0 ())
2136 | ([], [{con, tupleRep, ...}]) =>
2137 (* If there is only one big and it is an objptr that
2138 * ends in 00, then there is no need to box it.
2141 TupleRep.Direct {component, ...} =>
2143 val rep = TupleRep.rep tupleRep
2145 if Rep.isObjptrEndingIn00 rep
2148 val small = valOf small
2151 {objptr = {component = component,
2153 rep = sumWithSmall rep,
2157 rep = ConRep.Tuple tupleRep})
2164 (sumRep, Vector.concat [smallReps, objptrReps])
2169 ("PackedRepresentation.TyconRep.make",
2171 (fn {args, con, ...} =>
2172 Layout.record [("args", Vector.layout (Rep.layout o #rep) args),
2173 ("con", Con.layout con)]),
2174 Layout.tuple2 (layout,
2177 Layout.record [("con", Con.layout con),
2178 ("rep", ConRep.layout rep)])))
2183 conRep: Con.t -> ConRep.t,
2184 default: Label.t option,
2185 test: unit -> Operand.t})
2186 : Statement.t list * Transfer.t * Block.t list =
2188 val (statements, transfer) =
2191 (case (Vector.length cases, default) of
2193 (* Use _ instead of NONE for the default becuase
2194 * there may be an unreachable default case.
2197 val {con = c, dst, dstHasArg} =
2200 if not (Con.equals (c, con))
2201 then Error.bug "PackedRepresentation.genCase: One"
2204 Goto {args = (if dstHasArg
2205 then Vector.new1 (test ())
2206 else Vector.new0 ()),
2210 ([], Goto {dst = l, args = Vector.new0 ()})
2211 | _ => Error.bug "PackedRepresentation.genCase: One,prim datatype with more than one case")
2213 Objptrs.genCase (ps, {cases = cases,
2218 Small.genCase (s, {cases = cases,
2222 smallDefault = default,
2224 | SmallAndBox {box = {con, objptr}, small, ...} =>
2227 case Vector.peek (cases, fn {con = c, ...} =>
2228 Con.equals (c, con)) of
2230 | SOME {dst, dstHasArg, ...} =>
2233 Operand.cast (test (),
2234 ObjptrRep.ty objptr)
2238 {statements = Vector.new0 (),
2240 Goto {args = (if dstHasArg
2241 then Vector.new1 test
2242 else Vector.new0 ()),
2246 Small.genCase (small, {cases = cases,
2249 notSmall = notSmall,
2250 smallDefault = default,
2253 | SmallAndObjptr {objptr = {component, con}, small, ...} =>
2256 case Vector.peek (cases, fn {con = c, ...} =>
2257 Con.equals (c, con)) of
2259 | SOME {dst, dstHasArg, ...} =>
2266 Component.ty component)))
2270 {statements = Vector.new0 (),
2271 transfer = Goto {args = args,
2275 Small.genCase (small, {cases = cases,
2278 notSmall = notSmall,
2279 smallDefault = default,
2282 | SmallAndObjptrs {objptrs, small, ...} =>
2287 (objptrs, {cases = cases,
2290 test = (Operand.cast
2291 (test, Objptrs.ty objptrs))})
2293 Block.new {statements = Vector.fromList ss,
2296 Small.genCase (small, {cases = cases,
2299 notSmall = SOME objptr,
2300 smallDefault = default,
2303 | Unit => Error.bug "PackedRepresentation.TyconRep.genCase: Unit"
2305 (statements, transfer, Block.getExtra ())
2310 ("PackedRepresentation.TyconRep.genCase",
2311 fn (r, {cases, default, ...}) =>
2312 Layout.tuple [layout r,
2314 [("cases", Cases.layout cases),
2315 ("default", Option.layout Label.layout default)]],
2316 Layout.tuple3 (List.layout Statement.layout,
2318 List.layout Block.layout))
2326 val affect: 'a t * 'b t -> unit
2327 val constant: 'a -> 'a t
2328 val fixedPoint: unit -> unit
2330 val layout: ('a -> Layout.t) -> 'a t -> Layout.t
2331 val new: {compute: unit -> 'a,
2332 equals: 'a * 'a -> bool,
2338 datatype t = T of {affects: t list ref,
2339 compute: unit -> {change: bool},
2340 needToCompute: bool ref}
2342 (* A list of all ts such that !needToCompute = true. *)
2343 val todo: t list ref = ref []
2345 fun recompute (me as T {needToCompute, ...}) =
2348 else (List.push (todo, me)
2349 ; needToCompute := true)
2354 | T {affects, compute, needToCompute, ...} :: l =>
2357 val () = needToCompute := false
2358 val {change} = compute ()
2361 then List.foreach (!affects, recompute)
2367 fun affect (T {affects, ...}, z) = List.push (affects, z)
2369 fun new {compute: unit -> 'a,
2370 equals: 'a * 'a -> bool,
2371 init: 'a}: t * 'a ref =
2373 val r: 'a ref = ref init
2374 val affects = ref []
2379 val new = compute ()
2382 {change = not (equals (old, new))}
2384 val me = T {affects = affects,
2386 needToCompute = ref false}
2387 val () = recompute me
2395 | Variable of Dep.t * 'a ref
2399 | Variable (_, r) => !r
2401 fun layout l v = l (get v)
2403 val constant = Constant
2405 fun new z = Variable (Dep.new z)
2408 fn (Variable (d, _), Variable (d', _)) => Dep.affect (d, d')
2409 | (Constant _, _) => ()
2410 | (_, Constant _) => Error.bug "PackedRepresentation.Value.affect: Constant"
2412 val fixedPoint = Dep.fixedPoint
2415 fun compute (program as Ssa.Program.T {datatypes, ...}) =
2417 type tyconRepAndCons =
2418 (TyconRep.t * {con: Con.t, rep: ConRep.t} vector) Value.t
2419 val {get = conInfo: Con.t -> {rep: ConRep.t ref,
2420 tyconRep: tyconRepAndCons},
2421 set = setConInfo, ...} =
2422 Property.getSetOnce (Con.plist, Property.initRaise ("info", Con.layout))
2423 val {get = tupleRep: S.Type.t -> TupleRep.t Value.t,
2424 set = setTupleRep, ...} =
2425 Property.getSetOnce (S.Type.plist,
2426 Property.initRaise ("tupleRep", S.Type.layout))
2429 ("PackedRepresentation.setTupleRep",
2430 S.Type.layout o #1, Layout.ignore)
2432 fun vectorRep (t: S.Type.t): TupleRep.t = Value.get (tupleRep t)
2433 fun setVectorRep (t: S.Type.t, tr: TupleRep.t): unit =
2434 setTupleRep (t, Value.new {compute = fn () => tr,
2435 equals = TupleRep.equals,
2439 ("PackedRepresentation.setVectorRep",
2440 S.Type.layout, TupleRep.layout, Unit.layout)
2442 val {get = tyconRep: Tycon.t -> tyconRepAndCons, set = setTyconRep, ...} =
2443 Property.getSetOnce (Tycon.plist,
2444 Property.initRaise ("tyconRep", Tycon.layout))
2445 (* Initialize the datatypes. *)
2446 val typeRepRef = ref (fn _ => Error.bug "PackedRepresentation.typeRep")
2447 fun typeRep t = !typeRepRef t
2450 (datatypes, fn S.Datatype.T {cons, tycon} =>
2454 (cons, fn {args, con} =>
2457 objptrTycon = ObjptrTycon.new ()})
2463 (cons, fn {args, con, objptrTycon} =>
2464 {args = Vector.map (Prod.dest args,
2465 fn {elt, isMutable} =>
2466 {isMutable = isMutable,
2467 rep = Value.get (typeRep elt),
2470 objptrTycon = objptrTycon}))
2473 (cons, fn {con, rep} => #rep (conInfo con) := rep)
2477 fun equals ((r, v), (r', v')) =
2478 TyconRep.equals (r, r')
2479 andalso Vector.equals (v, v', fn ({con = c, rep = r},
2480 {con = c', rep = r'}) =>
2482 andalso ConRep.equals (r, r'))
2484 Value.new {compute = compute,
2486 init = (TyconRep.unit, Vector.new0 ())}
2487 val () = setTyconRep (tycon, rep)
2488 val () = Vector.foreach (cons, fn {con, ...} =>
2489 setConInfo (con, {rep = ref ConRep.unit,
2496 val delayedObjectTypes
2497 : (unit -> (ObjptrTycon.t * ObjectType.t) option) list ref =
2499 val {get = typeRep: S.Type.t -> Rep.t Value.t, ...} =
2503 (fn (t, typeRep: S.Type.t -> Rep.t Value.t) =>
2505 val constant = Value.constant
2506 val nonObjptr = constant o Rep.nonObjptr
2507 datatype z = datatype S.Type.dest
2509 case S.Type.dest t of
2510 CPointer => nonObjptr (Type.cpointer ())
2513 val r = tyconRep tycon
2514 fun compute () = TyconRep.rep (#1 (Value.get r))
2515 val r' = Value.new {compute = compute,
2516 equals = Rep.equals,
2518 val () = Value.affect (r, r')
2523 constant (Rep.T {rep = Rep.Objptr {endsIn00 = false},
2524 ty = Type.intInf ()})
2525 | Object {args, con} =>
2527 ObjectCon.Con con =>
2529 val {rep, tyconRep} = conInfo con
2530 fun compute () = ConRep.rep (!rep)
2531 val r = Value.new {compute = compute,
2532 equals = Rep.equals,
2534 val () = Value.affect (tyconRep, r)
2538 | ObjectCon.Tuple =>
2540 val opt = ObjptrTycon.new ()
2542 Vector.map (Prod.dest args, typeRep o #elt)
2546 Vector.map2 (rs, Prod.dest args,
2547 fn (r, {elt, isMutable}) =>
2548 {isMutable = isMutable,
2551 {forceBox = false, isVector = false})
2553 Value.new {compute = compute,
2554 equals = TupleRep.equals,
2555 init = TupleRep.unit}
2556 val () = Vector.foreach (rs, fn r =>
2557 Value.affect (r, tr))
2558 val hasIdentity = Prod.someIsMutable args
2561 (delayedObjectTypes, fn () =>
2562 case Value.get tr of
2563 TupleRep.Indirect opr =>
2565 (opt, (ObjectType.Normal
2566 {hasIdentity = hasIdentity,
2567 ty = ObjptrRep.componentsTy opr}))
2569 val () = setTupleRep (t, tr)
2570 fun compute () = TupleRep.rep (Value.get tr)
2571 val r = Value.new {compute = compute,
2572 equals = Rep.equals,
2574 val () = Value.affect (tr, r)
2578 | ObjectCon.Vector =>
2580 val hasIdentity = Prod.someIsMutable args
2581 val args = Prod.dest args
2588 (args, fn {elt, isMutable} =>
2589 {isMutable = isMutable,
2590 rep = Value.get (typeRep elt),
2594 val () = setVectorRep (t, tr)
2598 fun now opt = (ignore (tupleRep opt); opt)
2601 val opt = ObjptrTycon.new ()
2604 (delayedObjectTypes, fn () =>
2606 (* Delay computing tupleRep until the
2607 * delayedObjectTypes are computed
2608 * because the vector component types
2609 * may not be known yet.
2611 val tr = tupleRep opt
2614 TupleRep.Direct _ =>
2616 | TupleRep.Indirect opr =>
2617 ObjptrRep.componentsTy opr
2622 hasIdentity = hasIdentity})
2628 if 1 <> Vector.length args
2632 val {elt, isMutable, ...} =
2633 Vector.sub (args, 0)
2638 (case S.Type.dest elt of
2641 val nBits = WordSize.bits s
2642 val nInt = Bits.toInt nBits
2650 (ObjptrTycon.wordVector nBits)
2657 (Rep.T {rep = Rep.Objptr {endsIn00 = true},
2658 ty = Type.objptr opt})
2660 | Real s => nonObjptr (Type.real s)
2662 constant (Rep.T {rep = Rep.Objptr {endsIn00 = true},
2663 ty = Type.thread ()})
2666 val opt = ObjptrTycon.new ()
2668 Rep.T {rep = Rep.Objptr {endsIn00 = true},
2669 ty = Type.objptr opt}
2672 if Rep.isObjptr (Value.get r)
2675 val r' = Value.new {compute = compute,
2676 equals = Rep.equals,
2678 val () = Value.affect (r, r')
2681 (delayedObjectTypes, fn () =>
2686 then SOME (opt, ObjectType.Weak (SOME (Rep.ty r)))
2692 | Word s => nonObjptr (Type.word s)
2694 val () = typeRepRef := typeRep
2695 val _ = typeRep (S.Type.vector1 (S.Type.word WordSize.byte))
2696 (* Establish dependence between constructor argument type representations
2697 * and tycon representations.
2701 (datatypes, fn {cons, rep, ...} =>
2703 (cons, fn {args, ...} =>
2704 Vector.foreach (Prod.dest args, fn {elt, ...} =>
2705 Value.affect (typeRep elt, rep))))
2708 ("PackedRepresentation.typeRep",
2709 S.Type.layout, Value.layout Rep.layout)
2711 val () = S.Program.foreachVar (program, fn (_, t) => ignore (typeRep t))
2712 val () = Value.fixedPoint ()
2713 val conRep = ! o #rep o conInfo
2714 val tyconRep = #1 o Value.get o tyconRep
2717 (datatypes, [], fn ({cons, ...}, ac) =>
2719 (cons, ac, fn ({args, con, objptrTycon, ...}, ac) =>
2721 ConRep.Tuple (TupleRep.Indirect opr) =>
2723 ObjectType.Normal {hasIdentity = Prod.someIsMutable args,
2724 ty = ObjptrRep.componentsTy opr}) :: ac
2726 val objectTypes = ref objectTypes
2728 List.foreach (!delayedObjectTypes, fn f =>
2729 Option.app (f (), fn z => List.push (objectTypes, z)))
2730 val objectTypes = Vector.fromList (!objectTypes)
2734 (display (Layout.str "Representations:")
2736 (datatypes, fn {cons, tycon, ...} =>
2740 display (seq [Tycon.layout tycon,
2741 str " ", TyconRep.layout (tyconRep tycon)])
2745 record [("con", Con.layout con),
2746 ("rep", ConRep.layout (conRep con))])
2750 fun toRtype (t: S.Type.t): Type.t option =
2752 val ty = Rep.ty (Value.get (typeRep t))
2756 else SOME (Type.padToPrim ty)
2758 fun makeSrc (v, oper) {index} = oper (Vector.sub (v, index))
2759 fun genCase {cases, default, test, tycon} =
2760 TyconRep.genCase (tyconRep tycon,
2765 val tupleRep = Value.get o tupleRep
2768 ("PackedRepresentation.tupleRep",
2769 S.Type.layout, TupleRep.layout)
2771 fun object {args, con, dst, objectTy, oper} =
2773 val src = makeSrc (args, oper)
2776 NONE => TupleRep.tuple (tupleRep objectTy, {dst = dst, src = src})
2777 | SOME con => ConRep.conApp (conRep con, {dst = dst, src = src})
2779 fun getSelects (con, objectTy) =
2781 datatype z = datatype ObjectCon.t
2786 ConRep.ShiftAndTag {selects, ...} => (selects, NONE)
2787 | ConRep.Tuple tr => (TupleRep.selects tr, NONE)
2788 | _ => Error.bug "PackedRepresentation.getSelects: Con,non-select")
2789 | Tuple => (TupleRep.selects (tupleRep objectTy), NONE)
2791 case vectorRep objectTy of
2792 tr as TupleRep.Indirect pr =>
2793 (TupleRep.selects tr,
2794 SOME (Type.bytes (ObjptrRep.componentsTy pr)))
2795 | _ => Error.bug "PackedRepresentation.getSelects: Vector,non-Indirect"
2797 fun select {base, baseTy, dst, offset} =
2798 case S.Type.dest baseTy of
2799 S.Type.Object {con, ...} =>
2801 val (ss, eltWidth) = getSelects (con, baseTy)
2805 eltWidth = eltWidth,
2809 | _ => Error.bug "PackedRepresentation.select: non-object"
2810 fun update {base, baseTy, offset, value} =
2811 case S.Type.dest baseTy of
2812 S.Type.Object {con, ...} =>
2814 val (ss, eltWidth) = getSelects (con, baseTy)
2816 Selects.update (ss, {base = base,
2817 eltWidth = eltWidth,
2821 | _ => Error.bug "PackedRepresentation.update: non-object"
2823 {diagnostic = diagnostic,
2826 objectTypes = objectTypes,