Fix save-image-and-exit, clean up compiler a bit

core/bootstrap/compiler/compiler.factor

@@ -33,7 +33,7 @@ global [ { "compiler" } add-use ] bind
 
     delegate
 
-    underlying2
+    underlying
 
     find-pair-next namestack*
 

core/compiler/compiler-docs.factor

@@ -11,7 +11,6 @@ ARTICLE: "compiler-usage" "Calling the optimizing compiler"
 "Three utility words for bulk compilation:"
 { $subsection compile-batch }
 { $subsection compile-vocabs }
-{ $subsection compile-all }
 "Bulk compilation saves compile warnings and errors in a global variable, instead of printing them as they arise:"
 { $subsection compile-errors }
 "The warnings and errors can be viewed later:"
@@ -113,9 +112,6 @@ HELP: recompile
 { $description "Recompiles words whose compiled definitions have become out of date as a result of dependent words being redefined." } ;
 
 HELP: compile-all
-{ $description "Compiles all words which have not been compiled yet." } ;
-
-HELP: recompile-all
 { $description "Recompiles all words." } ;
 
 HELP: changed-words

core/compiler/compiler.factor

@@ -8,14 +8,13 @@ IN: compiler
 M: object inference-error-major? drop t ;
 
 : compile-error ( word error -- )
-    batch-mode get [
+    compile-errors get [
-        2array compile-errors get push
+        >r 2array r> push
     ] [
-        "quiet" get [ drop ] [ print-error flush ] if drop
+        "quiet" get [ 2drop ] [ print-error flush drop ] if
-    ] if ;
+    ] if* ;
 
 : begin-batch ( -- )
-    batch-mode on
     V{ } clone compile-errors set-global ;
 
 : compile-error. ( pair -- )
@@ -37,7 +36,6 @@ M: object inference-error-major? drop t ;
 : :warnings (:warnings) [ compile-error. ] each ;
 
 : end-batch ( -- )
-    batch-mode off
     "quiet" get [
         "Compile finished." print
         nl
@@ -48,6 +46,9 @@ M: object inference-error-major? drop t ;
         nl
     ] unless ;
 
+: with-compile-errors ( quot -- )
+    [ begin-batch call end-batch ] with-scope ; inline
+
 : compile ( word -- )
     H{ } clone [
         compiled-xts [ (compile) ] with-variable
@@ -56,15 +57,10 @@ M: object inference-error-major? drop t ;
 : compile-failed ( word error -- )
     dupd compile-error dup update-xt unchanged-word ;
 
-: forget-errors ( seq -- )
-    [ f "no-effect" set-word-prop ] each ;
-
 : (compile-batch) ( words -- )
     H{ } clone [
         compiled-xts [
-            [
+            [ [ (compile) ] [ compile-failed ] recover ] each
-                [ (compile) ] [ compile-failed ] recover
-            ] each
         ] with-variable
     ] keep [ swap add* ] { } assoc>map modify-code-heap ;
 
@@ -72,16 +68,11 @@ M: object inference-error-major? drop t ;
     dup empty? [
         drop
     ] [
-        dup begin-batch
+        [ (compile-batch) ] with-compile-errors
-        dup forget-errors
-        (compile-batch)
-        end-batch
     ] if ;
 
 : compile-vocabs ( seq -- ) [ words ] map concat compile-batch ;
 
-: compile-all ( -- ) vocabs compile-vocabs ;
-
 : compile-quot ( quot -- word ) define-temp dup compile ;
 
 : compile-1 ( quot -- ) compile-quot execute ;
@@ -91,5 +82,8 @@ M: object inference-error-major? drop t ;
         dup keys compile-batch clear-assoc
     ] when* ;
 
-: recompile-all ( -- )
+: forget-errors ( seq -- )
-    all-words [ changed-word ] each recompile ;
+    [ f "no-effect" set-word-prop ] each ;
+
+: compile-all ( -- )
+    all-words dup forget-errors [ changed-word ] each recompile ;

core/cpu/x86/architecture/architecture.factor

@@ -102,7 +102,7 @@ M: x86-backend %jump-t ( label -- )
     ! x86, this is redundant.
     "scratch" operand HEX: ffffffff MOV rc-absolute-cell rel-dispatch
     "n" operand "n" operand "scratch" operand [+] MOV
-    "n" operand compiled-header-size ADD ;
+    "n" operand dup word-xt-offset [+] MOV ;
 
 : dispatch-template ( word-table# quot -- )
     [

core/memory/memory-tests.factor

@@ -4,6 +4,8 @@ IN: temporary
 
 TUPLE: testing x y z ;
 
+[ save-image-and-exit ] unit-test-fails
+
 [ ] [
     num-types get [
         type>class [

vm/code_gc.c

@@ -264,18 +264,6 @@ void collect_literals(void)
 	iterate_code_heap(collect_literals_step);
 }
 
-/* Mark all XTs referenced from a code block */
-void mark_sweep_step(F_COMPILED *compiled, CELL code_start,
-	CELL reloc_start, CELL literals_start, CELL words_start, CELL words_end)
-{
-	F_COMPILED **start = (F_COMPILED **)words_start;
-	F_COMPILED **end = (F_COMPILED **)words_end;
-	F_COMPILED **iter = start;
-
-	while(iter < end)
-		recursive_mark(compiled_to_block(*iter++));
-}
-
 /* Mark all XTs and literals referenced from a word XT */
 void recursive_mark(F_BLOCK *block)
 {
@@ -391,14 +379,14 @@ void forward_object_xts(void)
 			F_WORD *word = untag_object(obj);
 
 			if(word->compiledp != F)
-				set_word_xt(word,forward_xt(word->code));
+				word->code = forward_xt(word->code);
 		}
 		else if(type_of(obj) == QUOTATION_TYPE)
 		{
 			F_QUOTATION *quot = untag_object(obj);
 
 			if(quot->compiledp != F)
-				set_quot_xt(quot,forward_xt(quot->code));
+				quot->code = forward_xt(quot->code);
 		}
 		else if(type_of(obj) == CALLSTACK_TYPE)
 		{
@@ -411,33 +399,33 @@ void forward_object_xts(void)
 	gc_off = false;
 }
 
-void compaction_code_block_fixup(F_COMPILED *compiled, CELL code_start,
+/* Set the XT fields now that the heap has been compacted */
-	CELL reloc_start, CELL literals_start, CELL words_start, CELL words_end)
+void fixup_object_xts(void)
 {
-	F_COMPILED **iter = (F_COMPILED **)words_start;
+	begin_scan();
-	F_COMPILED **end = (F_COMPILED **)words_end;
 
-	while(iter < end)
+	CELL obj;
+
+	while((obj = next_object()) != F)
 	{
-		*iter = forward_xt(*iter);
+		if(type_of(obj) == WORD_TYPE)
-		iter++;
+		{
+			F_WORD *word = untag_object(obj);
+
+			if(word->compiledp != F)
+				set_word_xt(word,word->code);
+		}
+		else if(type_of(obj) == QUOTATION_TYPE)
+		{
+			F_QUOTATION *quot = untag_object(obj);
+
+			if(quot->compiledp != F)
+				set_quot_xt(quot,quot->code);
 		}
 	}
 
-void forward_block_xts(void)
+	/* End the heap scan */
-{
+	gc_off = false;
-	F_BLOCK *scan = first_block(&code_heap);
-
-	while(scan)
-	{
-		if(scan->status == B_ALLOCATED)
-		{
-			iterate_code_heap_step(block_to_compiled(scan),
-				compaction_code_block_fixup);
-		}
-
-		scan = next_block(&code_heap,scan);
-	}
 }
 
 void compact_heap(F_HEAP *heap)
@@ -450,7 +438,6 @@ void compact_heap(F_HEAP *heap)
 
 		if(scan->status == B_ALLOCATED && scan != scan->forwarding)
 			memcpy(scan->forwarding,scan,scan->size);
-
 		scan = next;
 	}
 }
@@ -465,19 +452,20 @@ void compact_code_heap(void)
 	code_gc();
 
 	fprintf(stderr,"*** Code heap compaction...\n");
+	fflush(stderr);
 
 	/* Figure out where the code heap blocks are going to end up */
 	CELL size = compute_heap_forwarding(&code_heap);
 
-	/* Update word and quotation XTs to point to the new locations */
+	/* Update word and quotation code pointers */
 	forward_object_xts();
 
-	/* Update code block XTs to point to the new locations */
-	forward_block_xts();
-
 	/* Actually perform the compaction */
 	compact_heap(&code_heap);
 
+	/* Update word and quotation XTs */
+	fixup_object_xts();
+
 	/* Now update the free list; there will be a single free block at
 	the end */
 	build_free_list(&code_heap,size);

vm/code_heap.c

@@ -317,6 +317,9 @@ F_COMPILED *add_compiled_block(
 
 void set_word_xt(F_WORD *word, F_COMPILED *compiled)
 {
+	if(compiled->type != WORD_TYPE)
+		critical_error("bad param to set_word_xt",(CELL)compiled);
+
 	word->code = compiled;
 	word->xt = (XT)(compiled + 1);
 

vm/data_gc.h

@@ -239,9 +239,6 @@ DEFPUSHPOP(root_,extra_roots)
 #define REGISTER_UNTAGGED(obj) root_push(obj ? tag_object(obj) : 0)
 #define UNREGISTER_UNTAGGED(obj) obj = untag_object(root_pop())
 
-#define REGISTER_STRING(obj) REGISTER_UNTAGGED(obj)
-#define UNREGISTER_STRING(obj) UNREGISTER_UNTAGGED(obj)
-
 /* We ignore strings which point outside the data heap, but we might be given
 a char* which points inside the data heap, in which case it is a root, for
 example if we call unbox_char_string() the result is placed in a byte array */

vm/image.c

@@ -150,6 +150,10 @@ DEFINE_PRIMITIVE(save_image)
 
 DEFINE_PRIMITIVE(save_image_and_exit)
 {
+	F_CHAR *path = unbox_native_string();
+
+	REGISTER_C_STRING(path);
+
 	/* strip out userenv data which is set on startup anyway */
 	CELL i;
 	for(i = 0; i < FIRST_SAVE_ENV; i++)
@@ -158,8 +162,10 @@ DEFINE_PRIMITIVE(save_image_and_exit)
 	/* do a full GC + code heap compaction */
 	compact_code_heap();
 
+	UNREGISTER_C_STRING(path);
+
 	/* Save the image */
-	save_image(unbox_native_string());
+	save_image(path);
 
 	/* now exit; we cannot continue executing like this */
 	exit(0);

vm/quotations.c

@@ -39,6 +39,9 @@ bool jit_stack_frame_p(F_ARRAY *array)
 
 void set_quot_xt(F_QUOTATION *quot, F_COMPILED *code)
 {
+	if(code->type != QUOTATION_TYPE)
+		critical_error("bad param to set_word_xt",(CELL)code);
+
 	quot->code = code;
 	quot->xt = (XT)(code + 1);
 	quot->compiledp = T;

vm/types.c

@@ -285,9 +285,9 @@ F_STRING* reallot_string(F_STRING* string, CELL capacity, u16 fill)
 	if(capacity < to_copy)
 		to_copy = capacity;
 
-	REGISTER_STRING(string);
+	REGISTER_UNTAGGED(string);
 	F_STRING *new_string = allot_string_internal(capacity);
-	UNREGISTER_STRING(string);
+	UNREGISTER_UNTAGGED(string);
 
 	memcpy(new_string + 1,string + 1,to_copy * CHARS);
 	fill_string(new_string,to_copy,capacity,fill);
@@ -381,9 +381,9 @@ F_BYTE_ARRAY *allot_c_string(CELL capacity, CELL size)
 		F_BYTE_ARRAY *_c_str; \
 		if(check && !check_string(s,sizeof(type))) \
 			general_error(ERROR_C_STRING,tag_object(s),F,NULL); \
-		REGISTER_STRING(s); \
+		REGISTER_UNTAGGED(s); \
 		_c_str = allot_c_string(capacity,sizeof(type)); \
-		UNREGISTER_STRING(s); \
+		UNREGISTER_UNTAGGED(s); \
 		type *c_str = (type*)(_c_str + 1); \
 		type##_string_to_memory(s,c_str); \
 		c_str[capacity] = 0; \