Home My Page Projects Code Snippets Project Openings SML/NJ
Summary Activity Forums Tracker Lists Tasks Docs Surveys News SCM Files

SCM Repository

[smlnj] Annotation of /sml/trunk/cm/compile/link.sml
ViewVC logotype

Annotation of /sml/trunk/cm/compile/link.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 2934 - (view) (download)

1 : blume 402 (*
2 :     * Link traversals.
3 :     * - manages shared state
4 :     *
5 :     * (C) 1999 Lucent Technologies, Bell Laboratories
6 :     *
7 :     * Author: Matthias Blume (blume@kurims.kyoto-u.ac.jp)
8 :     *)
9 : blume 399 local
10 :     structure GP = GeneralParams
11 :     structure DG = DependencyGraph
12 :     structure GG = GroupGraph
13 :     structure DE = DynamicEnv
14 : blume 879 structure EM = ErrorMsg
15 : dbm 2492 structure PP = PrettyPrintNew
16 : blume 399
17 : blume 905 type env = DynamicEnv.env
18 : blume 737 type posmap = env IntMap.map
19 : blume 399 in
20 :     signature LINK = sig
21 : blume 403
22 :     type bfc
23 :     type bfcGetter = SmlInfo.info -> bfc
24 :    
25 : blume 399 (* Evict value from cache if it exists *)
26 : blume 400 val evict : GP.info -> SmlInfo.info -> unit
27 : blume 399
28 : blume 537 val evictStale : unit -> unit
29 :    
30 : blume 399 (* Check all values and evict those that depended on other
31 :     * meanwhile evicted ones. *)
32 : blume 400 val cleanup : GP.info -> unit
33 : blume 399
34 : blume 403 val newTraversal : GG.group * bfcGetter ->
35 : blume 399 { group: GP.info -> env option,
36 :     exports: (GP.info -> env option) SymbolMap.map }
37 :    
38 :     (* discard persistent state *)
39 :     val reset : unit -> unit
40 : blume 632
41 :     (* discard persistent state for a specific stable library *)
42 : blume 666 val unshare : SrcPath.file -> unit
43 : blume 399 end
44 :    
45 : blume 879 functor LinkFn (structure BFC : BFC where type bfc = Binfile.bfContents
46 : blume 737 val system_values : posmap SrcPathMap.map ref) :>
47 :     LINK where type bfc = BFC.bfc =
48 : blume 403 struct
49 : blume 399
50 : blume 573 exception Link of exn
51 :    
52 : blume 879 structure BF = Binfile
53 : mblume 1448 structure EX = Execute
54 : blume 399
55 : blume 879 type bfc = BF.bfContents
56 : blume 403 type bfcGetter = SmlInfo.info -> bfc
57 :    
58 : blume 905 type bfun = GP.info -> env -> env
59 : blume 399
60 :     datatype bnode =
61 : blume 400 B of bfun * BinInfo.info * bnode list
62 : blume 399
63 :     val stablemap = ref (StableMap.empty: bnode StableMap.map)
64 :    
65 : blume 905 type smemo = env * SmlInfo.info list
66 : blume 400
67 :     val smlmap = ref (SmlInfoMap.empty: smemo SmlInfoMap.map)
68 :    
69 : blume 905 val emptyStatic = StaticEnv.empty
70 :     val emptyDyn = DynamicEnv.empty
71 : blume 569
72 : blume 400 fun evict gp i = let
73 :     fun check () =
74 :     case SmlInfo.sh_mode i of
75 :     Sharing.SHARE true =>
76 :     SmlInfo.error gp i EM.WARN
77 : blume 735 (concat ["sharing for ", SmlInfo.descr i,
78 : blume 569 " may be lost"])
79 :     EM.nullErrorBody
80 : blume 400 | _ => ()
81 :     in
82 :     (smlmap := #1 (SmlInfoMap.remove (!smlmap, i))
83 :     before check ())
84 :     handle LibBase.NotFound => ()
85 :     end
86 :    
87 : blume 537 fun evictStale () =
88 :     smlmap := SmlInfoMap.filteri (SmlInfo.isKnown o #1) (!smlmap)
89 :    
90 : blume 400 fun cleanup gp = let
91 :     val visited = ref SmlInfoSet.empty
92 :     fun visit i =
93 :     if SmlInfoSet.member (!visited, i) then true
94 :     else
95 :     case SmlInfoMap.find (!smlmap, i) of
96 :     NONE => false
97 :     | SOME (_, l) => let
98 :     val bl = map visit l
99 :     val b = List.all (fn x => x) bl
100 :     in
101 :     if b then
102 :     (visited := SmlInfoSet.add (!visited, i);
103 :     true)
104 :     else (evict gp i; false)
105 :     end
106 :     in
107 : mblume 1446 app (ignore o visit o #1) (SmlInfoMap.listItemsi (!smlmap))
108 : blume 400 end
109 :    
110 : blume 652 fun newTraversal0 (GG.ERRORGROUP, _) =
111 : blume 587 { group = fn _ => NONE, exports = SymbolMap.empty }
112 : blume 652 | newTraversal0 (group as GG.GROUP grec, getBFC) = let
113 : blume 400
114 : blume 587 val { exports, grouppath, ... } = grec
115 : blume 569
116 :     fun exn_err (msg, error, descr, exn) = let
117 :     fun ppb pps =
118 : macqueen 1344 (PP.newline pps;
119 :     PP.string pps (General.exnMessage exn);
120 : blume 2934 app (fn s => PP.string pps (s ^ "\n"))
121 :     (SMLofNJ.exnHistory exn);
122 : macqueen 1344 PP.newline pps)
123 : blume 400 in
124 : blume 569 error (concat [msg, " ", descr]) ppb;
125 : blume 573 raise Link exn
126 : blume 569 end
127 : blume 400
128 : blume 737 fun link_stable (i, de) = let
129 : blume 569 val stable = BinInfo.stablename i
130 :     val os = BinInfo.offset i
131 :     val descr = BinInfo.describe i
132 :     val error = BinInfo.error i EM.COMPLAIN
133 :     val bfc = BFC.getStable { stable = stable, offset = os,
134 :     descr = descr }
135 :     handle exn => exn_err ("unable to load library module",
136 :     error, descr, exn)
137 :     in
138 : mblume 1448 BF.exec (bfc, de, Link)
139 :     handle Link exn =>
140 : blume 569 exn_err ("link-time exception in library code",
141 :     error, descr, exn)
142 :     end
143 :    
144 :     fun link_sml (gp, i, getBFC, getE, snl) = let
145 :     fun fresh () = let
146 :     val bfc = getBFC i
147 :     in
148 :     case getE gp of
149 :     NONE => NONE
150 :     | SOME e =>
151 : mblume 1448 (SOME (BF.exec (bfc, e, Link))
152 :     handle Link exn =>
153 : blume 569 exn_err ("link-time exception in user program",
154 :     SmlInfo.error gp i EM.COMPLAIN,
155 :     SmlInfo.descr i,
156 :     exn))
157 : blume 573 end handle exn as Link _ => raise exn
158 :     | _ => NONE
159 : blume 569 in
160 :     case SmlInfo.sh_mode i of
161 :     Sharing.SHARE _ =>
162 :     (case SmlInfoMap.find (!smlmap, i) of
163 :     NONE =>
164 :     (case fresh () of
165 :     NONE => NONE
166 :     | SOME de => let
167 :     val m = (de, snl)
168 :     in
169 :     smlmap :=
170 :     SmlInfoMap.insert (!smlmap, i, m);
171 :     SOME de
172 :     end)
173 :     | SOME (de, _) => SOME de)
174 :     | Sharing.DONTSHARE => (evict gp i; fresh ())
175 :     end
176 :    
177 : blume 399 val visited = ref SrcPathSet.empty
178 : blume 569
179 : blume 587 fun registerGroup GG.ERRORGROUP = ()
180 :     | registerGroup (g as GG.GROUP grec) = let
181 :     val { grouppath, kind, sublibs, ... } = grec
182 : blume 737 fun registerSublib NONE = ()
183 :     | registerSublib (SOME i) =
184 :     registerGroup (#2 (List.nth (sublibs, i)) ())
185 : blume 587 fun registerStableLib GG.ERRORGROUP = ()
186 :     | registerStableLib (GG.GROUP sg) = let
187 :     val { exports, grouppath = sgp, ... } = sg
188 : blume 737 val posmap =
189 :     let val (m', pm) =
190 : blume 587 SrcPathMap.remove (!system_values, sgp)
191 : blume 737 in system_values := m'; pm
192 :     end handle LibBase.NotFound => IntMap.empty
193 : blume 569
194 : blume 587 val localmap = ref StableMap.empty
195 :     fun bn (DG.BNODE n) = let
196 :     val i = #bininfo n
197 :     val li = #localimports n
198 :     val gi = #globalimports n
199 : blume 737 fun mySysval () =
200 :     IntMap.find (posmap, BinInfo.offset i)
201 : blume 587
202 : blume 737 fun new () =
203 :     case mySysval () of
204 :     (* We short-circuit traversal
205 :     * construction (and the resulting
206 :     * traversal) whenever we find a
207 :     * node whose dynamic value was
208 :     * created at bootstrap time.
209 :     * This assumes that anything in
210 :     * sysval can be shared -- which
211 :     * is enforced by the way the
212 :     * PIDMAP file is constructed. *)
213 :     SOME e => (fn gp => fn _ => e, NONE)
214 :     | NONE => let
215 :     val e0 = (fn _ => emptyDyn, [])
216 :     fun join ((f, NONE), (e, l)) =
217 :     (fn gp =>
218 :     DE.atop (f gp emptyDyn,
219 :     e gp),
220 :     l)
221 :     | join ((f, SOME (i, l')),
222 :     (e, l)) =
223 :     (e, B (f, i, l') :: l)
224 :     val ge =
225 :     foldl join e0 (map lfbn gi)
226 :     val le = foldl join ge (map bn li)
227 : blume 587 in
228 : blume 737 case (BinInfo.sh_mode i, le) of
229 :     (Sharing.SHARE _, (e, [])) =>
230 :     let fun thunk gp =
231 :     link_stable (i, e gp)
232 :     val m_thunk =
233 :     Memoize.memoize thunk
234 :     in
235 :     (fn gp => fn _ =>
236 :     m_thunk gp,
237 :     NONE)
238 :     end
239 :     | (Sharing.SHARE _, _) =>
240 :     EM.impossible
241 :     "Link: sh_mode inconsistent"
242 :     | (Sharing.DONTSHARE, (e, l)) =>
243 :     (fn gp => fn e' =>
244 :     link_stable
245 :     (i, DE.atop (e', e gp)),
246 :     SOME (i, l))
247 : blume 587 end
248 :     in
249 :     case StableMap.find (!stablemap, i) of
250 :     SOME (B (f, i, [])) =>
251 :     (case BinInfo.sh_mode i of
252 :     Sharing.DONTSHARE => (f, SOME (i, []))
253 :     | _ => (f, NONE))
254 :     | SOME (B (f, i, l)) => (f, SOME (i, l))
255 :     | NONE =>
256 :     (case StableMap.find (!localmap, i) of
257 : blume 569 SOME x => x
258 : blume 587 | NONE => let
259 :     val x = new ()
260 :     in
261 :     localmap := StableMap.insert
262 :     (!localmap, i, x);
263 :     x
264 : blume 569 end)
265 : blume 587 end
266 : blume 399
267 : blume 737 and fbn (_, n, p) = (registerSublib p; bn n)
268 : blume 399
269 : blume 715 and lfbn th = fbn (th ())
270 :    
271 : blume 587 fun sbn (DG.SB_SNODE n) =
272 :     EM.impossible "Link:SNODE in stable lib"
273 : blume 737 | sbn (DG.SB_BNODE (n as DG.BNODE bnrec, _, p)) =
274 :     let val _ = registerSublib p
275 :     val bininfo = #bininfo bnrec
276 : blume 587 val b as B (_, i, _) =
277 :     case bn n of
278 :     (f, NONE) => B (f, bininfo, [])
279 :     | (f, SOME (i, l)) => B (f, i, l)
280 :     in
281 :     stablemap :=
282 :     StableMap.insert (!stablemap, i, b)
283 :     end
284 :    
285 :     fun fsbn (_, n) = sbn n
286 : blume 652 fun impexp (nth, _, _) = fsbn (nth ())
287 : blume 446 in
288 : blume 587 SymbolMap.app impexp exports
289 : blume 446 end
290 : blume 652 fun force f = f ()
291 : blume 446 in
292 : blume 587 if SrcPathSet.member (!visited, grouppath) then ()
293 :     else (visited := SrcPathSet.add (!visited, grouppath);
294 :     case kind of
295 : blume 632 GG.LIB { kind = GG.STABLE _, ... } =>
296 :     registerStableLib g
297 : blume 737 | _ => app (registerGroup o force o #2) sublibs)
298 : blume 446 end
299 : blume 399
300 : blume 400 val _ = registerGroup group
301 : blume 399
302 : blume 400 val l_stablemap = ref StableMap.empty
303 :     val l_smlmap = ref SmlInfoMap.empty
304 : blume 399
305 : blume 400 fun bnode (B (f, i, l)) =
306 :     case StableMap.find (!l_stablemap, i) of
307 :     SOME th => th
308 :     | NONE => let
309 :     val fl = map bnode l
310 :     fun th gp = let
311 :     fun add (t, e) = DE.atop (t gp, e)
312 : blume 399 in
313 : blume 400 f gp (foldl add emptyDyn fl)
314 : blume 399 end
315 : blume 494 val m_th = Memoize.memoize th
316 : blume 400 in
317 :     l_stablemap :=
318 :     StableMap.insert (!l_stablemap, i, m_th);
319 :     m_th
320 :     end
321 : blume 399
322 : blume 737 fun sbn (DG.SB_BNODE (DG.BNODE { bininfo, ... }, _, _)) = let
323 : blume 400 val b = valOf (StableMap.find (!stablemap, bininfo))
324 : blume 573 fun th gp = SOME (bnode b gp)
325 :     handle exn as Link _ => raise exn
326 :     | _ => NONE
327 : blume 400 in
328 :     (th, [])
329 :     end
330 :     | sbn (DG.SB_SNODE n) = sn n
331 :    
332 :     and sn (DG.SNODE n) = let
333 :     val { smlinfo = i, localimports, globalimports } = n
334 :     in
335 :     case SmlInfoMap.find (!l_smlmap, i) of
336 :     SOME th => (th, [i])
337 :     | NONE => let
338 :     fun atop (NONE, _) = NONE
339 :     | atop (_, NONE) = NONE
340 :     | atop (SOME e, SOME e') = SOME (DE.atop (e, e'))
341 :     fun add ((f, l), (f', l')) =
342 :     (fn gp => atop (f gp, f' gp), l @ l')
343 : blume 537 val gi = foldl add (fn _ => SOME emptyDyn, [])
344 : blume 400 (map fsbn globalimports)
345 :     val (getE, snl) = foldl add gi (map sn localimports)
346 : blume 403 fun thunk gp = link_sml (gp, i, getBFC, getE, snl)
347 : blume 494 val m_thunk = Memoize.memoize thunk
348 : blume 400 in
349 :     l_smlmap := SmlInfoMap.insert (!l_smlmap, i, m_thunk);
350 :     (m_thunk, [i])
351 :     end
352 :     end
353 :    
354 :     and fsbn (_, n) = sbn n
355 :    
356 : blume 652 fun impexp (nth, _, _) gp = #1 (fsbn (nth ())) gp
357 : mblume 1448 handle Link exn => raise EX.Link
358 : blume 400
359 :     val exports' = SymbolMap.map impexp exports
360 :    
361 :     fun group' gp = let
362 :     fun one (_, NONE) = NONE
363 :     | one (f, SOME e) =
364 :     (case f gp of
365 :     NONE => NONE
366 :     | SOME e' => SOME (DE.atop (e', e)))
367 :     in
368 :     SymbolMap.foldl one (SOME emptyDyn) exports'
369 :     end
370 : blume 399 in
371 : blume 400 { exports = exports', group = group' }
372 : blume 399 end
373 :    
374 : blume 652 fun newTraversal (x as (GG.ERRORGROUP, _)) = newTraversal0 x
375 :     | newTraversal (x as (GG.GROUP { exports, ... }, _)) = let
376 : blume 737 val tth = Memoize.memoize (fn () => (newTraversal0 x))
377 : blume 652 in
378 :     { group = fn gp => #group (tth ()) gp,
379 :     exports = SymbolMap.mapi
380 :     (fn (sy, _) => fn gp =>
381 :     valOf (SymbolMap.find (#exports (tth ()),
382 :     sy))
383 :     gp)
384 :     exports }
385 :     end
386 :    
387 : blume 399 fun reset () = (stablemap := StableMap.empty;
388 :     smlmap := SmlInfoMap.empty)
389 : blume 632
390 :     fun unshare group =
391 :     let fun other (i, _) =
392 :     SrcPath.compare (BinInfo.group i, group) <> EQUAL
393 :     val sv = system_values
394 :     in
395 :     stablemap := StableMap.filteri other (!stablemap);
396 :     (sv := #1 (SrcPathMap.remove (!sv, group)))
397 :     handle LibBase.NotFound => ()
398 :     end
399 : blume 399 end
400 :     end

root@smlnj-gforge.cs.uchicago.edu
ViewVC Help
Powered by ViewVC 1.0.0