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