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.constants

basis/compiler/cfg/intrinsics/alien/alien.factor

@@ -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 ;
 

basis/compiler/cfg/intrinsics/fixnum/fixnum.factor

@@ -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 ;
 

basis/compiler/cfg/intrinsics/slots/slots.factor

@@ -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

basis/compiler/cfg/utilities/utilities.factor

@@ -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 ;

basis/compiler/constants/constants.factor

@@ -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 ;
+: card-bits 8 ; inline
-: deck-bits 18 ;
+: deck-bits 18 ; inline
-: card-mark ( -- n ) HEX: 40 HEX: 80 bitor ;
+: card-mark ( -- n ) HEX: 40 HEX: 80 bitor ; inline
 
 ! These constants must match vm/layouts.h
-: header-offset ( -- n ) object tag-number neg ;
+: header-offset ( -- n ) object tag-number neg ; inline
-: float-offset ( -- n ) 8 float tag-number - ;
+: float-offset ( -- n ) 8 float tag-number - ; inline
-: string-offset ( -- n ) 4 bootstrap-cells object tag-number - ;
+: string-offset ( -- n ) 4 bootstrap-cells object tag-number - ; inline
-: profile-count-offset ( -- n ) 7 bootstrap-cells object tag-number - ;
+: string-aux-offset ( -- n ) 2 bootstrap-cells string tag-number - ; inline
-: byte-array-offset ( -- n ) 2 bootstrap-cells object tag-number - ;
+: profile-count-offset ( -- n ) 7 bootstrap-cells object tag-number - ; inline
-: alien-offset ( -- n ) 3 bootstrap-cells object tag-number - ;
+: byte-array-offset ( -- n ) 2 bootstrap-cells object tag-number - ; inline
-: underlying-alien-offset ( -- n ) bootstrap-cell object tag-number - ;
+: alien-offset ( -- n ) 3 bootstrap-cells object tag-number - ; inline
-: tuple-class-offset ( -- n ) bootstrap-cell tuple tag-number - ;
+: underlying-alien-offset ( -- n ) bootstrap-cell object tag-number - ; inline
-: class-hash-offset ( -- n ) bootstrap-cell object tag-number - ;
+: tuple-class-offset ( -- n ) bootstrap-cell tuple tag-number - ; inline
-: word-xt-offset ( -- n ) 9 bootstrap-cells object tag-number - ;
+: class-hash-offset ( -- n ) bootstrap-cell object tag-number - ; inline
-: quot-xt-offset ( -- n ) 3 bootstrap-cells object tag-number - ;
+: word-xt-offset ( -- n ) 9 bootstrap-cells object tag-number - ; inline
-: word-code-offset ( -- n ) 10 bootstrap-cells object tag-number - ;
+: quot-xt-offset ( -- n ) 3 bootstrap-cells object tag-number - ; inline
-: array-start-offset ( -- n ) 2 bootstrap-cells object tag-number - ;
+: word-code-offset ( -- n ) 10 bootstrap-cells object tag-number - ; inline
-: compiled-header-size ( -- n ) 4 bootstrap-cells ;
+: 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-cell    0 ; inline
-: rc-absolute         1 ;
+: rc-absolute         1 ; inline
-: rc-relative         2 ;
+: rc-relative         2 ; inline
-: rc-absolute-ppc-2/2 3 ;
+: rc-absolute-ppc-2/2 3 ; inline
-: rc-relative-ppc-2   4 ;
+: rc-relative-ppc-2   4 ; inline
-: rc-relative-ppc-3   5 ;
+: rc-relative-ppc-3   5 ; inline
-: rc-relative-arm-3   6 ;
+: rc-relative-arm-3   6 ; inline
-: rc-indirect-arm     7 ;
+: rc-indirect-arm     7 ; inline
-: rc-indirect-arm-pc  8 ;
+: rc-indirect-arm-pc  8 ; inline
 
 ! Relocation types
-: rt-primitive 0 ;
+: rt-primitive 0 ; inline
-: rt-dlsym     1 ;
+: rt-dlsym     1 ; inline
-: rt-literal   2 ;
+: rt-literal   2 ; inline
-: rt-dispatch  3 ;
+: rt-dispatch  3 ; inline
-: rt-xt        4 ;
+: rt-xt        4 ; inline
-: rt-here      5 ;
+: rt-here      5 ; inline
-: rt-label     6 ;
+: rt-label     6 ; inline
-: rt-immediate 7 ;
+: rt-immediate 7 ; inline
 
 : rc-absolute? ( n -- ? )
     [ rc-absolute-ppc-2/2 = ]

basis/compiler/tests/intrinsics.factor

@@ -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: a ] [ 0 "abc" [ string-nth ] compile-call ] unit-test
-! [ CHAR: b ] [ 1 [ "abc" char-slot ] compile-call ] unit-test
+[ CHAR: a ] [ 0 [ "abc" string-nth ] compile-call ] unit-test
-! [ CHAR: b ] [ [ 1 "abc" char-slot ] compile-call ] unit-test
+[ CHAR: a ] [ [ 0 "abc" string-nth ] compile-call ] unit-test
-! 
+[ CHAR: b ] [ 1 "abc" [ string-nth ] compile-call ] unit-test
-! [ "axc" ] [ CHAR: x 1 "abc" [ [ set-char-slot ] keep { string } declare dup rehash-string ] compile-call ] unit-test
+[ CHAR: b ] [ 1 [ "abc" string-nth ] compile-call ] unit-test
-! [ "axc" ] [ CHAR: x 1 [ "abc" [ set-char-slot ] keep { string } declare dup rehash-string ] compile-call ] unit-test
+[ CHAR: b ] [ [ 1 "abc" string-nth ] compile-call ] unit-test
-! [ "axc" ] [ CHAR: x [ 1 "abc" [ set-char-slot ] keep { string } declare dup rehash-string ] 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

basis/cpu/ppc/ppc.factor

@@ -1,21 +1,10 @@
 ! Copyright (C) 2005, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: alien.c-types
+USING: accessors assocs sequences kernel combinators make math
-accessors
+math.order math.ranges system namespaces locals layouts words
-cpu.architecture
+alien alien.c-types cpu.architecture cpu.ppc.assembler
-compiler.cfg.registers
+compiler.cfg.registers compiler.cfg.instructions
-cpu.ppc.assembler
+compiler.constants compiler.codegen compiler.codegen.fixup ;
-kernel
-locals
-layouts
-combinators
-make
-compiler.cfg.instructions
-math.order
-system
-math
-compiler.constants
-namespaces 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
+: ds-reg 29 ; inline
-: rs-reg 31 ; inline
+: rs-reg 30 ; inline
 
 GENERIC: loc-reg ( loc -- reg )
 
-M: ds-loc log-reg drop ds-reg ;
+M: ds-loc loc-reg drop ds-reg ;
-M: rs-loc log-reg drop rs-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
+        "end" define-label
-        dst 0 >bignum %load-immediate
+        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
+        2 tag-fixnum temp LI
-        dst 1 bignum@ temp STW
+        temp dst 1 bignum@ STW
-        ! Store value
-        dst 3 bignum@ src 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
+        src dst 3 alien@ STW
-        temp \ f tag-number %load-immediate
         ! 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-1 swap 0 STB ;
-M: ppc %set-alien-integer-2 0 STH ;
+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-float swap 0 STFS ;
-M: ppc %set-alien-double 0 STFD ;
+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 -- )
+:: inc-allot-ptr ( nursery-ptr allot-ptr n -- )
-    scratch-reg inc-allot-ptr 4 LWZ
+    scratch-reg allot-ptr n 8 align ADDI
-    scratch-reg scratch-reg n 8 align ADD
+    scratch-reg nursery-ptr 4 STW ;
-    scratch-reg inc-allot-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
+    dst class store-tagged ;
-    nursery-ptr size inc-allot-ptr ;
 
-: %alien-global ( dest name -- )
+: %alien-global ( dst name -- )
-    [ f swap %load-dlsym ] [ drop dup 0 LWZ ] 2bi ;
+    [ 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
+    scratch-reg 1 pick xt-save STW
-    dup scrach-reg LI
+    dup scratch-reg LI
-    scrach-reg 1 pick next-save STW
+    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< [ \ BLT (%boolean) ] }
-        { cc<= [ \ BLE %boolean ] }
+        { cc<= [ \ BLE (%boolean) ] }
-        { cc> [ \ BGT %boolean ] }
+        { cc> [ \ BGT (%boolean) ] }
-        { cc>= [ \ BGE %boolean ] }
+        { cc>= [ \ BGE (%boolean) ] }
-        { cc= [ \ BEQ %boolean ] }
+        { cc= [ \ BEQ (%boolean) ] }
-        { cc/= [ \ BNE %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

basis/cpu/x86/x86.factor

@@ -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