/unmaintained/ppc/ppc.factor
text | 826 lines | 660 code | 166 blank | 0 comment | 0 complexity | 2630b4589e14bac291fc3678ff270e92 MD5 | raw file
1! Copyright (C) 2005, 2010 Slava Pestov. 2! See http://factorcode.org/license.txt for BSD license. 3USING: accessors assocs sequences kernel combinators 4classes.algebra byte-arrays make math math.order math.ranges 5system namespaces locals layouts words alien alien.accessors 6alien.c-types alien.complex alien.data alien.libraries 7literals cpu.architecture cpu.ppc.assembler cpu.ppc.assembler.backend 8compiler.cfg.registers compiler.cfg.instructions 9compiler.cfg.comparisons compiler.codegen.fixup 10compiler.cfg.intrinsics compiler.cfg.stack-frame 11compiler.cfg.build-stack-frame compiler.units compiler.constants 12compiler.codegen vm ; 13QUALIFIED-WITH: alien.c-types c 14FROM: cpu.ppc.assembler => B ; 15FROM: layouts => cell ; 16FROM: math => float ; 17IN: cpu.ppc 18 19! PowerPC register assignments: 20! r2-r12: integer vregs 21! r13: data stack 22! r14: retain stack 23! r15: VM pointer 24! r16-r29: integer vregs 25! r30: integer scratch 26! f0-f29: float vregs 27! f30: float scratch 28 29! Add some methods to the assembler that are useful to us 30M: label (B) [ 0 ] 2dip (B) rc-relative-ppc-3 label-fixup ; 31M: label BC [ 0 BC ] dip rc-relative-ppc-2 label-fixup ; 32 33enable-float-intrinsics 34 35M: ppc machine-registers 36 { 37 { int-regs $[ 2 12 [a,b] 16 29 [a,b] append ] } 38 { float-regs $[ 0 29 [a,b] ] } 39 } ; 40 41CONSTANT: scratch-reg 30 42CONSTANT: fp-scratch-reg 30 43 44M: ppc complex-addressing? f ; 45 46M: ppc fused-unboxing? f ; 47 48M: ppc %load-immediate ( reg n -- ) swap LOAD ; 49 50M: ppc %load-reference ( reg obj -- ) 51 [ [ 0 swap LOAD32 ] [ rc-absolute-ppc-2/2 rel-literal ] bi* ] 52 [ \ f type-number swap LI ] 53 if* ; 54 55M: ppc %alien-global ( register symbol dll -- ) 56 [ 0 swap LOAD32 ] 2dip rc-absolute-ppc-2/2 rel-dlsym ; 57 58CONSTANT: ds-reg 13 59CONSTANT: rs-reg 14 60CONSTANT: vm-reg 15 61 62: %load-vm-addr ( reg -- ) vm-reg MR ; 63 64M: ppc %vm-field ( dst field -- ) [ vm-reg ] dip LWZ ; 65 66M: ppc %set-vm-field ( src field -- ) [ vm-reg ] dip STW ; 67 68GENERIC: loc-reg ( loc -- reg ) 69 70M: ds-loc loc-reg drop ds-reg ; 71M: rs-loc loc-reg drop rs-reg ; 72 73: loc>operand ( loc -- reg n ) 74 [ loc-reg ] [ n>> cells neg ] bi ; inline 75 76M: ppc %peek loc>operand LWZ ; 77M: ppc %replace loc>operand STW ; 78 79:: (%inc) ( n reg -- ) reg reg n cells ADDI ; inline 80 81M: ppc %inc-d ( n -- ) ds-reg (%inc) ; 82M: ppc %inc-r ( n -- ) rs-reg (%inc) ; 83 84HOOK: reserved-area-size os ( -- n ) 85 86! The start of the stack frame contains the size of this frame 87! as well as the currently executing code block 88: factor-area-size ( -- n ) 2 cells ; foldable 89: next-save ( n -- i ) cell - ; foldable 90: xt-save ( n -- i ) 2 cells - ; foldable 91 92! Next, we have the spill area as well as the FFI parameter area. 93! It is safe for them to overlap, since basic blocks with FFI calls 94! will never spill -- indeed, basic blocks with FFI calls do not 95! use vregs at all, and the FFI call is a stack analysis sync point. 96! In the future this will change and the stack frame logic will 97! need to be untangled somewhat. 98 99: param@ ( n -- x ) reserved-area-size + ; inline 100 101: param-save-size ( -- n ) 8 cells ; foldable 102 103: local@ ( n -- x ) 104 reserved-area-size param-save-size + + ; inline 105 106: spill@ ( n -- offset ) 107 spill-offset local@ ; 108 109! Some FP intrinsics need a temporary scratch area in the stack 110! frame, 8 bytes in size. This is in the param-save area so it 111! does not overlap with spill slots. 112: scratch@ ( n -- offset ) 113 factor-area-size + ; 114 115! Finally we have the linkage area 116HOOK: lr-save os ( -- n ) 117 118M: ppc stack-frame-size ( stack-frame -- i ) 119 (stack-frame-size) 120 param-save-size + 121 reserved-area-size + 122 factor-area-size + 123 4 cells align ; 124 125M: ppc %call ( word -- ) 0 BL rc-relative-ppc-3 rel-word-pic ; 126 127M: ppc %jump ( word -- ) 128 0 6 LOAD32 4 rc-absolute-ppc-2/2 rel-here 129 0 B rc-relative-ppc-3 rel-word-pic-tail ; 130 131M: ppc %jump-label ( label -- ) B ; 132M: ppc %return ( -- ) BLR ; 133 134M:: ppc %dispatch ( src temp -- ) 135 0 temp LOAD32 136 3 cells rc-absolute-ppc-2/2 rel-here 137 temp temp src LWZX 138 temp MTCTR 139 BCTR ; 140 141: (%slot) ( dst obj slot scale tag -- obj dst slot ) 142 [ 0 assert= ] bi@ swapd ; 143 144M: ppc %slot ( dst obj slot scale tag -- ) (%slot) LWZX ; 145M: ppc %slot-imm ( dst obj slot tag -- ) slot-offset LWZ ; 146M: ppc %set-slot ( src obj slot scale tag -- ) (%slot) STWX ; 147M: ppc %set-slot-imm ( src obj slot tag -- ) slot-offset STW ; 148 149M: ppc %add ADD ; 150M: ppc %add-imm ADDI ; 151M: ppc %sub swap SUBF ; 152M: ppc %sub-imm SUBI ; 153M: ppc %mul MULLW ; 154M: ppc %mul-imm MULLI ; 155M: ppc %and AND ; 156M: ppc %and-imm ANDI ; 157M: ppc %or OR ; 158M: ppc %or-imm ORI ; 159M: ppc %xor XOR ; 160M: ppc %xor-imm XORI ; 161M: ppc %shl SLW ; 162M: ppc %shl-imm swapd SLWI ; 163M: ppc %shr SRW ; 164M: ppc %shr-imm swapd SRWI ; 165M: ppc %sar SRAW ; 166M: ppc %sar-imm SRAWI ; 167M: ppc %not NOT ; 168M: ppc %neg NEG ; 169 170:: overflow-template ( label dst src1 src2 cc insn -- ) 171 0 0 LI 172 0 MTXER 173 dst src2 src1 insn call 174 cc { 175 { cc-o [ label BO ] } 176 { cc/o [ label BNO ] } 177 } case ; inline 178 179M: ppc %fixnum-add ( label dst src1 src2 cc -- ) 180 [ ADDO. ] overflow-template ; 181 182M: ppc %fixnum-sub ( label dst src1 src2 cc -- ) 183 [ SUBFO. ] overflow-template ; 184 185M: ppc %fixnum-mul ( label dst src1 src2 cc -- ) 186 [ MULLWO. ] overflow-template ; 187 188M: ppc %add-float FADD ; 189M: ppc %sub-float FSUB ; 190M: ppc %mul-float FMUL ; 191M: ppc %div-float FDIV ; 192 193M: ppc integer-float-needs-stack-frame? t ; 194 195M:: ppc %integer>float ( dst src -- ) 196 HEX: 4330 scratch-reg LIS 197 scratch-reg 1 0 scratch@ STW 198 scratch-reg src MR 199 scratch-reg dup HEX: 8000 XORIS 200 scratch-reg 1 4 scratch@ STW 201 dst 1 0 scratch@ LFD 202 scratch-reg 4503601774854144.0 %load-reference 203 fp-scratch-reg scratch-reg float-offset LFD 204 dst dst fp-scratch-reg FSUB ; 205 206M:: ppc %float>integer ( dst src -- ) 207 fp-scratch-reg src FCTIWZ 208 fp-scratch-reg 1 0 scratch@ STFD 209 dst 1 4 scratch@ LWZ ; 210 211M: ppc %copy ( dst src rep -- ) 212 2over eq? [ 3drop ] [ 213 { 214 { tagged-rep [ MR ] } 215 { int-rep [ MR ] } 216 { double-rep [ FMR ] } 217 } case 218 ] if ; 219 220GENERIC: float-function-param* ( dst src -- ) 221 222M: spill-slot float-function-param* [ 1 ] dip n>> spill@ LFD ; 223M: integer float-function-param* FMR ; 224 225: float-function-param ( i src -- ) 226 [ float-regs cdecl param-regs at nth ] dip float-function-param* ; 227 228: float-function-return ( reg -- ) 229 float-regs return-regs at first double-rep %copy ; 230 231M:: ppc %unary-float-function ( dst src func -- ) 232 0 src float-function-param 233 func f %c-invoke 234 dst float-function-return ; 235 236M:: ppc %binary-float-function ( dst src1 src2 func -- ) 237 0 src1 float-function-param 238 1 src2 float-function-param 239 func f %c-invoke 240 dst float-function-return ; 241 242! Internal format is always double-precision on PowerPC 243M: ppc %single>double-float double-rep %copy ; 244M: ppc %double>single-float FRSP ; 245 246M: ppc %unbox-alien ( dst src -- ) 247 alien-offset LWZ ; 248 249M:: ppc %unbox-any-c-ptr ( dst src -- ) 250 [ 251 "end" define-label 252 0 dst LI 253 ! Is the object f? 254 0 src \ f type-number CMPI 255 "end" get BEQ 256 ! Compute tag in dst register 257 dst src tag-mask get ANDI 258 ! Is the object an alien? 259 0 dst alien type-number CMPI 260 ! Add an offset to start of byte array's data 261 dst src byte-array-offset ADDI 262 "end" get BNE 263 ! If so, load the offset and add it to the address 264 dst src alien-offset LWZ 265 "end" resolve-label 266 ] with-scope ; 267 268: alien@ ( n -- n' ) cells alien type-number - ; 269 270M:: ppc %box-alien ( dst src temp -- ) 271 [ 272 "f" define-label 273 dst \ f type-number %load-immediate 274 0 src 0 CMPI 275 "f" get BEQ 276 dst 5 cells alien temp %allot 277 temp \ f type-number %load-immediate 278 temp dst 1 alien@ STW 279 temp dst 2 alien@ STW 280 src dst 3 alien@ STW 281 src dst 4 alien@ STW 282 "f" resolve-label 283 ] with-scope ; 284 285:: %box-displaced-alien/f ( dst displacement base -- ) 286 base dst 1 alien@ STW 287 displacement dst 3 alien@ STW 288 displacement dst 4 alien@ STW ; 289 290:: %box-displaced-alien/alien ( dst displacement base temp -- ) 291 ! Set new alien's base to base.base 292 temp base 1 alien@ LWZ 293 temp dst 1 alien@ STW 294 295 ! Compute displacement 296 temp base 3 alien@ LWZ 297 temp temp displacement ADD 298 temp dst 3 alien@ STW 299 300 ! Compute address 301 temp base 4 alien@ LWZ 302 temp temp displacement ADD 303 temp dst 4 alien@ STW ; 304 305:: %box-displaced-alien/byte-array ( dst displacement base temp -- ) 306 base dst 1 alien@ STW 307 displacement dst 3 alien@ STW 308 temp base byte-array-offset ADDI 309 temp temp displacement ADD 310 temp dst 4 alien@ STW ; 311 312:: %box-displaced-alien/dynamic ( dst displacement base temp -- ) 313 "not-f" define-label 314 "not-alien" define-label 315 316 ! Is base f? 317 0 base \ f type-number CMPI 318 "not-f" get BNE 319 320 ! Yes, it is f. Fill in new object 321 dst displacement base %box-displaced-alien/f 322 323 "end" get B 324 325 "not-f" resolve-label 326 327 ! Check base type 328 temp base tag-mask get ANDI 329 330 ! Is base an alien? 331 0 temp alien type-number CMPI 332 "not-alien" get BNE 333 334 dst displacement base temp %box-displaced-alien/alien 335 336 ! We are done 337 "end" get B 338 339 ! Is base a byte array? It has to be, by now... 340 "not-alien" resolve-label 341 342 dst displacement base temp %box-displaced-alien/byte-array ; 343 344M:: ppc %box-displaced-alien ( dst displacement base temp base-class -- ) 345 ! This is ridiculous 346 [ 347 "end" define-label 348 349 ! If displacement is zero, return the base 350 dst base MR 351 0 displacement 0 CMPI 352 "end" get BEQ 353 354 ! Displacement is non-zero, we're going to be allocating a new 355 ! object 356 dst 5 cells alien temp %allot 357 358 ! Set expired to f 359 temp \ f type-number %load-immediate 360 temp dst 2 alien@ STW 361 362 dst displacement base temp 363 { 364 { [ base-class \ f class<= ] [ drop %box-displaced-alien/f ] } 365 { [ base-class \ alien class<= ] [ %box-displaced-alien/alien ] } 366 { [ base-class \ byte-array class<= ] [ %box-displaced-alien/byte-array ] } 367 [ %box-displaced-alien/dynamic ] 368 } cond 369 370 "end" resolve-label 371 ] with-scope ; 372 373: (%memory) ( val base displacement scale offset rep c-type -- base val displacement rep c-type ) 374 [ [ 0 assert= ] bi@ swapd ] 2dip ; inline 375 376M: ppc %load-memory-imm ( dst base offset rep c-type -- ) 377 [ 378 { 379 { c:char [ [ dup ] 2dip LBZ dup EXTSB ] } 380 { c:uchar [ LBZ ] } 381 { c:short [ LHA ] } 382 { c:ushort [ LHZ ] } 383 { c:int [ LWZ ] } 384 { c:uint [ LWZ ] } 385 } case 386 ] [ 387 { 388 { int-rep [ LWZ ] } 389 { float-rep [ LFS ] } 390 { double-rep [ LFD ] } 391 } case 392 ] ?if ; 393 394M: ppc %load-memory ( dst base displacement scale offset rep c-type -- ) 395 (%memory) [ 396 { 397 { c:char [ [ LBZX ] [ drop dup EXTSB ] 2bi ] } 398 { c:uchar [ LBZX ] } 399 { c:short [ LHAX ] } 400 { c:ushort [ LHZX ] } 401 { c:int [ LWZX ] } 402 { c:uint [ LWZX ] } 403 } case 404 ] [ 405 { 406 { int-rep [ LWZX ] } 407 { float-rep [ LFSX ] } 408 { double-rep [ LFDX ] } 409 } case 410 ] ?if ; 411 412M: ppc %store-memory-imm ( src base offset rep c-type -- ) 413 [ 414 { 415 { c:char [ STB ] } 416 { c:uchar [ STB ] } 417 { c:short [ STH ] } 418 { c:ushort [ STH ] } 419 { c:int [ STW ] } 420 { c:uint [ STW ] } 421 } case 422 ] [ 423 { 424 { int-rep [ STW ] } 425 { float-rep [ STFS ] } 426 { double-rep [ STFD ] } 427 } case 428 ] ?if ; 429 430M: ppc %store-memory ( src base displacement scale offset rep c-type -- ) 431 (%memory) [ 432 { 433 { c:char [ STBX ] } 434 { c:uchar [ STBX ] } 435 { c:short [ STHX ] } 436 { c:ushort [ STHX ] } 437 { c:int [ STWX ] } 438 { c:uint [ STWX ] } 439 } case 440 ] [ 441 { 442 { int-rep [ STWX ] } 443 { float-rep [ STFSX ] } 444 { double-rep [ STFDX ] } 445 } case 446 ] ?if ; 447 448: load-zone-ptr ( reg -- ) 449 vm-reg "nursery" vm-field-offset ADDI ; 450 451: load-allot-ptr ( nursery-ptr allot-ptr -- ) 452 [ drop load-zone-ptr ] [ swap 0 LWZ ] 2bi ; 453 454:: inc-allot-ptr ( nursery-ptr allot-ptr n -- ) 455 scratch-reg allot-ptr n data-alignment get align ADDI 456 scratch-reg nursery-ptr 0 STW ; 457 458:: store-header ( dst class -- ) 459 class type-number tag-header scratch-reg LI 460 scratch-reg dst 0 STW ; 461 462: store-tagged ( dst tag -- ) 463 dupd type-number ORI ; 464 465M:: ppc %allot ( dst size class nursery-ptr -- ) 466 nursery-ptr dst load-allot-ptr 467 nursery-ptr dst size inc-allot-ptr 468 dst class store-header 469 dst class store-tagged ; 470 471: load-cards-offset ( dst -- ) 472 0 swap LOAD32 rc-absolute-ppc-2/2 rel-cards-offset ; 473 474: load-decks-offset ( dst -- ) 475 0 swap LOAD32 rc-absolute-ppc-2/2 rel-decks-offset ; 476 477:: (%write-barrier) ( temp1 temp2 -- ) 478 card-mark scratch-reg LI 479 480 ! Mark the card 481 temp1 temp1 card-bits SRWI 482 temp2 load-cards-offset 483 temp1 scratch-reg temp2 STBX 484 485 ! Mark the card deck 486 temp1 temp1 deck-bits card-bits - SRWI 487 temp2 load-decks-offset 488 temp1 scratch-reg temp2 STBX ; 489 490M:: ppc %write-barrier ( src slot scale tag temp1 temp2 -- ) 491 scale 0 assert= tag 0 assert= 492 temp1 src slot ADD 493 temp1 temp2 (%write-barrier) ; 494 495M:: ppc %write-barrier-imm ( src slot tag temp1 temp2 -- ) 496 temp1 src slot tag slot-offset ADDI 497 temp1 temp2 (%write-barrier) ; 498 499M:: ppc %check-nursery-branch ( label size cc temp1 temp2 -- ) 500 temp1 vm-reg "nursery" vm-field-offset LWZ 501 temp2 vm-reg "nursery" vm-field-offset 2 cells + LWZ 502 temp1 temp1 size ADDI 503 ! is here >= end? 504 temp1 0 temp2 CMP 505 cc { 506 { cc<= [ label BLE ] } 507 { cc/<= [ label BGT ] } 508 } case ; 509 510: gc-root-offsets ( seq -- seq' ) 511 [ n>> spill@ ] map f like ; 512 513M: ppc %call-gc ( gc-roots -- ) 514 3 swap gc-root-offsets %load-reference 515 4 %load-vm-addr 516 "inline_gc" f %c-invoke ; 517 518M: ppc %prologue ( n -- ) 519 0 11 LOAD32 rc-absolute-ppc-2/2 rel-this 520 0 MFLR 521 { 522 [ [ 1 1 ] dip neg ADDI ] 523 [ [ 11 1 ] dip xt-save STW ] 524 [ 11 LI ] 525 [ [ 11 1 ] dip next-save STW ] 526 [ [ 0 1 ] dip lr-save + STW ] 527 } cleave ; 528 529M: ppc %epilogue ( n -- ) 530 #! At the end of each word that calls a subroutine, we store 531 #! the previous link register value in r0 by popping it off 532 #! the stack, set the link register to the contents of r0, 533 #! and jump to the link register. 534 [ [ 0 1 ] dip lr-save + LWZ ] 535 [ [ 1 1 ] dip ADDI ] bi 536 0 MTLR ; 537 538:: (%boolean) ( dst temp branch1 branch2 -- ) 539 "end" define-label 540 dst \ f type-number %load-immediate 541 "end" get branch1 execute( label -- ) 542 branch2 [ "end" get branch2 execute( label -- ) ] when 543 dst \ t %load-reference 544 "end" get resolve-label ; inline 545 546:: %boolean ( dst cc temp -- ) 547 cc negate-cc order-cc { 548 { cc< [ dst temp \ BLT f (%boolean) ] } 549 { cc<= [ dst temp \ BLE f (%boolean) ] } 550 { cc> [ dst temp \ BGT f (%boolean) ] } 551 { cc>= [ dst temp \ BGE f (%boolean) ] } 552 { cc= [ dst temp \ BEQ f (%boolean) ] } 553 { cc/= [ dst temp \ BNE f (%boolean) ] } 554 } case ; 555 556: (%compare) ( src1 src2 -- ) [ 0 ] dip CMP ; inline 557 558: (%compare-integer-imm) ( src1 src2 -- ) 559 [ 0 ] 2dip CMPI ; inline 560 561: (%compare-imm) ( src1 src2 -- ) 562 [ tag-fixnum ] [ \ f type-number ] if* (%compare-integer-imm) ; inline 563 564: (%compare-float-unordered) ( src1 src2 -- ) 565 [ 0 ] dip FCMPU ; inline 566 567: (%compare-float-ordered) ( src1 src2 -- ) 568 [ 0 ] dip FCMPO ; inline 569 570:: (%compare-float) ( src1 src2 cc compare -- branch1 branch2 ) 571 cc { 572 { cc< [ src1 src2 \ compare execute( a b -- ) \ BLT f ] } 573 { cc<= [ src1 src2 \ compare execute( a b -- ) \ BLT \ BEQ ] } 574 { cc> [ src1 src2 \ compare execute( a b -- ) \ BGT f ] } 575 { cc>= [ src1 src2 \ compare execute( a b -- ) \ BGT \ BEQ ] } 576 { cc= [ src1 src2 \ compare execute( a b -- ) \ BEQ f ] } 577 { cc<> [ src1 src2 \ compare execute( a b -- ) \ BLT \ BGT ] } 578 { cc<>= [ src1 src2 \ compare execute( a b -- ) \ BNO f ] } 579 { cc/< [ src1 src2 \ compare execute( a b -- ) \ BGE f ] } 580 { cc/<= [ src1 src2 \ compare execute( a b -- ) \ BGT \ BO ] } 581 { cc/> [ src1 src2 \ compare execute( a b -- ) \ BLE f ] } 582 { cc/>= [ src1 src2 \ compare execute( a b -- ) \ BLT \ BO ] } 583 { cc/= [ src1 src2 \ compare execute( a b -- ) \ BNE f ] } 584 { cc/<> [ src1 src2 \ compare execute( a b -- ) \ BEQ \ BO ] } 585 { cc/<>= [ src1 src2 \ compare execute( a b -- ) \ BO f ] } 586 } case ; inline 587 588M: ppc %compare [ (%compare) ] 2dip %boolean ; 589 590M: ppc %compare-imm [ (%compare-imm) ] 2dip %boolean ; 591 592M: ppc %compare-integer-imm [ (%compare-integer-imm) ] 2dip %boolean ; 593 594M:: ppc %compare-float-ordered ( dst src1 src2 cc temp -- ) 595 src1 src2 cc negate-cc \ (%compare-float-ordered) (%compare-float) :> ( branch1 branch2 ) 596 dst temp branch1 branch2 (%boolean) ; 597 598M:: ppc %compare-float-unordered ( dst src1 src2 cc temp -- ) 599 src1 src2 cc negate-cc \ (%compare-float-unordered) (%compare-float) :> ( branch1 branch2 ) 600 dst temp branch1 branch2 (%boolean) ; 601 602:: %branch ( label cc -- ) 603 cc order-cc { 604 { cc< [ label BLT ] } 605 { cc<= [ label BLE ] } 606 { cc> [ label BGT ] } 607 { cc>= [ label BGE ] } 608 { cc= [ label BEQ ] } 609 { cc/= [ label BNE ] } 610 } case ; 611 612M:: ppc %compare-branch ( label src1 src2 cc -- ) 613 src1 src2 (%compare) 614 label cc %branch ; 615 616M:: ppc %compare-imm-branch ( label src1 src2 cc -- ) 617 src1 src2 (%compare-imm) 618 label cc %branch ; 619 620M:: ppc %compare-integer-imm-branch ( label src1 src2 cc -- ) 621 src1 src2 (%compare-integer-imm) 622 label cc %branch ; 623 624:: (%branch) ( label branch1 branch2 -- ) 625 label branch1 execute( label -- ) 626 branch2 [ label branch2 execute( label -- ) ] when ; inline 627 628M:: ppc %compare-float-ordered-branch ( label src1 src2 cc -- ) 629 src1 src2 cc \ (%compare-float-ordered) (%compare-float) :> ( branch1 branch2 ) 630 label branch1 branch2 (%branch) ; 631 632M:: ppc %compare-float-unordered-branch ( label src1 src2 cc -- ) 633 src1 src2 cc \ (%compare-float-unordered) (%compare-float) :> ( branch1 branch2 ) 634 label branch1 branch2 (%branch) ; 635 636: load-from-frame ( dst n rep -- ) 637 { 638 { int-rep [ [ 1 ] dip LWZ ] } 639 { tagged-rep [ [ 1 ] dip LWZ ] } 640 { float-rep [ [ 1 ] dip LFS ] } 641 { double-rep [ [ 1 ] dip LFD ] } 642 { stack-params [ [ 0 1 ] dip LWZ [ 0 1 ] dip param@ STW ] } 643 } case ; 644 645: next-param@ ( n -- reg x ) 646 [ 17 ] dip param@ ; 647 648: store-to-frame ( src n rep -- ) 649 { 650 { int-rep [ [ 1 ] dip STW ] } 651 { tagged-rep [ [ 1 ] dip STW ] } 652 { float-rep [ [ 1 ] dip STFS ] } 653 { double-rep [ [ 1 ] dip STFD ] } 654 { stack-params [ [ [ 0 ] dip next-param@ LWZ 0 1 ] dip STW ] } 655 } case ; 656 657M: ppc %spill ( src rep dst -- ) 658 swap [ n>> spill@ ] dip store-to-frame ; 659 660M: ppc %reload ( dst rep src -- ) 661 swap [ n>> spill@ ] dip load-from-frame ; 662 663M: ppc %loop-entry ; 664 665M: ppc return-regs 666 { 667 { int-regs { 3 4 5 6 } } 668 { float-regs { 1 } } 669 } ; 670 671M:: ppc %save-param-reg ( stack reg rep -- ) 672 reg stack local@ rep store-to-frame ; 673 674M:: ppc %load-param-reg ( stack reg rep -- ) 675 reg stack local@ rep load-from-frame ; 676 677GENERIC: load-param ( reg src -- ) 678 679M: integer load-param int-rep %copy ; 680 681M: spill-slot load-param [ 1 ] dip n>> spill@ LWZ ; 682 683GENERIC: store-param ( reg dst -- ) 684 685M: integer store-param swap int-rep %copy ; 686 687M: spill-slot store-param [ 1 ] dip n>> spill@ STW ; 688 689:: call-unbox-func ( src func -- ) 690 3 src load-param 691 4 %load-vm-addr 692 func f %c-invoke ; 693 694M:: ppc %unbox ( src n rep func -- ) 695 src func call-unbox-func 696 ! Store the return value on the C stack 697 n [ rep reg-class-of return-regs at first rep %save-param-reg ] when* ; 698 699M:: ppc %unbox-long-long ( src n func -- ) 700 src func call-unbox-func 701 ! Store the return value on the C stack 702 n [ 703 3 1 n local@ STW 704 4 1 n cell + local@ STW 705 ] when ; 706 707M:: ppc %unbox-large-struct ( src n c-type -- ) 708 4 src load-param 709 3 1 n local@ ADDI 710 c-type heap-size 5 LI 711 "memcpy" "libc" load-library %c-invoke ; 712 713M:: ppc %box ( dst n rep func -- ) 714 n [ 0 rep reg-class-of cdecl param-reg rep %load-param-reg ] when* 715 rep double-rep? 5 4 ? %load-vm-addr 716 func f %c-invoke 717 3 dst store-param ; 718 719M:: ppc %box-long-long ( dst n func -- ) 720 n [ 721 3 1 n local@ LWZ 722 4 1 n cell + local@ LWZ 723 ] when 724 5 %load-vm-addr 725 func f %c-invoke 726 3 dst store-param ; 727 728: struct-return@ ( n -- n ) 729 [ stack-frame get params>> ] unless* local@ ; 730 731M: ppc %prepare-box-struct ( -- ) 732 #! Compute target address for value struct return 733 3 1 f struct-return@ ADDI 734 3 1 0 local@ STW ; 735 736M:: ppc %box-large-struct ( dst n c-type -- ) 737 ! If n = f, then we're boxing a returned struct 738 ! Compute destination address and load struct size 739 3 1 n struct-return@ ADDI 740 c-type heap-size 4 LI 741 5 %load-vm-addr 742 ! Call the function 743 "from_value_struct" f %c-invoke 744 3 dst store-param ; 745 746M:: ppc %restore-context ( temp1 temp2 -- ) 747 temp1 %context 748 ds-reg temp1 "datastack" context-field-offset LWZ 749 rs-reg temp1 "retainstack" context-field-offset LWZ ; 750 751M:: ppc %save-context ( temp1 temp2 -- ) 752 temp1 %context 753 1 temp1 "callstack-top" context-field-offset STW 754 ds-reg temp1 "datastack" context-field-offset STW 755 rs-reg temp1 "retainstack" context-field-offset STW ; 756 757M: ppc %c-invoke ( symbol dll -- ) 758 [ 11 ] 2dip %alien-global 11 MTLR BLRL ; 759 760M: ppc %alien-indirect ( src -- ) 761 [ 11 ] dip load-param 11 MTLR BLRL ; 762 763M: ppc immediate-arithmetic? ( n -- ? ) -32768 32767 between? ; 764 765M: ppc immediate-bitwise? ( n -- ? ) 0 65535 between? ; 766 767M: ppc immediate-store? drop f ; 768 769M: ppc return-struct-in-registers? ( c-type -- ? ) 770 c-type return-in-registers?>> ; 771 772M:: ppc %box-small-struct ( dst c-type -- ) 773 #! Box a <= 16-byte struct returned in r3:r4:r5:r6 774 c-type heap-size 7 LI 775 8 %load-vm-addr 776 "from_medium_struct" f %c-invoke 777 3 dst store-param ; 778 779: %unbox-struct-1 ( -- ) 780 ! Alien must be in r3. 781 3 3 0 LWZ ; 782 783: %unbox-struct-2 ( -- ) 784 ! Alien must be in r3. 785 4 3 4 LWZ 786 3 3 0 LWZ ; 787 788: %unbox-struct-4 ( -- ) 789 ! Alien must be in r3. 790 6 3 12 LWZ 791 5 3 8 LWZ 792 4 3 4 LWZ 793 3 3 0 LWZ ; 794 795M:: ppc %unbox-small-struct ( src c-type -- ) 796 src 3 load-param 797 c-type heap-size { 798 { [ dup 4 <= ] [ drop %unbox-struct-1 ] } 799 { [ dup 8 <= ] [ drop %unbox-struct-2 ] } 800 { [ dup 16 <= ] [ drop %unbox-struct-4 ] } 801 } cond ; 802 803M: ppc %begin-callback ( -- ) 804 3 %load-vm-addr 805 "begin_callback" f %c-invoke ; 806 807M: ppc %alien-callback ( quot -- ) 808 3 swap %load-reference 809 4 3 quot-entry-point-offset LWZ 810 4 MTLR 811 BLRL ; 812 813M: ppc %end-callback ( -- ) 814 3 %load-vm-addr 815 "end_callback" f %c-invoke ; 816 817enable-float-functions 818 819USE: vocabs.loader 820 821{ 822 { [ os macosx? ] [ "cpu.ppc.macosx" require ] } 823 { [ os linux? ] [ "cpu.ppc.linux" require ] } 824} cond 825 826complex-double c-type t >>return-in-registers? drop