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 329, Fri Jun 11 09:53:10 1999 UTC revision 330, Sat Jun 12 07:45:52 1999 UTC
# Line 36  Line 36 
36          PSS of SymbolSet.set          PSS of SymbolSet.set
37        | PS of Symbol.symbol        | PS of Symbol.symbol
38        | PSN of DG.snode        | PSN of DG.snode
       | PAP of AbsPath.t  
39    
40      datatype uitem =      datatype uitem =
41          USS of SymbolSet.set          USS of SymbolSet.set
42        | US of Symbol.symbol        | US of Symbol.symbol
43        | UBN of DG.bnode        | UBN of DG.bnode
       | UAP of AbsPath.t  
44    
45      fun compare (PS s, PS s') = SymbolOrdKey.compare (s, s')      fun compare (PS s, PS s') = SymbolOrdKey.compare (s, s')
46        | compare (PS _, _) = GREATER        | compare (PS _, _) = GREATER
# Line 52  Line 50 
50        | compare (_, PSS _) = LESS        | compare (_, PSS _) = LESS
51        | compare (PSN (DG.SNODE n), PSN (DG.SNODE n')) =        | compare (PSN (DG.SNODE n), PSN (DG.SNODE n')) =
52          SmlInfo.compare (#smlinfo n, #smlinfo n')          SmlInfo.compare (#smlinfo n, #smlinfo n')
       | compare (PSN _, _) = GREATER  
       | compare (_, PSN _) = LESS  
       | compare (PAP p, PAP p') = AbsPath.compare (p, p')  
53    
54      structure Map =      structure Map =
55          BinaryMapFn (struct          BinaryMapFn (struct
# Line 127  Line 122 
122               *  - Individual binfile contents (concatenated).               *  - Individual binfile contents (concatenated).
123               *)               *)
124    
125                (* Here we build an inverse map that records for each
126                 * imported bnode a representative symbol.
127                 * This is used for pickling BNODEs -- they get represented
128                 * by a symbol that they export. This avoids having to
129                 * pickle a filename in the case of BNODEs. *)
130                fun oneB (sy, ((_, DG.SB_BNODE (DG.BNODE n)), _), m) =
131                    StableMap.insert (m, #bininfo n, sy)
132                  | oneB (_, _, m) = m
133                fun oneSG ((_, GG.GROUP { exports, ... }), m) =
134                    SymbolMap.foldli oneB m exports
135                val inverseMap = foldl oneSG StableMap.empty subgroups
136    
137              val members = ref []              val members = ref []
138              val (registerOffset, getOffset) = let              val (registerOffset, getOffset) = let
139                  val dict = ref SmlInfoMap.empty                  val dict = ref SmlInfoMap.empty
# Line 227  Line 234 
234              fun w_primitive p k m =              fun w_primitive p k m =
235                  String.str (Primitive.toIdent primconf p) :: k m                  String.str (Primitive.toIdent primconf p) :: k m
236    
237              fun w_abspath_raw p k m = w_list w_string (AbsPath.pickle p) k m              fun warn_nonanchor s = let
238                    val relabs =
239                        if OS.Path.isRelative s then "relative" else "absolute"
240                    fun ppb pps =
241                        (PP.add_newline pps;
242                         PP.add_string pps ("subgroup: " ^ s);
243                         PP.add_newline pps;
244                         PP.add_string pps
245        "(This means that in order to be able to use the result of stabilization";
246                         PP.add_newline pps;
247                         PP.add_string pps "the subgroups must be in the same ";
248                         PP.add_string pps relabs;
249                         PP.add_string pps " location as it is now.)";
250                         PP.add_newline pps)
251                in
252                    EM.errorNoFile (#errcons gp, anyerrors) SM.nullRegion
253                        EM.WARN
254                        (concat [AbsPath.name (#grouppath grec),
255                                 ": subgroup referred to by ", relabs,
256                                 " pathname"])
257                        ppb
258                end
259    
260              val w_abspath = w_share w_abspath_raw PAP              fun w_abspath p k m =
261                    w_list w_string (AbsPath.pickle warn_nonanchor p) k m
262    
263              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
264                | w_bn (DG.BNODE { bininfo = i, ... }) k m =                | w_bn (DG.BNODE { bininfo = i, ... }) k m =
265                  "b" :: w_abspath (BinInfo.group i)                  "b" :: w_symbol (valOf (StableMap.find (inverseMap, i))) k m
                            (w_int (BinInfo.offset i) k) m  
266    
267              fun w_sn_raw (DG.SNODE n) k =              fun w_sn_raw (DG.SNODE n) k =
268                  w_si (#smlinfo n)                  w_si (#smlinfo n)
# Line 258  Line 286 
286              fun w_privileges p = w_list w_string (StringSet.listItems p)              fun w_privileges p = w_list w_string (StringSet.listItems p)
287    
288              fun pickle_group () = let              fun pickle_group () = let
289                  fun w_sg (GG.GROUP g) = w_abspath (#grouppath g)                  fun w_sg (p, _) = w_abspath p
290                  fun k0 m = []                  fun k0 m = []
291                  val m0 = (0, Map.empty)                  val m0 = (0, Map.empty)
292              in              in
293                  concat (w_exports exports                  (* Pickle the subgroups first because we need to already
294                     * have them back when we unpickle BNODEs. *)
295                    concat (w_list w_sg subgroups
296                                (w_exports exports
297                               (w_bool islib                               (w_bool islib
298                                     (w_privileges required                                      (w_privileges required k0))) m0)
                                           (w_list w_sg subgroups k0))) m0)  
299              end              end
300    
301              val pickle = pickle_group ()              val pickle = pickle_group ()
# Line 353  Line 383 
383                  if not (recomp gp g) then                  if not (recomp gp g) then
384                      (anyerrors := true; NONE)                      (anyerrors := true; NONE)
385                  else let                  else let
386                      fun notStable (GG.GROUP { stableinfo, ... }) =                      fun notStable (_, GG.GROUP { stableinfo, ... }) =
387                          case stableinfo of                          case stableinfo of
388                              GG.STABLE _ => false                              GG.STABLE _ => false
389                            | GG.NONSTABLE _ => true                            | GG.NONSTABLE _ => true
# Line 364  Line 394 
394                              val grammar = case l of [_] => " is" | _ => "s are"                              val grammar = case l of [_] => " is" | _ => "s are"
395                              fun ppb pps = let                              fun ppb pps = let
396                                  fun loop [] = ()                                  fun loop [] = ()
397                                    | loop (GG.GROUP { grouppath, ... } :: t) =                                    | loop ((p, GG.GROUP { grouppath, ... })
398                                              :: t) =
399                                      (PP.add_string pps                                      (PP.add_string pps
400                                          (AbsPath.name grouppath);                                          (AbsPath.name grouppath);
401                                         PP.add_string pps " (";
402                                         PP.add_string pps (AbsPath.name p);
403                                         PP.add_string pps ")";
404                                       PP.add_newline pps;                                       PP.add_newline pps;
405                                       loop t)                                       loop t)
406                              in                              in
# Line 391  Line 425 
425    
426      fun loadStable (gp, getGroup, anyerrors) group = let      fun loadStable (gp, getGroup, anyerrors) group = let
427    
428            val context = AbsPath.relativeContext (AbsPath.dir group)
429          fun bn2env n = Statenv2DAEnv.cvtMemo (fn () => bn2statenv gp n)          fun bn2env n = Statenv2DAEnv.cvtMemo (fn () => bn2statenv gp n)
430    
431          val errcons = #errcons gp          val errcons = #errcons gp
# Line 501  Line 536 
536              loop []              loop []
537          end          end
538    
539          val r_abspath = let          fun r_abspath () =
540              fun r_abspath_raw () =              case AbsPath.unpickle pcmode (r_list r_string (), context) of
                 case AbsPath.unpickle pcmode (r_list r_string ()) of  
541                      SOME p => p                      SOME p => p
542                    | NONE => raise Format                    | NONE => raise Format
             fun unUAP (UAP x) = x  
               | unUAP _ = raise Format  
         in  
             r_share r_abspath_raw UAP unUAP  
         end  
543    
544          val r_symbol = let          val r_symbol = let
545              fun r_symbol_raw () = let              fun r_symbol_raw () = let
# Line 569  Line 598 
598                            share = share }                            share = share }
599          end          end
600    
601            fun r_sg () = let
602                val p = r_abspath ()
603            in
604                (p, getGroup' p)
605            end
606    
607            fun unpickle_group () = let
608    
609                val subgroups = r_list r_sg ()
610                fun oneSG ((_, GG.GROUP { exports, ... }), m) =
611                    SymbolMap.unionWith #1 (exports, m)
612                val forwardMap = foldl oneSG SymbolMap.empty subgroups
613    
614          fun r_bn () =          fun r_bn () =
615              case rd () of              case rd () of
616                  #"p" => DG.PNODE (r_primitive ())                  #"p" => DG.PNODE (r_primitive ())
617                | #"b" => let                | #"b" => let
618                      val p = r_abspath ()                          val sy = r_symbol ()
                     val os = r_int ()  
619                  in                  in
620                      case getGroup' p of                          case SymbolMap.find (forwardMap, sy) of
621                          GG.GROUP { stableinfo = GG.STABLE im, ... } =>                              SOME ((_, DG.SB_BNODE (n as DG.BNODE _)), _) => n
                             (case IntBinaryMap.find (im, os) of  
                                  NONE => raise Format  
                                | SOME n => n)  
622                        | _ => raise Format                        | _ => raise Format
623                  end                  end
624                | _ => raise Format                | _ => raise Format
# Line 621  Line 659 
659          fun r_privileges () =          fun r_privileges () =
660              StringSet.addList (StringSet.empty, r_list r_string ())              StringSet.addList (StringSet.empty, r_list r_string ())
661    
         fun unpickle_group () = let  
662              val exports = r_exports ()              val exports = r_exports ()
663              val islib = r_bool ()              val islib = r_bool ()
664              val required = r_privileges ()              val required = r_privileges ()
             val subgroups = r_list (getGroup' o r_abspath) ()  
665              val simap = genStableInfoMap (exports, group)              val simap = genStableInfoMap (exports, group)
666          in          in
667              GG.GROUP { exports = exports,              GG.GROUP { exports = exports,

Legend:
Removed from v.329  
changed lines
  Added in v.330

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