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/main/autoload.sml
ViewVC logotype

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

Parent Directory Parent Directory | Revision Log Revision Log


Revision 879 - (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 : blume 879 structure ER = EnvRef
12 : blume 362 structure GG = GroupGraph
13 : blume 879 structure E = Environment
14 :     structure EM = ErrorMsg
15 : blume 362 in
16 : blume 355 signature AUTOLOAD = sig
17 :    
18 : blume 362 val register : ER.envref * GG.group -> unit
19 : blume 355
20 : blume 505 val mkManager : { get_ginfo: unit -> GP.info, dropPickles: unit -> unit }
21 : blume 879 -> 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 771 functor AutoLoadFn (structure L : LINK
29 : blume 403 structure BFC : BFC
30 : blume 771 structure C : COMPILE where type stats = BFC.stats
31 : blume 403 sharing type C.bfc = L.bfc = BFC.bfc) :> AUTOLOAD = struct
32 : blume 355
33 : blume 879 structure SE = StaticEnv
34 : blume 364
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 587 fun register (_, GG.ERRORGROUP) = ()
45 : blume 734 | register (ter: ER.envref, g as GG.GROUP { exports, ... }) =
46 :     let val te = #get ter ()
47 : blume 587 (* toplevel bindings (symbol set) ... *)
48 :     val tss = foldl SymbolSet.add' SymbolSet.empty
49 :     (E.catalogEnv (E.staticPart te))
50 :     (* "new" bindings (symbol set) ... *)
51 :     val nss = SymbolMap.foldli (fn (i, _, s) => SymbolSet.add (s, i))
52 :     SymbolSet.empty exports
53 :     (* to-be-retained bindings ... *)
54 :     val rss = SymbolSet.difference (tss, nss)
55 :     (* getting rid of unneeded bindings... *)
56 :     val te' = E.filterEnv (te, SymbolSet.listItems rss)
57 :     (* make traversal states *)
58 :     val { store, get } = BFC.new ()
59 :     val { exports = cTrav, ... } = C.newTraversal (L.evict, store, g)
60 : blume 879 val { exports = lTrav, ... } = L.newTraversal (g, #contents o get)
61 : blume 587 fun combine (ss, d) gp =
62 :     case ss gp of
63 :     SOME { stat, sym } =>
64 : blume 399 (case d gp of
65 :     SOME dyn => SOME (E.mkenv { static = stat,
66 :     symbolic = sym,
67 :     dynamic = dyn })
68 :     | NONE => NONE)
69 : blume 587 | NONE => NONE
70 :     fun mkNode (sy, ie) =
71 :     (ie, combine (valOf (SymbolMap.find (cTrav, sy)),
72 :     valOf (SymbolMap.find (lTrav, sy))))
73 :     val newNodes = SymbolMap.mapi mkNode exports
74 :     in
75 :     #set ter te';
76 :     pending := SymbolMap.unionWith #1 (newNodes, !pending)
77 :     end
78 : blume 355
79 : blume 505 fun mkManager { get_ginfo, dropPickles } (ast, ter: ER.envref) = let
80 : blume 372
81 :     val gp = get_ginfo ()
82 :    
83 : blume 399 fun loadit m = let
84 :     fun one ((_, tr), NONE) = NONE
85 :     | one ((_, tr), SOME e) =
86 :     (case tr gp of
87 :     NONE => NONE
88 : blume 587 | SOME e' => SOME (E.concatEnv (e', e)))
89 : blume 399 in
90 : blume 737 (* make sure that there are no stale values around... *)
91 : blume 400 L.cleanup gp;
92 : blume 587 SymbolMap.foldl one (SOME E.emptyEnv) m
93 : blume 399 end
94 : blume 372
95 : blume 355 val { skeleton, ... } =
96 :     SkelCvt.convert { tree = ast, err = fn _ => fn _ => fn _ => () }
97 :     val te = #get ter ()
98 : blume 587 val ste = E.staticPart te
99 : blume 364
100 :     (* First, we get rid of anything in "pending" that has
101 :     * meanwhile been added to the toplevel. *)
102 :     fun notTopDefined (sy, _) =
103 :     (SE.look (ste, sy); false) handle SE.Unbound => true
104 :     val pend = SymbolMap.filteri notTopDefined (!pending)
105 :     val _ = pending := pend
106 :     val (dae, _) = Statenv2DAEnv.cvt ste
107 : blume 355 val load = ref SymbolMap.empty
108 : blume 432 val announce = let
109 :     val announced = ref false
110 :     in
111 :     fn () =>
112 :     (if !announced then ()
113 :     else (announced := true;
114 :     Say.say ["[autoloading]\n"]))
115 :     end
116 : blume 399 fun lookpend sy = let
117 :     fun otherwise _ = EM.impossible "Autoload:lookpend"
118 :     in
119 : blume 355 case SymbolMap.find (pend, sy) of
120 : blume 652 SOME (x as ((_, e, _), _)) =>
121 : blume 432 (announce ();
122 :     load := SymbolMap.insert (!load, sy, x);
123 : blume 399 BuildDepend.look otherwise e sy)
124 : blume 355 | NONE => DAEnv.EMPTY
125 : blume 399 end
126 : blume 355 val lookimport = BuildDepend.look lookpend dae
127 :     val _ = BuildDepend.processOneSkeleton lookimport skeleton
128 : blume 364
129 :     (* Here are the nodes that actually have been picked because
130 :     * something demanded an exported symbol: *)
131 :     val loadmap0 = !load
132 :    
133 :     (* However, we want to avoid hanging on to stuff unnecessarily, so
134 :     * we now look for symbols that become available "for free" because
135 : blume 652 * their corresponding node has been picked. *)
136 : blume 364
137 : blume 652 fun add (((_, _, ss), _), allsyms) = SymbolSet.union (ss, allsyms)
138 : blume 364
139 : blume 652 val pickedsyms = SymbolMap.foldl add SymbolSet.empty loadmap0
140 : blume 364
141 : blume 652 fun isPicked ((_, _, ss), _) =
142 :     not (SymbolSet.isEmpty (SymbolSet.intersection (ss, pickedsyms)))
143 :    
144 : blume 364 val loadmap = SymbolMap.filter isPicked pend
145 :     val noloadmap = SymbolMap.filter (not o isPicked) pend
146 : blume 355 in
147 : blume 366 if SymbolMap.isEmpty loadmap then ()
148 :     else
149 : blume 432 (SrcPath.revalidateCwd ();
150 : blume 366 (* We temporarily turn verbosity off, so we need to wrap this
151 :     * with a SafeIO.perform... *)
152 :     SafeIO.perform
153 : blume 433 { openIt = fn () => #get StdConfig.verbose () before
154 :     #set StdConfig.verbose false,
155 : blume 737 closeIt = #set StdConfig.verbose,
156 : blume 459 cleanup = fn _ => (),
157 : blume 366 work = fn _ =>
158 :     (case loadit loadmap of
159 :     SOME e =>
160 : blume 587 (#set ter (E.concatEnv (e, te));
161 : blume 366 pending := noloadmap;
162 : blume 372 Say.say ["[autoloading done]\n"])
163 : blume 377 | NONE => raise Fail "unable to load module(s)") }
164 :     handle Fail msg =>
165 : blume 505 Say.say ["[autoloading failed: ", msg, "]\n"];
166 :     dropPickles ())
167 : blume 355 end
168 : blume 362
169 : blume 372 fun getPending () = SymbolMap.map #1 (!pending)
170 : blume 355 end
171 : blume 362 end

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