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 -- ? )