core/cpu/x86/intrinsics/intrinsics.factor

   1 ! Copyright (C) 2005, 2006 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: alien arrays cpu.x86.assembler cpu.x86.allot
   4 cpu.x86.architecture cpu.architecture kernel kernel.private math
   5 math.functions math.private namespaces quotations sequences
   6 words generic byte-arrays hashtables hashtables.private
   7 generator generator.registers generator.fixup sequences.private
   8 sbufs sbufs.private vectors vectors.private layouts system
   9 tuples.private strings.private slots.private ;
  10 IN: cpu.x86.intrinsics
  11
  12 ! Type checks
  13 \ tag [
  14     "in" operand tag-mask get AND
  15     "in" operand %tag-fixnum
  16 ] H{
  17     { +input+ { { f "in" } } }
  18     { +output+ { "in" } }
  19 } define-intrinsic
  20
  21 \ type [
  22     "end" define-label
  23     ! Make a copy
  24     "x" operand "obj" operand MOV
  25     ! Get the tag
  26     "x" operand tag-mask get AND
  27     ! Tag the tag
  28     "x" operand %tag-fixnum
  29     ! Compare with object tag number (3).
  30     "x" operand object tag-number tag-bits get shift CMP
  31     "end" get JNE
  32     ! If we have equality, load type from header
  33     "x" operand "obj" operand -3 [+] MOV
  34     "end" resolve-label
  35 ] H{
  36     { +input+ { { f "obj" } } }
  37     { +scratch+ { { f "x" } } }
  38     { +output+ { "x" } }
  39 } define-intrinsic
  40
  41 \ class-hash [
  42     "end" define-label
  43     "tuple" define-label
  44     "object" define-label
  45     ! Make a copy
  46     "x" operand "obj" operand MOV
  47     ! Get the tag
  48     "x" operand tag-mask get AND
  49     ! Tag the tag
  50     "x" operand %tag-fixnum
  51     ! Compare with tuple tag number (2).
  52     "x" operand tuple tag-number tag-bits get shift CMP
  53     "tuple" get JE
  54     ! Compare with object tag number (3).
  55     "x" operand object tag-number tag-bits get shift CMP
  56     "object" get JE
  57     "end" get JMP
  58     "object" get resolve-label
  59     ! Load header type
  60     "x" operand "obj" operand header-offset [+] MOV
  61     "end" get JMP
  62     "tuple" get resolve-label
  63     ! Load class hash
  64     "x" operand "obj" operand tuple-class-offset [+] MOV
  65     "x" operand dup class-hash-offset [+] MOV
  66     "end" resolve-label
  67 ] H{
  68     { +input+ { { f "obj" } } }
  69     { +scratch+ { { f "x" } } }
  70     { +output+ { "x" } }
  71 } define-intrinsic
  72
  73 ! Slots
  74
  75 \ slot {
  76     ! Slot number is literal
  77     {
  78         [
  79             "obj" operand %untag
  80             ! load slot value
  81             "obj" operand dup "n" get cells [+] MOV
  82         ] H{
  83             { +input+ { { f "obj" } { [ small-slot? ] "n" } } }
  84             { +output+ { "obj" } }
  85         }
  86     }
  87     ! Slot number in a register
  88     {
  89         [
  90             "obj" operand %untag
  91             ! turn tagged fixnum slot # into an offset,
  92             ! multiple of 4
  93             "n" operand fixnum>slot@
  94             ! load slot value
  95             "obj" operand dup "n" operand [+] MOV
  96         ] H{
  97             { +input+ { { f "obj" } { f "n" } } }
  98             { +output+ { "obj" } }
  99             { +clobber+ { "n" } }
 100         }
 101     }
 102 } define-intrinsics
 103
 104 : generate-write-barrier ( -- )
 105     #! Mark the card pointed to by vreg.
 106     "val" operand-immediate? "obj" get fresh-object? or [
 107         "obj" operand card-bits SHR
 108         "scratch" operand HEX: ffffffff MOV
 109         "cards_offset" f rc-absolute-cell rel-dlsym
 110         "scratch" operand dup [] MOV
 111         "scratch" operand "obj" operand [+] card-mark OR
 112     ] unless ;
 113
 114 \ set-slot {
 115     ! Slot number is literal
 116     {
 117         [
 118             "obj" operand %untag
 119             ! store new slot value
 120             "obj" operand "n" get cells [+] "val" operand MOV
 121             generate-write-barrier
 122         ] H{
 123             { +input+ { { f "val" } { f "obj" } { [ small-slot? ] "n" } } }
 124             { +scratch+ { { f "scratch" } } }
 125             { +clobber+ { "obj" } }
 126         }
 127     }
 128     ! Slot number in a register
 129     {
 130         [
 131             ! turn tagged fixnum slot # into an offset
 132             "n" operand fixnum>slot@
 133             "obj" operand %untag
 134             ! store new slot value
 135             "obj" operand "n" operand [+] "val" operand MOV
 136             ! reuse register
 137             "n" get "scratch" set
 138             generate-write-barrier
 139         ] H{
 140             { +input+ { { f "val" } { f "obj" } { f "n" } } }
 141             { +clobber+ { "obj" "n" } }
 142         }
 143     }
 144 } define-intrinsics
 145
 146 ! Sometimes, we need to do stuff with operands which are
 147 ! less than the word size. Instead of teaching the register
 148 ! allocator about the different sized registers, with all
 149 ! the complexity this entails, we just push/pop a register
 150 ! which is guaranteed to be unused (the tempreg)
 151 : small-reg cell 8 = RBX EBX ? ; inline
 152 : small-reg-8 BL ; inline
 153 : small-reg-16 BX ; inline
 154 : small-reg-32 EBX ; inline
 155
 156 \ char-slot [
 157     small-reg PUSH
 158     "n" operand 2 SHR
 159     small-reg dup XOR
 160     "obj" operand "n" operand ADD
 161     small-reg-16 "obj" operand string-offset [+] MOV
 162     small-reg %tag-fixnum
 163     "obj" operand small-reg MOV
 164     small-reg POP
 165 ] H{
 166     { +input+ { { f "n" } { f "obj" } } }
 167     { +output+ { "obj" } }
 168     { +clobber+ { "obj" "n" } }
 169 } define-intrinsic
 170
 171 \ set-char-slot [
 172     small-reg PUSH
 173     "val" operand %untag-fixnum
 174     "slot" operand 2 SHR
 175     "obj" operand "slot" operand ADD
 176     small-reg "val" operand MOV
 177     "obj" operand string-offset [+] small-reg-16 MOV
 178     small-reg POP
 179 ] H{
 180     { +input+ { { f "val" } { f "slot" } { f "obj" } } }
 181     { +clobber+ { "val" "slot" "obj" } }
 182 } define-intrinsic
 183
 184 ! Fixnums
 185 : fixnum-op ( op hash -- pair )
 186     >r [ "x" operand "y" operand ] swap add r> 2array ;
 187
 188 : fixnum-value-op ( op -- pair )
 189     H{
 190         { +input+ { { f "x" } { [ small-tagged? ] "y" } } }
 191         { +output+ { "x" } }
 192     } fixnum-op ;
 193
 194 : fixnum-register-op ( op -- pair )
 195     H{
 196         { +input+ { { f "x" } { f "y" } } }
 197         { +output+ { "x" } }
 198     } fixnum-op ;
 199
 200 : define-fixnum-op ( word op -- )
 201     [ fixnum-value-op ] keep fixnum-register-op
 202     2array define-intrinsics ;
 203
 204 {
 205     { fixnum+fast ADD }
 206     { fixnum-fast SUB }
 207     { fixnum-bitand AND }
 208     { fixnum-bitor OR }
 209     { fixnum-bitxor XOR }
 210 } [
 211     first2 define-fixnum-op
 212 ] each
 213
 214 \ fixnum-bitnot [
 215     "x" operand NOT
 216     "x" operand tag-mask get XOR
 217 ] H{
 218     { +input+ { { f "x" } } }
 219     { +output+ { "x" } }
 220 } define-intrinsic
 221
 222 \ fixnum*fast {
 223     {
 224         [
 225             "x" operand "y" get IMUL2
 226         ] H{
 227             { +input+ { { f "x" } { [ small-tagged? ] "y" } } }
 228             { +output+ { "x" } }
 229         }
 230     } {
 231         [
 232             "out" operand "x" operand MOV
 233             "out" operand %untag-fixnum
 234             "y" operand "out" operand IMUL2
 235         ] H{
 236             { +input+ { { f "x" } { f "y" } } }
 237             { +scratch+ { { f "out" } } }
 238             { +output+ { "out" } }
 239         }
 240     }
 241 } define-intrinsics
 242
 243 \ fixnum-shift [
 244     "x" operand "y" get neg SAR
 245     ! Mask off low bits
 246     "x" operand %untag
 247 ] H{
 248     { +input+ { { f "x" } { [ -31 0 between? ] "y" } } }
 249     { +output+ { "x" } }
 250 } define-intrinsic
 251
 252 : %untag-fixnums ( seq -- )
 253     [ %untag-fixnum ] unique-operands ;
 254
 255 : overflow-check ( word -- )
 256     "end" define-label
 257     "z" operand "x" operand MOV
 258     "z" operand "y" operand pick execute
 259     ! If the previous arithmetic operation overflowed, then we
 260     ! turn the result into a bignum and leave it in EAX.
 261     "end" get JNO
 262     ! There was an overflow. Recompute the original operand.
 263     { "y" "x" } %untag-fixnums
 264     "x" operand "y" operand rot execute
 265     "z" get "x" get %allot-bignum-signed-1
 266     "end" resolve-label ; inline
 267
 268 : overflow-template ( word insn -- )
 269     [ overflow-check ] curry H{
 270         { +input+ { { f "x" } { f "y" } } }
 271         { +scratch+ { { f "z" } } }
 272         { +output+ { "z" } }
 273         { +clobber+ { "x" "y" } }
 274     } define-intrinsic ;
 275
 276 \ fixnum+ \ ADD overflow-template
 277 \ fixnum- \ SUB overflow-template
 278
 279 : fixnum-jump ( op inputs -- pair )
 280     >r [ "x" operand "y" operand CMP ] swap add r> 2array ;
 281
 282 : fixnum-value-jump ( op -- pair )
 283     { { f "x" } { [ small-tagged? ] "y" } } fixnum-jump ;
 284
 285 : fixnum-register-jump ( op -- pair )
 286     { { f "x" } { f "y" } } fixnum-jump ;
 287
 288 : define-fixnum-jump ( word op -- )
 289     [ fixnum-value-jump ] keep fixnum-register-jump
 290     2array define-if-intrinsics ;
 291
 292 {
 293     { fixnum< JL }
 294     { fixnum<= JLE }
 295     { fixnum> JG }
 296     { fixnum>= JGE }
 297     { eq? JE }
 298 } [
 299     first2 define-fixnum-jump
 300 ] each
 301
 302 \ fixnum>bignum [
 303     "x" operand %untag-fixnum
 304     "x" get dup %allot-bignum-signed-1
 305 ] H{
 306     { +input+ { { f "x" } } }
 307     { +output+ { "x" } }
 308 } define-intrinsic
 309
 310 \ bignum>fixnum [
 311     "nonzero" define-label
 312     "positive" define-label
 313     "end" define-label
 314     "x" operand %untag
 315     "y" operand "x" operand cell [+] MOV
 316      ! if the length is 1, its just the sign and nothing else,
 317      ! so output 0
 318     "y" operand 1 v>operand CMP
 319     "nonzero" get JNE
 320     "y" operand 0 MOV
 321     "end" get JMP
 322     "nonzero" resolve-label
 323     ! load the value
 324     "y" operand "x" operand 3 cells [+] MOV
 325     ! load the sign
 326     "x" operand "x" operand 2 cells [+] MOV
 327     ! is the sign negative?
 328     "x" operand 0 CMP
 329     "positive" get JE
 330     "y" operand -1 IMUL2
 331     "positive" resolve-label
 332     "y" operand 3 SHL
 333     "end" resolve-label
 334 ] H{
 335     { +input+ { { f "x" } } }
 336     { +scratch+ { { f "y" } } }
 337     { +clobber+ { "x" } }
 338     { +output+ { "y" } }
 339 } define-intrinsic
 340
 341 ! User environment
 342 : %userenv ( -- )
 343     "x" operand 0 MOV
 344     "userenv" f rc-absolute-cell rel-dlsym
 345     "n" operand fixnum>slot@
 346     "n" operand "x" operand ADD ;
 347
 348 \ getenv [
 349     %userenv  "n" operand dup [] MOV
 350 ] H{
 351     { +input+ { { f "n" } } }
 352     { +scratch+ { { f "x" } } }
 353     { +output+ { "n" } }
 354 } define-intrinsic
 355
 356 \ setenv [
 357     %userenv  "n" operand [] "val" operand MOV
 358 ] H{
 359     { +input+ { { f "val" } { f "n" } } }
 360     { +scratch+ { { f "x" } } }
 361     { +clobber+ { "n" } }
 362 } define-intrinsic
 363
 364 \ <tuple> [
 365     tuple "n" get 2 + cells [
 366         ! Store length
 367         1 object@ "n" operand MOV
 368         ! Store class
 369         2 object@ "class" operand MOV
 370         ! Zero out the rest of the tuple
 371         "n" operand 1- [ 3 + object@ f v>operand MOV ] each
 372         ! Store tagged ptr in reg
 373         "tuple" get tuple %store-tagged
 374     ] %allot
 375 ] H{
 376     { +input+ { { f "class" } { [ inline-array? ] "n" } } }
 377     { +scratch+ { { f "tuple" } } }
 378     { +output+ { "tuple" } }
 379 } define-intrinsic
 380
 381 \ <array> [
 382     array "n" get 2 + cells [
 383         ! Store length
 384         1 object@ "n" operand MOV
 385         ! Zero out the rest of the tuple
 386         "n" get [ 2 + object@ "initial" operand MOV ] each
 387         ! Store tagged ptr in reg
 388         "array" get object %store-tagged
 389     ] %allot
 390 ] H{
 391     { +input+ { { [ inline-array? ] "n" } { f "initial" } } }
 392     { +scratch+ { { f "array" } } }
 393     { +output+ { "array" } }
 394 } define-intrinsic
 395
 396 \ <byte-array> [
 397     byte-array "n" get 2 cells + [
 398         ! Store length
 399         1 object@ "n" operand MOV
 400         ! Store initial element
 401         "n" get cell align cell /i [ 2 + object@ 0 MOV ] each
 402         ! Store tagged ptr in reg
 403         "array" get object %store-tagged
 404     ] %allot
 405 ] H{
 406     { +input+ { { [ inline-array? ] "n" } } }
 407     { +scratch+ { { f "array" } } }
 408     { +output+ { "array" } }
 409 } define-intrinsic
 410
 411 \ <ratio> [
 412     ratio 3 cells [
 413         1 object@ "numerator" operand MOV
 414         2 object@ "denominator" operand MOV
 415         ! Store tagged ptr in reg
 416         "ratio" get ratio %store-tagged
 417     ] %allot
 418 ] H{
 419     { +input+ { { f "numerator" } { f "denominator" } } }
 420     { +scratch+ { { f "ratio" } } }
 421     { +output+ { "ratio" } }
 422 } define-intrinsic
 423
 424 \ <complex> [
 425     complex 3 cells [
 426         1 object@ "real" operand MOV
 427         2 object@ "imaginary" operand MOV
 428         ! Store tagged ptr in reg
 429         "complex" get complex %store-tagged
 430     ] %allot
 431 ] H{
 432     { +input+ { { f "real" } { f "imaginary" } } }
 433     { +scratch+ { { f "complex" } } }
 434     { +output+ { "complex" } }
 435 } define-intrinsic
 436
 437 \ <wrapper> [
 438     wrapper 2 cells [
 439         1 object@ "obj" operand MOV
 440         ! Store tagged ptr in reg
 441         "wrapper" get object %store-tagged
 442     ] %allot
 443 ] H{
 444     { +input+ { { f "obj" } } }
 445     { +scratch+ { { f "wrapper" } } }
 446     { +output+ { "wrapper" } }
 447 } define-intrinsic
 448
 449 \ (hashtable) [
 450     hashtable 4 cells [
 451         1 object@ f v>operand MOV
 452         2 object@ f v>operand MOV
 453         3 object@ f v>operand MOV
 454         ! Store tagged ptr in reg
 455         "hashtable" get object %store-tagged
 456     ] %allot
 457 ] H{
 458     { +scratch+ { { f "hashtable" } } }
 459     { +output+ { "hashtable" } }
 460 } define-intrinsic
 461
 462 \ string>sbuf [
 463     sbuf 3 cells [
 464         1 object@ "length" operand MOV
 465         2 object@ "string" operand MOV
 466         ! Store tagged ptr in reg
 467         "sbuf" get object %store-tagged
 468     ] %allot
 469 ] H{
 470     { +input+ { { f "string" } { f "length" } } }
 471     { +scratch+ { { f "sbuf" } } }
 472     { +output+ { "sbuf" } }
 473 } define-intrinsic
 474
 475 \ array>vector [
 476     vector 3 cells [
 477         1 object@ "length" operand MOV
 478         2 object@ "array" operand MOV
 479         ! Store tagged ptr in reg
 480         "vector" get object %store-tagged
 481     ] %allot
 482 ] H{
 483     { +input+ { { f "array" } { f "length" } } }
 484     { +scratch+ { { f "vector" } } }
 485     { +output+ { "vector" } }
 486 } define-intrinsic
 487
 488 \ curry [
 489     \ curry 3 cells [
 490         1 object@ "obj" operand MOV
 491         2 object@ "quot" operand MOV
 492         ! Store tagged ptr in reg
 493         "curry" get object %store-tagged
 494     ] %allot
 495 ] H{
 496     { +input+ { { f "obj" } { f "quot" } } }
 497     { +scratch+ { { f "curry" } } }
 498     { +output+ { "curry" } }
 499 } define-intrinsic
 500
 501 ! Alien intrinsics
 502 : %alien-integer-get ( quot reg -- )
 503     small-reg PUSH
 504     "offset" operand %untag-fixnum
 505     "alien" operand-class %alien-accessor
 506     "offset" operand small-reg MOV
 507     "offset" operand %tag-fixnum
 508     small-reg POP ; inline
 509
 510 : alien-integer-get-template
 511     H{
 512         { +input+ {
 513             { f "alien" simple-c-ptr }
 514             { f "offset" fixnum }
 515         } }
 516         { +output+ { "offset" } }
 517         { +clobber+ { "alien" "offset" } }
 518     } ;
 519
 520 : define-getter
 521     [ %alien-integer-get ] 2curry
 522     alien-integer-get-template
 523     define-intrinsic ;
 524
 525 : define-unsigned-getter
 526     [ small-reg dup XOR MOV ] swap define-getter ;
 527
 528 : define-signed-getter
 529     [ [ >r MOV small-reg r> MOVSX ] curry ] keep define-getter ;
 530
 531 : %alien-integer-set ( quot reg -- )
 532     small-reg PUSH
 533     { "offset" "value" } %untag-fixnums
 534     small-reg "value" operand MOV
 535     "alien" operand-class %alien-accessor
 536     small-reg POP ; inline
 537
 538 : alien-integer-set-template
 539     H{
 540         { +input+ {
 541             { f "value" fixnum }
 542             { f "alien" simple-c-ptr }
 543             { f "offset" fixnum }
 544         } }
 545         { +clobber+ { "value" "alien" "offset" } }
 546     } ;
 547
 548 : define-setter
 549     [ swap MOV ] swap
 550     [ %alien-integer-set ] 2curry
 551     alien-integer-set-template
 552     define-intrinsic ;
 553
 554 \ alien-unsigned-1 small-reg-8 define-unsigned-getter
 555 \ set-alien-unsigned-1 small-reg-8 define-setter
 556
 557 \ alien-signed-1 small-reg-8 define-signed-getter
 558 \ set-alien-signed-1 small-reg-8 define-setter
 559
 560 \ alien-unsigned-2 small-reg-16 define-unsigned-getter
 561 \ set-alien-unsigned-2 small-reg-16 define-setter
 562
 563 \ alien-signed-2 small-reg-16 define-signed-getter
 564 \ set-alien-signed-2 small-reg-16 define-setter
 565
 566 \ alien-cell [
 567     "offset" operand %untag-fixnum
 568
 569     [ MOV ]
 570     "offset" operand
 571     "alien" operand-class
 572     %alien-accessor
 573
 574     "offset" get %allot-alien
 575 ] alien-integer-get-template define-intrinsic