-! Copyright (C) 2005, 2010 Slava Pestov.
+! Copyright (C) 2011 Erik Charlebois
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors assocs sequences kernel combinators make math
-math.order math.ranges system namespaces locals layouts words
-alien alien.accessors alien.c-types alien.complex alien.data
+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
-cpu.ppc.assembler.backend 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 ;
+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:
-! r2-r12: integer vregs
-! r13: data stack
-! r14: retain stack
-! r15: VM pointer
-! r16-r29: integer vregs
+! 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: ?
-! Add some methods to the assembler that are useful to us
-M: label (B) [ 0 ] 2dip (B) rc-relative-ppc-3 label-fixup ;
-M: label BC [ 0 BC ] dip rc-relative-ppc-2 label-fixup ;
+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
-<<
-\ ##integer>float t frame-required? set-word-prop
-\ ##float>integer t frame-required? set-word-prop
->>
+M: ppc vector-regs ( -- reg-class )
+ float-regs ;
-M: ppc machine-registers
+M: ppc machine-registers ( -- assoc )
{
- { int-regs $[ 2 12 [a,b] 16 29 [a,b] append ] }
+ { int-regs $[ 3 12 [a,b] 17 29 [a,b] append ] }
{ float-regs $[ 0 29 [a,b] ] }
} ;
-CONSTANT: scratch-reg 30
-CONSTANT: fp-scratch-reg 30
-
-M: ppc %load-immediate ( reg n -- ) swap LOAD ;
+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 %load-reference ( reg obj -- )
- [ 0 swap LOAD32 ] [ rc-absolute-ppc-2/2 rel-literal ] bi* ;
+! 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
-M: ppc %alien-global ( register symbol dll -- )
- [ 0 swap LOAD32 ] 2dip rc-absolute-ppc-2/2 rel-dlsym ;
+: 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 0xffff bitand LIS ]
+ [ [ dup ] dip 0xffff bitand ORI ] 2bi ;
+
+: LOAD64 ( r n -- )
+ [ dup ] dip {
+ [ nip -48 shift 0xffff bitand LIS ]
+ [ -32 shift 0xffff bitand ORI ]
+ [ drop 32 SLDI ]
+ [ -16 shift 0xffff bitand ORIS ]
+ [ 0xffff 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 -0x8000 0x7fff between? [ LI ] [ LOAD32 ] if ;
+M: ppc.64 %load-immediate ( reg val -- )
+ dup -0x8000 0x7fff between? [ LI ] [ LOAD64 ] if ;
-CONSTANT: ds-reg 13
-CONSTANT: rs-reg 14
-CONSTANT: vm-reg 15
+M: ppc %load-reference ( reg obj -- )
+ [ [ 0 %load-cell-imm ] [ %load-cell-imm-rc rel-literal ] bi* ]
+ [ \ f type-number LI ]
+ if* ;
-: %load-vm-addr ( reg -- ) vm-reg MR ;
+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 %vm-field ( dst field -- ) [ vm-reg ] dip LWZ ;
+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 %set-vm-field ( src field -- ) [ vm-reg ] dip STW ;
+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 ;
-: loc>operand ( loc -- reg n )
- [ loc-reg ] [ n>> cells neg ] bi ; inline
-
-M: ppc %peek loc>operand LWZ ;
-M: ppc %replace loc>operand STW ;
-
-:: (%inc) ( n reg -- ) reg reg n cells ADDI ; inline
-
-M: ppc %inc-d ( n -- ) ds-reg (%inc) ;
-M: ppc %inc-r ( n -- ) rs-reg (%inc) ;
-
-HOOK: reserved-area-size os ( -- n )
-
-! The start of the stack frame contains the size of this frame
-! as well as the currently executing code block
-: factor-area-size ( -- n ) 2 cells ; foldable
-: next-save ( n -- i ) cell - ; foldable
-: xt-save ( n -- i ) 2 cells - ; foldable
-
-! Next, we have the spill area as well as the FFI parameter area.
-! It is safe for them to overlap, since basic blocks with FFI calls
-! will never spill -- indeed, basic blocks with FFI calls do not
-! use vregs at all, and the FFI call is a stack analysis sync point.
-! In the future this will change and the stack frame logic will
-! need to be untangled somewhat.
-
-: param@ ( n -- x ) reserved-area-size + ; inline
-
-: param-save-size ( -- n ) 8 cells ; foldable
-
-: local@ ( n -- x )
- reserved-area-size param-save-size + + ; inline
-
-: spill@ ( n -- offset )
- spill-offset local@ ;
-
-! Some FP intrinsics need a temporary scratch area in the stack
-! frame, 8 bytes in size. This is in the param-save area so it
-! does not overlap with spill slots.
-: scratch@ ( n -- offset )
- factor-area-size + ;
-
-! GC root area
-: gc-root@ ( n -- offset )
- gc-root-offset local@ ;
-
-! Finally we have the linkage area
-HOOK: lr-save os ( -- n )
+! 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)
- param-save-size +
reserved-area-size +
+ param-save-size +
factor-area-size +
- 4 cells align ;
+ 16 align ;
-M: ppc %call ( word -- ) 0 BL rc-relative-ppc-3 rel-word-pic ;
+M: ppc %call ( word -- )
+ 0 BL rc-relative-ppc-3-pc rel-word-pic ;
-M: ppc %jump ( word -- )
- 0 6 LOAD32 4 rc-absolute-ppc-2/2 rel-here
- 0 B rc-relative-ppc-3 rel-word-pic-tail ;
-
-M: ppc %jump-label ( label -- ) B ;
-M: ppc %return ( -- ) BLR ;
-
-M:: ppc %dispatch ( src temp -- )
- 0 temp LOAD32
- 3 cells rc-absolute-ppc-2/2 rel-here
- temp temp src LWZX
- temp MTCTR
- BCTR ;
+: instrs ( n -- b ) 4 * ; inline
-M: ppc %slot ( dst obj slot -- ) swapd LWZX ;
-M: ppc %slot-imm ( dst obj slot tag -- ) slot-offset LWZ ;
-M: ppc %set-slot ( src obj slot -- ) swapd STWX ;
-M: ppc %set-slot-imm ( src obj slot tag -- ) slot-offset STW ;
+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 %string-nth ( dst src index temp -- )
- [
- "end" define-label
- temp src index ADD
- dst temp string-offset LBZ
- 0 dst HEX: 80 CMPI
- "end" get BLT
- temp src string-aux-offset LWZ
- temp temp index ADD
- temp temp index ADD
- temp temp byte-array-offset LHZ
- temp temp 7 SLWI
- dst dst temp XOR
- "end" resolve-label
- ] with-scope ;
+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 ;
-M:: ppc %set-string-nth-fast ( ch obj index temp -- )
- temp obj index ADD
- ch temp string-offset STB ;
-
-M: ppc %add ADD ;
-M: ppc %add-imm ADDI ;
-M: ppc %sub swap SUBF ;
-M: ppc %sub-imm SUBI ;
-M: ppc %mul MULLW ;
-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 %shl SLW ;
-M: ppc %shl-imm swapd SLWI ;
-M: ppc %shr SRW ;
-M: ppc %shr-imm swapd SRWI ;
-M: ppc %sar SRAW ;
-M: ppc %sar-imm SRAWI ;
-M: ppc %not NOT ;
-M: ppc %neg NEG ;
-
-:: overflow-template ( label dst src1 src2 insn -- )
- 0 0 LI
- 0 MTXER
+:: overflow-template ( label dst src1 src2 cc insn -- )
+ scratch-reg 0 LI
+ scratch-reg MTXER
dst src2 src1 insn call
- label BO ; inline
+ cc {
+ { cc-o [ 0 label BSO ] }
+ { cc/o [ 0 label BNS ] }
+ } case ; inline
-M: ppc %fixnum-add ( label dst src1 src2 -- )
+M: ppc %fixnum-add ( label dst src1 src2 cc -- )
[ ADDO. ] overflow-template ;
-M: ppc %fixnum-sub ( label dst src1 src2 -- )
+M: ppc %fixnum-sub ( label dst src1 src2 cc -- )
[ SUBFO. ] overflow-template ;
-M: ppc %fixnum-mul ( label dst src1 src2 -- )
+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 %integer>float ( dst src -- )
- HEX: 4330 scratch-reg LIS
+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
- scratch-reg src MR
- scratch-reg dup HEX: 8000 XORIS
- scratch-reg 1 4 scratch@ STW
+ src 1 4 scratch@ STW
+ ! Load back doubleword into FPR and convert from integer.
dst 1 0 scratch@ LFD
- scratch-reg 4503601774854144.0 %load-reference
- fp-scratch-reg scratch-reg float-offset LFD
- dst dst fp-scratch-reg FSUB ;
+ dst dst FCFID ;
-M:: ppc %float>integer ( dst src -- )
- fp-scratch-reg src FCTIWZ
+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 %copy ( dst src rep -- )
- 2over eq? [ 3drop ] [
- {
- { int-rep [ MR ] }
- { double-rep [ FMR ] }
- } case
- ] if ;
+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 ;
-GENERIC: float-function-param* ( dst src -- )
+! Scratch registers by register class.
+: scratch-regs ( -- regs )
+ {
+ { int-regs { 30 } }
+ { float-regs { 30 } }
+ } ;
-M: spill-slot float-function-param* [ 1 ] dip n>> spill@ LFD ;
-M: integer float-function-param* FMR ;
+! Return values of this class go here
+M: ppc return-regs ( -- regs )
+ {
+ { int-regs { 3 4 5 6 } }
+ { float-regs { 1 2 3 4 } }
+ } ;
-: float-function-param ( i src -- )
- [ float-regs cdecl param-regs nth ] dip float-function-param* ;
+! Is this structure small enough to be returned in registers?
+M: ppc return-struct-in-registers? ( c-type -- ? )
+ lookup-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 ;
-: float-function-return ( reg -- )
- float-regs return-reg double-rep %copy ;
+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 ;
-M:: ppc %unary-float-function ( dst src func -- )
- 0 src float-function-param
- func f %alien-invoke
- dst float-function-return ;
+:: 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 %binary-float-function ( dst src1 src2 func -- )
- 0 src1 float-function-param
- 1 src2 float-function-param
- func f %alien-invoke
- dst float-function-return ;
+M: ppc %alien-global ( register symbol dll -- )
+ [ 0 %load-cell-imm ] 2dip %load-cell-imm-rc rel-dlsym ;
-! Internal format is always double-precision on PowerPC
-M: ppc %single>double-float double-rep %copy ;
-M: ppc %double>single-float FRSP ;
+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 -- )
- alien-offset LWZ ;
-
+ 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
- 0 dst LI
! Is the object f?
- 0 src \ f type-number CMPI
- "end" get BEQ
- ! Compute tag in dst register
- dst src tag-mask get ANDI
+ dst 0 LI
+ 0 src \ f type-number %compare-cell-imm
+ 0 "end" get BEQ
+
! Is the object an alien?
- 0 dst alien type-number CMPI
- ! Add an offset to start of byte array's data
+ 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
- "end" get BNE
- ! If so, load the offset and add it to the address
- dst src alien-offset LWZ
+ 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
- dst \ f type-number %load-immediate
- 0 src 0 CMPI
- "f" get BEQ
+
+ ! 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 %load-immediate
- temp dst 1 alien@ STW
- temp dst 2 alien@ STW
- src dst 3 alien@ STW
- src dst 4 alien@ STW
+ 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 -- )
- ! This is ridiculous
[
"end" define-label
- "not-f" define-label
- "not-alien" define-label
- ! If displacement is zero, return the base
+ ! If displacement is zero, return the base.
dst base MR
- 0 displacement 0 CMPI
- "end" get BEQ
+ 0 displacement 0 %compare-cell-imm
+ 0 "end" get BEQ
! Displacement is non-zero, we're going to be allocating a new
! object
! Set expired to f
temp \ f type-number %load-immediate
- temp dst 2 alien@ STW
-
- ! Is base f?
- 0 base \ f type-number CMPI
- "not-f" get BNE
-
- ! Yes, it is f. Fill in new object
- base dst 1 alien@ STW
- displacement dst 3 alien@ STW
- displacement dst 4 alien@ STW
-
- "end" get B
-
- "not-f" resolve-label
-
- ! Check base type
- temp base tag-mask get ANDI
-
- ! Is base an alien?
- 0 temp alien type-number CMPI
- "not-alien" get BNE
-
- ! Yes, it is an alien. Set new alien's base to base.base
- temp base 1 alien@ LWZ
- temp dst 1 alien@ STW
-
- ! Compute displacement
- temp base 3 alien@ LWZ
- temp temp displacement ADD
- temp dst 3 alien@ STW
+ scratch-reg 2 alien@ LI
+ temp dst scratch-reg %store-cell-x
- ! Compute address
- temp base 4 alien@ LWZ
- temp temp displacement ADD
- temp dst 4 alien@ STW
-
- ! We are done
- "end" get B
-
- ! Is base a byte array? It has to be, by now...
- "not-alien" resolve-label
-
- base dst 1 alien@ STW
- displacement dst 3 alien@ STW
- temp base byte-array-offset ADDI
- temp temp displacement ADD
- temp dst 4 alien@ STW
+ 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 %alien-unsigned-1 LBZ ;
-M: ppc %alien-unsigned-2 LHZ ;
+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 %alien-signed-1 [ dup ] 2dip LBZ dup EXTSB ;
-M: ppc %alien-signed-2 LHA ;
+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 %alien-cell LWZ ;
+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 %alien-float LFS ;
-M: ppc %alien-double LFD ;
+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 %set-alien-integer-1 -rot STB ;
-M: ppc %set-alien-integer-2 -rot STH ;
-M: ppc %set-alien-cell -rot STW ;
+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 %set-alien-float -rot STFS ;
-M: ppc %set-alien-double -rot STFD ;
+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 ;
-: load-zone-ptr ( reg -- )
- vm-reg "nursery" vm-field-offset ADDI ;
-: load-allot-ptr ( nursery-ptr allot-ptr -- )
- [ drop load-zone-ptr ] [ swap 0 LWZ ] 2bi ;
+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 ;
-:: inc-allot-ptr ( nursery-ptr allot-ptr n -- )
- scratch-reg allot-ptr n data-alignment get align ADDI
- scratch-reg nursery-ptr 0 STW ;
+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 ;
-:: store-header ( dst class -- )
- class type-number tag-header scratch-reg LI
- scratch-reg dst 0 STW ;
+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 ;
-: store-tagged ( dst tag -- )
- dupd type-number ORI ;
+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 -- )
- nursery-ptr dst load-allot-ptr
- nursery-ptr dst size inc-allot-ptr
- dst class store-header
- dst class store-tagged ;
-
-: load-cards-offset ( dst -- )
- 0 swap LOAD32 rc-absolute-ppc-2/2 rel-cards-offset ;
-
-: load-decks-offset ( dst -- )
- 0 swap LOAD32 rc-absolute-ppc-2/2 rel-decks-offset ;
+ ! 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 -- )
- card-mark scratch-reg LI
-
- ! Mark the card
- temp1 temp1 card-bits SRWI
- temp2 load-cards-offset
- temp1 scratch-reg temp2 STBX
-
- ! Mark the card deck
- temp1 temp1 deck-bits card-bits - SRWI
- temp2 load-decks-offset
- temp1 scratch-reg temp2 STBX ;
-
-M:: ppc %write-barrier ( src slot 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 temp1 temp2 -- )
- temp1 src slot ADDI
+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 ( label size temp1 temp2 -- )
- temp2 load-zone-ptr
- temp1 temp2 0 LWZ
- temp2 temp2 2 cells LWZ
+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
- ! is here >= end?
- temp1 0 temp2 CMP
- label BLE ;
-
-M:: ppc %save-gc-root ( gc-root register -- )
- register 1 gc-root gc-root@ STW ;
-
-M:: ppc %load-gc-root ( gc-root register -- )
- register 1 gc-root gc-root@ LWZ ;
+ 0 temp1 temp2 %compare-cell
+ cc {
+ { cc<= [ 0 label BLE ] }
+ { cc/<= [ 0 label BGT ] }
+ } case ;
-M:: ppc %call-gc ( gc-root-count temp -- )
- 3 1 gc-root-base local@ ADDI
- gc-root-count 4 LI
- 5 %load-vm-addr
- "inline_gc" f %alien-invoke ;
+M: ppc %call-gc ( gc-map -- )
+ \ minor-gc %call gc-map-here ;
-M: ppc %prologue ( n -- )
- 0 11 LOAD32 rc-absolute-ppc-2/2 rel-this
+M:: ppc %prologue ( stack-size -- )
0 MFLR
- {
- [ [ 1 1 ] dip neg ADDI ]
- [ [ 11 1 ] dip xt-save STW ]
- [ 11 LI ]
- [ [ 11 1 ] dip next-save STW ]
- [ [ 0 1 ] dip lr-save + STW ]
- } cleave ;
-
-M: ppc %epilogue ( n -- )
- #! 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.
- [ [ 0 1 ] dip lr-save + LWZ ]
- [ [ 1 1 ] dip ADDI ] bi
+ 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
- "end" get branch1 execute( label -- )
- branch2 [ "end" get branch2 execute( label -- ) ] when
+ 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
{ cc/= [ dst temp \ BNE f (%boolean) ] }
} case ;
-: (%compare) ( src1 src2 -- ) [ 0 ] dip CMP ; inline
-: (%compare-imm) ( src1 src2 -- ) [ 0 ] [ ] [ \ f type-number or ] tri* CMPI ; inline
-: (%compare-float-unordered) ( src1 src2 -- ) [ 0 ] dip FCMPU ; inline
-: (%compare-float-ordered) ( src1 src2 -- ) [ 0 ] dip FCMPO ; inline
+: (%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 -- ) \ 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 -- ) \ BNO f ] }
+ { 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 \ BO ] }
+ { 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 \ BO ] }
+ { 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 \ BO ] }
- { cc/<>= [ src1 src2 \ compare execute( a b -- ) \ BO 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) ;
:: %branch ( label cc -- )
cc order-cc {
- { cc< [ label BLT ] }
- { cc<= [ label BLE ] }
- { cc> [ label BGT ] }
- { cc>= [ label BGE ] }
- { cc= [ label BEQ ] }
- { cc/= [ label BNE ] }
+ { 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-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 -- )
- label branch1 execute( label -- )
- branch2 [ label branch2 execute( label -- ) ] when ; inline
+ 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 )
src1 src2 cc \ (%compare-float-unordered) (%compare-float) :> ( branch1 branch2 )
label branch1 branch2 (%branch) ;
-: load-from-frame ( dst n rep -- )
- {
- { int-rep [ [ 1 ] dip LWZ ] }
- { float-rep [ [ 1 ] dip LFS ] }
- { double-rep [ [ 1 ] dip LFD ] }
- { stack-params [ [ 0 1 ] dip LWZ [ 0 1 ] dip param@ STW ] }
- } case ;
-
-: next-param@ ( n -- reg x )
- [ 17 ] dip param@ ;
-
-: store-to-frame ( src n rep -- )
- {
- { int-rep [ [ 1 ] dip STW ] }
- { float-rep [ [ 1 ] dip STFS ] }
+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 ] }
- { stack-params [ [ [ 0 ] dip next-param@ LWZ 0 1 ] dip STW ] }
+ { vector-rep [ scratch-reg swap LI 1 scratch-reg STVX ] }
+ { scalar-rep [ scratch-reg swap LI 1 scratch-reg STVX ] }
} case ;
-M: ppc %spill ( src rep dst -- )
- swap [ n>> spill@ ] dip store-to-frame ;
-
M: ppc %reload ( dst rep src -- )
- swap [ n>> spill@ ] dip load-from-frame ;
-
-M: ppc %loop-entry ;
-
-M: int-regs return-reg drop 3 ;
-M: int-regs param-regs 2drop { 3 4 5 6 7 8 9 10 } ;
-M: float-regs return-reg drop 1 ;
-
-M:: ppc %save-param-reg ( stack reg rep -- )
- reg stack local@ rep store-to-frame ;
-
-M:: ppc %load-param-reg ( stack reg rep -- )
- reg stack local@ rep load-from-frame ;
-
-M: ppc %pop-stack ( n -- )
- [ 3 ] dip <ds-loc> loc>operand LWZ ;
-
-M: ppc %push-stack ( -- )
- ds-reg ds-reg 4 ADDI
- int-regs return-reg ds-reg 0 STW ;
-
-M: ppc %push-context-stack ( -- )
- 11 %context
- 12 11 "datastack" context-field-offset LWZ
- 12 12 4 ADDI
- 12 11 "datastack" context-field-offset STW
- int-regs return-reg 12 0 STW ;
-
-M: ppc %pop-context-stack ( -- )
- 11 %context
- 12 11 "datastack" context-field-offset LWZ
- int-regs return-reg 12 0 LWZ
- 12 12 4 SUBI
- 12 11 "datastack" context-field-offset STW ;
-
-M: ppc %unbox ( n rep func -- )
- ! Value must be in r3
- 4 %load-vm-addr
- ! Call the unboxer
- f %alien-invoke
- ! Store the return value on the C stack
- over [ [ reg-class-of return-reg ] keep %save-param-reg ] [ 2drop ] if ;
-
-M: ppc %unbox-long-long ( n func -- )
- 4 %load-vm-addr
- ! Call the unboxer
- f %alien-invoke
- ! Store the return value on the C stack
- [
- [ [ 3 1 ] dip local@ STW ]
- [ [ 4 1 ] dip cell + local@ STW ] bi
- ] when* ;
-
-M: ppc %unbox-large-struct ( n c-type -- )
- ! Value must be in r3
- ! Compute destination address and load struct size
- [ [ 4 1 ] dip local@ ADDI ] [ heap-size 5 LI ] bi*
- 6 %load-vm-addr
- ! Call the function
- "to_value_struct" f %alien-invoke ;
-
-M:: ppc %box ( n rep func -- )
- ! If the source is a stack location, load it into freg #0.
- ! If the source is f, then we assume the value is already in
- ! freg #0.
- n [ 0 rep reg-class-of cdecl param-reg rep %load-param-reg ] when*
- rep double-rep? 5 4 ? %load-vm-addr
- func f %alien-invoke ;
-
-M: ppc %box-long-long ( n func -- )
- [
- [
- [ [ 3 1 ] dip local@ LWZ ]
- [ [ 4 1 ] dip cell + local@ LWZ ] bi
- ] when*
- 5 %load-vm-addr
- ] dip f %alien-invoke ;
-
-: struct-return@ ( n -- n )
- [ stack-frame get params>> ] unless* local@ ;
-
-M: ppc %prepare-box-struct ( -- )
- #! Compute target address for value struct return
- 3 1 f struct-return@ ADDI
- 3 1 0 local@ STW ;
-
-M: ppc %box-large-struct ( n c-type -- )
- ! If n = f, then we're boxing a returned struct
- ! Compute destination address and load struct size
- [ [ 3 1 ] dip struct-return@ ADDI ] [ heap-size 4 LI ] bi*
- 5 %load-vm-addr
- ! Call the function
- "from_value_struct" f %alien-invoke ;
-
-M:: ppc %restore-context ( temp1 temp2 -- )
- temp1 %context
- ds-reg temp1 "datastack" context-field-offset LWZ
- rs-reg temp1 "retainstack" context-field-offset LWZ ;
-
-M:: ppc %save-context ( temp1 temp2 -- )
- temp1 %context
- 1 temp1 "callstack-top" context-field-offset STW
- ds-reg temp1 "datastack" context-field-offset STW
- rs-reg temp1 "retainstack" context-field-offset STW ;
-
-M: ppc %alien-invoke ( symbol dll -- )
- [ 11 ] 2dip %alien-global 11 MTLR BLRL ;
-
-M: ppc %prepare-alien-indirect ( -- )
- 3 ds-reg 0 LWZ
- ds-reg ds-reg 4 SUBI
- 4 %load-vm-addr
- "pinned_alien_offset" f %alien-invoke
- 16 3 MR ;
-
-M: ppc %alien-indirect ( -- )
- 16 MTLR BLRL ;
-
-M: ppc immediate-arithmetic? ( n -- ? ) -32768 32767 between? ;
-
-M: ppc immediate-bitwise? ( n -- ? ) 0 65535 between? ;
-
-M: ppc struct-return-pointer-type void* ;
-
-M: ppc return-struct-in-registers? ( c-type -- ? )
- c-type return-in-registers?>> ;
-
-M: ppc %box-small-struct ( c-type -- )
- #! Box a <= 16-byte struct returned in r3:r4:r5:r6
- heap-size 7 LI
- 8 %load-vm-addr
- "from_medium_struct" f %alien-invoke ;
-
-: %unbox-struct-1 ( -- )
- ! Alien must be in r3.
- 4 %load-vm-addr
- "alien_offset" f %alien-invoke
- 3 3 0 LWZ ;
-
-: %unbox-struct-2 ( -- )
- ! Alien must be in r3.
- 4 %load-vm-addr
- "alien_offset" f %alien-invoke
- 4 3 4 LWZ
- 3 3 0 LWZ ;
-
-: %unbox-struct-4 ( -- )
- ! Alien must be in r3.
- 4 %load-vm-addr
- "alien_offset" f %alien-invoke
- 6 3 12 LWZ
- 5 3 8 LWZ
- 4 3 4 LWZ
- 3 3 0 LWZ ;
-
-M: ppc %begin-callback ( -- )
- 3 %load-vm-addr
- "begin_callback" f %alien-invoke ;
-
-M: ppc %alien-callback ( quot -- )
- 3 4 %restore-context
- 3 swap %load-reference
- 4 3 quot-entry-point-offset LWZ
- 4 MTLR
- BLRL
- 3 4 %save-context ;
-
-M: ppc %end-callback ( -- )
- 3 %load-vm-addr
- "end_callback" f %alien-invoke ;
-
-M: ppc %end-callback-value ( ctype -- )
- ! Save top of data stack
- 16 ds-reg 0 LWZ
- %end-callback
- ! Restore top of data stack
- 3 16 MR
- ! Unbox former top of data stack to return registers
- unbox-return ;
-
-M: ppc %unbox-small-struct ( size -- )
- heap-size cell align cell /i {
- { 1 [ %unbox-struct-1 ] }
- { 2 [ %unbox-struct-2 ] }
- { 4 [ %unbox-struct-4 ] }
+ 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 ;
-enable-float-functions
-
-USE: vocabs.loader
+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
{
- { [ os macosx? ] [ "cpu.ppc.macosx" require ] }
- { [ os linux? ] [ "cpu.ppc.linux" require ] }
+ { [ 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
+complex-double lookup-c-type t >>return-in-registers? drop
projects / factor.git / blobdiff