core/cpu/ppc/intrinsics/intrinsics.factor

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