Further progress on the ARM backend

core/cpu/arm/allot/allot.factor

@@ -22,7 +22,7 @@ IN: cpu.arm.allot
     ;
     
 : %store-tagged ( reg tag -- )
-    >r dup fresh-object v>operand R11 r> tag-number ORI ;
+    >r dup fresh-object v>operand R11 r> tag-number ORR ;
 
 : %allot-bignum ( #digits -- )
     #! 1 cell header, 1 cell length, 1 cell sign, + digits
@@ -32,10 +32,10 @@ IN: cpu.arm.allot
     R12 R11 cell <+> STR ! store the length
     ;
 
-: %allot-bignum-signed-1 ( reg -- )
+: %allot-bignum-signed-1 ( dst src -- )
     #! on entry, reg is a 30-bit quantity sign-extended to
     #! 32-bits.
-    #! exits with tagged ptr to bignum in allot-tmp.
+    #! exits with tagged ptr to bignum in reg.
     [
         "end" define-label
         ! is it zero?
@@ -55,9 +55,9 @@ IN: cpu.arm.allot
         ! store sign
         R12 R11 2 cells <+> STR
         ! store the number
-        dup v>operand R11 3 cells <+> STR
+        v>operand R11 3 cells <+> STR
         ! tag the bignum, store it in reg
-        bignum %tag-allot
+        bignum %store-tagged
         "end" resolve-label
     ] with-scope ;
 

core/cpu/arm/architecture/architecture.factor

@@ -52,19 +52,19 @@ M: immediate load-literal
 M: arm-backend stack-frame ( n -- i )
     factor-area-size + 8 align ;
 
-M: ppc-backend %save-xt ( -- )
+M: arm-backend %save-xt ( -- )
     R12 PC 8 SUB ;
 
 M: arm-backend %prologue ( n -- )
     SP SP pick SUB
-    R11 over LI
+    R11 over MOV
     R11 SP pick next-save <+> STR
-    R12 SP rot xt-save <+> STR
+    R12 SP pick xt-save <+> STR
-    LR SP pick lr-save <+> STR ;
+    LR SP rot lr-save <+> STR ;
 
 M: arm-backend %epilogue ( n -- )
-    LR SP lr-save <+> LDR
+    LR SP pick lr-save <+> LDR
-    SP SP rot stack-frame ADD ;
+    SP SP rot ADD ;
 
 : compile-dlsym ( symbol dll reg -- )
     [
@@ -99,9 +99,6 @@ M: arm-backend %call-label ( label -- ) BL ;
 
 M: arm-backend %jump-label ( label -- ) B ;
 
-: %load-xt ( word -- )
-    0 swap LOAD32  rc-absolute-ppc-2/2 rel-word ;
-
 : %prepare-primitive ( word -- )
     #! Save stack pointer to stack_chain->callstack_top, load XT
     R1 SP MOV
@@ -145,11 +142,9 @@ M: arm-backend %return ( -- ) %epilogue-later PC LR MOV ;
 
 M: arm-backend %unwind drop %return ;
 
-: (%peek/replace)
+M: arm-backend %peek >r v>operand r> loc>operand LDR ;
-    >r drop >r v>operand r> loc>operand r> execute ;
 
-M: int-regs (%peek) \ LDR (%peek/replace) ;
+M: arm-backend %replace >r v>operand r> loc>operand STR ;
-M: int-regs (%replace) \ STR (%peek/replace) ;
 
 : (%inc) ( n reg -- )
     dup rot cells dup 0 < [ neg SUB ] [ ADD ] if ;
@@ -255,14 +250,14 @@ 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
+M: arm-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
+    ds-reg R12 8 <+> STR
-    rs-reg 11 12 <+> STR ;
+    rs-reg R12 12 <+> STR ;
 
 M: arm-backend %alien-invoke ( symbol dll -- )
     ! Load target address
@@ -314,37 +309,50 @@ M: long-long-type c-type-stack-align? drop wince? not ;
 M: arm-backend fp-shadows-int? ( -- ? ) f ;
 
 ! Alien intrinsics
-: add-alien-offset "offset" operand tag-bits get <ASR> ADD ;
+M: arm-backend %unbox-byte-array ( dst src -- )
+    [ v>operand ] 2apply byte-array-offset ADD ;
 
-: (%unbox-alien) <+> roll call ; inline
+M: arm-backend %unbox-alien ( dst src -- )
+    [ v>operand ] 2apply alien-offset <+> LDR ;
 
-M: arm-backend %unbox-byte-array ( quot src -- )
+M: arm-backend %unbox-f ( dst src -- )
-    "address" operand "alien" operand add-alien-offset
+    drop v>operand 0 MOV ;
-    "address" operand alien-offset (%unbox-alien) ;
 
-M: arm-backend %unbox-alien ( quot src -- )
+M: arm-backend %unbox-any-c-ptr ( dst src -- )
-    "address" operand "alien" operand alien-offset <+> LDR
+    #! We need three registers here. R11 and R12 are reserved
-    "address" operand dup add-alien-offset
+    #! temporary registers. The third one is R14, which we have
-    "address" operand 0 (%unbox-alien) ;
+    #! to save/restore.
-
-M: arm-backend %unbox-f ( quot src -- )
-    "offset" operand dup %untag-fixnum
-    "offset" operand 0 (%unbox-alien) ;
-
-M: arm-backend %complex-alien-accessor ( quot src -- )
-    "is-f" define-label
-    "is-alien" define-label
     "end" define-label
-    "alien" operand f v>operand CMP
+    "start" define-label
-    "is-f" get EQ B
+    ! Save R14.
-    "address" operand "alien" operand header-offset neg <-> LDR
+    R14 SP 4 <-> STR
-    "address" operand alien type-number tag-header CMP
+    ! Address is computed in RR11
-    "is-alien" get EQ B
+    R11 0 MOV
-    [ %unbox-byte-array ] 2keep
+    ! Load object into R12
-    "end" get B
+    R12 swap v>operand MOV
-    "is-alien" resolve-label
+    ! We come back here with displaced aliens
-    [ %unbox-alien ] 2keep
+    "start" resolve-label
-    "end" get B
+    ! Is the object f?
-    "is-f" resolve-label
+    R12 f v>operand CMP
-    %unbox-f
+    ! If so, done
-    "end" resolve-label ;
+    "end" get EQ B
+    ! Is the object an alien?
+    R14 R12 header-offset <+> LDR
+    R14 alien type-number tag-header CMP
+    ! Add byte array address to address being computed
+    R11 R11 R12 NE ADD
+    ! Add an offset to start of byte array's data area
+    R11 R11 byte-array-offset NE ADD
+    "end" get NE B
+    ! If alien, load the offset
+    R14 R12 alien-offset LDR
+    ! Add it to address being computed
+    R11 R11 R14 ADD
+    ! Now recurse on the underlying alien
+    R12 R12 underlying-alien-offset LDR
+    "start" get B
+    "end" resolve-label
+    ! Done, store address in destination register
+    v>operand R11 MOV
+    ! Restore R14.
+    R14 SP 4 <-> LDR ;

core/cpu/arm/arm.factor

@@ -1,7 +1,9 @@
+! Copyright (C) 2007 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
 USING: alien alien.c-types kernel math namespaces
-cpu.architecture cpu.arm.architecture cpu.arm.intrinsics
+cpu.architecture cpu.arm.architecture cpu.arm.assembler
-generator generator.registers continuations compiler io
+cpu.arm.intrinsics generator generator.registers continuations
-vocabs.loader ;
+compiler io vocabs.loader sequences ;
 
 ! EABI passes floats in integer registers.
 [ alien-float ]
@@ -34,9 +36,9 @@ T{ arm-backend } compiler-backend set-global
     "==========" print
     "You should specify the -arm-variant=<variant> switch." print
     "<variant> can be one of arm3, arm4, arm4t, or arm5." print
-    "Assuming arm4t." print
+    "Assuming arm3." print
     "==========" print
-    "arm4t" "arm-variant" set
+    "arm3" "arm-variant" set-global
 ] if
 
 "arm-variant" get { "arm4" "arm4t" "arm5" } member? [

core/cpu/arm/assembler/assembler.factor

@@ -276,7 +276,7 @@ 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 ;
+: BLX have-BLX? get [ 1 (BX) ] [ LR PC MOV BX ] if ;
 
 ! More load and store instructions
 GENERIC: addressing-mode-3 ( addressing-mode -- n )

core/cpu/arm/bootstrap.factor

@@ -1,10 +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 cpu.arm5.assembler math layouts words vocabs ;
+cpu.arm.assembler math layouts words vocabs ;
 IN: bootstrap.arm
 
-T{ arm5-variant } arm-variant set-global
+! We generate ARM3 code
+f have-BX? set
 
 4 \ cell set
 big-endian off
@@ -66,12 +67,12 @@ big-endian off
 : jit-call
     scan-reg SP scan-save <+> STR              ! save scan pointer
     LR PC MOV                                  ! save return address
-    PC xt-reg MOV                              ! call
+    xt-reg BX                                  ! call
     scan-reg SP scan-save <+> LDR              ! restore scan pointer
     ;
 
 : jit-jump
-    PC xt-reg MOV ;
+    xt-reg BX ;
 
 [ load-word-xt jit-call ] { } make jit-word-call set
 
@@ -113,6 +114,6 @@ big-endian off
     LR SP 4 <-> LDR                            ! load return address
 ] { } make jit-epilog set
 
-[ PC LR MOV ] { } make jit-return set
+[ LR BX ] { } make jit-return set
 
 "bootstrap.arm" forget-vocab

core/cpu/arm/intrinsics/intrinsics.factor

@@ -16,11 +16,11 @@ IN: cpu.arm.intrinsics
     "obj" get operand-tag - <+/-> ;
 
 : %slot-literal-any-tag
-    "obj" operand "scratch" operand %untag
+    "scratch" operand "obj" operand %untag
     "val" operand "scratch" operand "n" get cells <+> ;
 
 : %slot-any
-    "obj" operand "scratch" operand %untag
+    "scratch" operand "obj" operand %untag
     "n" operand dup 1 <LSR> MOV
     "scratch" operand "val" operand "n" operand <+> ;
 
@@ -52,8 +52,8 @@ IN: cpu.arm.intrinsics
     }
 } define-intrinsics
 
-: generate-write-barrier ( -- )
+: %write-barrier ( -- )
-    "val" operand-immediate? "obj" get fresh-object? or [
+    "val" get operand-immediate? "obj" get fresh-object? or [
         "cards_offset" f R12 %alien-global
         "scratch" operand R12 "scratch" operand card-bits <LSR> ADD
         "val" operand "scratch" operand 0 LDRB
@@ -156,7 +156,7 @@ IN: cpu.arm.intrinsics
         "end" get VC B
         { "x" "y" } %untag-fixnums
         "x" operand "x" operand "y" operand roll execute
-        "x" get %allot-bignum-signed-1
+        "out" get "x" get %allot-bignum-signed-1
         "end" resolve-label
     ] with-scope ; inline
 
@@ -173,7 +173,7 @@ IN: cpu.arm.intrinsics
 
 \ fixnum>bignum [
     "x" operand dup %untag-fixnum
-    "x" get %allot-bignum-signed-1
+    "out" get "x" get %allot-bignum-signed-1
 ] H{
     { +input+ { { f "x" } } }
     { +scratch+ { { f "out" } } }