Working on compiled-usage

core/alien/compiler/compiler.factor

@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: arrays generator generator.registers generator.fixup
 hashtables kernel math namespaces sequences words
-inference.backend inference.dataflow system
+inference.state inference.backend inference.dataflow system
 math.parser classes alien.arrays alien.c-types alien.structs
 alien.syntax cpu.architecture alien inspector quotations assocs
 kernel.private threads continuations.private libc combinators ;

core/bootstrap/compiler/compiler.factor

@@ -1,3 +1,5 @@
+! Copyright (C) 2007, 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
 USING: compiler cpu.architecture vocabs.loader system sequences
 namespaces parser kernel kernel.private classes classes.private
 arrays hashtables vectors tuples sbufs inference.dataflow
@@ -59,6 +61,8 @@ nl
     hashcode* = get set
 } compile
 
+"." write flush
+
 {
     . lines
 } compile
@@ -69,7 +73,6 @@ nl
     malloc free memcpy
 } compile
 
-" done" print
+[ compiled-usages recompile ] recompile-hook set-global
-nl
 
-[ recompile ] recompile-hook set-global
+" done" print flush

core/compiler/compiler.factor

@@ -1,36 +1,63 @@
-! Copyright (C) 2004, 2007 Slava Pestov.
+! Copyright (C) 2004, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel namespaces arrays sequences io inference.backend
-generator debugger math.parser prettyprint words words.private
+inference.state generator debugger math.parser prettyprint words
-continuations vocabs assocs alien.compiler dlists optimizer
+words.private continuations vocabs assocs alien.compiler dlists
-definitions math compiler.errors threads ;
+optimizer definitions math compiler.errors threads graphs
+generic ;
 IN: compiler
 
-: compiled-usage ( word -- seq )
+SYMBOL: compiled-crossref
-    #! XXX
-    usage [ word? ] subset ;
 
-: ripple-up ( word effect -- )
+compiled-crossref global [ H{ } assoc-like ] change-at
-    over "compiled-effect" word-prop =
+
-    [ drop ] [
+: compiled-xref ( word dependencies -- )
-        compiled-usage
+    2dup "compiled-uses" set-word-prop
-        [ "was-compiled" word-prop ] subset
+    compiled-crossref get add-vertex ;
-        [ queue-compile ] each
+
-    ] if ;
+: compiled-unxref ( word -- )
+    dup "compiled-uses" word-prop
+    compiled-crossref get remove-vertex ;
+
+: compiled-usage ( word -- seq )
+    compiled-crossref get at keys ;
+
+: compiled-usages ( words -- seq )
+    compiled-crossref get [
+        [
+            over dup set
+            over "inline" word-prop pick generic? or
+            [ at namespace swap update ] [ 2drop ] if
+        ] curry each
+    ] H{ } make-assoc keys ;
+
+: ripple-up ( word -- )
+    compiled-usage [ queue-compile ] each ;
 
 : save-effect ( word effect -- )
-    over t "was-compiled" set-word-prop
+    over "compiled-uses" word-prop [
+        2dup swap "compiled-effect" word-prop =
+        [ over ripple-up ] unless
+    ] when
     "compiled-effect" set-word-prop ;
 
-: (compile) ( word -- )
+: finish-compile ( word effect dependencies -- )
+    >r dupd save-effect r> over compiled-unxref compiled-xref ;
+
+: compile-succeeded ( word -- effect dependencies )
     [
-        dup word-dataflow optimize >r over dup r> generate
+        dup word-dataflow >r swap dup r> optimize generate
-    ] [
+    ] computing-dependencies ;
+
+: compile-failed ( word error -- )
     dup inference-error? [ rethrow ] unless
-        over compiler-error f over compiled get set-at f
+    f pick compiled get set-at
-    ] recover
+    swap compiler-error ;
-    2drop ;
+
-!    2dup ripple-up save-effect ;
+: (compile) ( word -- )
+    [ dup compile-succeeded finish-compile ]
+    [ dupd compile-failed f save-effect ]
+    recover ;
 
 : delete-any ( assoc -- element )
     [ [ 2drop t ] assoc-find 2drop dup ] keep delete-at ;
@@ -55,7 +82,9 @@ IN: compiler
     [ compiled? not ] subset recompile ;
 
 : compile-call ( quot -- )
-    [ define-temp ] with-compilation-unit execute ;
+    H{ } clone changed-words
+    [ define-temp dup 1array compile ] with-variable
+    execute ;
 
 : recompile-all ( -- )
     [ all-words recompile ] with-compiler-errors ;

core/compiler/test/redefine.factor

@@ -1,8 +1,26 @@
 USING: compiler definitions generic assocs inference math
 namespaces parser tools.test words kernel sequences arrays io
-effects tools.test.inference ;
+effects tools.test.inference words.private ;
 IN: temporary
 
+DEFER: x-1
+DEFER: x-2
+
+[ [ f ] { } map>assoc modify-code-heap ] recompile-hook [
+    "IN: temporary USE: math GENERIC: x-1 ( x -- y ) M: integer x-1 ;" eval
+    "IN: temporary : x-2 3 x-1 ;" eval
+
+    [ t ] [
+        { x-2 } compile
+
+        \ x-2 word-xt
+
+        { x-1 } compile
+
+        \ x-2 word-xt eq?
+    ] unit-test
+] with-variable
+
 DEFER: b
 DEFER: c
 
@@ -49,3 +67,79 @@ DEFER: c
 [ ] [ "IN: temporary : d 4 ; inline" eval ] unit-test
 
 [ 4 4 ] [ "USE: temporary e" eval ] unit-test
+
+DEFER: x-3
+
+[ ] [ "IN: temporary : x-3 3 ;" eval ] unit-test
+
+DEFER: x-4
+
+[ ] [ "IN: temporary : x-4 x-3 ;" eval ] unit-test
+
+[ t ] [ \ x-4 compiled? ] unit-test
+
+[ ] [ "IN: temporary USE: sequences : x-3 { } [ ] each ;" eval ] unit-test
+
+[ f ] [ \ x-3 compiled? ] unit-test
+
+[ f ] [ \ x-4 compiled? ] unit-test
+
+[ ] [ "IN: temporary USING: kernel sequences ; : x-3 { } [ drop ] each ;" eval ] unit-test
+
+[ t ] [ \ x-3 compiled? ] unit-test
+
+[ t ] [ \ x-4 compiled? ] unit-test
+
+[ t ] [ \ x-3 "compiled-uses" word-prop >boolean ] unit-test
+
+[ t ] [ \ x-3 "compiled-uses" word-prop [ interned? ] all? ] unit-test
+
+DEFER: g-test-1
+
+DEFER: g-test-3
+
+[ ] [ "IN: temporary USE: math GENERIC: g-test-1 ( x -- y ) M: integer g-test-1 sq ;" eval ] unit-test
+
+[ ] [ "IN: temporary : g-test-2 ( -- y ) 3 g-test-1 ;" eval ] unit-test
+
+[ ] [ "IN: temporary : g-test-3 ( -- y ) g-test-2 ;" eval ] unit-test
+
+[ 25 ] [ 5 g-test-1 ] unit-test
+
+[ ] [ "IN: temporary USE: math GENERIC: g-test-1 ( x -- y ) M: integer g-test-1 ;" eval ] unit-test
+
+[ 5 ] [ 5 g-test-1 ] unit-test
+
+[ t ] [
+    \ g-test-3 word-xt
+
+    "IN: temporary USE: math GENERIC: g-test-1 ( x -- y ) M: integer g-test-1 3 + ;" eval
+
+    \ g-test-3 word-xt eq?
+] unit-test
+
+DEFER: g-test-5
+
+[ ] [ "IN: temporary : g-test-4 ( -- y ) 3 g-test-1 ; inline" eval ] unit-test
+
+[ ] [ "IN: temporary : g-test-5 ( -- y ) g-test-4 ;" eval ] unit-test
+
+[ 6 ] [ g-test-5 ] unit-test
+
+[ ] [ "IN: temporary USE: math GENERIC: g-test-1 ( x -- y ) M: integer g-test-1 10 + ;" eval ] unit-test
+
+[ 13 ] [ g-test-5 ] unit-test
+
+DEFER: g-test-6
+
+[ ] [ "IN: temporary USING: arrays kernel ; GENERIC: g-test-6 ( x -- y ) M: array g-test-6 drop 123 g-test-1 ;" eval ] unit-test
+
+DEFER: g-test-7
+
+[ ] [ "IN: temporary : g-test-7 { } g-test-6 ;" eval ] unit-test
+
+[ 133 ] [ g-test-7 ] unit-test
+
+[ ] [ "IN: temporary USE: math GENERIC: g-test-1 ( x -- y ) M: integer g-test-1 15 + ;" eval ] unit-test
+
+[ 138 ] [ g-test-7 ] unit-test

core/cpu/x86/assembler/assembler.factor

@@ -1,4 +1,4 @@
-! Copyright (C) 2005, 2007 Slava Pestov.
+! Copyright (C) 2005, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: arrays generator.fixup io.binary kernel
 combinators kernel.private math namespaces parser sequences

core/generator/generator-docs.factor

@@ -1,5 +1,6 @@
 USING: help.markup help.syntax words debugger generator.fixup
-generator.registers quotations kernel vectors arrays effects ;
+generator.registers quotations kernel vectors arrays effects
+sequences ;
 IN: generator
 
 ARTICLE: "generator" "Compiled code generator"
@@ -54,7 +55,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 } { "effect" effect } { "dataflow" "a dataflow graph" } }
+{ $values { "word" word } { "effect" effect } { "dependencies" sequence } { "dataflow" "a dataflow graph" } }
 { $description "Outputs the dataflow graph of a word, taking specializers into account (see " { $link "specializers" } ")." } ;
 
 HELP: define-intrinsics

core/inference/backend/backend-docs.factor

@@ -1,17 +1,11 @@
 USING: help.syntax help.markup words effects inference.dataflow
-inference.backend kernel sequences kernel.private
+inference.state inference.backend kernel sequences
-combinators combinators.private ;
+kernel.private combinators combinators.private ;
-
-HELP: recursive-state
-{ $var-description "During inference, holds an association list mapping words to labels." } ;
 
 HELP: literal-expected
 { $error-description "Thrown when inference encounters a " { $link call } " or " { $link if } " being applied to a value which is not known to be a literal. Such a form can have an arbitrary stack effect, and does not compile." }
 { $notes "This error will be thrown when compiling any combinator, such as " { $link each } ". However, words calling combinators can compile of the combinator is declared " { $link POSTPONE: inline } " and the quotation being passed in is a literal." } ;
 
-HELP: terminated?
-{ $var-description "During inference, a flag set to " { $link t } " if the current control flow path unconditionally throws an error." } ;
-
 HELP: too-many->r
 { $error-description "Thrown if inference notices a quotation pushing elements on the retain stack without popping them at the end." }
 { $notes "See " { $link "shuffle-words" } " for retain stack usage conventions." } ;
@@ -57,7 +51,7 @@ HELP: collect-recursion
 { $values { "#label" "a " { $link #label } " node" } { "seq" "a new sequence" } }
 { $description "Collect the input stacks of all child " { $link #call-label } " nodes that call the given label." } ;
 
-HELP: inline-closure
+HELP: inline-word
 { $values { "word" word } }
 { $description "Called during inference to infer stack effects of inline words."
 $nl

core/inference/backend/backend.factor

@@ -1,10 +1,10 @@
-! Copyright (C) 2004, 2007 Slava Pestov.
+! Copyright (C) 2004, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
+USING: inference.dataflow inference.state arrays generic io
+io.streams.string kernel math namespaces parser prettyprint
+sequences strings vectors words quotations effects classes
+continuations debugger assocs combinators compiler.errors ;
 IN: inference.backend
-USING: inference.dataflow arrays generic io io.streams.string
-kernel math namespaces parser prettyprint sequences
-strings vectors words quotations effects classes continuations
-debugger assocs combinators compiler.errors ;
 
 : recursive-label ( word -- label/f )
     recursive-state get at ;
@@ -57,14 +57,10 @@ M: object value-literal \ literal-expected inference-warning ;
 : ensure-values ( seq -- )
     meta-d [ add-inputs ] change d-in [ + ] change ;
 
-SYMBOL: terminated?
-
 : current-effect ( -- effect )
     d-in get meta-d get length <effect>
     terminated? get over set-effect-terminated? ;
 
-SYMBOL: recorded
-
 : init-inference ( -- )
     terminated? off
     V{ } clone meta-d set
@@ -340,6 +336,7 @@ TUPLE: unbalanced-branches-error quots in out ;
         recursive-label #call-label [ consume/produce ] keep
         set-node-in-d
     ] [
+        dup depends-on
         over effect-in length reify-curries
         #call consume/produce
     ] if ;
@@ -370,6 +367,7 @@ TUPLE: effect-error word effect ;
 : infer-compound ( word -- effect )
     [
         init-inference
+        dependencies off
         dup word-def over dup infer-quot-recursive
         finish-word
         current-effect
@@ -446,7 +444,8 @@ M: #call-label collect-recursion*
     [ swap [ at ] curry map ] keep
     [ set ] 2each ;
 
-: inline-closure ( word -- )
+: inline-word ( word -- )
+    dup depends-on
     dup inline-block over recursive-label? [
         flatten-meta-d >r
         drop join-values inline-block apply-infer
@@ -462,7 +461,7 @@ M: #call-label collect-recursion*
 M: compound apply-object
     [
         dup inline-recursive-label
-        [ declared-infer ] [ inline-closure ] if
+        [ declared-infer ] [ inline-word ] if
     ] [
         dup recursive-label
         [ declared-infer ] [ apply-word ] if

core/inference/dataflow/dataflow-docs.factor

@@ -3,6 +3,3 @@ USING: inference.dataflow help.syntax help.markup ;
 HELP: #return
 { $values { "label" "a word or " { $link f } } { "node" "a new " { $link node } } }
 { $description "Creates a node which returns from a nested label, or if " { $snippet "label" } " is " { $link f } ", the top-level word being compiled." } ;
-
-HELP: d-in
-{ $var-description "During inference, holds the number of inputs which the quotation has been inferred to require so far." } ;

core/inference/dataflow/dataflow.factor

@@ -1,11 +1,9 @@
-! Copyright (C) 2004, 2007 Slava Pestov.
+! Copyright (C) 2004, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
+USING: arrays generic assocs kernel math namespaces parser
+sequences words vectors math.intervals effects classes
+inference.state ;
 IN: inference.dataflow
-USING: arrays generic assocs kernel math
-namespaces parser sequences words vectors math.intervals
-effects classes ;
-
-SYMBOL: recursive-state
 
 ! Computed value
 : <computed> \ <computed> counter ;
@@ -30,20 +28,8 @@ TUPLE: composed quot1 quot2 ;
 
 C: <composed> composed
 
-SYMBOL: d-in
-SYMBOL: meta-d
-SYMBOL: meta-r
-
 UNION: special curried composed ;
 
-: push-d meta-d get push ;
-: pop-d meta-d get pop ;
-: peek-d meta-d get peek ;
-
-: push-r meta-r get push ;
-: pop-r meta-r get pop ;
-: peek-r meta-r get peek ;
-
 TUPLE: node param
 in-d out-d in-r out-r
 classes literals intervals
@@ -185,9 +171,6 @@ UNION: #branch #if #dispatch ;
     >r r-tail flatten-curries r> set-node-out-r
     >r d-tail flatten-curries r> set-node-out-d ;
 
-SYMBOL: dataflow-graph
-SYMBOL: current-node
-
 : node, ( node -- )
     dataflow-graph get [
         dup current-node [ set-node-successor ] change

core/inference/inference-docs.factor

@@ -1,6 +1,6 @@
 USING: help.syntax help.markup kernel sequences words io
 effects inference.dataflow inference.backend
-math combinators inference.transforms ;
+math combinators inference.transforms inference.state ;
 IN: inference
 
 ARTICLE: "inference-simple" "Straight-line stack effects"

core/inference/inference.factor

@@ -1,10 +1,10 @@
 ! Copyright (C) 2004, 2007 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-IN: inference
+USING: inference.backend inference.state inference.dataflow
-USING: inference.backend inference.dataflow
 inference.known-words inference.transforms inference.errors
 sequences prettyprint io effects kernel namespaces quotations
 words vocabs ;
+IN: inference
 
 GENERIC: infer ( quot -- effect )
 

core/inference/known-words/known-words.factor

@@ -1,16 +1,16 @@
 ! Copyright (C) 2004, 2007 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-IN: inference.known-words
 USING: alien arrays bit-arrays byte-arrays classes
 combinators.private continuations.private effects float-arrays
-generic hashtables hashtables.private inference.backend
+generic hashtables hashtables.private inference.state
-inference.dataflow io io.backend io.files io.files.private
+inference.backend inference.dataflow io io.backend io.files
-io.streams.c kernel kernel.private math math.private memory
+io.files.private io.streams.c kernel kernel.private math
-namespaces namespaces.private parser prettyprint quotations
+math.private memory namespaces namespaces.private parser
-quotations.private sbufs sbufs.private sequences
+prettyprint quotations quotations.private sbufs sbufs.private
-sequences.private slots.private strings strings.private system
+sequences sequences.private slots.private strings
-threads.private tuples tuples.private vectors vectors.private
+strings.private system threads.private tuples tuples.private
-words words.private assocs ;
+vectors vectors.private words words.private assocs ;
+IN: inference.known-words
 
 ! Shuffle words
 : infer-shuffle-inputs ( shuffle node -- )

core/inference/state/state-docs.factor

@@ -0,0 +1,11 @@
+USING: help.markup help.syntax inference.state ;
+
+HELP: d-in
+{ $var-description "During inference, holds the number of inputs which the quotation has been inferred to require so far." } ;
+
+HELP: recursive-state
+{ $var-description "During inference, holds an association list mapping words to labels." } ;
+
+HELP: terminated?
+{ $var-description "During inference, a flag set to " { $link t } " if the current control flow path unconditionally throws an error." } ;
+

core/inference/state/state.factor

@@ -0,0 +1,45 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: assocs namespaces sequences kernel ;
+IN: inference.state
+
+! Nesting state to solve recursion
+SYMBOL: recursive-state
+
+! Number of inputs current word expects from the stack
+SYMBOL: d-in
+
+! Compile-time data stack
+SYMBOL: meta-d
+
+: push-d meta-d get push ;
+: pop-d meta-d get pop ;
+: peek-d meta-d get peek ;
+
+! Compile-time retain stack
+SYMBOL: meta-r
+
+: push-r meta-r get push ;
+: pop-r meta-r get pop ;
+: peek-r meta-r get peek ;
+
+! Head of dataflow IR
+SYMBOL: dataflow-graph
+
+SYMBOL: current-node
+
+! Words that the current dataflow IR depends on
+SYMBOL: dependencies
+
+: depends-on ( word -- )
+    dup dependencies get dup [ set-at ] [ 3drop ] if ;
+
+: computing-dependencies ( quot -- dependencies )
+    H{ } clone [ dependencies rot with-variable ] keep keys ;
+    inline
+
+! Did the current control-flow path throw an error?
+SYMBOL: terminated?
+
+! Words we've inferred the stack effect of, for rollback
+SYMBOL: recorded

core/inference/transforms/transforms.factor

@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: arrays kernel words sequences generic math namespaces
 quotations assocs combinators math.bitfields inference.backend
-inference.dataflow tuples.private ;
+inference.dataflow inference.state tuples.private ;
 IN: inference.transforms
 
 : pop-literals ( n -- rstate seq )