basis/cpu/x86/x86.factor

   1 ! Copyright (C) 2005, 2010 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors assocs alien alien.c-types arrays strings
   4 cpu.x86.assembler cpu.x86.assembler.private cpu.x86.assembler.operands
   5 cpu.x86.features cpu.x86.features.private cpu.architecture kernel
   6 kernel.private math memory namespaces make sequences words system
   7 layouts combinators math.order math.vectors fry locals compiler.constants
   8 byte-arrays io macros quotations compiler compiler.units init vm
   9 compiler.cfg.registers
  10 compiler.cfg.instructions
  11 compiler.cfg.intrinsics
  12 compiler.cfg.comparisons
  13 compiler.cfg.stack-frame
  14 compiler.codegen.fixup ;
  15 FROM: layouts => cell ;
  16 FROM: math => float ;
  17 IN: cpu.x86
  18
  19 ! Add some methods to the assembler to be more useful to the backend
  20 M: label JMP 0 JMP rc-relative label-fixup ;
  21 M: label JUMPcc [ 0 ] dip JUMPcc rc-relative label-fixup ;
  22
  23 M: x86 vector-regs float-regs ;
  24
  25 HOOK: stack-reg cpu ( -- reg )
  26
  27 HOOK: frame-reg cpu ( -- reg )
  28
  29 HOOK: reserved-stack-space cpu ( -- n )
  30
  31 HOOK: extra-stack-space cpu ( stack-frame -- n )
  32
  33 : stack@ ( n -- op ) stack-reg swap [+] ;
  34
  35 : special@ ( n -- op )
  36     stack-frame get extra-stack-space +
  37     reserved-stack-space +
  38     stack@ ;
  39
  40 : spill@ ( n -- op ) spill-offset special@ ;
  41
  42 : gc-root@ ( n -- op ) gc-root-offset special@ ;
  43
  44 : param@ ( n -- op ) reserved-stack-space + stack@ ;
  45
  46 : decr-stack-reg ( n -- )
  47     dup 0 = [ drop ] [ stack-reg swap SUB ] if ;
  48
  49 : incr-stack-reg ( n -- )
  50     dup 0 = [ drop ] [ stack-reg swap ADD ] if ;
  51
  52 : align-stack ( n -- n' ) 16 align ;
  53
  54 M: x86 stack-frame-size ( stack-frame -- i )
  55     [ (stack-frame-size) ]
  56     [ extra-stack-space ] bi +
  57     reserved-stack-space +
  58     3 cells +
  59     align-stack ;
  60
  61 ! Must be a volatile register not used for parameter passing or
  62 ! integer return
  63 HOOK: temp-reg cpu ( -- reg )
  64
  65 HOOK: pic-tail-reg cpu ( -- reg )
  66
  67 M: x86 %load-immediate dup 0 = [ drop dup XOR ] [ MOV ] if ;
  68
  69 M: x86 %load-reference swap 0 MOV rc-absolute-cell rel-immediate ;
  70
  71 HOOK: ds-reg cpu ( -- reg )
  72 HOOK: rs-reg cpu ( -- reg )
  73
  74 : reg-stack ( n reg -- op ) swap cells neg [+] ;
  75
  76 GENERIC: loc>operand ( loc -- operand )
  77
  78 M: ds-loc loc>operand n>> ds-reg reg-stack ;
  79 M: rs-loc loc>operand n>> rs-reg reg-stack ;
  80
  81 M: x86 %peek loc>operand MOV ;
  82 M: x86 %replace loc>operand swap MOV ;
  83 : (%inc) ( n reg -- ) swap cells dup 0 > [ ADD ] [ neg SUB ] if ; inline
  84 M: x86 %inc-d ( n -- ) ds-reg (%inc) ;
  85 M: x86 %inc-r ( n -- ) rs-reg (%inc) ;
  86
  87 M: x86 %call ( word -- ) 0 CALL rc-relative rel-word-pic ;
  88
  89 : xt-tail-pic-offset ( -- n )
  90     #! See the comment in vm/cpu-x86.hpp
  91     4 1 + ; inline
  92
  93 HOOK: %prepare-jump cpu ( -- )
  94
  95 M: x86 %jump ( word -- )
  96     %prepare-jump
  97     0 JMP rc-relative rel-word-pic-tail ;
  98
  99 M: x86 %jump-label ( label -- ) 0 JMP rc-relative label-fixup ;
 100
 101 M: x86 %return ( -- ) 0 RET ;
 102
 103 : code-alignment ( align -- n )
 104     [ building get length dup ] dip align swap - ;
 105
 106 : align-code ( n -- )
 107     0 <repetition> % ;
 108
 109 :: (%slot-imm) ( obj slot tag -- op )
 110     obj slot tag slot-offset [+] ; inline
 111
 112 M: x86 %slot ( dst obj slot -- ) [+] MOV ;
 113 M: x86 %slot-imm ( dst obj slot tag -- ) (%slot-imm) MOV ;
 114 M: x86 %set-slot ( src obj slot -- ) [+] swap MOV ;
 115 M: x86 %set-slot-imm ( src obj slot tag -- ) (%slot-imm) swap MOV ;
 116
 117 :: two-operand ( dst src1 src2 rep -- dst src )
 118     dst src2 eq? dst src1 eq? not and [ "Cannot handle this case" throw ] when
 119     dst src1 rep %copy
 120     dst src2 ; inline
 121
 122 :: one-operand ( dst src rep -- dst )
 123     dst src rep %copy
 124     dst ; inline
 125
 126 M: x86 %add     2over eq? [ nip ADD ] [ [+] LEA ] if ;
 127 M: x86 %add-imm 2over eq? [ nip ADD ] [ [+] LEA ] if ;
 128 M: x86 %sub     int-rep two-operand SUB ;
 129 M: x86 %sub-imm 2over eq? [ nip SUB ] [ neg [+] LEA ] if ;
 130 M: x86 %mul     int-rep two-operand swap IMUL2 ;
 131 M: x86 %mul-imm IMUL3 ;
 132 M: x86 %and     int-rep two-operand AND ;
 133 M: x86 %and-imm int-rep two-operand AND ;
 134 M: x86 %or      int-rep two-operand OR ;
 135 M: x86 %or-imm  int-rep two-operand OR ;
 136 M: x86 %xor     int-rep two-operand XOR ;
 137 M: x86 %xor-imm int-rep two-operand XOR ;
 138 M: x86 %shl-imm int-rep two-operand SHL ;
 139 M: x86 %shr-imm int-rep two-operand SHR ;
 140 M: x86 %sar-imm int-rep two-operand SAR ;
 141
 142 M: x86 %min     int-rep two-operand [ CMP ] [ CMOVG ] 2bi ;
 143 M: x86 %max     int-rep two-operand [ CMP ] [ CMOVL ] 2bi ;
 144
 145 M: x86 %not     int-rep one-operand NOT ;
 146 M: x86 %neg     int-rep one-operand NEG ;
 147 M: x86 %log2    BSR ;
 148
 149 ! A bit of logic to avoid using MOVSS/MOVSD for reg-reg moves
 150 ! since this induces partial register stalls
 151 GENERIC: copy-register* ( dst src rep -- )
 152 GENERIC: copy-memory* ( dst src rep -- )
 153
 154 M: int-rep copy-register* drop MOV ;
 155 M: tagged-rep copy-register* drop MOV ;
 156 M: float-rep copy-register* drop MOVAPS ;
 157 M: double-rep copy-register* drop MOVAPS ;
 158 M: float-4-rep copy-register* drop MOVAPS ;
 159 M: double-2-rep copy-register* drop MOVAPS ;
 160 M: vector-rep copy-register* drop MOVDQA ;
 161
 162 M: object copy-memory* copy-register* ;
 163 M: float-rep copy-memory* drop MOVSS ;
 164 M: double-rep copy-memory* drop MOVSD ;
 165
 166 M: x86 %copy ( dst src rep -- )
 167     2over eq? [ 3drop ] [
 168         [ [ dup spill-slot? [ n>> spill@ ] when ] bi@ ] dip
 169         2over [ register? ] both? [ copy-register* ] [ copy-memory* ] if
 170     ] if ;
 171
 172 M: x86 %fixnum-add ( label dst src1 src2 -- )
 173     int-rep two-operand ADD JO ;
 174
 175 M: x86 %fixnum-sub ( label dst src1 src2 -- )
 176     int-rep two-operand SUB JO ;
 177
 178 M: x86 %fixnum-mul ( label dst src1 src2 -- )
 179     int-rep two-operand swap IMUL2 JO ;
 180
 181 M: x86 %unbox-alien ( dst src -- )
 182     alien-offset [+] MOV ;
 183
 184 M:: x86 %unbox-any-c-ptr ( dst src -- )
 185     [
 186         "end" define-label
 187         dst dst XOR
 188         ! Is the object f?
 189         src \ f type-number CMP
 190         "end" get JE
 191         ! Compute tag in dst register
 192         dst src MOV
 193         dst tag-mask get AND
 194         ! Is the object an alien?
 195         dst alien type-number CMP
 196         ! Add an offset to start of byte array's data
 197         dst src byte-array-offset [+] LEA
 198         "end" get JNE
 199         ! If so, load the offset and add it to the address
 200         dst src alien-offset [+] MOV
 201         "end" resolve-label
 202     ] with-scope ;
 203
 204 : alien@ ( reg n -- op ) cells alien type-number - [+] ;
 205
 206 M:: x86 %box-alien ( dst src temp -- )
 207     [
 208         "end" define-label
 209         dst \ f type-number MOV
 210         src src TEST
 211         "end" get JE
 212         dst 5 cells alien temp %allot
 213         dst 1 alien@ \ f type-number MOV ! base
 214         dst 2 alien@ \ f type-number MOV ! expired
 215         dst 3 alien@ src MOV ! displacement
 216         dst 4 alien@ src MOV ! address
 217         "end" resolve-label
 218     ] with-scope ;
 219
 220 M:: x86 %box-displaced-alien ( dst displacement base temp base-class -- )
 221     ! This is ridiculous
 222     [
 223         "end" define-label
 224         "not-f" define-label
 225         "not-alien" define-label
 226
 227         ! If displacement is zero, return the base
 228         dst base MOV
 229         displacement displacement TEST
 230         "end" get JE
 231
 232         ! Displacement is non-zero, we're going to be allocating a new
 233         ! object
 234         dst 5 cells alien temp %allot
 235
 236         ! Set expired to f
 237         dst 2 alien@ \ f type-number MOV
 238
 239         ! Is base f?
 240         base \ f type-number CMP
 241         "not-f" get JNE
 242
 243         ! Yes, it is f. Fill in new object
 244         dst 1 alien@ base MOV
 245         dst 3 alien@ displacement MOV
 246         dst 4 alien@ displacement MOV
 247
 248         "end" get JMP
 249
 250         "not-f" resolve-label
 251
 252         ! Check base type
 253         temp base MOV
 254         temp tag-mask get AND
 255
 256         ! Is base an alien?
 257         temp alien type-number CMP
 258         "not-alien" get JNE
 259
 260         ! Yes, it is an alien. Set new alien's base to base.base
 261         temp base 1 alien@ MOV
 262         dst 1 alien@ temp MOV
 263
 264         ! Compute displacement
 265         temp base 3 alien@ MOV
 266         temp displacement ADD
 267         dst 3 alien@ temp MOV
 268
 269         ! Compute address
 270         temp base 4 alien@ MOV
 271         temp displacement ADD
 272         dst 4 alien@ temp MOV
 273
 274         ! We are done
 275         "end" get JMP
 276
 277         ! Is base a byte array? It has to be, by now...
 278         "not-alien" resolve-label
 279
 280         dst 1 alien@ base MOV
 281         dst 3 alien@ displacement MOV
 282         temp base MOV
 283         temp byte-array-offset ADD
 284         temp displacement ADD
 285         dst 4 alien@ temp MOV
 286
 287         "end" resolve-label
 288     ] with-scope ;
 289
 290 ! The 'small-reg' mess is pretty crappy, but its only used on x86-32.
 291 ! On x86-64, all registers have 8-bit versions. However, a similar
 292 ! problem arises for shifts, where the shift count must be in CL, and
 293 ! so one day I will fix this properly by adding precoloring to the
 294 ! register allocator.
 295
 296 HOOK: has-small-reg? cpu ( reg size -- ? )
 297
 298 CONSTANT: have-byte-regs { EAX ECX EDX EBX }
 299
 300 M: x86.32 has-small-reg?
 301     {
 302         { 8 [ have-byte-regs member-eq? ] }
 303         { 16 [ drop t ] }
 304         { 32 [ drop t ] }
 305     } case ;
 306
 307 M: x86.64 has-small-reg? 2drop t ;
 308
 309 : small-reg-that-isn't ( exclude -- reg' )
 310     [ have-byte-regs ] dip
 311     [ native-version-of ] map
 312     '[ _ member-eq? not ] find nip ;
 313
 314 : with-save/restore ( reg quot -- )
 315     [ drop PUSH ] [ call ] [ drop POP ] 2tri ; inline
 316
 317 :: with-small-register ( dst exclude size quot: ( new-dst -- ) -- )
 318     ! If the destination register overlaps a small register with
 319     ! 'size' bits, we call the quot with that. Otherwise, we find a
 320     ! small register that is not in exclude, and call quot, saving and
 321     ! restoring the small register.
 322     dst size has-small-reg? [ dst quot call ] [
 323         exclude small-reg-that-isn't
 324         [ quot call ] with-save/restore
 325     ] if ; inline
 326
 327 M:: x86 %string-nth ( dst src index temp -- )
 328     ! We request a small-reg of size 8 since those of size 16 are
 329     ! a superset.
 330     "end" define-label
 331     dst { src index temp } 8 [| new-dst |
 332         ! Load the least significant 7 bits into new-dst.
 333         ! 8th bit indicates whether we have to load from
 334         ! the aux vector or not.
 335         temp src index [+] LEA
 336         new-dst 8-bit-version-of temp string-offset [+] MOV
 337         new-dst new-dst 8-bit-version-of MOVZX
 338         ! Do we have to look at the aux vector?
 339         new-dst HEX: 80 CMP
 340         "end" get JL
 341         ! Yes, this is a non-ASCII character. Load aux vector
 342         temp src string-aux-offset [+] MOV
 343         new-dst temp XCHG
 344         ! Compute index
 345         new-dst index ADD
 346         new-dst index ADD
 347         ! Load high 16 bits
 348         new-dst 16-bit-version-of new-dst byte-array-offset [+] MOV
 349         new-dst new-dst 16-bit-version-of MOVZX
 350         new-dst 7 SHL
 351         ! Compute code point
 352         new-dst temp XOR
 353         "end" resolve-label
 354         dst new-dst int-rep %copy
 355     ] with-small-register ;
 356
 357 M:: x86 %set-string-nth-fast ( ch str index temp -- )
 358     ch { index str temp } 8 [| new-ch |
 359         new-ch ch int-rep %copy
 360         temp str index [+] LEA
 361         temp string-offset [+] new-ch 8-bit-version-of MOV
 362     ] with-small-register ;
 363
 364 :: %alien-integer-getter ( dst src offset size quot -- )
 365     dst { src } size [| new-dst |
 366         new-dst dup size n-bit-version-of dup src offset [+] MOV
 367         quot call
 368         dst new-dst int-rep %copy
 369     ] with-small-register ; inline
 370
 371 : %alien-unsigned-getter ( dst src offset size -- )
 372     [ MOVZX ] %alien-integer-getter ; inline
 373
 374 : %alien-signed-getter ( dst src offset size -- )
 375     [ MOVSX ] %alien-integer-getter ; inline
 376
 377 :: %alien-integer-setter ( ptr offset value size -- )
 378     value { ptr } size [| new-value |
 379         new-value value int-rep %copy
 380         ptr offset [+] new-value size n-bit-version-of MOV
 381     ] with-small-register ; inline
 382
 383 M: x86 %alien-unsigned-1 8 %alien-unsigned-getter ;
 384 M: x86 %alien-unsigned-2 16 %alien-unsigned-getter ;
 385 M: x86 %alien-unsigned-4 32 [ 2drop ] %alien-integer-getter ;
 386
 387 M: x86 %alien-signed-1 8 %alien-signed-getter ;
 388 M: x86 %alien-signed-2 16 %alien-signed-getter ;
 389 M: x86 %alien-signed-4 32 %alien-signed-getter ;
 390
 391 M: x86 %alien-cell [+] MOV ;
 392 M: x86 %alien-float [+] MOVSS ;
 393 M: x86 %alien-double [+] MOVSD ;
 394 M: x86 %alien-vector [ [+] ] dip %copy ;
 395
 396 M: x86 %set-alien-integer-1 8 %alien-integer-setter ;
 397 M: x86 %set-alien-integer-2 16 %alien-integer-setter ;
 398 M: x86 %set-alien-integer-4 32 %alien-integer-setter ;
 399 M: x86 %set-alien-cell [ [+] ] dip MOV ;
 400 M: x86 %set-alien-float [ [+] ] dip MOVSS ;
 401 M: x86 %set-alien-double [ [+] ] dip MOVSD ;
 402 M: x86 %set-alien-vector [ [+] ] 2dip %copy ;
 403
 404 : shift-count? ( reg -- ? ) { ECX RCX } member-eq? ;
 405
 406 :: emit-shift ( dst src quot -- )
 407     src shift-count? [
 408         dst CL quot call
 409     ] [
 410         dst shift-count? [
 411             dst src XCHG
 412             src CL quot call
 413             dst src XCHG
 414         ] [
 415             ECX native-version-of [
 416                 CL src MOV
 417                 drop dst CL quot call
 418             ] with-save/restore
 419         ] if
 420     ] if ; inline
 421
 422 M: x86 %shl int-rep two-operand [ SHL ] emit-shift ;
 423 M: x86 %shr int-rep two-operand [ SHR ] emit-shift ;
 424 M: x86 %sar int-rep two-operand [ SAR ] emit-shift ;
 425
 426 HOOK: %mov-vm-ptr cpu ( reg -- )
 427
 428 HOOK: %vm-field-ptr cpu ( reg offset -- )
 429
 430 : load-zone-offset ( nursery-ptr -- )
 431     "nursery" vm-field-offset %vm-field-ptr ;
 432
 433 : load-allot-ptr ( nursery-ptr allot-ptr -- )
 434     [ drop load-zone-offset ] [ swap [] MOV ] 2bi ;
 435
 436 : inc-allot-ptr ( nursery-ptr n -- )
 437     [ [] ] dip data-alignment get align ADD ;
 438
 439 : store-header ( temp class -- )
 440     [ [] ] [ type-number tag-header ] bi* MOV ;
 441
 442 : store-tagged ( dst tag -- )
 443     type-number OR ;
 444
 445 M:: x86 %allot ( dst size class nursery-ptr -- )
 446     nursery-ptr dst load-allot-ptr
 447     dst class store-header
 448     dst class store-tagged
 449     nursery-ptr size inc-allot-ptr ;
 450
 451 HOOK: %mark-card cpu ( card temp -- )
 452 HOOK: %mark-deck cpu ( card temp -- )
 453
 454 :: (%write-barrier) ( src slot temp1 temp2 -- )
 455     temp1 src slot [+] LEA
 456     temp1 card-bits SHR
 457     temp1 temp2 %mark-card
 458     temp1 deck-bits card-bits - SHR
 459     temp1 temp2 %mark-deck ;
 460
 461 M: x86 %write-barrier ( src slot temp1 temp2 -- ) (%write-barrier) ;
 462
 463 M: x86 %write-barrier-imm ( src slot temp1 temp2 -- ) (%write-barrier) ;
 464
 465 M:: x86 %check-nursery ( label size temp1 temp2 -- )
 466     temp1 load-zone-offset
 467     ! Load 'here' into temp2
 468     temp2 temp1 [] MOV
 469     temp2 size ADD
 470     ! Load 'end' into temp1
 471     temp1 temp1 2 cells [+] MOV
 472     temp2 temp1 CMP
 473     label JLE ;
 474
 475 M: x86 %save-gc-root ( gc-root register -- ) [ gc-root@ ] dip MOV ;
 476
 477 M: x86 %load-gc-root ( gc-root register -- ) swap gc-root@ MOV ;
 478
 479 M: x86 %alien-global ( dst symbol library -- )
 480     [ 0 MOV ] 2dip rc-absolute-cell rel-dlsym ;
 481
 482 M: x86 %push-stack ( -- )
 483     ds-reg cell ADD
 484     ds-reg [] int-regs return-reg MOV ;
 485
 486 M: x86 %push-context-stack ( -- )
 487     temp-reg %context
 488     temp-reg "datastack" context-field-offset [+] bootstrap-cell ADD
 489     temp-reg temp-reg "datastack" context-field-offset [+] MOV
 490     temp-reg [] int-regs return-reg MOV ;
 491
 492 M: x86 %epilogue ( n -- ) cell - incr-stack-reg ;
 493
 494 :: %boolean ( dst temp word -- )
 495     dst \ f type-number MOV
 496     temp 0 MOV \ t rc-absolute-cell rel-immediate
 497     dst temp word execute ; inline
 498
 499 : (%compare) ( src1 src2 cc -- )
 500     2over [ { cc= cc/= } member? ] [ register? ] [ 0 = ] tri* and and
 501     [ drop dup TEST ]
 502     [ CMP ] if ;
 503
 504 M:: x86 %compare ( dst src1 src2 cc temp -- )
 505     src1 src2 cc (%compare)
 506     cc order-cc {
 507         { cc<  [ dst temp \ CMOVL %boolean ] }
 508         { cc<= [ dst temp \ CMOVLE %boolean ] }
 509         { cc>  [ dst temp \ CMOVG %boolean ] }
 510         { cc>= [ dst temp \ CMOVGE %boolean ] }
 511         { cc=  [ dst temp \ CMOVE %boolean ] }
 512         { cc/= [ dst temp \ CMOVNE %boolean ] }
 513     } case ;
 514
 515 M: x86 %compare-imm ( dst src1 src2 cc temp -- )
 516     %compare ;
 517
 518 M:: x86 %compare-branch ( label src1 src2 cc -- )
 519     src1 src2 cc (%compare)
 520     cc order-cc {
 521         { cc<  [ label JL ] }
 522         { cc<= [ label JLE ] }
 523         { cc>  [ label JG ] }
 524         { cc>= [ label JGE ] }
 525         { cc=  [ label JE ] }
 526         { cc/= [ label JNE ] }
 527     } case ;
 528
 529 M: x86 %compare-imm-branch ( label src1 src2 cc -- )
 530     %compare-branch ;
 531
 532 M: x86 %add-float double-rep two-operand ADDSD ;
 533 M: x86 %sub-float double-rep two-operand SUBSD ;
 534 M: x86 %mul-float double-rep two-operand MULSD ;
 535 M: x86 %div-float double-rep two-operand DIVSD ;
 536 M: x86 %min-float double-rep two-operand MINSD ;
 537 M: x86 %max-float double-rep two-operand MAXSD ;
 538 M: x86 %sqrt SQRTSD ;
 539
 540 : %clear-unless-in-place ( dst src -- )
 541     over = [ drop ] [ dup XORPS ] if ;
 542
 543 M: x86 %single>double-float [ %clear-unless-in-place ] [ CVTSS2SD ] 2bi ;
 544 M: x86 %double>single-float [ %clear-unless-in-place ] [ CVTSD2SS ] 2bi ;
 545
 546 M: x86 %integer>float [ drop dup XORPS ] [ CVTSI2SD ] 2bi ;
 547 M: x86 %float>integer CVTTSD2SI ;
 548
 549 : %cmov-float= ( dst src -- )
 550     [
 551         "no-move" define-label
 552
 553         "no-move" get [ JNE ] [ JP ] bi
 554         MOV
 555         "no-move" resolve-label
 556     ] with-scope ;
 557
 558 : %cmov-float/= ( dst src -- )
 559     [
 560         "no-move" define-label
 561         "move" define-label
 562
 563         "move" get JP
 564         "no-move" get JE
 565         "move" resolve-label
 566         MOV
 567         "no-move" resolve-label
 568     ] with-scope ;
 569
 570 :: (%compare-float) ( dst src1 src2 cc temp compare -- )
 571     cc {
 572         { cc<    [ src2 src1 \ compare execute( a b -- ) dst temp \ CMOVA  %boolean ] }
 573         { cc<=   [ src2 src1 \ compare execute( a b -- ) dst temp \ CMOVAE %boolean ] }
 574         { cc>    [ src1 src2 \ compare execute( a b -- ) dst temp \ CMOVA  %boolean ] }
 575         { cc>=   [ src1 src2 \ compare execute( a b -- ) dst temp \ CMOVAE %boolean ] }
 576         { cc=    [ src1 src2 \ compare execute( a b -- ) dst temp \ %cmov-float= %boolean ] }
 577         { cc<>   [ src1 src2 \ compare execute( a b -- ) dst temp \ CMOVNE %boolean ] }
 578         { cc<>=  [ src1 src2 \ compare execute( a b -- ) dst temp \ CMOVNP %boolean ] }
 579         { cc/<   [ src2 src1 \ compare execute( a b -- ) dst temp \ CMOVBE %boolean ] }
 580         { cc/<=  [ src2 src1 \ compare execute( a b -- ) dst temp \ CMOVB  %boolean ] }
 581         { cc/>   [ src1 src2 \ compare execute( a b -- ) dst temp \ CMOVBE %boolean ] }
 582         { cc/>=  [ src1 src2 \ compare execute( a b -- ) dst temp \ CMOVB  %boolean ] }
 583         { cc/=   [ src1 src2 \ compare execute( a b -- ) dst temp \ %cmov-float/= %boolean ] }
 584         { cc/<>  [ src1 src2 \ compare execute( a b -- ) dst temp \ CMOVE  %boolean ] }
 585         { cc/<>= [ src1 src2 \ compare execute( a b -- ) dst temp \ CMOVP  %boolean ] }
 586     } case ; inline
 587
 588 M: x86 %compare-float-ordered ( dst src1 src2 cc temp -- )
 589     \ COMISD (%compare-float) ;
 590
 591 M: x86 %compare-float-unordered ( dst src1 src2 cc temp -- )
 592     \ UCOMISD (%compare-float) ;
 593
 594 : %jump-float= ( label -- )
 595     [
 596         "no-jump" define-label
 597         "no-jump" get JP
 598         JE
 599         "no-jump" resolve-label
 600     ] with-scope ;
 601
 602 : %jump-float/= ( label -- )
 603     [ JNE ] [ JP ] bi ;
 604
 605 :: (%compare-float-branch) ( label src1 src2 cc compare -- )
 606     cc {
 607         { cc<    [ src2 src1 \ compare execute( a b -- ) label JA  ] }
 608         { cc<=   [ src2 src1 \ compare execute( a b -- ) label JAE ] }
 609         { cc>    [ src1 src2 \ compare execute( a b -- ) label JA  ] }
 610         { cc>=   [ src1 src2 \ compare execute( a b -- ) label JAE ] }
 611         { cc=    [ src1 src2 \ compare execute( a b -- ) label %jump-float= ] }
 612         { cc<>   [ src1 src2 \ compare execute( a b -- ) label JNE ] }
 613         { cc<>=  [ src1 src2 \ compare execute( a b -- ) label JNP ] }
 614         { cc/<   [ src2 src1 \ compare execute( a b -- ) label JBE ] }
 615         { cc/<=  [ src2 src1 \ compare execute( a b -- ) label JB  ] }
 616         { cc/>   [ src1 src2 \ compare execute( a b -- ) label JBE ] }
 617         { cc/>=  [ src1 src2 \ compare execute( a b -- ) label JB  ] }
 618         { cc/=   [ src1 src2 \ compare execute( a b -- ) label %jump-float/= ] }
 619         { cc/<>  [ src1 src2 \ compare execute( a b -- ) label JE  ] }
 620         { cc/<>= [ src1 src2 \ compare execute( a b -- ) label JP  ] }
 621     } case ;
 622
 623 M: x86 %compare-float-ordered-branch ( label src1 src2 cc -- )
 624     \ COMISD (%compare-float-branch) ;
 625
 626 M: x86 %compare-float-unordered-branch ( label src1 src2 cc -- )
 627     \ UCOMISD (%compare-float-branch) ;
 628
 629 MACRO: available-reps ( alist -- )
 630     ! Each SSE version adds new representations and supports
 631     ! all old ones
 632     unzip { } [ append ] accumulate rest swap suffix
 633     [ [ 1quotation ] map ] bi@ zip
 634     reverse [ { } ] suffix
 635     '[ _ cond ] ;
 636
 637 M: x86 %alien-vector-reps
 638     {
 639         { sse? { float-4-rep } }
 640         { sse2? { double-2-rep char-16-rep uchar-16-rep short-8-rep ushort-8-rep int-4-rep uint-4-rep longlong-2-rep ulonglong-2-rep } }
 641     } available-reps ;
 642
 643 M: x86 %zero-vector
 644     {
 645         { double-2-rep [ dup XORPS ] }
 646         { float-4-rep [ dup XORPS ] }
 647         [ drop dup PXOR ]
 648     } case ;
 649
 650 M: x86 %zero-vector-reps
 651     {
 652         { sse? { float-4-rep } }
 653         { sse2? { double-2-rep char-16-rep uchar-16-rep short-8-rep ushort-8-rep int-4-rep uint-4-rep longlong-2-rep ulonglong-2-rep } }
 654     } available-reps ;
 655
 656 M: x86 %fill-vector
 657     {
 658         { double-2-rep [ dup [ XORPS ] [ CMPEQPS ] 2bi ] }
 659         { float-4-rep  [ dup [ XORPS ] [ CMPEQPS ] 2bi ] }
 660         [ drop dup PCMPEQB ]
 661     } case ;
 662
 663 M: x86 %fill-vector-reps
 664     {
 665         { sse? { float-4-rep } }
 666         { sse2? { double-2-rep char-16-rep uchar-16-rep short-8-rep ushort-8-rep int-4-rep uint-4-rep longlong-2-rep ulonglong-2-rep } }
 667     } available-reps ;
 668
 669 M:: x86 %gather-vector-4 ( dst src1 src2 src3 src4 rep -- )
 670     rep signed-rep {
 671         { float-4-rep [
 672             dst src1 float-4-rep %copy
 673             dst src2 UNPCKLPS
 674             src3 src4 UNPCKLPS
 675             dst src3 MOVLHPS
 676         ] }
 677         { int-4-rep [
 678             dst src1 int-4-rep %copy
 679             dst src2 PUNPCKLDQ
 680             src3 src4 PUNPCKLDQ
 681             dst src3 PUNPCKLQDQ
 682         ] }
 683     } case ;
 684
 685 M: x86 %gather-vector-4-reps
 686     {
 687         ! Can't do this with sse1 since it will want to unbox
 688         ! double-precision floats and convert to single precision
 689         { sse2? { float-4-rep int-4-rep uint-4-rep } }
 690     } available-reps ;
 691
 692 M:: x86 %gather-vector-2 ( dst src1 src2 rep -- )
 693     rep signed-rep {
 694         { double-2-rep [
 695             dst src1 double-2-rep %copy
 696             dst src2 MOVLHPS
 697         ] }
 698         { longlong-2-rep [
 699             dst src1 longlong-2-rep %copy
 700             dst src2 PUNPCKLQDQ
 701         ] }
 702     } case ;
 703
 704 M: x86 %gather-vector-2-reps
 705     {
 706         { sse2? { double-2-rep longlong-2-rep ulonglong-2-rep } }
 707     } available-reps ;
 708
 709 : sse1-float-4-shuffle ( dst shuffle -- )
 710     {
 711         { { 0 1 2 3 } [ drop ] }
 712         { { 0 1 0 1 } [ dup MOVLHPS ] }
 713         { { 2 3 2 3 } [ dup MOVHLPS ] }
 714         { { 0 0 1 1 } [ dup UNPCKLPS ] }
 715         { { 2 2 3 3 } [ dup UNPCKHPS ] }
 716         [ dupd SHUFPS ]
 717     } case ;
 718
 719 : float-4-shuffle ( dst shuffle -- )
 720     sse3? [
 721         {
 722             { { 0 0 2 2 } [ dup MOVSLDUP ] }
 723             { { 1 1 3 3 } [ dup MOVSHDUP ] }
 724             [ sse1-float-4-shuffle ]
 725         } case
 726     ] [ sse1-float-4-shuffle ] if ;
 727
 728 : int-4-shuffle ( dst shuffle -- )
 729     {
 730         { { 0 1 2 3 } [ drop ] }
 731         { { 0 0 1 1 } [ dup PUNPCKLDQ ] }
 732         { { 2 2 3 3 } [ dup PUNPCKHDQ ] }
 733         { { 0 1 0 1 } [ dup PUNPCKLQDQ ] }
 734         { { 2 3 2 3 } [ dup PUNPCKHQDQ ] }
 735         [ dupd PSHUFD ]
 736     } case ;
 737
 738 : longlong-2-shuffle ( dst shuffle -- )
 739     first2 [ 2 * dup 1 + ] bi@ 4array int-4-shuffle ;
 740
 741 : >float-4-shuffle ( double-2-shuffle -- float-4-shuffle )
 742     [ 2 * { 0 1 } n+v ] map concat ;
 743
 744 M:: x86 %shuffle-vector-imm ( dst src shuffle rep -- )
 745     dst src rep %copy
 746     dst shuffle rep signed-rep {
 747         { double-2-rep [ >float-4-shuffle float-4-shuffle ] }
 748         { float-4-rep [ float-4-shuffle ] }
 749         { int-4-rep [ int-4-shuffle ] }
 750         { longlong-2-rep [ longlong-2-shuffle ] }
 751     } case ;
 752
 753 M: x86 %shuffle-vector-imm-reps
 754     {
 755         { sse? { float-4-rep } }
 756         { sse2? { double-2-rep int-4-rep uint-4-rep longlong-2-rep ulonglong-2-rep } }
 757     } available-reps ;
 758
 759 M: x86 %shuffle-vector ( dst src shuffle rep -- )
 760     two-operand PSHUFB ;
 761
 762 M: x86 %shuffle-vector-reps
 763     {
 764         { ssse3? { float-4-rep double-2-rep longlong-2-rep ulonglong-2-rep int-4-rep uint-4-rep short-8-rep ushort-8-rep char-16-rep uchar-16-rep } }
 765     } available-reps ;
 766
 767 M: x86 %merge-vector-head
 768     [ two-operand ] keep
 769     signed-rep {
 770         { double-2-rep   [ MOVLHPS ] }
 771         { float-4-rep    [ UNPCKLPS ] }
 772         { longlong-2-rep [ PUNPCKLQDQ ] }
 773         { int-4-rep      [ PUNPCKLDQ ] }
 774         { short-8-rep    [ PUNPCKLWD ] }
 775         { char-16-rep    [ PUNPCKLBW ] }
 776     } case ;
 777
 778 M: x86 %merge-vector-tail
 779     [ two-operand ] keep
 780     signed-rep {
 781         { double-2-rep   [ UNPCKHPD ] }
 782         { float-4-rep    [ UNPCKHPS ] }
 783         { longlong-2-rep [ PUNPCKHQDQ ] }
 784         { int-4-rep      [ PUNPCKHDQ ] }
 785         { short-8-rep    [ PUNPCKHWD ] }
 786         { char-16-rep    [ PUNPCKHBW ] }
 787     } case ;
 788
 789 M: x86 %merge-vector-reps
 790     {
 791         { sse? { float-4-rep } }
 792         { sse2? { double-2-rep char-16-rep uchar-16-rep short-8-rep ushort-8-rep int-4-rep uint-4-rep longlong-2-rep ulonglong-2-rep } }
 793     } available-reps ;
 794
 795 M: x86 %signed-pack-vector
 796     [ two-operand ] keep
 797     {
 798         { int-4-rep    [ PACKSSDW ] }
 799         { short-8-rep  [ PACKSSWB ] }
 800     } case ;
 801
 802 M: x86 %signed-pack-vector-reps
 803     {
 804         { sse2? { short-8-rep int-4-rep } }
 805     } available-reps ;
 806
 807 M: x86 %unsigned-pack-vector
 808     [ two-operand ] keep
 809     signed-rep {
 810         { int-4-rep   [ PACKUSDW ] }
 811         { short-8-rep [ PACKUSWB ] }
 812     } case ;
 813
 814 M: x86 %unsigned-pack-vector-reps
 815     {
 816         { sse2? { short-8-rep } }
 817         { sse4.1? { int-4-rep } }
 818     } available-reps ;
 819
 820 M: x86 %tail>head-vector ( dst src rep -- )
 821     dup {
 822         { float-4-rep [ drop UNPCKHPD ] }
 823         { double-2-rep [ drop UNPCKHPD ] }
 824         [ drop [ %copy ] [ drop PUNPCKHQDQ ] 3bi ]
 825     } case ;
 826
 827 M: x86 %unpack-vector-head ( dst src rep -- )
 828     {
 829         { char-16-rep  [ PMOVSXBW ] }
 830         { uchar-16-rep [ PMOVZXBW ] }
 831         { short-8-rep  [ PMOVSXWD ] }
 832         { ushort-8-rep [ PMOVZXWD ] }
 833         { int-4-rep    [ PMOVSXDQ ] }
 834         { uint-4-rep   [ PMOVZXDQ ] }
 835         { float-4-rep  [ CVTPS2PD ] }
 836     } case ;
 837
 838 M: x86 %unpack-vector-head-reps ( -- reps )
 839     {
 840         { sse2? { float-4-rep } }
 841         { sse4.1? { char-16-rep uchar-16-rep short-8-rep ushort-8-rep int-4-rep uint-4-rep } }
 842     } available-reps ;
 843
 844 M: x86 %integer>float-vector ( dst src rep -- )
 845     {
 846         { int-4-rep [ CVTDQ2PS ] }
 847     } case ;
 848
 849 M: x86 %integer>float-vector-reps
 850     {
 851         { sse2? { int-4-rep } }
 852     } available-reps ;
 853
 854 M: x86 %float>integer-vector ( dst src rep -- )
 855     {
 856         { float-4-rep [ CVTTPS2DQ ] }
 857     } case ;
 858
 859 M: x86 %float>integer-vector-reps
 860     {
 861         { sse2? { float-4-rep } }
 862     } available-reps ;
 863
 864 : (%compare-float-vector) ( dst src rep double single -- )
 865     [ double-2-rep eq? ] 2dip if ; inline
 866
 867 : %compare-float-vector ( dst src rep cc -- )
 868     {
 869         { cc<    [ [ CMPLTPD    ] [ CMPLTPS    ] (%compare-float-vector) ] }
 870         { cc<=   [ [ CMPLEPD    ] [ CMPLEPS    ] (%compare-float-vector) ] }
 871         { cc=    [ [ CMPEQPD    ] [ CMPEQPS    ] (%compare-float-vector) ] }
 872         { cc<>=  [ [ CMPORDPD   ] [ CMPORDPS   ] (%compare-float-vector) ] }
 873         { cc/<   [ [ CMPNLTPD   ] [ CMPNLTPS   ] (%compare-float-vector) ] }
 874         { cc/<=  [ [ CMPNLEPD   ] [ CMPNLEPS   ] (%compare-float-vector) ] }
 875         { cc/=   [ [ CMPNEQPD   ] [ CMPNEQPS   ] (%compare-float-vector) ] }
 876         { cc/<>= [ [ CMPUNORDPD ] [ CMPUNORDPS ] (%compare-float-vector) ] }
 877     } case ;
 878
 879 :: (%compare-int-vector) ( dst src rep int64 int32 int16 int8 -- )
 880     rep signed-rep :> rep'
 881     dst src rep' {
 882         { longlong-2-rep [ int64 call ] }
 883         { int-4-rep      [ int32 call ] }
 884         { short-8-rep    [ int16 call ] }
 885         { char-16-rep    [ int8  call ] }
 886     } case ; inline
 887
 888 : %compare-int-vector ( dst src rep cc -- )
 889     {
 890         { cc= [ [ PCMPEQQ ] [ PCMPEQD ] [ PCMPEQW ] [ PCMPEQB ] (%compare-int-vector) ] }
 891         { cc> [ [ PCMPGTQ ] [ PCMPGTD ] [ PCMPGTW ] [ PCMPGTB ] (%compare-int-vector) ] }
 892     } case ;
 893
 894 M: x86 %compare-vector ( dst src1 src2 rep cc -- )
 895     [ [ two-operand ] keep ] dip
 896     over float-vector-rep?
 897     [ %compare-float-vector ]
 898     [ %compare-int-vector ] if ;
 899
 900 : %compare-vector-eq-reps ( -- reps )
 901     {
 902         { sse? { float-4-rep } }
 903         { sse2? { double-2-rep char-16-rep uchar-16-rep short-8-rep ushort-8-rep int-4-rep uint-4-rep } }
 904         { sse4.1? { longlong-2-rep ulonglong-2-rep } }
 905     } available-reps ;
 906
 907 : %compare-vector-ord-reps ( -- reps )
 908     {
 909         { sse? { float-4-rep } }
 910         { sse2? { double-2-rep char-16-rep short-8-rep int-4-rep } }
 911         { sse4.2? { longlong-2-rep } }
 912     } available-reps ;
 913
 914 M: x86 %compare-vector-reps
 915     {
 916         { [ dup { cc= cc/= cc/<>= cc<>= } member-eq? ] [ drop %compare-vector-eq-reps ] }
 917         [ drop %compare-vector-ord-reps ]
 918     } cond ;
 919
 920 : %compare-float-vector-ccs ( cc -- ccs not? )
 921     {
 922         { cc<    [ { { cc<  f   }              } f ] }
 923         { cc<=   [ { { cc<= f   }              } f ] }
 924         { cc>    [ { { cc<  t   }              } f ] }
 925         { cc>=   [ { { cc<= t   }              } f ] }
 926         { cc=    [ { { cc=  f   }              } f ] }
 927         { cc<>   [ { { cc<  f   } { cc<    t } } f ] }
 928         { cc<>=  [ { { cc<>= f  }              } f ] }
 929         { cc/<   [ { { cc/<  f  }              } f ] }
 930         { cc/<=  [ { { cc/<= f  }              } f ] }
 931         { cc/>   [ { { cc/<  t  }              } f ] }
 932         { cc/>=  [ { { cc/<= t  }              } f ] }
 933         { cc/=   [ { { cc/=  f  }              } f ] }
 934         { cc/<>  [ { { cc/=  f  } { cc/<>= f } } f ] }
 935         { cc/<>= [ { { cc/<>= f }              } f ] }
 936     } case ;
 937
 938 : %compare-int-vector-ccs ( cc -- ccs not? )
 939     order-cc {
 940         { cc<    [ { { cc> t } } f ] }
 941         { cc<=   [ { { cc> f } } t ] }
 942         { cc>    [ { { cc> f } } f ] }
 943         { cc>=   [ { { cc> t } } t ] }
 944         { cc=    [ { { cc= f } } f ] }
 945         { cc/=   [ { { cc= f } } t ] }
 946         { t      [ {           } t ] }
 947         { f      [ {           } f ] }
 948     } case ;
 949
 950 M: x86 %compare-vector-ccs
 951     swap float-vector-rep?
 952     [ %compare-float-vector-ccs ]
 953     [ %compare-int-vector-ccs ] if ;
 954
 955 :: %test-vector-mask ( dst temp mask vcc -- )
 956     vcc {
 957         { vcc-any    [ dst dst TEST dst temp \ CMOVNE %boolean ] }
 958         { vcc-none   [ dst dst TEST dst temp \ CMOVE  %boolean ] }
 959         { vcc-all    [ dst mask CMP dst temp \ CMOVE  %boolean ] }
 960         { vcc-notall [ dst mask CMP dst temp \ CMOVNE %boolean ] }
 961     } case ;
 962
 963 : %move-vector-mask ( dst src rep -- mask )
 964     {
 965         { double-2-rep [ MOVMSKPS HEX: f ] }
 966         { float-4-rep  [ MOVMSKPS HEX: f ] }
 967         [ drop PMOVMSKB HEX: ffff ]
 968     } case ;
 969
 970 M:: x86 %test-vector ( dst src temp rep vcc -- )
 971     dst src rep %move-vector-mask :> mask
 972     dst temp mask vcc %test-vector-mask ;
 973
 974 :: %test-vector-mask-branch ( label temp mask vcc -- )
 975     vcc {
 976         { vcc-any    [ temp temp TEST label JNE ] }
 977         { vcc-none   [ temp temp TEST label JE ] }
 978         { vcc-all    [ temp mask CMP label JE ] }
 979         { vcc-notall [ temp mask CMP label JNE ] }
 980     } case ;
 981
 982 M:: x86 %test-vector-branch ( label src temp rep vcc -- )
 983     temp src rep %move-vector-mask :> mask
 984     label temp mask vcc %test-vector-mask-branch ;
 985
 986 M: x86 %test-vector-reps
 987     {
 988         { sse? { float-4-rep } }
 989         { sse2? { double-2-rep char-16-rep uchar-16-rep short-8-rep ushort-8-rep int-4-rep uint-4-rep longlong-2-rep ulonglong-2-rep } }
 990     } available-reps ;
 991
 992 M: x86 %add-vector ( dst src1 src2 rep -- )
 993     [ two-operand ] keep
 994     {
 995         { float-4-rep [ ADDPS ] }
 996         { double-2-rep [ ADDPD ] }
 997         { char-16-rep [ PADDB ] }
 998         { uchar-16-rep [ PADDB ] }
 999         { short-8-rep [ PADDW ] }
1000         { ushort-8-rep [ PADDW ] }
1001         { int-4-rep [ PADDD ] }
1002         { uint-4-rep [ PADDD ] }
1003         { longlong-2-rep [ PADDQ ] }
1004         { ulonglong-2-rep [ PADDQ ] }
1005     } case ;
1006
1007 M: x86 %add-vector-reps
1008     {
1009         { sse? { float-4-rep } }
1010         { sse2? { double-2-rep char-16-rep uchar-16-rep short-8-rep ushort-8-rep int-4-rep uint-4-rep longlong-2-rep ulonglong-2-rep } }
1011     } available-reps ;
1012
1013 M: x86 %saturated-add-vector ( dst src1 src2 rep -- )
1014     [ two-operand ] keep
1015     {
1016         { char-16-rep [ PADDSB ] }
1017         { uchar-16-rep [ PADDUSB ] }
1018         { short-8-rep [ PADDSW ] }
1019         { ushort-8-rep [ PADDUSW ] }
1020     } case ;
1021
1022 M: x86 %saturated-add-vector-reps
1023     {
1024         { sse2? { char-16-rep uchar-16-rep short-8-rep ushort-8-rep } }
1025     } available-reps ;
1026
1027 M: x86 %add-sub-vector ( dst src1 src2 rep -- )
1028     [ two-operand ] keep
1029     {
1030         { float-4-rep [ ADDSUBPS ] }
1031         { double-2-rep [ ADDSUBPD ] }
1032     } case ;
1033
1034 M: x86 %add-sub-vector-reps
1035     {
1036         { sse3? { float-4-rep double-2-rep } }
1037     } available-reps ;
1038
1039 M: x86 %sub-vector ( dst src1 src2 rep -- )
1040     [ two-operand ] keep
1041     {
1042         { float-4-rep [ SUBPS ] }
1043         { double-2-rep [ SUBPD ] }
1044         { char-16-rep [ PSUBB ] }
1045         { uchar-16-rep [ PSUBB ] }
1046         { short-8-rep [ PSUBW ] }
1047         { ushort-8-rep [ PSUBW ] }
1048         { int-4-rep [ PSUBD ] }
1049         { uint-4-rep [ PSUBD ] }
1050         { longlong-2-rep [ PSUBQ ] }
1051         { ulonglong-2-rep [ PSUBQ ] }
1052     } case ;
1053
1054 M: x86 %sub-vector-reps
1055     {
1056         { sse? { float-4-rep } }
1057         { sse2? { double-2-rep char-16-rep uchar-16-rep short-8-rep ushort-8-rep int-4-rep uint-4-rep longlong-2-rep ulonglong-2-rep } }
1058     } available-reps ;
1059
1060 M: x86 %saturated-sub-vector ( dst src1 src2 rep -- )
1061     [ two-operand ] keep
1062     {
1063         { char-16-rep [ PSUBSB ] }
1064         { uchar-16-rep [ PSUBUSB ] }
1065         { short-8-rep [ PSUBSW ] }
1066         { ushort-8-rep [ PSUBUSW ] }
1067     } case ;
1068
1069 M: x86 %saturated-sub-vector-reps
1070     {
1071         { sse2? { char-16-rep uchar-16-rep short-8-rep ushort-8-rep } }
1072     } available-reps ;
1073
1074 M: x86 %mul-vector ( dst src1 src2 rep -- )
1075     [ two-operand ] keep
1076     {
1077         { float-4-rep [ MULPS ] }
1078         { double-2-rep [ MULPD ] }
1079         { short-8-rep [ PMULLW ] }
1080         { ushort-8-rep [ PMULLW ] }
1081         { int-4-rep [ PMULLD ] }
1082         { uint-4-rep [ PMULLD ] }
1083     } case ;
1084
1085 M: x86 %mul-vector-reps
1086     {
1087         { sse? { float-4-rep } }
1088         { sse2? { double-2-rep short-8-rep ushort-8-rep } }
1089         { sse4.1? { int-4-rep uint-4-rep } }
1090     } available-reps ;
1091
1092 M: x86 %mul-high-vector ( dst src1 src2 rep -- )
1093     [ two-operand ] keep
1094     {
1095         { short-8-rep  [ PMULHW ] }
1096         { ushort-8-rep [ PMULHUW ] }
1097     } case ;
1098
1099 M: x86 %mul-high-vector-reps
1100     {
1101         { sse2? { short-8-rep ushort-8-rep } }
1102     } available-reps ;
1103
1104 M: x86 %mul-horizontal-add-vector ( dst src1 src2 rep -- )
1105     [ two-operand ] keep
1106     {
1107         { char-16-rep  [ PMADDUBSW ] }
1108         { uchar-16-rep [ PMADDUBSW ] }
1109         { short-8-rep  [ PMADDWD ] }
1110     } case ;
1111
1112 M: x86 %mul-horizontal-add-vector-reps
1113     {
1114         { sse2?  { short-8-rep } }
1115         { ssse3? { char-16-rep uchar-16-rep } }
1116     } available-reps ;
1117
1118 M: x86 %div-vector ( dst src1 src2 rep -- )
1119     [ two-operand ] keep
1120     {
1121         { float-4-rep [ DIVPS ] }
1122         { double-2-rep [ DIVPD ] }
1123     } case ;
1124
1125 M: x86 %div-vector-reps
1126     {
1127         { sse? { float-4-rep } }
1128         { sse2? { double-2-rep } }
1129     } available-reps ;
1130
1131 M: x86 %min-vector ( dst src1 src2 rep -- )
1132     [ two-operand ] keep
1133     {
1134         { char-16-rep [ PMINSB ] }
1135         { uchar-16-rep [ PMINUB ] }
1136         { short-8-rep [ PMINSW ] }
1137         { ushort-8-rep [ PMINUW ] }
1138         { int-4-rep [ PMINSD ] }
1139         { uint-4-rep [ PMINUD ] }
1140         { float-4-rep [ MINPS ] }
1141         { double-2-rep [ MINPD ] }
1142     } case ;
1143
1144 M: x86 %min-vector-reps
1145     {
1146         { sse? { float-4-rep } }
1147         { sse2? { uchar-16-rep short-8-rep double-2-rep } }
1148         { sse4.1? { char-16-rep ushort-8-rep int-4-rep uint-4-rep } }
1149     } available-reps ;
1150
1151 M: x86 %max-vector ( dst src1 src2 rep -- )
1152     [ two-operand ] keep
1153     {
1154         { char-16-rep [ PMAXSB ] }
1155         { uchar-16-rep [ PMAXUB ] }
1156         { short-8-rep [ PMAXSW ] }
1157         { ushort-8-rep [ PMAXUW ] }
1158         { int-4-rep [ PMAXSD ] }
1159         { uint-4-rep [ PMAXUD ] }
1160         { float-4-rep [ MAXPS ] }
1161         { double-2-rep [ MAXPD ] }
1162     } case ;
1163
1164 M: x86 %max-vector-reps
1165     {
1166         { sse? { float-4-rep } }
1167         { sse2? { uchar-16-rep short-8-rep double-2-rep } }
1168         { sse4.1? { char-16-rep ushort-8-rep int-4-rep uint-4-rep } }
1169     } available-reps ;
1170
1171 M: x86 %avg-vector ( dst src1 src2 rep -- )
1172     [ two-operand ] keep
1173     {
1174         { uchar-16-rep [ PAVGB ] }
1175         { ushort-8-rep [ PAVGW ] }
1176     } case ;
1177
1178 M: x86 %avg-vector-reps
1179     {
1180         { sse2? { uchar-16-rep ushort-8-rep } }
1181     } available-reps ;
1182
1183 M: x86 %dot-vector
1184     [ two-operand ] keep
1185     {
1186         { float-4-rep [ HEX: ff DPPS ] }
1187         { double-2-rep [ HEX: ff DPPD ] }
1188     } case ;
1189
1190 M: x86 %dot-vector-reps
1191     {
1192         { sse4.1? { float-4-rep double-2-rep } }
1193     } available-reps ;
1194
1195 M: x86 %sad-vector
1196     [ two-operand ] keep
1197     {
1198         { uchar-16-rep [ PSADBW ] }
1199     } case ;
1200
1201 M: x86 %sad-vector-reps
1202     {
1203         { sse2? { uchar-16-rep } }
1204     } available-reps ;
1205
1206 M: x86 %horizontal-add-vector ( dst src1 src2 rep -- )
1207     [ two-operand ] keep
1208     signed-rep {
1209         { float-4-rep  [ HADDPS ] }
1210         { double-2-rep [ HADDPD ] }
1211         { int-4-rep    [ PHADDD ] }
1212         { short-8-rep  [ PHADDW ] }
1213     } case ;
1214
1215 M: x86 %horizontal-add-vector-reps
1216     {
1217         { sse3? { float-4-rep double-2-rep } }
1218         { ssse3? { int-4-rep uint-4-rep short-8-rep ushort-8-rep } }
1219     } available-reps ;
1220
1221 M: x86 %horizontal-shl-vector-imm ( dst src1 src2 rep -- )
1222     two-operand PSLLDQ ;
1223
1224 M: x86 %horizontal-shl-vector-imm-reps
1225     {
1226         { sse2? { char-16-rep uchar-16-rep short-8-rep ushort-8-rep int-4-rep uint-4-rep longlong-2-rep ulonglong-2-rep float-4-rep double-2-rep } }
1227     } available-reps ;
1228
1229 M: x86 %horizontal-shr-vector-imm ( dst src1 src2 rep -- )
1230     two-operand PSRLDQ ;
1231
1232 M: x86 %horizontal-shr-vector-imm-reps
1233     {
1234         { sse2? { char-16-rep uchar-16-rep short-8-rep ushort-8-rep int-4-rep uint-4-rep longlong-2-rep ulonglong-2-rep float-4-rep double-2-rep } }
1235     } available-reps ;
1236
1237 M: x86 %abs-vector ( dst src rep -- )
1238     {
1239         { char-16-rep [ PABSB ] }
1240         { short-8-rep [ PABSW ] }
1241         { int-4-rep [ PABSD ] }
1242     } case ;
1243
1244 M: x86 %abs-vector-reps
1245     {
1246         { ssse3? { char-16-rep short-8-rep int-4-rep } }
1247     } available-reps ;
1248
1249 M: x86 %sqrt-vector ( dst src rep -- )
1250     {
1251         { float-4-rep [ SQRTPS ] }
1252         { double-2-rep [ SQRTPD ] }
1253     } case ;
1254
1255 M: x86 %sqrt-vector-reps
1256     {
1257         { sse? { float-4-rep } }
1258         { sse2? { double-2-rep } }
1259     } available-reps ;
1260
1261 M: x86 %and-vector ( dst src1 src2 rep -- )
1262     [ two-operand ] keep
1263     {
1264         { float-4-rep [ ANDPS ] }
1265         { double-2-rep [ ANDPS ] }
1266         [ drop PAND ]
1267     } case ;
1268
1269 M: x86 %and-vector-reps
1270     {
1271         { sse? { float-4-rep } }
1272         { sse2? { double-2-rep char-16-rep uchar-16-rep short-8-rep ushort-8-rep int-4-rep uint-4-rep longlong-2-rep ulonglong-2-rep } }
1273     } available-reps ;
1274
1275 M: x86 %andn-vector ( dst src1 src2 rep -- )
1276     [ two-operand ] keep
1277     {
1278         { float-4-rep [ ANDNPS ] }
1279         { double-2-rep [ ANDNPS ] }
1280         [ drop PANDN ]
1281     } case ;
1282
1283 M: x86 %andn-vector-reps
1284     {
1285         { sse? { float-4-rep } }
1286         { sse2? { double-2-rep char-16-rep uchar-16-rep short-8-rep ushort-8-rep int-4-rep uint-4-rep longlong-2-rep ulonglong-2-rep } }
1287     } available-reps ;
1288
1289 M: x86 %or-vector ( dst src1 src2 rep -- )
1290     [ two-operand ] keep
1291     {
1292         { float-4-rep [ ORPS ] }
1293         { double-2-rep [ ORPS ] }
1294         [ drop POR ]
1295     } case ;
1296
1297 M: x86 %or-vector-reps
1298     {
1299         { sse? { float-4-rep } }
1300         { sse2? { double-2-rep char-16-rep uchar-16-rep short-8-rep ushort-8-rep int-4-rep uint-4-rep longlong-2-rep ulonglong-2-rep } }
1301     } available-reps ;
1302
1303 M: x86 %xor-vector ( dst src1 src2 rep -- )
1304     [ two-operand ] keep
1305     {
1306         { float-4-rep [ XORPS ] }
1307         { double-2-rep [ XORPS ] }
1308         [ drop PXOR ]
1309     } case ;
1310
1311 M: x86 %xor-vector-reps
1312     {
1313         { sse? { float-4-rep } }
1314         { sse2? { double-2-rep char-16-rep uchar-16-rep short-8-rep ushort-8-rep int-4-rep uint-4-rep longlong-2-rep ulonglong-2-rep } }
1315     } available-reps ;
1316
1317 M: x86 %shl-vector ( dst src1 src2 rep -- )
1318     [ two-operand ] keep
1319     {
1320         { short-8-rep [ PSLLW ] }
1321         { ushort-8-rep [ PSLLW ] }
1322         { int-4-rep [ PSLLD ] }
1323         { uint-4-rep [ PSLLD ] }
1324         { longlong-2-rep [ PSLLQ ] }
1325         { ulonglong-2-rep [ PSLLQ ] }
1326     } case ;
1327
1328 M: x86 %shl-vector-reps
1329     {
1330         { sse2? { short-8-rep ushort-8-rep int-4-rep uint-4-rep longlong-2-rep ulonglong-2-rep } }
1331     } available-reps ;
1332
1333 M: x86 %shr-vector ( dst src1 src2 rep -- )
1334     [ two-operand ] keep
1335     {
1336         { short-8-rep [ PSRAW ] }
1337         { ushort-8-rep [ PSRLW ] }
1338         { int-4-rep [ PSRAD ] }
1339         { uint-4-rep [ PSRLD ] }
1340         { ulonglong-2-rep [ PSRLQ ] }
1341     } case ;
1342
1343 M: x86 %shr-vector-reps
1344     {
1345         { sse2? { short-8-rep ushort-8-rep int-4-rep uint-4-rep ulonglong-2-rep } }
1346     } available-reps ;
1347
1348 M: x86 %shl-vector-imm %shl-vector ;
1349 M: x86 %shl-vector-imm-reps %shl-vector-reps ;
1350 M: x86 %shr-vector-imm %shr-vector ;
1351 M: x86 %shr-vector-imm-reps %shr-vector-reps ;
1352
1353 : scalar-sized-reg ( reg rep -- reg' )
1354     rep-size 8 * n-bit-version-of ;
1355
1356 M: x86 %integer>scalar drop MOVD ;
1357
1358 :: %scalar>integer-32 ( dst src rep -- )
1359     rep {
1360         { int-scalar-rep [
1361             dst 32-bit-version-of src MOVD
1362             dst dst 32-bit-version-of
1363             2dup eq? [ 2drop ] [ MOVSX ] if
1364         ] }
1365         { uint-scalar-rep [
1366             dst 32-bit-version-of src MOVD
1367         ] }
1368         { short-scalar-rep [
1369             dst 32-bit-version-of src MOVD
1370             dst dst 16-bit-version-of MOVSX
1371         ] }
1372         { ushort-scalar-rep [
1373             dst 32-bit-version-of src MOVD
1374             dst dst 16-bit-version-of MOVZX
1375         ] }
1376         { char-scalar-rep [
1377             dst 32-bit-version-of src MOVD
1378             dst { } 8 [| tmp-dst |
1379                 tmp-dst dst int-rep %copy
1380                 tmp-dst tmp-dst 8-bit-version-of MOVSX
1381                 dst tmp-dst int-rep %copy
1382             ] with-small-register
1383         ] }
1384         { uchar-scalar-rep [
1385             dst 32-bit-version-of src MOVD
1386             dst { } 8 [| tmp-dst |
1387                 tmp-dst dst int-rep %copy
1388                 tmp-dst tmp-dst 8-bit-version-of MOVZX
1389                 dst tmp-dst int-rep %copy
1390             ] with-small-register
1391         ] }
1392     } case ;
1393
1394 M: x86.32 %scalar>integer ( dst src rep -- ) %scalar>integer-32 ;
1395
1396 M: x86.64 %scalar>integer ( dst src rep -- )
1397     {
1398         { longlong-scalar-rep  [ MOVD ] }
1399         { ulonglong-scalar-rep [ MOVD ] }
1400         [ %scalar>integer-32 ]
1401     } case ;
1402
1403 M: x86 %vector>scalar %copy ;
1404 M: x86 %scalar>vector %copy ;
1405
1406 M:: x86 %spill ( src rep dst -- ) dst src rep %copy ;
1407 M:: x86 %reload ( dst rep src -- ) dst src rep %copy ;
1408
1409 M: x86 %loop-entry 16 code-alignment [ NOP ] times ;
1410
1411 M:: x86 %restore-context ( temp1 temp2 -- )
1412     #! Load Factor stack pointers on entry from C to Factor.
1413     temp1 %context
1414     ds-reg temp1 "datastack" context-field-offset [+] MOV
1415     rs-reg temp1 "retainstack" context-field-offset [+] MOV ;
1416
1417 M:: x86 %save-context ( temp1 temp2 -- )
1418     #! Save Factor stack pointers in case the C code calls a
1419     #! callback which does a GC, which must reliably trace
1420     #! all roots.
1421     temp1 %context
1422     temp2 stack-reg cell neg [+] LEA
1423     temp1 "callstack-top" context-field-offset [+] temp2 MOV
1424     temp1 "datastack" context-field-offset [+] ds-reg MOV
1425     temp1 "retainstack" context-field-offset [+] rs-reg MOV ;
1426
1427 M: x86 value-struct? drop t ;
1428
1429 M: x86 immediate-arithmetic? ( n -- ? )
1430     HEX: -80000000 HEX: 7fffffff between? ;
1431
1432 M: x86 immediate-bitwise? ( n -- ? )
1433     HEX: -80000000 HEX: 7fffffff between? ;
1434
1435 : next-stack@ ( n -- operand )
1436     #! nth parameter from the next stack frame. Used to box
1437     #! input values to callbacks; the callback has its own
1438     #! stack frame set up, and we want to read the frame
1439     #! set up by the caller.
1440     frame-reg swap 2 cells + [+] ;
1441
1442 enable-min/max
1443 enable-fixnum-log2
1444
1445 :: install-sse2-check ( -- )
1446     [
1447         sse-version 20 < [
1448             "This image was built to use SSE2 but your CPU does not support it." print
1449             "You will need to bootstrap Factor again." print
1450             flush
1451             1 exit
1452         ] when
1453     ] "cpu.x86" add-startup-hook ;
1454
1455 : enable-sse2 ( version -- )
1456     20 >= [
1457         enable-float-intrinsics
1458         enable-float-functions
1459         enable-float-min/max
1460         enable-fsqrt
1461         install-sse2-check
1462     ] when ;
1463
1464 : check-sse ( -- )
1465     [ { (sse-version) } compile ] with-optimizer
1466     "Checking for multimedia extensions: " write sse-version
1467     [ sse-string write " detected" print ] [ enable-sse2 ] bi ;