mlton/ssa/ssa-tree2.fun

   1 (* Copyright (C) 2009,2014,2017 Matthew Fluet.
   2  * Copyright (C) 1999-2008 Henry Cejtin, Matthew Fluet, Suresh
   3  *    Jagannathan, and Stephen Weeks.
   4  * Copyright (C) 1997-2000 NEC Research Institute.
   5  *
   6  * MLton is released under a BSD-style license.
   7  * See the file MLton-LICENSE for details.
   8  *)
   9
  10 functor SsaTree2 (S: SSA_TREE2_STRUCTS): SSA_TREE2 =
  11 struct
  12
  13 open S
  14
  15 structure Prod =
  16    struct
  17       datatype 'a t = T of {elt: 'a, isMutable: bool} vector
  18
  19       fun dest (T p) = p
  20
  21       val make = T
  22
  23       fun empty () = T (Vector.new0 ())
  24
  25       fun fold (p, b, f) =
  26          Vector.fold (dest p, b, fn ({elt, ...}, b) => f (elt, b))
  27
  28       fun foreach (p, f) = Vector.foreach (dest p, f o #elt)
  29
  30       fun isEmpty p = Vector.isEmpty (dest p)
  31
  32       fun allAreImmutable (T v) = Vector.forall (v, not o #isMutable)
  33       fun allAreMutable (T v) = Vector.forall (v, #isMutable)
  34       fun someIsImmutable (T v) = Vector.exists (v, not o #isMutable)
  35       fun someIsMutable (T v) = Vector.exists (v, #isMutable)
  36
  37       fun sub (T p, i) = Vector.sub (p, i)
  38
  39       fun elt (p, i) = #elt (sub (p, i))
  40
  41       fun length p = Vector.length (dest p)
  42
  43       val equals: 'a t * 'a t * ('a * 'a -> bool) -> bool =
  44          fn (p1, p2, equals) =>
  45          Vector.equals (dest p1, dest p2,
  46                         fn ({elt = e1, isMutable = m1},
  47                             {elt = e2, isMutable = m2}) =>
  48                         m1 = m2 andalso equals (e1, e2))
  49
  50       fun layout (p, layout) =
  51          if isEmpty p
  52             then Layout.str "unit"
  53             else let
  54                     open Layout
  55                  in
  56                     seq [str "(",
  57                          (mayAlign o separateRight)
  58                          (Vector.toListMap (dest p, fn {elt, isMutable} =>
  59                                             if isMutable
  60                                                then seq [layout elt, str " ref"]
  61                                                else layout elt),
  62                           " *"),
  63                          str ")"]
  64                  end
  65
  66       val map: 'a t * ('a -> 'b) -> 'b t =
  67          fn (p, f) =>
  68          make (Vector.map (dest p, fn {elt, isMutable} =>
  69                            {elt = f elt,
  70                             isMutable = isMutable}))
  71
  72       val keepAllMap: 'a t * ('a -> 'b option) -> 'b t =
  73          fn (p, f) =>
  74          make (Vector.keepAllMap (dest p, fn {elt, isMutable} =>
  75                                   Option.map (f elt, fn elt =>
  76                                               {elt = elt,
  77                                                isMutable = isMutable})))
  78    end
  79
  80 structure ObjectCon =
  81    struct
  82       datatype t =
  83          Con of Con.t
  84        | Tuple
  85        | Vector
  86
  87       val equals: t * t -> bool =
  88          fn (Con c, Con c') => Con.equals (c, c')
  89           | (Tuple, Tuple) => true
  90           | (Vector, Vector) => true
  91           | _ => false
  92
  93       val isVector: t -> bool =
  94          fn Vector => true
  95           | _ => false
  96
  97       val layout: t -> Layout.t =
  98          fn oc =>
  99          let
 100             open Layout
 101          in
 102             case oc of
 103                Con c => Con.layout c
 104              | Tuple => str "Tuple"
 105              | Vector => str "Vector"
 106          end
 107    end
 108
 109 datatype z = datatype ObjectCon.t
 110
 111 structure Type =
 112    struct
 113       datatype t =
 114          T of {hash: Word.t,
 115                plist: PropertyList.t,
 116                tree: tree}
 117       and tree =
 118           CPointer
 119         | Datatype of Tycon.t
 120         | IntInf
 121         | Object of {args: t Prod.t,
 122                      con: ObjectCon.t}
 123         | Real of RealSize.t
 124         | Thread
 125         | Weak of t
 126         | Word of WordSize.t
 127
 128       local
 129          fun make f (T r) = f r
 130       in
 131          val hash = make #hash
 132          val plist = make #plist
 133          val tree = make #tree
 134       end
 135
 136       datatype dest = datatype tree
 137
 138       val dest = tree
 139
 140       fun equals (t, t') = PropertyList.equals (plist t, plist t')
 141
 142       val deVectorOpt: t -> t Prod.t option =
 143          fn t =>
 144          case dest t of
 145             Object {args, con = Vector} => SOME args
 146           | _ => NONE
 147
 148       val deVector1: t -> t =
 149          fn t =>
 150          case deVectorOpt t of
 151             SOME args =>
 152                if Prod.length args = 1
 153                   then Prod.elt (args, 0)
 154                   else Error.bug "SsaTree2.Type.deVector1"
 155           | _ => Error.bug "SsaTree2.Type.deVector1"
 156
 157       val isVector: t -> bool = isSome o deVectorOpt
 158
 159       val deWeakOpt: t -> t option =
 160          fn t =>
 161          case dest t of
 162             Weak t => SOME t
 163           | _ => NONE
 164
 165       val deWeak: t -> t = valOf o deWeakOpt
 166
 167       local
 168          val same: tree * tree -> bool =
 169             fn (CPointer, CPointer) => true
 170              | (Datatype t1, Datatype t2) => Tycon.equals (t1, t2)
 171              | (IntInf, IntInf) => true
 172              | (Object {args = a1, con = c1}, Object {args = a2, con = c2}) =>
 173                   ObjectCon.equals (c1, c2)
 174                   andalso Prod.equals (a1, a2, equals)
 175              | (Real s1, Real s2) => RealSize.equals (s1, s2)
 176              | (Thread, Thread) => true
 177              | (Weak t1, Weak t2) => equals (t1, t2)
 178              | (Word s1, Word s2) => WordSize.equals (s1, s2)
 179              | _ => false
 180          val table: t HashSet.t = HashSet.new {hash = hash}
 181       in
 182          fun lookup (hash, tr) =
 183             HashSet.lookupOrInsert (table, hash,
 184                                     fn t => same (tr, tree t),
 185                                     fn () => T {hash = hash,
 186                                                 plist = PropertyList.new (),
 187                                                 tree = tr})
 188
 189          fun stats () =
 190             let open Layout
 191             in align [seq [str "num types in hash table = ",
 192                            Int.layout (HashSet.size table)],
 193                       Control.sizeMessage ("types hash table", lookup)]
 194             end
 195       end
 196
 197       val newHash = Random.word
 198
 199       local
 200          fun make f : t -> t =
 201             let
 202                val w = newHash ()
 203             in
 204                fn t => lookup (Word.xorb (w, hash t), f t)
 205             end
 206       in
 207          val weak = make Weak
 208       end
 209
 210       val datatypee: Tycon.t -> t =
 211          fn t => lookup (Tycon.hash t, Datatype t)
 212
 213       val bool = datatypee Tycon.bool
 214
 215       val isBool: t -> bool =
 216          fn t =>
 217          case dest t of
 218             Datatype t => Tycon.equals (t, Tycon.bool)
 219           | _ => false
 220
 221       local
 222          fun make (tycon, tree) = lookup (Tycon.hash tycon, tree)
 223       in
 224          val cpointer = make (Tycon.cpointer, CPointer)
 225          val intInf = make (Tycon.intInf, IntInf)
 226          val thread = make (Tycon.thread, Thread)
 227       end
 228
 229       val real: RealSize.t -> t =
 230          fn s => lookup (Tycon.hash (Tycon.real s), Real s)
 231
 232       val word: WordSize.t -> t =
 233          fn s => lookup (Tycon.hash (Tycon.word s), Word s)
 234
 235       local
 236          val generator: Word.t = 0wx5555
 237          val tuple = newHash ()
 238          val vector = newHash ()
 239          fun hashProd (p, base) =
 240             Vector.fold (Prod.dest p, base, fn ({elt, ...}, w) =>
 241                          Word.xorb (w * generator, hash elt))
 242       in
 243          fun object {args, con}: t =
 244             let
 245                val base =
 246                   case con of
 247                      Con c => Con.hash c
 248                    | Tuple => tuple
 249                    | Vector => vector
 250                val hash = hashProd (args, base)
 251             in
 252                lookup (hash, Object {args = args, con = con})
 253             end
 254       end
 255
 256       fun vector p = object {args = p, con = Vector}
 257
 258       local
 259          fun make isMutable t =
 260             vector (Prod.make (Vector.new1 {elt = t, isMutable = isMutable}))
 261       in
 262          val array1 = make true
 263          val vector1 = make false
 264       end
 265
 266       fun ofConst c =
 267          let
 268             datatype z = datatype Const.t
 269          in
 270             case c of
 271                IntInf _ => intInf
 272              | Null => cpointer
 273              | Real r => real (RealX.size r)
 274              | Word w => word (WordX.size w)
 275              | WordVector v => vector1 (word (WordXVector.elementSize v))
 276          end
 277
 278       fun conApp (con, args) = object {args = args, con = Con con}
 279
 280       fun tuple ts = object {args = ts, con = Tuple}
 281
 282       fun reff1 t =
 283          object {args = Prod.make (Vector.new1 {elt = t, isMutable = true}),
 284                  con = Tuple}
 285
 286       val unit: t = tuple (Prod.empty ())
 287
 288       val isUnit: t -> bool =
 289          fn t =>
 290          case dest t of
 291             Object {args, con = Tuple} => Prod.isEmpty args
 292           | _ => false
 293
 294       local
 295          open Layout
 296       in
 297          val {get = layout, ...} =
 298             Property.get
 299             (plist,
 300              Property.initRec
 301              (fn (t, layout) =>
 302               case dest t of
 303                  CPointer => str "cpointer"
 304                | Datatype t => Tycon.layout t
 305                | IntInf => str "intInf"
 306                | Object {args, con} =>
 307                     if isUnit t
 308                        then str "unit"
 309                     else
 310                        let
 311                           val args = Prod.layout (args, layout)
 312                        in
 313                           case con of
 314                              Con c => seq [Con.layout c, str " of ", args]
 315                            | Tuple => args
 316                            | Vector => seq [args, str " vector"]
 317                        end
 318                | Real s => str (concat ["real", RealSize.toString s])
 319                | Thread => str "thread"
 320                | Weak t => seq [layout t, str " weak"]
 321                | Word s => str (concat ["word", WordSize.toString s])))
 322       end
 323
 324       fun checkPrimApp {args, prim, result}: bool =
 325          let
 326             exception BadPrimApp
 327             fun default () =
 328                let
 329                   val targs =
 330                      Prim.extractTargs
 331                      (prim,
 332                       {args = args,
 333                        result = result,
 334                        typeOps = {deArray = fn _ => raise BadPrimApp,
 335                                   deArrow = fn _ => raise BadPrimApp,
 336                                   deRef = fn _ => raise BadPrimApp,
 337                                   deVector = fn _ => raise BadPrimApp,
 338                                   deWeak = deWeak}})
 339                in
 340                   Prim.checkApp
 341                   (prim,
 342                    {args = args,
 343                     result = result,
 344                     targs = targs,
 345                     typeOps = {array = array1,
 346                                arrow = fn _ => raise BadPrimApp,
 347                                bool = bool,
 348                                cpointer = cpointer,
 349                                equals = equals,
 350                                exn = unit,
 351                                intInf = intInf,
 352                                real = real,
 353                                reff = fn _ => raise BadPrimApp,
 354                                thread = thread,
 355                                unit = unit,
 356                                vector = vector1,
 357                                weak = weak,
 358                                word = word}})
 359                end
 360             val default = fn () =>
 361                (default ()) handle BadPrimApp => false
 362
 363             datatype z = datatype Prim.Name.t
 364             fun arg i = Vector.sub (args, i)
 365             fun oneArg f = 1 = Vector.length args andalso f (arg 0)
 366             fun twoArgs f = 2 = Vector.length args andalso f (arg 0, arg 1)
 367             fun fiveArgs f = 5 = Vector.length args andalso f (arg 0, arg 1, arg 2, arg 3, arg 4)
 368             val seqIndex = word (WordSize.seqIndex ())
 369          in
 370             case Prim.name prim of
 371                Array_alloc _ =>
 372                   oneArg
 373                   (fn n =>
 374                    case deVectorOpt result of
 375                       SOME resp =>
 376                          Prod.allAreMutable resp
 377                          andalso equals (n, seqIndex)
 378                     | _ => false)
 379              | Array_copyArray =>
 380                   fiveArgs
 381                   (fn (dst, di, src, si, len) =>
 382                    case (deVectorOpt dst, deVectorOpt src) of
 383                       (SOME dstp, SOME srcp) =>
 384                          Vector.equals (Prod.dest dstp, Prod.dest srcp,
 385                                         fn ({elt = dstElt, isMutable = dstIsMutable},
 386                                             {elt = srcElt, isMutable = srcIsMutable}) =>
 387                                         dstIsMutable andalso srcIsMutable
 388                                         andalso equals (dstElt, srcElt))
 389                          andalso equals (di, seqIndex)
 390                          andalso equals (si, seqIndex)
 391                          andalso equals (len, seqIndex)
 392                          andalso isUnit result
 393                     | _ => false)
 394              | Array_copyVector =>
 395                   fiveArgs
 396                   (fn (dst, di, src, si, len) =>
 397                    case (deVectorOpt dst, deVectorOpt src) of
 398                       (SOME dstp, SOME srcp) =>
 399                          Vector.equals (Prod.dest dstp, Prod.dest srcp,
 400                                         fn ({elt = dstElt, isMutable = dstIsMutable},
 401                                             {elt = srcElt, ...}) =>
 402                                         dstIsMutable
 403                                         andalso equals (dstElt, srcElt))
 404                          andalso equals (di, seqIndex)
 405                          andalso equals (si, seqIndex)
 406                          andalso equals (len, seqIndex)
 407                          andalso isUnit result
 408                     | _ => false)
 409              | Array_length =>
 410                   oneArg
 411                   (fn a =>
 412                    isVector a andalso equals (result, seqIndex))
 413              | Array_toArray =>
 414                   oneArg
 415                   (fn arr =>
 416                    case (deVectorOpt arr, deVectorOpt result) of
 417                       (SOME arrp, SOME resp) =>
 418                          Vector.equals (Prod.dest arrp, Prod.dest resp,
 419                                         fn ({elt = arrElt, isMutable = arrIsMutable},
 420                                             {elt = resElt, isMutable = resIsMutable}) =>
 421                                         arrIsMutable andalso resIsMutable
 422                                         andalso equals (arrElt, resElt))
 423                     | _ => false)
 424              | Array_toVector =>
 425                   oneArg
 426                   (fn arr =>
 427                    case (deVectorOpt arr, deVectorOpt result) of
 428                       (SOME arrp, SOME resp) =>
 429                          Vector.equals (Prod.dest arrp, Prod.dest resp,
 430                                         fn ({elt = arrElt, isMutable = arrIsMutable},
 431                                             {elt = resElt, ...}) =>
 432                                         arrIsMutable
 433                                         andalso equals (arrElt, resElt))
 434                     | _ => false)
 435              | Array_uninit =>
 436                   twoArgs
 437                   (fn (arr, i) =>
 438                    case deVectorOpt arr of
 439                       SOME arrp =>
 440                          Prod.allAreMutable arrp
 441                          andalso equals (i, seqIndex)
 442                          andalso isUnit result
 443                     | _ => false)
 444              | Array_uninitIsNop =>
 445                   oneArg
 446                   (fn arr =>
 447                    case deVectorOpt arr of
 448                       SOME arrp =>
 449                          Prod.allAreMutable arrp
 450                          andalso isBool result
 451                     | _ => false)
 452              | _ => default ()
 453          end
 454    end
 455
 456 structure Cases =
 457    struct
 458       datatype t =
 459          Con of (Con.t * Label.t) vector
 460        | Word of WordSize.t * (WordX.t * Label.t) vector
 461
 462       fun equals (c1: t, c2: t): bool =
 463          let
 464             fun doit (l1, l2, eq') =
 465                Vector.equals
 466                (l1, l2, fn ((x1, a1), (x2, a2)) =>
 467                 eq' (x1, x2) andalso Label.equals (a1, a2))
 468          in
 469             case (c1, c2) of
 470                (Con l1, Con l2) => doit (l1, l2, Con.equals)
 471              | (Word (_, l1), Word (_, l2)) => doit (l1, l2, WordX.equals)
 472              | _ => false
 473          end
 474
 475       fun hd (c: t): Label.t =
 476          let
 477             fun doit v =
 478                if Vector.length v >= 1
 479                   then let val (_, a) = Vector.first v
 480                        in a
 481                        end
 482                else Error.bug "SsaTree2.Cases.hd"
 483          in
 484             case c of
 485                Con cs => doit cs
 486              | Word (_, cs) => doit cs
 487          end
 488
 489       fun isEmpty (c: t): bool =
 490          let
 491             fun doit v = Vector.isEmpty v
 492          in
 493             case c of
 494                Con cs => doit cs
 495              | Word (_, cs) => doit cs
 496          end
 497
 498       fun fold (c: t, b, f) =
 499          let
 500             fun doit l = Vector.fold (l, b, fn ((_, a), b) => f (a, b))
 501          in
 502             case c of
 503                Con l => doit l
 504              | Word (_, l) => doit l
 505          end
 506
 507       fun map (c: t, f): t =
 508          let
 509             fun doit l = Vector.map (l, fn (i, x) => (i, f x))
 510          in
 511             case c of
 512                Con l => Con (doit l)
 513              | Word (s, l) => Word (s, doit l)
 514          end
 515
 516       fun forall (c: t, f: Label.t -> bool): bool =
 517          let
 518             fun doit l = Vector.forall (l, fn (_, x) => f x)
 519          in
 520             case c of
 521                Con l => doit l
 522              | Word (_, l) => doit l
 523          end
 524
 525       fun foreach (c, f) = fold (c, (), fn (x, ()) => f x)
 526    end
 527
 528 structure Base =
 529    struct
 530       datatype 'a t =
 531          Object of 'a
 532        | VectorSub of {index: 'a,
 533                        vector: 'a}
 534
 535       fun layout (b: 'a t, layoutX: 'a -> Layout.t): Layout.t =
 536          let
 537             open Layout
 538          in
 539             case b of
 540                Object x => layoutX x
 541              | VectorSub {index, vector} =>
 542                   seq [str "$", Vector.layout layoutX (Vector.new2 (vector, index))]
 543          end
 544
 545       val equals: 'a t * 'a t * ('a * 'a -> bool) -> bool =
 546          fn (b1, b2, equalsX) =>
 547          case (b1, b2) of
 548             (Object x1, Object x2) => equalsX (x1, x2)
 549           | (VectorSub {index = i1, vector = v1},
 550              VectorSub {index = i2, vector = v2}) =>
 551                equalsX (i1, i2) andalso equalsX (v1, v2)
 552           | _ => false
 553
 554       fun object (b: 'a t): 'a =
 555          case b of
 556             Object x => x
 557           | VectorSub {vector = x, ...} => x
 558
 559       local
 560          val newHash = Random.word
 561          val object = newHash ()
 562          val vectorSub = newHash ()
 563       in
 564          val hash: 'a t * ('a -> word) -> word =
 565             fn (b, hashX) =>
 566             case b of
 567                Object x => Word.xorb (object, hashX x)
 568              | VectorSub {index, vector} =>
 569                   Word.xorb (Word.xorb (hashX index, hashX vector),
 570                              vectorSub)
 571       end
 572
 573       fun foreach (b: 'a t, f: 'a -> unit): unit =
 574          case b of
 575             Object x => f x
 576           | VectorSub {index, vector} => (f index; f vector)
 577
 578       fun map (b: 'a t, f: 'a -> 'b): 'b t =
 579          case b of
 580             Object x => Object (f x)
 581           | VectorSub {index, vector} => VectorSub {index = f index,
 582                                                     vector = f vector}
 583    end
 584
 585 structure Exp =
 586    struct
 587       datatype t =
 588          Const of Const.t
 589        | Inject of {sum: Tycon.t,
 590                     variant: Var.t}
 591        | Object of {con: Con.t option,
 592                     args: Var.t vector}
 593        | PrimApp of {prim: Type.t Prim.t,
 594                      args: Var.t vector}
 595        | Select of {base: Var.t Base.t,
 596                     offset: int}
 597        | Var of Var.t
 598
 599       val unit = Object {con = NONE, args = Vector.new0 ()}
 600
 601       fun foreachVar (e, v) =
 602          let
 603             fun vs xs = Vector.foreach (xs, v)
 604          in
 605             case e of
 606                Const _ => ()
 607              | Inject {variant, ...} => v variant
 608              | Object {args, ...} => vs args
 609              | PrimApp {args, ...} => vs args
 610              | Select {base, ...} => Base.foreach (base, v)
 611              | Var x => v x
 612          end
 613
 614       fun replaceVar (e, fx) =
 615          let
 616             fun fxs xs = Vector.map (xs, fx)
 617          in
 618             case e of
 619                Const _ => e
 620              | Inject {sum, variant} => Inject {sum = sum, variant = fx variant}
 621              | Object {con, args} => Object {con = con, args = fxs args}
 622              | PrimApp {prim, args} => PrimApp {args = fxs args, prim = prim}
 623              | Select {base, offset} =>
 624                   Select {base = Base.map (base, fx), offset = offset}
 625              | Var x => Var (fx x)
 626          end
 627
 628       fun layout' (e, layoutVar) =
 629          let
 630             open Layout
 631             fun layoutArgs xs = Vector.layout layoutVar xs
 632          in
 633             case e of
 634                Const c => Const.layout c
 635              | Inject {sum, variant} =>
 636                   seq [paren (layoutVar variant), str ": ", Tycon.layout sum]
 637              | Object {con, args} =>
 638                   seq [(case con of
 639                            NONE => empty
 640                          | SOME c => seq [Con.layout c, str " "]),
 641                        layoutArgs args]
 642              | PrimApp {args, prim} =>
 643                   seq [Prim.layout prim, str " ", layoutArgs args]
 644              | Select {base, offset} =>
 645                   seq [str "#", Int.layout offset, str " ",
 646                        paren (Base.layout (base, layoutVar))]
 647              | Var x => layoutVar x
 648          end
 649
 650       fun layout e = layout' (e, Var.layout)
 651
 652       fun maySideEffect (e: t): bool =
 653          case e of
 654             Const _ => false
 655           | Inject _ => false
 656           | Object _ => false
 657           | PrimApp {prim,...} => Prim.maySideEffect prim
 658           | Select _ => false
 659           | Var _ => false
 660
 661       fun varsEquals (xs, xs') = Vector.equals (xs, xs', Var.equals)
 662
 663       fun equals (e: t, e': t): bool =
 664          case (e, e') of
 665             (Const c, Const c') => Const.equals (c, c')
 666           | (Object {con, args}, Object {con = con', args = args'}) =>
 667                Option.equals (con, con', Con.equals)
 668                andalso varsEquals (args, args')
 669           | (PrimApp {prim, args, ...},
 670              PrimApp {prim = prim', args = args', ...}) =>
 671                Prim.equals (prim, prim') andalso varsEquals (args, args')
 672           | (Select {base = b1, offset = i1}, Select {base = b2, offset = i2}) =>
 673                Base.equals (b1, b2, Var.equals) andalso i1 = i2
 674           | (Var x, Var x') => Var.equals (x, x')
 675           | _ => false
 676       (* quell unused warning *)
 677       val _ = equals
 678
 679       local
 680          val newHash = Random.word
 681          val inject = newHash ()
 682          val primApp = newHash ()
 683          val select = newHash ()
 684          val tuple = newHash ()
 685          fun hashVars (xs: Var.t vector, w: Word.t): Word.t =
 686             Vector.fold (xs, w, fn (x, w) => Word.xorb (w, Var.hash x))
 687       in
 688          val hash: t -> Word.t =
 689             fn Const c => Const.hash c
 690              | Inject {sum, variant} =>
 691                   Word.xorb (inject,
 692                              Word.xorb (Tycon.hash sum, Var.hash variant))
 693              | Object {con, args, ...} =>
 694                   hashVars (args,
 695                             case con of
 696                                NONE => tuple
 697                              | SOME c => Con.hash c)
 698              | PrimApp {args, ...} => hashVars (args, primApp)
 699              | Select {base, offset} =>
 700                   Word.xorb (select,
 701                              Base.hash (base, Var.hash) + Word.fromInt offset)
 702              | Var x => Var.hash x
 703       end
 704       (* quell unused warning *)
 705       val _ = hash
 706    end
 707 datatype z = datatype Exp.t
 708
 709 structure Statement =
 710    struct
 711       datatype t =
 712          Bind of {var: Var.t option,
 713                   ty: Type.t,
 714                   exp: Exp.t}
 715        | Profile of ProfileExp.t
 716        | Update of {base: Var.t Base.t,
 717                     offset: int,
 718                     value: Var.t}
 719
 720       fun layout' (s: t, layoutVar): Layout.t =
 721          let
 722             open Layout
 723          in
 724             case s of
 725                Bind {var, ty, exp} =>
 726                   let
 727                      val (sep, ty) =
 728                         if !Control.showTypes
 729                            then (str ":", indent (seq [Type.layout ty, str " ="], 2))
 730                            else (str " =", empty)
 731                   in
 732                      mayAlign [mayAlign [seq [case var of
 733                                                  NONE => str "_"
 734                                                | SOME var => Var.layout var,
 735                                               sep],
 736                                          ty],
 737                                indent (Exp.layout' (exp, layoutVar), 2)]
 738                   end
 739              | Profile p => ProfileExp.layout p
 740              | Update {base, offset, value} =>
 741                   mayAlign [seq [Exp.layout' (Exp.Select {base = base,
 742                                                           offset = offset},
 743                                               layoutVar),
 744                                  str " :="],
 745                             layoutVar value]
 746          end
 747       fun layout s = layout' (s, Var.layout)
 748
 749       val profile = Profile
 750
 751       fun foreachDef (s: t, f: Var.t * Type.t -> unit): unit =
 752          case s of
 753             Bind {ty, var, ...} => Option.app (var, fn x => f (x, ty))
 754           | _ => ()
 755
 756       fun clear s = foreachDef (s, Var.clear o #1)
 757
 758       fun prettifyGlobals (v: t vector): Var.t -> Layout.t =
 759          let
 760             val {get = global: Var.t -> Layout.t, set = setGlobal, ...} =
 761                Property.getSet (Var.plist, Property.initFun Var.layout)
 762             val _ =
 763                Vector.foreach
 764                (v, fn s =>
 765                 case s of
 766                    Bind {var, exp, ...} =>
 767                       Option.app
 768                       (var, fn var =>
 769                        let
 770                           fun set () =
 771                              let
 772                                 val s = Layout.toString (Exp.layout' (exp, global))
 773                                 val maxSize = 20
 774                                 val dots = " ... "
 775                                 val dotsSize = String.size dots
 776                                 val frontSize = 2 * (maxSize - dotsSize) div 3
 777                                 val backSize = maxSize - dotsSize - frontSize
 778                                 val s =
 779                                    if String.size s > maxSize
 780                                       then concat [String.prefix (s, frontSize),
 781                                                    dots,
 782                                                    String.suffix (s, backSize)]
 783                                       else s
 784                              in
 785                                 setGlobal (var, Layout.seq [Var.layout var,
 786                                                             Layout.str (" (*" ^ s ^ "*)")])
 787                              end
 788                        in
 789                           case exp of
 790                              Const _ => set ()
 791                            | Object {con, args, ...} =>
 792                                 (case con of
 793                                     NONE => if Vector.isEmpty args then set () else ()
 794                                   | SOME _ => set ())
 795                            | _ => ()
 796                        end)
 797                  | _ => ())
 798          in
 799             global
 800          end
 801
 802       fun foreachUse (s: t, f: Var.t -> unit): unit =
 803          case s of
 804             Bind {exp, ...} => Exp.foreachVar (exp, f)
 805           | Profile _ => ()
 806           | Update {base, value, ...} => (Base.foreach (base, f); f value)
 807
 808       fun replaceDefsUses (s: t, {def: Var.t -> Var.t, use: Var.t -> Var.t}): t =
 809          case s of
 810             Bind {exp, ty, var} =>
 811                Bind {exp = Exp.replaceVar (exp, use),
 812                      ty = ty,
 813                      var = Option.map (var, def)}
 814           | Profile _ => s
 815           | Update {base, offset, value} =>
 816                Update {base = Base.map (base, use),
 817                        offset = offset,
 818                        value = use value}
 819
 820       fun replaceUses (s, f) = replaceDefsUses (s, {def = fn x => x, use = f})
 821    end
 822
 823 datatype z = datatype Statement.t
 824
 825 structure Handler =
 826    struct
 827       structure Label = Label
 828
 829       datatype t =
 830          Caller
 831        | Dead
 832        | Handle of Label.t
 833
 834       fun layout (h: t): Layout.t =
 835          let
 836             open Layout
 837          in
 838             case h of
 839                Caller => str "Caller"
 840              | Dead => str "Dead"
 841              | Handle l => seq [str "Handle ", Label.layout l]
 842          end
 843
 844       val equals =
 845          fn (Caller, Caller) => true
 846           | (Dead, Dead) => true
 847           | (Handle l, Handle l') => Label.equals (l, l')
 848           | _ => false
 849
 850       fun foldLabel (h: t, a: 'a, f: Label.t * 'a -> 'a): 'a =
 851          case h of
 852             Caller => a
 853           | Dead => a
 854           | Handle l => f (l, a)
 855
 856       fun foreachLabel (h, f) = foldLabel (h, (), f o #1)
 857
 858       fun map (h, f) =
 859          case h of
 860             Caller => Caller
 861           | Dead => Dead
 862           | Handle l => Handle (f l)
 863
 864       local
 865          val newHash = Random.word
 866          val caller = newHash ()
 867          val dead = newHash ()
 868          val handlee = newHash ()
 869       in
 870          fun hash (h: t): word =
 871             case h of
 872                Caller => caller
 873              | Dead => dead
 874              | Handle l => Word.xorb (handlee, Label.hash l)
 875       end
 876    end
 877
 878 structure Return =
 879    struct
 880       structure Label = Label
 881       structure Handler = Handler
 882
 883       datatype t =
 884          Dead
 885        | NonTail of {cont: Label.t,
 886                      handler: Handler.t}
 887        | Tail
 888
 889       fun layout r =
 890          let
 891             open Layout
 892          in
 893             case r of
 894                Dead => str "Dead"
 895              | NonTail {cont, handler} =>
 896                   seq [str "NonTail ",
 897                        Layout.record
 898                        [("cont", Label.layout cont),
 899                         ("handler", Handler.layout handler)]]
 900              | Tail => str "Tail"
 901          end
 902
 903       fun equals (r, r'): bool =
 904          case (r, r') of
 905             (Dead, Dead) => true
 906           | (NonTail {cont = c, handler = h},
 907              NonTail {cont = c', handler = h'}) =>
 908                Label.equals (c, c') andalso Handler.equals (h, h')
 909            | (Tail, Tail) => true
 910            | _ => false
 911
 912       fun foldLabel (r: t, a, f) =
 913          case r of
 914             Dead => a
 915           | NonTail {cont, handler} =>
 916                Handler.foldLabel (handler, f (cont, a), f)
 917           | Tail => a
 918
 919       fun foreachLabel (r, f) = foldLabel (r, (), f o #1)
 920
 921       fun foreachHandler (r, f) =
 922          case r of
 923             Dead => ()
 924           | NonTail {handler, ...} => Handler.foreachLabel (handler, f)
 925           | Tail => ()
 926
 927       fun map (r, f) =
 928          case r of
 929             Dead => Dead
 930           | NonTail {cont, handler} =>
 931                NonTail {cont = f cont,
 932                         handler = Handler.map (handler, f)}
 933           | Tail => Tail
 934
 935       fun compose (r, r') =
 936          case r' of
 937             Dead => Dead
 938           | NonTail {cont, handler} =>
 939                NonTail
 940                {cont = cont,
 941                 handler = (case handler of
 942                               Handler.Caller =>
 943                                  (case r of
 944                                      Dead => Handler.Caller
 945                                    | NonTail {handler, ...} => handler
 946                                    | Tail => Handler.Caller)
 947                             | Handler.Dead => handler
 948                             | Handler.Handle _ => handler)}
 949           | Tail => r
 950       (* quell unused warning *)
 951       val _ = compose
 952
 953       local
 954          val newHash = Random.word
 955          val dead = newHash ()
 956          val nonTail = newHash ()
 957          val tail = newHash ()
 958       in
 959          fun hash r =
 960             case r of
 961                Dead => dead
 962              | NonTail {cont, handler} =>
 963                   Word.xorb (Word.xorb (nonTail, Label.hash cont),
 964                              Handler.hash handler)
 965              | Tail => tail
 966       end
 967    end
 968
 969 structure Transfer =
 970    struct
 971       datatype t =
 972          Arith of {prim: Type.t Prim.t,
 973                    args: Var.t vector,
 974                    overflow: Label.t, (* Must be nullary. *)
 975                    success: Label.t, (* Must be unary. *)
 976                    ty: Type.t}
 977        | Bug (* MLton thought control couldn't reach here. *)
 978        | Call of {args: Var.t vector,
 979                   func: Func.t,
 980                   return: Return.t}
 981        | Case of {test: Var.t,
 982                   cases: Cases.t,
 983                   default: Label.t option} (* Must be nullary. *)
 984        | Goto of {dst: Label.t,
 985                   args: Var.t vector}
 986        | Raise of Var.t vector
 987        | Return of Var.t vector
 988        | Runtime of {prim: Type.t Prim.t,
 989                      args: Var.t vector,
 990                      return: Label.t} (* Must be nullary. *)
 991
 992       fun foreachFuncLabelVar (t, func: Func.t -> unit, label: Label.t -> unit, var) =
 993          let
 994             fun vars xs = Vector.foreach (xs, var)
 995          in
 996             case t of
 997                Arith {args, overflow, success, ...} =>
 998                   (vars args
 999                    ; label overflow
1000                    ; label success)
1001              | Bug => ()
1002              | Call {func = f, args, return, ...} =>
1003                   (func f
1004                    ; Return.foreachLabel (return, label)
1005                    ; vars args)
1006              | Case {test, cases, default, ...} =>
1007                   (var test
1008                    ; Cases.foreach (cases, label)
1009                    ; Option.app (default, label))
1010              | Goto {dst, args, ...} => (vars args; label dst)
1011              | Raise xs => vars xs
1012              | Return xs => vars xs
1013              | Runtime {args, return, ...} =>
1014                   (vars args
1015                    ; label return)
1016          end
1017
1018       fun foreachFunc (t, func) =
1019          foreachFuncLabelVar (t, func, fn _ => (), fn _ => ())
1020       (* quell unused warning *)
1021       val _ = foreachFunc
1022
1023       fun foreachLabelVar (t, label, var) =
1024          foreachFuncLabelVar (t, fn _ => (), label, var)
1025
1026       fun foreachLabel (t, j) = foreachLabelVar (t, j, fn _ => ())
1027       fun foreachVar (t, v) = foreachLabelVar (t, fn _ => (), v)
1028
1029       fun replaceLabelVar (t, fl, fx) =
1030          let
1031             fun fxs xs = Vector.map (xs, fx)
1032          in
1033             case t of
1034                Arith {prim, args, overflow, success, ty} =>
1035                   Arith {prim = prim,
1036                          args = fxs args,
1037                          overflow = fl overflow,
1038                          success = fl success,
1039                          ty = ty}
1040              | Bug => Bug
1041              | Call {func, args, return} =>
1042                   Call {func = func,
1043                         args = fxs args,
1044                         return = Return.map (return, fl)}
1045              | Case {test, cases, default} =>
1046                   Case {test = fx test,
1047                         cases = Cases.map(cases, fl),
1048                         default = Option.map(default, fl)}
1049              | Goto {dst, args} =>
1050                   Goto {dst = fl dst,
1051                         args = fxs args}
1052              | Raise xs => Raise (fxs xs)
1053              | Return xs => Return (fxs xs)
1054              | Runtime {prim, args, return} =>
1055                   Runtime {prim = prim,
1056                            args = fxs args,
1057                            return = fl return}
1058          end
1059
1060       fun replaceLabel (t, f) = replaceLabelVar (t, f, fn x => x)
1061       (* quell unused warning *)
1062       val _ = replaceLabel
1063       fun replaceVar (t, f) = replaceLabelVar (t, fn l => l, f)
1064
1065       local
1066          fun layoutCase ({test, cases, default}, layoutVar) =
1067             let
1068                open Layout
1069                fun doit (l, layout) =
1070                   Vector.toListMap
1071                   (l, fn (i, l) =>
1072                    seq [layout i, str " => ", Label.layout l])
1073                datatype z = datatype Cases.t
1074                val cases =
1075                   case cases of
1076                      Con l => doit (l, Con.layout)
1077                    | Word (_, l) => doit (l, WordX.layout)
1078                val cases =
1079                   case default of
1080                      NONE => cases
1081                    | SOME j =>
1082                         cases @ [seq [str "_ => ", Label.layout j]]
1083             in
1084                align [seq [str "case ", layoutVar test, str " of"],
1085                       indent (alignPrefix (cases, "| "), 2)]
1086             end
1087       in
1088          fun layout' (t, layoutVar) =
1089             let
1090                open Layout
1091                fun layoutArgs xs = Vector.layout layoutVar xs
1092                fun layoutPrim {prim, args} =
1093                   Exp.layout'
1094                   (Exp.PrimApp {prim = prim,
1095                                 args = args},
1096                    layoutVar)
1097             in
1098                case t of
1099                   Arith {prim, args, overflow, success, ...} =>
1100                      seq [Label.layout success, str " ",
1101                           tuple [layoutPrim {prim = prim, args = args}],
1102                           str " handle Overflow => ", Label.layout overflow]
1103                 | Bug => str "Bug"
1104                 | Call {func, args, return} =>
1105                      let
1106                         val call = seq [Func.layout func, str " ", layoutArgs args]
1107                      in
1108                         case return of
1109                            Return.Dead => seq [str "dead ", paren call]
1110                          | Return.NonTail {cont, handler} =>
1111                               seq [Label.layout cont, str " ",
1112                                    paren call,
1113                                    str " handle _ => ",
1114                                    case handler of
1115                                       Handler.Caller => str "raise"
1116                                     | Handler.Dead => str "dead"
1117                                     | Handler.Handle l => Label.layout l]
1118                          | Return.Tail => seq [str "return ", paren call]
1119                      end
1120                 | Case arg => layoutCase (arg, layoutVar)
1121                 | Goto {dst, args} =>
1122                      seq [Label.layout dst, str " ", layoutArgs args]
1123                 | Raise xs => seq [str "raise ", layoutArgs xs]
1124                 | Return xs => seq [str "return ", layoutArgs xs]
1125                 | Runtime {prim, args, return} =>
1126                      seq [Label.layout return, str " ",
1127                           tuple [layoutPrim {prim = prim, args = args}]]
1128             end
1129       end
1130       fun layout t = layout' (t, Var.layout)
1131
1132       fun varsEquals (xs, xs') = Vector.equals (xs, xs', Var.equals)
1133
1134       fun equals (e: t, e': t): bool =
1135          case (e, e') of
1136             (Arith {prim, args, overflow, success, ...},
1137              Arith {prim = prim', args = args',
1138                     overflow = overflow', success = success', ...}) =>
1139                Prim.equals (prim, prim') andalso
1140                varsEquals (args, args') andalso
1141                Label.equals (overflow, overflow') andalso
1142                Label.equals (success, success')
1143           | (Bug, Bug) => true
1144           | (Call {func, args, return},
1145              Call {func = func', args = args', return = return'}) =>
1146                Func.equals (func, func') andalso
1147                varsEquals (args, args') andalso
1148                Return.equals (return, return')
1149           | (Case {test, cases, default},
1150              Case {test = test', cases = cases', default = default'}) =>
1151                Var.equals (test, test')
1152                andalso Cases.equals (cases, cases')
1153                andalso Option.equals (default, default', Label.equals)
1154           | (Goto {dst, args}, Goto {dst = dst', args = args'}) =>
1155                Label.equals (dst, dst') andalso
1156                varsEquals (args, args')
1157           | (Raise xs, Raise xs') => varsEquals (xs, xs')
1158           | (Return xs, Return xs') => varsEquals (xs, xs')
1159           | (Runtime {prim, args, return},
1160              Runtime {prim = prim', args = args', return = return'}) =>
1161                Prim.equals (prim, prim') andalso
1162                varsEquals (args, args') andalso
1163                Label.equals (return, return')
1164           | _ => false
1165       (* quell unused warning *)
1166       val _ = equals
1167
1168       local
1169          val newHash = Random.word
1170          val bug = newHash ()
1171          val raisee = newHash ()
1172          val return = newHash ()
1173          fun hashVars (xs: Var.t vector, w: Word.t): Word.t =
1174             Vector.fold (xs, w, fn (x, w) => Word.xorb (w, Var.hash x))
1175          fun hash2 (w1: Word.t, w2: Word.t) = Word.xorb (w1, w2)
1176       in
1177          val hash: t -> Word.t =
1178             fn Arith {args, overflow, success, ...} =>
1179                   hashVars (args, hash2 (Label.hash overflow,
1180                                          Label.hash success))
1181              | Bug => bug
1182              | Call {func, args, return} =>
1183                   hashVars (args, hash2 (Func.hash func, Return.hash return))
1184              | Case {test, cases, default} =>
1185                   hash2 (Var.hash test,
1186                          Cases.fold
1187                          (cases,
1188                           Option.fold
1189                           (default, 0wx55555555,
1190                            fn (l, w) =>
1191                            hash2 (Label.hash l, w)),
1192                           fn (l, w) =>
1193                           hash2 (Label.hash l, w)))
1194              | Goto {dst, args} =>
1195                   hashVars (args, Label.hash dst)
1196              | Raise xs => hashVars (xs, raisee)
1197              | Return xs => hashVars (xs, return)
1198              | Runtime {args, return, ...} => hashVars (args, Label.hash return)
1199       end
1200       (* quell unused warning *)
1201       val _ = hash
1202    end
1203 datatype z = datatype Transfer.t
1204
1205 local
1206    open Layout
1207 in
1208    fun layoutFormals (xts: (Var.t * Type.t) vector) =
1209       Vector.layout (fn (x, t) =>
1210                     seq [Var.layout x,
1211                          if !Control.showTypes
1212                             then seq [str ": ", Type.layout t]
1213                          else empty])
1214       xts
1215 end
1216
1217 structure Block =
1218    struct
1219       datatype t =
1220          T of {args: (Var.t * Type.t) vector,
1221                label: Label.t,
1222                statements: Statement.t vector,
1223                transfer: Transfer.t}
1224
1225       local
1226          fun make f (T r) = f r
1227       in
1228          val args = make #args
1229          val label = make #label
1230          val transfer = make #transfer
1231       end
1232
1233       fun layout' (T {label, args, statements, transfer}, layoutVar) =
1234          let
1235             open Layout
1236             fun layoutStatement s = Statement.layout' (s, layoutVar)
1237             fun layoutTransfer t = Transfer.layout' (t, layoutVar)
1238          in
1239             align [seq [Label.layout label, str " ",
1240                         layoutFormals args],
1241                    indent (align
1242                            [align
1243                             (Vector.toListMap (statements, layoutStatement)),
1244                             layoutTransfer transfer],
1245                            2)]
1246          end
1247       fun layout b = layout' (b, Var.layout)
1248
1249       fun clear (T {label, args, statements, ...}) =
1250          (Label.clear label
1251           ; Vector.foreach (args, Var.clear o #1)
1252           ; Vector.foreach (statements, Statement.clear))
1253    end
1254
1255 structure Datatype =
1256    struct
1257       datatype t =
1258          T of {cons: {args: Type.t Prod.t,
1259                       con: Con.t} vector,
1260                tycon: Tycon.t}
1261
1262       fun layout (T {cons, tycon}) =
1263          let
1264             open Layout
1265          in
1266             seq [Tycon.layout tycon,
1267                  str " = ",
1268                  alignPrefix
1269                  (Vector.toListMap
1270                   (cons, fn {con, args} =>
1271                    seq [Con.layout con, str " of ",
1272                         Prod.layout (args, Type.layout)]),
1273                   "| ")]
1274          end
1275
1276       fun clear (T {cons, tycon}) =
1277          (Tycon.clear tycon
1278           ; Vector.foreach (cons, Con.clear o #con))
1279    end
1280
1281 structure Function =
1282    struct
1283       structure CPromise = ClearablePromise
1284
1285       type dest = {args: (Var.t * Type.t) vector,
1286                    blocks: Block.t vector,
1287                    mayInline: bool,
1288                    name: Func.t,
1289                    raises: Type.t vector option,
1290                    returns: Type.t vector option,
1291                    start: Label.t}
1292
1293       (* There is a messy interaction between the laziness used in controlFlow
1294        * and the property lists on labels because the former stores
1295        * stuff on the property lists.  So, if you force the laziness, then
1296        * clear the property lists, then try to use the lazy stuff, you will
1297        * get screwed with undefined properties.  The right thing to do is reset
1298        * the laziness when the properties are cleared.
1299        *)
1300       datatype t =
1301          T of {controlFlow:
1302                {dfsTree: unit -> Block.t Tree.t,
1303                 dominatorTree: unit -> Block.t Tree.t,
1304                 graph: unit DirectedGraph.t,
1305                 labelNode: Label.t -> unit DirectedGraph.Node.t,
1306                 nodeBlock: unit DirectedGraph.Node.t -> Block.t} CPromise.t,
1307                dest: dest}
1308
1309       local
1310          fun make f (T {dest, ...}) = f dest
1311       in
1312          val blocks = make #blocks
1313          val dest = make (fn d => d)
1314          val name = make #name
1315       end
1316
1317       fun foreachVar (f: t, fx: Var.t * Type.t -> unit): unit =
1318          let
1319             val {args, blocks, ...} = dest f
1320             val _ = Vector.foreach (args, fx)
1321             val _ =
1322                Vector.foreach
1323                (blocks, fn Block.T {args, statements, ...} =>
1324                 (Vector.foreach (args, fx)
1325                  ; Vector.foreach (statements, fn s =>
1326                                    Statement.foreachDef (s, fx))))
1327          in
1328             ()
1329          end
1330
1331       fun controlFlow (T {controlFlow, ...}) =
1332          let
1333             val {graph, labelNode, nodeBlock, ...} = CPromise.force controlFlow
1334          in
1335             {graph = graph, labelNode = labelNode, nodeBlock = nodeBlock}
1336          end
1337
1338       local
1339          fun make sel =
1340             fn T {controlFlow, ...} => sel (CPromise.force controlFlow) ()
1341       in
1342          val dominatorTree = make #dominatorTree
1343       end
1344
1345       fun dfs (f, v) =
1346          let
1347             val {blocks, start, ...} = dest f
1348             val numBlocks = Vector.length blocks
1349             val {get = labelIndex, set = setLabelIndex, rem, ...} =
1350                Property.getSetOnce (Label.plist,
1351                                     Property.initRaise ("index", Label.layout))
1352             val _ = Vector.foreachi (blocks, fn (i, Block.T {label, ...}) =>
1353                                      setLabelIndex (label, i))
1354             val visited = Array.array (numBlocks, false)
1355             fun visit (l: Label.t): unit =
1356                let
1357                   val i = labelIndex l
1358                in
1359                   if Array.sub (visited, i)
1360                      then ()
1361                   else
1362                      let
1363                         val _ = Array.update (visited, i, true)
1364                         val b as Block.T {transfer, ...} =
1365                            Vector.sub (blocks, i)
1366                         val v' = v b
1367                         val _ = Transfer.foreachLabel (transfer, visit)
1368                         val _ = v' ()
1369                      in
1370                         ()
1371                      end
1372                end
1373             val _ = visit start
1374             val _ = Vector.foreach (blocks, rem o Block.label)
1375          in
1376             ()
1377          end
1378
1379       local
1380          structure Graph = DirectedGraph
1381          structure Node = Graph.Node
1382          structure Edge = Graph.Edge
1383       in
1384          fun determineControlFlow ({blocks, start, ...}: dest) =
1385             let
1386                open Dot
1387                val g = Graph.new ()
1388                fun newNode () = Graph.newNode g
1389                val {get = labelNode, ...} =
1390                   Property.get
1391                   (Label.plist, Property.initFun (fn _ => newNode ()))
1392                val {get = nodeInfo: unit Node.t -> {block: Block.t},
1393                     set = setNodeInfo, ...} =
1394                   Property.getSetOnce
1395                   (Node.plist, Property.initRaise ("info", Node.layout))
1396                val _ =
1397                   Vector.foreach
1398                   (blocks, fn b as Block.T {label, transfer, ...} =>
1399                    let
1400                       val from = labelNode label
1401                       val _ = setNodeInfo (from, {block = b})
1402                       val _ =
1403                          Transfer.foreachLabel
1404                          (transfer, fn to =>
1405                           (ignore o Graph.addEdge)
1406                           (g, {from = from, to = labelNode to}))
1407                    in
1408                       ()
1409                    end)
1410                val root = labelNode start
1411                val dfsTree =
1412                   Promise.lazy
1413                   (fn () =>
1414                    Graph.dfsTree (g, {root = root,
1415                                       nodeValue = #block o nodeInfo}))
1416                val dominatorTree =
1417                   Promise.lazy
1418                   (fn () =>
1419                    Graph.dominatorTree (g, {root = root,
1420                                             nodeValue = #block o nodeInfo}))
1421             in
1422                {dfsTree = dfsTree,
1423                 dominatorTree = dominatorTree,
1424                 graph = g,
1425                 labelNode = labelNode,
1426                 nodeBlock = #block o nodeInfo}
1427             end
1428
1429          fun layoutDot (f, layoutVar) =
1430             let
1431                fun toStringStatement s = Layout.toString (Statement.layout' (s, layoutVar))
1432                fun toStringTransfer t =
1433                   Layout.toString
1434                   (case t of
1435                       Case {test, ...} =>
1436                          Layout.seq [Layout.str "case ", layoutVar test]
1437                     | _ => Transfer.layout' (t, layoutVar))
1438                fun toStringFormals args = Layout.toString (layoutFormals args)
1439                fun toStringHeader (name, args) = concat [name, " ", toStringFormals args]
1440                val {name, args, start, blocks, returns, raises, ...} = dest f
1441                open Dot
1442                val graph = Graph.new ()
1443                val {get = nodeOptions, ...} =
1444                   Property.get (Node.plist, Property.initFun (fn _ => ref []))
1445                fun setNodeText (n: unit Node.t, l): unit =
1446                   List.push (nodeOptions n, NodeOption.Label l)
1447                fun newNode () = Graph.newNode graph
1448                val {destroy, get = labelNode} =
1449                   Property.destGet (Label.plist,
1450                                     Property.initFun (fn _ => newNode ()))
1451                val {get = edgeOptions, set = setEdgeOptions, ...} =
1452                   Property.getSetOnce (Edge.plist, Property.initConst [])
1453                fun edge (from, to, label: string, style: style): unit =
1454                   let
1455                      val e = Graph.addEdge (graph, {from = from,
1456                                                     to = to})
1457                      val _ = setEdgeOptions (e, [EdgeOption.label label,
1458                                                  EdgeOption.Style style])
1459                   in
1460                      ()
1461                   end
1462                val _ =
1463                   Vector.foreach
1464                   (blocks, fn Block.T {label, args, statements, transfer} =>
1465                    let
1466                       val from = labelNode label
1467                       val edge = fn (to, label, style) =>
1468                          edge (from, labelNode to, label, style)
1469                       val () =
1470                          case transfer of
1471                             Arith {overflow, success, ...} =>
1472                                (edge (success, "", Solid)
1473                                 ; edge (overflow, "Overflow", Dashed))
1474                           | Bug => ()
1475                           | Call {return, ...} =>
1476                                let
1477                                   val _ =
1478                                      case return of
1479                                         Return.Dead => ()
1480                                       | Return.NonTail {cont, handler} =>
1481                                            (edge (cont, "", Dotted)
1482                                             ; (Handler.foreachLabel
1483                                                (handler, fn l =>
1484                                                 edge (l, "Handle", Dashed))))
1485                                       | Return.Tail => ()
1486                                in
1487                                   ()
1488                                end
1489                           | Case {cases, default, ...} =>
1490                                let
1491                                   fun doit (v, toString) =
1492                                      Vector.foreach
1493                                      (v, fn (x, j) =>
1494                                       edge (j, toString x, Solid))
1495                                   val _ =
1496                                      case cases of
1497                                         Cases.Con v =>
1498                                            doit (v, Con.toString)
1499                                       | Cases.Word (_, v) =>
1500                                            doit (v, WordX.toString)
1501                                   val _ =
1502                                      case default of
1503                                         NONE => ()
1504                                       | SOME j =>
1505                                            edge (j, "Default", Solid)
1506                                in
1507                                   ()
1508                                end
1509                           | Goto {dst, ...} => edge (dst, "", Solid)
1510                           | Raise _ => ()
1511                           | Return _ => ()
1512                           | Runtime {return, ...} => edge (return, "", Dotted)
1513                       val lab =
1514                          [(toStringTransfer transfer, Left)]
1515                       val lab =
1516                          Vector.foldr
1517                          (statements, lab, fn (s, ac) =>
1518                           (toStringStatement s, Left) :: ac)
1519                       val lab =
1520                          (toStringHeader (Label.toString label, args), Left)::lab
1521                       val _ = setNodeText (from, lab)
1522                    in
1523                       ()
1524                    end)
1525                val startNode = labelNode start
1526                val funNode =
1527                   let
1528                      val funNode = newNode ()
1529                      val _ = edge (funNode, startNode, "Start", Solid)
1530                      val lab =
1531                         [(toStringTransfer (Transfer.Goto {dst = start, args = Vector.new0 ()}), Left)]
1532                      val lab =
1533                         if !Control.showTypes
1534                            then ((Layout.toString o Layout.seq)
1535                                  [Layout.str ": ",
1536                                   Layout.record [("returns",
1537                                                   Option.layout
1538                                                   (Vector.layout Type.layout)
1539                                                   returns),
1540                                                  ("raises",
1541                                                   Option.layout
1542                                                   (Vector.layout Type.layout)
1543                                                   raises)]],
1544                                  Left)::lab
1545                            else lab
1546                      val lab =
1547                         (toStringHeader ("fun " ^ Func.toString name, args), Left)::
1548                         lab
1549                      val _ = setNodeText (funNode, lab)
1550                   in
1551                      funNode
1552                   end
1553                val controlFlowGraphLayout =
1554                   Graph.layoutDot
1555                   (graph, fn {nodeName} =>
1556                    {title = concat [Func.toString name, " control-flow graph"],
1557                     options = [GraphOption.Rank (Min, [{nodeName = nodeName funNode}])],
1558                     edgeOptions = edgeOptions,
1559                     nodeOptions =
1560                     fn n => let
1561                                val l = ! (nodeOptions n)
1562                                open NodeOption
1563                             in FontColor Black :: Shape Box :: l
1564                             end})
1565                val () = Graph.removeNode (graph, funNode)
1566                fun dominatorTreeLayout () =
1567                   let
1568                      val {get = nodeOptions, set = setNodeOptions, ...} =
1569                         Property.getSetOnce (Node.plist, Property.initConst [])
1570                      val _ =
1571                         Vector.foreach
1572                         (blocks, fn Block.T {label, ...} =>
1573                          setNodeOptions (labelNode label,
1574                                          [NodeOption.label (Label.toString label)]))
1575                      val dominatorTreeLayout =
1576                         Tree.layoutDot
1577                         (Graph.dominatorTree (graph,
1578                                               {root = startNode,
1579                                                nodeValue = fn n => n}),
1580                          {title = concat [Func.toString name, " dominator tree"],
1581                           options = [],
1582                           nodeOptions = nodeOptions})
1583                   in
1584                      dominatorTreeLayout
1585                   end
1586                fun loopForestLayout () =
1587                   let
1588                      val {get = nodeName, set = setNodeName, ...} =
1589                         Property.getSetOnce (Node.plist, Property.initConst "")
1590                      val _ =
1591                         Vector.foreach
1592                         (blocks, fn Block.T {label, ...} =>
1593                          setNodeName (labelNode label, Label.toString label))
1594                      val loopForestLayout =
1595                         Graph.LoopForest.layoutDot
1596                         (Graph.loopForestSteensgaard (graph,
1597                                                       {root = startNode}),
1598                          {title = concat [Func.toString name, " loop forest"],
1599                           options = [],
1600                           nodeName = nodeName})
1601                   in
1602                      loopForestLayout
1603                   end
1604             in
1605                {destroy = destroy,
1606                 controlFlowGraph = controlFlowGraphLayout,
1607                 dominatorTree = dominatorTreeLayout,
1608                 loopForest = loopForestLayout}
1609             end
1610       end
1611
1612       fun new (dest: dest) =
1613          let
1614             val controlFlow = CPromise.delay (fn () => determineControlFlow dest)
1615          in
1616             T {controlFlow = controlFlow,
1617                dest = dest}
1618          end
1619
1620       fun clear (T {controlFlow, dest, ...}) =
1621          let
1622             val {args, blocks, ...} = dest
1623             val _ = (Vector.foreach (args, Var.clear o #1)
1624                      ; Vector.foreach (blocks, Block.clear))
1625             val _ = CPromise.clear controlFlow
1626          in
1627             ()
1628          end
1629
1630       fun layoutHeader (f: t): Layout.t =
1631          let
1632             val {args, name, raises, returns, start, ...} = dest f
1633             open Layout
1634             val (sep, rty) =
1635                if !Control.showTypes
1636                   then (str ":",
1637                         indent (seq [record [("returns",
1638                                               Option.layout
1639                                               (Vector.layout Type.layout)
1640                                               returns),
1641                                              ("raises",
1642                                               Option.layout
1643                                               (Vector.layout Type.layout)
1644                                               raises)],
1645                                      str " ="],
1646                                 2))
1647                   else (str " =", empty)
1648          in
1649             mayAlign [mayAlign [seq [str "fun ",
1650                                      Func.layout name,
1651                                      str " ",
1652                                      layoutFormals args,
1653                                      sep],
1654                                 rty],
1655                       Transfer.layout (Transfer.Goto {dst = start, args = Vector.new0 ()})]
1656          end
1657
1658       fun layout' (f: t, layoutVar) =
1659          let
1660             val {blocks, ...} = dest f
1661             open Layout
1662             fun layoutBlock b = Block.layout' (b, layoutVar)
1663          in
1664             align [layoutHeader f,
1665                    indent (align (Vector.toListMap (blocks, layoutBlock)), 2)]
1666          end
1667       fun layout f = layout' (f, Var.layout)
1668
1669       fun layouts (f: t, layoutVar, output: Layout.t -> unit): unit =
1670          let
1671             val {blocks, name, ...} = dest f
1672             val _ = output (layoutHeader f)
1673             val _ =
1674                Vector.foreach
1675                (blocks, fn b =>
1676                 output (Layout.indent (Block.layout' (b, layoutVar), 2)))
1677             val _ =
1678                if not (!Control.keepDot)
1679                   then ()
1680                else
1681                   let
1682                      val {destroy, controlFlowGraph, dominatorTree, loopForest} =
1683                         layoutDot (f, layoutVar)
1684                      val name = Func.toString name
1685                      fun doit (s, g) =
1686                         let
1687                            open Control
1688                         in
1689                            saveToFile
1690                            ({suffix = concat [name, ".", s, ".dot"]},
1691                             Dot, (), Layout (fn () => g))
1692                         end
1693                      val _ = doit ("cfg", controlFlowGraph)
1694                         handle _ => Error.warning "SsaTree2.layouts: couldn't layout cfg"
1695                      val _ = doit ("dom", dominatorTree ())
1696                         handle _ => Error.warning "SsaTree2.layouts: couldn't layout dom"
1697                      val _ = doit ("lf", loopForest ())
1698                         handle _ => Error.warning "SsaTree2.layouts: couldn't layout lf"
1699                      val () = destroy ()
1700                   in
1701                      ()
1702                   end
1703          in
1704             ()
1705          end
1706
1707       fun alphaRename f =
1708          let
1709             local
1710                fun make (new, plist) =
1711                   let
1712                      val {get, set, destroy, ...} =
1713                         Property.destGetSetOnce (plist, Property.initConst NONE)
1714                      fun bind x =
1715                         let
1716                            val x' = new x
1717                            val _ = set (x, SOME x')
1718                         in
1719                            x'
1720                         end
1721                      fun lookup x =
1722                         case get x of
1723                            NONE => x
1724                          | SOME y => y
1725                   in (bind, lookup, destroy)
1726                   end
1727             in
1728                val (bindVar, lookupVar, destroyVar) =
1729                   make (Var.new, Var.plist)
1730                val (bindLabel, lookupLabel, destroyLabel) =
1731                   make (Label.new, Label.plist)
1732             end
1733             val {args, blocks, mayInline, name, raises, returns, start, ...} =
1734                dest f
1735             val args = Vector.map (args, fn (x, ty) => (bindVar x, ty))
1736             val bindLabel = ignore o bindLabel
1737             val bindVar = ignore o bindVar
1738             val _ =
1739                Vector.foreach
1740                (blocks, fn Block.T {label, args, statements, ...} =>
1741                 (bindLabel label
1742                  ; Vector.foreach (args, fn (x, _) => bindVar x)
1743                  ; Vector.foreach (statements, fn s =>
1744                                    Statement.foreachDef (s, bindVar o #1))))
1745             val blocks =
1746                Vector.map
1747                (blocks, fn Block.T {label, args, statements, transfer} =>
1748                 Block.T {label = lookupLabel label,
1749                          args = Vector.map (args, fn (x, ty) =>
1750                                             (lookupVar x, ty)),
1751                          statements = (Vector.map
1752                                        (statements, fn s =>
1753                                         Statement.replaceDefsUses
1754                                         (s, {def = lookupVar,
1755                                              use = lookupVar}))),
1756                          transfer = Transfer.replaceLabelVar
1757                                     (transfer, lookupLabel, lookupVar)})
1758             val start = lookupLabel start
1759             val _ = destroyVar ()
1760             val _ = destroyLabel ()
1761          in
1762             new {args = args,
1763                  blocks = blocks,
1764                  mayInline = mayInline,
1765                  name = name,
1766                  raises = raises,
1767                  returns = returns,
1768                  start = start}
1769          end
1770       (* quell unused warning *)
1771       val _ = alphaRename
1772
1773       fun profile (f: t, sourceInfo): t =
1774          if !Control.profile = Control.ProfileNone
1775             orelse !Control.profileIL <> Control.ProfileSource
1776             then f
1777          else
1778          let
1779             val _ = Control.diagnostic (fn () => layout f)
1780             val {args, blocks, mayInline, name, raises, returns, start} = dest f
1781             val extraBlocks = ref []
1782             val {get = labelBlock, set = setLabelBlock, rem} =
1783                Property.getSetOnce
1784                (Label.plist, Property.initRaise ("block", Label.layout))
1785             val _ =
1786                Vector.foreach
1787                (blocks, fn block as Block.T {label, ...} =>
1788                 setLabelBlock (label, block))
1789             val blocks =
1790                Vector.map
1791                (blocks, fn Block.T {args, label, statements, transfer} =>
1792                 let
1793                    val statements =
1794                       if Label.equals (label, start)
1795                          then (Vector.concat
1796                                [Vector.new1
1797                                 (Profile (ProfileExp.Enter sourceInfo)),
1798                                 statements])
1799                       else statements
1800                    fun leave () = Profile (ProfileExp.Leave sourceInfo)
1801                    fun prefix (l: Label.t,
1802                                statements: Statement.t vector): Label.t =
1803                       let
1804                          val Block.T {args, ...} = labelBlock l
1805                          val c = Label.newNoname ()
1806                          val xs = Vector.map (args, fn (x, _) => Var.new x)
1807                          val _ =
1808                             List.push
1809                             (extraBlocks,
1810                              Block.T
1811                              {args = Vector.map2 (xs, args, fn (x, (_, t)) =>
1812                                                   (x, t)),
1813                               label = c,
1814                               statements = statements,
1815                               transfer = Goto {args = xs,
1816                                                dst = l}})
1817                       in
1818                          c
1819                       end
1820                    fun genHandler (cont: Label.t)
1821                       : Statement.t vector * Label.t * Handler.t =
1822                       case raises of
1823                          NONE => (statements, cont, Handler.Caller)
1824                        | SOME ts =>
1825                             let
1826                                val xs = Vector.map (ts, fn _ => Var.newNoname ())
1827                                val l = Label.newNoname ()
1828                                val _ =
1829                                   List.push
1830                                   (extraBlocks,
1831                                    Block.T
1832                                    {args = Vector.zip (xs, ts),
1833                                     label = l,
1834                                     statements = Vector.new1 (leave ()),
1835                                     transfer = Transfer.Raise xs})
1836                             in
1837                                (statements,
1838                                 prefix (cont, Vector.new0 ()),
1839                                 Handler.Handle l)
1840                             end
1841                    fun addLeave () =
1842                       (Vector.concat [statements,
1843                                       Vector.new1 (leave ())],
1844                        transfer)
1845                    val (statements, transfer) =
1846                       case transfer of
1847                          Call {args, func, return} =>
1848                             let
1849                                datatype z = datatype Return.t
1850                             in
1851                                case return of
1852                                   Dead => (statements, transfer)
1853                                 | NonTail {cont, handler} =>
1854                                      (case handler of
1855                                          Handler.Dead => (statements, transfer)
1856                                        | Handler.Caller =>
1857                                             let
1858                                                val (statements, cont, handler) =
1859                                                   genHandler cont
1860                                                val return =
1861                                                   Return.NonTail
1862                                                   {cont = cont,
1863                                                    handler = handler}
1864                                             in
1865                                                (statements,
1866                                                 Call {args = args,
1867                                                       func = func,
1868                                                       return = return})
1869                                             end
1870                                        | Handler.Handle _ =>
1871                                             (statements, transfer))
1872                                 | Tail => addLeave ()
1873                             end
1874                        | Raise _ => addLeave ()
1875                        | Return _ => addLeave ()
1876                        | _ => (statements, transfer)
1877                 in
1878                    Block.T {args = args,
1879                             label = label,
1880                             statements = statements,
1881                             transfer = transfer}
1882                 end)
1883             val _ = Vector.foreach (blocks, rem o Block.label)
1884             val blocks = Vector.concat [Vector.fromList (!extraBlocks), blocks]
1885             val f =
1886                new {args = args,
1887                     blocks = blocks,
1888                     mayInline = mayInline,
1889                     name = name,
1890                     raises = raises,
1891                     returns = returns,
1892                     start = start}
1893             val _ = Control.diagnostic (fn () => layout f)
1894          in
1895             f
1896          end
1897
1898       val profile =
1899          Trace.trace2 ("SsaTree2.Function.profile", layout, SourceInfo.layout, layout)
1900          profile
1901    end
1902
1903 structure Program =
1904    struct
1905       datatype t =
1906          T of {
1907                datatypes: Datatype.t vector,
1908                globals: Statement.t vector,
1909                functions: Function.t list,
1910                main: Func.t
1911                }
1912    end
1913
1914 structure Program =
1915    struct
1916       open Program
1917
1918       local
1919          structure Graph = DirectedGraph
1920          structure Node = Graph.Node
1921          structure Edge = Graph.Edge
1922       in
1923          fun layoutCallGraph (T {functions, main, ...},
1924                               title: string): Layout.t =
1925             let
1926                open Dot
1927                val graph = Graph.new ()
1928                val {get = nodeOptions, set = setNodeOptions, ...} =
1929                   Property.getSetOnce
1930                   (Node.plist, Property.initRaise ("options", Node.layout))
1931                val {get = funcNode, destroy} =
1932                   Property.destGet
1933                   (Func.plist, Property.initFun
1934                    (fn f =>
1935                     let
1936                        val n = Graph.newNode graph
1937                        val _ =
1938                           setNodeOptions
1939                           (n,
1940                            let open NodeOption
1941                            in [FontColor Black, label (Func.toString f)]
1942                            end)
1943                     in
1944                        n
1945                     end))
1946                val {get = edgeOptions, set = setEdgeOptions, ...} =
1947                   Property.getSetOnce (Edge.plist, Property.initConst [])
1948                val _ =
1949                   List.foreach
1950                   (functions, fn f =>
1951                    let
1952                       val {name, blocks, ...} = Function.dest f
1953                       val from = funcNode name
1954                       val {get, destroy} =
1955                          Property.destGet
1956                          (Node.plist,
1957                           Property.initFun (fn _ => {nontail = ref false,
1958                                                      tail = ref false}))
1959                       val _ =
1960                          Vector.foreach
1961                          (blocks, fn Block.T {transfer, ...} =>
1962                           case transfer of
1963                              Call {func, return, ...} =>
1964                                 let
1965                                    val to = funcNode func
1966                                    val {tail, nontail} = get to
1967                                    datatype z = datatype Return.t
1968                                    val is =
1969                                       case return of
1970                                          Dead => false
1971                                        | NonTail _ => true
1972                                        | Tail => false
1973                                    val r = if is then nontail else tail
1974                                 in
1975                                    if !r
1976                                       then ()
1977                                    else (r := true
1978                                          ; (setEdgeOptions
1979                                             (Graph.addEdge
1980                                              (graph, {from = from, to = to}),
1981                                              if is
1982                                                 then []
1983                                              else [EdgeOption.Style Dotted])))
1984                                 end
1985                            | _ => ())
1986                       val _ = destroy ()
1987                    in
1988                       ()
1989                    end)
1990                val root = funcNode main
1991                val l =
1992                   Graph.layoutDot
1993                   (graph, fn {nodeName} =>
1994                    {title = title,
1995                     options = [GraphOption.Rank (Min, [{nodeName = nodeName root}])],
1996                     edgeOptions = edgeOptions,
1997                     nodeOptions = nodeOptions})
1998                val _ = destroy ()
1999             in
2000                l
2001             end
2002       end
2003
2004       fun layouts (p as T {datatypes, globals, functions, main},
2005                    output': Layout.t -> unit) =
2006          let
2007             val layoutVar = Statement.prettifyGlobals globals
2008             open Layout
2009             (* Layout includes an output function, so we need to rebind output
2010              * to the one above.
2011              *)
2012             val output = output'
2013          in
2014             output (str "\n\nDatatypes:")
2015             ; Vector.foreach (datatypes, output o Datatype.layout)
2016             ; output (str "\n\nGlobals:")
2017             ; Vector.foreach (globals, output o (fn s => Statement.layout' (s, layoutVar)))
2018             ; output (seq [str "\n\nMain: ", Func.layout main])
2019             ; output (str "\n\nFunctions:")
2020             ; List.foreach (functions, fn f =>
2021                             Function.layouts (f, layoutVar, output))
2022             ; if not (!Control.keepDot)
2023                  then ()
2024               else
2025                  let
2026                     open Control
2027                  in
2028                     saveToFile
2029                     ({suffix = "call-graph.dot"},
2030                      Dot, (), Layout (fn () =>
2031                                       layoutCallGraph (p, !Control.inputFile)))
2032                  end
2033          end
2034
2035       fun layoutStats (T {datatypes, globals, functions, main, ...}) =
2036          let
2037             val (mainNumVars, mainNumBlocks) =
2038                case List.peek (functions, fn f =>
2039                                Func.equals (main, Function.name f)) of
2040                   NONE => Error.bug "SsaTree2.Program.layoutStats: no main"
2041                 | SOME f =>
2042                      let
2043                         val numVars = ref 0
2044                         val _ = Function.foreachVar (f, fn _ => Int.inc numVars)
2045                         val {blocks, ...} = Function.dest f
2046                         val numBlocks = Vector.length blocks
2047                      in
2048                         (!numVars, numBlocks)
2049                      end
2050             val numTypes = ref 0
2051             val {get = countType, destroy} =
2052                Property.destGet
2053                (Type.plist,
2054                 Property.initRec
2055                 (fn (t, countType) =>
2056                  let
2057                     datatype z = datatype Type.dest
2058                     val _ =
2059                        case Type.dest t of
2060                           CPointer => ()
2061                         | Datatype _ => ()
2062                         | IntInf => ()
2063                         | Object {args, ...} => Prod.foreach (args, countType)
2064                         | Real _ => ()
2065                         | Thread => ()
2066                         | Weak t => countType t
2067                         | Word _ => ()
2068                     val _ = Int.inc numTypes
2069                  in
2070                     ()
2071                  end))
2072             val _ =
2073                Vector.foreach
2074                (datatypes, fn Datatype.T {cons, ...} =>
2075                 Vector.foreach (cons, fn {args, ...} =>
2076                                 Prod.foreach (args, countType)))
2077             val numStatements = ref (Vector.length globals)
2078             val numBlocks = ref 0
2079             val _ =
2080                List.foreach
2081                (functions, fn f =>
2082                 let
2083                    val {args, blocks, ...} = Function.dest f
2084                    val _ = Vector.foreach (args, countType o #2)
2085                    val _ =
2086                       Vector.foreach
2087                       (blocks, fn Block.T {args, statements, ...} =>
2088                        let
2089                           val _ = Int.inc numBlocks
2090                           val _ = Vector.foreach (args, countType o #2)
2091                           val _ =
2092                              Vector.foreach
2093                              (statements, fn stmt =>
2094                               let
2095                                  val _ = Int.inc numStatements
2096                                  datatype z = datatype Statement.t
2097                                  val _ =
2098                                     case stmt of
2099                                        Bind {ty, ...} => countType ty
2100                                      | _ => ()
2101                               in () end)
2102                        in () end)
2103                 in () end)
2104             val numFunctions = List.length functions
2105             val _ = destroy ()
2106             open Layout
2107          in
2108             align
2109             [seq [str "num vars in main = ", Int.layout mainNumVars],
2110              seq [str "num blocks in main = ", Int.layout mainNumBlocks],
2111              seq [str "num functions in program = ", Int.layout numFunctions],
2112              seq [str "num blocks in program = ", Int.layout (!numBlocks)],
2113              seq [str "num statements in program = ", Int.layout (!numStatements)],
2114              seq [str "num types in program = ", Int.layout (!numTypes)],
2115              Type.stats ()]
2116          end
2117
2118       (* clear all property lists reachable from program *)
2119       fun clear (T {datatypes, globals, functions, ...}) =
2120          ((* Can't do Type.clear because it clears out the info needed for
2121            * Type.dest.
2122            *)
2123           Vector.foreach (datatypes, Datatype.clear)
2124           ; Vector.foreach (globals, Statement.clear)
2125           ; List.foreach (functions, Function.clear))
2126
2127       fun clearGlobals (T {globals, ...}) =
2128          Vector.foreach (globals, Statement.clear)
2129
2130       fun clearTop (p as T {datatypes, functions, ...}) =
2131          (Vector.foreach (datatypes, Datatype.clear)
2132           ; List.foreach (functions, Func.clear o Function.name)
2133           ; clearGlobals p)
2134
2135       fun foreachVar (T {globals, functions, ...}, f) =
2136          (Vector.foreach (globals, fn s => Statement.foreachDef (s, f))
2137           ; List.foreach (functions, fn g => Function.foreachVar (g, f)))
2138
2139       fun foreachPrimApp (T {globals, functions, ...}, f) =
2140          let
2141             fun loopStatement (s: Statement.t) =
2142                case s of
2143                   Bind {exp = PrimApp {args, prim}, ...} =>
2144                      f {args = args, prim = prim}
2145                  | _ => ()
2146              fun loopTransfer t =
2147                 case t of
2148                    Arith {args, prim, ...} => f {args = args, prim = prim}
2149                  | Runtime {args, prim, ...} => f {args = args, prim = prim}
2150                  | _ => ()
2151              val _ = Vector.foreach (globals, loopStatement)
2152              val _ =
2153                 List.foreach
2154                 (functions, fn f =>
2155                  Vector.foreach
2156                  (Function.blocks f, fn Block.T {statements, transfer, ...} =>
2157                   (Vector.foreach (statements, loopStatement);
2158                    loopTransfer transfer)))
2159          in
2160             ()
2161          end
2162
2163       fun hasPrim (p, f) =
2164          Exn.withEscape
2165          (fn escape =>
2166           (foreachPrimApp (p, fn {prim, ...} =>
2167                            if f prim then escape true else ())
2168            ; false))
2169
2170       fun dfs (p, v) =
2171          let
2172             val T {functions, main, ...} = p
2173             val functions = Vector.fromList functions
2174             val numFunctions = Vector.length functions
2175             val {get = funcIndex, set = setFuncIndex, rem, ...} =
2176                Property.getSetOnce (Func.plist,
2177                                     Property.initRaise ("index", Func.layout))
2178             val _ = Vector.foreachi (functions, fn (i, f) =>
2179                                      setFuncIndex (#name (Function.dest f), i))
2180             val visited = Array.array (numFunctions, false)
2181             fun visit (f: Func.t): unit =
2182                let
2183                   val i = funcIndex f
2184                in
2185                   if Array.sub (visited, i)
2186                      then ()
2187                   else
2188                      let
2189                         val _ = Array.update (visited, i, true)
2190                         val f = Vector.sub (functions, i)
2191                         val v' = v f
2192                         val _ = Function.dfs
2193                                 (f, fn Block.T {transfer, ...} =>
2194                                  (Transfer.foreachFunc (transfer, visit)
2195                                   ; fn () => ()))
2196                         val _ = v' ()
2197                      in
2198                         ()
2199                      end
2200                end
2201             val _ = visit main
2202             val _ = Vector.foreach (functions, rem o Function.name)
2203          in
2204             ()
2205          end
2206
2207    end
2208
2209 end