1 ! Copyright (C) 2008 Slava Pestov.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: accessors arrays kernel continuations assocs namespaces
4 sequences words vocabs definitions hashtables init sets
5 math math.order classes classes.algebra ;
8 SYMBOL: old-definitions
9 SYMBOL: new-definitions
11 TUPLE: redefine-error def ;
13 : redefine-error ( definition -- )
15 { { "Continue" t } } throw-restarts drop ;
17 : add-once ( key assoc -- )
18 2dup key? [ over redefine-error ] when conjoin ;
20 : (remember-definition) ( definition loc assoc -- )
21 >r over set-where r> add-once ;
23 : remember-definition ( definition loc -- )
24 new-definitions get first (remember-definition) ;
26 : remember-class ( class loc -- )
27 over new-definitions get first key? [ dup redefine-error ] when
28 new-definitions get second (remember-definition) ;
30 : forward-reference? ( word -- ? )
31 dup old-definitions get assoc-stack
32 [ new-definitions get assoc-stack not ]
35 SYMBOL: recompile-hook
37 : <definitions> ( -- pair ) { H{ } H{ } } [ clone ] map ;
39 SYMBOL: definition-observers
41 GENERIC: definitions-changed ( assoc obj -- )
43 [ V{ } clone definition-observers set-global ]
44 "compiler.units" add-init-hook
46 : add-definition-observer ( obj -- )
47 definition-observers get push ;
49 : remove-definition-observer ( obj -- )
50 definition-observers get delete ;
52 : notify-definition-observers ( assoc -- )
53 definition-observers get
54 [ definitions-changed ] with each ;
56 : changed-vocabs ( assoc -- vocabs )
57 [ drop word? ] assoc-filter
58 [ drop vocabulary>> dup [ vocab ] when dup ] assoc-map ;
60 : updated-definitions ( -- assoc )
62 dup forgotten-definitions get update
63 dup new-definitions get first update
64 dup new-definitions get second update
65 dup changed-definitions get update
66 dup dup changed-vocabs update ;
68 : compile ( words -- )
69 recompile-hook get call
70 dup [ drop crossref? ] assoc-contains?
73 SYMBOL: outdated-tuples
74 SYMBOL: update-tuples-hook
76 : dependency>= ( how1 how2 -- ? )
85 : strongest-dependency ( how1 how2 -- how )
86 [ called-dependency or ] bi@ [ dependency>= ] most ;
88 : weakest-dependency ( how1 how2 -- how )
89 [ inlined-dependency or ] bi@ [ dependency>= not ] most ;
91 : compiled-usage ( word -- assoc )
92 compiled-crossref get at ;
94 : (compiled-usages) ( word -- assoc )
95 #! If the word is not flushable anymore, we have to recompile
96 #! all words which flushable away a call (presumably when the
97 #! word was still flushable). If the word is flushable, we
98 #! don't have to recompile words that folded this away.
100 [ "flushable" word-prop inlined-dependency flushed-dependency ? ] bi
101 [ dependency>= nip ] curry assoc-filter ;
103 : compiled-usages ( assoc -- assocs )
104 [ drop word? ] assoc-filter
105 [ [ drop (compiled-usages) ] { } assoc>map ] keep suffix ;
107 : compiled-generic-usage ( word -- assoc )
108 compiled-generic-crossref get at ;
110 : (compiled-generic-usages) ( generic class -- assoc )
112 [ compiled-generic-usage ] dip
113 [ classes-intersect? nip ] curry assoc-filter
116 : compiled-generic-usages ( assoc -- assocs )
117 [ (compiled-generic-usages) ] { } assoc>map ;
119 : words-only ( assoc -- assoc' )
120 [ drop word? ] assoc-filter ;
122 : to-recompile ( -- seq )
123 changed-definitions get compiled-usages
124 changed-generics get compiled-generic-usages
125 append assoc-combine keys ;
127 : call-recompile-hook ( -- )
128 to-recompile recompile-hook get call ;
130 : call-update-tuples-hook ( -- )
131 update-tuples-hook get call ;
133 : unxref-forgotten-definitions ( -- )
134 forgotten-definitions get
135 keys [ word? ] filter
136 [ delete-compiled-xref ] each ;
138 : finish-compilation-unit ( -- )
140 call-update-tuples-hook
141 unxref-forgotten-definitions
142 dup [ drop crossref? ] assoc-contains? modify-code-heap ;
144 : with-nested-compilation-unit ( quot -- )
146 H{ } clone changed-definitions set
147 H{ } clone changed-generics set
148 H{ } clone outdated-tuples set
149 H{ } clone new-classes set
150 [ finish-compilation-unit ] [ ] cleanup
151 ] with-scope ; inline
153 : with-compilation-unit ( quot -- )
155 H{ } clone changed-definitions set
156 H{ } clone changed-generics set
157 H{ } clone forgotten-definitions set
158 H{ } clone outdated-tuples set
159 H{ } clone new-classes set
160 <definitions> new-definitions set
161 <definitions> old-definitions set
163 finish-compilation-unit
165 notify-definition-observers
167 ] with-scope ; inline
169 : compile-call ( quot -- )
170 [ define-temp ] with-compilation-unit execute ;
172 : default-recompile-hook ( words -- alist )
173 [ f ] { } map>assoc ;
175 recompile-hook global
176 [ [ default-recompile-hook ] or ]