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 306, Tue Jun 1 08:25:21 1999 UTC revision 310, Wed Jun 2 07:28:27 1999 UTC
# Line 1  Line 1 
1  structure Stablize = struct  (*
2     * Reading, generating, and writing stable groups.
3     *
4     * (C) 1999 Lucent Technologies, Bell Laboratories
5     *
6     * Author: Matthias Blume (blume@kurims.kyoto-u.ac.jp)
7     *)
8    local
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 GP = GeneralParams
13        structure E = GenericVC.Environment
14    
15        type statenvgetter = GP.info -> DG.bnode -> E.staticEnv
16    in
17    
18      datatype item =  signature STABILIZE = sig
19          SS of SymbolSet.set  
20        | S of Symbol.symbol      val loadStable :
21        | SI of SmlInfo.info              (* only used during pickling *)          GP.info * (AbsPath.t -> GG.group option) * bool ref ->
22        | AP of AbsPath.t          AbsPath.t -> GG.group option
23        | BI of BinInfo.info              (* only used during unpickling *)  
24        val stabilize :
25      fun compare (S s, S s') = SymbolOrdKey.compare (s, s')          GP.info ->
26        | compare (S _, _) = GREATER          { group: GG.group, gpath: AbsPath.t, anyerrors: bool ref } ->
27        | compare (_, S _) = LESS          GG.group option
28        | compare (SS s, SS s') = SymbolSet.compare (s, s')  end
29        | compare (SS _, _) = GREATER  
30        | compare (_, SS _) = LESS  functor StabilizeFn (val bn2statenv : statenvgetter) :> STABILIZE = struct
31        | compare (SI i, SI i') = SmlInfo.compare (i, i')  
32        | compare (SI _, _) = GREATER      datatype pitem =
33        | compare (_, SI _) = LESS          PSS of SymbolSet.set
34        | compare (AP p, AP p') = AbsPath.compare (p, p')        | PS of Symbol.symbol
35        | compare (AP _, _) = GREATER        | PSN of DG.snode
36        | compare (_, AP _) = LESS        | PAP of AbsPath.t
37        | compare (BI i, BI i') = BinInfo.compare (i, i')  
38        datatype uitem =
39            USS of SymbolSet.set
40          | US of Symbol.symbol
41          | UBN of DG.bnode
42          | UAP of AbsPath.t
43    
44        fun compare (PS s, PS s') = SymbolOrdKey.compare (s, s')
45          | compare (PS _, _) = GREATER
46          | compare (_, PS _) = LESS
47          | compare (PSS s, PSS s') = SymbolSet.compare (s, s')
48          | compare (PSS _, _) = GREATER
49          | compare (_, PSS _) = LESS
50          | compare (PSN (DG.SNODE n), PSN (DG.SNODE n')) =
51            SmlInfo.compare (#smlinfo n, #smlinfo n')
52          | compare (PSN _, _) = GREATER
53          | compare (_, PSN _) = LESS
54          | compare (PAP p, PAP p') = AbsPath.compare (p, p')
55    
56      structure Map =      structure Map =
57          BinaryMapFn (struct          BinaryMapFn (struct
58                           type ord_key = item                           type ord_key = pitem
59                           val compare = compare                           val compare = compare
60          end)          end)
61    
62      fun stabilize (g as GG.GROUP grec, binSizeOf, binCopy, gp) =      fun genStableInfoMap (exports, group) = let
63            (* find all the exported bnodes that are in the same group: *)
64            fun add (((_, DG.SB_BNODE (n as DG.BNODE b)), _), m) = let
65                val i = #bininfo b
66            in
67                if AbsPath.compare (BinInfo.group i, group) = EQUAL then
68                    IntBinaryMap.insert (m, BinInfo.offset i, n)
69                else m
70            end
71              | add (_, m) = m
72        in
73            SymbolMap.foldl add IntBinaryMap.empty exports
74        end
75    
76        fun deleteFile n = OS.FileSys.remove n
77            handle e as Interrupt.Interrupt => raise e
78                 | _ => ()
79    
80        fun stabilize gp { group = g as GG.GROUP grec, gpath, anyerrors } =
81          case #stableinfo grec of          case #stableinfo grec of
82              GG.STABLE _ => g              GG.STABLE _ => SOME g
83            | GG.NONSTABLE granted => let            | GG.NONSTABLE granted => let
84    
85                    val bname = AbsPath.name o SmlInfo.binpath
86                    val bsz = OS.FileSys.fileSize o bname
87                    fun cpb s i = let
88                        val ins = BinIO.openIn (bname i)
89                        fun cp () =
90                            if BinIO.endOfStream ins then ()
91                            else (BinIO.output (s, BinIO.input ins); cp ())
92                    in
93                        cp () handle e => (BinIO.closeIn ins; raise e);
94                        BinIO.closeIn ins
95                    end
96                    val delb = deleteFile o bname
97    
98                    val grpSrcInfo = (#errcons gp, anyerrors)
99    
100                  val exports = #exports grec                  val exports = #exports grec
101                    val islib = #islib grec
102                    val required = StringSet.difference (#required grec,
103                                                         granted)
104                    val grouppath = #grouppath grec
105                    val subgroups = #subgroups grec
106    
107                  (* The format of a stable archive is the following:                  (* The format of a stable archive is the following:
108                   *  - It starts with the size s of the pickled dependency                   *  - It starts with the size s of the pickled dependency
# Line 49  Line 115 
115                   *    need no further adjustment.                   *    need no further adjustment.
116                   *  - Individual binfile contents (concatenated).                   *  - Individual binfile contents (concatenated).
117                   *)                   *)
                 val members = let  
                     fun sn (DG.SNODE { smlinfo, localimports = l, ... }, s) =  
                               if SmlInfoSet.member (s, smlinfo) then s  
                               else foldl sn (SmlInfoSet.add (s, smlinfo)) l  
                     fun impexp (((_, DG.SB_BNODE _), _), s) = s  
                       | impexp (((_, DG.SB_SNODE n), _), s) = sn (n, s)  
                 in  
                               SmlInfoSet.listItems  
                               (SymbolMap.foldl impexp SmlInfoSet.empty exports)  
                 end  
   
                 val offsetDict = let  
                     fun add (i, (d, n)) =  
                         (SmlInfoMap.insert (d, i, n), n + binSizeOf i)  
                 in  
                     #1 (foldl add (SmlInfoMap.empty, 0) members)  
                 end  
118    
119                  fun w_list w_item [] k m = "0" :: k m                  val members = ref []
120                    | w_list w_item [a] k m = "1" :: w_item a k m                  val (registerOffset, getOffset) = let
121                    | w_list w_item [a, b] k m = "2" :: w_item a (w_item b k) m                      val dict = ref SmlInfoMap.empty
122                        val cur = ref 0
123                        fun reg (i, sz) = let
124                            val os = !cur
125                        in
126                            cur := os + sz;
127                            dict := SmlInfoMap.insert (!dict, i, os);
128                            members := i :: (!members);
129                            os
130                        end
131                        fun get i = valOf (SmlInfoMap.find (!dict, i))
132                    in
133                        (reg, get)
134                    end
135    
136                    fun w_list w_item [] k m =
137                        "0" :: k m
138                      | w_list w_item [a] k m =
139                        "1" :: w_item a k m
140                      | w_list w_item [a, b] k m =
141                        "2" :: w_item a (w_item b k) m
142                    | w_list w_item [a, b, c] k m =                    | w_list w_item [a, b, c] k m =
143                      "3" :: w_item a (w_item b (w_item c k)) m                      "3" :: w_item a (w_item b (w_item c k)) m
144                    | w_list w_item [a, b, c, d] k m =                    | w_list w_item [a, b, c, d] k m =
# Line 115  Line 184 
184                      ns :: Symbol.name s :: "." :: k m                      ns :: Symbol.name s :: "." :: k m
185                  end                  end
186    
187                  val w_symbol = w_share w_symbol_raw S                  val w_symbol = w_share w_symbol_raw PS
188    
189                  val w_ss = w_share (w_list w_symbol o SymbolSet.listItems) SS                  val w_ss = w_share (w_list w_symbol o SymbolSet.listItems) PSS
190    
191                  val w_filter = w_option w_ss                  val w_filter = w_option w_ss
192    
# Line 134  Line 203 
203                    | w_sharing (SOME true) k m = "t" :: k m                    | w_sharing (SOME true) k m = "t" :: k m
204                    | w_sharing (SOME false) k m = "f" :: k m                    | w_sharing (SOME false) k m = "f" :: k m
205    
206                  fun w_si_raw i k = let                  fun w_si i k = let
207                      val spec = AbsPath.spec (SmlInfo.sourcepath i)                      val spec = AbsPath.spec (SmlInfo.sourcepath i)
208                      val locs = SmlInfo.errorLocation gp i                      val locs = SmlInfo.errorLocation gp i
209                      val offset = valOf (SmlInfoMap.find (offsetDict, i))                      val offset = registerOffset (i, bsz i)
210                  in                  in
211                      w_string spec                      w_string spec
212                          (w_string locs                          (w_string locs
# Line 145  Line 214 
214                                   (w_sharing (SmlInfo.share i) k)))                                   (w_sharing (SmlInfo.share i) k)))
215                  end                  end
216    
                 val w_si = w_share w_si_raw SI  
   
217                  fun w_primitive p k m = String.str (Primitive.toIdent p) :: k m                  fun w_primitive p k m = String.str (Primitive.toIdent p) :: k m
218    
219                  fun w_abspath_raw p k m =                  fun w_abspath_raw p k m =
220                      w_list w_string (AbsPath.pickle p) k m                      w_list w_string (AbsPath.pickle p) k m
221    
222                  val w_abspath = w_share w_abspath_raw AP                  val w_abspath = w_share w_abspath_raw PAP
223    
224                  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
225                    | w_bn (DG.BNODE { bininfo = i, ... }) k m =                    | w_bn (DG.BNODE { bininfo = i, ... }) k m =
226                      "b" :: w_abspath (BinInfo.group i)                      "b" :: w_abspath (BinInfo.group i)
227                                (w_int (BinInfo.offset i) k) m                                (w_int (BinInfo.offset i) k) m
228    
229                  fun w_sn (DG.SNODE n) k =                  fun w_sn_raw (DG.SNODE n) k =
230                      w_si (#smlinfo n)                      w_si (#smlinfo n)
231                          (w_list w_sn (#localimports n)                          (w_list w_sn (#localimports n)
232                                (w_list w_fsbn (#globalimports n) k))                                (w_list w_fsbn (#globalimports n) k))
233    
234                    and w_sn n = w_share w_sn_raw PSN n
235    
236                  and w_sbn (DG.SB_BNODE n) k m = "b" :: w_bn n k m                  and w_sbn (DG.SB_BNODE n) k m = "b" :: w_bn n k m
237                    | w_sbn (DG.SB_SNODE n) k m = "s" :: w_sn n k m                    | w_sbn (DG.SB_SNODE n) k m = "s" :: w_sn n k m
238    
# Line 178  Line 247 
247    
248                  fun w_privileges p = w_list w_string (StringSet.listItems p)                  fun w_privileges p = w_list w_string (StringSet.listItems p)
249    
250                  fun pickle_group (GG.GROUP g, granted) = let                  fun pickle_group () = let
251                      fun w_sg (GG.GROUP g) = w_abspath (#grouppath g)                      fun w_sg (GG.GROUP g) = w_abspath (#grouppath g)
                     val req' = StringSet.difference (#required g, granted)  
252                      fun k0 m = []                      fun k0 m = []
253                      val m0 = (0, Map.empty)                      val m0 = (0, Map.empty)
254                  in                  in
255                      concat                      concat
256                         (w_exports (#exports g)                         (w_exports exports
257                            (w_bool (#islib g)                             (w_bool islib
258                                (w_privileges req'                                (w_privileges required
259                                     (w_abspath (#grouppath g)                                      (w_list w_sg subgroups k0))) m0)
                                          (w_list w_sg (#subgroups g) k0)))) m0)  
260                  end                  end
261                  val pickle = pickle_group (g, granted)  
262                    val pickle = pickle_group ()
263                  val sz = size pickle                  val sz = size pickle
264                    val offset_adjustment = sz + 4
265    
266                    fun mkStableGroup () = let
267                        val m = ref SmlInfoMap.empty
268                        fun sn (DG.SNODE (n as { smlinfo, ... })) =
269                            case SmlInfoMap.find (!m, smlinfo) of
270                                SOME n => n
271                              | NONE => let
272                                    val li = map sn (#localimports n)
273                                    val gi = map fsbn (#globalimports n)
274                                    val sourcepath = SmlInfo.sourcepath smlinfo
275                                    val spec = AbsPath.spec sourcepath
276                                    val offset =
277                                        getOffset smlinfo + offset_adjustment
278                                    val share = SmlInfo.share smlinfo
279                                    val locs = SmlInfo.errorLocation gp smlinfo
280                                    val error = EM.errorNoSource grpSrcInfo locs
281                                    val i = BinInfo.new { group = grouppath,
282                                                          spec = spec,
283                                                          offset = offset,
284                                                          share = share,
285                                                          error = error }
286                                    val n = DG.BNODE { bininfo = i,
287                                                       localimports = li,
288                                                       globalimports = gi }
289              in              in
290                  Dummy.f ()                                  m := SmlInfoMap.insert (!m, smlinfo, n);
291                                    n
292              end              end
293    
294      fun g (getGroup, fsbn2env, knownStable, grpSrcInfo, group, s) = let                      and sbn (DG.SB_SNODE n) = sn n
295                          | sbn (DG.SB_BNODE n) = n
296    
297                        and fsbn (f, n) = (f, sbn n)
298    
299                        fun impexp ((f, n), e) = ((f, DG.SB_BNODE (sbn n)), e)
300    
301                        val exports = SymbolMap.map impexp (#exports grec)
302                        val simap = genStableInfoMap (exports, grouppath)
303                    in
304                        GG.GROUP { exports = exports,
305                                   islib = islib,
306                                   required = required,
307                                   grouppath = grouppath,
308                                   subgroups = subgroups,
309                                   stableinfo = GG.STABLE simap }
310                    end
311    
312                    fun writeInt32 (s, i) = let
313                        val a = Word8Array.array (4, 0w0)
314                        val _ = Pack32Big.update (a, 0, LargeWord.fromInt i)
315                    in
316                        BinIO.output (s, Word8Array.extract (a, 0, NONE))
317                    end
318                    val memberlist = rev (!members)
319    
320                    val policy = #fnpolicy (#param gp)
321                    val spath = FilenamePolicy.mkStablePath policy gpath
322                    fun delete () = deleteFile (AbsPath.name spath)
323                    val outs = AbsPath.openBinOut spath
324                    fun try () =
325                        (Say.vsay ["[stabilizing ", AbsPath.name gpath, "]\n"];
326                         writeInt32 (outs, sz);
327                         BinIO.output (outs, Byte.stringToBytes pickle);
328                         app (cpb outs) memberlist;
329                         app delb memberlist;
330                         BinIO.closeOut outs;
331                         SOME (mkStableGroup ()))
332                in
333                    Interrupt.guarded try
334                    handle e as Interrupt.Interrupt => (BinIO.closeOut outs;
335                                                        delete ();
336                                                        raise e)
337                         | exn => (BinIO.closeOut outs; NONE)
338                end
339    
340        fun loadStable (gp, getGroup, anyerrors) group = let
341    
342            fun bn2env n = Statenv2DAEnv.cvtMemo (fn () => bn2statenv gp n)
343    
344            val grpSrcInfo = (#errcons gp, anyerrors)
345    
346          exception Format          exception Format
347    
348            val policy = #fnpolicy (#param gp)
349            val spath = FilenamePolicy.mkStablePath policy group
350            val _ = Say.vsay ["[checking stable ", AbsPath.name group, "]\n"]
351            val s = AbsPath.openBinIn spath
352    
353            fun getGroup' p =
354                case getGroup p of
355                    SOME g => g
356                  | NONE => raise Format
357    
358          (* for getting sharing right... *)          (* for getting sharing right... *)
359          val m = ref IntBinaryMap.empty          val m = ref IntBinaryMap.empty
360          val next = ref 0          val next = ref 0
361    
         (* to build the stable info *)  
         val simap = ref IntBinaryMap.empty  
   
362          fun bytesIn n = let          fun bytesIn n = let
363              val bv = BinIO.inputN (s, n)              val bv = BinIO.inputN (s, n)
364          in          in
# Line 295  Line 446 
446                  case AbsPath.unpickle (r_list r_string ()) of                  case AbsPath.unpickle (r_list r_string ()) of
447                      SOME p => p                      SOME p => p
448                    | NONE => raise Format                    | NONE => raise Format
449              fun unAP (AP x) = x              fun unUAP (UAP x) = x
450                | unAP _ = raise Format                | unUAP _ = raise Format
451          in          in
452              r_share r_abspath_raw AP unAP              r_share r_abspath_raw UAP unUAP
453          end          end
454    
455          val r_symbol = let          val r_symbol = let
# Line 314  Line 465 
465              in              in
466                  ns (loop (first, []))                  ns (loop (first, []))
467              end              end
468              fun unS (S x) = x              fun unUS (US x) = x
469                | unS _ = raise Format                | unUS _ = raise Format
470          in          in
471              r_share r_symbol_raw S unS              r_share r_symbol_raw US unUS
472          end          end
473    
474          val r_ss = let          val r_ss = let
475              fun r_ss_raw () =              fun r_ss_raw () =
476                  SymbolSet.addList (SymbolSet.empty, r_list r_symbol ())                  SymbolSet.addList (SymbolSet.empty, r_list r_symbol ())
477              fun unSS (SS s) = s              fun unUSS (USS s) = s
478                | unSS _ = raise Format                | unUSS _ = raise Format
479          in          in
480              r_share r_ss_raw SS unSS              r_share r_ss_raw USS unUSS
481          end          end
482    
483          val r_filter = r_option r_ss          val r_filter = r_option r_ss
# Line 343  Line 494 
494                | #"f" => SOME false                | #"f" => SOME false
495                | _ => raise Format                | _ => raise Format
496    
497          val r_si = let          fun r_si () = let
             fun r_si_raw () = let  
498                  val spec = r_string ()                  val spec = r_string ()
499                  val locs = r_string ()                  val locs = r_string ()
500                  val offset = r_int () + offset_adjustment                  val offset = r_int () + offset_adjustment
501                  val share = r_sharing ()                  val share = r_sharing ()
502                  val error = EM.errorNoSource grpSrcInfo locs                  val error = EM.errorNoSource grpSrcInfo locs
503                  val i = BinInfo.new { group = group,          in
504                BinInfo.new { group = group,
505                                        error = error,                                        error = error,
506                                        spec = spec,                                        spec = spec,
507                                        offset = offset,                                        offset = offset,
508                                        share = share }                                        share = share }
             in  
                 simap := IntBinaryMap.insert (!simap, offset, i);  
                 i  
             end  
             fun unBI (BI i) = i  
               | unBI _ = raise Format  
         in  
             r_share r_si_raw BI unBI  
509          end          end
510    
511          fun r_bn () =          fun r_bn () =
512              case rd () of              case rd () of
513                  #"p" => DG.PNODE (r_primitive ())                  #"p" => DG.PNODE (r_primitive ())
514                | #"b" =>                | #"b" => let
515                      (case AbsPathMap.find (knownStable, r_abspath ()) of                      val p = r_abspath ()
516                        val os = r_int ()
517                    in
518                        case getGroup' p of
519                            GG.GROUP { stableinfo = GG.STABLE im, ... } =>
520                                (case IntBinaryMap.find (im, os) of
521                           NONE => raise Format                           NONE => raise Format
522                         | SOME im =>                                 | SOME n => n)
523                               (case IntBinaryMap.find (im, r_int ()) of                        | _ => raise Format
524                                    NONE => raise Format                  end
                                 | SOME n => n))  
525                | _ => raise Format                | _ => raise Format
526    
527          (* this is the place where what used to be an          (* this is the place where what used to be an
528           * SNODE changes to a BNODE! *)           * SNODE changes to a BNODE! *)
529          fun r_sn () =          fun r_sn_raw () =
530              DG.BNODE { bininfo = r_si (),              DG.BNODE { bininfo = r_si (),
531                         localimports = r_list r_sn (),                         localimports = r_list r_sn (),
532                         globalimports = r_list r_fsbn () }                         globalimports = r_list r_fsbn () }
533    
534            and r_sn () =
535                r_share r_sn_raw UBN (fn (UBN n) => n | _ => raise Format) ()
536    
537          (* this one changes from farsbnode to plain farbnode *)          (* this one changes from farsbnode to plain farbnode *)
538          and r_sbn () =          and r_sbn () =
539              case rd () of              case rd () of
# Line 396  Line 546 
546          fun r_impexp () = let          fun r_impexp () = let
547              val sy = r_symbol ()              val sy = r_symbol ()
548              val (f, n) = r_fsbn ()      (* really reads farbnodes! *)              val (f, n) = r_fsbn ()      (* really reads farbnodes! *)
549              val e = fsbn2env n              val e = bn2env n
550                (* put a filter in front to avoid having the FCTENV being
551                 * queried needlessly (this avoids spurious module loadings) *)
552                val e' = DAEnv.FILTER (SymbolSet.singleton sy, e)
553          in          in
554              (sy, ((f, DG.SB_BNODE n), e)) (* coerce to farsbnodes *)              (sy, ((f, DG.SB_BNODE n), e')) (* coerce to farsbnodes *)
555          end          end
556    
557          fun r_exports () =          fun r_exports () =
# Line 411  Line 564 
564              val exports = r_exports ()              val exports = r_exports ()
565              val islib = r_bool ()              val islib = r_bool ()
566              val required = r_privileges ()              val required = r_privileges ()
567              val grouppath = r_abspath ()              val subgroups = r_list (getGroup' o r_abspath) ()
568              val subgroups = r_list (getGroup o r_abspath) ()              val simap = genStableInfoMap (exports, group)
             fun add (((_, DG.SB_BNODE (DG.BNODE { bininfo, ... })), _), s) =  
                 IntBinarySet.add (s, BinInfo.offset bininfo)  
               | add (_, s) = s  
             val ens = SymbolMap.foldl add IntBinarySet.empty exports  
             fun isExported (os, _) = IntBinarySet.member (ens, os)  
             val final_simap = IntBinaryMap.filteri isExported (!simap)  
569          in          in
570              GG.GROUP { exports = exports,              GG.GROUP { exports = exports,
571                         islib = islib,                         islib = islib,
572                         required = required,                         required = required,
573                         grouppath = grouppath,                         grouppath = group,
574                         subgroups = subgroups,                         subgroups = subgroups,
575                         stableinfo = GG.STABLE final_simap }                         stableinfo = GG.STABLE simap }
576                before BinIO.closeIn s
577          end          end
578      in      in
579          SOME (unpickle_group ()) handle Format => NONE          SOME (unpickle_group ())
580      end          handle Format => (BinIO.closeIn s; NONE)
581                 | exn => (BinIO.closeIn s; raise exn)
582        end handle IO.Io _ => NONE
583  end  end
584    
585    end (* local *)

Legend:
Removed from v.306  
changed lines
  Added in v.310

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