mlton/ssa/known-case.fun

   1 (* Copyright (C) 2009 Matthew Fluet.
   2  * Copyright (C) 1999-2006 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 KnownCase (S: SSA_TRANSFORM_STRUCTS): SSA_TRANSFORM =
  11 struct
  12
  13 open S
  14 open Exp Transfer
  15
  16 fun mkPost ()
  17   = let
  18       val post = ref []
  19     in
  20       {addPost = fn th => List.push (post, th),
  21        post = fn () => List.foreach(!post, fn th => th ())}
  22     end
  23
  24 structure TyconInfo =
  25   struct
  26     datatype t = T of {cons: Con.t vector}
  27
  28     local
  29       fun make f (T r) = f r
  30     in
  31       val cons = make #cons
  32     end
  33
  34     fun layout (T {cons, ...})
  35       = Layout.record [("cons", Vector.layout Con.layout cons)]
  36   end
  37
  38 structure ConInfo =
  39   struct
  40     datatype t = T of {args: Type.t vector,
  41                        index: int,
  42                        tycon: Tycon.t}
  43
  44     local
  45       fun make f (T r) = f r
  46     in
  47       val args = make #args
  48       val index = make #index
  49     end
  50
  51     fun layout (T {index, ...})
  52       = Layout.record [("index", Int.layout index)]
  53   end
  54
  55 structure ConValue =
  56   struct
  57     type w = Var.t ref vector
  58     type v = w option
  59     type u = v option
  60     type t = Con.t * u
  61
  62     val equalsW : w * w -> bool
  63       = fn (x, y) => Vector.equals (x, y, fn (x, y) => Var.equals (!x, !y))
  64
  65     val layoutW = Vector.layout (Var.layout o !)
  66     val layoutV = Option.layout layoutW
  67     val layoutU = Option.layout layoutV
  68     val layout : t -> Layout.t = Layout.tuple2 (Con.layout, layoutU)
  69
  70     val joinV : v * v -> v
  71       = fn (SOME x, SOME y)
  72          => if equalsW (x, y)
  73               then SOME x
  74               else NONE
  75          | (NONE, _) => NONE
  76          | (_, NONE) => NONE
  77     val joinU : u * u -> u
  78       = fn (SOME x, SOME y) => SOME (joinV (x, y))
  79          | (NONE, y) => y
  80          | (x, NONE) => x
  81     val join : t * t -> t
  82       = fn ((conx, x), (cony, y)) =>
  83         if Con.equals (conx, cony)
  84           then (conx, joinU (x, y))
  85           else Error.bug "KnownCase.ConValue.join"
  86
  87     fun newKnown (con, args) : t = (con, SOME (SOME args))
  88     fun newUnknown con : t = (con, SOME NONE)
  89     fun new con : t = (con, NONE)
  90
  91     fun isTop ((_, x) : t) = isSome x
  92
  93     val con : t -> Con.t = fn (conx, _) => conx
  94   end
  95
  96 structure TyconValue =
  97   struct
  98     type t = ConValue.t vector
  99
 100     val layout : t -> Layout.t = Vector.layout ConValue.layout
 101
 102     val join : t * t -> t
 103       = fn (x, y) => Vector.map2 (x, y, ConValue.join)
 104
 105     fun newKnown (cons, con, args)
 106       = Vector.map
 107         (cons, fn con' =>
 108          if Con.equals (con, con')
 109            then ConValue.newKnown (con, args)
 110            else ConValue.new con')
 111
 112     fun newUnknown cons = Vector.map (cons, ConValue.newUnknown)
 113
 114     val cons : t -> Con.t vector
 115       = fn x => Vector.map (x, ConValue.con)
 116   end
 117
 118 structure VarInfo =
 119   struct
 120     datatype t = T of {active: bool ref,
 121                        tyconValues: TyconValue.t list ref,
 122                        var: Var.t}
 123
 124     local
 125       fun make f (T r) = f r
 126       fun make' f = (make f, ! o (make f))
 127     in
 128       val (_, active') = make' #active
 129     end
 130
 131     fun layout (T {active, tyconValues, var, ...})
 132       = Layout.record [("active", Bool.layout (!active)),
 133                        ("tyconValues", List.layout TyconValue.layout (!tyconValues)),
 134                        ("var", Var.layout var)]
 135
 136     fun new var = T {active = ref false,
 137                      tyconValues = ref [],
 138                      var = var}
 139
 140     fun deactivate (T {active, ...}) = active := false
 141     fun activate (T {active, ...}) = active := true
 142     fun activate' (vi, addPost: (unit -> unit) -> unit)
 143       = (addPost (fn () => deactivate vi);
 144          activate vi)
 145     val active = active'
 146
 147     fun tyconValue (T {tyconValues, ...})
 148       = case !tyconValues of h::_ => SOME h | _ => NONE
 149     fun popTyconValue (T {tyconValues, ...}) = ignore (List.pop tyconValues)
 150     fun pushTyconValue (T {tyconValues, ...}, tcv) = List.push (tyconValues, tcv)
 151     fun pushTyconValue' (vi, tcv, addPost)
 152       = let
 153           val _ = pushTyconValue (vi, tcv)
 154           val _ = addPost (fn () => popTyconValue vi)
 155         in
 156           ()
 157         end
 158     fun joinActiveTyconValue (vi, tcv, addPost, addPost')
 159       = if active vi
 160           then let val tcv' = valOf (tyconValue vi)
 161                in
 162                  popTyconValue vi;
 163                  pushTyconValue (vi, TyconValue.join (tcv, tcv'))
 164                end
 165           else (activate' (vi, addPost');
 166                 pushTyconValue' (vi, tcv, addPost))
 167   end
 168
 169 structure ReplaceInfo =
 170   struct
 171     datatype t = T of {replaces: Var.t ref list ref}
 172
 173     fun new var = T {replaces = ref [ref var]}
 174
 175     fun replace (T {replaces, ...})
 176       = case !replaces of h::_ => h | _ => Error.bug "KnownCase.ReplaceInfo.replace"
 177     fun popReplace (T {replaces, ...}) = ignore (List.pop replaces)
 178     fun pushReplace (T {replaces, ...}, rep) = List.push (replaces, ref rep)
 179     fun pushReplace' (vi, rep, addPost)
 180       = let
 181           val _ = pushReplace (vi, rep)
 182           val _ = addPost (fn () => popReplace vi)
 183         in
 184           ()
 185         end
 186     fun flipReplace (vi, rep)
 187       = let val r = replace vi
 188         in !r before (r := rep)
 189         end
 190     fun flipReplace' (vi, rep, addPost)
 191       = let
 192           val rep = flipReplace (vi, rep)
 193           val _ = addPost (fn () => ignore (flipReplace (vi, rep)))
 194         in
 195           rep
 196         end
 197     fun nextReplace' (vi, rep, addPost)
 198       = let
 199           val rep = flipReplace' (vi, rep, addPost)
 200           val _ = pushReplace' (vi, rep, addPost)
 201         in
 202           ()
 203         end
 204   end
 205
 206 structure LabelInfo =
 207   struct
 208     datatype t = T of {activations: (VarInfo.t * TyconValue.t) list ref,
 209                        block: Block.t,
 210                        depth: int ref,
 211                        pred: Label.t option option ref}
 212
 213     local
 214       fun make f (T r) = f r
 215       fun make' f = (make f, ! o (make f))
 216     in
 217       val block = make #block
 218       val (_, depth') = make' #depth
 219     end
 220
 221     fun layout (T {pred, ...})
 222       = Layout.record
 223         [("pred", Option.layout (Option.layout Label.layout) (!pred))]
 224
 225     fun new block = T {activations = ref [],
 226                        block = block,
 227                        depth = ref 0,
 228                        pred = ref NONE}
 229
 230     fun popDepth (T {depth, ...}) = Int.dec depth
 231     fun pushDepth (T {depth, ...}) = Int.inc depth
 232     fun pushDepth' (li, addPost)
 233       = let
 234           val _ = pushDepth li
 235           val _ = addPost (fn () => popDepth li)
 236         in
 237           ()
 238         end
 239
 240     fun addPred (T {pred, ...}, l)
 241       = case !pred
 242           of NONE => pred := SOME (SOME l)
 243            | SOME NONE => ()
 244            | SOME (SOME l') => if Label.equals (l, l')
 245                                  then ()
 246                                  else pred := SOME NONE
 247     fun onePred (T {pred, ...})
 248       = case !pred
 249           of SOME (SOME _) => true
 250            | _ => false
 251
 252     fun addActivation (T {activations, ...}, activation)
 253       = List.push (activations, activation)
 254     fun activate (T {activations, ...}, addPost)
 255       = let
 256           val {addPost = addPost', post = post'} = mkPost ()
 257         in
 258           List.foreach
 259           (!activations, fn (vi, tcv) =>
 260            VarInfo.joinActiveTyconValue (vi, tcv, addPost, addPost'));
 261           post' ()
 262         end
 263     val activate : t * ((unit -> unit) -> unit) -> unit
 264       = Trace.trace
 265         ("KnownCase.LabelInfo.activate",
 266          fn (T {activations, block = Block.T {label, ...}, ...}, _) =>
 267          let open Layout
 268          in
 269            seq [Label.layout label,
 270                 str " ",
 271                 (List.layout (tuple2 (VarInfo.layout,
 272                                       TyconValue.layout))
 273                              (!activations))]
 274          end,
 275          Layout.ignore)
 276         activate
 277   end
 278
 279 fun transform (Program.T {globals, datatypes, functions, main})
 280   = let
 281       (* restore and shrink *)
 282       val restore = restoreFunction {globals = globals}
 283       val shrink = shrinkFunction {globals = globals}
 284
 285       (* tyconInfo and conInfo *)
 286       val {get = tyconInfo: Tycon.t -> TyconInfo.t,
 287            set = setTyconInfo, ...}
 288         = Property.getSetOnce
 289           (Tycon.plist, Property.initRaise ("knownCase.tyconInfo", Tycon.layout))
 290       val {get = conInfo: Con.t -> ConInfo.t,
 291            set = setConInfo, ...}
 292         = Property.getSetOnce
 293           (Con.plist, Property.initRaise ("knownCase.conInfo", Con.layout))
 294       val _ = Vector.foreach
 295               (datatypes, fn Datatype.T {tycon, cons} =>
 296                (setTyconInfo (tycon, TyconInfo.T {cons = Vector.map (cons, #con)});
 297                 Vector.foreachi
 298                 (cons, fn (i, {con, args}) =>
 299                  setConInfo (con, ConInfo.T {args = args,
 300                                              index = i,
 301                                              tycon = tycon}))))
 302       (* Diagnostics *)
 303       val _ = Control.diagnostics
 304               (fn display =>
 305                let open Layout
 306                in
 307                  Vector.foreach
 308                  (datatypes, fn Datatype.T {tycon, cons} =>
 309                   let val tci = tyconInfo tycon
 310                   in
 311                     display (seq [Tycon.layout tycon, str " ",
 312                                   TyconInfo.layout tci,
 313                                   Vector.layout
 314                                   (fn {con, ...} =>
 315                                    let val ci = conInfo con
 316                                    in
 317                                      seq [Con.layout con, str " ",
 318                                           ConInfo.layout ci]
 319                                    end)
 320                                   cons])
 321                   end)
 322                end)
 323       fun optimizeTycon _ = true
 324       fun optimizeType ty = case Type.dest ty
 325                               of Type.Datatype tycon => optimizeTycon tycon
 326                                | _ => false
 327
 328       (* varInfo *)
 329       val {get = varInfo: Var.t -> VarInfo.t, ...}
 330         = Property.getSetOnce
 331           (Var.plist, Property.initFun (fn x => VarInfo.new x))
 332       (* replaceInfo *)
 333       val {get = replaceInfo: Var.t -> ReplaceInfo.t, ...}
 334         = Property.get
 335           (Var.plist, Property.initFun (fn x => ReplaceInfo.new x))
 336
 337
 338       fun bindVar' (x, ty, exp, addPost)
 339         = case Type.dest ty
 340             of Type.Datatype tycon
 341              => if optimizeTycon tycon
 342                   then let
 343                          val cons = TyconInfo.cons (tyconInfo tycon)
 344                          val tyconValue
 345                            = case exp
 346                                of SOME (ConApp {con, args})
 347                                 => TyconValue.newKnown
 348                                    (cons, con,
 349                                     Vector.map
 350                                     (args, ReplaceInfo.replace o replaceInfo))
 351                                 | _ => TyconValue.newUnknown cons
 352                        in
 353                          VarInfo.pushTyconValue'
 354                          (varInfo x, tyconValue, addPost)
 355                        end
 356                   else ()
 357              | _ => ()
 358
 359       fun bindVarArgs' (args, addPost)
 360         = Vector.foreach
 361           (args, fn (x, ty) =>
 362            bindVar' (x, ty, NONE, addPost))
 363       fun bindVarArgs args = bindVarArgs' (args, ignore)
 364       fun bindVarStatement' (Statement.T {var, ty, exp}, addPost)
 365         = Option.app
 366           (var, fn x =>
 367            bindVar' (x, ty, SOME exp, addPost))
 368       fun bindVarStatements' (statements, addPost)
 369         = Vector.foreach
 370           (statements, fn statement =>
 371            bindVarStatement' (statement, addPost))
 372       fun bindVarStatements statements = bindVarStatements' (statements, ignore)
 373
 374       val _ = bindVarStatements globals
 375       (* Diagnostics *)
 376       val _ = Control.diagnostics
 377               (fn display =>
 378                let open Layout
 379                in
 380                  Vector.foreach
 381                  (globals, fn Statement.T {var, ...} =>
 382                   Option.app
 383                   (var, fn x =>
 384                    let val vi = varInfo x
 385                    in
 386                      display (seq [Var.layout x, str " ",
 387                                    VarInfo.layout vi])
 388                    end))
 389                end)
 390
 391       (* labelInfo *)
 392       val {get = labelInfo: Label.t -> LabelInfo.t,
 393            set = setLabelInfo, ...}
 394         = Property.getSetOnce
 395           (Label.plist, Property.initRaise ("knownCase.labelInfo", Label.layout))
 396
 397       val functions
 398         = List.revMap
 399           (functions, fn f =>
 400            let
 401              val {args, blocks, mayInline, name, raises, returns, start} =
 402                 Function.dest f
 403              val _ = Vector.foreach
 404                      (blocks, fn block as Block.T {label, ...} =>
 405                       setLabelInfo (label, LabelInfo.new block))
 406              val _ = Vector.foreach
 407                      (blocks, fn Block.T {label, transfer, ...} =>
 408                       Transfer.foreachLabel
 409                       (transfer, fn l =>
 410                        let val li = labelInfo l
 411                        in LabelInfo.addPred (li, label)
 412                        end))
 413              (* Diagnostics *)
 414              val _ = Control.diagnostics
 415                      (fn display =>
 416                       let open Layout
 417                       in
 418                         Vector.foreach
 419                         (blocks, fn Block.T {label, ...} =>
 420                          let val li = labelInfo label
 421                          in
 422                            display (seq [Label.layout label, str " ",
 423                                          LabelInfo.layout li])
 424                          end)
 425                       end)
 426
 427              val newBlocks = ref []
 428              fun addBlock block = List.push (newBlocks, block)
 429              fun addNewBlock (block as Block.T {label, ...})
 430                = (setLabelInfo (label, LabelInfo.new block);
 431                   addBlock block)
 432              local
 433                val table: {hash: word,
 434                            transfer: Transfer.t,
 435                            label: Label.t} HashSet.t
 436                  = HashSet.new {hash = #hash}
 437              in
 438                 fun newBlock transfer =
 439                    let
 440                       val label = Label.newNoname ()
 441                       val block = Block.T {label = label,
 442                                            args = Vector.new0 (),
 443                                            statements = Vector.new0 (),
 444                                            transfer = transfer}
 445                       val _ = addNewBlock block
 446                    in
 447                       label
 448                    end
 449                 (* newBlock' isn't used, because it shares blocks that causes
 450                  * violation of the requirements for profiling information --
 451                  * namely that each block correspond to a unique sequence of
 452                  * source infos at it' start.
 453                  *
 454                  * I left the code in case we want to enable it when compiling
 455                  * without profiling.
 456                  *)
 457                 fun newBlock' transfer
 458                  = let
 459                      val hash = Transfer.hash transfer
 460                      val {label, ...}
 461                        = HashSet.lookupOrInsert
 462                          (table, hash,
 463                           fn {transfer = transfer', ...} =>
 464                           Transfer.equals (transfer, transfer'),
 465                           fn () => {hash = hash,
 466                                     label = newBlock transfer,
 467                                     transfer = transfer})
 468                    in
 469                      label
 470                    end
 471                 val _ = newBlock' (* quell unused variable warning *)
 472                fun bugBlock () = newBlock Bug
 473              end
 474
 475              val traceRewriteGoto
 476                = Trace.trace
 477                  ("KnownCase.rewriteGoto",
 478                   fn {dst, args} =>
 479                   Layout.record
 480                   [("dst", Label.layout dst),
 481                    ("args", Vector.layout Var.layout args)],
 482                   Option.layout
 483                   (Layout.tuple2
 484                    (Vector.layout Statement.layout,
 485                     Transfer.layout)))
 486              val traceRewriteCase
 487                = Trace.trace
 488                  ("KnownCase.rewriteCase",
 489                   fn {test, cases, default} =>
 490                   Layout.record
 491                   [("test", Var.layout test),
 492                    ("cases", Vector.layout
 493                              (Layout.tuple2 (Con.layout, Label.layout))
 494                              cases),
 495                    ("default", Option.layout Label.layout default)],
 496                   Option.layout
 497                   (Layout.tuple2
 498                    (Vector.layout Statement.layout,
 499                     Transfer.layout)))
 500              val traceRewriteTransfer
 501                = Trace.trace
 502                  ("KnownCase.rewriteTransfer",
 503                   Transfer.layout,
 504                   Option.layout
 505                   (Layout.tuple2
 506                    (Vector.layout Statement.layout,
 507                     Transfer.layout)))
 508
 509              fun rewriteGoto' {dst, args} :
 510                               (Statement.t vector * Transfer.t) option
 511                = let
 512                    val li = labelInfo dst
 513                    val Block.T {args = argsDst,
 514                                 statements = statementsDst,
 515                                 transfer = transferDst, ...}
 516                      = LabelInfo.block li
 517                    val depthDst = LabelInfo.depth' li
 518                  in
 519                    if depthDst <= 2
 520                       andalso
 521                       Vector.fold
 522                       (statementsDst, 0,
 523                        fn (Statement.T {exp = Profile _, ...}, i) => i
 524                         | (_, i) => i + 1) <= 0
 525                      then let
 526                             val {addPost, post} = mkPost ()
 527                             val _ = LabelInfo.pushDepth' (li, addPost)
 528
 529                             val vars = Vector.map2
 530                                        (args, argsDst,
 531                                         fn (x, (z, ty)) =>
 532                                         (x, Var.newNoname (),
 533                                          z, Var.newNoname (), ty))
 534
 535                             val moves1
 536                               = if depthDst > 0
 537                                   then Vector.map
 538                                        (vars, fn (_, _, z, t, ty) =>
 539                                         (if optimizeType ty
 540                                            then let
 541                                                   val zvi = varInfo z
 542                                                   val tvi = varInfo t
 543                                                 in
 544                                                   VarInfo.pushTyconValue'
 545                                                   (tvi,
 546                                                    valOf (VarInfo.tyconValue zvi),
 547                                                    addPost)
 548                                                 end
 549                                            else ();
 550                                          ReplaceInfo.nextReplace'
 551                                          (replaceInfo z, t, addPost);
 552                                          Statement.T {var = SOME t,
 553                                                       ty = ty,
 554                                                       exp = Var z}))
 555                                   else Vector.new0 ()
 556                             val moves2
 557                               = Vector.map
 558                                 (vars, fn (x, t, _, _, ty) =>
 559                                  (if optimizeType ty
 560                                     then let
 561                                            val xvi = varInfo x
 562                                            val tvi = varInfo t
 563                                          in
 564                                            VarInfo.pushTyconValue'
 565                                            (tvi,
 566                                             valOf (VarInfo.tyconValue xvi),
 567                                             addPost)
 568                                          end
 569                                     else ();
 570                                   Statement.T {var = SOME t,
 571                                                ty = ty,
 572                                                exp = Var x}))
 573                             val moves3
 574                               = Vector.map
 575                                 (vars, fn (_, t, z, _, ty) =>
 576                                  (if optimizeType ty
 577                                     then let
 578                                            val tvi = varInfo t
 579                                            val zvi = varInfo z
 580                                          in
 581                                            VarInfo.pushTyconValue'
 582                                            (zvi,
 583                                             valOf (VarInfo.tyconValue tvi),
 584                                             addPost)
 585                                          end
 586                                     else ();
 587                                   Statement.T {var = SOME z,
 588                                                ty = ty,
 589                                                exp = Var t}))
 590                             val _ = bindVarStatements' (statementsDst, addPost)
 591                           in
 592                             (case rewriteTransfer transferDst
 593                                of NONE => NONE
 594                                 | SOME (newStatements, newTransfer)
 595                                 => SOME (Vector.concat [moves1, moves2, moves3,
 596                                                         statementsDst,
 597                                                         newStatements],
 598                                          newTransfer))
 599                             before (post ())
 600                           end
 601                      else NONE
 602                  end
 603              and rewriteGoto goto = traceRewriteGoto
 604                                     rewriteGoto'
 605                                     goto
 606
 607              and rewriteCase' {test, cases, default} :
 608                               (Statement.t vector * Transfer.t) option
 609
 610                = let
 611                    val {addPost, post} = mkPost ()
 612
 613                    val testvi = varInfo test
 614                    val tyconValue as conValues
 615                      = case VarInfo.tyconValue testvi
 616                          of SOME tyconValue => tyconValue
 617                           | _ => Error.bug "KnownCase.rewriteCase: tyconValue"
 618                     val cons = TyconValue.cons tyconValue
 619                     val numCons = Vector.length cons
 620
 621                     datatype z = None
 622                                | One of (Con.t * ConValue.v)
 623                                | Many
 624
 625                     fun doOneSome (con, args)
 626                       = let
 627                           val goto
 628                             = case Vector.peek
 629                                    (cases, fn (con', _) =>
 630                                     Con.equals (con, con'))
 631                                 of SOME (_, dst)
 632                                  => {dst = dst, args = Vector.map (args, !)}
 633                                  | NONE
 634                                  => {dst = valOf default,
 635                                      args = Vector.new0 ()}
 636                         in
 637                           case rewriteGoto goto
 638                             of NONE => SOME (Vector.new0 (), Transfer.Goto goto)
 639                              | sst => sst
 640                         end
 641                     val doOneSome
 642                       = Trace.trace
 643                         ("KnownCase.doOneSome",
 644                          Layout.ignore, Layout.ignore)
 645                         doOneSome
 646
 647                     fun rewriteDefault conValues'
 648                       = let
 649                           val _ = VarInfo.pushTyconValue'
 650                                   (testvi, conValues', addPost)
 651                         in
 652                           rewriteGoto {dst = valOf default, args = Vector.new0 ()}
 653                         end
 654                     val rewriteDefault
 655                       = Trace.trace
 656                         ("KnownCase.rewriteCase.rewriteDefault",
 657                          Layout.ignore, Layout.ignore)
 658                         rewriteDefault
 659
 660 fun doOneNone con
 661   = let
 662       fun doit dst
 663         = SOME (Vector.new0 (),
 664                 Case
 665                 {test = test,
 666                  cases = Cases.Con (Vector.new1 (con, dst)),
 667                  default = if numCons = 1
 668                              then NONE
 669                              else SOME (bugBlock ())})
 670     in
 671       case Vector.peek
 672            (cases, fn (con', _) =>
 673             Con.equals (con, con'))
 674         of SOME (_, dst) => doit dst
 675          | NONE
 676          => let
 677               val args
 678                 = Vector.map
 679                   (ConInfo.args (conInfo con),
 680                    fn ty =>
 681                    let
 682                      val x = Var.newNoname ()
 683                      val xvi = varInfo x
 684                      val _ = case Type.dest ty
 685                                of Type.Datatype tycon
 686                                 => if optimizeTycon tycon
 687                                      then VarInfo.pushTyconValue'
 688                                           (xvi,
 689                                            TyconValue.newUnknown
 690                                            (TyconInfo.cons (tyconInfo tycon)),
 691                                            addPost)
 692                                      else ()
 693                                 | _ => ()
 694                    in
 695                      (x, ty)
 696                    end)
 697               val (xs, _) = Vector.unzip args
 698               val conValues' = TyconValue.newKnown
 699                                (cons, con,
 700                                 Vector.map
 701                                 (xs, ReplaceInfo.replace o replaceInfo))
 702               val label = Label.newNoname ()
 703               val (statements, transfer)
 704                 = case rewriteDefault conValues'
 705                     of SOME sst => sst
 706                      | NONE => (Vector.new0 (),
 707                                 Goto {dst = valOf default,
 708                                       args = Vector.new0 ()})
 709               val block = Block.T
 710                           {label = label,
 711                            args = args,
 712                            statements = statements,
 713                            transfer = transfer}
 714               val _ = addNewBlock block
 715             in
 716               doit label
 717             end
 718     end
 719 val doOneNone
 720   = Trace.trace
 721     ("KnownCase.rewriteCase.doOneNone",
 722      Layout.ignore, Layout.ignore)
 723     doOneNone
 724
 725 fun doMany ()
 726   = let
 727       val usedCons = Array.new (numCons, false)
 728       val cases = Vector.keepAllMap
 729                   (cases, fn (con, dst) =>
 730                    let
 731                      val conIndex = ConInfo.index (conInfo con)
 732                      val _ = Array.update (usedCons, conIndex, true)
 733                    in
 734                      if ConValue.isTop (Vector.sub (conValues, conIndex))
 735                        then SOME (con, dst)
 736                        else NONE
 737                    end)
 738       val (cases, default)
 739         = case default
 740             of NONE => (cases, NONE)
 741              | SOME dst
 742              => let
 743                   val conValues' = Vector.mapi
 744                                    (cons, fn (i, con) =>
 745                                     if Array.sub (usedCons, i)
 746                                       then ConValue.new con
 747                                       else Vector.sub (conValues, i))
 748
 749                   fun route (statements, (cases, default))
 750                     = if Vector.isEmpty statements
 751                         then (cases, default)
 752                         else let
 753                                fun route' dst
 754                                  = let
 755                                      val Block.T {args, ...}
 756                                        = LabelInfo.block (labelInfo dst)
 757
 758                                      val label = Label.newNoname ()
 759                                      val args = Vector.map
 760                                                 (args, fn (_, ty) =>
 761                                                  (Var.newNoname (), ty))
 762                                      val xs = Vector.map (args, #1)
 763                                      val block = Block.T
 764                                                  {label = label,
 765                                                   args = args,
 766                                                   statements = statements,
 767                                                   transfer = Goto {dst = dst,
 768                                                                    args = xs}}
 769                                      val _ = addNewBlock block
 770                                    in
 771                                      label
 772                                    end
 773                              in
 774                                (Vector.map (cases, fn (con, dst) => (con, route' dst)),
 775                                 Option.map (default, route'))
 776                              end
 777
 778                 in
 779                   case rewriteDefault conValues'
 780                     of SOME (statements,
 781                              Case {test = test',
 782                                    cases = Cases.Con cases',
 783                                    default = default'})
 784                      => if Option.equals
 785                            (SOME test,
 786                             Vector.foldr
 787                             (statements, SOME test',
 788                              fn (Statement.T _, NONE) => NONE
 789                               | (Statement.T {var, exp, ...}, SOME test') =>
 790                              if Option.equals (var, SOME test', Var.equals)
 791                                then case exp
 792                                       of Var test' => SOME test'
 793                                        | _ => NONE
 794                                else SOME test'),
 795                             Var.equals)
 796                           then let
 797                                  val (cases', default')
 798                                    = route (statements, (cases', default'))
 799                                in
 800                                  (Vector.concat [cases, cases'], default')
 801                                end
 802                           else (cases, SOME dst)
 803                      | SOME (statements, transfer)
 804                      => let
 805                           val label
 806                             = if Vector.isEmpty statements
 807                                 then newBlock transfer
 808                                 else let
 809                                        val label = Label.newNoname ()
 810                                        val block = Block.T
 811                                                    {label = label,
 812                                                     args = Vector.new0 (),
 813                                                     statements = statements,
 814                                                     transfer = transfer}
 815                                        val _ = addNewBlock block
 816                                      in
 817                                        label
 818                                      end
 819                         in
 820                           (cases, SOME label)
 821                         end
 822                      | NONE => (cases, SOME dst)
 823                 end
 824       val numCases = Vector.length cases
 825       fun doit (cases, default)
 826         = SOME (Vector.new0 (),
 827                 Case {test = test,
 828                       cases = Cases.Con cases,
 829                       default = default})
 830     in
 831       if numCases = numCons
 832         then doit (cases, NONE)
 833         else doit (cases,
 834                    case default
 835                      of SOME _ => default
 836                       | NONE => SOME (bugBlock ()))
 837     end
 838 val doMany
 839   = Trace.trace
 840     ("KnownCase.rewriteCase.doMany",
 841      Layout.ignore, Layout.ignore)
 842     doMany
 843
 844                  in
 845 (*
 846                    (if Vector.forall
 847                        (conValues, ConValue.isTop)
 848 *)
 849                    (if false
 850                       then NONE
 851                       else case Vector.foldi
 852                                 (conValues, None,
 853                                  fn (_, _, Many) => Many
 854                                   | (_, conValue, One ccv)
 855                                   => (case conValue
 856                                         of (_, NONE) => One ccv
 857                                          | (_, SOME _) => Many)
 858                                   | (_, conValue, None)
 859                                   => (case conValue
 860                                         of (_, NONE) => None
 861                                          | (con, SOME cv) => One (con, cv)))
 862                              of None => SOME (Vector.new0 (), Bug)
 863                               | One (con, SOME args) => doOneSome (con, args)
 864                               | One (con, NONE) => doOneNone con
 865                               | Many => doMany ())
 866                    before (post ())
 867                  end
 868              and rewriteCase casee = traceRewriteCase
 869                                      rewriteCase'
 870                                      casee
 871
 872              and rewriteTransfer' (transfer: Transfer.t) :
 873                                   (Statement.t vector * Transfer.t) option
 874                = case transfer
 875                    of Goto {dst, args} => rewriteGoto {dst = dst, args = args}
 876                     | Case {test, cases = Cases.Con cases, default}
 877                     => rewriteCase {test = test, cases = cases, default = default}
 878                     | _ => NONE
 879              and rewriteTransfer transfer = traceRewriteTransfer
 880                                             rewriteTransfer'
 881                                             transfer
 882
 883              fun activateGoto {dst, args}
 884                = let
 885                    val liDst = labelInfo dst
 886                    val Block.T {args = argsDst, ...}
 887                      = LabelInfo.block liDst
 888                  in
 889                    if LabelInfo.onePred liDst
 890                      then Vector.foreach2
 891                           (args, argsDst, fn (x, (y, ty)) =>
 892                            if optimizeType ty
 893                              then let
 894                                     val xvi = varInfo x
 895                                     val yvi = varInfo y
 896                                     val conValues'
 897                                       = valOf (VarInfo.tyconValue xvi)
 898                                   in
 899                                     LabelInfo.addActivation
 900                                     (liDst, (yvi, conValues'))
 901                                   end
 902                              else ())
 903                      else ()
 904                  end
 905              fun activateCase {test, cases, default}
 906                = let
 907                    val testvi = varInfo test
 908                    val tyconValue as conValues
 909                      = case VarInfo.tyconValue testvi
 910                          of NONE => Error.bug "KnownCase.activateCase: tyconValue"
 911                           | SOME tyconValue => tyconValue
 912                    val cons = TyconValue.cons tyconValue
 913                    val numCons = Vector.length cons
 914
 915                    val usedCons = Array.new (numCons, false)
 916                  in
 917                    Vector.foreach
 918                    (cases, fn (con, dst) =>
 919                     let
 920                       val conIndex = ConInfo.index (conInfo con)
 921                       val _ = Array.update (usedCons, conIndex, true)
 922                       val liDst = labelInfo dst
 923                       val Block.T {args = argsDst, ...}
 924                         = LabelInfo.block liDst
 925                       val conValues'
 926                         = TyconValue.newKnown
 927                           (cons, con,
 928                            Vector.map
 929                            (argsDst, ReplaceInfo.replace o replaceInfo o #1))
 930                     in
 931                       if LabelInfo.onePred liDst
 932                         then LabelInfo.addActivation
 933                              (liDst, (testvi, conValues'))
 934                         else ()
 935                     end);
 936                    Option.app
 937                    (default, fn dst =>
 938                     let
 939                       val liDst = labelInfo dst
 940                       val conValues' = Vector.mapi
 941                                        (cons, fn (i, con) =>
 942                                         if Array.sub (usedCons, i)
 943                                           then ConValue.new con
 944                                           else Vector.sub (conValues, i))
 945                     in
 946                       if LabelInfo.onePred liDst
 947                         then LabelInfo.addActivation
 948                              (liDst, (testvi, conValues'))
 949                         else ()
 950                     end)
 951                  end
 952              fun activateTransfer transfer
 953                = case transfer
 954                    of Goto {dst, args}
 955                     => activateGoto {dst = dst, args = args}
 956                     | Case {test, cases = Cases.Con cases, default}
 957                     => activateCase {test = test, cases = cases, default = default}
 958                     | _ => ()
 959
 960              fun rewriteBlock (Block.T {label, args, statements, transfer},
 961                                addPost)
 962                = let
 963                    val li = labelInfo label
 964                    val _ = LabelInfo.pushDepth' (li, addPost)
 965                    val _ = bindVarArgs' (args, addPost)
 966                    val _ = LabelInfo.activate (li, addPost)
 967                    val _ = bindVarStatements' (statements, addPost)
 968                    val _ = activateTransfer transfer
 969                    val (statements, transfer)
 970                      = case rewriteTransfer transfer
 971                          of NONE => (statements, transfer)
 972                           | SOME (newStatements, newTransfer)
 973                           => (Vector.concat [statements,newStatements],
 974                               newTransfer)
 975                  in
 976                     Block.T {label = label,
 977                              args = args,
 978                              statements = statements,
 979                              transfer = transfer}
 980                  end
 981              val rewriteBlock
 982                = Trace.trace
 983                  ("KnownCase.rewriteBlock",
 984                   Layout.tuple2 (Block.layout, Layout.ignore),
 985                   Block.layout)
 986                  rewriteBlock
 987
 988              fun doitTree tree
 989                = let
 990                    fun loop (Tree.T (block, children))
 991                      = let
 992                          val {addPost, post} = mkPost ()
 993                          val block = rewriteBlock (block, addPost)
 994                        in
 995                          addBlock block ;
 996                          Vector.foreach (children, loop) ;
 997                          post ()
 998                        end
 999                    val _ = loop tree
1000                  in
1001                    Vector.fromListRev (!newBlocks)
1002                  end
1003              val _ = bindVarArgs args
1004              val blocks = doitTree (Function.dominatorTree f)
1005
1006              val f = Function.new {args = args,
1007                                    blocks = blocks,
1008                                    mayInline = mayInline,
1009                                    name = name,
1010                                    raises = raises,
1011                                    returns = returns,
1012                                    start = start}
1013              val _ = Control.diagnostics
1014                      (fn display =>
1015                       display (Function.layout f))
1016              val f = eliminateDeadBlocksFunction f
1017              val _ = Control.diagnostics
1018                      (fn display =>
1019                       display (Function.layout f))
1020              val f = restore f
1021              val _ = Control.diagnostics
1022                      (fn display =>
1023                       display (Function.layout f))
1024              val f = shrink f
1025              val _ = Control.diagnostics
1026                      (fn display =>
1027                       display (Function.layout f))
1028              val _ = Function.clear f
1029            in
1030              f
1031            end)
1032       val program = Program.T {datatypes = datatypes,
1033                                globals = globals,
1034                                functions = functions,
1035                                main = main}
1036       val _ = Program.clearTop program
1037     in
1038       program
1039     end
1040 end