From bb3cea31ea82991d80adb2fd7de14d31b0237552 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Mon, 3 May 2010 18:28:31 -0400
Subject: [PATCH] cpu.ppc: updates for recent compiler changes, untested
---
basis/cpu/ppc/bootstrap.factor | 15 ++
basis/cpu/ppc/ppc.factor | 250 ++++++++++++++++++++-------------
2 files changed, 165 insertions(+), 100 deletions(-)
diff --git a/basis/cpu/ppc/bootstrap.factor b/basis/cpu/ppc/bootstrap.factor
index 4df7a487d4..5fb303409e 100644
--- a/basis/cpu/ppc/bootstrap.factor
+++ b/basis/cpu/ppc/bootstrap.factor
@@ -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
diff --git a/basis/cpu/ppc/ppc.factor b/basis/cpu/ppc/ppc.factor
index 70e8ef11ea..e07ee9d490 100644
--- a/basis/cpu/ppc/ppc.factor
+++ b/basis/cpu/ppc/ppc.factor
@@ -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 -- ? )