ARM fixes

core/alien/compiler/compiler.factor

@@ -387,7 +387,7 @@ TUPLE: callback-context ;
     dup alien-callback-xt dup rot [
         init-templates
         generate-profiler-prologue
-        %save-xt
+        %save-word-xt
         %prologue-later
         dup alien-stack-frame [
             dup registers>objects

core/cpu/architecture/architecture.factor

@@ -50,7 +50,12 @@ HOOK: %epilogue compiler-backend ( n -- )
 HOOK: %profiler-prologue compiler-backend ( word -- )
 
 ! Store word XT in stack frame
-HOOK: %save-xt compiler-backend ( -- )
+HOOK: %save-word-xt compiler-backend ( -- )
+
+! Store dispatch branch XT in stack frame
+HOOK: %save-dispatch-xt compiler-backend ( -- )
+
+M: object %save-dispatch-xt %save-word-xt ;
 
 ! Call another label
 HOOK: %call-label compiler-backend ( label -- )

core/cpu/arm/architecture/architecture.factor

@@ -47,6 +47,16 @@ M: rs-loc loc>operand rs-loc-n cells neg rs-reg swap <+/-> ;
         "end" resolve-label
     ] with-scope ;
 
+: call-cell ( -- )
+    ! Compute return address; we skip 3 instructions
+    LR PC 8 ADD
+    ! Load target address
+    R12 PC 0 <+> LDR
+    ! Jump to target address
+    R12 BX
+    ! The target address
+    0 , ;
+
 M: arm-backend load-indirect ( obj reg -- )
     tuck load-cell rc-absolute-cell rel-literal
     dup 0 <+> LDR ;
@@ -66,9 +76,12 @@ M: immediate load-literal
 M: arm-backend stack-frame ( n -- i )
     factor-area-size + 8 align ;
 
-M: arm-backend %save-xt ( -- )
+M: arm-backend %save-word-xt ( -- )
     R12 PC 9 cells SUB ;
 
+M: arm-backend %save-dispatch-xt ( -- )
+    R12 PC 2 cells SUB ;
+
 M: arm-backend %prologue ( n -- )
     SP SP pick SUB
     R11 over MOV
@@ -98,31 +111,36 @@ M: arm-backend %call-label ( label -- ) BL ;
 
 M: arm-backend %jump-label ( label -- ) B ;
 
-: %prepare-primitive ( word -- )
+: %prepare-primitive ( -- )
     #! Save stack pointer to stack_chain->callstack_top, load XT
-    R1 SP MOV
-    T{ temp-reg } load-literal
-    R12 R12 word-xt-offset <+> LDR ;
+    R1 SP MOV ;
 
 M: arm-backend %call-primitive ( word -- )
-    %prepare-primitive R12 BLX ;
+    %prepare-primitive
+    call-cell rc-absolute-cell rel-word ;
 
 M: arm-backend %jump-primitive ( word -- )
-    %prepare-primitive R12 BX ;
+    %prepare-primitive
+    ! Load target address
+    R12 PC 0 <+> LDR
+    ! Jump to target address
+    R12 BX
+    ! The target address
+    0 , rc-absolute-cell rel-word ;
 
 M: arm-backend %jump-t ( label -- )
     "flag" operand f v>operand CMP NE B ;
 
-: (%dispatch) ( word-table# reg -- )
+: (%dispatch) ( word-table# -- )
     #! Load jump table target address into reg.
     "scratch" operand PC "n" operand 1 <LSR> ADD
-    "scratch" operand 0 <+> LDR
+    "scratch" operand dup 0 <+> LDR
     rc-indirect-arm rel-dispatch
     "scratch" operand dup compiled-header-size ADD ;
 
 M: arm-backend %call-dispatch ( word-table# -- )
     [
-        "scratch" operand (%dispatch)
+        (%dispatch)
         "scratch" operand BLX
     ] H{
         { +input+ { { f "n" } } }
@@ -132,7 +150,8 @@ M: arm-backend %call-dispatch ( word-table# -- )
 M: arm-backend %jump-dispatch ( word-table# -- )
     [
         %epilogue-later
-        PC (%dispatch)
+        (%dispatch)
+        "scratch" operand BX
     ] H{
         { +input+ { { f "n" } } }
         { +scratch+ { { f "scratch" } } }
@@ -260,14 +279,7 @@ M: arm-backend %prepare-alien-invoke
     rs-reg R12 12 <+> STR ;
 
 M: arm-backend %alien-invoke ( symbol dll -- )
-    ! Load target address
-    R12 PC 4 <+> LDR
-    ! Store address of next instruction in LR
-    LR PC 4 ADD
-    ! Jump to target address
-    R12 BX
-    ! The target address
-    0 , rc-absolute rel-dlsym ;
+    call-cell rc-absolute-cell rel-dlsym ;
 
 M: arm-backend %prepare-alien-indirect ( -- )
     "unbox_alien" f %alien-invoke

core/cpu/ppc/architecture/architecture.factor

@@ -76,7 +76,7 @@ M: ppc-backend load-indirect ( obj reg -- )
     [ 0 swap LOAD32 rc-absolute-ppc-2/2 rel-literal ] keep
     dup 0 LWZ ;
 
-M: ppc-backend %save-xt ( -- )
+M: ppc-backend %save-word-xt ( -- )
     0 11 LOAD32 rc-absolute-ppc-2/2 rel-current-word ;
 
 M: ppc-backend %prologue ( n -- )

core/cpu/x86/architecture/architecture.factor

@@ -44,7 +44,7 @@ M: immediate load-literal v>operand swap v>operand MOV ;
 M: x86-backend stack-frame ( n -- i )
     3 cells + 16 align cell - ;
 
-M: x86-backend %save-xt ( -- )
+M: x86-backend %save-word-xt ( -- )
     xt-reg 0 MOV rc-absolute-cell rel-current-word ;
 
 : factor-area-size 4 cells ;

core/generator/generator.factor

@@ -60,7 +60,7 @@ GENERIC: generate-node ( node -- next )
     [
         init-templates
         generate-profiler-prologue
-        %save-xt
+        %save-word-xt
         %prologue-later
         current-label-start define-label
         current-label-start resolve-label
@@ -189,7 +189,7 @@ M: #if generate-node
     gensym [
         rot [
             copy-templates
-            %save-xt
+            %save-dispatch-xt
             %prologue-later
             [ generate-nodes ] with-node-iterator
         ] generate-1

vm/cpu-arm.S

@@ -124,3 +124,8 @@ DEF(void,lazy_jit_compile,(CELL quot)):
 	bl MANGLE(primitive_jit_compile)
 	EPILOGUE
         JUMP_QUOT            /* call the quotation */
+
+#ifdef WINCE
+	.section .drectve
+	.ascii " -export:c_to_factor"
+#endif