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 311, Wed Jun 2 09:08:48 1999 UTC revision 340, Fri Jun 18 05:32:46 1999 UTC
# Line 15  Line 15 
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 = GG.group * GP.info -> bool      type recomp = GP.info -> GG.group -> bool
19  in  in
20    
21  signature STABILIZE = sig  signature STABILIZE = sig
# Line 36  Line 36 
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 52  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 82  Line 77 
77    
78      fun stabilize gp { group = g as GG.GROUP grec, anyerrors } = let      fun stabilize gp { group = g as GG.GROUP grec, anyerrors } = let
79    
80            val primconf = #primconf (#param gp)
81            val policy = #fnpolicy (#param gp)
82    
83            val grouppath = #grouppath grec
84            val groupdir = AbsPath.dir grouppath
85    
86          fun doit granted = let          fun doit granted = let
87    
88                val _ =
89                    if StringSet.isEmpty granted then ()
90                    else
91                        Say.say ("$Stabilize: wrapping the following privileges:\n"
92                                 :: map (fn s => ("  " ^ s ^ "\n"))
93                                        (StringSet.listItems granted))
94    
95              val bname = AbsPath.name o SmlInfo.binpath              val bname = AbsPath.name o SmlInfo.binpath
96              val bsz = OS.FileSys.fileSize o bname              val bsz = OS.FileSys.fileSize o bname
97              fun cpb s i = let              fun cpb s i = let
# Line 94  Line 103 
103                  cp () handle e => (BinIO.closeIn ins; raise e);                  cp () handle e => (BinIO.closeIn ins; raise e);
104                      BinIO.closeIn ins                      BinIO.closeIn ins
105              end              end
             val delb = deleteFile o bname  
106    
107              val grpSrcInfo = (#errcons gp, anyerrors)              val grpSrcInfo = (#errcons gp, anyerrors)
108    
109              val exports = #exports grec              val exports = #exports grec
110              val islib = #islib grec              val islib = #islib grec
111              val required = StringSet.difference (#required grec, granted)              val required = StringSet.difference (#required grec, granted)
112              val grouppath = #grouppath grec              val sublibs = #sublibs grec
             val subgroups = #subgroups grec  
113    
114              (* The format of a stable archive is the following:              (* The format of a stable archive is the following:
115               *  - It starts with the size s of the pickled dependency               *  - It starts with the size s of the pickled dependency
# Line 116  Line 123 
123               *  - Individual binfile contents (concatenated).               *  - Individual binfile contents (concatenated).
124               *)               *)
125    
126                (* Here we build a mapping that maps each BNODE to a number
127                 * representing the sub-library that it came from and a
128                 * representative symbol that can be used to find the BNODE
129                 * within the exports of that library *)
130                fun oneB i (sy, ((_, DG.SB_BNODE (DG.BNODE n)), _), m) =
131                    StableMap.insert (m, #bininfo n, (i, sy))
132                  | oneB i (_, _, m) = m
133                fun oneSL ((_, g as GG.GROUP { exports, ... }), (m, i)) =
134                    (SymbolMap.foldli (oneB i) m exports, i + 1)
135                val inverseMap = #1 (foldl oneSL (StableMap.empty, 0) sublibs)
136    
137              val members = ref []              val members = ref []
138              val (registerOffset, getOffset) = let              val (registerOffset, getOffset) = let
139                  val dict = ref SmlInfoMap.empty                  val dict = ref SmlInfoMap.empty
# Line 203  Line 221 
221                | w_sharing (SOME false) k m = "f" :: k m                | w_sharing (SOME false) k m = "f" :: k m
222    
223              fun w_si i k = let              fun w_si i k = let
224                    (* FIXME: this is not a technical flaw, but perhaps one
225                     * that deserves fixing anyway:  If we only look at spec,
226                     * then we are losing information about sub-grouping
227                     * within libraries.  However, the spec in BinInfo.info
228                     * is only used for diagnostics and has no impact on the
229                     * operation of CM itself. *)
230                  val spec = AbsPath.spec (SmlInfo.sourcepath i)                  val spec = AbsPath.spec (SmlInfo.sourcepath i)
231                  val locs = SmlInfo.errorLocation gp i                  val locs = SmlInfo.errorLocation gp i
232                  val offset = registerOffset (i, bsz i)                  val offset = registerOffset (i, bsz i)
# Line 213  Line 237 
237                                 (w_sharing (SmlInfo.share i) k)))                                 (w_sharing (SmlInfo.share i) k)))
238              end              end
239    
240              fun w_primitive p k m = String.str (Primitive.toIdent p) :: k m              fun w_primitive p k m =
241                    String.str (Primitive.toIdent primconf p) :: k m
             fun w_abspath_raw p k m = w_list w_string (AbsPath.pickle p) k m  
242    
243              val w_abspath = w_share w_abspath_raw PAP              fun warn_relabs p abs = let
244                    val relabs = if abs then "absolute" else "relative"
245                    fun ppb pps =
246                        (PP.add_newline pps;
247                         PP.add_string pps (AbsPath.name p);
248                         PP.add_newline pps;
249                         PP.add_string pps
250        "(This means that in order to be able to use the result of stabilization";
251                         PP.add_newline pps;
252                         PP.add_string pps "the library must be in the same ";
253                         PP.add_string pps relabs;
254                         PP.add_string pps " location as it is now.)";
255                         PP.add_newline pps)
256                in
257                    EM.errorNoFile (#errcons gp, anyerrors) SM.nullRegion
258                        EM.WARN
259                        (concat [AbsPath.name grouppath,
260                                 ": library referred to by ", relabs,
261                                 " pathname:"])
262                        ppb
263                end
264    
265                fun w_abspath p k m =
266                    w_list w_string (AbsPath.pickle (warn_relabs p) (p, groupdir))
267                                    k m
268    
269              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
270                | w_bn (DG.BNODE { bininfo = i, ... }) k m =                | w_bn (DG.BNODE { bininfo = i, ... }) k m = let
271                  "b" :: w_abspath (BinInfo.group i)                      val (n, sy) = valOf (StableMap.find (inverseMap, i))
272                             (w_int (BinInfo.offset i) k) m                  in
273                        "b" :: w_int n (w_symbol sy k) m
274                    end
275    
276              fun w_sn_raw (DG.SNODE n) k =              fun w_sn_raw (DG.SNODE n) k =
277                  w_si (#smlinfo n)                  w_si (#smlinfo n)
# Line 246  Line 295 
295              fun w_privileges p = w_list w_string (StringSet.listItems p)              fun w_privileges p = w_list w_string (StringSet.listItems p)
296    
297              fun pickle_group () = let              fun pickle_group () = let
298                  fun w_sg (GG.GROUP g) = w_abspath (#grouppath g)                  fun w_sg (p, _) = w_abspath p
299                  fun k0 m = []                  fun k0 m = []
300                  val m0 = (0, Map.empty)                  val m0 = (0, Map.empty)
301              in              in
302                  concat (w_exports exports                  (* Pickle the sublibs first because we need to already
303                     * have them back when we unpickle BNODEs. *)
304                    concat (w_list w_sg sublibs
305                                (w_exports exports
306                               (w_bool islib                               (w_bool islib
307                                     (w_privileges required                                      (w_privileges required k0))) m0)
                                           (w_list w_sg subgroups k0))) m0)  
308              end              end
309    
310              val pickle = pickle_group ()              val pickle = pickle_group ()
311              val sz = size pickle              val sz = size pickle
312              val offset_adjustment = sz + 4              val offset_adjustment = sz + 4
313    
314              fun mkStableGroup () = let              fun mkStableGroup spath = let
315                  val m = ref SmlInfoMap.empty                  val m = ref SmlInfoMap.empty
316                  fun sn (DG.SNODE (n as { smlinfo, ... })) =                  fun sn (DG.SNODE (n as { smlinfo, ... })) =
317                      case SmlInfoMap.find (!m, smlinfo) of                      case SmlInfoMap.find (!m, smlinfo) of
# Line 269  Line 320 
320                              val li = map sn (#localimports n)                              val li = map sn (#localimports n)
321                              val gi = map fsbn (#globalimports n)                              val gi = map fsbn (#globalimports n)
322                              val sourcepath = SmlInfo.sourcepath smlinfo                              val sourcepath = SmlInfo.sourcepath smlinfo
323                                (* FIXME: see the comment near the other
324                                 * occurence of AbsPath.spec... *)
325                              val spec = AbsPath.spec sourcepath                              val spec = AbsPath.spec sourcepath
326                              val offset =                              val offset =
327                                  getOffset smlinfo + offset_adjustment                                  getOffset smlinfo + offset_adjustment
# Line 276  Line 329 
329                              val locs = SmlInfo.errorLocation gp smlinfo                              val locs = SmlInfo.errorLocation gp smlinfo
330                              val error = EM.errorNoSource grpSrcInfo locs                              val error = EM.errorNoSource grpSrcInfo locs
331                              val i = BinInfo.new { group = grouppath,                              val i = BinInfo.new { group = grouppath,
332                                                      stablepath = spath,
333                                                    spec = spec,                                                    spec = spec,
334                                                    offset = offset,                                                    offset = offset,
335                                                    share = share,                                                    share = share,
# Line 302  Line 356 
356                             islib = islib,                             islib = islib,
357                             required = required,                             required = required,
358                             grouppath = grouppath,                             grouppath = grouppath,
359                             subgroups = subgroups,                             sublibs = sublibs,
360                             stableinfo = GG.STABLE simap }                             stableinfo = GG.STABLE simap }
361              end              end
362    
# Line 314  Line 368 
368              end              end
369              val memberlist = rev (!members)              val memberlist = rev (!members)
370    
             val policy = #fnpolicy (#param gp)  
371              val gpath = #grouppath grec              val gpath = #grouppath grec
372              val spath = FilenamePolicy.mkStablePath policy gpath              val spath = FilenamePolicy.mkStablePath policy gpath
373              fun delete () = deleteFile (AbsPath.name spath)              fun delete () = deleteFile (AbsPath.name spath)
# Line 324  Line 377 
377                   writeInt32 (outs, sz);                   writeInt32 (outs, sz);
378                   BinIO.output (outs, Byte.stringToBytes pickle);                   BinIO.output (outs, Byte.stringToBytes pickle);
379                   app (cpb outs) memberlist;                   app (cpb outs) memberlist;
                  app delb memberlist;  
380                   BinIO.closeOut outs;                   BinIO.closeOut outs;
381                   SOME (mkStableGroup ()))                   SOME (mkStableGroup spath))
382          in          in
383              Interrupt.guarded try              Interrupt.guarded try
384              handle e as Interrupt.Interrupt => (BinIO.closeOut outs;              handle e as Interrupt.Interrupt => (BinIO.closeOut outs;
# Line 338  Line 390 
390          case #stableinfo grec of          case #stableinfo grec of
391              GG.STABLE _ => SOME g              GG.STABLE _ => SOME g
392            | GG.NONSTABLE granted =>            | GG.NONSTABLE granted =>
393                  if not (recomp (g, gp)) then                  if not (recomp gp g) then
394                      (anyerrors := true; NONE)                      (anyerrors := true; NONE)
395                  else let                  else let
396                      fun notStable (GG.GROUP { stableinfo, ... }) =                      fun notStable (_, GG.GROUP { stableinfo, ... }) =
397                          case stableinfo of                          case stableinfo of
398                              GG.STABLE _ => false                              GG.STABLE _ => false
399                            | GG.NONSTABLE _ => true                            | GG.NONSTABLE _ => true
400                  in                  in
401                      case List.filter notStable (#subgroups grec) of                      case List.filter notStable (#sublibs grec) of
402                          [] => doit granted                          [] => doit granted
403                        | l => let                        | l => let
404                              val grammar = case l of [_] => " is" | _ => "s are"                              val grammar = case l of [_] => " is" | _ => "s are"
405                              fun ppb pps = let                              fun ppb pps = let
406                                  fun loop [] = ()                                  fun loop [] = ()
407                                    | loop (GG.GROUP { grouppath, ... } :: t) =                                    | loop ((p, GG.GROUP { grouppath, ... })
408                                              :: t) =
409                                      (PP.add_string pps                                      (PP.add_string pps
410                                          (AbsPath.name grouppath);                                          (AbsPath.name grouppath);
411                                         PP.add_string pps " (";
412                                         PP.add_string pps (AbsPath.name p);
413                                         PP.add_string pps ")";
414                                       PP.add_newline pps;                                       PP.add_newline pps;
415                                       loop t)                                       loop t)
416                              in                              in
# Line 379  Line 435 
435    
436      fun loadStable (gp, getGroup, anyerrors) group = let      fun loadStable (gp, getGroup, anyerrors) group = let
437    
438            val groupdir = AbsPath.dir group
439          fun bn2env n = Statenv2DAEnv.cvtMemo (fn () => bn2statenv gp n)          fun bn2env n = Statenv2DAEnv.cvtMemo (fn () => bn2statenv gp n)
440    
441          val errcons = #errcons gp          val errcons = #errcons gp
# Line 389  Line 446 
446    
447          exception Format          exception Format
448    
449            val pcmode = #pcmode (#param gp)
450          val policy = #fnpolicy (#param gp)          val policy = #fnpolicy (#param gp)
451            val primconf = #primconf (#param gp)
452          val spath = FilenamePolicy.mkStablePath policy group          val spath = FilenamePolicy.mkStablePath policy group
453          val _ = Say.vsay ["[checking stable ", gname, "]\n"]          val _ = Say.vsay ["[checking stable ", gname, "]\n"]
454          val s = AbsPath.openBinIn spath          val s = AbsPath.openBinIn spath
# Line 487  Line 546 
546              loop []              loop []
547          end          end
548    
549          val r_abspath = let          fun r_abspath () =
550              fun r_abspath_raw () =              case AbsPath.unpickle pcmode (r_list r_string (), groupdir) of
                 case AbsPath.unpickle (r_list r_string ()) of  
551                      SOME p => p                      SOME p => p
552                    | NONE => raise Format                    | NONE => raise Format
             fun unUAP (UAP x) = x  
               | unUAP _ = raise Format  
         in  
             r_share r_abspath_raw UAP unUAP  
         end  
553    
554          val r_symbol = let          val r_symbol = let
555              fun r_symbol_raw () = let              fun r_symbol_raw () = let
# Line 529  Line 582 
582          val r_filter = r_option r_ss          val r_filter = r_option r_ss
583    
584          fun r_primitive () =          fun r_primitive () =
585              case Primitive.fromIdent (rd ()) of              case Primitive.fromIdent primconf (rd ()) of
586                  NONE => raise Format                  NONE => raise Format
587                | SOME p => p                | SOME p => p
588    
# Line 548  Line 601 
601              val error = EM.errorNoSource grpSrcInfo locs              val error = EM.errorNoSource grpSrcInfo locs
602          in          in
603              BinInfo.new { group = group,              BinInfo.new { group = group,
604                              stablepath = spath,
605                            error = error,                            error = error,
606                            spec = spec,                            spec = spec,
607                            offset = offset,                            offset = offset,
608                            share = share }                            share = share }
609          end          end
610    
611            fun r_sg () = let
612                val p = r_abspath ()
613            in
614                (p, getGroup' p)
615            end
616    
617            fun unpickle_group () = let
618    
619                val sublibs = r_list r_sg ()
620    
621          fun r_bn () =          fun r_bn () =
622              case rd () of              case rd () of
623                  #"p" => DG.PNODE (r_primitive ())                  #"p" => DG.PNODE (r_primitive ())
624                | #"b" => let                | #"b" => let
625                      val p = r_abspath ()                          val n = r_int ()
626                      val os = r_int ()                          val sy = r_symbol ()
627                            val (_, GG.GROUP { exports = slexp, ... }) =
628                                List.nth (sublibs, n) handle _ => raise Format
629                  in                  in
630                      case getGroup' p of                          case SymbolMap.find (slexp, sy) of
631                          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)  
632                        | _ => raise Format                        | _ => raise Format
633                  end                  end
634                | _ => raise Format                | _ => raise Format
# Line 606  Line 669 
669          fun r_privileges () =          fun r_privileges () =
670              StringSet.addList (StringSet.empty, r_list r_string ())              StringSet.addList (StringSet.empty, r_list r_string ())
671    
         fun unpickle_group () = let  
672              val exports = r_exports ()              val exports = r_exports ()
673              val islib = r_bool ()              val islib = r_bool ()
674              val required = r_privileges ()              val required = r_privileges ()
             val subgroups = r_list (getGroup' o r_abspath) ()  
675              val simap = genStableInfoMap (exports, group)              val simap = genStableInfoMap (exports, group)
676          in          in
677              GG.GROUP { exports = exports,              GG.GROUP { exports = exports,
678                         islib = islib,                         islib = islib,
679                         required = required,                         required = required,
680                         grouppath = group,                         grouppath = group,
681                         subgroups = subgroups,                         sublibs = sublibs,
682                         stableinfo = GG.STABLE simap }                         stableinfo = GG.STABLE simap }
683              before BinIO.closeIn s              before BinIO.closeIn s
684          end          end

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

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