From 85cdb1b76727a05238e4bacbb0e224486fcb2753 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sat, 30 Aug 2008 00:05:27 -0500
Subject: [PATCH 01/21] Working on new compiled usage strategy; old one was
wrong
---
basis/compiler/tests/redefine10.factor | 29 +++++++++++++++
basis/compiler/tests/redefine6.factor | 33 +++++++++++++++++
basis/compiler/tests/redefine7.factor | 29 +++++++++++++++
basis/compiler/tests/redefine8.factor | 32 +++++++++++++++++
basis/compiler/tests/redefine9.factor | 35 +++++++++++++++++++
.../tree/dead-code/simple/simple.factor | 2 +-
basis/stack-checker/state/state.factor | 5 ++-
core/assocs/assocs.factor | 2 +-
core/classes/tuple/tuple.factor | 3 --
core/compiler/units/units.factor | 1 +
core/definitions/definitions-tests.factor | 7 ++++
core/definitions/definitions.factor | 16 ++++++++-
core/generic/generic.factor | 4 +--
core/words/words.factor | 19 ++++++----
14 files changed, 199 insertions(+), 18 deletions(-)
create mode 100644 basis/compiler/tests/redefine10.factor
create mode 100644 basis/compiler/tests/redefine6.factor
create mode 100644 basis/compiler/tests/redefine7.factor
create mode 100644 basis/compiler/tests/redefine8.factor
create mode 100644 basis/compiler/tests/redefine9.factor
diff --git a/basis/compiler/tests/redefine10.factor b/basis/compiler/tests/redefine10.factor
new file mode 100644
index 0000000000..8a6fb8a313
--- /dev/null
+++ b/basis/compiler/tests/redefine10.factor
@@ -0,0 +1,29 @@
+USING: eval tools.test compiler.units vocabs multiline words
+kernel ;
+IN: compiler.tests
+
+! Mixin redefinition did not recompile all necessary words.
+
+[ ] [ [ "compiler.tests.redefine10" forget-vocab ] with-compilation-unit ] unit-test
+
+[ ] [
+ <"
+ USING: kernel math classes ;
+ IN: compiler.tests.redefine10
+ MIXIN: my-mixin
+ INSTANCE: fixnum my-mixin
+ : my-inline ( a -- b ) dup my-mixin instance? [ 1 + ] when ;
+ "> eval
+] unit-test
+
+[ ] [
+ <"
+ USE: math
+ IN: compiler.tests.redefine10
+ INSTANCE: float my-mixin
+ "> eval
+] unit-test
+
+[ 2.0 ] [
+ 1.0 "my-inline" "compiler.tests.redefine10" lookup execute
+] unit-test
diff --git a/basis/compiler/tests/redefine6.factor b/basis/compiler/tests/redefine6.factor
new file mode 100644
index 0000000000..73225c55b8
--- /dev/null
+++ b/basis/compiler/tests/redefine6.factor
@@ -0,0 +1,33 @@
+USING: eval tools.test compiler.units vocabs multiline words
+kernel ;
+IN: compiler.tests
+
+! Mixin redefinition did not recompile all necessary words.
+
+[ ] [ [ "compiler.tests.redefine6" forget-vocab ] with-compilation-unit ] unit-test
+
+[ ] [
+ <"
+ USING: kernel kernel.private ;
+ IN: compiler.tests.redefine6
+ GENERIC: my-generic ( a -- b )
+ MIXIN: my-mixin
+ M: my-mixin my-generic drop 0 ;
+ : my-inline ( a -- b ) { my-mixin } declare my-generic ;
+ "> eval
+] unit-test
+
+[ ] [
+ <"
+ USING: kernel ;
+ IN: compiler.tests.redefine6
+ TUPLE: my-tuple ;
+ M: my-tuple my-generic drop 1 ;
+ INSTANCE: my-tuple my-mixin
+ "> eval
+] unit-test
+
+[ 1 ] [
+ "my-tuple" "compiler.tests.redefine6" lookup boa
+ "my-inline" "compiler.tests.redefine6" lookup execute
+] unit-test
diff --git a/basis/compiler/tests/redefine7.factor b/basis/compiler/tests/redefine7.factor
new file mode 100644
index 0000000000..164a2e3831
--- /dev/null
+++ b/basis/compiler/tests/redefine7.factor
@@ -0,0 +1,29 @@
+USING: eval tools.test compiler.units vocabs multiline words
+kernel ;
+IN: compiler.tests
+
+! Mixin redefinition did not recompile all necessary words.
+
+[ ] [ [ "compiler.tests.redefine7" forget-vocab ] with-compilation-unit ] unit-test
+
+[ ] [
+ <"
+ USING: kernel math ;
+ IN: compiler.tests.redefine7
+ MIXIN: my-mixin
+ INSTANCE: fixnum my-mixin
+ : my-inline ( a -- b ) dup my-mixin? [ 1 + ] when ;
+ "> eval
+] unit-test
+
+[ ] [
+ <"
+ USE: math
+ IN: compiler.tests.redefine7
+ INSTANCE: float my-mixin
+ "> eval
+] unit-test
+
+[ 2.0 ] [
+ 1.0 "my-inline" "compiler.tests.redefine7" lookup execute
+] unit-test
diff --git a/basis/compiler/tests/redefine8.factor b/basis/compiler/tests/redefine8.factor
new file mode 100644
index 0000000000..c8b3377632
--- /dev/null
+++ b/basis/compiler/tests/redefine8.factor
@@ -0,0 +1,32 @@
+USING: eval tools.test compiler.units vocabs multiline words
+kernel ;
+IN: compiler.tests
+
+! Mixin redefinition did not recompile all necessary words.
+
+[ ] [ [ "compiler.tests.redefine8" forget-vocab ] with-compilation-unit ] unit-test
+
+[ ] [
+ <"
+ USING: kernel math math.order sorting ;
+ IN: compiler.tests.redefine8
+ MIXIN: my-mixin
+ INSTANCE: fixnum my-mixin
+ GENERIC: my-generic ( a -- b )
+ ! We add the bogus quotation here to hinder inlining
+ ! since otherwise we cannot trigger this bug.
+ M: my-mixin my-generic 1 + [ [ <=> ] sort ] drop ;
+ "> eval
+] unit-test
+
+[ ] [
+ <"
+ USE: math
+ IN: compiler.tests.redefine8
+ INSTANCE: float my-mixin
+ "> eval
+] unit-test
+
+[ 2.0 ] [
+ 1.0 "my-generic" "compiler.tests.redefine8" lookup execute
+] unit-test
diff --git a/basis/compiler/tests/redefine9.factor b/basis/compiler/tests/redefine9.factor
new file mode 100644
index 0000000000..8b8a170ed4
--- /dev/null
+++ b/basis/compiler/tests/redefine9.factor
@@ -0,0 +1,35 @@
+USING: eval tools.test compiler.units vocabs multiline words
+kernel generic.math ;
+IN: compiler.tests
+
+! Mixin redefinition did not recompile all necessary words.
+
+[ ] [ [ "compiler.tests.redefine9" forget-vocab ] with-compilation-unit ] unit-test
+
+[ ] [
+ <"
+ USING: kernel math math.order sorting ;
+ IN: compiler.tests.redefine9
+ MIXIN: my-mixin
+ INSTANCE: fixnum my-mixin
+ GENERIC: my-generic ( a -- b )
+ ! We add the bogus quotation here to hinder inlining
+ ! since otherwise we cannot trigger this bug.
+ M: my-mixin my-generic 1 + [ [ <=> ] sort ] drop ;
+ "> eval
+] unit-test
+
+[ ] [
+ <"
+ USE: math
+ IN: compiler.tests.redefine9
+ TUPLE: my-tuple ;
+ INSTANCE: my-tuple my-mixin
+ "> eval
+] unit-test
+
+[
+ "my-tuple" "compiler.tests.redefine9" lookup
+ "my-generic" "compiler.tests.redefine9" lookup
+ execute
+] [ no-math-method? ] must-fail-with
diff --git a/basis/compiler/tree/dead-code/simple/simple.factor b/basis/compiler/tree/dead-code/simple/simple.factor
index 2bcf91e6ab..5edc3b13ec 100644
--- a/basis/compiler/tree/dead-code/simple/simple.factor
+++ b/basis/compiler/tree/dead-code/simple/simple.factor
@@ -106,7 +106,7 @@ M: #push remove-dead-code*
] [ drop f ] if ;
: remove-flushable-call ( #call -- node )
- [ word>> +inlined+ depends-on ]
+ [ word>> +flushed+ depends-on ]
[ in-d>> #drop remove-dead-code* ]
bi ;
diff --git a/basis/stack-checker/state/state.factor b/basis/stack-checker/state/state.factor
index 1f85dc39fc..394d065a13 100755
--- a/basis/stack-checker/state/state.factor
+++ b/basis/stack-checker/state/state.factor
@@ -88,9 +88,8 @@ SYMBOL: meta-r
SYMBOL: dependencies
: depends-on ( word how -- )
- swap dependencies get dup [
- 2dup at +inlined+ eq? [ 3drop ] [ set-at ] if
- ] [ 3drop ] if ;
+ [ strongest-dependency ] curry
+ dependencies get dup [ swap change-at ] [ 3drop ] if ;
! Words we've inferred the stack effect of, for rollback
SYMBOL: recorded
diff --git a/core/assocs/assocs.factor b/core/assocs/assocs.factor
index b613147f29..3ebedfc6d7 100755
--- a/core/assocs/assocs.factor
+++ b/core/assocs/assocs.factor
@@ -186,7 +186,7 @@ M: sequence assoc-clone-like
>r >alist r> clone-like ;
M: sequence assoc-like
- over sequence? [ like ] [ assoc-clone-like ] if ;
+ >r >alist r> like ;
M: sequence >alist ;
diff --git a/core/classes/tuple/tuple.factor b/core/classes/tuple/tuple.factor
index 4482eb8131..4ff9d4c674 100755
--- a/core/classes/tuple/tuple.factor
+++ b/core/classes/tuple/tuple.factor
@@ -270,9 +270,6 @@ M: tuple-class define-tuple-class
tri* define-declared
] 3tri ;
-M: tuple-class update-generic
- over new-class? [ 2drop ] [ call-next-method ] if ;
-
M: tuple-class reset-class
[
dup "slots" word-prop [
diff --git a/core/compiler/units/units.factor b/core/compiler/units/units.factor
index d141bf68e3..1c1eaebc03 100755
--- a/core/compiler/units/units.factor
+++ b/core/compiler/units/units.factor
@@ -94,6 +94,7 @@ SYMBOL: update-tuples-hook
[
H{ } clone changed-definitions set
H{ } clone outdated-tuples set
+ H{ } clone new-classes set
[ finish-compilation-unit ] [ ] cleanup
] with-scope ; inline
diff --git a/core/definitions/definitions-tests.factor b/core/definitions/definitions-tests.factor
index b2d265a2e3..ec889458a3 100755
--- a/core/definitions/definitions-tests.factor
+++ b/core/definitions/definitions-tests.factor
@@ -31,3 +31,10 @@ TUPLE: another-class some-generic ;
} forget-all
] with-compilation-unit
] unit-test
+
+[ +flushed+ ] [ f +flushed+ strongest-dependency ] unit-test
+[ +flushed+ ] [ +flushed+ f strongest-dependency ] unit-test
+[ +inlined+ ] [ +flushed+ +inlined+ strongest-dependency ] unit-test
+[ +inlined+ ] [ +called+ +inlined+ strongest-dependency ] unit-test
+[ +flushed+ ] [ +called+ +flushed+ strongest-dependency ] unit-test
+[ +called+ ] [ +called+ f strongest-dependency ] unit-test
diff --git a/core/definitions/definitions.factor b/core/definitions/definitions.factor
index 0a83e43097..8b1cb6322d 100755
--- a/core/definitions/definitions.factor
+++ b/core/definitions/definitions.factor
@@ -1,15 +1,29 @@
! Copyright (C) 2006, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
IN: definitions
-USING: kernel sequences namespaces assocs graphs ;
+USING: kernel sequences namespaces assocs graphs math math.order ;
ERROR: no-compilation-unit definition ;
SYMBOL: changed-definitions
SYMBOL: +inlined+
+SYMBOL: +flushed+
SYMBOL: +called+
+: dependency<=> ( how1 how2 -- <=> )
+ [ { f +called+ +flushed+ +inlined+ } index ] bi@ <=> ;
+
+: dependency>= ( how1 how2 -- ? ) dependency<=> +lt+ eq? not ;
+
+: strongest-dependency ( how1 how2 -- how )
+ [ dependency>= ] most ;
+
+: dependency<= ( how1 how2 -- ? ) dependency<=> +gt+ eq? not ;
+
+: weakest-dependency ( how1 how2 -- how )
+ [ dependency<= ] most ;
+
: changed-definition ( defspec how -- )
swap changed-definitions get
[ set-at ] [ no-compilation-unit ] if* ;
diff --git a/core/generic/generic.factor b/core/generic/generic.factor
index ff81b5ded3..70d406a39b 100755
--- a/core/generic/generic.factor
+++ b/core/generic/generic.factor
@@ -62,9 +62,7 @@ TUPLE: check-method class generic ;
[ nip [ classes-intersect? ] [ class<= ] 2bi or ] curry assoc-filter
values ;
-GENERIC# update-generic 1 ( class generic -- )
-
-M: class update-generic
+: update-generic ( class generic -- )
affected-methods [ +called+ changed-definition ] each ;
: with-methods ( class generic quot -- )
diff --git a/core/words/words.factor b/core/words/words.factor
index 535295007e..8331c7a15c 100755
--- a/core/words/words.factor
+++ b/core/words/words.factor
@@ -121,15 +121,22 @@ compiled-crossref global [ H{ } assoc-like ] change-at
: compiled-usage ( word -- assoc )
compiled-crossref get at ;
+: (compiled-usages) ( word dependency -- assoc )
+ #! If the word is not flushable anymore, we have to recompile
+ #! all words which flushable away a call (presumably when the
+ #! word was still flushable). If the word is flushable, we
+ #! don't have to recompile words that folded this away.
+ [ drop compiled-usage ]
+ [
+ swap "flushable" word-prop +inlined+ +flushed+ ?
+ weakest-dependency
+ ] 2bi
+ [ dependency>= nip ] curry assoc-filter ;
+
: compiled-usages ( assoc -- seq )
clone [
dup [
- [
- [ compiled-usage ] dip
- +inlined+ eq? [
- [ nip +inlined+ eq? ] assoc-filter
- ] when
- ] dip swap update
+ [ (compiled-usages) ] dip swap update
] curry assoc-each
] keep keys ;
From b3f3068bdc5b488b122bf84a636ba61aa96d8f56 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sat, 30 Aug 2008 00:09:45 -0500
Subject: [PATCH 02/21] Massive focused action #1
---
core/bootstrap/primitives.factor | 1 -
core/classes/classes.factor | 2 +-
core/classes/mixin/mixin.factor | 14 +++-----------
core/compiler/units/units.factor | 2 --
core/definitions/definitions.factor | 9 ---------
5 files changed, 4 insertions(+), 24 deletions(-)
diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor
index b9191ac612..87ed5ea529 100755
--- a/core/bootstrap/primitives.factor
+++ b/core/bootstrap/primitives.factor
@@ -33,7 +33,6 @@ H{ } clone sub-primitives set
! Bring up a bare cross-compiling vocabulary.
"syntax" vocab vocab-words bootstrap-syntax set
H{ } clone dictionary set
-H{ } clone new-classes set
H{ } clone changed-definitions set
H{ } clone forgotten-definitions set
H{ } clone root-cache set
diff --git a/core/classes/classes.factor b/core/classes/classes.factor
index 64a8630f36..27205b487d 100755
--- a/core/classes/classes.factor
+++ b/core/classes/classes.factor
@@ -119,7 +119,7 @@ M: sequence implementors [ implementors ] gather ;
: (define-class) ( word props -- )
>r
- dup class? [ dup [ implementors-map+ ] [ new-class ] bi ] unless
+ dup class? [ implementors-map+ ] unless
dup reset-class
dup deferred? [ dup define-symbol ] when
dup props>>
diff --git a/core/classes/mixin/mixin.factor b/core/classes/mixin/mixin.factor
index 56ab6d37f1..3b12a277d7 100755
--- a/core/classes/mixin/mixin.factor
+++ b/core/classes/mixin/mixin.factor
@@ -39,11 +39,6 @@ TUPLE: check-mixin-class mixin ;
[ [ members swap bootstrap-word ] dip call ] [ drop ] 2bi
swap redefine-mixin-class ; inline
-: update-classes/new ( mixin -- )
- class-usages
- [ [ update-class ] each ]
- [ implementors [ make-generic ] each ] bi ;
-
: add-mixin-instance ( class mixin -- )
#! Note: we call update-classes on the new member, not the
#! mixin. This ensures that we only have to update the
@@ -53,12 +48,9 @@ TUPLE: check-mixin-class mixin ;
#! updated by transitivity; the mixins usages appear in
#! class-usages of the member, now that it's been added.
[ 2drop ] [
- [ [ suffix ] change-mixin-class ] 2keep
- tuck [ new-class? ] either? [
- update-classes/new
- ] [
- update-classes
- ] if
+ [ [ suffix ] change-mixin-class ]
+ [ drop update-classes ]
+ 2bi
] if-mixin-member? ;
: remove-mixin-instance ( class mixin -- )
diff --git a/core/compiler/units/units.factor b/core/compiler/units/units.factor
index 1c1eaebc03..616d8c957a 100755
--- a/core/compiler/units/units.factor
+++ b/core/compiler/units/units.factor
@@ -94,7 +94,6 @@ SYMBOL: update-tuples-hook
[
H{ } clone changed-definitions set
H{ } clone outdated-tuples set
- H{ } clone new-classes set
[ finish-compilation-unit ] [ ] cleanup
] with-scope ; inline
@@ -103,7 +102,6 @@ SYMBOL: update-tuples-hook
H{ } clone changed-definitions set
H{ } clone forgotten-definitions set
H{ } clone outdated-tuples set
- H{ } clone new-classes set
<definitions> new-definitions set
<definitions> old-definitions set
[
diff --git a/core/definitions/definitions.factor b/core/definitions/definitions.factor
index 8b1cb6322d..affccd95fb 100755
--- a/core/definitions/definitions.factor
+++ b/core/definitions/definitions.factor
@@ -28,15 +28,6 @@ SYMBOL: +called+
swap changed-definitions get
[ set-at ] [ no-compilation-unit ] if* ;
-SYMBOL: new-classes
-
-: new-class ( word -- )
- dup new-classes get
- [ set-at ] [ no-compilation-unit ] if* ;
-
-: new-class? ( word -- ? )
- new-classes get key? ;
-
GENERIC: where ( defspec -- loc )
M: object where drop f ;
From 3cef7c9992616238c672e6a0e2d572f8ca909db9 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sat, 30 Aug 2008 02:31:27 -0500
Subject: [PATCH 03/21] Smarter usage tracking system
---
basis/compiler/tree/cleanup/cleanup.factor | 11 +++--
.../tree/dead-code/simple/simple.factor | 2 +-
.../tree/propagation/inlining/inlining.factor | 19 ++++----
basis/compiler/tree/tree.factor | 2 +-
basis/hints/hints.factor | 2 +-
basis/stack-checker/backend/backend.factor | 2 +-
basis/stack-checker/inlining/inlining.factor | 2 +-
.../known-words/known-words.factor | 2 +-
basis/stack-checker/state/state-tests.factor | 18 ++++----
basis/stack-checker/state/state.factor | 3 +-
.../transforms/transforms.factor | 10 ++---
core/classes/algebra/algebra-tests.factor | 5 +++
core/classes/algebra/algebra.factor | 7 +++
core/classes/classes.factor | 2 +-
core/classes/mixin/mixin.factor | 14 ++++--
core/classes/tuple/tuple.factor | 2 +-
core/compiler/units/units-tests.factor | 11 +++++
core/compiler/units/units.factor | 43 ++++++++++++++++++-
core/definitions/definitions-tests.factor | 7 ---
core/definitions/definitions.factor | 41 ++++++++++--------
core/generic/generic.factor | 3 +-
core/words/words.factor | 26 +----------
22 files changed, 147 insertions(+), 87 deletions(-)
create mode 100644 core/compiler/units/units-tests.factor
diff --git a/basis/compiler/tree/cleanup/cleanup.factor b/basis/compiler/tree/cleanup/cleanup.factor
index 003bd1cc69..f0b664666b 100644
--- a/basis/compiler/tree/cleanup/cleanup.factor
+++ b/basis/compiler/tree/cleanup/cleanup.factor
@@ -42,7 +42,7 @@ GENERIC: cleanup* ( node -- node/nodes )
: cleanup-folding ( #call -- nodes )
#! Replace a #call having a known result with a #drop of its
#! inputs followed by #push nodes for the outputs.
- [ word>> +inlined+ depends-on ]
+ [ word>> inlined-dependency depends-on ]
[
[ node-output-infos ] [ out-d>> ] bi
[ [ literal>> ] dip #push ] 2map
@@ -50,11 +50,16 @@ GENERIC: cleanup* ( node -- node/nodes )
[ in-d>> #drop ]
tri prefix ;
+: add-method-dependency ( #call -- )
+ dup method>> word? [
+ [ method>> ] [ class>> <method-dependency> ] bi depends-on
+ ] [ drop ] if ;
+
: cleanup-inlining ( #call -- nodes )
[
dup method>>
- [ method>> dup word? [ +called+ depends-on ] [ drop ] if ]
- [ word>> +inlined+ depends-on ] if
+ [ add-method-dependency ]
+ [ word>> inlined-dependency depends-on ] if
] [ body>> cleanup ] bi ;
! Removing overflow checks
diff --git a/basis/compiler/tree/dead-code/simple/simple.factor b/basis/compiler/tree/dead-code/simple/simple.factor
index 5edc3b13ec..3ea9139e5f 100644
--- a/basis/compiler/tree/dead-code/simple/simple.factor
+++ b/basis/compiler/tree/dead-code/simple/simple.factor
@@ -106,7 +106,7 @@ M: #push remove-dead-code*
] [ drop f ] if ;
: remove-flushable-call ( #call -- node )
- [ word>> +flushed+ depends-on ]
+ [ word>> flushed-dependency depends-on ]
[ in-d>> #drop remove-dead-code* ]
bi ;
diff --git a/basis/compiler/tree/propagation/inlining/inlining.factor b/basis/compiler/tree/propagation/inlining/inlining.factor
index e01d12ac23..09f50b21ea 100644
--- a/basis/compiler/tree/propagation/inlining/inlining.factor
+++ b/basis/compiler/tree/propagation/inlining/inlining.factor
@@ -24,18 +24,19 @@ M: quotation splicing-nodes
body>> (propagate) ;
! Dispatch elimination
-: eliminate-dispatch ( #call word/quot/f -- ? )
- [
+: eliminate-dispatch ( #call class/f word/f -- ? )
+ dup [
+ [ >>class ] dip
over method>> over = [ drop ] [
2dup splicing-nodes
[ >>method ] [ >>body ] bi*
] if
propagate-body t
- ] [ f >>method f >>body drop f ] if* ;
+ ] [ 2drop f >>method f >>body f >>class drop f ] if ;
-: inlining-standard-method ( #call word -- method/f )
+: inlining-standard-method ( #call word -- class/f method/f )
[ in-d>> <reversed> ] [ [ dispatch# ] keep ] bi*
- [ swap nth value-info class>> ] dip
+ [ swap nth value-info class>> dup ] dip
specific-method ;
: inline-standard-method ( #call word -- ? )
@@ -51,15 +52,17 @@ M: quotation splicing-nodes
object
} [ class<= ] with find nip ;
-: inlining-math-method ( #call word -- quot/f )
+: inlining-math-method ( #call word -- class/f quot/f )
swap in-d>>
first2 [ value-info class>> normalize-math-class ] bi@
- 3dup math-both-known? [ math-method* ] [ 3drop f ] if ;
+ 3dup math-both-known?
+ [ math-method* ] [ 3drop f ] if
+ number swap ;
: inline-math-method ( #call word -- ? )
dupd inlining-math-method eliminate-dispatch ;
-: inlining-math-partial ( #call word -- quot/f )
+: inlining-math-partial ( #call word -- class/f quot/f )
[ "derived-from" word-prop first inlining-math-method ]
[ nip 1quotation ] 2bi
[ = not ] [ drop ] 2bi and ;
diff --git a/basis/compiler/tree/tree.factor b/basis/compiler/tree/tree.factor
index 9234aa5d86..2bb3fa0cfc 100755
--- a/basis/compiler/tree/tree.factor
+++ b/basis/compiler/tree/tree.factor
@@ -17,7 +17,7 @@ TUPLE: #introduce < node out-d ;
: #introduce ( out-d -- node )
\ #introduce new swap >>out-d ;
-TUPLE: #call < node word in-d out-d body method info ;
+TUPLE: #call < node word in-d out-d body method class info ;
: #call ( inputs outputs word -- node )
\ #call new
diff --git a/basis/hints/hints.factor b/basis/hints/hints.factor
index 59626a4f8a..fe4255d977 100644
--- a/basis/hints/hints.factor
+++ b/basis/hints/hints.factor
@@ -55,7 +55,7 @@ IN: hints
: HINTS:
scan-word
- [ +inlined+ changed-definition ]
+ [ inlined-dependency changed-definition ]
[ parse-definition "specializer" set-word-prop ] bi ;
parsing
diff --git a/basis/stack-checker/backend/backend.factor b/basis/stack-checker/backend/backend.factor
index 6a67b132c0..ff41ff3feb 100755
--- a/basis/stack-checker/backend/backend.factor
+++ b/basis/stack-checker/backend/backend.factor
@@ -72,7 +72,7 @@ GENERIC: apply-object ( obj -- )
M: wrapper apply-object
wrapped>>
- [ dup word? [ +called+ depends-on ] [ drop ] if ]
+ [ dup word? [ called-dependency depends-on ] [ drop ] if ]
[ push-literal ]
bi ;
diff --git a/basis/stack-checker/inlining/inlining.factor b/basis/stack-checker/inlining/inlining.factor
index 6523598cff..07ff016b2d 100644
--- a/basis/stack-checker/inlining/inlining.factor
+++ b/basis/stack-checker/inlining/inlining.factor
@@ -140,7 +140,7 @@ SYMBOL: enter-out
] [ undeclared-recursion-error inference-error ] if ;
: inline-word ( word -- )
- [ +inlined+ depends-on ]
+ [ inlined-dependency depends-on ]
[
{
{ [ dup inline-recursive-label ] [ call-recursive-inline-word ] }
diff --git a/basis/stack-checker/known-words/known-words.factor b/basis/stack-checker/known-words/known-words.factor
index 11e7a0d7fd..c01236fba9 100755
--- a/basis/stack-checker/known-words/known-words.factor
+++ b/basis/stack-checker/known-words/known-words.factor
@@ -176,7 +176,7 @@ do-primitive alien-invoke alien-indirect alien-callback
SYMBOL: +primitive+
: non-inline-word ( word -- )
- dup +called+ depends-on
+ dup called-dependency depends-on
{
{ [ dup "shuffle" word-prop ] [ infer-shuffle-word ] }
{ [ dup "special" word-prop ] [ infer-special ] }
diff --git a/basis/stack-checker/state/state-tests.factor b/basis/stack-checker/state/state-tests.factor
index 91382dfb99..a4dea993c0 100644
--- a/basis/stack-checker/state/state-tests.factor
+++ b/basis/stack-checker/state/state-tests.factor
@@ -9,22 +9,22 @@ definitions ;
SYMBOL: a
SYMBOL: b
-[ ] [ a +called+ depends-on ] unit-test
+[ ] [ a called-dependency depends-on ] unit-test
-[ H{ { a +called+ } } ] [
- [ a +called+ depends-on ] computing-dependencies
+[ H{ { a called-dependency } } ] [
+ [ a called-dependency depends-on ] computing-dependencies
] unit-test
-[ H{ { a +called+ } { b +inlined+ } } ] [
+[ H{ { a called-dependency } { b inlined-dependency } } ] [
[
- a +called+ depends-on b +inlined+ depends-on
+ a called-dependency depends-on b inlined-dependency depends-on
] computing-dependencies
] unit-test
-[ H{ { a +inlined+ } { b +inlined+ } } ] [
+[ H{ { a inlined-dependency } { b inlined-dependency } } ] [
[
- a +inlined+ depends-on
- a +called+ depends-on
- b +inlined+ depends-on
+ a inlined-dependency depends-on
+ a called-dependency depends-on
+ b inlined-dependency depends-on
] computing-dependencies
] unit-test
diff --git a/basis/stack-checker/state/state.factor b/basis/stack-checker/state/state.factor
index 394d065a13..51f90b69cc 100755
--- a/basis/stack-checker/state/state.factor
+++ b/basis/stack-checker/state/state.factor
@@ -1,7 +1,8 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: assocs namespaces sequences kernel definitions math
-effects accessors words stack-checker.errors ;
+effects accessors words stack-checker.errors
+compiler.units ;
IN: stack-checker.state
: <value> ( -- value ) \ <value> counter ;
diff --git a/basis/stack-checker/transforms/transforms.factor b/basis/stack-checker/transforms/transforms.factor
index d941f3242b..200b5d9c43 100755
--- a/basis/stack-checker/transforms/transforms.factor
+++ b/basis/stack-checker/transforms/transforms.factor
@@ -46,7 +46,7 @@ SYMBOL: +transform-n+
] [ 2drop give-up-transform ] if ;
: apply-transform ( word -- )
- [ +inlined+ depends-on ] [
+ [ inlined-dependency depends-on ] [
[ ]
[ +transform-quot+ word-prop ]
[ +transform-n+ word-prop ]
@@ -55,7 +55,7 @@ SYMBOL: +transform-n+
] bi ;
: apply-macro ( word -- )
- [ +inlined+ depends-on ] [
+ [ inlined-dependency depends-on ] [
[ ]
[ "macro" word-prop ]
[ "declared-effect" word-prop in>> length ]
@@ -92,13 +92,13 @@ SYMBOL: +transform-n+
\ spread [ spread>quot ] 1 define-transform
\ (call-next-method) [
- [ [ +inlined+ depends-on ] bi@ ] [ next-method-quot ] 2bi
+ [ [ inlined-dependency depends-on ] bi@ ] [ next-method-quot ] 2bi
] 2 define-transform
! Constructors
\ boa [
dup tuple-class? [
- dup +inlined+ depends-on
+ dup inlined-dependency depends-on
[ "boa-check" word-prop ]
[ tuple-layout '[ , <tuple-boa> ] ]
bi append
@@ -107,7 +107,7 @@ SYMBOL: +transform-n+
\ new [
dup tuple-class? [
- dup +inlined+ depends-on
+ dup inlined-dependency depends-on
dup all-slots rest-slice ! delegate slot
[ [ initial>> literalize , ] each literalize , \ boa , ] [ ] make
] [ drop f ] if
diff --git a/core/classes/algebra/algebra-tests.factor b/core/classes/algebra/algebra-tests.factor
index b43c8f3336..4558ce4737 100755
--- a/core/classes/algebra/algebra-tests.factor
+++ b/core/classes/algebra/algebra-tests.factor
@@ -310,3 +310,8 @@ SINGLETON: sb
SINGLETON: sc
[ sa ] [ sa { sa sb sc } min-class ] unit-test
+
+[ +lt+ ] [ integer sequence class<=> ] unit-test
+[ +lt+ ] [ sequence object class<=> ] unit-test
+[ +gt+ ] [ object sequence class<=> ] unit-test
+[ +eq+ ] [ integer integer class<=> ] unit-test
diff --git a/core/classes/algebra/algebra.factor b/core/classes/algebra/algebra.factor
index 23695c06f8..0f419678d1 100755
--- a/core/classes/algebra/algebra.factor
+++ b/core/classes/algebra/algebra.factor
@@ -186,6 +186,13 @@ M: anonymous-complement (classes-intersect?)
[ [ rank-class ] bi@ < ]
} cond ;
+: class<=> ( first second -- ? )
+ {
+ { [ 2dup class<= not ] [ 2drop +gt+ ] }
+ { [ 2dup swap class<= not ] [ 2drop +lt+ ] }
+ [ [ rank-class ] bi@ <=> ]
+ } cond ;
+
: class= ( first second -- ? )
[ class<= ] [ swap class<= ] 2bi and ;
diff --git a/core/classes/classes.factor b/core/classes/classes.factor
index 27205b487d..610269f8a3 100755
--- a/core/classes/classes.factor
+++ b/core/classes/classes.factor
@@ -119,7 +119,7 @@ M: sequence implementors [ implementors ] gather ;
: (define-class) ( word props -- )
>r
- dup class? [ implementors-map+ ] unless
+ dup class? [ dup implementors-map+ ] unless
dup reset-class
dup deferred? [ dup define-symbol ] when
dup props>>
diff --git a/core/classes/mixin/mixin.factor b/core/classes/mixin/mixin.factor
index 3b12a277d7..56ab6d37f1 100755
--- a/core/classes/mixin/mixin.factor
+++ b/core/classes/mixin/mixin.factor
@@ -39,6 +39,11 @@ TUPLE: check-mixin-class mixin ;
[ [ members swap bootstrap-word ] dip call ] [ drop ] 2bi
swap redefine-mixin-class ; inline
+: update-classes/new ( mixin -- )
+ class-usages
+ [ [ update-class ] each ]
+ [ implementors [ make-generic ] each ] bi ;
+
: add-mixin-instance ( class mixin -- )
#! Note: we call update-classes on the new member, not the
#! mixin. This ensures that we only have to update the
@@ -48,9 +53,12 @@ TUPLE: check-mixin-class mixin ;
#! updated by transitivity; the mixins usages appear in
#! class-usages of the member, now that it's been added.
[ 2drop ] [
- [ [ suffix ] change-mixin-class ]
- [ drop update-classes ]
- 2bi
+ [ [ suffix ] change-mixin-class ] 2keep
+ tuck [ new-class? ] either? [
+ update-classes/new
+ ] [
+ update-classes
+ ] if
] if-mixin-member? ;
: remove-mixin-instance ( class mixin -- )
diff --git a/core/classes/tuple/tuple.factor b/core/classes/tuple/tuple.factor
index 4ff9d4c674..f1fe241bfe 100755
--- a/core/classes/tuple/tuple.factor
+++ b/core/classes/tuple/tuple.factor
@@ -227,7 +227,7 @@ M: tuple-class update-class
2drop
[
[ update-tuples-after ]
- [ +inlined+ changed-definition ]
+ [ inlined-dependency changed-definition ]
[ redefined ]
tri
] each-subclass
diff --git a/core/compiler/units/units-tests.factor b/core/compiler/units/units-tests.factor
new file mode 100644
index 0000000000..6cff088aca
--- /dev/null
+++ b/core/compiler/units/units-tests.factor
@@ -0,0 +1,11 @@
+IN: compiler.units.tests
+USING: definitions compiler.units tools.test arrays sequences ;
+
+[ flushed-dependency ] [ f flushed-dependency strongest-dependency ] unit-test
+[ flushed-dependency ] [ flushed-dependency f strongest-dependency ] unit-test
+[ inlined-dependency ] [ flushed-dependency inlined-dependency strongest-dependency ] unit-test
+[ inlined-dependency ] [ called-dependency inlined-dependency strongest-dependency ] unit-test
+[ flushed-dependency ] [ called-dependency flushed-dependency strongest-dependency ] unit-test
+[ called-dependency ] [ called-dependency f strongest-dependency ] unit-test
+[ T{ method-dependency f array } ] [ called-dependency T{ method-dependency f array } strongest-dependency ] unit-test
+[ T{ method-dependency f sequence } ] [ T{ method-dependency f sequence } T{ method-dependency f array } strongest-dependency ] unit-test
diff --git a/core/compiler/units/units.factor b/core/compiler/units/units.factor
index 616d8c957a..a4b10757f6 100755
--- a/core/compiler/units/units.factor
+++ b/core/compiler/units/units.factor
@@ -1,7 +1,8 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel continuations assocs namespaces
-sequences words vocabs definitions hashtables init sets ;
+sequences words vocabs definitions hashtables init sets
+math.order classes.algebra ;
IN: compiler.units
SYMBOL: old-definitions
@@ -72,6 +73,46 @@ GENERIC: definitions-changed ( assoc obj -- )
SYMBOL: outdated-tuples
SYMBOL: update-tuples-hook
+: strongest-dependency ( how1 how2 -- how )
+ [ called-dependency or ] bi@
+ 2dup [ method-dependency? ] both?
+ [ [ class>> ] bi@ class-or <method-dependency> ] [ max ] if ;
+
+: weakest-dependency ( how1 how2 -- how )
+ [ inlined-dependency or ] bi@
+ 2dup [ method-dependency? ] both?
+ [ [ class>> ] bi@ class-and <method-dependency> ] [ min ] if ;
+
+: relevant-dependency? ( how to -- ? )
+ #! Note that an intersection check alone is not enough,
+ #! since we're also interested in empty mixins.
+ 2dup [ method-dependency? ] both? [
+ [ class>> ] bi@
+ [ classes-intersect? ] [ class<= ] 2bi or
+ ] [ after=? ] if ;
+
+: compiled-usage ( word -- assoc )
+ compiled-crossref get at ;
+
+: (compiled-usages) ( word dependency -- assoc )
+ #! If the word is not flushable anymore, we have to recompile
+ #! all words which flushable away a call (presumably when the
+ #! word was still flushable). If the word is flushable, we
+ #! don't have to recompile words that folded this away.
+ [ drop compiled-usage ]
+ [
+ swap "flushable" word-prop inlined-dependency flushed-dependency ?
+ weakest-dependency
+ ] 2bi
+ [ relevant-dependency? nip ] curry assoc-filter ;
+
+: compiled-usages ( assoc -- seq )
+ clone [
+ dup [
+ [ (compiled-usages) ] dip swap update
+ ] curry assoc-each
+ ] keep keys ;
+
: call-recompile-hook ( -- )
changed-definitions get [ drop word? ] assoc-filter
compiled-usages recompile-hook get call ;
diff --git a/core/definitions/definitions-tests.factor b/core/definitions/definitions-tests.factor
index ec889458a3..b2d265a2e3 100755
--- a/core/definitions/definitions-tests.factor
+++ b/core/definitions/definitions-tests.factor
@@ -31,10 +31,3 @@ TUPLE: another-class some-generic ;
} forget-all
] with-compilation-unit
] unit-test
-
-[ +flushed+ ] [ f +flushed+ strongest-dependency ] unit-test
-[ +flushed+ ] [ +flushed+ f strongest-dependency ] unit-test
-[ +inlined+ ] [ +flushed+ +inlined+ strongest-dependency ] unit-test
-[ +inlined+ ] [ +called+ +inlined+ strongest-dependency ] unit-test
-[ +flushed+ ] [ +called+ +flushed+ strongest-dependency ] unit-test
-[ +called+ ] [ +called+ f strongest-dependency ] unit-test
diff --git a/core/definitions/definitions.factor b/core/definitions/definitions.factor
index affccd95fb..2aa8b894b5 100755
--- a/core/definitions/definitions.factor
+++ b/core/definitions/definitions.factor
@@ -5,25 +5,32 @@ USING: kernel sequences namespaces assocs graphs math math.order ;
ERROR: no-compilation-unit definition ;
+SINGLETON: inlined-dependency
+SINGLETON: flushed-dependency
+SINGLETON: called-dependency
+
+TUPLE: method-dependency class ;
+C: <method-dependency> method-dependency
+
+UNION: dependency
+inlined-dependency
+flushed-dependency
+called-dependency
+method-dependency ;
+
+M: dependency <=>
+ [
+ dup method-dependency? [ drop method-dependency ] when
+ {
+ called-dependency
+ method-dependency
+ flushed-dependency
+ inlined-dependency
+ } index
+ ] bi@ <=> ;
+
SYMBOL: changed-definitions
-SYMBOL: +inlined+
-SYMBOL: +flushed+
-SYMBOL: +called+
-
-: dependency<=> ( how1 how2 -- <=> )
- [ { f +called+ +flushed+ +inlined+ } index ] bi@ <=> ;
-
-: dependency>= ( how1 how2 -- ? ) dependency<=> +lt+ eq? not ;
-
-: strongest-dependency ( how1 how2 -- how )
- [ dependency>= ] most ;
-
-: dependency<= ( how1 how2 -- ? ) dependency<=> +gt+ eq? not ;
-
-: weakest-dependency ( how1 how2 -- how )
- [ dependency<= ] most ;
-
: changed-definition ( defspec how -- )
swap changed-definitions get
[ set-at ] [ no-compilation-unit ] if* ;
diff --git a/core/generic/generic.factor b/core/generic/generic.factor
index 70d406a39b..ac7afe58fa 100755
--- a/core/generic/generic.factor
+++ b/core/generic/generic.factor
@@ -63,7 +63,8 @@ TUPLE: check-method class generic ;
values ;
: update-generic ( class generic -- )
- affected-methods [ +called+ changed-definition ] each ;
+ [ affected-methods ] [ drop <method-dependency> ] 2bi
+ [ changed-definition ] curry each ;
: with-methods ( class generic quot -- )
[ drop update-generic ]
diff --git a/core/words/words.factor b/core/words/words.factor
index 8331c7a15c..19e3915b04 100755
--- a/core/words/words.factor
+++ b/core/words/words.factor
@@ -118,28 +118,6 @@ compiled-crossref global [ H{ } assoc-like ] change-at
dup compiled-unxref
compiled-crossref get delete-at ;
-: compiled-usage ( word -- assoc )
- compiled-crossref get at ;
-
-: (compiled-usages) ( word dependency -- assoc )
- #! If the word is not flushable anymore, we have to recompile
- #! all words which flushable away a call (presumably when the
- #! word was still flushable). If the word is flushable, we
- #! don't have to recompile words that folded this away.
- [ drop compiled-usage ]
- [
- swap "flushable" word-prop +inlined+ +flushed+ ?
- weakest-dependency
- ] 2bi
- [ dependency>= nip ] curry assoc-filter ;
-
-: compiled-usages ( assoc -- seq )
- clone [
- dup [
- [ (compiled-usages) ] dip swap update
- ] curry assoc-each
- ] keep keys ;
-
GENERIC: redefined ( word -- )
M: object redefined drop ;
@@ -149,7 +127,7 @@ M: object redefined drop ;
over unxref
over redefined
>>def
- dup +inlined+ changed-definition
+ dup inlined-dependency changed-definition
dup crossref? [ dup xref ] when drop ;
: set-stack-effect ( effect word -- )
@@ -159,7 +137,7 @@ M: object redefined drop ;
[
drop
dup primitive? [ drop ] [
- [ redefined ] [ +inlined+ changed-definition ] bi
+ [ redefined ] [ inlined-dependency changed-definition ] bi
] if
] 2bi
] if ;
From 86e04a81dcc68991a874d199f77a8046413f0b13 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sat, 30 Aug 2008 02:32:17 -0500
Subject: [PATCH 04/21] Fix conflict
---
core/bootstrap/primitives.factor | 1 +
core/classes/classes.factor | 2 +-
core/compiler/units/units.factor | 2 ++
core/definitions/definitions.factor | 9 +++++++++
4 files changed, 13 insertions(+), 1 deletion(-)
diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor
index 87ed5ea529..b9191ac612 100755
--- a/core/bootstrap/primitives.factor
+++ b/core/bootstrap/primitives.factor
@@ -33,6 +33,7 @@ H{ } clone sub-primitives set
! Bring up a bare cross-compiling vocabulary.
"syntax" vocab vocab-words bootstrap-syntax set
H{ } clone dictionary set
+H{ } clone new-classes set
H{ } clone changed-definitions set
H{ } clone forgotten-definitions set
H{ } clone root-cache set
diff --git a/core/classes/classes.factor b/core/classes/classes.factor
index 610269f8a3..64a8630f36 100755
--- a/core/classes/classes.factor
+++ b/core/classes/classes.factor
@@ -119,7 +119,7 @@ M: sequence implementors [ implementors ] gather ;
: (define-class) ( word props -- )
>r
- dup class? [ dup implementors-map+ ] unless
+ dup class? [ dup [ implementors-map+ ] [ new-class ] bi ] unless
dup reset-class
dup deferred? [ dup define-symbol ] when
dup props>>
diff --git a/core/compiler/units/units.factor b/core/compiler/units/units.factor
index a4b10757f6..23e46876fe 100755
--- a/core/compiler/units/units.factor
+++ b/core/compiler/units/units.factor
@@ -135,6 +135,7 @@ SYMBOL: update-tuples-hook
[
H{ } clone changed-definitions set
H{ } clone outdated-tuples set
+ H{ } clone new-classes set
[ finish-compilation-unit ] [ ] cleanup
] with-scope ; inline
@@ -143,6 +144,7 @@ SYMBOL: update-tuples-hook
H{ } clone changed-definitions set
H{ } clone forgotten-definitions set
H{ } clone outdated-tuples set
+ H{ } clone new-classes set
<definitions> new-definitions set
<definitions> old-definitions set
[
diff --git a/core/definitions/definitions.factor b/core/definitions/definitions.factor
index 2aa8b894b5..456bb20410 100755
--- a/core/definitions/definitions.factor
+++ b/core/definitions/definitions.factor
@@ -35,6 +35,15 @@ SYMBOL: changed-definitions
swap changed-definitions get
[ set-at ] [ no-compilation-unit ] if* ;
+SYMBOL: new-classes
+
+: new-class ( word -- )
+ dup new-classes get
+ [ set-at ] [ no-compilation-unit ] if* ;
+
+: new-class? ( word -- ? )
+ new-classes get key? ;
+
GENERIC: where ( defspec -- loc )
M: object where drop f ;
From 98c2548fa3e66d4fc3e52c8ea492af99dd0f5ac4 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Sat, 30 Aug 2008 21:19:06 -0500
Subject: [PATCH 05/21] new accessors
---
basis/concurrency/locks/locks-tests.factor | 2 +-
basis/concurrency/locks/locks.factor | 45 +++++++++++-----------
2 files changed, 23 insertions(+), 24 deletions(-)
diff --git a/basis/concurrency/locks/locks-tests.factor b/basis/concurrency/locks/locks-tests.factor
index 92dede1655..67f9bbb15a 100755
--- a/basis/concurrency/locks/locks-tests.factor
+++ b/basis/concurrency/locks/locks-tests.factor
@@ -174,7 +174,7 @@ threads sequences calendar accessors ;
] ;
[ lock-timeout-test ] [
- linked-error-thread name>> "Lock timeout-er" =
+ thread>> name>> "Lock timeout-er" =
] must-fail-with
:: read/write-test ( -- )
diff --git a/basis/concurrency/locks/locks.factor b/basis/concurrency/locks/locks.factor
index 95b6801db2..8c1392dbfb 100755
--- a/basis/concurrency/locks/locks.factor
+++ b/basis/concurrency/locks/locks.factor
@@ -1,7 +1,7 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: deques dlists kernel threads continuations math
-concurrency.conditions ;
+concurrency.conditions combinators.short-circuit accessors ;
IN: concurrency.locks
! Simple critical sections
@@ -16,13 +16,13 @@ TUPLE: lock threads owner reentrant? ;
<PRIVATE
: acquire-lock ( lock timeout -- )
- over lock-owner
- [ 2dup >r lock-threads r> "lock" wait ] when drop
- self swap set-lock-owner ;
+ over owner>>
+ [ 2dup >r threads>> r> "lock" wait ] when drop
+ self >>owner drop ;
: release-lock ( lock -- )
- f over set-lock-owner
- lock-threads notify-1 ;
+ f >>owner
+ threads>> notify-1 ;
: do-lock ( lock timeout quot acquire release -- )
>r >r pick rot r> call ! use up timeout acquire
@@ -34,8 +34,8 @@ TUPLE: lock threads owner reentrant? ;
PRIVATE>
: with-lock-timeout ( lock timeout quot -- )
- pick lock-reentrant? [
- pick lock-owner self eq? [
+ pick reentrant?>> [
+ pick owner>> self eq? [
2nip call
] [
(with-lock)
@@ -56,44 +56,43 @@ TUPLE: rw-lock readers writers reader# writer ;
<PRIVATE
: add-reader ( lock -- )
- dup rw-lock-reader# 1+ swap set-rw-lock-reader# ;
+ [ 1+ ] change-reader# drop ;
: acquire-read-lock ( lock timeout -- )
- over rw-lock-writer
- [ 2dup >r rw-lock-readers r> "read lock" wait ] when drop
+ over writer>>
+ [ 2dup >r readers>> r> "read lock" wait ] when drop
add-reader ;
: notify-writer ( lock -- )
- rw-lock-writers notify-1 ;
+ writers>> notify-1 ;
: remove-reader ( lock -- )
- dup rw-lock-reader# 1- swap set-rw-lock-reader# ;
+ [ 1- ] change-reader# drop ;
: release-read-lock ( lock -- )
dup remove-reader
- dup rw-lock-reader# zero? [ notify-writer ] [ drop ] if ;
+ dup reader#>> zero? [ notify-writer ] [ drop ] if ;
: acquire-write-lock ( lock timeout -- )
- over rw-lock-writer pick rw-lock-reader# 0 > or
- [ 2dup >r rw-lock-writers r> "write lock" wait ] when drop
- self swap set-rw-lock-writer ;
+ over writer>> pick reader#>> 0 > or
+ [ 2dup >r writers>> r> "write lock" wait ] when drop
+ self >>writer drop ;
: release-write-lock ( lock -- )
- f over set-rw-lock-writer
- dup rw-lock-readers deque-empty?
- [ notify-writer ] [ rw-lock-readers notify-all ] if ;
+ f >>writer
+ dup readers>> deque-empty?
+ [ notify-writer ] [ readers>> notify-all ] if ;
: reentrant-read-lock-ok? ( lock -- ? )
#! If we already have a write lock, then we can grab a read
#! lock too.
- rw-lock-writer self eq? ;
+ writer>> self eq? ;
: reentrant-write-lock-ok? ( lock -- ? )
#! The only case where we have a writer and > 1 reader is
#! write -> read re-entrancy, and in this case we prohibit
#! a further write -> read -> write re-entrancy.
- dup rw-lock-writer self eq?
- swap rw-lock-reader# zero? and ;
+ { [ writer>> self eq? ] [ reader#>> zero? ] } 1&& ;
PRIVATE>
From 754d68fb958a1ec3f7ae3a60bd2dc64b7a5d5bc5 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Sat, 30 Aug 2008 21:22:29 -0500
Subject: [PATCH 06/21] new accessors
---
extra/turing/turing.factor | 10 +++++-----
1 file changed, 5 insertions(+), 5 deletions(-)
diff --git a/extra/turing/turing.factor b/extra/turing/turing.factor
index f5b510237b..18d66a2e51 100644
--- a/extra/turing/turing.factor
+++ b/extra/turing/turing.factor
@@ -1,6 +1,6 @@
-IN: turing
USING: arrays assocs io kernel math namespaces
-prettyprint sequences strings vectors words ;
+prettyprint sequences strings vectors words accessors ;
+IN: turing
! A turing machine simulator.
@@ -55,9 +55,9 @@ SYMBOL: tape
: turing-step ( -- )
#! Do one step of the turing machine.
next-state
- dup state-sym set-sym
- dup state-dir position [ + ] change
- state-next state set ;
+ dup sym>> set-sym
+ dup dir>> position [ + ] change
+ next>> state set ;
: c ( -- )
#! Print current turing machine state.
From 3f82d8eb9e8a196b29a9ed0a642e080f28c8e440 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Sat, 30 Aug 2008 21:25:47 -0500
Subject: [PATCH 07/21] no unit tests?? new accessors
---
extra/state-machine/state-machine.factor | 9 +++++----
1 file changed, 5 insertions(+), 4 deletions(-)
diff --git a/extra/state-machine/state-machine.factor b/extra/state-machine/state-machine.factor
index b5e8c16b02..6a785e91b7 100755
--- a/extra/state-machine/state-machine.factor
+++ b/extra/state-machine/state-machine.factor
@@ -1,5 +1,6 @@
-USING: kernel parser lexer strings math namespaces sequences words io
-arrays quotations debugger kernel.private sequences.private ;
+USING: kernel parser lexer strings math namespaces
+sequences words io arrays quotations debugger accessors
+sequences.private ;
IN: state-machine
: STATES:
@@ -20,9 +21,9 @@ M: missing-state error.
! quot is ( state string -- output-string )
[ missing-state ] <array> dup
[
- [ >r dup dup state-data swap state-place r> ] %
+ [ >r dup [ data>> ] [ place>> ] bi r> ] %
[ swapd bounds-check dispatch ] curry ,
- [ each pick set-state-place swap set-state-data ] %
+ [ each pick (>>place) swap (>>date) ] %
] [ ] make [ over make ] curry ;
: define-machine ( word state-class -- )
From 6313ca9e33f089423f7991730018c66fe97f591d Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Sat, 30 Aug 2008 21:55:29 -0500
Subject: [PATCH 08/21] new accessors
---
basis/prettyprint/prettyprint-tests.factor | 6 +++---
basis/prettyprint/sections/sections.factor | 4 ++--
2 files changed, 5 insertions(+), 5 deletions(-)
diff --git a/basis/prettyprint/prettyprint-tests.factor b/basis/prettyprint/prettyprint-tests.factor
index 6ad883cfcb..9bffb34ed1 100755
--- a/basis/prettyprint/prettyprint-tests.factor
+++ b/basis/prettyprint/prettyprint-tests.factor
@@ -195,11 +195,11 @@ DEFER: parse-error-file
: string-layout
{
- "USING: debugger io kernel lexer ;"
+ "USING: accessors debugger io kernel ;"
"IN: prettyprint.tests"
": string-layout-test ( error -- )"
- " \"Expected \" write dup unexpected-want expected>string write"
- " \" but got \" write unexpected-got expected>string print ;"
+ " \"Expected \" write dup want>> expected>string write"
+ " \" but got \" write got>> expected>string print ;"
} ;
diff --git a/basis/prettyprint/sections/sections.factor b/basis/prettyprint/sections/sections.factor
index 168e118d4b..aed476b5c6 100644
--- a/basis/prettyprint/sections/sections.factor
+++ b/basis/prettyprint/sections/sections.factor
@@ -115,10 +115,10 @@ M: object short-section? section-fits? ;
: pprint-section ( section -- )
dup short-section? [
- dup section-style [ short-section ] with-style
+ dup style>> [ short-section ] with-style
] [
[ <long-section ]
- [ dup section-style [ long-section ] with-style ]
+ [ dup style>> [ long-section ] with-style ]
[ long-section> ]
tri
] if ;
From 17b3a17cecf4293c4692a897f9f35279ee9f1946 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Sat, 30 Aug 2008 21:58:11 -0500
Subject: [PATCH 09/21] new accessors
---
basis/concurrency/messaging/messaging-tests.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/basis/concurrency/messaging/messaging-tests.factor b/basis/concurrency/messaging/messaging-tests.factor
index b5c022effe..0f9f97c4cc 100755
--- a/basis/concurrency/messaging/messaging-tests.factor
+++ b/basis/concurrency/messaging/messaging-tests.factor
@@ -7,7 +7,7 @@ match quotations concurrency.messaging concurrency.mailboxes
concurrency.count-downs accessors ;
IN: concurrency.messaging.tests
-[ ] [ my-mailbox mailbox-data clear-deque ] unit-test
+[ ] [ my-mailbox data>> clear-deque ] unit-test
[ "received" ] [
[
From 01fee5a1f431accf36ba06a2a077b691d2b40354 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Sat, 30 Aug 2008 21:58:20 -0500
Subject: [PATCH 10/21] new accessors
---
basis/multiline/multiline.factor | 11 ++++++-----
1 file changed, 6 insertions(+), 5 deletions(-)
diff --git a/basis/multiline/multiline.factor b/basis/multiline/multiline.factor
index cf671c5609..1cc418a1f6 100755
--- a/basis/multiline/multiline.factor
+++ b/basis/multiline/multiline.factor
@@ -1,10 +1,11 @@
! Copyright (C) 2007 Daniel Ehrenberg
! See http://factorcode.org/license.txt for BSD license.
-USING: namespaces parser lexer kernel sequences words quotations math ;
+USING: namespaces parser lexer kernel sequences words quotations math
+accessors ;
IN: multiline
: next-line-text ( -- str )
- lexer get dup next-line lexer-line-text ;
+ lexer get dup next-line text>> ;
: (parse-here) ( -- )
next-line-text [
@@ -22,7 +23,7 @@ IN: multiline
parse-here 1quotation define-inline ; parsing
: (parse-multiline-string) ( start-index end-text -- end-index )
- lexer get lexer-line-text [
+ lexer get text>> [
2dup start
[ rot dupd >r >r swap subseq % r> r> length + ] [
rot tail % "\n" % 0
@@ -32,8 +33,8 @@ IN: multiline
: parse-multiline-string ( end-text -- str )
[
- lexer get lexer-column swap (parse-multiline-string)
- lexer get set-lexer-column
+ lexer get column>> swap (parse-multiline-string)
+ lexer get (>>column)
] "" make rest but-last ;
: <"
From 6d1fbd3e22209144afa3793389f2bade5cf259c5 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Sat, 30 Aug 2008 21:58:26 -0500
Subject: [PATCH 11/21] new accessors
---
basis/units/units.factor | 6 +++---
1 file changed, 3 insertions(+), 3 deletions(-)
diff --git a/basis/units/units.factor b/basis/units/units.factor
index fb93691f0a..7604108b82 100755
--- a/basis/units/units.factor
+++ b/basis/units/units.factor
@@ -39,7 +39,7 @@ M: dimensions-not-equal summary drop "Dimensions do not match" ;
[ dimensions 2array ] bi@ =
[ dimensions-not-equal ] unless ;
-: 2values ( dim dim -- val val ) [ dimensioned-value ] bi@ ;
+: 2values ( dim dim -- val val ) [ value>> ] bi@ ;
: <dimension-op ( dim dim -- top bot val val )
2dup check-dimensions dup dimensions 2swap 2values ;
@@ -56,8 +56,8 @@ M: dimensions-not-equal summary drop "Dimensions do not match" ;
: d* ( d d -- d )
[ dup number? [ scalar ] when ] bi@
- [ [ dimensioned-top ] bi@ append ] 2keep
- [ [ dimensioned-bot ] bi@ append ] 2keep
+ [ [ top>> ] bi@ append ] 2keep
+ [ [ bot>> ] bi@ append ] 2keep
2values * dimension-op> ;
: d-neg ( d -- d ) -1 d* ;
From 843eb15522c926c1dfcd8a943da506a067c4f4c6 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Sat, 30 Aug 2008 21:58:34 -0500
Subject: [PATCH 12/21] new accessors
---
extra/classes/tuple/lib/lib.factor | 4 ++--
1 file changed, 2 insertions(+), 2 deletions(-)
diff --git a/extra/classes/tuple/lib/lib.factor b/extra/classes/tuple/lib/lib.factor
index 509843b9cd..a234ce0d41 100755
--- a/extra/classes/tuple/lib/lib.factor
+++ b/extra/classes/tuple/lib/lib.factor
@@ -1,11 +1,11 @@
! Copyright (C) 2007 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel macros sequences slots words classes.tuple
-quotations combinators ;
+quotations combinators accessors ;
IN: classes.tuple.lib
: reader-slots ( seq -- quot )
- [ slot-spec-reader 1quotation ] map [ cleave ] curry ;
+ [ reader>> 1quotation ] map [ cleave ] curry ;
MACRO: >tuple< ( class -- )
all-slots rest-slice reader-slots ;
From 5c19e28fb99e2352879d803fb4fe057f0112305b Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Sat, 30 Aug 2008 21:58:40 -0500
Subject: [PATCH 13/21] new accesors
---
extra/inverse/inverse.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/extra/inverse/inverse.factor b/extra/inverse/inverse.factor
index 72a74baf68..2340442d5b 100755
--- a/extra/inverse/inverse.factor
+++ b/extra/inverse/inverse.factor
@@ -208,7 +208,7 @@ DEFER: _
: slot-readers ( class -- quot )
all-slots rest ! tail gets rid of delegate
- [ slot-spec-reader 1quotation [ keep ] curry ] map concat
+ [ reader>> 1quotation [ keep ] curry ] map concat
[ ] like [ drop ] compose ;
: ?wrapped ( object -- wrapped )
From 14eea72acb974749a53e12d308fabb59a5349720 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Sat, 30 Aug 2008 21:58:46 -0500
Subject: [PATCH 14/21] new accessors
---
extra/lists/lazy/lazy.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/extra/lists/lazy/lazy.factor b/extra/lists/lazy/lazy.factor
index 6beb6e402d..8a1e73928c 100644
--- a/extra/lists/lazy/lazy.factor
+++ b/extra/lists/lazy/lazy.factor
@@ -24,7 +24,7 @@ TUPLE: lazy-cons car cdr ;
: lazy-cons ( car cdr -- promise )
[ promise ] bi@ \ lazy-cons boa
T{ promise f f t f } clone
- [ set-promise-value ] keep ;
+ swap >>value ;
M: lazy-cons car ( lazy-cons -- car )
car>> force ;
From a58dc274db83bbe72e6c82d2a2bf62ccb34171a8 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Sat, 30 Aug 2008 21:58:53 -0500
Subject: [PATCH 15/21] new accessors
---
extra/morse/morse.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/extra/morse/morse.factor b/extra/morse/morse.factor
index 591915b317..4cce93a5a1 100644
--- a/extra/morse/morse.factor
+++ b/extra/morse/morse.factor
@@ -116,7 +116,7 @@ LAZY: 'morse-words' ( -- parser )
PRIVATE>
: morse> ( str -- str )
- 'morse-words' parse car parse-result-parsed [
+ 'morse-words' parse car parsed>> [
[
>string morse>ch
] map >string
From ccd5b8ced43994d7a0f8db0b6d2c022562e1bbf5 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Sat, 30 Aug 2008 21:59:00 -0500
Subject: [PATCH 16/21] new accessors
---
extra/nehe/4/4.factor | 16 ++++++++--------
extra/nehe/5/5.factor | 18 +++++++++---------
2 files changed, 17 insertions(+), 17 deletions(-)
diff --git a/extra/nehe/4/4.factor b/extra/nehe/4/4.factor
index fc2727159b..429e6d9d9c 100644
--- a/extra/nehe/4/4.factor
+++ b/extra/nehe/4/4.factor
@@ -1,5 +1,5 @@
USING: arrays kernel math opengl opengl.gl opengl.glu ui
-ui.gadgets ui.render threads ;
+ui.gadgets ui.render threads accessors ;
IN: nehe.4
TUPLE: nehe4-gadget < gadget rtri rquad thread quit? ;
@@ -10,8 +10,8 @@ TUPLE: nehe4-gadget < gadget rtri rquad thread quit? ;
: <nehe4-gadget> ( -- gadget )
nehe4-gadget new-gadget
- 0.0 over set-nehe4-gadget-rtri
- 0.0 over set-nehe4-gadget-rquad ;
+ 0.0 >>rtri
+ 0.0 >>rquad ;
M: nehe4-gadget pref-dim* ( gadget -- dim )
drop width height 2array ;
@@ -53,22 +53,22 @@ M: nehe4-gadget draw-gadget* ( gadget -- )
1.0 -1.0 0.0 glVertex3f
-1.0 -1.0 0.0 glVertex3f
] do-state
- dup nehe4-gadget-rtri 0.2 + over set-nehe4-gadget-rtri
- dup nehe4-gadget-rquad 0.15 - swap set-nehe4-gadget-rquad ;
+ [ 0.2 + ] change-rtri
+ [ 0.15 - ] change-rquad drop ;
: nehe4-update-thread ( gadget -- )
- dup nehe4-gadget-quit? [ drop ] [
+ dup quit?>> [ drop ] [
redraw-interval sleep
dup relayout-1
nehe4-update-thread
] if ;
M: nehe4-gadget graft* ( gadget -- )
- [ f swap set-nehe4-gadget-quit? ] keep
+ f >>quit?
[ nehe4-update-thread ] in-thread drop ;
M: nehe4-gadget ungraft* ( gadget -- )
- t swap set-nehe4-gadget-quit? ;
+ t >>quit? drop ;
: run4 ( -- )
<nehe4-gadget> "NeHe Tutorial 4" open-window ;
diff --git a/extra/nehe/5/5.factor b/extra/nehe/5/5.factor
index f399a116ed..ebdfcd5367 100755
--- a/extra/nehe/5/5.factor
+++ b/extra/nehe/5/5.factor
@@ -1,5 +1,5 @@
USING: arrays kernel math opengl opengl.gl opengl.glu ui
-ui.gadgets ui.render threads ;
+ui.gadgets ui.render threads accessors ;
IN: nehe.5
TUPLE: nehe5-gadget < gadget rtri rquad thread quit? ;
@@ -9,8 +9,8 @@ TUPLE: nehe5-gadget < gadget rtri rquad thread quit? ;
: <nehe5-gadget> ( -- gadget )
nehe5-gadget new-gadget
- 0.0 over set-nehe5-gadget-rtri
- 0.0 over set-nehe5-gadget-rquad ;
+ 0.0 >>rtri
+ 0.0 >>rquad ;
M: nehe5-gadget pref-dim* ( gadget -- dim )
drop width height 2array ;
@@ -103,11 +103,11 @@ M: nehe5-gadget draw-gadget* ( gadget -- )
1.0 -1.0 1.0 glVertex3f
1.0 -1.0 -1.0 glVertex3f
] do-state
- dup nehe5-gadget-rtri 0.2 + over set-nehe5-gadget-rtri
- dup nehe5-gadget-rquad 0.15 - swap set-nehe5-gadget-rquad ;
+ [ 0.2 + ] change-rtri
+ [ 0.15 - ] change-rquad drop ;
: nehe5-update-thread ( gadget -- )
- dup nehe5-gadget-quit? [
+ dup quit?>> [
drop
] [
redraw-interval sleep
@@ -116,11 +116,11 @@ M: nehe5-gadget draw-gadget* ( gadget -- )
] if ;
M: nehe5-gadget graft* ( gadget -- )
- [ f swap set-nehe5-gadget-quit? ] keep
- [ nehe5-update-thread ] in-thread drop ;
+ f >>quit?
+ [ nehe5-update-thread ] in-thread drop ;
M: nehe5-gadget ungraft* ( gadget -- )
- t swap set-nehe5-gadget-quit? ;
+ t >>quit? drop ;
: run5 ( -- )
From 3891a7df74f84d64fd0874cc22aa9597f9990a6a Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Sat, 30 Aug 2008 21:59:09 -0500
Subject: [PATCH 17/21] new accessors
---
extra/ori/ori.factor | 6 +++---
1 file changed, 3 insertions(+), 3 deletions(-)
diff --git a/extra/ori/ori.factor b/extra/ori/ori.factor
index 20f022f19f..de720a229f 100644
--- a/extra/ori/ori.factor
+++ b/extra/ori/ori.factor
@@ -1,5 +1,5 @@
-USING: kernel namespaces
+USING: kernel namespaces accessors
math math.constants math.functions math.matrices math.vectors
sequences splitting grouping self math.trig ;
@@ -11,9 +11,9 @@ C: <ori> ori
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-: ori> ( -- val ) self> ori-val ;
+: ori> ( -- val ) self> val>> ;
-: >ori ( val -- ) self> set-ori-val ;
+: >ori ( val -- ) self> (>>val) ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
From 3eaa63b03acaed509450e85ff97a3a4a0da3a987 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Sat, 30 Aug 2008 21:59:18 -0500
Subject: [PATCH 18/21] new accessors
---
extra/pos/pos.factor | 9 +++++----
1 file changed, 5 insertions(+), 4 deletions(-)
diff --git a/extra/pos/pos.factor b/extra/pos/pos.factor
index 24c5410e99..38eb8dec96 100644
--- a/extra/pos/pos.factor
+++ b/extra/pos/pos.factor
@@ -1,5 +1,6 @@
-USING: kernel math math.functions math.vectors sequences self ;
+USING: kernel math math.functions math.vectors sequences self
+accessors ;
IN: pos
@@ -9,13 +10,13 @@ TUPLE: pos val ;
C: <pos> pos
-: pos> ( -- val ) self> pos-val ;
+: pos> ( -- val ) self> val>> ;
-: >pos ( val -- ) self> set-pos-val ;
+: >pos ( val -- ) self> (>>val) ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-: distance ( pos pos -- n ) pos-val swap pos-val v- [ sq ] map sum sqrt ;
+: distance ( pos pos -- n ) val>> swap val>> v- [ sq ] map sum sqrt ;
: move-by ( point -- ) pos> v+ >pos ;
From 3d88fec7e5ff33dda350c19b32296a89ed83b636 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Sat, 30 Aug 2008 21:59:30 -0500
Subject: [PATCH 19/21] new accessors
---
extra/regexp/regexp.factor | 8 ++++----
1 file changed, 4 insertions(+), 4 deletions(-)
diff --git a/extra/regexp/regexp.factor b/extra/regexp/regexp.factor
index 1bd81d46ea..4920d481b1 100755
--- a/extra/regexp/regexp.factor
+++ b/extra/regexp/regexp.factor
@@ -270,14 +270,14 @@ TUPLE: regexp source parser ignore-case? ;
] keep regexp boa ;
: do-ignore-case ( string regexp -- string regexp )
- dup regexp-ignore-case? [ >r >upper r> ] when ;
+ dup ignore-case?>> [ >r >upper r> ] when ;
: matches? ( string regexp -- ? )
- do-ignore-case regexp-parser just parse nil? not ;
+ do-ignore-case parser>> just parse nil? not ;
: match-head ( string regexp -- end )
- do-ignore-case regexp-parser parse dup nil?
- [ drop f ] [ car parse-result-unparsed from>> ] if ;
+ do-ignore-case parser>> parse dup nil?
+ [ drop f ] [ car unparsed>> from>> ] if ;
! Literal syntax for regexps
: parse-options ( string -- ? )
From 978adcf90c52395d37ffa126795c222fe764cdab Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Sat, 30 Aug 2008 21:59:46 -0500
Subject: [PATCH 20/21] new accessors
---
extra/fjsc/fjsc.factor | 4 +--
extra/json/reader/reader.factor | 7 +++--
.../parser-combinators.factor | 28 ++++++++++---------
extra/peg/ebnf/ebnf.factor | 4 +--
4 files changed, 23 insertions(+), 20 deletions(-)
diff --git a/extra/fjsc/fjsc.factor b/extra/fjsc/fjsc.factor
index 5f1f977d20..e12092603a 100755
--- a/extra/fjsc/fjsc.factor
+++ b/extra/fjsc/fjsc.factor
@@ -353,11 +353,11 @@ M: quotation fjsc-parse ( object -- ast )
] with-string-writer ;
: fjsc-compile* ( string -- string )
- 'statement' parse parse-result-ast fjsc-compile ;
+ 'statement' parse ast>> fjsc-compile ;
: fc* ( string -- string )
[
- 'statement' parse parse-result-ast values>> do-expressions
+ 'statement' parse ast>> values>> do-expressions
] { } make [ write ] each ;
diff --git a/extra/json/reader/reader.factor b/extra/json/reader/reader.factor
index 6bd6905804..e21b1292e3 100755
--- a/extra/json/reader/reader.factor
+++ b/extra/json/reader/reader.factor
@@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: kernel parser-combinators namespaces sequences promises strings
assocs math math.parser math.vectors math.functions math.order
- lists hashtables ascii ;
+ lists hashtables ascii accessors ;
IN: json.reader
! Grammar for JSON from RFC 4627
@@ -169,11 +169,12 @@ LAZY: 'value' ( -- parser )
'array' ,
'number' ,
] [<|>] spaced ;
+ERROR: could-not-parse-json ;
: json> ( string -- object )
#! Parse a json formatted string to a factor object
'value' parse dup nil? [
- "Could not parse json" throw
+ could-not-parse-json
] [
- car parse-result-parsed
+ car parsed>>
] if ;
diff --git a/extra/parser-combinators/parser-combinators.factor b/extra/parser-combinators/parser-combinators.factor
index 2414c1ced3..a05c140b86 100755
--- a/extra/parser-combinators/parser-combinators.factor
+++ b/extra/parser-combinators/parser-combinators.factor
@@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: lists lists.lazy promises kernel sequences strings math
arrays splitting quotations combinators namespaces
-unicode.case unicode.categories sequences.deep ;
+unicode.case unicode.categories sequences.deep accessors ;
IN: parser-combinators
! Parser combinator protocol
@@ -13,11 +13,13 @@ M: promise parse ( input parser -- list )
TUPLE: parse-result parsed unparsed ;
+ERROR: cannot-parse input ;
+
: parse-1 ( input parser -- result )
dupd parse dup nil? [
- "Cannot parse " rot append throw
+ rot cannot-parse
] [
- nip car parse-result-parsed
+ nip car parsed>>
] if ;
C: <parse-result> parse-result
@@ -26,12 +28,12 @@ C: <parse-result> parse-result
<parse-result> 1list ;
: parse-result-parsed-slice ( parse-result -- slice )
- dup parse-result-parsed empty? [
- parse-result-unparsed 0 0 rot <slice>
+ dup parsed>> empty? [
+ unparsed>> 0 0 rot <slice>
] [
- dup parse-result-unparsed
- dup slice-from [ rot parse-result-parsed length - ] keep
- rot slice-seq <slice>
+ dup unparsed>>
+ dup from>> [ rot parsed>> length - ] keep
+ rot seq>> <slice>
] if ;
: string= ( str1 str2 ignore-case -- ? )
@@ -132,7 +134,7 @@ TUPLE: and-parser parsers ;
: <&> ( parser1 parser2 -- parser )
over and-parser? [
- >r and-parser-parsers r> suffix
+ >r parsers>> r> suffix
] [
2array
] if and-parser boa ;
@@ -142,11 +144,11 @@ TUPLE: and-parser parsers ;
: and-parser-parse ( list p1 -- list )
swap [
- dup parse-result-unparsed rot parse
+ dup unparsed>> rot parse
[
- >r parse-result-parsed r>
- [ parse-result-parsed 2array ] keep
- parse-result-unparsed <parse-result>
+ >r parsed>> r>
+ [ parsed>> 2array ] keep
+ unparsed>> <parse-result>
] lazy-map-with
] lazy-map-with lconcat ;
diff --git a/extra/peg/ebnf/ebnf.factor b/extra/peg/ebnf/ebnf.factor
index 9ca8f470bb..6e9d78e649 100644
--- a/extra/peg/ebnf/ebnf.factor
+++ b/extra/peg/ebnf/ebnf.factor
@@ -508,10 +508,10 @@ M: ebnf-non-terminal (transform) ( ast -- parser )
: check-parse-result ( result -- result )
dup [
- dup parse-result-remaining [ blank? ] trim empty? [
+ dup remaining>> [ blank? ] trim empty? [
[
"Unable to fully parse EBNF. Left to parse was: " %
- parse-result-remaining %
+ remaining>> %
] "" make throw
] unless
] [
From f5fbd94a4c8759056247683e967420089bf33cb9 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sun, 31 Aug 2008 01:34:00 -0500
Subject: [PATCH 21/21] New compiled crossref implementation
---
basis/compiler/compiler.factor | 7 +-
basis/compiler/tests/insane.factor | 5 +-
basis/compiler/tests/redefine11.factor | 32 ++++++++
basis/compiler/tests/redefine9.factor | 2 +-
basis/compiler/tree/cleanup/cleanup.factor | 2 +-
.../known-words/known-words.factor | 12 ++-
.../tree/propagation/simple/simple.factor | 20 ++++-
basis/help/syntax/syntax.factor | 2 +-
basis/hints/hints.factor | 2 +-
basis/stack-checker/backend/backend.factor | 24 +-----
basis/stack-checker/state/state.factor | 13 ++-
basis/tools/deploy/deploy-tests.factor | 14 ++--
basis/tools/deploy/test/2/deploy.factor | 18 ++---
core/assocs/assocs.factor | 3 +
core/bootstrap/primitives.factor | 1 +
core/classes/classes.factor | 1 +
core/classes/mixin/mixin.factor | 6 +-
core/classes/tuple/tuple.factor | 3 +-
core/compiler/units/units-tests.factor | 2 -
core/compiler/units/units.factor | 66 ++++++++-------
core/definitions/definitions.factor | 18 ++---
core/generic/generic.factor | 15 +---
core/words/words.factor | 80 +++++++++++++------
23 files changed, 211 insertions(+), 137 deletions(-)
create mode 100644 basis/compiler/tests/redefine11.factor
diff --git a/basis/compiler/compiler.factor b/basis/compiler/compiler.factor
index 2947362430..d340c21663 100755
--- a/basis/compiler/compiler.factor
+++ b/basis/compiler/compiler.factor
@@ -42,12 +42,17 @@ SYMBOL: +failed+
[ compiled-unxref ]
[
dup crossref?
- [ dependencies get compiled-xref ] [ drop ] if
+ [
+ dependencies get
+ generic-dependencies get
+ compiled-xref
+ ] [ drop ] if
] tri ;
: (compile) ( word -- )
'[
H{ } clone dependencies set
+ H{ } clone generic-dependencies set
, {
[ compile-begins ]
diff --git a/basis/compiler/tests/insane.factor b/basis/compiler/tests/insane.factor
index 4c87f73722..aa79067252 100644
--- a/basis/compiler/tests/insane.factor
+++ b/basis/compiler/tests/insane.factor
@@ -1,4 +1,5 @@
IN: compiler.tests
-USING: words kernel stack-checker alien.strings tools.test ;
+USING: words kernel stack-checker alien.strings tools.test
+compiler.units ;
-[ ] [ \ if redefined [ string>alien ] infer. ] unit-test
+[ ] [ [ \ if redefined ] with-compilation-unit [ string>alien ] infer. ] unit-test
diff --git a/basis/compiler/tests/redefine11.factor b/basis/compiler/tests/redefine11.factor
new file mode 100644
index 0000000000..18b1a3a430
--- /dev/null
+++ b/basis/compiler/tests/redefine11.factor
@@ -0,0 +1,32 @@
+USING: eval tools.test compiler.units vocabs multiline words
+kernel classes.mixin arrays ;
+IN: compiler.tests
+
+! Mixin redefinition did not recompile all necessary words.
+
+[ ] [ [ "compiler.tests.redefine11" forget-vocab ] with-compilation-unit ] unit-test
+
+[ ] [
+ <"
+ USING: kernel math classes arrays ;
+ IN: compiler.tests.redefine11
+ MIXIN: my-mixin
+ INSTANCE: array my-mixin
+ INSTANCE: fixnum my-mixin
+ GENERIC: my-generic ( a -- b )
+ M: my-mixin my-generic drop 0 ;
+ M: object my-generic drop 1 ;
+ : my-inline ( -- b ) { } my-generic ;
+ "> eval
+] unit-test
+
+[ ] [
+ [
+ array "my-mixin" "compiler.tests.redefine11" lookup
+ remove-mixin-instance
+ ] with-compilation-unit
+] unit-test
+
+[ 1 ] [
+ "my-inline" "compiler.tests.redefine11" lookup execute
+] unit-test
diff --git a/basis/compiler/tests/redefine9.factor b/basis/compiler/tests/redefine9.factor
index 8b8a170ed4..7b0f8a2e9c 100644
--- a/basis/compiler/tests/redefine9.factor
+++ b/basis/compiler/tests/redefine9.factor
@@ -29,7 +29,7 @@ IN: compiler.tests
] unit-test
[
- "my-tuple" "compiler.tests.redefine9" lookup
+ "my-tuple" "compiler.tests.redefine9" lookup boa
"my-generic" "compiler.tests.redefine9" lookup
execute
] [ no-math-method? ] must-fail-with
diff --git a/basis/compiler/tree/cleanup/cleanup.factor b/basis/compiler/tree/cleanup/cleanup.factor
index f0b664666b..8056e75b3e 100644
--- a/basis/compiler/tree/cleanup/cleanup.factor
+++ b/basis/compiler/tree/cleanup/cleanup.factor
@@ -52,7 +52,7 @@ GENERIC: cleanup* ( node -- node/nodes )
: add-method-dependency ( #call -- )
dup method>> word? [
- [ method>> ] [ class>> <method-dependency> ] bi depends-on
+ [ word>> ] [ class>> ] bi depends-on-generic
] [ drop ] if ;
: cleanup-inlining ( #call -- nodes )
diff --git a/basis/compiler/tree/propagation/known-words/known-words.factor b/basis/compiler/tree/propagation/known-words/known-words.factor
index d9fc18acb0..23323e107d 100644
--- a/basis/compiler/tree/propagation/known-words/known-words.factor
+++ b/basis/compiler/tree/propagation/known-words/known-words.factor
@@ -5,6 +5,8 @@ math.partial-dispatch math.intervals math.parser math.order
layouts words sequences sequences.private arrays assocs classes
classes.algebra combinators generic.math splitting fry locals
classes.tuple alien.accessors classes.tuple.private slots.private
+definitions
+stack-checker.state
compiler.tree.comparisons
compiler.tree.propagation.info
compiler.tree.propagation.nodes
@@ -280,6 +282,14 @@ generic-comparison-ops [
] +constraints+ set-word-prop
\ instance? [
+ ! We need to force the caller word to recompile when the class
+ ! is redefined, since now we're making assumptions but the
+ ! class definition itself.
dup literal>> class?
- [ literal>> predicate-output-infos ] [ 2drop object-info ] if
+ [
+ literal>>
+ [ inlined-dependency depends-on ]
+ [ predicate-output-infos ]
+ bi
+ ] [ 2drop object-info ] if
] +outputs+ set-word-prop
diff --git a/basis/compiler/tree/propagation/simple/simple.factor b/basis/compiler/tree/propagation/simple/simple.factor
index 48a4b478e6..d664ae5ccf 100644
--- a/basis/compiler/tree/propagation/simple/simple.factor
+++ b/basis/compiler/tree/propagation/simple/simple.factor
@@ -2,9 +2,10 @@
! See http://factorcode.org/license.txt for BSD license.
USING: fry accessors kernel sequences sequences.private assocs words
namespaces classes.algebra combinators classes classes.tuple
-classes.tuple.private continuations arrays byte-arrays strings
-math math.partial-dispatch math.private slots generic
+classes.tuple.private continuations arrays
+math math.partial-dispatch math.private slots generic definitions
generic.standard generic.math
+stack-checker.state
compiler.tree
compiler.tree.propagation.info
compiler.tree.propagation.nodes
@@ -32,7 +33,14 @@ M: #push propagate-before
[ set-value-info ] 2each ;
M: #declare propagate-before
- declaration>> [ <class-info> swap refine-value-info ] assoc-each ;
+ #! We need to force the caller word to recompile when the
+ #! classes mentioned in the declaration are redefined, since
+ #! now we're making assumptions but their definitions.
+ declaration>> [
+ [ inlined-dependency depends-on ]
+ [ <class-info> swap refine-value-info ]
+ bi
+ ] assoc-each ;
: predicate-constraints ( value class boolean-value -- constraint )
[ [ is-instance-of ] dip t--> ]
@@ -74,7 +82,11 @@ M: #declare propagate-before
} cond 2nip ;
: propagate-predicate ( #call word -- infos )
- [ in-d>> first value-info ] [ "predicating" word-prop ] bi*
+ #! We need to force the caller word to recompile when the class
+ #! is redefined, since now we're making assumptions but the
+ #! class definition itself.
+ [ in-d>> first value-info ]
+ [ "predicating" word-prop dup inlined-dependency depends-on ] bi*
predicate-output-infos 1array ;
: default-output-value-infos ( #call word -- infos )
diff --git a/basis/help/syntax/syntax.factor b/basis/help/syntax/syntax.factor
index 877de30748..65120a5d01 100755
--- a/basis/help/syntax/syntax.factor
+++ b/basis/help/syntax/syntax.factor
@@ -18,5 +18,5 @@ IN: help.syntax
: ABOUT:
scan-object
in get vocab
- dup +inlined+ changed-definition
+ dup changed-definition
set-vocab-help ; parsing
diff --git a/basis/hints/hints.factor b/basis/hints/hints.factor
index fe4255d977..28bce0ec42 100644
--- a/basis/hints/hints.factor
+++ b/basis/hints/hints.factor
@@ -55,7 +55,7 @@ IN: hints
: HINTS:
scan-word
- [ inlined-dependency changed-definition ]
+ [ redefined ]
[ parse-definition "specializer" set-word-prop ] bi ;
parsing
diff --git a/basis/stack-checker/backend/backend.factor b/basis/stack-checker/backend/backend.factor
index ff41ff3feb..4d0fd6d8aa 100755
--- a/basis/stack-checker/backend/backend.factor
+++ b/basis/stack-checker/backend/backend.factor
@@ -8,29 +8,6 @@ sets generic.standard.engines.tuple stack-checker.state
stack-checker.visitor stack-checker.errors ;
IN: stack-checker.backend
-! Word properties we use
-SYMBOL: visited
-
-: reset-on-redefine { "inferred-effect" "cannot-infer" } ; inline
-
-: (redefined) ( word -- )
- dup visited get key? [ drop ] [
- [ reset-on-redefine reset-props ]
- [ visited get conjoin ]
- [
- crossref get at keys
- [ word? ] filter
- [
- [ reset-on-redefine [ word-prop ] with contains? ]
- [ inline? ]
- bi or
- ] filter
- [ (redefined) ] each
- ] tri
- ] if ;
-
-M: word redefined H{ } clone visited [ (redefined) ] with-variable ;
-
: push-d ( obj -- ) meta-d get push ;
: pop-d ( -- obj )
@@ -175,6 +152,7 @@ M: object apply-object push-literal ;
init-known-values
stack-visitor off
dependencies off
+ generic-dependencies off
[ [ def>> ] [ ] [ ] tri infer-quot-recursive end-infer ]
[ finish-word current-effect ]
bi
diff --git a/basis/stack-checker/state/state.factor b/basis/stack-checker/state/state.factor
index 51f90b69cc..3d3db980e1 100755
--- a/basis/stack-checker/state/state.factor
+++ b/basis/stack-checker/state/state.factor
@@ -1,7 +1,7 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: assocs namespaces sequences kernel definitions math
-effects accessors words stack-checker.errors
+effects accessors words fry classes.algebra stack-checker.errors
compiler.units ;
IN: stack-checker.state
@@ -89,8 +89,15 @@ SYMBOL: meta-r
SYMBOL: dependencies
: depends-on ( word how -- )
- [ strongest-dependency ] curry
- dependencies get dup [ swap change-at ] [ 3drop ] if ;
+ dependencies get dup
+ [ swap '[ , strongest-dependency ] change-at ] [ 3drop ] if ;
+
+! Generic words that the current quotation depends on
+SYMBOL: generic-dependencies
+
+: depends-on-generic ( generic class -- )
+ generic-dependencies get dup
+ [ swap '[ null or , class-or ] change-at ] [ 3drop ] if ;
! Words we've inferred the stack effect of, for rollback
SYMBOL: recorded
diff --git a/basis/tools/deploy/deploy-tests.factor b/basis/tools/deploy/deploy-tests.factor
index 5ca63a254f..9171a480cf 100755
--- a/basis/tools/deploy/deploy-tests.factor
+++ b/basis/tools/deploy/deploy-tests.factor
@@ -35,13 +35,13 @@ namespaces continuations layouts accessors ;
[ t ] [ 1200000 small-enough? ] unit-test
-[ ] [ "tetris" shake-and-bake ] unit-test
-
-[ t ] [ 1500000 small-enough? ] unit-test
-
-[ ] [ "bunny" shake-and-bake ] unit-test
-
-[ t ] [ 2500000 small-enough? ] unit-test
+! [ ] [ "tetris" shake-and-bake ] unit-test
+!
+! [ t ] [ 1500000 small-enough? ] unit-test
+!
+! [ ] [ "bunny" shake-and-bake ] unit-test
+!
+! [ t ] [ 2500000 small-enough? ] unit-test
{
"tools.deploy.test.1"
diff --git a/basis/tools/deploy/test/2/deploy.factor b/basis/tools/deploy/test/2/deploy.factor
index b8c37af20a..aeec8e94f7 100755
--- a/basis/tools/deploy/test/2/deploy.factor
+++ b/basis/tools/deploy/test/2/deploy.factor
@@ -1,15 +1,15 @@
USING: tools.deploy.config ;
H{
- { deploy-word-defs? f }
- { deploy-random? f }
- { deploy-name "tools.deploy.test.2" }
- { deploy-threads? t }
- { deploy-compiler? t }
{ deploy-math? t }
- { deploy-c-types? f }
- { deploy-io 2 }
- { deploy-reflection 1 }
+ { deploy-compiler? t }
+ { deploy-reflection 2 }
{ deploy-ui? f }
- { "stop-after-last-window?" t }
{ deploy-word-props? f }
+ { deploy-threads? t }
+ { deploy-c-types? f }
+ { deploy-random? f }
+ { "stop-after-last-window?" t }
+ { deploy-name "tools.deploy.test.2" }
+ { deploy-io 2 }
+ { deploy-word-defs? f }
}
diff --git a/core/assocs/assocs.factor b/core/assocs/assocs.factor
index 3ebedfc6d7..56567fab85 100755
--- a/core/assocs/assocs.factor
+++ b/core/assocs/assocs.factor
@@ -110,6 +110,9 @@ M: assoc assoc-clone-like ( assoc exemplar -- newassoc )
2dup [ assoc-size ] bi@ + pick new-assoc
[ rot update ] keep [ swap update ] keep ;
+: assoc-combine ( seq -- union )
+ H{ } clone [ dupd update ] reduce ;
+
: assoc-diff ( assoc1 assoc2 -- diff )
[ nip key? not ] curry assoc-filter ;
diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor
index b9191ac612..8d9f812cee 100755
--- a/core/bootstrap/primitives.factor
+++ b/core/bootstrap/primitives.factor
@@ -35,6 +35,7 @@ H{ } clone sub-primitives set
H{ } clone dictionary set
H{ } clone new-classes set
H{ } clone changed-definitions set
+H{ } clone changed-generics set
H{ } clone forgotten-definitions set
H{ } clone root-cache set
H{ } clone source-files set
diff --git a/core/classes/classes.factor b/core/classes/classes.factor
index 64a8630f36..5ec96bbbb0 100755
--- a/core/classes/classes.factor
+++ b/core/classes/classes.factor
@@ -122,6 +122,7 @@ M: sequence implementors [ implementors ] gather ;
dup class? [ dup [ implementors-map+ ] [ new-class ] bi ] unless
dup reset-class
dup deferred? [ dup define-symbol ] when
+ dup redefined
dup props>>
r> assoc-union >>props
dup predicate-word
diff --git a/core/classes/mixin/mixin.factor b/core/classes/mixin/mixin.factor
index 56ab6d37f1..a7770e2eb2 100755
--- a/core/classes/mixin/mixin.factor
+++ b/core/classes/mixin/mixin.factor
@@ -63,8 +63,10 @@ TUPLE: check-mixin-class mixin ;
: remove-mixin-instance ( class mixin -- )
[
- [ [ swap remove ] change-mixin-class ] keep
- update-classes
+ [ class-usages update-methods ]
+ [ [ swap remove ] change-mixin-class ]
+ [ nip update-classes ]
+ 2tri
] [ 2drop ] if-mixin-member? ;
M: mixin-class class-forgotten remove-mixin-instance ;
diff --git a/core/classes/tuple/tuple.factor b/core/classes/tuple/tuple.factor
index f1fe241bfe..8a9d230a7c 100755
--- a/core/classes/tuple/tuple.factor
+++ b/core/classes/tuple/tuple.factor
@@ -227,9 +227,8 @@ M: tuple-class update-class
2drop
[
[ update-tuples-after ]
- [ inlined-dependency changed-definition ]
[ redefined ]
- tri
+ bi
] each-subclass
]
[ define-new-tuple-class ]
diff --git a/core/compiler/units/units-tests.factor b/core/compiler/units/units-tests.factor
index 6cff088aca..b30e92bbfd 100644
--- a/core/compiler/units/units-tests.factor
+++ b/core/compiler/units/units-tests.factor
@@ -7,5 +7,3 @@ USING: definitions compiler.units tools.test arrays sequences ;
[ inlined-dependency ] [ called-dependency inlined-dependency strongest-dependency ] unit-test
[ flushed-dependency ] [ called-dependency flushed-dependency strongest-dependency ] unit-test
[ called-dependency ] [ called-dependency f strongest-dependency ] unit-test
-[ T{ method-dependency f array } ] [ called-dependency T{ method-dependency f array } strongest-dependency ] unit-test
-[ T{ method-dependency f sequence } ] [ T{ method-dependency f sequence } T{ method-dependency f array } strongest-dependency ] unit-test
diff --git a/core/compiler/units/units.factor b/core/compiler/units/units.factor
index 23e46876fe..78799287f5 100755
--- a/core/compiler/units/units.factor
+++ b/core/compiler/units/units.factor
@@ -1,8 +1,8 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors kernel continuations assocs namespaces
+USING: accessors arrays kernel continuations assocs namespaces
sequences words vocabs definitions hashtables init sets
-math.order classes.algebra ;
+math.order classes classes.algebra ;
IN: compiler.units
SYMBOL: old-definitions
@@ -74,48 +74,50 @@ SYMBOL: outdated-tuples
SYMBOL: update-tuples-hook
: strongest-dependency ( how1 how2 -- how )
- [ called-dependency or ] bi@
- 2dup [ method-dependency? ] both?
- [ [ class>> ] bi@ class-or <method-dependency> ] [ max ] if ;
+ [ called-dependency or ] bi@ max ;
: weakest-dependency ( how1 how2 -- how )
- [ inlined-dependency or ] bi@
- 2dup [ method-dependency? ] both?
- [ [ class>> ] bi@ class-and <method-dependency> ] [ min ] if ;
-
-: relevant-dependency? ( how to -- ? )
- #! Note that an intersection check alone is not enough,
- #! since we're also interested in empty mixins.
- 2dup [ method-dependency? ] both? [
- [ class>> ] bi@
- [ classes-intersect? ] [ class<= ] 2bi or
- ] [ after=? ] if ;
+ [ inlined-dependency or ] bi@ min ;
: compiled-usage ( word -- assoc )
compiled-crossref get at ;
-: (compiled-usages) ( word dependency -- assoc )
+: (compiled-usages) ( word -- assoc )
#! If the word is not flushable anymore, we have to recompile
#! all words which flushable away a call (presumably when the
#! word was still flushable). If the word is flushable, we
#! don't have to recompile words that folded this away.
- [ drop compiled-usage ]
- [
- swap "flushable" word-prop inlined-dependency flushed-dependency ?
- weakest-dependency
- ] 2bi
- [ relevant-dependency? nip ] curry assoc-filter ;
+ [ compiled-usage ]
+ [ "flushable" word-prop inlined-dependency flushed-dependency ? ] bi
+ [ after=? nip ] curry assoc-filter ;
-: compiled-usages ( assoc -- seq )
- clone [
- dup [
- [ (compiled-usages) ] dip swap update
- ] curry assoc-each
- ] keep keys ;
+: compiled-usages ( assoc -- assocs )
+ [ drop word? ] assoc-filter
+ [ [ drop (compiled-usages) ] { } assoc>map ] keep suffix ;
+
+: compiled-generic-usage ( word -- assoc )
+ compiled-generic-crossref get at ;
+
+: (compiled-generic-usages) ( generic class -- assoc )
+ dup class? [
+ [ compiled-generic-usage ] dip
+ [ [ classes-intersect? ] [ null class<= ] bi or nip ]
+ curry assoc-filter
+ ] [ 2drop f ] if ;
+
+: compiled-generic-usages ( assoc -- assocs )
+ [ (compiled-generic-usages) ] { } assoc>map ;
+
+: words-only ( assoc -- assoc' )
+ [ drop word? ] assoc-filter ;
+
+: to-recompile ( -- seq )
+ changed-definitions get compiled-usages
+ changed-generics get compiled-generic-usages
+ append assoc-combine keys ;
: call-recompile-hook ( -- )
- changed-definitions get [ drop word? ] assoc-filter
- compiled-usages recompile-hook get call ;
+ to-recompile recompile-hook get call ;
: call-update-tuples-hook ( -- )
update-tuples-hook get call ;
@@ -134,6 +136,7 @@ SYMBOL: update-tuples-hook
: with-nested-compilation-unit ( quot -- )
[
H{ } clone changed-definitions set
+ H{ } clone changed-generics set
H{ } clone outdated-tuples set
H{ } clone new-classes set
[ finish-compilation-unit ] [ ] cleanup
@@ -142,6 +145,7 @@ SYMBOL: update-tuples-hook
: with-compilation-unit ( quot -- )
[
H{ } clone changed-definitions set
+ H{ } clone changed-generics set
H{ } clone forgotten-definitions set
H{ } clone outdated-tuples set
H{ } clone new-classes set
diff --git a/core/definitions/definitions.factor b/core/definitions/definitions.factor
index 456bb20410..d9e9732488 100755
--- a/core/definitions/definitions.factor
+++ b/core/definitions/definitions.factor
@@ -9,21 +9,15 @@ SINGLETON: inlined-dependency
SINGLETON: flushed-dependency
SINGLETON: called-dependency
-TUPLE: method-dependency class ;
-C: <method-dependency> method-dependency
-
UNION: dependency
inlined-dependency
flushed-dependency
-called-dependency
-method-dependency ;
+called-dependency ;
M: dependency <=>
[
- dup method-dependency? [ drop method-dependency ] when
{
called-dependency
- method-dependency
flushed-dependency
inlined-dependency
} index
@@ -31,8 +25,14 @@ M: dependency <=>
SYMBOL: changed-definitions
-: changed-definition ( defspec how -- )
- swap changed-definitions get
+: changed-definition ( defspec -- )
+ inlined-dependency swap changed-definitions get
+ [ set-at ] [ no-compilation-unit ] if* ;
+
+SYMBOL: changed-generics
+
+: changed-generic ( class generic -- )
+ changed-generics get
[ set-at ] [ no-compilation-unit ] if* ;
SYMBOL: new-classes
diff --git a/core/generic/generic.factor b/core/generic/generic.factor
index ac7afe58fa..553ced5800 100755
--- a/core/generic/generic.factor
+++ b/core/generic/generic.factor
@@ -53,21 +53,12 @@ GENERIC: next-method-quot* ( class generic combination -- quot )
TUPLE: check-method class generic ;
: check-method ( class generic -- class generic )
- over class? over generic? and [
+ 2dup [ class? ] [ generic? ] bi* and [
\ check-method boa throw
] unless ; inline
-: affected-methods ( class generic -- seq )
- "methods" word-prop swap
- [ nip [ classes-intersect? ] [ class<= ] 2bi or ] curry assoc-filter
- values ;
-
-: update-generic ( class generic -- )
- [ affected-methods ] [ drop <method-dependency> ] 2bi
- [ changed-definition ] curry each ;
-
: with-methods ( class generic quot -- )
- [ drop update-generic ]
+ [ drop changed-generic ]
[ [ "methods" word-prop ] dip call ]
[ drop make-generic drop ]
3tri ; inline
@@ -167,7 +158,7 @@ M: method-body smart-usage
M: sequence update-methods ( class seq -- )
implementors [
- [ update-generic ] [ make-generic drop ] 2bi
+ [ changed-generic ] [ make-generic drop ] 2bi
] with each ;
: define-generic ( word combination -- )
diff --git a/core/words/words.factor b/core/words/words.factor
index 19e3915b04..5627a1a015 100755
--- a/core/words/words.factor
+++ b/core/words/words.factor
@@ -101,45 +101,79 @@ SYMBOL: compiled-crossref
compiled-crossref global [ H{ } assoc-like ] change-at
-: compiled-xref ( word dependencies -- )
- [ drop crossref? ] assoc-filter
- [ "compiled-uses" set-word-prop ]
- [ compiled-crossref get add-vertex* ]
- 2bi ;
+SYMBOL: compiled-generic-crossref
+
+compiled-generic-crossref global [ H{ } assoc-like ] change-at
+
+: (compiled-xref) ( word dependencies word-prop variable -- )
+ [ [ set-word-prop ] curry ]
+ [ [ get add-vertex* ] curry ]
+ bi* 2bi ;
+
+: compiled-xref ( word dependencies generic-dependencies -- )
+ [ [ drop crossref? ] assoc-filter ] bi@
+ [ over ] dip
+ [ "compiled-uses" compiled-crossref (compiled-xref) ]
+ [ "compiled-generic-uses" compiled-generic-crossref (compiled-xref) ]
+ 2bi* ;
+
+: (compiled-unxref) ( word word-prop variable -- )
+ [ [ [ dupd word-prop ] dip get remove-vertex* ] 2curry ]
+ [ drop [ f swap set-word-prop ] curry ]
+ 2bi bi ;
: compiled-unxref ( word -- )
- [
- dup "compiled-uses" word-prop
- compiled-crossref get remove-vertex*
- ]
- [ f "compiled-uses" set-word-prop ] bi ;
+ [ "compiled-uses" compiled-crossref (compiled-unxref) ]
+ [ "compiled-generic-uses" compiled-generic-crossref (compiled-unxref) ]
+ bi ;
: delete-compiled-xref ( word -- )
- dup compiled-unxref
- compiled-crossref get delete-at ;
+ [ compiled-unxref ]
+ [ compiled-crossref get delete-at ]
+ [ compiled-generic-crossref get delete-at ]
+ tri ;
-GENERIC: redefined ( word -- )
+GENERIC: inline? ( word -- ? )
-M: object redefined drop ;
+M: word inline? "inline" word-prop ;
+
+SYMBOL: visited
+
+: reset-on-redefine { "inferred-effect" "cannot-infer" } ; inline
+
+: (redefined) ( word -- )
+ dup visited get key? [ drop ] [
+ [ reset-on-redefine reset-props ]
+ [ visited get conjoin ]
+ [
+ crossref get at keys
+ [ word? ] filter
+ [
+ [ reset-on-redefine [ word-prop ] with contains? ]
+ [ inline? ]
+ bi or
+ ] filter
+ [ (redefined) ] each
+ ] tri
+ ] if ;
+
+: redefined ( word -- )
+ [ H{ } clone visited [ (redefined) ] with-variable ]
+ [ changed-definition ]
+ bi ;
: define ( word def -- )
[ ] like
over unxref
over redefined
>>def
- dup inlined-dependency changed-definition
dup crossref? [ dup xref ] when drop ;
: set-stack-effect ( effect word -- )
2dup "declared-effect" word-prop = [ 2drop ] [
swap
[ "declared-effect" set-word-prop ]
- [
- drop
- dup primitive? [ drop ] [
- [ redefined ] [ inlined-dependency changed-definition ] bi
- ] if
- ] 2bi
+ [ drop dup primitive? [ dup redefined ] unless drop ] 2bi
] if ;
: define-declared ( word def effect -- )
@@ -211,10 +245,6 @@ ERROR: bad-create name vocab ;
: constructor-word ( name vocab -- word )
>r "<" swap ">" 3append r> create ;
-GENERIC: inline? ( word -- ? )
-
-M: word inline? "inline" word-prop ;
-
PREDICATE: parsing-word < word "parsing" word-prop ;
: delimiter? ( obj -- ? )