New PPC backend (untested)
Slava Pestov
parent
c8521ad826
commit
10d3b4a55d
|
|
@ -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 ;
|
||||
|
|
@ -1 +0,0 @@
|
|||
Slava Pestov
|
||||
|
|
@ -1 +0,0 @@
|
|||
PowerPC inline memory allocation
|
||||
|
|
@ -1 +0,0 @@
|
|||
unportable
|
||||
|
|
@ -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 ;
|
||||
|
|
@ -1 +0,0 @@
|
|||
Slava Pestov
|
||||
|
|
@ -1 +0,0 @@
|
|||
PowerPC architecture description
|
||||
|
|
@ -1 +0,0 @@
|
|||
unportable
|
||||
|
|
@ -1 +0,0 @@
|
|||
Slava Pestov
|
||||
|
|
@ -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
|
||||
|
|
@ -1 +0,0 @@
|
|||
unportable
|
||||
|
|
@ -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 ;
|
||||
|
|
|
|||
Loading…
Reference in New Issue