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/src/cm/compile/link.sml
ViewVC logotype

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

Parent Directory Parent Directory | Revision Log Revision Log


Revision 573 - (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 E = GenericVC.Environment
14 : blume 537 structure BE = GenericVC.BareEnvironment
15 : blume 399 structure DE = DynamicEnv
16 :     structure EM = GenericVC.ErrorMsg
17 :     structure PP = PrettyPrint
18 :    
19 :     type env = E.dynenv
20 :     in
21 :     signature LINK = sig
22 : blume 403
23 :     type bfc
24 :     type bfcGetter = SmlInfo.info -> bfc
25 :    
26 : blume 399 (* Evict value from cache if it exists *)
27 : blume 400 val evict : GP.info -> SmlInfo.info -> unit
28 : blume 399
29 : blume 537 val evictStale : unit -> unit
30 :    
31 : blume 399 (* Check all values and evict those that depended on other
32 :     * meanwhile evicted ones. *)
33 : blume 400 val cleanup : GP.info -> unit
34 : blume 399
35 : blume 403 val newTraversal : GG.group * bfcGetter ->
36 : blume 399 { group: GP.info -> env option,
37 :     exports: (GP.info -> env option) SymbolMap.map }
38 :    
39 :     (* discard persistent state *)
40 :     val reset : unit -> unit
41 :     end
42 :    
43 :     functor LinkFn (structure MachDepVC : MACHDEP_VC
44 : blume 537 structure BFC : BFC
45 :     sharing type MachDepVC.Binfile.bfContent = BFC.bfc
46 : blume 569 val system_values : env SrcPathMap.map ref) :> LINK
47 : blume 537 where type bfc = BFC.bfc =
48 : blume 403 struct
49 : blume 399
50 : blume 573 exception Link of exn
51 :    
52 : blume 399 structure BF = MachDepVC.Binfile
53 :    
54 : blume 403 type bfc = BF.bfContent
55 :     type bfcGetter = SmlInfo.info -> bfc
56 :    
57 : blume 399 type bfun = GP.info -> E.dynenv -> E.dynenv
58 :    
59 :     datatype bnode =
60 : blume 400 B of bfun * BinInfo.info * bnode list
61 : blume 399
62 :     val stablemap = ref (StableMap.empty: bnode StableMap.map)
63 :    
64 : blume 400 type smemo = E.dynenv * SmlInfo.info list
65 :    
66 :     val smlmap = ref (SmlInfoMap.empty: smemo SmlInfoMap.map)
67 :    
68 : blume 569 val emptyStatic = E.staticPart E.emptyEnv
69 :     val emptyDyn = E.dynamicPart E.emptyEnv
70 :    
71 : blume 400 fun evict gp i = let
72 :     fun check () =
73 :     case SmlInfo.sh_mode i of
74 :     Sharing.SHARE true =>
75 :     SmlInfo.error gp i EM.WARN
76 : blume 569 (concat ["sharing for ",
77 :     SmlInfo.descr i,
78 :     " 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 :     app (visit o #1) (SmlInfoMap.listItemsi (!smlmap))
108 :     end
109 :    
110 : blume 569 fun newTraversal (group, getBFC) = let
111 : blume 400
112 : blume 569 val GG.GROUP { exports, grouppath, ... } = group
113 :    
114 :     fun exn_err (msg, error, descr, exn) = let
115 :     fun ppb pps =
116 :     (PP.add_newline pps;
117 :     PP.add_string pps (General.exnMessage exn);
118 :     PP.add_newline pps)
119 : blume 400 in
120 : blume 569 error (concat [msg, " ", descr]) ppb;
121 : blume 573 raise Link exn
122 : blume 569 end
123 : blume 400
124 : blume 569 (* We invoke mk_de here and only if we don't have the value
125 :     * available as a sysval. This saves the (unnecessary) traversal
126 :     * in the stable case. (Normally all sysval entries are from
127 :     * stable libraries.) *)
128 :     fun execute sysval (bfc, mk_de, gp: GP.info) =
129 :     case sysval (BF.exportPidOf bfc) of
130 :     NONE =>
131 :     BF.exec (bfc,
132 :     DE.atop (mk_de gp,
133 :     BE.dynamicPart(#corenv (#param gp))))
134 :     | SOME de' => de'
135 :    
136 :     (* Construction of the environment is delayed until we are
137 :     * sure we really REALLY need it. This way we spare ourselves
138 :     * the trouble of doing the ancestor traversal if we
139 :     * end up finding out we already have the value in sysVal. *)
140 :     fun link_stable sysval (i, mk_e, gp) = let
141 :     val stable = BinInfo.stablename i
142 :     val os = BinInfo.offset i
143 :     val descr = BinInfo.describe i
144 :     val error = BinInfo.error i EM.COMPLAIN
145 :     val bfc = BFC.getStable { stable = stable, offset = os,
146 :     descr = descr }
147 :     handle exn => exn_err ("unable to load library module",
148 :     error, descr, exn)
149 :     in
150 :     execute sysval (bfc, mk_e, gp)
151 :     handle exn =>
152 :     exn_err ("link-time exception in library code",
153 :     error, descr, exn)
154 :     end
155 :    
156 :     fun link_sml (gp, i, getBFC, getE, snl) = let
157 :     fun fresh () = let
158 :     val bfc = getBFC i
159 :     in
160 :     case getE gp of
161 :     NONE => NONE
162 :     | SOME e =>
163 :     (SOME (execute (fn _ => NONE) (bfc, fn _ => e, gp))
164 :     handle exn =>
165 :     exn_err ("link-time exception in user program",
166 :     SmlInfo.error gp i EM.COMPLAIN,
167 :     SmlInfo.descr i,
168 :     exn))
169 : blume 573 end handle exn as Link _ => raise exn
170 :     | _ => NONE
171 : blume 569 in
172 :     case SmlInfo.sh_mode i of
173 :     Sharing.SHARE _ =>
174 :     (case SmlInfoMap.find (!smlmap, i) of
175 :     NONE =>
176 :     (case fresh () of
177 :     NONE => NONE
178 :     | SOME de => let
179 :     val m = (de, snl)
180 :     in
181 :     smlmap :=
182 :     SmlInfoMap.insert (!smlmap, i, m);
183 :     SOME de
184 :     end)
185 :     | SOME (de, _) => SOME de)
186 :     | Sharing.DONTSHARE => (evict gp i; fresh ())
187 :     end
188 :    
189 : blume 399 val visited = ref SrcPathSet.empty
190 : blume 569
191 :     fun registerGroup g = let
192 : blume 446 val GG.GROUP { grouppath, kind, sublibs, ... } = g
193 : blume 569 fun registerStableLib (GG.GROUP sg) = let
194 :     val { exports, grouppath = sgp, ... } = sg
195 :     val sysvals =
196 :     let val (m', e) =
197 :     SrcPathMap.remove (!system_values, sgp)
198 :     in system_values := m'; e
199 :     end handle LibBase.NotFound => emptyDyn
200 :    
201 :     fun sv (SOME pid) =
202 :     (SOME (DE.bind (pid, DE.look sysvals pid, emptyDyn))
203 :     handle DE.Unbound => NONE)
204 :     | sv _ = NONE
205 :    
206 : blume 446 val localmap = ref StableMap.empty
207 : blume 537 fun bn (DG.BNODE n) = let
208 : blume 569 val { bininfo = i, localimports, globalimports } = n
209 :     fun new () = let
210 :     val e0 = (fn _ => emptyDyn, [])
211 :     fun join ((f, NONE), (e, l)) =
212 :     (fn gp => DE.atop (f gp emptyDyn, e gp), l)
213 :     | join ((f, SOME (i, l')), (e, l)) =
214 :     (e, B (f, i, l') :: l)
215 :     val ge = foldl join e0 (map fbn globalimports)
216 :     val le = foldl join ge (map bn localimports)
217 : blume 399 in
218 : blume 569 case (BinInfo.sh_mode i, le) of
219 :     (Sharing.SHARE _, (e, [])) => let
220 :     fun thunk gp = link_stable sv (i, e, gp)
221 :     val m_thunk = Memoize.memoize thunk
222 :     in
223 :     (fn gp => fn _ => m_thunk gp, NONE)
224 :     end
225 :     | (Sharing.SHARE _, _) =>
226 :     EM.impossible "Link: sh_mode inconsistent"
227 :     | (Sharing.DONTSHARE, (e, l)) =>
228 :     (fn gp => fn e' =>
229 :     link_stable sv
230 :     (i, fn gp => DE.atop (e', e gp), gp),
231 :     SOME (i, l))
232 : blume 399 end
233 : blume 569 in
234 :     case StableMap.find (!stablemap, i) of
235 :     SOME (B (f, i, [])) =>
236 :     (case BinInfo.sh_mode i of
237 :     Sharing.DONTSHARE => (f, SOME (i, []))
238 :     | _ => (f, NONE))
239 :     | SOME (B (f, i, l)) => (f, SOME (i, l))
240 :     | NONE => (case StableMap.find (!localmap, i) of
241 :     SOME x => x
242 :     | NONE => let val x = new ()
243 :     in localmap := StableMap.insert
244 :     (!localmap, i, x);
245 :     x
246 :     end)
247 :     end
248 : blume 399
249 : blume 446 and fbn (_, n) = bn n
250 : blume 399
251 : blume 446 fun sbn (DG.SB_SNODE n) =
252 :     EM.impossible "Link:SNODE in stable lib"
253 :     | sbn (DG.SB_BNODE (n as DG.BNODE { bininfo, ... }, _)) =
254 :     let
255 :     val b as B (_, i, _) =
256 :     case bn n of
257 :     (f, NONE) => B (f, bininfo, [])
258 :     | (f, SOME (i, l)) => B (f, i, l)
259 :     in
260 :     stablemap := StableMap.insert (!stablemap, i, b)
261 :     end
262 : blume 399
263 : blume 446 fun fsbn (_, n) = sbn n
264 :     fun impexp (n, _) = fsbn n
265 :     in
266 :     SymbolMap.app impexp exports
267 :     end
268 : blume 399 in
269 : blume 446 if SrcPathSet.member (!visited, grouppath) then ()
270 :     else (visited := SrcPathSet.add (!visited, grouppath);
271 : blume 569 app (registerGroup o #2) sublibs;
272 : blume 446 case kind of
273 : blume 505 GG.STABLELIB _ => registerStableLib g
274 : blume 446 | _ => ())
275 : blume 399 end
276 :    
277 : blume 400 val _ = registerGroup group
278 : blume 399
279 : blume 400 val l_stablemap = ref StableMap.empty
280 :     val l_smlmap = ref SmlInfoMap.empty
281 : blume 399
282 : blume 400 fun bnode (B (f, i, l)) =
283 :     case StableMap.find (!l_stablemap, i) of
284 :     SOME th => th
285 :     | NONE => let
286 :     val fl = map bnode l
287 :     fun th gp = let
288 :     fun add (t, e) = DE.atop (t gp, e)
289 : blume 399 in
290 : blume 400 f gp (foldl add emptyDyn fl)
291 : blume 399 end
292 : blume 494 val m_th = Memoize.memoize th
293 : blume 400 in
294 :     l_stablemap :=
295 :     StableMap.insert (!l_stablemap, i, m_th);
296 :     m_th
297 :     end
298 : blume 399
299 : blume 537 fun sbn (DG.SB_BNODE (DG.BNODE { bininfo, ... }, _)) = let
300 : blume 400 val b = valOf (StableMap.find (!stablemap, bininfo))
301 : blume 573 fun th gp = SOME (bnode b gp)
302 :     handle exn as Link _ => raise exn
303 :     | _ => NONE
304 : blume 400 in
305 :     (th, [])
306 :     end
307 :     | sbn (DG.SB_SNODE n) = sn n
308 :    
309 :     and sn (DG.SNODE n) = let
310 :     val { smlinfo = i, localimports, globalimports } = n
311 :     in
312 :     case SmlInfoMap.find (!l_smlmap, i) of
313 :     SOME th => (th, [i])
314 :     | NONE => let
315 :     fun atop (NONE, _) = NONE
316 :     | atop (_, NONE) = NONE
317 :     | atop (SOME e, SOME e') = SOME (DE.atop (e, e'))
318 :     fun add ((f, l), (f', l')) =
319 :     (fn gp => atop (f gp, f' gp), l @ l')
320 : blume 537 val gi = foldl add (fn _ => SOME emptyDyn, [])
321 : blume 400 (map fsbn globalimports)
322 :     val (getE, snl) = foldl add gi (map sn localimports)
323 : blume 403 fun thunk gp = link_sml (gp, i, getBFC, getE, snl)
324 : blume 494 val m_thunk = Memoize.memoize thunk
325 : blume 400 in
326 :     l_smlmap := SmlInfoMap.insert (!l_smlmap, i, m_thunk);
327 :     (m_thunk, [i])
328 :     end
329 :     end
330 :    
331 :     and fsbn (_, n) = sbn n
332 :    
333 : blume 573 fun impexp (n, _) gp = #1 (fsbn n) gp
334 :     handle Link exn => raise exn
335 : blume 400
336 :     val exports' = SymbolMap.map impexp exports
337 :    
338 :     fun group' gp = let
339 :     fun one (_, NONE) = NONE
340 :     | one (f, SOME e) =
341 :     (case f gp of
342 :     NONE => NONE
343 :     | SOME e' => SOME (DE.atop (e', e)))
344 :     in
345 :     SymbolMap.foldl one (SOME emptyDyn) exports'
346 :     end
347 : blume 399 in
348 : blume 400 { exports = exports', group = group' }
349 : blume 399 end
350 :    
351 :     fun reset () = (stablemap := StableMap.empty;
352 :     smlmap := SmlInfoMap.empty)
353 :     end
354 :     end

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