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