cleaning up relocation code

library/bootstrap/boot-stage2.factor

@@ -59,7 +59,7 @@ cpu "ppc" = [
     "/library/compiler/ppc/generator.factor"
 ] pull-in
 
-"compile" get cpu "x86" = and [
+"compile" get supported-cpu? and [
     init-assembler
     \ car compile
     \ = compile

library/compiler/generator.factor

@@ -4,34 +4,6 @@ IN: compiler
 USING: assembler inference errors kernel lists math namespaces
 strings words vectors ;
 
-! To support saving compiled code to disk, generator words
-! append relocation instructions to this vector.
-SYMBOL: relocation-table
-
-: rel, ( n -- ) relocation-table get vector-push ;
-
-: relocating compiled-offset cell - rel, ;
-
-: rel-primitive ( word rel/abs -- )
-    #! If flag is true; relative.
-    0 1 ? rel, relocating word-primitive rel, ;
-
-: rel-dlsym ( name dll rel/abs -- )
-    #! If flag is true; relative.
-    2 3 ? rel, relocating cons intern-literal rel, ;
-
-: rel-address ( -- )
-    #! Relocate address just compiled.
-    4 rel, relocating 0 rel, ;
-
-: rel-word ( word rel/abs -- )
-    #! If flag is true; relative.
-    over primitive? [
-        rel-primitive
-    ] [
-        nip [ rel-address ] unless
-    ] ifte ;
-
 : generate-node ( [[ op params ]] -- )
     #! Generate machine code for a node.
     unswons dup "generator" word-prop [

library/compiler/ppc/stack.factor

@@ -36,5 +36,14 @@ USING: compiler errors kernel math memory words ;
 \ dup [ drop  PEEK-DS PUSH-DS ] "generator" set-word-prop
 \ over [ drop  18 14 -4 LWZ  PUSH-DS ] "generator" set-word-prop
 \ pick [ drop  18 14 -8 LWZ  PUSH-DS ] "generator" set-word-prop
+
+\ swap [
+    drop
+    18 14 -4 LWZ
+    19 14 0 LWZ
+    19 14 -4 STW
+    18 14 0 STW
+] "generator" set-word-prop
+
 \ >r [ drop  POP-DS PUSH-CS ] "generator" set-word-prop
 \ r> [ drop  POP-CS PUSH-DS ] "generator" set-word-prop

library/compiler/x86/generator.factor

@@ -10,26 +10,21 @@ math memory namespaces words ;
     [ ESI ] EAX MOV
 ] "generator" set-word-prop
 
-: compile-call-label ( label -- )
+: compile-call-label ( label -- ) 0 CALL fixup t defer-xt ;
-    0 CALL fixup compiled-offset defer-xt ;
+: compile-jump-label ( label -- ) 0 JMP fixup t defer-xt ;
-
-: compile-jump-label ( label -- )
-    0 JMP fixup compiled-offset defer-xt ;
 
 : compile-call ( word -- )
-    dup dup postpone-word  compile-call-label  t rel-word ;
+    dup postpone-word  compile-call-label ;
 
 : compile-target ( word -- )
-    compiled-offset 0 compile-cell 0 defer-xt ;
+    compiled-offset 0 compile-cell f defer-xt ;
 
 #call [
     compile-call
 ] "generator" set-word-prop
 
 #jump [
-    dup dup postpone-word
+    dup postpone-word  compile-jump-label
-    compile-jump-label
-    t rel-word
 ] "generator" set-word-prop
 
 #call-label [
@@ -45,34 +40,24 @@ math memory namespaces words ;
     ! condition is now in EAX
     EAX f address CMP
     ! jump w/ address added later
-    0 JNE fixup compiled-offset defer-xt ;
+    0 JNE fixup t defer-xt ;
 
-#jump-t-label [
+#jump-t-label [ compile-jump-t ] "generator" set-word-prop
-    compile-jump-t
-] "generator" set-word-prop
 
-#jump-t [
+#jump-t [ dup compile-jump-t ] "generator" set-word-prop
-    dup compile-jump-t t rel-word
-] "generator" set-word-prop
 
 : compile-jump-f ( word -- )
     POP-DS
     ! condition is now in EAX
     EAX f address CMP
     ! jump w/ address added later
-    0 JE fixup compiled-offset defer-xt ;
+    0 JE fixup t defer-xt ;
 
-#jump-f-label [
+#jump-f-label [ compile-jump-f ] "generator" set-word-prop
-    compile-jump-f
-] "generator" set-word-prop
 
-#jump-f [
+#jump-f [ dup compile-jump-f ] "generator" set-word-prop
-    dup compile-jump-f t rel-word
-] "generator" set-word-prop
 
-#return-to [
+#return-to [ 0 PUSH fixup f defer-xt ] "generator" set-word-prop
-    0 PUSH fixup 0 defer-xt rel-address
-] "generator" set-word-prop
 
 #return [ drop RET ] "generator" set-word-prop
 
@@ -83,7 +68,7 @@ math memory namespaces words ;
     drop
     POP-DS
     EAX 1 SHR
-    EAX HEX: ffff ADD fixup rel-address
+    EAX HEX: ffff ADD fixup f rel-address
     [ EAX ] JMP
     compile-aligned
     compiled-offset swap set-compiled-cell ( fixup -- )
@@ -91,12 +76,12 @@ math memory namespaces words ;
 
 #target-label [
     #! Jump table entries are absolute addresses.
-    compile-target rel-address
+    compile-target
 ] "generator" set-word-prop
 
 #target [
     #! Jump table entries are absolute addresses.
-    dup dup postpone-word compile-target f rel-word
+    dup postpone-word compile-target
 ] "generator" set-word-prop
 
 #c-call [

library/compiler/x86/stack.factor

@@ -47,7 +47,7 @@ USING: inference kernel assembler words lists alien memory ;
     [ ESI ] swap address MOV ;
 
 : indirect-literal ( obj -- )
-    EAX swap intern-literal unit MOV  rel-address ;
+    EAX swap intern-literal unit MOV  f rel-address ;
 
 #push-immediate [
     ESI 4 ADD

library/compiler/xt.factor

@@ -2,7 +2,32 @@
 ! See http://factor.sf.net/license.txt for BSD license.
 IN: compiler
 USING: assembler errors kernel lists math namespaces strings
-words ;
+vectors words ;
+
+! To support saving compiled code to disk, generator words
+! append relocation instructions to this vector.
+SYMBOL: relocation-table
+
+: rel, ( n -- ) relocation-table get vector-push ;
+
+: relocating compiled-offset cell - rel, ;
+
+: rel-primitive ( word rel/abs -- )
+    #! If flag is true; relative.
+    0 1 ? rel, relocating word-primitive rel, ;
+
+: rel-dlsym ( name dll rel/abs -- )
+    #! If flag is true; relative.
+    2 3 ? rel, relocating cons intern-literal rel, ;
+
+: rel-address ( rel/abs -- )
+    #! Relocate address just compiled. If flag is true,
+    #! relative, and there is nothing to do.
+    [ 4 rel, relocating 0 rel, ] unless ;
+
+: rel-word ( word rel/abs -- )
+    #! If flag is true; relative.
+    over primitive? [ rel-primitive ] [ nip rel-address ] ifte ;
 
 ! We use a hashtable "compiled-xts" that maps words to
 ! xt's that are currently being compiled. The commit-xt's word
@@ -43,9 +68,11 @@ SYMBOL: deferred-xts
 
 SYMBOL: compile-words
 
-: defer-xt ( word where relative -- )
+: defer-xt ( word where rel/abs -- )
-    #! After word is compiled, put its XT at where, relative.
+    #! After word is compiled, put its XT at where. If rel/abs
-    3list deferred-xts cons@ ;
+    #! is true, this is a relative jump.
+    3dup compiled-offset 0 ? 3list deferred-xts cons@
+    nip rel-word ;
 
 : compiling? ( word -- ? )
     #! A word that is compiling or already compiled will not be