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 ;
+M: label B [ 0 B ] dip rc-relative-ppc-3-pc label-fixup ;
+M: label BL [ 0 BL ] dip rc-relative-ppc-3-pc label-fixup ;
+M: label BC [ 0 BC ] dip rc-relative-ppc-2-pc label-fixup ;
CONSTANT: scratch-reg 30
CONSTANT: fp-scratch-reg 30
CONSTANT: rs-reg 15
CONSTANT: vm-reg 16
-M: ppc machine-registers ( -- assoc )
+M: ppc machine-registers
{
{ 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 ;
+M: ppc frame-reg 31 ;
+M: ppc.32 vm-stack-space 16 ;
+M: ppc.64 vm-stack-space 32 ;
+M: ppc complex-addressing? f ;
! PW1-PW8 parameter save slots
: param-save-size ( -- n ) 8 cells ; foldable
: param@ ( n -- offset )
reserved-area-size + ;
-M: ppc gc-root-offset ( spill-slot -- n )
+M: ppc gc-root-offset
n>> spill@ cell /i ;
: LOAD32 ( r n -- )
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 -- )
+M: ppc.32 %load-immediate
dup -0x8000 0x7fff between? [ LI ] [ LOAD32 ] if ;
-M: ppc.64 %load-immediate ( reg val -- )
+M: ppc.64 %load-immediate
dup -0x8000 0x7fff between? [ LI ] [ LOAD64 ] if ;
-M: ppc %load-reference ( reg obj -- )
+M: ppc %load-reference
[ [ 0 %load-cell-imm ] [ %load-cell-imm-rc rel-literal ] bi* ]
[ \ f type-number LI ]
if* ;
M: rs-loc loc-reg drop rs-reg ;
! Load value at stack location loc into vreg.
-M: ppc %peek ( vreg loc -- )
+M: ppc %peek
[ loc-reg ] [ n>> cells neg ] bi %load-cell ;
! Replace value at stack location loc with value in vreg.
-M: ppc %replace ( vreg loc -- )
+M: ppc %replace
[ loc-reg ] [ n>> cells neg ] bi %store-cell ;
! Replace value at stack location with an immediate value.
} cond
scratch-reg reg offset %store-cell ;
-M: ppc %clear ( loc -- )
+M: ppc %clear
297 swap %replace-imm ;
! Increment stack pointer by n cells.
-M: ppc %inc ( loc -- )
+M: ppc %inc
[ ds-loc? [ ds-reg ds-reg ] [ rs-reg rs-reg ] if ] [ n>> ] bi cells ADDI ;
-M: ppc stack-frame-size ( stack-frame -- i )
+M: ppc stack-frame-size
(stack-frame-size)
reserved-area-size +
param-save-size +
factor-area-size +
16 align ;
-M: ppc %call ( word -- )
+M: ppc %call
0 BL rc-relative-ppc-3-pc rel-word-pic ;
: instrs ( n -- b ) 4 * ; inline
-M: ppc %jump ( word -- )
+M: ppc %jump
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 -- )
+M: ppc %dispatch
[ 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 -- )
+M: ppc %slot
[ 0 assert= ] bi@ %load-cell-x ;
-M: ppc %slot-imm ( dst obj slot tag -- )
+M: ppc %slot-imm
slot-offset scratch-reg swap LI
scratch-reg %load-cell-x ;
-M: ppc %set-slot ( src obj slot scale tag -- )
+M: ppc %set-slot
[ 0 assert= ] bi@ %store-cell-x ;
-M: ppc %set-slot-imm ( src obj slot tag -- )
+M: ppc %set-slot-imm
slot-offset [ scratch-reg ] dip LI scratch-reg %store-cell-x ;
M: ppc %jump-label B ;
M: ppc.32 %bit-count POPCNTW ;
M: ppc.64 %bit-count POPCNTD ;
-M: ppc %copy ( dst src rep -- )
+M: ppc %copy
2over eq? [ 3drop ] [
{
{ tagged-rep [ MR ] }
{ cc/o [ 0 label BNS ] }
} case ; inline
-M: ppc %fixnum-add ( label dst src1 src2 cc -- )
+M: ppc %fixnum-add
[ ADDO. ] overflow-template ;
-M: ppc %fixnum-sub ( label dst src1 src2 cc -- )
+M: ppc %fixnum-sub
[ SUBFO. ] overflow-template ;
-M: ppc.32 %fixnum-mul ( label dst src1 src2 cc -- )
+M: ppc.32 %fixnum-mul
[ MULLWO. ] overflow-template ;
-M: ppc.64 %fixnum-mul ( label dst src1 src2 cc -- )
+M: ppc.64 %fixnum-mul
[ MULLDO. ] overflow-template ;
M: ppc %add-float FADD ;
M: ppc %mul-float FMUL ;
M: ppc %div-float FDIV ;
-M: ppc %min-float ( dst src1 src2 -- )
+M: ppc %min-float
2dup [ scratch-reg ] 2dip FSUB
[ scratch-reg ] 2dip FSEL ;
-M: ppc %max-float ( dst src1 src2 -- )
+M: ppc %max-float
2dup [ scratch-reg ] 2dip FSUB
[ scratch-reg ] 2dip FSEL ;
} ;
! Return values of this class go here
-M: ppc return-regs ( -- regs )
+M: ppc return-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 -- ? )
+M: ppc return-struct-in-registers?
lookup-c-type return-in-registers?>> ;
! If t, the struct return pointer is never passed in a param reg
-M: ppc struct-return-on-stack? ( -- ? ) f ;
+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 ;
+M: integer load-param int-rep %copy ;
+M: spill-slot load-param [ 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: integer store-param swap int-rep %copy ;
+M: spill-slot store-param [ 1 ] dip n>> spill@ %store-cell ;
M:: ppc %unbox ( dst src func rep -- )
3 src load-param
dead-outputs [ first2 discard-reg-param ] each
; inline
-M: ppc %alien-invoke ( varargs? reg-inputs stack-inputs
- reg-outputs dead-outputs
- cleanup stack-size
- symbols dll gc-map -- )
+M: ppc %alien-invoke
'[ _ _ _ %c-invoke ] emit-alien-insn ;
M:: ppc %alien-indirect ( src
gc-map gc-map-here
] emit-alien-insn ;
-M: ppc %alien-assembly ( varargs? reg-inputs stack-inputs
- reg-outputs dead-outputs
- cleanup stack-size
- quot -- )
+M: ppc %alien-assembly
'[ _ call( -- ) ] emit-alien-insn ;
-M: ppc %callback-inputs ( reg-outputs stack-outputs -- )
+M: ppc %callback-inputs
[ [ 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 -- )
+M: ppc %callback-outputs
3 vm-reg MR
"end_callback" f f %c-invoke
[ first3 store-reg-param ] each ;
-M: ppc stack-cleanup ( stack-size return abi -- n )
+M: ppc stack-cleanup
3drop 0 ;
M: ppc fused-unboxing? f ;
-M: ppc %alien-global ( register symbol dll -- )
+M: ppc %alien-global
[ 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 %vm-field [ vm-reg ] dip %load-cell ;
+M: ppc %set-vm-field [ vm-reg ] dip %store-cell ;
-M: ppc %unbox-alien ( dst src -- )
+M: ppc %unbox-alien
scratch-reg alien-offset LI scratch-reg %load-cell-x ;
! Convert a c-ptr object to a raw C pointer.
{ c:ulonglong [ ] }
} case ;
-M: ppc.32 %load-memory-imm ( dst base offset rep c-type -- )
+M: ppc.32 %load-memory-imm
[
pick %trap-null
{
} case
] ?if ;
-M: ppc.64 %load-memory-imm ( dst base offset rep c-type -- )
+M: ppc.64 %load-memory-imm
[
pick %trap-null
{
] ?if ;
-M: ppc.32 %load-memory ( dst base displacement scale offset rep c-type -- )
+M: ppc.32 %load-memory
[ [ 0 assert= ] bi@ ] 2dip
[
pick %trap-null
} case
] ?if ;
-M: ppc.64 %load-memory ( dst base displacement scale offset rep c-type -- )
+M: ppc.64 %load-memory
[ [ 0 assert= ] bi@ ] 2dip
[
pick %trap-null
] ?if ;
-M: ppc.32 %store-memory-imm ( src base offset rep c-type -- )
+M: ppc.32 %store-memory-imm
[
{
{ c:char [ STB ] }
} case
] ?if ;
-M: ppc.64 %store-memory-imm ( src base offset rep c-type -- )
+M: ppc.64 %store-memory-imm
[
{
{ c:char [ STB ] }
} case
] ?if ;
-M: ppc.32 %store-memory ( src base displacement scale offset rep c-type -- )
+M: ppc.32 %store-memory
[ [ 0 assert= ] bi@ ] 2dip
[
{
} case
] ?if ;
-M: ppc.64 %store-memory ( src base displacement scale offset rep c-type -- )
+M: ppc.64 %store-memory
[ [ 0 assert= ] bi@ ] 2dip
[
{
{ cc/<= [ 0 label BGT ] }
} case ;
-M: ppc %call-gc ( gc-map -- )
+M: ppc %call-gc
\ minor-gc %call gc-map-here ;
M:: ppc %prologue ( stack-size -- )
src1 src2 cc \ (%compare-float-unordered) (%compare-float) :> ( branch1 branch2 )
label branch1 branch2 (%branch) ;
-M: ppc %spill ( src rep dst -- )
+M: ppc %spill
n>> spill@ swap {
{ int-rep [ [ 1 ] dip %store-cell ] }
{ tagged-rep [ [ 1 ] dip %store-cell ] }
{ scalar-rep [ scratch-reg swap LI 1 scratch-reg STVX ] }
} case ;
-M: ppc %reload ( dst rep src -- )
+M: ppc %reload
n>> spill@ swap {
{ int-rep [ [ 1 ] dip %load-cell ] }
{ tagged-rep [ [ 1 ] dip %load-cell ] }
{ scalar-rep [ scratch-reg swap LI 1 scratch-reg LVX ] }
} case ;
-M: ppc immediate-arithmetic? ( n -- ? ) -32768 32767 between? ;
-M: ppc immediate-bitwise? ( n -- ? ) 0 65535 between? ;
-M: ppc immediate-store? ( n -- ? ) immediate-comparand? ;
+M: ppc immediate-arithmetic? -32768 32767 between? ;
+M: ppc immediate-bitwise? 0 65535 between? ;
+M: ppc immediate-store? immediate-comparand? ;
-M: ppc enable-cpu-features ( -- )
+M: ppc enable-cpu-features
enable-float-intrinsics ;
USE: vocabs
projects / factor.git / blobdiff