Merge branch 'master' of git://factorcode.org/git/factor
John Benediktsson
commit
140835ec3f
|
|
@ -1,7 +1,7 @@
|
||||||
! Copyright (C) 2008 Slava Pestov.
|
! Copyright (C) 2008 Slava Pestov.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: accessors kernel sequences sets arrays
|
USING: accessors kernel sequences sets arrays math strings fry
|
||||||
compiler.cfg.linear-scan.live-intervals
|
prettyprint compiler.cfg.linear-scan.live-intervals
|
||||||
compiler.cfg.linear-scan.allocation ;
|
compiler.cfg.linear-scan.allocation ;
|
||||||
IN: compiler.cfg.linear-scan.debugger
|
IN: compiler.cfg.linear-scan.debugger
|
||||||
|
|
||||||
|
|
@ -21,3 +21,16 @@ IN: compiler.cfg.linear-scan.debugger
|
||||||
: check-linear-scan ( live-intervals machine-registers -- )
|
: check-linear-scan ( live-intervals machine-registers -- )
|
||||||
[ [ clone ] map ] dip allocate-registers
|
[ [ clone ] map ] dip allocate-registers
|
||||||
[ split-children ] map concat check-assigned ;
|
[ split-children ] map concat check-assigned ;
|
||||||
|
|
||||||
|
: picture ( uses -- str )
|
||||||
|
dup peek 1 + CHAR: space <string>
|
||||||
|
[ '[ CHAR: * swap _ set-nth ] each ] keep ;
|
||||||
|
|
||||||
|
: interval-picture ( interval -- str )
|
||||||
|
[ uses>> picture ]
|
||||||
|
[ copy-from>> unparse ]
|
||||||
|
[ vreg>> unparse ]
|
||||||
|
tri 3array ;
|
||||||
|
|
||||||
|
: live-intervals. ( seq -- )
|
||||||
|
[ interval-picture ] map simple-table. ;
|
||||||
|
|
|
||||||
|
|
@ -152,7 +152,7 @@ M: ##not generate-insn dst/src %not ;
|
||||||
[ dst/src ] [ temp>> register ] bi ; inline
|
[ dst/src ] [ temp>> register ] bi ; inline
|
||||||
|
|
||||||
M: ##integer>bignum generate-insn dst/src/temp %integer>bignum ;
|
M: ##integer>bignum generate-insn dst/src/temp %integer>bignum ;
|
||||||
M: ##bignum>integer generate-insn dst/src %bignum>integer ;
|
M: ##bignum>integer generate-insn dst/src/temp %bignum>integer ;
|
||||||
|
|
||||||
M: ##add-float generate-insn dst/src1/src2 %add-float ;
|
M: ##add-float generate-insn dst/src1/src2 %add-float ;
|
||||||
M: ##sub-float generate-insn dst/src1/src2 %sub-float ;
|
M: ##sub-float generate-insn dst/src1/src2 %sub-float ;
|
||||||
|
|
|
||||||
|
|
@ -76,7 +76,7 @@ HOOK: %sar-imm cpu ( dst src1 src2 -- )
|
||||||
HOOK: %not cpu ( dst src -- )
|
HOOK: %not cpu ( dst src -- )
|
||||||
|
|
||||||
HOOK: %integer>bignum cpu ( dst src temp -- )
|
HOOK: %integer>bignum cpu ( dst src temp -- )
|
||||||
HOOK: %bignum>integer cpu ( dst src -- )
|
HOOK: %bignum>integer cpu ( dst src temp -- )
|
||||||
|
|
||||||
HOOK: %add-float cpu ( dst src1 src2 -- )
|
HOOK: %add-float cpu ( dst src1 src2 -- )
|
||||||
HOOK: %sub-float cpu ( dst src1 src2 -- )
|
HOOK: %sub-float cpu ( dst src1 src2 -- )
|
||||||
|
|
|
||||||
|
|
@ -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
|
|
||||||
|
|
@ -11,8 +11,8 @@ big-endian on
|
||||||
|
|
||||||
4 jit-code-format set
|
4 jit-code-format set
|
||||||
|
|
||||||
: ds-reg 14 ;
|
: ds-reg 30 ;
|
||||||
: rs-reg 15 ;
|
: rs-reg 31 ;
|
||||||
|
|
||||||
: factor-area-size ( -- n ) 4 bootstrap-cells ;
|
: factor-area-size ( -- n ) 4 bootstrap-cells ;
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -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,32 @@
|
||||||
USING: accessors cpu.ppc.architecture cpu.ppc.intrinsics
|
! Copyright (C) 2005, 2008 Slava Pestov.
|
||||||
cpu.architecture namespaces alien.c-types kernel system
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
combinators ;
|
USING: alien.c-types
|
||||||
|
accessors
|
||||||
|
cpu.architecture
|
||||||
|
compiler.cfg.registers
|
||||||
|
cpu.ppc.assembler
|
||||||
|
kernel
|
||||||
|
locals
|
||||||
|
layouts
|
||||||
|
combinators
|
||||||
|
make
|
||||||
|
compiler.cfg.instructions
|
||||||
|
math.order
|
||||||
|
system
|
||||||
|
math
|
||||||
|
compiler.constants
|
||||||
|
namespaces compiler.codegen.fixup ;
|
||||||
|
IN: cpu.ppc
|
||||||
|
|
||||||
{
|
! PowerPC register assignments:
|
||||||
|
! r2-r28: integer vregs
|
||||||
|
! r29: integer scratch
|
||||||
|
! r30: data stack
|
||||||
|
! r31: retain stack
|
||||||
|
! f0-f29: float vregs
|
||||||
|
! f30, f31: float scratch
|
||||||
|
|
||||||
|
<< {
|
||||||
{ [ os macosx? ] [
|
{ [ os macosx? ] [
|
||||||
4 "longlong" c-type (>>align)
|
4 "longlong" c-type (>>align)
|
||||||
4 "ulonglong" c-type (>>align)
|
4 "ulonglong" c-type (>>align)
|
||||||
|
|
@ -12,4 +36,563 @@ combinators ;
|
||||||
t "longlong" c-type (>>stack-align?)
|
t "longlong" c-type (>>stack-align?)
|
||||||
t "ulonglong" c-type (>>stack-align?)
|
t "ulonglong" c-type (>>stack-align?)
|
||||||
] }
|
] }
|
||||||
} cond
|
} cond >>
|
||||||
|
|
||||||
|
M: ppc machine-registers
|
||||||
|
{
|
||||||
|
{ int-regs T{ range f 2 27 1 } }
|
||||||
|
{ double-float-regs T{ range f 0 28 1 } }
|
||||||
|
} ;
|
||||||
|
|
||||||
|
: scratch-reg 29 ; inline
|
||||||
|
: fp-scratch-reg-1 30 ; inline
|
||||||
|
: fp-scratch-reg-2 31 ; inline
|
||||||
|
|
||||||
|
M: ppc two-operand? f ;
|
||||||
|
|
||||||
|
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 30 ; inline
|
||||||
|
: rs-reg 31 ; 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 )
|
||||||
|
[ spill-counts>> [ swap reg-size * ] { } assoc>map sum ]
|
||||||
|
[ params>> ]
|
||||||
|
[ return>> ]
|
||||||
|
tri + +
|
||||||
|
reserved-area-size +
|
||||||
|
param-save-size +
|
||||||
|
factor-area-size +
|
||||||
|
4 cells align ;
|
||||||
|
|
||||||
|
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 ;
|
||||||
|
|
||||||
|
: bignum@ ( n -- offset ) cells bignum tag-number - ; inline
|
||||||
|
|
||||||
|
M: ppc %integer>bignum ( dst src temp -- )
|
||||||
|
[
|
||||||
|
{ "end" "non-zero" "pos" "store" } [ define-label ] each
|
||||||
|
dst 0 >bignum %load-immediate
|
||||||
|
! Is it zero? Then just go to the end and return this zero
|
||||||
|
0 src 0 CMPI
|
||||||
|
"end" get BEQ
|
||||||
|
! Allocate a bignum
|
||||||
|
dst 4 cells bignum temp %allot
|
||||||
|
! Write length
|
||||||
|
2 temp LI
|
||||||
|
dst 1 bignum@ temp STW
|
||||||
|
! Store value
|
||||||
|
dst 3 bignum@ src STW
|
||||||
|
! Compute sign
|
||||||
|
temp src MR
|
||||||
|
temp cell-bits 1- SRAWI
|
||||||
|
temp temp 1 ANDI
|
||||||
|
! Store sign
|
||||||
|
dst 2 bignum@ temp STW
|
||||||
|
! Make negative value positive
|
||||||
|
temp temp temp ADD
|
||||||
|
temp temp NEG
|
||||||
|
temp temp 1 ADDI
|
||||||
|
temp src temp MULLW
|
||||||
|
! Store the bignum
|
||||||
|
dst 3 bignum@ temp STW
|
||||||
|
"end" resolve-label
|
||||||
|
] with-scope ;
|
||||||
|
|
||||||
|
M:: %bignum>integer ( dst src temp -- )
|
||||||
|
[
|
||||||
|
"end" define-label
|
||||||
|
temp src 1 bignum@ LWZ
|
||||||
|
! if the length is 1, its just the sign and nothing else,
|
||||||
|
! so output 0
|
||||||
|
0 dst LI
|
||||||
|
0 temp 1 v>operand CMPI
|
||||||
|
"end" get BEQ
|
||||||
|
! load the value
|
||||||
|
dst src 3 bignum@ LWZ
|
||||||
|
! load the sign
|
||||||
|
temp src 2 bignum@ LWZ
|
||||||
|
! branchless arithmetic: we want to turn 0 into 1,
|
||||||
|
! and 1 into -1
|
||||||
|
temp temp temp ADD
|
||||||
|
temp temp 1 SUBI
|
||||||
|
! multiply value by sign
|
||||||
|
dst dst temp 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 ( dst src -- )
|
||||||
|
HEX: 4330 scratch-reg LIS
|
||||||
|
scratch-reg 1 0 param@ STW
|
||||||
|
scratch-reg src MR
|
||||||
|
scratch-reg dup HEX: 8000 XORIS
|
||||||
|
scratch-reg 1 cell param@ STW
|
||||||
|
fp-scratch-reg-2 1 0 param@ LFD
|
||||||
|
4503601774854144.0 scratch-reg load-indirect
|
||||||
|
fp-scratch-reg-2 scratch-reg float-offset LFD
|
||||||
|
fp-scratch-reg-2 fp-scratch-reg-2 fp-scratch-reg-2 FSUB ;
|
||||||
|
|
||||||
|
M:: ppc %float>integer ( dst src -- )
|
||||||
|
fp-scratch-reg-1 src FCTIWZ
|
||||||
|
fp-scratch-reg-2 1 0 param@ STFD
|
||||||
|
dst 1 4 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 ;
|
||||||
|
|
||||||
|
: spill-integer-base ( stack-frame -- n )
|
||||||
|
[ params>> ] [ return>> ] bi + ;
|
||||||
|
|
||||||
|
: stack@ 1 swap ; inline
|
||||||
|
|
||||||
|
: spill-integer@ ( n -- op )
|
||||||
|
cells
|
||||||
|
stack-frame get spill-integer-base
|
||||||
|
+ stack@ ;
|
||||||
|
|
||||||
|
: spill-float-base ( stack-frame -- n )
|
||||||
|
[ spill-counts>> int-regs swap at int-regs reg-size * ]
|
||||||
|
[ params>> ]
|
||||||
|
[ return>> ]
|
||||||
|
tri + + ;
|
||||||
|
|
||||||
|
: spill-float@ ( n -- op )
|
||||||
|
double-float-regs reg-size *
|
||||||
|
stack-frame get spill-float-base
|
||||||
|
+ stack@ ;
|
||||||
|
|
||||||
|
M: ppc %spill-integer ( src n -- ) spill-integer@ STW ;
|
||||||
|
M: ppc %reload-integer ( dst n -- ) spill-integer@ LWZ ;
|
||||||
|
|
||||||
|
M: ppc %spill-float ( src n -- ) spill-float@ STFD ;
|
||||||
|
M: ppc %reload-float ( dst n -- ) spill-float@ LFD ;
|
||||||
|
|
||||||
|
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 ;
|
||||||
|
|
|
||||||
|
|
@ -3,7 +3,7 @@
|
||||||
USING: locals alien.c-types alien.syntax arrays kernel
|
USING: locals alien.c-types alien.syntax arrays kernel
|
||||||
math namespaces sequences system layouts io vocabs.loader
|
math namespaces sequences system layouts io vocabs.loader
|
||||||
accessors init combinators command-line cpu.x86.assembler
|
accessors init combinators command-line cpu.x86.assembler
|
||||||
cpu.x86.architecture cpu.architecture compiler compiler.units
|
cpu.x86 cpu.architecture compiler compiler.units
|
||||||
compiler.constants compiler.alien compiler.codegen
|
compiler.constants compiler.alien compiler.codegen
|
||||||
compiler.codegen.fixup compiler.cfg.instructions
|
compiler.codegen.fixup compiler.cfg.instructions
|
||||||
compiler.cfg.builder compiler.cfg.intrinsics ;
|
compiler.cfg.builder compiler.cfg.intrinsics ;
|
||||||
|
|
|
||||||
|
|
@ -3,7 +3,7 @@
|
||||||
USING: accessors arrays kernel math namespaces make sequences
|
USING: accessors arrays kernel math namespaces make sequences
|
||||||
system layouts alien alien.c-types alien.accessors alien.structs
|
system layouts alien alien.c-types alien.accessors alien.structs
|
||||||
slots splitting assocs combinators cpu.x86.assembler
|
slots splitting assocs combinators cpu.x86.assembler
|
||||||
cpu.x86.architecture cpu.architecture compiler.constants
|
cpu.x86 cpu.architecture compiler.constants
|
||||||
compiler.codegen compiler.codegen.fixup
|
compiler.codegen compiler.codegen.fixup
|
||||||
compiler.cfg.instructions compiler.cfg.builder
|
compiler.cfg.instructions compiler.cfg.builder
|
||||||
compiler.cfg.intrinsics ;
|
compiler.cfg.intrinsics ;
|
||||||
|
|
|
||||||
|
|
@ -1 +0,0 @@
|
||||||
Slava Pestov
|
|
||||||
|
|
@ -1 +0,0 @@
|
||||||
unportable
|
|
||||||
|
|
@ -271,9 +271,7 @@ big-endian off
|
||||||
: jit-math ( insn -- )
|
: jit-math ( insn -- )
|
||||||
arg0 ds-reg [] MOV ! load second input
|
arg0 ds-reg [] MOV ! load second input
|
||||||
ds-reg bootstrap-cell SUB ! pop stack
|
ds-reg bootstrap-cell SUB ! pop stack
|
||||||
arg1 ds-reg [] MOV ! load first input
|
[ ds-reg [] arg0 ] dip execute ! compute result
|
||||||
[ arg1 arg0 ] dip execute ! compute result
|
|
||||||
ds-reg [] arg1 MOV ! push result
|
|
||||||
;
|
;
|
||||||
|
|
||||||
[ \ ADD jit-math ] f f f \ fixnum+fast define-sub-primitive
|
[ \ ADD jit-math ] f f f \ fixnum+fast define-sub-primitive
|
||||||
|
|
@ -296,10 +294,8 @@ big-endian off
|
||||||
[ \ XOR jit-math ] f f f \ fixnum-bitxor define-sub-primitive
|
[ \ XOR jit-math ] f f f \ fixnum-bitxor define-sub-primitive
|
||||||
|
|
||||||
[
|
[
|
||||||
arg0 ds-reg [] MOV ! load input input
|
ds-reg [] NOT ! complement
|
||||||
arg0 NOT ! complement
|
ds-reg [] tag-mask get XOR ! clear tag bits
|
||||||
arg0 tag-mask get XOR ! clear tag bits
|
|
||||||
ds-reg [] arg0 MOV ! save
|
|
||||||
] f f f \ fixnum-bitnot define-sub-primitive
|
] f f f \ fixnum-bitnot define-sub-primitive
|
||||||
|
|
||||||
[
|
[
|
||||||
|
|
|
||||||
|
|
@ -7,7 +7,7 @@ words system layouts combinators math.order fry locals
|
||||||
compiler.constants compiler.cfg.registers
|
compiler.constants compiler.cfg.registers
|
||||||
compiler.cfg.instructions compiler.codegen
|
compiler.cfg.instructions compiler.codegen
|
||||||
compiler.codegen.fixup ;
|
compiler.codegen.fixup ;
|
||||||
IN: cpu.x86.architecture
|
IN: cpu.x86
|
||||||
|
|
||||||
M: x86 two-operand? t ;
|
M: x86 two-operand? t ;
|
||||||
|
|
||||||
|
|
@ -111,49 +111,54 @@ M:: x86 %integer>bignum ( dst src temp -- )
|
||||||
#! 1 cell header, 1 cell length, 1 cell sign, + digits
|
#! 1 cell header, 1 cell length, 1 cell sign, + digits
|
||||||
#! length is the # of digits + sign
|
#! length is the # of digits + sign
|
||||||
[
|
[
|
||||||
{ "end" "nonzero" "positive" } [ define-label ] each
|
"end" define-label
|
||||||
src 0 CMP ! is it zero?
|
! Load cached zero value
|
||||||
"nonzero" get JNE
|
|
||||||
! Use cached zero value
|
|
||||||
dst 0 >bignum %load-indirect
|
dst 0 >bignum %load-indirect
|
||||||
"end" get JMP
|
src 0 CMP
|
||||||
"nonzero" resolve-label
|
! Is it zero? Then just go to the end and return this zero
|
||||||
|
"end" get JE
|
||||||
! Allocate a bignum
|
! Allocate a bignum
|
||||||
dst 4 cells bignum temp %allot
|
dst 4 cells bignum temp %allot
|
||||||
! Write length
|
! Write length
|
||||||
dst 1 bignum@ 2 tag-fixnum MOV
|
dst 1 bignum@ 2 tag-fixnum MOV
|
||||||
! Test sign
|
! Store value
|
||||||
src 0 CMP
|
|
||||||
"positive" get JGE
|
|
||||||
dst 2 bignum@ 1 MOV ! negative sign
|
|
||||||
src NEG
|
|
||||||
dst 3 bignum@ src MOV
|
|
||||||
src NEG ! we don't want to clobber src
|
|
||||||
"end" get JMP
|
|
||||||
"positive" resolve-label
|
|
||||||
dst 2 bignum@ 0 MOV ! positive sign
|
|
||||||
dst 3 bignum@ src MOV
|
dst 3 bignum@ src MOV
|
||||||
|
! Compute sign
|
||||||
|
temp src MOV
|
||||||
|
temp cell-bits 1- SAR
|
||||||
|
temp 1 AND
|
||||||
|
! Store sign
|
||||||
|
dst 2 bignum@ temp MOV
|
||||||
|
! Make negative value positive
|
||||||
|
temp temp ADD
|
||||||
|
temp NEG
|
||||||
|
temp 1 ADD
|
||||||
|
src temp IMUL2
|
||||||
|
! Store the bignum
|
||||||
|
dst 3 bignum@ temp MOV
|
||||||
"end" resolve-label
|
"end" resolve-label
|
||||||
] with-scope ;
|
] with-scope ;
|
||||||
|
|
||||||
M:: x86 %bignum>integer ( dst src -- )
|
M:: x86 %bignum>integer ( dst src temp -- )
|
||||||
[
|
[
|
||||||
"nonzero" define-label
|
|
||||||
"end" define-label
|
"end" define-label
|
||||||
dst src 1 bignum@ MOV
|
! load length
|
||||||
! if the length is 1, its just the sign and nothing else,
|
temp src 1 bignum@ MOV
|
||||||
! so output 0
|
! if the length is 1, its just the sign and nothing else,
|
||||||
dst 1 tag-fixnum CMP
|
! so output 0
|
||||||
"nonzero" get JNE
|
|
||||||
dst 0 MOV
|
dst 0 MOV
|
||||||
"end" get JMP
|
temp 1 tag-fixnum CMP
|
||||||
"nonzero" resolve-label
|
"end" get JE
|
||||||
! load the value
|
! load the value
|
||||||
dst src 3 bignum@ MOV
|
dst src 3 bignum@ MOV
|
||||||
! is the sign negative?
|
! load the sign
|
||||||
src 2 bignum@ 0 CMP
|
temp src 2 bignum@ MOV
|
||||||
"end" get JE
|
! convert it into -1 or 1
|
||||||
dst NEG
|
temp temp ADD
|
||||||
|
temp NEG
|
||||||
|
temp 1 ADD
|
||||||
|
! make dst signed
|
||||||
|
temp dst IMUL2
|
||||||
"end" resolve-label
|
"end" resolve-label
|
||||||
] with-scope ;
|
] with-scope ;
|
||||||
|
|
||||||
|
|
@ -206,21 +211,19 @@ M:: x86 %box-float ( dst src temp -- )
|
||||||
dst 16 float temp %allot
|
dst 16 float temp %allot
|
||||||
dst float-offset [+] src MOVSD ;
|
dst float-offset [+] src MOVSD ;
|
||||||
|
|
||||||
: alien@ ( reg n -- op ) cells object tag-number - [+] ;
|
: alien@ ( reg n -- op ) cells alien tag-number - [+] ;
|
||||||
|
|
||||||
M:: x86 %box-alien ( dst src temp -- )
|
M:: x86 %box-alien ( dst src temp -- )
|
||||||
[
|
[
|
||||||
{ "end" "f" } [ define-label ] each
|
"end" define-label
|
||||||
|
dst \ f tag-number MOV
|
||||||
src 0 CMP
|
src 0 CMP
|
||||||
"f" get JE
|
"end" get JE
|
||||||
dst 4 cells alien temp %allot
|
dst 4 cells alien temp %allot
|
||||||
dst 1 alien@ \ f tag-number MOV
|
dst 1 alien@ \ f tag-number MOV
|
||||||
dst 2 alien@ \ f tag-number MOV
|
dst 2 alien@ \ f tag-number MOV
|
||||||
! Store src in alien-offset slot
|
! Store src in alien-offset slot
|
||||||
dst 3 alien@ src MOV
|
dst 3 alien@ src MOV
|
||||||
"end" get JMP
|
|
||||||
"f" resolve-label
|
|
||||||
dst \ f tag-number MOV
|
|
||||||
"end" resolve-label
|
"end" resolve-label
|
||||||
] with-scope ;
|
] with-scope ;
|
||||||
|
|
||||||
|
|
@ -339,7 +342,7 @@ M: x86 %set-alien-double [ [] ] dip MOVSD ;
|
||||||
: inc-allot-ptr ( nursery-ptr n -- )
|
: inc-allot-ptr ( nursery-ptr n -- )
|
||||||
[ cell [+] ] dip 8 align ADD ;
|
[ cell [+] ] dip 8 align ADD ;
|
||||||
|
|
||||||
: store-header ( temp type -- )
|
: store-header ( temp class -- )
|
||||||
[ [] ] [ type-number tag-fixnum ] bi* MOV ;
|
[ [] ] [ type-number tag-fixnum ] bi* MOV ;
|
||||||
|
|
||||||
: store-tagged ( dst tag -- )
|
: store-tagged ( dst tag -- )
|
||||||
|
|
@ -463,11 +466,10 @@ M: x86 %compare-float-branch ( label cc src1 src2 -- )
|
||||||
M: x86 %spill-integer ( src n -- ) spill-integer@ swap MOV ;
|
M: x86 %spill-integer ( src n -- ) spill-integer@ swap MOV ;
|
||||||
M: x86 %reload-integer ( dst n -- ) spill-integer@ MOV ;
|
M: x86 %reload-integer ( dst n -- ) spill-integer@ MOV ;
|
||||||
|
|
||||||
M: x86 %spill-float spill-float@ swap MOVSD ;
|
M: x86 %spill-float ( src n -- ) spill-float@ swap MOVSD ;
|
||||||
M: x86 %reload-float spill-float@ MOVSD ;
|
M: x86 %reload-float ( dst n -- ) spill-float@ MOVSD ;
|
||||||
|
|
||||||
M: x86 %loop-entry
|
M: x86 %loop-entry 16 code-alignment [ NOP ] times ;
|
||||||
16 code-alignment [ NOP ] times ;
|
|
||||||
|
|
||||||
M: int-regs %save-param-reg drop >r stack@ r> MOV ;
|
M: int-regs %save-param-reg drop >r stack@ r> MOV ;
|
||||||
M: int-regs %load-param-reg drop swap stack@ MOV ;
|
M: int-regs %load-param-reg drop swap stack@ MOV ;
|
||||||
|
|
@ -407,7 +407,7 @@ HELP: ARTICLE:
|
||||||
} ;
|
} ;
|
||||||
|
|
||||||
HELP: ABOUT:
|
HELP: ABOUT:
|
||||||
{ $syntax "MAIN: article" }
|
{ $syntax "ABOUT: article" }
|
||||||
{ $values { "article" "a help article" } }
|
{ $values { "article" "a help article" } }
|
||||||
{ $description "Defines the main documentation article for the current vocabulary." } ;
|
{ $description "Defines the main documentation article for the current vocabulary." } ;
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -134,6 +134,20 @@ PRIVATE>
|
||||||
|
|
||||||
: pprint-cell ( obj -- ) [ pprint ] with-cell ;
|
: pprint-cell ( obj -- ) [ pprint ] with-cell ;
|
||||||
|
|
||||||
|
: simple-table. ( values -- )
|
||||||
|
standard-table-style [
|
||||||
|
[
|
||||||
|
[
|
||||||
|
[
|
||||||
|
dup string?
|
||||||
|
[ [ write ] with-cell ]
|
||||||
|
[ pprint-cell ]
|
||||||
|
if
|
||||||
|
] each
|
||||||
|
] with-row
|
||||||
|
] each
|
||||||
|
] tabular-output ;
|
||||||
|
|
||||||
GENERIC: see ( defspec -- )
|
GENERIC: see ( defspec -- )
|
||||||
|
|
||||||
: comment. ( string -- )
|
: comment. ( string -- )
|
||||||
|
|
|
||||||
|
|
@ -7,20 +7,6 @@ IN: tools.time
|
||||||
: benchmark ( quot -- runtime )
|
: benchmark ( quot -- runtime )
|
||||||
millis >r call millis r> - ; inline
|
millis >r call millis r> - ; inline
|
||||||
|
|
||||||
: simple-table. ( values -- )
|
|
||||||
standard-table-style [
|
|
||||||
[
|
|
||||||
[
|
|
||||||
[
|
|
||||||
dup string?
|
|
||||||
[ [ write ] with-cell ]
|
|
||||||
[ pprint-cell ]
|
|
||||||
if
|
|
||||||
] each
|
|
||||||
] with-row
|
|
||||||
] each
|
|
||||||
] tabular-output ;
|
|
||||||
|
|
||||||
: time. ( data -- )
|
: time. ( data -- )
|
||||||
unclip
|
unclip
|
||||||
"==== RUNNING TIME" print nl pprint " ms" print nl
|
"==== RUNNING TIME" print nl pprint " ms" print nl
|
||||||
|
|
|
||||||
|
|
@ -117,7 +117,7 @@ ARTICLE: "ui-workspace-keys" "UI keyboard shortcuts"
|
||||||
{ $heading "Implementation" }
|
{ $heading "Implementation" }
|
||||||
"Workspaces are instances of " { $link workspace } "." ;
|
"Workspaces are instances of " { $link workspace } "." ;
|
||||||
|
|
||||||
ARTICLE: "ui-tools" "UI development tools"
|
ARTICLE: "ui-tools" "UI developer tools"
|
||||||
"The Factor development environment can seem rather different from what you are used to, because it is very simple and powerful.."
|
"The Factor development environment can seem rather different from what you are used to, because it is very simple and powerful.."
|
||||||
$nl
|
$nl
|
||||||
"To take full advantage of the UI, you should be using a supported text editor. See " { $link "editor" } "."
|
"To take full advantage of the UI, you should be using a supported text editor. See " { $link "editor" } "."
|
||||||
|
|
|
||||||
|
|
@ -4,21 +4,15 @@ USING: help.markup help.syntax io.streams.string kernel quotations sequences str
|
||||||
IN: unix.groups
|
IN: unix.groups
|
||||||
|
|
||||||
HELP: all-groups
|
HELP: all-groups
|
||||||
{ $values
|
{ $values { "seq" sequence } }
|
||||||
|
|
||||||
{ "seq" sequence } }
|
|
||||||
{ $description "Returns a sequence of " { $link group } " tuples that are platform-dependent and field for field complete with the Unix " { $link group } " structure." } ;
|
{ $description "Returns a sequence of " { $link group } " tuples that are platform-dependent and field for field complete with the Unix " { $link group } " structure." } ;
|
||||||
|
|
||||||
HELP: effective-group-id
|
HELP: effective-group-id
|
||||||
{ $values
|
{ $values { "string" string } }
|
||||||
|
|
||||||
{ "string" string } }
|
|
||||||
{ $description "Returns the effective group id for the current user." } ;
|
{ $description "Returns the effective group id for the current user." } ;
|
||||||
|
|
||||||
HELP: effective-group-name
|
HELP: effective-group-name
|
||||||
{ $values
|
{ $values { "string" string } }
|
||||||
|
|
||||||
{ "string" string } }
|
|
||||||
{ $description "Returns the effective group name for the current user." } ;
|
{ $description "Returns the effective group name for the current user." } ;
|
||||||
|
|
||||||
HELP: group
|
HELP: group
|
||||||
|
|
@ -46,15 +40,11 @@ HELP: group-struct
|
||||||
{ $description "Returns an alien group struct to be turned into a group tuple by calling subsequent words." } ;
|
{ $description "Returns an alien group struct to be turned into a group tuple by calling subsequent words." } ;
|
||||||
|
|
||||||
HELP: real-group-id
|
HELP: real-group-id
|
||||||
{ $values
|
{ $values { "id" integer } }
|
||||||
|
|
||||||
{ "id" integer } }
|
|
||||||
{ $description "Returns the real group id for the current user." } ;
|
{ $description "Returns the real group id for the current user." } ;
|
||||||
|
|
||||||
HELP: real-group-name
|
HELP: real-group-name
|
||||||
{ $values
|
{ $values { "string" string } }
|
||||||
|
|
||||||
{ "string" string } }
|
|
||||||
{ $description "Returns the real group name for the current user." } ;
|
{ $description "Returns the real group name for the current user." } ;
|
||||||
|
|
||||||
HELP: set-effective-group
|
HELP: set-effective-group
|
||||||
|
|
@ -88,8 +78,9 @@ HELP: with-real-group
|
||||||
{ "string/id" "a string or a group id" } { "quot" quotation } }
|
{ "string/id" "a string or a group id" } { "quot" quotation } }
|
||||||
{ $description "Sets the real group name and calls the quotation. Restores the current group name on success or on error after the call." } ;
|
{ $description "Sets the real group name and calls the quotation. Restores the current group name on success or on error after the call." } ;
|
||||||
|
|
||||||
ARTICLE: "unix.groups" "unix.groups"
|
ARTICLE: "unix.groups" "Unix groups"
|
||||||
"The " { $vocab-link "unix.groups" } " vocabulary contains words that return information about Unix groups."
|
"The " { $vocab-link "unix.groups" } " vocabulary contains words that return information about Unix groups."
|
||||||
|
$nl
|
||||||
"Listing all groups:"
|
"Listing all groups:"
|
||||||
{ $subsection all-groups }
|
{ $subsection all-groups }
|
||||||
"Returning a passwd tuple:"
|
"Returning a passwd tuple:"
|
||||||
|
|
|
||||||
|
|
@ -4,27 +4,19 @@ USING: help.markup help.syntax io.streams.string kernel quotations sequences str
|
||||||
IN: unix.users
|
IN: unix.users
|
||||||
|
|
||||||
HELP: all-users
|
HELP: all-users
|
||||||
{ $values
|
{ $values { "seq" sequence } }
|
||||||
|
|
||||||
{ "seq" sequence } }
|
|
||||||
{ $description "Returns a sequence of high-level " { $link passwd } " tuples that are platform-dependent and field for field complete with the Unix " { $link passwd } " structure." } ;
|
{ $description "Returns a sequence of high-level " { $link passwd } " tuples that are platform-dependent and field for field complete with the Unix " { $link passwd } " structure." } ;
|
||||||
|
|
||||||
HELP: effective-username
|
HELP: effective-username
|
||||||
{ $values
|
{ $values { "string" string } }
|
||||||
|
|
||||||
{ "string" string } }
|
|
||||||
{ $description "Returns the effective username for the current user." } ;
|
{ $description "Returns the effective username for the current user." } ;
|
||||||
|
|
||||||
HELP: effective-user-id
|
HELP: effective-user-id
|
||||||
{ $values
|
{ $values { "id" integer } }
|
||||||
|
|
||||||
{ "id" integer } }
|
|
||||||
{ $description "Returns the effective username id for the current user." } ;
|
{ $description "Returns the effective username id for the current user." } ;
|
||||||
|
|
||||||
HELP: new-passwd
|
HELP: new-passwd
|
||||||
{ $values
|
{ $values { "passwd" passwd } }
|
||||||
|
|
||||||
{ "passwd" passwd } }
|
|
||||||
{ $description "Creates a new passwd tuple dependent on the operating system." } ;
|
{ $description "Creates a new passwd tuple dependent on the operating system." } ;
|
||||||
|
|
||||||
HELP: passwd
|
HELP: passwd
|
||||||
|
|
@ -40,25 +32,19 @@ HELP: passwd>new-passwd
|
||||||
{ $description "A platform-specific conversion routine from a passwd structure to a passwd tuple." } ;
|
{ $description "A platform-specific conversion routine from a passwd structure to a passwd tuple." } ;
|
||||||
|
|
||||||
HELP: real-username
|
HELP: real-username
|
||||||
{ $values
|
{ $values { "string" string } }
|
||||||
|
|
||||||
{ "string" string } }
|
|
||||||
{ $description "The real username of the current user." } ;
|
{ $description "The real username of the current user." } ;
|
||||||
|
|
||||||
HELP: real-user-id
|
HELP: real-user-id
|
||||||
{ $values
|
{ $values { "id" integer } }
|
||||||
|
|
||||||
{ "id" integer } }
|
|
||||||
{ $description "The real user id of the current user." } ;
|
{ $description "The real user id of the current user." } ;
|
||||||
|
|
||||||
HELP: set-effective-user
|
HELP: set-effective-user
|
||||||
{ $values
|
{ $values { "string/id" "a string or a user id" } }
|
||||||
{ "string/id" "a string or a user id" } }
|
|
||||||
{ $description "Sets the current effective user given a username or a user id." } ;
|
{ $description "Sets the current effective user given a username or a user id." } ;
|
||||||
|
|
||||||
HELP: set-real-user
|
HELP: set-real-user
|
||||||
{ $values
|
{ $values { "string/id" "a string or a user id" } }
|
||||||
{ "string/id" "a string or a user id" } }
|
|
||||||
{ $description "Sets the current real user given a username or a user id." } ;
|
{ $description "Sets the current real user given a username or a user id." } ;
|
||||||
|
|
||||||
HELP: user-passwd
|
HELP: user-passwd
|
||||||
|
|
@ -100,8 +86,9 @@ HELP: with-real-user
|
||||||
set-effective-user
|
set-effective-user
|
||||||
} related-words
|
} related-words
|
||||||
|
|
||||||
ARTICLE: "unix.users" "unix.users"
|
ARTICLE: "unix.users" "Unix users"
|
||||||
"The " { $vocab-link "unix.users" } " vocabulary contains words that return information about Unix users."
|
"The " { $vocab-link "unix.users" } " vocabulary contains words that return information about Unix users."
|
||||||
|
$nl
|
||||||
"Listing all users:"
|
"Listing all users:"
|
||||||
{ $subsection all-users }
|
{ $subsection all-users }
|
||||||
"Returning a passwd tuple:"
|
"Returning a passwd tuple:"
|
||||||
|
|
|
||||||
|
|
@ -1,6 +1,6 @@
|
||||||
! Copyright (C) 2008 Eduardo Cavazos, Slava Pestov.
|
! Copyright (C) 2008 Eduardo Cavazos, Slava Pestov.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: kernel system accessors namespaces splitting sequences make
|
USING: kernel system accessors namespaces splitting sequences
|
||||||
mason.config ;
|
mason.config ;
|
||||||
IN: mason.platform
|
IN: mason.platform
|
||||||
|
|
||||||
|
|
@ -10,10 +10,8 @@ IN: mason.platform
|
||||||
: gnu-make ( -- string )
|
: gnu-make ( -- string )
|
||||||
target-os get { "freebsd" "openbsd" "netbsd" } member? "gmake" "make" ? ;
|
target-os get { "freebsd" "openbsd" "netbsd" } member? "gmake" "make" ? ;
|
||||||
|
|
||||||
|
: boot-image-arch ( -- string )
|
||||||
|
target-cpu get dup "ppc" = [ target-os get "-" append prepend ] when ;
|
||||||
|
|
||||||
: boot-image-name ( -- string )
|
: boot-image-name ( -- string )
|
||||||
[
|
"boot." boot-image-arch ".image" 3append ;
|
||||||
"boot." %
|
|
||||||
target-cpu get "ppc" = [ target-os get % "-" % ] when
|
|
||||||
target-cpu get %
|
|
||||||
".image" %
|
|
||||||
] "" make ;
|
|
||||||
|
|
|
||||||
|
|
@ -20,7 +20,8 @@ IN: mason.updates
|
||||||
= not ;
|
= not ;
|
||||||
|
|
||||||
: new-image-available? ( -- ? )
|
: new-image-available? ( -- ? )
|
||||||
boot-image-name need-new-image? [ download-my-image t ] [ f ] if ;
|
boot-image-name need-new-image?
|
||||||
|
[ boot-image-arch download-image t ] [ f ] if ;
|
||||||
|
|
||||||
: new-code-available? ( -- ? )
|
: new-code-available? ( -- ? )
|
||||||
updates-available?
|
updates-available?
|
||||||
|
|
|
||||||
233
vm/cpu-ppc.S
233
vm/cpu-ppc.S
|
|
@ -4,30 +4,32 @@ in the public domain. */
|
||||||
|
|
||||||
/* Note that the XT is passed to the quotation in r11 */
|
/* Note that the XT is passed to the quotation in r11 */
|
||||||
#define CALL_OR_JUMP_QUOT \
|
#define CALL_OR_JUMP_QUOT \
|
||||||
lwz r11,9(r3) /* load quotation-xt slot */ XX \
|
lwz r11,9(r3) /* load quotation-xt slot */ XX \
|
||||||
|
|
||||||
#define CALL_QUOT \
|
#define CALL_QUOT \
|
||||||
CALL_OR_JUMP_QUOT XX \
|
CALL_OR_JUMP_QUOT XX \
|
||||||
mtlr r11 /* prepare to call XT with quotation in r3 */ XX \
|
mtlr r11 /* prepare to call XT with quotation in r3 */ XX \
|
||||||
blrl /* go */
|
blrl /* go */
|
||||||
|
|
||||||
#define JUMP_QUOT \
|
#define JUMP_QUOT \
|
||||||
CALL_OR_JUMP_QUOT XX \
|
CALL_OR_JUMP_QUOT XX \
|
||||||
mtctr r11 /* prepare to call XT with quotation in r3 */ XX \
|
mtctr r11 /* prepare to call XT with quotation in r3 */ XX \
|
||||||
bctr /* go */
|
bctr /* go */
|
||||||
|
|
||||||
#define PARAM_SIZE 32
|
#define PARAM_SIZE 32
|
||||||
|
|
||||||
#define SAVED_REGS_SIZE 96
|
#define SAVED_INT_REGS_SIZE 96
|
||||||
|
|
||||||
#define FRAME (RESERVED_SIZE + PARAM_SIZE + SAVED_REGS_SIZE + 8)
|
#define SAVED_FP_REGS_SIZE 144
|
||||||
|
|
||||||
|
#define FRAME (RESERVED_SIZE + PARAM_SIZE + SAVED_INT_REGS_SIZE + SAVED_FP_REGS_SIZE + 8)
|
||||||
|
|
||||||
#if defined( __APPLE__)
|
#if defined( __APPLE__)
|
||||||
#define LR_SAVE 8
|
#define LR_SAVE 8
|
||||||
#define RESERVED_SIZE 24
|
#define RESERVED_SIZE 24
|
||||||
#else
|
#else
|
||||||
#define LR_SAVE 4
|
#define LR_SAVE 4
|
||||||
#define RESERVED_SIZE 8
|
#define RESERVED_SIZE 8
|
||||||
#endif
|
#endif
|
||||||
|
|
||||||
#define SAVE_LR(reg) stw reg,(LR_SAVE + FRAME)(r1)
|
#define SAVE_LR(reg) stw reg,(LR_SAVE + FRAME)(r1)
|
||||||
|
|
@ -36,99 +38,142 @@ in the public domain. */
|
||||||
|
|
||||||
#define SAVE_AT(offset) (RESERVED_SIZE + PARAM_SIZE + 4 * offset)
|
#define SAVE_AT(offset) (RESERVED_SIZE + PARAM_SIZE + 4 * offset)
|
||||||
|
|
||||||
#define SAVE(register,offset) stw register,SAVE_AT(offset)(r1)
|
#define SAVE_INT(register,offset) stw register,SAVE_AT(offset)(r1)
|
||||||
|
#define RESTORE_INT(register,offset) lwz register,SAVE_AT(offset)(r1)
|
||||||
|
|
||||||
#define RESTORE(register,offset) lwz register,SAVE_AT(offset)(r1)
|
#define SAVE_FP(register,offset) stfd register,SAVE_AT(offset)(r1)
|
||||||
|
#define RESTORE_FP(register,offset) lfd register,SAVE_AT(offset)(r1)
|
||||||
|
|
||||||
#define PROLOGUE \
|
#define PROLOGUE \
|
||||||
mflr r0 XX /* get caller's return address */ \
|
mflr r0 XX /* get caller's return address */ \
|
||||||
stwu r1,-FRAME(r1) XX /* create a stack frame to hold non-volatile registers */ \
|
stwu r1,-FRAME(r1) XX /* create a stack frame to hold non-volatile registers */ \
|
||||||
SAVE_LR(r0)
|
SAVE_LR(r0)
|
||||||
|
|
||||||
#define EPILOGUE \
|
#define EPILOGUE \
|
||||||
LOAD_LR(r0) XX \
|
LOAD_LR(r0) XX \
|
||||||
lwz r1,0(r1) XX /* destroy the stack frame */ \
|
lwz r1,0(r1) XX /* destroy the stack frame */ \
|
||||||
mtlr r0 /* get ready to return */
|
mtlr r0 /* get ready to return */
|
||||||
|
|
||||||
|
/* We have to save and restore nonvolatile registers because
|
||||||
|
the Factor compiler treats the entire register file as volatile. */
|
||||||
DEF(void,c_to_factor,(CELL quot)):
|
DEF(void,c_to_factor,(CELL quot)):
|
||||||
PROLOGUE
|
PROLOGUE
|
||||||
|
|
||||||
SAVE(r13,0) /* save GPRs */
|
SAVE_INT(r13,0) /* save GPRs */
|
||||||
/* don't save ds pointer */
|
/* don't save ds pointer */
|
||||||
/* don't save rs pointer */
|
/* don't save rs pointer */
|
||||||
SAVE(r16,3)
|
SAVE_INT(r16,3)
|
||||||
SAVE(r17,4)
|
SAVE_INT(r17,4)
|
||||||
SAVE(r18,5)
|
SAVE_INT(r18,5)
|
||||||
SAVE(r19,6)
|
SAVE_INT(r19,6)
|
||||||
SAVE(r20,7)
|
SAVE_INT(r20,7)
|
||||||
SAVE(r21,8)
|
SAVE_INT(r21,8)
|
||||||
SAVE(r22,9)
|
SAVE_INT(r22,9)
|
||||||
SAVE(r23,10)
|
SAVE_INT(r23,10)
|
||||||
SAVE(r24,11)
|
SAVE_INT(r24,11)
|
||||||
SAVE(r25,12)
|
SAVE_INT(r25,12)
|
||||||
SAVE(r26,13)
|
SAVE_INT(r26,13)
|
||||||
SAVE(r27,14)
|
SAVE_INT(r27,14)
|
||||||
SAVE(r28,15)
|
SAVE_INT(r28,15)
|
||||||
SAVE(r29,16)
|
SAVE_INT(r29,16)
|
||||||
SAVE(r30,17)
|
SAVE_INT(r30,17)
|
||||||
SAVE(r31,18)
|
SAVE_INT(r31,18)
|
||||||
SAVE(r3,19) /* save quotation since we're about to mangle it */
|
|
||||||
|
|
||||||
mr r3,r1 /* pass call stack pointer as an argument */
|
SAVE_FP(f14,20) /* save FPRs */
|
||||||
|
SAVE_FP(f15,22)
|
||||||
|
SAVE_FP(f16,24)
|
||||||
|
SAVE_FP(f17,26)
|
||||||
|
SAVE_FP(f18,28)
|
||||||
|
SAVE_FP(f19,30)
|
||||||
|
SAVE_FP(f20,32)
|
||||||
|
SAVE_FP(f21,34)
|
||||||
|
SAVE_FP(f22,36)
|
||||||
|
SAVE_FP(f23,38)
|
||||||
|
SAVE_FP(f24,40)
|
||||||
|
SAVE_FP(f25,42)
|
||||||
|
SAVE_FP(f26,44)
|
||||||
|
SAVE_FP(f27,46)
|
||||||
|
SAVE_FP(f28,48)
|
||||||
|
SAVE_FP(f29,50)
|
||||||
|
SAVE_FP(f30,52)
|
||||||
|
SAVE_FP(f31,54)
|
||||||
|
|
||||||
|
SAVE_INT(r3,19) /* save quotation since we're about to mangle it */
|
||||||
|
|
||||||
|
mr r3,r1 /* pass call stack pointer as an argument */
|
||||||
bl MANGLE(save_callstack_bottom)
|
bl MANGLE(save_callstack_bottom)
|
||||||
|
|
||||||
RESTORE(r3,19) /* restore quotation */
|
RESTORE_INT(r3,19) /* restore quotation */
|
||||||
CALL_QUOT
|
CALL_QUOT
|
||||||
|
|
||||||
RESTORE(r31,18) /* restore GPRs */
|
RESTORE_FP(f31,54)
|
||||||
RESTORE(r30,17)
|
RESTORE_FP(f30,52)
|
||||||
RESTORE(r29,16)
|
RESTORE_FP(f29,50)
|
||||||
RESTORE(r28,15)
|
RESTORE_FP(f28,48)
|
||||||
RESTORE(r27,14)
|
RESTORE_FP(f27,46)
|
||||||
RESTORE(r26,13)
|
RESTORE_FP(f26,44)
|
||||||
RESTORE(r25,12)
|
RESTORE_FP(f25,42)
|
||||||
RESTORE(r24,11)
|
RESTORE_FP(f24,40)
|
||||||
RESTORE(r23,10)
|
RESTORE_FP(f23,38)
|
||||||
RESTORE(r22,9)
|
RESTORE_FP(f22,36)
|
||||||
RESTORE(r21,8)
|
RESTORE_FP(f21,34)
|
||||||
RESTORE(r20,7)
|
RESTORE_FP(f20,32)
|
||||||
RESTORE(r19,6)
|
RESTORE_FP(f19,30)
|
||||||
RESTORE(r18,5)
|
RESTORE_FP(f18,28)
|
||||||
RESTORE(r17,4)
|
RESTORE_FP(f17,26)
|
||||||
RESTORE(r16,3)
|
RESTORE_FP(f16,24)
|
||||||
/* don't restore rs pointer */
|
RESTORE_FP(f15,22)
|
||||||
/* don't restore ds pointer */
|
RESTORE_FP(f14,20) /* save FPRs */
|
||||||
RESTORE(r13,0)
|
|
||||||
|
|
||||||
EPILOGUE
|
RESTORE_INT(r31,18) /* restore GPRs */
|
||||||
blr
|
RESTORE_INT(r30,17)
|
||||||
|
RESTORE_INT(r29,16)
|
||||||
|
RESTORE_INT(r28,15)
|
||||||
|
RESTORE_INT(r27,14)
|
||||||
|
RESTORE_INT(r26,13)
|
||||||
|
RESTORE_INT(r25,12)
|
||||||
|
RESTORE_INT(r24,11)
|
||||||
|
RESTORE_INT(r23,10)
|
||||||
|
RESTORE_INT(r22,9)
|
||||||
|
RESTORE_INT(r21,8)
|
||||||
|
RESTORE_INT(r20,7)
|
||||||
|
RESTORE_INT(r19,6)
|
||||||
|
RESTORE_INT(r18,5)
|
||||||
|
RESTORE_INT(r17,4)
|
||||||
|
RESTORE_INT(r16,3)
|
||||||
|
/* don't restore rs pointer */
|
||||||
|
/* don't restore ds pointer */
|
||||||
|
RESTORE_INT(r13,0)
|
||||||
|
|
||||||
|
EPILOGUE
|
||||||
|
blr
|
||||||
|
|
||||||
/* We pass a function pointer to memcpy in r6 to work around a Mac OS X ABI
|
/* We pass a function pointer to memcpy in r6 to work around a Mac OS X ABI
|
||||||
limitation which would otherwise require us to do a bizzaro PC-relative
|
limitation which would otherwise require us to do a bizzaro PC-relative
|
||||||
trampoline to retrieve the function address */
|
trampoline to retrieve the function address */
|
||||||
DEF(void,set_callstack,(F_STACK_FRAME *to, F_STACK_FRAME *from, CELL length, void *memcpy)):
|
DEF(void,set_callstack,(F_STACK_FRAME *to, F_STACK_FRAME *from, CELL length, void *memcpy)):
|
||||||
sub r1,r3,r5 /* compute new stack pointer */
|
sub r1,r3,r5 /* compute new stack pointer */
|
||||||
mr r3,r1 /* start of destination of memcpy() */
|
mr r3,r1 /* start of destination of memcpy() */
|
||||||
stwu r1,-64(r1) /* setup fake stack frame for memcpy() */
|
stwu r1,-64(r1) /* setup fake stack frame for memcpy() */
|
||||||
mtlr r6 /* prepare to call memcpy() */
|
mtlr r6 /* prepare to call memcpy() */
|
||||||
blrl /* go */
|
blrl /* go */
|
||||||
lwz r1,0(r1) /* tear down fake stack frame */
|
lwz r1,0(r1) /* tear down fake stack frame */
|
||||||
lwz r0,LR_SAVE(r1) /* we have restored the stack; load return address */
|
lwz r0,LR_SAVE(r1) /* we have restored the stack; load return address */
|
||||||
mtlr r0 /* prepare to return to restored callstack */
|
mtlr r0 /* prepare to return to restored callstack */
|
||||||
blr /* go */
|
blr /* go */
|
||||||
|
|
||||||
DEF(void,throw_impl,(CELL quot, F_STACK_FRAME *rewind_to)):
|
DEF(void,throw_impl,(CELL quot, F_STACK_FRAME *rewind_to)):
|
||||||
mr r1,r4 /* compute new stack pointer */
|
mr r1,r4 /* compute new stack pointer */
|
||||||
lwz r0,LR_SAVE(r1) /* we have rewound the stack; load return address */
|
lwz r0,LR_SAVE(r1) /* we have rewound the stack; load return address */
|
||||||
mtlr r0
|
mtlr r0
|
||||||
JUMP_QUOT /* call the quotation */
|
JUMP_QUOT /* call the quotation */
|
||||||
|
|
||||||
DEF(void,lazy_jit_compile,(CELL quot)):
|
DEF(void,lazy_jit_compile,(CELL quot)):
|
||||||
mr r4,r1 /* save stack pointer */
|
mr r4,r1 /* save stack pointer */
|
||||||
PROLOGUE
|
PROLOGUE
|
||||||
bl MANGLE(primitive_jit_compile)
|
bl MANGLE(primitive_jit_compile)
|
||||||
EPILOGUE
|
EPILOGUE
|
||||||
JUMP_QUOT /* call the quotation */
|
JUMP_QUOT /* call the quotation */
|
||||||
|
|
||||||
/* Thanks to Joshua Grams for this code.
|
/* Thanks to Joshua Grams for this code.
|
||||||
|
|
||||||
|
|
@ -136,19 +181,19 @@ On PowerPC processors, we must flush the instruction cache manually
|
||||||
after writing to the code heap. */
|
after writing to the code heap. */
|
||||||
|
|
||||||
DEF(void,flush_icache,(void *start, int len)):
|
DEF(void,flush_icache,(void *start, int len)):
|
||||||
/* compute number of cache lines to flush */
|
/* compute number of cache lines to flush */
|
||||||
add r4,r4,r3
|
add r4,r4,r3
|
||||||
clrrwi r3,r3,5 /* align addr to next lower cache line boundary */
|
clrrwi r3,r3,5 /* align addr to next lower cache line boundary */
|
||||||
sub r4,r4,r3 /* then n_lines = (len + 0x1f) / 0x20 */
|
sub r4,r4,r3 /* then n_lines = (len + 0x1f) / 0x20 */
|
||||||
addi r4,r4,0x1f
|
addi r4,r4,0x1f
|
||||||
srwi. r4,r4,5 /* note '.' suffix */
|
srwi. r4,r4,5 /* note '.' suffix */
|
||||||
beqlr /* if n_lines == 0, just return. */
|
beqlr /* if n_lines == 0, just return. */
|
||||||
mtctr r4 /* flush cache lines */
|
mtctr r4 /* flush cache lines */
|
||||||
0: dcbf 0,r3 /* for each line... */
|
0: dcbf 0,r3 /* for each line... */
|
||||||
sync
|
sync
|
||||||
icbi 0,r3
|
icbi 0,r3
|
||||||
addi r3,r3,0x20
|
addi r3,r3,0x20
|
||||||
bdnz 0b
|
bdnz 0b
|
||||||
sync /* finish up */
|
sync /* finish up */
|
||||||
isync
|
isync
|
||||||
blr
|
blr
|
||||||
|
|
|
||||||
|
|
@ -1,8 +1,8 @@
|
||||||
#define FACTOR_CPU_STRING "ppc"
|
#define FACTOR_CPU_STRING "ppc"
|
||||||
#define F_FASTCALL
|
#define F_FASTCALL
|
||||||
|
|
||||||
register CELL ds asm("r14");
|
register CELL ds asm("r30");
|
||||||
register CELL rs asm("r15");
|
register CELL rs asm("r31");
|
||||||
|
|
||||||
void c_to_factor(CELL quot);
|
void c_to_factor(CELL quot);
|
||||||
void undefined(CELL word);
|
void undefined(CELL word);
|
||||||
|
|
|
||||||
Loading…
Reference in New Issue