mlton/backend/packed-representation.fun

   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.
   5  *
   6  * MLton is released under a BSD-style license.
   7  * See the file MLton-LICENSE for details.
   8  *)
   9
  10 (* Has a special case to make sure that true is represented as 1
  11  * and false is represented as 0.
  12  *)
  13
  14 functor PackedRepresentation (S: REPRESENTATION_STRUCTS): REPRESENTATION =
  15 struct
  16
  17 open S
  18
  19 local
  20    open Rssa
  21 in
  22    structure Block = Block
  23    structure Kind = Kind
  24    structure Label = Label
  25    structure ObjectType = ObjectType
  26    structure Operand = Operand
  27    structure ObjptrTycon = ObjptrTycon
  28    structure Prim = Prim
  29    structure RealSize = RealSize
  30    structure Runtime = Runtime
  31    structure Scale = Scale
  32    structure Statement = Statement
  33    structure Switch = Switch
  34    structure Transfer = Transfer
  35    structure Type = Type
  36    structure Var = Var
  37    structure WordSize = WordSize
  38    structure WordX = WordX
  39 end
  40 structure S = Ssa
  41 local
  42    open Ssa
  43 in
  44    structure Base = Base
  45    structure Con = Con
  46    structure ObjectCon = ObjectCon
  47    structure Prod = Prod
  48    structure Tycon = Tycon
  49 end
  50
  51 datatype z = datatype Operand.t
  52 datatype z = datatype Statement.t
  53 datatype z = datatype Transfer.t
  54
  55 structure Type =
  56    struct
  57       open Type
  58
  59       local
  60          fun mkPadToCheck (t: t, mk): (Bits.t * (unit -> t) -> t) =
  61             let
  62                val b = width t
  63                fun check (b', continue) =
  64                   if Bits.< (b, b')
  65                      then let
  66                              val pad = zero (Bits.- (b', b))
  67                           in
  68                              mk (t, pad)
  69                           end
  70                   else if Bits.equals (b, b')
  71                           then t
  72                        else continue ()
  73             in
  74                check
  75             end
  76          fun mkPadToPrim (t: t, mk): t =
  77             let
  78                val check = mkPadToCheck (t, mk)
  79             in
  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")))))
  86             end
  87          fun mkPadToWidth (t: t, b': Bits.t, mk): t =
  88             let
  89                val check = mkPadToCheck (t, mk)
  90             in
  91                check (b', fn () =>
  92                Error.bug "PackedRepresentation.Type.mkPadToWidth")
  93             end
  94          fun mk (t, pad) = seq (Vector.new2 (t, pad))
  95          fun mkLow (t, pad) = seq (Vector.new2 (pad, t))
  96       in
  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)
 101       end
 102
 103       val padToPrim =
 104          Trace.trace
 105          ("PackedRepresentation.Type.padToPrim", layout, layout)
 106          padToPrim
 107       val padToPrimLow =
 108          Trace.trace
 109          ("PackedRepresentation.Type.padToPrimLow", layout, layout)
 110          padToPrimLow
 111       val padToWidth =
 112          Trace.trace2
 113          ("PackedRepresentation.Type.padToWidth", layout, Bits.layout, layout)
 114          padToWidth
 115       val padToWidthLow =
 116          Trace.trace2
 117          ("PackedRepresentation.Type.padToWidthLow", layout, Bits.layout, layout)
 118          padToWidthLow
 119
 120    end
 121
 122 structure Rep =
 123    struct
 124       datatype rep =
 125          NonObjptr
 126        | Objptr of {endsIn00: bool}
 127
 128       datatype t = T of {rep: rep,
 129                          ty: Type.t}
 130
 131       fun layout (T {rep, ty}) =
 132          let
 133             open Layout
 134          in
 135             record [("rep",
 136                      case rep of
 137                         NonObjptr => str "NonObjptr"
 138                       | Objptr {endsIn00} =>
 139                            seq [str "Objptr ",
 140                                 record [("endsIn00", Bool.layout endsIn00)]]),
 141                     ("ty", Type.layout ty)]
 142          end
 143
 144       local
 145          fun make f (T r) = f r
 146       in
 147          val ty = make #ty
 148          val rep = make #rep
 149       end
 150
 151       fun equals (r, r') = Type.equals (ty r, ty r')
 152
 153       val equals =
 154          Trace.trace2
 155          ("PackedRepresentation.Rep.equals", layout, layout, Bool.layout)
 156          equals
 157
 158       fun nonObjptr ty = T {rep = NonObjptr,
 159                             ty = ty}
 160
 161       val bool = nonObjptr Type.bool
 162
 163       val width = Type.width o ty
 164
 165       val unit = T {rep = NonObjptr,
 166                     ty = Type.unit}
 167
 168       fun isObjptr (T {rep, ...}) =
 169          case rep of
 170             Objptr _ => true
 171           | _ => false
 172
 173       fun isObjptrEndingIn00 (T {rep, ...}) =
 174          case rep of
 175             Objptr {endsIn00} => endsIn00
 176           | _ => false
 177
 178       fun padToWidth (r as T {rep, ty}, width: Bits.t) =
 179          if Bits.equals (Type.width ty, width)
 180             then r
 181          else
 182             case rep of
 183                NonObjptr =>
 184                   T {rep = NonObjptr,
 185                      ty = Type.padToWidth (ty, width)}
 186              | Objptr _ => Error.bug "PackedRepresentation.Rep.padToWidth"
 187
 188       fun padToWidthLow (r as T {rep, ty}, width: Bits.t) =
 189          if Bits.equals (Type.width ty, width)
 190             then r
 191          else
 192             case rep of
 193                NonObjptr =>
 194                   T {rep = NonObjptr,
 195                      ty = Type.padToWidthLow (ty, width)}
 196              | Objptr _ => Error.bug "PackedRepresentation.Rep.padToWidth"
 197    end
 198
 199 structure Statement =
 200    struct
 201       open Statement
 202
 203       local
 204          fun make prim (z1: Operand.t, z2: Operand.t) =
 205             let
 206                val ty = Operand.ty z1
 207                val tmp = Var.newNoname ()
 208             in
 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})
 213             end
 214       in
 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}))
 219       end
 220    end
 221
 222 structure WordRep =
 223    struct
 224       (* WordRep describes the representation of (some of) the components in a
 225        * tuple as a word.
 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
 229        * width of the rep.
 230        *)
 231       datatype t = T of {components: {index: int,
 232                                       rep: Rep.t} vector,
 233                          rep: Rep.t}
 234
 235       fun layout (T {components, rep}) =
 236          let
 237             open Layout
 238          in
 239             record [("components",
 240                      Vector.layout (fn {index, rep} =>
 241                                     record [("index", Int.layout index),
 242                                             ("rep", Rep.layout rep)])
 243                      components),
 244                     ("rep", Rep.layout rep)]
 245          end
 246
 247       local
 248          fun make f (T r) = f r
 249       in
 250          val rep = make #rep
 251       end
 252
 253       val unit = T {components = Vector.new0 (),
 254                     rep = Rep.unit}
 255
 256       fun equals (wr, wr') = Rep.equals (rep wr, rep wr')
 257
 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)),
 263                                  Rep.width rep)
 264             then T {components = components,
 265                     rep = rep}
 266          else Error.bug "PackedRepresentation.WordRep.make"
 267
 268       val make =
 269          Trace.trace
 270          ("PackedRepresentation.WordRep.make",
 271           layout o T,
 272           layout)
 273          make
 274
 275       fun padToWidth (T {components, rep}, b: Bits.t): t =
 276          let
 277             val newRep = Rep.padToWidth (rep, b)
 278             val padBits = Bits.- (Rep.width newRep, Rep.width rep)
 279             val newComponent =
 280                {index = ~1,
 281                 rep = Rep.nonObjptr (Type.bits padBits)}
 282             val newComponents =
 283                Vector.concat
 284                [components, Vector.new1 newComponent]
 285          in
 286             make {components = newComponents,
 287                   rep = newRep}
 288          end
 289       fun padToWidthLow (T {components, rep}, b: Bits.t): t =
 290          let
 291             val newRep = Rep.padToWidthLow (rep, b)
 292             val padBits = Bits.- (Rep.width newRep, Rep.width rep)
 293             val newComponent =
 294                {index = ~1,
 295                 rep = Rep.nonObjptr (Type.bits padBits)}
 296             val newComponents =
 297                Vector.concat
 298                [Vector.new1 newComponent, components]
 299          in
 300             make {components = newComponents,
 301                   rep = newRep}
 302          end
 303
 304       fun tuple (T {components, ...},
 305                  {dst = (dstVar, dstTy): Var.t * Type.t,
 306                   src: {index: int} -> Operand.t}): Statement.t list =
 307          let
 308             val bits = Type.width dstTy
 309             val (accOpt,_,statements) =
 310                Vector.fold
 311                (components, (NONE,Bits.zero,[]),
 312                 fn ({index, rep, ...}, (accOpt,shift,statements)) =>
 313                 if index < 0
 314                    then (accOpt, Bits.+ (shift, Rep.width rep), statements)
 315                 else
 316                 let
 317                    val (src, ss) = Statement.resize (src {index = index},
 318                                                      Type.bits bits)
 319                    val ss = List.rev ss
 320                    val (src, ss) =
 321                       if Bits.equals (shift, Bits.zero)
 322                          then (src, ss)
 323                       else let
 324                               val (s, src) =
 325                                  Statement.lshift
 326                                  (src,
 327                                   Operand.word
 328                                   (WordX.fromIntInf (Bits.toIntInf shift,
 329                                                      WordSize.shiftArg)))
 330                            in
 331                               (src, s :: ss)
 332                            end
 333                    val (acc, ss) =
 334                       case accOpt of
 335                          NONE => (src, ss)
 336                        | SOME acc =>
 337                             let
 338                                val (s, acc) = Statement.orb (src, acc)
 339                             in
 340                                (acc, s :: ss)
 341                             end
 342                 in
 343                    (SOME acc, Bits.+ (shift, Rep.width rep), ss :: statements)
 344                 end)
 345             val statements =
 346                case accOpt of
 347                   NONE => []
 348                 | SOME src =>
 349                      [Bind {dst = (dstVar, dstTy),
 350                             isMutable = false,
 351                             src = src}]
 352                      :: statements
 353          in
 354             List.fold (statements, [], fn (ss, ac) => List.fold (ss, ac, op ::))
 355          end
 356
 357       val tuple =
 358          Trace.trace
 359          ("PackedRepresentation.WordRep.tuple",
 360           layout o #1, List.layout Statement.layout)
 361          tuple
 362    end
 363
 364 structure Component =
 365    struct
 366       datatype t =
 367          Direct of {index: int,
 368                     rep: Rep.t}
 369        | Word of WordRep.t
 370
 371       fun layout c =
 372          let
 373             open Layout
 374          in
 375             case c of
 376                Direct {index, rep} =>
 377                   seq [str "Direct ",
 378                        record [("index", Int.layout index),
 379                                ("rep", Rep.layout rep)]]
 380              | Word wr =>
 381                   seq [str "Word ", WordRep.layout wr]
 382          end
 383
 384       val rep: t -> Rep.t =
 385          fn Direct {rep, ...} => rep
 386           | Word wr => WordRep.rep wr
 387
 388       val ty = Rep.ty o rep
 389
 390       val unit = Word WordRep.unit
 391
 392       val equals: t * t -> bool =
 393          fn z =>
 394          case z of
 395             (Direct {rep = r, ...}, Direct {rep = r', ...}) => Rep.equals (r, r')
 396           | (Word wr, Word wr') => WordRep.equals (wr, wr')
 397           | _ => false
 398
 399       local
 400          fun mkPadToWidth (c: t, b: Bits.t, repPadToWidth, wordRepPadToWidth): t =
 401             case c of
 402                Direct {index, rep} =>
 403                   Direct {index = index,
 404                           rep = repPadToWidth (rep, b)}
 405              | Word r => Word (wordRepPadToWidth (r, b))
 406       in
 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)
 411       end
 412
 413       local
 414          fun mkPadToPrim (c: t, typePadToPrim, padToWidth) =
 415             let
 416                val ty = ty c
 417                val ty' = typePadToPrim ty
 418             in
 419                if Type.equals (ty, ty')
 420                   then c
 421                else padToWidth (c, Type.width ty')
 422             end
 423       in
 424          fun padToPrim c = mkPadToPrim (c, Type.padToPrim, padToWidth)
 425          fun padToPrimLow c = mkPadToPrim (c, Type.padToPrimLow, padToWidthLow)
 426       end
 427
 428       fun tuple (c: t, {dst: Var.t * Type.t,
 429                         src: {index: int} -> Operand.t})
 430          : Statement.t list =
 431          case c of
 432             Direct {index, ...} =>
 433                let
 434                   val (src, ss) =
 435                      Statement.resize (src {index = index}, #2 dst)
 436                in
 437                   ss @ [Bind {dst = dst,
 438                               isMutable = false,
 439                               src = src}]
 440                end
 441           | Word wr => WordRep.tuple (wr, {dst = dst, src = src})
 442
 443       val tuple =
 444          Trace.trace2
 445          ("PackedRepresentation.Component.tuple",
 446           layout,
 447           fn {dst = (dst, _), ...} => Var.layout dst,
 448           List.layout Statement.layout)
 449          tuple
 450    end
 451
 452 structure Unpack =
 453    struct
 454       datatype t = T of {shift: Bits.t,
 455                          ty: Type.t}
 456
 457       fun layout (T {shift, ty}) =
 458          let
 459             open Layout
 460          in
 461             record [("shift", Bits.layout shift),
 462                     ("ty", Type.layout ty)]
 463          end
 464
 465       val lshift: t * Bits.t -> t =
 466          fn (T {shift, ty}, b) =>
 467          T {shift = Bits.+ (shift, b),
 468             ty = ty}
 469
 470       fun select (T {shift, ty},
 471                   {dst = (dst, dstTy),
 472                    src: Operand.t}): Statement.t list =
 473          let
 474             val (src, ss1) =
 475                if Bits.isZero shift
 476                   then (src, [])
 477                else
 478                   let
 479                      val shift =
 480                         WordX.fromIntInf (Bits.toIntInf shift, WordSize.shiftArg)
 481                      val (s, tmp) = Statement.rshift (src, Operand.word shift)
 482                   in
 483                      (tmp, [s])
 484                   end
 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)
 490             val (src, ss3) =
 491                if Bits.equals (w, w')
 492 (*                orelse Type.isZero (Type.dropPrefix (Operand.ty src,
 493  *                                                     WordSize.bits sz))
 494  *)
 495                   then (src, [])
 496                else
 497                   let
 498                      val mask = WordX.resize (WordX.max (sz, {signed = false}), sz')
 499                      val (s, src) = Statement.andb (src, Operand.word mask)
 500                   in
 501                      (src, [s])
 502                   end
 503          in
 504             ss1 @ ss2 @ ss3 @ [Bind {dst = (dst, dstTy),
 505                                      isMutable = false,
 506                                      src = src}]
 507          end
 508
 509       val select =
 510          Trace.trace2
 511          ("PackedRepresentation.Unpack.select",
 512           layout,
 513           fn {dst = (dst, _), src} =>
 514           Layout.record [("dst", Var.layout dst),
 515                          ("src", Operand.layout src)],
 516           List.layout Statement.layout)
 517          select
 518
 519       fun update (T {shift, ty},
 520                   {chunk: Operand.t,
 521                    component: Operand.t}): Operand.t * Statement.t list =
 522          let
 523             val shift =
 524                WordX.fromIntInf (Bits.toIntInf shift, WordSize.shiftArg)
 525             val chunkTy = Operand.ty chunk
 526             val chunkWidth = Type.width chunkTy
 527             val mask =
 528                Operand.word
 529                (WordX.notb
 530                 (WordX.lshift
 531                  (WordX.resize (WordX.allOnes (WordSize.fromBits (Type.width ty)),
 532                                 WordSize.fromBits chunkWidth),
 533                   shift)))
 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)
 538          in
 539             (result, [s1] @ s2 @ [s3, s4])
 540          end
 541
 542       val update =
 543          Trace.trace2
 544          ("PackedRepresentation.Unpack.update",
 545           layout,
 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))
 551          update
 552    end
 553
 554 structure Base =
 555    struct
 556       open Base
 557
 558       fun toOperand {base: Operand.t t,
 559                      eltWidth: Bytes.t option,
 560                      offset: Bytes.t,
 561                      ty: Type.t}: Operand.t * Statement.t list =
 562          case base of
 563             Object base =>
 564                (Offset {base = base,
 565                         offset = offset,
 566                         ty = ty},
 567                 [])
 568           | VectorSub {index, vector} =>
 569                let
 570                   val eltWidth =
 571                      case eltWidth of
 572                         NONE => Error.bug "PackedRepresentation.Base.toOperand: eltWidth"
 573                       | SOME w => w
 574                in
 575                   case Scale.fromBytes eltWidth of
 576                      NONE =>
 577                         let
 578                            val seqIndexSize = WordSize.seqIndex ()
 579                            val seqIndexTy = Type.word seqIndexSize
 580                            val prod = Var.newNoname ()
 581                            val s =
 582                               PrimApp {args = (Vector.new2
 583                                                (index,
 584                                                 Operand.word
 585                                                 (WordX.fromIntInf
 586                                                  (Bytes.toIntInf eltWidth,
 587                                                   seqIndexSize)))),
 588                                        dst = SOME (prod, seqIndexTy),
 589                                        prim = (Prim.wordMul
 590                                                (seqIndexSize,
 591                                                 {signed = false}))}
 592                         in
 593                            (ArrayOffset {base = vector,
 594                                          index = Var {var = prod, ty = seqIndexTy},
 595                                          offset = offset,
 596                                          scale = Scale.One,
 597                                          ty = ty},
 598                             [s])
 599                         end
 600                    | SOME s =>
 601                         (ArrayOffset {base = vector,
 602                                       index = index,
 603                                       offset = offset,
 604                                       scale = s,
 605                                       ty = ty},
 606                          [])
 607                end
 608    end
 609
 610 structure Select =
 611    struct
 612       datatype t =
 613          None
 614        | Direct of {ty: Type.t}
 615        | Indirect of {offset: Bytes.t,
 616                       ty: Type.t}
 617        | IndirectUnpack of {offset: Bytes.t,
 618                             rest: Unpack.t,
 619                             ty: Type.t}
 620        | Unpack of Unpack.t
 621
 622       fun layout s =
 623          let
 624             open Layout
 625          in
 626             case s of
 627                None => str "None"
 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]
 640          end
 641
 642       val lshift: t * Bits.t -> t =
 643          fn (s, b) =>
 644          case s of
 645             None => None
 646           | Direct {ty} => Unpack (Unpack.T {shift = b, ty = ty})
 647           | Unpack u => Unpack (Unpack.lshift (u, b))
 648           | _ => Error.bug "PackedRepresentation.Select.lshift"
 649
 650       fun select (s: t, {base: Operand.t Base.t,
 651                          dst: Var.t * Type.t,
 652                          eltWidth: Bytes.t option}): Statement.t list =
 653          let
 654             fun move (src, ss) =
 655                let
 656                   val (dst, dstTy) = dst
 657                   val (src, ss') = Statement.resize (src, dstTy)
 658                in
 659                   ss @ ss' @ [Bind {dst = (dst, dstTy),
 660                                     isMutable = false,
 661                                     src = src}]
 662                end
 663          in
 664             case s of
 665                None => []
 666              | Direct _ => move (Base.object base, [])
 667              | Indirect {offset, ty} =>
 668                   move (Base.toOperand {base = base,
 669                                         eltWidth = eltWidth,
 670                                         offset = offset,
 671                                         ty = ty})
 672              | IndirectUnpack {offset, rest, ty} =>
 673                   let
 674                      val tmpVar = Var.newNoname ()
 675                      val tmpOp = Var {ty = ty, var = tmpVar}
 676                      val (src, ss) =
 677                         Base.toOperand {base = base,
 678                                         eltWidth = eltWidth,
 679                                         offset = offset,
 680                                         ty = ty}
 681                   in
 682                      ss @ (Bind {dst = (tmpVar, ty),
 683                                  isMutable = false,
 684                                  src = src}
 685                            :: Unpack.select (rest, {dst = dst, src = tmpOp}))
 686                   end
 687              | Unpack u =>
 688                   Unpack.select (u, {dst = dst, src = Base.object base})
 689          end
 690
 691       val select =
 692          Trace.trace
 693          ("PackedRepresentation.Select.select",
 694           layout o #1, List.layout Statement.layout)
 695          select
 696
 697       fun update (s: t, {base: Operand.t Base.t,
 698                          eltWidth: Bytes.t option,
 699                          value: Operand.t}): Statement.t list =
 700          case s of
 701             Indirect {offset, ty} =>
 702                let
 703                   val (dst, ss) =
 704                      Base.toOperand {base = base,
 705                                      eltWidth = eltWidth,
 706                                      offset = offset,
 707                                      ty = ty}
 708                in
 709                   ss @ [Move {dst = dst, src = value}]
 710                end
 711           | IndirectUnpack {offset, rest, ty} =>
 712                let
 713                   val (chunk, ss) =
 714                      Base.toOperand {base = base,
 715                                      eltWidth = eltWidth,
 716                                      offset = offset,
 717                                      ty = ty}
 718                   val (newChunk, ss') =
 719                      Unpack.update (rest, {chunk = chunk,
 720                                            component = value})
 721                in
 722                   ss @ ss' @ [Move {dst = chunk, src = newChunk}]
 723                end
 724           | _ => Error.bug "PackedRepresentation.Select.update: non-indirect"
 725
 726       val update =
 727          Trace.trace
 728          ("PackedRepresentation.Select.update",
 729           layout o #1, List.layout Statement.layout)
 730          update
 731    end
 732
 733 structure Selects =
 734    struct
 735       datatype t = T of {orig: S.Type.t,
 736                          select: Select.t} vector
 737
 738       fun layout (T v) = Vector.layout (Select.layout o #select) v
 739
 740       val empty = T (Vector.new0 ())
 741
 742       fun map (T v, f) =
 743          T (Vector.map (v, fn {orig, select} =>
 744                         {orig = orig,
 745                          select = f select}))
 746
 747       fun select (T v, {base: Operand.t Base.t,
 748                         dst: Var.t * Type.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})
 753
 754       fun update (T v, {base, eltWidth, offset, value}) =
 755          Select.update (#select (Vector.sub (v, offset)),
 756                         {base = base, eltWidth = eltWidth, value = value})
 757
 758       fun lshift (T v, b: Bits.t) =
 759          T (Vector.map (v, fn {orig, select} =>
 760                         {orig = orig,
 761                          select = Select.lshift (select, b)}))
 762    end
 763
 764 structure ObjptrRep =
 765    struct
 766       datatype t = T of {components: {component: Component.t,
 767                                       offset: Bytes.t} vector,
 768                          componentsTy: Type.t,
 769                          selects: Selects.t,
 770                          ty: Type.t,
 771                          tycon: ObjptrTycon.t}
 772
 773       fun layout (T {components, componentsTy, selects, ty, tycon}) =
 774          let
 775             open Layout
 776          in
 777             record
 778             [("components",
 779               Vector.layout (fn {component, offset} =>
 780                              record [("component", Component.layout component),
 781                                      ("offset", Bytes.layout offset)])
 782               components),
 783              ("componentsTy", Type.layout componentsTy),
 784              ("selects", Selects.layout selects),
 785              ("ty", Type.layout ty),
 786              ("tycon", ObjptrTycon.layout tycon)]
 787          end
 788
 789       local
 790          fun make f (T r) = f r
 791       in
 792          val componentsTy = make #componentsTy
 793          val ty = make #ty
 794       end
 795
 796       fun equals (T {tycon = c, ...}, T {tycon = c', ...}) =
 797          ObjptrTycon.equals (c, c')
 798
 799       fun rep (T {ty, ...}) =
 800          Rep.T {rep = Rep.Objptr {endsIn00 = true},
 801                 ty = ty}
 802
 803       fun make {components, isVector, selects, tycon} =
 804          let
 805             val width =
 806                Vector.fold
 807                (components, Bytes.zero, fn ({component = c, ...}, ac) =>
 808                 Bytes.+ (ac, Type.bytes (Component.ty c)))
 809             val padBytes: Bytes.t =
 810                if isVector
 811                   then let
 812                           val alignWidth =
 813                              case !Control.align of
 814                                 Control.Align4 => width
 815                               | Control.Align8 =>
 816                                    if (Vector.exists
 817                                        (components, fn {component = c, ...} =>
 818                                         (case Type.deReal (Component.ty c) of
 819                                             NONE => false
 820                                           | SOME s =>
 821                                                RealSize.equals (s, RealSize.R64))
 822                                         orelse
 823                                         (case Type.deWord (Component.ty c) of
 824                                             NONE => false
 825                                           | SOME s =>
 826                                                WordSize.equals (s, WordSize.word64))
 827                                         orelse
 828                                         (Type.isObjptr (Component.ty c)
 829                                          andalso WordSize.equals (WordSize.objptr (),
 830                                                                   WordSize.word64))))
 831                                       then Bytes.alignWord64 width
 832                                    else width
 833                        in
 834                           Bytes.- (alignWidth, width)
 835                        end
 836                else let
 837                        (* Note that with Align8 and objptrSize == 64bits,
 838                         * the following ensures that objptrs will be
 839                         * mod 8 aligned.
 840                         *)
 841                        val width' = Bytes.+ (width, Runtime.normalMetaDataSize ())
 842                        val alignWidth' =
 843                           case !Control.align of
 844                              Control.Align4 => Bytes.alignWord32 width'
 845                            | Control.Align8 => Bytes.alignWord64 width'
 846                        val alignWidth = Bytes.- (alignWidth', Runtime.normalMetaDataSize ())
 847                     in
 848                        Bytes.- (alignWidth, width)
 849                     end
 850             val (components, selects) =
 851                if Bytes.isZero padBytes
 852                   then (components, selects)
 853                else
 854                   (* Need to insert a pad before the first objptr. *)
 855                   let
 856                      val {no = nonObjptrs, yes = objptrs} =
 857                         Vector.partition
 858                         (components, fn {component = c, ...} =>
 859                          Rep.isObjptr (Component.rep c))
 860                      val padOffset =
 861                         if Vector.isEmpty objptrs
 862                            then width
 863                         else #offset (Vector.first objptrs)
 864                      val pad =
 865                         (#1 o Vector.unfoldi)
 866                         ((Bytes.toInt padBytes) div (Bytes.toInt Bytes.inWord32),
 867                          padOffset,
 868                          fn (_, padOffset) =>
 869                          ({component = (Component.padToWidth
 870                                         (Component.unit, Bits.inWord32)),
 871                            offset = padOffset},
 872                           Bytes.+ (padOffset, Bytes.inWord32)))
 873                      val objptrs =
 874                         Vector.map (objptrs, fn {component = c, offset} =>
 875                                     {component = c,
 876                                      offset = Bytes.+ (offset, padBytes)})
 877                      val components =
 878                         Vector.concat [nonObjptrs, pad, objptrs]
 879                      val selects =
 880                         Selects.map
 881                         (selects, fn s =>
 882                          case s of
 883                             Select.Indirect {offset, ty} =>
 884                                if Bytes.>= (offset, padOffset)
 885                                   then
 886                                      Select.Indirect
 887                                      {offset = Bytes.+ (offset, padBytes),
 888                                       ty = ty}
 889                                else s
 890                           | _ => s)
 891                   in
 892                      (components, selects)
 893                   end
 894             val componentsTy =
 895                Type.seq (Vector.map (components, Component.ty o #component))
 896          in
 897             T {components = components,
 898                componentsTy = componentsTy,
 899                selects = selects,
 900                ty = Type.objptr tycon,
 901                tycon = tycon}
 902          end
 903
 904       val make =
 905          let
 906             open Layout
 907          in
 908             Trace.trace
 909             ("PackedRepresentation.ObjptrRep.make",
 910              fn {components, isVector, selects, tycon} =>
 911              record
 912              [("components",
 913                Vector.layout (fn {component, offset} =>
 914                               record [("component", Component.layout component),
 915                                       ("offset", Bytes.layout offset)])
 916                components),
 917               ("isVector", Bool.layout isVector),
 918               ("selects", Selects.layout selects),
 919               ("tycon", ObjptrTycon.layout tycon)],
 920              layout)
 921          end
 922          make
 923
 924       fun box (component: Component.t, opt: ObjptrTycon.t, selects: Selects.t) =
 925          let
 926             val selects =
 927                Selects.map
 928                (selects, fn s =>
 929                 let
 930                    datatype z = datatype Select.t
 931                 in
 932                    case s of
 933                       None => None
 934                     | Direct {ty} => Indirect {offset = Bytes.zero, ty = ty}
 935                     | Unpack u => IndirectUnpack {offset = Bytes.zero,
 936                                                   rest = u,
 937                                                   ty = Component.ty component}
 938                     | _ => Error.bug "PackedRepresentation.ObjptrRep.box: cannot lift selects"
 939                 end)
 940          in
 941             make {components = Vector.new1 {component = component,
 942                                             offset = Bytes.zero},
 943                   isVector = false,
 944                   selects = selects,
 945                   tycon = opt}
 946          end
 947
 948       fun tuple (T {components, componentsTy, ty, tycon, ...},
 949                  {dst = dst: Var.t,
 950                   src: {index: int} -> Operand.t}) =
 951          let
 952             val object = Var {ty = ty, var = dst}
 953             val stores =
 954                Vector.foldr
 955                (components, [], fn ({component, offset}, ac) =>
 956                 let
 957                    val tmpVar = Var.newNoname ()
 958                    val tmpTy = Component.ty component
 959                    val statements =
 960                       Component.tuple (component,
 961                                        {dst = (tmpVar, tmpTy), src = src})
 962                 in
 963                    if List.isEmpty statements
 964                       then ac
 965                       else statements
 966                            @ (Move {dst = Offset {base = object,
 967                                                   offset = offset,
 968                                                   ty = tmpTy},
 969                                     src = Var {ty = tmpTy, var = tmpVar}}
 970                               :: ac)
 971                 end)
 972          in
 973             Object {dst = (dst, ty),
 974                     header = Runtime.typeIndexToHeader (ObjptrTycon.index tycon),
 975                     size = Bytes.+ (Type.bytes componentsTy, Runtime.normalMetaDataSize ())}
 976             :: stores
 977          end
 978
 979       val tuple =
 980          Trace.trace2
 981          ("PackedRepresentation.ObjptrRep.tuple",
 982           layout, Var.layout o #dst, List.layout Statement.layout)
 983          tuple
 984    end
 985
 986 structure TupleRep =
 987    struct
 988       datatype t =
 989          Direct of {component: Component.t,
 990                     selects: Selects.t}
 991        | Indirect of ObjptrRep.t
 992
 993       fun layout tr =
 994          let
 995             open Layout
 996          in
 997             case tr of
 998                Direct {component, selects} =>
 999                   seq [str "Direct ",
1000                        record [("component", Component.layout component),
1001                                ("selects", Selects.layout selects)]]
1002              | Indirect pr =>
1003                   seq [str "Indirect ", ObjptrRep.layout pr]
1004          end
1005
1006       val unit = Direct {component = Component.unit,
1007                          selects = Selects.empty}
1008
1009       val equals: t * t -> bool =
1010          fn z =>
1011          case z of
1012             (Direct {component = c, ...}, Direct {component = c', ...}) =>
1013                Component.equals (c, c')
1014           | (Indirect pr, Indirect pr') => ObjptrRep.equals (pr, pr')
1015           | _ => false
1016
1017       fun rep (tr: t): Rep.t =
1018          case tr of
1019             Direct {component, ...} => Component.rep component
1020           | Indirect p => ObjptrRep.rep p
1021
1022       val ty = Rep.ty o rep
1023
1024       fun selects (tr: t): Selects.t =
1025          case tr of
1026             Direct {selects, ...} => selects
1027           | Indirect (ObjptrRep.T {selects, ...}) => selects
1028
1029       fun tuple (tr: t,
1030                  {dst: Var.t * Type.t,
1031                   src: {index: int} -> Operand.t}): Statement.t list =
1032          case tr of
1033             Direct {component = c, ...} =>
1034                Component.tuple (c, {dst = dst, src = src})
1035           | Indirect pr =>
1036                ObjptrRep.tuple (pr, {dst = #1 dst, src = src})
1037
1038       val tuple =
1039          Trace.trace2
1040          ("PackedRepresentation.TupleRep.tuple",
1041           layout, Var.layout o #1 o #dst, List.layout Statement.layout)
1042          tuple
1043
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.
1054        *
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.
1062        *)
1063       fun make (objptrTycon: ObjptrTycon.t,
1064                 rs: {isMutable: bool,
1065                      rep: Rep.t,
1066                      ty: S.Type.t} vector,
1067                 {forceBox: bool,
1068                  isVector: bool}): t =
1069          let
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
1079             val () =
1080                Vector.foreachi
1081                (rs, fn (i, {rep, ...}) =>
1082                 let
1083                    fun addDirect (l, n) =
1084                       (List.push (l, {component = Component.Direct {index = i,
1085                                                                     rep = rep},
1086                                       index = i})
1087                        ; Int.inc n)
1088                    fun addSubword32 b =
1089                       (Array.update
1090                        (subword32s, b,
1091                         {index = i, rep = rep} :: Array.sub (subword32s, b))
1092                        ; widthSubword32s := !widthSubword32s + b)
1093                 in
1094                    case Rep.rep rep of
1095                       Rep.NonObjptr =>
1096                          let
1097                             val b = Bits.toInt (Rep.width rep)
1098                          in
1099                             case b of
1100                                0 => ()
1101                              | 8 => addSubword32 b
1102                              | 16 => addSubword32 b
1103                              | 32 => addDirect (word32s, numWord32s)
1104                              | 64 => addDirect (word64s, numWord64s)
1105                              | _ => (addSubword32 b
1106                                      ; hasNonPrim := true)
1107                          end
1108                     | Rep.Objptr _ => addDirect (objptrs, numObjptrs)
1109                 end)
1110             val selects = Array.array (Vector.length rs, Select.None)
1111             val hasNonPrim = !hasNonPrim
1112             val numComponents =
1113                !numObjptrs + !numWord64s + !numWord32s +
1114                (let
1115                    val widthSubword32s = !widthSubword32s
1116                 in
1117                    Int.quot (widthSubword32s, 32)
1118                    + Int.min (1, Int.rem (widthSubword32s, 32))
1119                 end)
1120             val needsBox =
1121                forceBox
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) =
1127                if not isBigEndian
1128                   then shift
1129                else Bytes.- (compSz, Bytes.+ (tySz, shift))
1130             fun simple (l, tyWidth: Bytes.t, offset: Bytes.t, components) =
1131                List.fold
1132                (l, (offset, components),
1133                 fn ({component, index}, (offset, ac)) =>
1134                 (Bytes.+ (offset, tyWidth),
1135                  let
1136                     val ty = Component.ty component
1137                     val () =
1138                        Array.update
1139                        (selects, index,
1140                         if needsBox
1141                            then Select.Indirect {offset = offset, ty = ty}
1142                         else Select.Direct {ty = ty})
1143                  in
1144                     {component = component,
1145                      offset = offset} :: ac
1146                  end))
1147             val offset = Bytes.zero
1148             val components = []
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.
1155              *)
1156             fun getSubword32Components (j: int,
1157                                         remainingWidth: Bits.t,
1158                                         components) =
1159                if 0 = j
1160                   then Vector.fromListRev components
1161                else
1162                   let
1163                      val elts = Array.sub (subword32s, j)
1164                   in
1165                      case elts of
1166                         [] => getSubword32Components (j - 1, remainingWidth, components)
1167                       | {index, rep} :: elts =>
1168                            let
1169                               val () = Array.update (subword32s, j, elts)
1170                               val remainingWidth = Bits.- (remainingWidth, Rep.width rep)
1171                            in
1172                               getSubword32Components
1173                               (Bits.toInt remainingWidth,
1174                                remainingWidth,
1175                                {index = index, rep = rep} :: components)
1176                            end
1177                   end
1178             (* max is the maximum index at which an element of
1179              * subword32s may be nonempty.
1180              *)
1181             fun makeSubword32s (max: int, offset: Bytes.t, ac) =
1182                if 0 = max
1183                   then (offset, ac)
1184                else
1185                   if List.isEmpty (Array.sub (subword32s, max))
1186                      then makeSubword32s (max - 1, offset, ac)
1187                   else
1188                      let
1189                         val components =
1190                            getSubword32Components (max, Bits.inWord32, [])
1191                         val componentTy =
1192                            Type.seq (Vector.map (components, Rep.ty o #rep))
1193                         val component =
1194                            (Component.Word o WordRep.T)
1195                            {components = components,
1196                             rep = Rep.T {rep = Rep.NonObjptr,
1197                                          ty = componentTy}}
1198                         val (component, componentTy) =
1199                            if needsBox
1200                               then if padToPrim
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)
1206                         val _ =
1207                            Vector.fold
1208                            (components, Bits.zero,
1209                             fn ({index, rep}, shift) =>
1210                             let
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,
1215                                                       ty = repTy}
1216                                fun getByteOffset () =
1217                                   Bytes.+
1218                                   (offset,
1219                                    byteShiftToByteOffset
1220                                    (Type.bytes componentTy,
1221                                     Bits.toBytes repTyWidth,
1222                                     Bits.toBytes shift))
1223                                val select =
1224                                   if needsBox
1225                                      then if ((Bits.isWord8Aligned shift
1226                                                andalso (Bits.equals
1227                                                         (repTyWidth,
1228                                                          Bits.inWord8)))
1229                                               orelse
1230                                               (Bits.isWord16Aligned shift
1231                                                andalso (Bits.equals
1232                                                         (repTyWidth,
1233                                                          Bits.inWord16))))
1234                                              then (Select.Indirect
1235                                                    {offset = getByteOffset (),
1236                                                     ty = repTy})
1237                                           else (Select.IndirectUnpack
1238                                                 {offset = offset,
1239                                                  rest = unpack,
1240                                                  ty = componentTy})
1241                                   else Select.Unpack unpack
1242                                val () =
1243                                   Array.update
1244                                   (selects, index, select)
1245                             in
1246                                Bits.+ (shift, repWidth)
1247                             end)
1248                         val ac = {component = component,
1249                                   offset = offset} :: ac
1250                      in
1251                         makeSubword32s
1252                         (max,
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.
1256                           *)
1257                          Bytes.+ (offset, Bytes.inWord32),
1258                          ac)
1259                      end
1260             fun makeSubword32sAllPrims (max: int, offset: Bytes.t, ac) =
1261                (* hasNonPrim = false, needsBox = true *)
1262                if 0 = max
1263                   then (offset, ac)
1264                else
1265                   if List.isEmpty (Array.sub (subword32s, max))
1266                      then makeSubword32sAllPrims (max - 1, offset, ac)
1267                   else
1268                      let
1269                         val origComponents =
1270                            getSubword32Components (max, Bits.inWord32, [])
1271                         val components =
1272                            if isBigEndian
1273                               then Vector.rev origComponents
1274                            else origComponents
1275                         val componentTy =
1276                            Type.seq (Vector.map (components, Rep.ty o #rep))
1277                         val component =
1278                            (Component.Word o WordRep.T)
1279                            {components = components,
1280                             rep = Rep.T {rep = Rep.NonObjptr,
1281                                          ty = componentTy}}
1282                         val component =
1283                            if padToPrim
1284                               then if isBigEndian
1285                                       then Component.padToPrimLow component
1286                                       else Component.padToPrim component
1287                            else if isBigEndian
1288                                    then Component.padToWidthLow (component, Bits.inWord32)
1289                                    else Component.padToWidth (component, Bits.inWord32)
1290                         val _ =
1291                            Vector.fold
1292                            (origComponents, offset,
1293                             fn ({index, rep}, offset) =>
1294                             let
1295                                val () =
1296                                   Array.update
1297                                   (selects, index,
1298                                    Select.Indirect
1299                                    {offset = offset,
1300                                     ty = Rep.ty rep})
1301                             in
1302                                Bytes.+ (offset, Bits.toBytes (Rep.width rep))
1303                             end)
1304                         val ac = {component = component,
1305                                   offset = offset} :: ac
1306                      in
1307                         makeSubword32sAllPrims
1308                         (max,
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.
1312                           *)
1313                          Bytes.+ (offset, Bytes.inWord32),
1314                          ac)
1315                      end
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
1323 (*
1324             val () =
1325                Assert.assert
1326                ("PackedRepresentation.TupleRep.make", fn () =>
1327                 numComponents = Vector.length components)
1328 *)
1329             val getSelects =
1330                Selects.T (Vector.tabulate
1331                           (Array.length selects, fn i =>
1332                            {orig = #ty (Vector.sub (rs, i)),
1333                             select = Array.sub (selects, i)}))
1334          in
1335             if needsBox
1336                then Indirect (ObjptrRep.make {components = components,
1337                                               isVector = isVector,
1338                                               selects = getSelects,
1339                                               tycon = objptrTycon})
1340             else if numComponents = 0
1341                     then unit
1342                  else Direct {component = #component (Vector.first components),
1343                               selects = getSelects}
1344          end
1345       val make =
1346          Trace.trace3
1347          ("PackedRepresentation.TupleRep.make",
1348           ObjptrTycon.layout,
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)],
1356
1357           layout)
1358          make
1359    end
1360
1361 structure ConRep =
1362    struct
1363       datatype t =
1364          ShiftAndTag of {component: Component.t,
1365                          selects: Selects.t,
1366                          tag: WordX.t,
1367                          ty: Type.t (* alread padded to prim *)}
1368        | Tag of {tag: WordX.t,
1369                  ty: Type.t}
1370        | Tuple of TupleRep.t
1371
1372       val layout =
1373          let
1374             open Layout
1375          in
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
1384          end
1385
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)
1393           | _ => false
1394
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
1399
1400       val box = Tuple o TupleRep.Indirect
1401
1402       local
1403          fun make i =
1404             let
1405                val tag = WordX.fromIntInf (i, WordSize.bool)
1406             in
1407                Tag {tag = tag, ty = Type.ofWordX tag}
1408             end
1409       in
1410          val falsee = make 0
1411          val truee = make 1
1412       end
1413
1414       val unit = Tuple TupleRep.unit
1415
1416       fun conApp (r: t, {dst: Var.t * Type.t,
1417                          src: {index: int} -> Operand.t}): Statement.t list =
1418          case r of
1419             ShiftAndTag {component, tag, ...} =>
1420                let
1421                   val (dstVar, dstTy) = dst
1422                   val shift = Operand.word (WordX.fromIntInf
1423                                             (Bits.toIntInf
1424                                              (WordSize.bits
1425                                               (WordX.size tag)),
1426                                              WordSize.shiftArg))
1427                   val tmpVar = Var.newNoname ()
1428                   val tmpTy =
1429                      Type.padToWidth (Component.ty component, Type.width dstTy)
1430                   val tmp = Var {ty = tmpTy, var = tmpVar}
1431                   val component =
1432                      Component.tuple (component, {dst = (tmpVar, tmpTy),
1433                                                   src = src})
1434                   val (s1, tmp) = Statement.lshift (tmp, shift)
1435                   val mask = Operand.word (WordX.resize
1436                                            (tag,
1437                                             WordSize.fromBits
1438                                             (Type.width
1439                                              (Operand.ty tmp))))
1440                   val (s2, tmp) = Statement.orb (tmp, mask)
1441                   val s3 = Bind {dst = (dstVar, dstTy),
1442                                  isMutable = false,
1443                                  src = tmp}
1444                in
1445                   component @ [s1, s2, s3]
1446                end
1447           | Tag {tag, ...} =>
1448                let
1449                   val (dstVar, dstTy) = dst
1450                   val src = Operand.word (WordX.resize
1451                                           (tag,
1452                                            WordSize.fromBits
1453                                            (Type.width dstTy)))
1454                in
1455                   [Bind {dst = (dstVar, dstTy),
1456                          isMutable = false,
1457                          src = src}]
1458                end
1459           | Tuple tr => TupleRep.tuple (tr, {dst = dst, src = src})
1460
1461       val conApp =
1462          Trace.trace
1463          ("PackedRepresentation.ConRep.conApp",
1464           layout o #1, List.layout Statement.layout)
1465          conApp
1466    end
1467
1468 structure Block =
1469    struct
1470       open Block
1471
1472       val extra: t list ref = ref []
1473
1474       fun getExtra () = !extra before extra := []
1475
1476       fun new {statements: Statement.t vector,
1477                transfer: Transfer.t}: Label.t =
1478          let
1479             val l = Label.newNoname ()
1480             val _ = List.push (extra,
1481                                Block.T {args = Vector.new0 (),
1482                                         kind = Kind.Jump,
1483                                         label = l,
1484                                         statements = statements,
1485                                         transfer = transfer})
1486          in
1487             l
1488          end
1489    end
1490
1491 structure Cases =
1492    struct
1493       type t = {con: Con.t, dst: Label.t, dstHasArg: bool} vector
1494
1495       fun layout (v: t): Layout.t =
1496          Vector.layout
1497          (fn {con, dst, dstHasArg} =>
1498           Layout.record [("con", Con.layout con),
1499                          ("dst", Label.layout dst),
1500                          ("dstHasArg", Bool.layout dstHasArg)])
1501          v
1502    end
1503
1504 structure Objptrs =
1505    struct
1506       (* 1 < Vector.length variants *)
1507       datatype t = T of {rep: Rep.t,
1508                          variants: {con: Con.t,
1509                                     objptr: ObjptrRep.t} vector}
1510
1511       fun layout (T {rep, variants}) =
1512          let
1513             open Layout
1514          in
1515             record [("rep", Rep.layout rep),
1516                     ("variants",
1517                      Vector.layout
1518                      (fn {con, objptr} =>
1519                       record [("con", Con.layout con),
1520                               ("objptr", ObjptrRep.layout objptr)])
1521                      variants)]
1522          end
1523
1524       local
1525          fun make f (T r) = f r
1526       in
1527          val rep = make #rep
1528       end
1529
1530       val ty = Rep.ty o rep
1531
1532       fun make {rep, variants}: t =
1533          T {rep = rep,
1534             variants = variants}
1535
1536       fun genCase (T {variants, ...},
1537                    {cases: Cases.t,
1538                     conRep: Con.t -> ConRep.t,
1539                     default: Label.t option,
1540                     test: Operand.t})
1541          : Statement.t list * Transfer.t =
1542          let
1543             val cases =
1544                Vector.keepAllMap
1545                (cases, fn {con, dst, dstHasArg} =>
1546                 case conRep con of
1547                    ConRep.Tuple (TupleRep.Indirect (ObjptrRep.T {ty, tycon, ...})) =>
1548                       SOME (WordX.fromIntInf (Int.toIntInf (ObjptrTycon.index tycon),
1549                                               WordSize.objptrHeader ()),
1550                             Block.new
1551                             {statements = Vector.new0 (),
1552                              transfer = Goto {args = if dstHasArg
1553                                                         then (Vector.new1
1554                                                               (Operand.cast (test, ty)))
1555                                                      else Vector.new0 (),
1556                                               dst = dst}})
1557                  | _ => NONE)
1558             val default =
1559                if Vector.length variants = Vector.length cases
1560                   then NONE
1561                else default
1562             val cases =
1563                QuickSort.sortVector (cases, fn ((w, _), (w', _)) =>
1564                                      WordX.le (w, w', {signed = false}))
1565             val shift = Operand.word (WordX.one WordSize.shiftArg)
1566             val (s, tag) =
1567                Statement.rshift (Offset {base = test,
1568                                          offset = Runtime.headerOffset (),
1569                                          ty = Type.objptrHeader ()},
1570                                  shift)
1571          in
1572             ([s], Switch (Switch.T {cases = cases,
1573                                     default = default,
1574                                     size = WordSize.objptrHeader (),
1575                                     test = tag}))
1576          end
1577    end
1578
1579 structure Small =
1580    struct
1581       datatype t = T of {isEnum: bool,
1582                          rep: Rep.t,
1583                          tagBits: Bits.t,
1584                          variants: Con.t vector}
1585
1586       fun layout (T {isEnum, rep, tagBits, variants}) =
1587          let
1588             open Layout
1589          in
1590             record [("isEnum", Bool.layout isEnum),
1591                     ("rep", Rep.layout rep),
1592                     ("tagBits", Bits.layout tagBits),
1593                     ("variants", Vector.layout Con.layout variants)]
1594          end
1595
1596       local
1597          fun make f (T r) = f r
1598       in
1599          val rep = make #rep
1600       end
1601
1602       val bool =
1603          T {isEnum = true,
1604             rep = Rep.bool,
1605             tagBits = Bits.one,
1606             variants = Vector.new2 (Con.falsee, Con.truee)}
1607
1608       fun genCase (T {isEnum, tagBits, variants, ...},
1609                    {cases: Cases.t,
1610                     conRep: Con.t -> ConRep.t,
1611                     isObjptr: bool,
1612                     notSmall: Label.t option,
1613                     smallDefault: Label.t option,
1614                     test: Operand.t})
1615          : Statement.t list * Transfer.t =
1616          let
1617             val tagSize = WordSize.fromBits tagBits
1618             val testBits = Type.width (Operand.ty test)
1619             val testSize = WordSize.fromBits testBits
1620             val cases =
1621                Vector.keepAllMap
1622                (cases, fn {con, dst, dstHasArg} =>
1623                 case conRep con of
1624                    ConRep.ShiftAndTag {tag, ty, ...} =>
1625                       let
1626                          val test = Operand.cast (test, Type.padToWidth (ty, testBits))
1627                          val (test, ss) = Statement.resize (test, ty)
1628                          val transfer =
1629                             Goto {args = if dstHasArg
1630                                             then Vector.new1 test
1631                                          else Vector.new0 (),
1632                                   dst = dst}
1633                       in
1634                          SOME (WordX.resize (tag, testSize),
1635                                Block.new {statements = Vector.fromList ss,
1636                                           transfer = transfer})
1637                       end
1638                  | ConRep.Tag {tag, ...} =>
1639                       let
1640                          val transfer =
1641                             Goto {args = if dstHasArg
1642                                             then Vector.new1 test
1643                                             else Vector.new0 (),
1644                                   dst = dst}
1645                       in
1646                          SOME (WordX.resize (tag, testSize),
1647                                Block.new {statements = Vector.new0 (),
1648                                           transfer = transfer})
1649                       end
1650                  | _ => NONE)
1651             val cases = QuickSort.sortVector (cases, fn ((w, _), (w', _)) =>
1652                                               WordX.le (w, w', {signed = false}))
1653             val tagOp =
1654                if isObjptr
1655                   then Operand.cast (test, Type.bits testBits)
1656                else test
1657             val (tagOp, ss) =
1658                if isEnum
1659                   then (tagOp, [])
1660                else
1661                   let
1662                      val mask =
1663                         Operand.word (WordX.resize
1664                                       (WordX.max (tagSize, {signed = false}),
1665                                        testSize))
1666                      val (s, tagOp) = Statement.andb (tagOp, mask)
1667                   in
1668                      (tagOp, [s])
1669                   end
1670             val default =
1671                if Vector.length variants = Vector.length cases
1672                   then notSmall
1673                else
1674                   case (notSmall, smallDefault) of
1675                      (NONE, _) => smallDefault
1676                    | (_, NONE) => notSmall
1677                    | (SOME notSmall, SOME smallDefault) =>
1678                         let
1679                            val (s, test) =
1680                               Statement.andb
1681                               (Operand.cast (test, Type.bits testBits),
1682                                Operand.word (WordX.fromIntInf (3, testSize)))
1683                            val t =
1684                               Switch
1685                               (Switch.T
1686                                {cases = Vector.new1 (WordX.zero testSize,
1687                                                      notSmall),
1688                                 default = SOME smallDefault,
1689                                 size = testSize,
1690                                 test = test})
1691                         in
1692                            SOME (Block.new {statements = Vector.new1 s,
1693                                             transfer = t})
1694                         end
1695             val transfer =
1696                Switch (Switch.T {cases = cases,
1697                                  default = default,
1698                                  size = testSize,
1699                                  test = tagOp})
1700          in
1701             (ss, transfer)
1702          end
1703
1704       val genCase =
1705          Trace.trace
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))
1711          genCase
1712    end
1713
1714 structure TyconRep =
1715    struct
1716       datatype t =
1717          One of {con: Con.t,
1718                  tupleRep: TupleRep.t}
1719        | Objptrs of Objptrs.t
1720        | Small of Small.t
1721        | SmallAndBox of {box: {con: Con.t,
1722                                objptr: ObjptrRep.t},
1723                          rep: Rep.t,
1724                          small: Small.t}
1725        | SmallAndObjptr of {objptr: {component: Component.t,
1726                                      con: Con.t},
1727                             rep: Rep.t,
1728                             small: Small.t}
1729        | SmallAndObjptrs of {objptrs: Objptrs.t,
1730                              rep: Rep.t,
1731                              small: Small.t}
1732        | Unit
1733
1734       fun layout (r: t): Layout.t =
1735          let
1736             open Layout
1737          in
1738             case r of
1739                One {con, tupleRep} =>
1740                   seq [str "One ",
1741                        record [("con", Con.layout con),
1742                                ("tupleRep", TupleRep.layout tupleRep)]]
1743              | Objptrs ps =>
1744                   seq [str "Objptrs ", Objptrs.layout ps]
1745              | Small s =>
1746                   seq [str "Small ", Small.layout s]
1747              | SmallAndBox {box = {con, objptr}, rep, small} =>
1748                   seq [str "SmallAndBox ",
1749                        record [("box",
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 ",
1756                        record
1757                        [("objptr",
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"
1768          end
1769
1770       val bool = Small Small.bool
1771
1772       val unit = Unit
1773
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
1781           | Unit => Rep.unit
1782
1783       fun equals (r, r') = Rep.equals (rep r, rep r')
1784
1785       val objptrBytes = Runtime.objptrSize
1786       val objptrBits = Promise.lazy (fn () => Bytes.toBits (objptrBytes ()))
1787       val objptrBitsAsInt = Promise.lazy (fn () => Bits.toInt (objptrBits ()))
1788
1789       local
1790          val aWithout =
1791             Promise.lazy
1792             (fn () => Array.tabulate (objptrBitsAsInt () + 1, fn i =>
1793                                       IntInf.pow (2, 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.
1796           *)
1797          val aWith =
1798             Promise.lazy
1799             (fn () => Array.tabulate (objptrBitsAsInt () + 1, fn i =>
1800                                       (Array.sub (aWithout (), i) * 3) div 4))
1801       in
1802          fun numTagsAvailable {tagBits: int, withObjptr: bool} =
1803             let
1804                val a = if withObjptr then aWith () else aWithout ()
1805             in
1806                Array.sub (a, tagBits)
1807             end
1808
1809          val numTagsAvailable =
1810             Trace.trace
1811             ("PackedRepresentation.TyconRep.numTagsAvailable",
1812              fn {tagBits, withObjptr} =>
1813              Layout.record [("tagBits", Int.layout tagBits),
1814                             ("withObjptr", Bool.layout withObjptr)],
1815              IntInf.layout)
1816             numTagsAvailable
1817
1818          fun tagBitsNeeded {numVariants: int, withObjptr: bool}: Bits.t =
1819             let
1820                val numVariants = Int.toIntInf numVariants
1821                val a = if withObjptr then aWith () else aWithout ()
1822             in
1823                case (BinarySearch.smallest
1824                      (a, fn numTags => numVariants <= numTags)) of
1825                   NONE => Error.bug "PackedRepresentation.TyconRep.tagBitsNeeded"
1826                 | SOME i => Bits.fromInt i
1827             end
1828
1829          val tagBitsNeeded =
1830             Trace.trace
1831             ("PackedRepresentation.TyconRep.tagBitsNeeded",
1832              fn {numVariants, withObjptr} =>
1833              Layout.record [("numVariants", Int.layout numVariants),
1834                             ("withObjptr", Bool.layout withObjptr)],
1835              Bits.layout)
1836             tagBitsNeeded
1837       end
1838
1839       fun make (variants: {args: {isMutable: bool,
1840                                   rep: Rep.t,
1841                                   ty: S.Type.t} vector,
1842                            con: Con.t,
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
1848             then
1849                let
1850                   val {args, con, objptrTycon} = Vector.sub (variants, 0)
1851                   val tupleRep =
1852                      TupleRep.make (objptrTycon, args,
1853                                     {forceBox = false,
1854                                      isVector = false})
1855                   val conRep = ConRep.Tuple tupleRep
1856                in
1857                   (One {con = con, tupleRep = tupleRep},
1858                    Vector.new1 {con = con, rep = conRep})
1859                end
1860          else if (2 = Vector.length variants
1861                   andalso let
1862                              val c = #con (Vector.first variants)
1863                           in
1864                              Con.equals (c, Con.falsee)
1865                              orelse Con.equals (c, Con.truee)
1866                           end)
1867             then (bool, Vector.new2 ({con = Con.falsee, rep = ConRep.falsee},
1868                                      {con = Con.truee, rep = ConRep.truee}))
1869          else
1870          let
1871             val numSmall : IntInf.t ref = ref 0
1872             val small = Array.array (objptrBitsAsInt (), [])
1873             val big = ref []
1874             val () =
1875                Vector.foreach
1876                (variants, fn {args, con, objptrTycon} =>
1877                 let
1878                    val tr =
1879                       TupleRep.make (objptrTycon, args,
1880                                      {forceBox = false,
1881                                       isVector = false})
1882                    fun makeBig () =
1883                       List.push (big,
1884                                  {con = con,
1885                                   objptrTycon = objptrTycon,
1886                                   tupleRep = tr})
1887                    val Rep.T {rep, ty} = TupleRep.rep tr
1888                 in
1889                    case rep of
1890                       Rep.NonObjptr =>
1891                          let
1892                             val i = Bits.toInt (Type.width ty)
1893                          in
1894                             if i >= objptrBitsAsInt ()
1895                                then makeBig ()
1896                             else
1897                                let
1898                                   val {component, selects} =
1899                                      case tr of
1900                                         TupleRep.Direct z => z
1901                                       | TupleRep.Indirect _ =>
1902                                            Error.bug "PackedRepresentation.TyconRep.make: small Indirect"
1903                                   val () = IntInf.inc numSmall
1904                                   val () =
1905                                      Array.update
1906                                      (small, i,
1907                                       {component = component,
1908                                        con = con,
1909                                        objptrTycon = objptrTycon,
1910                                        selects = selects}
1911                                       :: Array.sub (small, i))
1912                                in
1913                                   ()
1914                                end
1915                          end
1916                     | Rep.Objptr _ => makeBig ()
1917                 end)
1918             val big = !big
1919             val numSmall = !numSmall
1920             fun noLargerThan (i, ac) =
1921                if i < 0
1922                   then ac
1923                else (noLargerThan
1924                      (i - 1,
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.
1928              *)
1929             fun loop (maxSmallWidth: int,
1930                       forced,
1931                       withObjptr: bool,
1932                       numSmall: IntInf.t) =
1933                if 0 = numSmall
1934                   then (maxSmallWidth, forced, [])
1935                else
1936                   let
1937                      val vs = Array.sub (small, maxSmallWidth)
1938                   in
1939                      if List.isEmpty vs
1940                         then loop (maxSmallWidth - 1, forced,
1941                                    withObjptr, numSmall)
1942                      else
1943                         let
1944                            val numTags =
1945                               numTagsAvailable
1946                               {tagBits = objptrBitsAsInt () - maxSmallWidth,
1947                                withObjptr = withObjptr}
1948                         in
1949                            if numSmall <= numTags
1950                               then
1951                                  (* There are enough tag bits available. *)
1952                                  (maxSmallWidth,
1953                                   forced,
1954                                   noLargerThan (maxSmallWidth - 1, vs))
1955                            else
1956                               let
1957                                  val z = Int.toIntInf (List.length vs)
1958                                  val remaining = numSmall - z
1959                               in
1960                                  if remaining <= numTags
1961                                     then
1962                                        let
1963                                           val (front, back) =
1964                                              List.splitAt
1965                                              (vs,
1966                                               IntInf.toInt
1967                                               (numSmall - numTags))
1968                                        in
1969                                           (maxSmallWidth,
1970                                            List.append (front, forced),
1971                                            noLargerThan (maxSmallWidth - 1,
1972                                                          back))
1973                                        end
1974                                  else loop (maxSmallWidth - 1,
1975                                             vs @ forced,
1976                                             true,
1977                                             remaining)
1978                               end
1979                         end
1980                   end
1981             val (maxSmallWidth, forced, small) =
1982                loop (objptrBitsAsInt () - 1, [],
1983                      not (List.isEmpty big),
1984                      numSmall)
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) =
1989                let
1990                   val numSmall = List.length small
1991                in
1992                   if 0 = numSmall
1993                      then (NONE, Vector.new0 ())
1994                   else
1995                      let
1996                         val tagBits =
1997                            tagBitsNeeded {numVariants = numSmall,
1998                                           withObjptr = withObjptr}
1999                         val r = ref 0w0
2000                         fun getTag (): IntInf.t =
2001                            let
2002                               val w = !r
2003                               val w =
2004                                  if withObjptr andalso
2005                                     0w0 = Word.andb (w, 0w3)
2006                                     then w + 0w1
2007                                  else w
2008                               val () = r := w + 0w1
2009                            in
2010                               Word.toIntInf w
2011                            end
2012                         val small =
2013                            Vector.fromListMap
2014                            (small, fn {component, con, selects, ...} =>
2015                             let
2016                                val tag =
2017                                   WordX.fromIntInf
2018                                   (getTag (), WordSize.fromBits tagBits)
2019                                val isUnit = Type.isUnit (Component.ty component)
2020                                val component =
2021                                   Component.padToWidth
2022                                   (component, maxSmallWidth)
2023                                val selects = Selects.lshift (selects, tagBits)
2024                                val ty =
2025                                   Type.seq
2026                                   (Vector.new2
2027                                    (Type.ofWordX tag,
2028                                     Component.ty component))
2029                                val ty =
2030                                   if withObjptr
2031                                      then Type.resize (ty, objptrBits ())
2032                                   else Type.padToPrim ty
2033                             in
2034                                {component = component,
2035                                 con = con,
2036                                 isUnit = isUnit,
2037                                 selects = selects,
2038                                 tag = tag,
2039                                 ty = ty}
2040                             end)
2041                         val ty = Type.sum (Vector.map (small, #ty))
2042                         val rep = Rep.T {rep = Rep.NonObjptr, ty = ty}
2043                         val reps =
2044                            Vector.map
2045                            (small, fn {component, con, isUnit, selects, tag, ty,
2046                                        ...} =>
2047                             {con = con,
2048                              rep = if isUnit
2049                                       then ConRep.Tag {tag = tag, ty = ty}
2050                                    else (ConRep.ShiftAndTag
2051                                          {component = component,
2052                                           selects = selects,
2053                                           tag = tag,
2054                                           ty = ty})})
2055                         val isEnum =
2056                            Vector.forall
2057                            (reps, fn {rep, ...} =>
2058                             case rep of
2059                                ConRep.Tag _ => true
2060                              | _ => false)
2061                      in
2062                         (SOME (Small.T {isEnum = isEnum,
2063                                         rep = rep,
2064                                         tagBits = tagBits,
2065                                         variants = Vector.map (reps, #con)}),
2066                          reps)
2067                      end
2068                end
2069             fun makeSmallObjptr {component, con, objptrTycon, selects} =
2070                {con = con,
2071                 objptr = (ObjptrRep.box
2072                           (Component.padToWidth (component, objptrBits ()),
2073                            objptrTycon, selects))}
2074             fun makeBigObjptr {con, objptrTycon, tupleRep} =
2075                let
2076                   val objptr =
2077                      case tupleRep of
2078                         TupleRep.Direct {component, selects} =>
2079                            ObjptrRep.box (component, objptrTycon, selects)
2080                       | TupleRep.Indirect p => p
2081                in
2082                   {con = con, objptr = objptr}
2083                end
2084             fun sumWithSmall (r: Rep.t): Rep.t =
2085                Rep.T {rep = Rep.Objptr {endsIn00 = false},
2086                       ty = Type.sum (Vector.new2
2087                                      (Rep.ty r,
2088                                       Rep.ty (Small.rep (valOf small))))}
2089             fun box () =
2090                let
2091                   val objptrs =
2092                      Vector.concat
2093                      [Vector.fromListMap (forced, makeSmallObjptr),
2094                       Vector.fromListMap (big, makeBigObjptr)]
2095                   val sumRep =
2096                      if 1 = Vector.length objptrs
2097                         then
2098                            let
2099                               val objptr = Vector.first objptrs
2100                               val small = valOf small
2101                               val rep =
2102                                  sumWithSmall (ObjptrRep.rep (#objptr objptr))
2103                            in
2104                               SmallAndBox {box = objptr,
2105                                            rep = rep,
2106                                            small = small}
2107                            end
2108                      else
2109                         let
2110                            val ty =
2111                               Type.sum
2112                               (Vector.map (objptrs, ObjptrRep.ty o #objptr))
2113                            val objptrs =
2114                               Objptrs.make
2115                               {rep = Rep.T {rep = Rep.Objptr {endsIn00 = true},
2116                                             ty = ty},
2117                                variants = objptrs}
2118                         in
2119                            case small of
2120                               NONE => Objptrs objptrs
2121                             | SOME small =>
2122                                  SmallAndObjptrs
2123                                  {objptrs = objptrs,
2124                                   rep = sumWithSmall (Objptrs.rep objptrs),
2125                                   small = small}
2126                         end
2127                in
2128                   (sumRep,
2129                    Vector.map (objptrs, fn {con, objptr} =>
2130                                {con = con,
2131                                 rep = ConRep.box objptr}))
2132                end
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.
2139                       *)
2140                      (case tupleRep of
2141                          TupleRep.Direct {component, ...} =>
2142                             let
2143                                val rep = TupleRep.rep tupleRep
2144                             in
2145                                if Rep.isObjptrEndingIn00 rep
2146                                   then
2147                                      let
2148                                         val small = valOf small
2149                                      in
2150                                         (SmallAndObjptr
2151                                          {objptr = {component = component,
2152                                                     con = con},
2153                                           rep = sumWithSmall rep,
2154                                           small = small},
2155                                          Vector.new1
2156                                          {con = con,
2157                                           rep = ConRep.Tuple tupleRep})
2158                                      end
2159                                else box ()
2160                             end
2161                        | _ => box ())
2162                 | _ => box ()
2163          in
2164             (sumRep, Vector.concat [smallReps, objptrReps])
2165          end
2166
2167       val make =
2168          Trace.trace
2169          ("PackedRepresentation.TyconRep.make",
2170           Vector.layout
2171           (fn {args, con, ...} =>
2172            Layout.record [("args", Vector.layout (Rep.layout o #rep) args),
2173                           ("con", Con.layout con)]),
2174           Layout.tuple2 (layout,
2175                          Vector.layout
2176                          (fn {con, rep} =>
2177                           Layout.record [("con", Con.layout con),
2178                                          ("rep", ConRep.layout rep)])))
2179          make
2180
2181       fun genCase (r: t,
2182                    {cases: Cases.t,
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 =
2187          let
2188             val (statements, transfer) =
2189                case r of
2190                   One {con, ...} =>
2191                      (case (Vector.length cases, default) of
2192                          (1, _) =>
2193                             (* Use _ instead of NONE for the default becuase
2194                              * there may be an unreachable default case.
2195                              *)
2196                             let
2197                                val {con = c, dst, dstHasArg} =
2198                                   Vector.first cases
2199                             in
2200                                if not (Con.equals (c, con))
2201                                   then Error.bug "PackedRepresentation.genCase: One"
2202                                else
2203                                   ([],
2204                                    Goto {args = (if dstHasArg
2205                                                     then Vector.new1 (test ())
2206                                                  else Vector.new0 ()),
2207                                          dst = dst})
2208                             end
2209                        | (0, SOME l) =>
2210                             ([], Goto {dst = l, args = Vector.new0 ()})
2211                        | _ => Error.bug "PackedRepresentation.genCase: One,prim datatype with more than one case")
2212                 | Objptrs ps =>
2213                      Objptrs.genCase (ps, {cases = cases,
2214                                             conRep = conRep,
2215                                             default = default,
2216                                             test = test ()})
2217                 | Small s =>
2218                      Small.genCase (s, {cases = cases,
2219                                         conRep = conRep,
2220                                         isObjptr = false,
2221                                         notSmall = NONE,
2222                                         smallDefault = default,
2223                                         test = test ()})
2224                 | SmallAndBox {box = {con, objptr}, small, ...} =>
2225                      let
2226                         val notSmall =
2227                            case Vector.peek (cases, fn {con = c, ...} =>
2228                                              Con.equals (c, con)) of
2229                               NONE => default
2230                             | SOME {dst, dstHasArg, ...} =>
2231                                  let
2232                                     val test =
2233                                        Operand.cast (test (),
2234                                                      ObjptrRep.ty objptr)
2235                                  in
2236                                     SOME
2237                                     (Block.new
2238                                      {statements = Vector.new0 (),
2239                                       transfer =
2240                                       Goto {args = (if dstHasArg
2241                                                        then Vector.new1 test
2242                                                     else Vector.new0 ()),
2243                                             dst = dst}})
2244                                  end
2245                      in
2246                         Small.genCase (small, {cases = cases,
2247                                                conRep = conRep,
2248                                                isObjptr = true,
2249                                                notSmall = notSmall,
2250                                                smallDefault = default,
2251                                                test = test ()})
2252                      end
2253                 | SmallAndObjptr {objptr = {component, con}, small, ...} =>
2254                      let
2255                         val notSmall =
2256                            case Vector.peek (cases, fn {con = c, ...} =>
2257                                              Con.equals (c, con)) of
2258                               NONE => default
2259                             | SOME {dst, dstHasArg, ...} =>
2260                                  let
2261                                     val args =
2262                                        if dstHasArg
2263                                           then (Vector.new1
2264                                                 (Operand.cast
2265                                                  (test (),
2266                                                   Component.ty component)))
2267                                        else Vector.new0 ()
2268                                  in
2269                                     SOME (Block.new
2270                                           {statements = Vector.new0 (),
2271                                            transfer = Goto {args = args,
2272                                                             dst = dst}})
2273                                  end
2274                      in
2275                         Small.genCase (small, {cases = cases,
2276                                                conRep = conRep,
2277                                                isObjptr = true,
2278                                                notSmall = notSmall,
2279                                                smallDefault = default,
2280                                                test = test ()})
2281                      end
2282                 | SmallAndObjptrs {objptrs, small, ...} =>
2283                      let
2284                         val test = test ()
2285                         val (ss, t) =
2286                            Objptrs.genCase
2287                            (objptrs, {cases = cases,
2288                                       conRep = conRep,
2289                                       default = default,
2290                                       test = (Operand.cast
2291                                               (test, Objptrs.ty objptrs))})
2292                         val objptr =
2293                            Block.new {statements = Vector.fromList ss,
2294                                       transfer = t}
2295                      in
2296                         Small.genCase (small, {cases = cases,
2297                                                conRep = conRep,
2298                                                isObjptr = true,
2299                                                notSmall = SOME objptr,
2300                                                smallDefault = default,
2301                                                test = test})
2302                      end
2303                 | Unit => Error.bug "PackedRepresentation.TyconRep.genCase: Unit"
2304          in
2305             (statements, transfer, Block.getExtra ())
2306          end
2307
2308       val genCase =
2309          Trace.trace
2310          ("PackedRepresentation.TyconRep.genCase",
2311           fn (r, {cases, default, ...}) =>
2312           Layout.tuple [layout r,
2313                         Layout.record
2314                         [("cases", Cases.layout cases),
2315                          ("default", Option.layout Label.layout default)]],
2316           Layout.tuple3 (List.layout Statement.layout,
2317                          Transfer.layout,
2318                          List.layout Block.layout))
2319          genCase
2320    end
2321
2322 structure Value:
2323    sig
2324       type 'a t
2325
2326       val affect: 'a t * 'b t -> unit
2327       val constant: 'a -> 'a t
2328       val fixedPoint: unit -> unit
2329       val get: 'a t -> 'a
2330       val layout: ('a -> Layout.t) -> 'a t -> Layout.t
2331       val new: {compute: unit -> 'a,
2332                 equals: 'a * 'a -> bool,
2333                 init: 'a} -> 'a t
2334    end =
2335    struct
2336       structure Dep =
2337          struct
2338             datatype t = T of {affects: t list ref,
2339                                compute: unit -> {change: bool},
2340                                needToCompute: bool ref}
2341
2342             (* A list of all ts such that !needToCompute = true. *)
2343             val todo: t list ref = ref []
2344
2345             fun recompute (me as T {needToCompute, ...}) =
2346                if !needToCompute
2347                   then ()
2348                else (List.push (todo, me)
2349                      ; needToCompute := true)
2350
2351             fun fixedPoint () =
2352                case !todo of
2353                   [] => ()
2354                 | T {affects, compute, needToCompute, ...} :: l =>
2355                      let
2356                         val () = todo := l
2357                         val () = needToCompute := false
2358                         val {change} = compute ()
2359                         val () =
2360                            if change
2361                               then List.foreach (!affects, recompute)
2362                            else ()
2363                      in
2364                         fixedPoint ()
2365                      end
2366
2367             fun affect (T {affects, ...}, z) = List.push (affects, z)
2368
2369             fun new {compute: unit -> 'a,
2370                      equals: 'a * 'a -> bool,
2371                      init: 'a}: t * 'a ref =
2372                let
2373                   val r: 'a ref = ref init
2374                   val affects = ref []
2375                   val compute =
2376                      fn () =>
2377                      let
2378                         val old = !r
2379                         val new = compute ()
2380                         val () = r := new
2381                      in
2382                         {change = not (equals (old, new))}
2383                      end
2384                   val me = T {affects = affects,
2385                               compute = compute,
2386                               needToCompute = ref false}
2387                   val () = recompute me
2388                in
2389                   (me, r)
2390                end
2391          end
2392
2393       datatype 'a t =
2394          Constant of 'a
2395        | Variable of Dep.t * 'a ref
2396
2397       val get =
2398          fn Constant a => a
2399           | Variable (_, r) => !r
2400
2401       fun layout l v = l (get v)
2402
2403       val constant = Constant
2404
2405       fun new z = Variable (Dep.new z)
2406
2407       val affect =
2408          fn (Variable (d, _), Variable (d', _)) => Dep.affect (d, d')
2409           | (Constant _, _) => ()
2410           | (_, Constant _) => Error.bug "PackedRepresentation.Value.affect: Constant"
2411
2412       val fixedPoint = Dep.fixedPoint
2413    end
2414
2415 fun compute (program as Ssa.Program.T {datatypes, ...}) =
2416    let
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))
2427       val setTupleRep =
2428          Trace.trace
2429          ("PackedRepresentation.setTupleRep",
2430           S.Type.layout o #1, Layout.ignore)
2431          setTupleRep
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,
2436                                     init = tr})
2437       val setVectorRep =
2438          Trace.trace2
2439          ("PackedRepresentation.setVectorRep",
2440           S.Type.layout, TupleRep.layout, Unit.layout)
2441          setVectorRep
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
2448       val datatypes =
2449          Vector.map
2450          (datatypes, fn S.Datatype.T {cons, tycon} =>
2451           let
2452              val cons =
2453                 Vector.map
2454                 (cons, fn {args, con} =>
2455                  {args = args,
2456                   con = con,
2457                   objptrTycon = ObjptrTycon.new ()})
2458              fun compute () =
2459                 let
2460                    val (tr, cons) =
2461                       TyconRep.make
2462                       (Vector.map
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),
2468                                              ty = elt}),
2469                          con = con,
2470                          objptrTycon = objptrTycon}))
2471                    val () =
2472                       Vector.foreach
2473                       (cons, fn {con, rep} => #rep (conInfo con) := rep)
2474                 in
2475                    (tr, cons)
2476                 end
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'}) =>
2481                                        Con.equals (c, c')
2482                                        andalso ConRep.equals (r, r'))
2483              val rep =
2484                 Value.new {compute = compute,
2485                            equals = equals,
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,
2490                                                         tyconRep = rep}))
2491           in
2492              {cons = cons,
2493               rep = rep,
2494               tycon = tycon}
2495           end)
2496       val delayedObjectTypes
2497          : (unit -> (ObjptrTycon.t * ObjectType.t) option) list ref =
2498          ref []
2499       val {get = typeRep: S.Type.t -> Rep.t Value.t, ...} =
2500          Property.get
2501          (S.Type.plist,
2502           Property.initRec
2503           (fn (t, typeRep: S.Type.t -> Rep.t Value.t) =>
2504            let
2505               val constant = Value.constant
2506               val nonObjptr = constant o Rep.nonObjptr
2507               datatype z = datatype S.Type.dest
2508            in
2509               case S.Type.dest t of
2510                  CPointer => nonObjptr (Type.cpointer ())
2511                | Datatype tycon =>
2512                     let
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,
2517                                            init = Rep.unit}
2518                        val () = Value.affect (r, r')
2519                     in
2520                        r'
2521                     end
2522                | IntInf =>
2523                     constant (Rep.T {rep = Rep.Objptr {endsIn00 = false},
2524                                      ty = Type.intInf ()})
2525                | Object {args, con} =>
2526                     (case con of
2527                         ObjectCon.Con con =>
2528                            let
2529                               val {rep, tyconRep} = conInfo con
2530                               fun compute () = ConRep.rep (!rep)
2531                               val r = Value.new {compute = compute,
2532                                                  equals = Rep.equals,
2533                                                  init = Rep.unit}
2534                               val () = Value.affect (tyconRep, r)
2535                            in
2536                               r
2537                            end
2538                       | ObjectCon.Tuple =>
2539                            let
2540                               val opt = ObjptrTycon.new ()
2541                               val rs =
2542                                  Vector.map (Prod.dest args, typeRep o #elt)
2543                               fun compute () =
2544                                  TupleRep.make
2545                                  (opt,
2546                                   Vector.map2 (rs, Prod.dest args,
2547                                                fn (r, {elt, isMutable}) =>
2548                                                {isMutable = isMutable,
2549                                                 rep = Value.get r,
2550                                                 ty = elt}),
2551                                   {forceBox = false, isVector = false})
2552                               val tr =
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
2559                               val () =
2560                                  List.push
2561                                  (delayedObjectTypes, fn () =>
2562                                   case Value.get tr of
2563                                      TupleRep.Indirect opr =>
2564                                         SOME
2565                                         (opt, (ObjectType.Normal
2566                                                {hasIdentity = hasIdentity,
2567                                                 ty = ObjptrRep.componentsTy opr}))
2568                                    | _ => NONE)
2569                               val () = setTupleRep (t, tr)
2570                               fun compute () = TupleRep.rep (Value.get tr)
2571                               val r = Value.new {compute = compute,
2572                                                  equals = Rep.equals,
2573                                                  init = Rep.unit}
2574                               val () = Value.affect (tr, r)
2575                            in
2576                               r
2577                            end
2578                       | ObjectCon.Vector =>
2579                            let
2580                               val hasIdentity = Prod.someIsMutable args
2581                               val args = Prod.dest args
2582                               fun tupleRep opt =
2583                                  let
2584                                     val tr =
2585                                        TupleRep.make
2586                                        (opt,
2587                                         Vector.map
2588                                         (args, fn {elt, isMutable} =>
2589                                          {isMutable = isMutable,
2590                                           rep = Value.get (typeRep elt),
2591                                           ty = elt}),
2592                                         {forceBox = true,
2593                                          isVector = true})
2594                                     val () = setVectorRep (t, tr)
2595                                  in
2596                                     tr
2597                                  end
2598                               fun now opt = (ignore (tupleRep opt); opt)
2599                               fun delay () =
2600                                  let
2601                                     val opt = ObjptrTycon.new ()
2602                                     val () =
2603                                        List.push
2604                                        (delayedObjectTypes, fn () =>
2605                                         let
2606                                            (* Delay computing tupleRep until the
2607                                             * delayedObjectTypes are computed
2608                                             * because the vector component types
2609                                             * may not be known yet.
2610                                             *)
2611                                            val tr = tupleRep opt
2612                                            val ty =
2613                                               case tr of
2614                                                  TupleRep.Direct _ =>
2615                                                     TupleRep.ty tr
2616                                                | TupleRep.Indirect opr =>
2617                                                     ObjptrRep.componentsTy opr
2618                                         in
2619                                            SOME (opt,
2620                                                  ObjectType.Array
2621                                                  {elt = ty,
2622                                                   hasIdentity = hasIdentity})
2623                                         end)
2624                                  in
2625                                     opt
2626                                  end
2627                               val opt =
2628                                  if 1 <> Vector.length args
2629                                     then delay ()
2630                                  else
2631                                     let
2632                                        val {elt, isMutable, ...} =
2633                                           Vector.sub (args, 0)
2634                                     in
2635                                        if isMutable
2636                                           then delay ()
2637                                        else
2638                                           (case S.Type.dest elt of
2639                                               S.Type.Word s =>
2640                                                  let
2641                                                     val nBits = WordSize.bits s
2642                                                     val nInt = Bits.toInt nBits
2643                                                  in
2644                                                     if nInt = 8
2645                                                        orelse nInt = 16
2646                                                        orelse nInt = 32
2647                                                        orelse nInt = 64
2648                                                        then
2649                                                           now
2650                                                           (ObjptrTycon.wordVector nBits)
2651                                                     else delay ()
2652                                                  end
2653                                             | _ => delay ())
2654                                     end
2655                            in
2656                               constant
2657                               (Rep.T {rep = Rep.Objptr {endsIn00 = true},
2658                                       ty = Type.objptr opt})
2659                            end)
2660                | Real s => nonObjptr (Type.real s)
2661                | Thread =>
2662                     constant (Rep.T {rep = Rep.Objptr {endsIn00 = true},
2663                                      ty = Type.thread ()})
2664                | Weak t =>
2665                     let
2666                        val opt = ObjptrTycon.new ()
2667                        val rep =
2668                           Rep.T {rep = Rep.Objptr {endsIn00 = true},
2669                                  ty = Type.objptr opt}
2670                        val r = typeRep t
2671                        fun compute () =
2672                           if Rep.isObjptr (Value.get r)
2673                              then rep
2674                           else Rep.unit
2675                        val r' = Value.new {compute = compute,
2676                                            equals = Rep.equals,
2677                                            init = Rep.unit}
2678                        val () = Value.affect (r, r')
2679                        val () =
2680                           List.push
2681                           (delayedObjectTypes, fn () =>
2682                            let
2683                               val r = Value.get r
2684                            in
2685                               if Rep.isObjptr r
2686                                  then SOME (opt, ObjectType.Weak (SOME (Rep.ty r)))
2687                               else NONE
2688                            end)
2689                     in
2690                        r'
2691                     end
2692              | Word s => nonObjptr (Type.word s)
2693            end))
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.
2698        *)
2699       val () =
2700          Vector.foreach
2701          (datatypes, fn {cons, rep, ...} =>
2702           Vector.foreach
2703           (cons, fn {args, ...} =>
2704            Vector.foreach (Prod.dest args, fn {elt, ...} =>
2705                            Value.affect (typeRep elt, rep))))
2706       val typeRep =
2707          Trace.trace
2708          ("PackedRepresentation.typeRep",
2709           S.Type.layout, Value.layout Rep.layout)
2710          typeRep
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
2715       val objectTypes =
2716          Vector.fold
2717          (datatypes, [], fn ({cons, ...}, ac) =>
2718           Vector.fold
2719           (cons, ac, fn ({args, con, objptrTycon, ...}, ac) =>
2720            case conRep con of
2721               ConRep.Tuple (TupleRep.Indirect opr) =>
2722                  (objptrTycon,
2723                   ObjectType.Normal {hasIdentity = Prod.someIsMutable args,
2724                                      ty = ObjptrRep.componentsTy opr}) :: ac
2725             | _ => ac))
2726       val objectTypes = ref objectTypes
2727       val () =
2728          List.foreach (!delayedObjectTypes, fn f =>
2729                        Option.app (f (), fn z => List.push (objectTypes, z)))
2730       val objectTypes = Vector.fromList (!objectTypes)
2731       fun diagnostic () =
2732          Control.diagnostics
2733          (fn display =>
2734           (display (Layout.str "Representations:")
2735            ; (Vector.foreach
2736               (datatypes, fn {cons, tycon, ...} =>
2737                let
2738                   open Layout
2739                in
2740                   display (seq [Tycon.layout tycon,
2741                                 str " ", TyconRep.layout (tyconRep tycon)])
2742                   ; display (indent
2743                              (Vector.layout
2744                               (fn {con, ...} =>
2745                                record [("con", Con.layout con),
2746                                        ("rep", ConRep.layout (conRep con))])
2747                               cons,
2748                               2))
2749                end))))
2750       fun toRtype (t: S.Type.t): Type.t option =
2751          let
2752             val ty = Rep.ty (Value.get (typeRep t))
2753          in
2754             if Type.isUnit ty
2755                then NONE
2756             else SOME (Type.padToPrim ty)
2757          end
2758       fun makeSrc (v, oper) {index} = oper (Vector.sub (v, index))
2759       fun genCase {cases, default, test, tycon} =
2760          TyconRep.genCase (tyconRep tycon,
2761                            {cases = cases,
2762                             conRep = conRep,
2763                             default = default,
2764                             test = test})
2765       val tupleRep = Value.get o tupleRep
2766       val tupleRep =
2767          Trace.trace
2768          ("PackedRepresentation.tupleRep",
2769           S.Type.layout, TupleRep.layout)
2770          tupleRep
2771       fun object {args, con, dst, objectTy, oper} =
2772          let
2773             val src = makeSrc (args, oper)
2774          in
2775             case con of
2776                NONE => TupleRep.tuple (tupleRep objectTy, {dst = dst, src = src})
2777              | SOME con => ConRep.conApp (conRep con, {dst = dst, src = src})
2778          end
2779       fun getSelects (con, objectTy) =
2780          let
2781             datatype z = datatype ObjectCon.t
2782          in
2783             case con of
2784                Con con =>
2785                   (case conRep con of
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)
2790              | Vector =>
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"
2796          end
2797       fun select {base, baseTy, dst, offset} =
2798          case S.Type.dest baseTy of
2799             S.Type.Object {con, ...} =>
2800                let
2801                   val (ss, eltWidth) = getSelects (con, baseTy)
2802                in
2803                   Selects.select
2804                   (ss, {base = base,
2805                         eltWidth = eltWidth,
2806                         dst = dst,
2807                         offset = offset})
2808                end
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, ...} =>
2813                let
2814                   val (ss, eltWidth) = getSelects (con, baseTy)
2815                in
2816                   Selects.update (ss, {base = base,
2817                                        eltWidth = eltWidth,
2818                                        offset = offset,
2819                                        value = value})
2820                end
2821           | _ => Error.bug "PackedRepresentation.update: non-object"
2822    in
2823       {diagnostic = diagnostic,
2824        genCase = genCase,
2825        object = object,
2826        objectTypes = objectTypes,
2827        select = select,
2828        toRtype = toRtype,
2829        update = update}
2830    end
2831
2832 end