diff --git a/basis/cpu/ppc/allot/allot.factor b/basis/cpu/ppc/allot/allot.factor
deleted file mode 100644
index 3190973f26..0000000000
--- a/basis/cpu/ppc/allot/allot.factor
+++ /dev/null
@@ -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 ;
diff --git a/basis/cpu/ppc/allot/authors.txt b/basis/cpu/ppc/allot/authors.txt
deleted file mode 100644
index 1901f27a24..0000000000
--- a/basis/cpu/ppc/allot/authors.txt
+++ /dev/null
@@ -1 +0,0 @@
-Slava Pestov
diff --git a/basis/cpu/ppc/allot/summary.txt b/basis/cpu/ppc/allot/summary.txt
deleted file mode 100644
index 3c4941ea1d..0000000000
--- a/basis/cpu/ppc/allot/summary.txt
+++ /dev/null
@@ -1 +0,0 @@
-PowerPC inline memory allocation
diff --git a/basis/cpu/ppc/allot/tags.txt b/basis/cpu/ppc/allot/tags.txt
deleted file mode 100644
index 6bf68304bb..0000000000
--- a/basis/cpu/ppc/allot/tags.txt
+++ /dev/null
@@ -1 +0,0 @@
-unportable
diff --git a/basis/cpu/ppc/architecture/architecture.factor b/basis/cpu/ppc/architecture/architecture.factor
deleted file mode 100644
index f19b71f3e4..0000000000
--- a/basis/cpu/ppc/architecture/architecture.factor
+++ /dev/null
@@ -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 ;
diff --git a/basis/cpu/ppc/architecture/authors.txt b/basis/cpu/ppc/architecture/authors.txt
deleted file mode 100644
index 1901f27a24..0000000000
--- a/basis/cpu/ppc/architecture/authors.txt
+++ /dev/null
@@ -1 +0,0 @@
-Slava Pestov
diff --git a/basis/cpu/ppc/architecture/summary.txt b/basis/cpu/ppc/architecture/summary.txt
deleted file mode 100644
index 76fe694abe..0000000000
--- a/basis/cpu/ppc/architecture/summary.txt
+++ /dev/null
@@ -1 +0,0 @@
-PowerPC architecture description
diff --git a/basis/cpu/ppc/architecture/tags.txt b/basis/cpu/ppc/architecture/tags.txt
deleted file mode 100644
index 6bf68304bb..0000000000
--- a/basis/cpu/ppc/architecture/tags.txt
+++ /dev/null
@@ -1 +0,0 @@
-unportable
diff --git a/basis/cpu/ppc/intrinsics/authors.txt b/basis/cpu/ppc/intrinsics/authors.txt
deleted file mode 100755
index 1901f27a24..0000000000
--- a/basis/cpu/ppc/intrinsics/authors.txt
+++ /dev/null
@@ -1 +0,0 @@
-Slava Pestov
diff --git a/basis/cpu/ppc/intrinsics/intrinsics.factor b/basis/cpu/ppc/intrinsics/intrinsics.factor
deleted file mode 100644
index 634040b0d0..0000000000
--- a/basis/cpu/ppc/intrinsics/intrinsics.factor
+++ /dev/null
@@ -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
diff --git a/basis/cpu/ppc/intrinsics/tags.txt b/basis/cpu/ppc/intrinsics/tags.txt
deleted file mode 100644
index 6bf68304bb..0000000000
--- a/basis/cpu/ppc/intrinsics/tags.txt
+++ /dev/null
@@ -1 +0,0 @@
-unportable
diff --git a/basis/cpu/ppc/ppc.factor b/basis/cpu/ppc/ppc.factor
index 1577945118..8e7d8fed7d 100644
--- a/basis/cpu/ppc/ppc.factor
+++ b/basis/cpu/ppc/ppc.factor
@@ -1,8 +1,15 @@
-USING: accessors cpu.ppc.architecture cpu.ppc.intrinsics
-cpu.architecture namespaces alien.c-types kernel system
-combinators ;
+! Copyright (C) 2005, 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+IN: cpu.ppc.architecture
-{
+! PowerPC register assignments
+! r3-r11, r16-r31: integer vregs
+! f0-f13: float vregs
+! r12: scratch
+! r14: data stack
+! r15: retain stack
+
+<< {
{ [ os macosx? ] [
4 "longlong" c-type (>>align)
4 "ulonglong" c-type (>>align)
@@ -12,4 +19,545 @@ combinators ;
t "longlong" c-type (>>stack-align?)
t "ulonglong" c-type (>>stack-align?)
] }
-} cond
+} cond >>
+
+M: ppc machine-registers
+ {
+ { int-regs { 3 4 5 6 7 8 9 10 11 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 } }
+ { double-float-regs { 0 1 2 3 4 5 6 7 8 9 10 11 12 13 } }
+ } ;
+
+: scratch-reg 12 ; inline
+
+M: ppc two-operand? t ;
+
+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 14 ; inline
+: rs-reg 15 ; 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 )
+ local@ factor-area-size + 4 cells align ;
+
+! M: x86 stack-frame-size ( stack-frame -- i )
+! [ spill-counts>> [ swap reg-size * ] { } assoc>map sum ]
+! [ params>> ]
+! [ return>> ]
+! tri + +
+! 3 cells +
+! align-stack ;
+
+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 ;
+
+M: ppc %integer>bignum ( dst src temp -- )
+ [
+ { "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 bignum over 3 + cells %allot
+ 1+ v>operand 12 LI ! compute the length
+ 12 11 cell STW ! store the length
+ ! 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 ;
+
+: bignum@ ( n -- offset ) cells bignum tag-number - ; inline
+
+M:: %bignum>integer ( dst src -- )
+ [
+ "end" define-label
+ scratch-reg src 1 bignum@ LWZ
+ ! if the length is 1, its just the sign and nothing else,
+ ! so output 0
+ 0 dst LI
+ 0 scratch-reg 1 v>operand CMPI
+ "end" get BEQ
+ ! load the value
+ dst src 3 bignum@ LWZ
+ ! load the sign
+ scratch-reg src 2 bignum@ LWZ
+ ! branchless arithmetic: we want to turn 0 into 1,
+ ! and 1 into -1
+ scratch-reg scratch-reg 1 SLWI
+ scratch-reg scratch-reg NEG
+ scratch-reg scratch-reg 1 ADDI
+ ! multiply value by sign
+ dst dst scratch-reg 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
+ HEX: 4330 "scratch" operand LIS
+ "scratch" operand 1 0 param@ STW
+ "in" operand dup HEX: 8000 XORIS
+ "in" operand 1 cell param@ STW
+ "f1" operand 1 0 param@ LFD
+ 4503601774854144.0 "in" operand load-indirect
+ "f2" operand "in" operand float-offset LFD
+ "f1" operand "f1" operand "f2" operand FSUB ;
+
+M: ppc %float>integer
+ "scratch" operand "in" operand FCTIWZ
+ "scratch" operand 1 0 param@ STFD
+ "out" operand 1 cell 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 ;
+
+! M: ppc %spill-integer ( src n -- ) spill-integer@ swap MOV ;
+! M: ppc %reload-integer ( dst n -- ) spill-integer@ MOV ;
+!
+! M: ppc %spill-float ( src n -- ) spill-float@ swap MOVSD ;
+! M: ppc %reload-float ( dst n -- ) spill-float@ MOVSD ;
+
+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 ;