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/compile/compile.sml
ViewVC logotype

Diff of /sml/trunk/src/cm/compile/compile.sml

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

revision 402, Fri Aug 27 07:50:43 1999 UTC revision 403, Tue Aug 31 07:44:29 1999 UTC
# Line 31  Line 31 
31          (* notify linkage module about recompilation *)          (* notify linkage module about recompilation *)
32          type notifier = GP.info -> SmlInfo.info -> unit          type notifier = GP.info -> SmlInfo.info -> unit
33    
34          val sizeBFC : SmlInfo.info -> int          (* type of a function to store away the binfile contents *)
35          val writeBFC : BinIO.outstream -> SmlInfo.info -> unit          type bfcReceiver = SmlInfo.info * bfc -> unit
36    
37          val getII : SmlInfo.info -> IInfo.info          val getII : SmlInfo.info -> IInfo.info
         val getBFC : SmlInfo.info -> bfc  
38    
39          val evict : SmlInfo.info -> unit          val evict : SmlInfo.info -> unit
40          val evictAll : unit -> unit          val evictAll : unit -> unit
41    
42          val newSbnodeTraversal : unit -> GP.info -> DG.sbnode -> ed option          val newSbnodeTraversal : unit -> GP.info -> DG.sbnode -> ed option
43    
44          val newTraversal : notifier * GG.group ->          val newTraversal : notifier * bfcReceiver * GG.group ->
45              { group: GP.info -> result option,              { group: GP.info -> result option,
46                exports: (GP.info -> result option) SymbolMap.map }                exports: (GP.info -> result option) SymbolMap.map }
47      end      end
# Line 56  Line 56 
56    
57          type bfc = BF.bfContent          type bfc = BF.bfContent
58    
59            type bfcReceiver = SmlInfo.info * bfc -> unit
60    
61          structure FilterMap = BinaryMapFn          structure FilterMap = BinaryMapFn
62              (struct              (struct
63                  type ord_key = pid * SymbolSet.set                  type ord_key = pid * SymbolSet.set
# Line 65  Line 67 
67                        | unequal => unequal                        | unequal => unequal
68              end)              end)
69    
70            type bfinfo =
71                { cmdata: PidSet.set,
72                  statenv: unit -> statenv,
73                  symenv: unit -> symenv,
74                  statpid: pid,
75                  sympid: pid }
76    
77          type env = { envs: unit -> result, pids: PidSet.set }          type env = { envs: unit -> result, pids: PidSet.set }
78          type envdelta =          type envdelta = { ii: IInfo.info, ctxt: unit -> statenv }
             { ii: IInfo.info, ctxt: unit -> statenv, bfc: bfc option }  
79    
80          type memo = { bfc: bfc, ctxt: statenv, ts: TStamp.t }          type memo =
81                { ii: IInfo.info, ctxt: statenv, ts: TStamp.t, cmdata: PidSet.set }
82    
83          (* persistent state! *)          (* persistent state! *)
84          val filtermap = ref (FilterMap.empty: pid FilterMap.map)          val filtermap = ref (FilterMap.empty: pid FilterMap.map)
# Line 84  Line 93 
93          fun isValidMemo (memo: memo, provided, smlinfo) =          fun isValidMemo (memo: memo, provided, smlinfo) =
94              not (TStamp.needsUpdate { source = SmlInfo.lastseen smlinfo,              not (TStamp.needsUpdate { source = SmlInfo.lastseen smlinfo,
95                                        target = #ts memo })                                        target = #ts memo })
96              andalso let              andalso PidSet.equal (provided, #cmdata memo)
97                  val demanded =  
98                      PidSet.addList (PidSet.empty, BF.cmDataOf (#bfc memo))          fun memo2ii (memo: memo) = #ii memo
99              in  
100                  PidSet.equal (provided, demanded)          fun memo2ed memo = { ii = memo2ii memo, ctxt = fn () => #ctxt memo }
101              end  
102            fun bfc2memo (bfc, ctxt, ts) = let
103          fun memo2ii (memo: memo) =              val ii = { statenv = fn () => BF.senvOf bfc,
104              { statenv = fn () => BF.senvOf (#bfc memo),                         symenv = fn () => BF.symenvOf bfc,
105                symenv = fn () => BF.symenvOf (#bfc memo),                         statpid = BF.staticPidOf bfc,
106                statpid = BF.staticPidOf (#bfc memo),                         sympid = BF.lambdaPidOf bfc }
107                sympid = BF.lambdaPidOf (#bfc memo) }              val cmdata = PidSet.addList (PidSet.empty, BF.cmDataOf bfc)
108            in
109          fun memo2ed memo =              { ii = ii, ctxt = ctxt, ts = ts, cmdata = cmdata }
110              { ii = memo2ii memo,          end
               ctxt = fn () => #ctxt memo,  
               bfc = SOME (#bfc memo) }  
111    
112          fun pidset (p1, p2) = PidSet.add (PidSet.singleton p1, p2)          fun pidset (p1, p2) = PidSet.add (PidSet.singleton p1, p2)
113    
114          fun nofilter (ed: envdelta) = let          fun nofilter (ed: envdelta) = let
115              val { ii = { statenv, symenv, statpid, sympid }, ctxt, bfc } = ed              val { ii = { statenv, symenv, statpid, sympid }, ctxt } = ed
116          in          in
117              { envs = fn () => { stat = statenv (), sym = symenv () },              { envs = fn () => { stat = statenv (), sym = symenv () },
118                pids = pidset (statpid, sympid) }                pids = pidset (statpid, sympid) }
# Line 114  Line 121 
121          fun exportsNothingBut set se =          fun exportsNothingBut set se =
122              List.all (fn sy => SymbolSet.member (set, sy)) (E.catalogEnv se)              List.all (fn sy => SymbolSet.member (set, sy)) (E.catalogEnv se)
123    
124          fun filter ({ ii, ctxt, bfc }: envdelta, s) = let          fun filter ({ ii, ctxt }: envdelta, s) = let
125              val { statenv, symenv, statpid, sympid } = ii              val { statenv, symenv, statpid, sympid } = ii
126              val ste = statenv ()              val ste = statenv ()
127          in          in
# Line 174  Line 181 
181              lw v0 l              lw v0 l
182          end          end
183    
184          fun mkTraversal notify = let          fun mkTraversal (notify, storeBFC) = let
185              val localstate = ref SmlInfoMap.empty              val localstate = ref SmlInfoMap.empty
186    
187              fun pervenv (gp: GP.info) = let              fun pervenv (gp: GP.info) = let
# Line 203  Line 210 
210                           * minor issue anyway, and in the present case                           * minor issue anyway, and in the present case
211                           * it only happens when a stable library is                           * it only happens when a stable library is
212                           * replaced by a different one. *)                           * replaced by a different one. *)
213                          SOME { ii = ii, ctxt = #statenv ii, bfc = NONE }                          SOME { ii = ii, ctxt = #statenv ii }
214                    | DG.SB_SNODE n => snode gp n                    | DG.SB_SNODE n => snode gp n
215    
216              and fsbnode gp (f, n) =              and fsbnode gp (f, n) =
# Line 260  Line 267 
267                                                    senv = stat,                                                    senv = stat,
268                                                    symenv = sym,                                                    symenv = sym,
269                                                    corenv = corenv }                                                    corenv = corenv }
270                              val memo = { bfc = bfc, ctxt = stat,                              val memo = bfc2memo (bfc, stat, SmlInfo.lastseen i)
                                          ts = SmlInfo.lastseen i}  
271                          in                          in
                             SmlInfo.forgetParsetree i;  
272                              save bfc;                              save bfc;
273                                storeBFC (i, bfc);
274                              SOME memo                              SOME memo
275                          end                          end
276                  end (* compile *)                  end (* compile *)
# Line 295  Line 301 
301                                                     name = binname,                                                     name = binname,
302                                                     senv = stat },                                                     senv = stat },
303                                           ts)                                           ts)
304                                          before  
                                         Say.vsay ["[", binname, " loaded]\n"]  
305                                  in                                  in
306                                      SOME (SafeIO.perform                                      SOME (SafeIO.perform
307                                            { openIt = openIt,                                            { openIt = openIt,
# Line 309  Line 314 
314                                  case load () of                                  case load () of
315                                      NONE => compile (stat, sym, pids)                                      NONE => compile (stat, sym, pids)
316                                    | SOME (bfc, ts) => let                                    | SOME (bfc, ts) => let
317                                          val memo = { bfc = bfc,                                          val memo = bfc2memo (bfc, stat, ts)
                                                      ctxt = stat,  
                                                      ts = ts }  
318                                      in                                      in
319                                          if isValidMemo (memo, pids, i) then                                          if isValidMemo (memo, pids, i) then
320                                              SOME memo                                              (Say.vsay ["[", binname,
321                                                           " loaded]\n"];
322                                                 storeBFC (i, bfc);
323                                                 SOME memo)
324                                          else compile (stat, sym, pids)                                          else compile (stat, sym, pids)
325                                      end                                      end
326                              end (* fromfile *)                              end (* fromfile *)
# Line 341  Line 347 
347                    | NONE => let                    | NONE => let
348                          val mopt = notlocal ()                          val mopt = notlocal ()
349                      in                      in
350                            (* "Not local" means that we have not processed
351                             * this file before.  Therefore, we should now
352                             * remove its parse tree... *)
353                            SmlInfo.forgetParsetree i;
354                          localstate :=                          localstate :=
355                            SmlInfoMap.insert (!localstate, i, mopt);                            SmlInfoMap.insert (!localstate, i, mopt);
356                          Option.map memo2ed mopt                          Option.map memo2ed mopt
# Line 352  Line 362 
362              { sbnode = sbnode, impexp = impexp }              { sbnode = sbnode, impexp = impexp }
363          end          end
364    
365          fun newTraversal (notify, GG.GROUP { exports, ... }) = let          fun newTraversal (notify, storeBFC, GG.GROUP { exports, ... }) = let
366              val { impexp, ... } = mkTraversal notify              val { impexp, ... } = mkTraversal (notify, storeBFC)
367              fun group gp = let              fun group gp = let
368                  val k = #keep_going (#param gp)                  val k = #keep_going (#param gp)
369                  fun loop ([], success) = success                  fun loop ([], success) = success
# Line 378  Line 388 
388          end          end
389    
390          fun newSbnodeTraversal () = let          fun newSbnodeTraversal () = let
391              val { sbnode, ... } = mkTraversal (fn _ => fn _ => ())              val { sbnode, ... } = mkTraversal (fn _ => fn _ => (),
392              fun envdelta2ed { ii, bfc, ctxt } = { ii = ii, ctxt = ctxt () }                                                 fn _ => ())
393                fun envdelta2ed { ii, ctxt } = { ii = ii, ctxt = ctxt () }
394          in          in
395              fn gp => fn n => Option.map envdelta2ed (sbnode gp n)              fn gp => fn n => Option.map envdelta2ed (sbnode gp n)
396          end          end
397    
         local  
             fun get i = valOf (SmlInfoMap.find (!globalstate, i))  
         in  
             fun sizeBFC i = BF.size { content = #bfc (get i), nopickle = true }  
             fun writeBFC s i = BF.write { content = #bfc (get i),  
                                           stream = s, nopickle = true }  
             fun getII i = memo2ii (get i)  
             fun getBFC i = #bfc (get i)  
   
398              fun evict i =              fun evict i =
399                  (globalstate := #1 (SmlInfoMap.remove (!globalstate, i)))                  (globalstate := #1 (SmlInfoMap.remove (!globalstate, i)))
400                  handle LibBase.NotFound => ()                  handle LibBase.NotFound => ()
401    
402              fun evictAll () = globalstate := SmlInfoMap.empty              fun evictAll () = globalstate := SmlInfoMap.empty
403          end  
404            fun getII i = memo2ii (valOf (SmlInfoMap.find (!globalstate, i)))
405      end      end
406  end  end

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

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