mlton/ssa/simplify-types.fun

   1 (* Copyright (C) 2009 Matthew Fluet.
   2  * Copyright (C) 1999-2005, 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 (* This pass must happen before polymorphic equality is implemented because
  11  * 1. it will make polymorphic equality faster because some types are simpler
  12  * 2. it removes uses of polymorphic equality that must return true
  13  *
  14  * This pass computes a "cardinality" of each datatype, which is an
  15  * abstraction of the number of values of the datatype.
  16  *   Zero means the datatype has no values (except for bottom).
  17  *   One means the datatype has one values (except for bottom).
  18  *   Many means the datatype has many values.
  19  *
  20  * This pass removes all datatypes whose cardinality is Zero or One
  21  * and removes
  22  *   components of tuples
  23  *   function args
  24  *   constructor args
  25  * which are such datatypes.
  26  *
  27  * This pass marks constructors as one of
  28  *   Useless: it never appears in a ConApp.
  29  *   Transparent: it is the only variant in its datatype
  30  *     and its argument type does not contain any uses of
  31  *       Tycon.array or Tycon.vector.
  32  *   Useful: otherwise
  33  * This pass also removes Useless and Transparent constructors.
  34  *
  35  * We must keep track of Transparent constructors whose argument type
  36  * uses Tycon.array because of datatypes like the following:
  37  *   datatype t = T of t array
  38  * Such a datatype has Cardinality.Many, but we cannot eliminate
  39  * the datatype and replace the lhs by the rhs, i.e. we must keep the
  40  * circularity around.
  41  * Must do similar things for vectors.
  42  *
  43  * Also, to eliminate as many Transparent constructors as possible, for
  44  * something like the following,
  45  *   datatype t = T of u array
  46  *   and u = U of t vector
  47  * we (arbitrarily) expand one of the datatypes first.
  48  * The result will be something like
  49  *   datatype u = U of u array array
  50  * where all uses of t are replaced by u array.
  51  *)
  52
  53 functor SimplifyTypes (S: SSA_TRANSFORM_STRUCTS): SSA_TRANSFORM =
  54 struct
  55
  56 open S
  57 open Exp Transfer
  58 structure Cardinality =
  59    struct
  60       datatype t = Zero | One | Many
  61
  62       fun layout c =
  63          Layout.str (case c of
  64                         Zero => "zero"
  65                       | One => "one"
  66                       | Many => "many")
  67
  68       val equals: t * t -> bool = op =
  69    end
  70
  71 structure ConRep =
  72    struct
  73       datatype t =
  74          Useless
  75        | Transparent
  76        | Useful
  77
  78       val isUseful =
  79          fn Useful => true
  80           | _ => false
  81
  82       val isUseless =
  83          fn Useless => true
  84           | _ => false
  85
  86       val toString =
  87          fn Useless => "useless"
  88           | Transparent => "transparent"
  89           | Useful => "useful"
  90
  91       val layout = Layout.str o toString
  92    end
  93
  94 structure Result =
  95    struct
  96       datatype 'a t =
  97          Bugg
  98        | Delete
  99        | Keep of 'a
 100
 101       fun layout layoutX =
 102          let open Layout
 103          in fn Bugg => str "Bug"
 104        | Delete => str "Delete"
 105        | Keep x => seq [str "Keep ", layoutX x]
 106          end
 107    end
 108
 109 fun transform (Program.T {datatypes, globals, functions, main}) =
 110    let
 111       val {get = conInfo: Con.t -> {rep: ConRep.t ref,
 112                                     args: Type.t vector},
 113            set = setConInfo, ...} =
 114          Property.getSetOnce
 115          (Con.plist, Property.initRaise ("SimplifyTypes.conInfo", Con.layout))
 116       val conInfo =
 117          Trace.trace ("SimplifyTypes.conInfo",
 118                       Con.layout,
 119                       fn {rep, args} =>
 120                       Layout.record [("rep", ConRep.layout (!rep)),
 121                                      ("args", Vector.layout Type.layout args)])
 122          conInfo
 123       val conRep = ! o #rep o conInfo
 124       val conArgs = #args o conInfo
 125       fun setConRep (con, r) = #rep (conInfo con) := r
 126       val setConRep =
 127          Trace.trace2
 128          ("SimplifyTypes.setConRep", Con.layout, ConRep.layout, Unit.layout)
 129          setConRep
 130       val conIsUseful = ConRep.isUseful o conRep
 131       val conIsUseful =
 132          Trace.trace
 133          ("SimplifyTypes.conIsUseful", Con.layout, Bool.layout)
 134          conIsUseful
 135       (* Initialize conInfo *)
 136       val _ =
 137          Vector.foreach
 138          (datatypes, fn Datatype.T {cons, ...} =>
 139           Vector.foreach (cons, fn {con, args} =>
 140                           setConInfo (con, {rep = ref ConRep.Useless,
 141                                             args = args})))
 142       val {get = tyconReplacement: Tycon.t -> Type.t option,
 143            set = setTyconReplacement, ...} =
 144          Property.getSet (Tycon.plist, Property.initConst NONE)
 145       val setTyconReplacement = fn (c, t) => setTyconReplacement (c, SOME t)
 146       val {get = tyconInfo: Tycon.t -> {
 147                                         cardinality: Cardinality.t ref,
 148                                         cons: {
 149                                                con: Con.t,
 150                                                args: Type.t vector
 151                                                } vector ref,
 152                                         numCons: int ref,
 153                                         (* tycons whose cardinality depends on mine *)
 154                                         dependents: Tycon.t list ref,
 155                                         isOnWorklist: bool ref
 156                                         },
 157            set = setTyconInfo, ...} =
 158          Property.getSetOnce
 159          (Tycon.plist, Property.initRaise ("SimplifyTypes.tyconInfo", Tycon.layout))
 160
 161       local
 162          fun make sel = (! o sel o tyconInfo,
 163                          fn (t, x) => sel (tyconInfo t) := x)
 164       in
 165          val (tyconNumCons, setTyconNumCons) = make #numCons
 166          val (tyconCardinality, _) = make #cardinality
 167       end
 168       val _ =
 169          Vector.foreach
 170          (datatypes, fn Datatype.T {tycon, cons} =>
 171           setTyconInfo (tycon, {
 172                                 cardinality = ref Cardinality.Zero,
 173                                 numCons = ref 0,
 174                                 cons = ref cons,
 175                                 dependents = ref [],
 176                                 isOnWorklist = ref false
 177                                 }))
 178       (* Tentatively mark all constructors appearing in a ConApp as Useful
 179        * (some may later be marked as Transparent).
 180        *)
 181       val _ =
 182          let
 183             fun handleStatement (Statement.T {exp, ...}) =
 184                case exp of
 185                   ConApp {con, ...} => setConRep (con, ConRep.Useful)
 186                 | _ => ()
 187             (* Booleans are special because they are generated by primitives. *)
 188             val _ =
 189                List.foreach ([Con.truee, Con.falsee], fn c =>
 190                              setConRep (c, ConRep.Useful))
 191             val _ = Vector.foreach (globals, handleStatement)
 192             val _ = List.foreach
 193                     (functions, fn f =>
 194                      Vector.foreach
 195                      (Function.blocks f, fn Block.T {statements, ...} =>
 196                       Vector.foreach (statements, handleStatement)))
 197          in ()
 198          end
 199
 200       (* Remove useless constructors from datatypes.
 201        * Remove datatypes which have no cons.
 202        *)
 203       val datatypes =
 204          Vector.keepAllMap
 205          (datatypes, fn Datatype.T {tycon, cons} =>
 206           let
 207              val cons = Vector.keepAll (cons, conIsUseful o #con)
 208           in
 209              if Vector.isEmpty cons
 210                 then (setTyconReplacement (tycon, Type.unit)
 211                       ; NONE)
 212              else (#cons (tyconInfo tycon) := cons
 213                    ; SOME (Datatype.T {tycon = tycon, cons = cons}))
 214           end)
 215       (* Build the dependents for each tycon. *)
 216       val _ =
 217          Vector.foreach
 218          (datatypes, fn Datatype.T {tycon, cons} =>
 219           let
 220              datatype z = datatype Type.dest
 221              val {get = setTypeDependents, destroy = destroyTypeDependents} =
 222                 Property.destGet
 223                 (Type.plist,
 224                  Property.initRec
 225                  (fn (t, setTypeDependents) =>
 226                   case Type.dest t of
 227                      Array t => setTypeDependents t
 228                    | CPointer => ()
 229                    | Datatype tycon' =>
 230                         List.push (#dependents (tyconInfo tycon'), tycon)
 231                    | IntInf => ()
 232                    | Real _ => ()
 233                    | Ref t => setTypeDependents t
 234                    | Thread => ()
 235                    | Tuple ts => Vector.foreach (ts, setTypeDependents)
 236                    | Vector t => setTypeDependents t
 237                    | Weak t => setTypeDependents t
 238                    | Word _ => ()))
 239              val _ =
 240                 Vector.foreach (cons, fn {args, ...} =>
 241                                 Vector.foreach (args, setTypeDependents))
 242              val _ = destroyTypeDependents ()
 243           in ()
 244           end)
 245       (* diagnostic *)
 246       val _ =
 247          Control.diagnostics
 248          (fn display =>
 249           let open Layout
 250           in Vector.foreach
 251              (datatypes, fn Datatype.T {tycon, ...} =>
 252               display (seq [str "dependents of ",
 253                             Tycon.layout tycon,
 254                             str " = ",
 255                             List.layout Tycon.layout
 256                             (!(#dependents (tyconInfo tycon)))]))
 257           end)
 258
 259       local open Type Cardinality
 260       in
 261          fun typeCardinality t =
 262             case dest t of
 263                Datatype tycon => tyconCardinality tycon
 264              | Ref t => pointerCardinality t
 265              | Tuple ts => tupleCardinality ts
 266              | Weak t => pointerCardinality t
 267              | _ => Many
 268          and pointerCardinality (t: Type.t) =
 269             case typeCardinality t of
 270                Zero => Zero
 271              | _ => Many
 272          and tupleCardinality (ts: Type.t vector) =
 273             Exn.withEscape
 274             (fn escape =>
 275              (Vector.foreach (ts, fn t =>
 276                              let val c = typeCardinality t
 277                              in case c of
 278                                 Many => escape Many
 279                               | One => ()
 280                               | Zero => escape Zero
 281                              end)
 282               ; One))
 283       end
 284       fun conCardinality {args, con = _} = tupleCardinality args
 285       (* Compute the tycon cardinalities with a fixed point,
 286        * initially assuming every datatype tycon cardinality is Zero.
 287        *)
 288       val _ =
 289          let
 290             (* list of datatype tycons whose cardinality has not yet stabilized *)
 291             val worklist =
 292                ref (Vector.fold
 293                     (datatypes, [], fn (Datatype.T {tycon, ...}, ac) =>
 294                      tycon :: ac))
 295             fun loop () =
 296                case !worklist of
 297                   [] => ()
 298                 | tycon :: tycons =>
 299                      (worklist := tycons
 300                       ; let
 301                            val {cons, cardinality, dependents, isOnWorklist,
 302                                 ...} = tyconInfo tycon
 303                            val c =
 304                               Exn.withEscape
 305                               (fn escape =>
 306                                let datatype z = datatype Cardinality.t
 307                                in Vector.fold
 308                                   (!cons, Zero, fn (c, ac) =>
 309                                    case conCardinality c of
 310                                       Many => escape Many
 311                                     | One => (case ac of
 312                                                  Many => Error.bug "SimplifyTypes.simplify: Many"
 313                                                | One => escape Many
 314                                                | Zero => One)
 315                                     | Zero => ac)
 316                                end)
 317                         in isOnWorklist := false
 318                            ; if Cardinality.equals (c, !cardinality)
 319                                 then ()
 320                              else (cardinality := c
 321                                    ; (List.foreach
 322                                       (!dependents, fn tycon =>
 323                                        let
 324                                           val {isOnWorklist, ...} =
 325                                              tyconInfo tycon
 326                                        in if !isOnWorklist
 327                                              then ()
 328                                           else (isOnWorklist := true
 329                                                 ; List.push (worklist, tycon))
 330                                        end)))
 331                         end
 332                       ; loop ())
 333          in loop ()
 334          end
 335       (* diagnostic *)
 336       val _ =
 337          Control.diagnostics
 338          (fn display =>
 339           let open Layout
 340           in Vector.foreach
 341              (datatypes, fn Datatype.T {tycon, ...} =>
 342               display (seq [str "cardinality of ",
 343                             Tycon.layout tycon,
 344                             str " = ",
 345                             Cardinality.layout (tyconCardinality tycon)]))
 346           end)
 347       fun transparent (tycon, con, args) =
 348          (setTyconReplacement (tycon, Type.tuple args)
 349           ; setConRep (con, ConRep.Transparent)
 350           ; setTyconNumCons (tycon, 1))
 351       (* "unary" is datatypes with one constructor whose rhs contains an
 352        * array (or vector) type.
 353        * For datatypes with one variant not containing an array type, eliminate
 354        * the datatype.
 355        *)
 356       fun containsArrayOrVector (ty: Type.t): bool =
 357          let
 358             datatype z = datatype Type.dest
 359             fun loop t =
 360                case Type.dest t of
 361                   Array _ => true
 362                 | Ref t => loop t
 363                 | Tuple ts => Vector.exists (ts, loop)
 364                 | Vector _ => true
 365                 | Weak t => loop t
 366                 | _ => false
 367          in loop ty
 368          end
 369       val (datatypes, unary) =
 370          Vector.fold
 371          (datatypes, ([], []), fn (Datatype.T {tycon, cons}, (datatypes, unary)) =>
 372           let
 373              (* remove all cons with zero cardinality and mark them as useless *)
 374              val cons =
 375                 Vector.keepAllMap
 376                 (cons, fn c as {con, ...} =>
 377                  case conCardinality c of
 378                     Cardinality.Zero => (setConRep (con, ConRep.Useless)
 379                                          ; NONE)
 380                   | _ => SOME c)
 381           in case Vector.length cons of
 382              0 => (setTyconNumCons (tycon, 0)
 383                     ; setTyconReplacement (tycon, Type.unit)
 384                     ; (datatypes, unary))
 385            | 1 =>
 386                 let
 387                    val {con, args} = Vector.first cons
 388                 in
 389                    if Vector.exists (args, containsArrayOrVector)
 390                       then (datatypes,
 391                             {tycon = tycon, con = con, args = args} :: unary)
 392                    else (transparent (tycon, con, args)
 393                          ; (datatypes, unary))
 394                 end
 395            | _ => (Datatype.T {tycon = tycon, cons = cons} :: datatypes,
 396                    unary)
 397           end)
 398       fun containsTycon (ty: Type.t, tyc: Tycon.t): bool =
 399          let
 400             datatype z = datatype Type.dest
 401             val {get = containsTycon, destroy = destroyContainsTycon} =
 402                Property.destGet
 403                (Type.plist,
 404                 Property.initRec
 405                 (fn (t, containsTycon) =>
 406                  case Type.dest t of
 407                     Array t => containsTycon t
 408                   | Datatype tyc' =>
 409                        (case tyconReplacement tyc' of
 410                            NONE => Tycon.equals (tyc, tyc')
 411                          | SOME t => containsTycon t)
 412                   | Tuple ts => Vector.exists (ts, containsTycon)
 413                   | Ref t => containsTycon t
 414                   | Vector t => containsTycon t
 415                   | Weak t => containsTycon t
 416                   | _ => false))
 417             val res = containsTycon ty
 418             val () = destroyContainsTycon ()
 419          in res
 420          end
 421       (* Keep the circular transparent tycons, ditch the rest. *)
 422       val datatypes =
 423          List.fold
 424          (unary, datatypes, fn ({tycon, con, args}, accum) =>
 425           if Vector.exists (args, fn arg => containsTycon (arg, tycon))
 426              then Datatype.T {tycon = tycon,
 427                               cons = Vector.new1 {con = con, args = args}}
 428                   :: accum
 429           else (transparent (tycon, con, args)
 430                 ; accum))
 431       fun makeKeepSimplifyTypes simplifyType ts =
 432          Vector.keepAllMap (ts, fn t =>
 433                             let
 434                                val t = simplifyType t
 435                             in
 436                                if Type.isUnit t
 437                                   then NONE
 438                                else SOME t
 439                             end)
 440       val {get = simplifyType, destroy = destroySimplifyType} =
 441          Property.destGet
 442          (Type.plist,
 443           Property.initRec
 444           (fn (t, simplifyType) =>
 445            let
 446               val keepSimplifyTypes = makeKeepSimplifyTypes simplifyType
 447               open Type
 448            in case dest t of
 449               Array t => array (simplifyType t)
 450             | Datatype tycon =>
 451                  (case tyconReplacement tycon of
 452                      SOME t =>
 453                         let
 454                            val t = simplifyType t
 455                            val _ = setTyconReplacement (tycon, t)
 456                         in
 457                            t
 458                         end
 459                    | NONE => t)
 460             | Ref t => reff (simplifyType t)
 461             | Tuple ts => Type.tuple (keepSimplifyTypes ts)
 462             | Vector t => vector (simplifyType t)
 463             | Weak t => weak (simplifyType t)
 464             | _ => t
 465            end))
 466       val simplifyType =
 467          Trace.trace ("SimplifyTypes.simplifyType", Type.layout, Type.layout)
 468          simplifyType
 469       fun simplifyTypes ts = Vector.map (ts, simplifyType)
 470       val keepSimplifyTypes = makeKeepSimplifyTypes simplifyType
 471       (* Simplify constructor argument types. *)
 472       val datatypes =
 473          Vector.fromListMap
 474          (datatypes, fn Datatype.T {tycon, cons} =>
 475           (setTyconNumCons (tycon, Vector.length cons)
 476            ; Datatype.T {tycon = tycon,
 477                          cons = Vector.map (cons, fn {con, args} =>
 478                                             {con = con,
 479                                              args = keepSimplifyTypes args})}))
 480       val unitVar = Var.newNoname ()
 481       val {get = varInfo: Var.t -> Type.t, set = setVarInfo, ...} =
 482          Property.getSetOnce
 483          (Var.plist, Property.initRaise ("varInfo", Var.layout))
 484       fun simplifyVarType (x: Var.t, t: Type.t): Type.t =
 485          (setVarInfo (x, t)
 486           ; simplifyType t)
 487       fun simplifyMaybeVarType (x: Var.t option, t: Type.t): Type.t =
 488          case x of
 489             SOME x => simplifyVarType (x, t)
 490           | NONE => simplifyType t
 491       val oldVarType = varInfo
 492       val newVarType = simplifyType o oldVarType
 493       fun simplifyVar (x: Var.t): Var.t =
 494          if Type.isUnit (newVarType x)
 495             then unitVar
 496          else x
 497       val varIsUseless = Type.isUnit o newVarType
 498       fun removeUselessVars xs = Vector.keepAll (xs, not o varIsUseless)
 499       fun tuple xs =
 500          let
 501             val xs = removeUselessVars xs
 502          in if 1 = Vector.length xs
 503                then Var (Vector.first xs)
 504             else Tuple xs
 505          end
 506       fun simplifyFormals xts =
 507          Vector.keepAllMap
 508          (xts, fn (x, t) =>
 509           let val t = simplifyVarType (x, t)
 510           in if Type.isUnit t
 511                 then NONE
 512              else SOME (x, t)
 513           end)
 514       val typeIsUseful = not o Type.isUnit o simplifyType
 515       datatype result = datatype Result.t
 516       fun simplifyExp (e: Exp.t): Exp.t result =
 517          case e of
 518             ConApp {con, args} =>
 519                (case conRep con of
 520                    ConRep.Transparent => Keep (tuple args)
 521                  | ConRep.Useful =>
 522                       Keep (ConApp {con = con,
 523                                     args = removeUselessVars args})
 524                  | ConRep.Useless => Bugg)
 525           | PrimApp {prim, targs, args} =>
 526                Keep
 527                (let
 528                    fun normal () =
 529                       PrimApp {prim = prim,
 530                                targs = simplifyTypes targs,
 531                                args = Vector.map (args, simplifyVar)}
 532                    fun equal () =
 533                       if 2 = Vector.length args
 534                          then
 535                             if varIsUseless (Vector.first args)
 536                                then ConApp {con = Con.truee,
 537                                             args = Vector.new0 ()}
 538                             else normal ()
 539                       else Error.bug "SimplifyTypes.simplifyExp: strange eq/equal PrimApp"
 540                    open Prim.Name
 541                 in case Prim.name prim of
 542                    MLton_eq => equal ()
 543                  | MLton_equal => equal ()
 544                  | _ => normal ()
 545                 end)
 546           | Select {tuple, offset} =>
 547                let
 548                   val ts = Type.deTuple (oldVarType tuple)
 549                in Vector.fold'
 550                   (ts, 0, (offset, 0), fn (pos, t, (n, offset)) =>
 551                    if n = 0
 552                       then (Vector.Done
 553                             (Keep
 554                              (if offset = 0
 555                                  andalso not (Vector.existsR
 556                                               (ts, pos + 1, Vector.length ts,
 557                                                typeIsUseful))
 558                                  then Var tuple
 559                               else Select {tuple = tuple,
 560                                            offset = offset})))
 561                    else Vector.Continue (n - 1,
 562                                          if typeIsUseful t
 563                                             then offset + 1
 564                                          else offset),
 565                       fn _ => Error.bug "SimplifyTypes.simplifyExp: Select:newOffset")
 566                end
 567           | Tuple xs => Keep (tuple xs)
 568           | _ => Keep e
 569       val simplifyExp =
 570          Trace.trace ("SimplifyTypes.simplifyExp",
 571                       Exp.layout, Result.layout Exp.layout)
 572          simplifyExp
 573       fun simplifyTransfer (t : Transfer.t): Statement.t vector * Transfer.t =
 574          case t of
 575             Arith {prim, args, overflow, success, ty} =>
 576                (Vector.new0 (), Arith {prim = prim,
 577                                        args = Vector.map (args, simplifyVar),
 578                                        overflow = overflow,
 579                                        success = success,
 580                                        ty = ty})
 581           | Bug => (Vector.new0 (), t)
 582           | Call {func, args, return} =>
 583                (Vector.new0 (),
 584                 Call {func = func, return = return,
 585                       args = removeUselessVars args})
 586           | Case {test, cases = Cases.Con cases, default} =>
 587                let
 588                   val cases =
 589                      Vector.keepAll (cases, fn (con, _) =>
 590                                      not (ConRep.isUseless (conRep con)))
 591                   val default =
 592                      case (Vector.length cases, default) of
 593                         (_,     NONE)    => NONE
 594                       | (0,     SOME l)  => SOME l
 595                       | (n,     SOME l)  =>
 596                            if n = tyconNumCons (Type.deDatatype (oldVarType test))
 597                               then NONE
 598                            else SOME l
 599                   fun normal () =
 600                      (Vector.new0 (),
 601                       Case {test = test,
 602                             cases = Cases.Con cases,
 603                             default = default})
 604                in case (Vector.length cases, default) of
 605                   (0,         NONE)   => (Vector.new0 (), Bug)
 606                 | (0,         SOME l) =>
 607                      (Vector.new0 (), Goto {dst = l, args = Vector.new0 ()})
 608                 | (1, NONE)   =>
 609                      let
 610                         val (con, l) = Vector.first cases
 611                      in
 612                         if ConRep.isUseful (conRep con)
 613                            then
 614                               (* This case can occur because an array or vector
 615                                * tycon was kept around.
 616                                *)
 617                               normal ()
 618                         else (* The type has become a tuple.  Do the selects. *)
 619                            let
 620                               val ts = keepSimplifyTypes (conArgs con)
 621                               val (args, stmts) =
 622                                  if 1 = Vector.length ts
 623                                     then (Vector.new1 test, Vector.new0 ())
 624                                  else
 625                                     Vector.unzip
 626                                     (Vector.mapi
 627                                      (ts, fn (i, ty) =>
 628                                       let val x = Var.newNoname ()
 629                                       in (x,
 630                                           Statement.T
 631                                           {var = SOME x,
 632                                            ty = ty,
 633                                            exp = Select {tuple = test,
 634                                                          offset = i}})
 635                                       end))
 636                            in (stmts, Goto {dst = l, args = args})
 637                            end
 638                      end
 639                 | _ => normal ()
 640                end
 641           | Case _ => (Vector.new0 (), t)
 642           | Goto {dst, args} =>
 643                (Vector.new0 (), Goto {dst = dst, args = removeUselessVars args})
 644           | Raise xs => (Vector.new0 (), Raise (removeUselessVars xs))
 645           | Return xs => (Vector.new0 (), Return (removeUselessVars xs))
 646           | Runtime {prim, args, return} =>
 647                (Vector.new0 (), Runtime {prim = prim,
 648                                          args = Vector.map (args, simplifyVar),
 649                                          return = return})
 650       val simplifyTransfer =
 651          Trace.trace
 652          ("SimplifyTypes.simplifyTransfer", Transfer.layout,
 653           Layout.tuple2 (Vector.layout Statement.layout, Transfer.layout))
 654          simplifyTransfer
 655       fun simplifyStatement (Statement.T {var, ty, exp}) =
 656          let
 657             val ty = simplifyMaybeVarType (var, ty)
 658          in
 659             (* It is wrong to omit calling simplifyExp when var = NONE because
 660              * targs in a PrimApp may still need to be simplified.
 661              *)
 662             if not (Type.isUnit ty)
 663                orelse Exp.maySideEffect exp
 664                orelse (case exp of
 665                           Profile _ => true
 666                         | _ => false)
 667                then
 668                   (case simplifyExp exp of
 669                       Bugg => Bugg
 670                     | Delete => Delete
 671                     | Keep exp =>
 672                          Keep (Statement.T {var = var, ty = ty, exp = exp}))
 673             else Delete
 674          end
 675       fun simplifyBlock (Block.T {label, args, statements, transfer}) =
 676          let
 677             val args = simplifyFormals args
 678             val statements =
 679                Vector.fold'
 680                (statements, 0, [], fn (_, statement, statements) =>
 681                 case simplifyStatement statement of
 682                    Bugg => Vector.Done NONE
 683                  | Delete => Vector.Continue statements
 684                  | Keep s => Vector.Continue (s :: statements),
 685                 SOME o Vector.fromListRev)
 686          in
 687             case statements of
 688                NONE => Block.T {label = label,
 689                                 args = args,
 690                                 statements = Vector.new0 (),
 691                                 transfer = Bug}
 692              | SOME statements =>
 693                   let
 694                      val (stmts, transfer) = simplifyTransfer transfer
 695                      val statements = Vector.concat [statements, stmts]
 696                   in
 697                      Block.T {label = label,
 698                               args = args,
 699                               statements = statements,
 700                               transfer = transfer}
 701                   end
 702          end
 703       fun simplifyFunction f =
 704          let
 705             val {args, mayInline, name, raises, returns, start, ...} =
 706                Function.dest f
 707              val args = simplifyFormals args
 708              val blocks = ref []
 709              val _ =
 710                 Function.dfs (f, fn block =>
 711                               (List.push (blocks, simplifyBlock block)
 712                                ; fn () => ()))
 713              val returns = Option.map (returns, keepSimplifyTypes)
 714              val raises = Option.map (raises, keepSimplifyTypes)
 715          in
 716             Function.new {args = args,
 717                           blocks = Vector.fromList (!blocks),
 718                           mayInline = mayInline,
 719                           name = name,
 720                           raises = raises,
 721                           returns = returns,
 722                           start = start}
 723          end
 724       val globals =
 725          Vector.concat
 726          [Vector.new1 (Statement.T {var = SOME unitVar,
 727                                     ty = Type.unit,
 728                                     exp = Exp.unit}),
 729           Vector.keepAllMap (globals, fn s =>
 730                              case simplifyStatement s of
 731                                 Bugg => Error.bug "SimplifyTypes.globals: bind can't fail"
 732                               | Delete => NONE
 733                               | Keep b => SOME b)]
 734       val shrink = shrinkFunction {globals = globals}
 735       val functions = List.revMap (functions, shrink o simplifyFunction)
 736       val program =
 737          Program.T {datatypes = datatypes,
 738                     globals = globals,
 739                     functions = functions,
 740                     main = main}
 741       val _ = destroySimplifyType ()
 742       val _ = Program.clearTop program
 743    in
 744       program
 745    end
 746
 747 end