Annotation of /sml/trunk/src/cm/main/autoload.sml

Parent Directory | Revision Log

---

Revision 432 - (view) (download)

1 :	blume	355	(*
2 :			* The CM autoloading mechanism.
3 :			*
4 :			* (C) 1999 Lucent Technologies, Bell Laboratories
5 :			*
6 :			* Author: Matthias Blume (blume@kurims.kyoto-u.ac.jp)
7 :			*)
8 :	blume	362	local
9 :	blume	399	structure GP = GeneralParams
10 :	blume	362	structure DG = DependencyGraph
11 :			structure BE = GenericVC.BareEnvironment
12 :			structure ER = GenericVC.EnvRef
13 :			structure GG = GroupGraph
14 :	blume	372	structure E = GenericVC.Environment
15 :	blume	399	structure EM = GenericVC.ErrorMsg
16 :	blume	362	in
17 :	blume	355	signature AUTOLOAD = sig
18 :
19 :	blume	362	val register : ER.envref * GG.group -> unit
20 :	blume	355
21 :	blume	399	val mkManager : (unit -> GP.info) -> GenericVC.Ast.dec * ER.envref -> unit
22 :	blume	361
23 :	blume	362	val getPending : unit -> DG.impexp SymbolMap.map
24 :
25 :	blume	361	val reset : unit -> unit
26 :	blume	355	end
27 :
28 :	blume	399	functor AutoLoadFn (structure C : COMPILE
29 :	blume	403	structure L : LINK
30 :			structure BFC : BFC
31 :			sharing type C.bfc = L.bfc = BFC.bfc) :> AUTOLOAD = struct
32 :	blume	355
33 :	blume	364	structure SE = GenericVC.StaticEnv
34 :
35 :	blume	399	type traversal = GP.info -> E.environment option
36 :	blume	355	(* We let the topLevel env *logically* sit atop the pending
37 :			* autoload bindings. This way we do not have to intercept every
38 :			* change to the topLevel env. However, it means that any addition
39 :			* to "pending" must be subtracted from the topLevel env. *)
40 :	blume	399	val pending = ref (SymbolMap.empty: (DG.impexp * traversal) SymbolMap.map)
41 :	blume	355
42 :	blume	361	fun reset () = pending := SymbolMap.empty
43 :
44 :	blume	399	fun register (ter: ER.envref, g as GG.GROUP { exports, ... }) = let
45 :	blume	355	val te = #get ter ()
46 :			(* toplevel bindings (symbol set) ... *)
47 :			val tss = foldl SymbolSet.add' SymbolSet.empty
48 :			(BE.catalogEnv (BE.staticPart te))
49 :			(* "new" bindings (symbol set) ... *)
50 :			val nss = SymbolMap.foldli (fn (i, _, s) => SymbolSet.add (s, i))
51 :			SymbolSet.empty exports
52 :			(* to-be-retained bindings ... *)
53 :			val rss = SymbolSet.difference (tss, nss)
54 :			(* getting rid of unneeded bindings... *)
55 :			val te' = BE.filterEnv (te, SymbolSet.listItems rss)
56 :	blume	372	(* make traversal states *)
57 :	blume	403	val { store, get } = BFC.new ()
58 :			val { exports = cTrav, ... } = C.newTraversal (L.evict, store, g)
59 :			val { exports = lTrav, ... } = L.newTraversal (g, get)
60 :	blume	399	fun combine (ss, d) gp =
61 :			case ss gp of
62 :			SOME { stat, sym } =>
63 :			(case d gp of
64 :			SOME dyn => SOME (E.mkenv { static = stat,
65 :			symbolic = sym,
66 :			dynamic = dyn })
67 :			| NONE => NONE)
68 :			| NONE => NONE
69 :			fun mkNode (sy, ie) =
70 :			(ie, combine (valOf (SymbolMap.find (cTrav, sy)),
71 :			valOf (SymbolMap.find (lTrav, sy))))
72 :			val newNodes = SymbolMap.mapi mkNode exports
73 :	blume	355	in
74 :			#set ter te';
75 :	blume	399	pending := SymbolMap.unionWith #1 (newNodes, !pending)
76 :	blume	355	end
77 :
78 :	blume	372	fun mkManager get_ginfo (ast, ter: ER.envref) = let
79 :
80 :			val gp = get_ginfo ()
81 :
82 :	blume	399	fun loadit m = let
83 :			fun one ((_, tr), NONE) = NONE
84 :			| one ((_, tr), SOME e) =
85 :			(case tr gp of
86 :			NONE => NONE
87 :			| SOME e' => let
88 :			val be = GenericVC.CoerceEnv.e2b e'
89 :			in
90 :			SOME (BE.concatEnv (be, e))
91 :			end)
92 :			in
93 :			(* make sure that there are no stale value around... *)
94 :	blume	400	L.cleanup gp;
95 :	blume	399	SymbolMap.foldl one (SOME BE.emptyEnv) m
96 :			end
97 :	blume	372
98 :	blume	355	val { skeleton, ... } =
99 :			SkelCvt.convert { tree = ast, err = fn _ => fn _ => fn _ => () }
100 :			val te = #get ter ()
101 :	blume	364	val ste = BE.staticPart te
102 :
103 :			(* First, we get rid of anything in "pending" that has
104 :			* meanwhile been added to the toplevel. *)
105 :			fun notTopDefined (sy, _) =
106 :			(SE.look (ste, sy); false) handle SE.Unbound => true
107 :			val pend = SymbolMap.filteri notTopDefined (!pending)
108 :			val _ = pending := pend
109 :			val (dae, _) = Statenv2DAEnv.cvt ste
110 :	blume	355	val load = ref SymbolMap.empty
111 :	blume	432	val announce = let
112 :			val announced = ref false
113 :			in
114 :			fn () =>
115 :			(if !announced then ()
116 :			else (announced := true;
117 :			Say.say ["[autoloading]\n"]))
118 :			end
119 :	blume	399	fun lookpend sy = let
120 :			fun otherwise _ = EM.impossible "Autoload:lookpend"
121 :			in
122 :	blume	355	case SymbolMap.find (pend, sy) of
123 :	blume	399	SOME (x as ((_, e), _)) =>
124 :	blume	432	(announce ();
125 :			load := SymbolMap.insert (!load, sy, x);
126 :	blume	399	BuildDepend.look otherwise e sy)
127 :	blume	355	| NONE => DAEnv.EMPTY
128 :	blume	399	end
129 :	blume	355	val lookimport = BuildDepend.look lookpend dae
130 :			val _ = BuildDepend.processOneSkeleton lookimport skeleton
131 :	blume	364
132 :			(* Here are the nodes that actually have been picked because
133 :			* something demanded an exported symbol: *)
134 :			val loadmap0 = !load
135 :
136 :			(* However, we want to avoid hanging on to stuff unnecessarily, so
137 :			* we now look for symbols that become available "for free" because
138 :			* their corresponding node has been picked. So we first build
139 :			* three sets: sml- and stable-infos of picked nodes as well
140 :			* as the set of PNODEs: *)
141 :	blume	399	fun add ((((_, DG.SB_SNODE (DG.SNODE { smlinfo, ... })), _), _),
142 :	blume	364	(ss, bs, ps)) =
143 :			(SmlInfoSet.add (ss, smlinfo), bs, ps)
144 :	blume	399	| add ((((_, DG.SB_BNODE (DG.BNODE { bininfo, ... }, _)), _), _),
145 :	blume	364	(ss, bs, ps)) =
146 :			(ss, StableSet.add (bs, bininfo), ps)
147 :	blume	399	| add ((((_, DG.SB_BNODE (DG.PNODE p, _)), _), _), (ss, bs, ps)) =
148 :	blume	364	(ss, bs, StringSet.add (ps, Primitive.toString p))
149 :
150 :			val (smlinfos, stableinfos, prims) =
151 :			SymbolMap.foldl add
152 :			(SmlInfoSet.empty, StableSet.empty, StringSet.empty)
153 :			loadmap0
154 :
155 :			(* now we can easily find out whether a node has been picked... *)
156 :	blume	399	fun isPicked (((_, DG.SB_SNODE (DG.SNODE n)), _), _) =
157 :	blume	372	SmlInfoSet.member (smlinfos, #smlinfo n)
158 :	blume	399	| isPicked (((_, DG.SB_BNODE (DG.BNODE n, _)), _), _) =
159 :	blume	372	StableSet.member (stableinfos, #bininfo n)
160 :	blume	399	| isPicked (((_, DG.SB_BNODE (DG.PNODE p, _)), _), _) =
161 :	blume	364	StringSet.member (prims, Primitive.toString p)
162 :
163 :			val loadmap = SymbolMap.filter isPicked pend
164 :			val noloadmap = SymbolMap.filter (not o isPicked) pend
165 :	blume	355	in
166 :	blume	366	if SymbolMap.isEmpty loadmap then ()
167 :			else
168 :	blume	432	(SrcPath.revalidateCwd ();
169 :	blume	366	(* We temporarily turn verbosity off, so we need to wrap this
170 :			* with a SafeIO.perform... *)
171 :			SafeIO.perform
172 :			{ openIt = fn () =>
173 :			EnvConfig.getSet StdConfig.verbose (SOME false),
174 :			closeIt = ignore o (EnvConfig.getSet StdConfig.verbose) o SOME,
175 :			cleanup = fn () => (),
176 :			work = fn _ =>
177 :			(case loadit loadmap of
178 :			SOME e =>
179 :			(#set ter (BE.concatEnv (e, te));
180 :			pending := noloadmap;
181 :	blume	372	Say.say ["[autoloading done]\n"])
182 :	blume	377	| NONE => raise Fail "unable to load module(s)") }
183 :			handle Fail msg =>
184 :			Say.say ["[autoloading failed: ", msg, "]\n"])
185 :	blume	355	end
186 :	blume	362
187 :	blume	372	fun getPending () = SymbolMap.map #1 (!pending)
188 :	blume	355	end
189 :	blume	362	end

---

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