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 305, Mon May 31 15:00:06 1999 UTC revision 306, Tue Jun 1 08:25:21 1999 UTC
# Line 1  Line 1 
1  structure Stablize = struct  structure Stablize = struct
2    
3      structure DG = DependencyGraph      structure DG = DependencyGraph
4        structure GG = GroupGraph
5        structure EM = GenericVC.ErrorMsg
6    
7      datatype item =      datatype item =
8          SS of SymbolSet.set          SS of SymbolSet.set
9        | S of Symbol.symbol        | S of Symbol.symbol
10        | SI of SmlInfo.info        | SI of SmlInfo.info              (* only used during pickling *)
11        | AP of AbsPath.t        | AP of AbsPath.t
12          | BI of BinInfo.info              (* only used during unpickling *)
13    
14      fun compare (S s, S s') = SymbolOrdKey.compare (s, s')      fun compare (S s, S s') = SymbolOrdKey.compare (s, s')
15        | compare (S _, _) = GREATER        | compare (S _, _) = GREATER
# Line 18  Line 21 
21        | compare (SI _, _) = GREATER        | compare (SI _, _) = GREATER
22        | compare (_, SI _) = LESS        | compare (_, SI _) = LESS
23        | compare (AP p, AP p') = AbsPath.compare (p, p')        | compare (AP p, AP p') = AbsPath.compare (p, p')
24          | compare (AP _, _) = GREATER
25          | compare (_, AP _) = LESS
26          | compare (BI i, BI i') = BinInfo.compare (i, i')
27    
28      structure Map =      structure Map =
29          BinaryMapFn (struct          BinaryMapFn (struct
# Line 25  Line 31 
31                           val compare = compare                           val compare = compare
32          end)          end)
33    
34      fun f (g as GroupGraph.GROUP { exports, ... }, binSizeOf, binCopy) = let      fun stabilize (g as GG.GROUP grec, binSizeOf, binCopy, gp) =
35            case #stableinfo grec of
36                GG.STABLE _ => g
37              | GG.NONSTABLE granted => let
38    
39                    val exports = #exports grec
40    
41          (* The format of a stable archive is the following:          (* The format of a stable archive is the following:
42           *  - It starts with the size s of the pickled dependency graph.                   *  - It starts with the size s of the pickled dependency
43           *    This size itself is written as four-byte string.                   *    graph. This size itself is written as four-byte string.
44           *  - The pickled dependency graph.  This graph contains integer                   *  - The pickled dependency graph.  This graph contains
45           *    offsets of the binfiles for the individual ML members.                   *    integer offsets of the binfiles for the individual ML
46           *    These offsets need to be adjusted by adding s + 4.                   *    members. These offsets need to be adjusted by adding
47           *    The pickled dependency graph also contains integer offsets                   *    s + 4. The pickled dependency graph also contains integer
48           *    relative to other stable groups.  These offsets need no                   *    offsets relative to other stable groups.  These offsets
49           *    further adjustment.                   *    need no further adjustment.
50           *  - Individual binfile contents (concatenated).           *  - Individual binfile contents (concatenated).
51           *)           *)
52          val members = let          val members = let
53              fun sn (DG.SNODE { smlinfo = i, localimports = l, ... }, s) =                      fun sn (DG.SNODE { smlinfo, localimports = l, ... }, s) =
54                  if SmlInfoSet.member (s, i) then s                                if SmlInfoSet.member (s, smlinfo) then s
55                  else foldl sn (SmlInfoSet.add (s, i)) l                                else foldl sn (SmlInfoSet.add (s, smlinfo)) l
56              fun impexp (((_, DG.SB_BNODE _), _), s) = s              fun impexp (((_, DG.SB_BNODE _), _), s) = s
57                | impexp (((_, DG.SB_SNODE n), _), s) = sn (n, s)                | impexp (((_, DG.SB_SNODE n), _), s) = sn (n, s)
58          in          in
# Line 55  Line 67 
67              #1 (foldl add (SmlInfoMap.empty, 0) members)              #1 (foldl add (SmlInfoMap.empty, 0) members)
68          end          end
69    
70          fun w_list w_item [] k m = ";" :: k m                  fun w_list w_item [] k m = "0" :: k m
71            | w_list w_item (h :: t) k m = w_item h (w_list w_item t k) m                    | w_list w_item [a] k m = "1" :: w_item a k m
72                      | w_list w_item [a, b] k m = "2" :: w_item a (w_item b k) m
73                      | w_list w_item [a, b, c] k m =
74                        "3" :: w_item a (w_item b (w_item c k)) m
75                      | w_list w_item [a, b, c, d] k m =
76                        "4" :: w_item a (w_item b (w_item c (w_item d k))) m
77                      | w_list w_item (a :: b :: c :: d :: e :: r) k m =
78                        "5" :: w_item a (w_item b (w_item c (w_item d (w_item e
79                                                      (w_list w_item r k))))) m
80    
81          fun w_option w_item NONE k m = "n" :: k m          fun w_option w_item NONE k m = "n" :: k m
82            | w_option w_item (SOME i) k m = "s" :: w_item i k m            | w_option w_item (SOME i) k m = "s" :: w_item i k m
83    
84          fun int_encode i = let          fun int_encode i = let
85              (* this is the same mechanism that's also used in              (* this is the same mechanism that's also used in
86               * TopLevel/batch/binfile.sml -- maybe we should share it *)                       * TopLevel/batch/binfile.sml (maybe we should share it) *)
87              val n = Word32.fromInt i              val n = Word32.fromInt i
88              val // = LargeWord.div              val // = LargeWord.div
89              val %% = LargeWord.mod              val %% = LargeWord.mod
# Line 71  Line 91 
91              infix // %% !!              infix // %% !!
92              val toW8 = Word8.fromLargeWord              val toW8 = Word8.fromLargeWord
93              fun r (0w0, l) = Word8Vector.fromList l              fun r (0w0, l) = Word8Vector.fromList l
94                | r (n, l) = r (n // 0w128, toW8 ((n %% 0w128) !! 0w128) :: l)                        | r (n, l) =
95                            r (n // 0w128, toW8 ((n %% 0w128) !! 0w128) :: l)
96          in          in
97              Byte.bytesToString (r (n // 0w128, [toW8 (n %% 0w128)]))              Byte.bytesToString (r (n // 0w128, [toW8 (n %% 0w128)]))
98          end          end
# Line 81  Line 102 
102          fun w_share w C v k (i, m) =          fun w_share w C v k (i, m) =
103              case Map.find (m, C v) of              case Map.find (m, C v) of
104                  SOME i' => "o" :: w_int i' k (i, m)                  SOME i' => "o" :: w_int i' k (i, m)
105                | NONE => "n" :: w_int i (w v k) (i + 1, Map.insert (m, C v, i))                        | NONE => "n" :: w v k (i + 1, Map.insert (m, C v, i))
106    
107          fun w_symbol_raw s k m = SkelIO.w_name (s, k m)                  fun w_symbol_raw s k m = let
108                        val ns = case Symbol.nameSpace s of
109                            Symbol.SIGspace => "'"
110                          | Symbol.FCTspace => "("
111                          | Symbol.FSIGspace => ")"
112                          | Symbol.STRspace => ""
113                          | _ => GenericVC.ErrorMsg.impossible "stabilize:w_symbol"
114                    in
115                        ns :: Symbol.name s :: "." :: k m
116                    end
117    
118          val w_symbol = w_share w_symbol_raw S          val w_symbol = w_share w_symbol_raw S
119    
# Line 106  Line 136 
136    
137          fun w_si_raw i k = let          fun w_si_raw i k = let
138              val spec = AbsPath.spec (SmlInfo.sourcepath i)              val spec = AbsPath.spec (SmlInfo.sourcepath i)
139                        val locs = SmlInfo.errorLocation gp i
140              val offset = valOf (SmlInfoMap.find (offsetDict, i))              val offset = valOf (SmlInfoMap.find (offsetDict, i))
141          in          in
142              w_string spec (w_int offset (w_sharing (SmlInfo.share i) k))                      w_string spec
143                            (w_string locs
144                                (w_int offset
145                                     (w_sharing (SmlInfo.share i) k)))
146          end          end
147    
148          val w_si = w_share w_si_raw SI          val w_si = w_share w_si_raw SI
149    
150          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
151    
152          fun w_abspath_raw p k m = w_list w_string (AbsPath.pickle p) k m                  fun w_abspath_raw p k m =
153                        w_list w_string (AbsPath.pickle p) k m
154    
155          val w_abspath = w_share w_abspath_raw AP          val w_abspath = w_share w_abspath_raw AP
156    
         fun w_bi i k = w_abspath (BinInfo.group i) (w_int (BinInfo.offset i) k)  
   
157          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
158            | w_bn (DG.BNODE { bininfo, ... }) k m = "b" :: w_bi bininfo k m                    | w_bn (DG.BNODE { bininfo = i, ... }) k m =
159                        "b" :: w_abspath (BinInfo.group i)
160                                  (w_int (BinInfo.offset i) k) m
161    
162          fun w_sn (DG.SNODE n) k =          fun w_sn (DG.SNODE n) k =
163              w_si (#smlinfo n)              w_si (#smlinfo n)
164                   (w_list w_sn (#localimports n)                   (w_list w_sn (#localimports n)
165                                (w_list w_fsbn (#globalimports n) k))                                (w_list w_fsbn (#globalimports n) k))
166    
167          and w_sbn (DG.SB_BNODE n) = w_bn n                  and w_sbn (DG.SB_BNODE n) k m = "b" :: w_bn n k m
168            | w_sbn (DG.SB_SNODE n) = GenericVC.ErrorMsg.impossible                    | w_sbn (DG.SB_SNODE n) k m = "s" :: w_sn n k m
             "stabilize: non-stabilized subgroup? (2)"  
169    
170          and w_fsbn (f, n) k = w_filter f (w_sbn n k)          and w_fsbn (f, n) k = w_filter f (w_sbn n k)
171    
# Line 144  Line 178 
178    
179          fun w_privileges p = w_list w_string (StringSet.listItems p)          fun w_privileges p = w_list w_string (StringSet.listItems p)
180    
181          fun pickle_group (GroupGraph.GROUP g) = let                  fun pickle_group (GG.GROUP g, granted) = let
182              val { exports, islib, required, grouppath, subgroups, ... } = g                      fun w_sg (GG.GROUP g) = w_abspath (#grouppath g)
183              fun w_sg (GroupGraph.GROUP { grouppath = gp, ... }) = w_abspath gp                      val req' = StringSet.difference (#required g, granted)
184              fun k0 m = []              fun k0 m = []
185              val m0 = (0, Map.empty)              val m0 = (0, Map.empty)
186          in          in
187              concat              concat
188                (w_exports exports                         (w_exports (#exports g)
189                     (w_bool islib                            (w_bool (#islib g)
190                            (w_privileges required                                (w_privileges req'
191                                     (w_abspath grouppath                                     (w_abspath (#grouppath g)
192                                                (w_list w_sg subgroups k0)))) m0)                                           (w_list w_sg (#subgroups g) k0)))) m0)
193          end          end
194          val pickle = pickle_group g                  val pickle = pickle_group (g, granted)
195          val sz = size pickle          val sz = size pickle
196      in      in
197          ()                  Dummy.f ()
198                end
199    
200        fun g (getGroup, fsbn2env, knownStable, grpSrcInfo, group, s) = let
201    
202            exception Format
203    
204            (* for getting sharing right... *)
205            val m = ref IntBinaryMap.empty
206            val next = ref 0
207    
208            (* to build the stable info *)
209            val simap = ref IntBinaryMap.empty
210    
211            fun bytesIn n = let
212                val bv = BinIO.inputN (s, n)
213            in
214                if n = Word8Vector.length bv then bv
215                else raise Format
216            end
217    
218            val sz = LargeWord.toIntX (Pack32Big.subVec (bytesIn 4, 0))
219            val pickle = bytesIn sz
220            val offset_adjustment = sz + 4
221    
222            val rd = let
223                val pos = ref 0
224                fun rd () = let
225                    val p = !pos
226                in
227                    pos := p + 1;
228                    Byte.byteToChar (Word8Vector.sub (pickle, p))
229                    handle _ => raise Format
230                end
231            in
232                rd
233            end
234    
235            fun r_list r () =
236                case rd () of
237                    #"0" => []
238                  | #"1" => [r ()]
239                  | #"2" => [r (), r ()]
240                  | #"3" => [r (), r (), r ()]
241                  | #"4" => [r (), r (), r (), r ()]
242                  | #"5" => r () :: r () :: r () :: r () :: r () :: r_list r ()
243                  | _ => raise Format
244    
245            fun r_bool () =
246                case rd () of
247                    #"t" => true
248                  | #"f" => false
249                  | _ => raise Format
250    
251            fun r_option r_item () =
252                case rd () of
253                    #"n" => NONE
254                  | #"s" => SOME (r_item ())
255                  | _ => raise Format
256    
257            fun r_int () = let
258                fun loop n = let
259                    val w8 = Byte.charToByte (rd ())
260                    val n' = n * 0w128 + Word8.toLargeWord (Word8.andb (w8, 0w127))
261                in
262                    if Word8.andb (w8, 0w128) = 0w0 then n' else loop n'
263                end
264            in
265                LargeWord.toIntX (loop 0w0)
266            end
267    
268            fun r_share r_raw C unC () =
269                case rd () of
270                    #"o" => (case IntBinaryMap.find (!m, r_int ()) of
271                                 SOME x => unC x
272                               | NONE => raise Format)
273                  | #"n" => let
274                        val i = !next
275                        val _ = next := i + 1
276                        val v = r_raw ()
277                    in
278                        m := IntBinaryMap.insert (!m, i, C v);
279                        v
280                    end
281                  | _ => raise Format
282    
283            fun r_string () = let
284                fun loop l =
285                    case rd () of
286                        #"\"" => String.implode (rev l)
287                      | #"\\" => loop (rd () :: l)
288                      | c => loop (c :: l)
289            in
290                loop []
291            end
292    
293            val r_abspath = let
294                fun r_abspath_raw () =
295                    case AbsPath.unpickle (r_list r_string ()) of
296                        SOME p => p
297                      | NONE => raise Format
298                fun unAP (AP x) = x
299                  | unAP _ = raise Format
300            in
301                r_share r_abspath_raw AP unAP
302            end
303    
304            val r_symbol = let
305                fun r_symbol_raw () = let
306                    val (ns, first) =
307                        case rd () of
308                            #"`" => (Symbol.sigSymbol, rd ())
309                          | #"(" => (Symbol.fctSymbol, rd ())
310                          | #")" => (Symbol.fsigSymbol, rd ())
311                          | c => (Symbol.strSymbol, c)
312                    fun loop (#".", l) = String.implode (rev l)
313                      | loop (c, l) = loop (rd (), c :: l)
314                in
315                    ns (loop (first, []))
316                end
317                fun unS (S x) = x
318                  | unS _ = raise Format
319            in
320                r_share r_symbol_raw S unS
321            end
322    
323            val r_ss = let
324                fun r_ss_raw () =
325                    SymbolSet.addList (SymbolSet.empty, r_list r_symbol ())
326                fun unSS (SS s) = s
327                  | unSS _ = raise Format
328            in
329                r_share r_ss_raw SS unSS
330            end
331    
332            val r_filter = r_option r_ss
333    
334            fun r_primitive () =
335                case Primitive.fromIdent (rd ()) of
336                    NONE => raise Format
337                  | SOME p => p
338    
339            fun r_sharing () =
340                case rd () of
341                    #"n" => NONE
342                  | #"t" => SOME true
343                  | #"f" => SOME false
344                  | _ => raise Format
345    
346            val r_si = let
347                fun r_si_raw () = let
348                    val spec = r_string ()
349                    val locs = r_string ()
350                    val offset = r_int () + offset_adjustment
351                    val share = r_sharing ()
352                    val error = EM.errorNoSource grpSrcInfo locs
353                    val i = BinInfo.new { group = group,
354                                          error = error,
355                                          spec = spec,
356                                          offset = offset,
357                                          share = share }
358                in
359                    simap := IntBinaryMap.insert (!simap, offset, i);
360                    i
361                end
362                fun unBI (BI i) = i
363                  | unBI _ = raise Format
364            in
365                r_share r_si_raw BI unBI
366            end
367    
368            fun r_bn () =
369                case rd () of
370                    #"p" => DG.PNODE (r_primitive ())
371                  | #"b" =>
372                        (case AbsPathMap.find (knownStable, r_abspath ()) of
373                             NONE => raise Format
374                           | SOME im =>
375                                 (case IntBinaryMap.find (im, r_int ()) of
376                                      NONE => raise Format
377                                    | SOME n => n))
378                  | _ => raise Format
379    
380            (* this is the place where what used to be an
381             * SNODE changes to a BNODE! *)
382            fun r_sn () =
383                DG.BNODE { bininfo = r_si (),
384                           localimports = r_list r_sn (),
385                           globalimports = r_list r_fsbn () }
386    
387            (* this one changes from farsbnode to plain farbnode *)
388            and r_sbn () =
389                case rd () of
390                    #"b" => r_bn ()
391                  | #"s" => r_sn ()
392                  | _ => raise Format
393    
394            and r_fsbn () = (r_filter (), r_sbn ())
395    
396            fun r_impexp () = let
397                val sy = r_symbol ()
398                val (f, n) = r_fsbn ()      (* really reads farbnodes! *)
399                val e = fsbn2env n
400            in
401                (sy, ((f, DG.SB_BNODE n), e)) (* coerce to farsbnodes *)
402            end
403    
404            fun r_exports () =
405                foldl SymbolMap.insert' SymbolMap.empty (r_list r_impexp ())
406    
407            fun r_privileges () =
408                StringSet.addList (StringSet.empty, r_list r_string ())
409    
410            fun unpickle_group () = let
411                val exports = r_exports ()
412                val islib = r_bool ()
413                val required = r_privileges ()
414                val grouppath = r_abspath ()
415                val subgroups = r_list (getGroup o r_abspath) ()
416                fun add (((_, DG.SB_BNODE (DG.BNODE { bininfo, ... })), _), s) =
417                    IntBinarySet.add (s, BinInfo.offset bininfo)
418                  | add (_, s) = s
419                val ens = SymbolMap.foldl add IntBinarySet.empty exports
420                fun isExported (os, _) = IntBinarySet.member (ens, os)
421                val final_simap = IntBinaryMap.filteri isExported (!simap)
422            in
423                GG.GROUP { exports = exports,
424                           islib = islib,
425                           required = required,
426                           grouppath = grouppath,
427                           subgroups = subgroups,
428                           stableinfo = GG.STABLE final_simap }
429            end
430        in
431            SOME (unpickle_group ()) handle Format => NONE
432      end      end
433  end  end

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

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