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 310, Wed Jun 2 07:28:27 1999 UTC revision 345, Sun Jun 20 11:55:26 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      type statenvgetter = GP.info -> DG.bnode -> E.staticEnv
18        type recomp = GP.info -> GG.group -> bool
19  in  in
20    
21  signature STABILIZE = sig  signature STABILIZE = sig
# Line 22  Line 25 
25          AbsPath.t -> GG.group option          AbsPath.t -> GG.group option
26    
27      val stabilize :      val stabilize :
28          GP.info ->          GP.info -> { group: GG.group, anyerrors: bool ref } ->
         { group: GG.group, gpath: AbsPath.t, anyerrors: bool ref } ->  
29          GG.group option          GG.group option
30  end  end
31    
32  functor StabilizeFn (val bn2statenv : statenvgetter) :> STABILIZE = struct  functor StabilizeFn (val bn2statenv : statenvgetter
33                         val recomp: recomp) :> STABILIZE = struct
34    
35      datatype pitem =      datatype pitem =
36          PSS of SymbolSet.set          PSS of SymbolSet.set
37        | PS of Symbol.symbol        | PS of Symbol.symbol
38        | PSN of DG.snode        | PSN of DG.snode
       | PAP of AbsPath.t  
39    
40      datatype uitem =      datatype uitem =
41          USS of SymbolSet.set          USS of SymbolSet.set
42        | US of Symbol.symbol        | US of Symbol.symbol
43        | UBN of DG.bnode        | UBN of DG.bnode
       | UAP of AbsPath.t  
44    
45      fun compare (PS s, PS s') = SymbolOrdKey.compare (s, s')      fun compare (PS s, PS s') = SymbolOrdKey.compare (s, s')
46        | compare (PS _, _) = GREATER        | compare (PS _, _) = GREATER
# Line 49  Line 50 
50        | compare (_, PSS _) = LESS        | compare (_, PSS _) = LESS
51        | compare (PSN (DG.SNODE n), PSN (DG.SNODE n')) =        | compare (PSN (DG.SNODE n), PSN (DG.SNODE n')) =
52          SmlInfo.compare (#smlinfo n, #smlinfo n')          SmlInfo.compare (#smlinfo n, #smlinfo n')
       | compare (PSN _, _) = GREATER  
       | compare (_, PSN _) = LESS  
       | compare (PAP p, PAP p') = AbsPath.compare (p, p')  
53    
54      structure Map =      structure Map =
55          BinaryMapFn (struct          BinaryMapFn (struct
# Line 73  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, gpath, anyerrors } =      fun stabilize gp { group = g as GG.GROUP grec, anyerrors } = let
77          case #stableinfo grec of  
78              GG.STABLE _ => SOME g          val primconf = #primconf (#param gp)
79            | GG.NONSTABLE granted => let          val policy = #fnpolicy (#param gp)
80    
81            val grouppath = #grouppath grec
82            val groupdir = AbsPath.dir grouppath
83    
84            fun doit granted = let
85    
86                val _ =
87                    if StringSet.isEmpty granted then ()
88                    else
89                        Say.say ("$Stabilize: wrapping the following privileges:\n"
90                                 :: map (fn s => ("  " ^ s ^ "\n"))
91                                        (StringSet.listItems granted))
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,              val required = StringSet.difference (#required grec, granted)
116                                                       granted)              val sublibs = #sublibs grec
                 val grouppath = #grouppath 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 116  Line 127 
127                   *  - Individual binfile contents (concatenated).                   *  - Individual binfile contents (concatenated).
128                   *)                   *)
129    
130                (* Here we build a mapping that maps each BNODE to a number
131                 * representing the sub-library that it came from and a
132                 * representative symbol that can be used to find the BNODE
133                 * within the exports of that library *)
134                fun oneB i (sy, ((_, DG.SB_BNODE (DG.BNODE n)), _), m) =
135                    StableMap.insert (m, #bininfo n, (i, sy))
136                  | oneB i (_, _, m) = m
137                fun oneSL ((_, g as GG.GROUP { exports, ... }), (m, i)) =
138                    (SymbolMap.foldli (oneB i) m exports, i + 1)
139                val inverseMap = #1 (foldl oneSL (StableMap.empty, 0) sublibs)
140    
141                  val members = ref []                  val members = ref []
142                  val (registerOffset, getOffset) = let                  val (registerOffset, getOffset) = let
143                      val dict = ref SmlInfoMap.empty                      val dict = ref SmlInfoMap.empty
# Line 194  Line 216 
216                      fun esc #"\\" = "\\\\"                      fun esc #"\\" = "\\\\"
217                        | esc #"\"" = "\\\""                        | esc #"\"" = "\\\""
218                        | esc c = String.str c                        | esc c = String.str c
   
219                  in                  in
220                      String.translate esc s :: "\"" :: k m                      String.translate esc s :: "\"" :: k m
221                  end                  end
# Line 204  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 214  Line 241 
241                                   (w_sharing (SmlInfo.share i) k)))                                   (w_sharing (SmlInfo.share i) k)))
242                  end                  end
243    
244                  fun w_primitive p k m = String.str (Primitive.toIdent p) :: k m              fun w_primitive p k m =
245                    String.str (Primitive.toIdent primconf p) :: k m
                 fun w_abspath_raw p k m =  
                     w_list w_string (AbsPath.pickle p) k m  
246    
247                  val w_abspath = w_share w_abspath_raw PAP              fun warn_relabs p abs = let
248                    val relabs = if abs then "absolute" else "relative"
249                    fun ppb pps =
250                        (PP.add_newline pps;
251                         PP.add_string pps (AbsPath.name p);
252                         PP.add_newline pps;
253                         PP.add_string pps
254        "(This means that in order to be able to use the result of stabilization";
255                         PP.add_newline pps;
256                         PP.add_string pps "the library must be in the same ";
257                         PP.add_string pps relabs;
258                         PP.add_string pps " location as it is now.)";
259                         PP.add_newline pps)
260                in
261                    EM.errorNoFile (#errcons gp, anyerrors) SM.nullRegion
262                        EM.WARN
263                        (concat [AbsPath.name grouppath,
264                                 ": library referred to by ", relabs,
265                                 " pathname:"])
266                        ppb
267                end
268    
269                fun w_abspath p k m =
270                    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_abspath (BinInfo.group i)                      val (n, sy) = valOf (StableMap.find (inverseMap, i))
276                                (w_int (BinInfo.offset i) k) m                  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 248  Line 299 
299                  fun w_privileges p = w_list w_string (StringSet.listItems p)                  fun w_privileges p = w_list w_string (StringSet.listItems p)
300    
301                  fun pickle_group () = let                  fun pickle_group () = let
302                      fun w_sg (GG.GROUP g) = w_abspath (#grouppath g)                  fun w_sg (p, _) = w_abspath p
303                      fun k0 m = []                      fun k0 m = []
304                      val m0 = (0, Map.empty)                      val m0 = (0, Map.empty)
305                  in                  in
306                      concat                  (* Pickle the sublibs first because we need to already
307                     * have them back when we unpickle BNODEs. *)
308                    concat (w_list w_sg sublibs
309                         (w_exports exports                         (w_exports exports
310                             (w_bool islib                             (w_bool islib
311                                (w_privileges required                                      (w_privileges required k0))) m0)
                                     (w_list w_sg subgroups k0))) m0)  
312                  end                  end
313    
314                  val pickle = pickle_group ()                  val pickle = pickle_group ()
315                  val sz = size pickle                  val sz = size pickle
316                  val offset_adjustment = sz + 4                  val offset_adjustment = sz + 4
317    
318                  fun mkStableGroup () = let              fun mkStableGroup spath = let
319                      val m = ref SmlInfoMap.empty                      val m = ref SmlInfoMap.empty
320                      fun sn (DG.SNODE (n as { smlinfo, ... })) =                      fun sn (DG.SNODE (n as { smlinfo, ... })) =
321                          case SmlInfoMap.find (!m, smlinfo) of                          case SmlInfoMap.find (!m, smlinfo) of
# Line 272  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 279  Line 333 
333                                  val locs = SmlInfo.errorLocation gp smlinfo                                  val locs = SmlInfo.errorLocation gp smlinfo
334                                  val error = EM.errorNoSource grpSrcInfo locs                                  val error = EM.errorNoSource grpSrcInfo locs
335                                  val i = BinInfo.new { group = grouppath,                                  val i = BinInfo.new { group = grouppath,
336                                                      stablepath = spath,
337                                                        spec = spec,                                                        spec = spec,
338                                                        offset = offset,                                                        offset = offset,
339                                                        share = share,                                                        share = share,
# Line 305  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 317  Line 372 
372                  end                  end
373                  val memberlist = rev (!members)                  val memberlist = rev (!members)
374    
375                  val policy = #fnpolicy (#param gp)              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 ()))              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
390                                                      raise e)          end
391                       | exn => (BinIO.closeOut outs; NONE)      in
392            case #stableinfo grec of
393                GG.STABLE _ => SOME g
394              | GG.NONSTABLE granted =>
395                    if not (recomp gp g) then
396                        (anyerrors := true; NONE)
397                    else let
398                        fun notStable (_, GG.GROUP { stableinfo, ... }) =
399                            case stableinfo of
400                                GG.STABLE _ => false
401                              | GG.NONSTABLE _ => true
402                    in
403                        case List.filter notStable (#sublibs grec) of
404                            [] => doit granted
405                          | l => let
406                                val grammar = case l of [_] => " is" | _ => "s are"
407                                fun ppb pps = let
408                                    fun loop [] = ()
409                                      | loop ((p, GG.GROUP { grouppath, ... })
410                                              :: t) =
411                                        (PP.add_string pps
412                                            (AbsPath.name grouppath);
413                                         PP.add_string pps " (";
414                                         PP.add_string pps (AbsPath.name p);
415                                         PP.add_string pps ")";
416                                         PP.add_newline pps;
417                                         loop t)
418                                in
419                                    PP.add_newline pps;
420                                    PP.add_string pps
421                                        (concat ["because the following sub-group",
422                                                 grammar, " not stable:"]);
423                                    PP.add_newline pps;
424                                    loop l
425                                end
426                                val errcons = #errcons gp
427                                val gname = AbsPath.name (#grouppath grec)
428                            in
429                                EM.errorNoFile (errcons, anyerrors) SM.nullRegion
430                                   EM.COMPLAIN
431                                   (gname ^ " cannot be stabilized")
432                                   ppb;
433                                NONE
434                            end
435                    end
436              end              end
437    
438      fun loadStable (gp, getGroup, anyerrors) group = let      fun loadStable (gp, getGroup, anyerrors) group = let
439    
440            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 grpSrcInfo = (#errcons gp, anyerrors)          val errcons = #errcons gp
444            val grpSrcInfo = (errcons, anyerrors)
445            val gname = AbsPath.name group
446            fun error l = EM.errorNoFile (errcons, anyerrors) SM.nullRegion
447                EM.COMPLAIN (concat (gname :: ": " :: l)) EM.nullErrorBody
448    
449          exception Format          exception Format
450    
451            val pcmode = #pcmode (#param gp)
452          val policy = #fnpolicy (#param gp)          val policy = #fnpolicy (#param gp)
453            val primconf = #primconf (#param gp)
454          val spath = FilenamePolicy.mkStablePath policy group          val spath = FilenamePolicy.mkStablePath policy group
455          val _ = Say.vsay ["[checking stable ", AbsPath.name group, "]\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 => raise Format                    | NONE => (error ["unable to find ", AbsPath.name p];
463                                 raise Format)
464    
465          (* for getting sharing right... *)          (* for getting sharing right... *)
466          val m = ref IntBinaryMap.empty          val m = ref IntBinaryMap.empty
# Line 408  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 441  Line 549 
549              loop []              loop []
550          end          end
551    
552          val r_abspath = let              fun r_abspath () =
553              fun r_abspath_raw () =                  case AbsPath.unpickle pcmode (r_list r_string (), groupdir) of
                 case AbsPath.unpickle (r_list r_string ()) of  
554                      SOME p => p                      SOME p => p
555                    | NONE => raise Format                    | NONE => raise Format
             fun unUAP (UAP x) = x  
               | unUAP _ = raise Format  
         in  
             r_share r_abspath_raw UAP unUAP  
         end  
556    
557          val r_symbol = let          val r_symbol = let
558              fun r_symbol_raw () = let              fun r_symbol_raw () = let
# Line 483  Line 585 
585          val r_filter = r_option r_ss          val r_filter = r_option r_ss
586    
587          fun r_primitive () =          fun r_primitive () =
588              case Primitive.fromIdent (rd ()) of                  case Primitive.fromIdent primconf (rd ()) of
589                  NONE => raise Format                  NONE => raise Format
590                | SOME p => p                | SOME p => p
591    
# Line 502  Line 604 
604              val error = EM.errorNoSource grpSrcInfo locs              val error = EM.errorNoSource grpSrcInfo locs
605          in          in
606              BinInfo.new { group = group,              BinInfo.new { group = group,
607                                  stablepath = spath,
608                            error = error,                            error = error,
609                            spec = spec,                            spec = spec,
610                            offset = offset,                            offset = offset,
611                            share = share }                            share = share }
612          end          end
613    
614                fun r_sg () = let
615                    val p = r_abspath ()
616                in
617                    (p, getGroup' p)
618                end
619    
620                val sublibs = r_list r_sg ()
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 p = r_abspath ()                          val n = r_int ()
627                      val os = r_int ()                          val sy = r_symbol ()
628                            val (_, GG.GROUP { exports = slexp, ... }) =
629                                List.nth (sublibs, n) handle _ => raise Format
630                  in                  in
631                      case getGroup' p of                          case SymbolMap.find (slexp, sy) of
632                          GG.GROUP { stableinfo = GG.STABLE im, ... } =>                              SOME ((_, DG.SB_BNODE (n as DG.BNODE _)), _) => n
                             (case IntBinaryMap.find (im, os) of  
                                  NONE => raise Format  
                                | SOME n => n)  
633                        | _ => raise Format                        | _ => raise Format
634                  end                  end
635                | _ => raise Format                | _ => raise Format
# Line 560  Line 670 
670          fun r_privileges () =          fun r_privileges () =
671              StringSet.addList (StringSet.empty, r_list r_string ())              StringSet.addList (StringSet.empty, r_list r_string ())
672    
         fun unpickle_group () = let  
673              val exports = r_exports ()              val exports = r_exports ()
674              val islib = r_bool ()              val islib = r_bool ()
675              val required = r_privileges ()              val required = r_privileges ()
             val subgroups = r_list (getGroup' o r_abspath) ()  
676              val simap = genStableInfoMap (exports, group)              val simap = genStableInfoMap (exports, group)
677          in          in
678              GG.GROUP { exports = exports,              GG.GROUP { exports = exports,
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.310  
changed lines
  Added in v.345

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