1 ! Copyright (C) 2008, 2009 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 classes.tuple
6 classes.tuple.private generic source-files.errors ;
9 SYMBOL: old-definitions
10 SYMBOL: new-definitions
12 TUPLE: redefine-error def ;
14 : redefine-error ( definition -- )
16 { { "Continue" t } } throw-restarts drop ;
18 : add-once ( key assoc -- )
19 2dup key? [ over redefine-error ] when conjoin ;
21 : (remember-definition) ( definition loc assoc -- )
22 [ over set-where ] dip add-once ;
24 : remember-definition ( definition loc -- )
25 new-definitions get first (remember-definition) ;
27 : fake-definition ( definition -- )
28 old-definitions get [ delete-at ] with each ;
30 : remember-class ( class loc -- )
31 [ dup new-definitions get first key? [ dup redefine-error ] when ] dip
32 new-definitions get second (remember-definition) ;
34 : forward-reference? ( word -- ? )
35 dup old-definitions get assoc-stack
36 [ new-definitions get assoc-stack not ]
41 HOOK: recompile compiler-impl ( words -- alist )
43 ! Non-optimizing compiler
44 M: f recompile [ dup def>> ] { } map>assoc ;
46 : without-optimizer ( quot -- )
47 [ f compiler-impl ] dip with-variable ; inline
49 ! Trivial compiler. We don't want to touch the code heap
50 ! during stage1 bootstrap, it would just waste time.
51 SINGLETON: dummy-compiler
53 M: dummy-compiler recompile drop { } ;
55 : <definitions> ( -- pair ) { H{ } H{ } } [ clone ] map ;
57 SYMBOL: definition-observers
59 GENERIC: definitions-changed ( assoc obj -- )
61 [ V{ } clone definition-observers set-global ]
62 "compiler.units" add-startup-hook
64 ! This goes here because vocabs cannot depend on init
65 [ V{ } clone vocab-observers set-global ]
66 "vocabs" add-startup-hook
68 : add-definition-observer ( obj -- )
69 definition-observers get push ;
71 : remove-definition-observer ( obj -- )
72 definition-observers get delq ;
74 : notify-definition-observers ( assoc -- )
75 definition-observers get
76 [ definitions-changed ] with each ;
78 : changed-vocabs ( assoc -- vocabs )
79 [ drop word? ] assoc-filter
80 [ drop vocabulary>> dup [ vocab ] when dup ] assoc-map ;
82 : updated-definitions ( -- assoc )
84 dup forgotten-definitions get update
85 dup new-definitions get first update
86 dup new-definitions get second update
87 dup changed-definitions get update
88 dup dup changed-vocabs update ;
90 : compile ( words -- ) recompile modify-code-heap ;
92 : index>= ( obj1 obj2 seq -- ? )
93 [ index ] curry bi@ >= ;
95 : dependency>= ( how1 how2 -- ? )
96 { called-dependency flushed-dependency inlined-dependency }
99 : strongest-dependency ( how1 how2 -- how )
100 [ called-dependency or ] bi@ [ dependency>= ] most ;
102 : weakest-dependency ( how1 how2 -- how )
103 [ inlined-dependency or ] bi@ [ dependency>= not ] most ;
105 : compiled-usage ( word -- assoc )
106 compiled-crossref get at ;
108 : (compiled-usages) ( word -- assoc )
109 #! If the word is not flushable anymore, we have to recompile
110 #! all words which flushable away a call (presumably when the
111 #! word was still flushable). If the word is flushable, we
112 #! don't have to recompile words that folded this away.
114 [ "flushable" word-prop inlined-dependency flushed-dependency ? ] bi
115 [ dependency>= nip ] curry assoc-filter ;
117 : compiled-usages ( assoc -- assocs )
118 [ drop word? ] assoc-filter
119 [ [ drop (compiled-usages) ] { } assoc>map ] keep suffix ;
121 : compiled-generic-usage ( word -- assoc )
122 compiled-generic-crossref get at ;
124 : (compiled-generic-usages) ( generic class -- assoc )
125 [ compiled-generic-usage ] dip
127 2dup [ valid-class? ] both?
128 [ classes-intersect? ] [ 2drop f ] if nip
129 ] curry assoc-filter ;
131 : compiled-generic-usages ( assoc -- assocs )
132 [ (compiled-generic-usages) ] { } assoc>map ;
134 : words-only ( assoc -- assoc' )
135 [ drop word? ] assoc-filter ;
137 : to-recompile ( -- seq )
138 changed-definitions get compiled-usages
139 changed-generics get compiled-generic-usages
140 append assoc-combine keys ;
142 : process-forgotten-definitions ( -- )
143 forgotten-definitions get keys
144 [ [ word? ] filter [ delete-compiled-xref ] each ]
145 [ [ delete-definition-errors ] each ]
148 : finish-compilation-unit ( -- )
150 to-recompile recompile
152 process-forgotten-definitions
154 updated-definitions dup assoc-empty?
155 [ drop ] [ notify-definition-observers notify-error-observers ] if ;
157 : with-nested-compilation-unit ( quot -- )
159 H{ } clone changed-definitions set
160 H{ } clone changed-generics set
161 H{ } clone changed-effects set
162 H{ } clone outdated-generics set
163 H{ } clone outdated-tuples set
164 H{ } clone new-classes set
165 [ finish-compilation-unit ] [ ] cleanup
166 ] with-scope ; inline
168 : with-compilation-unit ( quot -- )
170 H{ } clone changed-definitions set
171 H{ } clone changed-generics set
172 H{ } clone changed-effects set
173 H{ } clone outdated-generics set
174 H{ } clone forgotten-definitions set
175 H{ } clone outdated-tuples set
176 H{ } clone new-classes set
177 <definitions> new-definitions set
178 <definitions> old-definitions set
179 [ finish-compilation-unit ] [ ] cleanup
180 ] with-scope ; inline