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 307, Tue Jun 1 09:38:28 1999 UTC
# Line 4  Line 4 
4      structure GG = GroupGraph      structure GG = GroupGraph
5      structure EM = GenericVC.ErrorMsg      structure EM = GenericVC.ErrorMsg
6    
7      datatype item =      datatype pitem =
8          SS of SymbolSet.set          PSS of SymbolSet.set
9        | S of Symbol.symbol        | PS of Symbol.symbol
10        | SI of SmlInfo.info              (* only used during pickling *)        | PSN of DG.snode
11        | AP of AbsPath.t        | PAP of AbsPath.t
12        | BI of BinInfo.info              (* only used during unpickling *)  
13        datatype uitem =
14      fun compare (S s, S s') = SymbolOrdKey.compare (s, s')          USS of SymbolSet.set
15        | compare (S _, _) = GREATER        | US of Symbol.symbol
16        | compare (_, S _) = LESS        | UBN of DG.bnode
17        | compare (SS s, SS s') = SymbolSet.compare (s, s')        | UAP of AbsPath.t
18        | compare (SS _, _) = GREATER  
19        | compare (_, SS _) = LESS      fun compare (PS s, PS s') = SymbolOrdKey.compare (s, s')
20        | compare (SI i, SI i') = SmlInfo.compare (i, i')        | compare (PS _, _) = GREATER
21        | compare (SI _, _) = GREATER        | compare (_, PS _) = LESS
22        | compare (_, SI _) = LESS        | compare (PSS s, PSS s') = SymbolSet.compare (s, s')
23        | compare (AP p, AP p') = AbsPath.compare (p, p')        | compare (PSS _, _) = GREATER
24        | compare (AP _, _) = GREATER        | compare (_, PSS _) = LESS
25        | compare (_, AP _) = LESS        | compare (PSN (DG.SNODE n), PSN (DG.SNODE n')) =
26        | compare (BI i, BI i') = BinInfo.compare (i, i')          SmlInfo.compare (#smlinfo n, #smlinfo n')
27          | compare (PSN _, _) = GREATER
28          | compare (_, PSN _) = LESS
29          | compare (PAP p, PAP p') = AbsPath.compare (p, p')
30    
31      structure Map =      structure Map =
32          BinaryMapFn (struct          BinaryMapFn (struct
33                           type ord_key = item                           type ord_key = pitem
34                           val compare = compare                           val compare = compare
35          end)          end)
36    
# Line 49  Line 52 
52                   *    need no further adjustment.                   *    need no further adjustment.
53                   *  - Individual binfile contents (concatenated).                   *  - Individual binfile contents (concatenated).
54                   *)                   *)
                 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  
55    
56                  fun w_list w_item [] k m = "0" :: k m                  val offsetDict = ref SmlInfoMap.empty
57                    | w_list w_item [a] k m = "1" :: w_item a k m                  val members = ref []
58                    | w_list w_item [a, b] k m = "2" :: w_item a (w_item b k) m                  val registerOffset = let
59                        val cur = ref 0
60                        fun reg (i, sz) = let
61                            val os = !cur
62                        in
63                            cur := os + sz;
64                            offsetDict := SmlInfoMap.insert (!offsetDict, i, os);
65                            members := i :: (!members);
66                            os
67                        end
68                    in
69                        reg
70                    end
71    
72                    fun w_list w_item [] k m =
73                        "0" :: k m
74                      | w_list w_item [a] k m =
75                        "1" :: w_item a k m
76                      | w_list w_item [a, b] k m =
77                        "2" :: w_item a (w_item b k) m
78                    | w_list w_item [a, b, c] k m =                    | w_list w_item [a, b, c] k m =
79                      "3" :: w_item a (w_item b (w_item c k)) m                      "3" :: w_item a (w_item b (w_item c k)) m
80                    | w_list w_item [a, b, c, d] k m =                    | w_list w_item [a, b, c, d] k m =
# Line 115  Line 120 
120                      ns :: Symbol.name s :: "." :: k m                      ns :: Symbol.name s :: "." :: k m
121                  end                  end
122    
123                  val w_symbol = w_share w_symbol_raw S                  val w_symbol = w_share w_symbol_raw PS
124    
125                  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
126    
127                  val w_filter = w_option w_ss                  val w_filter = w_option w_ss
128    
# Line 134  Line 139 
139                    | w_sharing (SOME true) k m = "t" :: k m                    | w_sharing (SOME true) k m = "t" :: k m
140                    | w_sharing (SOME false) k m = "f" :: k m                    | w_sharing (SOME false) k m = "f" :: k m
141    
142                  fun w_si_raw i k = let                  fun w_si i k = let
143                      val spec = AbsPath.spec (SmlInfo.sourcepath i)                      val spec = AbsPath.spec (SmlInfo.sourcepath i)
144                      val locs = SmlInfo.errorLocation gp i                      val locs = SmlInfo.errorLocation gp i
145                      val offset = valOf (SmlInfoMap.find (offsetDict, i))                      val offset = registerOffset (i, binSizeOf i)
146                  in                  in
147                      w_string spec                      w_string spec
148                          (w_string locs                          (w_string locs
# Line 145  Line 150 
150                                   (w_sharing (SmlInfo.share i) k)))                                   (w_sharing (SmlInfo.share i) k)))
151                  end                  end
152    
                 val w_si = w_share w_si_raw SI  
   
153                  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
154    
155                  fun w_abspath_raw p k m =                  fun w_abspath_raw p k m =
156                      w_list w_string (AbsPath.pickle p) k m                      w_list w_string (AbsPath.pickle p) k m
157    
158                  val w_abspath = w_share w_abspath_raw AP                  val w_abspath = w_share w_abspath_raw PAP
159    
160                  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
161                    | w_bn (DG.BNODE { bininfo = i, ... }) k m =                    | w_bn (DG.BNODE { bininfo = i, ... }) k m =
162                      "b" :: w_abspath (BinInfo.group i)                      "b" :: w_abspath (BinInfo.group i)
163                                (w_int (BinInfo.offset i) k) m                                (w_int (BinInfo.offset i) k) m
164    
165                  fun w_sn (DG.SNODE n) k =                  fun w_sn_raw (DG.SNODE n) k =
166                      w_si (#smlinfo n)                      w_si (#smlinfo n)
167                          (w_list w_sn (#localimports n)                          (w_list w_sn (#localimports n)
168                                (w_list w_fsbn (#globalimports n) k))                                (w_list w_fsbn (#globalimports n) k))
169    
170                    and w_sn n = w_share w_sn_raw PSN n
171    
172                  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
173                    | 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
174    
# Line 197  Line 202 
202                  Dummy.f ()                  Dummy.f ()
203              end              end
204    
205      fun g (getGroup, fsbn2env, knownStable, grpSrcInfo, group, s) = let      fun g (getGroup, bn2env, grpSrcInfo, group, s) = let
206    
207          exception Format          exception Format
208    
# Line 205  Line 210 
210          val m = ref IntBinaryMap.empty          val m = ref IntBinaryMap.empty
211          val next = ref 0          val next = ref 0
212    
         (* to build the stable info *)  
         val simap = ref IntBinaryMap.empty  
   
213          fun bytesIn n = let          fun bytesIn n = let
214              val bv = BinIO.inputN (s, n)              val bv = BinIO.inputN (s, n)
215          in          in
# Line 295  Line 297 
297                  case AbsPath.unpickle (r_list r_string ()) of                  case AbsPath.unpickle (r_list r_string ()) of
298                      SOME p => p                      SOME p => p
299                    | NONE => raise Format                    | NONE => raise Format
300              fun unAP (AP x) = x              fun unUAP (UAP x) = x
301                | unAP _ = raise Format                | unUAP _ = raise Format
302          in          in
303              r_share r_abspath_raw AP unAP              r_share r_abspath_raw UAP unUAP
304          end          end
305    
306          val r_symbol = let          val r_symbol = let
# Line 314  Line 316 
316              in              in
317                  ns (loop (first, []))                  ns (loop (first, []))
318              end              end
319              fun unS (S x) = x              fun unUS (US x) = x
320                | unS _ = raise Format                | unUS _ = raise Format
321          in          in
322              r_share r_symbol_raw S unS              r_share r_symbol_raw US unUS
323          end          end
324    
325          val r_ss = let          val r_ss = let
326              fun r_ss_raw () =              fun r_ss_raw () =
327                  SymbolSet.addList (SymbolSet.empty, r_list r_symbol ())                  SymbolSet.addList (SymbolSet.empty, r_list r_symbol ())
328              fun unSS (SS s) = s              fun unUSS (USS s) = s
329                | unSS _ = raise Format                | unUSS _ = raise Format
330          in          in
331              r_share r_ss_raw SS unSS              r_share r_ss_raw USS unUSS
332          end          end
333    
334          val r_filter = r_option r_ss          val r_filter = r_option r_ss
# Line 343  Line 345 
345                | #"f" => SOME false                | #"f" => SOME false
346                | _ => raise Format                | _ => raise Format
347    
348          val r_si = let          fun r_si () = let
             fun r_si_raw () = let  
349                  val spec = r_string ()                  val spec = r_string ()
350                  val locs = r_string ()                  val locs = r_string ()
351                  val offset = r_int () + offset_adjustment                  val offset = r_int () + offset_adjustment
352                  val share = r_sharing ()                  val share = r_sharing ()
353                  val error = EM.errorNoSource grpSrcInfo locs                  val error = EM.errorNoSource grpSrcInfo locs
354                  val i = BinInfo.new { group = group,          in
355                BinInfo.new { group = group,
356                                        error = error,                                        error = error,
357                                        spec = spec,                                        spec = spec,
358                                        offset = offset,                                        offset = offset,
359                                        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  
360          end          end
361    
362          fun r_bn () =          fun r_bn () =
363              case rd () of              case rd () of
364                  #"p" => DG.PNODE (r_primitive ())                  #"p" => DG.PNODE (r_primitive ())
365                | #"b" =>                | #"b" => let
366                      (case AbsPathMap.find (knownStable, r_abspath ()) of                      val p = r_abspath ()
367                        val os = r_int ()
368                        val GG.GROUP { stableinfo, ... } = getGroup p
369                    in
370                        case stableinfo of
371                            GG.NONSTABLE _ => raise Format
372                          | GG.STABLE im =>
373                                (case IntBinaryMap.find (im, os) of
374                           NONE => raise Format                           NONE => raise Format
375                         | SOME im =>                                 | SOME n => n)
376                               (case IntBinaryMap.find (im, r_int ()) of                  end
                                   NONE => raise Format  
                                 | SOME n => n))  
377                | _ => raise Format                | _ => raise Format
378    
379          (* this is the place where what used to be an          (* this is the place where what used to be an
380           * SNODE changes to a BNODE! *)           * SNODE changes to a BNODE! *)
381          fun r_sn () =          fun r_sn_raw () =
382              DG.BNODE { bininfo = r_si (),              DG.BNODE { bininfo = r_si (),
383                         localimports = r_list r_sn (),                         localimports = r_list r_sn (),
384                         globalimports = r_list r_fsbn () }                         globalimports = r_list r_fsbn () }
385    
386            and r_sn () =
387                r_share r_sn_raw UBN (fn (UBN n) => n | _ => raise Format) ()
388    
389          (* this one changes from farsbnode to plain farbnode *)          (* this one changes from farsbnode to plain farbnode *)
390          and r_sbn () =          and r_sbn () =
391              case rd () of              case rd () of
# Line 396  Line 398 
398          fun r_impexp () = let          fun r_impexp () = let
399              val sy = r_symbol ()              val sy = r_symbol ()
400              val (f, n) = r_fsbn ()      (* really reads farbnodes! *)              val (f, n) = r_fsbn ()      (* really reads farbnodes! *)
401              val e = fsbn2env n              val e = bn2env n
402          in          in
403              (sy, ((f, DG.SB_BNODE n), e)) (* coerce to farsbnodes *)              (sy, ((f, DG.SB_BNODE n), e)) (* coerce to farsbnodes *)
404          end          end
# Line 413  Line 415 
415              val required = r_privileges ()              val required = r_privileges ()
416              val grouppath = r_abspath ()              val grouppath = r_abspath ()
417              val subgroups = r_list (getGroup o r_abspath) ()              val subgroups = r_list (getGroup o r_abspath) ()
418              fun add (((_, DG.SB_BNODE (DG.BNODE { bininfo, ... })), _), s) =              (* find all the exported bnodes that are in the same group: *)
419                  IntBinarySet.add (s, BinInfo.offset bininfo)              fun add (((_, DG.SB_BNODE (n as DG.BNODE b)), _), m) = let
420                | add (_, s) = s                      val i = #bininfo b
421              val ens = SymbolMap.foldl add IntBinarySet.empty exports                  in
422              fun isExported (os, _) = IntBinarySet.member (ens, os)                      if AbsPath.compare (BinInfo.group i, group) = EQUAL then
423              val final_simap = IntBinaryMap.filteri isExported (!simap)                          IntBinaryMap.insert (m, BinInfo.offset i, n)
424                        else m
425                    end
426                  | add (_, m) = m
427                val simap = SymbolMap.foldl add IntBinaryMap.empty exports
428          in          in
429              GG.GROUP { exports = exports,              GG.GROUP { exports = exports,
430                         islib = islib,                         islib = islib,
431                         required = required,                         required = required,
432                         grouppath = grouppath,                         grouppath = grouppath,
433                         subgroups = subgroups,                         subgroups = subgroups,
434                         stableinfo = GG.STABLE final_simap }                         stableinfo = GG.STABLE simap }
435          end          end
436      in      in
437          SOME (unpickle_group ()) handle Format => NONE          SOME (unpickle_group ()) handle Format => NONE

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

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