compiler: preliminary implementation of tracking derived pointers in GC maps

basis/compiler/cfg/instructions/instructions.factor

@@ -830,13 +830,16 @@ UNION: conditional-branch-insn
 UNION: ##read ##slot ##slot-imm ##vm-field ##alien-global ;
 UNION: ##write ##set-slot ##set-slot-imm ##set-vm-field ;
 
-! Instructions that contain subroutine calls to functions which
+UNION: alien-call-insn
-! can callback arbitrary Factor code
-UNION: factor-call-insn
 ##alien-invoke
 ##alien-indirect
 ##alien-assembly ;
 
+! Instructions that contain subroutine calls to functions which
+! can callback arbitrary Factor code
+UNION: factor-call-insn
+alien-call-insn ;
+
 ! Instructions that contain subroutine calls to functions which
 ! allocate memory
 UNION: gc-map-insn
@@ -848,15 +851,10 @@ factor-call-insn ;
 M: gc-map-insn clone call-next-method [ clone ] change-gc-map ;
 
 ! Each one has a gc-map slot
-TUPLE: gc-map scrub-d scrub-r gc-roots ;
+TUPLE: gc-map scrub-d scrub-r gc-roots derived-roots ;
 
 : <gc-map> ( -- gc-map ) gc-map new ;
 
-UNION: alien-call-insn
-##alien-invoke
-##alien-indirect
-##alien-assembly ;
-
 ! Instructions that clobber registers. They receive inputs and
 ! produce outputs in spill slots.
 UNION: hairy-clobber-insn

basis/compiler/cfg/linear-scan/assignment/assignment.factor

@@ -146,9 +146,15 @@ RENAMING: assign [ vreg>reg ] [ vreg>reg ] [ vreg>reg ]
 M: vreg-insn assign-registers-in-insn
     [ assign-insn-defs ] [ assign-insn-uses ] [ assign-insn-temps ] tri ;
 
+: assign-gc-roots ( gc-map -- )
+    [ [ vreg>spill-slot ] map ] change-gc-roots drop ;
+
+: assign-derived-roots ( gc-map -- )
+    [ [ [ vreg>spill-slot ] bi@ ] assoc-map ] change-derived-roots drop ;
+
 M: gc-map-insn assign-registers-in-insn
     [ [ assign-insn-defs ] [ assign-insn-uses ] [ assign-insn-temps ] tri ]
-    [ gc-map>> [ [ vreg>spill-slot ] map ] change-gc-roots drop ]
+    [ gc-map>> [ assign-gc-roots ] [ assign-derived-roots ] bi ]
     bi ;
 
 M: insn assign-registers-in-insn drop ;

basis/compiler/cfg/liveness/liveness-tests.factor

@@ -206,3 +206,42 @@ V{
 [ H{ { 0 0 } } ] [ 2 get 4 get edge-live-in ] unit-test
 
 [ H{ { 1 1 } } ] [ 3 get 4 get edge-live-in ] unit-test
+
+
+V{
+    T{ ##prologue }
+    T{ ##branch }
+} 0 test-bb
+
+V{
+    T{ ##peek f 0 D 0 }
+    T{ ##tagged>integer f 1 0 }
+    T{ ##call-gc f T{ gc-map } }
+    T{ ##replace f 0 D 0 }
+    T{ ##call-gc f T{ gc-map } }
+    T{ ##replace f 1 D 0 }
+    T{ ##branch }
+} 1 test-bb
+
+V{
+    T{ ##epilogue }
+    T{ ##return }
+} 2 test-bb
+
+0 1 edge
+1 2 edge
+
+H{
+    { 0 tagged-rep }
+    { 1 int-rep }
+} representations set
+
+[ ] [ cfg new 0 get >>entry dup cfg set compute-live-sets ] unit-test
+
+[ V{ { 1 0 } } ] [ 1 get instructions>> 2 swap nth gc-map>> derived-roots>> ] unit-test
+
+[ { 0 } ] [ 1 get instructions>> 2 swap nth gc-map>> gc-roots>> ] unit-test
+
+[ V{ { 1 0 } } ] [ 1 get instructions>> 4 swap nth gc-map>> derived-roots>> ] unit-test
+
+[ { 0 } ] [ 1 get instructions>> 4 swap nth gc-map>> gc-roots>> ] unit-test

basis/compiler/cfg/liveness/liveness.factor

@@ -1,15 +1,28 @@
 ! Copyright (C) 2009, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel accessors assocs fry deques dlists namespaces
+USING: arrays kernel accessors assocs fry locals combinators
-sequences sets compiler.cfg compiler.cfg.def-use
+deques dlists namespaces sequences sets compiler.cfg
-compiler.cfg.instructions compiler.cfg.registers
+compiler.cfg.def-use compiler.cfg.instructions
-compiler.cfg.utilities compiler.cfg.predecessors
+compiler.cfg.registers compiler.cfg.utilities
-compiler.cfg.rpo cpu.architecture ;
+compiler.cfg.predecessors compiler.cfg.rpo cpu.architecture ;
 FROM: namespaces => set ;
 IN: compiler.cfg.liveness
 
-! See http://en.wikipedia.org/wiki/Liveness_analysis
+! Similar to http://en.wikipedia.org/wiki/Liveness_analysis,
+! with three additions:
 
+! 1) With SSA, it is not sufficient to have a single live-in set
+! per block. There is also there is an edge-live-in set per
+! edge, consisting of phi inputs from each predecessor.
+! 2) Liveness analysis annotates call sites with GC maps
+! indicating the spill slots in the stack frame that contain
+! tagged pointers, and thus have to be visited if a GC occurs
+! inside the call.
+! 3) GC maps can contain derived pointers. A derived pointer is
+! a pointer into the middle of a data heap object. Each derived
+! pointer has a base pointer, to keep it up to date when objects
+! are moved by the garbage collector. This extends live
+! intervals and inserts new ##phi instructions.
 SYMBOL: live-ins
 
 : live-in ( bb -- set )
@@ -27,6 +40,8 @@ SYMBOL: edge-live-ins
 : edge-live-in ( predecessor basic-block -- set )
     edge-live-ins get at at ;
 
+SYMBOL: base-pointers
+
 GENERIC: visit-insn ( live-set insn -- live-set )
 
 : kill-defs ( live-set insn -- live-set )
@@ -35,20 +50,64 @@ GENERIC: visit-insn ( live-set insn -- live-set )
 : gen-uses ( live-set insn -- live-set )
     uses-vregs [ over conjoin ] each ; inline
 
-M: vreg-insn visit-insn [ kill-defs ] [ gen-uses ] bi ;
+M: vreg-insn visit-insn
+    [ kill-defs ] [ gen-uses ] bi ;
 
-! Our liveness analysis annotates call sites with GC maps
+DEFER: lookup-base-pointer
-! indicating the spill slots in the stack frame that contain
+
-! tagged pointers, and thus have to be visited if a GC occurs
+GENERIC: lookup-base-pointer* ( insn -- vreg/f )
-! inside the call.
+
+M: ##tagged>integer lookup-base-pointer* src>> ;
+
+M: ##unbox-any-c-ptr lookup-base-pointer*
+    ! If the input to unbox-any-c-ptr was an alien and not a
+    ! byte array, then the derived pointer will be outside of
+    ! the data heap. The GC has to handle this case and ignore
+    ! it.
+    src>> ;
+
+M: ##copy lookup-base-pointer* src>> lookup-base-pointer ;
+
+M: ##add-imm lookup-base-pointer* src1>> lookup-base-pointer ;
+
+M: ##sub-imm lookup-base-pointer* src1>> lookup-base-pointer ;
+
+M: ##add lookup-base-pointer*
+    ! If both operands have a base pointer, then the user better
+    ! not be doing memory reads and writes on the object, since
+    ! we don't give it a base pointer in that case at all.
+    [ src1>> ] [ src2>> ] bi [ lookup-base-pointer ] bi@ xor ;
+
+M: ##sub lookup-base-pointer*
+    src1>> lookup-base-pointer ;
+
+M: vreg-insn lookup-base-pointer* drop f ;
+
+: lookup-base-pointer ( vreg -- vreg/f )
+    base-pointers get [ insn-of lookup-base-pointer* ] cache ;
+
+:: visit-derived-root ( vreg derived-roots gc-roots -- )
+    vreg lookup-base-pointer :> base
+    base [
+        { vreg base } derived-roots push
+        base gc-roots adjoin
+    ] when ;
+
+: visit-gc-root ( vreg derived-roots gc-roots -- )
+    pick rep-of {
+        { tagged-rep [ nip adjoin ] }
+        { int-rep [ visit-derived-root ] }
+        [ 2drop 2drop ]
+    } case ;
+
+: gc-roots ( live-set -- derived-roots gc-roots )
+    V{ } clone HS{ } clone
+    [ '[ drop _ _ visit-gc-root ] assoc-each ] 2keep
+    members ;
 
 : fill-gc-map ( live-set insn -- live-set )
-    representations get [
+    [ representations get [ dup gc-roots ] [ f f ] if ] dip
-        gc-map>> over keys
+    gc-map>> [ gc-roots<< ] [ derived-roots<< ] bi ;
-        [ rep-of tagged-rep? ] filter
-        >>gc-roots
-    ] when
-    drop ;
 
 M: gc-map-insn visit-insn
     [ kill-defs ] [ fill-gc-map ] [ gen-uses ] tri ;
@@ -60,9 +119,6 @@ M: insn visit-insn drop ;
 : transfer-liveness ( live-set instructions -- live-set' )
     [ clone ] [ <reversed> ] bi* [ visit-insn ] each ;
 
-: local-live-in ( instructions -- live-set )
-    [ H{ } ] dip transfer-liveness keys ;
-
 SYMBOL: work-list
 
 : add-to-work-list ( basic-blocks -- )
@@ -98,11 +154,13 @@ SYMBOL: work-list
 
 : compute-live-sets ( cfg -- )
     needs-predecessors
+    dup compute-insns
 
     <hashed-dlist> work-list set
     H{ } clone live-ins set
     H{ } clone edge-live-ins set
     H{ } clone live-outs set
+    H{ } clone base-pointers set
     post-order add-to-work-list
     work-list get [ liveness-step ] slurp-deque ;
 

basis/compiler/codegen/fixup/fixup-tests.factor

@@ -9,13 +9,14 @@ STRUCT: gc-info
 { scrub-d-count uint }
 { scrub-r-count uint }
 { gc-root-count uint }
+{ derived-root-count uint }
 { return-address-count uint } ;
 
 SINGLETON: fake-cpu
 
 fake-cpu \ cpu set
 
-M: fake-cpu gc-root-offsets ;
+M: fake-cpu gc-root-offset ;
 
 [ ] [
     [
@@ -27,7 +28,7 @@ M: fake-cpu gc-root-offsets ;
 
         50 <byte-array> %
 
-        T{ gc-map f B{ 0 1 1 1 0 } B{ 1 0 } V{ 1 3 } } gc-map-here
+        T{ gc-map f B{ 0 1 1 1 0 } B{ 1 0 } V{ 1 3 } V{ { 2 4 } } } gc-map-here
 
         emit-gc-info
     ] B{ } make
@@ -54,7 +55,10 @@ M: fake-cpu gc-root-offsets ;
             f t f t
         } underlying>> %
 
-        ! Return addresses - 4 bytes
+        ! Derived pointers
+        uint-array{ -1 -1 4 } underlying>> %
+
+        ! Return addresses
         uint-array{ 100 } underlying>> %
 
         ! GC info footer - 16 bytes
@@ -62,6 +66,7 @@ M: fake-cpu gc-root-offsets ;
             { scrub-d-count 5 }
             { scrub-r-count 2 }
             { gc-root-count 4 }
+            { derived-root-count 3 }
             { return-address-count 1 }
         } (underlying)>> %
     ] B{ } make

basis/compiler/codegen/fixup/fixup.factor

@@ -2,8 +2,8 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: arrays bit-arrays byte-arrays byte-vectors generic assocs
 hashtables io.binary kernel kernel.private math namespaces make
-sequences words quotations strings alien.accessors alien.strings
+sequences words quotations strings sorting alien.accessors
-layouts system combinators math.bitwise math.order
+alien.strings layouts system combinators math.bitwise math.order
 combinators.short-circuit combinators.smart accessors growable
 fry memoize compiler.constants compiler.cfg.instructions
 cpu.architecture ;
@@ -144,12 +144,14 @@ MEMO: cached-string>symbol ( symbol -- obj ) string>symbol ;
 ! - <scrubbed data stack locations>
 ! - <scrubbed retain stack locations>
 ! - <GC root spill slots>
+! uint[] <base pointers>
 ! uint[] <return addresses>
 ! uint <largest scrubbed data stack location>
 ! uint <largest scrubbed retain stack location>
 ! uint <largest GC root spill slot>
-! uint <number of return addresses>
+! uint <largest derived root spill slot>
-
+! int <number of return addresses>
+!
 SYMBOLS: return-addresses gc-maps ;
 
 : gc-map-needed? ( gc-map -- ? )
@@ -160,6 +162,7 @@ SYMBOLS: return-addresses gc-maps ;
             [ scrub-d>> empty? ]
             [ scrub-r>> empty? ]
             [ gc-roots>> empty? ]
+            [ derived-roots>> empty? ]
         } 1&& not
     ] when ;
 
@@ -169,33 +172,64 @@ SYMBOLS: return-addresses gc-maps ;
         compiled-offset return-addresses get push
     ] [ drop ] if ;
 
+: longest ( seqs -- n )
+    [ length ] [ max ] map-reduce ;
+
 : emit-scrub ( seqs -- n )
     ! seqs is a sequence of sequences of 0/1
-    dup [ length ] [ max ] map-reduce
+    dup longest
     [ '[ [ 0 = ] ?{ } map-as _ f pad-tail % ] each ] keep ;
 
 : integers>bits ( seq n -- bit-array )
     <bit-array> [ '[ [ t ] dip _ set-nth ] each ] keep ;
 
+: largest-spill-slot ( seqs -- n )
+    [ [ 0 ] [ supremum 1 + ] if-empty ] [ max ] map-reduce ;
+
 : emit-gc-roots ( seqs -- n )
     ! seqs is a sequence of sequences of integers 0..n-1
-    dup [ [ 0 ] [ supremum 1 + ] if-empty ] [ max ] map-reduce
+    dup largest-spill-slot
     [ '[ _ integers>bits % ] each ] keep ;
 
 : emit-uint ( n -- )
     building get push-uint ;
 
+: emit-uints ( n -- )
+    [ emit-uint ] each ;
+
+: gc-root-offsets ( gc-map -- offsets )
+    gc-roots>> [ gc-root-offset ] map ;
+
+: emit-gc-info-bitmaps ( -- scrub-d-count scrub-r-count gc-root-count )
+    [
+        gc-maps get {
+            [ [ scrub-d>> ] map emit-scrub ]
+            [ [ scrub-r>> ] map emit-scrub ]
+            [ [ gc-root-offsets ] map emit-gc-roots ]
+        } cleave
+    ] ?{ } make underlying>> % ;
+
+: emit-base-table ( alist longest -- )
+    -1 <array> <enum> swap assoc-union! seq>> emit-uints ;
+
+: derived-root-offsets ( gc-map -- offsets )
+    derived-roots>> [ [ gc-root-offset ] bi@ ] assoc-map ;
+
+: emit-base-tables ( -- count )
+    gc-maps get [ derived-root-offsets ] map
+    dup [ keys ] map largest-spill-slot
+    [ '[ _ emit-base-table ] each ] keep ;
+
+: emit-return-addresses ( -- )
+    return-addresses get emit-uints ;
+
 : gc-info ( -- byte-array )
     [
         return-addresses get empty? [ 0 emit-uint ] [
-            gc-maps get
+            emit-gc-info-bitmaps
-            [
+            emit-base-tables
-                [ [ scrub-d>> ] map emit-scrub ]
+            emit-return-addresses
-                [ [ scrub-r>> ] map emit-scrub ]
+            4array emit-uints
-                [ [ gc-roots>> gc-root-offsets ] map emit-gc-roots ] tri
-            ] ?{ } make underlying>> %
-            return-addresses get [ emit-uint ] each
-            [ emit-uint ] tri@
             return-addresses get length emit-uint
         ] if
     ] B{ } make ;

basis/compiler/tests/alien.factor

@@ -823,25 +823,3 @@ TUPLE: some-tuple x ;
         aa-indirect-1 >>x
     ] compile-call
 ] unit-test
-
-! Write barrier elimination was being done before scheduling and
-! GC check insertion, and didn't take subroutine calls into
-! account. Oops...
-: write-barrier-elim-in-wrong-place ( -- obj )
-    ! A callback used below
-    void { } cdecl [ compact-gc ] alien-callback
-    ! Allocate an object A in the nursery
-    1 f <array>
-    ! Subroutine call promotes the object to tenured
-    swap void { } cdecl alien-indirect
-    ! Allocate another object B in the nursery, store it into
-    ! the first
-    1 f <array> over set-first
-    ! Now object A's card should be marked and minor GC should
-    ! promote B to aging
-    minor-gc
-    ! Do stuff
-    [ 100 [ ] times ] infer.
-    ;
-
-[ { { f } } ] [ write-barrier-elim-in-wrong-place ] unit-test

basis/compiler/tests/codegen.factor

@@ -4,7 +4,8 @@ sequences tools.test namespaces.private slots.private
 sequences.private byte-arrays alien alien.accessors layouts
 words definitions compiler.units io combinators vectors grouping
 make alien.c-types combinators.short-circuit math.order
-math.libm math.parser math.functions alien.syntax ;
+math.libm math.parser math.functions alien.syntax memory
+stack-checker ;
 FROM: math => float ;
 QUALIFIED: namespaces.private
 IN: compiler.tests.codegen
@@ -463,6 +464,13 @@ TUPLE: myseq { underlying1 byte-array read-only } { underlying2 byte-array read-
     [ [ HEX: f bitand ] bi@ [ shift ] [ drop -3 shift ] 2bi ] compile-call
 ] unit-test
 
+! Alias analysis bug
+[ t ] [
+    [
+        10 10 <byte-array> [ <displaced-alien> underlying>> ] keep eq?
+    ] compile-call
+] unit-test
+
 ! GC root offsets were computed wrong on x86
 : gc-root-messup ( a -- b )
     dup [
@@ -473,9 +481,45 @@ TUPLE: myseq { underlying1 byte-array read-only } { underlying2 byte-array read-
 
 [ ] [ 2000 [ "hello" clone dup gc-root-messup first eq? t assert= ] times ] unit-test
 
-! Alias analysis bug
+! Write barrier elimination was being done before scheduling and
-[ t ] [
+! GC check insertion, and didn't take subroutine calls into
-    [
+! account. Oops...
-        10 10 <byte-array> [ <displaced-alien> underlying>> ] keep eq?
+: write-barrier-elim-in-wrong-place ( -- obj )
-    ] compile-call
+    ! A callback used below
-] unit-test
+    void { } cdecl [ compact-gc ] alien-callback
+    ! Allocate an object A in the nursery
+    1 f <array>
+    ! Subroutine call promotes the object to tenured
+    swap void { } cdecl alien-indirect
+    ! Allocate another object B in the nursery, store it into
+    ! the first
+    1 f <array> over set-first
+    ! Now object A's card should be marked and minor GC should
+    ! promote B to aging
+    minor-gc
+    ! Do stuff
+    [ 100 [ ] times ] infer.
+    ;
+
+[ { { f } } ] [ write-barrier-elim-in-wrong-place ] unit-test
+
+! GC maps must support derived pointers
+: (derived-pointer-test-1) ( -- byte-array )
+    2 <byte-array> ;
+
+: derived-pointer-test-1 ( -- byte-array )
+    ! A callback used below
+    void { } cdecl [ compact-gc ] alien-callback
+    ! Put the construction in a word since instruction selection
+    ! eliminates the untagged pointer entirely if the value is a
+    ! byte array
+    (derived-pointer-test-1) { c-ptr } declare
+    ! Store into an array, an untagged pointer to the payload
+    ! is now an available expression
+    123 over 0 set-alien-unsigned-1
+    ! GC, moving the array and derived pointer
+    swap void { } cdecl alien-indirect
+    ! Store into the array again
+    231 over 1 set-alien-unsigned-1 ;
+
+[ B{ 123 231 } ] [ derived-pointer-test-1 ] unit-test

basis/cpu/architecture/architecture.factor

@@ -225,7 +225,7 @@ M: object vm-stack-space 0 ;
 ! %store-memory work
 HOOK: complex-addressing? cpu ( -- ? )
 
-HOOK: gc-root-offsets cpu ( seq -- seq' )
+HOOK: gc-root-offset cpu ( spill-slot -- n )
 
 HOOK: %load-immediate cpu ( reg val -- )
 HOOK: %load-reference cpu ( reg obj -- )

basis/cpu/x86/x86.factor

@@ -503,8 +503,8 @@ M:: x86 %check-nursery-branch ( label size cc temp1 temp2 -- )
         { cc/<= [ label JG ] }
     } case ;
 
-M: x86 gc-root-offsets
+M: x86 gc-root-offset
-    [ n>> spill-offset special-offset cell + cell /i ] map f like ;
+    n>> spill-offset special-offset cell + cell /i ;
 
 M: x86 %call-gc ( gc-map -- )
     \ minor-gc %call

vm/contexts.cpp

@@ -60,9 +60,9 @@ void context::scrub_stacks(gc_info *info, cell index)
 	u8 *bitmap = info->gc_info_bitmap();
 
 	{
-		cell base = info->scrub_d_base(index);
+		cell base = info->callsite_scrub_d(index);
 
-		for(int loc = 0; loc < info->scrub_d_count; loc++)
+		for(cell loc = 0; loc < info->scrub_d_count; loc++)
 		{
 			if(bitmap_p(bitmap,base + loc))
 			{
@@ -75,7 +75,7 @@ void context::scrub_stacks(gc_info *info, cell index)
 	}
 
 	{
-		cell base = info->scrub_r_base(index);
+		cell base = info->callsite_scrub_r(index);
 
 		for(int loc = 0; loc < info->scrub_r_count; loc++)
 		{

vm/gc_info.cpp

@@ -3,17 +3,17 @@
 namespace factor
 {
 
-int gc_info::return_address_index(cell return_address)
+cell gc_info::return_address_index(cell return_address)
 {
 	u32 *return_address_array = return_addresses();
 
-	for(int i = 0; i < return_address_count; i++)
+	for(cell i = 0; i < return_address_count; i++)
 	{
 		if(return_address == return_address_array[i])
 			return i;
 	}
 
-	return -1;
+	return gc_info_missing_value;
 }
 
 }

vm/gc_info.hpp

@@ -1,15 +1,23 @@
 namespace factor
 {
 
+const u32 gc_info_missing_value = (u32)-1;
+
 struct gc_info {
-	int scrub_d_count;
+	u32 scrub_d_count;
-	int scrub_r_count;
+	u32 scrub_r_count;
-	int gc_root_count;
+	u32 gc_root_count;
-	int return_address_count;
+	u32 derived_root_count;
+	u32 return_address_count;
+
+	cell callsite_bitmap_size()
+	{
+		return scrub_d_count + scrub_r_count + gc_root_count;
+	}
 
 	cell total_bitmap_size()
 	{
-		return return_address_count * (scrub_d_count + scrub_r_count + gc_root_count);
+		return return_address_count * callsite_bitmap_size();
 	}
 
 	cell total_bitmap_bytes()
@@ -19,33 +27,43 @@ struct gc_info {
 
 	u32 *return_addresses()
 	{
-		return (u32 *)((u8 *)this - return_address_count * sizeof(u32));
+		return (u32 *)this - return_address_count;
+	}
+
+	u32 *base_pointer_map()
+	{
+		return return_addresses() - return_address_count * derived_root_count;
 	}
 
 	u8 *gc_info_bitmap()
 	{
-		return (u8 *)return_addresses() - total_bitmap_bytes();
+		return (u8 *)base_pointer_map() - total_bitmap_bytes();
 	}
 
-	cell scrub_d_base(cell index)
+	cell callsite_scrub_d(cell index)
 	{
 		return index * scrub_d_count;
 	}
 
-	cell scrub_r_base(cell index)
+	cell callsite_scrub_r(cell index)
 	{
 		return return_address_count * scrub_d_count +
 			index * scrub_r_count;
 	}
 
-	cell spill_slot_base(cell index)
+	cell callsite_gc_roots(cell index)
 	{
 		return return_address_count * scrub_d_count
 			+ return_address_count * scrub_r_count
 			+ index * gc_root_count;
 	}
 
-	int return_address_index(cell return_address);
+	cell lookup_base_pointer(cell index, cell derived_root)
+	{
+		return base_pointer_map()[index * derived_root_count + derived_root];
+	}
+
+	cell return_address_index(cell return_address);
 };
 
 }

vm/slot_visitor.hpp

@@ -292,27 +292,52 @@ struct call_frame_slot_visitor {
 		gc_info *info = compiled->block_gc_info();
 
 		assert(return_address < compiled->size());
-		int index = info->return_address_index(return_address);
+		u32 callsite = info->return_address_index(return_address);
-		if(index == -1)
+		if(callsite == gc_info_missing_value)
 			return;
 
 #ifdef DEBUG_GC_MAPS
 		std::cout << "call frame code block " << compiled << " with offset " << return_address << std::endl;
 #endif
-		u8 *bitmap = info->gc_info_bitmap();
-		cell base = info->spill_slot_base(index);
 		cell *stack_pointer = (cell *)(parent->frame_successor(frame) + 1);
+		u8 *bitmap = info->gc_info_bitmap();
 
-		for(int spill_slot = 0; spill_slot < info->gc_root_count; spill_slot++)
+		/* Subtract old value of base pointer from every derived pointer. */
+		for(cell spill_slot = 0; spill_slot < info->derived_root_count; spill_slot++)
 		{
-			if(bitmap_p(bitmap,base + spill_slot))
+			cell base_pointer = info->lookup_base_pointer(callsite, spill_slot);
+			if(base_pointer != gc_info_missing_value)
 			{
 #ifdef DEBUG_GC_MAPS
-				std::cout << "visiting spill slot " << spill_slot << std::endl;
+				std::cout << "visiting derived root " << spill_slot
+					<< " with base pointer " << base_pointer
+					<< std::endl;
+#endif
+				stack_pointer[spill_slot] -= stack_pointer[base_pointer];
+			}
+		}
+
+		/* Update all GC roots, including base pointers. */
+		cell callsite_gc_roots = info->callsite_gc_roots(callsite);
+
+		for(cell spill_slot = 0; spill_slot < info->gc_root_count; spill_slot++)
+		{
+			if(bitmap_p(bitmap,callsite_gc_roots + spill_slot))
+			{
+#ifdef DEBUG_GC_MAPS
+				std::cout << "visiting GC root " << spill_slot << std::endl;
 #endif
 				visitor->visit_handle(stack_pointer + spill_slot);
 			}
 		}
+
+		/* Add the base pointers to obtain new derived pointer values. */
+		for(cell spill_slot = 0; spill_slot < info->derived_root_count; spill_slot++)
+		{
+			cell base_pointer = info->lookup_base_pointer(callsite, spill_slot);
+			if(base_pointer != gc_info_missing_value)
+				stack_pointer[spill_slot] += stack_pointer[base_pointer];
+		}
 	}
 };
 

vm/vm.hpp

@@ -329,14 +329,16 @@ struct factor_vm
 		return (Type *)allot_object(Type::type_number,size);
 	}
 
+	inline bool in_data_heap_p(cell pointer)
+	{
+		return (pointer >= data->seg->start && pointer < data->seg->end);
+	}
+
 	inline void check_data_pointer(object *pointer)
 	{
 	#ifdef FACTOR_DEBUG
 		if(!(current_gc && current_gc->op == collect_growing_heap_op))
-		{
+			assert(in_data_heap_p((cell)pointer));
-			assert((cell)pointer >= data->seg->start
-				&& (cell)pointer < data->seg->end);
-		}
 	#endif
 	}