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 403 - (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 :     structure DE = DynamicEnv
15 :     structure EM = GenericVC.ErrorMsg
16 :     structure PP = PrettyPrint
17 :    
18 :     type env = E.dynenv
19 :     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 :     (* Check all values and evict those that depended on other
29 :     * meanwhile evicted ones. *)
30 : blume 400 val cleanup : GP.info -> unit
31 : blume 399
32 : blume 403 val newTraversal : GG.group * bfcGetter ->
33 : blume 399 { group: GP.info -> env option,
34 :     exports: (GP.info -> env option) SymbolMap.map }
35 :    
36 :     val sysval : GenericVC.PersStamps.persstamp option -> env option
37 :    
38 :     (* discard persistent state *)
39 :     val reset : unit -> unit
40 :     end
41 :    
42 :     functor LinkFn (structure MachDepVC : MACHDEP_VC
43 : blume 403 val system_values : env ref) :> LINK
44 :     where type bfc = MachDepVC.Binfile.bfContent =
45 :     struct
46 : blume 399
47 :     structure BF = MachDepVC.Binfile
48 :    
49 : blume 403 type bfc = BF.bfContent
50 :     type bfcGetter = SmlInfo.info -> bfc
51 :    
52 : blume 399 type bfun = GP.info -> E.dynenv -> E.dynenv
53 :    
54 :     datatype bnode =
55 : blume 400 B of bfun * BinInfo.info * bnode list
56 : blume 399
57 :     val stablemap = ref (StableMap.empty: bnode StableMap.map)
58 :    
59 :     val emptyStatic = E.staticPart E.emptyEnv
60 :     val emptyDyn = E.dynamicPart E.emptyEnv
61 :    
62 :     fun sysval NONE = NONE
63 :     | sysval (SOME pid) =
64 :     SOME (DynamicEnv.bind (pid,
65 :     DynamicEnv.look (!system_values) pid,
66 :     DynamicEnv.empty))
67 :     handle DynamicEnv.Unbound => NONE
68 :    
69 : blume 400 fun exn_err (msg, error, descr, exn) = let
70 :     fun ppb pps =
71 :     (PP.add_newline pps;
72 :     PP.add_string pps (General.exnMessage exn);
73 :     PP.add_newline pps)
74 : blume 399 in
75 : blume 400 error (concat [msg, " ", descr]) ppb;
76 :     raise exn
77 :     end
78 :    
79 :     fun execute (bfc, de) = let
80 :     fun exec () = E.dynamicPart (BF.exec (bfc, de))
81 :     in
82 : blume 399 case sysval (BF.exportPidOf bfc) of
83 :     NONE => exec ()
84 : blume 403 | SOME de' => de'
85 : blume 399 end
86 :    
87 :     fun memoize thunk = let
88 :     val r = ref (fn _ => raise Fail "Link:memoize")
89 :     fun firsttime gp = let
90 :     val v = thunk gp
91 :     in
92 :     r := (fn _ => v);
93 :     v
94 :     end
95 :     in
96 :     r := firsttime;
97 :     fn gp => !r gp
98 :     end
99 :    
100 : blume 400 type smemo = E.dynenv * SmlInfo.info list
101 :    
102 :     val smlmap = ref (SmlInfoMap.empty: smemo SmlInfoMap.map)
103 :    
104 :     fun evict gp i = let
105 :     fun check () =
106 :     case SmlInfo.sh_mode i of
107 :     Sharing.SHARE true =>
108 :     SmlInfo.error gp i EM.WARN
109 :     (concat ["sharing for ",
110 :     SmlInfo.descr i,
111 :     " may be lost"])
112 :     EM.nullErrorBody
113 :     | _ => ()
114 :     in
115 :     (smlmap := #1 (SmlInfoMap.remove (!smlmap, i))
116 :     before check ())
117 :     handle LibBase.NotFound => ()
118 :     end
119 :    
120 :     fun cleanup gp = let
121 :     val visited = ref SmlInfoSet.empty
122 :     fun visit i =
123 :     if SmlInfoSet.member (!visited, i) then true
124 :     else
125 :     case SmlInfoMap.find (!smlmap, i) of
126 :     NONE => false
127 :     | SOME (_, l) => let
128 :     val bl = map visit l
129 :     val b = List.all (fn x => x) bl
130 :     in
131 :     if b then
132 :     (visited := SmlInfoSet.add (!visited, i);
133 :     true)
134 :     else (evict gp i; false)
135 :     end
136 :     in
137 :     app (visit o #1) (SmlInfoMap.listItemsi (!smlmap))
138 :     end
139 :    
140 :     fun prim2dyn p (gp: GP.info) =
141 :     E.dynamicPart (Primitive.env (#primconf (#param gp)) p)
142 :    
143 :     fun getPerv (gp: GP.info) = E.dynamicPart (#pervasive (#param gp))
144 :    
145 :     fun link_stable (i, e) = let
146 :     val stable = BinInfo.stablename i
147 :     val os = BinInfo.offset i
148 :     val descr = BinInfo.describe i
149 :     val _ = Say.vsay ["[linking with ", descr, "]\n"]
150 :     val error = BinInfo.error i EM.COMPLAIN
151 :     in
152 :     let fun work s =
153 :     (Seek.seek (s, os);
154 :     (* We can use an empty static env because no
155 :     * unpickling will be done. *)
156 :     BF.read { stream = s, name = descr, senv = emptyStatic })
157 :     val bfc =
158 :     SafeIO.perform { openIt = fn () => BinIO.openIn stable,
159 :     closeIt = BinIO.closeIn,
160 :     work = work,
161 :     cleanup = fn () => () }
162 :     handle exn =>
163 :     exn_err ("unable to load library module",
164 :     error, descr, exn)
165 :     val epid = BF.exportPidOf bfc
166 :     in
167 :     execute (bfc, e)
168 :     handle exn => exn_err ("link-time exception in library code",
169 :     error, descr, exn)
170 :     end
171 :     end
172 :    
173 : blume 403 fun link_sml (gp, i, getBFC, getE, snl) = let
174 : blume 400 fun fresh () = let
175 :     val bfc = getBFC i
176 :     in
177 :     case getE gp of
178 :     NONE => NONE
179 :     | SOME e =>
180 :     (SOME (execute (bfc, e))
181 :     handle exn =>
182 :     exn_err ("link-time exception in user program",
183 :     SmlInfo.error gp i EM.COMPLAIN,
184 :     SmlInfo.descr i,
185 :     exn))
186 :     end handle _ => NONE
187 :     in
188 :     case SmlInfo.sh_mode i of
189 :     Sharing.SHARE _ =>
190 :     (case SmlInfoMap.find (!smlmap, i) of
191 :     NONE =>
192 :     (case fresh () of
193 :     NONE => NONE
194 :     | SOME de => let
195 :     val m = (de, snl)
196 :     in
197 :     smlmap :=
198 :     SmlInfoMap.insert (!smlmap, i, m);
199 :     SOME de
200 :     end)
201 :     | SOME (de, _) => SOME de)
202 :     | Sharing.DONTSHARE => (evict gp i; fresh ())
203 :     end
204 :    
205 : blume 399 fun registerGroup g = let
206 :     val GG.GROUP { grouppath, kind, sublibs, ... } = g
207 :     val visited = ref SrcPathSet.empty
208 :     fun registerStableLib (GG.GROUP { exports, ... }) = let
209 :     val localmap = ref StableMap.empty
210 :     fun bn (DG.PNODE p) =
211 : blume 400 (fn gp => fn _ => prim2dyn p gp, NONE)
212 : blume 399 | bn (DG.BNODE n) = let
213 :     val { bininfo = i, localimports, globalimports } = n
214 :     fun new () = let
215 : blume 400 val e0 = (getPerv, [])
216 :     fun join ((f, NONE), (e, l)) =
217 : blume 399 (fn gp => DE.atop (f gp emptyDyn, e gp), l)
218 : blume 400 | join ((f, SOME (i, l')), (e, l)) =
219 :     (e, B (f, i, l') :: l)
220 : blume 399 val ge = foldl join e0 (map fbn globalimports)
221 :     val le = foldl join ge (map bn localimports)
222 :     in
223 :     case (BinInfo.sh_mode i, le) of
224 :     (Sharing.SHARE _, (e, [])) => let
225 : blume 400 fun thunk gp = link_stable (i, e gp)
226 : blume 399 val m_thunk = memoize thunk
227 :     in
228 : blume 400 (fn gp => fn _ => m_thunk gp, NONE)
229 : blume 399 end
230 :     | (Sharing.SHARE _, _) =>
231 :     EM.impossible "Link: sh_mode inconsistent"
232 : blume 400 | (Sharing.DONTSHARE, (e, l)) =>
233 :     (fn gp => fn e' =>
234 :     link_stable (i, (DE.atop (e', e gp))),
235 :     SOME (i, l))
236 : blume 399 end
237 :     in
238 :     case StableMap.find (!stablemap, i) of
239 : blume 401 SOME (B (f, i, [])) =>
240 :     (case BinInfo.sh_mode i of
241 :     Sharing.DONTSHARE => (f, SOME (i, []))
242 :     | _ => (f, NONE))
243 :     | SOME (B (f, i, l)) => (f, SOME (i, l))
244 : blume 399 | NONE =>
245 :     (case StableMap.find (!localmap, i) of
246 :     SOME x => x
247 :     | NONE => let
248 :     val x = new ()
249 :     in
250 :     localmap :=
251 :     StableMap.insert (!localmap, i, x);
252 :     x
253 :     end)
254 :     end
255 :    
256 :     and fbn (_, n) = bn n
257 :    
258 :     fun sbn (DG.SB_SNODE n) =
259 :     EM.impossible "Link:SNODE in stable lib"
260 :     | sbn (DG.SB_BNODE (DG.PNODE _, _)) = ()
261 : blume 400 | sbn (DG.SB_BNODE (n as DG.BNODE { bininfo, ... }, _)) = let
262 :     val b as B (_, i, _) =
263 :     case bn n of
264 :     (f, NONE) => B (f, bininfo, [])
265 :     | (f, SOME (i, l)) => B (f, i, l)
266 : blume 399 in
267 : blume 400 stablemap := StableMap.insert (!stablemap, i, b)
268 : blume 399 end
269 :    
270 :     fun fsbn (_, n) = sbn n
271 :     fun impexp (n, _) = fsbn n
272 :     in
273 :     SymbolMap.app impexp exports
274 :     end
275 :     in
276 :     if SrcPathSet.member (!visited, grouppath) then ()
277 :     else (visited := SrcPathSet.add (!visited, grouppath);
278 :     app registerGroup sublibs;
279 :     case kind of
280 :     GG.STABLELIB => registerStableLib g
281 :     | _ => ())
282 :     end
283 :    
284 : blume 403 fun newTraversal (group as GG.GROUP { exports, ... }, getBFC) = let
285 : blume 400 val _ = registerGroup group
286 : blume 399
287 : blume 400 val l_stablemap = ref StableMap.empty
288 :     val l_smlmap = ref SmlInfoMap.empty
289 : blume 399
290 : blume 400 fun bnode (B (f, i, l)) =
291 :     case StableMap.find (!l_stablemap, i) of
292 :     SOME th => th
293 :     | NONE => let
294 :     val fl = map bnode l
295 :     fun th gp = let
296 :     fun add (t, e) = DE.atop (t gp, e)
297 : blume 399 in
298 : blume 400 f gp (foldl add emptyDyn fl)
299 : blume 399 end
300 : blume 400 val m_th = memoize th
301 :     in
302 :     l_stablemap :=
303 :     StableMap.insert (!l_stablemap, i, m_th);
304 :     m_th
305 :     end
306 : blume 399
307 : blume 400 fun sbn (DG.SB_BNODE (DG.PNODE p, _)) = (SOME o prim2dyn p, [])
308 :     | sbn (DG.SB_BNODE (DG.BNODE { bininfo, ... }, _)) = let
309 :     val b = valOf (StableMap.find (!stablemap, bininfo))
310 :     fun th gp =
311 :     SOME (bnode b gp)
312 :     handle exn => NONE
313 :     in
314 :     (th, [])
315 :     end
316 :     | sbn (DG.SB_SNODE n) = sn n
317 :    
318 :     and sn (DG.SNODE n) = let
319 :     val { smlinfo = i, localimports, globalimports } = n
320 :     in
321 :     case SmlInfoMap.find (!l_smlmap, i) of
322 :     SOME th => (th, [i])
323 :     | NONE => let
324 :     fun atop (NONE, _) = NONE
325 :     | atop (_, NONE) = NONE
326 :     | atop (SOME e, SOME e') = SOME (DE.atop (e, e'))
327 :     fun add ((f, l), (f', l')) =
328 :     (fn gp => atop (f gp, f' gp), l @ l')
329 :     val gi = foldl add (SOME o getPerv, [])
330 :     (map fsbn globalimports)
331 :     val (getE, snl) = foldl add gi (map sn localimports)
332 : blume 403 fun thunk gp = link_sml (gp, i, getBFC, getE, snl)
333 : blume 400 val m_thunk = memoize thunk
334 :     in
335 :     l_smlmap := SmlInfoMap.insert (!l_smlmap, i, m_thunk);
336 :     (m_thunk, [i])
337 :     end
338 :     end
339 :    
340 :     and fsbn (_, n) = sbn n
341 :    
342 :     fun impexp (n, _) = #1 (fsbn n)
343 :    
344 :     val exports' = SymbolMap.map impexp exports
345 :    
346 :     fun group' gp = let
347 :     fun one (_, NONE) = NONE
348 :     | one (f, SOME e) =
349 :     (case f gp of
350 :     NONE => NONE
351 :     | SOME e' => SOME (DE.atop (e', e)))
352 :     in
353 :     SymbolMap.foldl one (SOME emptyDyn) exports'
354 :     end
355 : blume 399 in
356 : blume 400 { exports = exports', group = group' }
357 : blume 399 end
358 :    
359 :     fun reset () = (stablemap := StableMap.empty;
360 :     smlmap := SmlInfoMap.empty)
361 :     end
362 :     end

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