New code-gc primitive

library/bootstrap/primitives.factor

@@ -123,7 +123,8 @@ call
     { "setenv" "kernel-internals"           }
     { "stat" "io"                           }
     { "(directory)" "io"                    }
-    { "gc" "memory"                         }
+    { "data-gc" "memory"                    }
+    { "code-gc" "memory"                    }
     { "gc-time" "memory"                    }
     { "save-image" "memory"                 }
     { "datastack" "kernel"                  }

library/compiler/inference/known-words.factor

@@ -235,7 +235,12 @@ t over set-effect-terminated?
 \ setenv { object fixnum } { } <effect> "infer-effect" set-word-prop
 \ stat { string } { object } <effect> "infer-effect" set-word-prop
 \ (directory) { string } { array } <effect> "infer-effect" set-word-prop
-\ gc { integer object } { } <effect> "infer-effect" set-word-prop
+\ data-gc { integer } { } <effect> "infer-effect" set-word-prop
+
+! code-gc does not declare a stack effect since it might be
+! called from a compiled word which becomes unreachable during
+! the course of its execution, resulting in a crash
+
 \ gc-time { } { integer } <effect> "infer-effect" set-word-prop
 \ save-image { string } { } <effect> "infer-effect" set-word-prop
 \ exit { integer } { } <effect> "infer-effect" set-word-prop

library/tools/memory.factor

@@ -5,7 +5,7 @@ USING: arrays errors generic hashtables io kernel
 kernel-internals math namespaces parser prettyprint sequences
 strings styles vectors words ;
 
-: full-gc ( -- ) generations 1- f gc ;
+: full-gc ( -- ) generations 1- data-gc ;
 
 ! Printing an overview of heap usage.
 

library/tools/memory.facts

@@ -1,7 +1,7 @@
 IN: memory
 USING: errors help test ;
 
-HELP: gc ( n -- )
+HELP: data-gc ( n -- )
 { $values { "n" "a positive integer" } }
 { $description "Collects all generations up to and including the " { $snippet "n" } "th generation. The nursery where new objects are allocated is generation 0, and tenured space is generation " { $snippet "g-1" } " where " { $snippet "g" } " is the value output by " { $link generations } "." } ;
 

vm/code_gc.c

@@ -232,3 +232,8 @@ void primitive_code_room(void)
 	box_unsigned_cell(heap_free_space(&compiling));
 	box_unsigned_cell(compiling.limit - compiling.base);
 }
+
+void primitive_code_gc(void)
+{
+	garbage_collection(TENURED,true);
+}

vm/code_gc.h

@@ -50,16 +50,6 @@ typedef struct
 typedef void (*CODE_HEAP_ITERATOR)(F_COMPILED *compiled, CELL code_start,
 	CELL reloc_start, CELL literal_start, CELL words_start, CELL words_end);
 
-void init_code_heap(CELL size);
-
-void iterate_code_heap(CODE_HEAP_ITERATOR iter);
-
-void collect_literals(void);
-
-void mark_and_sweep(CELL xt);
-
-void primitive_code_room(void);
-
 INLINE void iterate_code_heap_step(F_COMPILED *compiled, CODE_HEAP_ITERATOR iter)
 {
 	CELL code_start = (CELL)(compiled + 1);
@@ -80,3 +70,10 @@ INLINE F_COMPILED *xt_to_compiled(CELL xt)
 {
 	return (F_COMPILED *)(xt - sizeof(F_COMPILED));
 }
+
+void init_code_heap(CELL size);
+void iterate_code_heap(CODE_HEAP_ITERATOR iter);
+void collect_literals(void);
+void mark_and_sweep(CELL xt);
+void primitive_code_room(void);
+void primitive_code_gc(void);

vm/data_gc.c

@@ -446,10 +446,11 @@ void reset_generations(CELL from, CELL to)
 	clear_cards(from,to);
 }
 
-void begin_gc(CELL gen)
+void begin_gc(CELL gen, bool code_gc)
 {
 	collecting_gen = gen;
 	collecting_gen_start = generations[gen].base;
+	collecting_code = code_gc;
 
 	if(gen == TENURED)
 	{
@@ -471,9 +472,9 @@ void begin_gc(CELL gen)
 	}
 }
 
-void end_gc(CELL gen)
+void end_gc()
 {
-	if(gen == TENURED)
+	if(collecting_gen == TENURED)
 	{
 		/* we did a full collection; no more
 		old-to-new pointers remain since everything
@@ -483,7 +484,8 @@ void end_gc(CELL gen)
 		now empty */
 		reset_generations(NURSERY,TENURED - 1);
 
-		fprintf(stderr,"*** Data GC (%ld minor, %ld cards)\n",
+		fprintf(stderr,"*** %s GC (%ld minor, %ld cards)\n",
+			collecting_code ? "Code and data" : "Data",
 			minor_collections,cards_scanned);
 		minor_collections = 0;
 		cards_scanned = 0;
@@ -494,13 +496,20 @@ void end_gc(CELL gen)
 		next-oldest generation no longer has any
 		pointers into the younger generation (the
 		younger generation is empty!) */
-		unmark_cards(gen + 1,gen + 1);
+		unmark_cards(collecting_gen + 1,collecting_gen + 1);
 		/* all generations up to and including the one
 		collected are now empty */
-		reset_generations(NURSERY,gen);
+		reset_generations(NURSERY,collecting_gen);
 		
 		minor_collections++;
 	}
+	
+	if(collecting_code)
+	{
+		/* now that all reachable code blocks have been marked,
+		deallocate the rest */
+		free_unmarked(&compiling);
+	}
 }
 
 /* collect gen and all younger generations */
@@ -524,7 +533,7 @@ void garbage_collection(CELL gen, bool code_gc)
 			gen++;
 	}
 
-	begin_gc(gen);
+	begin_gc(gen,code_gc);
 
 	/* initialize chase pointer */
 	scan = newspace->here;
@@ -535,26 +544,30 @@ void garbage_collection(CELL gen, bool code_gc)
 	/* collect objects referenced from older generations */
 	collect_cards(gen);
 
-	/* collect literal objects referenced from compiled code */
-	collect_literals();
-	
+	if(!code_gc)
+	{
+		/* if we are doing code GC, then we will copy over literals
+		from any code block which gets marked as live. if we are not
+		doing code GC, just consider all literals as roots. */
+		collect_literals();
+	}
+
 	while(scan < newspace->here)
 		scan = collect_next(scan);
 
-	end_gc(gen);
+	end_gc();
 
 	gc_time += (current_millis() - start);
 }
 
-void primitive_gc(void)
+void primitive_data_gc(void)
 {
-	bool code_gc = unbox_boolean();
 	CELL gen = to_fixnum(dpop());
-	if(gen <= NURSERY || code_gc)
+	if(gen <= NURSERY)
 		gen = NURSERY;
 	else if(gen >= TENURED)
 		gen = TENURED;
-	garbage_collection(gen,code_gc);
+	garbage_collection(gen,false);
 }
 
 /* WARNING: only call this from a context where all local variables

vm/data_gc.h

@@ -142,6 +142,7 @@ CELL cards_scanned;
 /* only meaningful during a GC */
 CELL collecting_gen;
 CELL collecting_gen_start;
+bool collecting_code;
 
 /* test if the pointer is in generation being collected, or a younger one.
 init_data_heap() arranges things so that the older generations are first,
@@ -209,7 +210,7 @@ INLINE void* allot_object(CELL type, CELL length)
 void update_cards_offset(void);
 CELL collect_next(CELL scan);
 void garbage_collection(CELL gen, bool code_gc);
-void primitive_gc(void);
+void primitive_data_gc(void);
 void maybe_gc(CELL size);
 DLLEXPORT void simple_gc(void);
 void primitive_gc_time(void);

vm/primitives.c

@@ -92,7 +92,8 @@ void* primitives[] = {
 	primitive_setenv,
 	primitive_stat,
 	primitive_read_dir,
-	primitive_gc,
+	primitive_data_gc,
+	primitive_code_gc,
 	primitive_gc_time,
 	primitive_save_image,
 	primitive_datastack,