Redo compiler.codegen.fixup and get %dispatch to work

basis/compiler/codegen/codegen-tests.factor

@@ -0,0 +1,14 @@
+IN: compiler.codegen.tests
+USING: compiler.codegen.fixup tools.test cpu.architecture math kernel make
+compiler.constants ;
+
+[ ] [ [ ] with-fixup drop ] unit-test
+[ ] [ [ \ + %call ] with-fixup drop ] unit-test
+
+[ ] [ [ <label> dup define-label dup resolve-label %jump-label ] with-fixup drop ] unit-test
+[ ] [ [ <label> dup define-label dup resolve-label B{ 0 0 0 0 } % rc-absolute-cell label-fixup ] with-fixup drop ] unit-test
+
+! Error checking
+[ [ <label> dup define-label %jump-label ] with-fixup ] must-fail
+[ [ <label> dup define-label B{ 0 0 0 0 } % rc-relative label-fixup ] with-fixup ] must-fail
+[ [ <label> dup define-label B{ 0 0 0 0 } % rc-absolute-cell label-fixup ] with-fixup ] must-fail

basis/compiler/codegen/codegen.factor

@@ -26,14 +26,6 @@ SYMBOL: registers
 : ?register ( obj -- operand )
     dup vreg? [ register ] when ;
 
-: generate-insns ( insns -- code )
-    [
-        [
-            dup regs>> registers set
-            generate-insn
-        ] each
-    ] { } make fixup ;
-
 TUPLE: asm label code calls ;
 
 SYMBOL: calls
@@ -51,17 +43,22 @@ SYMBOL: labels
 
 : init-generator ( word -- )
     H{ } clone labels set
-    V{ } clone literal-table set
     V{ } clone calls set
     compiling-word set
     compiled-stack-traces? [ compiling-word get add-literal ] when ;
 
+: generate-insns ( asm -- code )
+    [
+        [ word>> init-generator ]
+        [
+            instructions>>
+            [ [ regs>> registers set ] [ generate-insn ] bi ] each
+        ] bi
+    ] with-fixup ;
+
 : generate ( mr -- asm )
     [
-        [ label>> ]
-        [ word>> init-generator ]
-        [ instructions>> generate-insns ] tri
-        calls get
+        [ label>> ] [ generate-insns ] bi calls get
         asm boa
     ] with-scope ;
 
@@ -487,7 +484,7 @@ M: _epilogue generate-insn
     stack-frame>> total-size>> %epilogue ;
 
 M: _label generate-insn
-    id>> lookup-label , ;
+    id>> lookup-label resolve-label ;
 
 M: _branch generate-insn
     label>> lookup-label %jump-label ;

basis/compiler/codegen/fixup/fixup.factor

@@ -4,51 +4,48 @@ USING: arrays byte-arrays byte-vectors generic assocs hashtables
 io.binary kernel kernel.private math namespaces make sequences
 words quotations strings alien.accessors alien.strings layouts
 system combinators math.bitwise math.order
-accessors growable cpu.architecture compiler.constants ;
+accessors growable compiler.constants ;
 IN: compiler.codegen.fixup
 
-GENERIC: fixup* ( obj -- )
+! Literal table
+SYMBOL: literal-table
+
+: add-literal ( obj -- ) literal-table get push ;
+
+! Labels
+SYMBOL: label-table
+
+TUPLE: label offset ;
+
+: <label> ( -- label ) label new ;
+: define-label ( name -- ) <label> swap set ;
 
 : compiled-offset ( -- n ) building get length ;
 
-SYMBOL: relocation-table
-SYMBOL: label-table
-
-M: label fixup* compiled-offset >>offset drop ;
+: resolve-label ( label/name -- )
+    dup label? [ get ] unless
+    compiled-offset >>offset drop ;
 
 : offset-for-class ( class -- n )
     rc-absolute-cell = cell 4 ? compiled-offset swap - ;
 
-TUPLE: label-fixup { label label } { class integer } ;
+TUPLE: label-fixup { label label } { class integer } { offset integer } ;
 
-: label-fixup ( label class -- ) \ label-fixup boa , ;
+: label-fixup ( label class -- )
+    dup offset-for-class \ label-fixup boa label-table get push ;
+
+! Relocation table
+SYMBOL: relocation-table
 
 : push-4 ( value vector -- )
     [ length ] [ B{ 0 0 0 0 } swap push-all ] [ underlying>> ] tri
     swap set-alien-unsigned-4 ;
 
 : add-relocation-entry ( type class offset -- )
-      { 0 24 28 } bitfield relocation-table get push-4 ;
+    { 0 24 28 } bitfield relocation-table get push-4 ;
 
-M: label-fixup fixup*
-    [ class>> dup offset-for-class ] [ label>> ] bi
-    [ drop [ rt-here ] 2dip add-relocation-entry ]
-    [ 3array label-table get push ]
-    3bi ;
-
-TUPLE: rel-fixup { class integer } { type integer } ;
-
-: rel-fixup ( class type -- ) \ rel-fixup boa , ;
-
-M: rel-fixup fixup*
-    [ type>> ] [ class>> dup offset-for-class ] bi
-    add-relocation-entry ;
-
-M: integer fixup* , ;
-
-SYMBOL: literal-table
-
-: add-literal ( obj -- ) literal-table get push ;
+: rel-fixup ( class type -- )
+    swap dup offset-for-class add-relocation-entry ;
 
 : add-dlsym-literals ( symbol dll -- )
     [ string>symbol add-literal ] [ add-literal ] bi* ;
@@ -77,22 +74,34 @@ SYMBOL: literal-table
 : rel-here ( offset class -- )
     [ add-literal ] dip rt-here rel-fixup ;
 
+! And the rest
+: resolve-offset ( label-fixup -- offset )
+    label>> offset>> [ "Unresolved label" throw ] unless* ;
+
+: resolve-absolute-label ( label-fixup -- )
+    dup resolve-offset neg add-literal
+    [ rt-here ] dip [ class>> ] [ offset>> ] bi add-relocation-entry ;
+
+: resolve-relative-label ( label-fixup -- )
+    [ class>> ] [ offset>> ] [ resolve-offset ] tri 3array ;
+
+: resolve-labels ( label-fixups -- labels' )
+    [ class>> rc-absolute? ] partition
+    [ [ resolve-absolute-label ] each ]
+    [ [ resolve-relative-label ] map concat ]
+    bi* ;
+
 : init-fixup ( -- )
-    BV{ } clone relocation-table set
-    V{ } clone label-table set ;
+    V{ } clone literal-table set
+    V{ } clone label-table set
+    BV{ } clone relocation-table set ;
 
-: resolve-labels ( labels -- labels' )
-    [
-        first3 offset>>
-        [ "Unresolved label" throw ] unless*
-        3array
-    ] map concat ;
-
-: fixup ( fixup-directives -- code )
+: with-fixup ( quot -- code )
     [
         init-fixup
-        [ fixup* ] each
+        call
+        label-table [ resolve-labels ] change
         literal-table get >array
         relocation-table get >byte-array
-        label-table get resolve-labels
-    ] B{ } make 4array ;
+        label-table get
+    ] B{ } make 4array ; inline

basis/cpu/architecture/architecture.factor

@@ -5,13 +5,6 @@ memory namespaces make sequences layouts system hashtables
 classes alien byte-arrays combinators words sets fry ;
 IN: cpu.architecture
 
-! Labels
-TUPLE: label offset ;
-
-: <label> ( -- label ) label new ;
-: define-label ( name -- ) <label> swap set ;
-: resolve-label ( label/name -- ) dup label? [ get ] unless , ;
-
 ! Register classes
 SINGLETON: int-regs
 SINGLETON: single-float-regs
@@ -52,7 +45,7 @@ HOOK: %jump-label cpu ( label -- )
 HOOK: %return cpu ( -- )
 
 HOOK: %dispatch cpu ( src temp -- )
-HOOK: %dispatch-label cpu ( src temp -- )
+HOOK: %dispatch-label cpu ( label -- )
 
 HOOK: %slot cpu ( dst obj slot tag temp -- )
 HOOK: %slot-imm cpu ( dst obj slot tag -- )

basis/cpu/x86/x86.factor

@@ -74,7 +74,7 @@ M: x86 %jump-label ( label -- ) 0 JMP rc-relative label-fixup ;
 M: x86 %return ( -- ) 0 RET ;
 
 : code-alignment ( align -- n )
-    [ building get [ integer? ] count dup ] dip align swap - ;
+    [ building get length dup ] dip align swap - ;
 
 : align-code ( n -- )
     0 <repetition> % ;

vm/code_block.cpp

@@ -159,7 +159,10 @@ cell compute_relocation(relocation_entry rel, cell index, code_block *compiled)
 	case RT_XT_PIC_TAIL:
 		return (cell)word_xt_pic_tail(untag<word>(ARG));
 	case RT_HERE:
-		return offset + untag_fixnum(ARG);
+	{
+		fixnum arg = untag_fixnum(ARG);
+		return (arg >= 0 ? offset + arg : (cell)(compiled +1) - arg);
+	}
 	case RT_THIS:
 		return (cell)(compiled + 1);
 	case RT_STACK_CHAIN: