! 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.c-types literals cpu.architecture cpu.ppc.assembler
-literals compiler.cfg.registers compiler.cfg.instructions
-compiler.constants compiler.codegen compiler.codegen.fixup
-compiler.cfg.intrinsics compiler.cfg.stack-frame ;
+alien alien.accessors alien.c-types 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 ;
+FROM: cpu.ppc.assembler => B ;
IN: cpu.ppc
! PowerPC register assignments:
M: ppc machine-registers
{
{ int-regs $[ 2 12 [a,b] 15 29 [a,b] append ] }
- { double-float-regs $[ 0 29 [a,b] ] }
+ { float-regs $[ 0 29 [a,b] ] }
} ;
CONSTANT: scratch-reg 30
: xt-save ( n -- i ) 2 cells - ;
! Next, we have the spill area as well as the FFI parameter area.
-! They overlap, since basic blocks with FFI calls will never
-! spill.
+! 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-integer-base ( -- n )
- stack-frame get spill-counts>> double-float-regs swap at
- double-float-regs reg-size * ;
-
-: spill-integer@ ( n -- offset )
- cells spill-integer-base + param@ ;
-
-: spill-float@ ( n -- offset )
- double-float-regs reg-size * param@ ;
+: spill@ ( n -- offset )
+ spill-offset local@ ;
! Some FP intrinsics need a temporary scratch area in the stack
-! frame, 8 bytes in size
+! frame, 8 bytes in size. This is in the param-save area so it
+! does not overlap with spill slots.
: scratch@ ( n -- offset )
stack-frame get total-size>>
factor-area-size -
param-save-size -
+ ;
+! GC root area
+: gc-root@ ( n -- offset )
+ gc-root-offset local@ ;
+
! Finally we have the linkage area
HOOK: lr-save os ( -- n )
M: ppc stack-frame-size ( stack-frame -- i )
- [ spill-counts>> [ swap reg-size * ] { } assoc>map sum ]
- [ params>> ]
- [ return>> ]
- tri + +
+ (stack-frame-size)
param-save-size +
reserved-area-size +
factor-area-size +
4 cells align ;
M: ppc %call ( word -- ) 0 BL rc-relative-ppc-3 rel-word-pic ;
-M: ppc %jump ( word -- ) 0 B rc-relative-ppc-3 rel-word ;
+
+M: ppc %jump ( word -- )
+ 0 6 LOAD32 8 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 offset -- )
+M:: ppc %dispatch ( src temp -- )
0 temp LOAD32
- 4 offset + cells rc-absolute-ppc-2/2 rel-here
+ 4 cells rc-absolute-ppc-2/2 rel-here
temp temp src LWZX
temp MTCTR
BCTR ;
-M: ppc %dispatch-label ( word -- )
- 0 , rc-absolute-cell rel-word ;
-
:: (%slot) ( obj slot tag temp -- reg offset )
temp slot obj ADD
temp tag neg ; inline
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 ;
-: %alien-invoke-tail ( func dll -- )
- [ scratch-reg ] 2dip %alien-global scratch-reg MTCTR BCTR ;
-
-:: exchange-regs ( r1 r2 -- )
- scratch-reg r1 MR
- r1 r2 MR
- r2 scratch-reg MR ;
-
-: ?MR ( r1 r2 -- ) 2dup = [ 2drop ] [ MR ] if ;
-
-:: move>args ( src1 src2 -- )
- {
- { [ src1 4 = ] [ 3 src2 ?MR 3 4 exchange-regs ] }
- { [ src1 3 = ] [ 4 src2 ?MR ] }
- { [ src2 3 = ] [ 4 src1 ?MR 3 4 exchange-regs ] }
- { [ src2 4 = ] [ 3 src1 ?MR ] }
- [ 3 src1 MR 4 src2 MR ]
- } cond ;
-
-: clear-xer ( -- )
+:: overflow-template ( label dst src1 src2 insn -- )
0 0 LI
- 0 MTXER ; inline
-
-:: overflow-template ( src1 src2 insn func -- )
- "no-overflow" define-label
- clear-xer
- scratch-reg src2 src1 insn call
- scratch-reg ds-reg 0 STW
- "no-overflow" get BNO
- src1 src2 move>args
- %prepare-alien-invoke
- func f %alien-invoke
- "no-overflow" resolve-label ; inline
-
-:: overflow-template-tail ( src1 src2 insn func -- )
- "overflow" define-label
- clear-xer
- scratch-reg src2 src1 insn call
- "overflow" get BO
- scratch-reg ds-reg 0 STW
- BLR
- "overflow" resolve-label
- src1 src2 move>args
- %prepare-alien-invoke
- func f %alien-invoke-tail ; inline
-
-M: ppc %fixnum-add ( src1 src2 -- )
- [ ADDO. ] "overflow_fixnum_add" overflow-template ;
+ 0 MTXER
+ dst src2 src1 insn call
+ label BO ; inline
-M: ppc %fixnum-add-tail ( src1 src2 -- )
- [ ADDO. ] "overflow_fixnum_add" overflow-template-tail ;
+M: ppc %fixnum-add ( label dst src1 src2 -- )
+ [ ADDO. ] overflow-template ;
-M: ppc %fixnum-sub ( src1 src2 -- )
- [ SUBFO. ] "overflow_fixnum_subtract" overflow-template ;
+M: ppc %fixnum-sub ( label dst src1 src2 -- )
+ [ SUBFO. ] overflow-template ;
-M: ppc %fixnum-sub-tail ( src1 src2 -- )
- [ SUBFO. ] "overflow_fixnum_subtract" overflow-template-tail ;
-
-M:: ppc %fixnum-mul ( src1 src2 temp1 temp2 -- )
- "no-overflow" define-label
- clear-xer
- temp1 src1 tag-bits get SRAWI
- temp2 temp1 src2 MULLWO.
- temp2 ds-reg 0 STW
- "no-overflow" get BNO
- src2 src2 tag-bits get SRAWI
- temp1 src2 move>args
- %prepare-alien-invoke
- "overflow_fixnum_multiply" f %alien-invoke
- "no-overflow" resolve-label ;
-
-M:: ppc %fixnum-mul-tail ( src1 src2 temp1 temp2 -- )
- "overflow" define-label
- clear-xer
- temp1 src1 tag-bits get SRAWI
- temp2 temp1 src2 MULLWO.
- "overflow" get BO
- temp2 ds-reg 0 STW
- BLR
- "overflow" resolve-label
- src2 src2 tag-bits get SRAWI
- temp1 src2 move>args
- %prepare-alien-invoke
- "overflow_fixnum_multiply" f %alien-invoke-tail ;
+M: ppc %fixnum-mul ( label dst src1 src2 -- )
+ [ MULLWO. ] overflow-template ;
: bignum@ ( n -- offset ) cells bignum tag-number - ; inline
temp dst 1 bignum@ STW
! Compute sign
temp src MR
- temp temp cell-bits 1- SRAWI
+ temp temp cell-bits 1 - SRAWI
temp temp 1 ANDI
! Store sign
temp dst 2 bignum@ STW
fp-scratch-reg 1 0 scratch@ STFD
dst 1 4 scratch@ LWZ ;
-M: ppc %copy ( dst src -- ) MR ;
-
-M: ppc %copy-float ( dst src -- ) FMR ;
+M: ppc %copy ( dst src rep -- )
+ {
+ { int-rep [ MR ] }
+ { double-float-rep [ FMR ] }
+ } case ;
M: ppc %unbox-float ( dst src -- ) float-offset LFD ;
src card# deck-bits SRWI
table scratch-reg card# STBX ;
-M: ppc %gc
- "end" define-label
- 12 load-zone-ptr
- 11 12 cell LWZ ! nursery.here -> r11
- 12 12 3 cells LWZ ! nursery.end -> r12
- 11 11 1024 ADDI ! add ALLOT_BUFFER_ZONE to here
- 11 0 12 CMP ! is here >= end?
- "end" get BLE
+M:: ppc %check-nursery ( label temp1 temp2 -- )
+ temp2 load-zone-ptr
+ temp1 temp2 cell LWZ
+ temp2 temp2 3 cells LWZ
+ ! add ALLOT_BUFFER_ZONE to here
+ temp1 temp1 1024 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 ;
+
+M:: ppc %call-gc ( gc-root-count -- )
%prepare-alien-invoke
- "minor_gc" f %alien-invoke
- "end" resolve-label ;
+ 3 1 gc-root-base local@ ADDI
+ gc-root-count 4 LI
+ "inline_gc" f %alien-invoke ;
M: ppc %prologue ( n -- )
0 11 LOAD32 rc-absolute-ppc-2/2 rel-this
M: ppc %compare-imm-branch (%compare-imm) %branch ;
M: ppc %compare-float-branch (%compare-float) %branch ;
-M: ppc %spill-integer ( src n -- ) spill-integer@ 1 swap STW ;
-M: ppc %reload-integer ( dst n -- ) spill-integer@ 1 swap LWZ ;
+: load-from-frame ( dst n rep -- )
+ {
+ { int-rep [ [ 1 ] dip LWZ ] }
+ { single-float-rep [ [ 1 ] dip LFS ] }
+ { double-float-rep [ [ 1 ] dip LFD ] }
+ { stack-params [ [ 0 1 ] dip LWZ [ 0 1 ] dip param@ STW ] }
+ } case ;
+
+: next-param@ ( n -- x ) param@ stack-frame get total-size>> + ;
+
+: store-to-frame ( src n rep -- )
+ {
+ { int-rep [ [ 1 ] dip STW ] }
+ { single-float-rep [ [ 1 ] dip STFS ] }
+ { double-float-rep [ [ 1 ] dip STFD ] }
+ { stack-params [ [ [ 0 1 ] dip next-param@ LWZ 0 1 ] dip STW ] }
+ } case ;
+
+M: ppc %spill ( src n rep -- )
+ [ spill@ ] dip store-to-frame ;
-M: ppc %spill-float ( src n -- ) spill-float@ 1 swap STFD ;
-M: ppc %reload-float ( dst n -- ) spill-float@ 1 swap LFD ;
+M: ppc %reload ( dst n rep -- )
+ [ spill@ ] dip load-from-frame ;
M: ppc %loop-entry ;
M: int-regs param-regs drop { 3 4 5 6 7 8 9 10 } ;
M: float-regs return-reg drop 1 ;
-M: int-regs %save-param-reg drop 1 rot local@ STW ;
-M: int-regs %load-param-reg drop 1 rot local@ LWZ ;
+M:: ppc %save-param-reg ( stack reg rep -- )
+ reg stack local@ rep store-to-frame ;
-GENERIC: STF ( src dst off reg-class -- )
-
-M: single-float-regs STF drop STFS ;
-M: double-float-regs STF drop STFD ;
-
-M: float-regs %save-param-reg [ 1 rot local@ ] dip STF ;
-
-GENERIC: LF ( dst src off reg-class -- )
-
-M: single-float-regs LF drop LFS ;
-M: double-float-regs LF drop LFD ;
-
-M: float-regs %load-param-reg [ 1 rot local@ ] dip LF ;
-
-M: stack-params %load-param-reg ( stack reg reg-class -- )
- drop [ 0 1 rot local@ LWZ 0 1 ] dip param@ STW ;
-
-: next-param@ ( n -- x ) param@ stack-frame get total-size>> + ;
-
-M: stack-params %save-param-reg ( stack reg reg-class -- )
- #! Funky. Read the parameter from the caller's stack frame.
- #! This word is used in callbacks
- drop
- [ 0 1 ] dip next-param@ LWZ
- [ 0 1 ] dip local@ STW ;
+M:: ppc %load-param-reg ( stack reg rep -- )
+ reg stack local@ rep load-from-frame ;
M: ppc %prepare-unbox ( -- )
! First parameter is top of stack
3 ds-reg 0 LWZ
ds-reg dup cell SUBI ;
-M: ppc %unbox ( n reg-class func -- )
+M: ppc %unbox ( n rep func -- )
! Value must be in r3
! Call the unboxer
f %alien-invoke
! Store the return value on the C stack
- over [ [ return-reg ] keep %save-param-reg ] [ 2drop ] if ;
+ over [ [ reg-class-of return-reg ] keep %save-param-reg ] [ 2drop ] if ;
M: ppc %unbox-long-long ( n func -- )
! Value must be in r3:r4
! Call the function
"to_value_struct" f %alien-invoke ;
-M: ppc %box ( n reg-class func -- )
+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.
- [ over [ 0 over param-reg swap %load-param-reg ] [ 2drop ] if ] dip
+ [ over [ 0 over reg-class-of param-reg swap %load-param-reg ] [ 2drop ] if ] dip
f %alien-invoke ;
M: ppc %box-long-long ( n func -- )
M: ppc %prepare-alien-indirect ( -- )
"unbox_alien" f %alien-invoke
- 13 3 MR ;
+ 15 3 MR ;
M: ppc %alien-indirect ( -- )
- 13 MTLR BLRL ;
+ 15 MTLR BLRL ;
M: ppc %callback-value ( ctype -- )
! Save top of data stack
} cond
"complex-double" c-type t >>return-in-registers? drop
+
+[
+ <c-type>
+ [ alien-unsigned-4 c-bool> ] >>getter
+ [ [ >c-bool ] 2dip set-alien-unsigned-4 ] >>setter
+ 4 >>size
+ 4 >>align
+ "box_boolean" >>boxer
+ "to_boolean" >>unboxer
+ "bool" define-primitive-type
+] with-compilation-unit
projects / factor.git / blobdiff