mlton/codegen/x86-codegen/x86-translate.fun

   1 (* Copyright (C) 2009 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 x86Translate(S: X86_TRANSLATE_STRUCTS): X86_TRANSLATE =
  11 struct
  12
  13   open S
  14
  15   val tracerTop = x86.tracerTop
  16
  17   fun argsToString(ss: string list): string
  18     = "(" ^ (concat (List.separate(ss, ", "))) ^ ")"
  19
  20   structure Machine = x86MLton.Machine
  21
  22   local
  23      open Machine
  24   in
  25      structure Label = Label
  26      structure Live = Live
  27      structure Register = Register
  28      structure Scale = Scale
  29      structure StackOffset = StackOffset
  30      structure Type = Type
  31      structure WordSize = WordSize
  32      structure WordX = WordX
  33   end
  34
  35   datatype z = datatype WordSize.prim
  36
  37   structure Global =
  38      struct
  39         open Machine.Global
  40
  41         fun toX86Operand (g: t) : (x86.Operand.t * x86.Size.t) vector =
  42            let
  43               val ty = Machine.Type.toCType (ty g)
  44               val index = index g
  45               val base =
  46                  x86.Immediate.label
  47                  (if isRoot g
  48                      then x86MLton.global_base ty
  49                   else x86MLton.globalObjptrNonRoot_base)
  50               val origin =
  51                  x86.MemLoc.imm
  52                  {base = base,
  53                   index = x86.Immediate.int index,
  54                   scale = x86.Scale.fromCType ty,
  55                   size = x86.Size.BYTE,
  56                   class = x86MLton.Classes.Globals}
  57               val sizes = x86.Size.fromCType ty
  58            in
  59               (#1 o Vector.mapAndFold)
  60               (sizes, 0, fn (size,offset) =>
  61                (((x86.Operand.memloc o x86.MemLoc.shift)
  62                  {origin = origin,
  63                   disp = x86.Immediate.int offset,
  64                   scale = x86.Scale.One,
  65                   size = size}, size), offset + x86.Size.toBytes size))
  66            end
  67      end
  68
  69   structure Operand =
  70     struct
  71       open Machine.Operand
  72
  73       fun get (f: ('a * 'b) -> 'c) (i: int) (v: ('a * 'b) vector) =
  74          f (Vector.sub (v, i))
  75       fun getOp0 v =
  76          get #1 0 v
  77
  78       val rec toX86Operand : t -> (x86.Operand.t * x86.Size.t) vector =
  79          fn ArrayOffset {base, index, offset, scale, ty}
  80             => let
  81                   val base = toX86Operand base
  82                   val _ = Assert.assert("x86Translate.Operand.toX86Operand: Array/base",
  83                                         fn () => Vector.length base = 1)
  84                   val base = getOp0 base
  85                   val index = toX86Operand index
  86                   val _ = Assert.assert("x86Translate.Operand.toX86Operand: Array/index",
  87                                        fn () => Vector.length index = 1)
  88                   val index = getOp0 index
  89                   val scale =
  90                      case scale of
  91                         Scale.One => x86.Scale.One
  92                       | Scale.Two => x86.Scale.Two
  93                       | Scale.Four => x86.Scale.Four
  94                       | Scale.Eight => x86.Scale.Eight
  95                   val ty = Type.toCType ty
  96                   val origin =
  97                      case (x86.Operand.deMemloc base,
  98                            x86.Operand.deImmediate index,
  99                            x86.Operand.deMemloc index) of
 100                         (SOME base, SOME index, _) =>
 101                            x86.MemLoc.simple
 102                            {base = base,
 103                             index = index,
 104                             scale = scale,
 105                             size = x86.Size.BYTE,
 106                             class = x86MLton.Classes.Heap}
 107                       | (SOME base, _, SOME index) =>
 108                            x86.MemLoc.complex
 109                            {base = base,
 110                             index = index,
 111                             scale = scale,
 112                             size = x86.Size.BYTE,
 113                             class = x86MLton.Classes.Heap}
 114                       | _ => Error.bug (concat ["x86Translate.Operand.toX86Operand: ",
 115                                                 "strange Offset: base: ",
 116                                                 x86.Operand.toString base,
 117                                                 " index: ",
 118                                                 x86.Operand.toString index])
 119                   val origin =
 120                      if Bytes.isZero offset
 121                         then origin
 122                         else x86.MemLoc.shift
 123                              {origin = origin,
 124                               disp = x86.Immediate.int (Bytes.toInt offset),
 125                               scale = x86.Scale.One,
 126                               size = x86.Size.BYTE}
 127                   val sizes = x86.Size.fromCType ty
 128                in
 129                   (#1 o Vector.mapAndFold)
 130                   (sizes, 0, fn (size,offset) =>
 131                    (((x86.Operand.memloc o x86.MemLoc.shift)
 132                      {origin = origin,
 133                       disp = x86.Immediate.int offset,
 134                       scale = x86.Scale.One,
 135                       size = size}, size), offset + x86.Size.toBytes size))
 136                end
 137           | Cast (z, _) => toX86Operand z
 138           | Contents {oper, ty} =>
 139                let
 140                   val ty = Type.toCType ty
 141                   val base = toX86Operand oper
 142                   val _ = Assert.assert("x86Translate.Operand.toX86Operand: Contents/base",
 143                                         fn () => Vector.length base = 1)
 144                   val base = getOp0 base
 145                   val origin =
 146                      case x86.Operand.deMemloc base of
 147                         SOME base =>
 148                            x86.MemLoc.simple
 149                            {base = base,
 150                             index = x86.Immediate.zero,
 151                             scale = x86.Scale.One,
 152                             size = x86.Size.BYTE,
 153                             class = x86MLton.Classes.Heap}
 154                       | _ => Error.bug (concat
 155                                         ["x86Translate.Operand.toX86Operand: ",
 156                                          "strange Contents: base: ",
 157                                          x86.Operand.toString base])
 158                   val sizes = x86.Size.fromCType ty
 159                in
 160                   (#1 o Vector.mapAndFold)
 161                   (sizes, 0, fn (size,offset) =>
 162                    (((x86.Operand.memloc o x86.MemLoc.shift)
 163                      {origin = origin,
 164                       disp = x86.Immediate.int offset,
 165                       scale = x86.Scale.One,
 166                       size = size}, size), offset + x86.Size.toBytes size))
 167                end
 168           | Frontier =>
 169                let
 170                   val frontier = x86MLton.gcState_frontierContentsOperand ()
 171                in
 172                   Vector.new1 (frontier, valOf (x86.Operand.size frontier))
 173                end
 174           | GCState =>
 175                Vector.new1 (x86.Operand.immediate_label x86MLton.gcState_label,
 176                             x86MLton.pointerSize)
 177           | Global g => Global.toX86Operand g
 178           | Label l =>
 179                Vector.new1 (x86.Operand.immediate_label l, x86MLton.pointerSize)
 180           | Null =>
 181                Vector.new1 (x86.Operand.immediate_zero, x86MLton.wordSize)
 182           | Offset {base = GCState, offset, ty} =>
 183                let
 184                   val offset = Bytes.toInt offset
 185                   val ty = Type.toCType ty
 186                   val offset = x86MLton.gcState_offset {offset = offset, ty = ty}
 187                in
 188                   Vector.new1 (offset, valOf (x86.Operand.size offset))
 189                end
 190           | Offset {base, offset, ty} =>
 191                let
 192                   val offset = Bytes.toInt offset
 193                  val ty = Type.toCType ty
 194                  val base = toX86Operand base
 195                  val _ = Assert.assert("x86Translate.Operand.toX86Operand: Offset/base",
 196                                        fn () => Vector.length base = 1)
 197                  val base = getOp0 base
 198                  val origin =
 199                    case x86.Operand.deMemloc base of
 200                      SOME base =>
 201                        x86.MemLoc.simple
 202                        {base = base,
 203                         index = x86.Immediate.int offset,
 204                         scale = x86.Scale.One,
 205                         size = x86.Size.BYTE,
 206                         class = x86MLton.Classes.Heap}
 207                    | _ => Error.bug (concat ["x86Translate.Operand.toX86Operand: ",
 208                                              "strange Offset: base: ",
 209                                              x86.Operand.toString base])
 210                   val sizes = x86.Size.fromCType ty
 211                in
 212                   (#1 o Vector.mapAndFold)
 213                   (sizes, 0, fn (size,offset) =>
 214                    (((x86.Operand.memloc o x86.MemLoc.shift)
 215                      {origin = origin,
 216                       disp = x86.Immediate.int offset,
 217                       scale = x86.Scale.One,
 218                       size = size}, size), offset + x86.Size.toBytes size))
 219                end
 220           | Real _ => Error.bug "x86Translate.Operand.toX86Operand: Real unimplemented"
 221           | Register r =>
 222                let
 223                   val ty = Machine.Type.toCType (Register.ty r)
 224                   val index = Machine.Register.index r
 225                   val base = x86.Immediate.label (x86MLton.local_base ty)
 226                   val origin =
 227                      x86.MemLoc.imm
 228                      {base = base,
 229                       index = x86.Immediate.int index,
 230                       scale = x86.Scale.fromCType ty,
 231                       size = x86.Size.BYTE,
 232                       class = x86MLton.Classes.Locals}
 233                   val sizes = x86.Size.fromCType ty
 234                in
 235                   (#1 o Vector.mapAndFold)
 236                   (sizes, 0, fn (size,offset) =>
 237                    (((x86.Operand.memloc o x86.MemLoc.shift)
 238                      {origin = origin,
 239                       disp = x86.Immediate.int offset,
 240                       scale = x86.Scale.One,
 241                       size = size}, size), offset + x86.Size.toBytes size))
 242                end
 243           | StackOffset (StackOffset.T {offset, ty}) =>
 244                let
 245                   val offset = Bytes.toInt offset
 246                   val ty = Type.toCType ty
 247                   val origin =
 248                      x86.MemLoc.simple
 249                      {base = x86MLton.gcState_stackTopContents (),
 250                       index = x86.Immediate.int offset,
 251                       scale = x86.Scale.One,
 252                       size = x86.Size.BYTE,
 253                       class = x86MLton.Classes.Stack}
 254                   val sizes = x86.Size.fromCType ty
 255                in
 256                   (#1 o Vector.mapAndFold)
 257                   (sizes, 0, fn (size,offset) =>
 258                    (((x86.Operand.memloc o x86.MemLoc.shift)
 259                      {origin = origin,
 260                       disp = x86.Immediate.int offset,
 261                       scale = x86.Scale.One,
 262                       size = size}, size), offset + x86.Size.toBytes size))
 263                end
 264           | StackTop =>
 265                let
 266                   val stackTop = x86MLton.gcState_stackTopContentsOperand ()
 267                in
 268                   Vector.new1 (stackTop, valOf (x86.Operand.size stackTop))
 269                end
 270           | Word w =>
 271                let
 272                   fun single size =
 273                      Vector.new1 (x86.Operand.immediate_word w, size)
 274                in
 275                   case WordSize.prim (WordX.size w) of
 276                      W8 => single x86.Size.BYTE
 277                    | W16 => single x86.Size.WORD
 278                    | W32 => single x86.Size.LONG
 279                    | W64 =>
 280                         let
 281                            val lo = WordX.resize (w, WordSize.word32)
 282                            val w = WordX.rshift (w,
 283                                                  WordX.fromIntInf (32, WordSize.word64),
 284                                                  {signed = true})
 285                            val hi = WordX.resize (w, WordSize.word32)
 286                         in
 287                            Vector.new2
 288                            ((x86.Operand.immediate_word lo, x86.Size.LONG),
 289                             (x86.Operand.immediate_word hi, x86.Size.LONG))
 290                         end
 291                end
 292     end
 293
 294   type transInfo = x86MLton.transInfo
 295
 296   structure Entry =
 297     struct
 298       structure Kind = Machine.Kind
 299
 300       fun toX86Blocks {label, kind,
 301                        transInfo as {frameInfoToX86, live, liveInfo,
 302                                      ...}: transInfo}
 303         = (
 304            x86Liveness.LiveInfo.setLiveOperands
 305            (liveInfo, label, live label);
 306            case kind
 307              of Kind.Jump
 308               => let
 309                  in
 310                    AppendList.single
 311                    (x86.Block.mkBlock'
 312                     {entry = SOME (x86.Entry.jump {label = label}),
 313                      statements = [],
 314                      transfer = NONE})
 315                  end
 316               | Kind.Func
 317               => let
 318                    val args
 319                      = List.fold
 320                        (live label,
 321                         x86.MemLocSet.empty,
 322                         fn (operand, args)
 323                          => case x86.Operand.deMemloc operand
 324                               of SOME memloc => x86.MemLocSet.add(args, memloc)
 325                                | NONE => args)
 326                  in
 327                    AppendList.single
 328                    (x86.Block.mkBlock'
 329                     {entry = SOME (x86.Entry.func {label = label,
 330                                                    live = args}),
 331                      statements = [],
 332                      transfer = NONE})
 333                  end
 334               | Kind.Cont {args, frameInfo, ...}
 335               => let
 336                     val frameInfo = frameInfoToX86 frameInfo
 337                     val args =
 338                        Vector.fold
 339                        (args, x86.MemLocSet.empty,
 340                         fn (operand,args) =>
 341                         Vector.fold
 342                         (Operand.toX86Operand (Live.toOperand operand), args,
 343                          fn ((operand,_),args) =>
 344                          case x86.Operand.deMemloc operand of
 345                             SOME memloc => x86.MemLocSet.add(args, memloc)
 346                           | NONE => args))
 347                  in
 348                    AppendList.single
 349                    (x86.Block.mkBlock'
 350                     {entry = SOME (x86.Entry.cont {label = label,
 351                                                    live = args,
 352                                                    frameInfo = frameInfo}),
 353                      statements = [],
 354                      transfer = NONE})
 355                  end
 356               | Kind.Handler {frameInfo, ...}
 357               => let
 358                  in
 359                    AppendList.single
 360                    (x86.Block.mkBlock'
 361                     {entry = SOME (x86.Entry.handler
 362                                    {frameInfo = frameInfoToX86 frameInfo,
 363                                     label = label,
 364                                     live = x86.MemLocSet.empty}),
 365                      statements = [],
 366                      transfer = NONE})
 367                  end
 368               | Kind.CReturn {dst, frameInfo, func}
 369               => let
 370                    val dsts =
 371                       case dst of
 372                          NONE => Vector.new0 ()
 373                        | SOME dst => Operand.toX86Operand (Live.toOperand dst)
 374                  in
 375                    x86MLton.creturn
 376                    {dsts = dsts,
 377                     frameInfo = Option.map (frameInfo, frameInfoToX86),
 378                     func = func,
 379                     label = label,
 380                     transInfo = transInfo}
 381                  end)
 382     end
 383
 384   structure Statement =
 385     struct
 386       open Machine.Statement
 387
 388       fun comments statement
 389         = if !Control.Native.commented > 0
 390             then let
 391                    val comment = (Layout.toString o layout) statement
 392                  in
 393                    (AppendList.single
 394                     (x86.Block.mkBlock'
 395                      {entry = NONE,
 396                       statements = [x86.Assembly.comment
 397                                     (concat ["begin: ",
 398                                              comment])],
 399                       transfer = NONE}),
 400                     AppendList.single
 401                     (x86.Block.mkBlock'
 402                      {entry = NONE,
 403                       statements = [x86.Assembly.comment
 404                                     (concat ["end: ",
 405                                              comment])],
 406                       transfer = NONE}))
 407                  end
 408             else (AppendList.empty,AppendList.empty)
 409
 410       fun toX86Blocks {statement,
 411                        transInfo as {...} : transInfo}
 412         = (case statement
 413              of Noop
 414               => AppendList.empty
 415               | Move {src, dst}
 416               => let
 417                    val (comment_begin,
 418                         comment_end) = comments statement
 419
 420                    val dsts = Operand.toX86Operand dst
 421                    val srcs = Operand.toX86Operand src
 422                    (* Operand.toX86Operand returns multi-word
 423                     * operands in and they will be moved in order,
 424                     * so it suffices to check for aliasing between
 425                     * the first dst and second src.
 426                     *)
 427                    val (dsts,srcs) =
 428                       if Vector.length srcs > 1
 429                          andalso x86.Operand.mayAlias
 430                                  (#1 (Vector.sub (dsts, 0)),
 431                                   #1 (Vector.sub (srcs, 1)))
 432                          then (Vector.rev dsts, Vector.rev srcs)
 433                          else (dsts,srcs)
 434                  in
 435                    AppendList.appends
 436                    [comment_begin,
 437                     AppendList.single
 438                     (x86.Block.mkBlock'
 439                      {entry = NONE,
 440                       statements
 441                       = (Vector.toList o Vector.map2)
 442                         (dsts,srcs,fn ((dst,_),(src,srcsize)) =>
 443                          (* dst = src *)
 444                          case x86.Size.class srcsize
 445                             of x86.Size.INT => x86.Assembly.instruction_mov
 446                                                {dst = dst,
 447                                                 src = src,
 448                                                 size = srcsize}
 449                           | x86.Size.FLT => x86.Assembly.instruction_pfmov
 450                                             {dst = dst,
 451                                              src = src,
 452                                              size = srcsize}
 453                           | _ => Error.bug "x86Translate.Statement.toX86Blocks: Move"),
 454                       transfer = NONE}),
 455                     comment_end]
 456                  end
 457               | PrimApp {dst, prim, args}
 458               => let
 459                    val (comment_begin, comment_end) = comments statement
 460                    val args = (Vector.concatV o Vector.map)
 461                               (args, Operand.toX86Operand)
 462                    val dsts =
 463                       case dst of
 464                          NONE => Vector.new0 ()
 465                        | SOME dst => Operand.toX86Operand dst
 466                  in
 467                    AppendList.appends
 468                    [comment_begin,
 469                     (x86MLton.prim {prim = prim,
 470                                     args = args,
 471                                     dsts = dsts,
 472                                     transInfo = transInfo}),
 473                     comment_end]
 474                  end
 475               | ProfileLabel l =>
 476                    AppendList.single
 477                    (x86.Block.mkProfileBlock'
 478                     {profileLabel = l}))
 479     end
 480
 481   structure Transfer =
 482     struct
 483       open Machine.Transfer
 484
 485       fun goto l
 486         = AppendList.single
 487           (x86.Block.mkBlock'
 488            {entry = NONE,
 489             statements = [],
 490             transfer = SOME (x86.Transfer.goto
 491                              {target = l})})
 492
 493       fun iff (test, a, b)
 494         = let
 495             val (test,testsize) =
 496                Vector.sub (Operand.toX86Operand test, 0)
 497           in
 498             if Label.equals(a, b)
 499               then AppendList.single
 500                    (x86.Block.mkBlock'
 501                     {entry = NONE,
 502                      statements = [],
 503                      transfer = SOME (x86.Transfer.goto {target = a})})
 504               else AppendList.single
 505                    ((* if (test) goto a
 506                      * goto b
 507                      *)
 508                     x86.Block.mkBlock'
 509                     {entry = NONE,
 510                      statements
 511                      = [x86.Assembly.instruction_test
 512                         {src1 = test,
 513                          src2 = test,
 514                          size = testsize}],
 515                      transfer
 516                      = SOME (x86.Transfer.iff
 517                              {condition = x86.Instruction.NZ,
 518                               truee = a,
 519                               falsee = b})})
 520           end
 521
 522       fun cmp (test, k, a, b)
 523         = let
 524             val (test,testsize) =
 525                Vector.sub (Operand.toX86Operand test, 0)
 526           in
 527             if Label.equals(a, b)
 528               then AppendList.single
 529                    (x86.Block.mkBlock'
 530                     {entry = NONE,
 531                      statements = [],
 532                      transfer = SOME (x86.Transfer.goto {target = a})})
 533               else AppendList.single
 534                    ((* if (test = k) goto a
 535                      * goto b
 536                      *)
 537                     x86.Block.mkBlock'
 538                     {entry = NONE,
 539                      statements
 540                      = [x86.Assembly.instruction_cmp
 541                         {src1 = test,
 542                          src2 = x86.Operand.immediate k,
 543                          size = testsize}],
 544                      transfer
 545                      = SOME (x86.Transfer.iff
 546                              {condition = x86.Instruction.E,
 547                               truee = a,
 548                               falsee = b})})
 549           end
 550
 551       fun switch(test, cases, default)
 552         = let
 553             val test = Operand.toX86Operand test
 554             val (test,_) = Vector.sub(test, 0)
 555           in
 556             AppendList.single
 557             (x86.Block.mkBlock'
 558              {entry = NONE,
 559               statements = [],
 560               transfer = SOME (x86.Transfer.switch
 561                                {test = test,
 562                                 cases = cases,
 563                                 default = default})})
 564           end
 565
 566       fun doSwitchWord (test, cases, default)
 567         = (case (cases, default)
 568              of ([],            NONE)
 569               => Error.bug "x86Translate.Transfer.doSwitchWord"
 570               | ([(_,l)],       NONE) => goto l
 571               | ([],            SOME l) => goto l
 572               | ([(w1,l1),(w2,l2)], NONE) =>
 573                 if WordX.isZero w1 andalso WordX.isOne w2
 574                    then iff(test,l2,l1)
 575                 else if WordX.isZero w2 andalso WordX.isOne w1
 576                    then iff(test,l1,l2)
 577                 else cmp(test,x86.Immediate.word w1,l1,l2)
 578               | ([(k',l')],      SOME l)
 579               => cmp(test,x86.Immediate.word k',l',l)
 580               | ((_,l)::cases,  NONE)
 581               => switch(test, x86.Transfer.Cases.word cases, l)
 582               | (cases,         SOME l)
 583               => switch(test, x86.Transfer.Cases.word cases, l))
 584
 585       fun comments transfer
 586         = if !Control.Native.commented > 0
 587             then let
 588                    val comment = (Layout.toString o layout) transfer
 589                  in
 590                    AppendList.single
 591                    (x86.Block.mkBlock'
 592                     {entry = NONE,
 593                      statements = [x86.Assembly.comment comment],
 594                       transfer = NONE})
 595                  end
 596             else AppendList.empty
 597
 598
 599       fun toX86Blocks {returns, transfer,
 600                        transInfo as {frameInfoToX86, ...}: transInfo}
 601         = (case transfer
 602              of Arith {prim, args, dst, overflow, success, ...}
 603               => let
 604                    val args = (Vector.concatV o Vector.map)
 605                               (args, Operand.toX86Operand)
 606                    val dsts = Operand.toX86Operand dst
 607                  in
 608                    AppendList.append
 609                    (comments transfer,
 610                     x86MLton.arith {prim = prim,
 611                                     args = args,
 612                                     dsts = dsts,
 613                                     overflow = overflow,
 614                                     success = success,
 615                                     transInfo = transInfo})
 616                  end
 617               | CCall {args, frameInfo, func, return}
 618               => let
 619                    val args = (Vector.concatV o Vector.map)
 620                               (args, Operand.toX86Operand)
 621                  in
 622                    AppendList.append
 623                    (comments transfer,
 624                     x86MLton.ccall {args = args,
 625                                     frameInfo = (Option.map
 626                                                  (frameInfo, frameInfoToX86)),
 627                                     func = func,
 628                                     return = return,
 629                                     transInfo = transInfo})
 630                  end
 631               | Return
 632               => AppendList.append
 633                  (comments transfer,
 634                   AppendList.single
 635                   (x86.Block.mkBlock'
 636                    {entry = NONE,
 637                     statements = [],
 638                     transfer
 639                     = SOME (x86.Transfer.return
 640                             {live
 641                              = Vector.fold
 642                                ((case returns of
 643                                     NONE => Error.bug "x86Translate.Transfer.toX86Blocsk: Return"
 644                                   | SOME zs => zs),
 645                                 x86.MemLocSet.empty,
 646                                 fn (operand, live) =>
 647                                 Vector.fold
 648                                 (Operand.toX86Operand operand, live,
 649                                  fn ((operand,_),live) =>
 650                                  case x86.Operand.deMemloc operand of
 651                                     SOME memloc => x86.MemLocSet.add(live, memloc)
 652                                   | NONE => live))})}))
 653               | Raise
 654               => AppendList.append
 655                  (comments transfer,
 656                   AppendList.single
 657                   (x86.Block.mkBlock'
 658                    {entry = NONE,
 659                     statements = [],
 660                     transfer
 661                     = SOME (x86.Transfer.raisee
 662                             {live
 663                              = x86.MemLocSet.add
 664                                (x86.MemLocSet.add
 665                                 (x86.MemLocSet.empty,
 666                                  x86MLton.gcState_stackBottomContents ()),
 667                                 x86MLton.gcState_exnStackContents ())})}))
 668               | Switch (Machine.Switch.T {cases, default, test, ...})
 669               => AppendList.append
 670                  (comments transfer,
 671                   doSwitchWord (test, Vector.toList cases, default))
 672               | Goto label
 673               => (AppendList.append
 674                   (comments transfer,
 675                    AppendList.single
 676                    ((* goto label *)
 677                     x86.Block.mkBlock'
 678                     {entry = NONE,
 679                      statements = [],
 680                      transfer = SOME (x86.Transfer.goto {target = label})})))
 681               | Call {label, live, return, ...}
 682               => let
 683                     val live =
 684                        Vector.fold
 685                        (live, x86.MemLocSet.empty, fn (operand, live) =>
 686                         Vector.fold
 687                         (Operand.toX86Operand (Live.toOperand operand), live,
 688                          fn ((operand, _), live) =>
 689                          case x86.Operand.deMemloc operand of
 690                             NONE => live
 691                           | SOME memloc => x86.MemLocSet.add (live, memloc)))
 692                     val com = comments transfer
 693                     val transfer =
 694                        case return of
 695                           NONE => x86.Transfer.tail {target = label,
 696                                                      live = live}
 697                         | SOME {return, handler, size} =>
 698                              x86.Transfer.nontail {target = label,
 699                                                    live = live,
 700                                                    return = return,
 701                                                    handler = handler,
 702                                                    size = Bytes.toInt size}
 703                  in
 704                     AppendList.append
 705                     (com,
 706                      AppendList.single
 707                      (x86.Block.mkBlock' {entry = NONE,
 708                                     statements = [],
 709                                     transfer = SOME transfer}))
 710                  end)
 711     end
 712
 713   structure Block =
 714     struct
 715       open Machine.Block
 716
 717       fun toX86Blocks {block = T {label,
 718                                   live,
 719                                   kind,
 720                                   returns,
 721                                   statements,
 722                                   transfer,
 723                                   ...},
 724                        transInfo as {...} : transInfo}
 725         = let
 726             val pseudo_blocks
 727               = AppendList.append
 728                 (AppendList.snoc
 729                  (Entry.toX86Blocks {label = label,
 730                                      kind = kind,
 731                                      transInfo = transInfo},
 732                   x86.Block.mkBlock'
 733                   {entry = NONE,
 734                    statements
 735                    = if !Control.Native.commented > 0
 736                        then let
 737                               val comment =
 738                                  concat ["Live: ",
 739                                          argsToString
 740                                          (Vector.toListMap
 741                                           (live, fn l =>
 742                                            Operand.toString (Live.toOperand l)))]
 743                             in
 744                               [x86.Assembly.comment comment]
 745                             end
 746                        else [],
 747                     transfer = NONE}),
 748                  Vector.foldr(statements,
 749                               (Transfer.toX86Blocks
 750                                {returns = (Option.map
 751                                            (returns, fn v =>
 752                                             Vector.map (v, Live.toOperand))),
 753                                 transfer = transfer,
 754                                 transInfo = transInfo}),
 755                               fn (statement,l)
 756                                => AppendList.append
 757                                   (Statement.toX86Blocks
 758                                    {statement = statement,
 759                                     transInfo = transInfo}, l)))
 760
 761             val pseudo_blocks = AppendList.toList pseudo_blocks
 762
 763             val blocks = x86.Block.compress pseudo_blocks
 764           in
 765             blocks
 766           end
 767     end
 768
 769   structure Chunk =
 770     struct
 771       open Machine.Chunk
 772
 773       fun toX86Chunk {chunk = T {blocks, ...},
 774                       frameInfoToX86,
 775                       liveInfo}
 776         = let
 777             val data = ref []
 778             val addData = fn l => List.push (data, l)
 779             val {get = live : Label.t -> x86.Operand.t list,
 780                  set = setLive,
 781                  rem = remLive, ...}
 782               = Property.getSetOnce
 783                 (Label.plist, Property.initRaise ("live", Label.layout))
 784             val _ = Vector.foreach
 785                     (blocks, fn Block.T {label, live, ...} =>
 786                      setLive (label,
 787                               (Vector.toList o #1 o Vector.unzip o
 788                                Vector.concatV o Vector.map)
 789                               (live, Operand.toX86Operand o Live.toOperand)))
 790             val transInfo = {addData = addData,
 791                              frameInfoToX86 = frameInfoToX86,
 792                              live = live,
 793                              liveInfo = liveInfo}
 794             val x86Blocks
 795               = List.concat (Vector.toListMap
 796                              (blocks,
 797                                 fn block
 798                                  => Block.toX86Blocks
 799                                     {block = block,
 800                                      transInfo = transInfo}))
 801             val _ = Vector.foreach (blocks, fn Block.T {label, ...} =>
 802                                     remLive label)
 803             val data = List.concatRev (!data)
 804             val data =
 805                if List.isEmpty data
 806                   then []
 807                   else (x86.Assembly.pseudoop_data())::data
 808           in
 809             x86.Chunk.T {data = data, blocks = x86Blocks}
 810           end
 811     end
 812
 813   fun translateChunk {chunk: x86MLton.Machine.Chunk.t,
 814                       frameInfoToX86,
 815                       liveInfo: x86Liveness.LiveInfo.t}:
 816                      {chunk: x86.Chunk.t}
 817     = {chunk = Chunk.toX86Chunk {chunk = chunk,
 818                                  frameInfoToX86 = frameInfoToX86,
 819                                  liveInfo = liveInfo}}
 820
 821   val (translateChunk, translateChunk_msg)
 822     = tracerTop
 823       "translateChunk"
 824       translateChunk
 825
 826   fun translateChunk_totals ()
 827     = (translateChunk_msg ();
 828        Control.indent ();
 829        Control.unindent ())
 830
 831 end