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 314, Fri Jun 4 06:41:45 1999 UTC revision 403, Tue Aug 31 07:44:29 1999 UTC
# Line 13  Line 13 
13      structure SM = GenericVC.SourceMap      structure SM = GenericVC.SourceMap
14      structure GP = GeneralParams      structure GP = GeneralParams
15      structure E = GenericVC.Environment      structure E = GenericVC.Environment
16        structure Pid = GenericVC.PersStamps
17      type statenvgetter = GP.info -> DG.bnode -> E.staticEnv      structure P = PickMod
18      type recomp = GP.info -> GG.group -> bool      structure UP = UnpickMod
19        structure E = GenericVC.Environment
20  in  in
21    
22  signature STABILIZE = sig  signature STABILIZE = sig
23    
24      val loadStable :      val loadStable :
25          GP.info * (AbsPath.t -> GG.group option) * bool ref ->          GP.info -> { getGroup: SrcPath.t -> GG.group option,
26          AbsPath.t -> GG.group option                       anyerrors: bool ref }
27            -> SrcPath.t -> GG.group option
28    
29      val stabilize :      val stabilize :
30          GP.info -> { group: GG.group, anyerrors: bool ref } ->          GP.info -> { group: GG.group, anyerrors: bool ref } -> GG.group option
         GG.group option  
31  end  end
32    
33  functor StabilizeFn (val bn2statenv : statenvgetter  functor StabilizeFn (val destroy_state : GP.info -> SmlInfo.info -> unit
34                       val recomp: recomp) :> STABILIZE = struct                       structure MachDepVC : MACHDEP_VC
35                         val recomp : GP.info -> GG.group ->
36                             (SmlInfo.info -> MachDepVC.Binfile.bfContent) option
37                         val getII : SmlInfo.info -> IInfo.info) :> STABILIZE =
38    struct
39    
40        structure BF = MachDepVC.Binfile
41    
42        structure SSMap = BinaryMapFn
43            (struct
44                 type ord_key = SymbolSet.set
45                 val compare = SymbolSet.compare
46            end)
47    
48      datatype pitem =      structure SNMap = BinaryMapFn
49          PSS of SymbolSet.set          (struct
50        | PS of Symbol.symbol               type ord_key = DG.snode
51        | PSN of DG.snode               fun compare (DG.SNODE n, DG.SNODE n') =
       | PAP of AbsPath.t  
   
     datatype uitem =  
         USS of SymbolSet.set  
       | US of Symbol.symbol  
       | UBN of DG.bnode  
       | UAP of AbsPath.t  
   
     fun compare (PS s, PS s') = SymbolOrdKey.compare (s, s')  
       | compare (PS _, _) = GREATER  
       | compare (_, PS _) = LESS  
       | compare (PSS s, PSS s') = SymbolSet.compare (s, s')  
       | compare (PSS _, _) = GREATER  
       | compare (_, PSS _) = LESS  
       | 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')  
   
     structure Map =  
         BinaryMapFn (struct  
                          type ord_key = pitem  
                          val compare = compare  
53          end)          end)
54    
55      fun genStableInfoMap (exports, group) = let      structure PU = PickleUtil
56          (* find all the exported bnodes that are in the same group: *)      structure UU = UnpickleUtil
         fun add (((_, DG.SB_BNODE (n as DG.BNODE b)), _), m) = let  
             val i = #bininfo b  
         in  
             if AbsPath.compare (BinInfo.group i, group) = EQUAL then  
                 IntBinaryMap.insert (m, BinInfo.offset i, n)  
             else m  
         end  
           | add (_, m) = m  
     in  
         SymbolMap.foldl add IntBinaryMap.empty exports  
     end  
57    
58      fun deleteFile n = OS.FileSys.remove n      type map = { ss: PU.id SSMap.map, sn: PU.id SNMap.map, pm: P.map }
59          handle e as Interrupt.Interrupt => raise e  
60               | _ => ()      val emptyMap = { ss = SSMap.empty, sn = SNMap.empty, pm = P.emptyMap }
61    
62        val lifter =
63            { extract = fn (m: map) => #pm m,
64              patchback = fn (m: map, pm) => { ss = #ss m, sn = #sn m, pm = pm } }
65    
66        infix 3 $
67        infixr 4 &
68        val op & = PU.&
69        val % = PU.%
70    
71        (* type info *)
72        val (BN, SN, SBN, SS, SI, FSBN, IMPEXP, SHM) = (1, 2, 3, 4, 5, 6, 7, 8)
73    
74        val SSs =
75            { find = fn (m: map, k) => SSMap.find (#ss m, k),
76              insert = fn ({ ss, sn, pm }, k, v) =>
77                           { sn = sn, ss = SSMap.insert (ss, k, v), pm = pm } }
78        val SNs =
79            { find = fn (m: map, k) => SNMap.find (#sn m, k),
80              insert = fn ({ ss, sn, pm }, k, v) =>
81                           { ss = ss, sn = SNMap.insert (sn, k, v), pm = pm } }
82    
83      fun stabilize gp { group = g as GG.GROUP grec, anyerrors } = let      fun stabilize gp { group = g as GG.GROUP grec, anyerrors } = let
84    
85          fun doit granted = let          val primconf = #primconf (#param gp)
86            val policy = #fnpolicy (#param gp)
87            val pervasive = #pervasive (#param gp)
88    
89            val grouppath = #grouppath grec
90    
91            fun doit (wrapped, getBFC) = let
92    
93                fun writeBFC s i = BF.write { stream = s,
94                                              content = getBFC i,
95                                              nopickle = true }
96                fun sizeBFC i = BF.size { content = getBFC i, nopickle = true }
97    
98              val _ =              val _ =
99                  if StringSet.isEmpty granted then ()                  Say.vsay ["[stabilizing ", SrcPath.descr grouppath, "]\n"]
100    
101                val _ =
102                    if StringSet.isEmpty wrapped then ()
103                  else                  else
104                      Say.say ("$Stabilize: wrapping the following privileges:\n"                      Say.say ("$Stabilize: wrapping the following privileges:\n"
105                               :: map (fn s => ("  " ^ s ^ "\n"))                               :: map (fn s => ("  " ^ s ^ "\n"))
106                                      (StringSet.listItems granted))                                      (StringSet.listItems wrapped))
   
             val bname = AbsPath.name o SmlInfo.binpath  
             val bsz = OS.FileSys.fileSize o bname  
             fun cpb s i = let  
                 val ins = BinIO.openIn (bname i)  
                 fun cp () =  
                     if BinIO.endOfStream ins then ()  
                     else (BinIO.output (s, BinIO.input ins); cp ())  
             in  
                 cp () handle e => (BinIO.closeIn ins; raise e);  
                     BinIO.closeIn ins  
             end  
             val delb = deleteFile o bname  
107    
108              val grpSrcInfo = (#errcons gp, anyerrors)              val grpSrcInfo = (#errcons gp, anyerrors)
109    
110              val exports = #exports grec              val exports = #exports grec
111              val islib = #islib grec              val required = StringSet.difference (#required grec, wrapped)
112              val required = StringSet.difference (#required grec, granted)              val sublibs = #sublibs grec
             val grouppath = #grouppath grec  
             val subgroups = #subgroups grec  
113    
114              (* The format of a stable archive is the following:              (* The format of a stable archive is the following:
115               *  - It starts with the size s of the pickled dependency               *  - It starts with the size s of the pickled dependency
116               *    graph. This size itself is written as four-byte string.               *    graph. This size itself is written as four-byte string.
117                 *  - The size t of the pickled environment for the entire
118                 *    library (using the pickleEnvN interface of the pickler)
119                 *    in the same format as s.
120               *  - The pickled dependency graph.  This graph contains               *  - The pickled dependency graph.  This graph contains
121               *    integer offsets of the binfiles for the individual ML               *    integer offsets of the binfiles for the individual ML
122               *    members. These offsets need to be adjusted by adding               *    members. These offsets need to be adjusted by adding
123               *    s + 4. The pickled dependency graph also contains integer               *    s + t + 8. The pickled dependency graph also contains integer
124               *    offsets relative to other stable groups.  These offsets               *    offsets relative to other stable groups.  These offsets
125               *    need no further adjustment.               *    need no further adjustment.
126               *  - Individual binfile contents (concatenated).               *  - The pickled environment (list).  To be unpickled using
127                 *    unpickleEnvN.
128                 *  - Individual binfile contents (concatenated) but without
129                 *    their static environments.
130               *)               *)
131    
132                (* Here we build a mapping that maps each BNODE to a number
133                 * representing the sub-library that it came from and a
134                 * representative symbol that can be used to find the BNODE
135                 * within the exports of that library *)
136                fun oneB i (sy, ((_, DG.SB_BNODE (DG.BNODE n, _)), _), m) =
137                    StableMap.insert (m, #bininfo n, (i, sy))
138                  | oneB i (_, _, m) = m
139                fun oneSL ((g as GG.GROUP { exports, ... }), (m, i)) =
140                    (SymbolMap.foldli (oneB i) m exports, i + 1)
141                val inverseMap = #1 (foldl oneSL (StableMap.empty, 0) sublibs)
142    
143              val members = ref []              val members = ref []
144              val (registerOffset, getOffset) = let              val (registerOffset, getOffset) = let
145                  val dict = ref SmlInfoMap.empty                  val dict = ref SmlInfoMap.empty
# Line 141  Line 157 
157                  (reg, get)                  (reg, get)
158              end              end
159    
160              fun w_list w_item [] k m =              (* Collect all BNODEs and PNODEs that we see and build
161                  "0" :: k m               * a context suitable for P.envPickler. *)
162                | w_list w_item [a] k m =              fun mkContext () = let
163                  "1" :: w_item a k m                  fun lst f [] k s = k s
164                | w_list w_item [a, b] k m =                    | lst f (h :: t) k s = f h (lst f t k) s
165                  "2" :: w_item a (w_item b k) m  
166                | w_list w_item [a, b, c] k m =                  fun sbn n k (s as (prims, bnodes, snodes)) =
167                  "3" :: w_item a (w_item b (w_item c k)) m                      case n of
168                | w_list w_item [a, b, c, d] k m =                          DG.SB_BNODE (DG.PNODE p, { statenv, ... }) => let
169                  "4" :: w_item a (w_item b (w_item c (w_item d k))) m                              val str = String.str (Primitive.toIdent primconf p)
170                | w_list w_item (a :: b :: c :: d :: e :: r) k m =                              val prims' = StringMap.insert (prims, str, statenv)
171                  "5" :: w_item a (w_item b (w_item c (w_item d (w_item e                          in
172                                                       (w_list w_item r k))))) m                              k (prims', bnodes, snodes)
173                            end
174              fun w_option w_item NONE k m = "n" :: k m                        | DG.SB_BNODE (DG.BNODE { bininfo = i, ... }, ii) => let
175                | w_option w_item (SOME i) k m = "s" :: w_item i k m                              val { statenv, ... } = ii
176                                val nsy = valOf (StableMap.find (inverseMap, i))
177              fun int_encode i = let                              val bnodes' =
178                  (* this is the same mechanism that's also used in                                  StableMap.insert (bnodes, i, (nsy, statenv))
179                   * TopLevel/batch/binfile.sml (maybe we should share it) *)                          in
180                  val n = Word32.fromInt i                              k (prims, bnodes', snodes)
181                  val // = LargeWord.div                          end
182                  val %% = LargeWord.mod                        | DG.SB_SNODE n => sn n k s
183                  val !! = LargeWord.orb  
184                  infix // %% !!                  and sn (DG.SNODE n) k (prims, bnodes, snodes) = let
185                  val toW8 = Word8.fromLargeWord                      val i = #smlinfo n
186                  fun r (0w0, l) = Word8Vector.fromList l                      val li = #localimports n
187                    | r (n, l) =                      val gi = #globalimports n
188                      r (n // 0w128, toW8 ((n %% 0w128) !! 0w128) :: l)                  in
189              in                      if SmlInfoSet.member (snodes, i) then
190                  Byte.bytesToString (r (n // 0w128, [toW8 (n %% 0w128)]))                          k (prims, bnodes, snodes)
191              end                      else let
192                            val snodes' = SmlInfoSet.add (snodes, i)
             fun w_int i k m = int_encode i :: k m  
   
             fun w_share w C v k (i, m) =  
                 case Map.find (m, C v) of  
                     SOME i' => "o" :: w_int i' k (i, m)  
                   | NONE => "n" :: w v k (i + 1, Map.insert (m, C v, i))  
   
             fun w_symbol_raw s k m = let  
                 val ns = case Symbol.nameSpace s of  
                     Symbol.SIGspace => "'"  
                   | Symbol.FCTspace => "("  
                   | Symbol.FSIGspace => ")"  
                   | Symbol.STRspace => ""  
                   | _ => GenericVC.ErrorMsg.impossible "stabilize:w_symbol"  
             in  
                 ns :: Symbol.name s :: "." :: k m  
             end  
   
             val w_symbol = w_share w_symbol_raw PS  
   
             val w_ss = w_share (w_list w_symbol o SymbolSet.listItems) PSS  
   
             val w_filter = w_option w_ss  
   
             fun w_string s k m = let  
                 fun esc #"\\" = "\\\\"  
                   | esc #"\"" = "\\\""  
                   | esc c = String.str c  
             in  
                 String.translate esc s :: "\"" :: k m  
             end  
   
             fun w_sharing NONE k m = "n" :: k m  
               | w_sharing (SOME true) k m = "t" :: k m  
               | w_sharing (SOME false) k m = "f" :: k m  
   
             fun w_si i k = let  
                 val spec = AbsPath.spec (SmlInfo.sourcepath i)  
                 val locs = SmlInfo.errorLocation gp i  
                 val offset = registerOffset (i, bsz i)  
193              in              in
194                  w_string spec                          lst sn li (lst fsbn gi k) (prims, bnodes, snodes')
195                     (w_string locs                      end
                          (w_int offset  
                                (w_sharing (SmlInfo.share i) k)))  
196              end              end
197    
198              fun w_primitive p k m = String.str (Primitive.toIdent p) :: k m                  and fsbn (_, n) k s = sbn n k s
   
             fun w_abspath_raw p k m = w_list w_string (AbsPath.pickle p) k m  
199    
200              val w_abspath = w_share w_abspath_raw PAP                  fun impexp (n, _) k s = fsbn n k s
201    
202                    val (prims, bnodes) =
203                        lst impexp (SymbolMap.listItems exports)
204                            (fn (prims, bnodes, _) => (prims, bnodes))
205                            (StringMap.empty, StableMap.empty, SmlInfoSet.empty)
206    
207                    val priml = StringMap.listItemsi prims
208                    val bnodel = StableMap.listItems bnodes
209    
210                    fun cvt lk id = let
211                        fun nloop [] = NONE
212                          | nloop ((k, ge) :: t) =
213                            (case lk (ge ()) id of
214                                 SOME _ => SOME (P.NodeKey k)
215                               | NONE => nloop t)
216                        fun ploop [] = nloop bnodel
217                          | ploop ((k, ge) :: t) =
218                            (case lk (ge ()) id of
219                                 SOME _ => SOME (P.PrimKey k)
220                               | NONE => ploop t)
221                    in
222                        case lk (E.staticPart pervasive) id of
223                            NONE => ploop priml
224                          | SOME _ => SOME (P.PrimKey "pv")
225                    end
226                in
227                    { lookSTR = cvt GenericVC.CMStaticEnv.lookSTR,
228                      lookSIG = cvt GenericVC.CMStaticEnv.lookSIG,
229                      lookFCT = cvt GenericVC.CMStaticEnv.lookFCT,
230                      lookFSIG = cvt GenericVC.CMStaticEnv.lookFSIG,
231                      lookTYC = cvt GenericVC.CMStaticEnv.lookTYC,
232                      lookEENV = cvt GenericVC.CMStaticEnv.lookEENV }
233                end
234    
235                (* make the picklers for static and symbolic environments;
236                 * lift them so we can use them here... *)
237                val envContext = mkContext ()
238    
239                val env_orig = P.envPickler envContext
240                val env = PU.lift_pickler lifter env_orig
241                val symenv_orig = P.symenvPickler
242                val symenv = PU.lift_pickler lifter symenv_orig
243                val lazy_env = PU.w_lazy env
244                val lazy_symenv = PU.w_lazy symenv
245    
246                val int = PU.w_int
247                val symbol = PickleSymPid.w_symbol
248                val pid = PickleSymPid.w_pid
249                val share = PU.ah_share
250                val option = PU.w_option
251                val list = PU.w_list
252                val string = PU.w_string
253                val bool = PU.w_bool
254                val int = PU.w_int
255    
256                fun symbolset ss = let
257                    val op $ = PU.$ SS
258                    fun raw_ss ss = "s" $ list symbol (SymbolSet.listItems ss)
259                in
260                    share SSs raw_ss ss
261                end
262    
263                val filter = option symbolset
264    
265                fun shm (Sharing.SHARE true) = %SHM "a"
266                  | shm (Sharing.SHARE false) = %SHM "b"
267                  | shm Sharing.DONTSHARE = %SHM "c"
268    
269                fun si i = let
270                    (* FIXME: this is not a technical flaw, but perhaps one
271                     * that deserves fixing anyway:  If we only look at spec,
272                     * then we are losing information about sub-grouping
273                     * within libraries.  However, the spec in BinInfo.info
274                     * is only used for diagnostics and has no impact on the
275                     * operation of CM itself. *)
276                    val spec = SrcPath.specOf (SmlInfo.sourcepath i)
277                    val locs = SmlInfo.errorLocation gp i
278                    val offset = registerOffset (i, sizeBFC i)
279                    val sh_mode = SmlInfo.sh_mode i
280                    val op $ = PU.$ SI
281                in
282                    "s" $ string spec & string locs & int offset & shm sh_mode
283                end
284    
285              fun w_bn (DG.PNODE p) k m = "p" :: w_primitive p k m              fun primitive p =
286                | w_bn (DG.BNODE { bininfo = i, ... }) k m =                  string (String.str (Primitive.toIdent primconf p))
                 "b" :: w_abspath (BinInfo.group i)  
                            (w_int (BinInfo.offset i) k) m  
287    
288              fun w_sn_raw (DG.SNODE n) k =              fun warn_relabs p abs = let
289                  w_si (#smlinfo n)                  val relabs = if abs then "absolute" else "relative"
290                       (w_list w_sn (#localimports n)                  fun ppb pps =
291                               (w_list w_fsbn (#globalimports n) k))                      (PP.add_newline pps;
292                         PP.add_string pps (SrcPath.descr p);
293                         PP.add_newline pps;
294                         PP.add_string pps
295        "(This means that in order to be able to use the result of stabilization";
296                         PP.add_newline pps;
297                         PP.add_string pps "the library must be in the same ";
298                         PP.add_string pps relabs;
299                         PP.add_string pps " location as it is now.)";
300                         PP.add_newline pps)
301                in
302                    EM.errorNoFile (#errcons gp, anyerrors) SM.nullRegion
303                        EM.WARN
304                        (concat [SrcPath.descr grouppath,
305                                 ": library referred to by ", relabs,
306                                 " pathname:"])
307                        ppb
308                end
309    
310              and w_sn n = w_share w_sn_raw PSN n              fun abspath p = let
311                    val pp = SrcPath.pickle (warn_relabs p) (p, grouppath)
312                in
313                    list string pp
314                end
315    
316              and w_sbn (DG.SB_BNODE n) k m = "b" :: w_bn n k m              fun sn n = let
317                | w_sbn (DG.SB_SNODE n) k m = "s" :: w_sn n k m                  val op $ = PU.$ SN
318                    fun raw_sn (DG.SNODE n) =
319                        "a" $ si (#smlinfo n) & list sn (#localimports n) &
320                        list fsbn (#globalimports n)
321                in
322                    share SNs raw_sn n
323                end
324    
325              and w_fsbn (f, n) k = w_filter f (w_sbn n k)              (* Here we ignore the interface info because we will not
326                 * need it anymore when we unpickle. *)
327                and sbn x = let
328                    val op $ = PU.$ SBN
329                in
330                    case x of
331                        DG.SB_BNODE (DG.PNODE p, { statenv = getE, ... }) =>
332                            "1" $ primitive p
333                      | DG.SB_BNODE (DG.BNODE { bininfo = i, ... }, _) => let
334                            val (n, sy) = valOf (StableMap.find (inverseMap, i))
335                        in
336                            "2" $ int n & symbol sy
337                        end
338                      | DG.SB_SNODE n => "3" $ sn n
339                end
340    
341              fun w_impexp (s, (n, _)) k = w_symbol s (w_fsbn n k)              and fsbn (f, n) = let
342                    val op $ = PU.$ FSBN
343                in
344                    "f" $ filter f & sbn n
345                end
346    
347              fun w_exports e = w_list w_impexp (SymbolMap.listItemsi e)              (* Here is the place where we need to write interface info. *)
348                fun impexp (s, (n, _)) = let
349                    val op $ = PU.$ IMPEXP
350                    val { statenv, symenv, statpid, sympid } =
351                        case n of
352                            (_, DG.SB_BNODE (_, ii)) => ii
353                          | (_, DG.SB_SNODE (DG.SNODE { smlinfo, ... })) =>
354                                getII smlinfo
355                in
356                    "i" $ symbol s & fsbn n &
357                          lazy_env (GenericVC.CoerceEnv.es2bs o statenv) &
358                          lazy_symenv symenv &
359                          pid statpid &
360                          pid sympid
361                end
362    
363              fun w_bool true k m = "t" :: k m              fun w_exports e = list impexp (SymbolMap.listItemsi e)
               | w_bool false k m = "f" :: k m  
364    
365              fun w_privileges p = w_list w_string (StringSet.listItems p)              fun privileges p = list string (StringSet.listItems p)
366    
367              fun pickle_group () = let              fun group () = let
368                  fun w_sg (GG.GROUP g) = w_abspath (#grouppath g)                  fun sg (GG.GROUP { grouppath, ... }) = abspath grouppath
                 fun k0 m = []  
                 val m0 = (0, Map.empty)  
369              in              in
370                  concat (w_exports exports                  (* Pickle the sublibs first because we need to already
371                               (w_bool islib                   * have them back when we unpickle BNODEs. *)
372                                     (w_privileges required                  list sg sublibs & w_exports exports & privileges required
                                           (w_list w_sg subgroups k0))) m0)  
373              end              end
374    
375              val pickle = pickle_group ()              val dg_pickle =
376              val sz = size pickle                  Byte.stringToBytes (PU.pickle emptyMap (group ()))
377              val offset_adjustment = sz + 4  
378                val dg_sz = Word8Vector.length dg_pickle
379    
380                val offset_adjustment = dg_sz + 4
381    
382              fun mkStableGroup () = let              fun mkStableGroup mksname = let
383                  val m = ref SmlInfoMap.empty                  val m = ref SmlInfoMap.empty
384                  fun sn (DG.SNODE (n as { smlinfo, ... })) =                  fun sn (DG.SNODE (n as { smlinfo, ... })) =
385                      case SmlInfoMap.find (!m, smlinfo) of                      case SmlInfoMap.find (!m, smlinfo) of
# Line 277  Line 388 
388                              val li = map sn (#localimports n)                              val li = map sn (#localimports n)
389                              val gi = map fsbn (#globalimports n)                              val gi = map fsbn (#globalimports n)
390                              val sourcepath = SmlInfo.sourcepath smlinfo                              val sourcepath = SmlInfo.sourcepath smlinfo
391                              val spec = AbsPath.spec sourcepath                              (* FIXME: see the comment near the other
392                                 * occurence of SrcPath.spec... *)
393                                val spec = SrcPath.specOf sourcepath
394                              val offset =                              val offset =
395                                  getOffset smlinfo + offset_adjustment                                  getOffset smlinfo + offset_adjustment
396                              val share = SmlInfo.share smlinfo                              val sh_mode = SmlInfo.sh_mode smlinfo
397                              val locs = SmlInfo.errorLocation gp smlinfo                              val locs = SmlInfo.errorLocation gp smlinfo
398                              val error = EM.errorNoSource grpSrcInfo locs                              val error = EM.errorNoSource grpSrcInfo locs
399                              val i = BinInfo.new { group = grouppath,                              val i = BinInfo.new { group = grouppath,
400                                                      mkStablename = mksname,
401                                                    spec = spec,                                                    spec = spec,
402                                                    offset = offset,                                                    offset = offset,
403                                                    share = share,                                                    sh_mode = sh_mode,
404                                                    error = error }                                                    error = error }
405                              val n = DG.BNODE { bininfo = i,                              val n = DG.BNODE { bininfo = i,
406                                                 localimports = li,                                                 localimports = li,
407                                                 globalimports = gi }                                                 globalimports = gi }
408                          in                          in
409                                destroy_state gp smlinfo;
410                              m := SmlInfoMap.insert (!m, smlinfo, n);                              m := SmlInfoMap.insert (!m, smlinfo, n);
411                              n                              n
412                          end                          end
413    
414                  and sbn (DG.SB_SNODE n) = sn n                  and sbn (DG.SB_SNODE (n as DG.SNODE { smlinfo = i, ... })) =
415                    | sbn (DG.SB_BNODE n) = n                      let val ii = getII i
416                        in
417                            (sn n, ii)
418                        end
419                      | sbn (DG.SB_BNODE (n, ii)) = (n, ii)
420    
421                  and fsbn (f, n) = (f, sbn n)                  and fsbn (f, n) = (f, #1 (sbn n))
422    
423                  fun impexp ((f, n), e) = ((f, DG.SB_BNODE (sbn n)), e)                  fun impexp ((f, n), e) = ((f, DG.SB_BNODE (sbn n)), e)
424    
425                  val exports = SymbolMap.map impexp (#exports grec)                  val exports = SymbolMap.map impexp (#exports grec)
                 val simap = genStableInfoMap (exports, grouppath)  
426              in              in
427                  GG.GROUP { exports = exports,                  GG.GROUP { exports = exports,
428                             islib = islib,                             kind = GG.STABLELIB,
429                             required = required,                             required = required,
430                             grouppath = grouppath,                             grouppath = grouppath,
431                             subgroups = subgroups,                             sublibs = sublibs }
                            stableinfo = GG.STABLE simap }  
432              end              end
433    
434              fun writeInt32 (s, i) = let              fun writeInt32 (s, i) = let
# Line 322  Line 439 
439              end              end
440              val memberlist = rev (!members)              val memberlist = rev (!members)
441    
442              val policy = #fnpolicy (#param gp)              fun mksname () = FilenamePolicy.mkStableName policy grouppath
443              val gpath = #grouppath grec              fun work outs =
444              val spath = FilenamePolicy.mkStablePath policy gpath                  (writeInt32 (outs, dg_sz);
445              fun delete () = deleteFile (AbsPath.name spath)                   BinIO.output (outs, dg_pickle);
446              val outs = AbsPath.openBinOut spath                   app (writeBFC outs) memberlist;
447              fun try () =                   mkStableGroup mksname)
448                  (Say.vsay ["[stabilizing ", AbsPath.name gpath, "]\n"];          in
449                   writeInt32 (outs, sz);              SOME (SafeIO.perform { openIt = AutoDir.openBinOut o mksname,
450                   BinIO.output (outs, Byte.stringToBytes pickle);                                     closeIt = BinIO.closeOut,
451                   app (cpb outs) memberlist;                                     work = work,
452                   app delb memberlist;                                     cleanup = fn () =>
453                   BinIO.closeOut outs;                                      (OS.FileSys.remove (mksname ())
454                   SOME (mkStableGroup ()))                                       handle _ => ()) })
455          in              handle exn => NONE
456              Interrupt.guarded try          end
457              handle e as Interrupt.Interrupt => (BinIO.closeOut outs;      in
458                                                  delete ();          case #kind grec of
459                                                  raise e)              GG.STABLELIB => SOME g
460                   | exn => (BinIO.closeOut outs; NONE)            | GG.NOLIB => EM.impossible "stabilize: no library"
461          end            | GG.LIB wrapped =>
462      in               (case recomp gp g of
463          case #stableinfo grec of                    NONE => (anyerrors := true; NONE)
464              GG.STABLE _ => SOME g                  | SOME bfc_acc => let
465            | GG.NONSTABLE granted =>                        fun notStable (GG.GROUP { kind, ... }) =
466                  if not (recomp gp g) then                            case kind of GG.STABLELIB => false | _ => true
                     (anyerrors := true; NONE)  
                 else let  
                     fun notStable (GG.GROUP { stableinfo, ... }) =  
                         case stableinfo of  
                             GG.STABLE _ => false  
                           | GG.NONSTABLE _ => true  
467                  in                  in
468                      case List.filter notStable (#subgroups grec) of                      case List.filter notStable (#sublibs grec) of
469                          [] => doit granted                          [] => doit (wrapped, bfc_acc)
470                        | l => let                        | l => let
471                              val grammar = case l of [_] => " is" | _ => "s are"                              val grammar = case l of [_] => " is" | _ => "s are"
472                              fun ppb pps = let                              fun ppb pps = let
473                                  fun loop [] = ()                                  fun loop [] = ()
474                                    | loop (GG.GROUP { grouppath, ... } :: t) =                                    | loop (GG.GROUP { grouppath, ... } :: t) =
475                                      (PP.add_string pps                                      (PP.add_string pps
476                                          (AbsPath.name grouppath);                                          (SrcPath.descr grouppath);
477                                       PP.add_newline pps;                                       PP.add_newline pps;
478                                       loop t)                                       loop t)
479                              in                              in
# Line 374  Line 485 
485                                  loop l                                  loop l
486                              end                              end
487                              val errcons = #errcons gp                              val errcons = #errcons gp
488                              val gname = AbsPath.name (#grouppath grec)                              val gdescr = SrcPath.descr (#grouppath grec)
489                          in                          in
490                              EM.errorNoFile (errcons, anyerrors) SM.nullRegion                              EM.errorNoFile (errcons, anyerrors) SM.nullRegion
491                                 EM.COMPLAIN                                 EM.COMPLAIN
492                                 (gname ^ " cannot be stabilized")                                 (gdescr ^ " cannot be stabilized")
493                                 ppb;                                 ppb;
494                              NONE                              NONE
495                          end                          end
496                      end)
497                  end                  end
     end  
   
     fun loadStable (gp, getGroup, anyerrors) group = let  
498    
499          fun bn2env n = Statenv2DAEnv.cvtMemo (fn () => bn2statenv gp n)      fun loadStable gp { getGroup, anyerrors } group = let
500    
501          val errcons = #errcons gp          val errcons = #errcons (gp: GeneralParams.info)
502          val grpSrcInfo = (errcons, anyerrors)          val grpSrcInfo = (errcons, anyerrors)
503          val gname = AbsPath.name group          val gdescr = SrcPath.descr group
504          fun error l = EM.errorNoFile (errcons, anyerrors) SM.nullRegion          fun error l = EM.errorNoFile (errcons, anyerrors) SM.nullRegion
505              EM.COMPLAIN (concat (gname :: ": " :: l)) EM.nullErrorBody              EM.COMPLAIN (concat ("(stable) " :: gdescr :: ": " :: l))
506                EM.nullErrorBody
507    
508          exception Format          exception Format = UU.Format
509    
510            val pcmode = #pcmode (#param gp)
511          val policy = #fnpolicy (#param gp)          val policy = #fnpolicy (#param gp)
512          val spath = FilenamePolicy.mkStablePath policy group          val primconf = #primconf (#param gp)
513          val _ = Say.vsay ["[checking stable ", gname, "]\n"]          val pervasive = #pervasive (#param gp)
514          val s = AbsPath.openBinIn spath  
515            fun mksname () = FilenamePolicy.mkStableName policy group
516    
517            fun work s = let
518    
519          fun getGroup' p =          fun getGroup' p =
520              case getGroup p of              case getGroup p of
521                  SOME g => g                  SOME g => g
522                | NONE =>                    | NONE => (error ["unable to find ", SrcPath.descr p];
                     (error ["unable to find ", AbsPath.name p];  
523                       raise Format)                       raise Format)
524    
         (* for getting sharing right... *)  
         val m = ref IntBinaryMap.empty  
         val next = ref 0  
   
525          fun bytesIn n = let          fun bytesIn n = let
526              val bv = BinIO.inputN (s, n)              val bv = BinIO.inputN (s, n)
527          in          in
# Line 420  Line 529 
529              else raise Format              else raise Format
530          end          end
531    
532          val sz = LargeWord.toIntX (Pack32Big.subVec (bytesIn 4, 0))              val dg_sz = LargeWord.toIntX (Pack32Big.subVec (bytesIn 4, 0))
533          val pickle = bytesIn sz              val dg_pickle = Byte.bytesToString (bytesIn dg_sz)
534          val offset_adjustment = sz + 4              val offset_adjustment = dg_sz + 4
535                val session = UU.mkSession (UU.stringGetter dg_pickle)
536          val rd = let  
537              val pos = ref 0              fun list m r = UU.r_list session m r
538              fun rd () = let              val string = UU.r_string session
539                  val p = !pos              val stringListM = UU.mkMap ()
540              in              val stringlist = list stringListM string
541                  pos := p + 1;  
542                  Byte.byteToChar (Word8Vector.sub (pickle, p))              fun abspath () =
543                  handle _ => raise Format                  SrcPath.unpickle pcmode (stringlist (), group)
544              end                  handle SrcPath.Format => raise Format
545          in                       | SrcPath.BadAnchor a =>
546              rd                         (error ["configuration anchor \"", a, "\" undefined"];
547          end                          raise Format)
   
         fun r_list r () =  
             case rd () of  
                 #"0" => []  
               | #"1" => [r ()]  
               | #"2" => [r (), r ()]  
               | #"3" => [r (), r (), r ()]  
               | #"4" => [r (), r (), r (), r ()]  
               | #"5" => r () :: r () :: r () :: r () :: r () :: r_list r ()  
               | _ => raise Format  
   
         fun r_bool () =  
             case rd () of  
                 #"t" => true  
               | #"f" => false  
               | _ => raise Format  
548    
549          fun r_option r_item () =              fun sg () = getGroup' (abspath ())
550              case rd () of              val sgListM = UU.mkMap ()
551                  #"n" => NONE              val sublibs = list sgListM sg ()
552                | #"s" => SOME (r_item ())  
553                | _ => raise Format              (* Now that we have the list of sublibs, we can build the
554                 * environment for unpickling the environment list.
555                 * We will need the environment list when unpickling the
556                 * export list (making SB_BNODES). *)
557                fun prim_context "pv" = SOME (E.staticPart pervasive)
558                  | prim_context s =
559                    SOME (E.staticPart (Primitive.env primconf
560                                        (valOf (Primitive.fromIdent primconf
561                                                (String.sub (s, 0))))))
562                    handle _ => NONE
563                fun node_context (n, sy) = let
564                    val GG.GROUP { exports = slexp, ... } = List.nth (sublibs, n)
565                in
566                    case SymbolMap.find (slexp, sy) of
567                        SOME ((_, DG.SB_BNODE (_, { statenv = ge, ... })), _) =>
568                            SOME (ge ())
569                      | _ => NONE
570                end handle _ => NONE
571    
572                val { symenv, env, symbol, symbollist } =
573                    UP.mkUnpicklers session
574                        { prim_context = prim_context,
575                          node_context = node_context }
576    
577                val lazy_symenv = UU.r_lazy session symenv
578                val lazy_env = UU.r_lazy session env
579    
580                fun option m r = UU.r_option session m r
581                val int = UU.r_int session
582                fun share m r = UU.share session m r
583                fun nonshare r = UU.nonshare session r
584                val bool = UU.r_bool session
585                val pid = UnpickleSymPid.r_pid string
586    
587                val stringListM = UU.mkMap ()
588                val ssM = UU.mkMap ()
589                val ssoM = UU.mkMap ()
590                val boolOptionM = UU.mkMap ()
591                val siM = UU.mkMap ()
592                val snM = UU.mkMap ()
593                val snListM = UU.mkMap ()
594                val sbnM = UU.mkMap ()
595                val fsbnM = UU.mkMap ()
596                val fsbnListM = UU.mkMap ()
597                val impexpM = UU.mkMap ()
598                val impexpListM = UU.mkMap ()
599    
600                fun symbolset () = let
601                    fun s #"s" = SymbolSet.addList (SymbolSet.empty, symbollist ())
602                      | s _ = raise Format
603                in
604                    share ssM s
605                end
606    
607                val filter = option ssoM symbolset
608    
609                fun primitive () =
610                    valOf (Primitive.fromIdent primconf
611                              (String.sub (string (), 0)))
612                    handle _ => raise Format
613    
614          fun r_int () = let              fun shm () = let
615              fun loop n = let                  fun s #"a" = Sharing.SHARE true
616                  val w8 = Byte.charToByte (rd ())                    | s #"b" = Sharing.SHARE false
617                  val n' = n * 0w128 + Word8.toLargeWord (Word8.andb (w8, 0w127))                    | s #"c" = Sharing.DONTSHARE
618              in                    | s _ = raise Format
619                  if Word8.andb (w8, 0w128) = 0w0 then n' else loop n'              in
620              end                  nonshare s
         in  
             LargeWord.toIntX (loop 0w0)  
621          end          end
622    
623          fun r_share r_raw C unC () =              fun si () = let
624              case rd () of                  fun s #"s" =
625                  #"o" => (case IntBinaryMap.find (!m, r_int ()) of                      let val spec = string ()
626                               SOME x => unC x                          val locs = string ()
627                             | NONE => raise Format)                          val offset = int () + offset_adjustment
628                | #"n" => let                          val sh_mode = shm ()
629                      val i = !next                          val error = EM.errorNoSource grpSrcInfo locs
                     val _ = next := i + 1  
                     val v = r_raw ()  
630                  in                  in
631                      m := IntBinaryMap.insert (!m, i, C v);                          BinInfo.new { group = group,
632                      v                                        mkStablename = mksname,
633                                          error = error,
634                                          spec = spec,
635                                          offset = offset,
636                                          sh_mode = sh_mode }
637                  end                  end
638                | _ => raise Format                    | s _ = raise Format
   
         fun r_string () = let  
             fun loop l =  
                 case rd () of  
                     #"\"" => String.implode (rev l)  
                   | #"\\" => loop (rd () :: l)  
                   | c => loop (c :: l)  
639          in          in
640              loop []                  share siM s
641          end          end
642    
643          val r_abspath = let              (* this is the place where what used to be an
644              fun r_abspath_raw () =               * SNODE changes to a BNODE! *)
645                  case AbsPath.unpickle (r_list r_string ()) of              fun sn () = let
646                      SOME p => p                  fun sn' #"a" =
647                    | NONE => raise Format                      DG.BNODE { bininfo = si (),
648              fun unUAP (UAP x) = x                                 localimports = snlist (),
649                | unUAP _ = raise Format                                 globalimports = fsbnlist () }
650                      | sn' _ = raise Format
651          in          in
652              r_share r_abspath_raw UAP unUAP                  share snM sn'
653          end          end
654    
655          val r_symbol = let              and snlist () = list snListM sn ()
656              fun r_symbol_raw () = let  
657                  val (ns, first) =              (* this one changes from farsbnode to plain farbnode *)
658                      case rd () of              and sbn () = let
659                          #"`" => (Symbol.sigSymbol, rd ())                  fun sbn' #"1" = DG.PNODE (primitive ())
660                        | #"(" => (Symbol.fctSymbol, rd ())                    | sbn' #"2" = let
661                        | #")" => (Symbol.fsigSymbol, rd ())                          val n = int ()
662                        | c => (Symbol.strSymbol, c)                          val sy = symbol ()
663                  fun loop (#".", l) = String.implode (rev l)                          val GG.GROUP { exports = slexp, ... } =
664                    | loop (c, l) = loop (rd (), c :: l)                              List.nth (sublibs, n) handle _ => raise Format
665              in              in
666                  ns (loop (first, []))                          case SymbolMap.find (slexp, sy) of
667                                SOME ((_, DG.SB_BNODE (n as DG.BNODE _, _)), _) =>
668                                    n
669                              | _ => raise Format
670              end              end
671              fun unUS (US x) = x                    | sbn' #"3" = sn ()
672                | unUS _ = raise Format                    | sbn' _ = raise Format
673          in          in
674              r_share r_symbol_raw US unUS                  share sbnM sbn'
675          end          end
676    
677          val r_ss = let              and fsbn () = let
678              fun r_ss_raw () =                  fun f #"f" = (filter (), sbn ())
679                  SymbolSet.addList (SymbolSet.empty, r_list r_symbol ())                    | f _ = raise Format
680              fun unUSS (USS s) = s              in
681                | unUSS _ = raise Format                  share fsbnM f
682                end
683    
684                and fsbnlist () = list fsbnListM fsbn ()
685    
686                fun impexp () = let
687                    fun ie #"i" =
688                        let val sy = symbol ()
689                            val (f, n) = fsbn () (* really reads farbnodes! *)
690                            val ge = lazy_env ()
691                            val ii = { statenv = GenericVC.CoerceEnv.bs2es o ge,
692                                       symenv = lazy_symenv (),
693                                       statpid = pid (),
694                                       sympid = pid () }
695                            val e = Statenv2DAEnv.cvtMemo ge
696                            (* put a filter in front to avoid having the FCTENV
697                             * being queried needlessly (this avoids spurious
698                             * module loadings) *)
699                            val e' = DAEnv.FILTER (SymbolSet.singleton sy, e)
700          in          in
701              r_share r_ss_raw USS unUSS                          (sy, ((f, DG.SB_BNODE (n, ii)), e'))
702          end          end
703                      | ie _ = raise Format
         val r_filter = r_option r_ss  
   
         fun r_primitive () =  
             case Primitive.fromIdent (rd ()) of  
                 NONE => raise Format  
               | SOME p => p  
   
         fun r_sharing () =  
             case rd () of  
                 #"n" => NONE  
               | #"t" => SOME true  
               | #"f" => SOME false  
               | _ => raise Format  
   
         fun r_si () = let  
             val spec = r_string ()  
             val locs = r_string ()  
             val offset = r_int () + offset_adjustment  
             val share = r_sharing ()  
             val error = EM.errorNoSource grpSrcInfo locs  
704          in          in
705              BinInfo.new { group = group,                  share impexpM ie
                           error = error,  
                           spec = spec,  
                           offset = offset,  
                           share = share }  
         end  
   
         fun r_bn () =  
             case rd () of  
                 #"p" => DG.PNODE (r_primitive ())  
               | #"b" => let  
                     val p = r_abspath ()  
                     val os = r_int ()  
                 in  
                     case getGroup' p of  
                         GG.GROUP { stableinfo = GG.STABLE im, ... } =>  
                             (case IntBinaryMap.find (im, os) of  
                                  NONE => raise Format  
                                | SOME n => n)  
                       | _ => raise Format  
706                  end                  end
               | _ => raise Format  
   
         (* this is the place where what used to be an  
          * SNODE changes to a BNODE! *)  
         fun r_sn_raw () =  
             DG.BNODE { bininfo = r_si (),  
                        localimports = r_list r_sn (),  
                        globalimports = r_list r_fsbn () }  
   
         and r_sn () =  
             r_share r_sn_raw UBN (fn (UBN n) => n | _ => raise Format) ()  
707    
708          (* this one changes from farsbnode to plain farbnode *)              val impexplist = list impexpListM impexp
         and r_sbn () =  
             case rd () of  
                 #"b" => r_bn ()  
               | #"s" => r_sn ()  
               | _ => raise Format  
709    
710          and r_fsbn () = (r_filter (), r_sbn ())              fun r_exports () = let
711                    val iel = impexplist ()
         fun r_impexp () = let  
             val sy = r_symbol ()  
             val (f, n) = r_fsbn ()      (* really reads farbnodes! *)  
             val e = bn2env n  
             (* put a filter in front to avoid having the FCTENV being  
              * queried needlessly (this avoids spurious module loadings) *)  
             val e' = DAEnv.FILTER (SymbolSet.singleton sy, e)  
712          in          in
713              (sy, ((f, DG.SB_BNODE n), e')) (* coerce to farsbnodes *)                  foldl SymbolMap.insert' SymbolMap.empty iel
714          end          end
715    
716          fun r_exports () =              val stringlist = list stringListM string
             foldl SymbolMap.insert' SymbolMap.empty (r_list r_impexp ())  
717    
718          fun r_privileges () =              fun privileges () =
719              StringSet.addList (StringSet.empty, r_list r_string ())                  StringSet.addList (StringSet.empty, stringlist ())
720    
         fun unpickle_group () = let  
721              val exports = r_exports ()              val exports = r_exports ()
722              val islib = r_bool ()              val required = privileges ()
             val required = r_privileges ()  
             val subgroups = r_list (getGroup' o r_abspath) ()  
             val simap = genStableInfoMap (exports, group)  
723          in          in
724              GG.GROUP { exports = exports,              GG.GROUP { exports = exports,
725                         islib = islib,                         kind = GG.STABLELIB,
726                         required = required,                         required = required,
727                         grouppath = group,                         grouppath = group,
728                         subgroups = subgroups,                         sublibs = sublibs }
                        stableinfo = GG.STABLE simap }  
             before BinIO.closeIn s  
729          end          end
730      in      in
731          SOME (unpickle_group ())          SOME (SafeIO.perform { openIt = BinIO.openIn o mksname,
732          handle Format => (BinIO.closeIn s; NONE)                                 closeIt = BinIO.closeIn,
733               | exn => (BinIO.closeIn s; raise exn)                                 work = work,
734      end handle IO.Io _ => NONE                                 cleanup = fn () => () })
735            handle Format => (error ["file is corrupted (old version?)"];
736                              NONE)
737                 | IO.Io _ => NONE
738        end
739  end  end
740    
741  end (* local *)  end (* local *)

Legend:
Removed from v.314  
changed lines
  Added in v.403

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