Merge branch 'smart_recompile' of slava@10.0.0.2:factor into smart_recompile

core/alien/compiler/compiler.factor

@@ -387,7 +387,6 @@ TUPLE: callback-context ;
 : generate-callback ( node -- )
     dup alien-callback-xt dup rot [
         init-templates
-        generate-profiler-prologue
         %save-word-xt
         %prologue-later
         dup alien-stack-frame [
@@ -395,6 +394,7 @@ TUPLE: callback-context ;
             dup wrap-callback-quot %alien-callback
             %callback-return
         ] with-stack-frame
+        0
     ] generate-1 ;
 
 M: alien-callback generate-node

core/bootstrap/compiler/compiler.factor

@@ -11,7 +11,7 @@ global [ { "compiler" } add-use ] bind
 
 "-no-stack-traces" cli-args member? [
     f compiled-stack-traces? set-global
-    0 set-profiler-prologues
+    0 profiler-prologue set-global
 ] when
 
 ! Compile a set of words ahead of our general
@@ -33,12 +33,14 @@ global [ { "compiler" } add-use ] bind
 
     delegate
 
-    underlying
+    underlying2
 
     find-pair-next namestack*
 
     bitand bitor bitxor bitnot
+} compile-batch
 
+{
     + 1+ 1- 2/ < <= > >= shift min
 
     new nth push pop peek hashcode* = get set

core/bootstrap/primitives.factor

@@ -189,7 +189,7 @@ H{ } clone update-map set
     { "tag" "kernel.private" }
     { "cwd" "io.files" }
     { "cd" "io.files" }
-    { "add-compiled-block" "generator" }
+    { "modify-code-heap" "generator" }
     { "dlopen" "alien" }
     { "dlsym" "alien" }
     { "dlclose" "alien" }
@@ -243,7 +243,6 @@ H{ } clone update-map set
     { "end-scan" "memory" }
     { "size" "memory" }
     { "die" "kernel" }
-    { "finalize-compile" "generator" }
     { "fopen" "io.streams.c" }
     { "fgetc" "io.streams.c" }
     { "fread" "io.streams.c" }

core/compiler/batch/batch.factor

@@ -0,0 +1,54 @@
+! Copyright (C) 2007 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: namespaces dlists kernel words inference.backend
+optimizer arrays definitions sequences assocs
+continuations generator compiler ;
+IN: compiler.batch
+
+! SYMBOL: compile-queue
+! SYMBOL: compile-results
+! 
+! TUPLE: compiled literals words rel labels code ;
+! 
+! C: <compiled> compiled
+! 
+! : queue-compile ( word -- )
+!     compile-queue get push-front ;
+! 
+! : word-dataflow ( word -- effect dataflow )
+!     [
+!         dup "no-effect" word-prop [ no-effect ] when
+!         dup specialized-def over dup 2array 1array infer-quot
+!         finish-word
+!     ] with-infer ;
+! 
+! : compiled-usage usage [ word? ] subset ;
+! 
+! : ripple-up ( effect word -- )
+!     tuck "compiled-effect" word-prop =
+!     [ drop ] [ compiled-usage [ queue-compile ] each ] if ;
+! 
+! : save-effect ( effect word -- )
+!     swap "compiled-effect" set-word-prop ;
+! 
+! : add-compiled ( word -- )
+!     >r f f f f f <compiled> r> compile-results get set-at ;
+! 
+! : compile-1 ( word -- )
+!     dup compile-results get at [ drop ] [
+!         [ [ word-dataflow drop ] [ 2drop f ] recover ] keep
+!         2dup ripple-up
+!         tuck save-effect
+!         add-compiled
+!     ] if ;
+! 
+! : compile-batch ( words -- )
+!     [
+!         <dlist> compile-queue set
+!         [ queue-compile ] each
+!         H{ } clone compile-results set
+!         compile-queue get [ compile-1 ] dlist-slurp
+!         compile-results get
+!     ] with-scope ;
+
+

core/compiler/compiler-docs.factor

@@ -5,8 +5,6 @@ IN: compiler
 ARTICLE: "compiler-usage" "Calling the optimizing compiler"
 "The main entry point to the optimizing compiler is a single word taking a word as input:"
 { $subsection compile }
-"The above word throws an error if the word did not compile. Another variant simply prints the error and returns:"
-{ $subsection try-compile }
 "The optimizing compiler can also compile a single quotation:"
 { $subsection compile-quot }
 { $subsection compile-1 }
@@ -76,18 +74,12 @@ $low-level-note ;
 
 HELP: compile
 { $values { "word" word } }
-{ $description "Compiles a word together with any uncompiled dependencies. Does nothing if the word is already compiled." }
+{ $description "Compiles a word together with any uncompiled dependencies. Does nothing if the word is already compiled." } ;
-{ $errors "If compilation fails, this word can throw an error. In particular, if the word's stack effect cannot be inferred, this word will throw an error. The related " { $link try-compile } " word logs errors and returns rather than throwing." } ;
 
 HELP: compile-failed
 { $values { "word" word } { "error" "an error" } }
 { $description "Called when the optimizing compiler fails to compile a word. The word is removed from the set of words pending compilation, and it's un-optimized compiled definition will be used. The error is reported by calling " { $link compile-error } "." } ;
 
-HELP: try-compile
-{ $values { "word" word } }
-{ $description "Compiles a word together with any uncompiled dependencies. Does nothing if the word is already compiled." }
-{ $errors "If compilation fails, this calls " { $link compile-failed } "." } ;
-
 HELP: forget-errors
 { $values { "seq" "a sequence of words" } }
 { $description "If any of the words in the sequence previously failed to compile, removes the marker indicating such."

core/compiler/compiler.factor

@@ -14,12 +14,8 @@ M: object inference-error-major? drop t ;
         "quiet" get [ drop ] [ print-error flush ] if drop
     ] if ;
 
-: begin-batch ( seq -- )
+: begin-batch ( -- )
     batch-mode on
-    "quiet" get [ drop ] [
-        [ "Compiling " % length # " words..." % ] "" make
-        print flush
-    ] if
     V{ } clone compile-errors set-global ;
 
 : compile-error. ( pair -- )
@@ -55,24 +51,30 @@ M: object inference-error-major? drop t ;
 : compile ( word -- )
     H{ } clone [
         compiled-xts [ (compile) ] with-variable
-    ] keep >alist finalize-compile ;
+    ] keep [ swap add* ] { } assoc>map modify-code-heap ;
 
 : compile-failed ( word error -- )
     dupd compile-error dup update-xt unchanged-word ;
 
-: try-compile ( word -- )
-    [ compile ] [ compile-failed ] recover ;
-
 : forget-errors ( seq -- )
     [ f "no-effect" set-word-prop ] each ;
 
+: (compile-batch) ( words -- )
+    H{ } clone [
+        compiled-xts [
+            [
+                [ (compile) ] [ compile-failed ] recover
+            ] each
+        ] with-variable
+    ] keep [ swap add* ] { } assoc>map modify-code-heap ;
+
 : compile-batch ( seq -- )
     dup empty? [
         drop
     ] [
         dup begin-batch
         dup forget-errors
-        [ try-compile ] each
+        (compile-batch)
         end-batch
     ] if ;
 

core/cpu/architecture/architecture.factor

@@ -5,8 +5,7 @@ namespaces sequences layouts system hashtables classes alien
 byte-arrays bit-arrays float-arrays combinators words ;
 IN: cpu.architecture
 
-: set-profiler-prologues ( n -- )
+SYMBOL: profiler-prologue
-    39 setenv ;
 
 SYMBOL: compiler-backend
 

core/cpu/arm/arm.factor

@@ -53,4 +53,4 @@ T{ arm-backend } compiler-backend set-global
     t have-BLX? set-global
 ] when
 
-7 cells set-profiler-prologues
+7 cells profiler-prologues set-global

core/cpu/ppc/architecture/architecture.factor

@@ -134,7 +134,7 @@ M: ppc-backend %jump-t ( label -- )
         "offset" operand "n" operand 1 SRAWI
         0 11 LOAD32 rc-absolute-ppc-2/2 rel-dispatch
         11 dup "offset" operand LWZX
-        11 dup compiled-header-size ADDI
+        11 dup word-xt-offset LWZ
         r> call
     ] H{
         { +input+ { { f "n" } } }

core/cpu/ppc/ppc.factor

@@ -14,4 +14,4 @@ namespaces alien.c-types kernel system combinators ;
 
 T{ ppc-backend } compiler-backend set-global
 
-6 cells set-profiler-prologues
+6 cells profiler-prologue set-global

core/cpu/x86/32/32.factor

@@ -275,7 +275,7 @@ T{ x86-backend f 4 } compiler-backend set-global
     JNE
 ] { } define-if-intrinsic
 
-10 set-profiler-prologues
+10 profiler-prologue set-global
 
 "-no-sse2" cli-args member? [
     "Checking if your CPU supports SSE2..." print flush

core/cpu/x86/64/64.factor

@@ -201,4 +201,4 @@ M: struct-type flatten-value-type ( type -- seq )
         ] each
     ] if ;
 
-12 set-profiler-prologues
+12 profiler-prologue set-global

core/generator/generator-docs.factor

@@ -15,25 +15,20 @@ $nl
 "The main entry point into the code generator:"
 { $subsection generate }
 "Primitive compiler interface exported by the Factor VM:"
-{ $subsection add-compiled-block }
+{ $subsection modify-code-heap } ;
-{ $subsection finalize-compile } ;
 
 ABOUT: "generator"
 
 HELP: compiled-xts
-{ $var-description "During compilation, holds a hashtable mapping words to temporary uninterned words. The XT of each value points to the compiled code block of each key; at the end of compilation, the XT of each key is set to the XT of the value." } ;
+{ $var-description "During compilation, holds a hashtable mapping words to 5-element arrays holding compiled code." } ;
 
 HELP: compiling?
 { $values { "word" word } { "?" "a boolean" } }
 { $description "Tests if a word is going to be or already is compiled." } ;
 
-HELP: finalize-compile ( xts -- )
+HELP: modify-code-heap ( array -- )
-{ $values { "xts" "an association list mapping words to uninterned words" } }
+{ $values { "array" "an array of 6-element arrays having shape " { $snippet "{ word code labels rel words literals }" } } }
-{ $description "Performs relocation, atomically changes the XT of each key to the XT of each value, and flushes the CPU instruction cache on architectures where this has to be done manually." } ;
+{ $description "Stores compiled code definitions in the code heap and updates words to point at those definitions." } ;
-
-HELP: add-compiled-block ( literals words rel labels code -- xt )
-{ $values { "literals" vector } { "words" "a vector of words" } { "rel" "a vector of integers" } { "labels" "an array of integers" } { "code" "a vector of integers" } { "xt" "an uninterned word" } }
-{ $description "Adds a new compiled block and outputs an uninterned word whose XT points at this block. This uninterned word can then be passed to " { $link finalize-compile } "." } ;
 
 HELP: compiling-word
 { $var-description "The word currently being compiled, set by " { $link generate-1 } "." } ;

core/generator/generator.factor

@@ -36,6 +36,8 @@ t compiled-stack-traces? set-global
     compiled-stack-traces? get compiling-word get f ?
     literal-table get push ;
 
+: 6array 3array >r 3array r> append ;
+
 : generate-1 ( word label node quot -- )
     pick f save-xt [
         roll compiling-word set
@@ -44,7 +46,7 @@ t compiled-stack-traces? set-global
         call
         literal-table get >array
         word-table get >array
-    ] { } make fixup add-compiled-block save-xt ;
+    ] { } make fixup 6array save-xt ;
 
 : generate-profiler-prologue ( -- )
     compiled-stack-traces? get [
@@ -65,6 +67,7 @@ GENERIC: generate-node ( node -- next )
         current-label-start define-label
         current-label-start resolve-label
         [ generate-nodes ] with-node-iterator
+        profiler-prologue get
     ] generate-1 ;
 
 : word-dataflow ( word -- dataflow )
@@ -84,11 +87,7 @@ SYMBOL: batch-mode
 
 : compile-begins ( word -- )
     compiler-hook get call
-    "quiet" get batch-mode get or [
+    "quiet" get [ drop ] [ "Compiling " write . flush ] if ;
-        drop
-    ] [
-        "Compiling " write . flush
-    ] if ;
 
 : (compile) ( word -- )
     dup compiling? not over compound? and [
@@ -192,6 +191,7 @@ M: #if generate-node
             %save-dispatch-xt
             %prologue-later
             [ generate-nodes ] with-node-iterator
+            0
         ] generate-1
     ] keep ;
 

core/words/words.factor

@@ -94,7 +94,6 @@ M: word uses ( word -- seq )
     word-def quot-uses keys ;
 
 M: compound redefined* ( word -- )
-    dup changed-word
     { "inferred-effect" "base-case" "no-effect" } reset-props ;
 
 <PRIVATE

vm/code_gc.c

@@ -254,19 +254,8 @@ void collect_literals_step(F_COMPILED *compiled, CELL code_start,
 	for(scan = literals_start; scan < literal_end; scan += CELLS)
 		copy_handle((CELL*)scan);
 
-	/* If the block is not finalized, the words area contains pointers to
+	for(scan = words_start; scan < words_end; scan += CELLS)
-	words in the data heap rather than XTs in the code heap */
+		copy_handle((CELL*)scan);
-	switch(compiled->finalized)
-	{
-	case false:
-		for(scan = words_start; scan < words_end; scan += CELLS)
-			copy_handle((CELL*)scan);
-		break;
-	case true:
-		break;
-	default:
-		critical_error("Invalid compiled->finalized",(CELL)compiled);
-	}
 }
 
 /* Copy literals referenced from all code blocks to newspace */
@@ -305,18 +294,6 @@ void recursive_mark(F_BLOCK *block)
 
 	F_COMPILED *compiled = block_to_compiled(block);
 	iterate_code_heap_step(compiled,collect_literals_step);
-
-	switch(compiled->finalized)
-	{
-	case false:
-		break;
-	case true:
-		iterate_code_heap_step(compiled,mark_sweep_step);
-		break;
-	default:
-		critical_error("Invalid compiled->finalized",(CELL)compiled);
-		break;
-	}
 }
 
 /* Push the free space and total size of the code heap */

vm/code_heap.c

@@ -42,6 +42,8 @@ static CELL xt_offset;
 INLINE CELL compute_code_rel(F_REL *rel,
 	CELL code_start, CELL literals_start, CELL words_start)
 {
+	F_WORD *word;
+
 	switch(REL_TYPE(rel))
 	{
 	case RT_PRIMITIVE:
@@ -53,11 +55,11 @@ INLINE CELL compute_code_rel(F_REL *rel,
 	case RT_DISPATCH:
 		return CREF(words_start,REL_ARGUMENT(rel));
 	case RT_XT:
-		return get(CREF(words_start,REL_ARGUMENT(rel)))
+		word = untag_word(get(CREF(words_start,REL_ARGUMENT(rel))));
-			+ sizeof(F_COMPILED) + xt_offset;
+		return (CELL)word->code + sizeof(F_COMPILED) + xt_offset;
 	case RT_XT_PROFILING:
-		return get(CREF(words_start,REL_ARGUMENT(rel)))
+		word = untag_word(get(CREF(words_start,REL_ARGUMENT(rel))));
-			+ sizeof(F_COMPILED);
+		return (CELL)word->code + sizeof(F_COMPILED);
 	case RT_LABEL:
 		return code_start + REL_ARGUMENT(rel);
 	default:
@@ -133,7 +135,7 @@ void apply_relocation(CELL class, CELL offset, F_FIXNUM absolute_value)
 void relocate_code_block(F_COMPILED *relocating, CELL code_start,
 	CELL reloc_start, CELL literals_start, CELL words_start, CELL words_end)
 {
-	xt_offset = (profiling_p() ? 0 : profiler_prologue());
+	xt_offset = (profiling_p() ? 0 : relocating->profiler_prologue);
 
 	F_REL *rel = (F_REL *)reloc_start;
 	F_REL *rel_end = (F_REL *)literals_start;
@@ -174,16 +176,6 @@ direct XT references, and perform fixups */
 void finalize_code_block(F_COMPILED *relocating, CELL code_start,
 	CELL reloc_start, CELL literals_start, CELL words_start, CELL words_end)
 {
-	CELL scan;
-
-	if(relocating->finalized != false)
-		critical_error("Finalizing a finalized block",(CELL)relocating);
-
-	for(scan = words_start; scan < words_end; scan += CELLS)
-		put(scan,(CELL)(untag_word(get(scan))->code));
-
-	relocating->finalized = true;
-
 	if(reloc_start != literals_start)
 	{
 		relocate_code_block(relocating,code_start,reloc_start,
@@ -242,8 +234,10 @@ CELL allot_code_block(CELL size)
 	return start;
 }
 
+/* Might GC */
 F_COMPILED *add_compiled_block(
 	CELL type,
+	CELL profiler_prologue,
 	F_ARRAY *code,
 	F_ARRAY *labels,
 	F_ARRAY *rel,
@@ -279,7 +273,7 @@ F_COMPILED *add_compiled_block(
 	header->reloc_length = rel_length;
 	header->literals_length = literals_length;
 	header->words_length = words_length;
-	header->finalized = false;
+	header->profiler_prologue = profiler_prologue;
 
 	here += sizeof(F_COMPILED);
 
@@ -327,49 +321,46 @@ void set_word_xt(F_WORD *word, F_COMPILED *compiled)
 	word->xt = (XT)(compiled + 1);
 
 	if(!profiling_p())
-		word->xt += profiler_prologue();
+		word->xt += compiled->profiler_prologue;
 
 	word->compiledp = T;
 }
 
-DEFINE_PRIMITIVE(add_compiled_block)
+DEFINE_PRIMITIVE(modify_code_heap)
 {
-	F_ARRAY *code = untag_array(dpop());
+	F_ARRAY *alist = untag_array(dpop());
-	F_ARRAY *labels = untag_array(dpop());
-	F_ARRAY *rel = untag_array(dpop());
-	F_ARRAY *words = untag_array(dpop());
-	F_ARRAY *literals = untag_array(dpop());
 
-	F_COMPILED *compiled = add_compiled_block(WORD_TYPE,code,labels,rel,words,literals);
+	CELL count = untag_fixnum_fast(alist->capacity);
-
-	/* push a new word whose XT points to this code block on the stack */
-	F_WORD *word = allot_word(F,F);
-	set_word_xt(word,compiled);
-	dpush(tag_object(word));
-}
-
-/* After batch compiling a bunch of words, perform various fixups to make them
-executable */
-DEFINE_PRIMITIVE(finalize_compile)
-{
-	F_ARRAY *array = untag_array(dpop());
-
-	/* set word XT's */
-	CELL count = untag_fixnum_fast(array->capacity);
 	CELL i;
 	for(i = 0; i < count; i++)
 	{
-		F_ARRAY *pair = untag_array(array_nth(array,i));
+		F_ARRAY *data = untag_array(array_nth(alist,i));
-		F_WORD *word = untag_word(array_nth(pair,0));
+
-		F_COMPILED *compiled = untag_word(array_nth(pair,1))->code;
+		F_WORD *word = untag_word(array_nth(data,0));
+		CELL profiler_prologue = to_cell(array_nth(data,1));
+		F_ARRAY *literals = untag_array(array_nth(data,2));
+		F_ARRAY *words = untag_array(array_nth(data,3));
+		F_ARRAY *rel = untag_array(array_nth(data,4));
+		F_ARRAY *labels = untag_array(array_nth(data,5));
+		F_ARRAY *code = untag_array(array_nth(data,6));
+
+		REGISTER_UNTAGGED(alist);
+		REGISTER_UNTAGGED(word);
+
+		F_COMPILED *compiled = add_compiled_block(
+			WORD_TYPE,
+			profiler_prologue,
+			code,
+			labels,
+			rel,
+			words,
+			literals);
+
+		UNREGISTER_UNTAGGED(word);
+		UNREGISTER_UNTAGGED(alist);
+
 		set_word_xt(word,compiled);
 	}
 
-	/* perform relocation */
+	iterate_code_heap(finalize_code_block);
-	for(i = 0; i < count; i++)
-	{
-		F_ARRAY *pair = untag_array(array_nth(array,i));
-		F_WORD *word = untag_word(array_nth(pair,0));
-		iterate_code_heap_step(word->code,finalize_code_block);
-	}
 }

vm/code_heap.h

@@ -63,6 +63,7 @@ void set_word_xt(F_WORD *word, F_COMPILED *compiled);
 
 F_COMPILED *add_compiled_block(
 	CELL type,
+	CELL profiler_prologue,
 	F_ARRAY *code,
 	F_ARRAY *labels,
 	F_ARRAY *rel,
@@ -71,5 +72,4 @@ F_COMPILED *add_compiled_block(
 
 CELL compiled_code_format(void);
 
-DECLARE_PRIMITIVE(add_compiled_block);
+DECLARE_PRIMITIVE(modify_code_heap);
-DECLARE_PRIMITIVE(finalize_compile);

vm/image.c

@@ -275,12 +275,7 @@ void fixup_code_block(F_COMPILED *relocating, CELL code_start,
 		data_fixup((CELL*)scan);
 
 	for(scan = words_start; scan < words_end; scan += CELLS)
-	{
+		data_fixup((CELL*)scan);
-		if(relocating->finalized)
-			code_fixup(scan);
-		else
-			data_fixup((CELL*)scan);
-	}
 
 	if(reloc_start != literals_start)
 	{

vm/layouts.h

@@ -152,7 +152,7 @@ typedef struct
 	CELL reloc_length; /* # bytes */
 	CELL literals_length; /* # bytes */
 	CELL words_length; /* # bytes */
-	CELL finalized; /* has finalize_code_block() been called on this yet? */
+	CELL profiler_prologue; /* # bytes */
 	CELL padding[2];
 } F_COMPILED;
 

vm/primitives.c

@@ -112,7 +112,7 @@ void *primitives[] = {
 	primitive_tag,
 	primitive_cwd,
 	primitive_cd,
-	primitive_add_compiled_block,
+	primitive_modify_code_heap,
 	primitive_dlopen,
 	primitive_dlsym,
 	primitive_dlclose,
@@ -166,7 +166,6 @@ void *primitives[] = {
 	primitive_end_scan,
 	primitive_size,
 	primitive_die,
-	primitive_finalize_compile,
 	primitive_fopen,
 	primitive_fgetc,
 	primitive_fread,

vm/profiler.c

@@ -5,11 +5,6 @@ bool profiling_p(void)
 	return to_boolean(userenv[PROFILING_ENV]);
 }
 
-F_FIXNUM profiler_prologue(void)
-{
-	return to_fixnum(userenv[PROFILER_PROLOGUE_ENV]);
-}
-
 void profiling_word(F_WORD *word)
 {
 	/* If we just enabled the profiler, reset call count */

vm/profiler.h

@@ -1,3 +1,2 @@
 bool profiling_p(void);
-F_FIXNUM profiler_prologue(void);
 DECLARE_PRIMITIVE(profiling);

vm/quotations.c

@@ -155,7 +155,7 @@ void jit_compile(F_QUOTATION *quot)
 	F_ARRAY *literals = allot_array(ARRAY_TYPE,1,tag_object(quot));
 	UNREGISTER_UNTAGGED(result);
 
-	F_COMPILED *compiled = add_compiled_block(QUOTATION_TYPE,result,NULL,NULL,NULL,literals);
+	F_COMPILED *compiled = add_compiled_block(QUOTATION_TYPE,0,result,NULL,NULL,NULL,literals);
 	iterate_code_heap_step(compiled,finalize_code_block);
 
 	UNREGISTER_UNTAGGED(quot);

vm/run.h

@@ -52,7 +52,6 @@ typedef enum {
 
 	/* Profiler support */    
 	PROFILING_ENV       = 38, /* is the profiler on? */
-	PROFILER_PROLOGUE_ENV     /* length of optimizing compiler's profiler prologue */
 } F_ENVTYPE;
 
 #define FIRST_SAVE_ENV BOOT_ENV