mlton/ssa/direct-exp.fun

   1 (* Copyright (C) 1999-2007 Henry Cejtin, Matthew Fluet, Suresh
   2  *    Jagannathan, and Stephen Weeks.
   3  * Copyright (C) 1997-2000 NEC Research Institute.
   4  *
   5  * MLton is released under a BSD-style license.
   6  * See the file MLton-LICENSE for details.
   7  *)
   8
   9 functor DirectExp (S: DIRECT_EXP_STRUCTS): DIRECT_EXP =
  10 struct
  11
  12 open S
  13
  14 structure DirectExp =
  15 struct
  16
  17 datatype t =
  18    Arith of {prim: Type.t Prim.t,
  19              args: t vector,
  20              overflow: t,
  21              ty: Type.t}
  22  | Call of {func: Func.t,
  23             args: t vector,
  24             ty: Type.t}
  25  | Case of {cases: cases,
  26             default: t option,
  27             test: t,
  28             ty: Type.t}
  29  | ConApp of {con: Con.t,
  30               args: t vector,
  31               ty: Type.t}
  32  | Const of Const.t
  33  | Detuple of {body: Var.t vector -> t,
  34                length: int,
  35                tuple: t}
  36  | DetupleBind of {body: t,
  37                    components: Var.t vector,
  38                    tuple: Var.t,
  39                    tupleTy: Type.t}
  40  | Handle of {try: t,
  41               catch: Var.t * Type.t,
  42               handler: t,
  43               ty: Type.t}
  44  | Let of {decs: {var: Var.t, exp: t} list,
  45            body: t}
  46  | Name of t * (Var.t -> t)
  47  | PrimApp of {prim: Type.t Prim.t,
  48                targs: Type.t vector,
  49                args: t vector,
  50                ty: Type.t}
  51  | Profile of ProfileExp.t
  52  | Raise of t
  53  | Runtime of {args: t vector,
  54                prim: Type.t Prim.t,
  55                ty: Type.t}
  56  | Select of {tuple: t,
  57               offset: int,
  58               ty: Type.t}
  59  | Seq of t * t
  60  | Tuple of {exps: t vector,
  61              ty: Type.t}
  62  | Var of Var.t * Type.t
  63 and cases =
  64    Con of {con: Con.t,
  65            args: (Var.t * Type.t) vector,
  66            body: t} vector
  67  | Word of WordSize.t * (WordX.t * t) vector
  68
  69 val arith = Arith
  70 val call = Call
  71 val casee = Case
  72 val conApp = ConApp
  73 val const = Const
  74 val detuple = Detuple
  75 val detupleBind = DetupleBind
  76 val handlee = Handle
  77 val lett = Let
  78 val name = Name
  79 val profile = Profile
  80 val raisee = Raise
  81 val select = Select
  82 val word = Const o Const.word
  83
  84 fun tuple (r as {exps, ...}) =
  85    if 1 = Vector.length exps
  86       then Vector.first exps
  87    else Tuple r
  88
  89 val var = Var
  90
  91 fun primApp {args, prim, targs, ty} =
  92    let
  93       fun runtime () =
  94          Runtime {args = args,
  95                   prim = prim,
  96                   ty = ty}
  97    in
  98       case Prim.name prim of
  99          Prim.Name.MLton_halt => runtime ()
 100        | Prim.Name.Thread_copyCurrent => runtime ()
 101        | _ => PrimApp {args = args,
 102                        prim = prim,
 103                        targs = targs,
 104                        ty = ty}
 105    end
 106
 107 local
 108    fun make c = conApp {con = c, args = Vector.new0 (), ty = Type.bool}
 109 in
 110    val truee = make Con.truee
 111    val falsee = make Con.falsee
 112 end
 113
 114 fun eq (e1, e2, ty) =
 115    primApp {prim = Prim.eq,
 116             targs = Vector.new1 ty,
 117             args = Vector.new2 (e1, e2),
 118             ty = Type.bool}
 119
 120 local
 121    open Layout
 122    fun lett (decs, body) =
 123       align [seq [str "let ", decs],
 124              seq [str "in ", body],
 125              str "end"]
 126 in
 127    fun layout e : Layout.t =
 128       case e of
 129          Arith {prim, args, overflow, ...} =>
 130             align [Prim.layoutApp (prim, args, layout),
 131                    seq [str "Overflow => ", layout overflow]]
 132        | Call {func, args, ty} =>
 133             seq [Func.layout func, str " ", layouts args,
 134                  str ": ", Type.layout ty]
 135        | Case {cases, default, test, ...} =>
 136             align
 137             [seq [str "case ", layout test, str " of"],
 138              indent
 139              (align [let
 140                         fun doit (v, f) =
 141                            Vector.layout
 142                            (fn z =>
 143                             let
 144                                val (x, e) = f z
 145                             in
 146                                seq [str "| ", x, str " => ", layout e]
 147                             end)
 148                            v
 149                         fun simple (v, f) =
 150                            doit (v, (fn (x, e) => (f x, e)))
 151                      in
 152                         case cases of
 153                            Con v =>
 154                               doit (v, fn {con, args, body} =>
 155                                     (seq [Con.layout con,
 156                                           Vector.layout (Var.layout o #1) args],
 157                                      body))
 158                          | Word (_, v) => simple (v, WordX.layout)
 159                      end,
 160                         case default of
 161                            NONE => empty
 162                          | SOME e => seq [str "  _ => ", layout e]],
 163               2)]
 164        | ConApp {con, args, ty} =>
 165             seq [Con.layout con, layouts args, str ": ", Type.layout ty]
 166        | Const c => Const.layout c
 167        | Detuple {tuple, ...} => seq [str "detuple ", layout tuple]
 168        | DetupleBind {body, components, tuple, ...} =>
 169             lett (seq [Vector.layout Var.layout components,
 170                        str " = ", Var.layout tuple],
 171                   layout body)
 172        | Handle {try, catch, handler, ...} =>
 173             align [layout try,
 174                    seq [str "handle ", Var.layout (#1 catch),
 175                         str " => ", layout handler]]
 176        | Let {decs, body} =>
 177             lett (align
 178                   (List.map (decs, fn {var, exp} =>
 179                              seq [Var.layout var, str " = ", layout exp])),
 180                      layout body)
 181        | Name _ => str "Name"
 182        | PrimApp {args, prim, ...} =>
 183             Prim.layoutApp (prim, args, layout)
 184        | Profile e => ProfileExp.layout e
 185        | Raise e => seq [str "raise ", layout e]
 186        | Runtime {args, prim, ...} =>
 187             Prim.layoutApp (prim, args, layout)
 188        | Select {tuple, offset, ...} =>
 189             seq [str "#", str (Int.toString (1 + offset)), str " ",
 190                  layout tuple]
 191        | Seq (e1, e2) => seq [layout e1, str "; ", layout e2]
 192        | Tuple {exps, ...} => layouts exps
 193        | Var (x, t) =>
 194             seq [Var.layout x, str ": ", Type.layout t]
 195    and layouts es = Vector.layout layout es
 196 end
 197
 198 structure Res =
 199    struct
 200       type t = {statements: Statement.t list,
 201                 transfer: Transfer.t}
 202
 203       fun layout {statements, transfer} =
 204          let
 205             open Layout
 206          in
 207             align [align (List.map (statements, Statement.layout)),
 208                    Transfer.layout transfer]
 209          end
 210
 211       fun prefix ({statements, transfer}: t, s: Statement.t): t =
 212          {statements = s :: statements,
 213           transfer = transfer}
 214    end
 215
 216 structure Cont:
 217    sig
 218       type t
 219
 220       val bind: Var.t * Res.t -> t
 221       val goto: Label.t -> t
 222       val layout: t -> Layout.t
 223       val receiveExp: (Exp.t * Type.t -> Res.t) -> t
 224       val receiveVar: (Var.t * Type.t -> Res.t) -> t
 225       val return: t
 226       val sendExp: t * Type.t * Exp.t -> Res.t
 227       val sendVar: t * Type.t * Var.t -> Res.t
 228       val toBlock: t * Type.t -> Block.t
 229    end =
 230    struct
 231       type bind = {arg: Var.t,
 232                    statements: Statement.t list,
 233                    transfer: Transfer.t}
 234
 235       datatype t =
 236          Bind of bind
 237        | Goto of Label.t
 238        | Prefix of t * Statement.t
 239        | ReceiveExp of Exp.t * Type.t -> Res.t
 240        | ReceiveVar of Var.t * Type.t -> Res.t
 241        | Return
 242
 243       fun layout (k: t): Layout.t =
 244          let
 245             open Layout
 246          in
 247             case k of
 248                Bind {arg, statements, transfer} =>
 249                   seq [str "Bind ",
 250                        record [("arg", Var.layout arg),
 251                                ("statements",
 252                                 List.layout Statement.layout statements),
 253                                ("transfer", Transfer.layout transfer)]]
 254              | Goto l => seq [str "Goto ", Label.layout l]
 255              | Prefix (k, s) => seq [str "Prefix ",
 256                                      tuple [layout k, Statement.layout s]]
 257              | ReceiveExp _ => str "ReceiveExp"
 258              | ReceiveVar _ => str "ReceiveVar"
 259              | Return => str "Return"
 260          end
 261
 262       fun bind (arg, {statements, transfer}) =
 263          Bind {arg = arg,
 264                statements = statements,
 265                transfer = transfer}
 266
 267       val goto = Goto
 268       val receiveExp = ReceiveExp
 269       val receiveVar = ReceiveVar
 270       val return = Return
 271
 272       fun toBind (k: t, ty: Type.t): bind =
 273          case k of
 274             Bind b => b
 275           | _ =>
 276                let
 277                   val arg = Var.newNoname ()
 278                   val {statements, transfer} = sendVar (k, ty, arg)
 279                in
 280                   {arg = arg,
 281                    statements = statements,
 282                    transfer = transfer}
 283                end
 284       and sendVar (k: t, ty: Type.t, x: Var.t): Res.t =
 285          case k of
 286             Bind b => sendBindExp (b, ty, Exp.Var x)
 287           | Goto dst => {statements = [],
 288                          transfer = Transfer.Goto {dst = dst,
 289                                                    args = Vector.new1 x}}
 290           | ReceiveExp f => f (Exp.Var x, ty)
 291           | ReceiveVar f => f (x, ty)
 292           | Prefix (k, s) => Res.prefix (sendVar (k, ty, x), s)
 293           | Return => {statements = [],
 294                        transfer = Transfer.Return (Vector.new1 x)}
 295       and sendBindExp ({arg, statements, transfer}, ty, e: Exp.t) =
 296          {statements = Statement.T {var = SOME arg,
 297                                     ty = ty,
 298                                     exp = e} :: statements,
 299           transfer = transfer}
 300
 301       val sendVar =
 302          Trace.trace3 ("DirectExp.Cont.sendVar", layout, Type.layout, Var.layout,
 303                        Res.layout)
 304          sendVar
 305
 306       val sendExp: t * Type.t * Exp.t -> Res.t =
 307          fn (k, ty, e) =>
 308          case k of
 309             ReceiveExp f => f (e, ty)
 310           | _ => sendBindExp (toBind (k, ty), ty, e)
 311
 312       val sendExp =
 313          Trace.trace3 ("DirectExp.Cont.sendExp", layout, Type.layout, Exp.layout,
 314                        Res.layout)
 315          sendExp
 316
 317       fun toBlock (k: t, ty: Type.t): Block.t =
 318          let
 319             val {arg, statements, transfer} = toBind (k, ty)
 320             val label = Label.newNoname ()
 321          in
 322             Block.T {label = label,
 323                      args = Vector.new1 (arg, ty),
 324                      statements = Vector.fromList statements,
 325                      transfer = transfer}
 326          end
 327
 328       val toBlock =
 329          Trace.trace2 ("DirectExp.Cont.toBlock", layout, Type.layout, Block.layout)
 330          toBlock
 331    end
 332
 333 fun selects (tuple: Var.t, ty: Type.t, components: Var.t vector)
 334    : Statement.t list =
 335    let
 336       val ts = Type.deTuple ty
 337    in
 338       Vector.foldi
 339       (ts, [], fn (i, t, ss) =>
 340        Statement.T {var = SOME (Vector.sub (components, i)),
 341                     ty = t,
 342                     exp = Exp.Select {tuple = tuple,
 343                                       offset = i}}
 344        :: ss)
 345    end
 346
 347 fun linearize' (e: t, h: Handler.t, k: Cont.t): Label.t * Block.t list =
 348    let
 349       val traceLinearizeLoop =
 350          Trace.trace3 ("DirectExp.linearize'.loop", layout, Handler.layout, Cont.layout,
 351                        Res.layout)
 352       val blocks: Block.t list ref = ref []
 353       fun newBlock (args: (Var.t * Type.t) vector,
 354                     {statements: Statement.t list,
 355                      transfer: Transfer.t}): Label.t =
 356          let
 357             val label = Label.newNoname ()
 358             val _ = List.push (blocks,
 359                                Block.T {label = label,
 360                                         args = args,
 361                                         statements = Vector.fromList statements,
 362                                         transfer = transfer})
 363          in
 364             label
 365          end
 366       fun reify (k: Cont.t, ty: Type.t): Label.t =
 367          let
 368             val b = Cont.toBlock (k, ty)
 369             val _ = List.push (blocks, b)
 370          in
 371             Block.label b
 372          end
 373       fun newLabel (args: (Var.t * Type.t) vector,
 374                     e: t,
 375                     h: Handler.t,
 376                     k: Cont.t): Label.t =
 377          newBlock (args, loop (e, h, k))
 378       and newLabel0 (e, h, k) = newLabel (Vector.new0 (), e, h, k)
 379       and loopf (e: t, h: Handler.t, f: Var.t * Type.t -> Res.t) =
 380          loop (e, h, Cont.receiveVar f)
 381       and loop arg : Res.t =
 382          traceLinearizeLoop
 383          (fn (e: t, h: Handler.t, k: Cont.t) =>
 384          case e of
 385             Arith {prim, args, overflow, ty} =>
 386                loops
 387                (args, h, fn xs =>
 388                 let
 389                    val l = reify (k, ty)
 390                    val k = Cont.goto l
 391                 in
 392                    {statements = [],
 393                     transfer =
 394                     Transfer.Arith {prim = prim,
 395                                     args = xs,
 396                                     overflow = newLabel0 (overflow, h, k),
 397                                     success = l,
 398                                     ty = ty}}
 399                 end)
 400           | Call {func, args, ty} =>
 401                loops
 402                (args, h, fn xs =>
 403                 {statements = [],
 404                  transfer = (Transfer.Call
 405                              {func = func,
 406                               args = xs,
 407                               return = Return.NonTail {cont = reify (k, ty),
 408                                                        handler = h}})})
 409           | Case {cases, default, test, ty} =>
 410                let
 411                   val k = Cont.goto (reify (k, ty))
 412                in
 413                   loopf (test, h, fn (x, _) =>
 414                          {statements = [],
 415                           transfer =
 416                           Transfer.Case
 417                           {test = x,
 418                            default = Option.map (default, fn e =>
 419                                                  newLabel0 (e, h, k)),
 420                            cases =
 421                            let
 422                               fun doit v =
 423                                  Vector.map (v, fn (c, e) =>
 424                                              (c, newLabel0 (e, h, k)))
 425                            in
 426                               case cases of
 427                                  Con v =>
 428                                     Cases.Con
 429                                     (Vector.map
 430                                      (v, fn {con, args, body} =>
 431                                       (con,
 432                                        newLabel (args, body, h, k))))
 433                                | Word (s, v) => Cases.Word (s, doit v)
 434                            end}})
 435                end
 436           | ConApp {con, args, ty} =>
 437                loops (args, h, fn xs =>
 438                       Cont.sendExp (k, ty, Exp.ConApp {con = con, args = xs}))
 439           | Const c => Cont.sendExp (k, Type.ofConst c, Exp.Const c)
 440           | Detuple {tuple, length, body} =>
 441                loop (tuple, h,
 442                      Cont.receiveExp
 443                      (fn (e, ty) =>
 444                       let
 445                          fun doit (tuple: Var.t): Res.t =
 446                             let
 447                                val (ss, xs) =
 448                                   case length of
 449                                      0 => ([], Vector.new0 ())
 450                                    | 1 => ([], Vector.new1 tuple)
 451                                    | _ =>
 452                                         let
 453                                            val xs =
 454                                               Vector.tabulate
 455                                               (length, fn _ => Var.newNoname ())
 456                                         in (selects (tuple, ty, xs), xs)
 457                                         end
 458                                val {statements, transfer} = loop (body xs, h, k)
 459                             in
 460                                {statements = List.appendRev (ss, statements),
 461                                 transfer = transfer}
 462                             end
 463                       in
 464                          case e of
 465                             Exp.Tuple xs => loop (body xs, h, k)
 466                           | Exp.Var x => doit x
 467                           | _ =>
 468                                let
 469                                   val tuple = Var.newNoname ()
 470                                in
 471                                   Res.prefix (doit tuple,
 472                                               Statement.T {var = SOME tuple,
 473                                                            ty = ty,
 474                                                            exp = e})
 475                                end
 476                       end))
 477           | DetupleBind {body, components, tuple, tupleTy} =>
 478                let
 479                   val {statements, transfer} = loop (body, h, k)
 480                   val ss =
 481                      case Vector.length components of
 482                         0 => []
 483                       | 1 => [Statement.T
 484                               {var = SOME (Vector.first components),
 485                                ty = tupleTy,
 486                                exp = Exp.Var tuple}]
 487                       | _ => selects (tuple, tupleTy, components)
 488                in
 489                   {statements = List.appendRev (ss, statements),
 490                    transfer = transfer}
 491                end
 492           | Handle {try, catch, handler, ty} =>
 493                let
 494                   val k = Cont.goto (reify (k, ty))
 495                   val hl = Label.newNoname ()
 496                   val {statements, transfer} = loop (handler, h, k)
 497                   val _ =
 498                      List.push (blocks,
 499                                 Block.T {label = hl,
 500                                          args = Vector.new1 catch,
 501                                          statements = Vector.fromList statements,
 502                                          transfer = transfer})
 503                in
 504                   loop (try, Handler.Handle hl, k)
 505                end
 506           | Let {decs, body} =>
 507                let
 508                   fun each decs =
 509                      case decs of
 510                         [] => loop (body, h, k)
 511                       | {var, exp} :: decs =>
 512                            loop (exp, h, Cont.bind (var, each decs))
 513                in
 514                   each decs
 515                end
 516           | Name (e, f) => loopf (e, h, fn (x, _) => loop (f x, h, k))
 517           | PrimApp {prim, targs, args, ty} =>
 518                loops
 519                (args, h, fn xs =>
 520                 Cont.sendExp (k, ty, Exp.PrimApp {prim = prim,
 521                                                   targs = targs,
 522                                                   args = xs}))
 523           | Profile e => Cont.sendExp (k, Type.unit, Exp.Profile e)
 524           | Raise e =>
 525                loopf (e, h, fn (x, _) =>
 526                       {statements = [],
 527                        transfer =
 528                        (case h of
 529                            Handler.Caller => Transfer.Raise (Vector.new1 x)
 530                          | Handler.Dead => Error.bug "DirectExp.linearize'.loop: Raise:to dead handler"
 531                          | Handler.Handle l =>
 532                               Transfer.Goto {args = Vector.new1 x,
 533                                              dst = l})})
 534           | Runtime {args, prim, ty} =>
 535                loops
 536                (args, h, fn xs =>
 537                 let
 538                    val l = reify (k, ty)
 539                    val k = Cont.goto l
 540                    val (args, exps) =
 541                       case Type.deTupleOpt ty of
 542                          NONE =>
 543                             let
 544                                val res = Var.newNoname ()
 545                             in
 546                                (Vector.new1 (res, ty),
 547                                 Vector.new1 (Var (res, ty)))
 548                             end
 549                        | SOME ts =>
 550                             if Vector.isEmpty ts
 551                                then (Vector.new0 (), Vector.new0 ())
 552                             else
 553                                Error.bug
 554                                (concat ["DirectExp.linearize'.loop: Runtime:with multiple return values: ",
 555                                         Prim.toString prim])
 556                 in
 557                    {statements = [],
 558                     transfer =
 559                     Transfer.Runtime
 560                     {prim = prim,
 561                      args = xs,
 562                      return = newLabel (args,
 563                                         tuple {exps = exps,
 564                                                ty = ty},
 565                                         h, k)}}
 566                 end)
 567           | Select {tuple, offset, ty} =>
 568                loopf (tuple, h, fn (tuple, _) =>
 569                       Cont.sendExp (k, ty, Exp.Select {tuple = tuple,
 570                                                        offset = offset}))
 571           | Seq (e1, e2) => loopf (e1, h, fn _ => loop (e2, h, k))
 572           | Tuple {exps, ty} =>
 573                loops (exps, h, fn xs => Cont.sendExp (k, ty, Exp.Tuple xs))
 574           | Var (x, ty) => Cont.sendVar (k, ty, x)) arg
 575       and loops (es: t vector, h: Handler.t, k: Var.t vector -> Res.t): Res.t =
 576          let
 577             val n = Vector.length es
 578             fun each (i, ac) =
 579                if i = n
 580                   then k (Vector.fromListRev ac)
 581                else loopf (Vector.sub (es, i), h, fn (x, _) =>
 582                            each (i + 1, x :: ac))
 583          in
 584             each (0, [])
 585          end
 586       val l = newLabel0 (e, h, k)
 587    in
 588       (l, !blocks)
 589    end
 590
 591 fun linearize (e: t, h) = linearize' (e, h, Cont.return)
 592
 593 val linearize =
 594    Trace.trace2 ("DirectExp.linearize", layout, Handler.layout,
 595                 Layout.tuple2 (Label.layout,
 596                                List.layout (Label.layout o Block.label)))
 597    linearize
 598
 599 fun linearizeGoto (e: t, h, l) = linearize' (e, h, Cont.goto l)
 600
 601 end
 602 end