steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

cpu.ppc: updates for recent compiler changes, untested

db4
Slava Pestov 2010-05-03 18:28:31 -04:00
parent 4352902bb6
commit bb3cea31ea
2 changed files with 165 additions and 100 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

15
basis/cpu/ppc/bootstrap.factor
View File

@ -491,6 +491,21 @@ CONSTANT: nv-reg 17
3 ds-reg 0 STW
] \ slot define-sub-primitive
[
! load string index from stack
3 ds-reg -4 LWZ
3 3 tag-bits get SRAWI
! load string from stack
4 ds-reg 0 LWZ
! load character
4 4 string-offset ADDI
3 3 4 LBZX
3 3 tag-bits get SLWI
! store character to stack
ds-reg ds-reg 4 SUB
3 ds-reg 0 STW
] \ string-nth-fast define-sub-primitive
! Shufflers
[
ds-reg dup 4 SUBI

250
basis/cpu/ppc/ppc.factor
View File

@ -1,14 +1,16 @@
! Copyright (C) 2005, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs sequences kernel combinators make math
math.order math.ranges system namespaces locals layouts words
alien alien.accessors alien.c-types alien.complex alien.data
literals cpu.architecture cpu.ppc.assembler
cpu.ppc.assembler.backend compiler.cfg.registers
compiler.cfg.instructions compiler.cfg.comparisons
compiler.codegen.fixup compiler.cfg.intrinsics
compiler.cfg.stack-frame compiler.cfg.build-stack-frame
compiler.units compiler.constants compiler.codegen vm ;
USING: accessors assocs sequences kernel combinators
classes.algebra byte-arrays make math math.order math.ranges
system namespaces locals layouts words alien alien.accessors
alien.c-types alien.complex alien.data literals cpu.architecture
cpu.ppc.assembler cpu.ppc.assembler.backend
compiler.cfg.registers compiler.cfg.instructions
compiler.cfg.comparisons compiler.codegen.fixup
compiler.cfg.intrinsics compiler.cfg.stack-frame
compiler.cfg.build-stack-frame compiler.units compiler.constants
compiler.codegen vm ;
QUALIFIED-WITH: alien.c-types c
FROM: cpu.ppc.assembler => B ;
FROM: layouts => cell ;
FROM: math => float ;
@ -31,8 +33,8 @@ M: label BC [ 0 BC ] dip rc-relative-ppc-2 label-fixup ;
enable-float-intrinsics
<<
\ ##integer>float t frame-required? set-word-prop
\ ##float>integer t frame-required? set-word-prop
\ ##integer>float t "frame-required?" set-word-prop
\ ##float>integer t "frame-required?" set-word-prop
>>
M: ppc machine-registers
@ -47,7 +49,9 @@ CONSTANT: fp-scratch-reg 30
M: ppc %load-immediate ( reg n -- ) swap LOAD ;
M: ppc %load-reference ( reg obj -- )
[ 0 swap LOAD32 ] [ rc-absolute-ppc-2/2 rel-literal ] bi* ;
[ [ 0 swap LOAD32 ] [ rc-absolute-ppc-2/2 rel-literal ] bi* ]
[ \ f type-number swap LI ]
if* ;
M: ppc %alien-global ( register symbol dll -- )
[ 0 swap LOAD32 ] 2dip rc-absolute-ppc-2/2 rel-dlsym ;
@ -109,10 +113,6 @@ HOOK: reserved-area-size os ( -- n )
: scratch@ ( n -- offset )
factor-area-size + ;
! GC root area
: gc-root@ ( n -- offset )
gc-root-offset local@ ;
! Finally we have the linkage area
HOOK: lr-save os ( -- n )
@ -165,19 +165,22 @@ M: ppc %sar-imm SRAWI ;
M: ppc %not NOT ;
M: ppc %neg NEG ;
:: overflow-template ( label dst src1 src2 insn -- )
:: overflow-template ( label dst src1 src2 cc insn -- )
0 0 LI
0 MTXER
dst src2 src1 insn call
label BO ; inline
cc {
{ cc-o [ label BO ] }
{ cc/o [ label BNO ] }
} case ; inline
M: ppc %fixnum-add ( label dst src1 src2 -- )
M: ppc %fixnum-add ( label dst src1 src2 cc -- )
[ ADDO. ] overflow-template ;
M: ppc %fixnum-sub ( label dst src1 src2 -- )
M: ppc %fixnum-sub ( label dst src1 src2 cc -- )
[ SUBFO. ] overflow-template ;
M: ppc %fixnum-mul ( label dst src1 src2 -- )
M: ppc %fixnum-mul ( label dst src1 src2 cc -- )
[ MULLWO. ] overflow-template ;
M: ppc %add-float FADD ;
@ -275,12 +278,69 @@ M:: ppc %box-alien ( dst src temp -- )
"f" resolve-label
] with-scope ;
:: %box-displaced-alien/f ( dst displacement base -- )
base dst 1 alien@ STW
displacement dst 3 alien@ STW
displacement dst 4 alien@ STW ;
:: %box-displaced-alien/alien ( dst displacement base temp -- )
! Set new alien's base to base.base
temp base 1 alien@ LWZ
temp dst 1 alien@ STW
! Compute displacement
temp base 3 alien@ LWZ
temp temp displacement ADD
temp dst 3 alien@ STW
! Compute address
temp base 4 alien@ LWZ
temp temp displacement ADD
temp dst 4 alien@ STW ;
:: %box-displaced-alien/byte-array ( dst displacement base temp -- )
base dst 1 alien@ STW
displacement dst 3 alien@ STW
temp base byte-array-offset ADDI
temp temp displacement ADD
temp dst 4 alien@ STW ;
:: %box-displaced-alien/dynamic ( dst displacement base temp -- )
"not-f" define-label
"not-alien" define-label
! Is base f?
0 base \ f type-number CMPI
"not-f" get BNE
! Yes, it is f. Fill in new object
dst displacement base %box-displaced-alien/f
"end" get B
"not-f" resolve-label
! Check base type
temp base tag-mask get ANDI
! Is base an alien?
0 temp alien type-number CMPI
"not-alien" get BNE
dst displacement base temp %box-displaced-alien/alien
! We are done
"end" get B
! Is base a byte array? It has to be, by now...
"not-alien" resolve-label
dst displacement base temp %box-displaced-alien/byte-array ;
M:: ppc %box-displaced-alien ( dst displacement base temp base-class -- )
! This is ridiculous
[
"end" define-label
"not-f" define-label
"not-alien" define-label
! If displacement is zero, return the base
dst base MR
@ -295,73 +355,48 @@ M:: ppc %box-displaced-alien ( dst displacement base temp base-class -- )
temp \ f type-number %load-immediate
temp dst 2 alien@ STW
! Is base f?
0 base \ f type-number CMPI
"not-f" get BNE
! Yes, it is f. Fill in new object
base dst 1 alien@ STW
displacement dst 3 alien@ STW
displacement dst 4 alien@ STW
"end" get B
"not-f" resolve-label
! Check base type
temp base tag-mask get ANDI
! Is base an alien?
0 temp alien type-number CMPI
"not-alien" get BNE
! Yes, it is an alien. Set new alien's base to base.base
temp base 1 alien@ LWZ
temp dst 1 alien@ STW
! Compute displacement
temp base 3 alien@ LWZ
temp temp displacement ADD
temp dst 3 alien@ STW
! Compute address
temp base 4 alien@ LWZ
temp temp displacement ADD
temp dst 4 alien@ STW
! We are done
"end" get B
! Is base a byte array? It has to be, by now...
"not-alien" resolve-label
base dst 1 alien@ STW
displacement dst 3 alien@ STW
temp base byte-array-offset ADDI
temp temp displacement ADD
temp dst 4 alien@ STW
dst displacement base temp
{
{ [ base-class \ f class<= ] [ 2drop %box-displaced-alien/f ] }
{ [ base-class \ alien class<= ] [ %box-displaced-alien/alien ] }
{ [ base-class \ byte-array class<= ] [ %box-displaced-alien/byte-array ] }
[ %box-displaced-alien/dynamic ]
} cond
"end" resolve-label
] with-scope ;
M: ppc %alien-unsigned-1 LBZ ;
M: ppc %alien-unsigned-2 LHZ ;
M:: ppc %load-memory-imm ( dst base offset rep c-type -- )
[
{
{ c:char [ [ dup ] 2dip LBZ dup EXTSB ] }
{ c:uchar [ LBZ ] }
{ c:short [ LHA ] }
{ c:ushort [ LHZ ] }
} case
] [
{
{ int-rep [ LWZ ] }
{ float-rep [ LFS ] }
{ double-rep [ LFD ] }
} case
] ?if ;
M: ppc %alien-signed-1 [ dup ] 2dip LBZ dup EXTSB ;
M: ppc %alien-signed-2 LHA ;
M: ppc %alien-cell LWZ ;
M: ppc %alien-float LFS ;
M: ppc %alien-double LFD ;
M: ppc %set-alien-integer-1 -rot STB ;
M: ppc %set-alien-integer-2 -rot STH ;
M: ppc %set-alien-cell -rot STW ;
M: ppc %set-alien-float -rot STFS ;
M: ppc %set-alien-double -rot STFD ;
M:: ppc %store-memory-imm ( src base offset rep c-type -- )
[
{
{ c:char [ STB ] }
{ c:uchar [ STB ] }
{ c:short [ STH ] }
{ c:ushort [ STH ] }
} case
] [
{
{ int-rep [ STW ] }
{ float-rep [ STFS ] }
{ double-rep [ STFD ] }
} case
] ?if ;
: load-zone-ptr ( reg -- )
vm-reg "nursery" vm-field-offset ADDI ;
@ -413,25 +448,21 @@ M:: ppc %write-barrier-imm ( src slot temp1 temp2 -- )
temp1 src slot ADDI
temp1 temp2 (%write-barrier) ;
M:: ppc %check-nursery ( label size temp1 temp2 -- )
M:: ppc %check-nursery-branch ( label size cc temp1 temp2 -- )
temp2 load-zone-ptr
temp1 temp2 0 LWZ
temp2 temp2 2 cells LWZ
temp1 temp1 size ADDI
! is here >= end?
temp1 0 temp2 CMP
label BLE ;
cc {
{ cc<= [ label BLE ] }
{ cc/<= [ label BGT ] }
} case ;
M:: ppc %save-gc-root ( gc-root register -- )
register 1 gc-root gc-root@ STW ;
M:: ppc %load-gc-root ( gc-root register -- )
register 1 gc-root gc-root@ LWZ ;
M:: ppc %call-gc ( gc-root-count temp -- )
3 1 gc-root-base local@ ADDI
gc-root-count 4 LI
5 %load-vm-addr
M: ppc %call-gc ( gc-roots -- )
3 swap %load-reference
4 %load-vm-addr
"inline_gc" f %alien-invoke ;
M: ppc %prologue ( n -- )
@ -473,9 +504,18 @@ M: ppc %epilogue ( n -- )
} case ;
: (%compare) ( src1 src2 -- ) [ 0 ] dip CMP ; inline
: (%compare-imm) ( src1 src2 -- ) [ 0 ] [ ] [ \ f type-number or ] tri* CMPI ; inline
: (%compare-float-unordered) ( src1 src2 -- ) [ 0 ] dip FCMPU ; inline
: (%compare-float-ordered) ( src1 src2 -- ) [ 0 ] dip FCMPO ; inline
: (%compare-integer-imm) ( src1 src2 -- )
[ 0 ] 2dip CMPI ; inline
: (%compare-imm) ( src1 src2 -- )
[ tag-fixnum ] [ \ f type-number ] if* (%compare-integer-imm) ; inline
: (%compare-float-unordered) ( src1 src2 -- )
[ 0 ] dip FCMPU ; inline
: (%compare-float-ordered) ( src1 src2 -- )
[ 0 ] dip FCMPO ; inline
:: (%compare-float) ( src1 src2 cc compare -- branch1 branch2 )
cc {
@ -499,6 +539,8 @@ M: ppc %compare [ (%compare) ] 2dip %boolean ;
M: ppc %compare-imm [ (%compare-imm) ] 2dip %boolean ;
M: ppc %compare-integer-imm [ (%compare-integer-imm) ] 2dip %boolean ;
M:: ppc %compare-float-ordered ( dst src1 src2 cc temp -- )
src1 src2 cc negate-cc \ (%compare-float-ordered) (%compare-float) :> ( branch1 branch2 )
dst temp branch1 branch2 (%boolean) ;
@ -525,6 +567,10 @@ M:: ppc %compare-imm-branch ( label src1 src2 cc -- )
src1 src2 (%compare-imm)
label cc %branch ;
M:: ppc %compare-integer-imm-branch ( label src1 src2 cc -- )
src1 src2 (%compare-integer-imm)
label cc %branch ;
:: (%branch) ( label branch1 branch2 -- )
label branch1 execute( label -- )
branch2 [ label branch2 execute( label -- ) ] when ; inline
@ -565,7 +611,9 @@ M: ppc %reload ( dst rep src -- )
M: ppc %loop-entry ;
M: int-regs return-reg drop 3 ;
M: int-regs param-regs 2drop { 3 4 5 6 7 8 9 10 } ;
M: float-regs return-reg drop 1 ;
M:: ppc %save-param-reg ( stack reg rep -- )
@ -682,6 +730,8 @@ M: ppc immediate-arithmetic? ( n -- ? ) -32768 32767 between? ;
M: ppc immediate-bitwise? ( n -- ? ) 0 65535 between? ;
M: ppc immediate-store? drop f ;
M: ppc struct-return-pointer-type void* ;
M: ppc return-struct-in-registers? ( c-type -- ? )