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/branches/SMLNJ/src/cm/main/autoload.sml
ViewVC logotype

Annotation of /sml/branches/SMLNJ/src/cm/main/autoload.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 630 - (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 : monnier 630 local
9 :     structure GP = GeneralParams
10 :     structure DG = DependencyGraph
11 :     structure BE = GenericVC.BareEnvironment
12 :     structure ER = GenericVC.EnvRef
13 :     structure GG = GroupGraph
14 :     structure E = GenericVC.Environment
15 :     structure EM = GenericVC.ErrorMsg
16 :     in
17 : blume 355 signature AUTOLOAD = sig
18 :    
19 : monnier 630 val register : ER.envref * GG.group -> unit
20 : blume 355
21 : monnier 630 val mkManager : (unit -> GP.info) -> GenericVC.Ast.dec * ER.envref -> unit
22 :    
23 :     val getPending : unit -> DG.impexp SymbolMap.map
24 :    
25 :     val reset : unit -> unit
26 : blume 355 end
27 :    
28 : monnier 630 functor AutoLoadFn (structure C : COMPILE
29 :     structure L : LINK
30 :     structure BFC : BFC
31 :     sharing type C.bfc = L.bfc = BFC.bfc) :> AUTOLOAD = struct
32 : blume 355
33 : monnier 630 structure SE = GenericVC.StaticEnv
34 : blume 355
35 : monnier 630 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 : monnier 630 val pending = ref (SymbolMap.empty: (DG.impexp * traversal) SymbolMap.map)
41 : blume 355
42 : monnier 630 fun reset () = pending := SymbolMap.empty
43 :    
44 :     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 : monnier 630 (* make traversal states *)
57 :     val { store, get } = BFC.new ()
58 :     val { exports = cTrav, ... } = C.newTraversal (L.evict, store, g)
59 :     val { exports = lTrav, ... } = L.newTraversal (g, get)
60 :     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 : monnier 630 pending := SymbolMap.unionWith #1 (newNodes, !pending)
76 : blume 355 end
77 :    
78 : monnier 630 fun mkManager get_ginfo (ast, ter: ER.envref) = let
79 :    
80 :     val gp = get_ginfo ()
81 :    
82 :     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 :     L.cleanup gp;
95 :     SymbolMap.foldl one (SOME BE.emptyEnv) m
96 :     end
97 :    
98 : blume 355 val { skeleton, ... } =
99 :     SkelCvt.convert { tree = ast, err = fn _ => fn _ => fn _ => () }
100 :     val te = #get ter ()
101 : monnier 630 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 : monnier 630 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 :     fun lookpend sy = let
120 :     fun otherwise _ = EM.impossible "Autoload:lookpend"
121 :     in
122 : blume 355 case SymbolMap.find (pend, sy) of
123 : monnier 630 SOME (x as ((_, e), _)) =>
124 :     (announce ();
125 :     load := SymbolMap.insert (!load, sy, x);
126 :     BuildDepend.look otherwise e sy)
127 : blume 355 | NONE => DAEnv.EMPTY
128 : monnier 630 end
129 : blume 355 val lookimport = BuildDepend.look lookpend dae
130 :     val _ = BuildDepend.processOneSkeleton lookimport skeleton
131 : monnier 630
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 :     fun add ((((_, DG.SB_SNODE (DG.SNODE { smlinfo, ... })), _), _),
142 :     (ss, bs, ps)) =
143 :     (SmlInfoSet.add (ss, smlinfo), bs, ps)
144 :     | add ((((_, DG.SB_BNODE (DG.BNODE { bininfo, ... }, _)), _), _),
145 :     (ss, bs, ps)) =
146 :     (ss, StableSet.add (bs, bininfo), ps)
147 :     | add ((((_, DG.SB_BNODE (DG.PNODE p, _)), _), _), (ss, bs, ps)) =
148 :     (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 :     fun isPicked (((_, DG.SB_SNODE (DG.SNODE n)), _), _) =
157 :     SmlInfoSet.member (smlinfos, #smlinfo n)
158 :     | isPicked (((_, DG.SB_BNODE (DG.BNODE n, _)), _), _) =
159 :     StableSet.member (stableinfos, #bininfo n)
160 :     | isPicked (((_, DG.SB_BNODE (DG.PNODE p, _)), _), _) =
161 :     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 : monnier 630 if SymbolMap.isEmpty loadmap then ()
167 :     else
168 :     (SrcPath.revalidateCwd ();
169 :     (* We temporarily turn verbosity off, so we need to wrap this
170 :     * with a SafeIO.perform... *)
171 :     SafeIO.perform
172 :     { openIt = fn () => #get StdConfig.verbose () before
173 :     #set StdConfig.verbose false,
174 :     closeIt = ignore o #set StdConfig.verbose,
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 :     Say.say ["[autoloading done]\n"])
182 :     | NONE => raise Fail "unable to load module(s)") }
183 :     handle Fail msg =>
184 :     Say.say ["[autoloading failed: ", msg, "]\n"])
185 : blume 355 end
186 : monnier 630
187 :     fun getPending () = SymbolMap.map #1 (!pending)
188 : blume 355 end
189 : monnier 630 end

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