Listener auto-compiles; more smart recompile work in progress

core/compiler/batch/batch.factor

@@ -5,50 +5,46 @@ optimizer arrays definitions sequences assocs
 continuations generator compiler ;
 IN: compiler.batch
 
-! SYMBOL: compile-queue
+: with-compilation-unit ( quot -- )
-! SYMBOL: compile-results
+    H{ } clone
-! 
+    [ compiled-xts swap with-variable ] keep
-! TUPLE: compiled literals words rel labels code ;
+    [ swap add* ] { } assoc>map modify-code-heap ;
-! 
-! 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 ;
 
+: compile-batch ( words -- )
+    [ [ (compile) ] curry [ print-error ] recover ] each ;
 
+SYMBOL: compile-queue
+
+: queue-compile ( word -- )
+    compile-queue get push-front ;
+
+: compiled-usage ( word -- seq )
+    #! XXX
+    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.factor

@@ -2,23 +2,49 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel namespaces arrays sequences io inference.backend
 generator debugger math.parser prettyprint words continuations
-vocabs assocs alien.compiler ;
+vocabs assocs alien.compiler dlists optimizer ;
 IN: compiler
 
+SYMBOL: compiler-hook
+
+: compile-begins ( word -- )
+    compiler-hook get [ call ] when*
+    "quiet" get [ drop ] [ "Compiling " write . flush ] if ;
+
+: (compile) ( word -- )
+    dup compiling? not over compound? and [
+        [
+            dup compile-begins
+            dup dup word-dataflow nip optimize generate
+        ] curry [ print-error ] recover
+    ] [ drop ] if ;
+
+: finish-compilation-unit ( assoc -- )
+    [ swap add* ] { } assoc>map modify-code-heap ;
+
+: with-compilation-unit ( quot -- )
+    [
+        <dlist> compile-queue set
+        H{ } clone compiled-xts set
+        call
+        compile-queue get [ (compile) ] dlist-slurp
+        compiled-xts get finish-compilation-unit
+    ] with-scope ; inline
+
 : compile-batch ( words -- )
-    H{ } clone [
+    [ [ queue-compile ] each ] with-compilation-unit ;
-        compiled-xts [
-            [ [ (compile) ] curry [ print-error ] recover ] each
-        ] with-variable
-    ] keep [ swap add* ] { } assoc>map modify-code-heap ;
 
-: compile ( word -- ) 1array compile-batch ;
+: compile ( word -- )
+    [ queue-compile ] with-compilation-unit ;
 
-: compile-vocabs ( seq -- ) [ words ] map concat compile-batch ;
+: compile-vocabs ( seq -- )
+    [ words ] map concat compile-batch ;
 
-: compile-quot ( quot -- word ) define-temp dup compile ;
+: compile-quot ( quot -- word )
+    define-temp dup compile ;
 
-: compile-1 ( quot -- ) compile-quot execute ;
+: compile-1 ( quot -- )
+    compile-quot execute ;
 
 : recompile ( -- )
     changed-words get [

core/generator/generator-docs.factor

@@ -1,5 +1,5 @@
 USING: help.markup help.syntax words debugger generator.fixup
-generator.registers quotations kernel vectors arrays ;
+generator.registers quotations kernel vectors arrays effects ;
 IN: generator
 
 ARTICLE: "generator" "Compiled code generator"
@@ -64,7 +64,7 @@ HELP: generate
 { $description "Generates machine code for " { $snippet "label" } " from " { $snippet "node" } ". The value of " { $snippet "word" } " is retained for debugging purposes; it is the word which will appear in a call stack trace if this compiled code block throws an error when run." } ;
 
 HELP: word-dataflow
-{ $values { "word" word } { "dataflow" "a dataflow graph" } }
+{ $values { "word" word } { "effect" effect } { "dataflow" "a dataflow graph" } }
 { $description "Outputs the dataflow graph of a word, taking specializers into account (see " { $link "specializers" } ")." } ;
 
 HELP: define-intrinsics

core/generator/generator.factor

@@ -4,13 +4,20 @@ USING: arrays assocs classes combinators cpu.architecture
 effects generator.fixup generator.registers generic hashtables
 inference inference.backend inference.dataflow io kernel
 kernel.private layouts math namespaces optimizer prettyprint
-quotations sequences system threads words ;
+quotations sequences system threads words dlists ;
 IN: generator
 
+SYMBOL: compile-queue
+
 SYMBOL: compiled-xts
 
-: save-xt ( word xt -- )
+: 6array 3array >r 3array r> append ;
-    swap dup unchanged-word compiled-xts get set-at ;
+
+: begin-compiling ( word -- )
+    f swap compiled-xts get set-at ;
+
+: finish-compiling ( word literals words rel labels code -- )
+    6array swap dup unchanged-word compiled-xts get set-at ;
 
 : compiling? ( word -- ? )
     {
@@ -19,6 +26,9 @@ SYMBOL: compiled-xts
         { [ t ] [ compiled? ] }
     } cond ;
 
+: queue-compile ( word -- )
+    compile-queue get push-front ;
+
 SYMBOL: compiling-word
 
 SYMBOL: compiling-label
@@ -36,17 +46,15 @@ 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 [
+    pick begin-compiling [
         roll compiling-word set
         pick compiling-label set
         init-generator
         call
         literal-table get >array
         word-table get >array
-    ] { } make fixup 6array save-xt ;
+    ] { } make fixup finish-compiling ;
 
 : generate-profiler-prologue ( -- )
     compiled-stack-traces? get [
@@ -70,30 +78,12 @@ GENERIC: generate-node ( node -- next )
         profiler-prologue get
     ] generate-1 ;
 
-: word-dataflow ( word -- dataflow )
+: 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 nip ;
+    ] with-infer ;
-
-SYMBOL: compiler-hook
-
-[ ] compiler-hook set-global
-
-SYMBOL: compile-errors
-
-: compile-begins ( word -- )
-    compiler-hook get call
-    "quiet" get [ drop ] [ "Compiling " write . flush ] if ;
-
-: (compile) ( word -- )
-    dup compiling? not over compound? and [
-        dup compile-begins
-        dup dup word-dataflow optimize generate
-    ] [
-        drop
-    ] if ;
 
 : intrinsics ( #call -- quot )
     node-param "intrinsics" word-prop ;
@@ -140,7 +130,7 @@ M: node generate-node drop iterate-next ;
     } cond ;
 
 : generate-call ( label -- next )
-    dup (compile)
+    dup queue-compile
     end-basic-block
     tail-call? [
         %jump f

core/listener/listener.factor

@@ -48,7 +48,7 @@ M: duplex-stream parse-interactive
     listener-hook get call prompt.
     [
         stdio get parse-interactive
-        [ do-parse-hook call ] [ bye ] if*
+        [ call ] [ bye ] if*
     ] try ;
 
 : until-quit ( -- )

core/parser/parser.factor

@@ -443,8 +443,8 @@ SYMBOL: parse-hook
             \ contents get string-lines parse-fresh
             dup finish-parsing
             do-parse-hook
-        ] with-scope
+        ] [ ] [ undo-parsing ] cleanup
-    ] [ ] [ undo-parsing ] cleanup ;
+    ] with-scope ;
 
 : parse-file-restarts ( file -- restarts )
     "Load " swap " again" 3append t 2array 1array ;

vm/code_heap.c

@@ -38,6 +38,11 @@ void *get_rel_symbol(F_REL *rel, CELL literals_start)
 
 static CELL xt_offset;
 
+void incompatible_call_error(void)
+{
+	critical_error("Calling non-optimized word from optimized word",0);
+}
+
 /* Compute an address to store at a relocation */
 INLINE CELL compute_code_rel(F_REL *rel,
 	CELL code_start, CELL literals_start, CELL words_start)
@@ -56,10 +61,16 @@ INLINE CELL compute_code_rel(F_REL *rel,
 		return CREF(words_start,REL_ARGUMENT(rel));
 	case RT_XT:
 		word = untag_word(get(CREF(words_start,REL_ARGUMENT(rel))));
-		return (CELL)word->code + sizeof(F_COMPILED) + xt_offset;
+		if(word->compiledp == F)
+			return (CELL)incompatible_call_error;
+		else
+			return (CELL)word->code + sizeof(F_COMPILED) + xt_offset;
 	case RT_XT_PROFILING:
 		word = untag_word(get(CREF(words_start,REL_ARGUMENT(rel))));
-		return (CELL)word->code + sizeof(F_COMPILED);
+		if(word->compiledp == F)
+			return (CELL)incompatible_call_error;
+		else
+			return (CELL)word->code + sizeof(F_COMPILED);
 	case RT_LABEL:
 		return code_start + REL_ARGUMENT(rel);
 	default:
@@ -365,5 +376,6 @@ DEFINE_PRIMITIVE(modify_code_heap)
 		set_word_xt(word,compiled);
 	}
 
-	iterate_code_heap(finalize_code_block);
+	if(count != 0)
+		iterate_code_heap(finalize_code_block);
 }