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 364, Fri Jul 2 07:33:12 1999 UTC revision 399, Thu Aug 26 09:55:09 1999 UTC
# Line 6  Line 6 
6   * Author: Matthias Blume (blume@kurims.kyoto-u.ac.jp)   * Author: Matthias Blume (blume@kurims.kyoto-u.ac.jp)
7   *)   *)
8  local  local
9        structure GP = GeneralParams
10      structure DG = DependencyGraph      structure DG = DependencyGraph
11      structure BE = GenericVC.BareEnvironment      structure BE = GenericVC.BareEnvironment
12      structure ER = GenericVC.EnvRef      structure ER = GenericVC.EnvRef
13      structure GG = GroupGraph      structure GG = GroupGraph
14        structure E = GenericVC.Environment
15        structure EM = GenericVC.ErrorMsg
16  in  in
17  signature AUTOLOAD = sig  signature AUTOLOAD = sig
18    
19      val register : ER.envref * GG.group -> unit      val register : ER.envref * GG.group -> unit
20    
21      val mkManager : (DG.impexp SymbolMap.map -> BE.environment option)      val mkManager : (unit -> GP.info) -> GenericVC.Ast.dec * ER.envref -> unit
         -> GenericVC.Ast.dec * ER.envref -> unit  
22    
23      val getPending : unit -> DG.impexp SymbolMap.map      val getPending : unit -> DG.impexp SymbolMap.map
24    
25      val reset : unit -> unit      val reset : unit -> unit
26  end  end
27    
28  structure AutoLoad :> AUTOLOAD = struct  functor AutoLoadFn (structure C : COMPILE
29                        structure L : LINK) :> AUTOLOAD = struct
30    
31      structure SE = GenericVC.StaticEnv      structure SE = GenericVC.StaticEnv
32    
33        type traversal = GP.info -> E.environment option
34      (* We let the topLevel env *logically* sit atop the pending      (* We let the topLevel env *logically* sit atop the pending
35       * autoload bindings.  This way we do not have to intercept every       * autoload bindings.  This way we do not have to intercept every
36       * change to the topLevel env.  However, it means that any addition       * change to the topLevel env.  However, it means that any addition
37       * to "pending" must be subtracted from the topLevel env. *)       * to "pending" must be subtracted from the topLevel env. *)
38      val pending = ref (SymbolMap.empty: DG.impexp SymbolMap.map)      val pending = ref (SymbolMap.empty: (DG.impexp * traversal) SymbolMap.map)
39    
40      fun reset () = pending := SymbolMap.empty      fun reset () = pending := SymbolMap.empty
41    
42      fun register (ter: ER.envref, GG.GROUP { exports, ... }) = let      fun register (ter: ER.envref, g as GG.GROUP { exports, ... }) = let
43          val te = #get ter ()          val te = #get ter ()
44          (* toplevel bindings (symbol set) ... *)          (* toplevel bindings (symbol set) ... *)
45          val tss = foldl SymbolSet.add' SymbolSet.empty          val tss = foldl SymbolSet.add' SymbolSet.empty
# Line 47  Line 51 
51          val rss = SymbolSet.difference (tss, nss)          val rss = SymbolSet.difference (tss, nss)
52          (* getting rid of unneeded bindings... *)          (* getting rid of unneeded bindings... *)
53          val te' = BE.filterEnv (te, SymbolSet.listItems rss)          val te' = BE.filterEnv (te, SymbolSet.listItems rss)
54            (* make traversal states *)
55            val { exports = cTrav, ... } = C.newTraversal (L.evict, g)
56            val { exports = lTrav, ... } = L.newTraversal g
57            fun combine (ss, d) gp =
58                case ss gp of
59                    SOME { stat, sym } =>
60                        (case d gp of
61                             SOME dyn => SOME (E.mkenv { static = stat,
62                                                         symbolic = sym,
63                                                         dynamic = dyn })
64                           | NONE => NONE)
65                  | NONE => NONE
66            fun mkNode (sy, ie) =
67                (ie, combine (valOf (SymbolMap.find (cTrav, sy)),
68                              valOf (SymbolMap.find (lTrav, sy))))
69            val newNodes = SymbolMap.mapi mkNode exports
70      in      in
71          #set ter te';          #set ter te';
72          pending := SymbolMap.unionWith #1 (exports, !pending)          pending := SymbolMap.unionWith #1 (newNodes, !pending)
73        end
74    
75        fun mkManager get_ginfo (ast, ter: ER.envref) = let
76    
77            val gp = get_ginfo ()
78    
79            fun loadit m = let
80                fun one ((_, tr), NONE) = NONE
81                  | one ((_, tr), SOME e) =
82                    (case tr gp of
83                         NONE => NONE
84                       | SOME e' => let
85                             val be = GenericVC.CoerceEnv.e2b e'
86                         in
87                             SOME (BE.concatEnv (be, e))
88                         end)
89            in
90                (* make sure that there are no stale value around... *)
91                L.cleanup ();
92                SymbolMap.foldl one (SOME BE.emptyEnv) m
93      end      end
94    
     fun mkManager loadit (ast, ter: ER.envref) = let  
95          val { skeleton, ... } =          val { skeleton, ... } =
96              SkelCvt.convert { tree = ast, err = fn _ => fn _ => fn _ => () }              SkelCvt.convert { tree = ast, err = fn _ => fn _ => fn _ => () }
97          val te = #get ter ()          val te = #get ter ()
# Line 66  Line 105 
105          val _ = pending := pend          val _ = pending := pend
106          val (dae, _) = Statenv2DAEnv.cvt ste          val (dae, _) = Statenv2DAEnv.cvt ste
107          val load = ref SymbolMap.empty          val load = ref SymbolMap.empty
108          fun lookpend sy =          fun lookpend sy = let
109                fun otherwise _ = EM.impossible "Autoload:lookpend"
110            in
111              case SymbolMap.find (pend, sy) of              case SymbolMap.find (pend, sy) of
112                  SOME (x as (_, e)) => (load := SymbolMap.insert (!load, sy, x);                  SOME (x as ((_, e), _)) =>
113                                         e)                      (load := SymbolMap.insert (!load, sy, x);
114                         BuildDepend.look otherwise e sy)
115                | NONE => DAEnv.EMPTY                | NONE => DAEnv.EMPTY
116            end
117          val lookimport = BuildDepend.look lookpend dae          val lookimport = BuildDepend.look lookpend dae
118          val _ = BuildDepend.processOneSkeleton lookimport skeleton          val _ = BuildDepend.processOneSkeleton lookimport skeleton
119    
# Line 83  Line 126 
126           * their corresponding node has been picked.  So we first build           * their corresponding node has been picked.  So we first build
127           * three sets: sml- and stable-infos of picked nodes as well           * three sets: sml- and stable-infos of picked nodes as well
128           * as the set of PNODEs: *)           * as the set of PNODEs: *)
129          fun add (((_, DG.SB_SNODE (DG.SNODE { smlinfo, ... })), _),          fun add ((((_, DG.SB_SNODE (DG.SNODE { smlinfo, ... })), _), _),
130                   (ss, bs, ps)) =                   (ss, bs, ps)) =
131              (SmlInfoSet.add (ss, smlinfo), bs, ps)              (SmlInfoSet.add (ss, smlinfo), bs, ps)
132            | add (((_, DG.SB_BNODE (DG.BNODE { bininfo, ... })), _),            | add ((((_, DG.SB_BNODE (DG.BNODE { bininfo, ... }, _)), _), _),
133                   (ss, bs, ps)) =                   (ss, bs, ps)) =
134              (ss, StableSet.add (bs, bininfo), ps)              (ss, StableSet.add (bs, bininfo), ps)
135            | add (((_, DG.SB_BNODE (DG.PNODE p)), _), (ss, bs, ps)) =            | add ((((_, DG.SB_BNODE (DG.PNODE p, _)), _), _), (ss, bs, ps)) =
136              (ss, bs, StringSet.add (ps, Primitive.toString p))              (ss, bs, StringSet.add (ps, Primitive.toString p))
137    
138          val (smlinfos, stableinfos, prims) =          val (smlinfos, stableinfos, prims) =
# Line 98  Line 141 
141                    loadmap0                    loadmap0
142    
143          (* now we can easily find out whether a node has been picked... *)          (* now we can easily find out whether a node has been picked... *)
144          fun isPicked ((_, DG.SB_SNODE (DG.SNODE { smlinfo, ... })), _) =          fun isPicked (((_, DG.SB_SNODE (DG.SNODE n)), _), _) =
145              SmlInfoSet.member (smlinfos, smlinfo)              SmlInfoSet.member (smlinfos, #smlinfo n)
146            | isPicked ((_, DG.SB_BNODE (DG.BNODE { bininfo, ... })), _) =            | isPicked (((_, DG.SB_BNODE (DG.BNODE n, _)), _), _) =
147              StableSet.member (stableinfos, bininfo)              StableSet.member (stableinfos, #bininfo n)
148            | isPicked ((_, DG.SB_BNODE (DG.PNODE p)), _) =            | isPicked (((_, DG.SB_BNODE (DG.PNODE p, _)), _), _) =
149              StringSet.member (prims, Primitive.toString p)              StringSet.member (prims, Primitive.toString p)
150    
151          val loadmap = SymbolMap.filter isPicked pend          val loadmap = SymbolMap.filter isPicked pend
152          val noloadmap = SymbolMap.filter (not o isPicked) pend          val noloadmap = SymbolMap.filter (not o isPicked) pend
153      in      in
154          case loadit loadmap of          if SymbolMap.isEmpty loadmap then ()
155            else
156                (Say.say ["[autoloading]\n"];
157                 SrcPath.revalidateCwd ();
158                 (* We temporarily turn verbosity off, so we need to wrap this
159                  * with a SafeIO.perform... *)
160                 SafeIO.perform
161                  { openIt = fn () =>
162                      EnvConfig.getSet StdConfig.verbose (SOME false),
163                    closeIt = ignore o (EnvConfig.getSet StdConfig.verbose) o SOME,
164                    cleanup = fn () => (),
165                    work = fn _ =>
166                      (case loadit loadmap of
167              SOME e =>              SOME e =>
168                  (#set ter (BE.concatEnv (e, te));                  (#set ter (BE.concatEnv (e, te));
169                   pending := noloadmap)                              pending := noloadmap;
170            | NONE => ()                              Say.say ["[autoloading done]\n"])
171                         | NONE => raise Fail "unable to load module(s)") }
172                  handle Fail msg =>
173                      Say.say ["[autoloading failed: ", msg, "]\n"])
174      end      end
175    
176      fun getPending () = !pending      fun getPending () = SymbolMap.map #1 (!pending)
177  end  end
178  end  end

Legend:
Removed from v.364  
changed lines
  Added in v.399

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