Home My Page Projects Code Snippets Project Openings SML/NJ
Summary Activity Forums Tracker Lists Tasks Docs Surveys News SCM Files

SCM Repository

[smlnj] Diff of /sml/trunk/src/cm/main/autoload.sml
ViewVC logotype

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

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 361, Wed Jun 30 06:44:04 1999 UTC revision 375, Wed Jul 7 03:08:04 1999 UTC
# Line 5  Line 5 
5   *   *
6   * Author: Matthias Blume (blume@kurims.kyoto-u.ac.jp)   * Author: Matthias Blume (blume@kurims.kyoto-u.ac.jp)
7   *)   *)
8    local
9        structure DG = DependencyGraph
10        structure BE = GenericVC.BareEnvironment
11        structure ER = GenericVC.EnvRef
12        structure GG = GroupGraph
13        structure E = GenericVC.Environment
14    in
15  signature AUTOLOAD = sig  signature AUTOLOAD = sig
16    
17      val register : GenericVC.EnvRef.envref * GroupGraph.group -> unit      val register : ER.envref * GG.group -> unit
18    
19        val mkManager : (unit -> GeneralParams.info) ->
20            GenericVC.Ast.dec * ER.envref -> unit
21    
22      val mkManager : (DependencyGraph.impexp SymbolMap.map ->      val getPending : unit -> DG.impexp SymbolMap.map
                      GenericVC.BareEnvironment.environment option)  
         -> GenericVC.Ast.dec * GenericVC.EnvRef.envref -> unit  
23    
24      val reset : unit -> unit      val reset : unit -> unit
25  end  end
26    
27  structure AutoLoad :> AUTOLOAD = struct  functor AutoLoadFn (structure RT : TRAVERSAL
28                            where type result =
29                              { stat: E.staticEnv, sym: E.symenv }
30                        structure ET : TRAVERSAL
31                            where type result = E.dynenv):> AUTOLOAD = struct
32    
33      structure DG = DependencyGraph      structure SE = GenericVC.StaticEnv
     structure ER = GenericVC.EnvRef  
     structure BE = GenericVC.BareEnvironment  
34    
35      (* We let the topLevel env *logically* sit atop the pending      (* We let the topLevel env *logically* sit atop the pending
36       * autoload bindings.  This way we do not have to intercept every       * autoload bindings.  This way we do not have to intercept every
37       * change to the topLevel env.  However, it means that any addition       * change to the topLevel env.  However, it means that any addition
38       * to "pending" must be subtracted from the topLevel env. *)       * to "pending" must be subtracted from the topLevel env. *)
39      val pending = ref (SymbolMap.empty: DG.impexp SymbolMap.map)      val pending =
40            ref (SymbolMap.empty: (DG.impexp * RT.ts * ET.ts) SymbolMap.map)
41    
42      fun reset () = pending := SymbolMap.empty      fun reset () = pending := SymbolMap.empty
43    
44      fun register (ter: ER.envref, GroupGraph.GROUP { exports, ... }) = let      fun register (ter: ER.envref, GG.GROUP { exports, ... }) = let
45          val te = #get ter ()          val te = #get ter ()
46          (* toplevel bindings (symbol set) ... *)          (* toplevel bindings (symbol set) ... *)
47          val tss = foldl SymbolSet.add' SymbolSet.empty          val tss = foldl SymbolSet.add' SymbolSet.empty
# Line 42  Line 53 
53          val rss = SymbolSet.difference (tss, nss)          val rss = SymbolSet.difference (tss, nss)
54          (* getting rid of unneeded bindings... *)          (* getting rid of unneeded bindings... *)
55          val te' = BE.filterEnv (te, SymbolSet.listItems rss)          val te' = BE.filterEnv (te, SymbolSet.listItems rss)
56            (* make traversal states *)
57            val rts = RT.start ()
58            val ets = ET.start ()
59            fun addState n = (n, rts, ets)
60      in      in
61          #set ter te';          #set ter te';
62          pending := SymbolMap.unionWith #1 (exports, !pending)          pending :=
63            SymbolMap.unionWith #1 (SymbolMap.map addState exports, !pending)
64        end
65    
66        fun mkManager get_ginfo (ast, ter: ER.envref) = let
67    
68            val gp = get_ginfo ()
69    
70            fun loadit m =
71                case RT.resume (fn ((n, _), rts, ets) => (n, rts)) gp m of
72                    NONE => NONE
73                  | SOME { stat, sym } => let
74                        fun exec () =
75                            ET.resume (fn ((n, _), rts, ets) => (n, ets)) gp m
76                    in
77                        case exec () of
78                            NONE => NONE
79                          | SOME dyn => let
80                                val e = E.mkenv { static = stat, symbolic = sym,
81                                                  dynamic =dyn }
82                                val be = GenericVC.CoerceEnv.e2b e
83                            in
84                                SOME be
85                            end
86      end      end
87    
     fun mkManager loadit (ast, ter: ER.envref) = let  
88          val { skeleton, ... } =          val { skeleton, ... } =
89              SkelCvt.convert { tree = ast, err = fn _ => fn _ => fn _ => () }              SkelCvt.convert { tree = ast, err = fn _ => fn _ => fn _ => () }
90          val te = #get ter ()          val te = #get ter ()
91          val (dae, _) = Statenv2DAEnv.cvt (BE.staticPart te)          val ste = BE.staticPart te
92          val pend = !pending  
93            (* First, we get rid of anything in "pending" that has
94             * meanwhile been added to the toplevel. *)
95            fun notTopDefined (sy, _) =
96                (SE.look (ste, sy); false) handle SE.Unbound => true
97            val pend = SymbolMap.filteri notTopDefined (!pending)
98            val _ = pending := pend
99            val (dae, _) = Statenv2DAEnv.cvt ste
100          val load = ref SymbolMap.empty          val load = ref SymbolMap.empty
101          fun lookpend sy =          fun lookpend sy =
102              case SymbolMap.find (pend, sy) of              case SymbolMap.find (pend, sy) of
103                  SOME (x as (_, e)) => (load := SymbolMap.insert (!load, sy, x);                  SOME (x as ((_, e), _, _)) =>
104                        (load := SymbolMap.insert (!load, sy, x);
105                                         e)                                         e)
106                | NONE => DAEnv.EMPTY                | NONE => DAEnv.EMPTY
107          val lookimport = BuildDepend.look lookpend dae          val lookimport = BuildDepend.look lookpend dae
108          val _ = BuildDepend.processOneSkeleton lookimport skeleton          val _ = BuildDepend.processOneSkeleton lookimport skeleton
109          val loadmap = !load  
110      in          (* Here are the nodes that actually have been picked because
111          case loadit loadmap of           * something demanded an exported symbol: *)
112              SOME e => let          val loadmap0 = !load
113                  val te' = BE.concatEnv (e, te)  
114                  fun notPicked (sy, _) =          (* However, we want to avoid hanging on to stuff unnecessarily, so
115                      not (isSome (SymbolMap.find (loadmap, sy)))           * we now look for symbols that become available "for free" because
116                  val pend' = SymbolMap.filteri notPicked pend           * their corresponding node has been picked.  So we first build
117             * three sets: sml- and stable-infos of picked nodes as well
118             * as the set of PNODEs: *)
119            fun add ((((_, DG.SB_SNODE (DG.SNODE { smlinfo, ... })), _), _, _),
120                     (ss, bs, ps)) =
121                (SmlInfoSet.add (ss, smlinfo), bs, ps)
122              | add ((((_, DG.SB_BNODE (DG.BNODE { bininfo, ... })), _), _, _),
123                     (ss, bs, ps)) =
124                (ss, StableSet.add (bs, bininfo), ps)
125              | add ((((_, DG.SB_BNODE (DG.PNODE p)), _), _, _), (ss, bs, ps)) =
126                (ss, bs, StringSet.add (ps, Primitive.toString p))
127    
128            val (smlinfos, stableinfos, prims) =
129                SymbolMap.foldl add
130                      (SmlInfoSet.empty, StableSet.empty, StringSet.empty)
131                      loadmap0
132    
133            (* now we can easily find out whether a node has been picked... *)
134            fun isPicked (((_, DG.SB_SNODE (DG.SNODE n)), _), _, _) =
135                SmlInfoSet.member (smlinfos, #smlinfo n)
136              | isPicked (((_, DG.SB_BNODE (DG.BNODE n)), _), _, _) =
137                StableSet.member (stableinfos, #bininfo n)
138              | isPicked (((_, DG.SB_BNODE (DG.PNODE p)), _), _, _) =
139                StringSet.member (prims, Primitive.toString p)
140    
141            val loadmap = SymbolMap.filter isPicked pend
142            val noloadmap = SymbolMap.filter (not o isPicked) pend
143              in              in
144                  #set ter te';          if SymbolMap.isEmpty loadmap then ()
145                  pending := pend'          else
146                (Say.say ["[autoloading]\n"];
147                 SrcPath.revalidateCwd ();
148                 (* We temporarily turn verbosity off, so we need to wrap this
149                  * with a SafeIO.perform... *)
150                 SafeIO.perform
151                  { openIt = fn () =>
152                      EnvConfig.getSet StdConfig.verbose (SOME false),
153                    closeIt = ignore o (EnvConfig.getSet StdConfig.verbose) o SOME,
154                    cleanup = fn () => (),
155                    work = fn _ =>
156                      (case loadit loadmap of
157                           SOME e =>
158                               (#set ter (BE.concatEnv (e, te));
159                                pending := noloadmap;
160                                Say.say ["[autoloading done]\n"])
161                         | NONE => Say.say ["[autoloading failed]\n"]) })
162              end              end
163            | NONE => ()  
164        fun getPending () = SymbolMap.map #1 (!pending)
165      end      end
166  end  end

Legend:
Removed from v.361  
changed lines
  Added in v.375

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