basis/cpu/x86/x86.factor

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