PowerPC backend almost functional; some new compiler unit tests added,
better compilation of 'f eq?'; f becomes an immediate operand move aux-offset to compiler.constantsdb4
sheeple
parent
c2117d4046
commit
d2ec46e38f
|
|
@ -15,7 +15,7 @@ IN: compiler.cfg.intrinsics.alien
|
|||
|
||||
: prepare-alien-accessor ( infos -- offset-vreg )
|
||||
<reversed> [ second class>> ] [ first ] bi
|
||||
dup value-info-small-tagged? [
|
||||
dup value-info-small-fixnum? [
|
||||
literal>> (prepare-alien-accessor-imm)
|
||||
] [ drop (prepare-alien-accessor) ] if ;
|
||||
|
||||
|
|
|
|||
|
|
@ -9,7 +9,10 @@ IN: compiler.cfg.intrinsics.fixnum
|
|||
|
||||
: (emit-fixnum-imm-op) ( infos insn -- dst )
|
||||
ds-drop
|
||||
[ ds-pop ] [ second literal>> tag-fixnum ] [ ] tri*
|
||||
[ ds-pop ]
|
||||
[ second literal>> [ tag-fixnum ] [ \ f tag-number ] if* ]
|
||||
[ ]
|
||||
tri*
|
||||
call ; inline
|
||||
|
||||
: (emit-fixnum-op) ( insn -- dst )
|
||||
|
|
@ -25,7 +28,7 @@ IN: compiler.cfg.intrinsics.fixnum
|
|||
] ; inline
|
||||
|
||||
: emit-fixnum-shift-fast ( node -- )
|
||||
dup node-input-infos dup second value-info-small-tagged? [
|
||||
dup node-input-infos dup second value-info-small-fixnum? [
|
||||
nip
|
||||
[ ds-drop ds-pop ] dip
|
||||
second literal>> dup sgn {
|
||||
|
|
@ -48,7 +51,7 @@ IN: compiler.cfg.intrinsics.fixnum
|
|||
|
||||
: emit-fixnum*fast ( node -- )
|
||||
node-input-infos
|
||||
dup second value-info-small-tagged?
|
||||
dup second value-info-small-fixnum?
|
||||
[ (emit-fixnum*fast-imm) ] [ drop (emit-fixnum*fast) ] if
|
||||
ds-push ;
|
||||
|
||||
|
|
|
|||
|
|
@ -25,7 +25,7 @@ IN: compiler.cfg.intrinsics.slots
|
|||
dup node-input-infos
|
||||
dup first value-tag [
|
||||
nip
|
||||
dup second value-info-small-tagged?
|
||||
dup second value-info-small-fixnum?
|
||||
[ (emit-slot-imm) ] [ (emit-slot) ] if
|
||||
ds-push
|
||||
] [ drop emit-primitive ] if ;
|
||||
|
|
@ -46,7 +46,7 @@ IN: compiler.cfg.intrinsics.slots
|
|||
dup second value-tag [
|
||||
nip
|
||||
[
|
||||
dup third value-info-small-tagged?
|
||||
dup third value-info-small-fixnum?
|
||||
[ (emit-set-slot-imm) ] [ (emit-set-slot) ] if
|
||||
] [ first class>> immediate class<= ] bi
|
||||
[ drop ] [ i i ##write-barrier ] if
|
||||
|
|
|
|||
|
|
@ -1,12 +1,24 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors kernel math layouts make sequences
|
||||
USING: accessors kernel math layouts make sequences combinators
|
||||
cpu.architecture namespaces compiler.cfg
|
||||
compiler.cfg.instructions ;
|
||||
IN: compiler.cfg.utilities
|
||||
|
||||
: value-info-small-fixnum? ( value-info -- ? )
|
||||
literal>> {
|
||||
{ [ dup fixnum? ] [ tag-fixnum small-enough? ] }
|
||||
[ drop f ]
|
||||
} cond ;
|
||||
|
||||
: value-info-small-tagged? ( value-info -- ? )
|
||||
literal>> dup fixnum? [ tag-fixnum small-enough? ] [ drop f ] if ;
|
||||
dup literal?>> [
|
||||
literal>> {
|
||||
{ [ dup fixnum? ] [ tag-fixnum small-enough? ] }
|
||||
{ [ dup not ] [ drop t ] }
|
||||
[ drop f ]
|
||||
} cond
|
||||
] [ drop f ] if ;
|
||||
|
||||
: set-basic-block ( basic-block -- )
|
||||
[ basic-block set ] [ instructions>> building set ] bi ;
|
||||
|
|
|
|||
|
|
@ -1,49 +1,50 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: math kernel layouts system ;
|
||||
USING: math kernel layouts system strings ;
|
||||
IN: compiler.constants
|
||||
|
||||
! These constants must match vm/memory.h
|
||||
: card-bits 8 ;
|
||||
: deck-bits 18 ;
|
||||
: card-mark ( -- n ) HEX: 40 HEX: 80 bitor ;
|
||||
: card-bits 8 ; inline
|
||||
: deck-bits 18 ; inline
|
||||
: card-mark ( -- n ) HEX: 40 HEX: 80 bitor ; inline
|
||||
|
||||
! These constants must match vm/layouts.h
|
||||
: header-offset ( -- n ) object tag-number neg ;
|
||||
: float-offset ( -- n ) 8 float tag-number - ;
|
||||
: string-offset ( -- n ) 4 bootstrap-cells object tag-number - ;
|
||||
: profile-count-offset ( -- n ) 7 bootstrap-cells object tag-number - ;
|
||||
: byte-array-offset ( -- n ) 2 bootstrap-cells object tag-number - ;
|
||||
: alien-offset ( -- n ) 3 bootstrap-cells object tag-number - ;
|
||||
: underlying-alien-offset ( -- n ) bootstrap-cell object tag-number - ;
|
||||
: tuple-class-offset ( -- n ) bootstrap-cell tuple tag-number - ;
|
||||
: class-hash-offset ( -- n ) bootstrap-cell object tag-number - ;
|
||||
: word-xt-offset ( -- n ) 9 bootstrap-cells object tag-number - ;
|
||||
: quot-xt-offset ( -- n ) 3 bootstrap-cells object tag-number - ;
|
||||
: word-code-offset ( -- n ) 10 bootstrap-cells object tag-number - ;
|
||||
: array-start-offset ( -- n ) 2 bootstrap-cells object tag-number - ;
|
||||
: compiled-header-size ( -- n ) 4 bootstrap-cells ;
|
||||
: header-offset ( -- n ) object tag-number neg ; inline
|
||||
: float-offset ( -- n ) 8 float tag-number - ; inline
|
||||
: string-offset ( -- n ) 4 bootstrap-cells object tag-number - ; inline
|
||||
: string-aux-offset ( -- n ) 2 bootstrap-cells string tag-number - ; inline
|
||||
: profile-count-offset ( -- n ) 7 bootstrap-cells object tag-number - ; inline
|
||||
: byte-array-offset ( -- n ) 2 bootstrap-cells object tag-number - ; inline
|
||||
: alien-offset ( -- n ) 3 bootstrap-cells object tag-number - ; inline
|
||||
: underlying-alien-offset ( -- n ) bootstrap-cell object tag-number - ; inline
|
||||
: tuple-class-offset ( -- n ) bootstrap-cell tuple tag-number - ; inline
|
||||
: class-hash-offset ( -- n ) bootstrap-cell object tag-number - ; inline
|
||||
: word-xt-offset ( -- n ) 9 bootstrap-cells object tag-number - ; inline
|
||||
: quot-xt-offset ( -- n ) 3 bootstrap-cells object tag-number - ; inline
|
||||
: word-code-offset ( -- n ) 10 bootstrap-cells object tag-number - ; inline
|
||||
: array-start-offset ( -- n ) 2 bootstrap-cells object tag-number - ; inline
|
||||
: compiled-header-size ( -- n ) 4 bootstrap-cells ; inline
|
||||
|
||||
! Relocation classes
|
||||
: rc-absolute-cell 0 ;
|
||||
: rc-absolute 1 ;
|
||||
: rc-relative 2 ;
|
||||
: rc-absolute-ppc-2/2 3 ;
|
||||
: rc-relative-ppc-2 4 ;
|
||||
: rc-relative-ppc-3 5 ;
|
||||
: rc-relative-arm-3 6 ;
|
||||
: rc-indirect-arm 7 ;
|
||||
: rc-indirect-arm-pc 8 ;
|
||||
: rc-absolute-cell 0 ; inline
|
||||
: rc-absolute 1 ; inline
|
||||
: rc-relative 2 ; inline
|
||||
: rc-absolute-ppc-2/2 3 ; inline
|
||||
: rc-relative-ppc-2 4 ; inline
|
||||
: rc-relative-ppc-3 5 ; inline
|
||||
: rc-relative-arm-3 6 ; inline
|
||||
: rc-indirect-arm 7 ; inline
|
||||
: rc-indirect-arm-pc 8 ; inline
|
||||
|
||||
! Relocation types
|
||||
: rt-primitive 0 ;
|
||||
: rt-dlsym 1 ;
|
||||
: rt-literal 2 ;
|
||||
: rt-dispatch 3 ;
|
||||
: rt-xt 4 ;
|
||||
: rt-here 5 ;
|
||||
: rt-label 6 ;
|
||||
: rt-immediate 7 ;
|
||||
: rt-primitive 0 ; inline
|
||||
: rt-dlsym 1 ; inline
|
||||
: rt-literal 2 ; inline
|
||||
: rt-dispatch 3 ; inline
|
||||
: rt-xt 4 ; inline
|
||||
: rt-here 5 ; inline
|
||||
: rt-label 6 ; inline
|
||||
: rt-immediate 7 ; inline
|
||||
|
||||
: rc-absolute? ( n -- ? )
|
||||
[ rc-absolute-ppc-2/2 = ]
|
||||
|
|
|
|||
|
|
@ -4,7 +4,8 @@ continuations sequences.private hashtables.private byte-arrays
|
|||
strings.private system random layouts vectors
|
||||
sbufs strings.private slots.private alien math.order
|
||||
alien.accessors alien.c-types alien.syntax alien.strings
|
||||
namespaces libc sequences.private io.encodings.ascii ;
|
||||
namespaces libc sequences.private io.encodings.ascii
|
||||
classes ;
|
||||
IN: compiler.tests
|
||||
|
||||
! Make sure that intrinsic ops compile to correct code.
|
||||
|
|
@ -27,6 +28,9 @@ IN: compiler.tests
|
|||
|
||||
[ 1 ] [ { 1 2 } [ 2 slot ] compile-call ] unit-test
|
||||
[ 1 ] [ [ { 1 2 } 2 slot ] compile-call ] unit-test
|
||||
|
||||
[ { f f } ] [ 2 f <array> ] unit-test
|
||||
|
||||
[ 3 ] [ 3 1 2 2array [ { array } declare [ 2 set-slot ] keep ] compile-call first ] unit-test
|
||||
[ 3 ] [ 3 1 2 [ 2array [ 2 set-slot ] keep ] compile-call first ] unit-test
|
||||
[ 3 ] [ [ 3 1 2 2array [ 2 set-slot ] keep ] compile-call first ] unit-test
|
||||
|
|
@ -37,13 +41,19 @@ IN: compiler.tests
|
|||
! Write barrier hits on the wrong value were causing segfaults
|
||||
[ -3 ] [ -3 1 2 [ 2array [ 3 set-slot ] keep ] compile-call second ] unit-test
|
||||
|
||||
! [ CHAR: b ] [ 1 "abc" [ char-slot ] compile-call ] unit-test
|
||||
! [ CHAR: b ] [ 1 [ "abc" char-slot ] compile-call ] unit-test
|
||||
! [ CHAR: b ] [ [ 1 "abc" char-slot ] compile-call ] unit-test
|
||||
!
|
||||
! [ "axc" ] [ CHAR: x 1 "abc" [ [ set-char-slot ] keep { string } declare dup rehash-string ] compile-call ] unit-test
|
||||
! [ "axc" ] [ CHAR: x 1 [ "abc" [ set-char-slot ] keep { string } declare dup rehash-string ] compile-call ] unit-test
|
||||
! [ "axc" ] [ CHAR: x [ 1 "abc" [ set-char-slot ] keep { string } declare dup rehash-string ] compile-call ] unit-test
|
||||
[ CHAR: a ] [ 0 "abc" [ string-nth ] compile-call ] unit-test
|
||||
[ CHAR: a ] [ 0 [ "abc" string-nth ] compile-call ] unit-test
|
||||
[ CHAR: a ] [ [ 0 "abc" string-nth ] compile-call ] unit-test
|
||||
[ CHAR: b ] [ 1 "abc" [ string-nth ] compile-call ] unit-test
|
||||
[ CHAR: b ] [ 1 [ "abc" string-nth ] compile-call ] unit-test
|
||||
[ CHAR: b ] [ [ 1 "abc" string-nth ] compile-call ] unit-test
|
||||
|
||||
[ HEX: 123456 ] [ 0 "\u123456bc" [ string-nth ] compile-call ] unit-test
|
||||
[ HEX: 123456 ] [ 0 [ "\u123456bc" string-nth ] compile-call ] unit-test
|
||||
[ HEX: 123456 ] [ [ 0 "\u123456bc" string-nth ] compile-call ] unit-test
|
||||
[ HEX: 123456 ] [ 1 "a\u123456c" [ string-nth ] compile-call ] unit-test
|
||||
[ HEX: 123456 ] [ 1 [ "a\u123456c" string-nth ] compile-call ] unit-test
|
||||
[ HEX: 123456 ] [ [ 1 "a\u123456c" string-nth ] compile-call ] unit-test
|
||||
|
||||
[ ] [ [ 0 getenv ] compile-call drop ] unit-test
|
||||
[ ] [ 1 getenv [ 1 setenv ] compile-call ] unit-test
|
||||
|
|
@ -158,6 +168,10 @@ IN: compiler.tests
|
|||
[ 4 ] [ 1 [ 3 fixnum+fast ] compile-call ] unit-test
|
||||
[ 4 ] [ [ 1 3 fixnum+fast ] compile-call ] unit-test
|
||||
|
||||
[ -2 ] [ 1 3 [ fixnum-fast ] compile-call ] unit-test
|
||||
[ -2 ] [ 1 [ 3 fixnum-fast ] compile-call ] unit-test
|
||||
[ -2 ] [ [ 1 3 fixnum-fast ] compile-call ] unit-test
|
||||
|
||||
[ 30001 ] [ 1 [ 30000 fixnum+fast ] compile-call ] unit-test
|
||||
|
||||
[ 6 ] [ 2 3 [ fixnum*fast ] compile-call ] unit-test
|
||||
|
|
@ -263,6 +277,8 @@ cell 8 = [
|
|||
|
||||
: compiled-fixnum>bignum fixnum>bignum ;
|
||||
|
||||
[ bignum ] [ 0 compiled-fixnum>bignum class ] unit-test
|
||||
|
||||
[ ] [
|
||||
10000 [
|
||||
32 random-bits >fixnum
|
||||
|
|
|
|||
|
|
@ -1,21 +1,10 @@
|
|||
! Copyright (C) 2005, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
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 ;
|
||||
USING: accessors assocs sequences kernel combinators make math
|
||||
math.order math.ranges system namespaces locals layouts words
|
||||
alien alien.c-types cpu.architecture cpu.ppc.assembler
|
||||
compiler.cfg.registers compiler.cfg.instructions
|
||||
compiler.constants compiler.codegen compiler.codegen.fixup ;
|
||||
IN: cpu.ppc
|
||||
|
||||
! PowerPC register assignments:
|
||||
|
|
@ -57,13 +46,13 @@ M:: ppc %load-indirect ( reg obj -- )
|
|||
obj rc-absolute-ppc-2/2 rel-literal
|
||||
reg reg 0 LWZ ;
|
||||
|
||||
: ds-reg 30 ; inline
|
||||
: rs-reg 31 ; inline
|
||||
: ds-reg 29 ; inline
|
||||
: rs-reg 30 ; inline
|
||||
|
||||
GENERIC: loc-reg ( loc -- reg )
|
||||
|
||||
M: ds-loc log-reg drop ds-reg ;
|
||||
M: rs-loc log-reg drop rs-reg ;
|
||||
M: ds-loc loc-reg drop ds-reg ;
|
||||
M: rs-loc loc-reg drop rs-reg ;
|
||||
|
||||
: loc>operand ( loc -- reg n )
|
||||
[ loc-reg ] [ n>> cells neg ] bi ; inline
|
||||
|
|
@ -137,9 +126,25 @@ 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 %string-nth ( dst src index temp -- )
|
||||
[
|
||||
"end" define-label
|
||||
temp src index ADD
|
||||
dst temp string-offset LBZ
|
||||
temp src string-aux-offset LWZ
|
||||
0 temp \ f tag-number CMPI
|
||||
"end" get BEQ
|
||||
temp temp index ADD
|
||||
temp temp index ADD
|
||||
temp temp byte-array-offset LHZ
|
||||
temp temp 8 SLWI
|
||||
dst dst temp OR
|
||||
"end" resolve-label
|
||||
] with-scope ;
|
||||
|
||||
M: ppc %add ADD ;
|
||||
M: ppc %add-imm ADDI ;
|
||||
M: ppc %sub swapd SUBF ;
|
||||
M: ppc %sub swap SUBF ;
|
||||
M: ppc %sub-imm SUBI ;
|
||||
M: ppc %mul MULLW ;
|
||||
M: ppc %mul-imm MULLI ;
|
||||
|
|
@ -156,44 +161,42 @@ M: ppc %not NOT ;
|
|||
|
||||
: bignum@ ( n -- offset ) cells bignum tag-number - ; inline
|
||||
|
||||
M: ppc %integer>bignum ( dst src temp -- )
|
||||
M:: ppc %integer>bignum ( dst src temp -- )
|
||||
[
|
||||
{ "end" "non-zero" "pos" "store" } [ define-label ] each
|
||||
dst 0 >bignum %load-immediate
|
||||
"end" define-label
|
||||
dst 0 >bignum %load-indirect
|
||||
! 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
|
||||
2 tag-fixnum temp LI
|
||||
temp dst 1 bignum@ STW
|
||||
! Compute sign
|
||||
temp src MR
|
||||
temp cell-bits 1- SRAWI
|
||||
temp temp cell-bits 1- SRAWI
|
||||
temp temp 1 ANDI
|
||||
! Store sign
|
||||
dst 2 bignum@ temp STW
|
||||
temp dst 2 bignum@ 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
|
||||
temp dst 3 bignum@ STW
|
||||
"end" resolve-label
|
||||
] with-scope ;
|
||||
|
||||
M:: %bignum>integer ( dst src temp -- )
|
||||
M:: ppc %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
|
||||
0 temp 1 tag-fixnum CMPI
|
||||
"end" get BEQ
|
||||
! load the value
|
||||
dst src 3 bignum@ LWZ
|
||||
|
|
@ -203,6 +206,7 @@ M:: %bignum>integer ( dst src temp -- )
|
|||
! and 1 into -1
|
||||
temp temp temp ADD
|
||||
temp temp 1 SUBI
|
||||
temp temp NEG
|
||||
! multiply value by sign
|
||||
dst dst temp MULLW
|
||||
"end" resolve-label
|
||||
|
|
@ -213,14 +217,14 @@ M: ppc %sub-float FSUB ;
|
|||
M: ppc %mul-float FMUL ;
|
||||
M: ppc %div-float FDIV ;
|
||||
|
||||
M: ppc %integer>float ( dst src -- )
|
||||
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
|
||||
scratch-reg 4503601774854144.0 %load-indirect
|
||||
fp-scratch-reg-2 scratch-reg float-offset LFD
|
||||
fp-scratch-reg-2 fp-scratch-reg-2 fp-scratch-reg-2 FSUB ;
|
||||
|
||||
|
|
@ -231,7 +235,7 @@ M:: ppc %float>integer ( dst src -- )
|
|||
|
||||
M: ppc %copy ( dst src -- ) MR ;
|
||||
|
||||
M: ppc %copy-float ( dst src -- ) MFR ;
|
||||
M: ppc %copy-float ( dst src -- ) FMR ;
|
||||
|
||||
M: ppc %unbox-float ( dst src -- ) float-offset LFD ;
|
||||
|
||||
|
|
@ -277,9 +281,9 @@ M:: ppc %box-alien ( dst src temp -- )
|
|||
"f" get BEQ
|
||||
dst 4 cells alien temp %allot
|
||||
! Store offset
|
||||
dst src 3 alien@ STW
|
||||
temp \ f tag-number %load-immediate
|
||||
src dst 3 alien@ STW
|
||||
! Store expired slot
|
||||
temp \ f tag-number %load-immediate
|
||||
temp dst 1 alien@ STW
|
||||
! Store underlying-alien slot
|
||||
temp dst 2 alien@ STW
|
||||
|
|
@ -289,7 +293,7 @@ M:: ppc %box-alien ( dst src temp -- )
|
|||
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-1 dupd 0 LBZ dup EXTSB ;
|
||||
M: ppc %alien-signed-2 0 LHA ;
|
||||
|
||||
M: ppc %alien-cell 0 LWZ ;
|
||||
|
|
@ -297,45 +301,47 @@ 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-integer-1 swap 0 STB ;
|
||||
M: ppc %set-alien-integer-2 swap 0 STH ;
|
||||
|
||||
M: ppc %set-alien-cell 0 STW ;
|
||||
M: ppc %set-alien-cell swap 0 STW ;
|
||||
|
||||
M: ppc %set-alien-float 0 STFS ;
|
||||
M: ppc %set-alien-double 0 STFD ;
|
||||
M: ppc %set-alien-float swap 0 STFS ;
|
||||
M: ppc %set-alien-double swap 0 STFD ;
|
||||
|
||||
: %load-dlsym ( symbol dll register -- )
|
||||
0 swap LOAD32 rc-absolute-ppc-2/2 rel-dlsym ;
|
||||
|
||||
: load-zone-ptr ( reg -- )
|
||||
[ "nursery" f ] dip %load-dlsym ;
|
||||
|
||||
: load-allot-ptr ( nursery-ptr allot-ptr -- )
|
||||
[ drop load-zone-ptr ] [ swap cell LWZ ] 2bi ;
|
||||
[ drop load-zone-ptr ] [ swap 4 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 ;
|
||||
:: inc-allot-ptr ( nursery-ptr allot-ptr n -- )
|
||||
scratch-reg allot-ptr n 8 align ADDI
|
||||
scratch-reg nursery-ptr 4 STW ;
|
||||
|
||||
:: store-header ( temp class -- )
|
||||
:: store-header ( dst class -- )
|
||||
class type-number tag-fixnum scratch-reg LI
|
||||
temp scratch-reg 0 STW ;
|
||||
scratch-reg dst 0 STW ;
|
||||
|
||||
: store-tagged ( dst tag -- )
|
||||
dupd tag-number ORI ;
|
||||
|
||||
M:: ppc %allot ( dst size class nursery-ptr -- )
|
||||
nursery-ptr dst load-allot-ptr
|
||||
nursery-ptr dst size inc-allot-ptr
|
||||
dst class store-header
|
||||
dst class store-tagged
|
||||
nursery-ptr size inc-allot-ptr ;
|
||||
dst class store-tagged ;
|
||||
|
||||
: %alien-global ( dest name -- )
|
||||
[ f swap %load-dlsym ] [ drop dup 0 LWZ ] 2bi ;
|
||||
: %alien-global ( dst name -- )
|
||||
[ f rot %load-dlsym ] [ drop dup 0 LWZ ] 2bi ;
|
||||
|
||||
: load-cards-offset ( dest -- )
|
||||
: load-cards-offset ( dst -- )
|
||||
"cards_offset" %alien-global ;
|
||||
|
||||
: load-decks-offset ( dest -- )
|
||||
: load-decks-offset ( dst -- )
|
||||
"decks_offset" %alien-global ;
|
||||
|
||||
M:: ppc %write-barrier ( src card# table -- )
|
||||
|
|
@ -359,18 +365,17 @@ M: ppc %gc
|
|||
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 scratch-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
|
||||
scratch-reg 1 pick xt-save STW
|
||||
dup scratch-reg LI
|
||||
scratch-reg 1 pick next-save STW
|
||||
0 1 rot lr-save + STW ;
|
||||
|
||||
M: ppc %epilogue ( n -- )
|
||||
|
|
@ -384,19 +389,19 @@ M: ppc %epilogue ( n -- )
|
|||
|
||||
:: (%boolean) ( dst word -- )
|
||||
"end" define-label
|
||||
\ f tag-number %load-immediate
|
||||
dst \ 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 ] }
|
||||
{ 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
|
||||
|
|
@ -426,7 +431,7 @@ M: ppc %compare-float-branch (%compare-float) %branch ;
|
|||
|
||||
: stack@ 1 swap ; inline
|
||||
|
||||
: spill-integer@ ( n -- op )
|
||||
: spill-integer@ ( n -- reg offset )
|
||||
cells
|
||||
stack-frame get spill-integer-base
|
||||
+ stack@ ;
|
||||
|
|
@ -437,7 +442,7 @@ M: ppc %compare-float-branch (%compare-float) %branch ;
|
|||
[ return>> ]
|
||||
tri + + ;
|
||||
|
||||
: spill-float@ ( n -- op )
|
||||
: spill-float@ ( n -- reg offset )
|
||||
double-float-regs reg-size *
|
||||
stack-frame get spill-float-base
|
||||
+ stack@ ;
|
||||
|
|
@ -560,7 +565,7 @@ 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 ;
|
||||
3 swap %load-indirect "c_to_factor" f %alien-invoke ;
|
||||
|
||||
M: ppc %prepare-alien-indirect ( -- )
|
||||
"unbox_alien" f %alien-invoke
|
||||
|
|
|
|||
|
|
@ -293,15 +293,13 @@ M:: x86 %box-alien ( dst src temp -- )
|
|||
[ quot call ] with-save/restore
|
||||
] if ; inline
|
||||
|
||||
: aux-offset 2 cells string tag-number - ; inline
|
||||
|
||||
M:: x86 %string-nth ( dst src index temp -- )
|
||||
"end" define-label
|
||||
dst { src index temp } [| new-dst |
|
||||
temp src index [+] LEA
|
||||
new-dst 1 small-reg temp string-offset [+] MOV
|
||||
new-dst new-dst 1 small-reg MOVZX
|
||||
temp src aux-offset [+] MOV
|
||||
temp src string-aux-offset [+] MOV
|
||||
temp \ f tag-number CMP
|
||||
"end" get JE
|
||||
new-dst temp XCHG
|
||||
|
|
|
|||
Loading…
Reference in New Issue