Replace compiled? primitive with compiled? word slot

TODO.FACTOR.txt

@@ -11,10 +11,6 @@
   - files can be reloaded and edited
   - modules can be (re)loaded
   - keyboard navigation
-- editor:
-  - more efficient multi-line inserts
-  - write "foo| " and put caret at | then select word element: selects
-    space
 - ui browser: show currently selected vocab & words
   - keyboard-navigatable list gadget of some kind
 - tuple= in dataflow view
@@ -22,7 +18,6 @@
 - ui quick start doc
 - auto-update browser and help when sources reload
 - how do we refer to command shortcuts in the docs?
-- reliably clonable gadgets
 - figure out if we need both set-model and set-model*
 - if i do 10000 [ . ] each and then clear, the listener window is slow
 - full-height nodes should really be full height
@@ -38,11 +33,11 @@
   - editor should support stream output protocol
   - double/triple click
   - autoscroll
-  - undo and redo
   - transpose char/word/line
-  - page up/down
-  - search and replace
   - drag scroll
+  - more efficient multi-line inserts
+  - write "foo| " and put caret at | then select word element: selects
+    space
 - slider needs to be modelized
 - fonts/ should go inside the .app -- we need multi-tier resource-path
 - should be possible to drop an image file on the .app to run it
@@ -50,7 +45,6 @@
 - own-selection violates ICCCM
 - cocoa: windows are not updated while resizing
 - grid slows down with 2000 lines
-- ui uses too much cpu time idling
 - see if its possible to only repaint dirty regions
 - x11 title bars are funny
 - rollover is not updated on window focus changes
@@ -102,6 +96,7 @@
 
 + misc:
 
+- symbol redef is an xref false positive
 - signal 4 on datastack underflow on mac intel??
 - fix alien-callback/SEH bug on win32
 - minor GC takes too long now, we should card mark code heap

library/bootstrap/image.factor

@@ -172,6 +172,7 @@ M: f '
         dup word-primitive ' ,
         dup word-def ' ,
         dup word-props ' ,
+        f ' ,
         0 ,
     ] { } make
     word-tag word-tag [ emit-seq ] emit-object

library/bootstrap/primitives.factor

@@ -99,7 +99,6 @@ call
     { "float>=" "math-internals"            }
     { "(word)" "kernel-internals"           }
     { "update-xt" "words"                   }
-    { "compiled?" "words"                   }
     { "drop" "kernel"                       }
     { "2drop" "kernel"                      }
     { "3drop" "kernel"                      }
@@ -284,6 +283,12 @@ num-types f <array> builtins set
         { "word-props" "words" }
         { "set-word-props" "words" }
     }
+    {
+        7
+        object
+        { "compiled?" "words" }
+        f
+    }
 } define-builtin
 
 "ratio?" "math" create t "inline" set-word-prop

vm/code_gc.c

@@ -67,6 +67,8 @@ CELL heap_allot(HEAP *heap, CELL size)
 	F_BLOCK *prev = NULL;
 	F_BLOCK *scan = heap->free_list;
 
+	size = align8(size);
+
 	while(scan)
 	{
 		CELL this_size = scan->size - sizeof(F_BLOCK);
@@ -209,20 +211,20 @@ void mark_sweep_step(F_COMPILED *compiled, CELL code_start,
 	if(compiled->finalized)
 	{
 		for(scan = words_start; scan < words_end; scan += CELLS)
-			mark_and_sweep(get(scan));
+			recursive_mark(get(scan));
 	}
 }
 
-void mark_and_sweep(CELL xt)
+void recursive_mark(CELL xt)
 {
 	F_BLOCK *block = xt_to_block(xt);
 
 	if(block->status == B_MARKED)
 		return;
-	else if(block->status == B_FREE)
-		critical_error("Marking a free block",(CELL)block);
-
+	else if(block->status == B_ALLOCATED)
 		block->status = B_MARKED;
+	else
+		critical_error("Marking the wrong block",(CELL)block);
 
 	F_COMPILED *compiled = xt_to_compiled(xt);
 	iterate_code_heap_step(compiled,collect_literals_step);

vm/code_gc.h

@@ -74,6 +74,6 @@ INLINE F_COMPILED *xt_to_compiled(CELL xt)
 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 recursive_mark(CELL xt);
 void primitive_code_room(void);
 void primitive_code_gc(void);

vm/compiler.c

@@ -232,6 +232,7 @@ void primitive_finalize_compile(void)
 		F_ARRAY *pair = untag_array(get(AREF(array,i)));
 		F_WORD *word = untag_word(get(AREF(pair,0)));
 		word->xt = to_cell(get(AREF(pair,1)));
+		word->compiledp = T;
 	}
 
 	/* perform relocation */

vm/data_gc.c

@@ -79,31 +79,6 @@ void primitive_size(void)
 	drepl(tag_fixnum(object_size(dpeek())));
 }
 
-/* The number of cells from the start of the object which should be scanned by
-the GC. Some types have a binary payload at the end (string, word, DLL) which
-we ignore. */
-CELL binary_payload_start(CELL pointer)
-{
-	switch(untag_header(get(pointer)))
-	{
-	/* these objects do not refer to other objects at all */
-	case STRING_TYPE:
-	case FLOAT_TYPE:
-	case BYTE_ARRAY_TYPE:
-	case BIGNUM_TYPE:
-		return 0;
-	/* these objects have some binary data at the end */
-	case WORD_TYPE:
-		return sizeof(F_WORD) - CELLS;
-	case ALIEN_TYPE:
-	case DLL_TYPE:
-		return CELLS * 2;
-	/* everything else consists entirely of pointers */
-	default:
-		return unaligned_object_size(pointer);
-	}
-}
-
 void primitive_data_room(void)
 {
 	F_ARRAY *a = array(ARRAY_TYPE,gen_count,F);
@@ -417,8 +392,37 @@ CELL copy_object(CELL pointer)
 		return RETAG(copy_object_impl(pointer),tag);
 }
 
-INLINE void collect_object(CELL scan)
+/* The number of cells from the start of the object which should be scanned by
+the GC. Some types have a binary payload at the end (string, word, DLL) which
+we ignore. */
+CELL binary_payload_start(CELL pointer)
 {
+	switch(untag_header(get(pointer)))
+	{
+	/* these objects do not refer to other objects at all */
+	case STRING_TYPE:
+	case FLOAT_TYPE:
+	case BYTE_ARRAY_TYPE:
+	case BIGNUM_TYPE:
+		return 0;
+	/* these objects have some binary data at the end */
+	case WORD_TYPE:
+		return sizeof(F_WORD) - CELLS;
+	case ALIEN_TYPE:
+	case DLL_TYPE:
+		return CELLS * 2;
+	/* everything else consists entirely of pointers */
+	default:
+		return unaligned_object_size(pointer);
+	}
+}
+
+/* Every object has a regular representation in the runtime, which makes GC
+much simpler. Every slot of the object until binary_payload_start is a pointer
+to some other object. */
+INLINE void collect_object(CELL start)
+{
+	CELL scan = start;
 	CELL payload_start = binary_payload_start(scan);
 	CELL end = scan + payload_start;
 
@@ -429,6 +433,16 @@ INLINE void collect_object(CELL scan)
 		copy_handle((CELL*)scan);
 		scan += CELLS;
 	}
+
+	/* It is odd to put this hook here, but this is the only special case
+	made for any type of object by the GC. If code GC is being performed,
+	compiled code blocks referenced by this word must be marked. */
+	if(collecting_code && object_type(start) == WORD_TYPE)
+	{
+		F_WORD *word = (F_WORD *)start;
+		if(word->compiledp != F)
+			recursive_mark(word->xt);
+	}
 }
 
 CELL collect_next(CELL scan)
@@ -487,6 +501,7 @@ void end_gc()
 		fprintf(stderr,"*** %s GC (%ld minor, %ld cards)\n",
 			collecting_code ? "Code and data" : "Data",
 			minor_collections,cards_scanned);
+		fflush(stderr);
 		minor_collections = 0;
 		cards_scanned = 0;
 	}

vm/layouts.h

@@ -105,6 +105,11 @@ typedef struct {
 	CELL array;
 } F_HASHTABLE;
 
+/* When a word is executed we jump to the value of the XT field. However this
+value is an unportable function pointer. Interpreted and primitive words will
+have their XT set to a value in the 'primitives' global (see primitives.c).
+Compiled words are marked as such and their XT, which point inside the code
+heap, are instead relocated on startup, and also considered a code GC root. */
 typedef struct {
 	/* TAGGED header */
 	CELL header;
@@ -120,6 +125,8 @@ typedef struct {
 	CELL def;
 	/* TAGGED property hash for library code */
 	CELL props;
+	/* TAGGED t or f, depending on if the word is compiled or not */
+	CELL compiledp;
 	/* UNTAGGED execution token: jump here to execute word */
 	CELL xt;
 } F_WORD;

vm/primitives.c

@@ -68,7 +68,6 @@ void* primitives[] = {
 	primitive_float_greatereq,
 	primitive_word,
 	primitive_update_xt,
-	primitive_word_compiledp,
 	primitive_drop,
 	primitive_2drop,
 	primitive_3drop,

vm/types.c

@@ -417,11 +417,9 @@ void primitive_hashtable(void)
 	dpush(tag_object(hash));
 }
 
-/* When a word is executed we jump to the value of the xt field. However this
-   value is an unportable function pointer, so in the image we store a primitive
-   number that indexes a list of xts. */
 void update_xt(F_WORD* word)
 {
+	word->compiledp = F;
 	word->xt = primitive_to_xt(to_fixnum(word->primitive));
 }
 
@@ -442,6 +440,7 @@ void primitive_word(void)
 	word->primitive = tag_fixnum(0);
 	word->def = F;
 	word->props = F;
+	word->compiledp = F;
 	word->xt = (CELL)undefined;
 	dpush(tag_word(word));
 }
@@ -451,23 +450,11 @@ void primitive_update_xt(void)
 	update_xt(untag_word(dpop()));
 }
 
-void primitive_word_compiledp(void)
-{
-	F_WORD* word = untag_word(dpop());
-	if(to_fixnum(word->primitive) != 1)
-		box_boolean(false);
-	else
-		box_boolean(word->xt != (CELL)docol);
-}
-
 void fixup_word(F_WORD* word)
 {
 	/* If this is a compiled word, relocate the code pointer. Otherwise,
 	reset it based on the primitive number of the word. */
-	if(code_relocation_base != 0
-		&& word->xt >= code_relocation_base
-		&& word->xt < code_relocation_base
-		- compiling.base + compiling.limit)
+	if(word->compiledp != F)
 		code_fixup(&word->xt);
 	else
 		update_xt(word);

vm/types.h

@@ -161,7 +161,6 @@ INLINE CELL tag_word(F_WORD *word)
 void update_xt(F_WORD* word);
 void primitive_word(void);
 void primitive_update_xt(void);
-void primitive_word_compiledp(void);
 void fixup_word(F_WORD* word);
 
 INLINE F_WRAPPER *untag_wrapper_fast(CELL tagged)