core/cpu/ppc/intrinsics/intrinsics.factor

   1 ! Copyright (C) 2005, 2008 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors alien alien.accessors alien.c-types arrays
   4 cpu.ppc.assembler cpu.ppc.architecture cpu.ppc.allot
   5 cpu.architecture kernel kernel.private math math.private
   6 namespaces sequences words generic quotations byte-arrays
   7 hashtables hashtables.private generator generator.registers
   8 generator.fixup sequences.private sbufs vectors system layouts
   9 math.floats.private classes slots.private combinators
  10 compiler.constants optimizer.allot ;
  11 IN: cpu.ppc.intrinsics
  12
  13 : %slot-literal-known-tag
  14     "val" operand
  15     "obj" operand
  16     "n" get cells
  17     "obj" get operand-tag - ;
  18
  19 : %slot-literal-any-tag
  20     "obj" operand "scratch1" operand %untag
  21     "val" operand "scratch1" operand "n" get cells ;
  22
  23 : %slot-any
  24     "obj" operand "scratch1" operand %untag
  25     "offset" operand "n" operand 1 SRAWI
  26     "scratch1" operand "val" operand "offset" operand ;
  27
  28 \ slot {
  29     ! Slot number is literal and the tag is known
  30     {
  31         [ %slot-literal-known-tag LWZ ] H{
  32             { +input+ { { f "obj" known-tag } { [ small-slot? ] "n" } } }
  33             { +scratch+ { { f "val" } } }
  34             { +output+ { "val" } }
  35         }
  36     }
  37     ! Slot number is literal
  38     {
  39         [ %slot-literal-any-tag LWZ ] H{
  40             { +input+ { { f "obj" } { [ small-slot? ] "n" } } }
  41             { +scratch+ { { f "scratch1" } { f "val" } } }
  42             { +output+ { "val" } }
  43         }
  44     }
  45     ! Slot number in a register
  46     {
  47         [ %slot-any LWZX ] H{
  48             { +input+ { { f "obj" } { f "n" } } }
  49             { +scratch+ { { f "val" } { f "scratch1" } { f "offset" } } }
  50             { +output+ { "val" } }
  51         }
  52     }
  53 } define-intrinsics
  54
  55 : load-cards-offset ( dest -- )
  56     "cards_offset" f pick %load-dlsym  dup 0 LWZ ;
  57
  58 : load-decks-offset ( dest -- )
  59     "decks_offset" f pick %load-dlsym  dup 0 LWZ ;
  60
  61 : %write-barrier ( -- )
  62     "val" get operand-immediate? "obj" get fresh-object? or [
  63         card-mark "scratch1" operand LI
  64
  65         ! Mark the card
  66         "val" operand load-cards-offset
  67         "obj" operand "scratch2" operand card-bits SRWI
  68         "scratch2" operand "scratch1" operand "val" operand STBX
  69
  70         ! Mark the card deck
  71         "val" operand load-decks-offset
  72         "obj" operand "scratch2" operand deck-bits SRWI
  73         "scratch2" operand "scratch1" operand "val" operand STBX
  74     ] unless ;
  75
  76 \ set-slot {
  77     ! Slot number is literal and tag is known
  78     {
  79         [ %slot-literal-known-tag STW %write-barrier ] H{
  80             { +input+ { { f "val" } { f "obj" known-tag } { [ small-slot? ] "n" } } }
  81             { +scratch+ { { f "scratch1" } { f "scratch2" } } }
  82             { +clobber+ { "val" } }
  83         }
  84     }
  85     ! Slot number is literal
  86     {
  87         [ %slot-literal-any-tag STW %write-barrier ] H{
  88             { +input+ { { f "val" } { f "obj" } { [ small-slot? ] "n" } } }
  89             { +scratch+ { { f "scratch1" } { f "scratch2" } } }
  90             { +clobber+ { "val" } }
  91         }
  92     }
  93     ! Slot number is in a register
  94     {
  95         [ %slot-any STWX %write-barrier ] H{
  96             { +input+ { { f "val" } { f "obj" } { f "n" } } }
  97             { +scratch+ { { f "scratch1" } { f "scratch2" } { f "offset" } } }
  98             { +clobber+ { "val" } }
  99         }
 100     }
 101 } define-intrinsics
 102
 103 : fixnum-register-op ( op -- pair )
 104     [ "out" operand "y" operand "x" operand ] swap suffix H{
 105         { +input+ { { f "x" } { f "y" } } }
 106         { +scratch+ { { f "out" } } }
 107         { +output+ { "out" } }
 108     } 2array ;
 109
 110 : fixnum-value-op ( op -- pair )
 111     [ "out" operand "x" operand "y" operand ] swap suffix H{
 112         { +input+ { { f "x" } { [ small-tagged? ] "y" } } }
 113         { +scratch+ { { f "out" } } }
 114         { +output+ { "out" } }
 115     } 2array ;
 116
 117 : define-fixnum-op ( word imm-op reg-op -- )
 118     >r fixnum-value-op r> fixnum-register-op 2array
 119     define-intrinsics ;
 120
 121 {
 122     { fixnum+fast ADDI ADD }
 123     { fixnum-fast SUBI SUBF }
 124     { fixnum-bitand ANDI AND }
 125     { fixnum-bitor ORI OR }
 126     { fixnum-bitxor XORI XOR }
 127 } [
 128     first3 define-fixnum-op
 129 ] each
 130
 131 \ fixnum*fast {
 132     {
 133         [
 134             "out" operand "x" operand "y" get MULLI
 135         ] H{
 136             { +input+ { { f "x" } { [ small-tagged? ] "y" } } }
 137             { +scratch+ { { f "out" } } }
 138             { +output+ { "out" } }
 139         }
 140     } {
 141         [
 142             "out" operand "x" operand %untag-fixnum
 143             "out" operand "y" operand "out" operand MULLW
 144         ] H{
 145             { +input+ { { f "x" } { f "y" } } }
 146             { +scratch+ { { f "out" } } }
 147             { +output+ { "out" } }
 148         }
 149     }
 150 } define-intrinsics
 151
 152 : %untag-fixnums ( seq -- )
 153     [ dup %untag-fixnum ] unique-operands ;
 154
 155 \ fixnum-shift-fast {
 156     {
 157         [
 158             "out" operand "x" operand "y" get
 159             dup 0 < [ neg SRAWI ] [ swapd SLWI ] if
 160             ! Mask off low bits
 161             "out" operand dup %untag
 162         ] H{
 163             { +input+ { { f "x" } { [ ] "y" } } }
 164             { +scratch+ { { f "out" } } }
 165             { +output+ { "out" } }
 166         }
 167     }
 168     {
 169         [
 170             { "positive" "end" } [ define-label ] each
 171             "out" operand "y" operand %untag-fixnum
 172             0 "y" operand 0 CMPI
 173             "positive" get BGE
 174             "out" operand dup NEG
 175             "out" operand "x" operand "out" operand SRAW
 176             "end" get B
 177             "positive" resolve-label
 178             "out" operand "x" operand "out" operand SLW
 179             "end" resolve-label
 180             ! Mask off low bits
 181             "out" operand dup %untag
 182         ] H{
 183             { +input+ { { f "x" } { f "y" } } }
 184             { +scratch+ { { f "out" } } }
 185             { +output+ { "out" } }
 186         }
 187     }
 188 } define-intrinsics
 189
 190 : generate-fixnum-mod
 191     #! PowerPC doesn't have a MOD instruction; so we compute
 192     #! x-(x/y)*y. Puts the result in "s" operand.
 193     "s" operand "r" operand "y" operand MULLW
 194     "s" operand "s" operand "x" operand SUBF ;
 195
 196 \ fixnum-mod [
 197     ! divide x by y, store result in x
 198     "r" operand "x" operand "y" operand DIVW
 199     generate-fixnum-mod
 200 ] H{
 201     { +input+ { { f "x" } { f "y" } } }
 202     { +scratch+ { { f "r" } { f "s" } } }
 203     { +output+ { "s" } }
 204 } define-intrinsic
 205
 206 \ fixnum-bitnot [
 207     "x" operand dup NOT
 208     "x" operand dup %untag
 209 ] H{
 210     { +input+ { { f "x" } } }
 211     { +output+ { "x" } }
 212 } define-intrinsic
 213
 214 : fixnum-register-jump ( op -- pair )
 215     [ "x" operand 0 "y" operand CMP ] swap suffix
 216     { { f "x" } { f "y" } } 2array ;
 217
 218 : fixnum-value-jump ( op -- pair )
 219     [ 0 "x" operand "y" operand CMPI ] swap suffix
 220     { { f "x" } { [ small-tagged? ] "y" } } 2array ;
 221
 222 : define-fixnum-jump ( word op -- )
 223     [ fixnum-value-jump ] keep fixnum-register-jump
 224     2array define-if-intrinsics ;
 225
 226 {
 227     { fixnum< BGE }
 228     { fixnum<= BGT }
 229     { fixnum> BLE }
 230     { fixnum>= BLT }
 231     { eq? BNE }
 232 } [
 233     first2 define-fixnum-jump
 234 ] each
 235
 236 : overflow-check ( insn1 insn2 -- )
 237     [
 238         >r 0 0 LI
 239         0 MTXER
 240         "r" operand "y" operand "x" operand r> execute
 241         >r
 242         "end" define-label
 243         "end" get BNO
 244         { "x" "y" } %untag-fixnums
 245         "r" operand "y" operand "x" operand r> execute
 246         "r" get %allot-bignum-signed-1
 247         "end" resolve-label
 248     ] with-scope ; inline
 249
 250 : overflow-template ( word insn1 insn2 -- )
 251     [ overflow-check ] 2curry H{
 252         { +input+ { { f "x" } { f "y" } } }
 253         { +scratch+ { { f "r" } } }
 254         { +output+ { "r" } }
 255         { +clobber+ { "x" "y" } }
 256     } define-intrinsic ;
 257
 258 \ fixnum+ \ ADD \ ADDO. overflow-template
 259 \ fixnum- \ SUBF \ SUBFO. overflow-template
 260
 261 : generate-fixnum/i
 262     #! This VOP is funny. If there is an overflow, it falls
 263     #! through to the end, and the result is in "x" operand.
 264     #! Otherwise it jumps to the "no-overflow" label and the
 265     #! result is in "r" operand.
 266     "end" define-label
 267     "no-overflow" define-label
 268     "r" operand "x" operand "y" operand DIVW
 269     ! if the result is greater than the most positive fixnum,
 270     ! which can only ever happen if we do
 271     ! most-negative-fixnum -1 /i, then the result is a bignum.
 272     most-positive-fixnum "s" operand LOAD
 273     "r" operand 0 "s" operand CMP
 274     "no-overflow" get BLE
 275     most-negative-fixnum neg "x" operand LOAD
 276     "x" get %allot-bignum-signed-1 ;
 277
 278 \ fixnum/i [
 279     generate-fixnum/i
 280     "end" get B
 281     "no-overflow" resolve-label
 282     "r" operand "x" operand %tag-fixnum
 283     "end" resolve-label
 284 ] H{
 285     { +input+ { { f "x" } { f "y" } } }
 286     { +scratch+ { { f "r" } { f "s" } } }
 287     { +output+ { "x" } }
 288     { +clobber+ { "y" } }
 289 } define-intrinsic
 290
 291 \ fixnum/mod [
 292     generate-fixnum/i
 293     0 "s" operand LI
 294     "end" get B
 295     "no-overflow" resolve-label
 296     generate-fixnum-mod
 297     "r" operand "x" operand %tag-fixnum
 298     "end" resolve-label
 299 ] H{
 300     { +input+ { { f "x" } { f "y" } } }
 301     { +scratch+ { { f "r" } { f "s" } } }
 302     { +output+ { "x" "s" } }
 303     { +clobber+ { "y" } }
 304 } define-intrinsic
 305
 306 \ fixnum>bignum [
 307     "x" operand dup %untag-fixnum
 308     "x" get %allot-bignum-signed-1
 309 ] H{
 310     { +input+ { { f "x" } } }
 311     { +output+ { "x" } }
 312 } define-intrinsic
 313
 314 \ bignum>fixnum [
 315     "nonzero" define-label
 316     "positive" define-label
 317     "end" define-label
 318     "x" operand dup %untag
 319     "y" operand "x" operand cell LWZ
 320      ! if the length is 1, its just the sign and nothing else,
 321      ! so output 0
 322     0 "y" operand 1 v>operand CMPI
 323     "nonzero" get BNE
 324     0 "y" operand LI
 325     "end" get B
 326     "nonzero" resolve-label
 327     ! load the value
 328     "y" operand "x" operand 3 cells LWZ
 329     ! load the sign
 330     "x" operand "x" operand 2 cells LWZ
 331     ! is the sign negative?
 332     0 "x" operand 0 CMPI
 333     "positive" get BEQ
 334     "y" operand dup -1 MULI
 335     "positive" resolve-label
 336     "y" operand dup %tag-fixnum
 337     "end" resolve-label
 338 ] H{
 339     { +input+ { { f "x" } } }
 340     { +scratch+ { { f "y" } } }
 341     { +clobber+ { "x" } }
 342     { +output+ { "y" } }
 343 } define-intrinsic
 344
 345 : define-float-op ( word op -- )
 346     [ "z" operand "x" operand "y" operand ] swap suffix H{
 347         { +input+ { { float "x" } { float "y" } } }
 348         { +scratch+ { { float "z" } } }
 349         { +output+ { "z" } }
 350     } define-intrinsic ;
 351
 352 {
 353     { float+ FADD }
 354     { float- FSUB }
 355     { float* FMUL }
 356     { float/f FDIV }
 357 } [
 358     first2 define-float-op
 359 ] each
 360
 361 : define-float-jump ( word op -- )
 362     [ "x" operand 0 "y" operand FCMPU ] swap suffix
 363     { { float "x" } { float "y" } } define-if-intrinsic ;
 364
 365 {
 366     { float< BGE }
 367     { float<= BGT }
 368     { float> BLE }
 369     { float>= BLT }
 370     { float= BNE }
 371 } [
 372     first2 define-float-jump
 373 ] each
 374
 375 \ float>fixnum [
 376     "scratch" operand "in" operand FCTIWZ
 377     "scratch" operand 1 0 param@ STFD
 378     "out" operand 1 cell param@ LWZ
 379     "out" operand dup %tag-fixnum
 380 ] H{
 381     { +input+ { { float "in" } } }
 382     { +scratch+ { { float "scratch" } { f "out" } } }
 383     { +output+ { "out" } }
 384 } define-intrinsic
 385
 386 \ fixnum>float [
 387     HEX: 4330 "scratch" operand LIS
 388     "scratch" operand 1 0 param@ STW
 389     "scratch" operand "in" operand %untag-fixnum
 390     "scratch" operand dup HEX: 8000 XORIS
 391     "scratch" operand 1 cell param@ STW
 392     "f1" operand 1 0 param@ LFD
 393     4503601774854144.0 "scratch" operand load-indirect
 394     "f2" operand "scratch" operand float-offset LFD
 395     "f1" operand "f1" operand "f2" operand FSUB
 396 ] H{
 397     { +input+ { { f "in" } } }
 398     { +scratch+ { { f "scratch" } { float "f1" } { float "f2" } } }
 399     { +output+ { "f1" } }
 400 } define-intrinsic
 401
 402
 403 \ tag [
 404     "out" operand "in" operand tag-mask get ANDI
 405     "out" operand dup %tag-fixnum
 406 ] H{
 407     { +input+ { { f "in" } } }
 408     { +scratch+ { { f "out" } } }
 409     { +output+ { "out" } }
 410 } define-intrinsic
 411
 412 : userenv ( reg -- )
 413     #! Load the userenv pointer in a register.
 414     "userenv" f rot %load-dlsym ;
 415
 416 \ getenv [
 417     "n" operand dup 1 SRAWI
 418     "x" operand userenv
 419     "x" operand "n" operand "x" operand ADD
 420     "x" operand dup 0 LWZ
 421 ] H{
 422     { +input+ { { f "n" } } }
 423     { +scratch+ { { f "x" } } }
 424     { +output+ { "x" } }
 425     { +clobber+ { "n" } }
 426 } define-intrinsic
 427
 428 \ setenv [
 429     "n" operand dup 1 SRAWI
 430     "x" operand userenv
 431     "x" operand "n" operand "x" operand ADD
 432     "val" operand "x" operand 0 STW
 433 ] H{
 434     { +input+ { { f "val" } { f "n" } } }
 435     { +scratch+ { { f "x" } } }
 436     { +clobber+ { "n" } }
 437 } define-intrinsic
 438
 439 \ (tuple) [
 440     tuple "layout" get size>> 2 + cells %allot
 441     ! Store layout
 442     "layout" get 12 load-indirect
 443     12 11 cell STW
 444     ! Store tagged ptr in reg
 445     "tuple" get tuple %store-tagged
 446 ] H{
 447     { +input+ { { [ ] "layout" } } }
 448     { +scratch+ { { f "tuple" } } }
 449     { +output+ { "tuple" } }
 450 } define-intrinsic
 451
 452 \ (array) [
 453     array "n" get 2 + cells %allot
 454     ! Store length
 455     "n" operand 12 LI
 456     12 11 cell STW
 457     ! Store tagged ptr in reg
 458     "array" get object %store-tagged
 459 ] H{
 460     { +input+ { { [ ] "n" } } }
 461     { +scratch+ { { f "array" } } }
 462     { +output+ { "array" } }
 463 } define-intrinsic
 464
 465 \ (byte-array) [
 466     byte-array "n" get 2 cells + %allot
 467     ! Store length
 468     "n" operand 12 LI
 469     12 11 cell STW
 470     ! Store tagged ptr in reg
 471     "array" get object %store-tagged
 472 ] H{
 473     { +input+ { { [ ] "n" } } }
 474     { +scratch+ { { f "array" } } }
 475     { +output+ { "array" } }
 476 } define-intrinsic
 477
 478 \ <ratio> [
 479     ratio 3 cells %allot
 480     "numerator" operand 11 1 cells STW
 481     "denominator" operand 11 2 cells STW
 482     ! Store tagged ptr in reg
 483     "ratio" get ratio %store-tagged
 484 ] H{
 485     { +input+ { { f "numerator" } { f "denominator" } } }
 486     { +scratch+ { { f "ratio" } } }
 487     { +output+ { "ratio" } }
 488 } define-intrinsic
 489
 490 \ <complex> [
 491     complex 3 cells %allot
 492     "real" operand 11 1 cells STW
 493     "imaginary" operand 11 2 cells STW
 494     ! Store tagged ptr in reg
 495     "complex" get complex %store-tagged
 496 ] H{
 497     { +input+ { { f "real" } { f "imaginary" } } }
 498     { +scratch+ { { f "complex" } } }
 499     { +output+ { "complex" } }
 500 } define-intrinsic
 501
 502 \ <wrapper> [
 503     wrapper 2 cells %allot
 504     "obj" operand 11 1 cells STW
 505     ! Store tagged ptr in reg
 506     "wrapper" get object %store-tagged
 507 ] H{
 508     { +input+ { { f "obj" } } }
 509     { +scratch+ { { f "wrapper" } } }
 510     { +output+ { "wrapper" } }
 511 } define-intrinsic
 512
 513 ! Alien intrinsics
 514 : %alien-accessor ( quot -- )
 515     "offset" operand dup %untag-fixnum
 516     "offset" operand dup "alien" operand ADD
 517     "value" operand "offset" operand 0 roll call ; inline
 518
 519 : alien-integer-get-template
 520     H{
 521         { +input+ {
 522             { unboxed-c-ptr "alien" c-ptr }
 523             { f "offset" fixnum }
 524         } }
 525         { +scratch+ { { f "value" } } }
 526         { +output+ { "value" } }
 527         { +clobber+ { "offset" } }
 528     } ;
 529
 530 : %alien-integer-get ( quot -- )
 531     %alien-accessor
 532     "value" operand dup %tag-fixnum ; inline
 533
 534 : alien-integer-set-template
 535     H{
 536         { +input+ {
 537             { f "value" fixnum }
 538             { unboxed-c-ptr "alien" c-ptr }
 539             { f "offset" fixnum }
 540         } }
 541         { +clobber+ { "value" "offset" } }
 542     } ;
 543
 544 : %alien-integer-set ( quot -- )
 545     "offset" get "value" get = [
 546         "value" operand dup %untag-fixnum
 547     ] unless
 548     %alien-accessor ; inline
 549
 550 : define-alien-integer-intrinsics ( word get-quot word set-quot -- )
 551     [ %alien-integer-set ] curry
 552     alien-integer-set-template
 553     define-intrinsic
 554     [ %alien-integer-get ] curry
 555     alien-integer-get-template
 556     define-intrinsic ;
 557
 558 \ alien-unsigned-1 [ LBZ ]
 559 \ set-alien-unsigned-1 [ STB ]
 560 define-alien-integer-intrinsics
 561
 562 \ alien-signed-1 [ pick >r LBZ r> dup EXTSB ]
 563 \ set-alien-signed-1 [ STB ]
 564 define-alien-integer-intrinsics
 565
 566 \ alien-unsigned-2 [ LHZ ]
 567 \ set-alien-unsigned-2 [ STH ]
 568 define-alien-integer-intrinsics
 569
 570 \ alien-signed-2 [ LHA ]
 571 \ set-alien-signed-2 [ STH ]
 572 define-alien-integer-intrinsics
 573
 574 \ alien-cell [
 575     [ LWZ ] %alien-accessor
 576 ] H{
 577     { +input+ {
 578         { unboxed-c-ptr "alien" c-ptr }
 579         { f "offset" fixnum }
 580     } }
 581     { +scratch+ { { unboxed-alien "value" } } }
 582     { +output+ { "value" } }
 583     { +clobber+ { "offset" } }
 584 } define-intrinsic
 585
 586 \ set-alien-cell [
 587     [ STW ] %alien-accessor
 588 ] H{
 589     { +input+ {
 590         { unboxed-c-ptr "value" pinned-c-ptr }
 591         { unboxed-c-ptr "alien" c-ptr }
 592         { f "offset" fixnum }
 593     } }
 594     { +clobber+ { "offset" } }
 595 } define-intrinsic
 596
 597 : alien-float-get-template
 598     H{
 599         { +input+ {
 600             { unboxed-c-ptr "alien" c-ptr }
 601             { f "offset" fixnum }
 602         } }
 603         { +scratch+ { { float "value" } } }
 604         { +output+ { "value" } }
 605         { +clobber+ { "offset" } }
 606     } ;
 607
 608 : alien-float-set-template
 609     H{
 610         { +input+ {
 611             { float "value" float }
 612             { unboxed-c-ptr "alien" c-ptr }
 613             { f "offset" fixnum }
 614         } }
 615         { +clobber+ { "offset" } }
 616     } ;
 617
 618 : define-alien-float-intrinsics ( word get-quot word set-quot -- )
 619     [ %alien-accessor ] curry
 620     alien-float-set-template
 621     define-intrinsic
 622     [ %alien-accessor ] curry
 623     alien-float-get-template
 624     define-intrinsic ;
 625
 626 \ alien-double [ LFD ]
 627 \ set-alien-double [ STFD ]
 628 define-alien-float-intrinsics
 629
 630 \ alien-float [ LFS ]
 631 \ set-alien-float [ STFS ]
 632 define-alien-float-intrinsics