factor/basis/cpu/ppc/ppc.factor

1085 lines
33 KiB
Factor

! Copyright (C) 2011 Erik Charlebois
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs sequences kernel combinators
classes.algebra byte-arrays make math math.order math.ranges
system namespaces locals layouts words alien alien.accessors
alien.c-types alien.complex alien.data alien.libraries
literals cpu.architecture cpu.ppc.assembler
compiler.cfg.registers compiler.cfg.instructions
compiler.cfg.comparisons compiler.codegen.fixup
compiler.cfg.intrinsics compiler.cfg.stack-frame
compiler.cfg.build-stack-frame compiler.units compiler.constants
compiler.codegen vm memory fry io prettyprint ;
QUALIFIED-WITH: alien.c-types c
FROM: cpu.ppc.assembler => B ;
FROM: layouts => cell ;
FROM: math => float ;
IN: cpu.ppc
! PowerPC register assignments:
! r0: reserved for function prolog/epilogues
! r1: call stack register
! r2: toc register / system reserved
! r3-r12: integer vregs
! r13: reserved by OS
! r14: data stack
! r15: retain stack
! r16: VM pointer
! r17-r29: integer vregs
! r30: integer scratch
! r31: frame register
! f0-f29: float vregs
! f30: float scratch
! f31: ?
HOOK: lr-save os ( -- n )
HOOK: has-toc os ( -- ? )
HOOK: reserved-area-size os ( -- n )
HOOK: allows-null-dereference os ( -- ? )
M: label B ( label -- ) [ 0 B ] dip rc-relative-ppc-3-pc label-fixup ;
M: label BL ( label -- ) [ 0 BL ] dip rc-relative-ppc-3-pc label-fixup ;
M: label BC ( bo bi label -- ) [ 0 BC ] dip rc-relative-ppc-2-pc label-fixup ;
CONSTANT: scratch-reg 30
CONSTANT: fp-scratch-reg 30
CONSTANT: ds-reg 14
CONSTANT: rs-reg 15
CONSTANT: vm-reg 16
enable-float-intrinsics
M: ppc vector-regs ( -- reg-class )
float-regs ;
M: ppc machine-registers ( -- assoc )
{
{ int-regs $[ 3 12 [a,b] 17 29 [a,b] append ] }
{ float-regs $[ 0 29 [a,b] ] }
} ;
M: ppc frame-reg ( -- reg ) 31 ;
M: ppc.32 vm-stack-space ( -- n ) 16 ;
M: ppc.64 vm-stack-space ( -- n ) 32 ;
M: ppc complex-addressing? ( -- ? ) f ;
! PW1-PW8 parameter save slots
: param-save-size ( -- n ) 8 cells ; foldable
! here be spill slots
! xt, size
: factor-area-size ( -- n ) 2 cells ; foldable
: spill@ ( n -- offset )
spill-offset reserved-area-size + param-save-size + ;
: param@ ( n -- offset )
reserved-area-size + ;
M: ppc gc-root-offset ( spill-slot -- n )
n>> spill@ cell /i ;
: LOAD32 ( r n -- )
[ -16 shift HEX: ffff bitand LIS ]
[ [ dup ] dip HEX: ffff bitand ORI ] 2bi ;
: LOAD64 ( r n -- )
[ dup ] dip {
[ nip -48 shift HEX: ffff bitand LIS ]
[ -32 shift HEX: ffff bitand ORI ]
[ drop 32 SLDI ]
[ -16 shift HEX: ffff bitand ORIS ]
[ HEX: ffff bitand ORI ]
} 3cleave ;
HOOK: %clear-tag-bits cpu ( dst src -- )
M: ppc.32 %clear-tag-bits tag-bits get CLRRWI ;
M: ppc.64 %clear-tag-bits tag-bits get CLRRDI ;
HOOK: %store-cell cpu ( dst src offset -- )
M: ppc.32 %store-cell STW ;
M: ppc.64 %store-cell STD ;
HOOK: %store-cell-x cpu ( dst src offset -- )
M: ppc.32 %store-cell-x STWX ;
M: ppc.64 %store-cell-x STDX ;
HOOK: %store-cell-update cpu ( dst src offset -- )
M: ppc.32 %store-cell-update STWU ;
M: ppc.64 %store-cell-update STDU ;
HOOK: %load-cell cpu ( dst src offset -- )
M: ppc.32 %load-cell LWZ ;
M: ppc.64 %load-cell LD ;
HOOK: %trap-null cpu ( src -- )
M: ppc.32 %trap-null
allows-null-dereference [ 0 TWEQI ] [ drop ] if ;
M: ppc.64 %trap-null
allows-null-dereference [ 0 TDEQI ] [ drop ] if ;
HOOK: %load-cell-x cpu ( dst src offset -- )
M: ppc.32 %load-cell-x LWZX ;
M: ppc.64 %load-cell-x LDX ;
HOOK: %load-cell-imm cpu ( dst imm -- )
M: ppc.32 %load-cell-imm LOAD32 ;
M: ppc.64 %load-cell-imm LOAD64 ;
HOOK: %compare-cell cpu ( cr lhs rhs -- )
M: ppc.32 %compare-cell CMPW ;
M: ppc.64 %compare-cell CMPD ;
HOOK: %compare-cell-imm cpu ( cr lhs imm -- )
M: ppc.32 %compare-cell-imm CMPWI ;
M: ppc.64 %compare-cell-imm CMPDI ;
HOOK: %load-cell-imm-rc cpu ( -- rel-class )
M: ppc.32 %load-cell-imm-rc rc-absolute-ppc-2/2 ;
M: ppc.64 %load-cell-imm-rc rc-absolute-ppc-2/2/2/2 ;
M: ppc.32 %load-immediate ( reg val -- )
dup HEX: -8000 HEX: 7fff between? [ LI ] [ LOAD32 ] if ;
M: ppc.64 %load-immediate ( reg val -- )
dup HEX: -8000 HEX: 7fff between? [ LI ] [ LOAD64 ] if ;
M: ppc %load-reference ( reg obj -- )
[ [ 0 %load-cell-imm ] [ %load-cell-imm-rc rel-literal ] bi* ]
[ \ f type-number LI ]
if* ;
M:: ppc %load-float ( dst val -- )
scratch-reg 0 %load-cell-imm val %load-cell-imm-rc rel-binary-literal
dst scratch-reg 0 LFS ;
M:: ppc %load-double ( dst val -- )
scratch-reg 0 %load-cell-imm val %load-cell-imm-rc rel-binary-literal
dst scratch-reg 0 LFD ;
M:: ppc %load-vector ( dst val rep -- )
scratch-reg 0 %load-cell-imm val %load-cell-imm-rc rel-binary-literal
dst 0 scratch-reg LVX ;
GENERIC: loc-reg ( loc -- reg )
M: ds-loc loc-reg drop ds-reg ;
M: rs-loc loc-reg drop rs-reg ;
! Load value at stack location loc into vreg.
M: ppc %peek ( vreg loc -- )
[ loc-reg ] [ n>> cells neg ] bi %load-cell ;
! Replace value at stack location loc with value in vreg.
M: ppc %replace ( vreg loc -- )
[ loc-reg ] [ n>> cells neg ] bi %store-cell ;
! Replace value at stack location with an immediate value.
M:: ppc %replace-imm ( src loc -- )
loc loc-reg :> reg
loc n>> cells neg :> offset
src {
{ [ dup not ] [
drop scratch-reg \ f type-number LI ] }
{ [ dup fixnum? ] [
[ scratch-reg ] dip tag-fixnum LI ] }
[ scratch-reg 0 LI rc-absolute rel-literal ]
} cond
scratch-reg reg offset %store-cell ;
! Increment data stack pointer by n cells.
M: ppc %inc-d ( n -- )
[ ds-reg ds-reg ] dip cells ADDI ;
! Increment retain stack pointer by n cells.
M: ppc %inc-r ( n -- )
[ rs-reg rs-reg ] dip cells ADDI ;
M: ppc stack-frame-size ( stack-frame -- i )
(stack-frame-size)
reserved-area-size +
param-save-size +
factor-area-size +
16 align ;
M: ppc %call ( word -- )
0 BL rc-relative-ppc-3-pc rel-word-pic ;
: instrs ( n -- b ) 4 * ; inline
M: ppc %jump ( word -- )
6 0 %load-cell-imm 1 instrs %load-cell-imm-rc rel-here
0 B rc-relative-ppc-3-pc rel-word-pic-tail ;
M: ppc %dispatch ( src temp -- )
[ nip 0 %load-cell-imm 3 instrs %load-cell-imm-rc rel-here ]
[ swap dupd %load-cell-x ]
[ nip MTCTR ] 2tri BCTR ;
M: ppc %slot ( dst obj slot scale tag -- )
[ 0 assert= ] bi@ %load-cell-x ;
M: ppc %slot-imm ( dst obj slot tag -- )
slot-offset scratch-reg swap LI
scratch-reg %load-cell-x ;
M: ppc %set-slot ( src obj slot scale tag -- )
[ 0 assert= ] bi@ %store-cell-x ;
M: ppc %set-slot-imm ( src obj slot tag -- )
slot-offset [ scratch-reg ] dip LI scratch-reg %store-cell-x ;
M: ppc %jump-label B ;
M: ppc %return BLR ;
M: ppc %add ADD ;
M: ppc %add-imm ADDI ;
M: ppc %sub SUB ;
M: ppc %sub-imm SUBI ;
M: ppc.32 %mul MULLW ;
M: ppc.64 %mul MULLD ;
M: ppc %mul-imm MULLI ;
M: ppc %and AND ;
M: ppc %and-imm ANDI. ;
M: ppc %or OR ;
M: ppc %or-imm ORI ;
M: ppc %xor XOR ;
M: ppc %xor-imm XORI ;
M: ppc.32 %shl SLW ;
M: ppc.64 %shl SLD ;
M: ppc.32 %shl-imm SLWI ;
M: ppc.64 %shl-imm SLDI ;
M: ppc.32 %shr SRW ;
M: ppc.64 %shr SRD ;
M: ppc.32 %shr-imm SRWI ;
M: ppc.64 %shr-imm SRDI ;
M: ppc.32 %sar SRAW ;
M: ppc.64 %sar SRAD ;
M: ppc.32 %sar-imm SRAWI ;
M: ppc.64 %sar-imm SRADI ;
M: ppc.32 %min [ 0 CMPW ] [ 0 ISEL ] 2bi ;
M: ppc.64 %min [ 0 CMPD ] [ 0 ISEL ] 2bi ;
M: ppc.32 %max [ 0 CMPW ] [ swap 0 ISEL ] 2bi ;
M: ppc.64 %max [ 0 CMPD ] [ swap 0 ISEL ] 2bi ;
M: ppc %not NOT ;
M: ppc %neg NEG ;
M: ppc.32 %log2 [ CNTLZW ] [ drop dup NEG ] [ drop dup 31 ADDI ] 2tri ;
M: ppc.64 %log2 [ CNTLZD ] [ drop dup NEG ] [ drop dup 63 ADDI ] 2tri ;
M: ppc.32 %bit-count POPCNTW ;
M: ppc.64 %bit-count POPCNTD ;
M: ppc %copy ( dst src rep -- )
2over eq? [ 3drop ] [
{
{ tagged-rep [ MR ] }
{ int-rep [ MR ] }
{ float-rep [ FMR ] }
{ double-rep [ FMR ] }
{ vector-rep [ dup VOR ] }
{ scalar-rep [ dup VOR ] }
} case
] if ;
:: overflow-template ( label dst src1 src2 cc insn -- )
scratch-reg 0 LI
scratch-reg MTXER
dst src2 src1 insn call
cc {
{ cc-o [ 0 label BSO ] }
{ cc/o [ 0 label BNS ] }
} case ; inline
M: ppc %fixnum-add ( label dst src1 src2 cc -- )
[ ADDO. ] overflow-template ;
M: ppc %fixnum-sub ( label dst src1 src2 cc -- )
[ SUBFO. ] overflow-template ;
M: ppc.32 %fixnum-mul ( label dst src1 src2 cc -- )
[ MULLWO. ] overflow-template ;
M: ppc.64 %fixnum-mul ( label dst src1 src2 cc -- )
[ MULLDO. ] overflow-template ;
M: ppc %add-float FADD ;
M: ppc %sub-float FSUB ;
M: ppc %mul-float FMUL ;
M: ppc %div-float FDIV ;
M: ppc %min-float ( dst src1 src2 -- )
2dup [ scratch-reg ] 2dip FSUB
[ scratch-reg ] 2dip FSEL ;
M: ppc %max-float ( dst src1 src2 -- )
2dup [ scratch-reg ] 2dip FSUB
[ scratch-reg ] 2dip FSEL ;
M: ppc %sqrt FSQRT ;
M: ppc %single>double-float FMR ;
M: ppc %double>single-float FRSP ;
M: ppc integer-float-needs-stack-frame? t ;
: scratch@ ( n -- offset )
reserved-area-size + ;
M:: ppc.32 %integer>float ( dst src -- )
! Sign extend to a doubleword and store.
scratch-reg src 31 %sar-imm
scratch-reg 1 0 scratch@ STW
src 1 4 scratch@ STW
! Load back doubleword into FPR and convert from integer.
dst 1 0 scratch@ LFD
dst dst FCFID ;
M:: ppc.64 %integer>float ( dst src -- )
src 1 0 scratch@ STD
dst 1 0 scratch@ LFD
dst dst FCFID ;
M:: ppc.32 %float>integer ( dst src -- )
fp-scratch-reg src FRIZ
fp-scratch-reg fp-scratch-reg FCTIWZ
fp-scratch-reg 1 0 scratch@ STFD
dst 1 4 scratch@ LWZ ;
M:: ppc.64 %float>integer ( dst src -- )
fp-scratch-reg src FRIZ
fp-scratch-reg fp-scratch-reg FCTID
fp-scratch-reg 1 0 scratch@ STFD
dst 1 0 scratch@ LD ;
! Scratch registers by register class.
: scratch-regs ( -- regs )
{
{ int-regs { 30 } }
{ float-regs { 30 } }
} ;
! Return values of this class go here
M: ppc return-regs ( -- regs )
{
{ int-regs { 3 4 5 6 } }
{ float-regs { 1 2 3 4 } }
} ;
! Is this structure small enough to be returned in registers?
M: ppc return-struct-in-registers? ( c-type -- ? )
c-type return-in-registers?>> ;
! If t, floats are never passed in param regs
M: ppc float-on-stack? ( -- ? ) f ;
! If t, the struct return pointer is never passed in a param reg
M: ppc struct-return-on-stack? ( -- ? ) f ;
GENERIC: load-param ( reg src -- )
M: integer load-param ( reg src -- ) int-rep %copy ;
M: spill-slot load-param ( reg src -- ) [ 1 ] dip n>> spill@ %load-cell ;
GENERIC: store-param ( reg dst -- )
M: integer store-param ( reg dst -- ) swap int-rep %copy ;
M: spill-slot store-param ( reg dst -- ) [ 1 ] dip n>> spill@ %store-cell ;
M:: ppc %unbox ( dst src func rep -- )
3 src load-param
4 vm-reg MR
func f f %c-invoke
3 dst store-param ;
M:: ppc %unbox-long-long ( dst1 dst2 src func -- )
3 src load-param
4 vm-reg MR
func f f %c-invoke
3 dst1 store-param
4 dst2 store-param ;
M:: ppc %local-allot ( dst size align offset -- )
dst 1 offset local-allot-offset reserved-area-size + ADDI ;
: param-reg ( n rep -- reg )
reg-class-of cdecl param-regs at nth ;
M:: ppc %box ( dst src func rep gc-map -- )
3 src load-param
4 vm-reg MR
func f gc-map %c-invoke
3 dst store-param ;
M:: ppc %box-long-long ( dst src1 src2 func gc-map -- )
3 src1 load-param
4 src2 load-param
5 vm-reg MR
func f gc-map %c-invoke
3 dst store-param ;
M:: ppc %save-context ( temp1 temp2 -- )
temp1 %context
1 temp1 "callstack-top" context-field-offset %store-cell
ds-reg temp1 "datastack" context-field-offset %store-cell
rs-reg temp1 "retainstack" context-field-offset %store-cell ;
M:: ppc %c-invoke ( name dll gc-map -- )
11 0 %load-cell-imm name dll %load-cell-imm-rc rel-dlsym
has-toc [
2 0 %load-cell-imm name dll %load-cell-imm-rc rel-dlsym-toc
] when
11 MTCTR
BCTRL
gc-map gc-map-here ;
: return-reg ( rep -- reg )
reg-class-of return-regs at first ;
: scratch-reg-class ( rep -- reg )
reg-class-of scratch-regs at first ;
:: store-stack-param ( vreg rep n -- )
rep scratch-reg-class rep vreg %reload
rep scratch-reg-class n param@ rep {
{ int-rep [ [ 1 ] dip %store-cell ] }
{ tagged-rep [ [ 1 ] dip %store-cell ] }
{ float-rep [ [ 1 ] dip STFS ] }
{ double-rep [ [ 1 ] dip STFD ] }
{ vector-rep [ scratch-reg swap LI 1 scratch-reg STVX ] }
{ scalar-rep [ scratch-reg swap LI 1 scratch-reg STVX ] }
} case ;
:: store-reg-param ( vreg rep reg -- )
reg rep vreg %reload ;
: discard-reg-param ( rep reg -- )
2drop ;
:: load-reg-param ( vreg rep reg -- )
reg rep vreg %spill ;
:: load-stack-param ( vreg rep n -- )
rep scratch-reg-class n param@ rep {
{ int-rep [ [ frame-reg ] dip %load-cell ] }
{ tagged-rep [ [ frame-reg ] dip %load-cell ] }
{ float-rep [ [ frame-reg ] dip LFS ] }
{ double-rep [ [ frame-reg ] dip LFD ] }
{ vector-rep [ scratch-reg swap LI frame-reg scratch-reg LVX ] }
{ scalar-rep [ scratch-reg swap LI frame-reg scratch-reg LVX ] }
} case
rep scratch-reg-class rep vreg %spill ;
:: emit-alien-insn ( reg-inputs stack-inputs reg-outputs dead-outputs cleanup stack-size quot -- )
stack-inputs [ first3 store-stack-param ] each
reg-inputs [ first3 store-reg-param ] each
quot call
reg-outputs [ first3 load-reg-param ] each
dead-outputs [ first2 discard-reg-param ] each
; inline
M: ppc %alien-invoke ( reg-inputs stack-inputs reg-outputs
dead-outputs cleanup stack-size
symbols dll gc-map -- )
'[ _ _ _ %c-invoke ] emit-alien-insn ;
M:: ppc %alien-indirect ( src reg-inputs stack-inputs
reg-outputs dead-outputs cleanup
stack-size gc-map -- )
reg-inputs stack-inputs reg-outputs dead-outputs cleanup stack-size [
has-toc [
11 src load-param
2 11 1 cells %load-cell
11 11 0 cells %load-cell
] [
11 src load-param
] if
11 MTCTR
BCTRL
gc-map gc-map-here
] emit-alien-insn ;
M: ppc %alien-assembly ( reg-inputs stack-inputs reg-outputs
dead-outputs cleanup stack-size quot
gc-map -- )
'[ _ _ gc-map set call( -- ) ] emit-alien-insn ;
M: ppc %callback-inputs ( reg-outputs stack-outputs -- )
[ [ first3 load-reg-param ] each ]
[ [ first3 load-stack-param ] each ] bi*
3 vm-reg MR
4 0 LI
"begin_callback" f f %c-invoke ;
M: ppc %callback-outputs ( reg-inputs -- )
3 vm-reg MR
"end_callback" f f %c-invoke
[ first3 store-reg-param ] each ;
M: ppc stack-cleanup ( stack-size return abi -- n )
3drop 0 ;
M: ppc fused-unboxing? f ;
M: ppc %alien-global ( register symbol dll -- )
[ 0 %load-cell-imm ] 2dip %load-cell-imm-rc rel-dlsym ;
M: ppc %vm-field ( dst field -- ) [ vm-reg ] dip %load-cell ;
M: ppc %set-vm-field ( src field -- ) [ vm-reg ] dip %store-cell ;
M: ppc %unbox-alien ( dst src -- )
scratch-reg alien-offset LI scratch-reg %load-cell-x ;
! Convert a c-ptr object to a raw C pointer.
! if (src == F_TYPE)
! dst = NULL;
! else if ((src & tag_mask) == ALIEN_TYPE)
! dst = ((alien*)src)->address;
! else // Assume (src & tag_mask) == BYTE_ARRAY_TYPE
! dst = ((byte_array*)src) + 1;
M:: ppc %unbox-any-c-ptr ( dst src -- )
[
"end" define-label
! Is the object f?
dst 0 LI
0 src \ f type-number %compare-cell-imm
0 "end" get BEQ
! Is the object an alien?
dst src tag-mask get ANDI.
! Assume unboxing a byte-array.
0 dst alien type-number %compare-cell-imm
dst src byte-array-offset ADDI
0 "end" get BNE
! Unbox the alien.
scratch-reg alien-offset LI
dst src scratch-reg %load-cell-x
"end" resolve-label
] with-scope ;
! Be very careful with this. It cannot be used as an immediate
! offset to a load or store.
: alien@ ( n -- n' ) cells alien type-number - ;
! Convert a raw C pointer to a c-ptr object.
! if (src == NULL)
! dst = F_TYPE;
! else {
! dst = allot_alien(NULL);
! dst->base = F_TYPE;
! dst->expired = F_TYPE;
! dst->displacement = src;
! dst->address = src;
! }
M:: ppc %box-alien ( dst src temp -- )
[
"f" define-label
! Is the object f?
dst \ f type-number LI
0 src 0 %compare-cell-imm
0 "f" get BEQ
! Allocate and initialize an alien object.
dst 5 cells alien temp %allot
temp \ f type-number LI
scratch-reg dst %clear-tag-bits
temp scratch-reg 1 cells %store-cell
temp scratch-reg 2 cells %store-cell
src scratch-reg 3 cells %store-cell
src scratch-reg 4 cells %store-cell
"f" resolve-label
] with-scope ;
! dst->base = base;
! dst->displacement = displacement;
! dst->displacement = displacement;
:: box-displaced-alien/f ( dst displacement base -- )
scratch-reg dst %clear-tag-bits
base scratch-reg 1 cells %store-cell
displacement scratch-reg 3 cells %store-cell
displacement scratch-reg 4 cells %store-cell ;
! dst->base = base->base;
! dst->displacement = base->displacement + displacement;
! dst->address = base->address + displacement;
:: box-displaced-alien/alien ( dst displacement base temp -- )
! Set new alien's base to base.base
scratch-reg 1 alien@ LI
temp base scratch-reg %load-cell-x
temp dst scratch-reg %store-cell-x
! Compute displacement
scratch-reg 3 alien@ LI
temp base scratch-reg %load-cell-x
temp temp displacement ADD
temp dst scratch-reg %store-cell-x
! Compute address
scratch-reg 4 alien@ LI
temp base scratch-reg %load-cell-x
temp temp displacement ADD
temp dst scratch-reg %store-cell-x ;
! dst->base = base;
! dst->displacement = displacement
! dst->address = base + sizeof(byte_array) + displacement
:: box-displaced-alien/byte-array ( dst displacement base temp -- )
scratch-reg dst %clear-tag-bits
base scratch-reg 1 cells %store-cell
displacement scratch-reg 3 cells %store-cell
temp base byte-array-offset ADDI
temp temp displacement ADD
temp scratch-reg 4 cells %store-cell ;
! if (base == F_TYPE)
! box_displaced_alien_f(dst, displacement, base);
! else if ((base & tag_mask) == ALIEN_TYPE)
! box_displaced_alien_alien(dst, displacement, base, temp);
! else
! box_displaced_alien_byte_array(dst, displacement, base, temp);
:: box-displaced-alien/dynamic ( dst displacement base temp -- )
"not-f" define-label
"not-alien" define-label
! Is base f?
0 base \ f type-number %compare-cell-imm
0 "not-f" get BNE
dst displacement base box-displaced-alien/f
"end" get B
! Is base an alien?
"not-f" resolve-label
temp base tag-mask get ANDI.
0 temp alien type-number %compare-cell-imm
0 "not-alien" get BNE
dst displacement base temp box-displaced-alien/alien
"end" get B
! Assume base is a byte array.
"not-alien" resolve-label
dst displacement base temp box-displaced-alien/byte-array ;
! if (displacement == 0)
! dst = base;
! else {
! dst = allot_alien(NULL);
! dst->expired = F_TYPE;
! if (is_subclass(base_class, F_TYPE))
! box_displaced_alien_f(dst, displacement, base);
! else if (is_subclass(base_class, ALIEN_TYPE))
! box_displaced_alien_alien(dst, displacement, base, temp);
! else if (is_subclass(base_class, BYTE_ARRAY_TYPE))
! box_displaced_alien_byte_array(dst, displacement, base, temp);
! else
! box_displaced_alien_dynamic(dst, displacement, base, temp);
! }
M:: ppc %box-displaced-alien ( dst displacement base temp base-class -- )
[
"end" define-label
! If displacement is zero, return the base.
dst base MR
0 displacement 0 %compare-cell-imm
0 "end" get BEQ
! Displacement is non-zero, we're going to be allocating a new
! object
dst 5 cells alien temp %allot
! Set expired to f
temp \ f type-number %load-immediate
scratch-reg 2 alien@ LI
temp dst scratch-reg %store-cell-x
dst displacement base temp
{
{ [ base-class \ f class<= ] [ drop box-displaced-alien/f ] }
{ [ base-class \ alien class<= ] [ box-displaced-alien/alien ] }
{ [ base-class \ byte-array class<= ] [ box-displaced-alien/byte-array ] }
[ box-displaced-alien/dynamic ]
} cond
"end" resolve-label
] with-scope ;
M:: ppc.32 %convert-integer ( dst src c-type -- )
c-type {
{ c:char [ dst src 24 CLRLWI dst dst EXTSB ] }
{ c:uchar [ dst src 24 CLRLWI ] }
{ c:short [ dst src 16 CLRLWI dst dst EXTSH ] }
{ c:ushort [ dst src 16 CLRLWI ] }
{ c:int [ ] }
{ c:uint [ ] }
} case ;
M:: ppc.64 %convert-integer ( dst src c-type -- )
c-type {
{ c:char [ dst src 56 CLRLDI dst dst EXTSB ] }
{ c:uchar [ dst src 56 CLRLDI ] }
{ c:short [ dst src 48 CLRLDI dst dst EXTSH ] }
{ c:ushort [ dst src 48 CLRLDI ] }
{ c:int [ dst src 32 CLRLDI dst dst EXTSW ] }
{ c:uint [ dst src 32 CLRLDI ] }
{ c:longlong [ ] }
{ c:ulonglong [ ] }
} case ;
M: ppc.32 %load-memory-imm ( dst base offset rep c-type -- )
[
pick %trap-null
{
{ c:char [ [ dup ] 2dip LBZ dup EXTSB ] }
{ c:uchar [ LBZ ] }
{ c:short [ LHA ] }
{ c:ushort [ LHZ ] }
{ c:int [ LWZ ] }
{ c:uint [ LWZ ] }
} case
] [
{
{ int-rep [ LWZ ] }
{ float-rep [ LFS ] }
{ double-rep [ LFD ] }
} case
] ?if ;
M: ppc.64 %load-memory-imm ( dst base offset rep c-type -- )
[
pick %trap-null
{
{ c:char [ [ dup ] 2dip LBZ dup EXTSB ] }
{ c:uchar [ LBZ ] }
{ c:short [ LHA ] }
{ c:ushort [ LHZ ] }
{ c:int [ LWZ ] }
{ c:uint [ LWZ ] }
{ c:longlong [ [ scratch-reg ] dip LI scratch-reg LDX ] }
{ c:ulonglong [ [ scratch-reg ] dip LI scratch-reg LDX ] }
} case
] [
{
{ int-rep [ [ scratch-reg ] dip LI scratch-reg LDX ] }
{ float-rep [ [ scratch-reg ] dip LI scratch-reg LFSX ] }
{ double-rep [ [ scratch-reg ] dip LI scratch-reg LFDX ] }
} case
] ?if ;
M: ppc.32 %load-memory ( dst base displacement scale offset rep c-type -- )
[ [ 0 assert= ] bi@ ] 2dip
[
pick %trap-null
{
{ c:char [ [ LBZX ] [ drop dup EXTSB ] 2bi ] }
{ c:uchar [ LBZX ] }
{ c:short [ LHAX ] }
{ c:ushort [ LHZX ] }
{ c:int [ LWZX ] }
{ c:uint [ LWZX ] }
} case
] [
{
{ int-rep [ LWZX ] }
{ float-rep [ LFSX ] }
{ double-rep [ LFDX ] }
} case
] ?if ;
M: ppc.64 %load-memory ( dst base displacement scale offset rep c-type -- )
[ [ 0 assert= ] bi@ ] 2dip
[
pick %trap-null
{
{ c:char [ [ LBZX ] [ drop dup EXTSB ] 2bi ] }
{ c:uchar [ LBZX ] }
{ c:short [ LHAX ] }
{ c:ushort [ LHZX ] }
{ c:int [ LWZX ] }
{ c:uint [ LWZX ] }
{ c:longlong [ LDX ] }
{ c:ulonglong [ LDX ] }
} case
] [
{
{ int-rep [ LDX ] }
{ float-rep [ LFSX ] }
{ double-rep [ LFDX ] }
} case
] ?if ;
M: ppc.32 %store-memory-imm ( src base offset rep c-type -- )
[
{
{ c:char [ STB ] }
{ c:uchar [ STB ] }
{ c:short [ STH ] }
{ c:ushort [ STH ] }
{ c:int [ STW ] }
{ c:uint [ STW ] }
} case
] [
{
{ int-rep [ STW ] }
{ float-rep [ STFS ] }
{ double-rep [ STFD ] }
} case
] ?if ;
M: ppc.64 %store-memory-imm ( src base offset rep c-type -- )
[
{
{ c:char [ STB ] }
{ c:uchar [ STB ] }
{ c:short [ STH ] }
{ c:ushort [ STH ] }
{ c:int [ STW ] }
{ c:uint [ STW ] }
{ c:longlong [ [ scratch-reg ] dip LI scratch-reg STDX ] }
{ c:ulonglong [ [ scratch-reg ] dip LI scratch-reg STDX ] }
} case
] [
{
{ int-rep [ [ scratch-reg ] dip LI scratch-reg STDX ] }
{ float-rep [ [ scratch-reg ] dip LI scratch-reg STFSX ] }
{ double-rep [ [ scratch-reg ] dip LI scratch-reg STFDX ] }
} case
] ?if ;
M: ppc.32 %store-memory ( src base displacement scale offset rep c-type -- )
[ [ 0 assert= ] bi@ ] 2dip
[
{
{ c:char [ STBX ] }
{ c:uchar [ STBX ] }
{ c:short [ STHX ] }
{ c:ushort [ STHX ] }
{ c:int [ STWX ] }
{ c:uint [ STWX ] }
} case
] [
{
{ int-rep [ STWX ] }
{ float-rep [ STFSX ] }
{ double-rep [ STFDX ] }
} case
] ?if ;
M: ppc.64 %store-memory ( src base displacement scale offset rep c-type -- )
[ [ 0 assert= ] bi@ ] 2dip
[
{
{ c:char [ STBX ] }
{ c:uchar [ STBX ] }
{ c:short [ STHX ] }
{ c:ushort [ STHX ] }
{ c:int [ STWX ] }
{ c:uint [ STWX ] }
{ c:longlong [ STDX ] }
{ c:ulonglong [ STDX ] }
} case
] [
{
{ int-rep [ STDX ] }
{ float-rep [ STFSX ] }
{ double-rep [ STFDX ] }
} case
] ?if ;
M:: ppc %allot ( dst size class nursery-ptr -- )
! dst = vm->nursery.here;
nursery-ptr vm-reg "nursery" vm-field-offset ADDI
dst nursery-ptr 0 %load-cell
! vm->nursery.here += align(size, data_alignment);
scratch-reg dst size data-alignment get align ADDI
scratch-reg nursery-ptr 0 %store-cell
! ((object*) dst)->header = type_number << 2;
scratch-reg class type-number tag-header LI
scratch-reg dst 0 %store-cell
! dst |= type_number
dst dst class type-number ORI ;
:: (%write-barrier) ( temp1 temp2 -- )
scratch-reg card-mark LI
! *(char *)(cards_offset + ((cell)slot_ptr >> card_bits))
! = card_mark_mask;
temp1 temp1 card-bits %shr-imm
temp2 0 %load-cell-imm %load-cell-imm-rc rel-cards-offset
scratch-reg temp1 temp2 STBX
! *(char *)(decks_offset + ((cell)slot_ptr >> deck_bits))
! = card_mark_mask;
temp1 temp1 deck-bits card-bits - %shr-imm
temp2 0 %load-cell-imm %load-cell-imm-rc rel-decks-offset
scratch-reg temp1 temp2 STBX ;
M:: ppc %write-barrier ( src slot scale tag temp1 temp2 -- )
scale 0 assert= tag 0 assert=
temp1 src slot ADD
temp1 temp2 (%write-barrier) ;
M:: ppc %write-barrier-imm ( src slot tag temp1 temp2 -- )
temp1 src slot tag slot-offset ADDI
temp1 temp2 (%write-barrier) ;
M:: ppc %check-nursery-branch ( label size cc temp1 temp2 -- )
! if (vm->nursery.here + size >= vm->nursery.end) ...
temp1 vm-reg "nursery" vm-field-offset %load-cell
temp2 vm-reg "nursery" vm-field-offset 2 cells + %load-cell
temp1 temp1 size ADDI
0 temp1 temp2 %compare-cell
cc {
{ cc<= [ 0 label BLE ] }
{ cc/<= [ 0 label BGT ] }
} case ;
M: ppc %call-gc ( gc-map -- )
\ minor-gc %call gc-map-here ;
M:: ppc %prologue ( stack-size -- )
0 MFLR
0 1 lr-save %store-cell
11 0 %load-cell-imm %load-cell-imm-rc rel-this
11 1 2 cells neg %store-cell
11 stack-size LI
11 1 1 cells neg %store-cell
1 1 stack-size neg %store-cell-update ;
! At the end of each word that calls a subroutine, we store
! the previous link register value in r0 by popping it off
! the stack, set the link register to the contents of r0,
! and jump to the link register.
M:: ppc %epilogue ( stack-size -- )
1 1 stack-size ADDI
0 1 lr-save %load-cell
0 MTLR ;
:: (%boolean) ( dst temp branch1 branch2 -- )
"end" define-label
dst \ f type-number %load-immediate
0 "end" get branch1 execute( n addr -- )
branch2 [ 0 "end" get branch2 execute( n addr -- ) ] when
dst \ t %load-reference
"end" get resolve-label ; inline
:: %boolean ( dst cc temp -- )
cc negate-cc order-cc {
{ cc< [ dst temp \ BLT f (%boolean) ] }
{ cc<= [ dst temp \ BLE f (%boolean) ] }
{ cc> [ dst temp \ BGT f (%boolean) ] }
{ cc>= [ dst temp \ BGE f (%boolean) ] }
{ cc= [ dst temp \ BEQ f (%boolean) ] }
{ cc/= [ dst temp \ BNE f (%boolean) ] }
} case ;
: (%compare) ( src1 src2 -- ) [ 0 ] 2dip %compare-cell ; inline
: (%compare-integer-imm) ( src1 src2 -- )
[ 0 ] 2dip %compare-cell-imm ; inline
: (%compare-imm) ( src1 src2 -- )
[ tag-fixnum ] [ \ f type-number ] if* (%compare-integer-imm) ; inline
: (%compare-float-unordered) ( src1 src2 -- )
[ 0 ] 2dip FCMPU ; inline
: (%compare-float-ordered) ( src1 src2 -- )
[ 0 ] 2dip FCMPO ; inline
:: (%compare-float) ( src1 src2 cc compare -- branch1 branch2 )
cc {
{ cc< [ src1 src2 \ compare execute( a b -- ) \ BLT f ] }
{ cc<= [ src1 src2 \ compare execute( a b -- ) \ BLT \ BEQ ] }
{ cc> [ src1 src2 \ compare execute( a b -- ) \ BGT f ] }
{ cc>= [ src1 src2 \ compare execute( a b -- ) \ BGT \ BEQ ] }
{ cc= [ src1 src2 \ compare execute( a b -- ) \ BEQ f ] }
{ cc<> [ src1 src2 \ compare execute( a b -- ) \ BLT \ BGT ] }
{ cc<>= [ src1 src2 \ compare execute( a b -- ) \ BNS f ] }
{ cc/< [ src1 src2 \ compare execute( a b -- ) \ BGE f ] }
{ cc/<= [ src1 src2 \ compare execute( a b -- ) \ BGT \ BSO ] }
{ cc/> [ src1 src2 \ compare execute( a b -- ) \ BLE f ] }
{ cc/>= [ src1 src2 \ compare execute( a b -- ) \ BLT \ BSO ] }
{ cc/= [ src1 src2 \ compare execute( a b -- ) \ BNE f ] }
{ cc/<> [ src1 src2 \ compare execute( a b -- ) \ BEQ \ BSO ] }
{ cc/<>= [ src1 src2 \ compare execute( a b -- ) \ BSO f ] }
} case ; inline
M: ppc %compare [ (%compare) ] 2dip %boolean ;
M: ppc %compare-imm [ (%compare-imm) ] 2dip %boolean ;
M: ppc %compare-integer-imm [ (%compare-integer-imm) ] 2dip %boolean ;
M:: ppc %compare-float-ordered ( dst src1 src2 cc temp -- )
src1 src2 cc negate-cc \ (%compare-float-ordered) (%compare-float) :> ( branch1 branch2 )
dst temp branch1 branch2 (%boolean) ;
M:: ppc %compare-float-unordered ( dst src1 src2 cc temp -- )
src1 src2 cc negate-cc \ (%compare-float-unordered) (%compare-float) :> ( branch1 branch2 )
dst temp branch1 branch2 (%boolean) ;
:: %branch ( label cc -- )
cc order-cc {
{ cc< [ 0 label BLT ] }
{ cc<= [ 0 label BLE ] }
{ cc> [ 0 label BGT ] }
{ cc>= [ 0 label BGE ] }
{ cc= [ 0 label BEQ ] }
{ cc/= [ 0 label BNE ] }
} case ;
M:: ppc %compare-branch ( label src1 src2 cc -- )
src1 src2 (%compare)
label cc %branch ;
M:: ppc %compare-imm-branch ( label src1 src2 cc -- )
src1 src2 (%compare-imm)
label cc %branch ;
M:: ppc %compare-integer-imm-branch ( label src1 src2 cc -- )
src1 src2 (%compare-integer-imm)
label cc %branch ;
:: (%branch) ( label branch1 branch2 -- )
0 label branch1 execute( cr label -- )
branch2 [ 0 label branch2 execute( cr label -- ) ] when ; inline
M:: ppc %compare-float-ordered-branch ( label src1 src2 cc -- )
src1 src2 cc \ (%compare-float-ordered) (%compare-float) :> ( branch1 branch2 )
label branch1 branch2 (%branch) ;
M:: ppc %compare-float-unordered-branch ( label src1 src2 cc -- )
src1 src2 cc \ (%compare-float-unordered) (%compare-float) :> ( branch1 branch2 )
label branch1 branch2 (%branch) ;
M: ppc %spill ( src rep dst -- )
n>> spill@ swap {
{ int-rep [ [ 1 ] dip %store-cell ] }
{ tagged-rep [ [ 1 ] dip %store-cell ] }
{ float-rep [ [ 1 ] dip STFS ] }
{ double-rep [ [ 1 ] dip STFD ] }
{ vector-rep [ scratch-reg swap LI 1 scratch-reg STVX ] }
{ scalar-rep [ scratch-reg swap LI 1 scratch-reg STVX ] }
} case ;
M: ppc %reload ( dst rep src -- )
n>> spill@ swap {
{ int-rep [ [ 1 ] dip %load-cell ] }
{ tagged-rep [ [ 1 ] dip %load-cell ] }
{ float-rep [ [ 1 ] dip LFS ] }
{ double-rep [ [ 1 ] dip LFD ] }
{ vector-rep [ scratch-reg swap LI 1 scratch-reg LVX ] }
{ scalar-rep [ scratch-reg swap LI 1 scratch-reg LVX ] }
} case ;
M: ppc %loop-entry ( -- ) ;
M: ppc immediate-arithmetic? ( n -- ? ) -32768 32767 between? ;
M: ppc immediate-bitwise? ( n -- ? ) 0 65535 between? ;
M: ppc immediate-store? ( n -- ? ) immediate-comparand? ;
USE: vocabs.loader
{
{ [ os linux? ] [
{
{ [ cpu ppc.32? ] [ "cpu.ppc.32.linux" require ] }
{ [ cpu ppc.64? ] [ "cpu.ppc.64.linux" require ] }
[ ]
} cond
] }
[ ]
} cond
complex-double c-type t >>return-in-registers? drop