mlton/backend/rep-type.fun

   1 (* Copyright (C) 2009-2010,2014,2016-2017 Matthew Fluet.
   2  * Copyright (C) 2004-2008 Henry Cejtin, Matthew Fluet, Suresh
   3  *    Jagannathan, and Stephen Weeks.
   4  *
   5  * MLton is released under a BSD-style license.
   6  * See the file MLton-LICENSE for details.
   7  *)
   8
   9 functor RepType (S: REP_TYPE_STRUCTS): REP_TYPE =
  10 struct
  11
  12 open S
  13
  14 structure CFunction = CFunction
  15
  16 structure Type =
  17    struct
  18       datatype t = T of {node: node,
  19                          width: Bits.t}
  20       and node =
  21           Bits
  22         | CPointer
  23         | ExnStack
  24         | GCState
  25         | Label of Label.t
  26         | Objptr of ObjptrTycon.t vector
  27         | Real of RealSize.t
  28         | Seq of t vector
  29         | Word of WordSize.t
  30
  31       local
  32          fun make f (T r) = f r
  33       in
  34          val node = make #node
  35          val width = make #width
  36       end
  37       val bytes: t -> Bytes.t = Bits.toBytes o width
  38
  39       val rec layout: t -> Layout.t =
  40          fn t =>
  41          let
  42             open Layout
  43          in
  44             case node t of
  45                Bits => str (concat ["Bits", Bits.toString (width t)])
  46              | CPointer => str "CPointer"
  47              | ExnStack => str "ExnStack"
  48              | GCState => str "GCState"
  49              | Label l => seq [str "Label ", Label.layout l]
  50              | Objptr opts =>
  51                   seq [str "Objptr ",
  52                        tuple (Vector.toListMap (opts, ObjptrTycon.layout))]
  53              | Real s => str (concat ["Real", RealSize.toString s])
  54              | Seq ts => List.layout layout (Vector.toList ts)
  55              | Word s => str (concat ["Word", WordSize.toString s])
  56          end
  57
  58       val rec equals: t * t -> bool =
  59          fn (t, t') =>
  60          Bits.equals (width t, width t')
  61          andalso
  62          (case (node t, node t') of
  63              (Bits, Bits) => true
  64            | (CPointer, CPointer) => true
  65            | (ExnStack, ExnStack) => true
  66            | (GCState, GCState) => true
  67            | (Label l, Label l') => Label.equals (l, l')
  68            | (Objptr opts, Objptr opts') =>
  69                 Vector.equals (opts, opts', ObjptrTycon.equals)
  70            | (Real s, Real s') => RealSize.equals (s, s')
  71            | (Seq ts, Seq ts') => Vector.equals (ts, ts', equals)
  72            | (Word s, Word s') => WordSize.equals (s, s')
  73            | _ => false)
  74
  75       val sameWidth: t * t -> bool =
  76          fn (t, t') => Bits.equals (width t, width t')
  77
  78
  79       val bits: Bits.t -> t = fn width => T {node = Bits, width = width}
  80
  81       val cpointer: unit -> t = fn () =>
  82          T {node = CPointer, width = WordSize.bits (WordSize.cpointer ())}
  83
  84       val exnStack: unit -> t = fn () =>
  85          T {node = ExnStack, width = WordSize.bits (WordSize.csize ())}
  86
  87       val gcState: unit -> t = fn () =>
  88          T {node = GCState, width = WordSize.bits (WordSize.cpointer ())}
  89
  90       val label: Label.t -> t =
  91          fn l => T {node = Label l, width = WordSize.bits (WordSize.cpointer ())}
  92
  93       val objptr: ObjptrTycon.t -> t =
  94          fn opt => T {node = Objptr (Vector.new1 opt),
  95                       width = WordSize.bits (WordSize.objptr ())}
  96
  97       val real: RealSize.t -> t =
  98          fn s => T {node = Real s, width = RealSize.bits s}
  99
 100       val word: WordSize.t -> t =
 101          fn s => T {node = Word s, width = WordSize.bits s}
 102
 103
 104       val bool: t = word WordSize.bool
 105
 106       val csize: unit -> t = word o WordSize.csize
 107
 108       val cint: unit -> t = word o WordSize.cint
 109
 110       val compareRes = word WordSize.compareRes
 111
 112       val objptrHeader: unit -> t = word o WordSize.objptrHeader
 113
 114       val seqIndex: unit -> t = word o WordSize.seqIndex
 115
 116       val shiftArg: t = word WordSize.shiftArg
 117
 118       val stack : unit -> t = fn () =>
 119          objptr ObjptrTycon.stack
 120
 121       val thread : unit -> t = fn () =>
 122          objptr ObjptrTycon.thread
 123
 124       val word0: t = bits Bits.zero
 125       val word8: t = word WordSize.word8
 126       val word32: t = word WordSize.word32
 127
 128       val wordVector: WordSize.t -> t =
 129          objptr o ObjptrTycon.wordVector o WordSize.bits
 130
 131       val word8Vector: unit -> t =  fn () =>
 132          wordVector WordSize.word8
 133
 134       val string: unit -> t = word8Vector
 135
 136       val unit: t = bits Bits.zero
 137
 138       val zero: Bits.t -> t = bits
 139
 140
 141       val ofWordX: WordX.t -> t =
 142          fn w => word (WordX.size w)
 143
 144       fun ofWordXVector (v: WordXVector.t): t =
 145          wordVector (WordXVector.elementSize v)
 146
 147
 148       val seq: t vector -> t =
 149          fn ts =>
 150          if Vector.isEmpty ts
 151             then unit
 152          else
 153             let
 154                fun seqOnto (ts, ac) =
 155                   Vector.foldr
 156                   (ts, ac, fn (t, ac) =>
 157                    if Bits.equals (width t, Bits.zero)
 158                       then ac
 159                    else (case node t of
 160                             Seq ts => seqOnto (ts, ac)
 161                           | _ => (case ac of
 162                                      [] => [t]
 163                                    | t' :: ac' =>
 164                                         (case (node t, node t') of
 165                                             (Bits, Bits) =>
 166                                                bits (Bits.+ (width t, width t')) :: ac'
 167                                           | _ => t :: ac))))
 168             in
 169                case seqOnto (ts, []) of
 170                   [] => word0
 171                 | [t] => t
 172                 | ts =>
 173                      let
 174                         val ts = Vector.fromList ts
 175                      in
 176                         T {node = Seq ts,
 177                            width = Vector.fold (ts, Bits.zero, fn (t, ac) =>
 178                                                 Bits.+ (ac, width t))}
 179                      end
 180             end
 181
 182       val seq = Trace.trace ("RepType.Type.seq", Vector.layout layout, layout) seq
 183
 184       val sum: t vector -> t =
 185          fn ts =>
 186          if Vector.isEmpty ts
 187             then Error.bug "RepType.Type.sum: empty"
 188          else
 189             let
 190                val opts =
 191                   Vector.concatV
 192                   (Vector.keepAllMap
 193                    (ts, fn t =>
 194                     case node t of
 195                        Objptr opts => SOME opts
 196                      | _ => NONE))
 197             in
 198                if Vector.isEmpty opts
 199                   then Vector.first ts
 200                else
 201                   T {node = (Objptr (QuickSort.sortVector (opts, ObjptrTycon.<=))),
 202                      width = WordSize.bits (WordSize.objptr ())}
 203             end
 204
 205       val sum = Trace.trace ("RepType.Type.sum", Vector.layout layout, layout) sum
 206
 207       val intInf: unit -> t = fn () =>
 208          sum (Vector.new2
 209               (wordVector (WordSize.bigIntInfWord ()),
 210                seq (Vector.new2
 211                     (bits Bits.one,
 212                      word (WordSize.fromBits
 213                            (Bits.- (WordSize.bits (WordSize.smallIntInfWord ()),
 214                                     Bits.one)))))))
 215
 216       val deLabel: t -> Label.t option =
 217          fn t =>
 218          case node t of
 219             Label l => SOME l
 220           | _ => NONE
 221
 222       val deObjptr: t -> ObjptrTycon.t option =
 223          fn t =>
 224          case node t of
 225             Objptr opts =>
 226                if 1 = Vector.length opts
 227                   then SOME (Vector.first opts)
 228                else NONE
 229           | _ => NONE
 230
 231       val deReal: t -> RealSize.t option =
 232          fn t =>
 233          case node t of
 234             Real s => SOME s
 235           | _ => NONE
 236
 237       val deSeq: t -> t vector option =
 238          fn t =>
 239          case node t of
 240             Seq v => SOME v
 241           | _ => NONE
 242
 243       val deWord: t -> WordSize.t option =
 244          fn t =>
 245          case node t of
 246             Word s => SOME s
 247           | _ => NONE
 248
 249       val isCPointer: t -> bool =
 250          fn t =>
 251          case node t of
 252             CPointer => true
 253           | _ => false
 254
 255       val isObjptr: t -> bool =
 256          fn t =>
 257          case node t of
 258             Objptr _ => true
 259           | _ => false
 260
 261       val isUnit: t -> bool = fn t => Bits.equals (Bits.zero, width t)
 262
 263       val isSubtype: t * t -> bool =
 264          fn (t, t') =>
 265          if not (sameWidth (t, t'))
 266             then false (* Error.bug "RepType.Type.isSubtype" *)
 267          else
 268             (equals (t, t')
 269              orelse
 270              case (node t, node t') of
 271                 (Objptr opts, Objptr opts') =>
 272                    Vector.isSubsequence (opts, opts', ObjptrTycon.equals)
 273               | (Real _, _) => false
 274               | (Bits, Objptr _) => true
 275               | (Word _, Objptr _) => true
 276               | (Seq ts, Objptr _) =>
 277                    Vector.forall
 278                    (ts, (fn Bits => true
 279                           | Real _ => true
 280                           | Word _ => true
 281                           | _ => false) o node)
 282               | (_, Bits) => true
 283               | (_, Word _) => true
 284               | (_, Seq ts) =>
 285                    Vector.forall
 286                    (ts, (fn Bits => true
 287                           | Real _ => true
 288                           | Word _ => true
 289                           | _ => false) o node)
 290               | _ => false)
 291
 292       val isSubtype =
 293          Trace.trace2 ("RepType.Type.isSubtype", layout, layout, Bool.layout)
 294          isSubtype
 295
 296       fun exists (t, p) =
 297          if p t
 298             then true
 299          else (case node t of
 300                   Seq ts => Vector.exists (ts, fn t => exists (t, p))
 301                 | _ => false)
 302
 303
 304       val resize: t * Bits.t -> t = fn (_, b) => bits b
 305
 306       val bogusWord: t -> WordX.t =
 307          fn t => WordX.one (WordSize.fromBits (width t))
 308
 309       local
 310          structure C =
 311             struct
 312                open CType
 313
 314                fun fromBits (b: Bits.t): t =
 315                   case Bits.toInt b of
 316                      8 => Word8
 317                    | 16 => Word16
 318                    | 32 => Word32
 319                    | 64 => Word64
 320                    | _ => Error.bug (concat ["RepType.Type.CType.fromBits: ",
 321                                              Bits.toString b])
 322             end
 323       in
 324          val toCType: t -> CType.t =
 325             fn t =>
 326             if isObjptr t
 327                then C.Objptr
 328             else
 329                case node t of
 330                   CPointer => C.CPointer
 331                 | GCState => C.CPointer
 332                 | Label _ => C.CPointer
 333                 | Real s =>
 334                      (case s of
 335                          RealSize.R32 => C.Real32
 336                        | RealSize.R64 => C.Real64)
 337                 | _ => C.fromBits (width t)
 338
 339          val name = C.name o toCType
 340
 341          val align: t * Bytes.t -> Bytes.t =
 342             fn (t, n) => C.align (toCType t, n)
 343       end
 344
 345       fun bytesAndObjptrs (t: t): Bytes.t * int =
 346          case node t of
 347             Objptr _ => (Bytes.zero, 1)
 348           | Seq ts =>
 349                (case Vector.peeki (ts, isObjptr o #2) of
 350                    NONE => (bytes t, 0)
 351                  | SOME (i, _) =>
 352                       let
 353                          val b = bytes (seq (Vector.prefix (ts, i)))
 354                          val j = (Vector.length ts) - i
 355                       in
 356                          (b, j)
 357                       end)
 358           | _ => (bytes t, 0)
 359    end
 360
 361 structure ObjectType =
 362    struct
 363       structure ObjptrTycon = ObjptrTycon
 364       structure Runtime = Runtime
 365
 366       type ty = Type.t
 367       datatype t =
 368          Array of {elt: ty,
 369                    hasIdentity: bool}
 370        | Normal of {hasIdentity: bool,
 371                     ty: ty}
 372        | Stack
 373        | Weak of Type.t option
 374
 375       fun layout (t: t) =
 376          let
 377             open Layout
 378          in
 379             case t of
 380                Array {elt, hasIdentity} =>
 381                   seq [str "Array ",
 382                        record [("elt", Type.layout elt),
 383                                ("hasIdentity", Bool.layout hasIdentity)]]
 384              | Normal {hasIdentity, ty} =>
 385                   seq [str "Normal ",
 386                        record [("hasIdentity", Bool.layout hasIdentity),
 387                                ("ty", Type.layout ty)]]
 388              | Stack => str "Stack"
 389              | Weak t => seq [str "Weak ", Option.layout Type.layout t]
 390          end
 391
 392       fun isOk (t: t): bool =
 393          case t of
 394             Array {elt, ...} =>
 395                let
 396                   val b = Type.width elt
 397                in
 398                   Bits.isByteAligned b
 399                end
 400           | Normal {ty, ...} =>
 401                let
 402                   val b = Bits.+ (Type.width ty,
 403                                   Type.width (Type.objptrHeader ()))
 404                in
 405                   case !Control.align of
 406                      Control.Align4 => Bits.isWord32Aligned b
 407                    | Control.Align8 => Bits.isWord64Aligned b
 408                end
 409           | Stack => true
 410           | Weak to => Option.fold (to, true, fn (t,_) => Type.isObjptr t)
 411
 412       val stack = Stack
 413
 414       val thread = fn () =>
 415          let
 416             val padding =
 417                let
 418                   val align =
 419                      case !Control.align of
 420                         Control.Align4 => Bytes.fromInt 4
 421                       | Control.Align8 => Bytes.fromInt 8
 422                   val bytesMetaData =
 423                      Bits.toBytes (Control.Target.Size.normalMetaData ())
 424                   val bytesCSize =
 425                      Bits.toBytes (Control.Target.Size.csize ())
 426                   val bytesExnStack =
 427                      Bits.toBytes (Type.width (Type.exnStack ()))
 428                   val bytesStack =
 429                      Bits.toBytes (Type.width (Type.stack ()))
 430
 431                   val bytesObject =
 432                      Bytes.+ (bytesMetaData,
 433                      Bytes.+ (bytesCSize,
 434                      Bytes.+ (bytesExnStack,
 435                               bytesStack)))
 436                   val bytesTotal =
 437                      Bytes.align (bytesObject, {alignment = align})
 438                   val bytesPad = Bytes.- (bytesTotal, bytesObject)
 439                in
 440                   Type.bits (Bytes.toBits bytesPad)
 441                end
 442          in
 443             Normal {hasIdentity = true,
 444                     ty = Type.seq (Vector.new4 (padding,
 445                                                 Type.csize (),
 446                                                 Type.exnStack (),
 447                                                 Type.stack ()))}
 448          end
 449
 450       (* Order in the following vector matters.  The basic pointer tycons must
 451        * correspond to the constants in gc/object.h.
 452        * STACK_TYPE_INDEX,
 453        * THREAD_TYPE_INDEX,
 454        * WEAK_GONE_TYPE_INDEX,
 455        * WORD8_VECTOR_TYPE_INDEX,
 456        * WORD16_VECTOR_TYPE_INDEX,
 457        * WORD32_VECTOR_TYPE_INDEX.
 458        * WORD64_VECTOR_TYPE_INDEX.
 459        *)
 460       val basic = fn () =>
 461          let
 462             fun wordVec i =
 463                let
 464                   val b = Bits.fromInt i
 465                in
 466                   (ObjptrTycon.wordVector b,
 467                    Array {hasIdentity = false,
 468                           elt = Type.word (WordSize.fromBits b)})
 469                end
 470          in
 471             Vector.fromList
 472             [(ObjptrTycon.stack, stack),
 473              (ObjptrTycon.thread, thread ()),
 474              (ObjptrTycon.weakGone, Weak NONE),
 475              wordVec 8,
 476              wordVec 32,
 477              wordVec 16,
 478              wordVec 64]
 479          end
 480
 481       local
 482          structure R = Runtime.RObjectType
 483       in
 484          fun toRuntime (t: t): R.t =
 485             case t of
 486                Array {elt, hasIdentity} =>
 487                   let
 488                      val (b, nops) = Type.bytesAndObjptrs elt
 489                   in
 490                      R.Array {hasIdentity = hasIdentity,
 491                               bytesNonObjptrs = b,
 492                               numObjptrs = nops}
 493                   end
 494              | Normal {hasIdentity, ty} =>
 495                   let
 496                      val (b, nops) = Type.bytesAndObjptrs ty
 497                   in
 498                      R.Normal {hasIdentity = hasIdentity,
 499                                bytesNonObjptrs = b,
 500                                numObjptrs = nops}
 501                   end
 502              | Stack => R.Stack
 503              | Weak to => R.Weak {gone = Option.isNone to}
 504       end
 505    end
 506
 507 open Type
 508
 509 structure GCField = Runtime.GCField
 510
 511 fun ofGCField (f: GCField.t): t =
 512    let
 513       datatype z = datatype GCField.t
 514    in
 515       case f of
 516          AtomicState => word32
 517        | CardMapAbsolute => cpointer ()
 518        | CurrentThread => thread ()
 519        | CurSourceSeqsIndex => word32
 520        | ExnStack => exnStack ()
 521        | Frontier => cpointer ()
 522        | Limit => cpointer ()
 523        | LimitPlusSlop => cpointer ()
 524        | MaxFrameSize => word32
 525        | SignalIsPending => word32
 526        | StackBottom => cpointer ()
 527        | StackLimit => cpointer ()
 528        | StackTop => cpointer ()
 529    end
 530
 531 fun castIsOk {from, to, tyconTy = _} =
 532    Bits.equals (width from, width to)
 533
 534 fun checkPrimApp {args, prim, result} =
 535    let
 536       datatype z = datatype Prim.Name.t
 537       fun done (argsP, resultP) =
 538          let
 539             val argsP = Vector.fromList argsP
 540          in
 541             (Vector.length args = Vector.length argsP)
 542             andalso (Vector.forall2 (args, argsP,
 543                                      fn (arg, argP) => argP arg))
 544             andalso (case (result, resultP) of
 545                         (NONE, NONE) => true
 546                       | (SOME result, SOME resultP) => resultP result
 547                       | _ => false)
 548          end
 549       val bits = fn s => fn t => equals (t, bits s)
 550       val bool = fn t => equals (t, bool)
 551       val cpointer = fn t => equals (t, cpointer ())
 552       val objptr = fn t => (case node t of Objptr _ => true | _ => false)
 553       val real = fn s => fn t => equals (t, real s)
 554       val seq = fn s => fn t =>
 555          (case node t
 556              of Seq _ => Bits.equals (width t, WordSize.bits s)
 557            | _ => false)
 558       val word = fn s => fn t => equals (t, word s)
 559
 560       val cint = word (WordSize.cint ())
 561       val csize = word (WordSize.csize ())
 562       val cptrdiff = word (WordSize.cptrdiff ())
 563       val shiftArg = word WordSize.shiftArg
 564
 565       val or = fn (p1, p2) => fn t => p1 t orelse p2 t
 566       val bitsOrSeq = fn s => or (bits (WordSize.bits s), seq s)
 567       val wordOrBitsOrSeq = fn s => or (word s, bitsOrSeq s)
 568       local
 569          fun make f s = let val t = f s in done ([t], SOME t) end
 570       in
 571          val realUnary = make real
 572          val wordUnary = make wordOrBitsOrSeq
 573       end
 574       local
 575          fun make f s = let val t = f s in done ([t, t], SOME t) end
 576       in
 577          val realBinary = make real
 578          val wordBinary = make wordOrBitsOrSeq
 579       end
 580       local
 581          fun make f s = let val t = f s in done ([t, t], SOME bool) end
 582       in
 583          val realCompare = make real
 584          val wordCompare = make wordOrBitsOrSeq
 585          val objptrCompare = make (fn _ => objptr) ()
 586       end
 587       fun realTernary s = done ([real s, real s, real s], SOME (real s))
 588       fun wordShift s = done ([wordOrBitsOrSeq s, shiftArg], SOME (wordOrBitsOrSeq s))
 589    in
 590       case Prim.name prim of
 591          CPointer_add => done ([cpointer, cptrdiff], SOME cpointer)
 592        | CPointer_diff => done ([cpointer, cpointer], SOME cptrdiff)
 593        | CPointer_equal => done ([cpointer, cpointer], SOME bool)
 594        | CPointer_fromWord => done ([csize], SOME cpointer)
 595        | CPointer_lt => done ([cpointer, cpointer], SOME bool)
 596        | CPointer_sub => done ([cpointer, cptrdiff], SOME cpointer)
 597        | CPointer_toWord => done ([cpointer], SOME csize)
 598        | FFI f => done (Vector.toListMap (CFunction.args f,
 599                                           fn t' => fn t => equals (t', t)),
 600                         SOME (fn t => equals (t, CFunction.return f)))
 601        | FFI_Symbol _ => done ([], SOME cpointer)
 602        | MLton_touch => done ([objptr], NONE)
 603        | Real_Math_acos s => realUnary s
 604        | Real_Math_asin s => realUnary s
 605        | Real_Math_atan s => realUnary s
 606        | Real_Math_atan2 s => realBinary s
 607        | Real_Math_cos s => realUnary s
 608        | Real_Math_exp s => realUnary s
 609        | Real_Math_ln s => realUnary s
 610        | Real_Math_log10 s => realUnary s
 611        | Real_Math_sin s => realUnary s
 612        | Real_Math_sqrt s => realUnary s
 613        | Real_Math_tan s => realUnary s
 614        | Real_abs s => realUnary s
 615        | Real_add s => realBinary s
 616        | Real_castToWord (s, s') => done ([real s], SOME (word s'))
 617        | Real_div s => realBinary s
 618        | Real_equal s => realCompare s
 619        | Real_ldexp s => done ([real s, cint], SOME (real s))
 620        | Real_le s => realCompare s
 621        | Real_lt s => realCompare s
 622        | Real_mul s => realBinary s
 623        | Real_muladd s => realTernary s
 624        | Real_mulsub s => realTernary s
 625        | Real_neg s => realUnary s
 626        | Real_qequal s => realCompare s
 627        | Real_rndToReal (s, s') => done ([real s], SOME (real s'))
 628        | Real_rndToWord (s, s', _) => done ([real s], SOME (word s'))
 629        | Real_round s => realUnary s
 630        | Real_sub s => realBinary s
 631        | Thread_returnToC => done ([], NONE)
 632        | Word_add s => wordBinary s
 633        | Word_addCheck (s, _) => wordBinary s
 634        | Word_andb s => wordBinary s
 635        | Word_castToReal (s, s') => done ([word s], SOME (real s'))
 636        | Word_equal s => (wordCompare s) orelse objptrCompare
 637        | Word_extdToWord (s, s', _) => done ([wordOrBitsOrSeq s],
 638                                              SOME (wordOrBitsOrSeq s'))
 639        | Word_lshift s => wordShift s
 640        | Word_lt (s, _) => wordCompare s
 641        | Word_mul (s, _) => wordBinary s
 642        | Word_mulCheck (s, _) => wordBinary s
 643        | Word_neg s => wordUnary s
 644        | Word_negCheck s => wordUnary s
 645        | Word_notb s => wordUnary s
 646        | Word_orb s => wordBinary s
 647        | Word_quot (s, _) => wordBinary s
 648        | Word_rem (s, _) => wordBinary s
 649        | Word_rndToReal (s, s', _) => done ([word s], SOME (real s'))
 650        | Word_rol s => wordShift s
 651        | Word_ror s => wordShift s
 652        | Word_rshift (s, _) => wordShift s
 653        | Word_sub s => wordBinary s
 654        | Word_subCheck (s, _) => wordBinary s
 655        | Word_xorb s => wordBinary s
 656        | _ => Error.bug (concat ["RepType.checkPrimApp got strange prim: ",
 657                                  Prim.toString prim])
 658    end
 659
 660 fun checkOffset {base, isVector, offset, result} =
 661    Exn.withEscape (fn escape =>
 662    let
 663       fun getTys ty =
 664          case node ty of
 665             Seq tys => Vector.toList tys
 666           | _ => [ty]
 667
 668       fun dropTys (tys, bits) =
 669          let
 670             fun loop (tys, bits) =
 671                if Bits.equals (bits, Bits.zero)
 672                   then tys
 673                else (case tys of
 674                         [] => escape false
 675                       | ty::tys =>
 676                            let
 677                               val b = width ty
 678                            in
 679                               if Bits.>= (bits, b)
 680                                  then loop (tys, Bits.- (bits, b))
 681                               else (case node ty of
 682                                        Bits => (Type.bits (Bits.- (b, bits))) :: tys
 683                                      | _ => escape false)
 684                            end)
 685          in
 686             if Bits.< (bits, Bits.zero)
 687                then escape false
 688             else loop (tys, bits)
 689          end
 690       val dropTys =
 691          Trace.trace2
 692          ("RepType.checkOffset.dropTys",
 693           List.layout Type.layout, Bits.layout,
 694           List.layout Type.layout)
 695          dropTys
 696       fun takeTys (tys, bits) =
 697          let
 698             fun loop (tys, bits, acc) =
 699                if Bits.equals (bits, Bits.zero)
 700                   then acc
 701                else (case tys of
 702                         [] => escape false
 703                       | ty::tys =>
 704                            let
 705                               val b = width ty
 706                            in
 707                               if Bits.>= (bits, b)
 708                                  then loop (tys, Bits.- (bits, b), ty :: acc)
 709                               else (case node ty of
 710                                        Bits => (Type.bits bits) :: acc
 711                                      | _ => escape false)
 712                            end)
 713          in
 714             if Bits.< (bits, Bits.zero)
 715                then escape false
 716             else List.rev (loop (tys, bits, []))
 717          end
 718       fun extractTys (tys, dropBits, takeBits) =
 719          takeTys (dropTys (tys, dropBits), takeBits)
 720
 721       fun equalsTys (tys1, tys2) =
 722          case (tys1, tys2) of
 723             ([], []) => true
 724           | (ty1::tys1, ty2::tys2) =>
 725                equals (ty1, ty2)
 726                andalso equalsTys (tys1, tys2)
 727           | _ => false
 728
 729       val alignBits =
 730          case !Control.align of
 731             Control.Align4 => Bits.inWord32
 732           | Control.Align8 => Bits.inWord64
 733
 734       val baseBits = width base
 735       val baseTys = getTys base
 736
 737       val offsetBytes = offset
 738       val offsetBits = Bytes.toBits offsetBytes
 739
 740       val resultBits = width result
 741       val resultTys = getTys result
 742
 743       val adjOffsetBits =
 744          if Control.Target.bigEndian ()
 745             andalso Bits.< (resultBits, Bits.inWord32)
 746             andalso Bits.> (baseBits, resultBits)
 747             then let
 748                     val paddedComponentBits =
 749                        if isVector
 750                           then Bits.min (baseBits, Bits.inWord32)
 751                        else Bits.inWord32
 752                     val paddedComponentOffsetBits =
 753                        Bits.alignDown (offsetBits, {alignment = paddedComponentBits})
 754                  in
 755                     Bits.+ (paddedComponentOffsetBits,
 756                             Bits.- (paddedComponentBits,
 757                                     Bits.- (Bits.+ (resultBits, offsetBits),
 758                                             paddedComponentOffsetBits)))
 759                  end
 760          else offsetBits
 761    in
 762       List.exists
 763       ([Bits.inWord8, Bits.inWord16, Bits.inWord32, Bits.inWord64], fn primBits =>
 764        Bits.equals (resultBits, primBits)
 765        andalso Bits.isAligned (offsetBits, {alignment = Bits.min (primBits, alignBits)}))
 766       andalso
 767       equalsTys (resultTys, extractTys (baseTys, adjOffsetBits, resultBits))
 768    end)
 769
 770 fun offsetIsOk {base, offset, tyconTy, result} =
 771    case node base of
 772       Objptr opts =>
 773          if Bytes.equals (offset, Runtime.headerOffset ())
 774             then equals (result, objptrHeader ())
 775          else if Bytes.equals (offset, Runtime.arrayLengthOffset ())
 776             then (1 = Vector.length opts)
 777                  andalso (case tyconTy (Vector.sub (opts, 0)) of
 778                              ObjectType.Array _ => true
 779                            | _ => false)
 780                  andalso (equals (result, seqIndex ()))
 781          else (1 = Vector.length opts)
 782               andalso (case tyconTy (Vector.sub (opts, 0)) of
 783                           ObjectType.Normal {ty, ...} =>
 784                              checkOffset {base = ty,
 785                                           isVector = false,
 786                                           offset = offset,
 787                                           result = result}
 788                         | _ => false)
 789     | _ => false
 790
 791 fun arrayOffsetIsOk {base, index, offset, tyconTy, result, scale} =
 792    case node base of
 793       CPointer =>
 794          (equals (index, csize ()))
 795          andalso (case node result of
 796                      CPointer => true
 797                    | Objptr _ => true (* for FFI export of indirect types *)
 798                    | Real _ => true
 799                    | Word _ => true
 800                    | _ => false)
 801          andalso (case Scale.fromBytes (bytes result) of
 802                      NONE => false
 803                    | SOME s => scale = s)
 804          andalso (Bytes.equals (offset, Bytes.zero))
 805     | Objptr opts =>
 806          (equals (index, seqIndex ()))
 807          andalso (1 = Vector.length opts)
 808          andalso (case tyconTy (Vector.first opts) of
 809                      ObjectType.Array {elt, ...} =>
 810                         if equals (elt, word8)
 811                            then (* special case for PackWord operations *)
 812                                 (case node result of
 813                                     Word wsRes =>
 814                                        (case Scale.fromBytes (WordSize.bytes wsRes) of
 815                                            NONE => false
 816                                          | SOME s => scale = s)
 817                                        andalso (Bytes.equals (offset, Bytes.zero))
 818                                   | _ => false)
 819                         else (case Scale.fromBytes (bytes elt) of
 820                                  NONE => scale = Scale.One
 821                                | SOME s => scale = s)
 822                              andalso (checkOffset {base = elt,
 823                                                    isVector = true,
 824                                                    offset = offset,
 825                                                    result = result})
 826                    | _ => false)
 827     | _ => false
 828
 829
 830
 831 structure BuiltInCFunction =
 832    struct
 833       open CFunction
 834
 835       datatype z = datatype Convention.t
 836       datatype z = datatype Target.t
 837
 838       fun bug () =
 839          vanilla {args = Vector.new1 (string ()),
 840                   name = "MLton_bug",
 841                   prototype = (Vector.new1 CType.objptr, NONE),
 842                   return = unit}
 843
 844       local
 845          fun make b = fn () =>
 846             T {args = Vector.new3 (Type.gcState (), Type.csize (), Type.bool),
 847                    convention = Cdecl,
 848                    kind = Kind.Runtime {bytesNeeded = NONE,
 849                                         ensuresBytesFree = true,
 850                                         mayGC = true,
 851                                         maySwitchThreads = b,
 852                                         modifiesFrontier = true,
 853                                         readsStackTop = true,
 854                                         writesStackTop = true},
 855                    prototype = (Vector.new3 (CType.cpointer, CType.csize (), CType.bool),
 856                                 NONE),
 857                    return = Type.unit,
 858                    symbolScope = SymbolScope.Private,
 859                    target = Direct "GC_collect"}
 860          val t = make true
 861          val f = make false
 862       in
 863          fun gc {maySwitchThreads = b} = if b then t () else f ()
 864       end
 865    end
 866
 867 end