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