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 345, Sun Jun 20 11:55:26 1999 UTC revision 370, Mon Jul 5 08:59:13 1999 UTC
# Line 13  Line 13 
13      structure SM = GenericVC.SourceMap      structure SM = GenericVC.SourceMap
14      structure GP = GeneralParams      structure GP = GeneralParams
15      structure E = GenericVC.Environment      structure E = GenericVC.Environment
16        structure Pid = GenericVC.PersStamps
17    
18      type statenvgetter = GP.info -> DG.bnode -> E.staticEnv      type statenvgetter = GP.info -> DG.bnode -> E.staticEnv
19      type recomp = GP.info -> GG.group -> bool      type recomp = GP.info -> GG.group -> bool
20        type pid = Pid.persstamp
21  in  in
22    
23  signature STABILIZE = sig  signature STABILIZE = sig
24    
25      val loadStable :      val loadStable :
26          GP.info * (AbsPath.t -> GG.group option) * bool ref ->          GP.info * (SrcPath.t -> GG.group option) * bool ref ->
27          AbsPath.t -> GG.group option          SrcPath.t -> GG.group option
28    
29      val stabilize :      val stabilize :
30          GP.info -> { group: GG.group, anyerrors: bool ref } ->          GP.info -> { group: GG.group, anyerrors: bool ref } ->
# Line 30  Line 32 
32  end  end
33    
34  functor StabilizeFn (val bn2statenv : statenvgetter  functor StabilizeFn (val bn2statenv : statenvgetter
35                         val transfer_state : SmlInfo.info * BinInfo.info -> unit
36                       val recomp: recomp) :> STABILIZE = struct                       val recomp: recomp) :> STABILIZE = struct
37    
38      datatype pitem =      datatype pitem =
# Line 62  Line 65 
65          fun add (((_, DG.SB_BNODE (n as DG.BNODE b)), _), m) = let          fun add (((_, DG.SB_BNODE (n as DG.BNODE b)), _), m) = let
66              val i = #bininfo b              val i = #bininfo b
67          in          in
68              if AbsPath.compare (BinInfo.group i, group) = EQUAL then              if SrcPath.compare (BinInfo.group i, group) = EQUAL then
69                  IntBinaryMap.insert (m, BinInfo.offset i, n)                  IntBinaryMap.insert (m, BinInfo.offset i, n)
70              else m              else m
71          end          end
# Line 71  Line 74 
74          SymbolMap.foldl add IntBinaryMap.empty exports          SymbolMap.foldl add IntBinaryMap.empty exports
75      end      end
76    
     fun deleteFile n = OS.FileSys.remove n handle _ => ()  
   
77      fun stabilize gp { group = g as GG.GROUP grec, anyerrors } = let      fun stabilize gp { group = g as GG.GROUP grec, anyerrors } = let
78    
79          val primconf = #primconf (#param gp)          val primconf = #primconf (#param gp)
80          val policy = #fnpolicy (#param gp)          val policy = #fnpolicy (#param gp)
81    
82          val grouppath = #grouppath grec          val grouppath = #grouppath grec
         val groupdir = AbsPath.dir grouppath  
83    
84          fun doit granted = let          fun doit wrapped = let
85    
86              val _ =              val _ =
87                  if StringSet.isEmpty granted then ()                  if StringSet.isEmpty wrapped then ()
88                  else                  else
89                      Say.say ("$Stabilize: wrapping the following privileges:\n"                      Say.say ("$Stabilize: wrapping the following privileges:\n"
90                               :: map (fn s => ("  " ^ s ^ "\n"))                               :: map (fn s => ("  " ^ s ^ "\n"))
91                                      (StringSet.listItems granted))                                      (StringSet.listItems wrapped))
92    
93              val bname = AbsPath.name o SmlInfo.binpath              val bname = SmlInfo.binname
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 N = 4096
98                  fun copy ins = let                  fun copy ins = let
99                      fun cp () =                      fun cp () =
100                          if BinIO.endOfStream ins then ()                          if BinIO.endOfStream ins then ()
101                          else (BinIO.output (s, BinIO.input ins); cp ())                          else (BinIO.output (s, BinIO.inputN (ins, N));
102                                  cp ())
103                  in                  in
104                      cp ()                      cp ()
105                  end                  end
# Line 111  Line 113 
113              val grpSrcInfo = (#errcons gp, anyerrors)              val grpSrcInfo = (#errcons gp, anyerrors)
114    
115              val exports = #exports grec              val exports = #exports grec
116              val islib = #islib grec              val required = StringSet.difference (#required grec, wrapped)
             val required = StringSet.difference (#required grec, granted)  
117              val sublibs = #sublibs grec              val sublibs = #sublibs grec
118    
119              (* The format of a stable archive is the following:              (* The format of a stable archive is the following:
# Line 231  Line 232 
232                   * within libraries.  However, the spec in BinInfo.info                   * within libraries.  However, the spec in BinInfo.info
233                   * is only used for diagnostics and has no impact on the                   * is only used for diagnostics and has no impact on the
234                   * operation of CM itself. *)                   * operation of CM itself. *)
235                  val spec = AbsPath.spec (SmlInfo.sourcepath i)                  val spec = SrcPath.specOf (SmlInfo.sourcepath i)
236                  val locs = SmlInfo.errorLocation gp i                  val locs = SmlInfo.errorLocation gp i
237                  val offset = registerOffset (i, bsz i)                  val offset = registerOffset (i, bsz i)
238              in              in
# Line 248  Line 249 
249                  val relabs = if abs then "absolute" else "relative"                  val relabs = if abs then "absolute" else "relative"
250                  fun ppb pps =                  fun ppb pps =
251                      (PP.add_newline pps;                      (PP.add_newline pps;
252                       PP.add_string pps (AbsPath.name p);                       PP.add_string pps (SrcPath.descr p);
253                       PP.add_newline pps;                       PP.add_newline pps;
254                       PP.add_string pps                       PP.add_string pps
255      "(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";
# Line 260  Line 261 
261              in              in
262                  EM.errorNoFile (#errcons gp, anyerrors) SM.nullRegion                  EM.errorNoFile (#errcons gp, anyerrors) SM.nullRegion
263                      EM.WARN                      EM.WARN
264                      (concat [AbsPath.name grouppath,                      (concat [SrcPath.descr grouppath,
265                               ": library referred to by ", relabs,                               ": library referred to by ", relabs,
266                               " pathname:"])                               " pathname:"])
267                      ppb                      ppb
268              end              end
269    
270              fun w_abspath p k m =              fun w_abspath p k m =
271                  w_list w_string (AbsPath.pickle (warn_relabs p) (p, groupdir))                  w_list w_string (SrcPath.pickle (warn_relabs p) (p, grouppath))
272                                  k m                                  k m
273    
274              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
# Line 277  Line 278 
278                      "b" :: w_int n (w_symbol sy k) m                      "b" :: w_int n (w_symbol sy k) m
279                  end                  end
280    
281              fun w_sn_raw (DG.SNODE n) k =              fun w_bool true k m = "t" :: k m
282                  w_si (#smlinfo n)                | w_bool false k m = "f" :: k m
283                       (w_list w_sn (#localimports n)  
284                               (w_list w_fsbn (#globalimports n) k))              fun w_sn_raw (DG.SNODE n) k = let
285                    val i = #smlinfo n
286                    val li = #localimports n
287                    val gi = #globalimports n
288                in
289                    Say.say ["+++ w_sn_raw: ", SmlInfo.descr i, "\n"];
290                    app (fn (DG.SNODE n, ref r) =>
291                          (Say.say ["     ", if r then "+" else "-",
292                                    SmlInfo.descr (#smlinfo n), "\n"])) li;
293                    app (fn ((_, sbn), ref r) =>
294                          (Say.say ["      ", if r then "+" else "-",
295                                    DG.describeSBN sbn, "\n"])) gi;
296                    w_si i (w_list w_sloci li (w_list w_sglobi gi k))
297                end
298    
299                and w_sloci (n, ref r) k m = w_sn n (w_bool r k) m
300                and w_sglobi (n, ref r) k m = w_fsbn n (w_bool r k) m
301    
302              and w_sn n = w_share w_sn_raw PSN n              and w_sn n = w_share w_sn_raw PSN n
303    
# Line 293  Line 310 
310    
311              fun w_exports e = w_list w_impexp (SymbolMap.listItemsi e)              fun w_exports e = w_list w_impexp (SymbolMap.listItemsi e)
312    
             fun w_bool true k m = "t" :: k m  
               | w_bool false k m = "f" :: k m  
   
313              fun w_privileges p = w_list w_string (StringSet.listItems p)              fun w_privileges p = w_list w_string (StringSet.listItems p)
314    
315              fun pickle_group () = let              fun pickle_group () = let
# Line 307  Line 321 
321                   * have them back when we unpickle BNODEs. *)                   * have them back when we unpickle BNODEs. *)
322                  concat (w_list w_sg sublibs                  concat (w_list w_sg sublibs
323                              (w_exports exports                              (w_exports exports
324                                  (w_bool islib                                   (w_privileges required k0)) m0)
                                     (w_privileges required k0))) m0)  
325              end              end
326    
327              val pickle = pickle_group ()              val pickle = pickle_group ()
328              val sz = size pickle              val sz = size pickle
329              val offset_adjustment = sz + 4              val offset_adjustment = sz + 4
330    
331              fun mkStableGroup spath = let              fun mkStableGroup mksname = let
332                  val m = ref SmlInfoMap.empty                  val m = ref SmlInfoMap.empty
333                  fun sn (DG.SNODE (n as { smlinfo, ... })) =                  fun sn (DG.SNODE (n as { smlinfo, ... })) =
334                      case SmlInfoMap.find (!m, smlinfo) of                      case SmlInfoMap.find (!m, smlinfo) of
335                          SOME n => n                          SOME n => n
336                        | NONE => let                        | NONE => let
337                              val li = map sn (#localimports n)                              val li = map sloci (#localimports n)
338                              val gi = map fsbn (#globalimports n)                              val gi = map sglobi (#globalimports n)
339                              val sourcepath = SmlInfo.sourcepath smlinfo                              val sourcepath = SmlInfo.sourcepath smlinfo
340                              (* FIXME: see the comment near the other                              (* FIXME: see the comment near the other
341                               * occurence of AbsPath.spec... *)                               * occurence of SrcPath.spec... *)
342                              val spec = AbsPath.spec sourcepath                              val spec = SrcPath.specOf sourcepath
343                              val offset =                              val offset =
344                                  getOffset smlinfo + offset_adjustment                                  getOffset smlinfo + offset_adjustment
345                              val share = SmlInfo.share smlinfo                              val share = SmlInfo.share smlinfo
346                              val locs = SmlInfo.errorLocation gp smlinfo                              val locs = SmlInfo.errorLocation gp smlinfo
347                              val error = EM.errorNoSource grpSrcInfo locs                              val error = EM.errorNoSource grpSrcInfo locs
348                              val i = BinInfo.new { group = grouppath,                              val i = BinInfo.new { group = grouppath,
349                                                    stablepath = spath,                                                    mkStablename = mksname,
350                                                    spec = spec,                                                    spec = spec,
351                                                    offset = offset,                                                    offset = offset,
352                                                    share = share,                                                    share = share,
# Line 342  Line 355 
355                                                 localimports = li,                                                 localimports = li,
356                                                 globalimports = gi }                                                 globalimports = gi }
357                          in                          in
358                                transfer_state (smlinfo, i);
359                              m := SmlInfoMap.insert (!m, smlinfo, n);                              m := SmlInfoMap.insert (!m, smlinfo, n);
360                              n                              n
361                          end                          end
362    
363                    and sloci (n, ref r) = (sn n, r)
364                    and sglobi (n, ref r) = (fsbn n, r)
365    
366                  and sbn (DG.SB_SNODE n) = sn n                  and sbn (DG.SB_SNODE n) = sn n
367                    | sbn (DG.SB_BNODE n) = n                    | sbn (DG.SB_BNODE n) = n
368    
# Line 357  Line 374 
374                  val simap = genStableInfoMap (exports, grouppath)                  val simap = genStableInfoMap (exports, grouppath)
375              in              in
376                  GG.GROUP { exports = exports,                  GG.GROUP { exports = exports,
377                             islib = islib,                             kind = GG.STABLELIB simap,
378                             required = required,                             required = required,
379                             grouppath = grouppath,                             grouppath = grouppath,
380                             sublibs = sublibs,                             sublibs = sublibs }
                            stableinfo = GG.STABLE simap }  
381              end              end
382    
383              fun writeInt32 (s, i) = let              fun writeInt32 (s, i) = let
# Line 373  Line 389 
389              val memberlist = rev (!members)              val memberlist = rev (!members)
390    
391              val gpath = #grouppath grec              val gpath = #grouppath grec
392              val spath = FilenamePolicy.mkStablePath policy gpath              fun mksname () = FilenamePolicy.mkStableName policy gpath
             fun delete () = deleteFile (AbsPath.name spath)  
393              fun work outs =              fun work outs =
394                  (Say.vsay ["[stabilizing ", AbsPath.name gpath, "]\n"];                  (Say.vsay ["[stabilizing ", SrcPath.descr gpath, "]\n"];
395                   writeInt32 (outs, sz);                   writeInt32 (outs, sz);
396                   BinIO.output (outs, Byte.stringToBytes pickle);                   BinIO.output (outs, Byte.stringToBytes pickle);
397                   app (cpb outs) memberlist;                   app (cpb outs) memberlist;
398                   mkStableGroup spath)                   mkStableGroup mksname)
399          in          in
400              SOME (SafeIO.perform { openIt = fn () => AbsPath.openBinOut spath,              SOME (SafeIO.perform { openIt = AutoDir.openBinOut o mksname,
401                                     closeIt = BinIO.closeOut,                                     closeIt = BinIO.closeOut,
402                                     work = work,                                     work = work,
403                                     cleanup = delete })                                     cleanup = fn () =>
404                                        (OS.FileSys.remove (mksname ())
405                                         handle _ => ()) })
406              handle exn => NONE              handle exn => NONE
407          end          end
408      in      in
409          case #stableinfo grec of          case #kind grec of
410              GG.STABLE _ => SOME g              GG.STABLELIB _ => SOME g
411            | GG.NONSTABLE granted =>            | GG.NOLIB => EM.impossible "stabilize: no library"
412              | GG.LIB wrapped =>
413                  if not (recomp gp g) then                  if not (recomp gp g) then
414                      (anyerrors := true; NONE)                      (anyerrors := true; NONE)
415                  else let                  else let
416                      fun notStable (_, GG.GROUP { stableinfo, ... }) =                      fun notStable (_, GG.GROUP { kind, ... }) =
417                          case stableinfo of                          case kind of GG.STABLELIB _ => false | _ => true
                             GG.STABLE _ => false  
                           | GG.NONSTABLE _ => true  
418                  in                  in
419                      case List.filter notStable (#sublibs grec) of                      case List.filter notStable (#sublibs grec) of
420                          [] => doit granted                          [] => doit wrapped
421                        | l => let                        | l => let
422                              val grammar = case l of [_] => " is" | _ => "s are"                              val grammar = case l of [_] => " is" | _ => "s are"
423                              fun ppb pps = let                              fun ppb pps = let
# Line 409  Line 425 
425                                    | loop ((p, GG.GROUP { grouppath, ... })                                    | loop ((p, GG.GROUP { grouppath, ... })
426                                            :: t) =                                            :: t) =
427                                      (PP.add_string pps                                      (PP.add_string pps
428                                          (AbsPath.name grouppath);                                          (SrcPath.descr grouppath);
429                                       PP.add_string pps " (";                                       PP.add_string pps " (";
430                                       PP.add_string pps (AbsPath.name p);                                       PP.add_string pps (SrcPath.descr p);
431                                       PP.add_string pps ")";                                       PP.add_string pps ")";
432                                       PP.add_newline pps;                                       PP.add_newline pps;
433                                       loop t)                                       loop t)
# Line 424  Line 440 
440                                  loop l                                  loop l
441                              end                              end
442                              val errcons = #errcons gp                              val errcons = #errcons gp
443                              val gname = AbsPath.name (#grouppath grec)                              val gdescr = SrcPath.descr (#grouppath grec)
444                          in                          in
445                              EM.errorNoFile (errcons, anyerrors) SM.nullRegion                              EM.errorNoFile (errcons, anyerrors) SM.nullRegion
446                                 EM.COMPLAIN                                 EM.COMPLAIN
447                                 (gname ^ " cannot be stabilized")                                 (gdescr ^ " cannot be stabilized")
448                                 ppb;                                 ppb;
449                              NONE                              NONE
450                          end                          end
# Line 437  Line 453 
453    
454      fun loadStable (gp, getGroup, anyerrors) group = let      fun loadStable (gp, getGroup, anyerrors) group = let
455    
456          val groupdir = AbsPath.dir group          val es2bs = GenericVC.CoerceEnv.es2bs
457          fun bn2env n = Statenv2DAEnv.cvtMemo (fn () => bn2statenv gp n)          fun bn2env n =
458                Statenv2DAEnv.cvtMemo (fn () => es2bs (bn2statenv gp n))
459    
460          val errcons = #errcons gp          val errcons = #errcons gp
461          val grpSrcInfo = (errcons, anyerrors)          val grpSrcInfo = (errcons, anyerrors)
462          val gname = AbsPath.name group          val gdescr = SrcPath.descr group
463          fun error l = EM.errorNoFile (errcons, anyerrors) SM.nullRegion          fun error l = EM.errorNoFile (errcons, anyerrors) SM.nullRegion
464              EM.COMPLAIN (concat (gname :: ": " :: l)) EM.nullErrorBody              EM.COMPLAIN (concat ("(stable) " :: gdescr :: ": " :: l))
465                EM.nullErrorBody
466    
467          exception Format          exception Format
468    
469          val pcmode = #pcmode (#param gp)          val pcmode = #pcmode (#param gp)
470          val policy = #fnpolicy (#param gp)          val policy = #fnpolicy (#param gp)
471          val primconf = #primconf (#param gp)          val primconf = #primconf (#param gp)
472          val spath = FilenamePolicy.mkStablePath policy group          fun mksname () = FilenamePolicy.mkStableName policy group
         val _ = Say.vsay ["[checking stable ", gname, "]\n"]  
473    
474          fun work s = let          fun work s = let
475    
476              fun getGroup' p =              fun getGroup' p =
477                  case getGroup p of                  case getGroup p of
478                      SOME g => g                      SOME g => g
479                    | NONE => (error ["unable to find ", AbsPath.name p];                    | NONE => (error ["unable to find ", SrcPath.descr p];
480                               raise Format)                               raise Format)
481    
482              (* for getting sharing right... *)              (* for getting sharing right... *)
483              val m = ref IntBinaryMap.empty              val m = ref IntBinaryMap.empty
484              val next = ref 0              val next = ref 0
485    
486                val pset = ref PidSet.empty
487    
488              fun bytesIn n = let              fun bytesIn n = let
489                  val bv = BinIO.inputN (s, n)                  val bv = BinIO.inputN (s, n)
490              in              in
# Line 550  Line 569 
569              end              end
570    
571              fun r_abspath () =              fun r_abspath () =
572                  case AbsPath.unpickle pcmode (r_list r_string (), groupdir) of                  SrcPath.unpickle pcmode (r_list r_string (), group)
573                      SOME p => p                  handle SrcPath.Format => raise Format
574                    | NONE => raise Format                       | SrcPath.BadAnchor a =>
575                           (error ["configuration anchor \"", a, "\" undefined"];
576                            raise Format)
577    
578    
579              val r_symbol = let              val r_symbol = let
580                  fun r_symbol_raw () = let                  fun r_symbol_raw () = let
581                      val (ns, first) =                      val (ns, first) =
582                          case rd () of                          case rd () of
583                              #"`" => (Symbol.sigSymbol, rd ())                              #"'" => (Symbol.sigSymbol, rd ())
584                            | #"(" => (Symbol.fctSymbol, rd ())                            | #"(" => (Symbol.fctSymbol, rd ())
585                            | #")" => (Symbol.fsigSymbol, rd ())                            | #")" => (Symbol.fsigSymbol, rd ())
586                            | c => (Symbol.strSymbol, c)                            | c => (Symbol.strSymbol, c)
# Line 604  Line 626 
626                  val error = EM.errorNoSource grpSrcInfo locs                  val error = EM.errorNoSource grpSrcInfo locs
627              in              in
628                  BinInfo.new { group = group,                  BinInfo.new { group = group,
629                                stablepath = spath,                                mkStablename = mksname,
630                                error = error,                                error = error,
631                                spec = spec,                                spec = spec,
632                                offset = offset,                                offset = offset,
# Line 638  Line 660 
660               * SNODE changes to a BNODE! *)               * SNODE changes to a BNODE! *)
661              fun r_sn_raw () =              fun r_sn_raw () =
662                  DG.BNODE { bininfo = r_si (),                  DG.BNODE { bininfo = r_si (),
663                             localimports = r_list r_sn (),                             localimports = r_list r_sloci (),
664                             globalimports = r_list r_fsbn () }                             globalimports = r_list r_sglobi () }
665    
666                and r_sloci () = (r_sn (), r_bool ())
667                and r_sglobi () = (r_fsbn (), r_bool ())
668    
669              and r_sn () =              and r_sn () =
670                  r_share r_sn_raw UBN (fn (UBN n) => n | _ => raise Format) ()                  r_share r_sn_raw UBN (fn (UBN n) => n | _ => raise Format) ()
# Line 671  Line 696 
696                  StringSet.addList (StringSet.empty, r_list r_string ())                  StringSet.addList (StringSet.empty, r_list r_string ())
697    
698              val exports = r_exports ()              val exports = r_exports ()
             val islib = r_bool ()  
699              val required = r_privileges ()              val required = r_privileges ()
700              val simap = genStableInfoMap (exports, group)              val simap = genStableInfoMap (exports, group)
701          in          in
702              GG.GROUP { exports = exports,              GG.GROUP { exports = exports,
703                         islib = islib,                         kind = GG.STABLELIB simap,
704                         required = required,                         required = required,
705                         grouppath = group,                         grouppath = group,
706                         sublibs = sublibs,                         sublibs = sublibs }
                        stableinfo = GG.STABLE simap }  
707          end          end
708      in      in
709          SOME (SafeIO.perform { openIt = fn () => AbsPath.openBinIn spath,          SOME (SafeIO.perform { openIt = BinIO.openIn o mksname,
710                                 closeIt = BinIO.closeIn,                                 closeIt = BinIO.closeIn,
711                                 work = work,                                 work = work,
712                                 cleanup = fn () => () })                                 cleanup = fn () => () })
713          handle Format => NONE          handle Format => NONE
714                 | IO.Io _ => NONE
715      end      end
716  end  end
717    

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

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