mlton/codegen/x86-codegen/x86.fun

   1 (* Copyright (C) 1999-2008 Henry Cejtin, Matthew Fluet, Suresh
   2  *    Jagannathan, and Stephen Weeks.
   3  * Copyright (C) 1997-2000 NEC Research Institute.
   4  *
   5  * MLton is released under a BSD-style license.
   6  * See the file MLton-LICENSE for details.
   7  *)
   8
   9 functor x86 (S: X86_STRUCTS): X86 =
  10 struct
  11
  12    val tracerTop
  13     = fn s => Control.traceBatch (Control.Pass, s)
  14 (*
  15     = fn s => fn f => (Control.trace (Control.Pass, s) f, fn () => ())
  16 *)
  17     val tracer
  18     = fn s => Control.traceBatch (Control.Detail, s)
  19 (*
  20     = fn s => fn f => (Control.trace (Control.Detail, s) f, fn () => ())
  21 *)
  22
  23   (* compensate for differences between
  24    *  C-escape sequences and ASM-escape sequences
  25    *)
  26   val Char_escapeASM = fn #"\000" => "\\000"
  27                         | #"\^G" => "\\007"
  28                         | #"\^K" => "\\013"
  29                         | #"?" => "?"
  30                         | #"'" => "'"
  31                         | c => Char.escapeC c
  32   fun String_escapeASM s = String.translate(s, Char_escapeASM)
  33
  34   val rec lexical
  35     = fn [] => EQUAL
  36        | thunk::tl => let
  37                         val ord = thunk ()
  38                       in
  39                         if Relation.equals(ord, EQUAL)
  40                           then lexical tl
  41                           else ord
  42                       end
  43
  44
  45   open S
  46
  47   structure Label =
  48      struct
  49         open Label
  50
  51         fun toString l =
  52            if !Control.labelsHaveExtra_
  53               then concat ["_", Label.toString l]
  54            else Label.toString l
  55
  56         val layout = Layout.str o toString
  57      end
  58
  59   structure Size =
  60     struct
  61       datatype class = INT | FLT | FPI
  62
  63       datatype t
  64         = BYTE | WORD | LONG
  65         | SNGL | DBLE | EXTD
  66         | FPIS | FPIL | FPIQ
  67
  68       val layout
  69         = let
  70             open Layout
  71           in
  72             fn BYTE => str "b"
  73              | WORD => str "w"
  74              | LONG => str "l"
  75              | SNGL => str "S"
  76              | DBLE => str "L"
  77              | EXTD => str "T"
  78              | FPIS => str "s"
  79              | FPIL => str "l"
  80              | FPIQ => str "q"
  81           end
  82       val toString = Layout.toString o layout
  83
  84       val fromBytes : int -> t
  85         = fn 1 => BYTE
  86            | 2 => WORD
  87            | 4 => LONG
  88            | _ => Error.bug "x86.Size.fromBytes"
  89       val toBytes : t -> int
  90         = fn BYTE => 1
  91            | WORD => 2
  92            | LONG => 4
  93            | SNGL => 4
  94            | DBLE => 8
  95            | EXTD => 10
  96            | FPIS => 2
  97            | FPIL => 4
  98            | FPIQ => 8
  99
 100       local
 101          datatype z = datatype CType.t
 102       in
 103          fun fromCType t =
 104             case t of
 105                CPointer => Vector.new1 LONG
 106              | Int8 => Vector.new1 BYTE
 107              | Int16 => Vector.new1 WORD
 108              | Int32 => Vector.new1 LONG
 109              | Int64 => Vector.new2 (LONG, LONG)
 110              | Objptr => Vector.new1 LONG
 111              | Real32 => Vector.new1 SNGL
 112              | Real64 => Vector.new1 DBLE
 113              | Word8 => Vector.new1 BYTE
 114              | Word16 => Vector.new1 WORD
 115              | Word32 => Vector.new1 LONG
 116              | Word64 => Vector.new2 (LONG, LONG)
 117       end
 118
 119       val class
 120         = fn BYTE => INT
 121            | WORD => INT
 122            | LONG => INT
 123            | SNGL => FLT
 124            | DBLE => FLT
 125            | EXTD => FLT
 126            | FPIS => FPI
 127            | FPIL => FPI
 128            | FPIQ => FPI
 129
 130       val toFPI
 131         = fn WORD => FPIS
 132            | LONG => FPIL
 133            | FPIS => FPIS
 134            | FPIL => FPIL
 135            | FPIQ => FPIQ
 136            | _ => Error.bug "x86.Size.toFPI"
 137
 138       val eq = fn (s1, s2) => s1 = s2
 139       val lt = fn (s1, s2) => (toBytes s1) < (toBytes s2)
 140     end
 141
 142   structure Register =
 143     struct
 144
 145       datatype reg
 146         = EAX | EBX | ECX | EDX | EDI | ESI | EBP | ESP
 147       val allReg = [EAX, EBX, ECX, EDX, EDI, ESI, EBP, ESP]
 148
 149       datatype part
 150         = E | X | L | H
 151
 152       datatype t = T of {reg: reg, part: part}
 153
 154       fun size (T {part, ...})
 155         = case part
 156             of E => Size.LONG
 157              | X => Size.WORD
 158              | L => Size.BYTE
 159              | H => Size.BYTE
 160
 161       fun layout (T {reg, part})
 162         = let
 163             open Layout
 164             val {prefix, suffix}
 165               = case part
 166                   of E => {prefix = str "%e", suffix = str "x"}
 167                    | X => {prefix = str "%", suffix = str "x"}
 168                    | L => {prefix = str "%", suffix = str "l"}
 169                    | H => {prefix = str "%", suffix = str "h"}
 170           in
 171             case reg
 172               of EAX => seq [prefix, str "a", suffix]
 173                | EBX => seq [prefix, str "b", suffix]
 174                | ECX => seq [prefix, str "c", suffix]
 175                | EDX => seq [prefix, str "d", suffix]
 176                | EDI => seq [prefix, str "di"]
 177                | ESI => seq [prefix, str "si"]
 178                | EBP => seq [prefix, str "bp"]
 179                | ESP => seq [prefix, str "sp"]
 180           end
 181       val toString = Layout.toString o layout
 182
 183       fun eq(T r1, T r2) = r1 = r2
 184
 185       val eax = T {reg = EAX, part = E}
 186       val ebx = T {reg = EBX, part = E}
 187       val ecx = T {reg = ECX, part = E}
 188       val edx = T {reg = EDX, part = E}
 189       val ax = T {reg= EAX, part = X}
 190       val al = T {reg = EAX, part = L}
 191       val bl = T {reg = EBX, part = L}
 192       val cl = T {reg = ECX, part = L}
 193       val dl = T {reg = EDX, part = L}
 194       val edi = T {reg = EDI, part = E}
 195       val esi = T {reg = ESI, part = E}
 196       val esp = T {reg = ESP, part = E}
 197       val ebp = T {reg = EBP, part = E}
 198
 199       val byteRegisters = [T {reg = EAX, part = L},
 200                            T {reg = EAX, part = H},
 201                            T {reg = EBX, part = L},
 202                            T {reg = EBX, part = H},
 203                            T {reg = ECX, part = L},
 204                            T {reg = ECX, part = H},
 205                            T {reg = EDX, part = L},
 206                            T {reg = EDX, part = H}]
 207       val byteRegisters = List.rev byteRegisters
 208
 209       val wordRegisters = [T {reg = EAX, part = X},
 210                            T {reg = EBX, part = X},
 211                            T {reg = ECX, part = X},
 212                            T {reg = EDX, part = X},
 213                            T {reg = EDI, part = X},
 214                            T {reg = ESI, part = X},
 215                            T {reg = EBP, part = X},
 216                            T {reg = ESP, part = X}]
 217       val wordRegisters = List.rev wordRegisters
 218
 219       val longRegisters = [T {reg = EAX, part = E},
 220                            T {reg = EBX, part = E},
 221                            T {reg = ECX, part = E},
 222                            T {reg = EDX, part = E},
 223                            T {reg = EDI, part = E},
 224                            T {reg = ESI, part = E},
 225                            T {reg = EBP, part = E},
 226                            T {reg = ESP, part = E}]
 227       val longRegisters = List.rev longRegisters
 228
 229       val all = List.concat [byteRegisters, wordRegisters, longRegisters]
 230
 231       fun valid r = List.contains(all, r, eq)
 232
 233       val contains
 234         = fn (E, E) => true | (E, X) => true | (E, L) => true | (E, H) => true
 235            | (X, X) => true | (X, L) => true | (X, H) => true
 236            | (L, L) => true
 237            | (H, H) => true
 238            | _      => false
 239
 240       fun coincide (T {reg = reg1, part = part1},
 241                     T {reg = reg2, part = part2})
 242         = reg1 = reg2 andalso (contains(part1,part2) orelse
 243                                contains(part2,part1))
 244
 245       fun coincident' reg
 246         = List.keepAllMap([E, X, L, H],
 247                           fn part
 248                            => let
 249                                 val register' = T {reg = reg, part = part}
 250                               in
 251                                 if valid register' andalso
 252                                    coincide(T {reg = reg, part = E}, register')
 253                                   then SOME register'
 254                                   else NONE
 255                               end)
 256
 257       val registers
 258         = fn Size.BYTE => byteRegisters
 259            | Size.WORD => wordRegisters
 260            | Size.LONG => longRegisters
 261            | _ => Error.bug "x86.Register.registers"
 262
 263       val baseRegisters = longRegisters
 264       val indexRegisters = [T {reg = EAX, part = E},
 265                             T {reg = EBX, part = E},
 266                             T {reg = ECX, part = E},
 267                             T {reg = EDX, part = E},
 268                             T {reg = EDI, part = E},
 269                             T {reg = ESI, part = E},
 270                             T {reg = EBP, part = E}]
 271
 272       val callerSaveRegisters = [T {reg = EAX, part = E},
 273                                  T {reg = EAX, part = X},
 274                                  T {reg = EAX, part = L},
 275                                  T {reg = EAX, part = H},
 276                                  T {reg = ECX, part = E},
 277                                  T {reg = ECX, part = X},
 278                                  T {reg = ECX, part = L},
 279                                  T {reg = ECX, part = H},
 280                                  T {reg = EDX, part = E},
 281                                  T {reg = EDX, part = X},
 282                                  T {reg = EDX, part = L},
 283                                  T {reg = EDX, part = H}]
 284       val calleeSaveRegisters = [T {reg = EBX, part = E},
 285                                  T {reg = EBX, part = X},
 286                                  T {reg = EBX, part = L},
 287                                  T {reg = EBX, part = H},
 288                                  T {reg = EDI, part = E},
 289                                  T {reg = EDI, part = X},
 290                                  T {reg = ESI, part = E},
 291                                  T {reg = ESI, part = X}]
 292
 293       val withLowPart (* (fullsize,lowsize) *)
 294         = fn (Size.WORD,Size.BYTE) => [T {reg = EAX, part = X},
 295                                        T {reg = EBX, part = X},
 296                                        T {reg = ECX, part = X},
 297                                        T {reg = EDX, part = X}]
 298            | (Size.LONG,Size.BYTE) => [T {reg = EAX, part = E},
 299                                        T {reg = EBX, part = E},
 300                                        T {reg = ECX, part = E},
 301                                        T {reg = EDX, part = E}]
 302            | (Size.LONG,Size.WORD) => longRegisters
 303            | _ => Error.bug "x86.Register.withLowPart: fullsize,lowsize"
 304
 305       val lowPartOf (* (register,lowsize) *)
 306         = fn (T {reg,       part = L},Size.BYTE) => T {reg = reg, part = L}
 307            | (T {reg,       part = H},Size.BYTE) => T {reg = reg, part = H}
 308            | (T {reg = EAX, ...},     Size.BYTE) => T {reg = EAX, part = L}
 309            | (T {reg = EBX, ...},     Size.BYTE) => T {reg = EBX, part = L}
 310            | (T {reg = ECX, ...},     Size.BYTE) => T {reg = ECX, part = L}
 311            | (T {reg = EDX, ...},     Size.BYTE) => T {reg = EDX, part = L}
 312            | (T {reg,       part = X},Size.WORD) => T {reg = reg, part = X}
 313            | (T {reg,       ...},     Size.WORD) => T {reg = reg, part = X}
 314            | _ => Error.bug "x86.Register.lowPartOf: register,lowsize"
 315     end
 316
 317   structure FltRegister =
 318     struct
 319       datatype t = T of int
 320
 321       fun layout (T i)
 322         = let
 323             open Layout
 324           in if i = 0
 325                then str "%st"
 326                else seq [str "%st", paren (Int.layout i)]
 327           end
 328       val toString = Layout.toString o layout
 329
 330       fun eq (T f1, T f2) = f1 = f2
 331
 332       fun push (T i) = T (i + 1)
 333       fun pop (T i) = T (i - 1)
 334       fun id (T i) = T i
 335
 336 (*
 337       val return = T 0
 338 *)
 339       val top = T 0
 340       val one = T 1
 341       val total = 8 : int
 342     end
 343
 344   structure Immediate =
 345     struct
 346       datatype u
 347         = Word of WordX.t
 348         | Label of Label.t
 349         | LabelPlusWord of Label.t * WordX.t
 350       and t
 351         = T of {immediate: u,
 352                 plist: PropertyList.t,
 353                 hash: Word.t}
 354
 355       local
 356         open Layout
 357       in
 358         val rec layoutU
 359           = fn Word w => WordX.layout w
 360              | Label l => Label.layout l
 361              | LabelPlusWord (l, w)
 362              => paren (seq [Label.layout l, str "+", WordX.layout w])
 363         and layout
 364           = fn T {immediate, ...} => layoutU immediate
 365       end
 366
 367       val rec eqU
 368         = fn (Word w1, Word w2) => WordX.equals (w1, w2)
 369            | (Label l1, Label l2) => Label.equals(l1, l2)
 370            | (LabelPlusWord (l1, w1), LabelPlusWord (l2,w2))
 371            => Label.equals(l1,l2) andalso WordX.equals(w1, w2)
 372            | _ => false
 373       and eq
 374         = fn (T {plist = plist1, ...},
 375               T {plist = plist2, ...})
 376            => PropertyList.equals(plist1, plist2)
 377
 378       local
 379         open WordX
 380       in
 381         val rec evalU
 382           = fn Word w => SOME w
 383              | Label _ => NONE
 384              | LabelPlusWord _ => NONE
 385         and eval
 386           = fn T {immediate, ...} => evalU immediate
 387       end
 388
 389       val isZero = fn i => case eval i of SOME w => WordX.isZero w | _ => false
 390
 391       local
 392         open Word
 393       in
 394         val rec hashU
 395           = fn Word w => WordX.hash w
 396              | Label l => Label.hash l
 397              | LabelPlusWord (l,w)
 398              => Word.xorb(0wx5555 * (Label.hash l), WordX.hash w)
 399         and hash
 400           = fn T {hash, ...} => hash
 401       end
 402
 403       local
 404         val table: t HashSet.t ref = ref (HashSet.new {hash = hash})
 405       in
 406         val construct
 407           = fn immediate
 408              => let
 409                   val hash = hashU immediate
 410                 in
 411                   HashSet.lookupOrInsert
 412                   (!table,
 413                    hash,
 414                    fn T {immediate = immediate', ...}
 415                     => eqU(immediate', immediate),
 416                    fn () => T {immediate = immediate,
 417                                hash = hash,
 418                                plist = PropertyList.new ()})
 419                 end
 420
 421         val destruct
 422           = fn T {immediate, ...} => immediate
 423
 424         fun clearAll ()
 425           = HashSet.foreach
 426             (!table, fn T {immediate, plist, ...} =>
 427              let in
 428                PropertyList.clear plist;
 429                case immediate
 430                  of Word _ => ()
 431                   | Label l => Label.clear l
 432                   | LabelPlusWord (l, _) => Label.clear l
 433              end)
 434       end
 435
 436       val word = construct o Word
 437       val label = construct o Label
 438       val labelPlusWord = fn (l, w) =>
 439          if WordSize.equals (WordX.size w, WordSize.word32)
 440             then construct (LabelPlusWord (l, w))
 441          else Error.bug "x86.Immediate.labelPlusWord"
 442
 443       val int' = fn (i, ws) => word (WordX.fromIntInf (IntInf.fromInt i, ws))
 444       val int = fn i => int' (i, WordSize.word32)
 445       val zero = int 0
 446
 447       val labelPlusInt = fn (l, i) =>
 448          labelPlusWord (l, WordX.fromIntInf (IntInf.fromInt i, WordSize.word32))
 449
 450       val deLabel
 451         = fn T {immediate = Label l, ...} => SOME l
 452            | _ => NONE
 453     end
 454
 455   structure Scale =
 456     struct
 457       datatype t
 458         = One | Two | Four | Eight
 459
 460       val layout
 461         = let
 462             open Layout
 463           in
 464             fn One => str "1"
 465              | Two => str "2"
 466              | Four => str "4"
 467              | Eight => str "8"
 468           end
 469
 470       val fromBytes : int -> t
 471         = fn 1 => One
 472            | 2 => Two
 473            | 4 => Four
 474            | 8 => Eight
 475            | _ => Error.bug "x86.Scale.fromBytes"
 476       local
 477          datatype z = datatype CType.t
 478       in
 479          fun fromCType t =
 480             case t of
 481                CPointer => Four
 482              | Int8 => One
 483              | Int16 => Two
 484              | Int32 => Four
 485              | Int64 => Eight
 486              | Objptr => Four
 487              | Real32 => Four
 488              | Real64 => Eight
 489              | Word8 => One
 490              | Word16 => Two
 491              | Word32 => Four
 492              | Word64 => Eight
 493       end
 494
 495       fun eq(s1, s2) = s1 = s2
 496
 497       val toWordX
 498         = fn One => WordX.fromIntInf (1, WordSize.word32)
 499            | Two => WordX.fromIntInf (2, WordSize.word32)
 500            | Four => WordX.fromIntInf (4, WordSize.word32)
 501            | Eight => WordX.fromIntInf (8, WordSize.word32)
 502       val toImmediate = Immediate.word o toWordX
 503     end
 504
 505   structure Address =
 506     struct
 507       datatype t = T of {disp: Immediate.t option,
 508                          base: Register.t option,
 509                          index: Register.t option,
 510                          scale: Scale.t option}
 511
 512       fun layout (T {disp, base, index, scale})
 513         = let
 514             open Layout
 515           in
 516             seq [case disp
 517                    of NONE => empty
 518                     | SOME disp => Immediate.layout disp,
 519                  if (isSome base orelse isSome index)
 520                    then paren (seq
 521                                [case base
 522                                   of NONE => empty
 523                                   | SOME base
 524                                   => Register.layout base,
 525                                 case index
 526                                   of NONE => empty
 527                                    | SOME index
 528                                    => seq [str ",", Register.layout index],
 529                                 case scale
 530                                   of NONE => empty
 531                                   | SOME scale
 532                                   => seq [str ",", Scale.layout scale]])
 533                    else empty]
 534           end
 535
 536       fun eq(T {disp = disp,  base = base,  index = index,  scale = scale},
 537              T {disp = disp', base = base', index = index', scale = scale'})
 538         = (case (disp, disp')
 539              of (NONE, NONE) => true
 540               | (SOME disp, SOME disp') => Immediate.eq(disp, disp')
 541               | _ => false) andalso
 542           base = base' andalso
 543           index = index' andalso
 544           scale = scale'
 545     end
 546
 547   structure MemLoc =
 548     struct
 549       structure Class =
 550         struct
 551           val counter = Counter.new 0
 552           datatype t = T of {counter: int,
 553                              name: string}
 554
 555           fun layout (T {name, ...})
 556             = let
 557                 open Layout
 558               in
 559                 str name
 560               end
 561           val toString = Layout.toString o layout
 562
 563           fun new {name}
 564             = let
 565                 val class = T {counter = Counter.next counter,
 566                                name = name}
 567               in
 568                 class
 569               end
 570
 571           val eq
 572             = fn (T {counter = counter1, ...},
 573                   T {counter = counter2, ...})
 574                => counter1 = counter2
 575           val compare
 576             = fn (T {counter = counter1, ...},
 577                   T {counter = counter2, ...})
 578                => Int.compare (counter1, counter2)
 579           val counter
 580             = fn (T {counter, ...}) => counter
 581           val mayAlias = eq
 582
 583           val Temp = new {name = "Temp"}
 584           val StaticTemp = new {name = "StaticTemp"}
 585           val CStack = new {name = "CStack"}
 586           val Code = new {name = "Code"}
 587         end
 588
 589       datatype u
 590         = U of {immBase: Immediate.t option,
 591                 memBase: t option,
 592                 immIndex: Immediate.t option,
 593                 memIndex: t option,
 594                 scale: Scale.t,
 595                 size: Size.t,
 596                 class: Class.t}
 597       and t
 598         = T of {memloc: u,
 599                 hash: Word.t,
 600                 plist: PropertyList.t,
 601                 counter: Int.t,
 602                 utilized: t list}
 603
 604       local
 605         open Layout
 606       in
 607         val rec layoutImmMem
 608           = fn (NONE, NONE) => str "0"
 609              | (SOME imm, NONE) => Immediate.layout imm
 610              | (NONE, SOME mem) => layout mem
 611              | (SOME imm, SOME mem) => seq [Immediate.layout imm,
 612                                             str "+",
 613                                             layout mem]
 614
 615         and layoutImmMemScale
 616           = fn (NONE, NONE, _) => str "0"
 617              | (SOME imm, NONE, _) => Immediate.layout imm
 618              | (NONE, SOME mem, scale) => seq [layout mem,
 619                                                str "*",
 620                                                Scale.layout scale]
 621              | (SOME imm, SOME mem, scale) => seq [Immediate.layout imm,
 622                                                    str "+(",
 623                                                    layout mem,
 624                                                    str "*",
 625                                                    Scale.layout scale,
 626                                                    str ")"]
 627         and layoutU
 628           = fn U {immBase, memBase,
 629                   immIndex, memIndex,
 630                   scale,
 631                   size, class}
 632              => seq [str "MEM<",
 633                      Size.layout size,
 634                      str ">{",
 635                      Class.layout class,
 636                      str "}[(",
 637                      layoutImmMem (immBase, memBase),
 638                      str ")+(",
 639                      layoutImmMemScale (immIndex, memIndex, scale),
 640                      str ")]"]
 641         and layout
 642           = fn T {memloc, ...} => layoutU memloc
 643       end
 644       val toString = Layout.toString o layout
 645
 646       val rec hashImmMem
 647         = fn (NONE, NONE) => 0wx55555555
 648            | (SOME imm, NONE) => Immediate.hash imm
 649            | (NONE, SOME mem) => hash mem
 650            | (SOME imm, SOME mem)
 651            => Word.xorb(0wx5555 * (Immediate.hash imm), hash mem)
 652       and hashU
 653         = fn U {immBase, memBase, immIndex, memIndex, ...}
 654            => let
 655                 val hashBase = hashImmMem(immBase, memBase)
 656                 val hashIndex = hashImmMem(immIndex, memIndex)
 657               in
 658                 Word.xorb(0wx5555 * hashBase, hashIndex)
 659               end
 660       and hash
 661         = fn T {hash, ...} => hash
 662
 663       val rec eqImm
 664         = fn (NONE, NONE) => true
 665            | (SOME imm1, SOME imm2) => Immediate.eq(imm1, imm2)
 666            | _ => false
 667       and eqMem
 668         = fn (NONE, NONE) => true
 669            | (SOME mem1, SOME mem2) => eq(mem1, mem2)
 670            | _ => false
 671       and eqU
 672         = fn (U {immBase = immBase1, memBase = memBase1,
 673                  immIndex = immIndex1, memIndex = memIndex1,
 674                  scale = scale1, size = size1,
 675                  class = class1},
 676               U {immBase = immBase2, memBase = memBase2,
 677                  immIndex = immIndex2, memIndex = memIndex2,
 678                  scale = scale2, size = size2,
 679                  class = class2})
 680            => Class.eq(class1, class2) andalso
 681               eqImm(immBase1, immBase2) andalso
 682               eqMem(memBase1, memBase2) andalso
 683               eqImm(immIndex1, immIndex2) andalso
 684               eqMem(memIndex1, memIndex2) andalso
 685               Scale.eq(scale1, scale2) andalso
 686               Size.eq(size1, size2)
 687       and eq
 688         = fn (T {plist = plist1, ...},
 689               T {plist = plist2, ...})
 690            => PropertyList.equals(plist1, plist2)
 691
 692       val rec utilizedMem
 693         = fn NONE => []
 694            | SOME m => m::(utilized m)
 695       and utilizedU
 696         = fn U {memBase, memIndex, ...}
 697            => (utilizedMem memBase) @ (utilizedMem memIndex)
 698       and utilized
 699         = fn T {utilized, ...}
 700            => utilized
 701
 702       local
 703         val counter = Counter.new 0
 704         val table: t HashSet.t ref = ref (HashSet.new {hash = hash})
 705       in
 706         val construct
 707           = fn memloc
 708              => let
 709                   val hash = hashU memloc
 710                 in
 711                   HashSet.lookupOrInsert
 712                   (!table,
 713                    hash,
 714                    fn T {memloc = memloc', ...} => eqU(memloc', memloc),
 715                    fn () => T {memloc = memloc,
 716                                hash = hash,
 717                                plist = PropertyList.new (),
 718                                counter = Counter.next counter,
 719                                utilized = utilizedU memloc})
 720                 end
 721
 722         val destruct
 723           = fn T {memloc, ...}
 724              => memloc
 725
 726         fun clearAll ()
 727           = HashSet.foreach
 728             (!table, fn T {plist, ...} =>
 729              let in
 730                PropertyList.clear plist
 731              end)
 732       end
 733
 734       val rec mayAliasImmIndex
 735         = fn ({immIndex = immIndex1, size = size1},
 736               {immIndex = immIndex2, size = size2})
 737            => let
 738                 val size1 = IntInf.fromInt (Size.toBytes size1)
 739                 val size2 = IntInf.fromInt (Size.toBytes size2)
 740               in
 741                 case (Immediate.eval (case immIndex1
 742                                         of NONE => Immediate.zero
 743                                          | SOME immIndex => immIndex),
 744                       Immediate.eval (case immIndex2
 745                                         of NONE => Immediate.zero
 746                                          | SOME immIndex => immIndex))
 747                   of (SOME pos1, SOME pos2)
 748                    => (let
 749                          val pos1 = WordX.toIntInfX pos1
 750                          val pos2 = WordX.toIntInfX pos2
 751                        in
 752                          if pos1 < pos2
 753                            then pos2 < (pos1 + size1)
 754                            else pos1 < (pos2 + size2)
 755                        end
 756                        handle Overflow => false)
 757                    | _ => true
 758           end
 759       and mayAliasU
 760         = fn (U {immBase = SOME immBase1, memBase = NONE,
 761                  immIndex = immIndex1, memIndex = NONE,
 762                  size = size1, ...},
 763               U {immBase = SOME immBase2, memBase = NONE,
 764                  immIndex = immIndex2, memIndex = NONE,
 765                  size = size2, ...})
 766            => Immediate.eq(immBase1, immBase2)
 767               andalso
 768               mayAliasImmIndex ({immIndex = immIndex1,
 769                                  size = size1},
 770                                 {immIndex = immIndex2,
 771                                  size = size2})
 772            | (U {immBase = SOME immBase1, memBase = NONE,
 773                  immIndex = immIndex1, memIndex = SOME memIndex1,
 774                  size = size1, ...},
 775               U {immBase = SOME immBase2, memBase = NONE,
 776                  immIndex = immIndex2, memIndex = SOME memIndex2,
 777                  size = size2, ...})
 778            => not (Immediate.eq(immBase1, immBase2))
 779               andalso
 780               (not (eq(memIndex1, memIndex2))
 781                orelse
 782                mayAliasImmIndex ({immIndex = immIndex1,
 783                                   size = size1},
 784                                  {immIndex = immIndex2,
 785                                   size = size2}))
 786            | (U {immBase = NONE, memBase = SOME memBase1,
 787                  immIndex = immIndex1, memIndex = NONE,
 788                  size = size1, ...},
 789               U {immBase = NONE, memBase = SOME memBase2,
 790                  immIndex = immIndex2, memIndex = NONE,
 791                  size = size2, ...})
 792            => not (eq(memBase1, memBase2))
 793               orelse
 794               mayAliasImmIndex ({immIndex = immIndex1,
 795                                  size = size1},
 796                                 {immIndex = immIndex2,
 797                                  size = size2})
 798            | (U {immBase = NONE, memBase = SOME memBase1,
 799                  immIndex = immIndex1, memIndex = SOME memIndex1,
 800                  size = size1, ...},
 801               U {immBase = NONE, memBase = SOME memBase2,
 802                  immIndex = immIndex2, memIndex = SOME memIndex2,
 803                  size = size2, ...})
 804            => not (eq(memBase1, memBase2))
 805               orelse
 806               not (eq(memIndex1, memIndex2))
 807               orelse
 808               mayAliasImmIndex ({immIndex = immIndex1,
 809                                  size = size1},
 810                                 {immIndex = immIndex2,
 811                                  size = size2})
 812            | _ => true
 813       and mayAlias
 814         = fn (T {memloc = memloc1 as U {class = class1, ...}, ...},
 815               T {memloc = memloc2 as U {class = class2, ...}, ...})
 816            => Class.mayAlias(class1, class2) andalso
 817               mayAliasU(memloc1, memloc2)
 818
 819       val rec mayAliasOrdImmIndex
 820         = fn ({immIndex = immIndex1, size = size1},
 821               {immIndex = immIndex2, size = size2})
 822            => let
 823                 val size1 = IntInf.fromInt (Size.toBytes size1)
 824                 val size2 = IntInf.fromInt (Size.toBytes size2)
 825               in
 826                 case (Immediate.eval (case immIndex1
 827                                         of NONE => Immediate.zero
 828                                          | SOME immIndex => immIndex),
 829                       Immediate.eval (case immIndex2
 830                                         of NONE => Immediate.zero
 831                                          | SOME immIndex => immIndex))
 832                   of (SOME pos1, SOME pos2)
 833                    => (let
 834                          val pos1 = WordX.toIntInfX pos1
 835                          val pos2 = WordX.toIntInfX pos2
 836                        in
 837                          if pos1 < pos2
 838                            then if pos2 < (pos1 + size1)
 839                                   then SOME LESS
 840                                   else NONE
 841                            else if pos1 < (pos2 + size2)
 842                                   then SOME GREATER
 843                                   else NONE
 844                        end
 845                        handle Overflow => NONE)
 846                    | _ => SOME EQUAL
 847           end
 848       and mayAliasOrdU
 849         = fn (U {immBase = SOME immBase1, memBase = NONE,
 850                  immIndex = immIndex1, memIndex = NONE,
 851                  size = size1, ...},
 852               U {immBase = SOME immBase2, memBase = NONE,
 853                  immIndex = immIndex2, memIndex = NONE,
 854                  size = size2, ...})
 855            => if Immediate.eq(immBase1, immBase2)
 856                 then mayAliasOrdImmIndex ({immIndex = immIndex1,
 857                                            size = size1},
 858                                           {immIndex = immIndex2,
 859                                            size = size2})
 860                 else NONE
 861            | (U {immBase = SOME immBase1, memBase = NONE,
 862                  immIndex = immIndex1, memIndex = SOME memIndex1,
 863                  size = size1, ...},
 864               U {immBase = SOME immBase2, memBase = NONE,
 865                  immIndex = immIndex2, memIndex = SOME memIndex2,
 866                  size = size2, ...})
 867            => if Immediate.eq(immBase1, immBase2)
 868                 then if not (eq(memIndex1, memIndex2))
 869                        then SOME EQUAL
 870                        else mayAliasOrdImmIndex ({immIndex = immIndex1,
 871                                                   size = size1},
 872                                                  {immIndex = immIndex2,
 873                                                   size = size2})
 874                 else NONE
 875            | (U {immBase = NONE, memBase = SOME memBase1,
 876                  immIndex = immIndex1, memIndex = NONE,
 877                  size = size1, ...},
 878               U {immBase = NONE, memBase = SOME memBase2,
 879                  immIndex = immIndex2, memIndex = NONE,
 880                  size = size2, ...})
 881            => if not (eq(memBase1, memBase2))
 882                 then SOME EQUAL
 883                 else mayAliasOrdImmIndex ({immIndex = immIndex1,
 884                                            size = size1},
 885                                           {immIndex = immIndex2,
 886                                            size = size2})
 887            | (U {immBase = NONE, memBase = SOME memBase1,
 888                  immIndex = immIndex1, memIndex = SOME memIndex1,
 889                  size = size1, ...},
 890               U {immBase = NONE, memBase = SOME memBase2,
 891                  immIndex = immIndex2, memIndex = SOME memIndex2,
 892                  size = size2, ...})
 893            => if (not (eq(memBase1, memBase2))
 894                   orelse
 895                   not (eq(memIndex1, memIndex2)))
 896                 then SOME EQUAL
 897                 else mayAliasOrdImmIndex ({immIndex = immIndex1,
 898                                            size = size1},
 899                                           {immIndex = immIndex2,
 900                                            size = size2})
 901            | _ => SOME EQUAL
 902       and mayAliasOrd
 903         = fn (T {memloc = memloc1 as U {class = class1, ...}, ...},
 904               T {memloc = memloc2 as U {class = class2, ...}, ...})
 905            => if Class.mayAlias(class1, class2)
 906                 then mayAliasOrdU(memloc1, memloc2)
 907                 else NONE
 908
 909       val compare
 910         = fn (T {counter = counter1, ...},
 911               T {counter = counter2, ...})
 912            => Int.compare(counter1, counter2)
 913
 914       fun replaceMem replacer
 915         = fn NONE => NONE
 916            | SOME mem => SOME (replace replacer mem)
 917       and replaceU replacer
 918         = fn memloc as T {memloc = U {immBase, memBase, immIndex, memIndex,
 919                                       scale, size, class}, ...}
 920            => let
 921                 val memBase' = replaceMem replacer memBase
 922                 val memIndex' = replaceMem replacer memIndex
 923               in
 924                 if eqMem(memBase, memBase') andalso eqMem(memIndex, memIndex')
 925                   then memloc
 926                   else construct (U {immBase = immBase,
 927                                      memBase = memBase',
 928                                      immIndex = immIndex,
 929                                      memIndex = memIndex',
 930                                      scale = scale,
 931                                      size = size,
 932                                      class = class})
 933               end
 934       and replace replacer
 935         = fn memloc
 936            => let
 937                 val memloc' = replacer memloc
 938               in
 939                 if eq(memloc', memloc)
 940                   then replaceU replacer memloc
 941                   else memloc'
 942               end
 943
 944       val rec sizeU = fn U {size, ...} => size
 945       and size = fn T {memloc, ...} => sizeU memloc
 946       val rec classU = fn U {class, ...} => class
 947       and class = fn T {memloc, ...} => classU memloc
 948
 949       fun scaleImmediate (imm, scale) =
 950         case Immediate.destruct imm of
 951            Immediate.Word w => Immediate.word (WordX.mul (w,
 952                                                           Scale.toWordX scale,
 953                                                           {signed = true}))
 954          | _ => Error.bug "x86.MemLoc.scaleImmediate"
 955
 956       fun addImmediate (imm1, imm2) =
 957         case (Immediate.destruct imm1, Immediate.destruct imm2) of
 958            (Immediate.Word w1, Immediate.Word w2) => Immediate.word (WordX.add (w1, w2))
 959          | _ => Error.bug "x86.MemLoc.scaleImmediate"
 960
 961       val imm = fn {base, index, scale, size, class}
 962         => construct (U {immBase = SOME base,
 963                          memBase = NONE,
 964                          immIndex = SOME (scaleImmediate (index, scale)),
 965                          memIndex = NONE,
 966                          scale = scale,
 967                          size = size,
 968                          class = class})
 969       val basic = fn {base, index, scale, size, class}
 970         => construct (U {immBase = SOME base,
 971                          memBase = NONE,
 972                          immIndex = NONE,
 973                          memIndex = SOME index,
 974                          scale = scale,
 975                          size = size,
 976                          class = class})
 977       val simple = fn {base, index, scale, size, class}
 978         => construct (U {immBase = NONE,
 979                          memBase = SOME base,
 980                          immIndex = SOME (scaleImmediate (index, scale)),
 981                          memIndex = NONE,
 982                          scale = scale,
 983                          size = size,
 984                          class = class})
 985
 986       val complex = fn {base, index, scale, size, class}
 987         => construct (U {immBase = NONE,
 988                          memBase = SOME base,
 989                          immIndex = NONE,
 990                          memIndex = SOME index,
 991                          scale = scale,
 992                          size = size,
 993                          class = class})
 994       val shift = fn {origin, disp, scale, size}
 995         => let
 996               val disp = scaleImmediate (disp, scale)
 997               val U {immBase, memBase,
 998                      immIndex, memIndex,
 999                      scale, class, ...} =
1000                  destruct origin
1001            in
1002               construct (U {immBase = immBase,
1003                             memBase = memBase,
1004                             immIndex =
1005                             case immIndex of
1006                                NONE => SOME disp
1007                              | SOME immIndex => SOME (addImmediate (immIndex, disp)),
1008                             memIndex = memIndex,
1009                             scale = scale,
1010                             size = size,
1011                             class = class})
1012            end
1013
1014       local
1015         val num : int ref = ref 0
1016       in
1017         val temp = fn {size} => (Int.inc num;
1018                                  imm {base = Immediate.zero,
1019                                       index = Immediate.int (!num),
1020                                       scale = Scale.One,
1021                                       size = size,
1022                                       class = Class.Temp})
1023       end
1024
1025       (*
1026        * Static memory locations
1027        *)
1028       fun makeContents {base, size, class}
1029         = imm {base = base,
1030                index = Immediate.zero,
1031                scale = Scale.Four,
1032                size = size,
1033                class = class}
1034 (*
1035       local
1036         datatype z = datatype CType.t
1037         datatype z = datatype Size.t
1038       in
1039          fun cReturnTempContents sizes =
1040             (List.rev o #1)
1041             (List.fold
1042              (sizes, ([],0), fn (size, (contents, index)) =>
1043               ((cReturnTempContent (index, size))::contents,
1044                index + Size.toBytes size)))
1045          fun cReturnTempContent size =
1046             List.first(cReturnTempContents [size])
1047          val cReturnTempContents = fn size =>
1048             cReturnTempContents (
1049             case size of
1050                Int s => let datatype z = datatype IntSize.t
1051                         in case s of
1052                              I8 => [BYTE]
1053                            | I16 => [WORD]
1054                            | I32 => [LONG]
1055                            | I64 => [LONG, LONG]
1056                         end
1057              | Pointer => [LONG]
1058              | Real s => let datatype z = datatype RealSize.t
1059                          in case s of
1060                               R32 => [SNGL]
1061                             | R64 => [DBLE]
1062                          end
1063              | Word s => let datatype z = datatype WordSize.t
1064                          in case s of
1065                               W8 => [BYTE]
1066                             | W16 => [WORD]
1067                             | W32 => [LONG]
1068                          end)
1069       end
1070 *)
1071     end
1072
1073   local
1074     structure ClassElement =
1075       struct
1076         type t = MemLoc.Class.t
1077         val compare = MemLoc.Class.compare
1078         local
1079           fun make f = fn (a, b) => f (MemLoc.Class.counter a, MemLoc.Class.counter b)
1080         in
1081           val op < = make Int.<
1082           val op > = make Int.>
1083           val op >= = make Int.>=
1084           val op <= = make Int.<=
1085         end
1086         val min = fn (a, b) => if Int.<(MemLoc.Class.counter a, MemLoc.Class.counter b)
1087                                  then a
1088                                  else b
1089         val max = fn (a, b) => min (b, a)
1090         val equals = MemLoc.Class.eq
1091         val layout = MemLoc.Class.layout
1092       end
1093   in
1094     structure ClassSet = OrderedUniqueSet(open ClassElement)
1095   end
1096   local
1097     structure MemLocElement =
1098       struct
1099         type t = MemLoc.t
1100         val equals = MemLoc.eq
1101         val layout = MemLoc.layout
1102 (*
1103         val compare = MemLoc.compare
1104         local
1105           fun make f = fn (a, b) => f (MemLoc.counter a, MemLoc.counter b)
1106         in
1107           val op < = make Int.<
1108           val op > = make Int.>
1109           val op >= = make Int.>=
1110           val op <= = make Int.<=
1111         end
1112         val min = fn (a, b) => if Int.<(MemLoc.counter a, MemLoc.counter b)
1113                                  then a
1114                                  else b
1115         val max = fn (a, b) => min (b, a)
1116         val hash = MemLoc.hash
1117 *)
1118       end
1119   in
1120     structure MemLocSet = UnorderedSet(open MemLocElement)
1121 (*
1122     structure MemLocSet = OrderedUniqueSet(open MemLocElement)
1123 *)
1124 (*
1125     structure MemLocSet' = UnorderedSet(open MemLocElement)
1126     structure MemLocSet = HashedUniqueSet(structure Set = MemLocSet'
1127                                           structure Element = MemLocElement)
1128 *)
1129   end
1130
1131   structure Operand =
1132     struct
1133       datatype t
1134         = Register of Register.t
1135         | FltRegister of FltRegister.t
1136         | Immediate of Immediate.t
1137         | Label of Label.t
1138         | Address of Address.t
1139         | MemLoc of MemLoc.t
1140
1141       val size
1142         = fn Register r => SOME (Register.size r)
1143            | FltRegister _ => SOME Size.EXTD
1144            | Immediate _ => NONE
1145            | Label _ => NONE
1146            | Address _ => NONE
1147            | MemLoc m => SOME (MemLoc.size m)
1148
1149       val layout
1150         = let
1151             open Layout
1152           in
1153             fn Register r => Register.layout r
1154              | FltRegister f => FltRegister.layout f
1155              | Immediate i => seq [str "$", Immediate.layout i]
1156              | Label l => Label.layout l
1157              | Address a => Address.layout a
1158              | MemLoc m => MemLoc.layout m
1159           end
1160       val toString = Layout.toString o layout
1161
1162       val eq
1163         = fn (Register r1,    Register r2)    => Register.eq(r1, r2)
1164            | (FltRegister f1, FltRegister f2) => FltRegister.eq(f1, f2)
1165            | (Immediate i1,   Immediate i2)   => Immediate.eq(i1, i2)
1166            | (Label l1,       Label l2)       => Label.equals(l1, l2)
1167            | (Address a1,     Address a2)     => Address.eq(a1, a2)
1168            | (MemLoc m1,      MemLoc m2)      => MemLoc.eq(m1, m2)
1169            | _                                => false
1170
1171       val mayAlias
1172         = fn (Register r1,    Register r2)    => Register.eq(r1, r2)
1173            | (Register _,     _)              => false
1174            | (FltRegister f1, FltRegister f2) => FltRegister.eq(f1, f2)
1175            | (FltRegister _,  _)              => false
1176            | (Immediate i1,   Immediate i2)   => Immediate.eq(i1, i2)
1177            | (Immediate _,    _)              => false
1178            | (Label l1,       Label l2)       => Label.equals(l1, l2)
1179            | (Label _,        _)              => false
1180            | (Address _,      Address _)      => true
1181            | (Address _,      MemLoc _)       => true
1182            | (Address _,      _)              => false
1183            | (MemLoc m1,      MemLoc m2)      => MemLoc.mayAlias(m1, m2)
1184            | (MemLoc _,       Address _)      => true
1185            | (MemLoc _,       _)              => false
1186
1187       val register = Register
1188       val deRegister
1189         = fn Register x => SOME x
1190            | _ => NONE
1191       val fltregister = FltRegister
1192       val deFltregister
1193         = fn FltRegister x => SOME x
1194            | _ => NONE
1195       val immediate = Immediate
1196       val deImmediate
1197         = fn Immediate x => SOME x
1198            | _ => NONE
1199       val immediate_word = immediate o Immediate.word
1200       val immediate_int' = immediate o Immediate.int'
1201       val immediate_int = immediate o Immediate.int
1202       val immediate_zero = immediate Immediate.zero
1203       val immediate_label = immediate o Immediate.label
1204       val label = Label
1205       val deLabel
1206         = fn Label x => SOME x
1207            | _ => NONE
1208       val address = Address
1209       val memloc = MemLoc
1210       fun memloc_label l =
1211          memloc (MemLoc.makeContents { base = Immediate.label l,
1212                                        size = Size.LONG,
1213                                        class = MemLoc.Class.Code })
1214       val deMemloc
1215         = fn MemLoc x => SOME x
1216            | _ => NONE
1217
1218       local
1219         val cReturnTemp = Label.fromString "cReturnTemp"
1220         fun cReturnTempContent (index, size) =
1221            MemLoc.imm
1222            {base = Immediate.label cReturnTemp,
1223             index = Immediate.int index,
1224             scale = Scale.One,
1225             size = size,
1226             class = MemLoc.Class.StaticTemp}
1227          datatype z = datatype CType.t
1228          datatype z = datatype Size.t
1229       in
1230          fun cReturnTemps ty =
1231             if RepType.isUnit ty
1232                then []
1233             else
1234                let
1235                   fun w (r, s) =
1236                      [{src = register r, dst = cReturnTempContent (0, s)}]
1237                   val w8 = w (Register.al, BYTE)
1238                   val w16 = w (Register.ax, WORD)
1239                   val w32 = w (Register.eax, LONG)
1240                   val w64 =[{src = register Register.eax,
1241                              dst = cReturnTempContent (0, LONG)},
1242                             {src = register Register.edx,
1243                              dst = cReturnTempContent (4, LONG)}]
1244                in
1245                   case RepType.toCType ty of
1246                      CPointer => w32
1247                    | Int8 => w8
1248                    | Int16 => w16
1249                    | Int32 => w32
1250                    | Int64 => w64
1251                    | Objptr => w32
1252                    | Real32 => [{src = fltregister FltRegister.top,
1253                                  dst = cReturnTempContent (0, SNGL)}]
1254                    | Real64 => [{src = fltregister FltRegister.top,
1255                                  dst = cReturnTempContent (0, DBLE)}]
1256                    | Word8 => w8
1257                    | Word16 => w16
1258                    | Word32 => w32
1259                    | Word64 => w64
1260                end
1261       end
1262     end
1263
1264   structure Instruction =
1265     struct
1266       (* Integer binary arithmetic(w/o mult & div)/logic instructions. *)
1267       datatype binal
1268         = ADD (* signed/unsigned addition; p. 63 *)
1269         | ADC (* signed/unsigned addition with carry; p. 61 *)
1270         | SUB (* signed/unsigned subtraction; p. 713 *)
1271         | SBB (* signed/unsigned subtraction with borrow; p. 667 *)
1272         | AND (* logical and; p. 70 *)
1273         | OR  (* logical or; p. 499 *)
1274         | XOR (* logical xor; p. 758 *)
1275       val binal_layout
1276         = let
1277             open Layout
1278           in
1279             fn ADD => str "add"
1280              | ADC => str "adc"
1281              | SUB => str "sub"
1282              | SBB => str "sbb"
1283              | AND => str "and"
1284              | OR  => str "or"
1285              | XOR => str "xor"
1286           end
1287
1288       (* Integer multiplication and division. *)
1289       datatype md
1290         = IMUL (* signed multiplication (one operand form); p. 335 *)
1291         | MUL  (* unsigned multiplication; p. 488 *)
1292         | IDIV (* signed division; p. 332 *)
1293         | DIV  (* unsigned division; p. 188 *)
1294         | IMOD (* signed modulus; *)
1295         | MOD  (* unsigned modulus; *)
1296       val md_layout
1297         = let
1298             open Layout
1299           in
1300             fn IMUL => str "imul"
1301              | MUL  => str "mul"
1302              | IDIV => str "idiv"
1303              | DIV  => str "div"
1304              | IMOD => str "imod"
1305              | MOD  => str "mod"
1306           end
1307
1308       (* Integer unary arithmetic/logic instructions. *)
1309       datatype unal
1310         = INC (* increment by 1; p. 341 *)
1311         | DEC (* decrement by 1; p. 186 *)
1312         | NEG (* two's complement negation; p. 494 *)
1313         | NOT (* one's complement negation; p. 497 *)
1314       val unal_layout
1315         = let
1316             open Layout
1317           in
1318             fn INC => str "inc"
1319              | DEC => str "dec"
1320              | NEG => str "neg"
1321              | NOT => str "not"
1322           end
1323
1324       (* Integer shift/rotate arithmetic/logic instructions. *)
1325       datatype sral
1326         = SAL (* shift arithmetic left; p. 662 *)
1327         | SHL (* shift logical left; p. 662 *)
1328         | SAR (* shift arithmetic right; p. 662 *)
1329         | SHR (* shift logical right; p. 662 *)
1330         | ROL (* rotate left; p. 631 *)
1331         | RCL (* rotate through carry left; p. 631 *)
1332         | ROR (* rotate right; p. 631 *)
1333         | RCR (* rotate through carry right; p. 631 *)
1334       val sral_layout
1335         = let
1336             open Layout
1337           in
1338             fn SAL => str "sal"
1339              | SHL => str "shl"
1340              | SAR => str "sar"
1341              | SHR => str "shr"
1342              | ROL => str "rol"
1343              | RCL => str "rcl"
1344              | ROR => str "ror"
1345              | RCR => str "rcr"
1346           end
1347
1348       (* Move with extention instructions. *)
1349       datatype movx
1350         = MOVSX (* move with sign extention; p. 481 *)
1351         | MOVZX (* move with zero extention; p. 486 *)
1352       val movx_layout
1353         = let
1354             open Layout
1355           in
1356             fn MOVSX => str "movs"
1357              | MOVZX => str "movz"
1358           end
1359
1360       (* Condition test field; p. 795 *)
1361       datatype condition
1362         = O   (* overflow *)       | NO  (* not overflow *)
1363         | B   (* below *)          | NB  (* not below *)
1364         | AE  (* above or equal *) | NAE (* not above or equal *)
1365         | C   (* carry *)          | NC  (* not carry *)
1366         | E   (* equal *)          | NE  (* not equal *)
1367         | Z   (* zero *)           | NZ  (* not zero *)
1368         | BE  (* below or equal *) | NBE (* not below or equal *)
1369         | A   (* above *)          | NA  (* not above *)
1370         | S   (* sign *)           | NS  (* not sign *)
1371         | P   (* parity *)         | NP  (* not parity *)
1372         | PE  (* parity even *)    | PO  (* parity odd *)
1373         | L   (* less than *)
1374         | NL  (* not less than *)
1375         | LE  (* less than or equal *)
1376         | NLE (* not less than or equal *)
1377         | G   (* greater than *)
1378         | NG  (* not greater than *)
1379         | GE  (* greater than or equal *)
1380         | NGE (* not greater than or equal *)
1381
1382       val condition_negate
1383         = fn O   => NO  | NO  => O
1384            | B   => NB  | NB  => B
1385            | AE  => NAE | NAE => AE
1386            | C   => NC  | NC  => C
1387            | E   => NE  | NE  => E
1388            | Z   => NZ  | NZ  => Z
1389            | BE  => NBE | NBE => BE
1390            | A   => NA  | NA  => A
1391            | S   => NS  | NS  => S
1392            | P   => NP  | NP  => P
1393            | PE  => PO  | PO  => PE
1394            | L   => NL  | NL  => L
1395            | LE  => NLE | NLE => LE
1396            | G   => NG  | NG  => G
1397            | GE  => NGE | NGE => GE
1398
1399       val condition_reverse
1400         = fn B   => A   | NB  => NA
1401            | AE  => BE  | NAE => NBE
1402            | E   => E   | NE  => NE
1403            | BE  => AE  | NBE => NAE
1404            | A   => B   | NA  => NB
1405            | L   => G   | NL  => NG
1406            | LE  => GE  | NLE => NGE
1407            | G   => L   | NG  => NL
1408            | GE  => LE  | NGE => NLE
1409            | c   => c
1410
1411       local
1412         open Layout
1413       in
1414         val rec condition_layout
1415         = fn O  => str "o"
1416            | B  => str "b"
1417            | AE => str "ae"
1418            | C  => str "c"
1419            | E  => str "e"
1420            | Z  => str "z"
1421            | BE => str "be"
1422            | A  => str "a"
1423            | S  => str "s"
1424            | P  => str "p"
1425            | PE => str "pe"
1426            | PO => str "po"
1427            | L  => str "l"
1428            | LE => str "le"
1429            | G  => str "g"
1430            | GE => str "ge"
1431            | c  => seq [str "n", condition_layout (condition_negate c)]
1432       end
1433       val condition_toString = Layout.toString o condition_layout
1434
1435       (* Floating-point binary arithmetic instructions. *)
1436       datatype fbina
1437         = FADD  (* addition; p. 205 *)
1438         | FSUB  (* subtraction; p. 297 *)
1439         | FSUBR (* reversed subtraction; p. 301 *)
1440         | FMUL  (* multiplication; p. 256 *)
1441         | FDIV  (* division; p. 229 *)
1442         | FDIVR (* reversed division; p. 233 *)
1443       val fbina_layout
1444         = let
1445             open Layout
1446           in
1447             fn FADD => str "fadd"
1448              | FSUB => str "fsub"
1449              | FSUBR => str "fsubr"
1450              | FMUL => str "fmul"
1451              | FDIV => str "fdiv"
1452              | FDIVR => str "fdivr"
1453           end
1454       val fbina_reverse
1455         = fn FADD  => FADD
1456            | FSUB  => FSUBR
1457            | FSUBR => FSUB
1458            | FMUL  => FMUL
1459            | FDIV  => FDIVR
1460            | FDIVR => FDIV
1461
1462       (* Floating-point unary arithmetic instructions. *)
1463       datatype funa
1464         = F2XM1   (* compute 2^x-1; p. 201 *)
1465         | FABS    (* absolute value; p. 203 *)
1466         | FCHS    (* change sign; p. 214 *)
1467         | FSQRT   (* square root; p. 284 *)
1468         | FSIN    (* sine; p. 280 *)
1469         | FCOS    (* cosine; p. 226 *)
1470         | FRNDINT (* round to integer; p. 271 *)
1471       val funa_layout
1472         = let
1473             open Layout
1474           in
1475             fn F2XM1 => str "f2xm1"
1476              | FABS => str "fabs"
1477              | FCHS => str "fchs"
1478              | FSQRT => str "fsqrt"
1479              | FSIN => str "fsin"
1480              | FCOS => str "fcos"
1481              | FRNDINT => str "frndint"
1482           end
1483
1484       (* Floating-point binary arithmetic stack instructions. *)
1485       datatype fbinas
1486         = FSCALE (* scale; p. 278 *)
1487         | FPREM (* partial remainder; p. 263 *)
1488         | FPREM1 (* IEEE partial remainder; p. 266 *)
1489       val fbinas_layout
1490         = let
1491             open Layout
1492           in
1493             fn FSCALE => str "fscale"
1494              | FPREM=> str "fprem"
1495              | FPREM1 => str "fprem1"
1496           end
1497
1498       (* floating point binary arithmetic stack pop instructions. *)
1499       datatype fbinasp
1500         = FYL2X (* compute y * log_2 x; p. 327 *)
1501         | FYL2XP1 (* compute y * log_2 (x + 1.0); p. 329 *)
1502         | FPATAN (* partial arctangent; p. 261 *)
1503       val fbinasp_layout
1504         = let
1505             open Layout
1506           in
1507             fn FYL2X => str "fyl2x"
1508              | FYL2XP1 => str "fyl2xp1"
1509              | FPATAN => str "fpatan"
1510           end
1511
1512       (* Floating-point constants. *)
1513       datatype fldc
1514         = ONE  (* +1.0; p. 250 *)
1515         | ZERO (* +0.0; p. 250 *)
1516         | PI   (* pi; p. 250 *)
1517         | L2E  (* log_2 e; p. 250 *)
1518         | LN2  (* log_e 2; p. 250 *)
1519         | L2T  (* log_2 10; p. 250 *)
1520         | LG2  (* log_10 2; p. 250 *)
1521       val fldc_layout
1522         = let
1523             open Layout
1524           in
1525             fn ONE => str "fld1"
1526              | ZERO => str "fldz"
1527              | PI => str "fldpi"
1528              | L2E => str "fldl2e"
1529              | LN2 => str "fldln2"
1530              | L2T => str "fldl2t"
1531              | LG2 => str "fldlg2"
1532           end
1533
1534       (* x86 Instructions.
1535        * src operands are not changed by the instruction.
1536        * dst operands are changed by the instruction.
1537        *)
1538       datatype t
1539         (* No operation *)
1540         = NOP
1541         (* Halt *)
1542         | HLT
1543         (* Integer binary arithmetic(w/o mult & div)/logic instructions.
1544          *)
1545         | BinAL of {oper: binal,
1546                     src: Operand.t,
1547                     dst: Operand.t,
1548                     size: Size.t}
1549         (* Psuedo integer multiplication and division.
1550          *)
1551         | pMD of {oper: md,
1552                   src: Operand.t,
1553                   dst: Operand.t,
1554                   size: Size.t}
1555         (* Integer multiplication and division.
1556          *)
1557         | MD of {oper: md,
1558                  src: Operand.t,
1559                  size: Size.t}
1560         (* Integer signed/unsiged multiplication (two operand form); p. 335
1561          *)
1562         | IMUL2 of {src: Operand.t,
1563                     dst: Operand.t,
1564                     size: Size.t}
1565         (* Integer unary arithmetic/logic instructions.
1566          *)
1567         | UnAL of {oper: unal,
1568                    dst: Operand.t,
1569                    size: Size.t}
1570         (* Integer shift/rotate arithmetic/logic instructions.
1571          *)
1572         | SRAL of {oper: sral,
1573                    count: Operand.t,
1574                    dst: Operand.t,
1575                    size: Size.t}
1576         (* Arithmetic compare.
1577          *)
1578         | CMP  of {src1: Operand.t,
1579                    src2: Operand.t,
1580                    size: Size.t}
1581         (* Logical compare.
1582          *)
1583         | TEST of {src1: Operand.t,
1584                    src2: Operand.t,
1585                    size: Size.t}
1586         (* Set byte on condition.
1587          *)
1588         | SETcc of {condition: condition,
1589                     dst: Operand.t,
1590                     size: Size.t}
1591         (* Jump.
1592          *)
1593         | JMP of {target: Operand.t,
1594                   absolute: bool}
1595         (* Jump if condition is met.
1596          *)
1597         | Jcc of {condition: condition,
1598                   target: Operand.t}
1599         (* Call procedure.
1600          *)
1601         | CALL of {target: Operand.t,
1602                    absolute: bool}
1603         (* Return from procedure.
1604          *)
1605         | RET of {src: Operand.t option}
1606         (* Move.
1607          *)
1608         | MOV of {src: Operand.t,
1609                   dst: Operand.t,
1610                   size: Size.t}
1611         (* Conditional move.
1612          *)
1613         | CMOVcc of {condition: condition,
1614                      src: Operand.t,
1615                      dst: Operand.t,
1616                      size: Size.t}
1617         (* Exchange register/memory with register.
1618          *)
1619         | XCHG of {src: Operand.t,
1620                    dst: Operand.t,
1621                    size: Size.t}
1622         (* Pseudo-push a value onto a stack.
1623          *)
1624         | pPUSH of {src: Operand.t,
1625                     base: Operand.t,
1626                     size: Size.t}
1627         (* Pseudo-pop a value from a stack.
1628          *)
1629         | pPOP of {dst: Operand.t,
1630                    base: Operand.t,
1631                    size: Size.t}
1632         (* Push a value onto the stack.
1633          *)
1634         | PUSH of {src: Operand.t,
1635                    size: Size.t}
1636         (* Pop a value from the stack.
1637          *)
1638         | POP of {dst: Operand.t,
1639                   size: Size.t}
1640         (* Convert X to 2X with sign extension.
1641          *)
1642         | CX of {size: Size.t}
1643         (* Move with extention.
1644          *)
1645         | MOVX of {oper: movx,
1646                    src: Operand.t,
1647                    srcsize: Size.t,
1648                    dst: Operand.t,
1649                    dstsize: Size.t}
1650         (* Move with contraction.
1651          *)
1652         | XVOM of {src: Operand.t,
1653                    srcsize: Size.t,
1654                    dst: Operand.t,
1655                    dstsize: Size.t}
1656         (* Load effective address.
1657          *)
1658         | LEA of {src: Operand.t,
1659                   dst: Operand.t,
1660                   size: Size.t}
1661         (* Pseudo floating-point move.
1662          *)
1663         | pFMOV of {src: Operand.t,
1664                     dst: Operand.t,
1665                     size: Size.t}
1666         (* Pseudo floating-point move with extension.
1667          *)
1668         | pFMOVX of {src: Operand.t,
1669                      dst: Operand.t,
1670                      srcsize: Size.t,
1671                      dstsize: Size.t}
1672         (* Pseudo floating-point move with contraction.
1673          *)
1674         | pFXVOM of {src: Operand.t,
1675                      dst: Operand.t,
1676                      srcsize: Size.t,
1677                      dstsize: Size.t}
1678         (* Pseudo floating-point load constant.
1679          *)
1680         | pFLDC of {oper: fldc,
1681                     dst: Operand.t,
1682                     size: Size.t}
1683         (* Pseudo floating-point move from integer.
1684          *)
1685         | pFMOVFI of {src: Operand.t,
1686                       dst: Operand.t,
1687                       srcsize: Size.t,
1688                       dstsize: Size.t}
1689         (* Pseudo floating-point move to integer.
1690          *)
1691         | pFMOVTI of {src: Operand.t,
1692                       dst: Operand.t,
1693                       srcsize: Size.t,
1694                       dstsize: Size.t}
1695         (* Pseudo floating-point compare.
1696          *)
1697         | pFCOM of {src1: Operand.t,
1698                     src2: Operand.t,
1699                     size: Size.t}
1700         (* Pseudo floating-point unordered compare.
1701          *)
1702         | pFUCOM of {src1: Operand.t,
1703                      src2: Operand.t,
1704                      size: Size.t}
1705         (* Pseudo floating-point binary arithmetic instructions.
1706          *)
1707         | pFBinA of {oper: fbina,
1708                      src: Operand.t,
1709                      dst: Operand.t,
1710                      size: Size.t}
1711         (* Pseudo floating-point unary arithmetic instructions.
1712          *)
1713         | pFUnA of {oper: funa,
1714                     dst: Operand.t,
1715                     size: Size.t}
1716         (* Pseudo floating-point partial tangent instruction.
1717          *)
1718         | pFPTAN of {dst: Operand.t,
1719                      size: Size.t}
1720         (* Pseudo floating-point binary arithmetic stack instructions.
1721          *)
1722         | pFBinAS of {oper: fbinas,
1723                       src: Operand.t,
1724                       dst: Operand.t,
1725                       size: Size.t}
1726         (* Pseudo floating-point binary arithmetic stack pop instructions.
1727          *)
1728         | pFBinASP of {oper: fbinasp,
1729                        src: Operand.t,
1730                        dst: Operand.t,
1731                        size: Size.t}
1732         (* Floating-point load real.
1733          *)
1734         | FLD of {src: Operand.t,
1735                   size: Size.t}
1736         (* Floating-point store real.
1737          *)
1738         | FST of {dst: Operand.t,
1739                   size: Size.t,
1740                   pop: bool}
1741         (* Floating-point load integer.
1742          *)
1743         | FILD of {src: Operand.t,
1744                    size: Size.t}
1745         (* Floating-point store integer.
1746          *)
1747         | FIST of {dst: Operand.t,
1748                    size: Size.t,
1749                    pop: bool}
1750         (* Floating-point exchange.
1751          *)
1752         | FXCH of {src: Operand.t}
1753         (* Floating-point load constant.
1754          *)
1755         | FLDC of {oper: fldc}
1756         (* Floating-point load control word.
1757          *)
1758         | FLDCW of {src: Operand.t}
1759         (* Floating-point store control word.
1760          *)
1761         | FSTCW of {dst: Operand.t,
1762                     check: bool}
1763         (* Floating-point store status word.
1764          *)
1765         | FSTSW of {dst: Operand.t,
1766                     check: bool}
1767         (* Floating-point compare.
1768          *)
1769         | FCOM of {src: Operand.t,
1770                    size: Size.t,
1771                    pop: bool,
1772                    pop': bool}
1773         (* Floating-point unordered compare.
1774          *)
1775         | FUCOM of {src: Operand.t,
1776                     pop: bool,
1777                     pop': bool}
1778         (* Floating-point binary arithmetic instructions.
1779          *)
1780         | FBinA of {oper: fbina,
1781                     src: Operand.t,
1782                     dst: Operand.t,
1783                     size: Size.t,
1784                     pop: bool}
1785         (* Floating-point unary arithmetic instructions.
1786          *)
1787         | FUnA of {oper: funa}
1788         (* Floating-point partial tangent instruction.
1789          *)
1790         | FPTAN
1791         (* Floating-point binary arithmetic stack instructions.
1792          *)
1793         | FBinAS of {oper: fbinas}
1794         (* Floating-point binary arithmetic stack pop instructions.
1795          *)
1796         | FBinASP of {oper: fbinasp}
1797
1798       val layout
1799         = let
1800             open Layout
1801             fun bin (oper, size, oper1, oper2)
1802               = seq [oper,
1803                      size,
1804                      str " ",
1805                      oper1,
1806                      str ",",
1807                      oper2]
1808             fun un (oper, size, oper1)
1809               = seq [oper,
1810                      size,
1811                      str " ",
1812                      oper1]
1813           in
1814             fn NOP
1815              => str "nop"
1816              | HLT
1817              => str "hlt"
1818              | BinAL {oper, src, dst, size}
1819              => bin (binal_layout oper,
1820                      Size.layout size,
1821                      Operand.layout src,
1822                      Operand.layout dst)
1823              | pMD {oper, src, dst, size}
1824              => bin (md_layout oper,
1825                      Size.layout size,
1826                      Operand.layout src,
1827                      Operand.layout dst)
1828              | MD {oper, src, size}
1829              => un (md_layout oper,
1830                     Size.layout size,
1831                     Operand.layout src)
1832              | IMUL2 {src, dst, size}
1833              => bin (str "imul",
1834                      Size.layout size,
1835                      Operand.layout src,
1836                      Operand.layout dst)
1837              | UnAL {oper, dst, size}
1838              => un (unal_layout oper,
1839                     Size.layout size,
1840                     Operand.layout dst)
1841              | SRAL {oper, count, dst, size}
1842              => bin (sral_layout oper,
1843                      Size.layout size,
1844                      Operand.layout count,
1845                      Operand.layout dst)
1846              | CMP {src1, src2, size}
1847              => bin (str "cmp",
1848                      Size.layout size,
1849                      Operand.layout src2,
1850                      Operand.layout src1)
1851              | TEST {src1, src2, size}
1852              => bin (str "test",
1853                      Size.layout size,
1854                      Operand.layout src2,
1855                      Operand.layout src1)
1856              | SETcc {condition, dst, ...}
1857              => seq [str "set",
1858                      condition_layout condition,
1859                      str " ",
1860                      Operand.layout dst]
1861              | JMP {target, absolute}
1862              => seq [str "jmp ",
1863                      if absolute then str "*" else empty,
1864                      Operand.layout target]
1865              | Jcc {condition, target}
1866              => seq [str "j",
1867                      condition_layout condition,
1868                      str " ",
1869                      Operand.layout target]
1870              | CALL {target, absolute}
1871              => seq [str "call ",
1872                      if absolute then str "*" else empty,
1873                      Operand.layout target]
1874              | RET {src}
1875              => seq [str "ret",
1876                      case src
1877                        of NONE => empty
1878                         | SOME src => seq [str " ", Operand.layout src]]
1879              | MOV {src, dst, size}
1880              => bin (str "mov",
1881                      Size.layout size,
1882                      Operand.layout src,
1883                      Operand.layout dst)
1884              | CMOVcc {condition, src, dst, size}
1885              => seq [str "cmov",
1886                      condition_layout condition,
1887                      Size.layout size,
1888                      str " ",
1889                      Operand.layout src,
1890                      str ",",
1891                      Operand.layout dst]
1892              | XCHG {src, dst, size}
1893              => bin (str "xchg",
1894                      Size.layout size,
1895                      Operand.layout src,
1896                      Operand.layout dst)
1897              | pPUSH {src, base, size}
1898              => seq [str "ppush",
1899                      Size.layout size,
1900                      str " [",
1901                      Operand.layout base,
1902                      str "] ",
1903                      Operand.layout src]
1904              | pPOP {dst, base, size}
1905              => seq [str "ppop",
1906                      Size.layout size,
1907                      str " [",
1908                      Operand.layout base,
1909                      str " ]",
1910                      Operand.layout dst]
1911              | PUSH {src, size}
1912              => seq [str "push",
1913                      Size.layout size,
1914                      str " ",
1915                      Operand.layout src]
1916              | POP {dst, size}
1917              => seq [str "pop",
1918                      Size.layout size,
1919                      str " ",
1920                      Operand.layout dst]
1921              | CX {size}
1922              => (case size
1923                    of Size.BYTE => str "cbtw"
1924                     | Size.WORD => str "cwtd"
1925                     | Size.LONG => str "cltd"
1926                     | _ => Error.bug "x86.Instruction.layout: CX,unsupported conversion")
1927              | MOVX {oper, src, srcsize, dst, dstsize}
1928              => bin (movx_layout oper,
1929                      seq [Size.layout srcsize,
1930                           Size.layout dstsize],
1931                      Operand.layout src,
1932                      Operand.layout dst)
1933              | XVOM {src, srcsize, dst, dstsize}
1934              => bin (str "xvom",
1935                      seq [Size.layout srcsize,
1936                           Size.layout dstsize],
1937                      Operand.layout src,
1938                      Operand.layout dst)
1939              | LEA {src, dst, size}
1940              => bin (str "lea",
1941                      Size.layout size,
1942                      Operand.layout src,
1943                      Operand.layout dst)
1944              | pFMOV {src, dst, size}
1945              => bin (str "fmov",
1946                      Size.layout size,
1947                      Operand.layout src,
1948                      Operand.layout dst)
1949              | pFMOVX {src, dst, srcsize, dstsize}
1950              => bin (str "fmovx",
1951                      seq [Size.layout srcsize,
1952                           Size.layout dstsize],
1953                      Operand.layout src,
1954                      Operand.layout dst)
1955              | pFXVOM {src, dst, srcsize, dstsize}
1956              => bin (str "fmov",
1957                      seq [Size.layout srcsize,
1958                           Size.layout dstsize],
1959                      Operand.layout src,
1960                      Operand.layout dst)
1961              | pFLDC {oper, dst, size}
1962              => un (fldc_layout oper,
1963                     Size.layout size,
1964                     Operand.layout dst)
1965              | pFMOVFI {src, dst, srcsize, dstsize}
1966              => bin (str "fmovfi",
1967                      seq [Size.layout srcsize,
1968                           Size.layout dstsize],
1969                      Operand.layout src,
1970                      Operand.layout dst)
1971              | pFMOVTI {src, dst, srcsize, dstsize}
1972              => bin (str "fmovti",
1973                      seq [Size.layout srcsize,
1974                           Size.layout dstsize],
1975                      Operand.layout src,
1976                      Operand.layout dst)
1977              | pFCOM {src1, src2, size}
1978              => bin (str "fcom",
1979                      Size.layout size,
1980                      Operand.layout src1,
1981                      Operand.layout src2)
1982              | pFUCOM {src1, src2, size}
1983              => bin (str "fucom",
1984                      Size.layout size,
1985                      Operand.layout src1,
1986                      Operand.layout src2)
1987              | pFBinA {oper, src, dst, size}
1988              => bin (fbina_layout oper,
1989                      Size.layout size,
1990                      Operand.layout src,
1991                      Operand.layout dst)
1992              | pFUnA {oper, dst, size}
1993              => un (funa_layout oper,
1994                     Size.layout size,
1995                     Operand.layout dst)
1996              | pFPTAN {dst, size}
1997              => un (str "fptan",
1998                     Size.layout size,
1999                     Operand.layout dst)
2000              | pFBinAS {oper, src, dst, size}
2001              => bin (fbinas_layout oper,
2002                      Size.layout size,
2003                      Operand.layout src,
2004                      Operand.layout dst)
2005              | pFBinASP {oper, src, dst, size}
2006              => bin (fbinasp_layout oper,
2007                      Size.layout size,
2008                      Operand.layout src,
2009                      Operand.layout dst)
2010              | FLD {src, size}
2011              => un (str "fld",
2012                     case src
2013                       of Operand.FltRegister _ => empty
2014                        | _ => Size.layout size,
2015                     Operand.layout src)
2016              | FST {dst, size, pop}
2017              => un (str "fst",
2018                     seq [if pop then str "p" else empty,
2019                          case dst
2020                            of Operand.FltRegister _ => empty
2021                             | _ => Size.layout size],
2022                     Operand.layout dst)
2023              | FILD {src, size}
2024              => un (str "fild",
2025                     Size.layout size,
2026                     Operand.layout src)
2027              | FIST {dst, size, pop}
2028              => un (str "fist",
2029                     seq [if pop then str "p" else empty,
2030                          Size.layout size],
2031                     Operand.layout dst)
2032              | FXCH {src}
2033              => seq [str "fxch ",
2034                      Operand.layout src]
2035              | FLDC {oper}
2036              => seq [fldc_layout oper]
2037              | FLDCW {src}
2038              => seq [str "fldcw ",
2039                      Operand.layout src]
2040              | FSTCW {dst, check}
2041              => seq [if check then str "fstcw " else str "fnstcw ",
2042                      Operand.layout dst]
2043              | FSTSW {dst, check}
2044              => seq [if check then str "fstsw " else str "fnstsw ",
2045                      Operand.layout dst]
2046              | FCOM {src, size, pop, pop'}
2047              => seq [str "fcom",
2048                      if pop andalso pop'
2049                        then str "pp"
2050                        else seq [if pop then str "p" else empty,
2051                                  case src
2052                                    of Operand.FltRegister _
2053                                     => empty
2054                                     | _ => Size.layout size,
2055                                  str " ",
2056                                  Operand.layout src]]
2057              | FUCOM {src, pop, pop'}
2058              => seq [str "fucom",
2059                      if pop andalso pop'
2060                        then str "pp"
2061                        else seq [if pop then str "p " else str " ",
2062                                  Operand.layout src]]
2063              | FBinA {oper, src, dst, size, pop}
2064              => seq [fbina_layout oper,
2065                      case src
2066                        of Operand.FltRegister _
2067                         => seq [if pop then str "p " else str " ",
2068                                 Operand.layout src,
2069                                 str ", ",
2070                                 Operand.layout dst]
2071                         | _
2072                         => seq [Size.layout size,
2073                                 str " ",
2074                                 Operand.layout src]]
2075              | FUnA {oper}
2076              => seq [funa_layout oper]
2077              | FPTAN
2078              => seq [str "fptan"]
2079              | FBinAS {oper}
2080              => seq [fbinas_layout oper]
2081              | FBinASP {oper}
2082              => seq [fbinasp_layout oper]
2083           end
2084       val toString = Layout.toString o layout
2085
2086       val uses_defs_kills
2087         = fn NOP
2088            => {uses = [], defs = [], kills = []}
2089            | HLT
2090            => {uses = [], defs = [], kills = []}
2091            | BinAL {src, dst, ...}
2092            => {uses = [src, dst], defs = [dst], kills = []}
2093            | pMD {src, dst, ...}
2094            => {uses = [src, dst], defs = [dst], kills = []}
2095            | MD {oper, src, size}
2096            => let
2097                 val (hi,lo)
2098                   = case size
2099                       of Size.BYTE
2100                        => (Register.T {reg = Register.EAX, part = Register.H},
2101                            Register.T {reg = Register.EAX, part = Register.L})
2102                        | Size.WORD
2103                        => (Register.T {reg = Register.EDX, part = Register.X},
2104                            Register.T {reg = Register.EAX, part = Register.X})
2105                        | Size.LONG
2106                        => (Register.T {reg = Register.EDX, part = Register.E},
2107                            Register.T {reg = Register.EAX, part = Register.E})
2108                        | _ => Error.bug "x86.Instruction.uses_defs: MD, size"
2109               in
2110                 if oper = IMUL orelse oper = MUL
2111                   then {uses = [src, Operand.register lo],
2112                         defs = [Operand.register hi, Operand.register lo],
2113                         kills = []}
2114                   else {uses = [src, Operand.register hi, Operand.register lo],
2115                         defs = [Operand.register hi, Operand.register lo],
2116                         kills = []}
2117               end
2118            | IMUL2 {src, dst, ...}
2119            => {uses = [src, dst], defs = [dst], kills = []}
2120            | UnAL {dst, ...}
2121            => {uses = [dst], defs = [dst], kills = []}
2122            | SRAL {count, dst, size, ...}
2123            => if isSome (Operand.deMemloc count)
2124                 then let
2125                        val reg
2126                          = case size
2127                              of Size.BYTE
2128                                => Register.T {reg = Register.ECX,
2129                                               part = Register.L}
2130                                | Size.WORD
2131                                => Register.T {reg = Register.ECX,
2132                                               part = Register.X}
2133                                | Size.LONG
2134                                => Register.T {reg = Register.ECX,
2135                                               part = Register.E}
2136                                | _ => Error.bug "x86.Instruction.uses_defs: SRAL, size"
2137                      in
2138                        {uses = [count, dst, Operand.register reg],
2139                         defs = [dst],
2140                         kills = []}
2141                      end
2142                 else {uses = [count, dst],
2143                       defs = [dst],
2144                       kills = []}
2145            | CMP {src1, src2, ...}
2146            => {uses = [src1, src2], defs = [], kills = []}
2147            | TEST {src1, src2, ...}
2148            => {uses = [src1, src2], defs = [], kills = []}
2149            | SETcc {dst, ...}
2150            => {uses = [], defs = [dst], kills = []}
2151            | JMP {target, ...}
2152            => {uses = [target], defs = [], kills = []}
2153            | Jcc {target, ...}
2154            => {uses = [target], defs = [], kills = []}
2155            | CALL {target, ...}
2156            => {uses = [target], defs = [], kills = []}
2157            | RET {src}
2158            => {uses = case src of NONE => [] | SOME src => [src],
2159                defs = [],
2160                kills = []}
2161            | MOV {src, dst, ...}
2162            => {uses = [src], defs = [dst], kills = []}
2163            | CMOVcc {src, dst, ...}
2164            => {uses = [src], defs = [dst], kills = []}
2165            | XCHG {src, dst, ...}
2166            => {uses = [src,dst], defs = [src,dst], kills = []}
2167            | pPUSH {src, base, size, ...}
2168            => {uses = [src,base],
2169                defs = base::
2170                       (case base
2171                          of Operand.MemLoc base
2172                           => [Operand.MemLoc
2173                               (MemLoc.simple {base = base,
2174                                               index = Immediate.zero,
2175                                               size = size,
2176                                               scale = Scale.One,
2177                                               class = MemLoc.Class.CStack})]
2178                           | _ => []),
2179                kills = []}
2180            | pPOP {dst, base, size, ...}
2181            => {uses = base::
2182                       (case base
2183                          of Operand.MemLoc base
2184                           => [Operand.MemLoc
2185                               (MemLoc.simple {base = base,
2186                                               index = Immediate.zero,
2187                                               size = size,
2188                                               scale = Scale.One,
2189                                               class = MemLoc.Class.CStack})]
2190                           | _ => []),
2191                defs = [dst,base],
2192                kills = []}
2193            | PUSH {src, ...}
2194            => {uses = [src, Operand.register Register.esp],
2195                defs = [Operand.register Register.esp,
2196                        Operand.address (Address.T {disp = NONE,
2197                                                    base = SOME Register.esp,
2198                                                    index = NONE,
2199                                                    scale = NONE})],
2200                kills = []}
2201            | POP {dst, ...}
2202            => {uses = [Operand.register Register.esp,
2203                        Operand.address (Address.T {disp = NONE,
2204                                                    base = SOME Register.esp,
2205                                                    index = NONE,
2206                                                    scale = NONE})],
2207                defs = [dst, Operand.register Register.esp],
2208                kills = []}
2209            | CX {size}
2210            => let
2211                 val (hi,lo)
2212                   = case size
2213                       of Size.BYTE
2214                        => (Register.T {reg = Register.EAX, part = Register.H},
2215                            Register.T {reg = Register.EAX, part = Register.L})
2216                        | Size.WORD
2217                        => (Register.T {reg = Register.EDX, part = Register.X},
2218                            Register.T {reg = Register.EAX, part = Register.X})
2219                        | Size.LONG
2220                        => (Register.T {reg = Register.EDX, part = Register.E},
2221                            Register.T {reg = Register.EAX, part = Register.E})
2222                        | _ => Error.bug "x86.Instruction.uses_defs: CX, size"
2223               in
2224                 {uses = [Operand.register lo],
2225                  defs = [Operand.register hi, Operand.register lo],
2226                  kills = []}
2227               end
2228            | MOVX {src, dst, ...}
2229            => {uses = [src], defs = [dst], kills = []}
2230            | XVOM {src, dst, ...}
2231            => {uses = [src], defs = [dst], kills = []}
2232            | LEA {src, dst, ...}
2233            => {uses = [src], defs = [dst], kills = []}
2234            | pFMOV {src, dst, ...}
2235            => {uses = [src], defs = [dst], kills = []}
2236            | pFMOVX {src, dst, ...}
2237            => {uses = [src], defs = [dst], kills = []}
2238            | pFXVOM {src, dst, ...}
2239            => {uses = [src], defs = [dst], kills = []}
2240            | pFLDC {dst, ...}
2241            => {uses = [], defs = [dst], kills = []}
2242            | pFMOVFI {src, dst, ...}
2243            => {uses = [src], defs = [dst], kills = []}
2244            | pFMOVTI {src, dst, ...}
2245            => {uses = [src], defs = [dst], kills = []}
2246            | pFCOM {src1, src2, ...}
2247            => {uses = [src1, src2], defs = [], kills = []}
2248            | pFUCOM {src1, src2, ...}
2249            => {uses = [src1, src2], defs = [], kills = []}
2250            | pFBinA {src, dst, ...}
2251            => {uses = [src, dst], defs = [dst], kills = []}
2252            | pFUnA {dst, ...}
2253            => {uses = [dst], defs = [dst], kills = []}
2254            | pFPTAN {dst, ...}
2255            => {uses = [dst], defs = [dst], kills = []}
2256            | pFBinAS {src, dst, ...}
2257            => {uses = [src, dst], defs = [dst], kills = []}
2258            | pFBinASP {src, dst, ...}
2259            => {uses = [src, dst],
2260                defs = [dst],
2261                kills = if Operand.eq(src,dst)
2262                          then []
2263                          else [src]}
2264            | FLD {src, ...}
2265            => {uses = [src],
2266                defs = [Operand.fltregister FltRegister.top],
2267                kills = []}
2268            | FST {dst, pop, ...}
2269            => {uses = [Operand.fltregister FltRegister.top],
2270                defs = [dst],
2271                kills = if pop
2272                          then [Operand.fltregister FltRegister.top]
2273                          else []}
2274            | FILD {src, ...}
2275            => {uses = [src],
2276                defs = [Operand.fltregister FltRegister.top],
2277                kills = []}
2278            | FIST {dst, pop, ...}
2279            => {uses = [Operand.fltregister FltRegister.top],
2280                defs = [dst],
2281                kills = if pop
2282                          then [Operand.fltregister FltRegister.top]
2283                          else []}
2284            | FXCH {src}
2285            => {uses = [src, Operand.fltregister FltRegister.top],
2286                defs = [src, Operand.fltregister FltRegister.top],
2287                kills = []}
2288            | FLDC {...}
2289            => {uses = [],
2290                defs = [Operand.fltregister FltRegister.top],
2291                kills = []}
2292            | FLDCW {src}
2293            => {uses = [src], defs = [], kills = []}
2294            | FSTCW {dst, ...}
2295            => {uses = [], defs = [dst], kills = []}
2296            | FSTSW {dst, ...}
2297            => {uses = [], defs = [dst], kills = []}
2298            | FCOM {src, pop, pop', ...}
2299            => {uses = [src, Operand.fltregister FltRegister.top],
2300                defs = [],
2301                kills = if pop andalso pop'
2302                          then [Operand.fltregister FltRegister.top, src]
2303                        else if pop
2304                          then [Operand.fltregister FltRegister.top]
2305                        else []}
2306            | FUCOM {src, pop, pop'}
2307            => {uses = [src, Operand.fltregister FltRegister.top],
2308                defs = [],
2309                kills = if pop andalso pop'
2310                          then [Operand.fltregister FltRegister.top, src]
2311                        else if pop
2312                          then [Operand.fltregister FltRegister.top]
2313                        else []}
2314            | FBinA {src, dst, pop, ...}
2315            => {uses = [src, dst],
2316                defs = [dst],
2317                kills = if pop then [src] else []}
2318            | FUnA {...}
2319            => {uses = [Operand.fltregister FltRegister.top],
2320                defs = [Operand.fltregister FltRegister.top], kills = []}
2321            | FPTAN
2322            => {uses = [Operand.fltregister FltRegister.top],
2323                defs = [Operand.fltregister FltRegister.top], kills = []}
2324            | FBinAS {...}
2325            => {uses = [Operand.fltregister FltRegister.top,
2326                        Operand.fltregister FltRegister.one],
2327                defs = [Operand.fltregister FltRegister.top,
2328                        Operand.fltregister FltRegister.one],
2329                kills = []}
2330            | FBinASP {...}
2331            => {uses = [Operand.fltregister FltRegister.top,
2332                        Operand.fltregister FltRegister.one],
2333                defs = [Operand.fltregister FltRegister.one],
2334                kills = [Operand.fltregister FltRegister.top]}
2335
2336       val hints
2337         = fn pMD {dst, size, ...}
2338            => let
2339                 val (hi,lo)
2340                   = case size
2341                       of Size.BYTE
2342                        => (Register.T {reg = Register.EAX, part = Register.H},
2343                            Register.T {reg = Register.EAX, part = Register.L})
2344                        | Size.WORD
2345                        => (Register.T {reg = Register.EDX, part = Register.X},
2346                            Register.T {reg = Register.EAX, part = Register.X})
2347                        | Size.LONG
2348                        => (Register.T {reg = Register.EDX, part = Register.E},
2349                            Register.T {reg = Register.EAX, part = Register.E})
2350                        | _ => Error.bug "x86.Instruction.hints: MD, size"
2351
2352                 val temp = MemLoc.temp {size = size}
2353               in
2354                 [(temp, hi),
2355                  (case Operand.deMemloc dst
2356                     of SOME memloc => (memloc, lo)
2357                      | NONE => (temp, lo))]
2358               end
2359           | MD {src, size, ...}
2360            => let
2361                 val (hi,lo)
2362                   = case size
2363                       of Size.BYTE
2364                        => (Register.T {reg = Register.EAX, part = Register.H},
2365                            Register.T {reg = Register.EAX, part = Register.L})
2366                        | Size.WORD
2367                        => (Register.T {reg = Register.EDX, part = Register.X},
2368                            Register.T {reg = Register.EAX, part = Register.X})
2369                        | Size.LONG
2370                        => (Register.T {reg = Register.EDX, part = Register.E},
2371                            Register.T {reg = Register.EAX, part = Register.E})
2372                        | _ => Error.bug "x86.Instruction.hints: MD, size"
2373
2374                 val temp = MemLoc.temp {size = size}
2375               in
2376                 [(temp, hi),
2377                  (case Operand.deMemloc src
2378                     of SOME memloc => (memloc, lo)
2379                      | NONE => (temp, lo))]
2380               end
2381            | SRAL {count, size, ...}
2382            => (case Operand.deMemloc count
2383                  of SOME memloc
2384                   => let
2385                        val reg
2386                          = case size
2387                              of Size.BYTE
2388                                => Register.T {reg = Register.ECX,
2389                                               part = Register.L}
2390                                | Size.WORD
2391                                => Register.T {reg = Register.ECX,
2392                                               part = Register.X}
2393                                | Size.LONG
2394                                => Register.T {reg = Register.ECX,
2395                                               part = Register.E}
2396                                | _ => Error.bug "x86.Instruction.hints: SRAL, size"
2397                      in
2398                        [(memloc, reg)]
2399                      end
2400                   | NONE => [])
2401            | pPUSH {base, ...}
2402            => (case Operand.deMemloc base
2403                  of SOME base => [(base,Register.esp)]
2404                   | NONE => [])
2405            | pPOP {base, ...}
2406            => (case Operand.deMemloc base
2407                  of SOME base => [(base,Register.esp)]
2408                   | NONE => [])
2409            | PUSH {...}
2410            => let
2411                 val temp = MemLoc.temp {size = Size.LONG}
2412               in
2413                 [(temp,Register.esp)]
2414               end
2415            | POP {...}
2416            => let
2417                 val temp = MemLoc.temp {size = Size.LONG}
2418               in
2419                 [(temp,Register.esp)]
2420               end
2421            | _ => []
2422
2423       val srcs_dsts
2424         = fn NOP
2425            => {srcs = NONE, dsts = NONE}
2426            | HLT
2427            => {srcs = NONE, dsts = NONE}
2428            | BinAL {src, dst, ...}
2429            => {srcs = SOME [src, dst], dsts = SOME [dst]}
2430            | pMD {src, dst, ...}
2431            => {srcs = SOME [src, dst], dsts = SOME [dst]}
2432            | MD {oper, src, size, ...}
2433            => let
2434                 val (hi,lo)
2435                   = case size
2436                       of Size.BYTE
2437                        => (Register.T {reg = Register.EAX, part = Register.H},
2438                            Register.T {reg = Register.EAX, part = Register.L})
2439                        | Size.WORD
2440                        => (Register.T {reg = Register.EDX, part = Register.X},
2441                            Register.T {reg = Register.EAX, part = Register.X})
2442                        | Size.LONG
2443                        => (Register.T {reg = Register.EDX, part = Register.E},
2444                            Register.T {reg = Register.EAX, part = Register.E})
2445                        | _ => Error.bug "x86.Instruction.srcs_dsts: MD, size"
2446               in
2447                 if oper = IMUL orelse oper = MUL
2448                   then {srcs = SOME [src,
2449                                      Operand.register lo],
2450                         dsts = SOME [Operand.register hi,
2451                                      Operand.register lo]}
2452                   else {srcs = SOME [src,
2453                                      Operand.register hi,
2454                                      Operand.register lo],
2455                         dsts = SOME [Operand.register hi,
2456                                      Operand.register lo]}
2457               end
2458            | IMUL2 {src, dst, ...}
2459            => {srcs = SOME [src, dst], dsts = SOME [dst]}
2460            | UnAL {dst, ...}
2461            => {srcs = SOME [dst], dsts = SOME [dst]}
2462            | SRAL {count, dst, size, ...}
2463            => if isSome (Operand.deMemloc count)
2464                 then let
2465                        val reg
2466                          = case size
2467                              of Size.BYTE
2468                                => Register.T {reg = Register.ECX,
2469                                               part = Register.L}
2470                                | Size.WORD
2471                                => Register.T {reg = Register.ECX,
2472                                               part = Register.X}
2473                                | Size.LONG
2474                                => Register.T {reg = Register.ECX,
2475                                               part = Register.E}
2476                                | _ => Error.bug "x86.Instruction.srcs_dsts: SRAL, size"
2477                      in
2478                        {srcs = SOME [count, dst, Operand.register reg],
2479                         dsts = SOME [dst]}
2480                      end
2481                 else {srcs = SOME [count, dst],
2482                       dsts = SOME [dst]}
2483            | CMP {src1, src2, ...}
2484            => {srcs = SOME [src1, src2], dsts = NONE}
2485            | TEST {src1, src2, ...}
2486            => {srcs = SOME [src1, src2], dsts = NONE}
2487            | SETcc {dst, ...}
2488            => {srcs = NONE, dsts = SOME [dst]}
2489            | JMP {target, ...}
2490            => {srcs = SOME [target], dsts = NONE}
2491            | Jcc {target, ...}
2492            => {srcs = SOME [target], dsts = NONE}
2493            | CALL {target, ...}
2494            => {srcs = SOME [target], dsts = NONE}
2495            | RET {src}
2496            => {srcs = case src of NONE => NONE | SOME src => SOME [src],
2497                dsts = NONE}
2498            | MOV {src, dst, ...}
2499            => {srcs = SOME [src], dsts = SOME [dst]}
2500            | CMOVcc {src, dst, ...}
2501            => {srcs = SOME [src], dsts = SOME [dst]}
2502            | XCHG {src, dst, ...}
2503            => {srcs = SOME [src,dst], dsts = SOME [src,dst]}
2504            | pPUSH {src, base, ...}
2505            => {srcs = SOME [src,base], dsts = SOME [base]}
2506            | pPOP {dst, base, ...}
2507            => {srcs = SOME [base], dsts = SOME [dst,base]}
2508            | PUSH {src, ...}
2509            => {srcs = SOME [src, Operand.register Register.esp],
2510                dsts = SOME [Operand.register Register.esp]}
2511            | POP {dst, ...}
2512            => {srcs = SOME [Operand.register Register.esp],
2513                dsts = SOME [dst, Operand.register Register.esp]}
2514            | CX {size, ...}
2515            => let
2516                 val (hi,lo)
2517                   = case size
2518                       of Size.BYTE
2519                        => (Register.T {reg = Register.EAX, part = Register.H},
2520                            Register.T {reg = Register.EAX, part = Register.L})
2521                        | Size.WORD
2522                        => (Register.T {reg = Register.EDX, part = Register.X},
2523                            Register.T {reg = Register.EAX, part = Register.X})
2524                        | Size.LONG
2525                        => (Register.T {reg = Register.EDX, part = Register.E},
2526                            Register.T {reg = Register.EAX, part = Register.E})
2527                        | _ => Error.bug "x86.Instruction.srcs_dsts: CX, size"
2528               in
2529                 {srcs = SOME [Operand.register lo],
2530                  dsts = SOME [Operand.register hi, Operand.register lo]}
2531               end
2532            | MOVX {src, dst, ...}
2533            => {srcs = SOME [src], dsts = SOME [dst]}
2534            | XVOM {src, dst, ...}
2535            => {srcs = SOME [src], dsts = SOME [dst]}
2536            | LEA {src, dst, ...}
2537            => {srcs = SOME [src], dsts = SOME [dst]}
2538            | pFMOV {src, dst, ...}
2539            => {srcs = SOME [src], dsts = SOME [dst]}
2540            | pFMOVX {src, dst, ...}
2541            => {srcs = SOME [src], dsts = SOME [dst]}
2542            | pFXVOM {src, dst, ...}
2543            => {srcs = SOME [src], dsts = SOME [dst]}
2544            | pFLDC {dst, ...}
2545            => {srcs = SOME [], dsts = SOME [dst]}
2546            | pFMOVFI {src, dst, ...}
2547            => {srcs = SOME [src], dsts = SOME [dst]}
2548            | pFMOVTI {src, dst, ...}
2549            => {srcs = SOME [src], dsts = SOME [dst]}
2550            | pFCOM {src1, src2, ...}
2551            => {srcs = SOME [src1, src2], dsts = NONE}
2552            | pFUCOM {src1, src2, ...}
2553            => {srcs = SOME [src1, src2], dsts = NONE}
2554            | pFBinA {src, dst, ...}
2555            => {srcs = SOME [src, dst], dsts = SOME [dst]}
2556            | pFUnA {dst, ...}
2557            => {srcs = SOME [dst], dsts = SOME [dst]}
2558            | pFPTAN {dst, ...}
2559            => {srcs = SOME [dst], dsts = SOME [dst]}
2560            | pFBinAS {src, dst, ...}
2561            => {srcs = SOME [src, dst], dsts = SOME [dst]}
2562            | pFBinASP {src, dst, ...}
2563            => {srcs = SOME [src, dst],
2564                dsts = SOME [dst]}
2565            | FLD {src, ...}
2566            => {srcs = SOME [src],
2567                dsts = SOME [Operand.fltregister FltRegister.top]}
2568            | FST {dst, ...}
2569            => {srcs = SOME [Operand.fltregister FltRegister.top],
2570                dsts = SOME [dst]}
2571            | FILD {src, ...}
2572            => {srcs = SOME [src],
2573                dsts = SOME [Operand.fltregister FltRegister.top]}
2574            | FIST {dst, ...}
2575            => {srcs = SOME [Operand.fltregister FltRegister.top],
2576                dsts = SOME [dst]}
2577            | FXCH {src}
2578            => {srcs = SOME [src, Operand.fltregister FltRegister.top],
2579                dsts = SOME [src, Operand.fltregister FltRegister.top]}
2580            | FLDC {...}
2581            => {srcs = NONE,
2582                dsts = SOME [Operand.fltregister FltRegister.top]}
2583            | FLDCW {src}
2584            => {srcs = SOME [src], dsts = NONE}
2585            | FSTCW {dst, ...}
2586            => {srcs = NONE, dsts = SOME [dst]}
2587            | FSTSW {dst, ...}
2588            => {srcs = NONE, dsts = SOME [dst]}
2589            | FCOM {src, ...}
2590            => {srcs = SOME [src, Operand.fltregister FltRegister.top],
2591                dsts = NONE}
2592            | FUCOM {src, ...}
2593            => {srcs = SOME [src, Operand.fltregister FltRegister.top],
2594                dsts = NONE}
2595            | FBinA {src, dst, ...}
2596            => {srcs = SOME [src, dst],
2597                dsts = SOME [dst]}
2598            | FUnA {...}
2599            => {srcs = SOME [Operand.fltregister FltRegister.top],
2600                dsts = SOME [Operand.fltregister FltRegister.top]}
2601            | FPTAN
2602            => {srcs = SOME [Operand.fltregister FltRegister.top],
2603                dsts = SOME [Operand.fltregister FltRegister.top]}
2604            | FBinAS {...}
2605            => {srcs = SOME [Operand.fltregister FltRegister.top,
2606                             Operand.fltregister FltRegister.one],
2607                dsts = SOME [Operand.fltregister FltRegister.top,
2608                             Operand.fltregister FltRegister.one]}
2609            | FBinASP {...}
2610            => {srcs = SOME [Operand.fltregister FltRegister.top,
2611                             Operand.fltregister FltRegister.one],
2612                dsts = SOME [Operand.fltregister FltRegister.one]}
2613
2614       fun replace replacer
2615         = fn NOP
2616            => NOP
2617            | HLT
2618            => HLT
2619            | BinAL {oper, src, dst, size}
2620            => BinAL {oper = oper,
2621                      src = replacer {use = true, def = false} src,
2622                      dst = replacer {use = true, def = true} dst,
2623                      size = size}
2624            | pMD {oper, src, dst, size}
2625            => pMD {oper = oper,
2626                    src = replacer {use = true, def = false} src,
2627                    dst = replacer {use = true, def = true} dst,
2628                    size = size}
2629            | MD {oper, src, size}
2630            => MD {oper = oper,
2631                   src = replacer {use = true, def = false} src,
2632                   size = size}
2633            | IMUL2 {src, dst, size}
2634            => IMUL2 {src = replacer {use = true, def = false} src,
2635                      dst = replacer {use = true, def = true} dst,
2636                      size = size}
2637            | UnAL {oper, dst, size}
2638            => UnAL {oper = oper,
2639                     dst = replacer {use = true, def = true} dst,
2640                     size = size}
2641            | SRAL {oper, count, dst, size}
2642            => SRAL {oper = oper,
2643                     count = replacer {use = true, def = false} count,
2644                     dst = replacer {use = true, def = true} dst,
2645                     size = size}
2646            | CMP {src1, src2, size}
2647            => CMP {src1 = replacer {use = true, def = false} src1,
2648                    src2 = replacer {use = true, def = false} src2,
2649                    size = size}
2650            | TEST {src1, src2, size}
2651            => TEST {src1 = replacer {use = true, def = false} src1,
2652                     src2 = replacer {use = true, def = false} src2,
2653                     size = size}
2654            | SETcc {condition, dst, size}
2655            => SETcc {condition = condition,
2656                      dst = replacer {use = false, def = true} dst,
2657                      size = size}
2658            | JMP {target, absolute}
2659            => JMP {target = replacer {use = true, def = false} target,
2660                    absolute = absolute}
2661            | Jcc {condition, target}
2662            => Jcc {condition = condition,
2663                    target = replacer {use = true, def = false} target}
2664            | CALL {target, absolute}
2665            => CALL {target = replacer {use = true, def = false} target,
2666                     absolute = absolute}
2667            | RET {src}
2668            => (case src
2669                  of NONE => RET {src = NONE}
2670                   | SOME src
2671                   => RET {src = SOME (replacer {use = true, def = false} src)})
2672            | MOV {src, dst, size}
2673            => MOV {src = replacer {use = true, def = false} src,
2674                    dst = replacer {use = false, def = true} dst,
2675                    size = size}
2676            | CMOVcc {condition, src, dst, size}
2677            => CMOVcc {condition = condition,
2678                       src = replacer {use = true, def = false} src,
2679                       dst = replacer {use = false, def = true} dst,
2680                       size = size}
2681            | XCHG {src, dst, size}
2682            => XCHG {src = replacer {use = true, def = true} src,
2683                     dst = replacer {use = true, def = true} dst,
2684                     size = size}
2685            | pPUSH {src, base, size}
2686            => pPUSH {src = replacer {use = true, def = false} src,
2687                      base = replacer {use = true, def = true} base,
2688                      size = size}
2689            | pPOP {dst, base, size}
2690            => pPOP {dst = replacer {use = false, def = true} dst,
2691                     base = replacer {use = true, def = true} base,
2692                     size = size}
2693            | PUSH {src, size}
2694            => PUSH {src = replacer {use = true, def = false} src,
2695                     size = size}
2696            | POP {dst, size}
2697            => POP {dst = replacer {use = false, def = true} dst,
2698                    size = size}
2699            | CX {size}
2700            => CX {size = size}
2701            | MOVX {oper, src, srcsize, dst, dstsize}
2702            => MOVX {oper = oper,
2703                     src = replacer {use = true, def = false} src,
2704                     srcsize = srcsize,
2705                     dst = replacer {use = false, def = true} dst,
2706                     dstsize = dstsize}
2707            | XVOM {src, srcsize, dst, dstsize}
2708            => XVOM {src = replacer {use = true, def = false} src,
2709                     srcsize = srcsize,
2710                     dst = replacer {use = false, def = true} dst,
2711                     dstsize = dstsize}
2712            | LEA {src, dst, size}
2713            => LEA {src = replacer {use = true, def = false} src,
2714                    dst = replacer {use = false, def = true} dst,
2715                    size = size}
2716            | pFMOV {src, dst, size}
2717            => pFMOV {src = replacer {use = true, def = false} src,
2718                      dst = replacer {use = false, def = true} dst,
2719                      size = size}
2720            | pFMOVX {src, dst, srcsize, dstsize}
2721            => pFMOVX {src = replacer {use = true, def = false} src,
2722                       dst = replacer {use = false, def = true} dst,
2723                       srcsize = srcsize, dstsize = dstsize}
2724            | pFXVOM {src, dst, srcsize, dstsize}
2725            => pFXVOM {src = replacer {use = true, def = false} src,
2726                       dst = replacer {use = false, def = true} dst,
2727                       srcsize = srcsize, dstsize = dstsize}
2728            | pFLDC {oper, dst, size}
2729            => pFLDC {oper = oper,
2730                      dst = replacer {use = false, def = true} dst,
2731                      size = size}
2732            | pFMOVFI {src, srcsize, dst, dstsize}
2733            => pFMOVFI {src = replacer {use = true, def = false} src,
2734                        srcsize = srcsize,
2735                        dst = replacer {use = false, def = true} dst,
2736                        dstsize = dstsize}
2737            | pFMOVTI {src, dst, srcsize, dstsize}
2738            => pFMOVTI {src = replacer {use = true, def = false} src,
2739                        srcsize = srcsize,
2740                        dst = replacer {use = false, def = true} dst,
2741                        dstsize = dstsize}
2742            | pFCOM {src1, src2, size}
2743            => pFCOM {src1 = replacer {use = true, def = false} src1,
2744                      src2 = replacer {use = true, def = false} src2,
2745                      size = size}
2746            | pFUCOM {src1, src2, size}
2747            => pFUCOM {src1 = replacer {use = true, def = false} src1,
2748                       src2 = replacer {use = true, def = false} src2,
2749                       size = size}
2750            | pFBinA {oper, src, dst, size}
2751            => pFBinA {oper = oper,
2752                       src = replacer {use = true, def = false} src,
2753                       dst = replacer {use = true, def = true} dst,
2754                       size = size}
2755            | pFUnA {oper, dst, size}
2756            => pFUnA {oper = oper,
2757                      dst = replacer {use = true, def = true} dst,
2758                      size = size}
2759            | pFPTAN {dst, size}
2760            => pFPTAN {dst = replacer {use = true, def = true} dst,
2761                       size = size}
2762            | pFBinAS {oper, src, dst, size}
2763            => pFBinAS {oper = oper,
2764                        src = replacer {use = true, def = false} src,
2765                        dst = replacer {use = true, def = true} dst,
2766                        size = size}
2767            | pFBinASP {oper, src, dst, size}
2768            => pFBinASP {oper = oper,
2769                         src = replacer {use = true, def = true} src,
2770                         dst = replacer {use = true, def = true} dst,
2771                         size = size}
2772            | FLD {src, size}
2773            => FLD {src = replacer {use = true, def = false} src,
2774                    size = size}
2775            | FST {dst, size, pop}
2776            => FST {dst = replacer {use = false, def = true} dst,
2777                    size = size,
2778                    pop = pop}
2779            | FILD {src, size}
2780            => FILD {src = replacer {use = true, def = false} src,
2781                     size = size}
2782            | FIST {dst, size, pop}
2783            => FIST {dst = replacer {use = false, def = true} dst,
2784                     size = size,
2785                     pop = pop}
2786            | FXCH {src}
2787            => FXCH {src = replacer {use = true, def = true} src}
2788            | FLDC {oper}
2789            => FLDC {oper = oper}
2790            | FLDCW {src}
2791            => FLDCW {src = replacer {use = true, def = false} src}
2792            | FSTCW {dst, check}
2793            => FSTCW {dst = replacer {use = false, def = true} dst,
2794                      check = check}
2795            | FSTSW {dst, check}
2796            => FSTSW {dst = replacer {use = false, def = true} dst,
2797                      check = check}
2798            | FCOM {src, size, pop, pop'}
2799            => FCOM {src = replacer {use = true, def = false} src,
2800                     size = size,
2801                     pop = pop,
2802                     pop' = pop'}
2803            | FUCOM {src, pop, pop'}
2804            => FUCOM {src = replacer {use = true, def = false} src,
2805                      pop = pop,
2806                      pop' = pop'}
2807            | FBinA {oper, src, dst, size, pop}
2808            => FBinA {oper = oper,
2809                      src = replacer {use = true, def = false} src,
2810                      dst = replacer {use = true, def = true} dst,
2811                      size = size,
2812                      pop = pop}
2813            | FUnA {oper}
2814            => FUnA {oper = oper}
2815            | FPTAN
2816            => FPTAN
2817            | FBinAS {oper}
2818            => FBinAS {oper = oper}
2819            | FBinASP {oper}
2820            => FBinASP {oper = oper}
2821
2822       val nop = fn () => NOP
2823       val hlt = fn () => HLT
2824       val binal = BinAL
2825       val pmd = pMD
2826       val md = MD
2827       val imul2 = IMUL2
2828       val unal = UnAL
2829       val sral = SRAL
2830       val cmp = CMP
2831       val test = TEST
2832       val setcc = SETcc
2833       val jmp = JMP
2834       val jcc = Jcc
2835       val call = CALL
2836       val ret = RET
2837       val mov = MOV
2838       val cmovcc = CMOVcc
2839       val xchg = XCHG
2840       val ppush = pPUSH
2841       val ppop = pPOP
2842       val push = PUSH
2843       val pop = POP
2844       val cx = CX
2845       val movx = MOVX
2846       val xvom = XVOM
2847       val lea = LEA
2848       val pfmov = pFMOV
2849       val pfmovx = pFMOVX
2850       val pfxvom = pFXVOM
2851       val pfldc = pFLDC
2852       val pfmovfi = pFMOVFI
2853       val pfmovti = pFMOVTI
2854       val pfcom = pFCOM
2855       val pfucom = pFUCOM
2856       val pfbina = pFBinA
2857       val pfuna = pFUnA
2858       val pfptan = pFPTAN
2859       val pfbinas = pFBinAS
2860       val pfbinasp = pFBinASP
2861       val fld = FLD
2862       val fst = FST
2863       val fild = FILD
2864       val fist = FIST
2865       val fxch = FXCH
2866       val fldc = FLDC
2867       val fldcw = FLDCW
2868       val fstcw = FSTCW
2869       val fstsw = FSTSW
2870       val fcom = FCOM
2871       val fucom = FUCOM
2872       val fbina = FBinA
2873       val funa = FUnA
2874       val fptan = fn () => FPTAN
2875       val fbinas = FBinAS
2876       val fbinasp = FBinASP
2877     end
2878
2879   structure Directive =
2880     struct
2881       structure Id =
2882         struct
2883           val num : int ref = ref 0
2884           datatype t = T of {num : int,
2885                              plist: PropertyList.t}
2886           fun new () = let
2887                          val id = T {num = !num,
2888                                      plist = PropertyList.new ()}
2889                          val _ = Int.inc num
2890                        in
2891                          id
2892                        end
2893           val plist = fn T {plist, ...} => plist
2894           val layout
2895             = let
2896                 open Layout
2897               in
2898                 fn T {num, ...} => seq [str "RegAlloc", Int.layout num]
2899               end
2900           val toString = Layout.toString o layout
2901         end
2902
2903       datatype t
2904         (* Transfers *)
2905           (* Assert that a memloc is in a register with properties;
2906            * used at top of basic blocks to establish passing convention.
2907            *)
2908         = Assume of {assumes: {register: Register.t,
2909                                memloc: MemLoc.t,
2910                                weight: int,
2911                                sync: bool,
2912                                reserve: bool} list}
2913         | FltAssume of {assumes: {memloc: MemLoc.t,
2914                                   weight: int,
2915                                   sync: bool} list}
2916           (* Ensure that memloc is in the register, possibly reserverd;
2917            * used at bot of basic blocks to establish passing convention,
2918            * also used before C calls to set-up %esp.
2919            *)
2920         | Cache of {caches: {register: Register.t,
2921                              memloc: MemLoc.t,
2922                              reserve: bool} list}
2923         | FltCache of {caches: {memloc: MemLoc.t} list}
2924           (* Reset the register allocation;
2925            * used at bot of basic blocks that fall-thru
2926            * to a block with multiple incoming paths of control.
2927            *)
2928         | Reset
2929           (* Ensure that memlocs are commited to memory;
2930            * used at bot of basic blocks to establish passing conventions
2931            *)
2932         | Force of {commit_memlocs: MemLocSet.t,
2933                     commit_classes: ClassSet.t,
2934                     remove_memlocs: MemLocSet.t,
2935                     remove_classes: ClassSet.t,
2936                     dead_memlocs: MemLocSet.t,
2937                     dead_classes: ClassSet.t}
2938         (* C calls *)
2939           (* Prepare for a C call; i.e., clear all caller save registers;
2940            * also, clear the flt. register stack;
2941            * used before C calls.
2942            *)
2943         | CCall
2944         (* Assert the return value;
2945          * used after C calls.
2946          *)
2947         | Return of {returns: {src: Operand.t, dst: MemLoc.t} list}
2948         (* Misc. *)
2949           (* Assert that the register is not free for the allocator;
2950            * used ???
2951            *)
2952         | Reserve of {registers: Register.t list}
2953           (* Assert that the register is free for the allocator;
2954            * used to free registers at fall-thru;
2955            * also used after C calls to free %esp.
2956            *)
2957         | Unreserve of {registers : Register.t list}
2958           (* Clear the floating point stack;
2959            * used at bot of basic blocks to establish passing convention
2960            *)
2961         | ClearFlt
2962           (* Save the register allocation in id and
2963            *  assert that live are used at this point;
2964            * used at bot of basic blocks to delay establishment
2965            *  of passing convention to compensation block
2966            *)
2967         | SaveRegAlloc of {live: MemLocSet.t,
2968                            id: Id.t}
2969           (* Restore the register allocation from id and
2970            *  remove anything tracked that is not live;
2971            * used at bot of basic blocks to delay establishment
2972            *  of passing convention to compensation block
2973            *)
2974         | RestoreRegAlloc of {live: MemLocSet.t,
2975                               id: Id.t}
2976
2977       val toString
2978         = fn Assume {assumes}
2979            => concat["Assume: ",
2980                      "assumes: ",
2981                      List.fold
2982                      (assumes,
2983                       "",
2984                       fn ({register, memloc, sync, reserve, ...}, s)
2985                        => concat[MemLoc.toString memloc,
2986                                  " -> ", Register.toString register,
2987                                  if reserve then " (reserved)" else "",
2988                                  if sync then " (sync)" else "",
2989                                  " ",
2990                                  s])]
2991            | FltAssume {assumes}
2992            => concat["FltAssume: ",
2993                      "assumes: ",
2994                      List.fold
2995                      (assumes,
2996                       "",
2997                       fn ({memloc, sync, ...}, s)
2998                        => concat[MemLoc.toString memloc,
2999                                  if sync then " (sync)" else "",
3000                                  " ",
3001                                  s])]
3002            | Cache {caches}
3003            => concat["Cache: ",
3004                      "caches: ",
3005                      List.fold
3006                      (caches,
3007                       "",
3008                       fn ({register, memloc, reserve}, s)
3009                        => concat[MemLoc.toString memloc,
3010                                  " -> ", Register.toString register,
3011                                  if reserve then " (reserved)" else "",
3012                                  " ",
3013                                  s])]
3014            | FltCache {caches}
3015            => concat["FltCache: ",
3016                      "caches: ",
3017                      List.fold
3018                      (caches,
3019                       "",
3020                       fn ({memloc}, s)
3021                        => concat[MemLoc.toString memloc,
3022                                  " ",
3023                                  s])]
3024            | Force {commit_memlocs, commit_classes,
3025                     remove_memlocs, remove_classes,
3026                     dead_memlocs, dead_classes}
3027            => concat["Force: ",
3028                      "commit_memlocs: ",
3029                      MemLocSet.fold
3030                      (commit_memlocs,
3031                       "",
3032                       fn (memloc,s)
3033                        => concat[MemLoc.toString memloc, " ", s]),
3034                      "commit_classes: ",
3035                      ClassSet.fold
3036                      (commit_classes,
3037                       "",
3038                       fn (class,s)
3039                        => concat[MemLoc.Class.toString class, " ", s]),
3040                      "remove_memlocs: ",
3041                      MemLocSet.fold
3042                      (remove_memlocs,
3043                       "",
3044                       fn (memloc,s)
3045                        => concat[MemLoc.toString memloc, " ", s]),
3046                      "remove_classes: ",
3047                      ClassSet.fold
3048                      (remove_classes,
3049                       "",
3050                       fn (class,s)
3051                        => concat[MemLoc.Class.toString class, " ", s]),
3052                      "dead_memlocs: ",
3053                      MemLocSet.fold
3054                      (dead_memlocs,
3055                       "",
3056                       fn (memloc,s)
3057                        => concat[MemLoc.toString memloc, " ", s]),
3058                      "dead_classes: ",
3059                      ClassSet.fold
3060                      (dead_classes,
3061                       "",
3062                       fn (class,s)
3063                        => concat[MemLoc.Class.toString class, " ", s])]
3064            | Reset
3065            => concat["Reset"]
3066            | CCall
3067            => concat["CCall"]
3068            | Return {returns}
3069            => concat["Return: ", List.toString (fn {src,dst} =>
3070                                                 concat ["(", Operand.toString src,
3071                                                         ",", MemLoc.toString dst, ")"]) returns]
3072            | Reserve {registers}
3073            => concat["Reserve: ",
3074                      "registers: ",
3075                      List.fold(registers,
3076                                "",
3077                                fn (register,s)
3078                                 => concat[Register.toString register, " ", s])]
3079            | Unreserve {registers}
3080            => concat["Unreserve: ",
3081                      "registers: ",
3082                      List.fold(registers,
3083                                "",
3084                                fn (register,s)
3085                                 => concat[Register.toString register, " ", s])]
3086            | ClearFlt
3087            => concat["ClearFlt"]
3088            | SaveRegAlloc {live, id}
3089            => concat["SaveRegAlloc: ",
3090                      "live: ",
3091                      MemLocSet.fold
3092                      (live,
3093                       "",
3094                       fn (memloc,s)
3095                        => concat[MemLoc.toString memloc, " ", s]),
3096                      Id.toString id]
3097            | RestoreRegAlloc {live, id}
3098            => concat["RestoreRegAlloc: ",
3099                      "live: ",
3100                      MemLocSet.fold
3101                      (live,
3102                       "",
3103                       fn (memloc,s)
3104                        => concat[MemLoc.toString memloc, " ", s]),
3105                      Id.toString id]
3106       val layout = Layout.str o toString
3107
3108       val uses_defs_kills
3109         = fn Assume {assumes}
3110            => List.fold
3111               (assumes,
3112                {uses = [], defs = [], kills = []},
3113                fn ({register, memloc, ...},
3114                    {uses, defs, ...})
3115                 => {uses = (Operand.memloc memloc)::uses,
3116                     defs = (Operand.register register)::defs,
3117                     kills = []})
3118            | FltAssume {assumes}
3119            => List.fold
3120               (assumes,
3121                {uses = [], defs = [], kills = []},
3122                fn ({memloc, ...},
3123                    {uses, defs, ...})
3124                 => {uses = (Operand.memloc memloc)::uses,
3125                     defs = defs,
3126                     kills = []})
3127            | Cache {caches}
3128            => List.fold
3129               (caches,
3130                {uses = [], defs = [], kills = []},
3131                fn ({register, memloc, ...},
3132                    {uses, defs, ...})
3133                 => {uses = (Operand.memloc memloc)::uses,
3134                     defs = (Operand.register register)::defs,
3135                     kills = []})
3136            | FltCache {caches}
3137            => List.fold
3138               (caches,
3139                {uses = [], defs = [], kills = []},
3140                fn ({memloc, ...},
3141                    {uses, defs, ...})
3142                 => {uses = (Operand.memloc memloc)::uses,
3143                     defs = defs,
3144                     kills = []})
3145            | Reset => {uses = [], defs = [], kills = []}
3146            | Force {commit_memlocs, remove_memlocs, ...}
3147            => {uses = List.map(MemLocSet.toList commit_memlocs, Operand.memloc) @
3148                       List.map(MemLocSet.toList remove_memlocs, Operand.memloc),
3149                defs = [],
3150                kills = []}
3151            | CCall => {uses = [], defs = [], kills = []}
3152            | Return {returns}
3153            => let
3154                  val uses = List.map(returns, fn {src, ...} => src)
3155                  val defs = List.map(returns, fn {dst, ...} => Operand.memloc dst)
3156               in
3157                  {uses = uses, defs = defs, kills = []}
3158               end
3159            | Reserve {...} => {uses = [], defs = [], kills = []}
3160            | Unreserve {...} => {uses = [], defs = [], kills = []}
3161            | ClearFlt => {uses = [], defs = [], kills = []}
3162            | SaveRegAlloc {live, ...}
3163            => {uses = List.map(MemLocSet.toList live, Operand.memloc),
3164                defs = [],
3165                kills = []}
3166            | RestoreRegAlloc {...}
3167            => {uses = [], defs = [], kills = []}
3168
3169       val hints
3170         = fn Cache {caches}
3171            => List.map
3172               (caches,
3173                fn {register, memloc, ...}
3174                 => (memloc, register))
3175            | _ => []
3176
3177       fun replace replacer
3178         = fn Assume {assumes}
3179            => Assume {assumes
3180                       = List.map
3181                         (assumes,
3182                          fn {register, memloc, weight, sync, reserve}
3183                           => {register = register,
3184                               memloc = memloc,
3185                               weight = weight,
3186                               sync = sync,
3187                               reserve = reserve})}
3188            | FltAssume {assumes}
3189            => FltAssume {assumes
3190                          = List.map
3191                            (assumes,
3192                             fn {memloc, weight, sync}
3193                              => {memloc = memloc,
3194                                  weight = weight,
3195                                  sync = sync})}
3196            | Cache {caches}
3197            => Cache {caches
3198                      = List.map
3199                        (caches,
3200                         fn {register, memloc, reserve}
3201                          => {register = case replacer {use = false, def = true}
3202                                              (Operand.register register)
3203                                           of Operand.Register register => register
3204                                            | _ => Error.bug "x86.Directive.replace: Cache, register",
3205                              memloc = case replacer {use = true, def = false}
3206                                            (Operand.memloc memloc)
3207                                         of Operand.MemLoc memloc => memloc
3208                                          | _ => Error.bug "x86.Directive.replace: Cache, memloc",
3209                              reserve = reserve})}
3210            | FltCache {caches}
3211            => FltCache {caches
3212                         = List.map
3213                           (caches,
3214                            fn {memloc}
3215                             => {memloc = case replacer {use = true, def = false}
3216                                               (Operand.memloc memloc)
3217                                            of Operand.MemLoc memloc => memloc
3218                                             | _ => Error.bug "x86.Directive.replace: FltCache, memloc"})}
3219            | Reset => Reset
3220            | Force {commit_memlocs, commit_classes,
3221                     remove_memlocs, remove_classes,
3222                     dead_memlocs, dead_classes}
3223            => Force {commit_memlocs = MemLocSet.map
3224                                       (commit_memlocs,
3225                                        fn memloc
3226                                         => case replacer
3227                                                 {use = true, def = false}
3228                                                 (Operand.memloc memloc)
3229                                              of Operand.MemLoc memloc => memloc
3230                                               | _ => Error.bug "x86.Directive.replace: Force, commit_memlocs"),
3231                      commit_classes = commit_classes,
3232                      remove_memlocs = MemLocSet.map
3233                                       (remove_memlocs,
3234                                        fn memloc
3235                                         => case replacer
3236                                                 {use = true, def = false}
3237                                                 (Operand.memloc memloc)
3238                                              of Operand.MemLoc memloc => memloc
3239                                               | _ => Error.bug "x86.Directive.replace: Force, remove_memlocs"),
3240                      remove_classes = remove_classes,
3241                      dead_memlocs = MemLocSet.map
3242                                     (dead_memlocs,
3243                                      fn memloc
3244                                       => case replacer
3245                                               {use = false, def = false}
3246                                               (Operand.memloc memloc)
3247                                            of Operand.MemLoc memloc => memloc
3248                                             | _ => Error.bug "x86.Directive.replace: Force, dead_memlocs"),
3249                      dead_classes = dead_classes}
3250            | CCall => CCall
3251            | Return {returns}
3252            => Return {returns = List.map
3253                                 (returns, fn {src,dst} =>
3254                                  {src = src,
3255                                   dst =
3256                                   case replacer {use = true, def = false}
3257                                        (Operand.memloc dst)
3258                                     of Operand.MemLoc memloc => memloc
3259                                      | _ => Error.bug "x86.Directive.replace: Return, returns"})}
3260            | Reserve {registers} => Reserve {registers = registers}
3261            | Unreserve {registers} => Unreserve {registers = registers}
3262            | ClearFlt => ClearFlt
3263            | SaveRegAlloc {live, id} => SaveRegAlloc {live = live, id = id}
3264            | RestoreRegAlloc {live, id} => RestoreRegAlloc {live = live, id = id}
3265
3266       val assume = Assume
3267       val fltassume = FltAssume
3268       val cache = Cache
3269       val fltcache = FltCache
3270       val reset = fn () => Reset
3271       val force = Force
3272       val ccall = fn () => CCall
3273       val return = Return
3274       val reserve = Reserve
3275       val unreserve = Unreserve
3276       val saveregalloc = SaveRegAlloc
3277       val restoreregalloc = RestoreRegAlloc
3278       val clearflt = fn () => ClearFlt
3279     end
3280
3281   structure PseudoOp =
3282     struct
3283       datatype t
3284         = Data
3285         | Text
3286         | SymbolStub
3287         | NonLazySymbolPointer
3288         | Balign of Immediate.t * Immediate.t option * Immediate.t option
3289         | P2align of Immediate.t * Immediate.t option * Immediate.t option
3290         | Space of Immediate.t * Immediate.t
3291         | Byte of Immediate.t list
3292         | Word of Immediate.t list
3293         | Long of Immediate.t list
3294         | String of string list
3295         | Global of Label.t
3296         | Hidden of Label.t
3297         | IndirectSymbol of Label.t
3298         | Local of Label.t
3299         | Comm of Label.t * Immediate.t * Immediate.t option
3300
3301       val layout
3302         = let
3303             open Layout
3304           in
3305             fn Data => str ".data"
3306              | Text => str ".text"
3307              | SymbolStub
3308              => str ".section __IMPORT,__jump_table,symbol_stubs,self_modifying_code+pure_instructions,5"
3309              | NonLazySymbolPointer
3310              => str ".section __IMPORT,__pointers,non_lazy_symbol_pointers"
3311              | Balign (i,fill,max)
3312              => seq [str ".balign ",
3313                      Immediate.layout i,
3314                      case (fill, max)
3315                        of (NONE, NONE) => empty
3316                         | (SOME fill, NONE) => seq [str ",",
3317                                                     Immediate.layout fill]
3318                         | (NONE, SOME max) => seq [str ",,",
3319                                                    Immediate.layout max]
3320                         | (SOME fill, SOME max) => seq [str ",",
3321                                                         Immediate.layout fill,
3322                                                         str ",",
3323                                                         Immediate.layout max]]
3324              | P2align (i,fill,max)
3325              => seq [str ".p2align ",
3326                      Immediate.layout i,
3327                      case (fill, max)
3328                        of (NONE, NONE) => empty
3329                         | (SOME fill, NONE) => seq [str ",",
3330                                                     Immediate.layout fill]
3331                         | (NONE, SOME max) => seq [str ",,",
3332                                                    Immediate.layout max]
3333                         | (SOME fill, SOME max) => seq [str ",",
3334                                                         Immediate.layout fill,
3335                                                         str ",",
3336                                                         Immediate.layout max]]
3337              | Space (i,f)
3338              => seq [str ".space ",
3339                      Immediate.layout i,
3340                      str ",",
3341                      Immediate.layout f]
3342              | Byte bs
3343              => seq [str ".byte ",
3344                      seq (separate(List.map (bs, Immediate.layout), ","))]
3345              | Word ws
3346              => seq [str ".word ",
3347                      seq (separate(List.map (ws, Immediate.layout), ","))]
3348              | Long ls
3349              => seq [str ".long ",
3350                      seq (separate(List.map (ls, Immediate.layout), ","))]
3351              | String ss
3352              => seq [str ".ascii ",
3353                      seq (separate(List.map
3354                                    (ss,
3355                                     fn s => seq [str "\"",
3356                                                  str (String_escapeASM s),
3357                                                  str "\""]),
3358                                    ","))]
3359              | Global l
3360              => seq [str ".globl ",
3361                      Label.layout l]
3362              | Hidden l
3363              => (* visibility directive depends on target object file *)
3364                 let
3365                    val elf = seq [str ".hidden ", Label.layout l]
3366                    val macho = seq [str ".private_extern ", Label.layout l]
3367                    val coff = seq [str "/* ", str ".hidden ", Label.layout l, str " */"]
3368                 in
3369                    case !Control.Target.os of
3370                       MLton.Platform.OS.Cygwin => coff
3371                     | MLton.Platform.OS.Darwin => macho
3372                     | MLton.Platform.OS.MinGW => coff
3373                     | _ => elf
3374                 end
3375              | IndirectSymbol l
3376              => seq [str ".indirect_symbol ",
3377                      Label.layout l]
3378              | Local l
3379              => seq [str ".local ",
3380                      Label.layout l]
3381              | Comm (l, i, a)
3382              => seq [str ".comm ",
3383                      Label.layout l,
3384                      str ",",
3385                      Immediate.layout i,
3386                      case a of NONE => empty
3387                              | SOME i => seq [str ",", Immediate.layout i]]
3388           end
3389       val toString = Layout.toString o layout
3390
3391       fun replace replacer
3392         = let
3393             val replacerLabel
3394               = fn label
3395                  => case Operand.deLabel
3396                          (replacer {use = true, def = false}
3397                                    (Operand.label label))
3398                       of SOME label => label
3399                        | NONE => Error.bug "x86.PseudoOp.replace.replacerLabel"
3400             val replacerImmediate
3401               = fn immediate
3402                  => case Operand.deImmediate
3403                          (replacer {use = true, def = false}
3404                                    (Operand.immediate immediate))
3405                              of SOME immediate => immediate
3406                               | NONE => Error.bug "x86.PseudoOp.replace.replacerImmediate"
3407           in
3408             fn Data => Data
3409              | Text => Text
3410              | SymbolStub => SymbolStub
3411              | NonLazySymbolPointer => NonLazySymbolPointer
3412              | Balign (i,fill,max) => Balign (replacerImmediate i,
3413                                               Option.map(fill, replacerImmediate),
3414                                               Option.map(max, replacerImmediate))
3415              | P2align (i,fill,max) => P2align (replacerImmediate i,
3416                                                 Option.map(fill, replacerImmediate),
3417                                                 Option.map(max, replacerImmediate))
3418              | Space (i,f) => Space (replacerImmediate i, replacerImmediate f)
3419              | Byte bs => Byte (List.map(bs, replacerImmediate))
3420              | Word ws => Word (List.map(ws, replacerImmediate))
3421              | Long ls => Long (List.map(ls, replacerImmediate))
3422              | String ss => String ss
3423              | Global l => Global (replacerLabel l)
3424              | Hidden l => Hidden (replacerLabel l)
3425              | IndirectSymbol l => IndirectSymbol (replacerLabel l)
3426              | Local l => Local (replacerLabel l)
3427              | Comm (l, i, a) => Comm (replacerLabel l,
3428                                        replacerImmediate i,
3429                                        Option.map(a, replacerImmediate))
3430           end
3431
3432       val data = fn () => Data
3433       val text = fn () => Text
3434       val symbol_stub = fn () => SymbolStub
3435       val non_lazy_symbol_pointer = fn () => NonLazySymbolPointer
3436       val balign = Balign
3437       val p2align = P2align
3438       val space = Space
3439       val byte = Byte
3440       val word = Word
3441       val long = Long
3442       val string = String
3443       val global = Global
3444       val hidden = Hidden
3445       val indirect_symbol = IndirectSymbol
3446       val locall = Local
3447       val comm = Comm
3448     end
3449
3450   structure Assembly =
3451     struct
3452       datatype t
3453         = Comment of string
3454         | Directive of Directive.t
3455         | PseudoOp of PseudoOp.t
3456         | Label of Label.t
3457         | Instruction of Instruction.t
3458
3459       val layout
3460         = let
3461             open Layout
3462           in
3463             fn Comment s => seq [str "/* ",  str s, str " */"]
3464              | Directive d => seq [str "# directive: ", Directive.layout d]
3465              | PseudoOp p => seq [PseudoOp.layout p]
3466              | Label l => seq [Label.layout l, str ":"]
3467              | Instruction i => seq [str "\t", Instruction.layout i]
3468           end
3469       val toString = Layout.toString o layout
3470
3471       val uses_defs_kills
3472         = fn Comment _ => {uses = [], defs = [], kills = []}
3473            | Directive d => Directive.uses_defs_kills d
3474            | PseudoOp _ => {uses = [], defs = [], kills = []}
3475            | Label _ => {uses = [], defs = [], kills = []}
3476            | Instruction i => Instruction.uses_defs_kills i
3477
3478       val hints
3479         = fn Comment _ => []
3480            | Directive d => Directive.hints d
3481            | PseudoOp _ => []
3482            | Label _ => []
3483            | Instruction i => Instruction.hints i
3484
3485       fun replace replacer
3486         = fn Comment s => Comment s
3487            | Directive d => Directive (Directive.replace replacer d)
3488            | PseudoOp p => PseudoOp (PseudoOp.replace replacer p)
3489            | Label l => Label (case Operand.deLabel
3490                                     (replacer {use = false, def = true}
3491                                               (Operand.label l))
3492                                  of SOME l => l
3493                                   | NONE => Error.bug "x86.Assembly.replace, Label")
3494            | Instruction i => Instruction (Instruction.replace replacer i)
3495
3496       val comment = Comment
3497       val isComment = fn Comment _ => true | _ => false
3498       val directive = Directive
3499       val directive_assume = Directive o Directive.assume
3500       val directive_fltassume = Directive o Directive.fltassume
3501       val directive_cache = Directive o Directive.cache
3502       val directive_fltcache = Directive o Directive.fltcache
3503       val directive_reset = Directive o Directive.reset
3504       val directive_force = Directive o Directive.force
3505       val directive_ccall = Directive o Directive.ccall
3506       val directive_return = Directive o Directive.return
3507       val directive_reserve = Directive o Directive.reserve
3508       val directive_unreserve = Directive o Directive.unreserve
3509       val directive_saveregalloc = Directive o Directive.saveregalloc
3510       val directive_restoreregalloc = Directive o Directive.restoreregalloc
3511       val directive_clearflt = Directive o Directive.clearflt
3512       val pseudoop = PseudoOp
3513       val pseudoop_data = PseudoOp o PseudoOp.data
3514       val pseudoop_text = PseudoOp o PseudoOp.text
3515       val pseudoop_symbol_stub = PseudoOp o PseudoOp.symbol_stub
3516       val pseudoop_non_lazy_symbol_pointer =
3517          PseudoOp o PseudoOp.non_lazy_symbol_pointer
3518       val pseudoop_balign = PseudoOp o PseudoOp.balign
3519       val pseudoop_p2align = PseudoOp o PseudoOp.p2align
3520       val pseudoop_space = PseudoOp o PseudoOp.space
3521       val pseudoop_byte = PseudoOp o PseudoOp.byte
3522       val pseudoop_word = PseudoOp o PseudoOp.word
3523       val pseudoop_long = PseudoOp o PseudoOp.long
3524       val pseudoop_string = PseudoOp o PseudoOp.string
3525       val pseudoop_global = PseudoOp o PseudoOp.global
3526       val pseudoop_hidden = PseudoOp o PseudoOp.hidden
3527       val pseudoop_indirect_symbol = PseudoOp o PseudoOp.indirect_symbol
3528       val pseudoop_local = PseudoOp o PseudoOp.locall
3529       val pseudoop_comm = PseudoOp o PseudoOp.comm
3530       val label = Label
3531       val instruction = Instruction
3532       val instruction_nop = Instruction o Instruction.nop
3533       val instruction_hlt = Instruction o Instruction.hlt
3534       val instruction_binal = Instruction o Instruction.binal
3535       val instruction_pmd = Instruction o Instruction.pmd
3536       val instruction_md = Instruction o Instruction.md
3537       val instruction_imul2 = Instruction o Instruction.imul2
3538       val instruction_unal = Instruction o Instruction.unal
3539       val instruction_sral = Instruction o Instruction.sral
3540       val instruction_cmp = Instruction o Instruction.cmp
3541       val instruction_test = Instruction o Instruction.test
3542       val instruction_setcc = Instruction o Instruction.setcc
3543       val instruction_jmp = Instruction o Instruction.jmp
3544       val instruction_jcc = Instruction o Instruction.jcc
3545       val instruction_call = Instruction o Instruction.call
3546       val instruction_ret = Instruction o Instruction.ret
3547       val instruction_mov = Instruction o Instruction.mov
3548       val instruction_cmovcc = Instruction o Instruction.cmovcc
3549       val instruction_xchg = Instruction o Instruction.xchg
3550       val instruction_ppush = Instruction o Instruction.ppush
3551       val instruction_ppop = Instruction o Instruction.ppop
3552       val instruction_push = Instruction o Instruction.push
3553       val instruction_pop = Instruction o Instruction.pop
3554       val instruction_cx = Instruction o Instruction.cx
3555       val instruction_movx = Instruction o Instruction.movx
3556       val instruction_xvom = Instruction o Instruction.xvom
3557       val instruction_lea = Instruction o Instruction.lea
3558       val instruction_pfmov = Instruction o Instruction.pfmov
3559       val instruction_pfmovx = Instruction o Instruction.pfmovx
3560       val instruction_pfxvom = Instruction o Instruction.pfxvom
3561       val instruction_pfldc = Instruction o Instruction.pfldc
3562       val instruction_pfmovfi = Instruction o Instruction.pfmovfi
3563       val instruction_pfmovti = Instruction o Instruction.pfmovti
3564       val instruction_pfcom = Instruction o Instruction.pfcom
3565       val instruction_pfucom = Instruction o Instruction.pfucom
3566       val instruction_pfbina = Instruction o Instruction.pfbina
3567       val instruction_pfuna = Instruction o Instruction.pfuna
3568       val instruction_pfptan = Instruction o Instruction.pfptan
3569       val instruction_pfbinas = Instruction o Instruction.pfbinas
3570       val instruction_pfbinasp = Instruction o Instruction.pfbinasp
3571       val instruction_fld = Instruction o Instruction.fld
3572       val instruction_fst = Instruction o Instruction.fst
3573       val instruction_fild = Instruction o Instruction.fild
3574       val instruction_fist = Instruction o Instruction.fist
3575       val instruction_fxch = Instruction o Instruction.fxch
3576       val instruction_fldc = Instruction o Instruction.fldc
3577       val instruction_fldcw = Instruction o Instruction.fldcw
3578       val instruction_fstcw = Instruction o Instruction.fstcw
3579       val instruction_fstsw = Instruction o Instruction.fstsw
3580       val instruction_fcom = Instruction o Instruction.fcom
3581       val instruction_fucom = Instruction o Instruction.fucom
3582       val instruction_fbina = Instruction o Instruction.fbina
3583       val instruction_funa = Instruction o Instruction.funa
3584       val instruction_fptan = Instruction o Instruction.fptan
3585       val instruction_fbinas = Instruction o Instruction.fbinas
3586       val instruction_fbinasp = Instruction o Instruction.fbinasp
3587     end
3588
3589   structure FrameInfo =
3590      struct
3591         datatype t = T of {size: int,
3592                            frameLayoutsIndex: int}
3593
3594         fun toString (T {size, frameLayoutsIndex})
3595            = concat ["{",
3596                      "size = ", Int.toString size, ", ",
3597                      "frameLayoutsIndex = ",
3598                      Int.toString frameLayoutsIndex, "}"]
3599      end
3600
3601   structure Entry =
3602     struct
3603       datatype t
3604         = Jump of {label: Label.t}
3605         | Func of {label: Label.t,
3606                    live: MemLocSet.t}
3607         | Cont of {label: Label.t,
3608                    live: MemLocSet.t,
3609                    frameInfo: FrameInfo.t}
3610         | Handler of {frameInfo: FrameInfo.t,
3611                       label: Label.t,
3612                       live: MemLocSet.t}
3613         | CReturn of {dsts: (Operand.t * Size.t) vector,
3614                       frameInfo: FrameInfo.t option,
3615                       func: RepType.t CFunction.t,
3616                       label: Label.t}
3617
3618       val toString
3619         = fn Jump {label} => concat ["Jump::",
3620                                      Label.toString label]
3621            | Func {label, live}
3622            => concat ["Func::",
3623                       Label.toString label,
3624                       " [",
3625                       (concat o List.separate)
3626                       (MemLocSet.fold
3627                        (live,
3628                         [],
3629                         fn (memloc, l) => (MemLoc.toString memloc)::l),
3630                        ", "),
3631                       "]"]
3632            | Cont {label, live, frameInfo}
3633            => concat ["Cont::",
3634                       Label.toString label,
3635                       " [",
3636                       (concat o List.separate)
3637                       (MemLocSet.fold
3638                        (live,
3639                         [],
3640                         fn (memloc, l) => (MemLoc.toString memloc)::l),
3641                        ", "),
3642                       "] ",
3643                       FrameInfo.toString frameInfo]
3644            | Handler {frameInfo, label, live}
3645            => concat ["Handler::",
3646                       Label.toString label,
3647                       " [",
3648                       (concat o List.separate)
3649                       (MemLocSet.fold
3650                        (live,
3651                         [],
3652                         fn (memloc, l) => (MemLoc.toString memloc)::l),
3653                        ", "),
3654                       "] (",
3655                       FrameInfo.toString frameInfo,
3656                       ")"]
3657            | CReturn {dsts, frameInfo, func, label}
3658            => concat ["CReturn::",
3659                       Label.toString label,
3660                       " ",
3661                       Vector.toString (fn (dst,_) => Operand.toString dst) dsts,
3662                       " ",
3663                       (CFunction.Target.toString o CFunction.target) func,
3664                       " ",
3665                       case frameInfo of
3666                          NONE => ""
3667                        | SOME f => FrameInfo.toString f]
3668
3669       val uses_defs_kills
3670         = fn CReturn {dsts, func, ...}
3671            => let
3672                  val uses =
3673                     List.map (Operand.cReturnTemps (CFunction.return func),
3674                               fn {dst, ...} => Operand.memloc dst)
3675               in
3676                  {uses = uses,
3677                   defs = Vector.toListMap(dsts, fn (dst, _) => dst),
3678                   kills = []}
3679               end
3680            | _ => {uses = [], defs = [], kills = []}
3681
3682       val label
3683         = fn Jump {label, ...} => label
3684            | Func {label, ...} => label
3685            | Cont {label, ...} => label
3686            | Handler {label, ...} => label
3687            | CReturn {label, ...} => label
3688
3689       val live
3690         = fn Func {live, ...} => live
3691            | Cont {live, ...} => live
3692            | Handler {live, ...} => live
3693            | _ => MemLocSet.empty
3694
3695       val jump = Jump
3696       val func = Func
3697       val isFunc = fn Func _ => true | _ => false
3698       val cont = Cont
3699       val handler = Handler
3700       val creturn = CReturn
3701     end
3702
3703   structure Transfer =
3704     struct
3705       structure Cases =
3706         struct
3707           datatype 'a t = Word of (WordX.t * 'a) list
3708
3709           val word = Word
3710
3711           fun isEmpty cases
3712             = case cases
3713                of Word [] => true
3714                 | _ => false
3715
3716           fun isSingle cases
3717             = case cases
3718                 of Word [_] => true
3719                  | _ => false
3720
3721           fun extract(cases,f)
3722             = let
3723                 fun doit [(k,target)] = f (k, target)
3724                   | doit _ = Error.bug "x86.Transfer.Cases.extract"
3725               in
3726                 case cases
3727                   of Word cases => doit cases
3728               end
3729
3730           fun count(cases, p)
3731             = let
3732                 fun doit [] = (0 : int)
3733                   | doit ((_,target)::cases) = let
3734                                                  val n = doit cases
3735                                                in
3736                                                  if p target
3737                                                    then 1 + n
3738                                                    else n
3739                                                end
3740               in
3741                 case cases
3742                   of Word cases => doit cases
3743               end
3744
3745           fun keepAll(cases, p)
3746             = let
3747                 fun doit l = List.keepAll(l, fn (k,target) => p (k,target))
3748               in
3749                 case cases
3750                   of Word cases => Word(doit cases)
3751               end
3752
3753           fun forall(cases, f)
3754             = let
3755                 fun doit l = List.forall(l, fn (k, target) => f (k, target))
3756               in
3757                 case cases
3758                   of Word cases => doit cases
3759               end
3760
3761           fun foreach(cases, f)
3762             = let
3763                 fun doit l = List.foreach(l, fn (k, target) => f (k, target))
3764               in
3765                 case cases
3766                   of Word cases => doit cases
3767               end
3768
3769           fun map(cases, f)
3770             = let
3771                 fun doit l = List.map(l, fn (k,target) => (k, f (k, target)))
3772               in
3773                 case cases
3774                   of Word cases => Word(doit cases)
3775               end
3776
3777           fun mapToList(cases, f)
3778             = let
3779                 fun doit l = List.map(l, fn (k,target) => f (k, target))
3780               in
3781                 case cases
3782                   of Word cases => doit cases
3783               end
3784         end
3785
3786       datatype t
3787         = Goto of {target: Label.t}
3788         | Iff of {condition: Instruction.condition,
3789                   truee: Label.t,
3790                   falsee: Label.t}
3791         | Switch of {test: Operand.t,
3792                      cases: Label.t Cases.t,
3793                      default: Label.t}
3794         | Tail of {target: Label.t,
3795                    live: MemLocSet.t}
3796         | NonTail of {target: Label.t,
3797                       live: MemLocSet.t,
3798                       return: Label.t,
3799                       handler: Label.t option,
3800                       size: int}
3801         | Return of {live: MemLocSet.t}
3802         | Raise of {live: MemLocSet.t}
3803         | CCall of {args: (Operand.t * Size.t) list,
3804                     frameInfo: FrameInfo.t option,
3805                     func: RepType.t CFunction.t,
3806                     return: Label.t option}
3807
3808       val toString
3809         = fn Goto {target}
3810            => concat ["GOTO ",
3811                       Label.toString target]
3812            | Iff {condition, truee, falsee}
3813            => concat["IF ",
3814                      Instruction.condition_toString condition,
3815                      " THEN GOTO ",
3816                      Label.toString truee,
3817                      " ELSE GOTO ",
3818                      Label.toString falsee]
3819            | Switch {test, cases, default}
3820            => (concat["SWITCH ",
3821                       Operand.toString test]) ^
3822               (concat o Cases.mapToList)
3823               (cases,
3824                fn (w, target) => concat[" (",
3825                                         WordX.toString w,
3826                                         " -> GOTO ",
3827                                         Label.toString target,
3828                                         ")"]) ^
3829               (concat[" GOTO ",
3830                       Label.toString default])
3831            | Tail {target, live}
3832            => concat ["TAIL ",
3833                       Label.toString target,
3834                       " [",
3835                       (concat o List.separate)
3836                       (MemLocSet.fold
3837                        (live,
3838                         [],
3839                         fn (memloc, l) => (MemLoc.toString memloc)::l),
3840                        ", "),
3841                       "]"]
3842            | NonTail {target, live, return, handler, size}
3843            => concat ["NONTAIL ",
3844                       Label.toString target,
3845                       " [",
3846                       (concat o List.separate)
3847                       (MemLocSet.fold
3848                        (live,
3849                         [],
3850                         fn (memloc, l) => (MemLoc.toString memloc)::l),
3851                        ", "),
3852                       "] <",
3853                       Label.toString return,
3854                       " ",
3855                       Int.toString size,
3856                       "> {",
3857                       case handler
3858                         of SOME handler => Label.toString handler
3859                          | NONE => "",
3860                       "}"]
3861            | Return {live}
3862            => concat ["RETURN",
3863                       " [",
3864                       (concat o List.separate)
3865                       (MemLocSet.fold
3866                        (live,
3867                         [],
3868                         fn (memloc, l) => (MemLoc.toString memloc)::l),
3869                        ", "),
3870                       "]"]
3871            | Raise {live}
3872            => concat ["RAISE",
3873                       " [",
3874                       (concat o List.separate)
3875                       (MemLocSet.fold
3876                        (live,
3877                         [],
3878                         fn (memloc, l) => (MemLoc.toString memloc)::l),
3879                        ", "),
3880                       "]"]
3881            | CCall {args, func, return, ...}
3882            => concat ["CCALL ",
3883                       (CFunction.Convention.toString o CFunction.convention) func,
3884                       " ",
3885                       (CFunction.Target.toString o CFunction.target) func,
3886                       "(",
3887                       (concat o List.separate)
3888                       (List.map(args, fn (oper,_) => Operand.toString oper),
3889                        ", "),
3890                       ") <",
3891                       Option.toString Label.toString return,
3892                       ">"]
3893
3894       val uses_defs_kills
3895         = fn Switch {test, ...}
3896            => {uses = [test], defs = [], kills = []}
3897            | CCall {args, func, ...}
3898            => let
3899                  val defs =
3900                     List.map (Operand.cReturnTemps (CFunction.return func),
3901                               fn {dst, ...} => Operand.memloc dst)
3902               in
3903                  {uses = List.map(args, fn (oper,_) => oper),
3904                   defs = defs, kills = []}
3905               end
3906            | _ => {uses = [], defs = [], kills = []}
3907
3908       val nearTargets
3909         = fn Goto {target} => [target]
3910            | Iff {truee,falsee,...} => [truee,falsee]
3911            | Switch {cases,default,...}
3912            => default::(Cases.mapToList
3913                         (cases,
3914                          fn (_,target) => target))
3915            | NonTail {return,handler,...} => return::(case handler
3916                                                         of NONE => nil
3917                                                          | SOME handler => [handler])
3918            | CCall {return, ...}
3919            => (case return of
3920                  NONE => []
3921                | SOME l => [l])
3922            | _ => []
3923
3924       val live
3925         = fn Tail {live,...} => live
3926            | NonTail {live,...} => live
3927            | Return {live,...} => live
3928            | Raise {live,...} => live
3929            | _ => MemLocSet.empty
3930
3931       fun replace replacer
3932         = fn Switch {test, cases, default}
3933            => Switch {test = replacer {use = true, def = false} test,
3934                       cases = cases,
3935                       default = default}
3936            | CCall {args, frameInfo, func, return}
3937            => CCall {args = List.map(args,
3938                                      fn (oper,size) => (replacer {use = true,
3939                                                                   def = false}
3940                                                                  oper,
3941                                                         size)),
3942                      frameInfo = frameInfo,
3943                      func = func,
3944                      return = return}
3945            | transfer => transfer
3946
3947       val goto = Goto
3948       val iff = Iff
3949       val switch = Switch
3950       val tail = Tail
3951       val nontail = NonTail
3952       val return = Return
3953       val raisee = Raise
3954       val ccall = CCall
3955     end
3956
3957   structure ProfileLabel =
3958     struct
3959       open ProfileLabel
3960
3961       fun toAssembly pl =
3962         let
3963           val label = Label.fromString (toString pl)
3964         in
3965           [Assembly.pseudoop_global label,
3966            Assembly.pseudoop_hidden label,
3967            Assembly.label label]
3968         end
3969       fun toAssemblyOpt pl =
3970         case pl of
3971           NONE => []
3972         | SOME pl => toAssembly pl
3973     end
3974
3975   structure Block =
3976     struct
3977       datatype t' = T' of {entry: Entry.t option,
3978                            profileLabel: ProfileLabel.t option,
3979                            statements: Assembly.t list,
3980                            transfer: Transfer.t option}
3981       fun mkBlock' {entry, statements, transfer} =
3982         T' {entry = entry,
3983             profileLabel = NONE,
3984             statements = statements,
3985             transfer = transfer}
3986       fun mkProfileBlock' {profileLabel} =
3987         T' {entry = NONE,
3988             profileLabel = SOME profileLabel,
3989             statements = [],
3990             transfer = NONE}
3991
3992       datatype t = T of {entry: Entry.t,
3993                          profileLabel: ProfileLabel.t option,
3994                          statements: Assembly.t list,
3995                          transfer: Transfer.t}
3996
3997       fun printBlock (T {entry, profileLabel, statements, transfer, ...})
3998         = (print (Entry.toString entry);
3999            print ":\n";
4000            Option.app
4001            (profileLabel, fn profileLabel =>
4002             (print (ProfileLabel.toString profileLabel);
4003              print ":\n"));
4004            List.foreach
4005            (statements, fn asm =>
4006             (print (Assembly.toString asm);
4007              print "\n"));
4008            print (Transfer.toString transfer);
4009            print "\n")
4010
4011       fun printBlock' (T' {entry, profileLabel, statements, transfer, ...})
4012         = (print (if isSome entry
4013                     then Entry.toString (valOf entry)
4014                     else "---");
4015            print ":\n";
4016            Option.app
4017            (profileLabel, fn profileLabel =>
4018             (print (ProfileLabel.toString profileLabel);
4019              print ":\n"));
4020            List.foreach
4021            (statements, fn asm =>
4022             (print (Assembly.toString asm);
4023              print "\n"));
4024            print (if isSome transfer
4025                     then Transfer.toString (valOf transfer)
4026                     else "NONE");
4027            print "\n")
4028
4029       val compress': t' list -> t' list =
4030          fn l =>
4031          List.fold
4032          (rev l, [],
4033           fn (b' as T' {entry, profileLabel, statements, transfer}, ac) =>
4034           case transfer of
4035              SOME _ => b' :: ac
4036            | NONE =>
4037                 case ac of
4038                    [] => Error.bug "x86.Block.compress': dangling transfer"
4039                  | b2' :: ac =>
4040                       let
4041                          val T' {entry = entry2,
4042                                  profileLabel = profileLabel2,
4043                                  statements = statements2,
4044                                  transfer = transfer2} = b2'
4045                       in
4046                          case entry2 of
4047                             SOME _ =>
4048                                Error.bug "x86.Block.compress': mismatched transfer"
4049                           | NONE =>
4050                                let
4051                                   val (pl, ss) =
4052                                      case (profileLabel, statements) of
4053                                         (NONE, []) =>
4054                                            (profileLabel2, statements2)
4055                                       | _ =>
4056                                            (profileLabel,
4057                                             statements
4058                                             @ (ProfileLabel.toAssemblyOpt
4059                                                profileLabel2)
4060                                             @ statements2)
4061                                in
4062                                   T' {entry = entry,
4063                                       profileLabel = pl,
4064                                       statements = ss,
4065                                       transfer = transfer2} :: ac
4066                                end
4067                       end)
4068
4069       val compress: t' list -> t list =
4070          fn l =>
4071          List.map
4072          (compress' l, fn T' {entry, profileLabel, statements, transfer} =>
4073           case (entry, transfer) of
4074              (SOME e, SOME t) =>
4075                 T {entry = e,
4076                    profileLabel = profileLabel,
4077                    statements = statements,
4078                    transfer = t}
4079            | _ => Error.bug "x86.Block.compress")
4080     end
4081
4082   structure Chunk =
4083     struct
4084       datatype t = T of {data: Assembly.t list,
4085                          blocks: Block.t list}
4086     end
4087 end