mlton/backend/backend.fun

   1 (* Copyright (C) 2009,2013-2014,2017 Matthew Fluet.
   2  * Copyright (C) 1999-2008 Henry Cejtin, Matthew Fluet, Suresh
   3  *    Jagannathan, and Stephen Weeks.
   4  * Copyright (C) 1997-2000 NEC Research Institute.
   5  *
   6  * MLton is released under a BSD-style license.
   7  * See the file MLton-LICENSE for details.
   8  *)
   9
  10 functor Backend (S: BACKEND_STRUCTS): BACKEND =
  11 struct
  12
  13 open S
  14
  15 structure M = Machine
  16 local
  17    open Machine
  18 in
  19    structure Global = Global
  20    structure Label = Label
  21    structure Live = Live
  22    structure ObjptrTycon = ObjptrTycon
  23    structure RealX = RealX
  24    structure Register = Register
  25    structure Runtime = Runtime
  26    structure StackOffset = StackOffset
  27    structure WordSize = WordSize
  28    structure WordX = WordX
  29    structure WordXVector = WordXVector
  30 end
  31 local
  32    open Runtime
  33 in
  34    structure GCField = GCField
  35 end
  36
  37 structure Rssa = Rssa (open Ssa Machine)
  38 structure R = Rssa
  39 local
  40    open Rssa
  41 in
  42    structure CType = CType
  43    structure Const = Const
  44    structure Func = Func
  45    structure Function = Function
  46    structure Prim = Prim
  47    structure Type = Type
  48    structure Var = Var
  49 end
  50
  51 structure AllocateRegisters = AllocateRegisters (structure Machine = Machine
  52                                                  structure Rssa = Rssa)
  53 structure Chunkify = Chunkify (Rssa)
  54 structure ImplementHandlers = ImplementHandlers (structure Rssa = Rssa)
  55 structure ImplementProfiling = ImplementProfiling (structure Machine = Machine
  56                                                    structure Rssa = Rssa)
  57 structure LimitCheck = LimitCheck (structure Rssa = Rssa)
  58 structure ParallelMove = ParallelMove ()
  59 structure SignalCheck = SignalCheck(structure Rssa = Rssa)
  60 structure SsaToRssa = SsaToRssa (structure Rssa = Rssa
  61                                  structure Ssa = Ssa)
  62
  63 structure VarOperand =
  64    struct
  65       datatype t =
  66          Allocate of {operand: M.Operand.t option ref}
  67        | Const of M.Operand.t
  68
  69       fun layout i =
  70          let
  71             open Layout
  72          in
  73             case i of
  74                Allocate {operand, ...} =>
  75                   seq [str "Allocate ",
  76                        record [("operand",
  77                                 Option.layout M.Operand.layout (!operand))]]
  78              | Const oper => seq [str "Const ", M.Operand.layout oper]
  79          end
  80
  81       val operand: t -> M.Operand.t =
  82          fn Allocate {operand, ...} => valOf (!operand)
  83           | Const oper => oper
  84    end
  85
  86 structure IntSet = UniqueSet (val cacheSize: int = 1
  87                               val bits: int = 14
  88                               structure Element =
  89                                  struct
  90                                     open Int
  91                                     fun hash n = Word.fromInt n
  92                                  end)
  93
  94 structure Chunk =
  95    struct
  96       datatype t = T of {blocks: M.Block.t list ref,
  97                          chunkLabel: M.ChunkLabel.t}
  98
  99       fun label (T {chunkLabel, ...}) = chunkLabel
 100
 101       fun new (): t =
 102          T {blocks = ref [],
 103             chunkLabel = M.ChunkLabel.newNoname ()}
 104
 105       fun newBlock (T {blocks, ...}, z) =
 106          List.push (blocks, M.Block.T z)
 107    end
 108
 109 val traceGenBlock =
 110    Trace.trace ("Backend.genBlock",
 111                 Label.layout o R.Block.label,
 112                 Unit.layout)
 113
 114 fun eliminateDeadCode (f: R.Function.t): R.Function.t =
 115    let
 116       val {args, blocks, name, returns, raises, start} = R.Function.dest f
 117       val {get, rem, set, ...} =
 118          Property.getSetOnce (Label.plist, Property.initConst false)
 119       val get = Trace.trace ("Backend.labelIsReachable",
 120                              Label.layout,
 121                              Bool.layout) get
 122       val _ =
 123          R.Function.dfs (f, fn R.Block.T {label, ...} =>
 124                          (set (label, true)
 125                           ; fn () => ()))
 126       val blocks =
 127          Vector.keepAll (blocks, fn R.Block.T {label, ...} =>
 128                          let
 129                             val res = get label
 130                             val () = rem label
 131                          in
 132                             res
 133                          end)
 134    in
 135       R.Function.new {args = args,
 136                       blocks = blocks,
 137                       name = name,
 138                       returns = returns,
 139                       raises = raises,
 140                       start = start}
 141    end
 142
 143 fun toMachine (program: Ssa.Program.t, codegen) =
 144    let
 145       fun pass (name, doit, program) =
 146          Control.passTypeCheck {display = Control.Layouts Rssa.Program.layouts,
 147                                 name = name,
 148                                 stats = R.Program.layoutStats,
 149                                 style = Control.No,
 150                                 suffix = "rssa",
 151                                 thunk = fn () => doit program,
 152                                 typeCheck = R.Program.typeCheck}
 153       val program = pass ("toRssa", SsaToRssa.convert, (program, codegen))
 154       fun rssaSimplify p =
 155          let
 156             open Rssa
 157             fun pass' ({name, doit}, sel, p) =
 158                let
 159                   val _ =
 160                      let open Control
 161                      in maybeSaveToFile
 162                         ({name = name,
 163                           suffix = "pre.rssa"},
 164                          Control.No, p, Control.Layouts Program.layouts)
 165                      end
 166                   val p =
 167                      Control.passTypeCheck
 168                      {display = Control.Layouts
 169                                 (fn (r,output) =>
 170                                  Program.layouts (sel r, output)),
 171                       name = name,
 172                       stats = Program.layoutStats o sel,
 173                       style = Control.No,
 174                       suffix = "post.rssa",
 175                       thunk = fn () => doit p,
 176                       typeCheck = Program.typeCheck o sel}
 177                in
 178                   p
 179                end
 180             fun pass ({name, doit}, p) =
 181                pass' ({name = name, doit = doit}, fn p => p, p)
 182             fun maybePass ({name, doit, execute}, p) =
 183                if List.foldr (!Control.executePasses, execute, fn ((re, new), old) =>
 184                   if Regexp.Compiled.matchesAll (re, name)
 185                      then new
 186                      else old)
 187                then pass ({name = name, doit = doit}, p)
 188                else (Control.messageStr (Control.Pass, name ^ " skipped"); p)
 189             val p = maybePass ({name = "rssaShrink1",
 190                                 doit = Program.shrink,
 191                                 execute = true}, p)
 192             val p = pass ({name = "insertLimitChecks",
 193                            doit = LimitCheck.transform}, p)
 194             val p = pass ({name = "insertSignalChecks",
 195                            doit = SignalCheck.transform}, p)
 196             val p = pass ({name = "implementHandlers",
 197                            doit = ImplementHandlers.transform}, p)
 198             val p = maybePass ({name = "rssaShrink2",
 199                                 doit = Program.shrink,
 200                                 execute = true}, p)
 201             val () = Program.checkHandlers p
 202             val (p, makeProfileInfo) =
 203                pass' ({name = "implementProfiling",
 204                        doit = ImplementProfiling.doit},
 205                       fn (p,_) => p, p)
 206             val p = maybePass ({name = "rssaOrderFunctions",
 207                                 doit = Program.orderFunctions,
 208                                 execute = true}, p)
 209          in
 210             (p, makeProfileInfo)
 211          end
 212       val (program, makeProfileInfo) =
 213          Control.passTypeCheck
 214          {display = Control.Layouts (fn ((program, _), output) =>
 215                                      Rssa.Program.layouts (program, output)),
 216           name = "rssaSimplify",
 217           stats = fn (program,_) => Rssa.Program.layoutStats program,
 218           style = Control.No,
 219           suffix = "rssa",
 220           thunk = fn () => rssaSimplify program,
 221           typeCheck = R.Program.typeCheck o #1}
 222       val _ =
 223          let
 224             open Control
 225          in
 226             if !keepRSSA
 227                then saveToFile ({suffix = "rssa"},
 228                                 No,
 229                                 program,
 230                                 Layouts Rssa.Program.layouts)
 231             else ()
 232          end
 233       val program =
 234          Control.pass
 235          {display = Control.Layouts Machine.Program.layouts,
 236           name = "toMachine",
 237           stats = fn _ => Layout.empty,
 238           style = Control.No,
 239           suffix = "machine",
 240           thunk = fn () =>
 241 let
 242       val R.Program.T {functions, handlesSignals, main, objectTypes} = program
 243       (* Chunk information *)
 244       val {get = labelChunk, set = setLabelChunk, ...} =
 245          Property.getSetOnce (Label.plist,
 246                               Property.initRaise ("labelChunk", Label.layout))
 247       val {get = funcChunk: Func.t -> Chunk.t, set = setFuncChunk, ...} =
 248          Property.getSetOnce (Func.plist,
 249                               Property.initRaise ("funcChunk", Func.layout))
 250       val chunks = ref []
 251       fun newChunk () =
 252          let
 253             val c = Chunk.new ()
 254             val _ = List.push (chunks, c)
 255          in
 256             c
 257          end
 258       val handlers = ref []
 259       (* Set funcChunk and labelChunk. *)
 260       val _ =
 261          Vector.foreach
 262          (Chunkify.chunkify program, fn {funcs, labels} =>
 263           let
 264              val c = newChunk ()
 265              val _ = Vector.foreach (funcs, fn f => setFuncChunk (f, c))
 266              val _ = Vector.foreach (labels, fn l => setLabelChunk (l, c))
 267           in
 268              ()
 269           end)
 270       (* FrameInfo. *)
 271       local
 272          val frameLabels = ref []
 273          val frameLayouts = ref []
 274          val frameLayoutsCounter = Counter.new 0
 275          val _ = IntSet.reset ()
 276          val table = HashSet.new {hash = Word.fromInt o #frameOffsetsIndex}
 277          val frameOffsets: Bytes.t vector list ref = ref []
 278          val frameOffsetsCounter = Counter.new 0
 279          val {get = frameOffsetsIndex: IntSet.t -> int, ...} =
 280             Property.get
 281             (IntSet.plist,
 282              Property.initFun
 283              (fn offsets =>
 284               let
 285                  val _ = List.push (frameOffsets,
 286                                     QuickSort.sortVector
 287                                     (Vector.fromListMap
 288                                      (IntSet.toList offsets, Bytes.fromInt),
 289                                      Bytes.<=))
 290               in
 291                  Counter.next frameOffsetsCounter
 292               end))
 293       in
 294          fun allFrameInfo () =
 295             let
 296                (* Reverse lists because the index is from back of list. *)
 297                val frameLabels = Vector.fromListRev (!frameLabels)
 298                val frameLayouts = Vector.fromListRev (!frameLayouts)
 299                val frameOffsets = Vector.fromListRev (!frameOffsets)
 300             in
 301                (frameLabels, frameLayouts, frameOffsets)
 302             end
 303          fun getFrameLayoutsIndex {isC: bool,
 304                                    label: Label.t,
 305                                    offsets: Bytes.t list,
 306                                    size: Bytes.t}: int =
 307             let
 308                val foi =
 309                   frameOffsetsIndex (IntSet.fromList
 310                                      (List.map (offsets, Bytes.toInt)))
 311                fun new () =
 312                   let
 313                      val _ =
 314                         List.push (frameLayouts,
 315                                    {frameOffsetsIndex = foi,
 316                                     isC = isC,
 317                                     size = size})
 318                      val _ = List.push (frameLabels, label)
 319                   in
 320                      Counter.next frameLayoutsCounter
 321                   end
 322             in
 323                (* We need to give each frame its own layout index in two cases.
 324                 * 1. If we are using the C codegen, in which case we want the
 325                 *    indices in a chunk to be consecutive integers so that gcc
 326                 *    will use a jump table.
 327                 * 2. If we are profiling, we want every frame to have a
 328                 *    different index so that it can have its own profiling info.
 329                 *    This will be created by the call to makeProfileInfo at the
 330                 *    end of the backend.
 331                 *)
 332                if !Control.codegen = Control.CCodegen
 333                   orelse !Control.codegen = Control.LLVMCodegen
 334                   orelse !Control.profile <> Control.ProfileNone
 335                   then new ()
 336                else
 337                #frameLayoutsIndex
 338                (HashSet.lookupOrInsert
 339                 (table, Word.fromInt foi,
 340                  fn {frameOffsetsIndex = foi', isC = isC', size = s', ...} =>
 341                  foi = foi'
 342                  andalso isC = isC'
 343                  andalso Bytes.equals (size, s'),
 344                  fn () => {frameLayoutsIndex = new (),
 345                            frameOffsetsIndex = foi,
 346                            isC = isC,
 347                            size = size}))
 348             end
 349       end
 350       val {get = frameInfo: Label.t -> M.FrameInfo.t option,
 351            set = setFrameInfo, ...} =
 352          Property.getSetOnce (Label.plist,
 353                               Property.initConst NONE)
 354       val setFrameInfo =
 355          Trace.trace2 ("Backend.setFrameInfo",
 356                        Label.layout, Option.layout M.FrameInfo.layout,
 357                        Unit.layout)
 358          setFrameInfo
 359       (* The global raise operands. *)
 360       local
 361          val table: (Type.t vector * M.Live.t vector) list ref = ref []
 362       in
 363          fun raiseOperands (ts: Type.t vector): M.Live.t vector =
 364             case List.peek (!table, fn (ts', _) =>
 365                             Vector.equals (ts, ts', Type.equals)) of
 366                NONE =>
 367                   let
 368                      val gs =
 369                         Vector.map (ts, fn ty =>
 370                                     M.Live.Global
 371                                     (Global.new {isRoot = false,
 372                                                  ty = ty}))
 373                      val _ = List.push (table, (ts, gs))
 374                   in
 375                      gs
 376                   end
 377              | SOME (_, gs) => gs
 378       end
 379       val {get = varInfo: Var.t -> {operand: VarOperand.t,
 380                                     ty: Type.t},
 381            set = setVarInfo, ...} =
 382          Property.getSetOnce (Var.plist,
 383                               Property.initRaise ("Backend.info", Var.layout))
 384       val setVarInfo =
 385          Trace.trace2 ("Backend.setVarInfo",
 386                        Var.layout, VarOperand.layout o #operand, Unit.layout)
 387          setVarInfo
 388       val varInfo =
 389          Trace.trace ("Backend.varInfo",
 390                       Var.layout,
 391                       fn {operand, ...} =>
 392                       Layout.record [("operand", VarOperand.layout operand)])
 393          varInfo
 394       val varOperand: Var.t -> M.Operand.t =
 395          VarOperand.operand o #operand o varInfo
 396       (* Hash tables for uniquifying globals. *)
 397       local
 398          fun ('a, 'b) make (equals: 'a * 'a -> bool,
 399                             info: 'a -> string * Type.t * 'b) =
 400             let
 401                val set: {a: 'a,
 402                          global: M.Global.t,
 403                          hash: word,
 404                          value: 'b} HashSet.t = HashSet.new {hash = #hash}
 405                fun get (a: 'a): M.Operand.t =
 406                   let
 407                      val (string, ty, value) = info a
 408                      val hash = String.hash string
 409                   in
 410                      M.Operand.Global
 411                      (#global
 412                       (HashSet.lookupOrInsert
 413                        (set, hash,
 414                         fn {a = a', ...} => equals (a, a'),
 415                         fn () => {a = a,
 416                                   hash = hash,
 417                                   global = M.Global.new {isRoot = true,
 418                                                          ty = ty},
 419                                   value = value})))
 420                   end
 421                fun all () =
 422                   HashSet.fold
 423                   (set, [], fn ({global, value, ...}, ac) =>
 424                    (global, value) :: ac)
 425             in
 426                (all, get)
 427             end
 428       in
 429          val (allReals, globalReal) =
 430             make (RealX.equals,
 431                   fn r => (RealX.toString r,
 432                            Type.real (RealX.size r),
 433                            r))
 434          val (allVectors, globalVector) =
 435             make (WordXVector.equals,
 436                   fn v => (WordXVector.toString v,
 437                            Type.ofWordXVector v,
 438                            v))
 439       end
 440       fun bogusOp (t: Type.t): M.Operand.t =
 441          case Type.deReal t of
 442             NONE => let
 443                        val bogusWord =
 444                           M.Operand.Word
 445                           (WordX.zero
 446                            (WordSize.fromBits (Type.width t)))
 447                     in
 448                        case Type.deWord t of
 449                           NONE => M.Operand.Cast (bogusWord, t)
 450                         | SOME _ => bogusWord
 451                     end
 452           | SOME s => globalReal (RealX.zero s)
 453       fun constOperand (c: Const.t): M.Operand.t =
 454          let
 455             datatype z = datatype Const.t
 456          in
 457             case c of
 458                IntInf _ =>
 459                   Error.bug "Backend.constOperand: IntInf"
 460              | Null => M.Operand.Null
 461              | Real r => globalReal r
 462              | Word w => M.Operand.Word w
 463              | WordVector v => globalVector v
 464          end
 465       fun parallelMove {chunk = _,
 466                         dsts: M.Operand.t vector,
 467                         srcs: M.Operand.t vector}: M.Statement.t vector =
 468          let
 469             val moves =
 470                Vector.fold2 (srcs, dsts, [],
 471                              fn (src, dst, ac) => {src = src, dst = dst} :: ac)
 472             fun temp r =
 473                M.Operand.Register (Register.new (M.Operand.ty r, NONE))
 474          in
 475             Vector.fromList
 476             (ParallelMove.move {
 477                                 equals = M.Operand.equals,
 478                                 move = M.Statement.move,
 479                                 moves = moves,
 480                                 interfere = M.Operand.interfere,
 481                                 temp = temp
 482                                 })
 483          end
 484       fun runtimeOp (field: GCField.t): M.Operand.t =
 485          case field of
 486             GCField.Frontier => M.Operand.Frontier
 487           | GCField.StackTop => M.Operand.StackTop
 488           | _ =>
 489                M.Operand.Offset {base = M.Operand.GCState,
 490                                  offset = GCField.offset field,
 491                                  ty = Type.ofGCField field}
 492       val exnStackOp = runtimeOp GCField.ExnStack
 493       val stackBottomOp = runtimeOp GCField.StackBottom
 494       val stackTopOp = runtimeOp GCField.StackTop
 495       fun translateOperand (oper: R.Operand.t): M.Operand.t =
 496          let
 497             datatype z = datatype R.Operand.t
 498          in
 499             case oper of
 500                ArrayOffset {base, index, offset, scale, ty} =>
 501                   let
 502                      val base = translateOperand base
 503                   in
 504                      if M.Operand.isLocation base
 505                         then M.Operand.ArrayOffset {base = base,
 506                                                     index = translateOperand index,
 507                                                     offset = offset,
 508                                                     scale = scale,
 509                                                     ty = ty}
 510                      else bogusOp ty
 511                   end
 512              | Cast (z, t) => M.Operand.Cast (translateOperand z, t)
 513              | Const c => constOperand c
 514              | EnsuresBytesFree =>
 515                   Error.bug "Backend.translateOperand: EnsuresBytesFree"
 516              | GCState => M.Operand.GCState
 517              | Offset {base, offset, ty} =>
 518                   let
 519                      val base = translateOperand base
 520                   in
 521                      if M.Operand.isLocation base
 522                         then M.Operand.Offset {base = base,
 523                                                offset = offset,
 524                                                ty = ty}
 525                      else bogusOp ty
 526                   end
 527              | ObjptrTycon opt =>
 528                   M.Operand.Word
 529                   (WordX.fromIntInf
 530                    (Word.toIntInf (Runtime.typeIndexToHeader
 531                                    (ObjptrTycon.index opt)),
 532                     WordSize.objptrHeader ()))
 533              | Runtime f => runtimeOp f
 534              | Var {var, ...} => varOperand var
 535          end
 536       fun translateOperands ops = Vector.map (ops, translateOperand)
 537       fun genStatement (s: R.Statement.t,
 538                         handlerLinkOffset: {handler: Bytes.t,
 539                                             link: Bytes.t} option)
 540          : M.Statement.t vector =
 541          let
 542             fun handlerOffset () = #handler (valOf handlerLinkOffset)
 543             fun linkOffset () = #link (valOf handlerLinkOffset)
 544             datatype z = datatype R.Statement.t
 545          in
 546             case s of
 547                Bind {dst = (var, _), src, ...} =>
 548                   Vector.new1
 549                   (M.Statement.move {dst = varOperand var,
 550                                      src = translateOperand src})
 551              | Move {dst, src} =>
 552                   Vector.new1
 553                   (M.Statement.move {dst = translateOperand dst,
 554                                      src = translateOperand src})
 555              | Object {dst, header, size} =>
 556                   M.Statement.object {dst = varOperand (#1 dst),
 557                                       header = header,
 558                                       size = size}
 559              | PrimApp {dst, prim, args} =>
 560                   let
 561                      datatype z = datatype Prim.Name.t
 562                   in
 563                      case Prim.name prim of
 564                         MLton_touch => Vector.new0 ()
 565                       | _ =>
 566                            Vector.new1
 567                            (M.Statement.PrimApp
 568                             {args = translateOperands args,
 569                              dst = Option.map (dst, varOperand o #1),
 570                              prim = prim})
 571                   end
 572              | ProfileLabel s => Vector.new1 (M.Statement.ProfileLabel s)
 573              | SetExnStackLocal =>
 574                   (* ExnStack = stackTop + (offset + LABEL_SIZE) - StackBottom; *)
 575                   let
 576                      val tmp1 =
 577                         M.Operand.Register
 578                         (Register.new (Type.cpointer (), NONE))
 579                      val tmp2 =
 580                         M.Operand.Register
 581                         (Register.new (Type.csize (), NONE))
 582                   in
 583                      Vector.new3
 584                      (M.Statement.PrimApp
 585                       {args = (Vector.new2
 586                                (stackTopOp,
 587                                 M.Operand.Word
 588                                 (WordX.fromIntInf
 589                                  (Int.toIntInf
 590                                   (Bytes.toInt
 591                                    (Bytes.+ (handlerOffset (), Runtime.labelSize ()))),
 592                                   WordSize.cpointer ())))),
 593                        dst = SOME tmp1,
 594                        prim = Prim.cpointerAdd},
 595                       M.Statement.PrimApp
 596                       {args = Vector.new2 (tmp1, stackBottomOp),
 597                        dst = SOME tmp2,
 598                        prim = Prim.cpointerDiff},
 599                       M.Statement.move
 600                       {dst = exnStackOp,
 601                        src = M.Operand.Cast (tmp2, Type.exnStack ())})
 602                   end
 603              | SetExnStackSlot =>
 604                   (* ExnStack = *(uint* )(stackTop + offset); *)
 605                   Vector.new1
 606                   (M.Statement.move
 607                    {dst = exnStackOp,
 608                     src = M.Operand.stackOffset {offset = linkOffset (),
 609                                                  ty = Type.exnStack ()}})
 610              | SetHandler h =>
 611                   Vector.new1
 612                   (M.Statement.move
 613                    {dst = M.Operand.stackOffset {offset = handlerOffset (),
 614                                                  ty = Type.label h},
 615                     src = M.Operand.Label h})
 616              | SetSlotExnStack =>
 617                   (* *(uint* )(stackTop + offset) = ExnStack; *)
 618                   Vector.new1
 619                   (M.Statement.move
 620                    {dst = M.Operand.stackOffset {offset = linkOffset (),
 621                                                  ty = Type.exnStack ()},
 622                     src = exnStackOp})
 623              | _ => Error.bug (concat
 624                                ["Backend.genStatement: strange statement: ",
 625                                 R.Statement.toString s])
 626          end
 627       val genStatement =
 628          Trace.trace ("Backend.genStatement",
 629                       R.Statement.layout o #1, Vector.layout M.Statement.layout)
 630          genStatement
 631       val bugTransfer = fn () =>
 632          M.Transfer.CCall
 633          {args = (Vector.new1
 634                   (globalVector
 635                    (WordXVector.fromString
 636                     "backend thought control shouldn't reach here"))),
 637           frameInfo = NONE,
 638           func = Type.BuiltInCFunction.bug (),
 639           return = NONE}
 640       val {get = labelInfo: Label.t -> {args: (Var.t * Type.t) vector},
 641            set = setLabelInfo, ...} =
 642          Property.getSetOnce
 643          (Label.plist, Property.initRaise ("labelInfo", Label.layout))
 644       val setLabelInfo =
 645          Trace.trace2 ("Backend.setLabelInfo",
 646                        Label.layout, Layout.ignore, Unit.layout)
 647          setLabelInfo
 648       fun callReturnStackOffsets (xs: 'a vector,
 649                                   ty: 'a -> Type.t,
 650                                   shift: Bytes.t): StackOffset.t vector =
 651          #1 (Vector.mapAndFold
 652              (xs, Bytes.zero,
 653               fn (x, offset) =>
 654               let
 655                  val ty = ty x
 656                  val offset = Type.align (ty, offset)
 657               in
 658                  (StackOffset.T {offset = Bytes.+ (shift, offset), ty = ty},
 659                   Bytes.+ (offset, Type.bytes ty))
 660               end))
 661       val operandLive: M.Operand.t -> M.Live.t =
 662          valOf o M.Live.fromOperand
 663       val operandsLive: M.Operand.t vector -> M.Live.t vector =
 664          fn ops => Vector.map (ops, operandLive)
 665       val isGlobal =
 666          let
 667             val {get: Var.t -> bool, set, rem, ...} =
 668                Property.getSet
 669                (Var.plist,
 670                 Property.initRaise ("Backend.toMachine.isGlobal", Var.layout))
 671             val _ =
 672                Function.foreachDef (main, fn (x, _) => set (x, false))
 673             val _ =
 674                List.foreach
 675                (functions, fn f =>
 676                 (Function.foreachUse (f, fn x => set (x, true))
 677                  ; Function.foreachDef (f, fn (x, _) => rem x)))
 678          in
 679             get
 680          end
 681       fun genFunc (f: Function.t, isMain: bool): unit =
 682          let
 683             val f = eliminateDeadCode f
 684             val {args, blocks, name, raises, returns, start, ...} =
 685                Function.dest f
 686             val raises = Option.map (raises, fn ts => raiseOperands ts)
 687             val returns =
 688                Option.map (returns, fn ts =>
 689                            callReturnStackOffsets (ts, fn t => t, Bytes.zero))
 690             val chunk = funcChunk name
 691             fun labelArgOperands (l: R.Label.t): M.Operand.t vector =
 692                Vector.map (#args (labelInfo l), varOperand o #1)
 693             fun newVarInfo (x, ty: Type.t) =
 694                let
 695                   val operand =
 696                      if isMain andalso isGlobal x
 697                         then let
 698                                 val _ =
 699                                    Control.diagnostics
 700                                    (fn display =>
 701                                     let
 702                                        open Layout
 703                                     in
 704                                        display (seq
 705                                                 [str "Global: ",
 706                                                  R.Var.layout x,
 707                                                  str ": ",
 708                                                  R.Type.layout ty])
 709                                     end)
 710                              in
 711                                 VarOperand.Const (M.Operand.Global
 712                                                   (M.Global.new {isRoot = true,
 713                                                                  ty = ty}))
 714                              end
 715                      else VarOperand.Allocate {operand = ref NONE}
 716                in
 717                   setVarInfo (x, {operand = operand,
 718                                   ty = ty})
 719                end
 720             fun newVarInfos xts = Vector.foreach (xts, newVarInfo)
 721             (* Set the constant operands, labelInfo, and varInfo. *)
 722             val _ = newVarInfos args
 723             val _ =
 724                Rssa.Function.dfs
 725                (f, fn R.Block.T {args, label, statements, transfer, ...} =>
 726                 let
 727                    val _ = setLabelInfo (label, {args = args})
 728                    val _ = newVarInfos args
 729                    val _ =
 730                       Vector.foreach
 731                       (statements, fn s =>
 732                        let
 733                           fun normal () = R.Statement.foreachDef (s, newVarInfo)
 734                        in
 735                           case s of
 736                              R.Statement.Bind {dst = (var, _), isMutable, src} =>
 737                                 if isMutable
 738                                    then normal ()
 739                                 else
 740                                    let
 741                                       fun set (z: M.Operand.t,
 742                                                casts: Type.t list) =
 743                                          let
 744                                             val z =
 745                                                List.fold
 746                                                (casts, z, fn (t, z) =>
 747                                                 M.Operand.Cast (z, t))
 748                                          in
 749                                             setVarInfo
 750                                             (var, {operand = VarOperand.Const z,
 751                                                    ty = M.Operand.ty z})
 752                                          end
 753                                       fun loop (z: R.Operand.t, casts) =
 754                                          case z of
 755                                             R.Operand.Cast (z, t) =>
 756                                                loop (z, t :: casts)
 757                                           | R.Operand.Const c =>
 758                                                set (constOperand c, casts)
 759                                           | R.Operand.Var {var = var', ...} =>
 760                                                (case #operand (varInfo var') of
 761                                                    VarOperand.Const z =>
 762                                                       set (z, casts)
 763                                                  | VarOperand.Allocate _ =>
 764                                                       normal ())
 765                                           | _ => normal ()
 766                                    in
 767                                       loop (src, [])
 768                                    end
 769                            | _ => normal ()
 770                        end)
 771                    val _ = R.Transfer.foreachDef (transfer, newVarInfo)
 772                 in
 773                    fn () => ()
 774                 end)
 775             (* Allocate stack slots. *)
 776             local
 777                val varInfo =
 778                   fn x =>
 779                   let
 780                      val {operand, ty, ...} = varInfo x
 781                   in
 782                      {operand = (case operand of
 783                                     VarOperand.Allocate {operand, ...} =>
 784                                        SOME operand
 785                                   | _ => NONE),
 786                       ty = ty}
 787                   end
 788             in
 789                val {handlerLinkOffset, labelInfo = labelRegInfo, ...} =
 790                   let
 791                      fun formalsStackOffsets args =
 792                         callReturnStackOffsets (args, fn (_, ty) => ty, Bytes.zero)
 793                   in
 794                      AllocateRegisters.allocate {formalsStackOffsets = formalsStackOffsets,
 795                                                  function = f,
 796                                                  varInfo = varInfo}
 797                   end
 798             end
 799             (* Set the frameInfo for blocks in this function. *)
 800             val _ =
 801                Vector.foreach
 802                (blocks, fn R.Block.T {kind, label, ...} =>
 803                 let
 804                    fun doit (useOffsets: bool): unit =
 805                       let
 806                          val {liveNoFormals, size, ...} = labelRegInfo label
 807                          val offsets =
 808                             if useOffsets
 809                                then
 810                                   Vector.fold
 811                                   (liveNoFormals, [], fn (oper, ac) =>
 812                                    case oper of
 813                                       M.Operand.StackOffset (StackOffset.T {offset, ty}) =>
 814                                          if Type.isObjptr ty
 815                                             then offset :: ac
 816                                          else ac
 817                                     | _ => ac)
 818                             else
 819                                []
 820                          val isC =
 821                             case kind of
 822                                R.Kind.CReturn _ => true
 823                              | _ => false
 824                          val frameLayoutsIndex =
 825                             getFrameLayoutsIndex {isC = isC,
 826                                                   label = label,
 827                                                   offsets = offsets,
 828                                                   size = size}
 829                       in
 830                          setFrameInfo
 831                          (label,
 832                           SOME (M.FrameInfo.T
 833                                 {frameLayoutsIndex = frameLayoutsIndex}))
 834                       end
 835                 in
 836                    case R.Kind.frameStyle kind of
 837                       R.Kind.None => ()
 838                     | R.Kind.OffsetsAndSize => doit true
 839                     | R.Kind.SizeOnly => doit false
 840                 end)
 841             (* ------------------------------------------------- *)
 842             (*                    genTransfer                    *)
 843             (* ------------------------------------------------- *)
 844             fun genTransfer (t: R.Transfer.t, chunk: Chunk.t)
 845                : M.Statement.t vector * M.Transfer.t =
 846                let
 847                   fun simple t = (Vector.new0 (), t)
 848                in
 849                   case t of
 850                      R.Transfer.Arith {args, dst, overflow, prim, success,
 851                                        ...} =>
 852                         simple
 853                         (M.Transfer.Arith {args = translateOperands args,
 854                                            dst = varOperand dst,
 855                                            overflow = overflow,
 856                                            prim = prim,
 857                                            success = success})
 858                    | R.Transfer.CCall {args, func, return} =>
 859                         simple (M.Transfer.CCall
 860                                 {args = translateOperands args,
 861                                  frameInfo = (case return of
 862                                                  NONE => NONE
 863                                                | SOME l => frameInfo l),
 864                                  func = func,
 865                                  return = return})
 866                    | R.Transfer.Call {func, args, return} =>
 867                         let
 868                            datatype z = datatype R.Return.t
 869                            val (contLive, frameSize, return) =
 870                               case return of
 871                                  Dead => (Vector.new0 (), Bytes.zero, NONE)
 872                                | Tail => (Vector.new0 (), Bytes.zero, NONE)
 873                                | NonTail {cont, handler} =>
 874                                     let
 875                                        val {liveNoFormals, size, ...} =
 876                                           labelRegInfo cont
 877                                        datatype z = datatype R.Handler.t
 878                                        val handler =
 879                                           case handler of
 880                                              Caller => NONE
 881                                            | Dead => NONE
 882                                            | Handle h => SOME h
 883                                     in
 884                                        (liveNoFormals,
 885                                         size,
 886                                         SOME {return = cont,
 887                                               handler = handler,
 888                                               size = size})
 889                                     end
 890                            val dsts =
 891                               callReturnStackOffsets
 892                               (args, R.Operand.ty, frameSize)
 893                            val setupArgs =
 894                               parallelMove
 895                               {chunk = chunk,
 896                                dsts = Vector.map (dsts, M.Operand.StackOffset),
 897                                srcs = translateOperands args}
 898                            val live =
 899                               Vector.concat [operandsLive contLive,
 900                                              Vector.map (dsts, Live.StackOffset)]
 901                            val transfer =
 902                               M.Transfer.Call {label = funcToLabel func,
 903                                                live = live,
 904                                                return = return}
 905                         in
 906                            (setupArgs, transfer)
 907                         end
 908                    | R.Transfer.Goto {dst, args} =>
 909                         (parallelMove {srcs = translateOperands args,
 910                                        dsts = labelArgOperands dst,
 911                                        chunk = labelChunk dst},
 912                          M.Transfer.Goto dst)
 913                    | R.Transfer.Raise srcs =>
 914                         (M.Statement.moves {dsts = Vector.map (valOf raises,
 915                                                                Live.toOperand),
 916                                             srcs = translateOperands srcs},
 917                          M.Transfer.Raise)
 918                    | R.Transfer.Return xs =>
 919                         (parallelMove {chunk = chunk,
 920                                        dsts = Vector.map (valOf returns,
 921                                                           M.Operand.StackOffset),
 922                                        srcs = translateOperands xs},
 923                          M.Transfer.Return)
 924                    | R.Transfer.Switch switch =>
 925                         let
 926                            val R.Switch.T {cases, default, size, test} =
 927                               switch
 928                         in
 929                            simple
 930                            (case (Vector.length cases, default) of
 931                                (0, NONE) => bugTransfer ()
 932                              | (1, NONE) =>
 933                                   M.Transfer.Goto (#2 (Vector.sub (cases, 0)))
 934                              | (0, SOME dst) => M.Transfer.Goto dst
 935                              | _ =>
 936                                   M.Transfer.Switch
 937                                   (M.Switch.T
 938                                    {cases = cases,
 939                                     default = default,
 940                                     size = size,
 941                                     test = translateOperand test}))
 942                         end
 943                end
 944             val genTransfer =
 945                Trace.trace ("Backend.genTransfer",
 946                             R.Transfer.layout o #1,
 947                             Layout.tuple2 (Vector.layout M.Statement.layout,
 948                                            M.Transfer.layout))
 949                genTransfer
 950             fun genBlock (R.Block.T {args, kind, label, statements, transfer,
 951                                      ...}) : unit =
 952                let
 953                   val _ =
 954                      if Label.equals (label, start)
 955                         then let
 956                                 val live = #live (labelRegInfo start)
 957                                 val returns =
 958                                    Option.map
 959                                    (returns, fn returns =>
 960                                     Vector.map (returns, Live.StackOffset))
 961                              in
 962                                 Chunk.newBlock
 963                                 (chunk,
 964                                  {label = funcToLabel name,
 965                                   kind = M.Kind.Func,
 966                                   live = operandsLive live,
 967                                   raises = raises,
 968                                   returns = returns,
 969                                   statements = Vector.new0 (),
 970                                   transfer = M.Transfer.Goto start})
 971                              end
 972                      else ()
 973                   val {live, liveNoFormals, size, ...} = labelRegInfo label
 974                   val chunk = labelChunk label
 975                   val statements =
 976                      Vector.concatV
 977                      (Vector.map (statements, fn s =>
 978                                   genStatement (s, handlerLinkOffset)))
 979                   val (preTransfer, transfer) = genTransfer (transfer, chunk)
 980                   val (kind, live, pre) =
 981                      case kind of
 982                         R.Kind.Cont _ =>
 983                            let
 984                               val srcs = callReturnStackOffsets (args, #2, size)
 985                            in
 986                               (M.Kind.Cont {args = Vector.map (srcs,
 987                                                                Live.StackOffset),
 988                                             frameInfo = valOf (frameInfo label)},
 989                                liveNoFormals,
 990                                parallelMove
 991                                {chunk = chunk,
 992                                 dsts = Vector.map (args, varOperand o #1),
 993                                 srcs = Vector.map (srcs, M.Operand.StackOffset)})
 994                            end
 995                       | R.Kind.CReturn {func, ...} =>
 996                            let
 997                               val dst =
 998                                  case Vector.length args of
 999                                     0 => NONE
1000                                   | 1 => SOME (operandLive
1001                                                (varOperand
1002                                                 (#1 (Vector.sub (args, 0)))))
1003                                   | _ => Error.bug "Backend.genBlock: CReturn"
1004                            in
1005                               (M.Kind.CReturn {dst = dst,
1006                                                frameInfo = frameInfo label,
1007                                                func = func},
1008                                liveNoFormals,
1009                                Vector.new0 ())
1010                            end
1011                       | R.Kind.Handler =>
1012                            let
1013                               val _ =
1014                                  List.push
1015                                  (handlers, {chunkLabel = Chunk.label chunk,
1016                                              label = label})
1017                               val dsts = Vector.map (args, varOperand o #1)
1018                               val handles =
1019                                  raiseOperands (Vector.map (dsts, M.Operand.ty))
1020                            in
1021                               (M.Kind.Handler
1022                                {frameInfo = valOf (frameInfo label),
1023                                 handles = handles},
1024                                liveNoFormals,
1025                                M.Statement.moves
1026                                {dsts = dsts,
1027                                 srcs = Vector.map (handles, Live.toOperand)})
1028                            end
1029                       | R.Kind.Jump => (M.Kind.Jump, live, Vector.new0 ())
1030                   val (first, statements) =
1031                      if !Control.profile = Control.ProfileTimeLabel
1032                         then
1033                            case (if Vector.isEmpty statements
1034                                     then NONE
1035                                  else (case Vector.first statements of
1036                                           s as M.Statement.ProfileLabel _ =>
1037                                              SOME s
1038                                         | _ => NONE)) of
1039                               NONE =>
1040                                  Error.bug
1041                                  (concat ["Backend.genBlock: ",
1042                                           "missing ProfileLabel in ",
1043                                           Label.toString label])
1044                             | SOME s =>
1045                                  (Vector.new1 s,
1046                                   Vector.dropPrefix (statements, 1))
1047                      else (Vector.new0 (), statements)
1048                   val statements =
1049                      Vector.concat [first, pre, statements, preTransfer]
1050                   val returns =
1051                      Option.map (returns, fn returns =>
1052                                  Vector.map (returns, Live.StackOffset))
1053                in
1054                   Chunk.newBlock (chunk,
1055                                   {kind = kind,
1056                                    label = label,
1057                                    live = operandsLive live,
1058                                    raises = raises,
1059                                    returns = returns,
1060                                    statements = statements,
1061                                    transfer = transfer})
1062                end
1063             val genBlock = traceGenBlock genBlock
1064             val _ = Vector.foreach (blocks, genBlock)
1065             val _ =
1066                if isMain
1067                   then ()
1068                else Vector.foreach (blocks, R.Block.clear)
1069          in
1070             ()
1071          end
1072       val genFunc =
1073          Trace.trace2 ("Backend.genFunc",
1074                        Func.layout o Function.name, Bool.layout, Unit.layout)
1075          genFunc
1076       (* Generate the main function first.
1077        * Need to do this in order to set globals.
1078        *)
1079       val _ = genFunc (main, true)
1080       val _ = List.foreach (functions, fn f => genFunc (f, false))
1081       val chunks = !chunks
1082       fun chunkToMachine (Chunk.T {chunkLabel, blocks}) =
1083          let
1084             val blocks = Vector.fromList (!blocks)
1085             val regMax = CType.memo (fn _ => ref ~1)
1086             val regsNeedingIndex =
1087                Vector.fold
1088                (blocks, [], fn (b, ac) =>
1089                 M.Block.foldDefs
1090                 (b, ac, fn (z, ac) =>
1091                  case z of
1092                     M.Operand.Register r =>
1093                        (case Register.indexOpt r of
1094                            NONE => r :: ac
1095                          | SOME i =>
1096                               let
1097                                  val z = regMax (Type.toCType (Register.ty r))
1098                                  val _ =
1099                                     if i > !z
1100                                        then z := i
1101                                     else ()
1102                               in
1103                                  ac
1104                               end)
1105                   | _ => ac))
1106             val _ =
1107                List.foreach
1108                (regsNeedingIndex, fn r =>
1109                 let
1110                    val z = regMax (Type.toCType (Register.ty r))
1111                    val i = 1 + !z
1112                    val _ = z := i
1113                    val _ = Register.setIndex (r, i)
1114                 in
1115                    ()
1116                 end)
1117          in
1118             Machine.Chunk.T {chunkLabel = chunkLabel,
1119                              blocks = blocks,
1120                              regMax = ! o regMax}
1121          end
1122       val mainName = R.Function.name main
1123       val main = {chunkLabel = Chunk.label (funcChunk mainName),
1124                   label = funcToLabel mainName}
1125       val chunks = List.revMap (chunks, chunkToMachine)
1126       (* The clear is necessary because properties have been attached to Funcs
1127        * and Labels, and they appear as labels in the resulting program.
1128        *)
1129       val _ = List.foreach (chunks, fn M.Chunk.T {blocks, ...} =>
1130                             Vector.foreach (blocks, Label.clear o M.Block.label))
1131       val (frameLabels, frameLayouts, frameOffsets) = allFrameInfo ()
1132       val maxFrameSize: Bytes.t =
1133          List.fold
1134          (chunks, Bytes.zero, fn (M.Chunk.T {blocks, ...}, max) =>
1135           Vector.fold
1136           (blocks, max, fn (M.Block.T {kind, statements, transfer, ...}, max) =>
1137            let
1138               fun doOperand (z: M.Operand.t, max: Bytes.t): Bytes.t =
1139                  let
1140                     datatype z = datatype M.Operand.t
1141                  in
1142                     case z of
1143                        ArrayOffset {base, index, ...} =>
1144                           doOperand (base, doOperand (index, max))
1145                      | Cast (z, _) => doOperand (z, max)
1146                      | Contents {oper, ...} => doOperand (oper, max)
1147                      | Offset {base, ...} => doOperand (base, max)
1148                      | StackOffset (StackOffset.T {offset, ty}) =>
1149                           Bytes.max (Bytes.+ (offset, Type.bytes ty), max)
1150                      | _ => max
1151                  end
1152               val max =
1153                  case M.Kind.frameInfoOpt kind of
1154                     NONE => max
1155                   | SOME (M.FrameInfo.T {frameLayoutsIndex, ...}) =>
1156                        Bytes.max
1157                        (max,
1158                         #size (Vector.sub (frameLayouts, frameLayoutsIndex)))
1159               val max =
1160                  Vector.fold
1161                  (statements, max, fn (s, max) =>
1162                   M.Statement.foldOperands (s, max, doOperand))
1163               val max =
1164                  M.Transfer.foldOperands (transfer, max, doOperand)
1165            in
1166               max
1167            end))
1168       val maxFrameSize = Bytes.alignWord32 maxFrameSize
1169       val profileInfo = makeProfileInfo {frames = frameLabels}
1170       val program =
1171          Machine.Program.T
1172          {chunks = chunks,
1173           frameLayouts = frameLayouts,
1174           frameOffsets = frameOffsets,
1175           handlesSignals = handlesSignals,
1176           main = main,
1177           maxFrameSize = maxFrameSize,
1178           objectTypes = objectTypes,
1179           profileInfo = profileInfo,
1180           reals = allReals (),
1181           vectors = allVectors ()}
1182
1183       local
1184          open Machine
1185          fun pass' ({name, doit}, sel, p) =
1186             let
1187                val _ =
1188                   let open Control
1189                   in maybeSaveToFile
1190                      ({name = name,
1191                        suffix = "pre.machine"},
1192                       Control.No, p, Control.Layouts Program.layouts)
1193                   end
1194                val p =
1195                   Control.passTypeCheck
1196                   {display = Control.Layouts
1197                              (fn (r,output) =>
1198                               Program.layouts (sel r, output)),
1199                    name = name,
1200                    stats = fn _ => Layout.empty,
1201                    style = Control.No,
1202                    suffix = "post.machine",
1203                    thunk = fn () => doit p,
1204                    typeCheck = Program.typeCheck o sel}
1205             in
1206                p
1207             end
1208          fun pass ({name, doit}, p) =
1209             pass' ({name = name, doit = doit}, fn p => p, p)
1210          fun maybePass ({name, doit, execute}, p) =
1211             if List.foldr (!Control.executePasses, execute, fn ((re, new), old) =>
1212                if Regexp.Compiled.matchesAll (re, name)
1213                   then new
1214                   else old)
1215                then pass ({name = name, doit = doit}, p)
1216                else (Control.messageStr (Control.Pass, name ^ " skipped"); p)
1217
1218          fun shuffle p =
1219             let
1220                fun shuffle v =
1221                   let
1222                      val a = Array.fromVector v
1223                      val () = Array.shuffle a
1224                   in
1225                      Array.toVector a
1226                   end
1227                val Machine.Program.T
1228                   {chunks, frameLayouts, frameOffsets,
1229                    handlesSignals, main, maxFrameSize,
1230                    objectTypes, profileInfo,
1231                    reals, vectors} = p
1232                val chunks = Vector.fromList chunks
1233                val chunks = shuffle chunks
1234                val chunks =
1235                   Vector.map
1236                   (chunks, fn Machine.Chunk.T {blocks, chunkLabel, regMax} =>
1237                    Machine.Chunk.T
1238                    {blocks = shuffle blocks,
1239                     chunkLabel = chunkLabel,
1240                     regMax = regMax})
1241                val chunks = Vector.toList chunks
1242             in
1243                Machine.Program.T
1244                {chunks = chunks,
1245                 frameLayouts = frameLayouts,
1246                 frameOffsets = frameOffsets,
1247                 handlesSignals = handlesSignals,
1248                 main = main,
1249                 maxFrameSize = maxFrameSize,
1250                 objectTypes = objectTypes,
1251                 profileInfo = profileInfo,
1252                 reals = reals,
1253                 vectors = vectors}
1254             end
1255       in
1256          val program = maybePass ({name = "machineShuffle",
1257                                    doit = shuffle,
1258                                    execute = false}, program)
1259       end
1260 in
1261    program
1262 end}
1263    in
1264       program
1265    end
1266 end