mlton/codegen/x86-codegen/x86-mlton.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 x86MLton (S: X86_MLTON_STRUCTS): X86_MLTON =
  10 struct
  11
  12   open S
  13   open x86MLtonBasic
  14   open x86
  15   local
  16      open Machine
  17   in
  18      structure CFunction = CFunction
  19      structure RealSize = RealSize
  20      structure Prim = Prim
  21      structure WordSize = WordSize
  22      datatype z = datatype RealSize.t
  23      datatype z = datatype WordSize.prim
  24   end
  25
  26   type transInfo = {addData : x86.Assembly.t list -> unit,
  27                     frameInfoToX86: (x86MLtonBasic.Machine.FrameInfo.t
  28                                      -> x86.FrameInfo.t),
  29                     live: x86.Label.t -> x86.Operand.t list,
  30                     liveInfo: x86Liveness.LiveInfo.t}
  31
  32   fun implementsPrim (p: 'a Prim.t) =
  33      let
  34         datatype z = datatype RealSize.t
  35         datatype z = datatype WordSize.prim
  36         fun w32168 s =
  37            case WordSize.prim s of
  38               W8 => true
  39             | W16 => true
  40             | W32 => true
  41             | W64 => false
  42         datatype z = datatype Prim.Name.t
  43      in
  44         case Prim.name p of
  45            CPointer_add => true
  46          | CPointer_diff => true
  47          | CPointer_equal => true
  48          | CPointer_fromWord => true
  49          | CPointer_lt => true
  50          | CPointer_sub => true
  51          | CPointer_toWord => true
  52          | FFI_Symbol _ => true
  53          | Real_Math_acos _ => true
  54          | Real_Math_asin _ => true
  55          | Real_Math_atan _ => true
  56          | Real_Math_atan2 _ => true
  57          | Real_Math_cos _ => true
  58          | Real_Math_exp _ => true
  59          | Real_Math_ln _ => true
  60          | Real_Math_log10 _ => true
  61          | Real_Math_sin _ => true
  62          | Real_Math_sqrt _ => true
  63          | Real_Math_tan _ => true
  64          | Real_abs _ => true
  65          | Real_add _ => true
  66          | Real_castToWord _ => false (* !! *)
  67          | Real_div _ => true
  68          | Real_equal _ => true
  69          | Real_ldexp _ => true
  70          | Real_le _ => true
  71          | Real_lt _ => true
  72          | Real_mul _ => true
  73          | Real_muladd _ => true
  74          | Real_mulsub _ => true
  75          | Real_neg _ => true
  76          | Real_qequal _ => true
  77          | Real_rndToReal _ => true
  78          | Real_rndToWord (_, s2, {signed}) => signed andalso w32168 s2
  79          | Real_round _ => true
  80          | Real_sub _ => true
  81          | Thread_returnToC => false
  82          | Word_add _ => true
  83          | Word_addCheck _ => true
  84          | Word_andb _ => true
  85          | Word_castToReal _ => false (* !! *)
  86          | Word_equal s => w32168 s
  87          | Word_extdToWord (s1, s2, _) => w32168 s1 andalso w32168 s2
  88          | Word_lshift s => w32168 s
  89          | Word_lt (s, _) => w32168 s
  90          | Word_mul (s, _) => w32168 s
  91          | Word_mulCheck (s, _) => w32168 s
  92          | Word_neg _ => true
  93          | Word_negCheck _ => true
  94          | Word_notb _ => true
  95          | Word_orb _ => true
  96          | Word_quot (s, _) => w32168 s
  97          | Word_rem (s, _) => w32168 s
  98          | Word_rndToReal (s1, _, {signed}) => signed andalso w32168 s1
  99          | Word_rol s => w32168 s
 100          | Word_ror s => w32168 s
 101          | Word_rshift (s, _) => w32168 s
 102          | Word_sub _ => true
 103          | Word_subCheck _ => true
 104          | Word_xorb _ => true
 105          | _ => false
 106      end
 107
 108   val implementsPrim: Machine.Type.t Prim.t -> bool =
 109      Trace.trace
 110      ("x86MLton.implementsPrim", Prim.layout, Bool.layout)
 111      implementsPrim
 112
 113   fun prim {prim : RepType.t Prim.t,
 114             args : (Operand.t * Size.t) vector,
 115             dsts : (Operand.t * Size.t) vector,
 116             transInfo = {addData, ...} : transInfo}
 117     = let
 118         val primName = Prim.toString prim
 119         datatype z = datatype Prim.Name.t
 120
 121         fun getDst1 ()
 122           = Vector.sub (dsts, 0)
 123             handle _ => Error.bug "x86MLton.prim: getDst1"
 124         fun getDst2 ()
 125           = (Vector.sub (dsts, 0), Vector.sub (dsts, 1))
 126             handle _ => Error.bug "x86MLton.prim: getDst2"
 127         fun getSrc1 ()
 128           = Vector.sub (args, 0)
 129             handle _ => Error.bug "x86MLton.prim: getSrc1"
 130         fun getSrc2 ()
 131           = (Vector.sub (args, 0), Vector.sub (args, 1))
 132             handle _ => Error.bug "x86MLton.prim: getSrc2"
 133         fun getSrc3 ()
 134           = (Vector.sub (args, 0), Vector.sub (args, 1), Vector.sub (args, 2))
 135             handle _ => Error.bug "x86MLton.prim: getSrc3"
 136         fun getSrc4 ()
 137           = (Vector.sub (args, 0), Vector.sub (args, 1),
 138              Vector.sub (args, 2), Vector.sub (args, 3))
 139             handle _ => Error.bug "x86MLton.prim: getSrc4"
 140
 141         fun mov ()
 142           = let
 143               val (dst,dstsize) = getDst1 ()
 144               val (src,srcsize) = getSrc1 ()
 145               val _
 146                 = Assert.assert
 147                   ("x86MLton.prim: mov, dstsize/srcsize",
 148                    fn () => srcsize = dstsize)
 149             in
 150               AppendList.fromList
 151               [Block.mkBlock'
 152                {entry = NONE,
 153                 statements
 154                 = [Assembly.instruction_mov
 155                    {dst = dst,
 156                     src = src,
 157                     size = srcsize}],
 158                 transfer = NONE}]
 159             end
 160
 161         fun movx oper
 162           = let
 163               val (dst,dstsize) = getDst1 ()
 164               val (src,srcsize) = getSrc1 ()
 165               val _
 166                 = Assert.assert
 167                   ("x86MLton.prim: movx, dstsize/srcsize",
 168                    fn () => Size.lt(srcsize,dstsize))
 169             in
 170               AppendList.fromList
 171               [Block.mkBlock'
 172                {entry = NONE,
 173                 statements
 174                 = [Assembly.instruction_movx
 175                    {oper = oper,
 176                     dst = dst,
 177                     src = src,
 178                     dstsize = dstsize,
 179                     srcsize = srcsize}],
 180                 transfer = NONE}]
 181             end
 182
 183         fun xvom ()
 184           = let
 185               val (dst,dstsize) = getDst1 ()
 186               val (src,srcsize) = getSrc1 ()
 187               val _
 188                 = Assert.assert
 189                   ("x86MLton.prim: xvom, dstsize/srcsize",
 190                    fn () => Size.lt(dstsize,srcsize))
 191             in
 192               AppendList.fromList
 193               [Block.mkBlock'
 194                {entry = NONE,
 195                 statements
 196                 = [Assembly.instruction_xvom
 197                    {dst = dst,
 198                     src = src,
 199                     dstsize = dstsize,
 200                     srcsize = srcsize}],
 201                 transfer = NONE}]
 202             end
 203
 204         fun binal oper
 205           = let
 206               val ((src1,src1size),
 207                    (src2,src2size)) = getSrc2 ()
 208               val (dst,dstsize) = getDst1 ()
 209               val _
 210                 = Assert.assert
 211                   ("x86MLton.prim: binal, dstsize/src1size/src2size",
 212                    fn () => src1size = dstsize andalso
 213                             src2size = dstsize)
 214
 215               (* Reverse src1/src2 when src1 and src2 are temporaries
 216                * and the oper is commutative.
 217                *)
 218               val (src1,src2)
 219                 = if (oper = Instruction.ADD)
 220                      orelse
 221                      (oper = Instruction.ADC)
 222                      orelse
 223                      (oper = Instruction.AND)
 224                      orelse
 225                      (oper = Instruction.OR)
 226                      orelse
 227                      (oper = Instruction.XOR)
 228                     then case (Operand.deMemloc src1, Operand.deMemloc src2)
 229                            of (SOME memloc_src1, SOME memloc_src2)
 230                             => if x86Liveness.track memloc_src1
 231                                   andalso
 232                                   x86Liveness.track memloc_src2
 233                                  then (src2,src1)
 234                                  else (src1,src2)
 235                             | _ => (src1,src2)
 236                     else (src1,src2)
 237             in
 238               AppendList.fromList
 239               [Block.mkBlock'
 240                {entry = NONE,
 241                 statements
 242                 = [Assembly.instruction_mov
 243                    {dst = dst,
 244                     src = src1,
 245                     size = src1size},
 246                    Assembly.instruction_binal
 247                    {oper = oper,
 248                     dst = dst,
 249                     src = src2,
 250                     size = dstsize}],
 251                 transfer = NONE}]
 252             end
 253
 254         fun binal64 (oper1, oper2)
 255           = let
 256               val ((src1,src1size),
 257                    (src2,src2size),
 258                    (src3,src3size),
 259                    (src4,src4size)) = getSrc4 ()
 260               val ((dst1,dst1size),
 261                    (dst2,dst2size)) = getDst2 ()
 262               val _
 263                 = Assert.assert
 264                   ("x86MLton.prim: binal64, dst1size/dst2size/src1size/src2size/src3size/src4size",
 265                    fn () => src1size = dst1size andalso
 266                             src3size = dst1size andalso
 267                             src2size = dst2size andalso
 268                             src4size = dst2size andalso
 269                             dst1size = dst2size)
 270               val tdst1 =
 271                  if List.exists ([src2,src3,src4], fn src =>
 272                                  Operand.mayAlias (dst1, src))
 273                     then wordTemp1ContentsOperand dst1size
 274                     else dst1
 275               val tdst2 =
 276                  if List.exists ([src3,src4], fn src =>
 277                                  Operand.mayAlias (dst2, src))
 278                     then wordTemp1ContentsOperand dst2size
 279                     else dst2
 280             in
 281               AppendList.fromList
 282               [Block.mkBlock'
 283                {entry = NONE,
 284                 statements
 285                 = [Assembly.instruction_mov
 286                    {dst = tdst1,
 287                     src = src1,
 288                     size = src1size},
 289                    Assembly.instruction_mov
 290                    {dst = tdst2,
 291                     src = src2,
 292                     size = src2size},
 293                    Assembly.instruction_binal
 294                    {oper = oper1,
 295                     dst = tdst1,
 296                     src = src3,
 297                     size = dst1size},
 298                    Assembly.instruction_binal
 299                    {oper = oper2,
 300                     dst = tdst2,
 301                     src = src4,
 302                     size = dst2size},
 303                    Assembly.instruction_mov
 304                    {dst = dst1,
 305                     src = tdst1,
 306                     size = dst1size},
 307                    Assembly.instruction_mov
 308                    {dst = dst2,
 309                     src = tdst2,
 310                     size = dst2size}],
 311                 transfer = NONE}]
 312             end
 313
 314         fun pmd oper
 315           = let
 316               val ((src1,src1size),
 317                    (src2,src2size)) = getSrc2 ()
 318               val (dst,dstsize) = getDst1 ()
 319               val _
 320                 = Assert.assert
 321                   ("x86MLton.prim: pmd, dstsize/src1size/src2size",
 322                    fn () => src1size = dstsize andalso
 323                             src2size = dstsize)
 324
 325               (* Reverse src1/src2 when src1 and src2 are temporaries
 326                * and the oper is commutative.
 327                *)
 328               val (src1,src2)
 329                 = if (oper = Instruction.IMUL)
 330                      orelse
 331                      (oper = Instruction.MUL)
 332                     then case (Operand.deMemloc src1, Operand.deMemloc src2)
 333                            of (SOME memloc_src1, SOME memloc_src2)
 334                             => if x86Liveness.track memloc_src1
 335                                   andalso
 336                                   x86Liveness.track memloc_src2
 337                                  then (src2,src1)
 338                                  else (src1,src2)
 339                             | _ => (src1,src2)
 340                     else (src1,src2)
 341             in
 342               AppendList.fromList
 343               [Block.mkBlock'
 344                {entry = NONE,
 345                 statements
 346                 = [Assembly.instruction_mov
 347                    {dst = dst,
 348                     src = src1,
 349                     size = src1size},
 350                    Assembly.instruction_pmd
 351                    {oper = oper,
 352                     dst = dst,
 353                     src = src2,
 354                     size = dstsize}],
 355                 transfer = NONE}]
 356             end
 357
 358         fun imul2 ()
 359           = let
 360               val ((src1,src1size),
 361                    (src2,src2size)) = getSrc2 ()
 362               val (dst,dstsize) = getDst1 ()
 363               val _
 364                 = Assert.assert
 365                   ("x86MLton.prim: imul2, dstsize/src1size/src2size",
 366                    fn () => src1size = dstsize andalso
 367                             src2size = dstsize)
 368
 369               (* Reverse src1/src2 when src1 and src2 are temporaries
 370                * and the oper is commutative.
 371                *)
 372               val (src1,src2)
 373                 = case (Operand.deMemloc src1, Operand.deMemloc src2)
 374                     of (SOME memloc_src1, SOME memloc_src2)
 375                      => if x86Liveness.track memloc_src1
 376                            andalso
 377                            x86Liveness.track memloc_src2
 378                           then (src2,src1)
 379                           else (src1,src2)
 380                      | _ => (src1,src2)
 381             in
 382               AppendList.fromList
 383               [Block.mkBlock'
 384                {entry = NONE,
 385                 statements
 386                 = [Assembly.instruction_mov
 387                    {dst = dst,
 388                     src = src1,
 389                     size = src1size},
 390                    Assembly.instruction_imul2
 391                    {dst = dst,
 392                     src = src2,
 393                     size = dstsize}],
 394                 transfer = NONE}]
 395             end
 396
 397         fun unal oper
 398           = let
 399               val (src,srcsize) = getSrc1 ()
 400               val (dst,dstsize) = getDst1 ()
 401               val _
 402                 = Assert.assert
 403                   ("x86MLton.prim: unal, dstsize/srcsize",
 404                    fn () => srcsize = dstsize)
 405             in
 406               AppendList.fromList
 407               [Block.mkBlock'
 408                {entry = NONE,
 409                 statements
 410                 = [Assembly.instruction_mov
 411                    {dst = dst,
 412                     src = src,
 413                     size = srcsize},
 414                    Assembly.instruction_unal
 415                    {oper = oper,
 416                     dst = dst,
 417                     size = dstsize}],
 418                 transfer = NONE}]
 419             end
 420
 421         fun unal64 (oper, mk)
 422           = let
 423               val ((src1,src1size),(src2,src2size)) = getSrc2 ()
 424               val ((dst1,dst1size),(dst2,dst2size)) = getDst2 ()
 425               val _
 426                 = Assert.assert
 427                   ("x86MLton.prim: unal64, dst1size/dst2size/src1size/src2size",
 428                    fn () => src1size = dst1size andalso
 429                             src2size = dst2size andalso
 430                             dst1size = dst2size)
 431               val tdst1 =
 432                  if List.exists ([src2], fn src =>
 433                                  Operand.mayAlias (dst1, src))
 434                     then wordTemp1ContentsOperand dst1size
 435                     else dst1
 436             in
 437               AppendList.fromList
 438               [Block.mkBlock'
 439                {entry = NONE,
 440                 statements
 441                 = [Assembly.instruction_mov
 442                    {dst = tdst1,
 443                     src = src1,
 444                     size = src1size},
 445                    Assembly.instruction_mov
 446                    {dst = dst2,
 447                     src = src2,
 448                     size = src2size},
 449                    Assembly.instruction_mov
 450                    {dst = dst1,
 451                     src = tdst1,
 452                     size = dst1size},
 453                    Assembly.instruction_unal
 454                    {oper = oper,
 455                     dst = dst1,
 456                     size = dst1size}] @
 457                   (mk (dst2,dst2size)) @
 458                   [Assembly.instruction_unal
 459                    {oper = oper,
 460                     dst = dst2,
 461                     size = dst2size}],
 462                 transfer = NONE}]
 463             end
 464
 465         fun sral oper
 466           = let
 467               val (dst,dstsize) = getDst1 ()
 468               val ((src1,src1size),
 469                    (src2,src2size)) = getSrc2 ()
 470               val _
 471                 = Assert.assert
 472                   ("x86MLton.prim: sral, dstsize/src1size",
 473                    fn () => src1size = dstsize)
 474               val _
 475                 = Assert.assert
 476                   ("x86MLton.prim: sral, src2size",
 477                    fn () => src2size = wordSize)
 478             in
 479               AppendList.fromList
 480               [Block.mkBlock'
 481                {entry = NONE,
 482                 statements
 483                 = [Assembly.instruction_mov
 484                    {dst = dst,
 485                     src = src1,
 486                     size = dstsize},
 487                    Assembly.instruction_sral
 488                    {oper = oper,
 489                     dst = dst,
 490                     count = src2,
 491                     size = dstsize}],
 492                 transfer = NONE}]
 493             end
 494
 495         fun cmp condition
 496           = let
 497               val (dst,dstsize) = getDst1 ()
 498               val ((src1,src1size),
 499                    (src2,src2size)) = getSrc2 ()
 500               val _
 501                 = Assert.assert
 502                   ("x86MLton.prim: cmp, src1size/src2size",
 503                    fn () => src1size = src2size)
 504             in
 505               (* Can't have an immediate in src1 position,
 506                * so reverse the srcs and reverse the condition.
 507                *
 508                * This won't fix an immediate in both positions.
 509                * Either constant folding eliminated it
 510                * or the register allocator will raise an error.
 511                *)
 512               case Operand.deImmediate src1
 513                 of SOME _ => AppendList.fromList
 514                              [Block.mkBlock'
 515                               {entry = NONE,
 516                                statements
 517                                = [Assembly.instruction_cmp
 518                                   {src1 = src2,
 519                                    src2 = src1,
 520                                    size = src1size},
 521                                   Assembly.instruction_setcc
 522                                   {condition = Instruction.condition_reverse condition,
 523                                    dst = dst,
 524                                    size = dstsize}],
 525                                transfer = NONE}]
 526                  | NONE => AppendList.fromList
 527                            [Block.mkBlock'
 528                             {entry = NONE,
 529                              statements
 530                              = [Assembly.instruction_cmp
 531                                 {src1 = src1,
 532                                  src2 = src2,
 533                                  size = src1size},
 534                                 Assembly.instruction_setcc
 535                                 {condition = condition,
 536                                  dst = dst,
 537                                  size = dstsize}],
 538                              transfer = NONE}]
 539             end
 540
 541         fun fbina oper
 542           = let
 543               val (dst,dstsize) = getDst1 ()
 544               val ((src1,src1size),
 545                    (src2,src2size)) = getSrc2 ()
 546               val _
 547                 = Assert.assert
 548                   ("x86MLton.prim: fbina, dstsize/src1size/src2size",
 549                    fn () => src1size = dstsize andalso
 550                             src2size = dstsize)
 551
 552               (* Reverse src1/src2 when src1 and src2 are temporaries.
 553                *)
 554               val (oper,src1,src2)
 555                 = case (Operand.deMemloc src1, Operand.deMemloc src2)
 556                     of (SOME memloc_src1, SOME memloc_src2)
 557                      => if x86Liveness.track memloc_src1
 558                            andalso
 559                            x86Liveness.track memloc_src2
 560                           then (Instruction.fbina_reverse oper,src2,src1)
 561                           else (oper,src1,src2)
 562                      | _ => (oper,src1,src2)
 563             in
 564               AppendList.fromList
 565               [Block.mkBlock'
 566                {entry = NONE,
 567                 statements
 568                 = [Assembly.instruction_pfmov
 569                    {dst = dst,
 570                     src = src1,
 571                     size = src1size},
 572                    Assembly.instruction_pfbina
 573                    {oper = oper,
 574                     dst = dst,
 575                     src = src2,
 576                     size = dstsize}],
 577                 transfer = NONE}]
 578             end
 579
 580         fun fbina_fmul oper
 581           = let
 582               val (dst,dstsize) = getDst1 ()
 583               val ((src1,src1size),
 584                    (src2,src2size),
 585                    (src3,src3size)) = getSrc3 ()
 586               val _
 587                 = Assert.assert
 588                   ("x86MLton.prim: fbina_fmul, dstsize/src1size/src2size/src3size",
 589                    fn () => src1size = dstsize andalso
 590                             src2size = dstsize andalso
 591                             src3size = dstsize)
 592             in
 593               AppendList.fromList
 594               [Block.mkBlock'
 595                {entry = NONE,
 596                 statements
 597                 = [Assembly.instruction_pfmov
 598                    {dst = dst,
 599                     src = src1,
 600                     size = src1size},
 601                    Assembly.instruction_pfbina
 602                    {oper = Instruction.FMUL,
 603                     dst = dst,
 604                     src = src2,
 605                     size = dstsize},
 606                    Assembly.instruction_pfbina
 607                    {oper = oper,
 608                     dst = dst,
 609                     src = src3,
 610                     size = dstsize}],
 611                 transfer = NONE}]
 612             end
 613
 614         fun funa oper
 615           = let
 616               val (dst,dstsize) = getDst1 ()
 617               val (src,srcsize) = getSrc1 ()
 618               val _
 619                 = Assert.assert
 620                   ("x86MLton.prim: funa, dstsize/srcsize",
 621                    fn () => srcsize = dstsize)
 622             in
 623               AppendList.fromList
 624               [Block.mkBlock'
 625                {entry = NONE,
 626                 statements
 627                 = [Assembly.instruction_pfmov
 628                    {dst = dst,
 629                     src = src,
 630                     size = srcsize},
 631                    Assembly.instruction_pfuna
 632                    {oper = oper,
 633                     dst = dst,
 634                     size = dstsize}],
 635                 transfer = NONE}]
 636             end
 637
 638         fun flogarithm oper
 639           = let
 640               val (dst,dstsize) = getDst1 ()
 641               val (src,srcsize) = getSrc1 ()
 642               val _
 643                 = Assert.assert
 644                   ("x86MLton.prim: flogarithm, dstsize/srcsize",
 645                    fn () => srcsize = dstsize)
 646             in
 647               AppendList.fromList
 648               [Block.mkBlock'
 649                {entry = NONE,
 650                 statements
 651                 = [Assembly.instruction_pfldc
 652                    {oper = oper,
 653                     dst = dst,
 654                     size = dstsize},
 655                    Assembly.instruction_pfbinasp
 656                    {oper = Instruction.FYL2X,
 657                     src = src,
 658                     dst = dst,
 659                     size = dstsize}],
 660                 transfer = NONE}]
 661             end
 662
 663         val (comment_begin,
 664              comment_end)
 665           = if !Control.Native.commented > 0
 666               then let
 667                      val comment = primName
 668                    in
 669                      (AppendList.single
 670                       (x86.Block.mkBlock'
 671                        {entry = NONE,
 672                         statements
 673                         = [x86.Assembly.comment
 674                            ("begin prim: " ^ comment)],
 675                         transfer = NONE}),
 676                       AppendList.single
 677                       (x86.Block.mkBlock'
 678                        {entry = NONE,
 679                         statements
 680                         = [x86.Assembly.comment
 681                            ("end prim: " ^ comment)],
 682                         transfer = NONE}))
 683                    end
 684               else (AppendList.empty,AppendList.empty)
 685         fun bitop (size, i) =
 686            case WordSize.prim size of
 687               W8 => binal i
 688             | W16 => binal i
 689             | W32 => binal i
 690             | W64 => binal64 (i, i)
 691         fun compare (size, {signed}, s, u) =
 692            let
 693               val f = if signed then s else u
 694            in
 695               case WordSize.prim size of
 696                  W8 => cmp f
 697                | W16 => cmp f
 698                | W32 => cmp f
 699                | W64 => Error.bug "x86MLton.prim: compare, W64"
 700            end
 701         fun shift (size, i) =
 702            case WordSize.prim size of
 703               W8 => sral i
 704             | W16 => sral i
 705             | W32 => sral i
 706             | W64 => Error.bug "x86MLton.prim: shift, W64"
 707       in
 708         AppendList.appends
 709         [comment_begin,
 710          (case Prim.name prim of
 711                CPointer_add => binal Instruction.ADD
 712              | CPointer_diff => binal Instruction.SUB
 713              | CPointer_equal => cmp Instruction.E
 714              | CPointer_fromWord => mov ()
 715              | CPointer_lt => cmp Instruction.B
 716              | CPointer_sub => binal Instruction.SUB
 717              | CPointer_toWord => mov ()
 718              | FFI_Symbol {name, symbolScope, ...}
 719              => let
 720                    datatype z = datatype CFunction.SymbolScope.t
 721                    datatype z = datatype Control.Format.t
 722                    datatype z = datatype MLton.Platform.OS.t
 723
 724                    val (dst, dstsize) = getDst1 ()
 725
 726                    val label = fn () => Label.fromString name
 727
 728                    (* how to access an imported label's address *)
 729                    (* windows coff will add another leading _ to label *)
 730                    val coff = fn () => Label.fromString ("_imp__" ^ name)
 731                    val macho = fn () =>
 732                       let
 733                          val label =
 734                             Label.newString (concat ["L_", name, "_non_lazy_ptr"])
 735                          val () =
 736                             addData
 737                             [Assembly.pseudoop_non_lazy_symbol_pointer (),
 738                              Assembly.label label,
 739                              Assembly.pseudoop_indirect_symbol (Label.fromString name),
 740                              Assembly.pseudoop_long [Immediate.zero]]
 741                       in
 742                          label
 743                       end
 744                    val elf = fn () => Label.fromString (name ^ "@GOT")
 745
 746                    val importLabel = fn () =>
 747                       case !Control.Target.os of
 748                          Cygwin => coff ()
 749                        | Darwin => macho ()
 750                        | MinGW => coff ()
 751                        | _ => elf ()
 752
 753                    val direct = fn () =>
 754                       AppendList.fromList
 755                       [Block.mkBlock'
 756                        {entry = NONE,
 757                         statements =
 758                         [Assembly.instruction_lea
 759                          {dst = dst,
 760                           src = Operand.memloc_label (label ()),
 761                           size = dstsize}],
 762                         transfer = NONE}]
 763
 764                    val indirect = fn () =>
 765                       AppendList.fromList
 766                       [Block.mkBlock'
 767                        {entry = NONE,
 768                         statements =
 769                         [Assembly.instruction_mov
 770                          {dst = dst,
 771                           src = Operand.memloc_label (importLabel ()),
 772                           size = dstsize}],
 773                         transfer = NONE}]
 774                 in
 775                    case (symbolScope,
 776                          !Control.Target.os,
 777                          !Control.positionIndependent) of
 778                     (* Even private PIC symbols on darwin need indirection. *)
 779                       (Private, Darwin, true) => indirect ()
 780                     (* As long as the symbol is private (thus it is not
 781                      * exported to code outside this text segment), then
 782                      * use normal addressing. If PIC is needed, then the
 783                      * memloc_label is updated to relative access in the
 784                      * allocate-registers pass.
 785                      *)
 786                     | (Private, _, _) => direct ()
 787                     (* On darwin, even executables use the defintion address.
 788                      * Therefore we don't need to do indirection.
 789                      *)
 790                     | (Public, Darwin, _) => direct ()
 791                     (* On ELF, a public symbol must be accessed via
 792                      * the GOT. This is because the final value may not be
 793                      * in this text segment. If the executable uses it, then
 794                      * the unique C address resides in the executable's
 795                      * text segment. The loader does this by creating a PLT
 796                      * proxy or copying values to the executable text segment.
 797                      * When linking an executable, ELF uses a special trick
 798                      * to "simplify" the code. All exported functions and
 799                      * symbols have pointers that correspond  to the
 800                      * executable. Function pointers point to the
 801                      * automatically created PLT entry in the executable.
 802                      * Variables are copied/relocated into the executable bss.
 803                      *
 804                      * This means that direct access is fine for executable
 805                      * and archive formats. (It also means direct access is
 806                      * NOT fine for a library, even if it defines the symbol)
 807                      *
 808                      *)
 809                     | (Public, _, true) => indirect ()
 810                     | (Public, _, false) => direct ()
 811                     (* On darwin, the address is the point of definition. So
 812                      * indirection is needed. We also need to make a stub!
 813                      *)
 814                     | (External, Darwin, _) => indirect ()
 815                     (* On windows, the address is the point of definition. So
 816                      * we must always use an indirect lookup to the symbols
 817                      * windows rewrites (__imp__name) in our segment.
 818                      *)
 819                     | (External, MinGW, _) => indirect ()
 820                     | (External, Cygwin, _) => indirect ()
 821                     (* When compiling ELF to a library, we access external
 822                      * symbols via some address that is updated by the loader.
 823                      * That address resides within our data segment, and can
 824                      * be easily referenced using RBX-relative addressing.
 825                      * This trick is used on every platform MLton supports.
 826                      * ELF rewrites symbols of form name@GOT.
 827                      *)
 828                     | (External, _, true) => indirect ()
 829                     | (External, _, false) => direct ()
 830                 end
 831              | Real_Math_acos _
 832              => let
 833                   val (dst,dstsize) = getDst1 ()
 834                   val (src,srcsize) = getSrc1 ()
 835                   val _
 836                     = Assert.assert
 837                       ("x86MLton.prim: Real_Math_acos, dstsize/srcsize",
 838                        fn () => srcsize = dstsize)
 839                   val realTemp1ContentsOperand = realTemp1ContentsOperand srcsize
 840                   val realTemp2ContentsOperand = realTemp2ContentsOperand srcsize
 841                   val realTemp3ContentsOperand = realTemp3ContentsOperand srcsize
 842                 in
 843                   AppendList.fromList
 844                   [Block.mkBlock'
 845                    {entry = NONE,
 846                     statements
 847                     = [Assembly.instruction_pfmov
 848                        {dst = realTemp1ContentsOperand,
 849                         src = src,
 850                         size = srcsize},
 851                        Assembly.instruction_pfmov
 852                        {dst = realTemp2ContentsOperand,
 853                         src = realTemp1ContentsOperand,
 854                         size = srcsize},
 855                        Assembly.instruction_pfbina
 856                        {oper = Instruction.FMUL,
 857                         dst = realTemp2ContentsOperand,
 858                         src = realTemp2ContentsOperand,
 859                         size = srcsize},
 860                        Assembly.instruction_pfldc
 861                        {oper = Instruction.ONE,
 862                         dst = realTemp3ContentsOperand,
 863                         size = srcsize},
 864                        Assembly.instruction_pfbina
 865                        {oper = Instruction.FSUB,
 866                         dst = realTemp3ContentsOperand,
 867                         src = realTemp2ContentsOperand,
 868                         size = srcsize},
 869                        Assembly.instruction_pfuna
 870                        {oper = Instruction.FSQRT,
 871                         dst = realTemp3ContentsOperand,
 872                         size = srcsize},
 873                        Assembly.instruction_pfmov
 874                        {dst = dst,
 875                         src = realTemp3ContentsOperand,
 876                         size = dstsize},
 877                        Assembly.instruction_pfbinasp
 878                        {oper = Instruction.FPATAN,
 879                         src = realTemp1ContentsOperand,
 880                         dst = dst,
 881                         size = dstsize}],
 882                     transfer = NONE}]
 883                 end
 884              | Real_Math_asin _
 885              => let
 886                   val (dst,dstsize) = getDst1 ()
 887                   val (src,srcsize) = getSrc1 ()
 888                   val _
 889                     = Assert.assert
 890                       ("x86MLton.prim: Real_Math_asin, dstsize/srcsize",
 891                        fn () => srcsize = dstsize)
 892                   val realTemp1ContentsOperand = realTemp1ContentsOperand srcsize
 893                   val realTemp2ContentsOperand = realTemp2ContentsOperand srcsize
 894                 in
 895                   AppendList.fromList
 896                   [Block.mkBlock'
 897                    {entry = NONE,
 898                     statements
 899                     = [Assembly.instruction_pfmov
 900                        {dst = dst,
 901                         src = src,
 902                         size = srcsize},
 903                        Assembly.instruction_pfmov
 904                        {dst = realTemp1ContentsOperand,
 905                         src = dst,
 906                         size = dstsize},
 907                        Assembly.instruction_pfbina
 908                        {oper = Instruction.FMUL,
 909                         dst = realTemp1ContentsOperand,
 910                         src = realTemp1ContentsOperand,
 911                         size = dstsize},
 912                        Assembly.instruction_pfldc
 913                        {oper = Instruction.ONE,
 914                         dst = realTemp2ContentsOperand,
 915                         size = dstsize},
 916                        Assembly.instruction_pfbina
 917                        {oper = Instruction.FSUB,
 918                         dst = realTemp2ContentsOperand,
 919                         src = realTemp1ContentsOperand,
 920                         size = dstsize},
 921                        Assembly.instruction_pfuna
 922                        {oper = Instruction.FSQRT,
 923                         dst = realTemp2ContentsOperand,
 924                         size = dstsize},
 925                        Assembly.instruction_pfbinasp
 926                        {oper = Instruction.FPATAN,
 927                         src = realTemp2ContentsOperand,
 928                         dst = dst,
 929                         size = dstsize}],
 930                     transfer = NONE}]
 931                 end
 932              | Real_Math_atan _
 933              => let
 934                   val (dst,dstsize) = getDst1 ()
 935                   val (src,srcsize) = getSrc1 ()
 936                   val _
 937                     = Assert.assert
 938                       ("x86MLton.prim: Real_Math_atan, dstsize/srcsize",
 939                        fn () => srcsize = dstsize)
 940                   val realTemp1ContentsOperand = realTemp1ContentsOperand srcsize
 941                 in
 942                   AppendList.fromList
 943                   [Block.mkBlock'
 944                    {entry = NONE,
 945                     statements
 946                     = [Assembly.instruction_pfmov
 947                        {dst = dst,
 948                         src = src,
 949                         size = srcsize},
 950                        Assembly.instruction_pfldc
 951                        {oper = Instruction.ONE,
 952                         dst = realTemp1ContentsOperand,
 953                         size = dstsize},
 954                        Assembly.instruction_pfbinasp
 955                        {oper = Instruction.FPATAN,
 956                         src = realTemp1ContentsOperand,
 957                         dst = dst,
 958                         size = dstsize}],
 959                     transfer = NONE}]
 960                 end
 961              | Real_Math_atan2 _
 962              => let
 963                   val (dst,dstsize) = getDst1 ()
 964                   val ((src1,src1size),
 965                        (src2,src2size))= getSrc2 ()
 966                   val _
 967                     = Assert.assert
 968                       ("x86MLton.prim: Real_Math_atan2, dstsize/src1size/src2size",
 969                        fn () => src1size = dstsize andalso
 970                                 src2size = dstsize)
 971                 in
 972                   AppendList.fromList
 973                   [Block.mkBlock'
 974                    {entry = NONE,
 975                     statements
 976                     = [Assembly.instruction_pfmov
 977                        {dst = dst,
 978                         src = src1,
 979                         size = src1size},
 980                        Assembly.instruction_pfbinasp
 981                        {oper = Instruction.FPATAN,
 982                         src = src2,
 983                         dst = dst,
 984                         size = dstsize}],
 985                     transfer = NONE}]
 986                 end
 987              | Real_Math_cos _ => funa Instruction.FCOS
 988              | Real_Math_exp _
 989              => let
 990                   val (dst,dstsize) = getDst1 ()
 991                   val (src,srcsize) = getSrc1 ()
 992                   val _
 993                     = Assert.assert
 994                       ("x86MLton.prim: Real_Math_exp, dstsize/srcsize",
 995                        fn () => srcsize = dstsize)
 996                   val realTemp1ContentsOperand = realTemp1ContentsOperand srcsize
 997                   val realTemp2ContentsOperand = realTemp2ContentsOperand srcsize
 998                 in
 999                   AppendList.fromList
1000                   [Block.mkBlock'
1001                    {entry = NONE,
1002                     statements
1003                     = [Assembly.instruction_pfldc
1004                        {oper = Instruction.L2E,
1005                         dst = dst,
1006                         size = dstsize},
1007                        Assembly.instruction_pfbina
1008                        {oper = Instruction.FMUL,
1009                         src = src,
1010                         dst = dst,
1011                         size = dstsize},
1012                        Assembly.instruction_pfmov
1013                        {src = dst,
1014                         dst = realTemp1ContentsOperand,
1015                         size = dstsize},
1016                        Assembly.instruction_pfuna
1017                        {oper = Instruction.FRNDINT,
1018                         dst = realTemp1ContentsOperand,
1019                         size = dstsize},
1020                        Assembly.instruction_pfbina
1021                        {oper = Instruction.FSUB,
1022                         src = realTemp1ContentsOperand,
1023                         dst = dst,
1024                         size = dstsize},
1025                        Assembly.instruction_pfuna
1026                        {oper = Instruction.F2XM1,
1027                         dst = dst,
1028                         size = dstsize},
1029                        Assembly.instruction_pfldc
1030                        {oper = Instruction.ONE,
1031                         dst = realTemp2ContentsOperand,
1032                         size = dstsize},
1033                        Assembly.instruction_pfbina
1034                        {oper = Instruction.FADD,
1035                         src = realTemp2ContentsOperand,
1036                         dst = dst,
1037                         size = dstsize},
1038                        Assembly.instruction_pfbinas
1039                        {oper = Instruction.FSCALE,
1040                         src = realTemp1ContentsOperand,
1041                         dst = dst,
1042                         size = dstsize}],
1043                     transfer = NONE}]
1044                 end
1045              | Real_Math_ln _ => flogarithm Instruction.LN2
1046              | Real_Math_log10 _ => flogarithm Instruction.LG2
1047              | Real_Math_sin _ => funa Instruction.FSIN
1048              | Real_Math_sqrt _ => funa Instruction.FSQRT
1049              | Real_Math_tan _
1050              => let
1051                   val (dst,dstsize) = getDst1 ()
1052                   val (src,srcsize) = getSrc1 ()
1053                   val _
1054                     = Assert.assert
1055                       ("x86MLton.prim: Real_Math_tan, dstsize/srcsize",
1056                        fn () => srcsize = dstsize)
1057                 in
1058                   AppendList.fromList
1059                   [Block.mkBlock'
1060                    {entry = NONE,
1061                     statements
1062                     = [Assembly.instruction_pfmov
1063                        {src = src,
1064                         dst = dst,
1065                         size = dstsize},
1066                        Assembly.instruction_pfptan
1067                        {dst = dst,
1068                         size = dstsize}],
1069                     transfer = NONE}]
1070                 end
1071              | Real_mul _ => fbina Instruction.FMUL
1072              | Real_muladd _ => fbina_fmul Instruction.FADD
1073              | Real_mulsub _ => fbina_fmul Instruction.FSUB
1074              | Real_add _ => fbina Instruction.FADD
1075              | Real_sub _ => fbina Instruction.FSUB
1076              | Real_div _ => fbina Instruction.FDIV
1077              | Real_lt _
1078              => let
1079                   val (dst,dstsize) = getDst1 ()
1080                   val ((src1,src1size),
1081                        (src2,src2size))= getSrc2 ()
1082                   val _
1083                     = Assert.assert
1084                       ("x86MLton.prim: Real_lt, src1size/src2size",
1085                        fn () => src1size = src2size)
1086                 in
1087                   AppendList.fromList
1088                   [Block.mkBlock'
1089                    {entry = NONE,
1090                     statements
1091                     = [Assembly.instruction_pfcom
1092                        {src1 = src2,
1093                         src2 = src1,
1094                         size = src1size},
1095                        Assembly.instruction_fstsw
1096                        {dst = fpswTempContentsOperand,
1097                         check = false},
1098                        Assembly.instruction_test
1099                        {src1 = fpswTempContentsOperand,
1100                         src2 = Operand.immediate_int' (0x4500, WordSize.word16),
1101                         size = Size.WORD},
1102                        Assembly.instruction_setcc
1103                        {condition = Instruction.Z,
1104                         dst = dst,
1105                         size = dstsize}],
1106                     transfer = NONE}]
1107                 end
1108              | Real_le _
1109              => let
1110                   val (dst,dstsize) = getDst1 ()
1111                   val ((src1,src1size),
1112                        (src2,src2size))= getSrc2 ()
1113                   val _
1114                     = Assert.assert
1115                       ("x86MLton.prim: Real_le, src1size/src2size",
1116                        fn () => src1size = src2size)
1117                 in
1118                   AppendList.fromList
1119                   [Block.mkBlock'
1120                    {entry = NONE,
1121                     statements
1122                     = [Assembly.instruction_pfcom
1123                        {src1 = src2,
1124                         src2 = src1,
1125                         size = src1size},
1126                        Assembly.instruction_fstsw
1127                        {dst = fpswTempContentsOperand,
1128                         check = false},
1129                        Assembly.instruction_test
1130                        {src1 = fpswTempContentsOperand,
1131                         src2 = Operand.immediate_int' (0x500, WordSize.word16),
1132                         size = Size.WORD},
1133                        Assembly.instruction_setcc
1134                        {condition = Instruction.Z,
1135                         dst = dst,
1136                         size = dstsize}],
1137                     transfer = NONE}]
1138                 end
1139              | Real_equal _
1140              => let
1141                   val (dst,dstsize) = getDst1 ()
1142                   val ((src1,src1size),
1143                        (src2,src2size))= getSrc2 ()
1144                   val _
1145                     = Assert.assert
1146                       ("x86MLton.prim: Real_equal, src1size/src2size",
1147                        fn () => src1size = src2size)
1148                 in
1149                   AppendList.fromList
1150                   [Block.mkBlock'
1151                    {entry = NONE,
1152                     statements
1153                     = [Assembly.instruction_pfucom
1154                        {src1 = src2,
1155                         src2 = src1,
1156                         size = src1size},
1157                        Assembly.instruction_fstsw
1158                        {dst = fpswTempContentsOperand,
1159                         check = false},
1160                        Assembly.instruction_binal
1161                        {oper = Instruction.AND,
1162                         dst = fpswTempContentsOperand,
1163                         src = Operand.immediate_int' (0x4500, WordSize.word16),
1164                         size = Size.WORD},
1165                        Assembly.instruction_cmp
1166                        {src1 = fpswTempContentsOperand,
1167                         src2 = Operand.immediate_int' (0x4000, WordSize.word16),
1168                         size = Size.WORD},
1169                        Assembly.instruction_setcc
1170                        {condition = Instruction.E,
1171                         dst = dst,
1172                         size = dstsize}],
1173                     transfer = NONE}]
1174                 end
1175              | Real_qequal _
1176              => let
1177                   val (dst,dstsize) = getDst1 ()
1178                   val ((src1,src1size),
1179                        (src2,src2size))= getSrc2 ()
1180                   val _
1181                     = Assert.assert
1182                       ("x86MLton.prim: Real_qequal, src1size/src2size",
1183                        fn () => src1size = src2size)
1184                 in
1185                   AppendList.fromList
1186                   [Block.mkBlock'
1187                    {entry = NONE,
1188                     statements
1189                     = [Assembly.instruction_pfucom
1190                        {src1 = src2,
1191                         src2 = src1,
1192                         size = src1size},
1193                        Assembly.instruction_fstsw
1194                        {dst = fpswTempContentsOperand,
1195                         check = false},
1196                        Assembly.instruction_test
1197                        {src1 = fpswTempContentsOperand,
1198                         src2 = Operand.immediate_int' (0x4400, WordSize.word16),
1199                         size = Size.WORD},
1200                        Assembly.instruction_setcc
1201                        {condition = Instruction.NE,
1202                         dst = dst,
1203                         size = dstsize}],
1204                     transfer = NONE}]
1205                 end
1206              | Real_abs _ => funa Instruction.FABS
1207              | Real_rndToReal (s, s')
1208              => let
1209                   val (dst,dstsize) = getDst1 ()
1210                   val (src,srcsize) = getSrc1 ()
1211                   fun mov () =
1212                      AppendList.fromList
1213                      [Block.mkBlock'
1214                       {entry = NONE,
1215                        statements
1216                        = [Assembly.instruction_pfmov
1217                           {dst = dst,
1218                            src = src,
1219                            size = srcsize}],
1220                        transfer = NONE}]
1221                   fun movx () =
1222                      AppendList.fromList
1223                      [Block.mkBlock'
1224                       {entry = NONE,
1225                        statements
1226                        = [Assembly.instruction_pfmovx
1227                           {dst = dst,
1228                            src = src,
1229                            srcsize = srcsize,
1230                            dstsize = dstsize}],
1231                        transfer = NONE}]
1232                   fun xvom () =
1233                      AppendList.fromList
1234                      [Block.mkBlock'
1235                       {entry = NONE,
1236                        statements
1237                        = [Assembly.instruction_pfxvom
1238                           {dst = dst,
1239                            src = src,
1240                            srcsize = srcsize,
1241                            dstsize = dstsize}],
1242                        transfer = NONE}]
1243                 in
1244                    case (s, s') of
1245                       (R64, R64) => mov ()
1246                     | (R64, R32) => xvom ()
1247                     | (R32, R64) => movx ()
1248                     | (R32, R32) => mov ()
1249                 end
1250              | Real_rndToWord (s, s', _)
1251              => let
1252                   fun default () =
1253                     let
1254                       val (dst,dstsize) = getDst1 ()
1255                       val (src,srcsize) = getSrc1 ()
1256                     in
1257                       AppendList.fromList
1258                       [Block.mkBlock'
1259                        {entry = NONE,
1260                         statements
1261                         = [Assembly.instruction_pfmovti
1262                            {dst = dst,
1263                             src = src,
1264                             srcsize = srcsize,
1265                             dstsize = dstsize}],
1266                         transfer = NONE}]
1267                     end
1268                   fun default' () =
1269                     let
1270                       val (dst,dstsize) = getDst1 ()
1271                       val (src,srcsize) = getSrc1 ()
1272                       val (tmp,tmpsize) =
1273                          (fildTempContentsOperand, Size.WORD)
1274                     in
1275                       AppendList.fromList
1276                       [Block.mkBlock'
1277                        {entry = NONE,
1278                         statements
1279                         = [Assembly.instruction_pfmovti
1280                            {dst = tmp,
1281                             src = src,
1282                             srcsize = srcsize,
1283                             dstsize = tmpsize},
1284                            Assembly.instruction_xvom
1285                            {src = tmp,
1286                             dst = dst,
1287                             dstsize = dstsize,
1288                             srcsize = tmpsize}],
1289                         transfer = NONE}]
1290                     end
1291                 in
1292                    case (s, WordSize.prim s') of
1293                       (R64, W64) => Error.bug "x86MLton.prim: Real_toWord, W64"
1294                     | (R64, W32) => default ()
1295                     | (R64, W16) => default ()
1296                     | (R64, W8) => default' ()
1297                     | (R32, W64) => Error.bug "x86MLton.prim: Real_toWord, W64"
1298                     | (R32, W32) => default ()
1299                     | (R32, W16) => default ()
1300                     | (R32, W8) => default' ()
1301                 end
1302              | Real_ldexp _
1303              => let
1304                   val (dst,dstsize) = getDst1 ()
1305                   val ((src1,src1size),
1306                        (src2,src2size)) = getSrc2 ()
1307                   val _
1308                     = Assert.assert
1309                       ("x86MLton.prim: Real_ldexp, dstsize/src1size",
1310                        fn () => src1size = dstsize)
1311                   val _
1312                     = Assert.assert
1313                       ("x86MLton.prim: Real_ldexp, src2size",
1314                        fn () => src2size = Size.LONG)
1315                   val realTemp1ContentsOperand = realTemp1ContentsOperand src1size
1316                 in
1317                   AppendList.fromList
1318                   [Block.mkBlock'
1319                    {entry = NONE,
1320                     statements
1321                     = [Assembly.instruction_pfmovfi
1322                        {dst = realTemp1ContentsOperand,
1323                         src = src2,
1324                         srcsize = src2size,
1325                         dstsize = dstsize},
1326                        Assembly.instruction_pfmov
1327                        {dst = dst,
1328                         src = src1,
1329                         size = dstsize},
1330                        Assembly.instruction_pfbinas
1331                        {oper = Instruction.FSCALE,
1332                         dst = dst,
1333                         src = realTemp1ContentsOperand,
1334                         size = dstsize}],
1335                     transfer = NONE}]
1336                 end
1337              | Real_neg _ => funa Instruction.FCHS
1338              | Real_round _ => funa Instruction.FRNDINT
1339              | Word_add s =>
1340                 (case WordSize.prim s of
1341                     W8 => binal Instruction.ADD
1342                   | W16 => binal Instruction.ADD
1343                   | W32 => binal Instruction.ADD
1344                   | W64 => binal64 (Instruction.ADD, Instruction.ADC))
1345              | Word_andb s => bitop (s, Instruction.AND)
1346              | Word_equal _ => cmp Instruction.E
1347              | Word_lshift s => shift (s, Instruction.SHL)
1348              | Word_lt (s, sg) => compare (s, sg, Instruction.L, Instruction.B)
1349              | Word_mul (s, {signed}) =>
1350                 (case WordSize.prim s of
1351                     W8 => pmd (if signed
1352                                   then Instruction.IMUL
1353                                else Instruction.MUL)
1354                   | W16 => imul2 ()
1355                   | W32 => imul2 ()
1356                   | W64 => Error.bug "x86MLton.prim: Word_mul, W64")
1357              | Word_neg s =>
1358                 (case WordSize.prim s of
1359                     W8 => unal Instruction.NEG
1360                   | W16 => unal Instruction.NEG
1361                   | W32 => unal Instruction.NEG
1362                   | W64 => unal64 (Instruction.NEG,
1363                                    fn (dst,dstsize) => [Assembly.instruction_binal
1364                                                         {dst = dst,
1365                                                          oper = Instruction.ADC,
1366                                                          src = Operand.immediate_zero,
1367                                                          size = dstsize}]))
1368              | Word_notb s =>
1369                 (case WordSize.prim s of
1370                     W8 => unal Instruction.NOT
1371                   | W16 => unal Instruction.NOT
1372                   | W32 => unal Instruction.NOT
1373                   | W64 => unal64 (Instruction.NOT, fn _ => []))
1374              | Word_orb s => bitop (s, Instruction.OR)
1375              | Word_quot (_, {signed}) =>
1376                   pmd (if signed then Instruction.IDIV else Instruction.DIV)
1377              | Word_rem (_, {signed}) =>
1378                   pmd (if signed then Instruction.IMOD else Instruction.MOD)
1379              | Word_rol s => shift (s, Instruction.ROL)
1380              | Word_ror s => shift (s, Instruction.ROR)
1381              | Word_rshift (s, {signed}) =>
1382                   shift (s, if signed then Instruction.SAR else Instruction.SHR)
1383              | Word_sub s =>
1384                 (case WordSize.prim s of
1385                     W8 => binal Instruction.SUB
1386                   | W16 => binal Instruction.SUB
1387                   | W32 => binal Instruction.SUB
1388                   | W64 => binal64 (Instruction.SUB, Instruction.SBB))
1389              | Word_rndToReal (s, s', _)
1390              => let
1391                   fun default () =
1392                     let
1393                       val (dst,dstsize) = getDst1 ()
1394                       val (src,srcsize) = getSrc1 ()
1395                     in
1396                       AppendList.fromList
1397                       [Block.mkBlock'
1398                        {entry = NONE,
1399                         statements
1400                         = [Assembly.instruction_pfmovfi
1401                            {src = src,
1402                             dst = dst,
1403                             srcsize = srcsize,
1404                             dstsize = dstsize}],
1405                         transfer = NONE}]
1406                     end
1407                   fun default' () =
1408                     let
1409                       val (dst,dstsize) = getDst1 ()
1410                       val (src,srcsize) = getSrc1 ()
1411                       val (tmp,tmpsize) =
1412                          (fildTempContentsOperand, Size.WORD)
1413                     in
1414                       AppendList.fromList
1415                       [Block.mkBlock'
1416                        {entry = NONE,
1417                         statements
1418                         = [Assembly.instruction_movx
1419                            {oper = Instruction.MOVSX,
1420                             src = src,
1421                             dst = tmp,
1422                             dstsize = tmpsize,
1423                             srcsize = srcsize},
1424                            Assembly.instruction_pfmovfi
1425                            {src = tmp,
1426                             dst = dst,
1427                             srcsize = tmpsize,
1428                             dstsize = dstsize}],
1429                         transfer = NONE}]
1430                     end
1431                 in
1432                    case (WordSize.prim s, s') of
1433                       (W32, R64) => default ()
1434                     | (W32, R32) => default ()
1435                     | (W16, R64) => default ()
1436                     | (W16, R32) => default ()
1437                     | (W8, R64) => default' ()
1438                     | (W8, R32) => default' ()
1439                     | _ => Error.bug "x86MLton.prim: Word_toReal, W64"
1440                 end
1441              | Word_extdToWord (s, s', {signed}) =>
1442                   let
1443                      val b = WordSize.bits s
1444                      val b' = WordSize.bits s'
1445                   in
1446                      if Bits.< (b, b')
1447                         then movx (if signed
1448                                       then Instruction.MOVSX
1449                                    else Instruction.MOVZX)
1450                      else if Bits.equals (b, b')
1451                              then mov ()
1452                           else xvom ()
1453                   end
1454              | Word_xorb s => bitop (s, Instruction.XOR)
1455              | _ => Error.bug ("x86MLton.prim: strange Prim.Name.t: " ^ primName)),
1456          comment_end]
1457       end
1458
1459   fun ccall {args: (x86.Operand.t * x86.Size.t) vector,
1460              frameInfo,
1461              func,
1462              return: x86.Label.t option,
1463              transInfo = {...}: transInfo}
1464     = let
1465         val CFunction.T {convention, target, ...} = func
1466         val comment_begin
1467           = if !Control.Native.commented > 0
1468               then AppendList.single
1469                    (x86.Block.mkBlock'
1470                     {entry = NONE,
1471                      statements =
1472                      [x86.Assembly.comment
1473                       (concat
1474                        ["begin ccall: ",
1475                         CFunction.Convention.toString convention,
1476                         " ",
1477                         CFunction.Target.toString target])],
1478                      transfer = NONE})
1479             else AppendList.empty
1480       in
1481         AppendList.appends
1482         [comment_begin,
1483          AppendList.single
1484          (Block.mkBlock'
1485           {entry = NONE,
1486            statements = [],
1487            transfer = SOME (Transfer.ccall
1488                             {args = Vector.toList args,
1489                              frameInfo = frameInfo,
1490                              func = func,
1491                              return = return})})]
1492       end
1493
1494   fun creturn {dsts: (x86.Operand.t * x86.Size.t) vector,
1495                frameInfo: x86.FrameInfo.t option,
1496                func: RepType.t CFunction.t,
1497                label: x86.Label.t,
1498                transInfo = {live, liveInfo, ...}: transInfo}
1499     = let
1500         val CFunction.T {convention, target, ...} = func
1501         fun default ()
1502           = let
1503               val _ = x86Liveness.LiveInfo.setLiveOperands
1504                       (liveInfo, label, live label)
1505             in
1506               AppendList.single
1507               (x86.Block.mkBlock'
1508                {entry = SOME (Entry.creturn {dsts = dsts,
1509                                              frameInfo = frameInfo,
1510                                              func = func,
1511                                              label = label}),
1512                 statements = [],
1513                 transfer = NONE})
1514             end
1515         val comment_end
1516           = if !Control.Native.commented > 0
1517               then AppendList.single
1518                    (x86.Block.mkBlock'
1519                     {entry = NONE,
1520                      statements =
1521                      [x86.Assembly.comment
1522                       (concat
1523                        ["begin creturn: ",
1524                         CFunction.Convention.toString convention,
1525                         " ",
1526                         CFunction.Target.toString target])],
1527                      transfer = NONE})
1528               else AppendList.empty
1529       in
1530         AppendList.appends [default (), comment_end]
1531       end
1532
1533   fun arith {prim : RepType.t Prim.t,
1534              args : (Operand.t * Size.t) vector,
1535              dsts : (Operand.t * Size.t) vector,
1536              overflow : Label.t,
1537              success : Label.t,
1538              transInfo = {live, liveInfo, ...} : transInfo}
1539     = let
1540         val primName = Prim.toString prim
1541         datatype z = datatype Prim.Name.t
1542
1543         fun getDst1 ()
1544           = Vector.sub (dsts, 0)
1545             handle _ => Error.bug "x86MLton.arith: getDst1"
1546         fun getDst2 ()
1547           = (Vector.sub (dsts, 0), Vector.sub (dsts, 1))
1548             handle _ => Error.bug "x86MLton.arith: getDst2"
1549         fun getSrc1 ()
1550           = Vector.sub (args, 0)
1551             handle _ => Error.bug "x86MLton.arith: getSrc1"
1552         fun getSrc2 ()
1553           = (Vector.sub (args, 0), Vector.sub (args, 1))
1554             handle _ => Error.bug "x86MLton.arith: getSrc2"
1555         fun getSrc4 ()
1556           = (Vector.sub (args, 0), Vector.sub (args, 1),
1557              Vector.sub (args, 2), Vector.sub (args, 3))
1558             handle _ => Error.bug "x86MLton.arith: getSrc4"
1559
1560         fun check (statements, condition)
1561           = AppendList.single
1562             (x86.Block.mkBlock'
1563              {entry = NONE,
1564               statements = statements,
1565               transfer = SOME (x86.Transfer.iff
1566                                {condition = condition,
1567                                 truee = overflow,
1568                                 falsee = success})})
1569         fun binal (oper: x86.Instruction.binal, condition)
1570           = let
1571               val (dst, dstsize) = getDst1 ()
1572               val ((src1, src1size), (src2, src2size)) = getSrc2 ()
1573               val _ = Assert.assert
1574                       ("x86MLton.arith: binal, dstsize/src1size/src2size",
1575                        fn () => src1size = dstsize andalso src2size = dstsize)
1576               (* Reverse src1/src2 when src1 and src2 are
1577                * temporaries and the oper is commutative.
1578                *)
1579               val (src1,src2)
1580                 = if (oper = x86.Instruction.ADD)
1581                     then case (x86.Operand.deMemloc src1,
1582                                x86.Operand.deMemloc src2)
1583                            of (SOME memloc_src1, SOME memloc_src2)
1584                             => if x86Liveness.track memloc_src1
1585                                   andalso
1586                                   x86Liveness.track memloc_src2
1587                                  then (src2,src1)
1588                                  else (src1,src2)
1589                             | _ => (src1,src2)
1590                     else (src1,src2)
1591             in
1592               check ([Assembly.instruction_mov
1593                       {dst = dst,
1594                        src = src1,
1595                        size = dstsize},
1596                       Assembly.instruction_binal
1597                       {oper = oper,
1598                        dst = dst,
1599                        src = src2,
1600                        size = dstsize}],
1601                      condition)
1602             end
1603         fun binal64 (oper1: x86.Instruction.binal,
1604                      oper2: x86.Instruction.binal,
1605                      condition)
1606           = let
1607               val ((dst1, dst1size), (dst2, dst2size)) = getDst2 ()
1608               val ((src1, src1size), (src2, src2size),
1609                    (src3, src3size), (src4, src4size)) = getSrc4 ()
1610               val _ = Assert.assert
1611                       ("x86MLton.arith: binal64, dst1size/dst2size/src1size/src2size/src3size/src4size",
1612                        fn () => src1size = dst1size andalso src3size = dst1size andalso
1613                                 src2size = dst2size andalso src4size = dst2size andalso
1614                                 dst1size = dst2size)
1615               val tdst1 =
1616                  if List.exists ([src2,src3,src4], fn src =>
1617                                  Operand.mayAlias (dst1, src))
1618                     then wordTemp1ContentsOperand dst1size
1619                     else dst1
1620               val tdst2 =
1621                  if List.exists ([src3,src4], fn src =>
1622                                  Operand.mayAlias (dst2, src))
1623                     then wordTemp1ContentsOperand dst2size
1624                     else dst2
1625             in
1626               check ([Assembly.instruction_mov
1627                       {dst = tdst1,
1628                        src = src1,
1629                        size = dst1size},
1630                       Assembly.instruction_mov
1631                       {dst = tdst2,
1632                        src = src2,
1633                        size = dst2size},
1634                       Assembly.instruction_binal
1635                       {oper = oper1,
1636                        dst = tdst1,
1637                        src = src3,
1638                        size = dst1size},
1639                       Assembly.instruction_binal
1640                       {oper = oper2,
1641                        dst = tdst2,
1642                        src = src4,
1643                        size = dst2size},
1644                       Assembly.instruction_mov
1645                       {dst = dst1,
1646                        src = tdst1,
1647                        size = dst1size},
1648                       Assembly.instruction_mov
1649                       {dst = dst2,
1650                        src = tdst2,
1651                        size = dst2size}],
1652                      condition)
1653             end
1654         fun pmd (oper: x86.Instruction.md, condition)
1655           = let
1656               val (dst, dstsize) = getDst1 ()
1657               val ((src1, src1size), (src2, src2size)) = getSrc2 ()
1658               val _ = Assert.assert
1659                       ("x86MLton.arith: pmd, dstsize/src1size/src2size",
1660                        fn () => src1size = dstsize andalso src2size = dstsize)
1661               (* Reverse src1/src2 when src1 and src2 are
1662                * temporaries and the oper is commutative.
1663                *)
1664               val (src1, src2)
1665                 = if oper = x86.Instruction.MUL
1666                     then case (x86.Operand.deMemloc src1,
1667                                x86.Operand.deMemloc src2)
1668                            of (SOME memloc_src1, SOME memloc_src2)
1669                             => if x86Liveness.track memloc_src1
1670                                   andalso
1671                                   x86Liveness.track memloc_src2
1672                                  then (src2,src1)
1673                                  else (src1,src2)
1674                             | _ => (src1,src2)
1675                     else (src1,src2)
1676             in
1677               check ([Assembly.instruction_mov
1678                       {dst = dst,
1679                        src = src1,
1680                        size = dstsize},
1681                       Assembly.instruction_pmd
1682                       {oper = oper,
1683                        dst = dst,
1684                        src = src2,
1685                        size = dstsize}],
1686                      condition)
1687             end
1688         fun unal (oper: x86.Instruction.unal, condition)
1689           = let
1690               val (dst, dstsize) = getDst1 ()
1691               val (src1, src1size) = getSrc1 ()
1692               val _ = Assert.assert
1693                       ("x86MLton.arith: unal, dstsize/src1size",
1694                        fn () => src1size = dstsize)
1695             in
1696               check ([Assembly.instruction_mov
1697                       {dst = dst,
1698                        src = src1,
1699                        size = dstsize},
1700                       Assembly.instruction_unal
1701                       {oper = oper,
1702                        dst = dst,
1703                        size = dstsize}],
1704                      condition)
1705             end
1706
1707         fun neg64 ()
1708           = let
1709               val ((dst1, dst1size), (dst2, dst2size)) = getDst2 ()
1710               val ((src1, src1size), (src2, src2size)) = getSrc2 ()
1711               val _ = Assert.assert
1712                       ("x86MLton.arith: neg64, dst1size/dst2size/src1size/src2size",
1713                        fn () => src1size = dst1size andalso
1714                                 src2size = dst2size andalso
1715                                 dst1size = dst2size)
1716               val tdst1 =
1717                  if List.exists ([src2], fn src =>
1718                                  Operand.mayAlias (dst1, src))
1719                     then wordTemp1ContentsOperand dst1size
1720                     else dst1
1721               val loZ = Label.newString "loZ"
1722               val _ = x86Liveness.LiveInfo.setLiveOperands
1723                       (liveInfo, loZ, dst2::((live success) @ (live overflow)))
1724               val loNZ = Label.newString "loNZ"
1725               val _ = x86Liveness.LiveInfo.setLiveOperands
1726                       (liveInfo, loNZ, dst2::(live success))
1727             in
1728                AppendList.fromList
1729                [x86.Block.mkBlock'
1730                 {entry = NONE,
1731                  statements = [Assembly.instruction_mov
1732                                {dst = tdst1,
1733                                 src = src1,
1734                                 size = dst1size},
1735                                Assembly.instruction_mov
1736                                {dst = dst2,
1737                                 src = src2,
1738                                 size = dst2size},
1739                                Assembly.instruction_mov
1740                                {dst = dst1,
1741                                 src = tdst1,
1742                                 size = dst1size},
1743                                Assembly.instruction_unal
1744                                {oper = x86.Instruction.NEG,
1745                                 dst = dst1,
1746                                 size = dst1size}],
1747                  transfer = SOME (x86.Transfer.iff
1748                                   {condition = x86.Instruction.Z,
1749                                    truee = loZ,
1750                                    falsee = loNZ})},
1751                 x86.Block.mkBlock'
1752                 {entry = SOME (x86.Entry.jump {label = loNZ}),
1753                  statements = [Assembly.instruction_unal
1754                                {dst = dst2,
1755                                 oper = Instruction.INC,
1756                                 size = dst2size},
1757                                Assembly.instruction_unal
1758                                {oper = x86.Instruction.NEG,
1759                                 dst = dst2,
1760                                 size = dst2size}],
1761                  transfer = SOME (x86.Transfer.goto {target = success})},
1762                 x86.Block.mkBlock'
1763                 {entry = SOME (x86.Entry.jump {label = loZ}),
1764                  statements = [Assembly.instruction_unal
1765                                {oper = x86.Instruction.NEG,
1766                                 dst = dst2,
1767                                 size = dst2size}],
1768                  transfer = SOME (x86.Transfer.iff
1769                                   {condition = x86.Instruction.O,
1770                                    truee = overflow,
1771                                    falsee = success})}]
1772             end
1773
1774         fun imul2 condition
1775           = let
1776               val (dst, dstsize) = getDst1 ()
1777               val ((src1, src1size), (src2, src2size)) = getSrc2 ()
1778               val _ = Assert.assert
1779                       ("x86MLton.arith: imul2, dstsize/src1size/src2size",
1780                        fn () => src1size = dstsize andalso src2size = dstsize)
1781               (* Reverse src1/src2 when src1 and src2 are
1782                * temporaries and the oper is commutative.
1783                *)
1784               val (src1, src2)
1785                 = case (x86.Operand.deMemloc src1,
1786                         x86.Operand.deMemloc src2)
1787                     of (SOME memloc_src1, SOME memloc_src2)
1788                      => if x86Liveness.track memloc_src1
1789                            andalso
1790                            x86Liveness.track memloc_src2
1791                           then (src2,src1)
1792                           else (src1,src2)
1793                      | _ => (src1,src2)
1794             in
1795               check ([Assembly.instruction_mov
1796                       {dst = dst,
1797                        src = src1,
1798                        size = dstsize},
1799                       Assembly.instruction_imul2
1800                       {dst = dst,
1801                        src = src2,
1802                        size = dstsize}],
1803                      condition)
1804             end
1805
1806         val (comment_begin,_)
1807           = if !Control.Native.commented > 0
1808               then let
1809                      val comment = primName
1810                    in
1811                      (AppendList.single
1812                       (x86.Block.mkBlock'
1813                        {entry = NONE,
1814                         statements
1815                         = [x86.Assembly.comment
1816                            ("begin arith: " ^ comment)],
1817                         transfer = NONE}),
1818                       AppendList.single
1819                       (x86.Block.mkBlock'
1820                        {entry = NONE,
1821                         statements
1822                         = [x86.Assembly.comment
1823                            ("end arith: " ^ comment)],
1824                         transfer = NONE}))
1825                    end
1826               else (AppendList.empty,AppendList.empty)
1827         fun flag {signed} =
1828            if signed then x86.Instruction.O else x86.Instruction.C
1829       in
1830         AppendList.appends
1831         [comment_begin,
1832          (case Prim.name prim of
1833              Word_addCheck (s, sg) =>
1834                 let
1835                    val flag = flag sg
1836                 in
1837                    case WordSize.prim s of
1838                       W8 => binal (x86.Instruction.ADD, flag)
1839                     | W16 => binal (x86.Instruction.ADD, flag)
1840                     | W32 => binal (x86.Instruction.ADD, flag)
1841                     | W64 => binal64 (x86.Instruction.ADD, x86.Instruction.ADC, flag)
1842                 end
1843            | Word_mulCheck (s, {signed}) =>
1844                 let
1845                 in
1846                    if signed
1847                       then
1848                          (case WordSize.prim s of
1849                              W8 => pmd (x86.Instruction.IMUL, x86.Instruction.O)
1850                            | W16 => imul2 x86.Instruction.O
1851                            | W32 => imul2 x86.Instruction.O
1852                            | W64 => Error.bug "x86MLton.arith: Word_mulCheck, W64")
1853                    else
1854                       (case WordSize.prim s of
1855                           W8 => pmd (x86.Instruction.MUL, x86.Instruction.C)
1856                         | W16 => pmd (x86.Instruction.MUL, x86.Instruction.C)
1857                         | W32 => pmd (x86.Instruction.MUL, x86.Instruction.C)
1858                         | W64 => Error.bug "x86MLton.arith: Word_mulCheck, W64")
1859                 end
1860            | Word_negCheck s =>
1861                (case WordSize.prim s of
1862                   W8 => unal (x86.Instruction.NEG, x86.Instruction.O)
1863                 | W16 => unal (x86.Instruction.NEG, x86.Instruction.O)
1864                 | W32 => unal (x86.Instruction.NEG, x86.Instruction.O)
1865                 | W64 => neg64 ())
1866            | Word_subCheck (s, sg) =>
1867                 let
1868                    val flag = flag sg
1869                 in
1870                    case WordSize.prim s of
1871                       W8 => binal (x86.Instruction.SUB, flag)
1872                     | W16 => binal (x86.Instruction.SUB, flag)
1873                     | W32 => binal (x86.Instruction.SUB, flag)
1874                     | W64 => binal64 (x86.Instruction.SUB, x86.Instruction.SBB, flag)
1875                 end
1876            | _ => Error.bug ("x86MLton.arith: strange Prim.Name.t: " ^ primName))]
1877       end
1878
1879 end