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

Diff of /sml/trunk/src/cm/stable/stabilize.sml

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

revision 309, Wed Jun 2 03:21:57 1999 UTC revision 311, Wed Jun 2 09:08:48 1999 UTC
# Line 9  Line 9 
9      structure DG = DependencyGraph      structure DG = DependencyGraph
10      structure GG = GroupGraph      structure GG = GroupGraph
11      structure EM = GenericVC.ErrorMsg      structure EM = GenericVC.ErrorMsg
12        structure PP = PrettyPrint
13        structure SM = GenericVC.SourceMap
14      structure GP = GeneralParams      structure GP = GeneralParams
15      structure E = GenericVC.Environment      structure E = GenericVC.Environment
16    
17        type statenvgetter = GP.info -> DG.bnode -> E.staticEnv
18        type recomp = GG.group * GP.info -> bool
19  in  in
20    
21  signature STABILIZE = sig  signature STABILIZE = sig
22    
23      val loadStable :      val loadStable :
24          GP.info * (AbsPath.t -> GG.group) ->          GP.info * (AbsPath.t -> GG.group option) * bool ref ->
25          { group: AbsPath.t, s: BinIO.instream, anyerrors: bool ref } ->          AbsPath.t -> GG.group option
         GG.group option  
26    
27      val stabilize :      val stabilize :
28          GP.info ->          GP.info -> { group: GG.group, anyerrors: bool ref } ->
29          { group: GG.group, s: BinIO.outstream, anyerrors: bool ref } ->          GG.group option
         GG.group  
30  end  end
31    
32  functor StablizeFn  functor StabilizeFn (val bn2statenv : statenvgetter
33      (val bn2statenv : GP.info -> DG.bnode -> E.staticEnv                       val recomp: recomp) :> STABILIZE = struct
      val binSizeOf : SmlInfo.info -> int  
      val copyBin : BinIO.outstream -> SmlInfo.info -> unit) :> STABILIZE =  
 struct  
   
34    
35      datatype pitem =      datatype pitem =
36          PSS of SymbolSet.set          PSS of SymbolSet.set
# Line 77  Line 76 
76          SymbolMap.foldl add IntBinaryMap.empty exports          SymbolMap.foldl add IntBinaryMap.empty exports
77      end      end
78    
79      fun stabilize gp { group = g as GG.GROUP grec, s = outs, anyerrors } =      fun deleteFile n = OS.FileSys.remove n
80          case #stableinfo grec of          handle e as Interrupt.Interrupt => raise e
81              GG.STABLE _ => g               | _ => ()
82            | GG.NONSTABLE granted => let  
83        fun stabilize gp { group = g as GG.GROUP grec, anyerrors } = let
84    
85            fun doit granted = let
86                val bname = AbsPath.name o SmlInfo.binpath
87                val bsz = OS.FileSys.fileSize o bname
88                fun cpb s i = let
89                    val ins = BinIO.openIn (bname i)
90                    fun cp () =
91                        if BinIO.endOfStream ins then ()
92                        else (BinIO.output (s, BinIO.input ins); cp ())
93                in
94                    cp () handle e => (BinIO.closeIn ins; raise e);
95                        BinIO.closeIn ins
96                end
97                val delb = deleteFile o bname
98    
99                  val grpSrcInfo = (#errcons gp, anyerrors)                  val grpSrcInfo = (#errcons gp, anyerrors)
100    
101                  val exports = #exports grec                  val exports = #exports grec
102                  val islib = #islib grec                  val islib = #islib grec
103                  val required = StringSet.difference (#required grec,              val required = StringSet.difference (#required grec, granted)
                                                      granted)  
104                  val grouppath = #grouppath grec                  val grouppath = #grouppath grec
105                  val subgroups = #subgroups grec                  val subgroups = #subgroups grec
106    
# Line 181  Line 194 
194                      fun esc #"\\" = "\\\\"                      fun esc #"\\" = "\\\\"
195                        | esc #"\"" = "\\\""                        | esc #"\"" = "\\\""
196                        | esc c = String.str c                        | esc c = String.str c
   
197                  in                  in
198                      String.translate esc s :: "\"" :: k m                      String.translate esc s :: "\"" :: k m
199                  end                  end
# Line 193  Line 205 
205                  fun w_si i k = let                  fun w_si i k = let
206                      val spec = AbsPath.spec (SmlInfo.sourcepath i)                      val spec = AbsPath.spec (SmlInfo.sourcepath i)
207                      val locs = SmlInfo.errorLocation gp i                      val locs = SmlInfo.errorLocation gp i
208                      val offset = registerOffset (i, binSizeOf i)                  val offset = registerOffset (i, bsz i)
209                  in                  in
210                      w_string spec                      w_string spec
211                          (w_string locs                          (w_string locs
# Line 203  Line 215 
215    
216                  fun w_primitive p k m = String.str (Primitive.toIdent p) :: k m                  fun w_primitive p k m = String.str (Primitive.toIdent p) :: k m
217    
218                  fun w_abspath_raw p k m =              fun w_abspath_raw p k m = w_list w_string (AbsPath.pickle p) k m
                     w_list w_string (AbsPath.pickle p) k m  
219    
220                  val w_abspath = w_share w_abspath_raw PAP                  val w_abspath = w_share w_abspath_raw PAP
221    
# Line 239  Line 250 
250                      fun k0 m = []                      fun k0 m = []
251                      val m0 = (0, Map.empty)                      val m0 = (0, Map.empty)
252                  in                  in
253                      concat                  concat (w_exports exports
                        (w_exports exports  
254                             (w_bool islib                             (w_bool islib
255                                (w_privileges required                                (w_privileges required
256                                      (w_list w_sg subgroups k0))) m0)                                      (w_list w_sg subgroups k0))) m0)
# Line 302  Line 312 
312                  in                  in
313                      BinIO.output (s, Word8Array.extract (a, 0, NONE))                      BinIO.output (s, Word8Array.extract (a, 0, NONE))
314                  end                  end
315              in              val memberlist = rev (!members)
316    
317                val policy = #fnpolicy (#param gp)
318                val gpath = #grouppath grec
319                val spath = FilenamePolicy.mkStablePath policy gpath
320                fun delete () = deleteFile (AbsPath.name spath)
321                val outs = AbsPath.openBinOut spath
322                fun try () =
323                    (Say.vsay ["[stabilizing ", AbsPath.name gpath, "]\n"];
324                  writeInt32 (outs, sz);                  writeInt32 (outs, sz);
325                  BinIO.output (outs, Byte.stringToBytes pickle);                  BinIO.output (outs, Byte.stringToBytes pickle);
326                  app (copyBin outs) (rev (!members));                   app (cpb outs) memberlist;
327                  mkStableGroup ()                   app delb memberlist;
328                     BinIO.closeOut outs;
329                     SOME (mkStableGroup ()))
330            in
331                Interrupt.guarded try
332                handle e as Interrupt.Interrupt => (BinIO.closeOut outs;
333                                                    delete ();
334                                                    raise e)
335                     | exn => (BinIO.closeOut outs; NONE)
336            end
337        in
338            case #stableinfo grec of
339                GG.STABLE _ => SOME g
340              | GG.NONSTABLE granted =>
341                    if not (recomp (g, gp)) then
342                        (anyerrors := true; NONE)
343                    else let
344                        fun notStable (GG.GROUP { stableinfo, ... }) =
345                            case stableinfo of
346                                GG.STABLE _ => false
347                              | GG.NONSTABLE _ => true
348                    in
349                        case List.filter notStable (#subgroups grec) of
350                            [] => doit granted
351                          | l => let
352                                val grammar = case l of [_] => " is" | _ => "s are"
353                                fun ppb pps = let
354                                    fun loop [] = ()
355                                      | loop (GG.GROUP { grouppath, ... } :: t) =
356                                        (PP.add_string pps
357                                            (AbsPath.name grouppath);
358                                         PP.add_newline pps;
359                                         loop t)
360                                in
361                                    PP.add_newline pps;
362                                    PP.add_string pps
363                                        (concat ["because the following sub-group",
364                                                 grammar, " not stable:"]);
365                                    PP.add_newline pps;
366                                    loop l
367                                end
368                                val errcons = #errcons gp
369                                val gname = AbsPath.name (#grouppath grec)
370                            in
371                                EM.errorNoFile (errcons, anyerrors) SM.nullRegion
372                                   EM.COMPLAIN
373                                   (gname ^ " cannot be stabilized")
374                                   ppb;
375                                NONE
376                            end
377                    end
378              end              end
379    
380      fun loadStable (gp, getGroup) { group, s, anyerrors } = let      fun loadStable (gp, getGroup, anyerrors) group = let
381    
382          val bn2env = #1 o Statenv2DAEnv.cvt o bn2statenv gp          fun bn2env n = Statenv2DAEnv.cvtMemo (fn () => bn2statenv gp n)
383    
384          val grpSrcInfo = (#errcons gp, anyerrors)          val errcons = #errcons gp
385            val grpSrcInfo = (errcons, anyerrors)
386            val gname = AbsPath.name group
387            fun error l = EM.errorNoFile (errcons, anyerrors) SM.nullRegion
388                EM.COMPLAIN (concat (gname :: ": " :: l)) EM.nullErrorBody
389    
390          exception Format          exception Format
391    
392            val policy = #fnpolicy (#param gp)
393            val spath = FilenamePolicy.mkStablePath policy group
394            val _ = Say.vsay ["[checking stable ", gname, "]\n"]
395            val s = AbsPath.openBinIn spath
396    
397            fun getGroup' p =
398                case getGroup p of
399                    SOME g => g
400                  | NONE =>
401                        (error ["unable to find ", AbsPath.name p];
402                         raise Format)
403    
404          (* for getting sharing right... *)          (* for getting sharing right... *)
405          val m = ref IntBinaryMap.empty          val m = ref IntBinaryMap.empty
406          val next = ref 0          val next = ref 0
# Line 476  Line 560 
560                | #"b" => let                | #"b" => let
561                      val p = r_abspath ()                      val p = r_abspath ()
562                      val os = r_int ()                      val os = r_int ()
                     val GG.GROUP { stableinfo, ... } = getGroup p  
563                  in                  in
564                      case stableinfo of                      case getGroup' p of
565                          GG.NONSTABLE _ => raise Format                          GG.GROUP { stableinfo = GG.STABLE im, ... } =>
                       | GG.STABLE im =>  
566                              (case IntBinaryMap.find (im, os) of                              (case IntBinaryMap.find (im, os) of
567                                   NONE => raise Format                                   NONE => raise Format
568                                 | SOME n => n)                                 | SOME n => n)
569                          | _ => raise Format
570                  end                  end
571                | _ => raise Format                | _ => raise Format
572    
# Line 510  Line 593 
593              val sy = r_symbol ()              val sy = r_symbol ()
594              val (f, n) = r_fsbn ()      (* really reads farbnodes! *)              val (f, n) = r_fsbn ()      (* really reads farbnodes! *)
595              val e = bn2env n              val e = bn2env n
596                (* put a filter in front to avoid having the FCTENV being
597                 * queried needlessly (this avoids spurious module loadings) *)
598                val e' = DAEnv.FILTER (SymbolSet.singleton sy, e)
599          in          in
600              (sy, ((f, DG.SB_BNODE n), e)) (* coerce to farsbnodes *)              (sy, ((f, DG.SB_BNODE n), e')) (* coerce to farsbnodes *)
601          end          end
602    
603          fun r_exports () =          fun r_exports () =
# Line 524  Line 610 
610              val exports = r_exports ()              val exports = r_exports ()
611              val islib = r_bool ()              val islib = r_bool ()
612              val required = r_privileges ()              val required = r_privileges ()
613              val subgroups = r_list (getGroup o r_abspath) ()              val subgroups = r_list (getGroup' o r_abspath) ()
614              val simap = genStableInfoMap (exports, group)              val simap = genStableInfoMap (exports, group)
615          in          in
616              GG.GROUP { exports = exports,              GG.GROUP { exports = exports,
# Line 533  Line 619 
619                         grouppath = group,                         grouppath = group,
620                         subgroups = subgroups,                         subgroups = subgroups,
621                         stableinfo = GG.STABLE simap }                         stableinfo = GG.STABLE simap }
622                before BinIO.closeIn s
623          end          end
624      in      in
625          SOME (unpickle_group ()) handle Format => NONE          SOME (unpickle_group ())
626      end          handle Format => (BinIO.closeIn s; NONE)
627                 | exn => (BinIO.closeIn s; raise exn)
628        end handle IO.Io _ => NONE
629  end  end
630    
631  end (* local *)  end (* local *)

Legend:
Removed from v.309  
changed lines
  Added in v.311

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