From 00d970cf1590be892a316ae93161b8f5aa2491b5 Mon Sep 17 00:00:00 2001
From: slava <slava@factorcode.org>
Date: Wed, 9 Aug 2006 06:12:01 +0000
Subject: [PATCH] Compiled code labels are now first-class

---
 library/compiler/generator/generator.factor   | 34 +++++-----
 library/compiler/generator/xt.factor          | 63 +++++++++++--------
 library/compiler/inference/known-words.factor |  2 +-
 library/compiler/ppc/assembler.factor         |  2 +
 library/compiler/ppc/intrinsics.factor        | 28 ++++-----
 library/compiler/x86/architecture.factor      |  4 +-
 library/compiler/x86/intrinsics.factor        | 24 +++----
 vm/alien.c                                    | 18 +++---
 vm/bignum.c                                   |  1 -
 vm/factor.c                                   |  1 -
 vm/image.c                                    | 24 +++++--
 vm/image.h                                    |  6 +-
 vm/run.c                                      | 41 +++++++++---
 vm/run.h                                      |  1 -
 14 files changed, 150 insertions(+), 99 deletions(-)

diff --git a/library/compiler/generator/generator.factor b/library/compiler/generator/generator.factor
index f608fd6ae2..677f7d2cc6 100644
--- a/library/compiler/generator/generator.factor
+++ b/library/compiler/generator/generator.factor
@@ -42,17 +42,23 @@ UNION: #terminal
 
 : init-generator ( -- )
     V{ } clone relocation-table set
-    V{ } clone literal-table set ;
+    V{ } clone literal-table set
+    V{ } clone label-table set
+    V{ } clone label-relocation-table set ;
 
 : generate-1 ( word node quot -- | quot: node -- )
-    [
+    #! Generate the code, then dump five vectors to pass to
+    #! add-compiled-block.
+    pick f save-xt [
         init-generator
         init-templates
         generate-code
         relocation-table get
         literal-table get
+        label-table get
+        label-relocation-table get
     ] V{ } make
-    code-format 2swap add-compiled-block swap save-xt ;
+    code-format add-compiled-block save-xt ;
 
 SYMBOL: generate-queue
 
@@ -90,9 +96,6 @@ M: node generate-node ( node -- next ) drop iterate-next ;
     tail-call? [ %jump f ] [ %call iterate-next ] if ;
 
 M: #label generate-node ( node -- next )
-    #! We remap the IR node's label to a new label object here,
-    #! to avoid problems with two IR #label nodes having the
-    #! same label in different lexical scopes.
     dup node-param dup generate-call >r
     swap node-child generate-word r> ;
 
@@ -103,8 +106,8 @@ M: #label generate-node ( node -- next )
 : generate-if ( node label -- next )
     <label> [
         >r >r node-children first2 generate-nodes
-        r> r> end-false-branch save-xt generate-nodes
-    ] keep save-xt iterate-next ;
+        r> r> end-false-branch resolve-label generate-nodes
+    ] keep resolve-label iterate-next ;
 
 M: #if generate-node ( node -- next )
     [
@@ -125,12 +128,12 @@ M: #if generate-node ( node -- next )
     [with-template] "if-intrinsic" set-word-prop ;
 
 : if>boolean-intrinsic ( label -- )
-    <label> "end" set
+    "end" define-label
     f 0 <int-vreg> load-literal
     "end" get %jump-label
-    save-xt
+    resolve-label
     t 0 <int-vreg> load-literal
-    "end" get save-xt
+    "end" get resolve-label
     0 <int-vreg> phantom-d get phantom-push
     compute-free-vregs ;
 
@@ -154,7 +157,7 @@ M: #call-label generate-node ( node -- next )
     node-param generate-call ;
 
 ! #dispatch
-: target-label ( label -- ) 0 , rel-absolute-cell rel-word ;
+: target-label ( label -- ) 0 , rel-absolute-cell rel-label ;
 
 : dispatch-head ( node -- label/node )
     #! Output the jump table insn and return a list of
@@ -167,9 +170,9 @@ M: #call-label generate-node ( node -- next )
 
 : dispatch-body ( label/node -- )
     <label> swap [
-        first2 save-xt generate-nodes end-basic-block
+        first2 resolve-label generate-nodes end-basic-block
         dup %jump-label
-    ] each save-xt ;
+    ] each resolve-label ;
 
 M: #dispatch generate-node ( node -- next )
     #! The parameter is a list of nodes, each one is a branch to
@@ -220,9 +223,10 @@ M: #shuffle generate-node ( #shuffle -- )
 ! #return
 M: #return generate-node drop end-basic-block %return f ;
 
-! These constants must match native/card.h
+! These constants must match vm/memory.h
 : card-bits 7 ;
 : card-mark HEX: 80 ;
 
+! These constants must match vm/layouts.h
 : float-offset 8 float-tag - ;
 : string-offset 3 cells object-tag - ;
diff --git a/library/compiler/generator/xt.factor b/library/compiler/generator/xt.factor
index 56ec99efee..77069da638 100644
--- a/library/compiler/generator/xt.factor
+++ b/library/compiler/generator/xt.factor
@@ -5,27 +5,31 @@ USING: arrays assembler errors generic hashtables kernel
 kernel-internals math namespaces prettyprint queues
 sequences strings vectors words ;
 
-: <label> ( -- label )
-    #! Make a label.
-    gensym  dup t "label" set-word-prop ;
+: compiled ( -- n ) building get length code-format * ;
 
-: label? ( obj -- ? )
-    dup word? [ "label" word-prop ] [ drop f ] if ;
+TUPLE: label # offset ;
+
+SYMBOL: label-table
+
+: push-label ( label -- )
+    label-table get 2dup memq?
+    [ 2drop ] [ dup length pick set-label-# push ] if ;
+
+C: label ( -- label ) ;
+
+: define-label ( name -- ) <label> swap set ;
+
+: resolve-label ( label -- )
+    compiled swap set-label-offset ;
 
-! We use a hashtable "compiled-xts" that maps words to
-! xt's that are currently being compiled. The commit-xt's word
-! sets the xt of each word in the hashtable to the value in the
-! hastable.
 SYMBOL: compiled-xts
 
-: save-xt ( xt word -- ) compiled-xts get set-hash ;
+: save-xt ( word -- )
+    compiled swap compiled-xts get set-hash ;
 
 : commit-xts ( -- )
     compiled-xts get [ swap set-word-xt ] hash-each ;
 
-: compiled-xt ( word -- xt )
-    dup compiled-xts get hash [ ] [ word-xt ] ?if ;
-
 SYMBOL: literal-table
 
 : add-literal ( obj -- n )
@@ -36,8 +40,7 @@ SYMBOL: literal-table
     ] if ;
 
 SYMBOL: relocation-table
-
-: rel, ( n -- ) relocation-table get push ;
+SYMBOL: label-relocation-table
 
 : rel-absolute-cell 0 ;
 : rel-absolute 1 ;
@@ -47,29 +50,36 @@ SYMBOL: relocation-table
 : rel-relative-2 5 ;
 : rel-relative-3 6 ;
 
-: compiled ( -- n ) building get length code-format * ;
-
-: rel-type, ( arg class type -- )
+: (rel) ( arg class type -- { m n } )
     #! Write a relocation instruction for the runtime image
     #! loader.
-    over >r >r >r 16 shift r> 8 shift bitor r> bitor rel,
-    compiled r> rel-absolute-cell = cell 4 ? - rel, ;
+    over >r >r >r 16 shift r> 8 shift bitor r> bitor
+    compiled r> rel-absolute-cell = cell 4 ? - 2array ;
+
+: rel, ( arg class type -- )
+    (rel) relocation-table get nappend ;
+
+: label, ( arg class type -- )
+    (rel) label-relocation-table get nappend ;
 
 : rel-dlsym ( name dll class -- )
-   >r 2array add-literal r> 1 rel-type, ;
+   >r 2array add-literal r> 1 rel, ;
 
 : rel-here ( class -- )
-    dup rel-relative = [ drop ] [ 0 swap 2 rel-type, ] if ;
+    dup rel-relative = [ drop ] [ 0 swap 2 rel, ] if ;
 
 : rel-word ( word class -- )
     over primitive?
     [ >r word-primitive r> 0 ] [ >r add-literal r> 5 ] if
-    rel-type, ;
+    rel, ;
 
-: rel-cards ( class -- ) 0 swap 3 rel-type, ;
+: rel-cards ( class -- ) 0 swap 3 rel, ;
 
 : rel-literal ( literal class -- )
-    >r add-literal r> 4 rel-type, ;
+    >r add-literal r> 4 rel, ;
+
+: rel-label ( label class -- )
+    >r dup push-label label-# r> 5 label, ;
 
 ! When a word is encountered that has not been previously
 ! compiled, it is pushed onto this vector. Compilation stops
@@ -80,9 +90,8 @@ SYMBOL: compile-words
     #! A word that is compiling or already compiled will not be
     #! added to the list of words to be compiled.
     dup compiled?
-    over label? or
     over compile-words get member? or
-    swap compiled-xts get hash or ;
+    swap compiled-xts get hash-member? or ;
 
 : with-compiler ( quot -- )
     [
diff --git a/library/compiler/inference/known-words.factor b/library/compiler/inference/known-words.factor
index ef7eeb8f17..48776ee337 100644
--- a/library/compiler/inference/known-words.factor
+++ b/library/compiler/inference/known-words.factor
@@ -289,7 +289,7 @@ sequences strings vectors words prettyprint ;
 \ cwd [ [ ] [ string ] ] "infer-effect" set-word-prop
 \ cd [ [ string ] [ ] ] "infer-effect" set-word-prop
 
-\ add-compiled-block [ [ vector integer vector vector ] [ integer ] ] "infer-effect" set-word-prop
+\ add-compiled-block [ [ vector vector vector vector integer ] [ integer ] ] "infer-effect" set-word-prop
 
 \ dlopen [ [ string ] [ dll ] ] "infer-effect" set-word-prop
 \ dlsym [ [ string object ] [ integer ] ] "infer-effect" set-word-prop
diff --git a/library/compiler/ppc/assembler.factor b/library/compiler/ppc/assembler.factor
index cf673e335b..8cadd5bd65 100644
--- a/library/compiler/ppc/assembler.factor
+++ b/library/compiler/ppc/assembler.factor
@@ -162,12 +162,14 @@ words ;
 G: (B) ( dest aa lk -- ) 2 standard-combination ;
 M: integer (B) i-form 18 insn ;
 M: word (B) 0 -rot (B) rel-relative-3 rel-word ;
+M: label (B) 0 -rot (B) rel-relative-3 rel-label ;
 
 : B 0 0 (B) ; : BL 0 1 (B) ;
 
 GENERIC: BC
 M: integer BC 0 0 b-form 16 insn ;
 M: word BC >r 0 BC r> rel-relative-2 rel-word ;
+M: label BC >r 0 BC r> rel-relative-2 rel-label ;
 
 : BLT 12 0 rot BC ;  : BGE 4 0 rot BC ;
 : BGT 12 1 rot BC ;  : BLE 4 1 rot BC ;
diff --git a/library/compiler/ppc/intrinsics.factor b/library/compiler/ppc/intrinsics.factor
index 7af8980215..9fc56a06b9 100644
--- a/library/compiler/ppc/intrinsics.factor
+++ b/library/compiler/ppc/intrinsics.factor
@@ -129,14 +129,14 @@ math-internals namespaces sequences words ;
 
 : simple-overflow ( word -- )
     >r
-    <label> "end" set
+    "end" define-label
     "end" get BNO
     { "x" "y" } [ operand ] map prune [ dup untag-fixnum ] each
     3 "y" operand "x" operand r> execute
     "s48_long_to_bignum" f %alien-invoke
     ! An untagged pointer to the bignum is now in r3; tag it
     3 "r" operand bignum-tag ORI
-    "end" get save-xt ; inline
+    "end" get resolve-label ; inline
 
 \ fixnum+ [
     finalize-contents
@@ -164,7 +164,7 @@ math-internals namespaces sequences words ;
 
 \ fixnum* [
     finalize-contents
-    <label> "end" set
+    "end" define-label
     "r" operand "x" operand untag-fixnum
     0 MTXER
     12 "y" operand "r" operand MULLWO.
@@ -178,7 +178,7 @@ math-internals namespaces sequences words ;
     "s48_bignum_arithmetic_shift" f %alien-invoke
     ! An untagged pointer to the bignum is now in r3; tag it
     3 12 bignum-tag ORI
-    "end" get save-xt
+    "end" get resolve-label
     "s" operand 12 MR
 ] H{
     { +input { { f "x" } { f "y" } } }
@@ -192,8 +192,8 @@ math-internals namespaces sequences words ;
     #! through to the end, and the result is in "x" operand.
     #! Otherwise it jumps to the "no-overflow" label and the
     #! result is in "r" operand.
-    <label> "end" set
-    <label> "no-overflow" set
+    "end" define-label
+    "no-overflow" define-label
     "r" operand "x" operand "y" operand DIVW
     ! if the result is greater than the most positive fixnum,
     ! which can only ever happen if we do
@@ -209,9 +209,9 @@ math-internals namespaces sequences words ;
     finalize-contents
     generate-fixnum/i
     "end" get B
-    "no-overflow" get save-xt
+    "no-overflow" get resolve-label
     "r" operand "x" operand tag-fixnum
-    "end" get save-xt
+    "end" get resolve-label
 ] H{
     { +input { { f "x" } { f "y" } } }
     { +scratch { { f "r" } { f "s" } } }
@@ -224,10 +224,10 @@ math-internals namespaces sequences words ;
     generate-fixnum/i
     0 "s" operand LI
     "end" get B
-    "no-overflow" get save-xt
+    "no-overflow" get resolve-label
     generate-fixnum-mod
     "r" operand "x" operand tag-fixnum
-    "end" get save-xt
+    "end" get resolve-label
 ] H{
     { +input { { f "x" } { f "y" } } }
     { +scratch { { f "r" } { f "s" } } }
@@ -276,8 +276,8 @@ math-internals namespaces sequences words ;
 } define-intrinsic
 
 \ type [
-    <label> "f" set
-    <label> "end" set
+    "f" define-label
+    "end" define-label
     ! Get the tag
     "obj" operand "y" operand tag-mask ANDI
     ! Tag the tag
@@ -294,10 +294,10 @@ math-internals namespaces sequences words ;
     "x" operand "obj" operand object-tag neg LWZ
     "x" operand dup untag
     "end" get B
-    "f" get save-xt
+    "f" get resolve-label
     ! The pointer is equal to 3. Load F_TYPE (9).
     f type tag-bits shift "x" operand LI
-    "end" get save-xt
+    "end" get resolve-label
 ] H{
     { +input { { f "obj" } } }
     { +scratch { { f "x" } { f "y" } } }
diff --git a/library/compiler/x86/architecture.factor b/library/compiler/x86/architecture.factor
index 6ab88c976d..752fbaca33 100644
--- a/library/compiler/x86/architecture.factor
+++ b/library/compiler/x86/architecture.factor
@@ -110,7 +110,7 @@ M: object load-literal ( literal vreg -- )
     #! Compile a piece of code that jumps to an offset in a
     #! jump table indexed by the fixnum at the top of the stack.
     #! The jump table must immediately follow this macro.
-    <label> "end" set
+    "end" define-label
     ! Untag and multiply to get a jump table offset
     "n" operand fixnum>slot@
     ! Add to jump table base. We use a temporary register since
@@ -124,7 +124,7 @@ M: object load-literal ( literal vreg -- )
     ! Align for better performance
     compile-aligned
     ! Fix up jump table pointer
-    "end" get save-xt ;
+    "end" get resolve-label ;
 
 : %return ( -- ) %epilogue RET ;
 
diff --git a/library/compiler/x86/intrinsics.factor b/library/compiler/x86/intrinsics.factor
index c08a03205f..0f7d054480 100644
--- a/library/compiler/x86/intrinsics.factor
+++ b/library/compiler/x86/intrinsics.factor
@@ -15,9 +15,9 @@ IN: compiler
 
 \ type [
     #! Intrinstic version of type primitive.
-    <label> "header" set
-    <label> "f" set
-    <label> "end" set
+    "header" define-label
+    "f" define-label
+    "end" define-label
     ! Make a copy
     "x" operand "obj" operand MOV
     ! Get the tag
@@ -29,7 +29,7 @@ IN: compiler
     ! It doesn't store type info in its header
     "obj" operand tag-bits SHL
     "end" get JMP
-    "header" get save-xt
+    "header" get resolve-label
     ! It does store type info in its header
     ! Is the pointer itself equal to 3? Then its F_TYPE (9).
     "x" operand object-tag CMP
@@ -39,10 +39,10 @@ IN: compiler
     ! Mask off header tag, making a fixnum.
     "obj" operand object-tag XOR
     "end" get JMP
-    "f" get save-xt
+    "f" get resolve-label
     ! The pointer is equal to 3. Load F_TYPE (9).
     "obj" operand f type tag-bits shift MOV
-    "end" get save-xt
+    "end" get resolve-label
 ] H{
     { +input { { f "obj" } } }
     { +scratch { { f "x" } { f "y" } } }
@@ -166,7 +166,7 @@ IN: compiler
     "z" operand "y" operand pick execute
     ! If the previous arithmetic operation overflowed, then we
     ! turn the result into a bignum and leave it in EAX.
-    <label> "end" set
+    "end" define-label
     "end" get JNO
     ! There was an overflow. Recompute the original operand.
     { "y" "x" } [ tag-bits SAR ] unique-operands
@@ -175,7 +175,7 @@ IN: compiler
     ! An untagged pointer to the bignum is now in EAX; tag it
     T{ int-regs } return-reg bignum-tag OR
     "z" operand T{ int-regs } return-reg ?MOV
-    "end" get save-xt ; inline
+    "end" get resolve-label ; inline
 
 : simple-overflow-template ( word insn -- )
     [ simple-overflow ] curry H{
@@ -192,7 +192,7 @@ IN: compiler
     finalize-contents
     "y" operand tag-bits SAR
     "y" operand IMUL
-    <label> "end" set
+    "end" define-label
     "end" get JNO
     "s48_fixnum_pair_to_bignum" f
     "x" operand remainder-reg 2array compile-c-call*
@@ -202,7 +202,7 @@ IN: compiler
     "x" operand tag-bits neg 2array compile-c-call*
     ! an untagged pointer to the bignum is now in EAX; tag it
     T{ int-regs } return-reg bignum-tag OR
-    "end" get save-xt
+    "end" get resolve-label
 ] H{
     { +input { { 0 "x" } { 1 "y" } } }
     { +output { "x" } }
@@ -212,7 +212,7 @@ IN: compiler
     #! The same code is used for fixnum/i and fixnum/mod.
     #! This has specific register
     #! ECX and EAX, and the result is in EDX.
-    <label> "end" set
+    "end" define-label
     prepare-division
     "y" operand IDIV
     ! Make a copy since following shift is destructive
@@ -235,7 +235,7 @@ IN: compiler
     stack-reg 16 cell - ADD
     ! the remainder is now in EDX
     remainder-reg POP
-    "end" get save-xt ;
+    "end" get resolve-label ;
 
 \ fixnum/i [ generate-fixnum/mod ] H{
     { +input { { 0 "x" } { 1 "y" } } }
diff --git a/vm/alien.c b/vm/alien.c
index b2fd178c7f..33a70d7c69 100644
--- a/vm/alien.c
+++ b/vm/alien.c
@@ -46,13 +46,6 @@ void *unbox_alien(void)
 	return alien_offset(dpop());
 }
 
-/* pop ( alien n ) from datastack, return alien's address plus n */
-INLINE void *alien_pointer(void)
-{
-	F_FIXNUM offset = unbox_signed_cell();
-	return unbox_alien() + offset;
-}
-
 /* make an alien */
 ALIEN *make_alien(CELL delegate, CELL displacement)
 {
@@ -98,7 +91,14 @@ void fixup_alien(ALIEN *d)
 	d->expired = true;
 }
 
-/* define words to read/write numericals values at an alien address */
+/* pop ( alien n ) from datastack, return alien's address plus n */
+INLINE void *alien_pointer(void)
+{
+	F_FIXNUM offset = unbox_signed_cell();
+	return unbox_alien() + offset;
+}
+
+/* define words to read/write values at an alien address */
 #define DEF_ALIEN_SLOT(name,type,boxer) \
 void primitive_alien_##name (void) \
 { \
@@ -139,7 +139,7 @@ void box_value_struct(void *src, CELL size)
 }
 
 /* for FFI calls returning an 8-byte struct. This only
-happends on Intel Mac OS X */
+happens on Intel Mac OS X */
 void box_value_pair(CELL x, CELL y)
 {
 	F_ARRAY *array = byte_array(8);
diff --git a/vm/bignum.c b/vm/bignum.c
index 5d6126fbab..2f6b8fe539 100644
--- a/vm/bignum.c
+++ b/vm/bignum.c
@@ -41,7 +41,6 @@ MIT in each case. */
  */
 
 /* Changes for Factor:
- *  - Add s48_ prefix to file names
  *  - Adapt s48_bignumint.h for Factor memory manager
  *  - Add more bignum <-> C type conversions
  */
diff --git a/vm/factor.c b/vm/factor.c
index 8240123a33..589bff4689 100644
--- a/vm/factor.c
+++ b/vm/factor.c
@@ -22,7 +22,6 @@ void init_factor(const char* image,
 	userenv[CARD_OFF_ENV] = tag_cell(cards_offset);
 	userenv[IMAGE_ENV] = tag_object(from_char_string(image));
 	userenv[CELL_SIZE_ENV] = tag_fixnum(sizeof(CELL));
-	userenv[COMPILED_BASE_ENV] = tag_cell(compiling.base);
 }
 
 INLINE bool factor_arg(const char* str, const char* arg, CELL* value)
diff --git a/vm/image.c b/vm/image.c
index f17d5fb83b..92f52a6f7b 100644
--- a/vm/image.c
+++ b/vm/image.c
@@ -179,6 +179,9 @@ void undefined_symbol(void)
 
 INLINE CELL get_literal(CELL literal_start, CELL num)
 {
+	if(!literal_start)
+		critical_error("Only RT_LABEL relocations can appear in the label-relocation-table",0);
+
 	return get(LITERAL_REF(literal_start,num));
 }
 
@@ -209,9 +212,13 @@ CELL get_rel_word(F_REL *rel, CELL literal_start)
 	return (CELL)word->xt;
 }
 
-INLINE CELL compute_code_rel(F_REL *rel, CELL original,
-	CELL offset, CELL literal_start)
+INLINE CELL compute_code_rel(F_REL *rel,
+	CELL code_start, CELL literal_start,
+	F_VECTOR *labels)
 {
+	CELL offset = rel->offset + code_start;
+	F_ARRAY *array = untag_array_fast(labels->array);
+
 	switch(REL_TYPE(rel))
 	{
 	case RT_PRIMITIVE:
@@ -226,13 +233,20 @@ INLINE CELL compute_code_rel(F_REL *rel, CELL original,
 		return LITERAL_REF(literal_start,REL_ARGUMENT(rel));
 	case RT_WORD:
 		return get_rel_word(rel,literal_start);
+	case RT_LABEL:
+		if(labels == NULL)
+			critical_error("RT_LABEL can only appear in label-relocation-table",0);
+
+		return to_fixnum(get(AREF(array,REL_ARGUMENT(rel))))
+			+ code_start;
 	default:
 		critical_error("Unsupported rel type",rel->type);
 		return -1;
 	}
 }
 
-INLINE void relocate_code_step(F_REL *rel, CELL code_start, CELL literal_start)
+void relocate_code_step(F_REL *rel, CELL code_start, CELL literal_start,
+	F_VECTOR *labels)
 {
 	CELL original;
 	CELL new_value;
@@ -270,7 +284,7 @@ INLINE void relocate_code_step(F_REL *rel, CELL code_start, CELL literal_start)
 
 	/* to_c_string can fill up the heap */
 	maybe_gc(0);
-	new_value = compute_code_rel(rel,original,offset,literal_start);
+	new_value = compute_code_rel(rel,code_start,literal_start,labels);
 
 	switch(REL_CLASS(rel))
 	{
@@ -321,7 +335,7 @@ CELL relocate_code_next(CELL relocating)
 
 	/* apply relocations */
 	while(rel < rel_end)
-		relocate_code_step(rel++,code_start,literal_start);
+		relocate_code_step(rel++,code_start,literal_start,NULL);
 	
 	CELL *scan = (CELL*)literal_start;
 	CELL *literal_end = (CELL*)(literal_start + compiled->literal_length);
diff --git a/vm/image.h b/vm/image.h
index b30fa69b24..8a9be866ff 100644
--- a/vm/image.h
+++ b/vm/image.h
@@ -53,7 +53,9 @@ typedef enum {
 	/* an indirect literal from the word's literal table */
 	RT_LITERAL,
 	/* a word */
-	RT_WORD
+	RT_WORD,
+	/* a local label */
+	RT_LABEL
 } F_RELTYPE;
 
 #define REL_ABSOLUTE_CELL 0
@@ -88,6 +90,8 @@ INLINE void code_fixup(CELL *cell)
 
 void relocate_data();
 
+void relocate_code_step(F_REL *rel, CELL code_start, CELL literal_start,
+	F_VECTOR *labels);
 CELL relocate_code_next(CELL relocating);
 void relocate_code();
 
diff --git a/vm/run.c b/vm/run.c
index 96cb3f9378..de6d311b32 100644
--- a/vm/run.c
+++ b/vm/run.c
@@ -319,19 +319,35 @@ void deposit_vector(F_VECTOR *vector, CELL format)
 	compiling.here += count * format;
 }
 
-void add_compiled_block(F_VECTOR *code, CELL code_format,
-	F_VECTOR *reloc, F_VECTOR *literals)
+void fixup_labels(F_VECTOR *label_rel, CELL code_start, CELL literal_start,
+	F_VECTOR *labels)
+{
+	F_ARRAY *array = untag_array_fast(labels->array);
+	CELL length = untag_fixnum_fast(label_rel->top);
+	CELL i;
+	
+	for(i = 0; i < length; i += 2)
+	{
+		F_REL rel;
+		rel.type = to_cell(get(AREF(array,i)));
+		rel.offset = to_cell(get(AREF(array,i + 1)));
+		relocate_code_step(&rel,code_start,literal_start,labels);
+	}
+}
+
+void add_compiled_block(CELL code_format, F_VECTOR *code, F_VECTOR *label_rel,
+	F_VECTOR *labels, F_VECTOR *literals, F_VECTOR *rel)
 {
 	CELL start = compiling.here;
 	CELL code_length = untag_fixnum_fast(code->top) * code_format;
-	CELL reloc_length = untag_fixnum_fast(reloc->top) * CELLS;
+	CELL rel_length = untag_fixnum_fast(rel->top) * CELLS;
 	CELL literal_length = untag_fixnum_fast(literals->top) * CELLS;
 
 	/* compiled header */
 	F_COMPILED header;
 	header.header = COMPILED_HEADER;
 	header.code_length = align8(code_length);
-	header.reloc_length = reloc_length;
+	header.reloc_length = rel_length;
 	header.literal_length = literal_length;
 	memcpy((void*)compiling.here,&header,sizeof(F_COMPILED));
 	compiling.here += sizeof(F_COMPILED);
@@ -340,24 +356,29 @@ void add_compiled_block(F_VECTOR *code, CELL code_format,
 	deposit_vector(code,code_format);
 	compiling.here = align8(compiling.here);
 
-	/* relocation info */
-	deposit_vector(reloc,CELLS);
+	/* relation info */
+	deposit_vector(rel,CELLS);
 
 	/* literals */
 	deposit_vector(literals,CELLS);
 
+	/* labels */
+	fixup_labels(label_rel,start + sizeof(F_COMPILED),0,labels);
+
 	/* push the XT of the new word on the stack */
 	box_unsigned_cell(start + sizeof(F_COMPILED));
 }
 
 void primitive_add_compiled_block(void)
 {
-	F_VECTOR *literals = untag_vector(dpop());
-	F_VECTOR *rel = untag_vector(dpop());
 	CELL code_format = to_cell(dpop());
 	F_VECTOR *code = untag_vector(dpop());
-	
-	add_compiled_block(code,code_format,rel,literals);
+	F_VECTOR *label_rel = untag_vector(dpop());
+	F_VECTOR *labels = untag_vector(dpop());
+	F_VECTOR *literals = untag_vector(dpop());
+	F_VECTOR *rel = untag_vector(dpop());
+
+	add_compiled_block(code_format,code,label_rel,labels,literals,rel);
 }
 
 void primitive_finalize_compile(void)
diff --git a/vm/run.h b/vm/run.h
index c9ecfd761d..170b502476 100644
--- a/vm/run.h
+++ b/vm/run.h
@@ -29,7 +29,6 @@ CELL callframe_end;
 #define GEN_ENV           15 /* set to gen_count */
 #define IMAGE_ENV         16 /* image name */
 #define CELL_SIZE_ENV     17 /* sizeof(CELL) */
-#define COMPILED_BASE_ENV 18 /* base of code heap */
 
 /* TAGGED user environment data; see getenv/setenv prims */
 DLLEXPORT CELL userenv[USER_ENV];