mlton/backend/rssa.fun

   1 (* Copyright (C) 2009,2016-2017 Matthew Fluet.
   2  * Copyright (C) 1999-2008 Henry Cejtin, Matthew Fluet, Suresh
   3  *    Jagannathan, and Stephen Weeks.
   4  * Copyright (C) 1997-2000 NEC Research Institute.
   5  *
   6  * MLton is released under a BSD-style license.
   7  * See the file MLton-LICENSE for details.
   8  *)
   9
  10 functor Rssa (S: RSSA_STRUCTS): RSSA =
  11 struct
  12
  13 open S
  14
  15 local
  16    open Prim
  17 in
  18    structure ApplyArg = ApplyArg
  19    structure ApplyResult = ApplyResult
  20 end
  21 local
  22    open Runtime
  23 in
  24    structure CFunction = CFunction
  25    structure GCField = GCField
  26 end
  27
  28 fun constrain (ty: Type.t): Layout.t =
  29    let
  30       open Layout
  31    in
  32       if !Control.showTypes
  33          then seq [str ": ", Type.layout ty]
  34       else empty
  35    end
  36
  37 structure Operand =
  38    struct
  39       datatype t =
  40          ArrayOffset of {base: t,
  41                          index: t,
  42                          offset: Bytes.t,
  43                          scale: Scale.t,
  44                          ty: Type.t}
  45        | Cast of t * Type.t
  46        | Const of Const.t
  47        | EnsuresBytesFree
  48        | GCState
  49        | Offset of {base: t,
  50                     offset: Bytes.t,
  51                     ty: Type.t}
  52        | ObjptrTycon of ObjptrTycon.t
  53        | Runtime of GCField.t
  54        | Var of {var: Var.t,
  55                  ty: Type.t}
  56
  57       val null = Const Const.null
  58
  59       val word = Const o Const.word
  60
  61       fun zero s = word (WordX.fromIntInf (0, s))
  62
  63       fun bool b =
  64          word (WordX.fromIntInf (if b then 1 else 0, WordSize.bool))
  65
  66       val ty =
  67          fn ArrayOffset {ty, ...} => ty
  68           | Cast (_, ty) => ty
  69           | Const c =>
  70                let
  71                   datatype z = datatype Const.t
  72                in
  73                   case c of
  74                      IntInf _ => Type.intInf ()
  75                    | Null => Type.cpointer ()
  76                    | Real r => Type.real (RealX.size r)
  77                    | Word w => Type.ofWordX w
  78                    | WordVector v => Type.ofWordXVector v
  79                end
  80           | EnsuresBytesFree => Type.csize ()
  81           | GCState => Type.gcState ()
  82           | Offset {ty, ...} => ty
  83           | ObjptrTycon _ => Type.objptrHeader ()
  84           | Runtime z => Type.ofGCField z
  85           | Var {ty, ...} => ty
  86
  87       fun layout (z: t): Layout.t =
  88          let
  89             open Layout
  90          in
  91             case z of
  92                ArrayOffset {base, index, offset, scale, ty} =>
  93                   seq [str (concat ["X", Type.name ty, " "]),
  94                        tuple [layout base, layout index, Scale.layout scale,
  95                               Bytes.layout offset]]
  96              | Cast (z, ty) =>
  97                   seq [str "Cast ", tuple [layout z, Type.layout ty]]
  98              | Const c => seq [Const.layout c, constrain (ty z)]
  99              | EnsuresBytesFree => str "<EnsuresBytesFree>"
 100              | GCState => str "<GCState>"
 101              | Offset {base, offset, ty} =>
 102                   seq [str (concat ["O", Type.name ty, " "]),
 103                        tuple [layout base, Bytes.layout offset],
 104                        constrain ty]
 105              | ObjptrTycon opt => ObjptrTycon.layout opt
 106              | Runtime r => GCField.layout r
 107              | Var {var, ...} => Var.layout var
 108          end
 109
 110       fun cast (z: t, t: Type.t): t =
 111          if Type.equals (t, ty z)
 112             then z
 113          else Cast (z, t)
 114
 115       val cast = Trace.trace2 ("Rssa.Operand.cast", layout, Type.layout, layout) cast
 116
 117       val rec isLocation =
 118          fn ArrayOffset _ => true
 119           | Cast (z, _) => isLocation z
 120           | Offset _ => true
 121           | Runtime _ => true
 122           | Var _ => true
 123           | _ => false
 124
 125       fun 'a foldVars (z: t, a: 'a, f: Var.t * 'a -> 'a): 'a =
 126          case z of
 127             ArrayOffset {base, index, ...} =>
 128                foldVars (index, foldVars (base, a, f), f)
 129           | Cast (z, _) => foldVars (z, a, f)
 130           | Offset {base, ...} => foldVars (base, a, f)
 131           | Var {var, ...} => f (var, a)
 132           | _ => a
 133
 134       fun replaceVar (z: t, f: Var.t -> t): t =
 135          let
 136             fun loop (z: t): t =
 137                case z of
 138                   ArrayOffset {base, index, offset, scale, ty} =>
 139                      ArrayOffset {base = loop base,
 140                                   index = loop index,
 141                                   offset = offset,
 142                                   scale = scale,
 143                                   ty = ty}
 144                 | Cast (t, ty) => Cast (loop t, ty)
 145                 | Offset {base, offset, ty} =>
 146                      Offset {base = loop base,
 147                              offset = offset,
 148                              ty = ty}
 149                 | Var {var, ...} => f var
 150                 | _ => z
 151          in
 152             loop z
 153          end
 154
 155    end
 156
 157 structure Switch =
 158    struct
 159       local
 160          structure S = Switch (open S
 161                                structure Type = Type
 162                                structure Use = Operand)
 163       in
 164          open S
 165       end
 166
 167       fun replaceVar (T {cases, default, size, test}, f) =
 168          T {cases = cases,
 169             default = default,
 170             size = size,
 171             test = Operand.replaceVar (test, f)}
 172    end
 173
 174 structure Statement =
 175    struct
 176       datatype t =
 177          Bind of {dst: Var.t * Type.t,
 178                   isMutable: bool,
 179                   src: Operand.t}
 180        | Move of {dst: Operand.t,
 181                   src: Operand.t}
 182        | Object of {dst: Var.t * Type.t,
 183                     header: word,
 184                     size: Bytes.t}
 185        | PrimApp of {args: Operand.t vector,
 186                      dst: (Var.t * Type.t) option,
 187                      prim: Type.t Prim.t}
 188        | Profile of ProfileExp.t
 189        | ProfileLabel of ProfileLabel.t
 190        | SetExnStackLocal
 191        | SetExnStackSlot
 192        | SetHandler of Label.t
 193        | SetSlotExnStack
 194
 195       fun 'a foldDefUse (s, a: 'a, {def: Var.t * Type.t * 'a -> 'a,
 196                                     use: Var.t * 'a -> 'a}): 'a =
 197          let
 198             fun useOperand (z: Operand.t, a) = Operand.foldVars (z, a, use)
 199          in
 200             case s of
 201                Bind {dst = (x, t), src, ...} => def (x, t, useOperand (src, a))
 202              | Move {dst, src} => useOperand (src, useOperand (dst, a))
 203              | Object {dst = (dst, ty), ...} => def (dst, ty, a)
 204              | PrimApp {dst, args, ...} =>
 205                   Vector.fold (args,
 206                                Option.fold (dst, a, fn ((x, t), a) =>
 207                                             def (x, t, a)),
 208                                useOperand)
 209              | Profile _ => a
 210              | ProfileLabel _ => a
 211              | SetExnStackLocal => a
 212              | SetExnStackSlot => a
 213              | SetHandler _ => a
 214              | SetSlotExnStack => a
 215          end
 216
 217       fun foreachDefUse (s: t, {def, use}) =
 218          foldDefUse (s, (), {def = fn (x, t, ()) => def (x, t),
 219                              use = use o #1})
 220
 221       fun 'a foldDef (s: t, a: 'a, f: Var.t * Type.t * 'a -> 'a): 'a =
 222          foldDefUse (s, a, {def = f, use = #2})
 223
 224       fun foreachDef (s:t , f: Var.t * Type.t -> unit) =
 225          foldDef (s, (), fn (x, t, ()) => f (x, t))
 226
 227       fun 'a foldUse (s: t, a: 'a, f: Var.t * 'a -> 'a) =
 228          foldDefUse (s, a, {def = #3, use = f})
 229
 230       fun foreachUse (s, f) = foldUse (s, (), f o #1)
 231
 232       fun replaceUses (s: t, f: Var.t -> Operand.t): t =
 233          let
 234             fun oper (z: Operand.t): Operand.t =
 235                Operand.replaceVar (z, f)
 236          in
 237             case s of
 238                Bind {dst, isMutable, src} =>
 239                   Bind {dst = dst,
 240                         isMutable = isMutable,
 241                         src = oper src}
 242              | Move {dst, src} => Move {dst = oper dst, src = oper src}
 243              | Object _ => s
 244              | PrimApp {args, dst, prim} =>
 245                   PrimApp {args = Vector.map (args, oper),
 246                            dst = dst,
 247                            prim = prim}
 248              | Profile _ => s
 249              | ProfileLabel _ => s
 250              | SetExnStackLocal => s
 251              | SetExnStackSlot => s
 252              | SetHandler _ => s
 253              | SetSlotExnStack => s
 254          end
 255
 256       val layout =
 257          let
 258             open Layout
 259          in
 260             fn Bind {dst = (x, t), src, ...} =>
 261                   mayAlign
 262                   [seq [Var.layout x, constrain t],
 263                    indent (seq [str "= ", Operand.layout src], 2)]
 264              | Move {dst, src} =>
 265                   mayAlign
 266                   [Operand.layout dst,
 267                    indent (seq [str ":= ", Operand.layout src], 2)]
 268              | Object {dst = (dst, ty), header, size} =>
 269                   mayAlign
 270                   [seq [Var.layout dst, constrain ty],
 271                    indent (seq [str "= Object ",
 272                                 record [("header", seq [str "0x", Word.layout header]),
 273                                         ("size", Bytes.layout size)]],
 274                            2)]
 275              | PrimApp {dst, prim, args, ...} =>
 276                   mayAlign
 277                   [case dst of
 278                       NONE => seq [str "_", constrain (Type.unit)]
 279                     | SOME (x, t) => seq [Var.layout x, constrain t],
 280                    indent (seq [str "= ", Prim.layout prim, str " ",
 281                                 Vector.layout Operand.layout args],
 282                            2)]
 283              | Profile e => ProfileExp.layout e
 284              | ProfileLabel p =>
 285                   seq [str "ProfileLabel ", ProfileLabel.layout p]
 286              | SetExnStackLocal => str "SetExnStackLocal"
 287              | SetExnStackSlot => str "SetExnStackSlot "
 288              | SetHandler l => seq [str "SetHandler ", Label.layout l]
 289              | SetSlotExnStack => str "SetSlotExnStack "
 290          end
 291
 292       val toString = Layout.toString o layout
 293
 294       fun clear (s: t) =
 295          foreachDef (s, Var.clear o #1)
 296
 297       fun resize (src: Operand.t, dstTy: Type.t): Operand.t * t list =
 298          let
 299             val srcTy = Operand.ty src
 300
 301             val (src, srcTy, ssSrc, dstTy, finishDst) =
 302                case (Type.deReal srcTy, Type.deReal dstTy) of
 303                   (NONE, NONE) =>
 304                      (src, srcTy, [], dstTy, fn dst => (dst, []))
 305                 | (SOME rs, NONE) =>
 306                      let
 307                         val ws = WordSize.fromBits (RealSize.bits rs)
 308                         val tmp = Var.newNoname ()
 309                         val tmpTy = Type.word ws
 310                      in
 311                         (Operand.Var {ty = tmpTy, var = tmp},
 312                          tmpTy,
 313                          [PrimApp {args = Vector.new1 src,
 314                                    dst = SOME (tmp, tmpTy),
 315                                    prim = Prim.realCastToWord (rs, ws)}],
 316                          dstTy, fn dst => (dst, []))
 317                      end
 318                 | (NONE, SOME rs) =>
 319                      let
 320                         val ws = WordSize.fromBits (RealSize.bits rs)
 321                         val tmp = Var.newNoname ()
 322                         val tmpTy = Type.real rs
 323                      in
 324                         (src, srcTy, [],
 325                          Type.word ws,
 326                          fn dst =>
 327                          (Operand.Var {ty = tmpTy, var = tmp},
 328                           [PrimApp {args = Vector.new1 dst,
 329                                     dst = SOME (tmp, tmpTy),
 330                                     prim = Prim.wordCastToReal (ws, rs)}]))
 331                      end
 332                 | (SOME _, SOME _) =>
 333                      (src, srcTy, [], dstTy, fn dst => (dst, []))
 334
 335             val srcW = Type.width srcTy
 336             val dstW = Type.width dstTy
 337
 338             val (dst, ssConv) =
 339                if Bits.equals (srcW, dstW)
 340                   then (Operand.cast (src, dstTy), [])
 341                else let
 342                        val tmp = Var.newNoname ()
 343                        val tmpTy = dstTy
 344                     in
 345                        (Operand.Var {ty = tmpTy, var = tmp},
 346                         [PrimApp {args = Vector.new1 src,
 347                                   dst = SOME (tmp, tmpTy),
 348                                   prim = (Prim.wordExtdToWord
 349                                           (WordSize.fromBits srcW,
 350                                            WordSize.fromBits dstW,
 351                                            {signed = false}))}])
 352                     end
 353
 354             val (dst, ssDst) = finishDst dst
 355          in
 356             (dst, ssSrc @ ssConv @ ssDst)
 357          end
 358    end
 359
 360 datatype z = datatype Statement.t
 361
 362 structure Transfer =
 363    struct
 364       datatype t =
 365          Arith of {args: Operand.t vector,
 366                    dst: Var.t,
 367                    overflow: Label.t,
 368                    prim: Type.t Prim.t,
 369                    success: Label.t,
 370                    ty: Type.t}
 371        | CCall of {args: Operand.t vector,
 372                    func: Type.t CFunction.t,
 373                    return: Label.t option}
 374        | Call of {args: Operand.t vector,
 375                   func: Func.t,
 376                   return: Return.t}
 377        | Goto of {args: Operand.t vector,
 378                   dst: Label.t}
 379        | Raise of Operand.t vector
 380        | Return of Operand.t vector
 381        | Switch of Switch.t
 382
 383       fun layout t =
 384          let
 385             open Layout
 386          in
 387             case t of
 388                Arith {args, dst, overflow, prim, success, ty} =>
 389                   seq [str "Arith ",
 390                        record [("args", Vector.layout Operand.layout args),
 391                                ("dst", Var.layout dst),
 392                                ("overflow", Label.layout overflow),
 393                                ("prim", Prim.layout prim),
 394                                ("success", Label.layout success),
 395                                ("ty", Type.layout ty)]]
 396              | CCall {args, func, return} =>
 397                   seq [str "CCall ",
 398                        record [("args", Vector.layout Operand.layout args),
 399                                ("func", CFunction.layout (func, Type.layout)),
 400                                ("return", Option.layout Label.layout return)]]
 401              | Call {args, func, return} =>
 402                   seq [Func.layout func, str " ",
 403                        Vector.layout Operand.layout args,
 404                        str " ", Return.layout return]
 405              | Goto {dst, args} =>
 406                   seq [Label.layout dst, str " ",
 407                        Vector.layout Operand.layout args]
 408              | Raise xs => seq [str "raise ", Vector.layout Operand.layout xs]
 409              | Return xs => seq [str "return ", Vector.layout Operand.layout xs]
 410              | Switch s => Switch.layout s
 411          end
 412
 413       fun bug () =
 414          CCall {args = (Vector.new1
 415                         (Operand.Const
 416                          (Const.string "control shouldn't reach here"))),
 417                 func = Type.BuiltInCFunction.bug (),
 418                 return = NONE}
 419
 420       fun foreachFunc (t, f : Func.t -> unit) : unit =
 421          case t of
 422             Call {func, ...} => f func
 423           | _ => ()
 424
 425       fun 'a foldDefLabelUse (t, a: 'a,
 426                               {def: Var.t * Type.t * 'a -> 'a,
 427                                label: Label.t * 'a -> 'a,
 428                                use: Var.t * 'a -> 'a}): 'a =
 429          let
 430             fun useOperand (z, a) = Operand.foldVars (z, a, use)
 431             fun useOperands (zs: Operand.t vector, a) =
 432                Vector.fold (zs, a, useOperand)
 433          in
 434             case t of
 435                Arith {args, dst, overflow, success, ty, ...} =>
 436                   let
 437                      val a = label (overflow, a)
 438                      val a = label (success, a)
 439                      val a = def (dst, ty, a)
 440                      val a = useOperands (args, a)
 441                   in
 442                      a
 443                   end
 444              | CCall {args, return, ...} =>
 445                   useOperands (args,
 446                                case return of
 447                                   NONE => a
 448                                 | SOME l => label (l, a))
 449              | Call {args, return, ...} =>
 450                   useOperands (args, Return.foldLabel (return, a, label))
 451              | Goto {args, dst, ...} => label (dst, useOperands (args, a))
 452              | Raise zs => useOperands (zs, a)
 453              | Return zs => useOperands (zs, a)
 454              | Switch s => Switch.foldLabelUse (s, a, {label = label,
 455                                                        use = useOperand})
 456          end
 457
 458       fun foreachDefLabelUse (t, {def, label, use}) =
 459          foldDefLabelUse (t, (), {def = fn (x, t, ()) => def (x, t),
 460                                   label = label o #1,
 461                                   use = use o #1})
 462
 463       fun foldLabel (t, a, f) = foldDefLabelUse (t, a, {def = #3,
 464                                                         label = f,
 465                                                         use = #2})
 466
 467       fun foreachLabel (t, f) = foldLabel (t, (), f o #1)
 468
 469       fun foldDef (t, a, f) = foldDefLabelUse (t, a, {def = f,
 470                                                       label = #2,
 471                                                       use = #2})
 472
 473       fun foreachDef (t, f) =
 474          foldDef (t, (), fn (x, t, ()) => f (x, t))
 475
 476       fun foldUse (t, a, f) = foldDefLabelUse (t, a, {def = #3,
 477                                                       label = #2,
 478                                                       use = f})
 479
 480       fun foreachUse (t, f) = foldUse (t, (), f o #1)
 481
 482       fun clear (t: t): unit =
 483          foreachDef (t, Var.clear o #1)
 484
 485       local
 486          fun make i = WordX.fromIntInf (i, WordSize.bool)
 487       in
 488          fun ifBool (test, {falsee, truee}) =
 489             Switch (Switch.T
 490                     {cases = Vector.new2 ((make 0, falsee), (make 1, truee)),
 491                      default = NONE,
 492                      size = WordSize.bool,
 493                      test = test})
 494          fun ifZero (test, {falsee, truee}) =
 495             Switch (Switch.T
 496                     {cases = Vector.new1 (make 0, truee),
 497                      default = SOME falsee,
 498                      size = WordSize.bool,
 499                      test = test})
 500       end
 501
 502       fun replaceUses (t: t, f: Var.t -> Operand.t): t =
 503          let
 504             fun oper z = Operand.replaceVar (z, f)
 505             fun opers zs = Vector.map (zs, oper)
 506          in
 507             case t of
 508                Arith {args, dst, overflow, prim, success, ty} =>
 509                   Arith {args = opers args,
 510                          dst = dst,
 511                          overflow = overflow,
 512                          prim = prim,
 513                          success = success,
 514                          ty = ty}
 515              | CCall {args, func, return} =>
 516                   CCall {args = opers args,
 517                          func = func,
 518                          return = return}
 519              | Call {args, func, return} =>
 520                   Call {args = opers args,
 521                         func = func,
 522                         return = return}
 523              | Goto {args, dst} =>
 524                   Goto {args = opers args,
 525                         dst = dst}
 526              | Raise zs => Raise (opers zs)
 527              | Return zs => Return (opers zs)
 528              | Switch s => Switch (Switch.replaceVar (s, f))
 529          end
 530    end
 531
 532 structure Kind =
 533    struct
 534       datatype t =
 535          Cont of {handler: Handler.t}
 536        | CReturn of {func: Type.t CFunction.t}
 537        | Handler
 538        | Jump
 539
 540       fun layout k =
 541          let
 542             open Layout
 543          in
 544             case k of
 545                Cont {handler} =>
 546                   seq [str "Cont ",
 547                        record [("handler", Handler.layout handler)]]
 548              | CReturn {func} =>
 549                   seq [str "CReturn ",
 550                        record [("func", CFunction.layout (func, Type.layout))]]
 551              | Handler => str "Handler"
 552              | Jump => str "Jump"
 553          end
 554
 555       datatype frameStyle = None | OffsetsAndSize | SizeOnly
 556       fun frameStyle (k: t): frameStyle =
 557          case k of
 558             Cont _ => OffsetsAndSize
 559           | CReturn {func, ...} =>
 560                if CFunction.mayGC func
 561                   then OffsetsAndSize
 562                else if !Control.profile = Control.ProfileNone
 563                        then None
 564                     else SizeOnly
 565           | Handler => SizeOnly
 566           | Jump => None
 567    end
 568
 569 local
 570    open Layout
 571 in
 572    fun layoutFormals (xts: (Var.t * Type.t) vector) =
 573       Vector.layout (fn (x, t) =>
 574                     seq [Var.layout x,
 575                          if !Control.showTypes
 576                             then seq [str ": ", Type.layout t]
 577                          else empty])
 578       xts
 579 end
 580
 581 structure Block =
 582    struct
 583       datatype t =
 584          T of {args: (Var.t * Type.t) vector,
 585                kind: Kind.t,
 586                label: Label.t,
 587                statements: Statement.t vector,
 588                transfer: Transfer.t}
 589
 590       local
 591          fun make f (T r) = f r
 592       in
 593          val kind = make #kind
 594          val label = make #label
 595       end
 596
 597       fun clear (T {args, label, statements, transfer, ...}) =
 598          (Vector.foreach (args, Var.clear o #1)
 599           ; Label.clear label
 600           ; Vector.foreach (statements, Statement.clear)
 601           ; Transfer.clear transfer)
 602
 603       fun layout (T {args, kind, label, statements, transfer, ...}) =
 604          let
 605             open Layout
 606          in
 607             align [seq [Label.layout label, str " ",
 608                         Vector.layout (fn (x, t) =>
 609                                        if !Control.showTypes
 610                                           then seq [Var.layout x, str ": ",
 611                                                     Type.layout t]
 612                                        else Var.layout x) args,
 613                         str " ", Kind.layout kind, str " = "],
 614                    indent (align
 615                            [align
 616                             (Vector.toListMap (statements, Statement.layout)),
 617                             Transfer.layout transfer],
 618                            2)]
 619          end
 620
 621       fun foreachDef (T {args, statements, transfer, ...}, f) =
 622          (Vector.foreach (args, f)
 623           ; Vector.foreach (statements, fn s => Statement.foreachDef (s, f))
 624           ; Transfer.foreachDef (transfer, f))
 625
 626       fun foreachUse (T {statements, transfer, ...}, f) =
 627          (Vector.foreach (statements, fn s => Statement.foreachUse (s, f))
 628           ; Transfer.foreachUse (transfer, f))
 629    end
 630
 631 structure Function =
 632    struct
 633       datatype t = T of {args: (Var.t * Type.t) vector,
 634                          blocks: Block.t vector,
 635                          name: Func.t,
 636                          raises: Type.t vector option,
 637                          returns: Type.t vector option,
 638                          start: Label.t}
 639
 640       local
 641          fun make f (T r) = f r
 642       in
 643          val blocks = make #blocks
 644          val name = make #name
 645       end
 646
 647       fun dest (T r) = r
 648       val new = T
 649
 650       fun clear (T {name, args, blocks, ...}) =
 651          (Func.clear name
 652           ; Vector.foreach (args, Var.clear o #1)
 653           ; Vector.foreach (blocks, Block.clear))
 654
 655       fun layoutHeader (T {args, name, raises, returns, start, ...}): Layout.t =
 656          let
 657             open Layout
 658          in
 659             seq [str "fun ", Func.layout name,
 660                  str " ", layoutFormals args,
 661                  if !Control.showTypes
 662                     then seq [str ": ",
 663                               record [("raises",
 664                                        Option.layout
 665                                        (Vector.layout Type.layout) raises),
 666                                       ("returns",
 667                                        Option.layout
 668                                        (Vector.layout Type.layout) returns)]]
 669                  else empty,
 670                  str " = ", Label.layout start, str " ()"]
 671          end
 672
 673       fun layouts (f as T {blocks, ...}, output) =
 674          (output (layoutHeader f)
 675           ; Vector.foreach (blocks, fn b =>
 676                             output (Layout.indent (Block.layout b, 2))))
 677
 678       fun layout (f as T {blocks, ...}) =
 679          let
 680             open Layout
 681          in
 682             align [layoutHeader f,
 683                    indent (align (Vector.toListMap (blocks, Block.layout)), 2)]
 684          end
 685
 686       fun foreachDef (T {args, blocks, ...}, f) =
 687          (Vector.foreach (args, f)
 688           ; (Vector.foreach (blocks, fn b => Block.foreachDef (b, f))))
 689
 690       fun foreachUse (T {blocks, ...}, f) =
 691          Vector.foreach (blocks, fn b => Block.foreachUse (b, f))
 692
 693       fun dfs (T {blocks, start, ...}, v) =
 694          let
 695             val numBlocks = Vector.length blocks
 696             val {get = labelIndex, set = setLabelIndex, rem, ...} =
 697                Property.getSetOnce (Label.plist,
 698                                     Property.initRaise ("index", Label.layout))
 699             val _ = Vector.foreachi (blocks, fn (i, Block.T {label, ...}) =>
 700                                      setLabelIndex (label, i))
 701             val visited = Array.array (numBlocks, false)
 702             fun visit (l: Label.t): unit =
 703                let
 704                   val i = labelIndex l
 705                in
 706                   if Array.sub (visited, i)
 707                      then ()
 708                   else
 709                      let
 710                         val _ = Array.update (visited, i, true)
 711                         val b as Block.T {transfer, ...} =
 712                            Vector.sub (blocks, i)
 713                         val v' = v b
 714                         val _ = Transfer.foreachLabel (transfer, visit)
 715                         val _ = v' ()
 716                      in
 717                         ()
 718                      end
 719                end
 720             val _ = visit start
 721             val _ = Vector.foreach (blocks, rem o Block.label)
 722          in
 723             ()
 724          end
 725
 726       structure Graph = DirectedGraph
 727       structure Node = Graph.Node
 728
 729       fun dominatorTree (T {blocks, start, ...}): Block.t Tree.t =
 730          let
 731             open Dot
 732             val g = Graph.new ()
 733             fun newNode () = Graph.newNode g
 734             val {get = labelNode, ...} =
 735                Property.get
 736                (Label.plist, Property.initFun (fn _ => newNode ()))
 737             val {get = nodeInfo: unit Node.t -> {block: Block.t},
 738                  set = setNodeInfo, ...} =
 739                Property.getSetOnce
 740                (Node.plist, Property.initRaise ("info", Node.layout))
 741             val () =
 742                Vector.foreach
 743                (blocks, fn b as Block.T {label, ...}=>
 744                 setNodeInfo (labelNode label, {block = b}))
 745             val () =
 746                Vector.foreach
 747                (blocks, fn Block.T {label, transfer, ...} =>
 748                 let
 749                    val from = labelNode label
 750                    val _ =
 751                       Transfer.foreachLabel
 752                       (transfer, fn to =>
 753                        (ignore o Graph.addEdge)
 754                        (g, {from = from, to = labelNode to}))
 755                 in
 756                    ()
 757                 end)
 758          in
 759             Graph.dominatorTree (g, {root = labelNode start,
 760                                      nodeValue = #block o nodeInfo})
 761          end
 762
 763       fun dropProfile (f: t): t =
 764          let
 765             val {args, blocks, name, raises, returns, start} = dest f
 766             val blocks =
 767                Vector.map
 768                (blocks, fn Block.T {args, kind, label, statements, transfer} =>
 769                 Block.T {args = args,
 770                          kind = kind,
 771                          label = label,
 772                          statements = Vector.keepAll
 773                                       (statements,
 774                                        fn Statement.Profile _ => false
 775                                         | Statement.ProfileLabel _ => false
 776                                         | _ => true),
 777                          transfer = transfer})
 778          in
 779             new {args = args,
 780                  blocks = blocks,
 781                  name = name,
 782                  raises = raises,
 783                  returns = returns,
 784                  start = start}
 785          end
 786
 787       fun shrink (f: t): t =
 788          let
 789             val {args, blocks, name, raises, returns, start} = dest f
 790             val {get = labelInfo, rem, set = setLabelInfo, ...} =
 791                Property.getSetOnce
 792                (Label.plist, Property.initRaise ("info", Label.layout))
 793             val () =
 794                Vector.foreach
 795                (blocks, fn block as Block.T {label, ...} =>
 796                 setLabelInfo (label, {block = block,
 797                                       inline = ref false,
 798                                       occurrences = ref 0}))
 799             fun visitLabel l = Int.inc (#occurrences (labelInfo l))
 800             val () = visitLabel start
 801             val () =
 802                Vector.foreach (blocks, fn Block.T {transfer, ...} =>
 803                                Transfer.foreachLabel (transfer, visitLabel))
 804             datatype z = datatype Statement.t
 805             datatype z = datatype Transfer.t
 806             val () =
 807                Vector.foreach
 808                (blocks, fn Block.T {transfer, ...} =>
 809                 case transfer of
 810                    Goto {dst, ...} =>
 811                       let
 812                          val {inline, occurrences, ...} = labelInfo dst
 813                       in
 814                          if 1 = !occurrences
 815                             then inline := true
 816                          else ()
 817                       end
 818                  | _ => ())
 819             fun expand (ss: Statement.t vector list, t: Transfer.t)
 820                : Statement.t vector * Transfer.t =
 821                let
 822                   fun done () = (Vector.concat (rev ss), t)
 823                in
 824                   case t of
 825                      Goto {args, dst} =>
 826                         let
 827                            val {block, inline, ...} = labelInfo dst
 828                         in
 829                            if not (!inline)
 830                               then done ()
 831                            else
 832                               let
 833                                  val Block.T {args = formals, statements,
 834                                               transfer, ...} =
 835                                     block
 836                                  val binds =
 837                                     Vector.map2
 838                                     (formals, args, fn (dst, src) =>
 839                                      Bind {dst = dst,
 840                                            isMutable = false,
 841                                            src = src})
 842                               in
 843                                  expand (statements :: binds :: ss, transfer)
 844                               end
 845                         end
 846                    | _ => done ()
 847                end
 848             val blocks =
 849                Vector.fromList
 850                (Vector.fold
 851                 (blocks, [],
 852                  fn (Block.T {args, kind, label, statements, transfer}, ac) =>
 853                  let
 854                     val {inline, ...} = labelInfo label
 855                  in
 856                     if !inline
 857                        then ac
 858                     else
 859                        let
 860                           val (statements, transfer) =
 861                              expand ([statements], transfer)
 862                        in
 863                           Block.T {args = args,
 864                                    kind = kind,
 865                                    label = label,
 866                                    statements = statements,
 867                                    transfer = transfer} :: ac
 868                        end
 869                  end))
 870             val () = Vector.foreach (blocks, rem o Block.label)
 871          in
 872             new {args = args,
 873                  blocks = blocks,
 874                  name = name,
 875                  raises = raises,
 876                  returns = returns,
 877                  start = start}
 878          end
 879    end
 880
 881 structure Program =
 882    struct
 883       datatype t =
 884          T of {functions: Function.t list,
 885                handlesSignals: bool,
 886                main: Function.t,
 887                objectTypes: ObjectType.t vector}
 888
 889       fun clear (T {functions, main, ...}) =
 890          (List.foreach (functions, Function.clear)
 891           ; Function.clear main)
 892
 893       fun layouts (T {functions, main, objectTypes, ...},
 894                    output': Layout.t -> unit): unit =
 895          let
 896             open Layout
 897             val output = output'
 898          in
 899             output (str "\nObjectTypes:")
 900             ; Vector.foreachi (objectTypes, fn (i, ty) =>
 901                                output (seq [str "opt_", Int.layout i,
 902                                             str " = ", ObjectType.layout ty]))
 903             ; output (str "\nMain:")
 904             ; Function.layouts (main, output)
 905             ; output (str "\nFunctions:")
 906             ; List.foreach (functions, fn f => Function.layouts (f, output))
 907          end
 908
 909       fun layoutStats (T {functions, main, objectTypes, ...}) =
 910          let
 911             val numStatements = ref 0
 912             val numBlocks = ref 0
 913             val _ =
 914                List.foreach
 915                (main::functions, fn f =>
 916                 let
 917                    val {blocks, ...} = Function.dest f
 918                 in
 919                    Vector.foreach
 920                    (blocks, fn Block.T {statements, ...} =>
 921                     (Int.inc numBlocks
 922                      ; numStatements := !numStatements + Vector.length statements))
 923                 end)
 924             val numFunctions = 1 + List.length functions
 925             val numObjectTypes = Vector.length objectTypes
 926             open Layout
 927          in
 928             align
 929             [seq [str "num functions in program = ", Int.layout numFunctions],
 930              seq [str "num blocks in program = ", Int.layout (!numBlocks)],
 931              seq [str "num statements in program = ", Int.layout (!numStatements)],
 932              seq [str "num object types in program = ", Int.layout (numObjectTypes)]]
 933          end
 934
 935       fun dropProfile (T {functions, handlesSignals, main, objectTypes}) =
 936          (Control.profile := Control.ProfileNone
 937           ; T {functions = List.map (functions, Function.dropProfile),
 938                handlesSignals = handlesSignals,
 939                main = Function.dropProfile main,
 940                objectTypes = objectTypes})
 941       (* quell unused warning *)
 942       val _ = dropProfile
 943
 944       fun dfs (p, v) =
 945          let
 946             val T {functions, main, ...} = p
 947             val functions = Vector.fromList (main::functions)
 948             val numFunctions = Vector.length functions
 949             val {get = funcIndex, set = setFuncIndex, rem, ...} =
 950                Property.getSetOnce (Func.plist,
 951                                     Property.initRaise ("index", Func.layout))
 952             val _ = Vector.foreachi (functions, fn (i, f) =>
 953                                      setFuncIndex (#name (Function.dest f), i))
 954             val visited = Array.array (numFunctions, false)
 955             fun visit (f: Func.t): unit =
 956                let
 957                   val i = funcIndex f
 958                in
 959                   if Array.sub (visited, i)
 960                      then ()
 961                   else
 962                      let
 963                         val _ = Array.update (visited, i, true)
 964                         val f = Vector.sub (functions, i)
 965                         val v' = v f
 966                         val _ = Function.dfs
 967                                 (f, fn Block.T {transfer, ...} =>
 968                                  (Transfer.foreachFunc (transfer, visit)
 969                                   ; fn () => ()))
 970                         val _ = v' ()
 971                      in
 972                         ()
 973                      end
 974                end
 975             val _ = visit (Function.name main)
 976             val _ = Vector.foreach (functions, rem o Function.name)
 977          in
 978             ()
 979          end
 980
 981       fun orderFunctions (p as T {handlesSignals, objectTypes, ...}) =
 982          let
 983             val functions = ref []
 984             val () =
 985                dfs
 986                (p, fn f =>
 987                 let
 988                    val {args, name, raises, returns, start, ...} =
 989                       Function.dest f
 990                    val blocks = ref []
 991                    val () =
 992                       Function.dfs
 993                       (f, fn b =>
 994                        (List.push (blocks, b)
 995                         ; fn () => ()))
 996                    val f = Function.new {args = args,
 997                                          blocks = Vector.fromListRev (!blocks),
 998                                          name = name,
 999                                          raises = raises,
1000                                          returns = returns,
1001                                          start = start}
1002                 in
1003                    List.push (functions, f)
1004                    ; fn () => ()
1005                 end)
1006             val (main, functions) =
1007                case List.rev (!functions) of
1008                   main::functions => (main, functions)
1009                 | _ => Error.bug "Rssa.orderFunctions: main/functions"
1010          in
1011             T {functions = functions,
1012                handlesSignals = handlesSignals,
1013                main = main,
1014                objectTypes = objectTypes}
1015          end
1016
1017       fun copyProp (T {functions, handlesSignals, main, objectTypes, ...}): t =
1018          let
1019             val tracePrimApply =
1020                Trace.trace3
1021                ("Rssa.copyProp.primApply",
1022                 Prim.layout,
1023                 List.layout (ApplyArg.layout (Var.layout o #var)),
1024                 Layout.ignore,
1025                 ApplyResult.layout (Var.layout o #var))
1026             val {get = replaceVar: Var.t -> Operand.t,
1027                  set = setReplaceVar, ...} =
1028                Property.getSetOnce
1029                (Var.plist, Property.initRaise ("replacement", Var.layout))
1030             fun dontReplace (x: Var.t, t: Type.t): unit =
1031                setReplaceVar (x, Operand.Var {var = x, ty = t})
1032             val setReplaceVar = fn (x: Var.t, t: Type.t, z: Operand.t) =>
1033                let
1034                   val z =
1035                      if Type.equals (Operand.ty z, t)
1036                         then z
1037                         else Operand.Cast (z, t)
1038                in
1039                   setReplaceVar (x, z)
1040                end
1041             fun loopStatement (s: Statement.t): Statement.t option =
1042                let
1043                   val s = Statement.replaceUses (s, replaceVar)
1044                   fun keep () =
1045                      (Statement.foreachDef (s, dontReplace)
1046                       ; SOME s)
1047                in
1048                   case s of
1049                      Bind {dst = (dst, dstTy), isMutable, src} =>
1050                         if isMutable
1051                            then keep ()
1052                         else
1053                            let
1054                               datatype z = datatype Operand.t
1055                               fun getSrc src =
1056                                  case src of
1057                                     Cast (src, _) => getSrc src
1058                                   | Const _ => SOME src
1059                                   | Var _ => SOME src
1060                                   | _ => NONE
1061                            in
1062                               case getSrc src of
1063                                  NONE => keep ()
1064                                | SOME src =>
1065                                     (setReplaceVar (dst, dstTy, src)
1066                                      ; NONE)
1067                            end
1068                    | PrimApp {args, dst, prim} =>
1069                         let
1070                            fun replace (z: Operand.t): Statement.t option =
1071                               (Option.app (dst, fn (x, t) =>
1072                                            setReplaceVar (x, t, z))
1073                                ; NONE)
1074                            datatype z = datatype Operand.t
1075                            fun getArg arg =
1076                               case arg of
1077                                  Cast (arg, _) => getArg arg
1078                                | Const c => SOME (ApplyArg.Const c)
1079                                | Var x => SOME (ApplyArg.Var x)
1080                                | _ => NONE
1081                            val applyArgs = Vector.keepAllMap (args, getArg)
1082                            datatype z = datatype ApplyResult.t
1083                         in
1084                            if Vector.length args <> Vector.length applyArgs
1085                               then keep ()
1086                            else
1087                               case (tracePrimApply
1088                                     Prim.apply
1089                                     (prim, Vector.toList applyArgs,
1090                                      fn ({var = x, ...}, {var = y, ...}) =>
1091                                      Var.equals (x, y))) of
1092                                  Apply (prim, args) =>
1093                                     let
1094                                        val args =
1095                                           Vector.fromListMap (args, Operand.Var)
1096                                        val () = Option.app (dst, dontReplace)
1097                                     in
1098                                        SOME (PrimApp {args = args,
1099                                                       dst = dst,
1100                                                       prim = prim})
1101                                     end
1102                                | Bool b => replace (Operand.bool b)
1103                                | Const c => replace (Operand.Const c)
1104                                | Overflow => keep ()
1105                                | Unknown => keep ()
1106                                | Var x => replace (Operand.Var x)
1107                         end
1108                 | _ => keep ()
1109                end
1110             fun loopTransfer t =
1111                (Transfer.foreachDef (t, dontReplace)
1112                 ; Transfer.replaceUses (t, replaceVar))
1113             fun loopFormals args = Vector.foreach (args, dontReplace)
1114             fun loopFunction (f: Function.t): Function.t =
1115                let
1116                   val {args, name, raises, returns, start, ...} =
1117                      Function.dest f
1118                   val () = loopFormals args
1119                   val blocks = ref []
1120                   val () =
1121                      Function.dfs
1122                      (f, fn Block.T {args, kind, label, statements, transfer} =>
1123                       let
1124                          val () = loopFormals args
1125                          val statements =
1126                             Vector.keepAllMap (statements, loopStatement)
1127                          val transfer = loopTransfer transfer
1128                          val () =
1129                             List.push
1130                             (blocks, Block.T {args = args,
1131                                               kind = kind,
1132                                               label = label,
1133                                               statements = statements,
1134                                               transfer = transfer})
1135                       in
1136                          fn () => ()
1137                       end)
1138                   val blocks = Vector.fromList (!blocks)
1139                in
1140                   Function.new {args = args,
1141                                 blocks = blocks,
1142                                 name = name,
1143                                 raises = raises,
1144                                 returns = returns,
1145                                 start = start}
1146                end
1147             (* Must process main first, because it defines globals that are
1148              * used in other functions.
1149              *)
1150             val main = loopFunction main
1151             val functions = List.revMap (functions, loopFunction)
1152          in
1153             T {functions = functions,
1154                handlesSignals = handlesSignals,
1155                main = main,
1156                objectTypes = objectTypes}
1157          end
1158
1159       fun shrink (T {functions, handlesSignals, main, objectTypes}) =
1160          let
1161             val p =
1162                T {functions = List.revMap (functions, Function.shrink),
1163                   handlesSignals = handlesSignals,
1164                   main = Function.shrink main,
1165                   objectTypes = objectTypes}
1166             val p = copyProp p
1167             val () = clear p
1168          in
1169             p
1170          end
1171
1172       structure ExnStack =
1173          struct
1174             structure ZPoint =
1175                struct
1176                   datatype t = Caller | Me
1177
1178                   val equals: t * t -> bool = op =
1179
1180                   val toString =
1181                      fn Caller => "Caller"
1182                       | Me => "Me"
1183
1184                   val layout = Layout.str o toString
1185                end
1186
1187             structure L = FlatLattice (structure Point = ZPoint)
1188             open L
1189             structure Point = ZPoint
1190
1191             val me = point Point.Me
1192          end
1193
1194       structure HandlerLat = FlatLattice (structure Point = Label)
1195
1196       structure HandlerInfo =
1197          struct
1198             datatype t = T of {block: Block.t,
1199                                global: ExnStack.t,
1200                                handler: HandlerLat.t,
1201                                slot: ExnStack.t,
1202                                visited: bool ref}
1203
1204             fun new (b: Block.t): t =
1205                T {block = b,
1206                   global = ExnStack.new (),
1207                   handler = HandlerLat.new (),
1208                   slot = ExnStack.new (),
1209                   visited = ref false}
1210
1211             fun layout (T {global, handler, slot, ...}) =
1212                Layout.record [("global", ExnStack.layout global),
1213                               ("slot", ExnStack.layout slot),
1214                               ("handler", HandlerLat.layout handler)]
1215          end
1216
1217       val traceGoto =
1218          Trace.trace ("Rssa.checkHandlers.goto", Label.layout, Unit.layout)
1219
1220       fun checkHandlers (T {functions, ...}) =
1221          let
1222             val debug = false
1223             fun checkFunction (f: Function.t): unit =
1224                let
1225                   val {name, start, blocks, ...} = Function.dest f
1226                   val {get = labelInfo: Label.t -> HandlerInfo.t,
1227                        rem = remLabelInfo,
1228                        set = setLabelInfo} =
1229                      Property.getSetOnce
1230                      (Label.plist, Property.initRaise ("info", Label.layout))
1231                   val _ =
1232                      Vector.foreach
1233                      (blocks, fn b =>
1234                       setLabelInfo (Block.label b, HandlerInfo.new b))
1235                   (* Do a DFS of the control-flow graph. *)
1236                   fun visitLabel l = visitInfo (labelInfo l)
1237                   and visitInfo
1238                      (hi as HandlerInfo.T {block, global, handler, slot,
1239                                            visited, ...}): unit =
1240                      if !visited
1241                         then ()
1242                      else
1243                         let
1244                            val _ = visited := true
1245                            val Block.T {label, statements, transfer, ...} = block
1246                            val _ =
1247                               if debug
1248                                  then
1249                                     let
1250                                        open Layout
1251                                     in
1252                                        outputl
1253                                        (seq [str "visiting ",
1254                                              Label.layout label],
1255                                         Out.error)
1256                                     end
1257                               else ()
1258                            datatype z = datatype Statement.t
1259                            val {global, handler, slot} =
1260                               Vector.fold
1261                               (statements,
1262                                {global = global, handler = handler, slot = slot},
1263                                fn (s, {global, handler, slot}) =>
1264                                case s of
1265                                   SetExnStackLocal => {global = ExnStack.me,
1266                                                        handler = handler,
1267                                                        slot = slot}
1268                                 | SetExnStackSlot => {global = slot,
1269                                                       handler = handler,
1270                                                       slot = slot}
1271                                 | SetSlotExnStack => {global = global,
1272                                                       handler = handler,
1273                                                       slot = global}
1274                                 | SetHandler l => {global = global,
1275                                                    handler = HandlerLat.point l,
1276                                                    slot = slot}
1277                                 | _ => {global = global,
1278                                         handler = handler,
1279                                         slot = slot})
1280                            fun fail msg =
1281                               (Control.message
1282                                (Control.Silent, fn () =>
1283                                 let open Layout
1284                                 in align
1285                                    [str "before: ", HandlerInfo.layout hi,
1286                                     str "block: ", Block.layout block,
1287                                     seq [str "after: ",
1288                                          Layout.record
1289                                          [("global", ExnStack.layout global),
1290                                           ("slot", ExnStack.layout slot),
1291                                           ("handler",
1292                                            HandlerLat.layout handler)]],
1293                                     Vector.layout
1294                                     (fn Block.T {label, ...} =>
1295                                      seq [Label.layout label,
1296                                           str " ",
1297                                           HandlerInfo.layout (labelInfo label)])
1298                                     blocks]
1299                                 end)
1300                                ; Error.bug (concat ["Rssa.checkHandlers: handler mismatch at ", msg]))
1301                            fun assert (msg, f) =
1302                               if f
1303                                  then ()
1304                               else fail msg
1305                            fun goto (l: Label.t): unit =
1306                               let
1307                                  val HandlerInfo.T {global = g, handler = h,
1308                                                     slot = s, ...} =
1309                                     labelInfo l
1310                                  val _ =
1311                                     assert ("goto",
1312                                             ExnStack.<= (global, g)
1313                                             andalso ExnStack.<= (slot, s)
1314                                             andalso HandlerLat.<= (handler, h))
1315                               in
1316                                  visitLabel l
1317                               end
1318                            val goto = traceGoto goto
1319                            fun tail name =
1320                               assert (name,
1321                                       ExnStack.forcePoint
1322                                       (global, ExnStack.Point.Caller))
1323                            datatype z = datatype Transfer.t
1324                         in
1325                            case transfer of
1326                               Arith {overflow, success, ...} =>
1327                                  (goto overflow; goto success)
1328                             | CCall {return, ...} => Option.app (return, goto)
1329                             | Call {return, ...} =>
1330                                  assert
1331                                  ("return",
1332                                   let
1333                                      datatype z = datatype Return.t
1334                                   in
1335                                      case return of
1336                                         Dead => true
1337                                       | NonTail {handler = h, ...} =>
1338                                            (case h of
1339                                                Handler.Caller =>
1340                                                   ExnStack.forcePoint
1341                                                   (global, ExnStack.Point.Caller)
1342                                              | Handler.Dead => true
1343                                              | Handler.Handle l =>
1344                                                   let
1345                                                      val res =
1346                                                         ExnStack.forcePoint
1347                                                         (global,
1348                                                          ExnStack.Point.Me)
1349                                                         andalso
1350                                                         HandlerLat.forcePoint
1351                                                         (handler, l)
1352                                                      val _ = goto l
1353                                                   in
1354                                                      res
1355                                                   end)
1356                                       | Tail => true
1357                                   end)
1358                             | Goto {dst, ...} => goto dst
1359                             | Raise _ => tail "raise"
1360                             | Return _ => tail "return"
1361                             | Switch s => Switch.foreachLabel (s, goto)
1362                         end
1363                   val info as HandlerInfo.T {global, ...} = labelInfo start
1364                   val _ = ExnStack.forcePoint (global, ExnStack.Point.Caller)
1365                   val _ = visitInfo info
1366                   val _ =
1367                      Control.diagnostics
1368                      (fn display =>
1369                       let
1370                          open Layout
1371                          val _ =
1372                             display (seq [str "checkHandlers ",
1373                                           Func.layout name])
1374                          val _ =
1375                             Vector.foreach
1376                             (blocks, fn Block.T {label, ...} =>
1377                              display (seq
1378                                       [Label.layout label,
1379                                        str " ",
1380                                        HandlerInfo.layout (labelInfo label)]))
1381                       in
1382                          ()
1383                       end)
1384                   val _ = Vector.foreach (blocks, fn b =>
1385                                           remLabelInfo (Block.label b))
1386                in
1387                   ()
1388                end
1389             val _ = List.foreach (functions, checkFunction)
1390          in
1391             ()
1392          end
1393
1394       fun checkScopes (program as T {functions, main, ...}): unit =
1395          let
1396             datatype status =
1397                Defined
1398              | Global
1399              | InScope
1400              | Undefined
1401             fun make (layout, plist) =
1402                let
1403                   val {get, set, ...} =
1404                      Property.getSet (plist, Property.initConst Undefined)
1405                   fun bind (x, isGlobal) =
1406                      case get x of
1407                         Global => ()
1408                       | Undefined =>
1409                            set (x, if isGlobal then Global else InScope)
1410                       | _ => Error.bug ("Rssa.checkScopes: duplicate definition of "
1411                                         ^ (Layout.toString (layout x)))
1412                   fun reference x =
1413                      case get x of
1414                         Global => ()
1415                       | InScope => ()
1416                       | _ => Error.bug (concat
1417                                         ["Rssa.checkScopes: reference to ",
1418                                          Layout.toString (layout x),
1419                                          " not in scope"])
1420                   fun unbind x =
1421                      case get x of
1422                         Global => ()
1423                       | _ => set (x, Defined)
1424                in (bind, reference, unbind)
1425                end
1426             val (bindVar, getVar, unbindVar) = make (Var.layout, Var.plist)
1427             val bindVar =
1428                Trace.trace2
1429                ("Rssa.bindVar", Var.layout, Bool.layout, Unit.layout)
1430                bindVar
1431             val getVar =
1432                Trace.trace ("Rssa.getVar", Var.layout, Unit.layout) getVar
1433             val unbindVar =
1434                Trace.trace ("Rssa.unbindVar", Var.layout, Unit.layout) unbindVar
1435             val (bindFunc, _, _) = make (Func.layout, Func.plist)
1436             val bindFunc = fn f => bindFunc (f, false)
1437             val (bindLabel, getLabel, unbindLabel) =
1438                make (Label.layout, Label.plist)
1439             val bindLabel = fn l => bindLabel (l, false)
1440             fun loopFunc (f: Function.t, isMain: bool): unit =
1441                let
1442                   val bindVar = fn x => bindVar (x, isMain)
1443                   val {args, blocks, ...} = Function.dest f
1444                   val _ = Vector.foreach (args, bindVar o #1)
1445                   val _ = Vector.foreach (blocks, bindLabel o Block.label)
1446                   val _ =
1447                      Vector.foreach
1448                      (blocks, fn Block.T {transfer, ...} =>
1449                       Transfer.foreachLabel (transfer, getLabel))
1450                   (* Descend the dominator tree, verifying that variable
1451                    * definitions dominate variable uses.
1452                    *)
1453                   val _ =
1454                      Tree.traverse
1455                      (Function.dominatorTree f,
1456                       fn Block.T {args, statements, transfer, ...} =>
1457                       let
1458                          val _ = Vector.foreach (args, bindVar o #1)
1459                          val _ =
1460                             Vector.foreach
1461                             (statements, fn s =>
1462                              (Statement.foreachUse (s, getVar)
1463                               ; Statement.foreachDef (s, bindVar o #1)))
1464                          val _ = Transfer.foreachUse (transfer, getVar)
1465                          val _ = Transfer.foreachDef (transfer, bindVar o #1)
1466                       in
1467                          fn () =>
1468                          if isMain
1469                             then ()
1470                          else
1471                             let
1472                                val _ =
1473                                   Vector.foreach
1474                                   (statements, fn s =>
1475                                    Statement.foreachDef (s, unbindVar o #1))
1476                                val _ =
1477                                   Transfer.foreachDef (transfer, unbindVar o #1)
1478                                val _ = Vector.foreach (args, unbindVar o #1)
1479                             in
1480                                ()
1481                             end
1482                       end)
1483                   val _ = Vector.foreach (blocks, unbindLabel o Block.label)
1484                   val _ = Vector.foreach (args, unbindVar o #1)
1485                in
1486                   ()
1487                end
1488             val _ = List.foreach (functions, bindFunc o Function.name)
1489             val _ = loopFunc (main, true)
1490             val _ = List.foreach (functions, fn f => loopFunc (f, false))
1491             val _ = clear program
1492          in ()
1493          end
1494
1495       fun typeCheck (p as T {functions, main, objectTypes, ...}) =
1496          let
1497             val _ =
1498                Vector.foreach
1499                (objectTypes, fn ty =>
1500                 Err.check ("objectType",
1501                            fn () => ObjectType.isOk ty,
1502                            fn () => ObjectType.layout ty))
1503             fun tyconTy (opt: ObjptrTycon.t): ObjectType.t =
1504                Vector.sub (objectTypes, ObjptrTycon.index opt)
1505             val () = checkScopes p
1506             val {get = labelBlock: Label.t -> Block.t,
1507                  set = setLabelBlock, ...} =
1508                Property.getSetOnce (Label.plist,
1509                                     Property.initRaise ("block", Label.layout))
1510             val {get = funcInfo, set = setFuncInfo, ...} =
1511                Property.getSetOnce (Func.plist,
1512                                     Property.initRaise ("info", Func.layout))
1513             val {get = varType: Var.t -> Type.t, set = setVarType, ...} =
1514                Property.getSetOnce (Var.plist,
1515                                     Property.initRaise ("type", Var.layout))
1516             val setVarType =
1517                Trace.trace2 ("Rssa.setVarType", Var.layout, Type.layout,
1518                              Unit.layout)
1519                setVarType
1520             fun checkOperand (x: Operand.t): unit =
1521                 let
1522                    datatype z = datatype Operand.t
1523                    fun ok () =
1524                       case x of
1525                          ArrayOffset {base, index, offset, scale, ty} =>
1526                             (checkOperand base
1527                              ; checkOperand index
1528                              ; Type.arrayOffsetIsOk {base = Operand.ty base,
1529                                                      index = Operand.ty index,
1530                                                      offset = offset,
1531                                                      tyconTy = tyconTy,
1532                                                      result = ty,
1533                                                      scale = scale})
1534                        | Cast (z, ty) =>
1535                             (checkOperand z
1536                             ; Type.castIsOk {from = Operand.ty z,
1537                                              to = ty,
1538                                              tyconTy = tyconTy})
1539                        | Const _ => true
1540                        | EnsuresBytesFree => true
1541                        | GCState => true
1542                        | Offset {base, offset, ty} =>
1543                             Type.offsetIsOk {base = Operand.ty base,
1544                                              offset = offset,
1545                                              tyconTy = tyconTy,
1546                                              result = ty}
1547                        | ObjptrTycon _ => true
1548                        | Runtime _ => true
1549                        | Var {ty, var} => Type.isSubtype (varType var, ty)
1550                 in
1551                    Err.check ("operand", ok, fn () => Operand.layout x)
1552                 end
1553             val checkOperand =
1554                Trace.trace ("Rssa.checkOperand", Operand.layout, Unit.layout)
1555                checkOperand
1556             fun checkOperands v = Vector.foreach (v, checkOperand)
1557             fun check' (x, name, isOk, layout) =
1558                Err.check (name, fn () => isOk x, fn () => layout x)
1559             val labelKind = Block.kind o labelBlock
1560             fun statementOk (s: Statement.t): bool =
1561                let
1562                   datatype z = datatype Statement.t
1563                in
1564                   case s of
1565                      Bind {src, dst = (_, dstTy), ...} =>
1566                         (checkOperand src
1567                          ; Type.isSubtype (Operand.ty src, dstTy))
1568                    | Move {dst, src} =>
1569                         (checkOperand dst
1570                          ; checkOperand src
1571                          ; (Type.isSubtype (Operand.ty src, Operand.ty dst)
1572                             andalso Operand.isLocation dst))
1573                    | Object {dst = (_, ty), header, size} =>
1574                         let
1575                            val tycon =
1576                               ObjptrTycon.fromIndex
1577                               (Runtime.headerToTypeIndex header)
1578                         in
1579                            Type.isSubtype (Type.objptr tycon, ty)
1580                            andalso
1581                            Bytes.equals
1582                            (size,
1583                             Bytes.align
1584                             (size,
1585                              {alignment = (case !Control.align of
1586                                                Control.Align4 => Bytes.inWord32
1587                                              | Control.Align8 => Bytes.inWord64)}))
1588                            andalso
1589                            (case tyconTy tycon of
1590                                ObjectType.Normal {ty, ...} =>
1591                                   Bytes.equals
1592                                   (size, Bytes.+ (Runtime.normalMetaDataSize (),
1593                                                   Type.bytes ty))
1594                               | _ => false)
1595                         end
1596                    | PrimApp {args, dst, prim} =>
1597                         (Vector.foreach (args, checkOperand)
1598                          ; (Type.checkPrimApp
1599                             {args = Vector.map (args, Operand.ty),
1600                              prim = prim,
1601                              result = Option.map (dst, #2)}))
1602                    | Profile _ => true
1603                    | ProfileLabel _ => true
1604                    | SetExnStackLocal => true
1605                    | SetExnStackSlot => true
1606                    | SetHandler l =>
1607                         (case labelKind l of
1608                             Kind.Handler => true
1609                           | _ => false)
1610                    | SetSlotExnStack => true
1611                end
1612             val statementOk =
1613                Trace.trace ("Rssa.statementOk",
1614                             Statement.layout,
1615                             Bool.layout)
1616                            statementOk
1617             fun gotoOk {args: Type.t vector,
1618                         dst: Label.t}: bool =
1619                let
1620                   val Block.T {args = formals, kind, ...} = labelBlock dst
1621                in
1622                   Vector.equals (args, formals, fn (t, (_, t')) =>
1623                                  Type.isSubtype (t, t'))
1624                   andalso (case kind of
1625                               Kind.Jump => true
1626                             | _ => false)
1627                end
1628             fun labelIsNullaryJump l = gotoOk {dst = l, args = Vector.new0 ()}
1629             fun tailIsOk (caller: Type.t vector option,
1630                           callee: Type.t vector option): bool =
1631                case (caller, callee) of
1632                   (_, NONE) => true
1633                 | (SOME caller, SOME callee) =>
1634                      Vector.equals (callee, caller, Type.isSubtype)
1635                 | _ => false
1636             fun nonTailIsOk (formals: (Var.t * Type.t) vector,
1637                              returns: Type.t vector option): bool =
1638                case returns of
1639                   NONE => true
1640                 | SOME ts =>
1641                      Vector.equals (formals, ts, fn ((_, t), t') =>
1642                                     Type.isSubtype (t', t))
1643             fun callIsOk {args, func, raises, return, returns} =
1644                let
1645                   val Function.T {args = formals,
1646                                   raises = raises',
1647                                   returns = returns', ...} =
1648                      funcInfo func
1649
1650                in
1651                   Vector.equals (args, formals, fn (z, (_, t)) =>
1652                                  Type.isSubtype (Operand.ty z, t))
1653                   andalso
1654                   (case return of
1655                       Return.Dead =>
1656                          Option.isNone raises'
1657                          andalso Option.isNone returns'
1658                     | Return.NonTail {cont, handler} =>
1659                          let
1660                             val Block.T {args = cArgs, kind = cKind, ...} =
1661                                labelBlock cont
1662                          in
1663                             nonTailIsOk (cArgs, returns')
1664                             andalso
1665                             (case cKind of
1666                                 Kind.Cont {handler = h} =>
1667                                    Handler.equals (handler, h)
1668                                    andalso
1669                                    (case h of
1670                                        Handler.Caller =>
1671                                           tailIsOk (raises, raises')
1672                                      | Handler.Dead => true
1673                                      | Handler.Handle l =>
1674                                           let
1675                                              val Block.T {args = hArgs,
1676                                                           kind = hKind, ...} =
1677                                                 labelBlock l
1678                                           in
1679                                              nonTailIsOk (hArgs, raises')
1680                                              andalso
1681                                              (case hKind of
1682                                                  Kind.Handler => true
1683                                                | _ => false)
1684                                           end)
1685                               | _ => false)
1686                          end
1687                     | Return.Tail =>
1688                          tailIsOk (raises, raises')
1689                          andalso tailIsOk (returns, returns'))
1690                end
1691
1692             fun checkFunction (Function.T {args, blocks, raises, returns, start,
1693                                            ...}) =
1694                let
1695                   val _ = Vector.foreach (args, setVarType)
1696                   val _ =
1697                      Vector.foreach
1698                      (blocks, fn b as Block.T {args, label, statements,
1699                                                transfer, ...} =>
1700                       (setLabelBlock (label, b)
1701                        ; Vector.foreach (args, setVarType)
1702                        ; Vector.foreach (statements, fn s =>
1703                                          Statement.foreachDef
1704                                          (s, setVarType))
1705                        ; Transfer.foreachDef (transfer, setVarType)))
1706                   val _ = labelIsNullaryJump start
1707                   fun transferOk (t: Transfer.t): bool =
1708                      let
1709                         datatype z = datatype Transfer.t
1710                      in
1711                         case t of
1712                            Arith {args, overflow, prim, success, ty, ...} =>
1713                               let
1714                                  val _ = checkOperands args
1715                               in
1716                                  Prim.mayOverflow prim
1717                                  andalso labelIsNullaryJump overflow
1718                                  andalso labelIsNullaryJump success
1719                                  andalso
1720                                  Type.checkPrimApp
1721                                  {args = Vector.map (args, Operand.ty),
1722                                   prim = prim,
1723                                   result = SOME ty}
1724                               end
1725                          | CCall {args, func, return} =>
1726                               let
1727                                  val _ = checkOperands args
1728                               in
1729                                  CFunction.isOk (func, {isUnit = Type.isUnit})
1730                                  andalso
1731                                  Vector.equals (args, CFunction.args func,
1732                                                 fn (z, t) =>
1733                                                 Type.isSubtype
1734                                                 (Operand.ty z, t))
1735                                  andalso
1736                                  case return of
1737                                     NONE => true
1738                                   | SOME l =>
1739                                        case labelKind l of
1740                                           Kind.CReturn {func = f} =>
1741                                              CFunction.equals (func, f)
1742                                         | _ => false
1743                               end
1744                          | Call {args, func, return} =>
1745                               let
1746                                  val _ = checkOperands args
1747                               in
1748                                  callIsOk {args = args,
1749                                            func = func,
1750                                            raises = raises,
1751                                            return = return,
1752                                            returns = returns}
1753                               end
1754                          | Goto {args, dst} =>
1755                               (checkOperands args
1756                                ; gotoOk {args = Vector.map (args, Operand.ty),
1757                                          dst = dst})
1758                          | Raise zs =>
1759                               (checkOperands zs
1760                                ; (case raises of
1761                                      NONE => false
1762                                    | SOME ts =>
1763                                         Vector.equals
1764                                         (zs, ts, fn (z, t) =>
1765                                          Type.isSubtype (Operand.ty z, t))))
1766                          | Return zs =>
1767                               (checkOperands zs
1768                                ; (case returns of
1769                                      NONE => false
1770                                    | SOME ts =>
1771                                         Vector.equals
1772                                         (zs, ts, fn (z, t) =>
1773                                          Type.isSubtype (Operand.ty z, t))))
1774                          | Switch s =>
1775                               Switch.isOk (s, {checkUse = checkOperand,
1776                                                labelIsOk = labelIsNullaryJump})
1777                      end
1778                   val transferOk =
1779                      Trace.trace ("Rssa.transferOk",
1780                                   Transfer.layout,
1781                                   Bool.layout)
1782                      transferOk
1783                   fun blockOk (Block.T {args, kind, statements, transfer, ...})
1784                      : bool =
1785                      let
1786                         fun kindOk (k: Kind.t): bool =
1787                            let
1788                               datatype z = datatype Kind.t
1789                            in
1790                               case k of
1791                                  Cont _ => true
1792                                | CReturn {func} =>
1793                                     let
1794                                        val return = CFunction.return func
1795                                     in
1796                                        0 = Vector.length args
1797                                        orelse
1798                                        (1 = Vector.length args
1799                                         andalso
1800                                         let
1801                                            val expects =
1802                                               #2 (Vector.first args)
1803                                         in
1804                                            Type.isSubtype (return, expects)
1805                                            andalso
1806                                            CType.equals (Type.toCType return,
1807                                                          Type.toCType expects)
1808                                         end)
1809                                     end
1810                                | Handler => true
1811                                | Jump => true
1812                            end
1813                         val _ = check' (kind, "kind", kindOk, Kind.layout)
1814                         val _ =
1815                            Vector.foreach
1816                            (statements, fn s =>
1817                             check' (s, "statement", statementOk,
1818                                     Statement.layout))
1819                         val _ = check' (transfer, "transfer", transferOk,
1820                                         Transfer.layout)
1821                      in
1822                         true
1823                      end
1824                   val blockOk =
1825                      Trace.trace ("Rssa.blockOk",
1826                                   Block.layout,
1827                                   Bool.layout)
1828                                  blockOk
1829
1830                   val _ =
1831                      Vector.foreach
1832                      (blocks, fn b =>
1833                       check' (b, "block", blockOk, Block.layout))
1834                in
1835                   ()
1836                end
1837             val _ =
1838                List.foreach
1839                (functions, fn f as Function.T {name, ...} =>
1840                 setFuncInfo (name, f))
1841             val _ = checkFunction main
1842             val _ = List.foreach (functions, checkFunction)
1843             val _ =
1844                check'
1845                (main, "main function",
1846                 fn f =>
1847                 let
1848                    val {args, ...} = Function.dest f
1849                 in
1850                    Vector.isEmpty args
1851                 end,
1852                 Function.layout)
1853             val _ = clear p
1854          in
1855             ()
1856          end handle Err.E e => (Layout.outputl (Err.layout e, Out.error)
1857                                 ; Error.bug "Rssa.typeCheck")
1858    end
1859
1860 end