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 309, Wed Jun 2 03:21:57 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    in
15    
16    signature STABILIZE = sig
17    
18      datatype item =      val loadStable :
19          SS of SymbolSet.set          GP.info * (AbsPath.t -> GG.group) ->
20        | S of Symbol.symbol          { group: AbsPath.t, s: BinIO.instream, anyerrors: bool ref } ->
21        | SI of SmlInfo.info              (* only used during pickling *)          GG.group option
22        | AP of AbsPath.t  
23        | BI of BinInfo.info              (* only used during unpickling *)      val stabilize :
24            GP.info ->
25      fun compare (S s, S s') = SymbolOrdKey.compare (s, s')          { group: GG.group, s: BinIO.outstream, anyerrors: bool ref } ->
26        | compare (S _, _) = GREATER          GG.group
27        | compare (_, S _) = LESS  end
28        | compare (SS s, SS s') = SymbolSet.compare (s, s')  
29        | compare (SS _, _) = GREATER  functor StablizeFn
30        | compare (_, SS _) = LESS      (val bn2statenv : GP.info -> DG.bnode -> E.staticEnv
31        | compare (SI i, SI i') = SmlInfo.compare (i, i')       val binSizeOf : SmlInfo.info -> int
32        | compare (SI _, _) = GREATER       val copyBin : BinIO.outstream -> SmlInfo.info -> unit) :> STABILIZE =
33        | compare (_, SI _) = LESS  struct
34        | compare (AP p, AP p') = AbsPath.compare (p, p')  
35        | compare (AP _, _) = GREATER  
36        | compare (_, AP _) = LESS      datatype pitem =
37        | compare (BI i, BI i') = BinInfo.compare (i, i')          PSS of SymbolSet.set
38          | PS of Symbol.symbol
39          | PSN of DG.snode
40          | PAP of AbsPath.t
41    
42        datatype uitem =
43            USS of SymbolSet.set
44          | US of Symbol.symbol
45          | UBN of DG.bnode
46          | UAP of AbsPath.t
47    
48        fun compare (PS s, PS s') = SymbolOrdKey.compare (s, s')
49          | compare (PS _, _) = GREATER
50          | compare (_, PS _) = LESS
51          | compare (PSS s, PSS s') = SymbolSet.compare (s, s')
52          | compare (PSS _, _) = GREATER
53          | compare (_, PSS _) = LESS
54          | compare (PSN (DG.SNODE n), PSN (DG.SNODE n')) =
55            SmlInfo.compare (#smlinfo n, #smlinfo n')
56          | compare (PSN _, _) = GREATER
57          | compare (_, PSN _) = LESS
58          | compare (PAP p, PAP p') = AbsPath.compare (p, p')
59    
60      structure Map =      structure Map =
61          BinaryMapFn (struct          BinaryMapFn (struct
62                           type ord_key = item                           type ord_key = pitem
63                           val compare = compare                           val compare = compare
64          end)          end)
65    
66      fun stabilize (g as GG.GROUP grec, binSizeOf, binCopy, gp) =      fun genStableInfoMap (exports, group) = let
67            (* find all the exported bnodes that are in the same group: *)
68            fun add (((_, DG.SB_BNODE (n as DG.BNODE b)), _), m) = let
69                val i = #bininfo b
70            in
71                if AbsPath.compare (BinInfo.group i, group) = EQUAL then
72                    IntBinaryMap.insert (m, BinInfo.offset i, n)
73                else m
74            end
75              | add (_, m) = m
76        in
77            SymbolMap.foldl add IntBinaryMap.empty exports
78        end
79    
80        fun stabilize gp { group = g as GG.GROUP grec, s = outs, anyerrors } =
81          case #stableinfo grec of          case #stableinfo grec of
82              GG.STABLE _ => g              GG.STABLE _ => g
83            | GG.NONSTABLE granted => let            | GG.NONSTABLE granted => let
84    
85                    val grpSrcInfo = (#errcons gp, anyerrors)
86    
87                  val exports = #exports grec                  val exports = #exports grec
88                    val islib = #islib grec
89                    val required = StringSet.difference (#required grec,
90                                                         granted)
91                    val grouppath = #grouppath grec
92                    val subgroups = #subgroups grec
93    
94                  (* The format of a stable archive is the following:                  (* The format of a stable archive is the following:
95                   *  - It starts with the size s of the pickled dependency                   *  - It starts with the size s of the pickled dependency
# Line 49  Line 102 
102                   *    need no further adjustment.                   *    need no further adjustment.
103                   *  - Individual binfile contents (concatenated).                   *  - Individual binfile contents (concatenated).
104                   *)                   *)
                 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  
105    
106                  fun w_list w_item [] k m = "0" :: k m                  val members = ref []
107                    | w_list w_item [a] k m = "1" :: w_item a k m                  val (registerOffset, getOffset) = let
108                    | w_list w_item [a, b] k m = "2" :: w_item a (w_item b k) m                      val dict = ref SmlInfoMap.empty
109                        val cur = ref 0
110                        fun reg (i, sz) = let
111                            val os = !cur
112                        in
113                            cur := os + sz;
114                            dict := SmlInfoMap.insert (!dict, i, os);
115                            members := i :: (!members);
116                            os
117                        end
118                        fun get i = valOf (SmlInfoMap.find (!dict, i))
119                    in
120                        (reg, get)
121                    end
122    
123                    fun w_list w_item [] k m =
124                        "0" :: k m
125                      | w_list w_item [a] k m =
126                        "1" :: w_item a k m
127                      | w_list w_item [a, b] k m =
128                        "2" :: w_item a (w_item b k) m
129                    | w_list w_item [a, b, c] k m =                    | w_list w_item [a, b, c] k m =
130                      "3" :: w_item a (w_item b (w_item c k)) m                      "3" :: w_item a (w_item b (w_item c k)) m
131                    | w_list w_item [a, b, c, d] k m =                    | w_list w_item [a, b, c, d] k m =
# Line 115  Line 171 
171                      ns :: Symbol.name s :: "." :: k m                      ns :: Symbol.name s :: "." :: k m
172                  end                  end
173    
174                  val w_symbol = w_share w_symbol_raw S                  val w_symbol = w_share w_symbol_raw PS
175    
176                  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
177    
178                  val w_filter = w_option w_ss                  val w_filter = w_option w_ss
179    
# Line 134  Line 190 
190                    | w_sharing (SOME true) k m = "t" :: k m                    | w_sharing (SOME true) k m = "t" :: k m
191                    | w_sharing (SOME false) k m = "f" :: k m                    | w_sharing (SOME false) k m = "f" :: k m
192    
193                  fun w_si_raw i k = let                  fun w_si i k = let
194                      val spec = AbsPath.spec (SmlInfo.sourcepath i)                      val spec = AbsPath.spec (SmlInfo.sourcepath i)
195                      val locs = SmlInfo.errorLocation gp i                      val locs = SmlInfo.errorLocation gp i
196                      val offset = valOf (SmlInfoMap.find (offsetDict, i))                      val offset = registerOffset (i, binSizeOf i)
197                  in                  in
198                      w_string spec                      w_string spec
199                          (w_string locs                          (w_string locs
# Line 145  Line 201 
201                                   (w_sharing (SmlInfo.share i) k)))                                   (w_sharing (SmlInfo.share i) k)))
202                  end                  end
203    
                 val w_si = w_share w_si_raw SI  
   
204                  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
205    
206                  fun w_abspath_raw p k m =                  fun w_abspath_raw p k m =
207                      w_list w_string (AbsPath.pickle p) k m                      w_list w_string (AbsPath.pickle p) k m
208    
209                  val w_abspath = w_share w_abspath_raw AP                  val w_abspath = w_share w_abspath_raw PAP
210    
211                  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
212                    | w_bn (DG.BNODE { bininfo = i, ... }) k m =                    | w_bn (DG.BNODE { bininfo = i, ... }) k m =
213                      "b" :: w_abspath (BinInfo.group i)                      "b" :: w_abspath (BinInfo.group i)
214                                (w_int (BinInfo.offset i) k) m                                (w_int (BinInfo.offset i) k) m
215    
216                  fun w_sn (DG.SNODE n) k =                  fun w_sn_raw (DG.SNODE n) k =
217                      w_si (#smlinfo n)                      w_si (#smlinfo n)
218                          (w_list w_sn (#localimports n)                          (w_list w_sn (#localimports n)
219                                (w_list w_fsbn (#globalimports n) k))                                (w_list w_fsbn (#globalimports n) k))
220    
221                    and w_sn n = w_share w_sn_raw PSN n
222    
223                  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
224                    | 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
225    
# Line 178  Line 234 
234    
235                  fun w_privileges p = w_list w_string (StringSet.listItems p)                  fun w_privileges p = w_list w_string (StringSet.listItems p)
236    
237                  fun pickle_group (GG.GROUP g, granted) = let                  fun pickle_group () = let
238                      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)  
239                      fun k0 m = []                      fun k0 m = []
240                      val m0 = (0, Map.empty)                      val m0 = (0, Map.empty)
241                  in                  in
242                      concat                      concat
243                         (w_exports (#exports g)                         (w_exports exports
244                            (w_bool (#islib g)                             (w_bool islib
245                                (w_privileges req'                                (w_privileges required
246                                     (w_abspath (#grouppath g)                                      (w_list w_sg subgroups k0))) m0)
                                          (w_list w_sg (#subgroups g) k0)))) m0)  
247                  end                  end
248                  val pickle = pickle_group (g, granted)  
249                    val pickle = pickle_group ()
250                  val sz = size pickle                  val sz = size pickle
251                    val offset_adjustment = sz + 4
252    
253                    fun mkStableGroup () = let
254                        val m = ref SmlInfoMap.empty
255                        fun sn (DG.SNODE (n as { smlinfo, ... })) =
256                            case SmlInfoMap.find (!m, smlinfo) of
257                                SOME n => n
258                              | NONE => let
259                                    val li = map sn (#localimports n)
260                                    val gi = map fsbn (#globalimports n)
261                                    val sourcepath = SmlInfo.sourcepath smlinfo
262                                    val spec = AbsPath.spec sourcepath
263                                    val offset =
264                                        getOffset smlinfo + offset_adjustment
265                                    val share = SmlInfo.share smlinfo
266                                    val locs = SmlInfo.errorLocation gp smlinfo
267                                    val error = EM.errorNoSource grpSrcInfo locs
268                                    val i = BinInfo.new { group = grouppath,
269                                                          spec = spec,
270                                                          offset = offset,
271                                                          share = share,
272                                                          error = error }
273                                    val n = DG.BNODE { bininfo = i,
274                                                       localimports = li,
275                                                       globalimports = gi }
276              in              in
277                  Dummy.f ()                                  m := SmlInfoMap.insert (!m, smlinfo, n);
278                                    n
279              end              end
280    
281      fun g (getGroup, fsbn2env, knownStable, grpSrcInfo, group, s) = let                      and sbn (DG.SB_SNODE n) = sn n
282                          | sbn (DG.SB_BNODE n) = n
283    
284                        and fsbn (f, n) = (f, sbn n)
285    
286                        fun impexp ((f, n), e) = ((f, DG.SB_BNODE (sbn n)), e)
287    
288                        val exports = SymbolMap.map impexp (#exports grec)
289                        val simap = genStableInfoMap (exports, grouppath)
290                    in
291                        GG.GROUP { exports = exports,
292                                   islib = islib,
293                                   required = required,
294                                   grouppath = grouppath,
295                                   subgroups = subgroups,
296                                   stableinfo = GG.STABLE simap }
297                    end
298    
299                    fun writeInt32 (s, i) = let
300                        val a = Word8Array.array (4, 0w0)
301                        val _ = Pack32Big.update (a, 0, LargeWord.fromInt i)
302                    in
303                        BinIO.output (s, Word8Array.extract (a, 0, NONE))
304                    end
305                in
306                    writeInt32 (outs, sz);
307                    BinIO.output (outs, Byte.stringToBytes pickle);
308                    app (copyBin outs) (rev (!members));
309                    mkStableGroup ()
310                end
311    
312        fun loadStable (gp, getGroup) { group, s, anyerrors } = let
313    
314            val bn2env = #1 o Statenv2DAEnv.cvt o bn2statenv gp
315    
316            val grpSrcInfo = (#errcons gp, anyerrors)
317    
318          exception Format          exception Format
319    
# Line 205  Line 321 
321          val m = ref IntBinaryMap.empty          val m = ref IntBinaryMap.empty
322          val next = ref 0          val next = ref 0
323    
         (* to build the stable info *)  
         val simap = ref IntBinaryMap.empty  
   
324          fun bytesIn n = let          fun bytesIn n = let
325              val bv = BinIO.inputN (s, n)              val bv = BinIO.inputN (s, n)
326          in          in
# Line 295  Line 408 
408                  case AbsPath.unpickle (r_list r_string ()) of                  case AbsPath.unpickle (r_list r_string ()) of
409                      SOME p => p                      SOME p => p
410                    | NONE => raise Format                    | NONE => raise Format
411              fun unAP (AP x) = x              fun unUAP (UAP x) = x
412                | unAP _ = raise Format                | unUAP _ = raise Format
413          in          in
414              r_share r_abspath_raw AP unAP              r_share r_abspath_raw UAP unUAP
415          end          end
416    
417          val r_symbol = let          val r_symbol = let
# Line 314  Line 427 
427              in              in
428                  ns (loop (first, []))                  ns (loop (first, []))
429              end              end
430              fun unS (S x) = x              fun unUS (US x) = x
431                | unS _ = raise Format                | unUS _ = raise Format
432          in          in
433              r_share r_symbol_raw S unS              r_share r_symbol_raw US unUS
434          end          end
435    
436          val r_ss = let          val r_ss = let
437              fun r_ss_raw () =              fun r_ss_raw () =
438                  SymbolSet.addList (SymbolSet.empty, r_list r_symbol ())                  SymbolSet.addList (SymbolSet.empty, r_list r_symbol ())
439              fun unSS (SS s) = s              fun unUSS (USS s) = s
440                | unSS _ = raise Format                | unUSS _ = raise Format
441          in          in
442              r_share r_ss_raw SS unSS              r_share r_ss_raw USS unUSS
443          end          end
444    
445          val r_filter = r_option r_ss          val r_filter = r_option r_ss
# Line 343  Line 456 
456                | #"f" => SOME false                | #"f" => SOME false
457                | _ => raise Format                | _ => raise Format
458    
459          val r_si = let          fun r_si () = let
             fun r_si_raw () = let  
460                  val spec = r_string ()                  val spec = r_string ()
461                  val locs = r_string ()                  val locs = r_string ()
462                  val offset = r_int () + offset_adjustment                  val offset = r_int () + offset_adjustment
463                  val share = r_sharing ()                  val share = r_sharing ()
464                  val error = EM.errorNoSource grpSrcInfo locs                  val error = EM.errorNoSource grpSrcInfo locs
465                  val i = BinInfo.new { group = group,          in
466                BinInfo.new { group = group,
467                                        error = error,                                        error = error,
468                                        spec = spec,                                        spec = spec,
469                                        offset = offset,                                        offset = offset,
470                                        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  
471          end          end
472    
473          fun r_bn () =          fun r_bn () =
474              case rd () of              case rd () of
475                  #"p" => DG.PNODE (r_primitive ())                  #"p" => DG.PNODE (r_primitive ())
476                | #"b" =>                | #"b" => let
477                      (case AbsPathMap.find (knownStable, r_abspath ()) of                      val p = r_abspath ()
478                           NONE => raise Format                      val os = r_int ()
479                         | SOME im =>                      val GG.GROUP { stableinfo, ... } = getGroup p
480                               (case IntBinaryMap.find (im, r_int ()) of                  in
481                        case stableinfo of
482                            GG.NONSTABLE _ => raise Format
483                          | GG.STABLE im =>
484                                (case IntBinaryMap.find (im, os) of
485                                    NONE => raise Format                                    NONE => raise Format
486                                  | SOME n => n))                                 | SOME n => n)
487                    end
488                | _ => raise Format                | _ => raise Format
489    
490          (* this is the place where what used to be an          (* this is the place where what used to be an
491           * SNODE changes to a BNODE! *)           * SNODE changes to a BNODE! *)
492          fun r_sn () =          fun r_sn_raw () =
493              DG.BNODE { bininfo = r_si (),              DG.BNODE { bininfo = r_si (),
494                         localimports = r_list r_sn (),                         localimports = r_list r_sn (),
495                         globalimports = r_list r_fsbn () }                         globalimports = r_list r_fsbn () }
496    
497            and r_sn () =
498                r_share r_sn_raw UBN (fn (UBN n) => n | _ => raise Format) ()
499    
500          (* this one changes from farsbnode to plain farbnode *)          (* this one changes from farsbnode to plain farbnode *)
501          and r_sbn () =          and r_sbn () =
502              case rd () of              case rd () of
# Line 396  Line 509 
509          fun r_impexp () = let          fun r_impexp () = let
510              val sy = r_symbol ()              val sy = r_symbol ()
511              val (f, n) = r_fsbn ()      (* really reads farbnodes! *)              val (f, n) = r_fsbn ()      (* really reads farbnodes! *)
512              val e = fsbn2env n              val e = bn2env n
513          in          in
514              (sy, ((f, DG.SB_BNODE n), e)) (* coerce to farsbnodes *)              (sy, ((f, DG.SB_BNODE n), e)) (* coerce to farsbnodes *)
515          end          end
# Line 411  Line 524 
524              val exports = r_exports ()              val exports = r_exports ()
525              val islib = r_bool ()              val islib = r_bool ()
526              val required = r_privileges ()              val required = r_privileges ()
             val grouppath = r_abspath ()  
527              val subgroups = r_list (getGroup o r_abspath) ()              val subgroups = r_list (getGroup o r_abspath) ()
528              fun add (((_, DG.SB_BNODE (DG.BNODE { bininfo, ... })), _), s) =              val simap = genStableInfoMap (exports, group)
                 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)  
529          in          in
530              GG.GROUP { exports = exports,              GG.GROUP { exports = exports,
531                         islib = islib,                         islib = islib,
532                         required = required,                         required = required,
533                         grouppath = grouppath,                         grouppath = group,
534                         subgroups = subgroups,                         subgroups = subgroups,
535                         stableinfo = GG.STABLE final_simap }                         stableinfo = GG.STABLE simap }
536          end          end
537      in      in
538          SOME (unpickle_group ()) handle Format => NONE          SOME (unpickle_group ()) handle Format => NONE
539      end      end
540  end  end
541    
542    end (* local *)

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

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