USING: accessors kernel namespaces arrays sequences io words fry
continuations vocabs assocs dlists definitions math graphs generic
generic.single combinators deques search-deques macros
-source-files.errors combinators.short-circuit
+source-files.errors combinators.short-circuit classes.algebra
stack-checker stack-checker.dependencies stack-checker.inlining
stack-checker.errors
-compiler.errors compiler.units compiler.utilities
+compiler.errors compiler.units compiler.utilities compiler.crossref
compiler.tree.builder
compiler.tree.optimizer
-compiler.crossref
-
compiler.cfg
compiler.cfg.builder
compiler.cfg.optimizer
SINGLETON: optimizing-compiler
+M: optimizing-compiler update-call-sites ( class generic -- words )
+ #! Words containing call sites with inferred type 'class'
+ #! which inlined a method on 'generic'
+ compiled-generic-usage swap
+ '[ nip _ classes-intersect? ] assoc-filter keys ;
+
M: optimizing-compiler recompile ( words -- alist )
[
<hashed-dlist> compile-queue set
"--- compile done" compiler-message ;
M: optimizing-compiler to-recompile ( -- words )
- changed-definitions get compiled-usages
- changed-generics get compiled-generic-usages
- append assoc-combine keys ;
+ changed-definitions get compiled-usages assoc-combine keys ;
M: optimizing-compiler process-forgotten-words
[ delete-compiled-xref ] each ;
-! Copyright (C) 2009 Slava Pestov.
+! Copyright (C) 2009, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: assocs classes.algebra compiler.units definitions graphs
grouping kernel namespaces sequences words
: compiled-generic-usage ( word -- assoc )
compiled-generic-crossref get at ;
-: (compiled-generic-usages) ( generic class -- assoc )
- [ compiled-generic-usage ] dip
- [
- 2dup [ valid-class? ] both?
- [ classes-intersect? ] [ 2drop f ] if nip
- ] curry assoc-filter ;
-
-: compiled-generic-usages ( assoc -- assocs )
- [ (compiled-generic-usages) ] { } assoc>map ;
-
: (compiled-xref) ( word dependencies word-prop variable -- )
[ [ concat ] dip set-word-prop ] [ get add-vertex* ] bi-curry* 2bi ;
-! Copyright (C) 2004, 2009 Slava Pestov.
+! Copyright (C) 2004, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays definitions assocs kernel kernel.private
slots.private namespaces make sequences strings words words.symbol
dup deferred? [ define-symbol ] [ drop ] if ;
: (define-class) ( word props -- )
+ reset-caches
+ [ drop update-map- ]
[
- {
- [ dup class? [ drop ] [ [ implementors-map+ ] [ new-class ] bi ] if ]
- [ reset-class ]
- [ ?define-symbol ]
- [ changed-definition ]
- [ ]
- } cleave
- ] dip [ assoc-union ] curry change-props
- dup predicate-word
- [ 1quotation "predicate" set-word-prop ]
- [ swap "predicating" set-word-prop ]
- [ drop t "class" set-word-prop ]
+ [
+ {
+ [ dup class? [ drop ] [ implementors-map+ ] if ]
+ [ reset-class ]
+ [ ?define-symbol ]
+ [ ]
+ } cleave
+ ] dip [ assoc-union ] curry change-props
+ dup predicate-word
+ [ 1quotation "predicate" set-word-prop ]
+ [ swap "predicating" set-word-prop ]
+ [ drop t "class" set-word-prop ]
+ 2tri
+ ]
+ [ drop update-map+ ]
2tri ;
PRIVATE>
[ nip [ update-class ] each ] [ update-methods ] 2bi ;
: define-class ( word superclass members participants metaclass -- )
- #! If it was already a class, update methods after.
- reset-caches
- make-class-props
- [ drop update-map- ]
- [ (define-class) ]
- [ drop update-map+ ]
- 2tri ;
+ make-class-props [ (define-class) ] [ drop changed-definition ] 2bi ;
: forget-predicate ( class -- )
dup "predicate" word-prop
dup mixin-class? [
drop
] [
- [ { } redefine-mixin-class ]
- [ H{ } clone "instances" set-word-prop ]
- [ update-classes ]
- tri
+ {
+ [ { } redefine-mixin-class ]
+ [ H{ } clone "instances" set-word-prop ]
+ [ changed-definition ]
+ [ update-classes ]
+ } cleave
] if ;
TUPLE: check-mixin-class class ;
[ [ members swap bootstrap-word ] dip call ] [ drop ] 2bi
swap redefine-mixin-class ; inline
-: update-mixin-class ( member mixin -- )
- class-usages
- [ update-methods ]
- [ [ update-class ] each ]
- [ implementors [ remake-generic ] each ]
- tri ;
-
: (add-mixin-instance) ( class mixin -- )
- [ [ suffix ] change-mixin-class ]
- [ [ f ] 2dip "instances" word-prop set-at ]
- [ update-mixin-class ]
- 2tri ;
+ #! Call update-methods before adding the member:
+ #! - Call sites of generics specializing on 'mixin'
+ #! where the inferred type is 'class' are updated,
+ #! - Call sites where the inferred type is a subtype
+ #! of 'mixin' disjoint from 'class' are not updated
+ dup class-usages {
+ [ nip update-methods ]
+ [ drop [ suffix ] change-mixin-class ]
+ [ drop [ f ] 2dip "instances" word-prop set-at ]
+ [ 2nip [ update-class ] each ]
+ } 3cleave ;
GENERIC# add-mixin-instance 1 ( class mixin -- )
[ 2drop ] [ (add-mixin-instance) ] if-mixin-member? ;
: (remove-mixin-instance) ( class mixin -- )
- [ [ swap remove ] change-mixin-class ]
- [ "instances" word-prop delete-at ]
- [ update-mixin-class ]
- 2tri ;
+ #! Call update-methods after removing the member:
+ #! - Call sites of generics specializing on 'mixin'
+ #! where the inferred type is 'class' are updated,
+ #! - Call sites where the inferred type is a subtype
+ #! of 'mixin' disjoint from 'class' are not updated
+ dup class-usages {
+ [ drop [ swap remove ] change-mixin-class ]
+ [ drop "instances" word-prop delete-at ]
+ [ 2nip [ update-class ] each ]
+ [ nip update-methods ]
+ } 3cleave ;
: remove-mixin-instance ( class mixin -- )
- #! The order of the three clauses is important here. The last
- #! one must come after the other two so that the entries it
- #! adds to changed-generics are not overwritten.
[ (remove-mixin-instance) ] [ 2drop ] if-mixin-member? ;
M: mixin-class class-forgotten remove-mixin-instance ;
! Copyright (C) 2004, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: words sequences kernel assocs combinators classes
-classes.algebra classes.algebra.private namespaces arrays math
-quotations ;
+classes.private classes.algebra classes.algebra.private
+namespaces arrays math quotations definitions ;
IN: classes.union
PREDICATE: union-class < class
M: union-class update-class define-union-predicate ;
: (define-union-class) ( class members -- )
- f swap f union-class define-class ;
+ f swap f union-class make-class-props (define-class) ;
PRIVATE>
: define-union-class ( class members -- )
- [ (define-union-class) ] [ drop update-classes ] 2bi ;
+ [ (define-union-class) ]
+ [ drop changed-definition ]
+ [ drop update-classes ]
+ 2tri ;
M: union-class rank-class drop 2 ;
-! Copyright (C) 2008, 2009 Slava Pestov.
+! Copyright (C) 2008, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays kernel continuations assocs namespaces
sequences words vocabs definitions hashtables init sets
SYMBOL: compiler-impl
+HOOK: update-call-sites compiler-impl ( class generic -- words )
+
+M: generic update-generic ( class generic -- )
+ [ update-call-sites [ changed-definition ] each ]
+ [ remake-generic drop ]
+ 2bi ;
+
+M: sequence update-methods ( class seq -- )
+ implementors [ update-generic ] with each ;
+
HOOK: recompile compiler-impl ( words -- alist )
HOOK: to-recompile compiler-impl ( -- words )
: compile ( words -- ) recompile modify-code-heap ;
! Non-optimizing compiler
-M: f recompile
- [ dup def>> ] { } map>assoc ;
+M: f update-call-sites
+ 2drop { } ;
M: f to-recompile
- changed-definitions get [ drop word? ] assoc-filter
- changed-generics get assoc-union keys ;
+ changed-definitions get [ drop word? ] assoc-filter keys ;
+
+M: f recompile
+ [ dup def>> ] { } map>assoc ;
M: f process-forgotten-words drop ;
: with-nested-compilation-unit ( quot -- )
[
H{ } clone changed-definitions set
- H{ } clone changed-generics set
H{ } clone changed-effects set
H{ } clone outdated-generics set
H{ } clone outdated-tuples set
H{ } clone new-words set
- H{ } clone new-classes set
[ finish-compilation-unit ] [ ] cleanup
] with-scope ; inline
: with-compilation-unit ( quot -- )
[
H{ } clone changed-definitions set
- H{ } clone changed-generics set
H{ } clone changed-effects set
H{ } clone outdated-generics set
H{ } clone forgotten-definitions set
H{ } clone outdated-tuples set
H{ } clone new-words set
- H{ } clone new-classes set
<definitions> new-definitions set
<definitions> old-definitions set
[ finish-compilation-unit ] [ ] cleanup
-! Copyright (C) 2006, 2009 Slava Pestov.
+! Copyright (C) 2006, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel sequences namespaces assocs math accessors ;
IN: definitions
SYMBOL: changed-effects
-SYMBOL: changed-generics
-
SYMBOL: outdated-generics
SYMBOL: new-words
-SYMBOL: new-classes
-
: new-word ( word -- )
dup new-words get set-in-unit ;
: new-word? ( word -- ? )
new-words get key? ;
-: new-class ( word -- )
- dup new-classes get set-in-unit ;
-
-: new-class? ( word -- ? )
- new-classes get key? ;
-
GENERIC: where ( defspec -- loc )
M: object where drop f ;
\ check-method boa throw
] unless ; inline
-: changed-generic ( class generic -- )
- changed-generics get
- [ [ [ class-or ] when* ] change-at ] [ no-compilation-unit ] if* ;
-
: remake-generic ( generic -- )
dup outdated-generics get set-in-unit ;
: remake-generics ( -- )
outdated-generics get keys [ generic? ] filter [ make-generic ] each ;
+GENERIC: update-generic ( class generic -- )
+
: with-methods ( class generic quot -- )
- [ drop changed-generic ]
- [ [ "methods" word-prop ] dip call ]
- [ drop remake-generic drop ]
- 3tri ; inline
+ [ "methods" word-prop ] prepose [ update-generic ] 2bi ; inline
: method-word-name ( class generic -- string )
[ name>> ] bi@ "=>" glue ;
[ call-next-method ] bi
] if ;
-M: sequence update-methods ( class seq -- )
- implementors [
- [ changed-generic ] [ remake-generic drop ] 2bi
- ] with each ;
-
: define-generic ( word combination effect -- )
[ nip swap set-stack-effect ]
[
projects / factor.git / commitdiff