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 366 - (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 :     structure DG = DependencyGraph
10 :     structure BE = GenericVC.BareEnvironment
11 :     structure ER = GenericVC.EnvRef
12 :     structure GG = GroupGraph
13 :     in
14 : blume 355 signature AUTOLOAD = sig
15 :    
16 : blume 362 val register : ER.envref * GG.group -> unit
17 : blume 355
18 : blume 362 val mkManager : (DG.impexp SymbolMap.map -> BE.environment option)
19 :     -> GenericVC.Ast.dec * ER.envref -> unit
20 : blume 361
21 : blume 362 val getPending : unit -> DG.impexp SymbolMap.map
22 :    
23 : blume 361 val reset : unit -> unit
24 : blume 355 end
25 :    
26 :     structure AutoLoad :> AUTOLOAD = struct
27 :    
28 : blume 364 structure SE = GenericVC.StaticEnv
29 :    
30 : blume 355 (* We let the topLevel env *logically* sit atop the pending
31 :     * autoload bindings. This way we do not have to intercept every
32 :     * change to the topLevel env. However, it means that any addition
33 :     * to "pending" must be subtracted from the topLevel env. *)
34 :     val pending = ref (SymbolMap.empty: DG.impexp SymbolMap.map)
35 :    
36 : blume 361 fun reset () = pending := SymbolMap.empty
37 :    
38 : blume 362 fun register (ter: ER.envref, GG.GROUP { exports, ... }) = let
39 : blume 355 val te = #get ter ()
40 :     (* toplevel bindings (symbol set) ... *)
41 :     val tss = foldl SymbolSet.add' SymbolSet.empty
42 :     (BE.catalogEnv (BE.staticPart te))
43 :     (* "new" bindings (symbol set) ... *)
44 :     val nss = SymbolMap.foldli (fn (i, _, s) => SymbolSet.add (s, i))
45 :     SymbolSet.empty exports
46 :     (* to-be-retained bindings ... *)
47 :     val rss = SymbolSet.difference (tss, nss)
48 :     (* getting rid of unneeded bindings... *)
49 :     val te' = BE.filterEnv (te, SymbolSet.listItems rss)
50 :     in
51 :     #set ter te';
52 :     pending := SymbolMap.unionWith #1 (exports, !pending)
53 :     end
54 :    
55 :     fun mkManager loadit (ast, ter: ER.envref) = let
56 :     val { skeleton, ... } =
57 :     SkelCvt.convert { tree = ast, err = fn _ => fn _ => fn _ => () }
58 :     val te = #get ter ()
59 : blume 364 val ste = BE.staticPart te
60 :    
61 :     (* First, we get rid of anything in "pending" that has
62 :     * meanwhile been added to the toplevel. *)
63 :     fun notTopDefined (sy, _) =
64 :     (SE.look (ste, sy); false) handle SE.Unbound => true
65 :     val pend = SymbolMap.filteri notTopDefined (!pending)
66 :     val _ = pending := pend
67 :     val (dae, _) = Statenv2DAEnv.cvt ste
68 : blume 355 val load = ref SymbolMap.empty
69 :     fun lookpend sy =
70 :     case SymbolMap.find (pend, sy) of
71 :     SOME (x as (_, e)) => (load := SymbolMap.insert (!load, sy, x);
72 :     e)
73 :     | NONE => DAEnv.EMPTY
74 :     val lookimport = BuildDepend.look lookpend dae
75 :     val _ = BuildDepend.processOneSkeleton lookimport skeleton
76 : blume 364
77 :     (* Here are the nodes that actually have been picked because
78 :     * something demanded an exported symbol: *)
79 :     val loadmap0 = !load
80 :    
81 :     (* However, we want to avoid hanging on to stuff unnecessarily, so
82 :     * we now look for symbols that become available "for free" because
83 :     * their corresponding node has been picked. So we first build
84 :     * three sets: sml- and stable-infos of picked nodes as well
85 :     * as the set of PNODEs: *)
86 :     fun add (((_, DG.SB_SNODE (DG.SNODE { smlinfo, ... })), _),
87 :     (ss, bs, ps)) =
88 :     (SmlInfoSet.add (ss, smlinfo), bs, ps)
89 :     | add (((_, DG.SB_BNODE (DG.BNODE { bininfo, ... })), _),
90 :     (ss, bs, ps)) =
91 :     (ss, StableSet.add (bs, bininfo), ps)
92 :     | add (((_, DG.SB_BNODE (DG.PNODE p)), _), (ss, bs, ps)) =
93 :     (ss, bs, StringSet.add (ps, Primitive.toString p))
94 :    
95 :     val (smlinfos, stableinfos, prims) =
96 :     SymbolMap.foldl add
97 :     (SmlInfoSet.empty, StableSet.empty, StringSet.empty)
98 :     loadmap0
99 :    
100 :     (* now we can easily find out whether a node has been picked... *)
101 :     fun isPicked ((_, DG.SB_SNODE (DG.SNODE { smlinfo, ... })), _) =
102 :     SmlInfoSet.member (smlinfos, smlinfo)
103 :     | isPicked ((_, DG.SB_BNODE (DG.BNODE { bininfo, ... })), _) =
104 :     StableSet.member (stableinfos, bininfo)
105 :     | isPicked ((_, DG.SB_BNODE (DG.PNODE p)), _) =
106 :     StringSet.member (prims, Primitive.toString p)
107 :    
108 :     val loadmap = SymbolMap.filter isPicked pend
109 :     val noloadmap = SymbolMap.filter (not o isPicked) pend
110 : blume 355 in
111 : blume 366 if SymbolMap.isEmpty loadmap then ()
112 :     else
113 :     (Say.say ["[autoloading..."];
114 :     SrcPath.revalidateCwd ();
115 :     (* We temporarily turn verbosity off, so we need to wrap this
116 :     * with a SafeIO.perform... *)
117 :     SafeIO.perform
118 :     { openIt = fn () =>
119 :     EnvConfig.getSet StdConfig.verbose (SOME false),
120 :     closeIt = ignore o (EnvConfig.getSet StdConfig.verbose) o SOME,
121 :     cleanup = fn () => (),
122 :     work = fn _ =>
123 :     (case loadit loadmap of
124 :     SOME e =>
125 :     (#set ter (BE.concatEnv (e, te));
126 :     pending := noloadmap;
127 :     Say.say ["done]\n"])
128 :     | NONE => Say.say ["failed]\n"]) })
129 : blume 355 end
130 : blume 362
131 :     fun getPending () = !pending
132 : blume 355 end
133 : blume 362 end

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