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

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