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 568, Tue Mar 7 03:59:09 2000 UTC revision 569, Tue Mar 7 04:01:07 2000 UTC
# Line 21  Line 21 
21    
22  signature STABILIZE = sig  signature STABILIZE = sig
23    
24        val libStampIsValid : GP.info ->
25            SrcPath.t * DG.sbnode list * GG.subgrouplist -> bool
26    
27      val loadStable :      val loadStable :
28          GP.info -> { getGroup: SrcPath.t -> GG.group option,          GP.info -> { getGroup: SrcPath.t -> GG.group option,
29                       anyerrors: bool ref }                       anyerrors: bool ref }
# Line 53  Line 56 
56      structure PU = PickleUtil      structure PU = PickleUtil
57      structure UU = UnpickleUtil      structure UU = UnpickleUtil
58    
59        val libstamp_nbytes = 16
60    
61      type map = { ss: PU.id SSMap.map, sn: PU.id SNMap.map, pm: P.map }      type map = { ss: PU.id SSMap.map, sn: PU.id SNMap.map, pm: P.map }
62    
63      val emptyMap = { ss = SSMap.empty, sn = SNMap.empty, pm = P.emptyMap }      val emptyMap = { ss = SSMap.empty, sn = SNMap.empty, pm = P.emptyMap }
# Line 86  Line 91 
91              else raise UU.Format              else raise UU.Format
92          end          end
93    
94            val libstamp = bytesIn libstamp_nbytes  (* ignored *)
95          val dg_sz = LargeWord.toIntX (Pack32Big.subVec (bytesIn 4, 0))          val dg_sz = LargeWord.toIntX (Pack32Big.subVec (bytesIn 4, 0))
96          val dg_pickle = Byte.bytesToString (bytesIn dg_sz)          val dg_pickle = Byte.bytesToString (bytesIn dg_sz)
97      in      in
# Line 98  Line 104 
104                           work = #pickle o fetch_pickle,                           work = #pickle o fetch_pickle,
105                           cleanup = fn _ => () }                           cleanup = fn _ => () }
106    
107        fun mkInverseMap sublibs = let
108            (* Here we build a mapping that maps each BNODE to the path
109             * representing the sub-library that it came from and a
110             * representative symbol that can be used to find the BNODE
111             * within the exports of that library.
112             * It is not enough to just use the BNODE's group path
113             * because that group might not actually be in our list
114             * of sublibs.  Instead, it could be defined in a library
115             * component (subgroup) or in another library and just
116             * be "passed through". *)
117            fun oneB p (sy, ((_, DG.SB_BNODE (DG.BNODE n, _)), _), m) =
118                StableMap.insert (m, #bininfo n, (p, sy))
119              | oneB _ (_, _, m) = m
120            fun oneSL ((p, g as GG.GROUP { exports, ... }), m) =
121                SymbolMap.foldli (oneB p) m exports
122            val im = foldl oneSL StableMap.empty sublibs
123            fun look i =
124                case StableMap.find (im, i) of
125                    SOME p => p
126                  | NONE => EM.impossible "stabilize: bad inverse map"
127        in
128            look
129        end
130    
131        (* A stamp for a library is created by "pickling" the dependency graph
132         * of the library in a cursory fashion, thereby recording the ii pids
133         * of external references.  The so-created pickle string is never used
134         * for unpickling.  Instead, it is hashed and recorded as part of
135         * the regular library file.  In paranoia mode CM checks if the recorded
136         * hash is identical to the one that _would_ be created if one were
137         * to re-build the library now. *)
138        fun libStampOf (grouppath, export_nodes, sublibs) = let
139            val inverseMap = mkInverseMap sublibs
140    
141            val pid = PickleSymPid.w_pid
142            val share = PU.ah_share
143            val symbol = PickleSymPid.w_symbol
144            val string = PU.w_string
145            val list = PU.w_list
146    
147            fun abspath p = let
148                val op $ = PU.$ AP
149                val l = SrcPath.pickle (fn _ => ()) (p, grouppath)
150            in
151                "p" $ [list string l]
152            end
153    
154            fun sn n = let
155                val op $ = PU.$ SN
156                fun raw_sn (DG.SNODE n) =
157                    "a" $ [list sn (#localimports n), list fsbn (#globalimports n)]
158            in
159                share SNs raw_sn n
160            end
161    
162            and sbn x = let
163                val op $ = PU.$ SBN
164            in
165                case x of
166                    DG.SB_BNODE (DG.BNODE { bininfo = i, ... }, ii) => let
167                        val (p, sy) = inverseMap i
168                        val { statpid, sympid, ... } = ii
169                    in
170                        "2" $ [abspath p, symbol sy, pid statpid, pid sympid]
171                    end
172                  | DG.SB_SNODE n => "3" $ [sn n]
173            end
174    
175            and fsbn (_, n) = let val op $ = PU.$ FSBN in "f" $ [sbn n] end
176    
177            fun group () = let
178                val op $ = PU.$ G
179            in "g" $ [list sbn export_nodes]
180            end
181        in
182            P.pickle2hash (Byte.stringToBytes (PU.pickle emptyMap (group ())))
183        end
184    
185        (* Comparison of old and new library stamps. *)
186        fun libStampIsValid (gp: GP.info) (a as (grouppath, _, _)) = let
187            val newStamp = Byte.bytesToString (Pid.toBytes (libStampOf a))
188            val policy = #fnpolicy (#param gp)
189            val sname = FilenamePolicy.mkStableName policy grouppath
190            fun work s = let
191                val oldStamp =
192                    Byte.bytesToString (BinIO.inputN (s, libstamp_nbytes))
193            in
194                oldStamp = newStamp
195            end
196        in
197            SafeIO.perform { openIt = fn () => BinIO.openIn sname,
198                             closeIt = BinIO.closeIn,
199                             work = work,
200                             cleanup = fn _ => () }
201            handle _ => false
202        end
203    
204      fun loadStable gp { getGroup, anyerrors } group = let      fun loadStable gp { getGroup, anyerrors } group = let
205    
206          val errcons = #errcons (gp: GeneralParams.info)          val errcons = #errcons (gp: GeneralParams.info)
# Line 123  Line 226 
226                               raise Format)                               raise Format)
227    
228              val { size = dg_sz, pickle = dg_pickle } = fetch_pickle s              val { size = dg_sz, pickle = dg_pickle } = fetch_pickle s
229              val offset_adjustment = dg_sz + 4              val offset_adjustment = dg_sz + 4 + libstamp_nbytes
230              val { getter, dropper } =              val { getter, dropper } =
231                  UU.stringGetter' (SOME dg_pickle, mkPickleFetcher mksname)                  UU.stringGetter' (SOME dg_pickle, mkPickleFetcher mksname)
232              val session = UU.mkSession getter              val session = UU.mkSession getter
233    
234              val sgListM = UU.mkMap ()              val sgListM = UU.mkMap ()
             val stringListM = UU.mkMap ()  
             val stringListM = UU.mkMap ()  
235              val ssM = UU.mkMap ()              val ssM = UU.mkMap ()
236              val ssoM = UU.mkMap ()              val ssoM = UU.mkMap ()
237              val boolOptionM = UU.mkMap ()              val boolOptionM = UU.mkMap ()
# Line 147  Line 248 
248              val exportsM = UU.mkMap ()              val exportsM = UU.mkMap ()
249              val privilegesM = UU.mkMap ()              val privilegesM = UU.mkMap ()
250              val poM = UU.mkMap ()              val poM = UU.mkMap ()
251                val stringListM = UU.mkMap ()
252    
253              fun list m r = UU.r_list session m r              fun list m r = UU.r_list session m r
254              val string = UU.r_string session              val string = UU.r_string session
# Line 160  Line 262 
262              val bool = UU.r_bool session              val bool = UU.r_bool session
263              val pid = UnpickleSymPid.r_pid (session, string)              val pid = UnpickleSymPid.r_pid (session, string)
264    
265              fun abspath () = let              fun list2path sl =
266                  fun ap #"p" =                  SrcPath.unpickle pcmode (sl, group)
                     (SrcPath.unpickle pcmode (stringlist (), group)  
267                       handle SrcPath.Format => raise Format                       handle SrcPath.Format => raise Format
268                            | SrcPath.BadAnchor a =>                            | SrcPath.BadAnchor a =>
269                           (error ["configuration anchor \"", a, "\" undefined"];                           (error ["configuration anchor \"", a, "\" undefined"];
270                            raise Format))                          raise Format)
271    
272                fun abspath () = let
273                    fun ap #"p" = list2path (stringlist ())
274                    | ap _ = raise Format                    | ap _ = raise Format
275              in              in
276                  share apM ap                  share apM ap
# Line 180  Line 284 
284    
285              fun gr #"g" =              fun gr #"g" =
286                  let val sublibs = list sgListM sg ()                  let val sublibs = list sgListM sg ()
287                        val sublibm =
288                            foldl SrcPathMap.insert' SrcPathMap.empty sublibs
289    
290                      (* Now that we have the list of sublibs, we can build the                      (* Now that we have the list of sublibs, we can build the
291                       * environment for unpickling the environment list.                       * environment for unpickling the environment list.
292                       * We will need the environment list when unpickling the                       * We will need the environment list when unpickling the
293                       * export list (making SB_BNODES). *)                       * export list (making SB_BNODES). *)
294                      fun node_context (n, sy) = let                      fun node_context (sl, sy) = let
295                          val (_, GG.GROUP { exports = slexp, ... }) =                          val GG.GROUP { exports = slexp, ... } =
296                              List.nth (sublibs, n)                              valOf (SrcPathMap.find (sublibm, list2path sl))
297                      in                      in
298                          case SymbolMap.find (slexp, sy) of                          case SymbolMap.find (slexp, sy) of
299                              SOME ((_, DG.SB_BNODE (_, x)), _) =>                              SOME ((_, DG.SB_BNODE (_, x)), _) =>
# Line 198  Line 304 
304                      val { symenv, env, symbol, symbollist } =                      val { symenv, env, symbol, symbollist } =
305                          UP.mkUnpicklers session                          UP.mkUnpicklers session
306                             { node_context = node_context,                             { node_context = node_context,
307                               prim_context = E.primEnv }                               prim_context = E.primEnv,
308                                 stringlist = stringlist }
309    
310                      val lazy_symenv = UU.r_lazy session symenv                      val lazy_symenv = UU.r_lazy session symenv
311                      val lazy_env = UU.r_lazy session env                      val lazy_env = UU.r_lazy session env
# Line 263  Line 370 
370                      (* this one changes from farsbnode to plain farbnode *)                      (* this one changes from farsbnode to plain farbnode *)
371                      and sbn () = let                      and sbn () = let
372                          fun sbn' #"2" = let                          fun sbn' #"2" = let
373                                  val n = int ()                                  val p = abspath ()
374                                  val sy = symbol ()                                  val sy = symbol ()
375                                  val (_, GG.GROUP { exports = slexp, ... }) =                                  val GG.GROUP { exports = slexp, ... } =
376                                      List.nth (sublibs, n)                                      valOf (SrcPathMap.find (sublibm, p))
377                                      handle _ => raise Format                                      handle _ => raise Format
378                              in                              in
379                                  case SymbolMap.find (slexp, sy) of                                  case SymbolMap.find (slexp, sy) of
# Line 327  Line 434 
434                          share exportsM e                          share exportsM e
435                      end                      end
436    
                     val stringlist = list stringListM string  
   
437                      fun privileges () = let                      fun privileges () = let
438                          fun p #"p" =                          fun p #"p" =
439                              StringSet.addList (StringSet.empty, stringlist ())                              StringSet.addList (StringSet.empty, stringlist ())
# Line 364  Line 469 
469    
470          val policy = #fnpolicy (#param gp)          val policy = #fnpolicy (#param gp)
471    
472            fun doit (wrapped, getBFC) = let
473    
474          val grouppath = #grouppath grec          val grouppath = #grouppath grec
475                val sublibs = #sublibs grec
476                val exports = #exports grec
477    
478          fun doit (wrapped, getBFC) = let              val libstamp =
479                    libStampOf (grouppath,
480                                map (#2 o #1) (SymbolMap.listItems exports),
481                                sublibs)
482    
483              fun writeBFC s i = BF.write { stream = s,              fun writeBFC s i = BF.write { stream = s,
484                                            content = getBFC i,                                            content = getBFC i,
# Line 386  Line 498 
498    
499              val grpSrcInfo = (#errcons gp, anyerrors)              val grpSrcInfo = (#errcons gp, anyerrors)
500    
             val exports = #exports grec  
501              val required = StringSet.difference (#required grec, wrapped)              val required = StringSet.difference (#required grec, wrapped)
             val sublibs = #sublibs grec  
502    
503              (* The format of a stable archive is the following:              (* The format of a stable archive is the following:
504               *  - It starts with the size s of the pickled dependency               *  - It starts with the size s of the pickled dependency
# Line 406  Line 516 
516               *    their static environments.               *    their static environments.
517               *)               *)
518    
519              (* Here we build a mapping that maps each BNODE to a number              val inverseMap = mkInverseMap sublibs
              * representing the sub-library that it came from and a  
              * representative symbol that can be used to find the BNODE  
              * within the exports of that library *)  
             fun oneB i (sy, ((_, DG.SB_BNODE (DG.BNODE n, _)), _), m) =  
                 StableMap.insert (m, #bininfo n, (i, sy))  
               | oneB i (_, _, m) = m  
             fun oneSL ((_, g as GG.GROUP { exports, ... }), (m, i)) =  
                 (SymbolMap.foldli (oneB i) m exports, i + 1)  
             val inverseMap = #1 (foldl oneSL (StableMap.empty, 0) sublibs)  
520    
521              val members = ref []              val members = ref []
522              val (registerOffset, getOffset) = let              val (registerOffset, getOffset) = let
# Line 434  Line 535 
535                  (reg, get)                  (reg, get)
536              end              end
537    
538                fun path2list p = let
539                    fun warn_relabs abs = let
540                        val relabs = if abs then "absolute" else "relative"
541                        fun ppb pps =
542                            (PP.add_newline pps;
543                             PP.add_string pps (SrcPath.descr p);
544                             PP.add_newline pps;
545                             PP.add_string pps
546         "(This means that in order to be able to use the result of stabilization";
547                             PP.add_newline pps;
548                             PP.add_string pps "the library must be in the same ";
549                             PP.add_string pps relabs;
550                             PP.add_string pps " location as it is now.)";
551                             PP.add_newline pps)
552                    in
553                        EM.errorNoFile (#errcons gp, anyerrors) SM.nullRegion
554                                       EM.WARN
555                                       (concat [SrcPath.descr grouppath,
556                                                ": library referred to by ",
557                                                relabs, " pathname:"])
558                                       ppb
559                    end
560                in
561                    SrcPath.pickle warn_relabs (p, grouppath)
562                end
563    
564              (* Collect all BNODEs that we see and build              (* Collect all BNODEs that we see and build
565               * a context suitable for P.envPickler. *)               * a context suitable for P.envPickler. *)
566              fun mkContext () = let              fun mkContext () = let
# Line 444  Line 571 
571                      case n of                      case n of
572                          DG.SB_BNODE (DG.BNODE { bininfo = i, ... }, ii) => let                          DG.SB_BNODE (DG.BNODE { bininfo = i, ... }, ii) => let
573                              val { statenv, ... } = ii                              val { statenv, ... } = ii
574                              val nsy = valOf (StableMap.find (inverseMap, i))                              val (p, sy) = inverseMap i
575                                val pl = path2list p
576                              val bnodes' =                              val bnodes' =
577                                  StableMap.insert (bnodes, i,                                  StableMap.insert (bnodes, i,
578                                                    (nsy, #env o statenv))                                                    ((pl, sy), #env o statenv))
579                          in                          in
580                              k (bnodes', snodes)                              k (bnodes', snodes)
581                          end                          end
# Line 553  Line 681 
681                         option pid rts_pid, shm sh_mode]                         option pid rts_pid, shm sh_mode]
682              end              end
683    
             fun warn_relabs p abs = let  
                 val relabs = if abs then "absolute" else "relative"  
                 fun ppb pps =  
                     (PP.add_newline pps;  
                      PP.add_string pps (SrcPath.descr p);  
                      PP.add_newline pps;  
                      PP.add_string pps  
     "(This means that in order to be able to use the result of stabilization";  
                      PP.add_newline pps;  
                      PP.add_string pps "the library must be in the same ";  
                      PP.add_string pps relabs;  
                      PP.add_string pps " location as it is now.)";  
                      PP.add_newline pps)  
             in  
                 EM.errorNoFile (#errcons gp, anyerrors) SM.nullRegion  
                     EM.WARN  
                     (concat [SrcPath.descr grouppath,  
                              ": library referred to by ", relabs,  
                              " pathname:"])  
                     ppb  
             end  
   
684              fun abspath p = let              fun abspath p = let
685                  val op $ = PU.$ AP                  val op $ = PU.$ AP
                 val pp = SrcPath.pickle (warn_relabs p) (p, grouppath)  
686              in              in
687                  "p" $ [list string pp]                  "p" $ [list string (path2list p)]
688              end              end
689    
690              fun sn n = let              fun sn n = let
# Line 598  Line 703 
703              in              in
704                  case x of                  case x of
705                      DG.SB_BNODE (DG.BNODE { bininfo = i, ... }, _) => let                      DG.SB_BNODE (DG.BNODE { bininfo = i, ... }, _) => let
706                          val (n, sy) = valOf (StableMap.find (inverseMap, i))                          val (p, sy) = inverseMap i
707                      in                      in
708                          "2" $ [int n, symbol sy]                          "2" $ [abspath p, symbol sy]
709                      end                      end
710                    | DG.SB_SNODE n => "3" $ [sn n]                    | DG.SB_SNODE n => "3" $ [sn n]
711              end              end
# Line 647  Line 752 
752              in              in
753                  (* Pickle the sublibs first because we need to already                  (* Pickle the sublibs first because we need to already
754                   * have them back when we unpickle BNODEs. *)                   * have them back when we unpickle BNODEs. *)
755                  "g" $ [list sg sublibs, w_exports exports, privileges required]                  "g" $ [list sg sublibs,
756                           w_exports exports,
757                           privileges required]
758              end              end
759    
760              val dg_pickle =              val dg_pickle =
# Line 655  Line 762 
762    
763              val dg_sz = Word8Vector.length dg_pickle              val dg_sz = Word8Vector.length dg_pickle
764    
765              val offset_adjustment = dg_sz + 4              val offset_adjustment = dg_sz + 4 + libstamp_nbytes
766    
767              (* We could generate the graph for a stable group here directly              (* We could generate the graph for a stable group here directly
768               * by transcribing the original graph.  However, it is cumbersome               * by transcribing the original graph.  However, it is cumbersome
# Line 683  Line 790 
790              val memberlist = rev (!members)              val memberlist = rev (!members)
791    
792              fun mksname () = FilenamePolicy.mkStableName policy grouppath              fun mksname () = FilenamePolicy.mkStableName policy grouppath
793                val libstamp_bytes = Pid.toBytes libstamp
794                val _ =
795                    if Word8Vector.length libstamp_bytes <> libstamp_nbytes then
796                        EM.impossible "stabilize: libstamp size wrong"
797                    else ()
798              fun work outs =              fun work outs =
799                  (writeInt32 (outs, dg_sz);                  (BinIO.output (outs, libstamp_bytes);
800                     writeInt32 (outs, dg_sz);
801                   BinIO.output (outs, dg_pickle);                   BinIO.output (outs, dg_pickle);
802                   app (writeBFC outs) memberlist)                   app (writeBFC outs) memberlist)
803          in          in

Legend:
Removed from v.568  
changed lines
  Added in v.569

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