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

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

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

revision 629, Wed Apr 26 04:06:41 2000 UTC revision 630, Wed Apr 26 18:40:56 2000 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 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  signature AUTOLOAD = sig  signature AUTOLOAD = sig
18    
19      val register : GenericVC.EnvRef.envref * GroupGraph.group -> unit      val register : ER.envref * GG.group -> unit
20    
21      val mkManager : (DependencyGraph.impexp SymbolMap.map ->      val mkManager : (unit -> GP.info) -> GenericVC.Ast.dec * ER.envref -> unit
22                       GenericVC.BareEnvironment.environment option)  
23          -> GenericVC.Ast.dec * GenericVC.EnvRef.envref -> unit      val getPending : unit -> DG.impexp SymbolMap.map
24    
25        val reset : unit -> unit
26  end  end
27    
28  structure AutoLoad :> AUTOLOAD = struct  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    
33      structure DG = DependencyGraph      structure SE = GenericVC.StaticEnv
     structure ER = GenericVC.EnvRef  
     structure BE = GenericVC.BareEnvironment  
34    
35        type traversal = GP.info -> E.environment option
36      (* We let the topLevel env *logically* sit atop the pending      (* We let the topLevel env *logically* sit atop the pending
37       * autoload bindings.  This way we do not have to intercept every       * autoload bindings.  This way we do not have to intercept every
38       * change to the topLevel env.  However, it means that any addition       * change to the topLevel env.  However, it means that any addition
39       * to "pending" must be subtracted from the topLevel env. *)       * to "pending" must be subtracted from the topLevel env. *)
40      val pending = ref (SymbolMap.empty: DG.impexp SymbolMap.map)      val pending = ref (SymbolMap.empty: (DG.impexp * traversal) SymbolMap.map)
41    
42        fun reset () = pending := SymbolMap.empty
43    
44      fun register (ter: ER.envref, GroupGraph.GROUP { exports, ... }) = let      fun register (ter: ER.envref, g as 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 38  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 { 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      in      in
74          #set ter te';          #set ter te';
75          pending := SymbolMap.unionWith #1 (exports, !pending)          pending := SymbolMap.unionWith #1 (newNodes, !pending)
76        end
77    
78        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      end
97    
     fun mkManager loadit (ast, ter: ER.envref) = let  
98          val { skeleton, ... } =          val { skeleton, ... } =
99              SkelCvt.convert { tree = ast, err = fn _ => fn _ => fn _ => () }              SkelCvt.convert { tree = ast, err = fn _ => fn _ => fn _ => () }
100          val te = #get ter ()          val te = #get ter ()
101          val (dae, _) = Statenv2DAEnv.cvt (BE.staticPart te)          val ste = BE.staticPart te
102          val pend = !pending  
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          val load = ref SymbolMap.empty          val load = ref SymbolMap.empty
111          fun lookpend sy =          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              case SymbolMap.find (pend, sy) of              case SymbolMap.find (pend, sy) of
123                  SOME (x as (_, e)) => (load := SymbolMap.insert (!load, sy, x);                  SOME (x as ((_, e), _)) =>
124                                         e)                      (announce ();
125                         load := SymbolMap.insert (!load, sy, x);
126                         BuildDepend.look otherwise e sy)
127                | NONE => DAEnv.EMPTY                | NONE => DAEnv.EMPTY
128            end
129          val lookimport = BuildDepend.look lookpend dae          val lookimport = BuildDepend.look lookpend dae
130          val _ = BuildDepend.processOneSkeleton lookimport skeleton          val _ = BuildDepend.processOneSkeleton lookimport skeleton
131          val loadmap = !load  
132      in          (* Here are the nodes that actually have been picked because
133          case loadit loadmap of           * something demanded an exported symbol: *)
134              SOME e => let          val loadmap0 = !load
135                  val te' = BE.concatEnv (e, te)  
136                  fun notPicked (sy, _) =          (* However, we want to avoid hanging on to stuff unnecessarily, so
137                      not (isSome (SymbolMap.find (loadmap, sy)))           * we now look for symbols that become available "for free" because
138                  val pend' = SymbolMap.filteri notPicked pend           * 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              in              in
166                  #set ter te';          if SymbolMap.isEmpty loadmap then ()
167                  pending := pend'          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              end              end
186            | NONE => ()  
187        fun getPending () = SymbolMap.map #1 (!pending)
188      end      end
189  end  end

Legend:
Removed from v.629  
changed lines
  Added in v.630

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