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 348, Tue Jun 22 05:43:46 1999 UTC revision 360, Tue Jun 29 09:21:02 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 getPid : SmlInfo.info -> pid option
36                         val warmup : BinInfo.info * pid option -> unit
37                       val recomp: recomp) :> STABILIZE = struct                       val recomp: recomp) :> STABILIZE = struct
38    
39      datatype pitem =      datatype pitem =
# Line 62  Line 66 
66          fun add (((_, DG.SB_BNODE (n as DG.BNODE b)), _), m) = let          fun add (((_, DG.SB_BNODE (n as DG.BNODE b)), _), m) = let
67              val i = #bininfo b              val i = #bininfo b
68          in          in
69              if AbsPath.compare (BinInfo.group i, group) = EQUAL then              if SrcPath.compare (BinInfo.group i, group) = EQUAL then
70                  IntBinaryMap.insert (m, BinInfo.offset i, n)                  IntBinaryMap.insert (m, BinInfo.offset i, n)
71              else m              else m
72          end          end
# Line 71  Line 75 
75          SymbolMap.foldl add IntBinaryMap.empty exports          SymbolMap.foldl add IntBinaryMap.empty exports
76      end      end
77    
     fun deleteFile n = OS.FileSys.remove n handle _ => ()  
   
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)          val primconf = #primconf (#param gp)
81          val policy = #fnpolicy (#param gp)          val policy = #fnpolicy (#param gp)
82    
83          val grouppath = #grouppath grec          val grouppath = #grouppath grec
         val groupdir = AbsPath.dir grouppath  
84    
85          fun doit wrapped = let          fun doit wrapped = let
86    
# Line 90  Line 91 
91                               :: map (fn s => ("  " ^ s ^ "\n"))                               :: map (fn s => ("  " ^ s ^ "\n"))
92                                      (StringSet.listItems wrapped))                                      (StringSet.listItems wrapped))
93    
94              val bname = AbsPath.name o SmlInfo.binpath              val bname = SmlInfo.binname
95              val bsz = OS.FileSys.fileSize o bname              val bsz = OS.FileSys.fileSize o bname
96    
97              fun cpb s i = let              fun cpb s i = let
98                    val N = 4096
99                  fun copy ins = let                  fun copy ins = let
100                      fun cp () =                      fun cp () =
101                          if BinIO.endOfStream ins then ()                          if BinIO.endOfStream ins then ()
102                          else (BinIO.output (s, BinIO.input ins); cp ())                          else (BinIO.output (s, BinIO.inputN (ins, N));
103                                  cp ())
104                  in                  in
105                      cp ()                      cp ()
106                  end                  end
# Line 230  Line 233 
233                   * within libraries.  However, the spec in BinInfo.info                   * within libraries.  However, the spec in BinInfo.info
234                   * is only used for diagnostics and has no impact on the                   * is only used for diagnostics and has no impact on the
235                   * operation of CM itself. *)                   * operation of CM itself. *)
236                  val spec = AbsPath.spec (SmlInfo.sourcepath i)                  val spec = SrcPath.specOf (SmlInfo.sourcepath i)
237                  val locs = SmlInfo.errorLocation gp i                  val locs = SmlInfo.errorLocation gp i
238                  val offset = registerOffset (i, bsz i)                  val offset = registerOffset (i, bsz i)
239              in              in
# Line 247  Line 250 
250                  val relabs = if abs then "absolute" else "relative"                  val relabs = if abs then "absolute" else "relative"
251                  fun ppb pps =                  fun ppb pps =
252                      (PP.add_newline pps;                      (PP.add_newline pps;
253                       PP.add_string pps (AbsPath.name p);                       PP.add_string pps (SrcPath.descr p);
254                       PP.add_newline pps;                       PP.add_newline pps;
255                       PP.add_string pps                       PP.add_string pps
256      "(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 259  Line 262 
262              in              in
263                  EM.errorNoFile (#errcons gp, anyerrors) SM.nullRegion                  EM.errorNoFile (#errcons gp, anyerrors) SM.nullRegion
264                      EM.WARN                      EM.WARN
265                      (concat [AbsPath.name grouppath,                      (concat [SrcPath.descr grouppath,
266                               ": library referred to by ", relabs,                               ": library referred to by ", relabs,
267                               " pathname:"])                               " pathname:"])
268                      ppb                      ppb
269              end              end
270    
271              fun w_abspath p k m =              fun w_abspath p k m =
272                  w_list w_string (AbsPath.pickle (warn_relabs p) (p, groupdir))                  w_list w_string (SrcPath.pickle (warn_relabs p) (p, grouppath))
273                                  k m                                  k m
274    
275              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 276  Line 279 
279                      "b" :: w_int n (w_symbol sy k) m                      "b" :: w_int n (w_symbol sy k) m
280                  end                  end
281    
282                fun w_pid p = w_string (Byte.bytesToString (Pid.toBytes p))
283    
284              fun w_sn_raw (DG.SNODE n) k =              fun w_sn_raw (DG.SNODE n) k =
285                  w_si (#smlinfo n)                  w_option w_pid (getPid (#smlinfo n))
286                             (w_si (#smlinfo n)
287                       (w_list w_sn (#localimports n)                       (w_list w_sn (#localimports n)
288                               (w_list w_fsbn (#globalimports n) k))                                         (w_list w_fsbn (#globalimports n) k)))
289    
290              and w_sn n = w_share w_sn_raw PSN n              and w_sn n = w_share w_sn_raw PSN n
291    
# Line 313  Line 319 
319              val sz = size pickle              val sz = size pickle
320              val offset_adjustment = sz + 4              val offset_adjustment = sz + 4
321    
322              fun mkStableGroup spath = let              fun mkStableGroup sname = let
323                  val m = ref SmlInfoMap.empty                  val m = ref SmlInfoMap.empty
324                  fun sn (DG.SNODE (n as { smlinfo, ... })) =                  fun sn (DG.SNODE (n as { smlinfo, ... })) =
325                      case SmlInfoMap.find (!m, smlinfo) of                      case SmlInfoMap.find (!m, smlinfo) of
# Line 323  Line 329 
329                              val gi = map fsbn (#globalimports n)                              val gi = map fsbn (#globalimports n)
330                              val sourcepath = SmlInfo.sourcepath smlinfo                              val sourcepath = SmlInfo.sourcepath smlinfo
331                              (* FIXME: see the comment near the other                              (* FIXME: see the comment near the other
332                               * occurence of AbsPath.spec... *)                               * occurence of SrcPath.spec... *)
333                              val spec = AbsPath.spec sourcepath                              val spec = SrcPath.specOf sourcepath
334                              val offset =                              val offset =
335                                  getOffset smlinfo + offset_adjustment                                  getOffset smlinfo + offset_adjustment
336                              val share = SmlInfo.share smlinfo                              val share = SmlInfo.share smlinfo
337                              val locs = SmlInfo.errorLocation gp smlinfo                              val locs = SmlInfo.errorLocation gp smlinfo
338                              val error = EM.errorNoSource grpSrcInfo locs                              val error = EM.errorNoSource grpSrcInfo locs
339                              val i = BinInfo.new { group = grouppath,                              val i = BinInfo.new { group = grouppath,
340                                                    stablepath = spath,                                                    stablename = sname,
341                                                    spec = spec,                                                    spec = spec,
342                                                    offset = offset,                                                    offset = offset,
343                                                    share = share,                                                    share = share,
# Line 370  Line 376 
376              val memberlist = rev (!members)              val memberlist = rev (!members)
377    
378              val gpath = #grouppath grec              val gpath = #grouppath grec
379              val spath = FilenamePolicy.mkStablePath policy gpath              val sname = FilenamePolicy.mkStableName policy gpath
             fun delete () = deleteFile (AbsPath.name spath)  
380              fun work outs =              fun work outs =
381                  (Say.vsay ["[stabilizing ", AbsPath.name gpath, "]\n"];                  (Say.vsay ["[stabilizing ", SrcPath.descr gpath, "]\n"];
382                   writeInt32 (outs, sz);                   writeInt32 (outs, sz);
383                   BinIO.output (outs, Byte.stringToBytes pickle);                   BinIO.output (outs, Byte.stringToBytes pickle);
384                   app (cpb outs) memberlist;                   app (cpb outs) memberlist;
385                   mkStableGroup spath)                   mkStableGroup sname)
386          in          in
387              SOME (SafeIO.perform { openIt = fn () => AbsPath.openBinOut spath,              SOME (SafeIO.perform { openIt = fn () => AutoDir.openBinOut sname,
388                                     closeIt = BinIO.closeOut,                                     closeIt = BinIO.closeOut,
389                                     work = work,                                     work = work,
390                                     cleanup = delete })                                     cleanup = fn () =>
391                                        (OS.FileSys.remove sname handle _ => ()) })
392              handle exn => NONE              handle exn => NONE
393          end          end
394      in      in
# Line 394  Line 400 
400                      (anyerrors := true; NONE)                      (anyerrors := true; NONE)
401                  else let                  else let
402                      fun notStable (_, GG.GROUP { kind, ... }) =                      fun notStable (_, GG.GROUP { kind, ... }) =
403                          case kind of GG.STABLELIB _ => true | _ => false                          case kind of GG.STABLELIB _ => false | _ => true
404                  in                  in
405                      case List.filter notStable (#sublibs grec) of                      case List.filter notStable (#sublibs grec) of
406                          [] => doit wrapped                          [] => doit wrapped
# Line 405  Line 411 
411                                    | loop ((p, GG.GROUP { grouppath, ... })                                    | loop ((p, GG.GROUP { grouppath, ... })
412                                            :: t) =                                            :: t) =
413                                      (PP.add_string pps                                      (PP.add_string pps
414                                          (AbsPath.name grouppath);                                          (SrcPath.descr grouppath);
415                                       PP.add_string pps " (";                                       PP.add_string pps " (";
416                                       PP.add_string pps (AbsPath.name p);                                       PP.add_string pps (SrcPath.descr p);
417                                       PP.add_string pps ")";                                       PP.add_string pps ")";
418                                       PP.add_newline pps;                                       PP.add_newline pps;
419                                       loop t)                                       loop t)
# Line 420  Line 426 
426                                  loop l                                  loop l
427                              end                              end
428                              val errcons = #errcons gp                              val errcons = #errcons gp
429                              val gname = AbsPath.name (#grouppath grec)                              val gdescr = SrcPath.descr (#grouppath grec)
430                          in                          in
431                              EM.errorNoFile (errcons, anyerrors) SM.nullRegion                              EM.errorNoFile (errcons, anyerrors) SM.nullRegion
432                                 EM.COMPLAIN                                 EM.COMPLAIN
433                                 (gname ^ " cannot be stabilized")                                 (gdescr ^ " cannot be stabilized")
434                                 ppb;                                 ppb;
435                              NONE                              NONE
436                          end                          end
# Line 433  Line 439 
439    
440      fun loadStable (gp, getGroup, anyerrors) group = let      fun loadStable (gp, getGroup, anyerrors) group = let
441    
442          val groupdir = AbsPath.dir group          val es2bs = GenericVC.CoerceEnv.es2bs
443          fun bn2env n = Statenv2DAEnv.cvtMemo (fn () => bn2statenv gp n)          fun bn2env n =
444                Statenv2DAEnv.cvtMemo (fn () => es2bs (bn2statenv gp n))
445    
446          val errcons = #errcons gp          val errcons = #errcons gp
447          val grpSrcInfo = (errcons, anyerrors)          val grpSrcInfo = (errcons, anyerrors)
448          val gname = AbsPath.name group          val gdescr = SrcPath.descr group
449          fun error l = EM.errorNoFile (errcons, anyerrors) SM.nullRegion          fun error l = EM.errorNoFile (errcons, anyerrors) SM.nullRegion
450              EM.COMPLAIN (concat (gname :: ": " :: l)) EM.nullErrorBody              EM.COMPLAIN (concat (gdescr :: ": " :: l)) EM.nullErrorBody
451    
452          exception Format          exception Format
453    
454          val pcmode = #pcmode (#param gp)          val pcmode = #pcmode (#param gp)
455          val policy = #fnpolicy (#param gp)          val policy = #fnpolicy (#param gp)
456          val primconf = #primconf (#param gp)          val primconf = #primconf (#param gp)
457          val spath = FilenamePolicy.mkStablePath policy group          val sname = FilenamePolicy.mkStableName policy group
458          val _ = Say.vsay ["[checking stable ", gname, "]\n"]          val _ = Say.vsay ["[checking stable ", gdescr, "]\n"]
459    
460          fun work s = let          fun work s = let
461    
462              fun getGroup' p =              fun getGroup' p =
463                  case getGroup p of                  case getGroup p of
464                      SOME g => g                      SOME g => g
465                    | NONE => (error ["unable to find ", AbsPath.name p];                    | NONE => (error ["unable to find ", SrcPath.descr p];
466                               raise Format)                               raise Format)
467    
468              (* for getting sharing right... *)              (* for getting sharing right... *)
469              val m = ref IntBinaryMap.empty              val m = ref IntBinaryMap.empty
470              val next = ref 0              val next = ref 0
471    
472                val pset = ref PidSet.empty
473    
474              fun bytesIn n = let              fun bytesIn n = let
475                  val bv = BinIO.inputN (s, n)                  val bv = BinIO.inputN (s, n)
476              in              in
# Line 546  Line 555 
555              end              end
556    
557              fun r_abspath () =              fun r_abspath () =
558                  case AbsPath.unpickle pcmode (r_list r_string (), groupdir) of                  case SrcPath.unpickle pcmode (r_list r_string (), group) of
559                      SOME p => p                      SOME p => p
560                    | NONE => raise Format                    | NONE => raise Format
561    
# Line 554  Line 563 
563                  fun r_symbol_raw () = let                  fun r_symbol_raw () = let
564                      val (ns, first) =                      val (ns, first) =
565                          case rd () of                          case rd () of
566                              #"`" => (Symbol.sigSymbol, rd ())                              #"'" => (Symbol.sigSymbol, rd ())
567                            | #"(" => (Symbol.fctSymbol, rd ())                            | #"(" => (Symbol.fctSymbol, rd ())
568                            | #")" => (Symbol.fsigSymbol, rd ())                            | #")" => (Symbol.fsigSymbol, rd ())
569                            | c => (Symbol.strSymbol, c)                            | c => (Symbol.strSymbol, c)
# Line 600  Line 609 
609                  val error = EM.errorNoSource grpSrcInfo locs                  val error = EM.errorNoSource grpSrcInfo locs
610              in              in
611                  BinInfo.new { group = group,                  BinInfo.new { group = group,
612                                stablepath = spath,                                stablename = sname,
613                                error = error,                                error = error,
614                                spec = spec,                                spec = spec,
615                                offset = offset,                                offset = offset,
# Line 630  Line 639 
639                      end                      end
640                    | _ => raise Format                    | _ => raise Format
641    
642                fun r_pid () = Pid.fromBytes (Byte.stringToBytes (r_string ()))
643    
644              (* this is the place where what used to be an              (* this is the place where what used to be an
645               * SNODE changes to a BNODE! *)               * SNODE changes to a BNODE! *)
646              fun r_sn_raw () =              fun r_sn_raw () = let
647                  DG.BNODE { bininfo = r_si (),                  val popt = r_option r_pid ()
648                    val i = r_si ()
649                in
650                    warmup (i, popt);
651                    DG.BNODE { bininfo = i,
652                             localimports = r_list r_sn (),                             localimports = r_list r_sn (),
653                             globalimports = r_list r_fsbn () }                             globalimports = r_list r_fsbn () }
654                end
655    
656              and r_sn () =              and r_sn () =
657                  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 677  Line 693 
693                         sublibs = sublibs }                         sublibs = sublibs }
694          end          end
695      in      in
696          SOME (SafeIO.perform { openIt = fn () => AbsPath.openBinIn spath,          SOME (SafeIO.perform { openIt = fn () => BinIO.openIn sname,
697                                 closeIt = BinIO.closeIn,                                 closeIt = BinIO.closeIn,
698                                 work = work,                                 work = work,
699                                 cleanup = fn () => () })                                 cleanup = fn () => () })

Legend:
Removed from v.348  
changed lines
  Added in v.360

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