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 330, Sat Jun 12 07:45:52 1999 UTC revision 345, Sun Jun 20 11:55:26 1999 UTC
# Line 71  Line 71 
71          SymbolMap.foldl add IntBinaryMap.empty exports          SymbolMap.foldl add IntBinaryMap.empty exports
72      end      end
73    
74      fun deleteFile n = OS.FileSys.remove n      fun deleteFile n = OS.FileSys.remove n handle _ => ()
         handle e as Interrupt.Interrupt => raise e  
              | _ => ()  
75    
76      fun stabilize gp { group = g as GG.GROUP grec, anyerrors } = let      fun stabilize gp { group = g as GG.GROUP grec, anyerrors } = let
77    
78          val primconf = #primconf (#param gp)          val primconf = #primconf (#param gp)
79          val policy = #fnpolicy (#param gp)          val policy = #fnpolicy (#param gp)
80    
81            val grouppath = #grouppath grec
82            val groupdir = AbsPath.dir grouppath
83    
84          fun doit granted = let          fun doit granted = let
85    
86              val _ =              val _ =
# Line 91  Line 92 
92    
93              val bname = AbsPath.name o SmlInfo.binpath              val bname = AbsPath.name o SmlInfo.binpath
94              val bsz = OS.FileSys.fileSize o bname              val bsz = OS.FileSys.fileSize o bname
95    
96              fun cpb s i = let              fun cpb s i = let
97                  val ins = BinIO.openIn (bname i)                  fun copy ins = let
98                  fun cp () =                  fun cp () =
99                      if BinIO.endOfStream ins then ()                      if BinIO.endOfStream ins then ()
100                      else (BinIO.output (s, BinIO.input ins); cp ())                      else (BinIO.output (s, BinIO.input ins); cp ())
101              in              in
102                  cp () handle e => (BinIO.closeIn ins; raise e);                      cp ()
103                      BinIO.closeIn ins                  end
104                in
105                    SafeIO.perform { openIt = fn () => BinIO.openIn (bname i),
106                                     closeIt = BinIO.closeIn,
107                                     work = copy,
108                                     cleanup = fn () => () }
109              end              end
             val delb = deleteFile o bname  
110    
111              val grpSrcInfo = (#errcons gp, anyerrors)              val grpSrcInfo = (#errcons gp, anyerrors)
112    
113              val exports = #exports grec              val exports = #exports grec
114              val islib = #islib grec              val islib = #islib grec
115              val required = StringSet.difference (#required grec, granted)              val required = StringSet.difference (#required grec, granted)
116              val grouppath = #grouppath grec              val sublibs = #sublibs grec
             val subgroups = #subgroups grec  
117    
118              (* The format of a stable archive is the following:              (* The format of a stable archive is the following:
119               *  - It starts with the size s of the pickled dependency               *  - It starts with the size s of the pickled dependency
# Line 122  Line 127 
127               *  - Individual binfile contents (concatenated).               *  - Individual binfile contents (concatenated).
128               *)               *)
129    
130              (* Here we build an inverse map that records for each              (* Here we build a mapping that maps each BNODE to a number
131               * imported bnode a representative symbol.               * representing the sub-library that it came from and a
132               * This is used for pickling BNODEs -- they get represented               * representative symbol that can be used to find the BNODE
133               * by a symbol that they export. This avoids having to               * within the exports of that library *)
134               * pickle a filename in the case of BNODEs. *)              fun oneB i (sy, ((_, DG.SB_BNODE (DG.BNODE n)), _), m) =
135              fun oneB (sy, ((_, DG.SB_BNODE (DG.BNODE n)), _), m) =                  StableMap.insert (m, #bininfo n, (i, sy))
136                  StableMap.insert (m, #bininfo n, sy)                | oneB i (_, _, m) = m
137                | oneB (_, _, m) = m              fun oneSL ((_, g as GG.GROUP { exports, ... }), (m, i)) =
138              fun oneSG ((_, GG.GROUP { exports, ... }), m) =                  (SymbolMap.foldli (oneB i) m exports, i + 1)
139                  SymbolMap.foldli oneB m exports              val inverseMap = #1 (foldl oneSL (StableMap.empty, 0) sublibs)
             val inverseMap = foldl oneSG StableMap.empty subgroups  
140    
141              val members = ref []              val members = ref []
142              val (registerOffset, getOffset) = let              val (registerOffset, getOffset) = let
# Line 221  Line 225 
225                | w_sharing (SOME false) k m = "f" :: k m                | w_sharing (SOME false) k m = "f" :: k m
226    
227              fun w_si i k = let              fun w_si i k = let
228                    (* FIXME: this is not a technical flaw, but perhaps one
229                     * that deserves fixing anyway:  If we only look at spec,
230                     * then we are losing information about sub-grouping
231                     * within libraries.  However, the spec in BinInfo.info
232                     * is only used for diagnostics and has no impact on the
233                     * operation of CM itself. *)
234                  val spec = AbsPath.spec (SmlInfo.sourcepath i)                  val spec = AbsPath.spec (SmlInfo.sourcepath i)
235                  val locs = SmlInfo.errorLocation gp i                  val locs = SmlInfo.errorLocation gp i
236                  val offset = registerOffset (i, bsz i)                  val offset = registerOffset (i, bsz i)
# Line 234  Line 244 
244              fun w_primitive p k m =              fun w_primitive p k m =
245                  String.str (Primitive.toIdent primconf p) :: k m                  String.str (Primitive.toIdent primconf p) :: k m
246    
247              fun warn_nonanchor s = let              fun warn_relabs p abs = let
248                  val relabs =                  val relabs = if abs then "absolute" else "relative"
                     if OS.Path.isRelative s then "relative" else "absolute"  
249                  fun ppb pps =                  fun ppb pps =
250                      (PP.add_newline pps;                      (PP.add_newline pps;
251                       PP.add_string pps ("subgroup: " ^ s);                       PP.add_string pps (AbsPath.name p);
252                       PP.add_newline pps;                       PP.add_newline pps;
253                       PP.add_string pps                       PP.add_string pps
254      "(This means that in order to be able to use the result of stabilization";      "(This means that in order to be able to use the result of stabilization";
255                       PP.add_newline pps;                       PP.add_newline pps;
256                       PP.add_string pps "the subgroups must be in the same ";                       PP.add_string pps "the library must be in the same ";
257                       PP.add_string pps relabs;                       PP.add_string pps relabs;
258                       PP.add_string pps " location as it is now.)";                       PP.add_string pps " location as it is now.)";
259                       PP.add_newline pps)                       PP.add_newline pps)
260              in              in
261                  EM.errorNoFile (#errcons gp, anyerrors) SM.nullRegion                  EM.errorNoFile (#errcons gp, anyerrors) SM.nullRegion
262                      EM.WARN                      EM.WARN
263                      (concat [AbsPath.name (#grouppath grec),                      (concat [AbsPath.name grouppath,
264                               ": subgroup referred to by ", relabs,                               ": library referred to by ", relabs,
265                               " pathname"])                               " pathname:"])
266                      ppb                      ppb
267              end              end
268    
269              fun w_abspath p k m =              fun w_abspath p k m =
270                  w_list w_string (AbsPath.pickle warn_nonanchor p) k m                  w_list w_string (AbsPath.pickle (warn_relabs p) (p, groupdir))
271                                    k m
272    
273              fun w_bn (DG.PNODE p) k m = "p" :: w_primitive p k m              fun w_bn (DG.PNODE p) k m = "p" :: w_primitive p k m
274                | w_bn (DG.BNODE { bininfo = i, ... }) k m =                | w_bn (DG.BNODE { bininfo = i, ... }) k m = let
275                  "b" :: w_symbol (valOf (StableMap.find (inverseMap, i))) k m                      val (n, sy) = valOf (StableMap.find (inverseMap, i))
276                    in
277                        "b" :: w_int n (w_symbol sy k) m
278                    end
279    
280              fun w_sn_raw (DG.SNODE n) k =              fun w_sn_raw (DG.SNODE n) k =
281                  w_si (#smlinfo n)                  w_si (#smlinfo n)
# Line 290  Line 303 
303                  fun k0 m = []                  fun k0 m = []
304                  val m0 = (0, Map.empty)                  val m0 = (0, Map.empty)
305              in              in
306                  (* Pickle the subgroups first because we need to already                  (* Pickle the sublibs first because we need to already
307                   * have them back when we unpickle BNODEs. *)                   * have them back when we unpickle BNODEs. *)
308                  concat (w_list w_sg subgroups                  concat (w_list w_sg sublibs
309                              (w_exports exports                              (w_exports exports
310                                  (w_bool islib                                  (w_bool islib
311                                      (w_privileges required k0))) m0)                                      (w_privileges required k0))) m0)
# Line 311  Line 324 
324                              val li = map sn (#localimports n)                              val li = map sn (#localimports n)
325                              val gi = map fsbn (#globalimports n)                              val gi = map fsbn (#globalimports n)
326                              val sourcepath = SmlInfo.sourcepath smlinfo                              val sourcepath = SmlInfo.sourcepath smlinfo
327                                (* FIXME: see the comment near the other
328                                 * occurence of AbsPath.spec... *)
329                              val spec = AbsPath.spec sourcepath                              val spec = AbsPath.spec sourcepath
330                              val offset =                              val offset =
331                                  getOffset smlinfo + offset_adjustment                                  getOffset smlinfo + offset_adjustment
# Line 345  Line 360 
360                             islib = islib,                             islib = islib,
361                             required = required,                             required = required,
362                             grouppath = grouppath,                             grouppath = grouppath,
363                             subgroups = subgroups,                             sublibs = sublibs,
364                             stableinfo = GG.STABLE simap }                             stableinfo = GG.STABLE simap }
365              end              end
366    
# Line 360  Line 375 
375              val gpath = #grouppath grec              val gpath = #grouppath grec
376              val spath = FilenamePolicy.mkStablePath policy gpath              val spath = FilenamePolicy.mkStablePath policy gpath
377              fun delete () = deleteFile (AbsPath.name spath)              fun delete () = deleteFile (AbsPath.name spath)
378              val outs = AbsPath.openBinOut spath              fun work outs =
             fun try () =  
379                  (Say.vsay ["[stabilizing ", AbsPath.name gpath, "]\n"];                  (Say.vsay ["[stabilizing ", AbsPath.name gpath, "]\n"];
380                   writeInt32 (outs, sz);                   writeInt32 (outs, sz);
381                   BinIO.output (outs, Byte.stringToBytes pickle);                   BinIO.output (outs, Byte.stringToBytes pickle);
382                   app (cpb outs) memberlist;                   app (cpb outs) memberlist;
383                   app delb memberlist;                   mkStableGroup spath)
384                   BinIO.closeOut outs;          in
385                   SOME (mkStableGroup spath))              SOME (SafeIO.perform { openIt = fn () => AbsPath.openBinOut spath,
386          in                                     closeIt = BinIO.closeOut,
387              Interrupt.guarded try                                     work = work,
388              handle e as Interrupt.Interrupt => (BinIO.closeOut outs;                                     cleanup = delete })
389                                                  delete ();              handle exn => NONE
                                                 raise e)  
                  | exn => (BinIO.closeOut outs; NONE)  
390          end          end
391      in      in
392          case #stableinfo grec of          case #stableinfo grec of
# Line 388  Line 400 
400                              GG.STABLE _ => false                              GG.STABLE _ => false
401                            | GG.NONSTABLE _ => true                            | GG.NONSTABLE _ => true
402                  in                  in
403                      case List.filter notStable (#subgroups grec) of                      case List.filter notStable (#sublibs grec) of
404                          [] => doit granted                          [] => doit granted
405                        | l => let                        | l => let
406                              val grammar = case l of [_] => " is" | _ => "s are"                              val grammar = case l of [_] => " is" | _ => "s are"
# Line 425  Line 437 
437    
438      fun loadStable (gp, getGroup, anyerrors) group = let      fun loadStable (gp, getGroup, anyerrors) group = let
439    
440          val context = AbsPath.relativeContext (AbsPath.dir group)          val groupdir = AbsPath.dir group
441          fun bn2env n = Statenv2DAEnv.cvtMemo (fn () => bn2statenv gp n)          fun bn2env n = Statenv2DAEnv.cvtMemo (fn () => bn2statenv gp n)
442    
443          val errcons = #errcons gp          val errcons = #errcons gp
# Line 441  Line 453 
453          val primconf = #primconf (#param gp)          val primconf = #primconf (#param gp)
454          val spath = FilenamePolicy.mkStablePath policy group          val spath = FilenamePolicy.mkStablePath policy group
455          val _ = Say.vsay ["[checking stable ", gname, "]\n"]          val _ = Say.vsay ["[checking stable ", gname, "]\n"]
456          val s = AbsPath.openBinIn spath  
457            fun work s = let
458    
459          fun getGroup' p =          fun getGroup' p =
460              case getGroup p of              case getGroup p of
461                  SOME g => g                  SOME g => g
462                | NONE =>                    | NONE => (error ["unable to find ", AbsPath.name p];
                     (error ["unable to find ", AbsPath.name p];  
463                       raise Format)                       raise Format)
464    
465          (* for getting sharing right... *)          (* for getting sharing right... *)
# Line 503  Line 515 
515          fun r_int () = let          fun r_int () = let
516              fun loop n = let              fun loop n = let
517                  val w8 = Byte.charToByte (rd ())                  val w8 = Byte.charToByte (rd ())
518                  val n' = n * 0w128 + Word8.toLargeWord (Word8.andb (w8, 0w127))                      val n' =
519                            n * 0w128 + Word8.toLargeWord (Word8.andb (w8, 0w127))
520              in              in
521                  if Word8.andb (w8, 0w128) = 0w0 then n' else loop n'                  if Word8.andb (w8, 0w128) = 0w0 then n' else loop n'
522              end              end
# Line 537  Line 550 
550          end          end
551    
552          fun r_abspath () =          fun r_abspath () =
553              case AbsPath.unpickle pcmode (r_list r_string (), context) of                  case AbsPath.unpickle pcmode (r_list r_string (), groupdir) of
554                  SOME p => p                  SOME p => p
555                | NONE => raise Format                | NONE => raise Format
556    
# Line 604  Line 617 
617              (p, getGroup' p)              (p, getGroup' p)
618          end          end
619    
620          fun unpickle_group () = let              val sublibs = r_list r_sg ()
   
             val subgroups = r_list r_sg ()  
             fun oneSG ((_, GG.GROUP { exports, ... }), m) =  
                 SymbolMap.unionWith #1 (exports, m)  
             val forwardMap = foldl oneSG SymbolMap.empty subgroups  
621    
622              fun r_bn () =              fun r_bn () =
623                  case rd () of                  case rd () of
624                      #"p" => DG.PNODE (r_primitive ())                      #"p" => DG.PNODE (r_primitive ())
625                    | #"b" => let                    | #"b" => let
626                            val n = r_int ()
627                          val sy = r_symbol ()                          val sy = r_symbol ()
628                            val (_, GG.GROUP { exports = slexp, ... }) =
629                                List.nth (sublibs, n) handle _ => raise Format
630                      in                      in
631                          case SymbolMap.find (forwardMap, sy) of                          case SymbolMap.find (slexp, sy) of
632                              SOME ((_, DG.SB_BNODE (n as DG.BNODE _)), _) => n                              SOME ((_, DG.SB_BNODE (n as DG.BNODE _)), _) => n
633                            | _ => raise Format                            | _ => raise Format
634                      end                      end
# Line 668  Line 679 
679                         islib = islib,                         islib = islib,
680                         required = required,                         required = required,
681                         grouppath = group,                         grouppath = group,
682                         subgroups = subgroups,                         sublibs = sublibs,
683                         stableinfo = GG.STABLE simap }                         stableinfo = GG.STABLE simap }
             before BinIO.closeIn s  
684          end          end
685      in      in
686          SOME (unpickle_group ())          SOME (SafeIO.perform { openIt = fn () => AbsPath.openBinIn spath,
687          handle Format => (BinIO.closeIn s; NONE)                                 closeIt = BinIO.closeIn,
688               | exn => (BinIO.closeIn s; raise exn)                                 work = work,
689      end handle IO.Io _ => NONE                                 cleanup = fn () => () })
690            handle Format => NONE
691        end
692  end  end
693    
694  end (* local *)  end (* local *)

Legend:
Removed from v.330  
changed lines
  Added in v.345

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