1 ! Copyright (C) 2011 Erik Charlebois
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: accessors alien alien.accessors alien.c-types alien.complex alien.data
4 alien.libraries assocs byte-arrays classes.algebra classes.struct combinators
5 compiler.cfg compiler.cfg.build-stack-frame compiler.cfg.comparisons
6 compiler.cfg.instructions compiler.cfg.intrinsics compiler.cfg.registers
7 compiler.cfg.stack-frame compiler.codegen compiler.codegen.fixup
8 compiler.constants compiler.units cpu.architecture cpu.ppc.assembler fry io
9 kernel layouts literals locals make math math.order math.ranges memory
10 namespaces prettyprint sequences system vm words ;
11 QUALIFIED-WITH: alien.c-types c
12 FROM: cpu.ppc.assembler => B ;
16 ! PowerPC register assignments:
17 ! r0: reserved for function prolog/epilogues
18 ! r1: call stack register
19 ! r2: toc register / system reserved
20 ! r3-r12: integer vregs
25 ! r17-r29: integer vregs
26 ! r30: integer scratch
32 HOOK: lr-save os ( -- n )
33 HOOK: has-toc os ( -- ? )
34 HOOK: reserved-area-size os ( -- n )
35 HOOK: allows-null-dereference os ( -- ? )
37 M: label B ( label -- ) [ 0 B ] dip rc-relative-ppc-3-pc label-fixup ;
38 M: label BL ( label -- ) [ 0 BL ] dip rc-relative-ppc-3-pc label-fixup ;
39 M: label BC ( bo bi label -- ) [ 0 BC ] dip rc-relative-ppc-2-pc label-fixup ;
41 CONSTANT: scratch-reg 30
42 CONSTANT: fp-scratch-reg 30
47 M: ppc machine-registers ( -- assoc )
49 { int-regs $[ 3 12 [a,b] 17 29 [a,b] append ] }
50 { float-regs $[ 0 29 [a,b] ] }
53 M: ppc frame-reg ( -- reg ) 31 ;
54 M: ppc.32 vm-stack-space ( -- n ) 16 ;
55 M: ppc.64 vm-stack-space ( -- n ) 32 ;
56 M: ppc complex-addressing? ( -- ? ) f ;
58 ! PW1-PW8 parameter save slots
59 : param-save-size ( -- n ) 8 cells ; foldable
62 : factor-area-size ( -- n ) 2 cells ; foldable
64 : spill@ ( n -- offset )
65 spill-offset reserved-area-size + param-save-size + ;
67 : param@ ( n -- offset )
68 reserved-area-size + ;
70 M: ppc gc-root-offset ( spill-slot -- n )
74 [ -16 shift 0xffff bitand LIS ]
75 [ [ dup ] dip 0xffff bitand ORI ] 2bi ;
79 [ nip -48 shift 0xffff bitand LIS ]
80 [ -32 shift 0xffff bitand ORI ]
82 [ -16 shift 0xffff bitand ORIS ]
86 HOOK: %clear-tag-bits cpu ( dst src -- )
87 M: ppc.32 %clear-tag-bits tag-bits get CLRRWI ;
88 M: ppc.64 %clear-tag-bits tag-bits get CLRRDI ;
90 HOOK: %store-cell cpu ( dst src offset -- )
91 M: ppc.32 %store-cell STW ;
92 M: ppc.64 %store-cell STD ;
94 HOOK: %store-cell-x cpu ( dst src offset -- )
95 M: ppc.32 %store-cell-x STWX ;
96 M: ppc.64 %store-cell-x STDX ;
98 HOOK: %store-cell-update cpu ( dst src offset -- )
99 M: ppc.32 %store-cell-update STWU ;
100 M: ppc.64 %store-cell-update STDU ;
102 HOOK: %load-cell cpu ( dst src offset -- )
103 M: ppc.32 %load-cell LWZ ;
104 M: ppc.64 %load-cell LD ;
106 HOOK: %trap-null cpu ( src -- )
108 allows-null-dereference [ 0 TWEQI ] [ drop ] if ;
110 allows-null-dereference [ 0 TDEQI ] [ drop ] if ;
112 HOOK: %load-cell-x cpu ( dst src offset -- )
113 M: ppc.32 %load-cell-x LWZX ;
114 M: ppc.64 %load-cell-x LDX ;
116 HOOK: %load-cell-imm cpu ( dst imm -- )
117 M: ppc.32 %load-cell-imm LOAD32 ;
118 M: ppc.64 %load-cell-imm LOAD64 ;
120 HOOK: %compare-cell cpu ( cr lhs rhs -- )
121 M: ppc.32 %compare-cell CMPW ;
122 M: ppc.64 %compare-cell CMPD ;
124 HOOK: %compare-cell-imm cpu ( cr lhs imm -- )
125 M: ppc.32 %compare-cell-imm CMPWI ;
126 M: ppc.64 %compare-cell-imm CMPDI ;
128 HOOK: %load-cell-imm-rc cpu ( -- rel-class )
129 M: ppc.32 %load-cell-imm-rc rc-absolute-ppc-2/2 ;
130 M: ppc.64 %load-cell-imm-rc rc-absolute-ppc-2/2/2/2 ;
132 M: ppc.32 %load-immediate ( reg val -- )
133 dup -0x8000 0x7fff between? [ LI ] [ LOAD32 ] if ;
134 M: ppc.64 %load-immediate ( reg val -- )
135 dup -0x8000 0x7fff between? [ LI ] [ LOAD64 ] if ;
137 M: ppc %load-reference ( reg obj -- )
138 [ [ 0 %load-cell-imm ] [ %load-cell-imm-rc rel-literal ] bi* ]
139 [ \ f type-number LI ]
142 M:: ppc %load-float ( dst val -- )
143 scratch-reg 0 %load-cell-imm val %load-cell-imm-rc rel-binary-literal
144 dst scratch-reg 0 LFS ;
146 M:: ppc %load-double ( dst val -- )
147 scratch-reg 0 %load-cell-imm val %load-cell-imm-rc rel-binary-literal
148 dst scratch-reg 0 LFD ;
150 M:: ppc %load-vector ( dst val rep -- )
151 scratch-reg 0 %load-cell-imm val %load-cell-imm-rc rel-binary-literal
152 dst 0 scratch-reg LVX ;
154 GENERIC: loc-reg ( loc -- reg )
155 M: ds-loc loc-reg drop ds-reg ;
156 M: rs-loc loc-reg drop rs-reg ;
158 ! Load value at stack location loc into vreg.
159 M: ppc %peek ( vreg loc -- )
160 [ loc-reg ] [ n>> cells neg ] bi %load-cell ;
162 ! Replace value at stack location loc with value in vreg.
163 M: ppc %replace ( vreg loc -- )
164 [ loc-reg ] [ n>> cells neg ] bi %store-cell ;
166 ! Replace value at stack location with an immediate value.
167 M:: ppc %replace-imm ( src loc -- )
169 loc n>> cells neg :> offset
172 drop scratch-reg \ f type-number LI ] }
174 [ scratch-reg ] dip tag-fixnum LI ] }
175 [ scratch-reg 0 LI rc-absolute rel-literal ]
177 scratch-reg reg offset %store-cell ;
179 M: ppc %clear ( loc -- )
180 297 swap %replace-imm ;
182 ! Increment stack pointer by n cells.
183 M: ppc %inc ( loc -- )
184 [ ds-loc? [ ds-reg ds-reg ] [ rs-reg rs-reg ] if ] [ n>> ] bi cells ADDI ;
186 M: ppc stack-frame-size ( stack-frame -- i )
193 M: ppc %call ( word -- )
194 0 BL rc-relative-ppc-3-pc rel-word-pic ;
196 : instrs ( n -- b ) 4 * ; inline
198 M: ppc %jump ( word -- )
199 6 0 %load-cell-imm 1 instrs %load-cell-imm-rc rel-here
200 0 B rc-relative-ppc-3-pc rel-word-pic-tail ;
202 M: ppc %dispatch ( src temp -- )
203 [ nip 0 %load-cell-imm 3 instrs %load-cell-imm-rc rel-here ]
204 [ swap dupd %load-cell-x ]
205 [ nip MTCTR ] 2tri BCTR ;
207 M: ppc %slot ( dst obj slot scale tag -- )
208 [ 0 assert= ] bi@ %load-cell-x ;
210 M: ppc %slot-imm ( dst obj slot tag -- )
211 slot-offset scratch-reg swap LI
212 scratch-reg %load-cell-x ;
214 M: ppc %set-slot ( src obj slot scale tag -- )
215 [ 0 assert= ] bi@ %store-cell-x ;
217 M: ppc %set-slot-imm ( src obj slot tag -- )
218 slot-offset [ scratch-reg ] dip LI scratch-reg %store-cell-x ;
220 M: ppc %jump-label B ;
223 M: ppc %add-imm ADDI ;
225 M: ppc %sub-imm SUBI ;
226 M: ppc.32 %mul MULLW ;
227 M: ppc.64 %mul MULLD ;
228 M: ppc %mul-imm MULLI ;
230 M: ppc %and-imm ANDI. ;
234 M: ppc %xor-imm XORI ;
237 M: ppc.32 %shl-imm SLWI ;
238 M: ppc.64 %shl-imm SLDI ;
241 M: ppc.32 %shr-imm SRWI ;
242 M: ppc.64 %shr-imm SRDI ;
243 M: ppc.32 %sar SRAW ;
244 M: ppc.64 %sar SRAD ;
245 M: ppc.32 %sar-imm SRAWI ;
246 M: ppc.64 %sar-imm SRADI ;
247 M: ppc.32 %min [ 0 CMPW ] [ 0 ISEL ] 2bi ;
248 M: ppc.64 %min [ 0 CMPD ] [ 0 ISEL ] 2bi ;
249 M: ppc.32 %max [ 0 CMPW ] [ swap 0 ISEL ] 2bi ;
250 M: ppc.64 %max [ 0 CMPD ] [ swap 0 ISEL ] 2bi ;
253 M: ppc.32 %log2 [ CNTLZW ] [ drop dup NEG ] [ drop dup 31 ADDI ] 2tri ;
254 M: ppc.64 %log2 [ CNTLZD ] [ drop dup NEG ] [ drop dup 63 ADDI ] 2tri ;
255 M: ppc.32 %bit-count POPCNTW ;
256 M: ppc.64 %bit-count POPCNTD ;
258 M: ppc %copy ( dst src rep -- )
259 2over eq? [ 3drop ] [
261 { tagged-rep [ MR ] }
263 { float-rep [ FMR ] }
264 { double-rep [ FMR ] }
265 { vector-rep [ dup VOR ] }
266 { scalar-rep [ dup VOR ] }
270 :: overflow-template ( label dst src1 src2 cc insn -- )
273 dst src2 src1 insn call
275 { cc-o [ 0 label BSO ] }
276 { cc/o [ 0 label BNS ] }
279 M: ppc %fixnum-add ( label dst src1 src2 cc -- )
280 [ ADDO. ] overflow-template ;
282 M: ppc %fixnum-sub ( label dst src1 src2 cc -- )
283 [ SUBFO. ] overflow-template ;
285 M: ppc.32 %fixnum-mul ( label dst src1 src2 cc -- )
286 [ MULLWO. ] overflow-template ;
287 M: ppc.64 %fixnum-mul ( label dst src1 src2 cc -- )
288 [ MULLDO. ] overflow-template ;
290 M: ppc %add-float FADD ;
291 M: ppc %sub-float FSUB ;
292 M: ppc %mul-float FMUL ;
293 M: ppc %div-float FDIV ;
295 M: ppc %min-float ( dst src1 src2 -- )
296 2dup [ scratch-reg ] 2dip FSUB
297 [ scratch-reg ] 2dip FSEL ;
299 M: ppc %max-float ( dst src1 src2 -- )
300 2dup [ scratch-reg ] 2dip FSUB
301 [ scratch-reg ] 2dip FSEL ;
304 M: ppc %single>double-float FMR ;
305 M: ppc %double>single-float FRSP ;
307 M: ppc integer-float-needs-stack-frame? t ;
309 : scratch@ ( n -- offset )
310 reserved-area-size + ;
312 M:: ppc.32 %integer>float ( dst src -- )
313 ! Sign extend to a doubleword and store.
314 scratch-reg src 31 %sar-imm
315 scratch-reg 1 0 scratch@ STW
317 ! Load back doubleword into FPR and convert from integer.
321 M:: ppc.64 %integer>float ( dst src -- )
326 M:: ppc.32 %float>integer ( dst src -- )
327 fp-scratch-reg src FRIZ
328 fp-scratch-reg fp-scratch-reg FCTIWZ
329 fp-scratch-reg 1 0 scratch@ STFD
330 dst 1 4 scratch@ LWZ ;
332 M:: ppc.64 %float>integer ( dst src -- )
333 fp-scratch-reg src FRIZ
334 fp-scratch-reg fp-scratch-reg FCTID
335 fp-scratch-reg 1 0 scratch@ STFD
336 dst 1 0 scratch@ LD ;
338 ! Scratch registers by register class.
339 : scratch-regs ( -- regs )
342 { float-regs { 30 } }
345 ! Return values of this class go here
346 M: ppc return-regs ( -- regs )
348 { int-regs { 3 4 5 6 } }
349 { float-regs { 1 2 3 4 } }
352 ! Is this structure small enough to be returned in registers?
353 M: ppc return-struct-in-registers? ( c-type -- ? )
354 lookup-c-type return-in-registers?>> ;
356 ! If t, the struct return pointer is never passed in a param reg
357 M: ppc struct-return-on-stack? ( -- ? ) f ;
359 GENERIC: load-param ( reg src -- )
360 M: integer load-param ( reg src -- ) int-rep %copy ;
361 M: spill-slot load-param ( reg src -- ) [ 1 ] dip n>> spill@ %load-cell ;
363 GENERIC: store-param ( reg dst -- )
364 M: integer store-param ( reg dst -- ) swap int-rep %copy ;
365 M: spill-slot store-param ( reg dst -- ) [ 1 ] dip n>> spill@ %store-cell ;
367 M:: ppc %unbox ( dst src func rep -- )
373 M:: ppc %unbox-long-long ( dst1 dst2 src func -- )
380 M:: ppc %local-allot ( dst size align offset -- )
381 dst 1 offset local-allot-offset reserved-area-size + ADDI ;
383 : param-reg ( n rep -- reg )
384 reg-class-of cdecl param-regs at nth ;
386 M:: ppc %box ( dst src func rep gc-map -- )
389 func f gc-map %c-invoke
392 M:: ppc %box-long-long ( dst src1 src2 func gc-map -- )
396 func f gc-map %c-invoke
399 M:: ppc %save-context ( temp1 temp2 -- )
401 1 temp1 "callstack-top" context offset-of %store-cell
402 ds-reg temp1 "datastack" context offset-of %store-cell
403 rs-reg temp1 "retainstack" context offset-of %store-cell ;
405 M:: ppc %c-invoke ( name dll gc-map -- )
406 11 0 %load-cell-imm name dll %load-cell-imm-rc rel-dlsym
408 2 0 %load-cell-imm name dll %load-cell-imm-rc rel-dlsym-toc
414 : return-reg ( rep -- reg )
415 reg-class-of return-regs at first ;
417 : scratch-reg-class ( rep -- reg )
418 reg-class-of scratch-regs at first ;
420 :: store-stack-param ( vreg rep n -- )
421 rep scratch-reg-class rep vreg %reload
422 rep scratch-reg-class n param@ rep {
423 { int-rep [ [ 1 ] dip %store-cell ] }
424 { tagged-rep [ [ 1 ] dip %store-cell ] }
425 { float-rep [ [ 1 ] dip STFS ] }
426 { double-rep [ [ 1 ] dip STFD ] }
427 { vector-rep [ scratch-reg swap LI 1 scratch-reg STVX ] }
428 { scalar-rep [ scratch-reg swap LI 1 scratch-reg STVX ] }
431 :: store-reg-param ( vreg rep reg -- )
432 reg rep vreg %reload ;
434 : discard-reg-param ( rep reg -- )
437 :: load-reg-param ( vreg rep reg -- )
438 reg rep vreg %spill ;
440 :: load-stack-param ( vreg rep n -- )
441 rep scratch-reg-class n param@ rep {
442 { int-rep [ [ frame-reg ] dip %load-cell ] }
443 { tagged-rep [ [ frame-reg ] dip %load-cell ] }
444 { float-rep [ [ frame-reg ] dip LFS ] }
445 { double-rep [ [ frame-reg ] dip LFD ] }
446 { vector-rep [ scratch-reg swap LI frame-reg scratch-reg LVX ] }
447 { scalar-rep [ scratch-reg swap LI frame-reg scratch-reg LVX ] }
449 rep scratch-reg-class rep vreg %spill ;
451 :: emit-alien-insn ( varargs? reg-inputs stack-inputs
452 reg-outputs dead-outputs
455 stack-inputs [ first3 store-stack-param ] each
456 reg-inputs [ first3 store-reg-param ] each
458 reg-outputs [ first3 load-reg-param ] each
459 dead-outputs [ first2 discard-reg-param ] each
462 M: ppc %alien-invoke ( varargs? reg-inputs stack-inputs
463 reg-outputs dead-outputs
465 symbols dll gc-map -- )
466 '[ _ _ _ %c-invoke ] emit-alien-insn ;
468 M:: ppc %alien-indirect ( src
469 varargs? reg-inputs stack-inputs
470 reg-outputs dead-outputs
473 reg-inputs stack-inputs reg-outputs dead-outputs cleanup stack-size [
476 2 11 1 cells %load-cell
477 11 11 0 cells %load-cell
486 M: ppc %alien-assembly ( varargs? reg-inputs stack-inputs
487 reg-outputs dead-outputs
490 '[ _ call( -- ) ] emit-alien-insn ;
492 M: ppc %callback-inputs ( reg-outputs stack-outputs -- )
493 [ [ first3 load-reg-param ] each ]
494 [ [ first3 load-stack-param ] each ] bi*
497 "begin_callback" f f %c-invoke ;
499 M: ppc %callback-outputs ( reg-inputs -- )
501 "end_callback" f f %c-invoke
502 [ first3 store-reg-param ] each ;
504 M: ppc stack-cleanup ( stack-size return abi -- n )
507 M: ppc fused-unboxing? f ;
509 M: ppc %alien-global ( register symbol dll -- )
510 [ 0 %load-cell-imm ] 2dip %load-cell-imm-rc rel-dlsym ;
512 M: ppc %vm-field ( dst field -- ) [ vm-reg ] dip %load-cell ;
513 M: ppc %set-vm-field ( src field -- ) [ vm-reg ] dip %store-cell ;
515 M: ppc %unbox-alien ( dst src -- )
516 scratch-reg alien-offset LI scratch-reg %load-cell-x ;
518 ! Convert a c-ptr object to a raw C pointer.
521 ! else if ((src & tag_mask) == ALIEN_TYPE)
522 ! dst = ((alien*)src)->address;
523 ! else // Assume (src & tag_mask) == BYTE_ARRAY_TYPE
524 ! dst = ((byte_array*)src) + 1;
525 M:: ppc %unbox-any-c-ptr ( dst src -- )
529 0 src \ f type-number %compare-cell-imm
532 ! Is the object an alien?
533 dst src tag-mask get ANDI.
534 ! Assume unboxing a byte-array.
535 0 dst alien type-number %compare-cell-imm
536 dst src byte-array-offset ADDI
540 scratch-reg alien-offset LI
541 dst src scratch-reg %load-cell-x
544 ! Be very careful with this. It cannot be used as an immediate
545 ! offset to a load or store.
546 : alien@ ( n -- n' ) cells alien type-number - ;
548 ! Convert a raw C pointer to a c-ptr object.
552 ! dst = allot_alien(NULL);
553 ! dst->base = F_TYPE;
554 ! dst->expired = F_TYPE;
555 ! dst->displacement = src;
556 ! dst->address = src;
558 M:: ppc %box-alien ( dst src temp -- )
562 dst \ f type-number LI
563 0 src 0 %compare-cell-imm
566 ! Allocate and initialize an alien object.
567 dst 5 cells alien temp %allot
568 temp \ f type-number LI
569 scratch-reg dst %clear-tag-bits
570 temp scratch-reg 1 cells %store-cell
571 temp scratch-reg 2 cells %store-cell
572 src scratch-reg 3 cells %store-cell
573 src scratch-reg 4 cells %store-cell
575 f-label resolve-label ;
578 ! dst->displacement = displacement;
579 ! dst->displacement = displacement;
580 :: box-displaced-alien/f ( dst displacement base -- )
581 scratch-reg dst %clear-tag-bits
582 base scratch-reg 1 cells %store-cell
583 displacement scratch-reg 3 cells %store-cell
584 displacement scratch-reg 4 cells %store-cell ;
586 ! dst->base = base->base;
587 ! dst->displacement = base->displacement + displacement;
588 ! dst->address = base->address + displacement;
589 :: box-displaced-alien/alien ( dst displacement base temp -- )
590 ! Set new alien's base to base.base
591 scratch-reg 1 alien@ LI
592 temp base scratch-reg %load-cell-x
593 temp dst scratch-reg %store-cell-x
595 ! Compute displacement
596 scratch-reg 3 alien@ LI
597 temp base scratch-reg %load-cell-x
598 temp temp displacement ADD
599 temp dst scratch-reg %store-cell-x
602 scratch-reg 4 alien@ LI
603 temp base scratch-reg %load-cell-x
604 temp temp displacement ADD
605 temp dst scratch-reg %store-cell-x ;
608 ! dst->displacement = displacement
609 ! dst->address = base + sizeof(byte_array) + displacement
610 :: box-displaced-alien/byte-array ( dst displacement base temp -- )
611 scratch-reg dst %clear-tag-bits
612 base scratch-reg 1 cells %store-cell
613 displacement scratch-reg 3 cells %store-cell
614 temp base byte-array-offset ADDI
615 temp temp displacement ADD
616 temp scratch-reg 4 cells %store-cell ;
618 ! if (base == F_TYPE)
619 ! box_displaced_alien_f(dst, displacement, base);
620 ! else if ((base & tag_mask) == ALIEN_TYPE)
621 ! box_displaced_alien_alien(dst, displacement, base, temp);
623 ! box_displaced_alien_byte_array(dst, displacement, base, temp);
624 :: box-displaced-alien/dynamic ( dst displacement base temp end -- )
629 0 base \ f type-number %compare-cell-imm
631 dst displacement base box-displaced-alien/f
636 temp base tag-mask get ANDI.
637 0 temp alien type-number %compare-cell-imm
639 dst displacement base temp box-displaced-alien/alien
642 ! Assume base is a byte array.
643 not-alien resolve-label
644 dst displacement base temp box-displaced-alien/byte-array ;
646 ! if (displacement == 0)
649 ! dst = allot_alien(NULL);
650 ! dst->expired = F_TYPE;
651 ! if (is_subclass(base_class, F_TYPE))
652 ! box_displaced_alien_f(dst, displacement, base);
653 ! else if (is_subclass(base_class, ALIEN_TYPE))
654 ! box_displaced_alien_alien(dst, displacement, base, temp);
655 ! else if (is_subclass(base_class, BYTE_ARRAY_TYPE))
656 ! box_displaced_alien_byte_array(dst, displacement, base, temp);
658 ! box_displaced_alien_dynamic(dst, displacement, base, temp);
660 M:: ppc %box-displaced-alien ( dst displacement base temp base-class -- )
663 ! If displacement is zero, return the base.
665 0 displacement 0 %compare-cell-imm
668 ! Displacement is non-zero, we're going to be allocating a new
670 dst 5 cells alien temp %allot
673 temp \ f type-number %load-immediate
674 scratch-reg 2 alien@ LI
675 temp dst scratch-reg %store-cell-x
677 dst displacement base temp
679 { [ base-class \ f class<= ] [ drop box-displaced-alien/f ] }
680 { [ base-class \ alien class<= ] [ box-displaced-alien/alien ] }
681 { [ base-class \ byte-array class<= ] [ box-displaced-alien/byte-array ] }
682 [ end box-displaced-alien/dynamic ]
687 M:: ppc.32 %convert-integer ( dst src c-type -- )
689 { c:char [ dst src 24 CLRLWI dst dst EXTSB ] }
690 { c:uchar [ dst src 24 CLRLWI ] }
691 { c:short [ dst src 16 CLRLWI dst dst EXTSH ] }
692 { c:ushort [ dst src 16 CLRLWI ] }
697 M:: ppc.64 %convert-integer ( dst src c-type -- )
699 { c:char [ dst src 56 CLRLDI dst dst EXTSB ] }
700 { c:uchar [ dst src 56 CLRLDI ] }
701 { c:short [ dst src 48 CLRLDI dst dst EXTSH ] }
702 { c:ushort [ dst src 48 CLRLDI ] }
703 { c:int [ dst src 32 CLRLDI dst dst EXTSW ] }
704 { c:uint [ dst src 32 CLRLDI ] }
709 M: ppc.32 %load-memory-imm ( dst base offset rep c-type -- )
713 { c:char [ [ dup ] 2dip LBZ dup EXTSB ] }
723 { float-rep [ LFS ] }
724 { double-rep [ LFD ] }
728 M: ppc.64 %load-memory-imm ( dst base offset rep c-type -- )
732 { c:char [ [ dup ] 2dip LBZ dup EXTSB ] }
738 { c:longlong [ [ scratch-reg ] dip LI scratch-reg LDX ] }
739 { c:ulonglong [ [ scratch-reg ] dip LI scratch-reg LDX ] }
743 { int-rep [ [ scratch-reg ] dip LI scratch-reg LDX ] }
744 { float-rep [ [ scratch-reg ] dip LI scratch-reg LFSX ] }
745 { double-rep [ [ scratch-reg ] dip LI scratch-reg LFDX ] }
750 M: ppc.32 %load-memory ( dst base displacement scale offset rep c-type -- )
751 [ [ 0 assert= ] bi@ ] 2dip
755 { c:char [ [ LBZX ] [ drop dup EXTSB ] 2bi ] }
758 { c:ushort [ LHZX ] }
765 { float-rep [ LFSX ] }
766 { double-rep [ LFDX ] }
770 M: ppc.64 %load-memory ( dst base displacement scale offset rep c-type -- )
771 [ [ 0 assert= ] bi@ ] 2dip
775 { c:char [ [ LBZX ] [ drop dup EXTSB ] 2bi ] }
778 { c:ushort [ LHZX ] }
781 { c:longlong [ LDX ] }
782 { c:ulonglong [ LDX ] }
787 { float-rep [ LFSX ] }
788 { double-rep [ LFDX ] }
793 M: ppc.32 %store-memory-imm ( src base offset rep c-type -- )
806 { float-rep [ STFS ] }
807 { double-rep [ STFD ] }
811 M: ppc.64 %store-memory-imm ( src base offset rep c-type -- )
820 { c:longlong [ [ scratch-reg ] dip LI scratch-reg STDX ] }
821 { c:ulonglong [ [ scratch-reg ] dip LI scratch-reg STDX ] }
825 { int-rep [ [ scratch-reg ] dip LI scratch-reg STDX ] }
826 { float-rep [ [ scratch-reg ] dip LI scratch-reg STFSX ] }
827 { double-rep [ [ scratch-reg ] dip LI scratch-reg STFDX ] }
831 M: ppc.32 %store-memory ( src base displacement scale offset rep c-type -- )
832 [ [ 0 assert= ] bi@ ] 2dip
838 { c:ushort [ STHX ] }
845 { float-rep [ STFSX ] }
846 { double-rep [ STFDX ] }
850 M: ppc.64 %store-memory ( src base displacement scale offset rep c-type -- )
851 [ [ 0 assert= ] bi@ ] 2dip
857 { c:ushort [ STHX ] }
860 { c:longlong [ STDX ] }
861 { c:ulonglong [ STDX ] }
866 { float-rep [ STFSX ] }
867 { double-rep [ STFDX ] }
871 M:: ppc %allot ( dst size class nursery-ptr -- )
872 ! dst = vm->nursery.here;
873 nursery-ptr vm-reg "nursery" vm offset-of ADDI
874 dst nursery-ptr 0 %load-cell
875 ! vm->nursery.here += align(size, data_alignment);
876 scratch-reg dst size data-alignment get align ADDI
877 scratch-reg nursery-ptr 0 %store-cell
878 ! ((object*) dst)->header = type_number << 2;
879 scratch-reg class type-number tag-header LI
880 scratch-reg dst 0 %store-cell
882 dst dst class type-number ORI ;
884 :: (%write-barrier) ( temp1 temp2 -- )
885 scratch-reg card-mark LI
886 ! *(char *)(cards_offset + ((cell)slot_ptr >> card_bits))
888 temp1 temp1 card-bits %shr-imm
889 temp2 0 %load-cell-imm %load-cell-imm-rc rel-cards-offset
890 scratch-reg temp1 temp2 STBX
891 ! *(char *)(decks_offset + ((cell)slot_ptr >> deck_bits))
893 temp1 temp1 deck-bits card-bits - %shr-imm
894 temp2 0 %load-cell-imm %load-cell-imm-rc rel-decks-offset
895 scratch-reg temp1 temp2 STBX ;
897 M:: ppc %write-barrier ( src slot scale tag temp1 temp2 -- )
898 scale 0 assert= tag 0 assert=
900 temp1 temp2 (%write-barrier) ;
902 M:: ppc %write-barrier-imm ( src slot tag temp1 temp2 -- )
903 temp1 src slot tag slot-offset ADDI
904 temp1 temp2 (%write-barrier) ;
906 M:: ppc %check-nursery-branch ( label size cc temp1 temp2 -- )
907 ! if (vm->nursery.here + size >= vm->nursery.end) ...
908 temp1 vm-reg "nursery" vm offset-of %load-cell
909 temp2 vm-reg "nursery" vm offset-of 2 cells + %load-cell
910 temp1 temp1 size ADDI
911 0 temp1 temp2 %compare-cell
913 { cc<= [ 0 label BLE ] }
914 { cc/<= [ 0 label BGT ] }
917 M: ppc %call-gc ( gc-map -- )
918 \ minor-gc %call gc-map-here ;
920 M:: ppc %prologue ( stack-size -- )
922 0 1 lr-save %store-cell
923 11 0 %load-cell-imm %load-cell-imm-rc rel-this
924 11 1 2 cells neg %store-cell
926 11 1 1 cells neg %store-cell
927 1 1 stack-size neg %store-cell-update ;
929 ! At the end of each word that calls a subroutine, we store
930 ! the previous link register value in r0 by popping it off
931 ! the stack, set the link register to the contents of r0,
932 ! and jump to the link register.
933 M:: ppc %epilogue ( stack-size -- )
935 0 1 lr-save %load-cell
938 :: (%boolean) ( dst temp branch1 branch2 -- )
940 dst \ f type-number %load-immediate
941 0 "end" get branch1 execute( n addr -- )
942 branch2 [ 0 "end" get branch2 execute( n addr -- ) ] when
943 dst \ t %load-reference
944 "end" get resolve-label ; inline
946 :: %boolean ( dst cc temp -- )
947 cc negate-cc order-cc {
948 { cc< [ dst temp \ BLT f (%boolean) ] }
949 { cc<= [ dst temp \ BLE f (%boolean) ] }
950 { cc> [ dst temp \ BGT f (%boolean) ] }
951 { cc>= [ dst temp \ BGE f (%boolean) ] }
952 { cc= [ dst temp \ BEQ f (%boolean) ] }
953 { cc/= [ dst temp \ BNE f (%boolean) ] }
956 : (%compare) ( src1 src2 -- ) [ 0 ] 2dip %compare-cell ; inline
958 : (%compare-integer-imm) ( src1 src2 -- )
959 [ 0 ] 2dip %compare-cell-imm ; inline
961 : (%compare-imm) ( src1 src2 -- )
962 [ tag-fixnum ] [ \ f type-number ] if* (%compare-integer-imm) ; inline
964 : (%compare-float-unordered) ( src1 src2 -- )
965 [ 0 ] 2dip FCMPU ; inline
967 : (%compare-float-ordered) ( src1 src2 -- )
968 [ 0 ] 2dip FCMPO ; inline
970 :: (%compare-float) ( src1 src2 cc compare -- branch1 branch2 )
972 { cc< [ src1 src2 \ compare execute( a b -- ) \ BLT f ] }
973 { cc<= [ src1 src2 \ compare execute( a b -- ) \ BLT \ BEQ ] }
974 { cc> [ src1 src2 \ compare execute( a b -- ) \ BGT f ] }
975 { cc>= [ src1 src2 \ compare execute( a b -- ) \ BGT \ BEQ ] }
976 { cc= [ src1 src2 \ compare execute( a b -- ) \ BEQ f ] }
977 { cc<> [ src1 src2 \ compare execute( a b -- ) \ BLT \ BGT ] }
978 { cc<>= [ src1 src2 \ compare execute( a b -- ) \ BNS f ] }
979 { cc/< [ src1 src2 \ compare execute( a b -- ) \ BGE f ] }
980 { cc/<= [ src1 src2 \ compare execute( a b -- ) \ BGT \ BSO ] }
981 { cc/> [ src1 src2 \ compare execute( a b -- ) \ BLE f ] }
982 { cc/>= [ src1 src2 \ compare execute( a b -- ) \ BLT \ BSO ] }
983 { cc/= [ src1 src2 \ compare execute( a b -- ) \ BNE f ] }
984 { cc/<> [ src1 src2 \ compare execute( a b -- ) \ BEQ \ BSO ] }
985 { cc/<>= [ src1 src2 \ compare execute( a b -- ) \ BSO f ] }
988 M: ppc %compare [ (%compare) ] 2dip %boolean ;
990 M: ppc %compare-imm [ (%compare-imm) ] 2dip %boolean ;
992 M: ppc %compare-integer-imm [ (%compare-integer-imm) ] 2dip %boolean ;
994 M:: ppc %compare-float-ordered ( dst src1 src2 cc temp -- )
995 src1 src2 cc negate-cc \ (%compare-float-ordered) (%compare-float) :> ( branch1 branch2 )
996 dst temp branch1 branch2 (%boolean) ;
998 M:: ppc %compare-float-unordered ( dst src1 src2 cc temp -- )
999 src1 src2 cc negate-cc \ (%compare-float-unordered) (%compare-float) :> ( branch1 branch2 )
1000 dst temp branch1 branch2 (%boolean) ;
1002 :: %branch ( label cc -- )
1004 { cc< [ 0 label BLT ] }
1005 { cc<= [ 0 label BLE ] }
1006 { cc> [ 0 label BGT ] }
1007 { cc>= [ 0 label BGE ] }
1008 { cc= [ 0 label BEQ ] }
1009 { cc/= [ 0 label BNE ] }
1012 M:: ppc %compare-branch ( label src1 src2 cc -- )
1013 src1 src2 (%compare)
1016 M:: ppc %compare-imm-branch ( label src1 src2 cc -- )
1017 src1 src2 (%compare-imm)
1020 M:: ppc %compare-integer-imm-branch ( label src1 src2 cc -- )
1021 src1 src2 (%compare-integer-imm)
1024 :: (%branch) ( label branch1 branch2 -- )
1025 0 label branch1 execute( cr label -- )
1026 branch2 [ 0 label branch2 execute( cr label -- ) ] when ; inline
1028 M:: ppc %compare-float-ordered-branch ( label src1 src2 cc -- )
1029 src1 src2 cc \ (%compare-float-ordered) (%compare-float) :> ( branch1 branch2 )
1030 label branch1 branch2 (%branch) ;
1032 M:: ppc %compare-float-unordered-branch ( label src1 src2 cc -- )
1033 src1 src2 cc \ (%compare-float-unordered) (%compare-float) :> ( branch1 branch2 )
1034 label branch1 branch2 (%branch) ;
1036 M: ppc %spill ( src rep dst -- )
1038 { int-rep [ [ 1 ] dip %store-cell ] }
1039 { tagged-rep [ [ 1 ] dip %store-cell ] }
1040 { float-rep [ [ 1 ] dip STFS ] }
1041 { double-rep [ [ 1 ] dip STFD ] }
1042 { vector-rep [ scratch-reg swap LI 1 scratch-reg STVX ] }
1043 { scalar-rep [ scratch-reg swap LI 1 scratch-reg STVX ] }
1046 M: ppc %reload ( dst rep src -- )
1048 { int-rep [ [ 1 ] dip %load-cell ] }
1049 { tagged-rep [ [ 1 ] dip %load-cell ] }
1050 { float-rep [ [ 1 ] dip LFS ] }
1051 { double-rep [ [ 1 ] dip LFD ] }
1052 { vector-rep [ scratch-reg swap LI 1 scratch-reg LVX ] }
1053 { scalar-rep [ scratch-reg swap LI 1 scratch-reg LVX ] }
1056 M: ppc immediate-arithmetic? ( n -- ? ) -32768 32767 between? ;
1057 M: ppc immediate-bitwise? ( n -- ? ) 0 65535 between? ;
1058 M: ppc immediate-store? ( n -- ? ) immediate-comparand? ;
1060 M: ppc enable-cpu-features ( -- )
1061 enable-float-intrinsics ;
1067 { [ cpu ppc.32? ] [ "cpu.ppc.32.linux" require ] }
1068 { [ cpu ppc.64? ] [ "cpu.ppc.64.linux" require ] }
1075 complex-double lookup-c-type t >>return-in-registers? drop