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
[smlnj] / 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 398, Wed Aug 25 15:36:43 1999 UTC revision 399, Thu Aug 26 09:55:09 1999 UTC
# Line 13  Line 13 
13      type symenv = E.symenv      type symenv = E.symenv
14      type result = { stat: statenv, sym: symenv }      type result = { stat: statenv, sym: symenv }
15      type ed = { ii: IInfo.info, ctxt: statenv }      type ed = { ii: IInfo.info, ctxt: statenv }
     type env = { envs: unit -> result, pids: PidSet.set }  
16  in  in
17      signature COMPILE = sig      signature COMPILE = sig
18          (* reset internal persistent state *)          (* reset internal persistent state *)
19          val reset : unit -> unit          val reset : unit -> unit
20    
21            (* notify linkage module about recompilation *)
22            type notifier = SmlInfo.info -> unit
23    
24          val sizeBFC : SmlInfo.info -> int          val sizeBFC : SmlInfo.info -> int
25          val writeBFC : BinIO.outstream -> SmlInfo.info -> unit          val writeBFC : BinIO.outstream -> SmlInfo.info -> unit
26          val getII : SmlInfo.info -> IInfo.info          val getII : SmlInfo.info -> IInfo.info
27          val newTraversal : unit ->  
28              { sbnode: GP.info -> DG.sbnode -> ed option,          val newSbnodeTraversal : notifier -> GP.info -> DG.sbnode -> ed option
29                impexp: GP.info -> DG.impexp -> env option }  
30          val  recomp: GP.info -> GG.group -> bool          val newTraversal : notifier * GG.group ->
31                { group: GP.info -> result option,
32                  exports: (GP.info -> result option) SymbolMap.map }
33      end      end
34    
35      functor CompileFn (structure MachDepVC : MACHDEP_VC) :> COMPILE = struct      functor CompileFn (structure MachDepVC : MACHDEP_VC) :> COMPILE = struct
36    
37            type notifier = SmlInfo.info -> unit
38    
39          structure BF = MachDepVC.Binfile          structure BF = MachDepVC.Binfile
40    
41          type bfc = BF.bfContent          type bfc = BF.bfContent
# Line 42  Line 49 
49                        | unequal => unequal                        | unequal => unequal
50              end)              end)
51    
52            type env = { envs: unit -> result, pids: PidSet.set }
53          type envdelta =          type envdelta =
54              { ii: IInfo.info, ctxt: unit -> statenv, bfc: bfc option }              { ii: IInfo.info, ctxt: unit -> statenv, bfc: bfc option }
55    
# Line 117  Line 125 
125              end              end
126          end          end
127    
128          (* This is a bit ugly because somehow we need to mix dummy          local
          * dynamic envs into the equation just to be able to use  
          * concatEnv.  But, alas', that's life... *)  
         fun rlayer (r, r') = let  
129              fun r2e { stat, sym } = E.mkenv { static = stat, symbolic = sym,              fun r2e { stat, sym } = E.mkenv { static = stat, symbolic = sym,
130                                                dynamic = DE.empty }                                                dynamic = DE.empty }
131              fun e2r e = { stat = E.staticPart e, sym = E.symbolicPart e }              fun e2r e = { stat = E.staticPart e, sym = E.symbolicPart e }
132          in          in
133              e2r (E.concatEnv (r2e r, r2e r'))              (* This is a bit ugly because somehow we need to mix dummy
134                 * dynamic envs into the equation just to be able to use
135                 * concatEnv.  But, alas', that's life... *)
136                fun rlayer (r, r') = e2r (E.concatEnv (r2e r, r2e r'))
137    
138                val emptyEnv =
139                    { envs = fn () => e2r E.emptyEnv, pids = PidSet.empty }
140          end          end
141    
142          fun layer ({ envs = e, pids = p }, { envs = e', pids = p' }) =          fun layer ({ envs = e, pids = p }, { envs = e', pids = p' }) =
143              { envs = fn () => rlayer (e (), e' ()),              { envs = fn () => rlayer (e (), e' ()),
144                pids = PidSet.union (p, p') }                pids = PidSet.union (p, p') }
145    
         fun newTraversal ()  = let  
             val localmap = ref SmlInfoMap.empty  
   
             fun pervenv (gp: GP.info) = let  
                 val e = #pervasive (#param gp)  
                 val ste = E.staticPart e  
                 val sye = E.symbolicPart e  
             in  
                 { envs = fn () => { stat = ste, sym = sye },  
                   pids = PidSet.empty }  
             end  
   
146              fun layerwork k w v0 l = let              fun layerwork k w v0 l = let
147                  fun lw v0 [] = v0                  fun lw v0 [] = v0
148                    | lw NONE (h :: t) =                    | lw NONE (h :: t) =
# Line 159  Line 158 
158                  lw v0 l                  lw v0 l
159              end              end
160    
161            fun mkTraversal notify = let
162                val localmap = ref SmlInfoMap.empty
163    
164                fun pervenv (gp: GP.info) = let
165                    val e = #pervasive (#param gp)
166                    val ste = E.staticPart e
167                    val sye = E.symbolicPart e
168                in
169                    { envs = fn () => { stat = ste, sym = sye },
170                      pids = PidSet.empty }
171                end
172    
173              fun sbnode gp n =              fun sbnode gp n =
174                  case n of                  case n of
175                      DG.SB_BNODE (_, ii) =>                      DG.SB_BNODE (_, ii) =>
# Line 198  Line 209 
209                          fun cleanup () =                          fun cleanup () =
210                              OS.FileSys.remove binname handle _ => ()                              OS.FileSys.remove binname handle _ => ()
211                      in                      in
212                            notify i;
213                          SafeIO.perform { openIt =                          SafeIO.perform { openIt =
214                                             fn () => AutoDir.openBinOut binname,                                             fn () => AutoDir.openBinOut binname,
215                                           closeIt = BinIO.closeOut,                                           closeIt = BinIO.closeOut,
# Line 314  Line 326 
326              end (* snode *)              end (* snode *)
327    
328              fun impexp gp (n, _) = fsbnode gp n              fun impexp gp (n, _) = fsbnode gp n
   
             fun envdelta2ed { ii, bfc, ctxt } = { ii = ii, ctxt = ctxt () }  
329          in          in
330              { sbnode = fn gp => fn n => Option.map envdelta2ed (sbnode gp n),              { sbnode = sbnode, impexp = impexp }
               impexp = impexp }  
331          end          end
332    
333          fun recomp gp (GG.GROUP { exports, ... }) = let          fun newTraversal (notify, GG.GROUP { exports, ... }) = let
334              val { impexp, ... } = newTraversal ()              val { impexp, ... } = mkTraversal notify
335                fun group gp = let
336              val k = #keep_going (#param gp)              val k = #keep_going (#param gp)
337              fun loop ([], success) = success              fun loop ([], success) = success
338                | loop (h :: t, success) =                | loop (h :: t, success) =
339                  if isSome (impexp gp h) then loop (t, success)                  if isSome (impexp gp h) then loop (t, success)
340                  else if k then loop (t, false) else false                  else if k then loop (t, false) else false
341                    val eo =
342                        layerwork k (impexp gp) (SOME emptyEnv)
343                        (SymbolMap.listItems exports)
344                in
345                    case eo of
346                        NONE => NONE
347                      | SOME e => SOME (#envs e ())
348                end
349                fun mkExport ie gp =
350                    case impexp gp ie of
351                        NONE => NONE
352                      | SOME e => SOME (#envs e ())
353            in
354                { group = group,
355                  exports = SymbolMap.map mkExport exports }
356            end
357    
358            fun newSbnodeTraversal notify = let
359                val { sbnode, ... } = mkTraversal notify
360                fun envdelta2ed { ii, bfc, ctxt } = { ii = ii, ctxt = ctxt () }
361          in          in
362              loop (SymbolMap.listItems exports, true)              fn gp => fn n => Option.map envdelta2ed (sbnode gp n)
363          end          end
364    
365          local          local
Legend:
Removed from v.398  
changed lines
  Added in v.399
root@smlnj-gforge.cs.uchicago.edu
 ViewVC Help
Powered by ViewVC 1.0.0  
Powered By FusionForge