mlton/codegen/amd64-codegen/amd64-translate.fun

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