New PPC backend (untested)

db4
Slava Pestov 2008-11-05 00:31:08 -06:00
parent c8521ad826
commit 10d3b4a55d
12 changed files with 553 additions and 1096 deletions

View File

@ -1,112 +0,0 @@
! Copyright (C) 2006, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel cpu.ppc.architecture cpu.ppc.assembler
kernel.private namespaces math sequences generic arrays
compiler.generator compiler.generator.registers
compiler.generator.fixup system layouts
cpu.architecture alien ;
IN: cpu.ppc.allot
: load-zone-ptr ( reg -- )
>r "nursery" f r> %load-dlsym ;
: %allot ( header size -- )
#! Store a pointer to 'size' bytes allocated from the
#! nursery in r11.
8 align ! align the size
12 load-zone-ptr ! nusery -> r12
11 12 cell LWZ ! nursery.here -> r11
11 11 pick ADDI ! increment r11
11 12 cell STW ! r11 -> nursery.here
11 11 rot SUBI ! old value
type-number tag-fixnum 12 LI ! compute header
12 11 0 STW ! store header
;
: %store-tagged ( reg tag -- )
>r dup fresh-object v>operand 11 r> tag-number ORI ;
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
0 frame-required
%prepare-alien-invoke
"minor_gc" f %alien-invoke
"end" resolve-label ;
: %allot-float ( reg -- )
#! exits with tagged ptr to object in r12, untagged in r11
float 16 %allot
11 8 STFD
12 11 float tag-number ORI
f fresh-object ;
M: ppc %box-float ( dst src -- )
[ v>operand ] bi@ %allot-float 12 MR ;
: %allot-bignum ( #digits -- )
#! 1 cell header, 1 cell length, 1 cell sign, + digits
#! length is the # of digits + sign
bignum over 3 + cells %allot
1+ v>operand 12 LI ! compute the length
12 11 cell STW ! store the length
;
: %allot-bignum-signed-1 ( reg -- )
#! on entry, reg is a 30-bit quantity sign-extended to
#! 32-bits.
#! exits with tagged ptr to bignum in reg
[
{ "end" "non-zero" "pos" "store" } [ define-label ] each
! is it zero?
0 over v>operand 0 CMPI
"non-zero" get BNE
dup 0 >bignum %load-literal
"end" get B
! it is non-zero
"non-zero" resolve-label
1 %allot-bignum
! is the fixnum negative?
0 over v>operand 0 CMPI
"pos" get BGE
1 12 LI
! store negative sign
12 11 2 cells STW
! negate fixnum
dup v>operand dup -1 MULI
"store" get B
"pos" resolve-label
0 12 LI
! store positive sign
12 11 2 cells STW
"store" resolve-label
! store the number
dup v>operand 11 3 cells STW
! tag the bignum, store it in reg
bignum %store-tagged
"end" resolve-label
] with-scope ;
M: ppc %box-alien ( dst src -- )
{ "end" "f" } [ define-label ] each
0 over v>operand 0 CMPI
"f" get BEQ
alien 4 cells %allot
! Store offset
v>operand 11 3 cells STW
f v>operand 12 LI
! Store expired slot
12 11 1 cells STW
! Store underlying-alien slot
12 11 2 cells STW
! Store tagged ptr in reg
dup object %store-tagged
"end" get B
"f" resolve-label
f v>operand swap v>operand LI
"end" resolve-label ;

View File

@ -1 +0,0 @@
Slava Pestov

View File

@ -1 +0,0 @@
PowerPC inline memory allocation

View File

@ -1 +0,0 @@
unportable

View File

@ -1,331 +0,0 @@
! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors alien.c-types cpu.ppc.assembler
cpu.architecture generic kernel kernel.private math memory
namespaces sequences words assocs compiler.generator
compiler.generator.registers compiler.generator.fixup system
layouts classes words.private alien combinators
compiler.constants math.order make ;
IN: cpu.ppc.architecture
! PowerPC register assignments
! r3-r10, r16-r31: integer vregs
! f0-f13: float vregs
! r11, r12: scratch
! r14: data stack
! r15: retain stack
: ds-reg 14 ; inline
: rs-reg 15 ; inline
: reserved-area-size ( -- n )
os {
{ linux [ 2 ] }
{ macosx [ 6 ] }
} case cells ; foldable
: lr-save ( -- n )
os {
{ linux [ 1 ] }
{ macosx [ 2 ] }
} case cells ; foldable
: param@ ( n -- x ) reserved-area-size + ; inline
: param-save-size ( -- n ) 8 cells ; foldable
: local@ ( n -- x )
reserved-area-size param-save-size + + ; inline
: factor-area-size ( -- n ) 2 cells ; foldable
: next-save ( n -- i ) cell - ;
: xt-save ( n -- i ) 2 cells - ;
M: ppc stack-frame-size ( n -- i )
local@ factor-area-size + 4 cells align ;
M: temp-reg v>operand drop 11 ;
M: int-regs return-reg drop 3 ;
M: int-regs param-regs drop { 3 4 5 6 7 8 9 10 } ;
M: int-regs vregs
drop {
3 4 5 6 7 8 9 10
16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31
} ;
M: float-regs return-reg drop 1 ;
M: float-regs param-regs
drop os H{
{ macosx { 1 2 3 4 5 6 7 8 9 10 11 12 13 } }
{ linux { 1 2 3 4 5 6 7 8 } }
} at ;
M: float-regs vregs drop { 0 1 2 3 4 5 6 7 8 9 10 11 12 13 } ;
GENERIC: loc>operand ( loc -- reg n )
M: ds-loc loc>operand n>> cells neg ds-reg swap ;
M: rs-loc loc>operand n>> cells neg rs-reg swap ;
M: immediate load-literal
[ v>operand ] bi@ LOAD ;
M: ppc load-indirect ( obj reg -- )
[ 0 swap LOAD32 rc-absolute-ppc-2/2 rel-literal ] keep
dup 0 LWZ ;
M: ppc %save-word-xt ( -- )
0 11 LOAD32 rc-absolute-ppc-2/2 rel-this ;
M: ppc %prologue ( n -- )
0 MFLR
1 1 pick neg ADDI
11 1 pick xt-save STW
dup 11 LI
11 1 pick next-save STW
0 1 rot lr-save + STW ;
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 pick lr-save + LWZ
1 1 rot ADDI
0 MTLR ;
: (%call) ( reg -- ) MTLR BLRL ;
: (%jump) ( reg -- ) MTCTR BCTR ;
: %load-dlsym ( symbol dll register -- )
0 swap LOAD32 rc-absolute-ppc-2/2 rel-dlsym ;
M: ppc %call ( label -- ) BL ;
M: ppc %jump-label ( label -- ) B ;
M: ppc %jump-f ( label -- )
0 "flag" operand f v>operand CMPI BEQ ;
M: ppc %dispatch ( -- )
[
%epilogue-later
0 11 LOAD32 rc-absolute-ppc-2/2 rel-here
"offset" operand "n" operand 1 SRAWI
11 11 "offset" operand ADD
11 dup 6 cells LWZ
11 (%jump)
] H{
{ +input+ { { f "n" } } }
{ +scratch+ { { f "offset" } } }
} with-template ;
M: ppc %dispatch-label ( word -- )
0 , rc-absolute-cell rel-word ;
M: ppc %return ( -- ) %epilogue-later BLR ;
M: ppc %peek ( vreg loc -- )
>r v>operand r> loc>operand LWZ ;
M: ppc %replace
>r v>operand r> loc>operand STW ;
M: ppc %unbox-float ( dst src -- )
[ v>operand ] bi@ float-offset LFD ;
M: ppc %inc-d ( n -- ) ds-reg dup rot cells ADDI ;
M: ppc %inc-r ( n -- ) rs-reg dup rot cells ADDI ;
M: int-regs %save-param-reg drop 1 rot local@ STW ;
M: int-regs %load-param-reg drop 1 rot local@ LWZ ;
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 >r 1 rot local@ r> 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 >r 1 rot local@ r> LF ;
M: stack-params %load-param-reg ( stack reg reg-class -- )
drop >r 0 1 rot local@ LWZ 0 1 r> 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 rot next-param@ LWZ
0 1 rot local@ STW ;
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 -- )
! 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 ;
M: ppc %unbox-long-long ( n func -- )
! Value must be in r3:r4
! Call the unboxer
f %alien-invoke
! Store the return value on the C stack
[
3 1 pick local@ STW
4 1 rot cell + local@ STW
] when* ;
M: ppc %unbox-large-struct ( n c-type -- )
! Value must be in r3
! Compute destination address and load struct size
[ 4 1 rot local@ ADDI ] [ heap-size 5 LI ] bi*
! Call the function
"to_value_struct" f %alien-invoke ;
M: ppc %box ( n reg-class 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.
>r
over [ 0 over param-reg swap %load-param-reg ] [ 2drop ] if
r> f %alien-invoke ;
M: ppc %box-long-long ( n func -- )
>r [
3 1 pick local@ LWZ
4 1 rot cell + local@ LWZ
] when* r> 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 rot struct-return@ ADDI ] [ heap-size 4 LI ] bi*
! Call the function
"box_value_struct" f %alien-invoke ;
M: ppc %prepare-alien-invoke
#! Save Factor stack pointers in case the C code calls a
#! callback which does a GC, which must reliably trace
#! all roots.
"stack_chain" f 11 %load-dlsym
11 11 0 LWZ
1 11 0 STW
ds-reg 11 8 STW
rs-reg 11 12 STW ;
M: ppc %alien-invoke ( symbol dll -- )
11 %load-dlsym 11 (%call) ;
M: ppc %alien-callback ( quot -- )
3 load-indirect "c_to_factor" f %alien-invoke ;
M: ppc %prepare-alien-indirect ( -- )
"unbox_alien" f %alien-invoke
13 3 MR ;
M: ppc %alien-indirect ( -- )
13 (%call) ;
M: ppc %callback-value ( ctype -- )
! Save top of data stack
3 ds-reg 0 LWZ
3 1 0 local@ STW
! Restore data/call/retain stacks
"unnest_stacks" f %alien-invoke
! Restore top of data stack
3 1 0 local@ LWZ
! Unbox former top of data stack to return registers
unbox-return ;
: %untag ( src dest -- ) 0 0 31 tag-bits get - RLWINM ;
: %tag-fixnum ( src dest -- ) tag-bits get SLWI ;
: %untag-fixnum ( dest src -- ) tag-bits get SRAWI ;
M: ppc value-structs?
#! On Linux/PPC, value structs are passed in the same way
#! as reference structs, we just have to make a copy first.
os linux? not ;
M: ppc fp-shadows-int? ( -- ? ) os macosx? ;
M: ppc small-enough? ( n -- ? ) -32768 32767 between? ;
M: ppc struct-small-enough? ( size -- ? ) drop f ;
M: ppc %box-small-struct
drop "No small structs" throw ;
M: ppc %unbox-small-struct
drop "No small structs" throw ;
! Alien intrinsics
M: ppc %unbox-byte-array ( dst src -- )
[ v>operand ] bi@ byte-array-offset ADDI ;
M: ppc %unbox-alien ( dst src -- )
[ v>operand ] bi@ alien-offset LWZ ;
M: ppc %unbox-f ( dst src -- )
drop 0 swap v>operand LI ;
M: ppc %unbox-any-c-ptr ( dst src -- )
{ "is-byte-array" "end" "start" } [ define-label ] each
! Address is computed in R12
0 12 LI
! Load object into R11
11 swap v>operand MR
! We come back here with displaced aliens
"start" resolve-label
! Is the object f?
0 11 f v>operand CMPI
! If so, done
"end" get BEQ
! Is the object an alien?
0 11 header-offset LWZ
0 0 alien type-number tag-fixnum CMPI
"is-byte-array" get BNE
! If so, load the offset
0 11 alien-offset LWZ
! Add it to address being computed
12 12 0 ADD
! Now recurse on the underlying alien
11 11 underlying-alien-offset LWZ
"start" get B
"is-byte-array" resolve-label
! Add byte array address to address being computed
12 12 11 ADD
! Add an offset to start of byte array's data area
12 12 byte-array-offset ADDI
"end" resolve-label
! Done, store address in destination register
v>operand 12 MR ;

View File

@ -1 +0,0 @@
Slava Pestov

View File

@ -1 +0,0 @@
PowerPC architecture description

View File

@ -1 +0,0 @@
unportable

View File

@ -1 +0,0 @@
Slava Pestov

View File

@ -1,640 +0,0 @@
! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors alien alien.accessors alien.c-types arrays
cpu.ppc.assembler cpu.ppc.architecture cpu.ppc.allot
cpu.architecture kernel kernel.private math math.private
namespaces sequences words generic quotations byte-arrays
hashtables hashtables.private
sequences.private sbufs vectors system layouts
math.floats.private classes slots.private
combinators
compiler.constants
compiler.intrinsics
compiler.generator
compiler.generator.fixup
compiler.generator.registers ;
IN: cpu.ppc.intrinsics
: %slot-literal-known-tag ( -- out value offset )
"val" operand
"obj" operand
"n" get cells
"obj" get operand-tag - ;
: %slot-literal-any-tag ( -- out value offset )
"obj" operand "scratch1" operand %untag
"val" operand "scratch1" operand "n" get cells ;
: %slot-any ( -- out value offset )
"obj" operand "scratch1" operand %untag
"offset" operand "n" operand 1 SRAWI
"scratch1" operand "val" operand "offset" operand ;
\ slot {
! Slot number is literal and the tag is known
{
[ %slot-literal-known-tag LWZ ] H{
{ +input+ { { f "obj" known-tag } { [ small-slot? ] "n" } } }
{ +scratch+ { { f "val" } } }
{ +output+ { "val" } }
}
}
! Slot number is literal
{
[ %slot-literal-any-tag LWZ ] H{
{ +input+ { { f "obj" } { [ small-slot? ] "n" } } }
{ +scratch+ { { f "scratch1" } { f "val" } } }
{ +output+ { "val" } }
}
}
! Slot number in a register
{
[ %slot-any LWZX ] H{
{ +input+ { { f "obj" } { f "n" } } }
{ +scratch+ { { f "val" } { f "scratch1" } { f "offset" } } }
{ +output+ { "val" } }
}
}
} define-intrinsics
: load-cards-offset ( dest -- )
"cards_offset" f pick %load-dlsym dup 0 LWZ ;
: load-decks-offset ( dest -- )
"decks_offset" f pick %load-dlsym dup 0 LWZ ;
: %write-barrier ( -- )
"val" get operand-immediate? "obj" get fresh-object? or [
card-mark "scratch1" operand LI
! Mark the card
"val" operand load-cards-offset
"obj" operand "scratch2" operand card-bits SRWI
"scratch2" operand "scratch1" operand "val" operand STBX
! Mark the card deck
"val" operand load-decks-offset
"obj" operand "scratch2" operand deck-bits SRWI
"scratch2" operand "scratch1" operand "val" operand STBX
] unless ;
\ set-slot {
! Slot number is literal and tag is known
{
[ %slot-literal-known-tag STW %write-barrier ] H{
{ +input+ { { f "val" } { f "obj" known-tag } { [ small-slot? ] "n" } } }
{ +scratch+ { { f "scratch1" } { f "scratch2" } } }
{ +clobber+ { "val" } }
}
}
! Slot number is literal
{
[ %slot-literal-any-tag STW %write-barrier ] H{
{ +input+ { { f "val" } { f "obj" } { [ small-slot? ] "n" } } }
{ +scratch+ { { f "scratch1" } { f "scratch2" } } }
{ +clobber+ { "val" } }
}
}
! Slot number is in a register
{
[ %slot-any STWX %write-barrier ] H{
{ +input+ { { f "val" } { f "obj" } { f "n" } } }
{ +scratch+ { { f "scratch1" } { f "scratch2" } { f "offset" } } }
{ +clobber+ { "val" } }
}
}
} define-intrinsics
: fixnum-register-op ( op -- pair )
[ "out" operand "y" operand "x" operand ] swap suffix H{
{ +input+ { { f "x" } { f "y" } } }
{ +scratch+ { { f "out" } } }
{ +output+ { "out" } }
} 2array ;
: fixnum-value-op ( op -- pair )
[ "out" operand "x" operand "y" operand ] swap suffix H{
{ +input+ { { f "x" } { [ small-tagged? ] "y" } } }
{ +scratch+ { { f "out" } } }
{ +output+ { "out" } }
} 2array ;
: define-fixnum-op ( word imm-op reg-op -- )
>r fixnum-value-op r> fixnum-register-op 2array
define-intrinsics ;
{
{ fixnum+fast ADDI ADD }
{ fixnum-fast SUBI SUBF }
{ fixnum-bitand ANDI AND }
{ fixnum-bitor ORI OR }
{ fixnum-bitxor XORI XOR }
} [
first3 define-fixnum-op
] each
\ fixnum*fast {
{
[
"out" operand "x" operand "y" get MULLI
] H{
{ +input+ { { f "x" } { [ small-tagged? ] "y" } } }
{ +scratch+ { { f "out" } } }
{ +output+ { "out" } }
}
} {
[
"out" operand "x" operand %untag-fixnum
"out" operand "y" operand "out" operand MULLW
] H{
{ +input+ { { f "x" } { f "y" } } }
{ +scratch+ { { f "out" } } }
{ +output+ { "out" } }
}
}
} define-intrinsics
: %untag-fixnums ( seq -- )
[ dup %untag-fixnum ] unique-operands ;
\ fixnum-shift-fast {
{
[
"out" operand "x" operand "y" get
dup 0 < [ neg SRAWI ] [ swapd SLWI ] if
! Mask off low bits
"out" operand dup %untag
] H{
{ +input+ { { f "x" } { [ ] "y" } } }
{ +scratch+ { { f "out" } } }
{ +output+ { "out" } }
}
}
{
[
{ "positive" "end" } [ define-label ] each
"out" operand "y" operand %untag-fixnum
0 "y" operand 0 CMPI
"positive" get BGE
"out" operand dup NEG
"out" operand "x" operand "out" operand SRAW
"end" get B
"positive" resolve-label
"out" operand "x" operand "out" operand SLW
"end" resolve-label
! Mask off low bits
"out" operand dup %untag
] H{
{ +input+ { { f "x" } { f "y" } } }
{ +scratch+ { { f "out" } } }
{ +output+ { "out" } }
}
}
} define-intrinsics
: generate-fixnum-mod ( -- )
#! PowerPC doesn't have a MOD instruction; so we compute
#! x-(x/y)*y. Puts the result in "s" operand.
"s" operand "r" operand "y" operand MULLW
"s" operand "s" operand "x" operand SUBF ;
\ fixnum-mod [
! divide x by y, store result in x
"r" operand "x" operand "y" operand DIVW
generate-fixnum-mod
] H{
{ +input+ { { f "x" } { f "y" } } }
{ +scratch+ { { f "r" } { f "s" } } }
{ +output+ { "s" } }
} define-intrinsic
\ fixnum-bitnot [
"x" operand dup NOT
"x" operand dup %untag
] H{
{ +input+ { { f "x" } } }
{ +output+ { "x" } }
} define-intrinsic
: fixnum-register-jump ( op -- pair )
[ "x" operand 0 "y" operand CMP ] swap suffix
{ { f "x" } { f "y" } } 2array ;
: fixnum-value-jump ( op -- pair )
[ 0 "x" operand "y" operand CMPI ] swap suffix
{ { f "x" } { [ small-tagged? ] "y" } } 2array ;
: define-fixnum-jump ( word op -- )
[ fixnum-value-jump ] keep fixnum-register-jump
2array define-if-intrinsics ;
{
{ fixnum< BGE }
{ fixnum<= BGT }
{ fixnum> BLE }
{ fixnum>= BLT }
{ eq? BNE }
} [
first2 define-fixnum-jump
] each
: overflow-check ( insn1 insn2 -- )
[
>r 0 0 LI
0 MTXER
"r" operand "y" operand "x" operand r> execute
>r
"end" define-label
"end" get BNO
{ "x" "y" } %untag-fixnums
"r" operand "y" operand "x" operand r> execute
"r" get %allot-bignum-signed-1
"end" resolve-label
] with-scope ; inline
: overflow-template ( word insn1 insn2 -- )
[ overflow-check ] 2curry H{
{ +input+ { { f "x" } { f "y" } } }
{ +scratch+ { { f "r" } } }
{ +output+ { "r" } }
{ +clobber+ { "x" "y" } }
} define-intrinsic ;
\ fixnum+ \ ADD \ ADDO. overflow-template
\ fixnum- \ SUBF \ SUBFO. overflow-template
: generate-fixnum/i ( -- )
#! This VOP is funny. If there is an overflow, it falls
#! through to the end, and the result is in "x" operand.
#! Otherwise it jumps to the "no-overflow" label and the
#! result is in "r" operand.
"end" define-label
"no-overflow" define-label
"r" operand "x" operand "y" operand DIVW
! if the result is greater than the most positive fixnum,
! which can only ever happen if we do
! most-negative-fixnum -1 /i, then the result is a bignum.
most-positive-fixnum "s" operand LOAD
"r" operand 0 "s" operand CMP
"no-overflow" get BLE
most-negative-fixnum neg "x" operand LOAD
"x" get %allot-bignum-signed-1 ;
\ fixnum/i [
generate-fixnum/i
"end" get B
"no-overflow" resolve-label
"r" operand "x" operand %tag-fixnum
"end" resolve-label
] H{
{ +input+ { { f "x" } { f "y" } } }
{ +scratch+ { { f "r" } { f "s" } } }
{ +output+ { "x" } }
{ +clobber+ { "y" } }
} define-intrinsic
\ fixnum/mod [
generate-fixnum/i
0 "s" operand LI
"end" get B
"no-overflow" resolve-label
generate-fixnum-mod
"r" operand "x" operand %tag-fixnum
"end" resolve-label
] H{
{ +input+ { { f "x" } { f "y" } } }
{ +scratch+ { { f "r" } { f "s" } } }
{ +output+ { "x" "s" } }
{ +clobber+ { "y" } }
} define-intrinsic
\ fixnum>bignum [
"x" operand dup %untag-fixnum
"x" get %allot-bignum-signed-1
] H{
{ +input+ { { f "x" } } }
{ +output+ { "x" } }
} define-intrinsic
\ bignum>fixnum [
"nonzero" define-label
"positive" define-label
"end" define-label
"x" operand dup %untag
"y" operand "x" operand cell LWZ
! if the length is 1, its just the sign and nothing else,
! so output 0
0 "y" operand 1 v>operand CMPI
"nonzero" get BNE
0 "y" operand LI
"end" get B
"nonzero" resolve-label
! load the value
"y" operand "x" operand 3 cells LWZ
! load the sign
"x" operand "x" operand 2 cells LWZ
! is the sign negative?
0 "x" operand 0 CMPI
"positive" get BEQ
"y" operand dup -1 MULI
"positive" resolve-label
"y" operand dup %tag-fixnum
"end" resolve-label
] H{
{ +input+ { { f "x" } } }
{ +scratch+ { { f "y" } } }
{ +clobber+ { "x" } }
{ +output+ { "y" } }
} define-intrinsic
: define-float-op ( word op -- )
[ "z" operand "x" operand "y" operand ] swap suffix H{
{ +input+ { { float "x" } { float "y" } } }
{ +scratch+ { { float "z" } } }
{ +output+ { "z" } }
} define-intrinsic ;
{
{ float+ FADD }
{ float- FSUB }
{ float* FMUL }
{ float/f FDIV }
} [
first2 define-float-op
] each
: define-float-jump ( word op -- )
[ "x" operand 0 "y" operand FCMPU ] swap suffix
{ { float "x" } { float "y" } } define-if-intrinsic ;
{
{ float< BGE }
{ float<= BGT }
{ float> BLE }
{ float>= BLT }
{ float= BNE }
} [
first2 define-float-jump
] each
\ float>fixnum [
"scratch" operand "in" operand FCTIWZ
"scratch" operand 1 0 param@ STFD
"out" operand 1 cell param@ LWZ
"out" operand dup %tag-fixnum
] H{
{ +input+ { { float "in" } } }
{ +scratch+ { { float "scratch" } { f "out" } } }
{ +output+ { "out" } }
} define-intrinsic
\ fixnum>float [
HEX: 4330 "scratch" operand LIS
"scratch" operand 1 0 param@ STW
"scratch" operand "in" operand %untag-fixnum
"scratch" operand dup HEX: 8000 XORIS
"scratch" operand 1 cell param@ STW
"f1" operand 1 0 param@ LFD
4503601774854144.0 "scratch" operand load-indirect
"f2" operand "scratch" operand float-offset LFD
"f1" operand "f1" operand "f2" operand FSUB
] H{
{ +input+ { { f "in" } } }
{ +scratch+ { { f "scratch" } { float "f1" } { float "f2" } } }
{ +output+ { "f1" } }
} define-intrinsic
\ tag [
"out" operand "in" operand tag-mask get ANDI
"out" operand dup %tag-fixnum
] H{
{ +input+ { { f "in" } } }
{ +scratch+ { { f "out" } } }
{ +output+ { "out" } }
} define-intrinsic
: userenv ( reg -- )
#! Load the userenv pointer in a register.
"userenv" f rot %load-dlsym ;
\ getenv [
"n" operand dup 1 SRAWI
"x" operand userenv
"x" operand "n" operand "x" operand ADD
"x" operand dup 0 LWZ
] H{
{ +input+ { { f "n" } } }
{ +scratch+ { { f "x" } } }
{ +output+ { "x" } }
{ +clobber+ { "n" } }
} define-intrinsic
\ setenv [
"n" operand dup 1 SRAWI
"x" operand userenv
"x" operand "n" operand "x" operand ADD
"val" operand "x" operand 0 STW
] H{
{ +input+ { { f "val" } { f "n" } } }
{ +scratch+ { { f "x" } } }
{ +clobber+ { "n" } }
} define-intrinsic
\ (tuple) [
tuple "layout" get size>> 2 + cells %allot
! Store layout
"layout" get 12 load-indirect
12 11 cell STW
! Store tagged ptr in reg
"tuple" get tuple %store-tagged
] H{
{ +input+ { { [ ] "layout" } } }
{ +scratch+ { { f "tuple" } } }
{ +output+ { "tuple" } }
} define-intrinsic
\ (array) [
array "n" get 2 + cells %allot
! Store length
"n" operand 12 LI
12 11 cell STW
! Store tagged ptr in reg
"array" get object %store-tagged
] H{
{ +input+ { { [ ] "n" } } }
{ +scratch+ { { f "array" } } }
{ +output+ { "array" } }
} define-intrinsic
\ (byte-array) [
byte-array "n" get 2 cells + %allot
! Store length
"n" operand 12 LI
12 11 cell STW
! Store tagged ptr in reg
"array" get object %store-tagged
] H{
{ +input+ { { [ ] "n" } } }
{ +scratch+ { { f "array" } } }
{ +output+ { "array" } }
} define-intrinsic
\ <ratio> [
ratio 3 cells %allot
"numerator" operand 11 1 cells STW
"denominator" operand 11 2 cells STW
! Store tagged ptr in reg
"ratio" get ratio %store-tagged
] H{
{ +input+ { { f "numerator" } { f "denominator" } } }
{ +scratch+ { { f "ratio" } } }
{ +output+ { "ratio" } }
} define-intrinsic
\ <complex> [
complex 3 cells %allot
"real" operand 11 1 cells STW
"imaginary" operand 11 2 cells STW
! Store tagged ptr in reg
"complex" get complex %store-tagged
] H{
{ +input+ { { f "real" } { f "imaginary" } } }
{ +scratch+ { { f "complex" } } }
{ +output+ { "complex" } }
} define-intrinsic
\ <wrapper> [
wrapper 2 cells %allot
"obj" operand 11 1 cells STW
! Store tagged ptr in reg
"wrapper" get object %store-tagged
] H{
{ +input+ { { f "obj" } } }
{ +scratch+ { { f "wrapper" } } }
{ +output+ { "wrapper" } }
} define-intrinsic
! Alien intrinsics
: %alien-accessor ( quot -- )
"offset" operand dup %untag-fixnum
"scratch" operand "offset" operand "alien" operand ADD
"value" operand "scratch" operand 0 roll call ; inline
: alien-integer-get-template
H{
{ +input+ {
{ unboxed-c-ptr "alien" c-ptr }
{ f "offset" fixnum }
} }
{ +scratch+ { { f "value" } { f "scratch" } } }
{ +output+ { "value" } }
{ +clobber+ { "offset" } }
} ;
: %alien-integer-get ( quot -- )
%alien-accessor
"value" operand dup %tag-fixnum ; inline
: alien-integer-set-template
H{
{ +input+ {
{ f "value" fixnum }
{ unboxed-c-ptr "alien" c-ptr }
{ f "offset" fixnum }
} }
{ +scratch+ { { f "scratch" } } }
{ +clobber+ { "value" "offset" } }
} ;
: %alien-integer-set ( quot -- )
"offset" get "value" get = [
"value" operand dup %untag-fixnum
] unless
%alien-accessor ; inline
: define-alien-integer-intrinsics ( word get-quot word set-quot -- )
[ %alien-integer-set ] curry
alien-integer-set-template
define-intrinsic
[ %alien-integer-get ] curry
alien-integer-get-template
define-intrinsic ;
\ alien-unsigned-1 [ LBZ ]
\ set-alien-unsigned-1 [ STB ]
define-alien-integer-intrinsics
\ alien-signed-1 [ pick >r LBZ r> dup EXTSB ]
\ set-alien-signed-1 [ STB ]
define-alien-integer-intrinsics
\ alien-unsigned-2 [ LHZ ]
\ set-alien-unsigned-2 [ STH ]
define-alien-integer-intrinsics
\ alien-signed-2 [ LHA ]
\ set-alien-signed-2 [ STH ]
define-alien-integer-intrinsics
\ alien-cell [
[ LWZ ] %alien-accessor
] H{
{ +input+ {
{ unboxed-c-ptr "alien" c-ptr }
{ f "offset" fixnum }
} }
{ +scratch+ { { unboxed-alien "value" } { f "scratch" } } }
{ +output+ { "value" } }
{ +clobber+ { "offset" } }
} define-intrinsic
\ set-alien-cell [
[ STW ] %alien-accessor
] H{
{ +input+ {
{ unboxed-c-ptr "value" pinned-c-ptr }
{ unboxed-c-ptr "alien" c-ptr }
{ f "offset" fixnum }
} }
{ +scratch+ { { f "scratch" } } }
{ +clobber+ { "offset" } }
} define-intrinsic
: alien-float-get-template
H{
{ +input+ {
{ unboxed-c-ptr "alien" c-ptr }
{ f "offset" fixnum }
} }
{ +scratch+ { { float "value" } { f "scratch" } } }
{ +output+ { "value" } }
{ +clobber+ { "offset" } }
} ;
: alien-float-set-template
H{
{ +input+ {
{ float "value" float }
{ unboxed-c-ptr "alien" c-ptr }
{ f "offset" fixnum }
} }
{ +scratch+ { { f "scratch" } } }
{ +clobber+ { "offset" } }
} ;
: define-alien-float-intrinsics ( word get-quot word set-quot -- )
[ %alien-accessor ] curry
alien-float-set-template
define-intrinsic
[ %alien-accessor ] curry
alien-float-get-template
define-intrinsic ;
\ alien-double [ LFD ]
\ set-alien-double [ STFD ]
define-alien-float-intrinsics
\ alien-float [ LFS ]
\ set-alien-float [ STFS ]
define-alien-float-intrinsics

View File

@ -1 +0,0 @@
unportable

View File

@ -1,8 +1,15 @@
USING: accessors cpu.ppc.architecture cpu.ppc.intrinsics
cpu.architecture namespaces alien.c-types kernel system
combinators ;
! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
IN: cpu.ppc.architecture
{
! PowerPC register assignments
! r3-r11, r16-r31: integer vregs
! f0-f13: float vregs
! r12: scratch
! r14: data stack
! r15: retain stack
<< {
{ [ os macosx? ] [
4 "longlong" c-type (>>align)
4 "ulonglong" c-type (>>align)
@ -12,4 +19,545 @@ combinators ;
t "longlong" c-type (>>stack-align?)
t "ulonglong" c-type (>>stack-align?)
] }
} cond
} cond >>
M: ppc machine-registers
{
{ int-regs { 3 4 5 6 7 8 9 10 11 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 } }
{ double-float-regs { 0 1 2 3 4 5 6 7 8 9 10 11 12 13 } }
} ;
: scratch-reg 12 ; inline
M: ppc two-operand? t ;
M: ppc %load-immediate ( reg n -- ) swap LOAD ;
M:: ppc %load-indirect ( reg obj -- )
0 reg LOAD32
obj rc-absolute-ppc-2/2 rel-literal
reg reg 0 LWZ ;
: ds-reg 14 ; inline
: rs-reg 15 ; inline
GENERIC: loc-reg ( loc -- reg )
M: ds-loc log-reg drop ds-reg ;
M: rs-loc log-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 -- ) dup rot cells ADDI ; inline
M: ppc %inc-d ( n -- ) ds-reg (%inc) ;
M: ppc %inc-r ( n -- ) rs-reg (%inc) ;
: reserved-area-size ( -- n )
os {
{ linux [ 2 ] }
{ macosx [ 6 ] }
} case cells ; foldable
: lr-save ( -- n )
os {
{ linux [ 1 ] }
{ macosx [ 2 ] }
} case cells ; foldable
: param@ ( n -- x ) reserved-area-size + ; inline
: param-save-size ( -- n ) 8 cells ; foldable
: local@ ( n -- x )
reserved-area-size param-save-size + + ; inline
: factor-area-size ( -- n ) 2 cells ; foldable
: next-save ( n -- i ) cell - ;
: xt-save ( n -- i ) 2 cells - ;
M: ppc stack-frame-size ( stack-frame -- i )
local@ factor-area-size + 4 cells align ;
! M: x86 stack-frame-size ( stack-frame -- i )
! [ spill-counts>> [ swap reg-size * ] { } assoc>map sum ]
! [ params>> ]
! [ return>> ]
! tri + +
! 3 cells +
! align-stack ;
M: ppc %call ( label -- ) BL ;
M: ppc %jump-label ( label -- ) B ;
M: ppc %return ( -- ) BLR ;
M:: ppc %dispatch ( src temp -- )
0 temp LOAD32 rc-absolute-ppc-2/2 rel-here
temp temp src ADD
temp temp 5 cells LWZ
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
: (%slot-imm) ( obj slot tag -- reg offset )
[ cells ] dip - ; inline
M: ppc %slot ( dst obj slot tag temp -- ) (%slot) LWZ ;
M: ppc %slot-imm ( dst obj slot tag -- ) (%slot-imm) LWZ ;
M: ppc %set-slot ( src obj slot tag temp -- ) (%slot) STW ;
M: ppc %set-slot-imm ( src obj slot tag -- ) (%slot-imm) STW ;
M: ppc %add ADD ;
M: ppc %add-imm ADDI ;
M: ppc %sub swapd 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-imm swapd SLWI ;
M: ppc %shr-imm swapd SRWI ;
M: ppc %sar-imm SRAWI ;
M: ppc %not NOT ;
M: ppc %integer>bignum ( dst src temp -- )
[
{ "end" "non-zero" "pos" "store" } [ define-label ] each
! is it zero?
0 over v>operand 0 CMPI
"non-zero" get BNE
dup 0 >bignum %load-literal
"end" get B
! it is non-zero
"non-zero" resolve-label
1 bignum over 3 + cells %allot
1+ v>operand 12 LI ! compute the length
12 11 cell STW ! store the length
! is the fixnum negative?
0 over v>operand 0 CMPI
"pos" get BGE
1 12 LI
! store negative sign
12 11 2 cells STW
! negate fixnum
dup v>operand dup -1 MULI
"store" get B
"pos" resolve-label
0 12 LI
! store positive sign
12 11 2 cells STW
"store" resolve-label
! store the number
dup v>operand 11 3 cells STW
! tag the bignum, store it in reg
bignum %store-tagged
"end" resolve-label
] with-scope ;
: bignum@ ( n -- offset ) cells bignum tag-number - ; inline
M:: %bignum>integer ( dst src -- )
[
"end" define-label
scratch-reg src 1 bignum@ LWZ
! if the length is 1, its just the sign and nothing else,
! so output 0
0 dst LI
0 scratch-reg 1 v>operand CMPI
"end" get BEQ
! load the value
dst src 3 bignum@ LWZ
! load the sign
scratch-reg src 2 bignum@ LWZ
! branchless arithmetic: we want to turn 0 into 1,
! and 1 into -1
scratch-reg scratch-reg 1 SLWI
scratch-reg scratch-reg NEG
scratch-reg scratch-reg 1 ADDI
! multiply value by sign
dst dst scratch-reg MULLW
"end" resolve-label
] with-scope ;
M: ppc %add-float FADD ;
M: ppc %sub-float FSUB ;
M: ppc %mul-float FMUL ;
M: ppc %div-float FDIV ;
M: ppc %integer>float
HEX: 4330 "scratch" operand LIS
"scratch" operand 1 0 param@ STW
"in" operand dup HEX: 8000 XORIS
"in" operand 1 cell param@ STW
"f1" operand 1 0 param@ LFD
4503601774854144.0 "in" operand load-indirect
"f2" operand "in" operand float-offset LFD
"f1" operand "f1" operand "f2" operand FSUB ;
M: ppc %float>integer
"scratch" operand "in" operand FCTIWZ
"scratch" operand 1 0 param@ STFD
"out" operand 1 cell param@ LWZ ;
M: ppc %copy ( dst src -- ) MR ;
M: ppc %copy-float ( dst src -- ) MFR ;
M: ppc %unbox-float ( dst src -- ) float-offset LFD ;
M:: ppc %unbox-any-c-ptr ( dst src temp -- )
[
{ "is-byte-array" "end" "start" } [ define-label ] each
! Address is computed in dst
0 dst LI
! Load object into scratch-reg
scratch-reg src MR
! We come back here with displaced aliens
"start" resolve-label
! Is the object f?
0 scratch-reg \ f tag-number CMPI
! If so, done
"end" get BEQ
! Is the object an alien?
0 scratch-reg header-offset LWZ
0 0 alien type-number tag-fixnum CMPI
"is-byte-array" get BNE
! If so, load the offset
0 scratch-reg alien-offset LWZ
! Add it to address being computed
dst dst 0 ADD
! Now recurse on the underlying alien
scratch-reg scratch-reg underlying-alien-offset LWZ
"start" get B
"is-byte-array" resolve-label
! Add byte array address to address being computed
dst dst scratch-reg ADD
! Add an offset to start of byte array's data area
dst dst byte-array-offset ADDI
"end" resolve-label
] with-scope ;
: alien@ ( n -- n' ) cells object tag-number - ;
M:: ppc %box-alien ( dst src temp -- )
[
"f" define-label
dst \ f tag-number %load-immediate
0 src 0 CMPI
"f" get BEQ
dst 4 cells alien temp %allot
! Store offset
dst src 3 alien@ STW
temp \ f tag-number %load-immediate
! Store expired slot
temp dst 1 alien@ STW
! Store underlying-alien slot
temp dst 2 alien@ STW
"f" resolve-label
] with-scope ;
M: ppc %alien-unsigned-1 0 LBZ ;
M: ppc %alien-unsigned-2 0 LHZ ;
M: ppc %alien-signed-1 dupd 0 LBZ EXTSB ;
M: ppc %alien-signed-2 0 LHA ;
M: ppc %alien-cell 0 LWZ ;
M: ppc %alien-float 0 LFS ;
M: ppc %alien-double 0 LFD ;
M: ppc %set-alien-integer-1 0 STB ;
M: ppc %set-alien-integer-2 0 STH ;
M: ppc %set-alien-cell 0 STW ;
M: ppc %set-alien-float 0 STFS ;
M: ppc %set-alien-double 0 STFD ;
: load-zone-ptr ( reg -- )
[ "nursery" f ] dip %load-dlsym ;
: load-allot-ptr ( nursery-ptr allot-ptr -- )
[ drop load-zone-ptr ] [ swap cell LWZ ] 2bi ;
:: inc-allot-ptr ( nursery-ptr n -- )
scratch-reg inc-allot-ptr 4 LWZ
scratch-reg scratch-reg n 8 align ADD
scratch-reg inc-allot-ptr 4 STW ;
:: store-header ( temp class -- )
class type-number tag-fixnum scratch-reg LI
temp scratch-reg 0 STW ;
: store-tagged ( dst tag -- )
dupd tag-number ORI ;
M:: ppc %allot ( dst size class nursery-ptr -- )
nursery-ptr dst load-allot-ptr
dst class store-header
dst class store-tagged
nursery-ptr size inc-allot-ptr ;
: %alien-global ( dest name -- )
[ f swap %load-dlsym ] [ drop dup 0 LWZ ] 2bi ;
: load-cards-offset ( dest -- )
"cards_offset" %alien-global ;
: load-decks-offset ( dest -- )
"decks_offset" %alien-global ;
M:: ppc %write-barrier ( src card# table -- )
card-mark scratch-reg LI
! Mark the card
table load-cards-offset
src card# card-bits SRWI
table scratch-reg card# STBX
! Mark the card deck
table load-decks-offset
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
0 frame-required
%prepare-alien-invoke
"minor_gc" f %alien-invoke
"end" resolve-label ;
M: ppc %prologue ( n -- )
0 scrach-reg LOAD32 rc-absolute-ppc-2/2 rel-this
0 MFLR
1 1 pick neg ADDI
scrach-reg 1 pick xt-save STW
dup scrach-reg LI
scrach-reg 1 pick next-save STW
0 1 rot lr-save + STW ;
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 pick lr-save + LWZ
1 1 rot ADDI
0 MTLR ;
:: (%boolean) ( dst word -- )
"end" define-label
\ f tag-number %load-immediate
"end" get word execute
dst \ t %load-indirect
"end" get resolve-label ; inline
: %boolean ( dst cc -- )
negate-cc {
{ cc< [ \ BLT %boolean ] }
{ cc<= [ \ BLE %boolean ] }
{ cc> [ \ BGT %boolean ] }
{ cc>= [ \ BGE %boolean ] }
{ cc= [ \ BEQ %boolean ] }
{ cc/= [ \ BNE %boolean ] }
} case ;
: (%compare) ( src1 src2 -- ) [ 0 ] dip CMP ; inline
: (%compare-imm) ( src1 src2 -- ) [ 0 ] 2dip CMPI ; inline
: (%compare-float) ( src1 src2 -- ) [ 0 ] dip FCMPU ; inline
M: ppc %compare (%compare) %boolean ;
M: ppc %compare-imm (%compare-imm) %boolean ;
M: ppc %compare-float (%compare-float) %boolean ;
: %branch ( label cc -- )
{
{ cc< [ BLT ] }
{ cc<= [ BLE ] }
{ cc> [ BGT ] }
{ cc>= [ BGE ] }
{ cc= [ BEQ ] }
{ cc/= [ BNE ] }
} case ;
M: ppc %compare-branch (%compare) %branch ;
M: ppc %compare-imm-branch (%compare-imm) %branch ;
M: ppc %compare-float-branch (%compare-float) %branch ;
! M: ppc %spill-integer ( src n -- ) spill-integer@ swap MOV ;
! M: ppc %reload-integer ( dst n -- ) spill-integer@ MOV ;
!
! M: ppc %spill-float ( src n -- ) spill-float@ swap MOVSD ;
! M: ppc %reload-float ( dst n -- ) spill-float@ MOVSD ;
M: ppc %loop-entry ;
M: int-regs return-reg drop 3 ;
M: int-regs param-regs drop { 3 4 5 6 7 8 9 10 } ;
M: float-regs return-reg drop 1 ;
M: float-regs param-regs
drop os H{
{ macosx { 1 2 3 4 5 6 7 8 9 10 11 12 13 } }
{ linux { 1 2 3 4 5 6 7 8 } }
} at ;
M: int-regs %save-param-reg drop 1 rot local@ STW ;
M: int-regs %load-param-reg drop 1 rot local@ LWZ ;
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 >r 1 rot local@ r> 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 >r 1 rot local@ r> LF ;
M: stack-params %load-param-reg ( stack reg reg-class -- )
drop >r 0 1 rot local@ LWZ 0 1 r> 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 rot next-param@ LWZ
0 1 rot local@ STW ;
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 -- )
! 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 ;
M: ppc %unbox-long-long ( n func -- )
! Value must be in r3:r4
! Call the unboxer
f %alien-invoke
! Store the return value on the C stack
[
3 1 pick local@ STW
4 1 rot cell + local@ STW
] when* ;
M: ppc %unbox-large-struct ( n c-type -- )
! Value must be in r3
! Compute destination address and load struct size
[ 4 1 rot local@ ADDI ] [ heap-size 5 LI ] bi*
! Call the function
"to_value_struct" f %alien-invoke ;
M: ppc %box ( n reg-class 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.
>r
over [ 0 over param-reg swap %load-param-reg ] [ 2drop ] if
r> f %alien-invoke ;
M: ppc %box-long-long ( n func -- )
>r [
3 1 pick local@ LWZ
4 1 rot cell + local@ LWZ
] when* r> 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 rot struct-return@ ADDI ] [ heap-size 4 LI ] bi*
! Call the function
"box_value_struct" f %alien-invoke ;
M: ppc %prepare-alien-invoke
#! Save Factor stack pointers in case the C code calls a
#! callback which does a GC, which must reliably trace
#! all roots.
"stack_chain" f 11 %load-dlsym
11 11 0 LWZ
1 11 0 STW
ds-reg 11 8 STW
rs-reg 11 12 STW ;
M: ppc %alien-invoke ( symbol dll -- )
11 %load-dlsym 11 MTLR BLRL ;
M: ppc %alien-callback ( quot -- )
3 load-indirect "c_to_factor" f %alien-invoke ;
M: ppc %prepare-alien-indirect ( -- )
"unbox_alien" f %alien-invoke
13 3 MR ;
M: ppc %alien-indirect ( -- )
13 MTLR BLRL ;
M: ppc %callback-value ( ctype -- )
! Save top of data stack
3 ds-reg 0 LWZ
3 1 0 local@ STW
! Restore data/call/retain stacks
"unnest_stacks" f %alien-invoke
! Restore top of data stack
3 1 0 local@ LWZ
! Unbox former top of data stack to return registers
unbox-return ;
M: ppc value-structs?
#! On Linux/PPC, value structs are passed in the same way
#! as reference structs, we just have to make a copy first.
os linux? not ;
M: ppc fp-shadows-int? ( -- ? ) os macosx? ;
M: ppc small-enough? ( n -- ? ) -32768 32767 between? ;
M: ppc struct-small-enough? ( size -- ? ) drop f ;
M: ppc %box-small-struct
drop "No small structs" throw ;
M: ppc %unbox-small-struct
drop "No small structs" throw ;