Updating ARM optimizing compiler backend

core/cpu/arm/4/4.factor

@@ -6,7 +6,7 @@ math math.private namespaces sequences words quotations
 byte-arrays hashtables.private hashtables generator
 generator.registers generator.fixup sequences.private
 strings.private ;
-IN: cpu.arm5.intrinsics
+IN: cpu.arm4
 
 : (%char-slot)
     "out" operand string-offset MOV

core/cpu/arm/4/summary.txt

@@ -0,0 +1 @@
+Additional compiler intrinsics for ARM4

core/cpu/arm/5/5.factor

@@ -0,0 +1,3 @@
+USING: cpu.arm.assembler cpu.arm4 namespaces ;
+
+t have-BLX? set-global

core/cpu/arm/5/authors.txt

@@ -0,0 +1 @@
+Slava Pestov

core/cpu/arm/allot/allot.factor

@@ -8,31 +8,28 @@ IN: cpu.arm.allot
 
 : load-zone-ptr ( reg -- ) "nursery" f rot %alien-global ;
 
-: object@ "allot-tmp" operand swap cells <+> ;
-
 : %allot ( header size -- )
     #! Store a pointer to 'size' bytes allocated from the
-    #! nursery in allot-tmp.
+    #! nursery in R11
     8 align ! align the size
     R12 load-zone-ptr ! nusery -> r12
-    "allot-tmp" operand R12 cell <+> LDR ! nursery.here -> allot-tmp
+    R11 R12 cell <+> LDR ! nursery.here -> r11
-    "allot-tmp" operand dup pick ADD ! increment allot-tmp
+    R11 R11 pick ADD ! increment r11
-    "allot-tmp" operand R12 cell <+> STR ! allot-tmp -> nursery.here
+    R11 R12 cell <+> STR ! r11 -> nursery.here
-    "allot-tmp" operand dup rot SUB ! old value
+    R11 R11 rot SUB ! old value
     R12 swap type-number tag-header MOV ! compute header
-    R12 0 object@ STR ! store header
+    R12 R11 0 <+> STR ! store header
     ;
     
-: %tag-allot ( tag -- )
+: %store-tagged ( reg tag -- )
-    "allot-tmp" operand dup rot tag-number ORR
+    >r dup fresh-object v>operand R11 r> tag-number ORI ;
-    "allot-tmp" get fresh-object ;
 
 : %allot-bignum ( #digits -- )
     #! 1 cell header, 1 cell length, 1 cell sign, + digits
     #! length is the # of digits + sign
     bignum over 3 + cells %allot
     R12 swap 1+ v>operand MOV ! compute the length
-    R12 1 object@ STR ! store the length
+    R12 R11 cell <+> STR ! store the length
     ;
 
 : %allot-bignum-signed-1 ( reg -- )
@@ -43,7 +40,7 @@ IN: cpu.arm.allot
         "end" define-label
         ! is it zero?
         dup v>operand 0 CMP
-        0 >bignum "allot-tmp" operand EQ load-indirect
+        0 >bignum over EQ load-literal
         "end" get EQ B
         ! ! it is non-zero
         1 %allot-bignum
@@ -56,29 +53,27 @@ IN: cpu.arm.allot
         ! positive sign
         R12 0 GE MOV
         ! store sign
-        R12 2 object@ STR
+        R12 R11 2 cells <+> STR
         ! store the number
-        v>operand 3 object@ STR
+        dup v>operand R11 3 cells <+> STR
         ! tag the bignum, store it in reg
         bignum %tag-allot
         "end" resolve-label
     ] with-scope ;
 
-: %allot-alien ( ptr -- )
+M: arm-backend %box-alien ( dst src -- )
-    #! Tagged pointer to alien is in allot-tmp on exit.
-    [
-        "temp" set
     "end" define-label
-        "temp" operand 0 CMP
+    dup v>operand 0 CMP
-        "allot-tmp" operand f v>operand EQ MOV
+    over f v>operand EQ MOV
     "end" get EQ B
     alien 4 cells %allot
-        "temp" operand 2 object@ STR
+    ! Store offset
-        "temp" operand f v>operand MOV
+    v>operand R11 3 cells <+> STR
-        "temp" operand 1 object@ STR
+    R12 f v>operand R12
-        "temp" operand 0 MOV
+    ! Store expired slot
-        "temp" operand 3 object@ STR
+    R12 R11 1 cells <+> STR
+    ! Store underlying-alien slot
+    R12 R11 2 cells <+> STR
     ! Store tagged ptr in reg
-        object %tag-allot
+    object %store-tagged
-        "end" resolve-label
+    "end" resolve-label ;
-    ] with-scope ;

core/cpu/arm/architecture/architecture.factor

@@ -9,8 +9,8 @@ IN: cpu.arm.architecture
 TUPLE: arm-backend ;
 
 ! ARM register assignments:
-! R0, R1, R2, R3 integer vregs
+! R0-R4, R7-R10 integer vregs
-! R12 temporary
+! R11, R12 temporary
 ! R5 data stack
 ! R6 retain stack
 ! R7 primitives
@@ -22,7 +22,7 @@ M: temp-reg v>operand drop R12 ;
 
 M: int-regs return-reg drop R0 ;
 M: int-regs param-regs drop { R0 R1 R2 R3 } ;
-M: int-regs vregs drop { R0 R1 R2 R3 R4 R7 R8 R9 R10 R11 } ;
+M: int-regs vregs drop { R0 R1 R2 R3 R4 R7 R8 R9 R10 } ;
 
 ! No FPU support yet
 M: float-regs param-regs drop { } ;
@@ -44,15 +44,27 @@ M: immediate load-literal
         v>operand load-indirect
     ] if ;
 
-M: arm-backend stack-frame ( n -- i ) 4 + 8 align ;
+: lr-save ( n -- i ) cell - ;
+: next-save ( n -- i ) 2 cells - ;
+: xt-save ( n -- i ) 3 cells - ;
+: factor-area-size 5 cells ;
+
+M: arm-backend stack-frame ( n -- i )
+    factor-area-size + 8 align ;
+
+M: ppc-backend %save-xt ( -- )
+    R12 PC 8 SUB ;
 
 M: arm-backend %prologue ( n -- )
-    LR SP 4 <-> STR
+    SP SP pick SUB
-    SP SP rot stack-frame SUB ;
+    R11 over LI
+    R11 SP pick next-save <+> STR
+    R12 SP rot xt-save <+> STR
+    LR SP pick lr-save <+> STR ;
 
 M: arm-backend %epilogue ( n -- )
-    SP SP rot stack-frame ADD
+    LR SP lr-save <+> LDR
-    LR SP 4 <-> LDR ;
+    SP SP rot stack-frame ADD ;
 
 : compile-dlsym ( symbol dll reg -- )
     [
@@ -83,26 +95,32 @@ M: arm-backend %profiler-prologue ( word -- )
     R0 R12 profile-count-offset <+> STR
     "end" resolve-label ;
 
-: primitive-addr ( word dst -- )
+M: arm-backend %call-label ( label -- ) BL ;
-    #! Load a word address into dst.
-    R7 rot word-primitive cells <+> LDR ;
 
-M: arm-backend %call ( label -- )
+M: arm-backend %jump-label ( label -- ) B ;
-    #! Far C call for primitives, near C call for compiled defs.
-    dup primitive? [ R0 primitive-addr R0 BLX ] [ BL ] if ;
 
-M: arm-backend %jump-label ( label -- )
+: %load-xt ( word -- )
-    #! For tail calls. IP not saved on C stack.
+    0 swap LOAD32  rc-absolute-ppc-2/2 rel-word ;
-    #! WARNING: don't clobber LR here!
+
-    dup primitive? [ PC primitive-addr ] [ B ] if ;
+: %prepare-primitive ( word -- )
+    #! Save stack pointer to stack_chain->callstack_top, load XT
+    R1 SP MOV
+    T{ temp-reg } load-literal
+    R12 R12 word-xt-offset <+> LDR ;
+
+M: arm-backend %call-primitive ( word -- )
+    %prepare-primitive R12 BLX ;
+
+M: arm-backend %jump-primitive ( word -- )
+    %prepare-primitive R12 BX ;
 
 M: arm-backend %jump-t ( label -- )
-    "flag" operand object tag-number CMP NE B ;
+    "flag" operand f v>operand CMP NE B ;
 
 : (%dispatch) ( word-table# reg -- )
     #! Load jump table target address into reg.
-    "n" operand PC "n" operand 1 <LSR> ADD
+    "scratch" operand PC "n" operand 1 <LSR> ADD
-    "n" operand 0 <+> LDR
+    "scratch" operand 0 <+> LDR
     rc-indirect-arm rel-dispatch ;
 
 M: arm-backend %call-dispatch ( word-table# -- )
@@ -112,7 +130,6 @@ M: arm-backend %call-dispatch ( word-table# -- )
     ] H{
         { +input+ { { f "n" } } }
         { +scratch+ { { f "scratch" } } }
-        { +clobber+ { "n" } }
     } with-template ;
 
 M: arm-backend %jump-dispatch ( word-table# -- )
@@ -121,7 +138,7 @@ M: arm-backend %jump-dispatch ( word-table# -- )
         PC (%dispatch)
     ] H{
         { +input+ { { f "n" } } }
-        { +clobber+ { "n" } }
+        { +scratch+ { { f "scratch" } } }
     } with-template ;
 
 M: arm-backend %return ( -- ) %epilogue-later PC LR MOV ;
@@ -134,9 +151,6 @@ M: arm-backend %unwind drop %return ;
 M: int-regs (%peek) \ LDR (%peek/replace) ;
 M: int-regs (%replace) \ STR (%peek/replace) ;
 
-M: arm-backend %move-int>int ( dst src -- )
-    [ v>operand ] 2apply MOV ;
-
 : (%inc) ( n reg -- )
     dup rot cells dup 0 < [ neg SUB ] [ ADD ] if ;
 
@@ -215,11 +229,13 @@ M: arm-backend %box-small-struct ( size -- )
     R2 swap MOV
     "box_small_struct" f %alien-invoke ;
 
+: temp@ stack-frame* factor-area-size - swap - ;
+
 : struct-return@ ( size n -- n )
     [
         stack-frame* +
     ] [
-        stack-frame* swap - cell -
+        stack-frame* factor-area-size - swap -
     ] ?if ;
 
 M: arm-backend %prepare-box-struct ( size -- )
@@ -239,6 +255,15 @@ M: arm-backend %box-large-struct ( n size -- )
 M: arm-backend struct-small-enough? ( size -- ? )
     wince? [ drop f ] [ 4 <= ] if ;
 
+M: ppc-backend %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 R12 %alien-global
+    SP R12 0 <+> STR
+    ds-reg 11 8 <+> STR
+    rs-reg 11 12 <+> STR ;
+
 M: arm-backend %alien-invoke ( symbol dll -- )
     ! Load target address
     R12 PC 4 <+> LDR
@@ -249,15 +274,13 @@ M: arm-backend %alien-invoke ( symbol dll -- )
     ! The target address
     0 , rc-absolute rel-dlsym ;
 
-: temp@ SP stack-frame* 2 cells - <+> ;
-
 M: arm-backend %prepare-alien-indirect ( -- )
     "unbox_alien" f %alien-invoke
-    R0 temp@ STR ;
+    R0 SP cell temp@ <+> STR ;
 
 M: arm-backend %alien-indirect ( -- )
-    IP temp@ LDR
+    R12 SP cell temp@ <+> LDR
-    IP BLX ;
+    R12 BLX ;
 
 M: arm-backend %alien-callback ( quot -- )
     R0 load-indirect
@@ -266,11 +289,11 @@ M: arm-backend %alien-callback ( quot -- )
 M: arm-backend %callback-value ( ctype -- )
     ! Save top of data stack
     %prepare-unbox
-    R0 temp@ STR
+    R0 SP cell temp@ <+> STR
     ! Restore data/call/retain stacks
     "unnest_stacks" f %alien-invoke
     ! Place former top of data stack in R0
-    R0 temp@ LDR
+    R0 SP cell temp@ <+> LDR
     ! Unbox R0
     unbox-return ;
 

core/cpu/arm/arm.factor

@@ -24,27 +24,29 @@ vocabs.loader ;
 
 T{ arm-backend } compiler-backend set-global
 
-: (detect-arm5) ;
+! We don't auto-detect since that would require us to support
-
+! illegal instruction traps. This works on Linux but not on
-\ (detect-arm5) [
+! Windows CE.
-    ! The LDRH word is defined in the module we conditionally
-    ! load below...
-    ! R0 PC 0 <+> LDRH
-    HEX: e1df00b0 ,
-] H{
-    { +scratch+ { { 0 "scratch" } } }
-} define-intrinsic
-
-: detect-arm5 (detect-arm5) ;
-
-: arm5? ( -- ? ) [ detect-arm5 ] catch not ;
 
 "arm-variant" get [
-    \ detect-arm5 compile
+    "ARM variant: " write "arm-variant" get print
-    "Detecting ARM architecture variant..." print
+] [
-    arm5? "arm5" "arm3" ? "arm-variant" set
+    "==========" print
-] unless
+    "You should specify the -arm-variant=<variant> switch." print
+    "<variant> can be one of arm3, arm4, arm4t, or arm5." print
+    "Assuming arm4t." print
+    "==========" print
+    "arm4t" "arm-variant" set
+] if
 
-"ARM architecture variant: " write "arm-variant" get print
+"arm-variant" get { "arm4" "arm4t" "arm5" } member? [
+    "cpu.arm.4" require
+] when
 
-"arm-variant" "arm5" = [ "cpu.arm5" require ] when
+"arm-variant" get { "arm4t" "arm5" } member? [
+    t have-BX? set-global
+] when
+
+"arm-variant" get "arm5" = [
+    t have-BLX? set-global
+] when

core/cpu/arm/assembler/assembler.factor

@@ -4,8 +4,6 @@ USING: arrays generator generator.fixup kernel sequences words
 namespaces math math.bitfields ;
 IN: cpu.arm.assembler
 
-SYMBOL: arm-variant
-
 : define-registers ( seq -- )
     dup length [ "register" set-word-prop ] 2each ;
 
@@ -253,15 +251,77 @@ M: object addressing-mode-2 shifter-op { { 1 25 } 0 } bitfield ;
 : STR 0 0 addr2 ;
 : STRB 1 0 addr2 ;
 
-HOOK: BX arm-variant ( operand -- )
-
-HOOK: BLX arm-variant ( operand -- )
-
 ! We might have to simulate these instructions since older ARM
 ! chips don't have them.
-M: f BX PC swap MOV ;
+SYMBOL: have-BX?
+SYMBOL: have-BLX?
 
-M: f BLX LR PC MOV BX ;
+GENERIC# (BX) 1 ( Rm l -- )
+
+M: register (BX) ( Rm l -- )
+    {
+        { 1 24 }
+        { 1 21 }
+        { BIN: 1111 16 }
+        { BIN: 1111 12 }
+        { BIN: 1111 8 }
+        5
+        { 1 4 }
+        { register 0 }
+    } insn ;
+
+M: word (BX) 0 swap (BX) rc-relative-arm-3 rel-word ;
+
+M: label (BX) 0 swap (BX) rc-relative-arm-3 label-fixup ;
+
+: BX have-BX? get [ 0 (BX) ] [ PC swap MOV ] if ;
+
+: BLX have-BLX? get [ 1 (BLX) ] [ LR PC MOV BX ] if ;
+
+! More load and store instructions
+GENERIC: addressing-mode-3 ( addressing-mode -- n )
+
+: b>n/n ( b -- n n ) dup -4 shift swap HEX: f bitand ;
+
+M: addressing addressing-mode-3
+    [ addressing-p ] keep
+    [ addressing-u ] keep
+    [ addressing-w ] keep
+    delegate addressing-mode-3
+    { 0 21 23 24 } bitfield ;
+
+M: integer addressing-mode-3
+    b>n/n {
+        ! { 1 24 }
+        { 1 22 }
+        { 1 7 }
+        { 1 4 }
+        0
+        8
+    } bitfield ;
+
+M: object addressing-mode-3
+    shifter-op {
+        ! { 1 24 }
+        { 1 7 }
+        { 1 4 }
+        0
+    } bitfield ;
+
+: addr3 ( Rn Rd addressing-mode h l s -- )
+    {
+        6
+        20
+        5
+        { addressing-mode-3 0 }
+        { register 16 }
+        { register 12 }
+    } insn ;
+
+: LDRH 1 1 0 addr3 ;
+: LDRSB 0 1 1 addr3 ;
+: LDRSH 1 1 1 addr3 ;
+: STRH 1 0 0 addr3 ;
 
 ! Load and store multiple instructions
 

core/cpu/arm/bootstrap.factor

@@ -1,9 +1,11 @@
 ! Copyright (C) 2007 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: bootstrap.image.private kernel namespaces system
-cpu.arm.assembler math layouts words vocabs ;
+cpu.arm.assembler cpu.arm5.assembler math layouts words vocabs ;
 IN: bootstrap.arm
 
+T{ arm5-variant } arm-variant set-global
+
 4 \ cell set
 big-endian off
 
@@ -17,7 +19,7 @@ big-endian off
 : temp-reg R3 ;
 : xt-reg R12 ;
 
-: stack-frame 8 bootstrap-cells ;
+: stack-frame 16 bootstrap-cells ;
 
 : next-save stack-frame 2 bootstrap-cells - ;
 : xt-save stack-frame 3 bootstrap-cells - ;

core/cpu/arm/intrinsics/intrinsics.factor

@@ -9,27 +9,45 @@ sbufs.private vectors vectors.private system tuples.private
 layouts strings.private slots.private ;
 IN: cpu.arm.intrinsics
 
+: %slot-literal-known-tag
+    "val" operand
+    "obj" operand
+    "n" get cells
+    "obj" get operand-tag - <+/-> ;
+
+: %slot-literal-any-tag
+    "obj" operand "scratch" operand %untag
+    "val" operand "scratch" operand "n" get cells <+> ;
+
+: %slot-any
+    "obj" operand "scratch" operand %untag
+    "n" operand dup 1 <LSR> MOV
+    "scratch" operand "val" operand "n" operand <+> ;
+
 \ slot {
+    ! Slot number is literal and the tag is known
+    {
+        [ %slot-literal-known-tag LDR ] H{
+            { +input+ { { f "obj" known-tag } { [ small-slot? ] "n" } } }
+            { +scratch+ { { f "val" } } }
+            { +output+ { "val" } }
+        }
+    }
     ! Slot number is literal
     {
-        [
+        [ %slot-literal-any-tag LDR ] H{
-            "out" operand "obj" operand %untag
-            "out" operand dup "n" get cells <+> LDR
-        ] H{
             { +input+ { { f "obj" } { [ small-slot? ] "n" } } }
-            { +scratch+ { { f "out" } } }
+            { +scratch+ { { f "scratch" } { f "val" } } }
-            { +output+ { "out" } }
+            { +output+ { "val" } }
         }
     }
     ! Slot number in a register
     {
-        [
+        [ %slot-any LDR ] H{
-            "out" operand "obj" operand %untag
-            "out" operand dup "n" operand 1 <LSR> <+> LDR
-        ] H{
             { +input+ { { f "obj" } { f "n" } } }
-            { +scratch+ { { f "out" } } }
+            { +scratch+ { { f "val" } { f "scratch" } } }
-            { +output+ { "out" } }
+            { +output+ { "val" } }
+            { +clobber+ { "n" } }
         }
     }
 } define-intrinsics
@@ -44,13 +62,17 @@ IN: cpu.arm.intrinsics
     ] unless ;
 
 \ set-slot {
+    ! Slot number is literal and tag is known
+    {
+        [ %slot-literal-known-tag STR %write-barrier ] H{
+            { +input+ { { f "val" } { f "obj" known-tag } { [ small-slot? ] "n" } } }
+            { +scratch+ { { f "scratch" } } }
+            { +clobber+ { "val" } }
+        }
+    }
     ! Slot number is literal
     {
-        [
+        [ %slot-literal-any-tag STR %write-barrier ] H{
-            "scratch" operand "obj" operand %untag
-            "val" operand "scratch" operand "n" get cells <+> STR
-            generate-write-barrier
-        ] H{
             { +input+ { { f "val" } { f "obj" } { [ small-slot? ] "n" } } }
             { +scratch+ { { f "scratch" } } }
             { +clobber+ { "val" } }
@@ -58,12 +80,7 @@ IN: cpu.arm.intrinsics
     }
     ! Slot number is in a register
     {
-        [
+        [ %slot-any STR %write-barrier ] H{
-            "scratch" operand "obj" operand %untag
-            "n" operand "scratch" operand "n" operand 1 <LSR> ADD
-            "val" operand "n" operand 0 STR
-            generate-write-barrier
-        ] H{
             { +input+ { { f "val" } { f "obj" } { f "n" } } }
             { +scratch+ { { f "scratch" } } }
             { +clobber+ { "val" "n" } }
@@ -135,7 +152,7 @@ IN: cpu.arm.intrinsics
 : overflow-check ( insn -- )
     [
         "end" define-label
-        [ "allot-tmp" operand "x" operand "y" operand roll S execute ] keep
+        [ "out" operand "x" operand "y" operand roll S execute ] keep
         "end" get VC B
         { "x" "y" } %untag-fixnums
         "x" operand "x" operand "y" operand roll execute
@@ -146,8 +163,8 @@ IN: cpu.arm.intrinsics
 : overflow-template ( word insn -- )
     [ overflow-check ] curry H{
         { +input+ { { f "x" } { f "y" } } }
-        { +scratch+ { { f "allot-tmp" } } }
+        { +scratch+ { { f "out" } } }
-        { +output+ { "allot-tmp" } }
+        { +output+ { "out" } }
         { +clobber+ { "x" "y" } }
     } define-intrinsic ;
 
@@ -159,9 +176,9 @@ IN: cpu.arm.intrinsics
     "x" get %allot-bignum-signed-1
 ] H{
     { +input+ { { f "x" } } }
-    { +scratch+ { { f "allot-tmp" } } }
+    { +scratch+ { { f "out" } } }
     { +clobber+ { "x" } }
-    { +output+ { "allot-tmp" } }
+    { +output+ { "out" } }
 } define-intrinsic
 
 \ bignum>fixnum [
@@ -224,28 +241,39 @@ IN: cpu.arm.intrinsics
 } define-intrinsic
 
 \ type [
+    ! Get the tag
+    "out" operand "obj" operand tag-mask get AND
+    ! Compare with object tag number (3).
+    "out" operand object tag-number CMP
+    ! Tag the tag if it is not equal to 3
+    "out" operand dup NE %tag-fixnum
+    ! Load the object header if tag is equal to 3
+    "out" operand "obj" operand object tag-number <-> EQ LDR
+] H{
+    { +input+ { { f "obj" } } }
+    { +scratch+ { { f "out" } } }
+    { +output+ { "out" } }
+} define-intrinsic
+
+\ class-hash [
     "end" define-label
     ! Get the tag
-    "y" operand "obj" operand tag-mask get AND
+    "out" operand "obj" operand tag-mask get AND
+    ! Compare with tuple tag number (2).
+    "out" operand tuple tag-number CMP
+    "out" operand "obj" operand tuple-class-offset <+/-> EQ LDR
+    "out" operand dup class-hash-offset <+/-> EQ LDR
+    "end" get EQ B
     ! Compare with object tag number (3).
-    "y" operand object tag-number CMP
+    "out" operand object tag-number CMP
-    ! Tag the tag if it is not equal to 3
+    "out" operand "obj" operand object tag-number <-> EQ LDR
-    "x" operand "y" operand NE %tag-fixnum
+    ! Tag the tag
-    ! Jump to end if it is not equal to 3
+    "out" operand dup NE %tag-fixnum
-    "end" get NE B
-    ! Is the pointer itself equal to 3? Then its F_TYPE (9).
-    "obj" operand object tag-number CMP
-    ! Load F_TYPE (9) if it is equal
-    "x" operand f type v>operand EQ MOV
-    ! Load the object header if it is not equal
-    "x" operand "obj" operand object tag-number <-> NE LDR
-    ! Turn the header into a fixnum
-    "x" operand dup NE %untag
     "end" resolve-label
 ] H{
     { +input+ { { f "obj" } } }
-    { +scratch+ { { f "x" } { f "y" } } }
+    { +scratch+ { { f "out" } } }
-    { +output+ { "x" } }
+    { +output+ { "out" } }
 } define-intrinsic
 
 : userenv ( reg -- )
@@ -273,7 +301,7 @@ IN: cpu.arm.intrinsics
     { +clobber+ { "n" } }
 } define-intrinsic
 
-: %set-slot "allot-tmp" operand swap cells <+> STR ;
+: %set-slot R11 swap cells <+> STR ;
 
 : %store-length
     R12 "n" operand MOV
@@ -289,11 +317,11 @@ IN: cpu.arm.intrinsics
     ! Zero out the rest of the tuple
     R12 f v>operand MOV
     "n" get 1- [ 1+ R12 %fill-array ] each
-    object %tag-allot
+    "out" get object %store-tagged
 ] H{
     { +input+ { { f "class" } { [ inline-array? ] "n" } } }
-    { +scratch+ { { f "allot-tmp" } } }
+    { +scratch+ { { f "out" } } }
-    { +output+ { "allot-tmp" } }
+    { +output+ { "out" } }
 } define-intrinsic
 
 \ <array> [
@@ -301,11 +329,11 @@ IN: cpu.arm.intrinsics
     %store-length
     ! Store initial element
     "n" get [ "initial" operand %fill-array ] each
-    object %tag-allot
+    "out" get object %store-tagged
 ] H{
     { +input+ { { [ inline-array? ] "n" } { f "initial" } } }
-    { +scratch+ { { f "allot-tmp" } } }
+    { +scratch+ { { f "out" } } }
-    { +output+ { "allot-tmp" } }
+    { +output+ { "out" } }
 } define-intrinsic
 
 \ <byte-array> [
@@ -314,22 +342,22 @@ IN: cpu.arm.intrinsics
     ! Store initial element
     R12 0 MOV
     "n" get cell align cell /i [ R12 %fill-array ] each
-    object %tag-allot
+    "out" get object %store-tagged
 ] H{
     { +input+ { { [ inline-array? ] "n" } } }
-    { +scratch+ { { f "allot-tmp" } } }
+    { +scratch+ { { f "out" } } }
-    { +output+ { "allot-tmp" } }
+    { +output+ { "out" } }
 } define-intrinsic
 
 \ <ratio> [
     ratio 3 cells %allot
     "numerator" operand 1 %set-slot
     "denominator" operand 2 %set-slot
-    ratio %tag-allot
+    "out" get ratio %store-tagged
 ] H{
     { +input+ { { f "numerator" } { f "denominator" } } }
-    { +scratch+ { { f "allot-tmp" } } }
+    { +scratch+ { { f "out" } } }
-    { +output+ { "allot-tmp" } }
+    { +output+ { "out" } }
 } define-intrinsic
 
 \ <complex> [
@@ -337,22 +365,22 @@ IN: cpu.arm.intrinsics
     "real" operand 1 %set-slot
     "imaginary" operand 2 %set-slot
     ! Store tagged ptr in reg
-    complex %tag-allot
+    "out" get complex %store-tagged
 ] H{
     { +input+ { { f "real" } { f "imaginary" } } }
-    { +scratch+ { { f "allot-tmp" } } }
+    { +scratch+ { { f "out" } } }
-    { +output+ { "allot-tmp" } }
+    { +output+ { "out" } }
 } define-intrinsic
 
 \ <wrapper> [
     wrapper 2 cells %allot
     "obj" operand 1 %set-slot
     ! Store tagged ptr in reg
-    wrapper %tag-allot
+    "out" get object %store-tagged
 ] H{
     { +input+ { { f "obj" } } }
-    { +scratch+ { { f "allot-tmp" } } }
+    { +scratch+ { { f "out" } } }
-    { +output+ { "allot-tmp" } }
+    { +output+ { "out" } }
 } define-intrinsic
 
 \ (hashtable) [
@@ -362,80 +390,82 @@ IN: cpu.arm.intrinsics
     R12 2 %set-slot
     R12 3 %set-slot
     ! Store tagged ptr in reg
-    object %tag-allot
+    "out" get object %store-tagged
 ] H{
-    { +scratch+ { { f "allot-tmp" } } }
+    { +scratch+ { { f "out" } } }
-    { +output+ { "allot-tmp" } }
+    { +output+ { "out" } }
 } define-intrinsic
 
 \ string>sbuf [
     sbuf 3 cells %allot
     "length" operand 1 %set-slot
     "string" operand 2 %set-slot
-    object %tag-allot
+    "out" get object %store-tagged
 ] H{
     { +input+ { { f "string" } { f "length" } } }
-    { +scratch+ { { f "allot-tmp" } } }
+    { +scratch+ { { f "out" } } }
-    { +output+ { "allot-tmp" } }
+    { +output+ { "out" } }
 } define-intrinsic
 
 \ array>vector [
     vector 3 cells %allot
     "length" operand 1 %set-slot
     "array" operand 2 %set-slot
-    object %tag-allot
+    "out" get object %store-tagged
 ] H{
     { +input+ { { f "array" } { f "length" } } }
-    { +scratch+ { { f "allot-tmp" } } }
+    { +scratch+ { { f "out" } } }
-    { +output+ { "allot-tmp" } }
+    { +output+ { "out" } }
 } define-intrinsic
 
 \ curry [
     \ curry 3 cells %allot
     "obj" operand 1 %set-slot
     "quot" operand 2 %set-slot
-    object %tag-allot
+    "out" get object %store-tagged
 ] H{
     { +input+ { { f "obj" } { f "quot" } } }
-    { +scratch+ { { f "allot-tmp" } } }
+    { +scratch+ { { f "out" } } }
-    { +output+ { "allot-tmp" } }
+    { +output+ { "out" } }
 } define-intrinsic
 
 ! Alien intrinsics
+: %alien-accessor ( quot -- )
+    "offset" operand dup %untag-fixnum
+    "offset" operand dup "alien" operand ADD
+    "value" operand "offset" operand 0 <+> roll call ; inline
+
 : alien-integer-get-template
     H{
         { +input+ {
-            { f "alien" simple-c-ptr }
+            { unboxed-c-ptr "alien" c-ptr }
             { f "offset" fixnum }
         } }
-        { +scratch+ { { f "output" } } }
+        { +scratch+ { { f "value" } } }
-        { +output+ { "output" } }
+        { +output+ { "value" } }
         { +clobber+ { "offset" } }
     } ;
 
-: %alien-get ( quot -- )
-    "output" get "address" set
-    "output" operand "alien" operand-class %alien-accessor ;
-
 : %alien-integer-get ( quot -- )
-    %alien-get
+    %alien-accessor
-    "output" operand dup %tag-fixnum ; inline
+    "value" operand dup %tag-fixnum ; inline
-
-: %alien-integer-set ( quot -- )
-    "value" operand dup %untag-fixnum
-    "value" operand "alien" operand-class %alien-accessor ; inline
 
 : alien-integer-set-template
     H{
         { +input+ {
             { f "value" fixnum }
-            { f "alien" simple-c-ptr }
+            { unboxed-c-ptr "alien" c-ptr }
             { f "offset" fixnum }
         } }
-        { +scratch+ { { f "address" } } }
         { +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
@@ -448,15 +478,31 @@ IN: cpu.arm.intrinsics
 \ set-alien-unsigned-1 [ STRB ]
 define-alien-integer-intrinsics
 
-\ alien-cell [
+: alien-cell-template
-    [ LDR ] %alien-get
+    H{
-    "output" get %allot-alien
-] H{
         { +input+ {
-        { f "alien" simple-c-ptr }
+            { unboxed-c-ptr "alien" c-ptr }
             { f "offset" fixnum }
         } }
-    { +scratch+ { { f "output" } { f "allot-tmp" } } }
+        { +scratch+ { { unboxed-alien "value" } } }
-    { +output+ { "allot-tmp" } }
+        { +output+ { "value" } }
         { +clobber+ { "offset" } }
-} define-intrinsic
+    } ;
+
+\ alien-cell
+[ [ LDR ] %alien-accessor ]
+alien-cell-template define-intrinsic
+
+: set-alien-cell-template
+    H{
+        { +input+ {
+            { unboxed-c-ptr "value" pinned-c-ptr }
+            { unboxed-c-ptr "alien" c-ptr }
+            { f "offset" fixnum }
+        } }
+        { +clobber+ { "offset" } }
+    } ;
+
+\ set-alien-cell
+[ [ STR ] %alien-accessor ]
+set-alien-cell-template define-intrinsic

core/cpu/arm5/arm5.factor

@@ -1,4 +0,0 @@
-USING: cpu.arm.assembler cpu.arm5.assembler cpu.arm5.intrinsics
-namespaces ;
-
-T{ arm5-variant } arm-variant set-global

core/cpu/arm5/assembler/assembler.factor

@@ -1,74 +0,0 @@
-! Copyright (C) 2007 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: arrays generator generator.fixup kernel sequences words
-namespaces math math.bitfields cpu.arm.assembler ;
-IN: cpu.arm5.assembler
-
-TUPLE: arm5-variant ;
-
-GENERIC# (BX) 1 ( Rm l -- )
-
-M: register (BX) ( Rm l -- )
-    {
-        { 1 24 }
-        { 1 21 }
-        { BIN: 1111 16 }
-        { BIN: 1111 12 }
-        { BIN: 1111 8 }
-        5
-        { 1 4 }
-        { register 0 }
-    } insn ;
-
-M: word (BX) 0 swap (BX) rc-relative-arm-3 rel-word ;
-
-M: label (BX) 0 swap (BX) rc-relative-arm-3 label-fixup ;
-
-M: arm5-variant BX 0 (BX) ;
-
-M: arm5-variant BLX 1 (BX) ;
-
-! More load and store instructions
-GENERIC: addressing-mode-3 ( addressing-mode -- n )
-
-: b>n/n ( b -- n n ) dup -4 shift swap HEX: f bitand ;
-
-M: addressing addressing-mode-3
-    [ addressing-p ] keep
-    [ addressing-u ] keep
-    [ addressing-w ] keep
-    delegate addressing-mode-3
-    { 0 21 23 24 } bitfield ;
-
-M: integer addressing-mode-3
-    b>n/n {
-        ! { 1 24 }
-        { 1 22 }
-        { 1 7 }
-        { 1 4 }
-        0
-        8
-    } bitfield ;
-
-M: object addressing-mode-3
-    shifter-op {
-        ! { 1 24 }
-        { 1 7 }
-        { 1 4 }
-        0
-    } bitfield ;
-
-: addr3 ( Rn Rd addressing-mode h l s -- )
-    {
-        6
-        20
-        5
-        { addressing-mode-3 0 }
-        { register 16 }
-        { register 12 }
-    } insn ;
-
-: LDRH 1 1 0 addr3 ;
-: LDRSB 0 1 1 addr3 ;
-: LDRSH 1 1 1 addr3 ;
-: STRH 1 0 0 addr3 ;

core/cpu/ppc/architecture/architecture.factor

@@ -15,10 +15,8 @@ TUPLE: ppc-backend ;
 ! r14: data stack
 ! r15: retain stack
 
-! For stack frame layout, see vm/cpu-ppc.h.
+: ds-reg 14 ; inline
-
+: rs-reg 15 ; inline
-: ds-reg 14 ;
-: rs-reg 15 ;
 
 : reserved-area-size
     os {
@@ -59,13 +57,11 @@ M: int-regs vregs
     } ;
 
 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 )
@@ -123,7 +119,7 @@ M: ppc-backend %call-label ( label -- ) BL ;
 M: ppc-backend %jump-label ( label -- ) B ;
 
 : %prepare-primitive ( word -- )
-    ! Save stack pointer to stack_chain->callstack_top, load XT
+    #! Save stack pointer to stack_chain->callstack_top, load XT
     4 1 MR 11 %load-xt ;
 
 : (%call) 11 MTLR BLRL ;
@@ -137,7 +133,7 @@ M: ppc-backend %jump-primitive ( word -- )
     %prepare-primitive (%jump) ;
 
 M: ppc-backend %jump-t ( label -- )
-    0 "flag" operand \ f tag-number CMPI BNE ;
+    0 "flag" operand f v>operand CMPI BNE ;
 
 : dispatch-template ( word-table# quot -- )
     [

core/generator/generator.factor

@@ -312,3 +312,4 @@ M: #return generate-node drop end-basic-block %return f ;
 : underlying-alien-offset cell object tag-number - ;
 : tuple-class-offset 2 cells tuple tag-number - ;
 : class-hash-offset cell object tag-number - ;
+: word-xt-offset 8 cells object tag-number - ;