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

Parent Directory | 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