Home My Page Projects Code Snippets Project Openings SML/NJ
Summary Activity Forums Tracker Lists Tasks Docs Surveys News SCM Files

SCM Repository

[smlnj] Annotation of /sml/trunk/src/cm/stable/stabilize.sml
ViewVC logotype

Annotation of /sml/trunk/src/cm/stable/stabilize.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 513 - (view) (download)

1 : blume 309 (*
2 :     * Reading, generating, and writing stable groups.
3 :     *
4 :     * (C) 1999 Lucent Technologies, Bell Laboratories
5 :     *
6 :     * Author: Matthias Blume (blume@kurims.kyoto-u.ac.jp)
7 :     *)
8 :     local
9 : blume 304 structure DG = DependencyGraph
10 : blume 306 structure GG = GroupGraph
11 :     structure EM = GenericVC.ErrorMsg
12 : blume 311 structure PP = PrettyPrint
13 :     structure SM = GenericVC.SourceMap
14 : blume 309 structure GP = GeneralParams
15 :     structure E = GenericVC.Environment
16 : blume 357 structure Pid = GenericVC.PersStamps
17 : blume 398 structure P = PickMod
18 :     structure UP = UnpickMod
19 :     structure E = GenericVC.Environment
20 : blume 309 in
21 : blume 304
22 : blume 309 signature STABILIZE = sig
23 :    
24 :     val loadStable :
25 : blume 398 GP.info -> { getGroup: SrcPath.t -> GG.group option,
26 :     anyerrors: bool ref }
27 :     -> SrcPath.t -> GG.group option
28 : blume 309
29 :     val stabilize :
30 : blume 398 GP.info -> { group: GG.group, anyerrors: bool ref } -> GG.group option
31 : blume 309 end
32 :    
33 : blume 403 functor StabilizeFn (val destroy_state : GP.info -> SmlInfo.info -> unit
34 :     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 : blume 309
40 : blume 403 structure BF = MachDepVC.Binfile
41 :    
42 : blume 447 structure SSMap = MapFn
43 : blume 385 (struct
44 :     type ord_key = SymbolSet.set
45 :     val compare = SymbolSet.compare
46 :     end)
47 :    
48 : blume 447 structure SNMap = MapFn
49 : blume 384 (struct
50 :     type ord_key = DG.snode
51 :     fun compare (DG.SNODE n, DG.SNODE n') =
52 :     SmlInfo.compare (#smlinfo n, #smlinfo n')
53 : blume 304 end)
54 :    
55 : blume 398 structure PU = PickleUtil
56 :     structure UU = UnpickleUtil
57 : blume 384
58 : blume 398 type map = { ss: PU.id SSMap.map, sn: PU.id SNMap.map, pm: P.map }
59 : blume 393
60 : blume 398 val emptyMap = { ss = SSMap.empty, sn = SNMap.empty, pm = P.emptyMap }
61 : blume 393
62 : blume 398 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 : blume 393 infix 3 $
67 :    
68 :     (* type info *)
69 : blume 513 val (BN, SN, SBN, SS, SI, FSBN, IMPEXP, SHM, G, AP,
70 :     PRIM, EXPORTS, PRIV) =
71 :     (1001, 1002, 1003, 1004, 1005, 1006, 1007, 1008, 1009, 1010,
72 :     1011, 1012, 1013)
73 : blume 393
74 : blume 398 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 : blume 385
83 : blume 505 fun fetch_pickle s = let
84 :     fun bytesIn n = let
85 :     val bv = BinIO.inputN (s, n)
86 :     in
87 :     if n = Word8Vector.length bv then bv
88 :     else raise UU.Format
89 :     end
90 :    
91 :     val dg_sz = LargeWord.toIntX (Pack32Big.subVec (bytesIn 4, 0))
92 :     val dg_pickle = Byte.bytesToString (bytesIn dg_sz)
93 :     in
94 :     { size = dg_sz, pickle = dg_pickle }
95 :     end
96 :    
97 :     fun mkPickleFetcher mksname () =
98 :     SafeIO.perform { openIt = BinIO.openIn o mksname,
99 :     closeIt = BinIO.closeIn,
100 :     work = #pickle o fetch_pickle,
101 :     cleanup = fn _ => () }
102 :    
103 : blume 311 fun stabilize gp { group = g as GG.GROUP grec, anyerrors } = let
104 : blume 304
105 : blume 323 val primconf = #primconf (#param gp)
106 :     val policy = #fnpolicy (#param gp)
107 : blume 398 val pervasive = #pervasive (#param gp)
108 : blume 323
109 : blume 340 val grouppath = #grouppath grec
110 :    
111 : blume 403 fun doit (wrapped, getBFC) = let
112 : blume 312
113 : blume 403 fun writeBFC s i = BF.write { stream = s,
114 :     content = getBFC i,
115 :     nopickle = true }
116 :     fun sizeBFC i = BF.size { content = getBFC i, nopickle = true }
117 :    
118 : blume 314 val _ =
119 : blume 403 Say.vsay ["[stabilizing ", SrcPath.descr grouppath, "]\n"]
120 :    
121 :     val _ =
122 : blume 348 if StringSet.isEmpty wrapped then ()
123 : blume 314 else
124 :     Say.say ("$Stabilize: wrapping the following privileges:\n"
125 : blume 312 :: map (fn s => (" " ^ s ^ "\n"))
126 : blume 348 (StringSet.listItems wrapped))
127 : blume 312
128 : blume 311 val grpSrcInfo = (#errcons gp, anyerrors)
129 : blume 308
130 : blume 311 val exports = #exports grec
131 : blume 348 val required = StringSet.difference (#required grec, wrapped)
132 : blume 340 val sublibs = #sublibs grec
133 : blume 304
134 : blume 311 (* The format of a stable archive is the following:
135 :     * - It starts with the size s of the pickled dependency
136 :     * graph. This size itself is written as four-byte string.
137 : blume 398 * - The size t of the pickled environment for the entire
138 :     * library (using the pickleEnvN interface of the pickler)
139 :     * in the same format as s.
140 : blume 311 * - The pickled dependency graph. This graph contains
141 :     * integer offsets of the binfiles for the individual ML
142 :     * members. These offsets need to be adjusted by adding
143 : blume 398 * s + t + 8. The pickled dependency graph also contains integer
144 : blume 311 * offsets relative to other stable groups. These offsets
145 :     * need no further adjustment.
146 : blume 398 * - Individual binfile contents (concatenated) but without
147 :     * their static environments.
148 : blume 311 *)
149 : blume 304
150 : blume 340 (* Here we build a mapping that maps each BNODE to a number
151 :     * representing the sub-library that it came from and a
152 :     * representative symbol that can be used to find the BNODE
153 :     * within the exports of that library *)
154 : blume 398 fun oneB i (sy, ((_, DG.SB_BNODE (DG.BNODE n, _)), _), m) =
155 : blume 340 StableMap.insert (m, #bininfo n, (i, sy))
156 :     | oneB i (_, _, m) = m
157 : blume 444 fun oneSL ((_, g as GG.GROUP { exports, ... }), (m, i)) =
158 : blume 340 (SymbolMap.foldli (oneB i) m exports, i + 1)
159 :     val inverseMap = #1 (foldl oneSL (StableMap.empty, 0) sublibs)
160 : blume 330
161 : blume 311 val members = ref []
162 :     val (registerOffset, getOffset) = let
163 :     val dict = ref SmlInfoMap.empty
164 :     val cur = ref 0
165 :     fun reg (i, sz) = let
166 :     val os = !cur
167 : blume 306 in
168 : blume 311 cur := os + sz;
169 :     dict := SmlInfoMap.insert (!dict, i, os);
170 :     members := i :: (!members);
171 :     os
172 : blume 306 end
173 : blume 311 fun get i = valOf (SmlInfoMap.find (!dict, i))
174 :     in
175 :     (reg, get)
176 :     end
177 : blume 304
178 : blume 398 (* Collect all BNODEs and PNODEs that we see and build
179 :     * a context suitable for P.envPickler. *)
180 :     fun mkContext () = let
181 :     fun lst f [] k s = k s
182 :     | lst f (h :: t) k s = f h (lst f t k) s
183 :    
184 :     fun sbn n k (s as (prims, bnodes, snodes)) =
185 :     case n of
186 :     DG.SB_BNODE (DG.PNODE p, { statenv, ... }) => let
187 :     val str = String.str (Primitive.toIdent primconf p)
188 : blume 461 val prims' =
189 :     StringMap.insert (prims, str, #env o statenv)
190 : blume 398 in
191 :     k (prims', bnodes, snodes)
192 :     end
193 :     | DG.SB_BNODE (DG.BNODE { bininfo = i, ... }, ii) => let
194 :     val { statenv, ... } = ii
195 :     val nsy = valOf (StableMap.find (inverseMap, i))
196 :     val bnodes' =
197 : blume 461 StableMap.insert (bnodes, i,
198 :     (nsy, #env o statenv))
199 : blume 398 in
200 :     k (prims, bnodes', snodes)
201 :     end
202 :     | DG.SB_SNODE n => sn n k s
203 :    
204 :     and sn (DG.SNODE n) k (prims, bnodes, snodes) = let
205 :     val i = #smlinfo n
206 :     val li = #localimports n
207 :     val gi = #globalimports n
208 :     in
209 :     if SmlInfoSet.member (snodes, i) then
210 :     k (prims, bnodes, snodes)
211 :     else let
212 :     val snodes' = SmlInfoSet.add (snodes, i)
213 :     in
214 :     lst sn li (lst fsbn gi k) (prims, bnodes, snodes')
215 :     end
216 :     end
217 :    
218 :     and fsbn (_, n) k s = sbn n k s
219 :    
220 :     fun impexp (n, _) k s = fsbn n k s
221 :    
222 :     val (prims, bnodes) =
223 :     lst impexp (SymbolMap.listItems exports)
224 :     (fn (prims, bnodes, _) => (prims, bnodes))
225 :     (StringMap.empty, StableMap.empty, SmlInfoSet.empty)
226 :    
227 :     val priml = StringMap.listItemsi prims
228 :     val bnodel = StableMap.listItems bnodes
229 :    
230 :     fun cvt lk id = let
231 :     fun nloop [] = NONE
232 :     | nloop ((k, ge) :: t) =
233 :     (case lk (ge ()) id of
234 :     SOME _ => SOME (P.NodeKey k)
235 :     | NONE => nloop t)
236 :     fun ploop [] = nloop bnodel
237 :     | ploop ((k, ge) :: t) =
238 :     (case lk (ge ()) id of
239 :     SOME _ => SOME (P.PrimKey k)
240 :     | NONE => ploop t)
241 :     in
242 :     case lk (E.staticPart pervasive) id of
243 :     NONE => ploop priml
244 :     | SOME _ => SOME (P.PrimKey "pv")
245 :     end
246 :     in
247 :     { lookSTR = cvt GenericVC.CMStaticEnv.lookSTR,
248 :     lookSIG = cvt GenericVC.CMStaticEnv.lookSIG,
249 :     lookFCT = cvt GenericVC.CMStaticEnv.lookFCT,
250 :     lookFSIG = cvt GenericVC.CMStaticEnv.lookFSIG,
251 :     lookTYC = cvt GenericVC.CMStaticEnv.lookTYC,
252 :     lookEENV = cvt GenericVC.CMStaticEnv.lookEENV }
253 :     end
254 :    
255 :     (* make the picklers for static and symbolic environments;
256 :     * lift them so we can use them here... *)
257 :     val envContext = mkContext ()
258 : blume 403
259 : blume 398 val env_orig = P.envPickler envContext
260 :     val env = PU.lift_pickler lifter env_orig
261 :     val symenv_orig = P.symenvPickler
262 :     val symenv = PU.lift_pickler lifter symenv_orig
263 :     val lazy_env = PU.w_lazy env
264 :     val lazy_symenv = PU.w_lazy symenv
265 :    
266 : blume 384 val int = PU.w_int
267 : blume 398 val symbol = PickleSymPid.w_symbol
268 :     val pid = PickleSymPid.w_pid
269 : blume 384 val share = PU.ah_share
270 :     val option = PU.w_option
271 :     val list = PU.w_list
272 :     val string = PU.w_string
273 :     val bool = PU.w_bool
274 :     val int = PU.w_int
275 : blume 304
276 : blume 385 fun symbolset ss = let
277 :     val op $ = PU.$ SS
278 : blume 513 fun raw_ss ss = "s" $ [list symbol (SymbolSet.listItems ss)]
279 : blume 385 in
280 :     share SSs raw_ss ss
281 :     end
282 : blume 304
283 : blume 384 val filter = option symbolset
284 : blume 304
285 : blume 513 val op $ = PU.$ SHM
286 :     fun shm (Sharing.SHARE true) = "a" $ []
287 :     | shm (Sharing.SHARE false) = "b" $ []
288 :     | shm Sharing.DONTSHARE = "c" $ []
289 : blume 304
290 : blume 384 fun si i = let
291 : blume 340 (* FIXME: this is not a technical flaw, but perhaps one
292 :     * that deserves fixing anyway: If we only look at spec,
293 :     * then we are losing information about sub-grouping
294 :     * within libraries. However, the spec in BinInfo.info
295 :     * is only used for diagnostics and has no impact on the
296 :     * operation of CM itself. *)
297 : blume 354 val spec = SrcPath.specOf (SmlInfo.sourcepath i)
298 : blume 311 val locs = SmlInfo.errorLocation gp i
299 : blume 398 val offset = registerOffset (i, sizeBFC i)
300 : blume 387 val sh_mode = SmlInfo.sh_mode i
301 : blume 385 val op $ = PU.$ SI
302 : blume 311 in
303 : blume 513 "s" $ [string spec, string locs, int offset, shm sh_mode]
304 : blume 311 end
305 : blume 306
306 : blume 513 fun primitive p = let
307 :     val op $ = PU.$ PRIM
308 :     in
309 :     "p" $ [string (String.str (Primitive.toIdent primconf p))]
310 :     end
311 : blume 306
312 : blume 340 fun warn_relabs p abs = let
313 :     val relabs = if abs then "absolute" else "relative"
314 : blume 330 fun ppb pps =
315 :     (PP.add_newline pps;
316 : blume 354 PP.add_string pps (SrcPath.descr p);
317 : blume 330 PP.add_newline pps;
318 :     PP.add_string pps
319 :     "(This means that in order to be able to use the result of stabilization";
320 :     PP.add_newline pps;
321 : blume 340 PP.add_string pps "the library must be in the same ";
322 : blume 330 PP.add_string pps relabs;
323 :     PP.add_string pps " location as it is now.)";
324 :     PP.add_newline pps)
325 :     in
326 :     EM.errorNoFile (#errcons gp, anyerrors) SM.nullRegion
327 :     EM.WARN
328 : blume 354 (concat [SrcPath.descr grouppath,
329 : blume 340 ": library referred to by ", relabs,
330 :     " pathname:"])
331 : blume 330 ppb
332 :     end
333 : blume 306
334 : blume 384 fun abspath p = let
335 : blume 513 val op $ = PU.$ AP
336 : blume 384 val pp = SrcPath.pickle (warn_relabs p) (p, grouppath)
337 :     in
338 : blume 513 "p" $ [list string pp]
339 : blume 384 end
340 : blume 306
341 : blume 385 fun sn n = let
342 : blume 398 val op $ = PU.$ SN
343 : blume 385 fun raw_sn (DG.SNODE n) =
344 : blume 513 "a" $ [si (#smlinfo n), list sn (#localimports n),
345 :     list fsbn (#globalimports n)]
346 : blume 384 in
347 : blume 385 share SNs raw_sn n
348 :     end
349 : blume 306
350 : blume 398 (* Here we ignore the interface info because we will not
351 :     * need it anymore when we unpickle. *)
352 : blume 385 and sbn x = let
353 :     val op $ = PU.$ SBN
354 :     in
355 :     case x of
356 : blume 398 DG.SB_BNODE (DG.PNODE p, { statenv = getE, ... }) =>
357 : blume 513 "1" $ [primitive p]
358 : blume 398 | DG.SB_BNODE (DG.BNODE { bininfo = i, ... }, _) => let
359 :     val (n, sy) = valOf (StableMap.find (inverseMap, i))
360 :     in
361 : blume 513 "2" $ [int n, symbol sy]
362 : blume 398 end
363 : blume 513 | DG.SB_SNODE n => "3" $ [sn n]
364 : blume 385 end
365 :    
366 :     and fsbn (f, n) = let
367 :     val op $ = PU.$ FSBN
368 :     in
369 : blume 513 "f" $ [filter f, sbn n]
370 : blume 385 end
371 : blume 370
372 : blume 398 (* Here is the place where we need to write interface info. *)
373 : blume 385 fun impexp (s, (n, _)) = let
374 :     val op $ = PU.$ IMPEXP
375 : blume 398 val { statenv, symenv, statpid, sympid } =
376 :     case n of
377 :     (_, DG.SB_BNODE (_, ii)) => ii
378 :     | (_, DG.SB_SNODE (DG.SNODE { smlinfo, ... })) =>
379 :     getII smlinfo
380 : blume 461 fun es2bs { env, ctxt } =
381 :     { env = GenericVC.CoerceEnv.es2bs env, ctxt = ctxt }
382 : blume 385 in
383 : blume 513 "i" $ [symbol s, fsbn n,
384 :     lazy_env (es2bs o statenv),
385 :     lazy_symenv symenv,
386 :     pid statpid,
387 :     pid sympid]
388 : blume 384 end
389 : blume 307
390 : blume 513 fun w_exports e = let
391 :     val op $ = PU.$ EXPORTS
392 :     in
393 :     "e" $ [list impexp (SymbolMap.listItemsi e)]
394 :     end
395 : blume 306
396 : blume 513 fun privileges p = let
397 :     val op $ = PU.$ PRIV
398 :     in
399 :     "p" $ [list string (StringSet.listItems p)]
400 :     end
401 : blume 306
402 : blume 384 fun group () = let
403 : blume 513 val op $ = PU.$ G
404 : blume 444 fun sg (p, g) = abspath p
405 : blume 311 in
406 : blume 340 (* Pickle the sublibs first because we need to already
407 : blume 330 * have them back when we unpickle BNODEs. *)
408 : blume 513 "g" $ [list sg sublibs, w_exports exports, privileges required]
409 : blume 311 end
410 : blume 308
411 : blume 398 val dg_pickle =
412 :     Byte.stringToBytes (PU.pickle emptyMap (group ()))
413 : blume 403
414 : blume 398 val dg_sz = Word8Vector.length dg_pickle
415 : blume 308
416 : blume 398 val offset_adjustment = dg_sz + 4
417 :    
418 : blume 361 fun mkStableGroup mksname = let
419 : blume 311 val m = ref SmlInfoMap.empty
420 :     fun sn (DG.SNODE (n as { smlinfo, ... })) =
421 :     case SmlInfoMap.find (!m, smlinfo) of
422 :     SOME n => n
423 :     | NONE => let
424 : blume 371 val li = map sn (#localimports n)
425 :     val gi = map fsbn (#globalimports n)
426 : blume 311 val sourcepath = SmlInfo.sourcepath smlinfo
427 : blume 340 (* FIXME: see the comment near the other
428 : blume 354 * occurence of SrcPath.spec... *)
429 :     val spec = SrcPath.specOf sourcepath
430 : blume 311 val offset =
431 :     getOffset smlinfo + offset_adjustment
432 : blume 387 val sh_mode = SmlInfo.sh_mode smlinfo
433 : blume 311 val locs = SmlInfo.errorLocation gp smlinfo
434 :     val error = EM.errorNoSource grpSrcInfo locs
435 :     val i = BinInfo.new { group = grouppath,
436 : blume 361 mkStablename = mksname,
437 : blume 311 spec = spec,
438 :     offset = offset,
439 : blume 387 sh_mode = sh_mode,
440 : blume 311 error = error }
441 :     val n = DG.BNODE { bininfo = i,
442 :     localimports = li,
443 :     globalimports = gi }
444 :     in
445 :     m := SmlInfoMap.insert (!m, smlinfo, n);
446 :     n
447 :     end
448 : blume 308
449 : blume 398 and sbn (DG.SB_SNODE (n as DG.SNODE { smlinfo = i, ... })) =
450 :     let val ii = getII i
451 :     in
452 :     (sn n, ii)
453 :     end
454 :     | sbn (DG.SB_BNODE (n, ii)) = (n, ii)
455 : blume 308
456 : blume 398 and fsbn (f, n) = (f, #1 (sbn n))
457 : blume 308
458 : blume 311 fun impexp ((f, n), e) = ((f, DG.SB_BNODE (sbn n)), e)
459 : blume 308
460 : blume 311 val exports = SymbolMap.map impexp (#exports grec)
461 :     in
462 : blume 426 SmlInfoMap.appi (fn (i, _) => destroy_state gp i) (!m);
463 : blume 311 GG.GROUP { exports = exports,
464 : blume 505 kind = GG.STABLELIB (fn () => ()),
465 : blume 311 required = required,
466 :     grouppath = grouppath,
467 : blume 348 sublibs = sublibs }
468 : blume 311 end
469 : blume 308
470 : blume 311 fun writeInt32 (s, i) = let
471 :     val a = Word8Array.array (4, 0w0)
472 :     val _ = Pack32Big.update (a, 0, LargeWord.fromInt i)
473 :     in
474 :     BinIO.output (s, Word8Array.extract (a, 0, NONE))
475 :     end
476 :     val memberlist = rev (!members)
477 :    
478 : blume 403 fun mksname () = FilenamePolicy.mkStableName policy grouppath
479 : blume 345 fun work outs =
480 : blume 403 (writeInt32 (outs, dg_sz);
481 : blume 398 BinIO.output (outs, dg_pickle);
482 :     app (writeBFC outs) memberlist;
483 : blume 361 mkStableGroup mksname)
484 : blume 311 in
485 : blume 361 SOME (SafeIO.perform { openIt = AutoDir.openBinOut o mksname,
486 : blume 345 closeIt = BinIO.closeOut,
487 :     work = work,
488 : blume 459 cleanup = fn _ =>
489 : blume 361 (OS.FileSys.remove (mksname ())
490 :     handle _ => ()) })
491 : blume 426 handle exn =>
492 :     (EM.errorNoFile (#errcons gp, anyerrors) SM.nullRegion
493 :     EM.COMPLAIN
494 :     (concat ["Exception raised while stabilizing ",
495 :     SrcPath.descr grouppath])
496 :     EM.nullErrorBody;
497 :     NONE)
498 : blume 311 end
499 :     in
500 : blume 348 case #kind grec of
501 : blume 505 GG.STABLELIB _ => SOME g
502 : blume 348 | GG.NOLIB => EM.impossible "stabilize: no library"
503 :     | GG.LIB wrapped =>
504 : blume 403 (case recomp gp g of
505 :     NONE => (anyerrors := true; NONE)
506 :     | SOME bfc_acc => let
507 : blume 444 fun notStable (_, GG.GROUP { kind, ... }) =
508 : blume 505 case kind of GG.STABLELIB _ => false | _ => true
509 : blume 403 in
510 : blume 340 case List.filter notStable (#sublibs grec) of
511 : blume 403 [] => doit (wrapped, bfc_acc)
512 : blume 311 | l => let
513 :     val grammar = case l of [_] => " is" | _ => "s are"
514 :     fun ppb pps = let
515 :     fun loop [] = ()
516 : blume 444 | loop ((p, _) :: t) =
517 :     (PP.add_string pps (SrcPath.descr p);
518 : blume 311 PP.add_newline pps;
519 :     loop t)
520 :     in
521 :     PP.add_newline pps;
522 :     PP.add_string pps
523 :     (concat ["because the following sub-group",
524 :     grammar, " not stable:"]);
525 :     PP.add_newline pps;
526 :     loop l
527 :     end
528 :     val errcons = #errcons gp
529 : blume 354 val gdescr = SrcPath.descr (#grouppath grec)
530 : blume 311 in
531 :     EM.errorNoFile (errcons, anyerrors) SM.nullRegion
532 :     EM.COMPLAIN
533 : blume 354 (gdescr ^ " cannot be stabilized")
534 : blume 311 ppb;
535 :     NONE
536 :     end
537 : blume 403 end)
538 : blume 311 end
539 : blume 310
540 : blume 398 fun loadStable gp { getGroup, anyerrors } group = let
541 : blume 306
542 : blume 398 val errcons = #errcons (gp: GeneralParams.info)
543 : blume 311 val grpSrcInfo = (errcons, anyerrors)
544 : blume 354 val gdescr = SrcPath.descr group
545 : blume 311 fun error l = EM.errorNoFile (errcons, anyerrors) SM.nullRegion
546 : blume 367 EM.COMPLAIN (concat ("(stable) " :: gdescr :: ": " :: l))
547 :     EM.nullErrorBody
548 : blume 309
549 : blume 384 exception Format = UU.Format
550 : blume 306
551 : blume 318 val pcmode = #pcmode (#param gp)
552 : blume 310 val policy = #fnpolicy (#param gp)
553 : blume 323 val primconf = #primconf (#param gp)
554 : blume 398 val pervasive = #pervasive (#param gp)
555 :    
556 : blume 361 fun mksname () = FilenamePolicy.mkStableName policy group
557 : blume 310
558 : blume 345 fun work s = let
559 : blume 310
560 : blume 345 fun getGroup' p =
561 :     case getGroup p of
562 :     SOME g => g
563 : blume 354 | NONE => (error ["unable to find ", SrcPath.descr p];
564 : blume 345 raise Format)
565 : blume 306
566 : blume 505 val { size = dg_sz, pickle = dg_pickle } = fetch_pickle s
567 : blume 398 val offset_adjustment = dg_sz + 4
568 : blume 505 val { getter, dropper } =
569 :     UU.stringGetter' (SOME dg_pickle, mkPickleFetcher mksname)
570 :     val session = UU.mkSession getter
571 : blume 345
572 : blume 398 val sgListM = UU.mkMap ()
573 : blume 384 val stringListM = UU.mkMap ()
574 : blume 513 val stringListM = UU.mkMap ()
575 : blume 385 val ssM = UU.mkMap ()
576 : blume 384 val ssoM = UU.mkMap ()
577 :     val boolOptionM = UU.mkMap ()
578 : blume 385 val siM = UU.mkMap ()
579 : blume 384 val snM = UU.mkMap ()
580 :     val snListM = UU.mkMap ()
581 :     val sbnM = UU.mkMap ()
582 : blume 385 val fsbnM = UU.mkMap ()
583 : blume 384 val fsbnListM = UU.mkMap ()
584 : blume 385 val impexpM = UU.mkMap ()
585 : blume 384 val impexpListM = UU.mkMap ()
586 : blume 513 val groupM = UU.mkMap ()
587 :     val apM = UU.mkMap ()
588 :     val primitiveM = UU.mkMap ()
589 :     val exportsM = UU.mkMap ()
590 :     val privilegesM = UU.mkMap ()
591 : blume 304
592 : blume 513 fun list m r = UU.r_list session m r
593 :     val string = UU.r_string session
594 :     val stringlist = list stringListM string
595 : blume 305
596 : blume 513 fun option m r = UU.r_option session m r
597 :     val int = UU.r_int session
598 :     fun share m r = UU.share session m r
599 :     fun nonshare r = UU.nonshare session r
600 :     val bool = UU.r_bool session
601 :     val pid = UnpickleSymPid.r_pid (session, string)
602 : blume 305
603 : blume 513 fun abspath () = let
604 :     fun ap #"p" =
605 :     (SrcPath.unpickle pcmode (stringlist (), group)
606 :     handle SrcPath.Format => raise Format
607 :     | SrcPath.BadAnchor a =>
608 :     (error ["configuration anchor \"", a, "\" undefined"];
609 :     raise Format))
610 :     | ap _ = raise Format
611 : blume 387 in
612 : blume 513 share apM ap
613 : blume 387 end
614 : blume 305
615 : blume 513 fun sg () = let
616 :     val p = abspath ()
617 : blume 345 in
618 : blume 513 (p, getGroup' p)
619 : blume 345 end
620 : blume 306
621 : blume 513 fun gr #"g" =
622 :     let val sublibs = list sgListM sg ()
623 : blume 306
624 : blume 513 (* Now that we have the list of sublibs, we can build the
625 :     * environment for unpickling the environment list.
626 :     * We will need the environment list when unpickling the
627 :     * export list (making SB_BNODES). *)
628 :     fun prim_context "pv" = SOME (E.staticPart pervasive)
629 :     | prim_context s =
630 :     SOME (E.staticPart
631 :     (Primitive.env primconf
632 :     (valOf (Primitive.fromIdent primconf
633 :     (String.sub (s, 0))))))
634 :     handle _ => NONE
635 :     fun node_context (n, sy) = let
636 : blume 444 val (_, GG.GROUP { exports = slexp, ... }) =
637 : blume 513 List.nth (sublibs, n)
638 : blume 398 in
639 :     case SymbolMap.find (slexp, sy) of
640 : blume 513 SOME ((_, DG.SB_BNODE (_, x)), _) =>
641 :     SOME (#env (#statenv x ()))
642 :     | _ => NONE
643 :     end handle _ => NONE
644 :    
645 :     val { symenv, env, symbol, symbollist } =
646 :     UP.mkUnpicklers session
647 :     { prim_context = prim_context,
648 :     node_context = node_context }
649 :    
650 :     val lazy_symenv = UU.r_lazy session symenv
651 :     val lazy_env = UU.r_lazy session env
652 :    
653 :     fun symbolset () = let
654 :     fun s #"s" =
655 :     SymbolSet.addList (SymbolSet.empty, symbollist ())
656 :     | s _ = raise Format
657 :     in
658 :     share ssM s
659 : blume 398 end
660 : blume 306
661 : blume 513 val filter = option ssoM symbolset
662 : blume 306
663 : blume 513 fun primitive () = let
664 :     fun p #"p" =
665 :     (valOf (Primitive.fromIdent primconf
666 :     (String.sub (string (), 0)))
667 :     handle _ => raise Format)
668 :     | p _ = raise Format
669 :     in
670 :     share primitiveM p
671 :     end
672 : blume 384
673 : blume 513 fun shm () = let
674 :     fun s #"a" = Sharing.SHARE true
675 :     | s #"b" = Sharing.SHARE false
676 :     | s #"c" = Sharing.DONTSHARE
677 :     | s _ = raise Format
678 : blume 385 in
679 : blume 513 nonshare s
680 : blume 385 end
681 : blume 330
682 : blume 513 fun si () = let
683 :     fun s #"s" =
684 :     let val spec = string ()
685 :     val locs = string ()
686 :     val offset = int () + offset_adjustment
687 :     val sh_mode = shm ()
688 :     val error = EM.errorNoSource grpSrcInfo locs
689 :     in
690 :     BinInfo.new { group = group,
691 :     mkStablename = mksname,
692 :     error = error,
693 :     spec = spec,
694 :     offset = offset,
695 :     sh_mode = sh_mode }
696 :     end
697 :     | s _ = raise Format
698 :     in
699 :     share siM s
700 :     end
701 : blume 384
702 : blume 513 (* this is the place where what used to be an
703 :     * SNODE changes to a BNODE! *)
704 :     fun sn () = let
705 :     fun sn' #"a" =
706 :     DG.BNODE { bininfo = si (),
707 :     localimports = snlist (),
708 :     globalimports = fsbnlist () }
709 :     | sn' _ = raise Format
710 :     in
711 :     share snM sn'
712 :     end
713 : blume 330
714 : blume 513 and snlist () = list snListM sn ()
715 : blume 330
716 : blume 513 (* this one changes from farsbnode to plain farbnode *)
717 :     and sbn () = let
718 :     fun sbn' #"1" = DG.PNODE (primitive ())
719 :     | sbn' #"2" = let
720 :     val n = int ()
721 :     val sy = symbol ()
722 :     val (_, GG.GROUP { exports = slexp, ... }) =
723 :     List.nth (sublibs, n)
724 :     handle _ => raise Format
725 :     in
726 :     case SymbolMap.find (slexp, sy) of
727 :     SOME ((_, DG.SB_BNODE(n, _)), _) =>
728 :     (case n of
729 :     DG.BNODE _ => n
730 :     | _ => raise Format)
731 :     | _ => raise Format
732 :     end
733 :     | sbn' #"3" = sn ()
734 :     | sbn' _ = raise Format
735 :     in
736 :     share sbnM sbn'
737 :     end
738 : blume 384
739 : blume 513 and fsbn () = let
740 :     fun f #"f" = (filter (), sbn ())
741 :     | f _ = raise Format
742 :     in
743 :     share fsbnM f
744 :     end
745 :    
746 :     and fsbnlist () = list fsbnListM fsbn ()
747 :    
748 :     fun impexp () = let
749 :     fun ie #"i" =
750 :     let val sy = symbol ()
751 :     (* really reads farbnodes! *)
752 :     val (f, n) = fsbn ()
753 :     val ge = lazy_env ()
754 :     fun bs2es { env, ctxt } =
755 :     { env = GenericVC.CoerceEnv.bs2es env,
756 :     ctxt = ctxt }
757 :     val ge' = bs2es o ge
758 :     val ii = { statenv = Memoize.memoize ge',
759 :     symenv = lazy_symenv (),
760 :     statpid = pid (),
761 :     sympid = pid () }
762 :     val e = Statenv2DAEnv.cvtMemo (#env o ge)
763 :     (* put a filter in front to avoid having the
764 :     * FCTENV being queried needlessly (this
765 :     * avoids spurious module loadings) *)
766 :     val e' =
767 :     DAEnv.FILTER (SymbolSet.singleton sy, e)
768 :     in
769 :     (sy, ((f, DG.SB_BNODE (n, ii)), e'))
770 :     end
771 :     | ie _ = raise Format
772 :     in
773 :     share impexpM ie
774 :     end
775 :    
776 :     val impexplist = list impexpListM impexp
777 :    
778 :     fun r_exports () = let
779 :     fun e #"e" =
780 :     foldl SymbolMap.insert'
781 :     SymbolMap.empty (impexplist ())
782 :     | e _ = raise Format
783 :     in
784 :     share exportsM e
785 :     end
786 :    
787 :     val stringlist = list stringListM string
788 :    
789 :     fun privileges () = let
790 :     fun p #"p" =
791 :     StringSet.addList (StringSet.empty, stringlist ())
792 :     | p _ = raise Format
793 :     in
794 :     share privilegesM p
795 :     end
796 :    
797 :     val exports = r_exports ()
798 :     val required = privileges ()
799 :     in
800 :     GG.GROUP { exports = exports,
801 :     kind = GG.STABLELIB dropper,
802 :     required = required,
803 :     grouppath = group,
804 :     sublibs = sublibs }
805 :     end
806 :     | gr _ = raise Format
807 : blume 306 in
808 : blume 513 share groupM gr
809 : blume 306 end
810 : blume 304 in
811 : blume 361 SOME (SafeIO.perform { openIt = BinIO.openIn o mksname,
812 : blume 345 closeIt = BinIO.closeIn,
813 :     work = work,
814 : blume 459 cleanup = fn _ => () })
815 : blume 402 handle Format => (error ["file is corrupted (old version?)"];
816 :     NONE)
817 : blume 346 | IO.Io _ => NONE
818 : blume 345 end
819 : blume 304 end
820 : blume 309
821 :     end (* local *)

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