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 375, Wed Jul 7 03:08:04 1999 UTC revision 403, Tue Aug 31 07:44:29 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      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 : (unit -> GeneralParams.info) ->      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  functor AutoLoadFn (structure RT : TRAVERSAL  functor AutoLoadFn (structure C : COMPILE
29                          where type result =                      structure L : LINK
30                            { stat: E.staticEnv, sym: E.symenv }                      structure BFC : BFC
31                      structure ET : TRAVERSAL                      sharing type C.bfc = L.bfc = BFC.bfc) :> AUTOLOAD = struct
                         where type result = E.dynenv):> AUTOLOAD = struct  
32    
33      structure SE = GenericVC.StaticEnv      structure SE = GenericVC.StaticEnv
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 =      val pending = ref (SymbolMap.empty: (DG.impexp * traversal) SymbolMap.map)
         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, GG.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 54  Line 54 
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 *)          (* make traversal states *)
57          val rts = RT.start ()          val { store, get } = BFC.new ()
58          val ets = ET.start ()          val { exports = cTrav, ... } = C.newTraversal (L.evict, store, g)
59          fun addState n = (n, rts, ets)          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 :=          pending := SymbolMap.unionWith #1 (newNodes, !pending)
         SymbolMap.unionWith #1 (SymbolMap.map addState exports, !pending)  
76      end      end
77    
78      fun mkManager get_ginfo (ast, ter: ER.envref) = let      fun mkManager get_ginfo (ast, ter: ER.envref) = let
79    
80          val gp = get_ginfo ()          val gp = get_ginfo ()
81    
82          fun loadit m =          fun loadit m = let
83              case RT.resume (fn ((n, _), rts, ets) => (n, rts)) gp m of              fun one ((_, tr), NONE) = NONE
84                  | one ((_, tr), SOME e) =
85                    (case tr gp of
86                  NONE => NONE                  NONE => NONE
87                | SOME { stat, sym } => let                     | SOME e' => let
88                      fun exec () =                           val be = GenericVC.CoerceEnv.e2b e'
                         ET.resume (fn ((n, _), rts, ets) => (n, ets)) gp m  
89                  in                  in
90                      case exec () of                           SOME (BE.concatEnv (be, e))
91                          NONE => NONE                       end)
                       | SOME dyn => let  
                             val e = E.mkenv { static = stat, symbolic = sym,  
                                               dynamic =dyn }  
                             val be = GenericVC.CoerceEnv.e2b e  
92                          in                          in
93                              SOME be              (* make sure that there are no stale value around... *)
94                          end              L.cleanup gp;
95                SymbolMap.foldl one (SOME BE.emptyEnv) m
96                  end                  end
97    
98          val { skeleton, ... } =          val { skeleton, ... } =
# Line 98  Line 108 
108          val _ = pending := pend          val _ = pending := pend
109          val (dae, _) = Statenv2DAEnv.cvt ste          val (dae, _) = Statenv2DAEnv.cvt ste
110          val load = ref SymbolMap.empty          val load = ref SymbolMap.empty
111          fun lookpend sy =          fun lookpend sy = let
112                fun otherwise _ = EM.impossible "Autoload:lookpend"
113            in
114              case SymbolMap.find (pend, sy) of              case SymbolMap.find (pend, sy) of
115                  SOME (x as ((_, e), _, _)) =>                  SOME (x as ((_, e), _)) =>
116                      (load := SymbolMap.insert (!load, sy, x);                      (load := SymbolMap.insert (!load, sy, x);
117                       e)                       BuildDepend.look otherwise e sy)
118                | NONE => DAEnv.EMPTY                | NONE => DAEnv.EMPTY
119            end
120          val lookimport = BuildDepend.look lookpend dae          val lookimport = BuildDepend.look lookpend dae
121          val _ = BuildDepend.processOneSkeleton lookimport skeleton          val _ = BuildDepend.processOneSkeleton lookimport skeleton
122    
# Line 116  Line 129 
129           * their corresponding node has been picked.  So we first build           * their corresponding node has been picked.  So we first build
130           * three sets: sml- and stable-infos of picked nodes as well           * three sets: sml- and stable-infos of picked nodes as well
131           * as the set of PNODEs: *)           * as the set of PNODEs: *)
132          fun add ((((_, DG.SB_SNODE (DG.SNODE { smlinfo, ... })), _), _, _),          fun add ((((_, DG.SB_SNODE (DG.SNODE { smlinfo, ... })), _), _),
133                   (ss, bs, ps)) =                   (ss, bs, ps)) =
134              (SmlInfoSet.add (ss, smlinfo), bs, ps)              (SmlInfoSet.add (ss, smlinfo), bs, ps)
135            | add ((((_, DG.SB_BNODE (DG.BNODE { bininfo, ... })), _), _, _),            | add ((((_, DG.SB_BNODE (DG.BNODE { bininfo, ... }, _)), _), _),
136                   (ss, bs, ps)) =                   (ss, bs, ps)) =
137              (ss, StableSet.add (bs, bininfo), ps)              (ss, StableSet.add (bs, bininfo), ps)
138            | add ((((_, DG.SB_BNODE (DG.PNODE p)), _), _, _), (ss, bs, ps)) =            | add ((((_, DG.SB_BNODE (DG.PNODE p, _)), _), _), (ss, bs, ps)) =
139              (ss, bs, StringSet.add (ps, Primitive.toString p))              (ss, bs, StringSet.add (ps, Primitive.toString p))
140    
141          val (smlinfos, stableinfos, prims) =          val (smlinfos, stableinfos, prims) =
# Line 131  Line 144 
144                    loadmap0                    loadmap0
145    
146          (* now we can easily find out whether a node has been picked... *)          (* now we can easily find out whether a node has been picked... *)
147          fun isPicked (((_, DG.SB_SNODE (DG.SNODE n)), _), _, _) =          fun isPicked (((_, DG.SB_SNODE (DG.SNODE n)), _), _) =
148              SmlInfoSet.member (smlinfos, #smlinfo n)              SmlInfoSet.member (smlinfos, #smlinfo n)
149            | isPicked (((_, DG.SB_BNODE (DG.BNODE n)), _), _, _) =            | isPicked (((_, DG.SB_BNODE (DG.BNODE n, _)), _), _) =
150              StableSet.member (stableinfos, #bininfo n)              StableSet.member (stableinfos, #bininfo n)
151            | isPicked (((_, DG.SB_BNODE (DG.PNODE p)), _), _, _) =            | isPicked (((_, DG.SB_BNODE (DG.PNODE p, _)), _), _) =
152              StringSet.member (prims, Primitive.toString p)              StringSet.member (prims, Primitive.toString p)
153    
154          val loadmap = SymbolMap.filter isPicked pend          val loadmap = SymbolMap.filter isPicked pend
# Line 158  Line 171 
171                             (#set ter (BE.concatEnv (e, te));                             (#set ter (BE.concatEnv (e, te));
172                              pending := noloadmap;                              pending := noloadmap;
173                              Say.say ["[autoloading done]\n"])                              Say.say ["[autoloading done]\n"])
174                       | NONE => Say.say ["[autoloading failed]\n"]) })                       | NONE => raise Fail "unable to load module(s)") }
175                  handle Fail msg =>
176                      Say.say ["[autoloading failed: ", msg, "]\n"])
177      end      end
178    
179      fun getPending () = SymbolMap.map #1 (!pending)      fun getPending () = SymbolMap.map #1 (!pending)

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

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