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 310, Wed Jun 2 07:28:27 1999 UTC
# Line 11  Line 11 
11      structure EM = GenericVC.ErrorMsg      structure EM = GenericVC.ErrorMsg
12      structure GP = GeneralParams      structure GP = GeneralParams
13      structure E = GenericVC.Environment      structure E = GenericVC.Environment
14    
15        type statenvgetter = GP.info -> DG.bnode -> E.staticEnv
16  in  in
17    
18  signature STABILIZE = sig  signature STABILIZE = sig
19    
20      val loadStable :      val loadStable :
21          GP.info * (AbsPath.t -> GG.group) ->          GP.info * (AbsPath.t -> GG.group option) * bool ref ->
22          { group: AbsPath.t, s: BinIO.instream, anyerrors: bool ref } ->          AbsPath.t -> GG.group option
         GG.group option  
23    
24      val stabilize :      val stabilize :
25          GP.info ->          GP.info ->
26          { group: GG.group, s: BinIO.outstream, anyerrors: bool ref } ->          { group: GG.group, gpath: AbsPath.t, anyerrors: bool ref } ->
27          GG.group          GG.group option
28  end  end
29    
30  functor StablizeFn  functor StabilizeFn (val bn2statenv : statenvgetter) :> STABILIZE = struct
     (val bn2statenv : GP.info -> DG.bnode -> E.staticEnv  
      val binSizeOf : SmlInfo.info -> int  
      val copyBin : BinIO.outstream -> SmlInfo.info -> unit) :> STABILIZE =  
 struct  
   
31    
32      datatype pitem =      datatype pitem =
33          PSS of SymbolSet.set          PSS of SymbolSet.set
# Line 77  Line 73 
73          SymbolMap.foldl add IntBinaryMap.empty exports          SymbolMap.foldl add IntBinaryMap.empty exports
74      end      end
75    
76      fun stabilize gp { group = g as GG.GROUP grec, s = outs, anyerrors } =      fun deleteFile n = OS.FileSys.remove n
77            handle e as Interrupt.Interrupt => raise e
78                 | _ => ()
79    
80        fun stabilize gp { group = g as GG.GROUP grec, gpath, anyerrors } =
81          case #stableinfo grec of          case #stableinfo grec of
82              GG.STABLE _ => g              GG.STABLE _ => SOME g
83            | GG.NONSTABLE granted => let            | GG.NONSTABLE granted => let
84    
85                    val bname = AbsPath.name o SmlInfo.binpath
86                    val bsz = OS.FileSys.fileSize o bname
87                    fun cpb s i = let
88                        val ins = BinIO.openIn (bname i)
89                        fun cp () =
90                            if BinIO.endOfStream ins then ()
91                            else (BinIO.output (s, BinIO.input ins); cp ())
92                    in
93                        cp () handle e => (BinIO.closeIn ins; raise e);
94                        BinIO.closeIn ins
95                    end
96                    val delb = deleteFile o bname
97    
98                  val grpSrcInfo = (#errcons gp, anyerrors)                  val grpSrcInfo = (#errcons gp, anyerrors)
99    
100                  val exports = #exports grec                  val exports = #exports grec
# Line 193  Line 206 
206                  fun w_si i k = let                  fun w_si i k = let
207                      val spec = AbsPath.spec (SmlInfo.sourcepath i)                      val spec = AbsPath.spec (SmlInfo.sourcepath i)
208                      val locs = SmlInfo.errorLocation gp i                      val locs = SmlInfo.errorLocation gp i
209                      val offset = registerOffset (i, binSizeOf i)                      val offset = registerOffset (i, bsz i)
210                  in                  in
211                      w_string spec                      w_string spec
212                          (w_string locs                          (w_string locs
# Line 302  Line 315 
315                  in                  in
316                      BinIO.output (s, Word8Array.extract (a, 0, NONE))                      BinIO.output (s, Word8Array.extract (a, 0, NONE))
317                  end                  end
318              in                  val memberlist = rev (!members)
319    
320                    val policy = #fnpolicy (#param gp)
321                    val spath = FilenamePolicy.mkStablePath policy gpath
322                    fun delete () = deleteFile (AbsPath.name spath)
323                    val outs = AbsPath.openBinOut spath
324                    fun try () =
325                        (Say.vsay ["[stabilizing ", AbsPath.name gpath, "]\n"];
326                  writeInt32 (outs, sz);                  writeInt32 (outs, sz);
327                  BinIO.output (outs, Byte.stringToBytes pickle);                  BinIO.output (outs, Byte.stringToBytes pickle);
328                  app (copyBin outs) (rev (!members));                       app (cpb outs) memberlist;
329                  mkStableGroup ()                       app delb memberlist;
330                         BinIO.closeOut outs;
331                         SOME (mkStableGroup ()))
332                in
333                    Interrupt.guarded try
334                    handle e as Interrupt.Interrupt => (BinIO.closeOut outs;
335                                                        delete ();
336                                                        raise e)
337                         | exn => (BinIO.closeOut outs; NONE)
338              end              end
339    
340      fun loadStable (gp, getGroup) { group, s, anyerrors } = let      fun loadStable (gp, getGroup, anyerrors) group = let
341    
342          val bn2env = #1 o Statenv2DAEnv.cvt o bn2statenv gp          fun bn2env n = Statenv2DAEnv.cvtMemo (fn () => bn2statenv gp n)
343    
344          val grpSrcInfo = (#errcons gp, anyerrors)          val grpSrcInfo = (#errcons gp, anyerrors)
345    
346          exception Format          exception Format
347    
348            val policy = #fnpolicy (#param gp)
349            val spath = FilenamePolicy.mkStablePath policy group
350            val _ = Say.vsay ["[checking stable ", AbsPath.name group, "]\n"]
351            val s = AbsPath.openBinIn spath
352    
353            fun getGroup' p =
354                case getGroup p of
355                    SOME g => g
356                  | NONE => raise Format
357    
358          (* for getting sharing right... *)          (* for getting sharing right... *)
359          val m = ref IntBinaryMap.empty          val m = ref IntBinaryMap.empty
360          val next = ref 0          val next = ref 0
# Line 476  Line 514 
514                | #"b" => let                | #"b" => let
515                      val p = r_abspath ()                      val p = r_abspath ()
516                      val os = r_int ()                      val os = r_int ()
                     val GG.GROUP { stableinfo, ... } = getGroup p  
517                  in                  in
518                      case stableinfo of                      case getGroup' p of
519                          GG.NONSTABLE _ => raise Format                          GG.GROUP { stableinfo = GG.STABLE im, ... } =>
                       | GG.STABLE im =>  
520                              (case IntBinaryMap.find (im, os) of                              (case IntBinaryMap.find (im, os) of
521                                   NONE => raise Format                                   NONE => raise Format
522                                 | SOME n => n)                                 | SOME n => n)
523                          | _ => raise Format
524                  end                  end
525                | _ => raise Format                | _ => raise Format
526    
# Line 510  Line 547 
547              val sy = r_symbol ()              val sy = r_symbol ()
548              val (f, n) = r_fsbn ()      (* really reads farbnodes! *)              val (f, n) = r_fsbn ()      (* really reads farbnodes! *)
549              val e = bn2env n              val e = bn2env n
550                (* put a filter in front to avoid having the FCTENV being
551                 * queried needlessly (this avoids spurious module loadings) *)
552                val e' = DAEnv.FILTER (SymbolSet.singleton sy, e)
553          in          in
554              (sy, ((f, DG.SB_BNODE n), e)) (* coerce to farsbnodes *)              (sy, ((f, DG.SB_BNODE n), e')) (* coerce to farsbnodes *)
555          end          end
556    
557          fun r_exports () =          fun r_exports () =
# Line 524  Line 564 
564              val exports = r_exports ()              val exports = r_exports ()
565              val islib = r_bool ()              val islib = r_bool ()
566              val required = r_privileges ()              val required = r_privileges ()
567              val subgroups = r_list (getGroup o r_abspath) ()              val subgroups = r_list (getGroup' o r_abspath) ()
568              val simap = genStableInfoMap (exports, group)              val simap = genStableInfoMap (exports, group)
569          in          in
570              GG.GROUP { exports = exports,              GG.GROUP { exports = exports,
# Line 533  Line 573 
573                         grouppath = group,                         grouppath = group,
574                         subgroups = subgroups,                         subgroups = subgroups,
575                         stableinfo = GG.STABLE simap }                         stableinfo = GG.STABLE simap }
576                before BinIO.closeIn s
577          end          end
578      in      in
579          SOME (unpickle_group ()) handle Format => NONE          SOME (unpickle_group ())
580      end          handle Format => (BinIO.closeIn s; NONE)
581                 | exn => (BinIO.closeIn s; raise exn)
582        end handle IO.Io _ => NONE
583  end  end
584    
585  end (* local *)  end (* local *)

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

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