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 393 - (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 310
18 :     type statenvgetter = GP.info -> DG.bnode -> E.staticEnv
19 : blume 314 type recomp = GP.info -> GG.group -> bool
20 : blume 357 type pid = Pid.persstamp
21 : blume 309 in
22 : blume 304
23 : blume 309 signature STABILIZE = sig
24 :    
25 :     val loadStable :
26 : blume 354 GP.info * (SrcPath.t -> GG.group option) * bool ref ->
27 :     SrcPath.t -> GG.group option
28 : blume 309
29 :     val stabilize :
30 : blume 311 GP.info -> { group: GG.group, anyerrors: bool ref } ->
31 : blume 310 GG.group option
32 : blume 309 end
33 :    
34 : blume 311 functor StabilizeFn (val bn2statenv : statenvgetter
35 : blume 363 val transfer_state : SmlInfo.info * BinInfo.info -> unit
36 : blume 357 val recomp : recomp) :> STABILIZE = struct
37 : blume 309
38 : blume 385 structure SSMap = BinaryMapFn
39 :     (struct
40 :     type ord_key = SymbolSet.set
41 :     val compare = SymbolSet.compare
42 :     end)
43 :    
44 : blume 384 structure SNMap = BinaryMapFn
45 :     (struct
46 :     type ord_key = DG.snode
47 :     fun compare (DG.SNODE n, DG.SNODE n') =
48 :     SmlInfo.compare (#smlinfo n, #smlinfo n')
49 : blume 304 end)
50 :    
51 : blume 385 type 'a maps = { ss: 'a SSMap.map, sn: 'a SNMap.map }
52 : blume 384
53 : blume 385 val initMap = { ss = SSMap.empty, sn = SNMap.empty }
54 : blume 393
55 :     structure PU = PickleUtilFn (type 'a map = 'a maps val emptyMap = initMap)
56 :     structure PSym = PickleSymbolFn (structure PU = PU)
57 :     structure UU = UnpickleUtil
58 :    
59 :     infix 3 $
60 :     infixr 4 &
61 :     val op & = PU.&
62 :     val % = PU.%
63 :    
64 :     (* type info *)
65 :     val (BN, SN, SBN, SS, SI, FSBN, IMPEXP, SHM) = (1, 2, 3, 4, 5, 6, 7, 8)
66 :    
67 : blume 385 val SSs = { find = fn (m: 'a maps, k) => SSMap.find (#ss m, k),
68 :     insert = fn ({ ss, sn }, k, v) =>
69 :     { sn = sn, ss = SSMap.insert (ss, k, v) } }
70 :     val SNs = { find = fn (m: 'a maps, k) => SNMap.find (#sn m, k),
71 :     insert = fn ({ ss, sn }, k, v) =>
72 :     { ss = ss, sn = SNMap.insert (sn, k, v) } }
73 :    
74 : blume 308 fun genStableInfoMap (exports, group) = let
75 :     (* find all the exported bnodes that are in the same group: *)
76 :     fun add (((_, DG.SB_BNODE (n as DG.BNODE b)), _), m) = let
77 :     val i = #bininfo b
78 :     in
79 : blume 354 if SrcPath.compare (BinInfo.group i, group) = EQUAL then
80 : blume 308 IntBinaryMap.insert (m, BinInfo.offset i, n)
81 :     else m
82 :     end
83 :     | add (_, m) = m
84 :     in
85 :     SymbolMap.foldl add IntBinaryMap.empty exports
86 :     end
87 :    
88 : blume 311 fun stabilize gp { group = g as GG.GROUP grec, anyerrors } = let
89 : blume 304
90 : blume 323 val primconf = #primconf (#param gp)
91 :     val policy = #fnpolicy (#param gp)
92 :    
93 : blume 340 val grouppath = #grouppath grec
94 :    
95 : blume 348 fun doit wrapped = let
96 : blume 312
97 : blume 314 val _ =
98 : blume 348 if StringSet.isEmpty wrapped then ()
99 : blume 314 else
100 :     Say.say ("$Stabilize: wrapping the following privileges:\n"
101 : blume 312 :: map (fn s => (" " ^ s ^ "\n"))
102 : blume 348 (StringSet.listItems wrapped))
103 : blume 312
104 : blume 354 val bname = SmlInfo.binname
105 : blume 311 val bsz = OS.FileSys.fileSize o bname
106 : blume 345
107 : blume 311 fun cpb s i = let
108 : blume 360 val N = 4096
109 : blume 345 fun copy ins = let
110 :     fun cp () =
111 :     if BinIO.endOfStream ins then ()
112 : blume 360 else (BinIO.output (s, BinIO.inputN (ins, N));
113 :     cp ())
114 : blume 345 in
115 :     cp ()
116 :     end
117 : blume 311 in
118 : blume 345 SafeIO.perform { openIt = fn () => BinIO.openIn (bname i),
119 :     closeIt = BinIO.closeIn,
120 :     work = copy,
121 :     cleanup = fn () => () }
122 : blume 311 end
123 : blume 310
124 : blume 311 val grpSrcInfo = (#errcons gp, anyerrors)
125 : blume 308
126 : blume 311 val exports = #exports grec
127 : blume 348 val required = StringSet.difference (#required grec, wrapped)
128 : blume 340 val sublibs = #sublibs grec
129 : blume 304
130 : blume 311 (* The format of a stable archive is the following:
131 :     * - It starts with the size s of the pickled dependency
132 :     * graph. This size itself is written as four-byte string.
133 :     * - 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 :     * s + 4. The pickled dependency graph also contains integer
137 :     * offsets relative to other stable groups. These offsets
138 :     * need no further adjustment.
139 :     * - Individual binfile contents (concatenated).
140 :     *)
141 : blume 304
142 : blume 340 (* Here we build a mapping that maps each BNODE to a number
143 :     * representing the sub-library that it came from and a
144 :     * representative symbol that can be used to find the BNODE
145 :     * within the exports of that library *)
146 :     fun oneB i (sy, ((_, DG.SB_BNODE (DG.BNODE n)), _), m) =
147 :     StableMap.insert (m, #bininfo n, (i, sy))
148 :     | oneB i (_, _, m) = m
149 : blume 380 fun oneSL ((g as GG.GROUP { exports, ... }), (m, i)) =
150 : blume 340 (SymbolMap.foldli (oneB i) m exports, i + 1)
151 :     val inverseMap = #1 (foldl oneSL (StableMap.empty, 0) sublibs)
152 : blume 330
153 : blume 311 val members = ref []
154 :     val (registerOffset, getOffset) = let
155 :     val dict = ref SmlInfoMap.empty
156 :     val cur = ref 0
157 :     fun reg (i, sz) = let
158 :     val os = !cur
159 : blume 306 in
160 : blume 311 cur := os + sz;
161 :     dict := SmlInfoMap.insert (!dict, i, os);
162 :     members := i :: (!members);
163 :     os
164 : blume 306 end
165 : blume 311 fun get i = valOf (SmlInfoMap.find (!dict, i))
166 :     in
167 :     (reg, get)
168 :     end
169 : blume 304
170 : blume 384 val int = PU.w_int
171 : blume 393 val symbol = PSym.w_symbol
172 : blume 384 val share = PU.ah_share
173 :     val option = PU.w_option
174 :     val list = PU.w_list
175 :     val string = PU.w_string
176 :     val bool = PU.w_bool
177 :     val int = PU.w_int
178 : blume 304
179 : blume 385 fun symbolset ss = let
180 :     val op $ = PU.$ SS
181 :     fun raw_ss ss = "s" $ list symbol (SymbolSet.listItems ss)
182 :     in
183 :     share SSs raw_ss ss
184 :     end
185 : blume 304
186 : blume 384 val filter = option symbolset
187 : blume 304
188 : blume 387 fun shm (Sharing.SHARE true) = %SHM "a"
189 :     | shm (Sharing.SHARE false) = %SHM "b"
190 :     | shm Sharing.DONTSHARE = %SHM "c"
191 : blume 304
192 : blume 384 fun si i = let
193 : blume 340 (* FIXME: this is not a technical flaw, but perhaps one
194 :     * that deserves fixing anyway: If we only look at spec,
195 :     * then we are losing information about sub-grouping
196 :     * within libraries. However, the spec in BinInfo.info
197 :     * is only used for diagnostics and has no impact on the
198 :     * operation of CM itself. *)
199 : blume 354 val spec = SrcPath.specOf (SmlInfo.sourcepath i)
200 : blume 311 val locs = SmlInfo.errorLocation gp i
201 :     val offset = registerOffset (i, bsz i)
202 : blume 387 val sh_mode = SmlInfo.sh_mode i
203 : blume 385 val op $ = PU.$ SI
204 : blume 311 in
205 : blume 387 "s" $ string spec & string locs & int offset & shm sh_mode
206 : blume 311 end
207 : blume 306
208 : blume 384 fun primitive p =
209 :     string (String.str (Primitive.toIdent primconf p))
210 : blume 306
211 : blume 340 fun warn_relabs p abs = let
212 :     val relabs = if abs then "absolute" else "relative"
213 : blume 330 fun ppb pps =
214 :     (PP.add_newline pps;
215 : blume 354 PP.add_string pps (SrcPath.descr p);
216 : blume 330 PP.add_newline pps;
217 :     PP.add_string pps
218 :     "(This means that in order to be able to use the result of stabilization";
219 :     PP.add_newline pps;
220 : blume 340 PP.add_string pps "the library must be in the same ";
221 : blume 330 PP.add_string pps relabs;
222 :     PP.add_string pps " location as it is now.)";
223 :     PP.add_newline pps)
224 :     in
225 :     EM.errorNoFile (#errcons gp, anyerrors) SM.nullRegion
226 :     EM.WARN
227 : blume 354 (concat [SrcPath.descr grouppath,
228 : blume 340 ": library referred to by ", relabs,
229 :     " pathname:"])
230 : blume 330 ppb
231 :     end
232 : blume 306
233 : blume 384 fun abspath p = let
234 :     val pp = SrcPath.pickle (warn_relabs p) (p, grouppath)
235 :     in
236 :     list string pp
237 :     end
238 : blume 306
239 : blume 384 val op $ = PU.$ BN
240 :     fun bn (DG.PNODE p) = "1" $ primitive p
241 :     | bn (DG.BNODE { bininfo = i, ... }) = let
242 : blume 340 val (n, sy) = valOf (StableMap.find (inverseMap, i))
243 :     in
244 : blume 384 "2" $ int n & symbol sy
245 : blume 340 end
246 : blume 306
247 : blume 385 fun sn n = let
248 :     fun raw_sn (DG.SNODE n) =
249 :     "a" $ si (#smlinfo n) & list sn (#localimports n) &
250 :     list fsbn (#globalimports n)
251 : blume 384 in
252 : blume 385 share SNs raw_sn n
253 :     end
254 : blume 306
255 : blume 385 and sbn x = let
256 :     val op $ = PU.$ SBN
257 :     in
258 :     case x of
259 :     DG.SB_BNODE n => "a" $ bn n
260 :     | DG.SB_SNODE n => "b" $ sn n
261 :     end
262 :    
263 :     and fsbn (f, n) = let
264 :     val op $ = PU.$ FSBN
265 :     in
266 :     "f" $ filter f & sbn n
267 :     end
268 : blume 370
269 : blume 385 fun impexp (s, (n, _)) = let
270 :     val op $ = PU.$ IMPEXP
271 :     in
272 :     "i" $ symbol s & fsbn n
273 : blume 384 end
274 : blume 307
275 : blume 384 fun w_exports e = list impexp (SymbolMap.listItemsi e)
276 : blume 306
277 : blume 384 fun privileges p = list string (StringSet.listItems p)
278 : blume 306
279 : blume 384 fun group () = let
280 :     fun sg (GG.GROUP { grouppath, ... }) = abspath grouppath
281 : blume 311 in
282 : blume 340 (* Pickle the sublibs first because we need to already
283 : blume 330 * have them back when we unpickle BNODEs. *)
284 : blume 384 list sg sublibs & w_exports exports & privileges required
285 : blume 311 end
286 : blume 308
287 : blume 393 val pickle = PU.pickle (group ())
288 : blume 311 val sz = size pickle
289 :     val offset_adjustment = sz + 4
290 : blume 308
291 : blume 361 fun mkStableGroup mksname = let
292 : blume 311 val m = ref SmlInfoMap.empty
293 :     fun sn (DG.SNODE (n as { smlinfo, ... })) =
294 :     case SmlInfoMap.find (!m, smlinfo) of
295 :     SOME n => n
296 :     | NONE => let
297 : blume 371 val li = map sn (#localimports n)
298 :     val gi = map fsbn (#globalimports n)
299 : blume 311 val sourcepath = SmlInfo.sourcepath smlinfo
300 : blume 340 (* FIXME: see the comment near the other
301 : blume 354 * occurence of SrcPath.spec... *)
302 :     val spec = SrcPath.specOf sourcepath
303 : blume 311 val offset =
304 :     getOffset smlinfo + offset_adjustment
305 : blume 387 val sh_mode = SmlInfo.sh_mode smlinfo
306 : blume 311 val locs = SmlInfo.errorLocation gp smlinfo
307 :     val error = EM.errorNoSource grpSrcInfo locs
308 :     val i = BinInfo.new { group = grouppath,
309 : blume 361 mkStablename = mksname,
310 : blume 311 spec = spec,
311 :     offset = offset,
312 : blume 387 sh_mode = sh_mode,
313 : blume 311 error = error }
314 :     val n = DG.BNODE { bininfo = i,
315 :     localimports = li,
316 :     globalimports = gi }
317 :     in
318 : blume 363 transfer_state (smlinfo, i);
319 : blume 311 m := SmlInfoMap.insert (!m, smlinfo, n);
320 :     n
321 :     end
322 : blume 308
323 : blume 311 and sbn (DG.SB_SNODE n) = sn n
324 :     | sbn (DG.SB_BNODE n) = n
325 : blume 308
326 : blume 311 and fsbn (f, n) = (f, sbn n)
327 : blume 308
328 : blume 311 fun impexp ((f, n), e) = ((f, DG.SB_BNODE (sbn n)), e)
329 : blume 308
330 : blume 311 val exports = SymbolMap.map impexp (#exports grec)
331 :     val simap = genStableInfoMap (exports, grouppath)
332 :     in
333 :     GG.GROUP { exports = exports,
334 : blume 348 kind = GG.STABLELIB simap,
335 : blume 311 required = required,
336 :     grouppath = grouppath,
337 : blume 348 sublibs = sublibs }
338 : blume 311 end
339 : blume 308
340 : blume 311 fun writeInt32 (s, i) = let
341 :     val a = Word8Array.array (4, 0w0)
342 :     val _ = Pack32Big.update (a, 0, LargeWord.fromInt i)
343 :     in
344 :     BinIO.output (s, Word8Array.extract (a, 0, NONE))
345 :     end
346 :     val memberlist = rev (!members)
347 :    
348 :     val gpath = #grouppath grec
349 : blume 361 fun mksname () = FilenamePolicy.mkStableName policy gpath
350 : blume 345 fun work outs =
351 : blume 354 (Say.vsay ["[stabilizing ", SrcPath.descr gpath, "]\n"];
352 : blume 311 writeInt32 (outs, sz);
353 :     BinIO.output (outs, Byte.stringToBytes pickle);
354 :     app (cpb outs) memberlist;
355 : blume 361 mkStableGroup mksname)
356 : blume 311 in
357 : blume 361 SOME (SafeIO.perform { openIt = AutoDir.openBinOut o mksname,
358 : blume 345 closeIt = BinIO.closeOut,
359 :     work = work,
360 : blume 354 cleanup = fn () =>
361 : blume 361 (OS.FileSys.remove (mksname ())
362 :     handle _ => ()) })
363 : blume 345 handle exn => NONE
364 : blume 311 end
365 :     in
366 : blume 348 case #kind grec of
367 :     GG.STABLELIB _ => SOME g
368 :     | GG.NOLIB => EM.impossible "stabilize: no library"
369 :     | GG.LIB wrapped =>
370 : blume 314 if not (recomp gp g) then
371 : blume 311 (anyerrors := true; NONE)
372 :     else let
373 : blume 380 fun notStable (GG.GROUP { kind, ... }) =
374 : blume 353 case kind of GG.STABLELIB _ => false | _ => true
375 : blume 308 in
376 : blume 340 case List.filter notStable (#sublibs grec) of
377 : blume 348 [] => doit wrapped
378 : blume 311 | l => let
379 :     val grammar = case l of [_] => " is" | _ => "s are"
380 :     fun ppb pps = let
381 :     fun loop [] = ()
382 : blume 380 | loop (GG.GROUP { grouppath, ... } :: t) =
383 : blume 311 (PP.add_string pps
384 : blume 354 (SrcPath.descr grouppath);
385 : blume 311 PP.add_newline pps;
386 :     loop t)
387 :     in
388 :     PP.add_newline pps;
389 :     PP.add_string pps
390 :     (concat ["because the following sub-group",
391 :     grammar, " not stable:"]);
392 :     PP.add_newline pps;
393 :     loop l
394 :     end
395 :     val errcons = #errcons gp
396 : blume 354 val gdescr = SrcPath.descr (#grouppath grec)
397 : blume 311 in
398 :     EM.errorNoFile (errcons, anyerrors) SM.nullRegion
399 :     EM.COMPLAIN
400 : blume 354 (gdescr ^ " cannot be stabilized")
401 : blume 311 ppb;
402 :     NONE
403 :     end
404 : blume 308 end
405 : blume 311 end
406 : blume 310
407 :     fun loadStable (gp, getGroup, anyerrors) group = let
408 : blume 306
409 : blume 355 val es2bs = GenericVC.CoerceEnv.es2bs
410 :     fun bn2env n =
411 :     Statenv2DAEnv.cvtMemo (fn () => es2bs (bn2statenv gp n))
412 : blume 308
413 : blume 311 val errcons = #errcons gp
414 :     val grpSrcInfo = (errcons, anyerrors)
415 : blume 354 val gdescr = SrcPath.descr group
416 : blume 311 fun error l = EM.errorNoFile (errcons, anyerrors) SM.nullRegion
417 : blume 367 EM.COMPLAIN (concat ("(stable) " :: gdescr :: ": " :: l))
418 :     EM.nullErrorBody
419 : blume 309
420 : blume 384 exception Format = UU.Format
421 : blume 306
422 : blume 318 val pcmode = #pcmode (#param gp)
423 : blume 310 val policy = #fnpolicy (#param gp)
424 : blume 323 val primconf = #primconf (#param gp)
425 : blume 361 fun mksname () = FilenamePolicy.mkStableName policy group
426 : blume 310
427 : blume 345 fun work s = let
428 : blume 310
429 : blume 345 fun getGroup' p =
430 :     case getGroup p of
431 :     SOME g => g
432 : blume 354 | NONE => (error ["unable to find ", SrcPath.descr p];
433 : blume 345 raise Format)
434 : blume 306
435 : blume 345 (* for getting sharing right... *)
436 :     val m = ref IntBinaryMap.empty
437 :     val next = ref 0
438 : blume 304
439 : blume 357 val pset = ref PidSet.empty
440 :    
441 : blume 345 fun bytesIn n = let
442 :     val bv = BinIO.inputN (s, n)
443 :     in
444 :     if n = Word8Vector.length bv then bv
445 :     else raise Format
446 :     end
447 : blume 304
448 : blume 345 val sz = LargeWord.toIntX (Pack32Big.subVec (bytesIn 4, 0))
449 : blume 384 val pickle = Byte.bytesToString (bytesIn sz)
450 : blume 345 val offset_adjustment = sz + 4
451 :    
452 : blume 391 val session = UU.mkSession (UU.stringGetter pickle)
453 : blume 304
454 : blume 384 fun list m r = UU.r_list session m r
455 :     fun option m r = UU.r_option session m r
456 :     val int = UU.r_int session
457 :     fun share m r = UU.share session m r
458 : blume 387 fun nonshare r = UU.nonshare session r
459 : blume 384 val string = UU.r_string session
460 : blume 393 val symbol = UnpickleSymbol.r_symbol (session, string)
461 : blume 384 val bool = UU.r_bool session
462 : blume 304
463 : blume 384 val stringListM = UU.mkMap ()
464 :     val symbolListM = UU.mkMap ()
465 :     val stringListM = UU.mkMap ()
466 : blume 385 val ssM = UU.mkMap ()
467 : blume 384 val ssoM = UU.mkMap ()
468 :     val boolOptionM = UU.mkMap ()
469 : blume 385 val siM = UU.mkMap ()
470 : blume 384 val sgListM = UU.mkMap ()
471 :     val snM = UU.mkMap ()
472 :     val snListM = UU.mkMap ()
473 :     val bnM = UU.mkMap ()
474 :     val sbnM = UU.mkMap ()
475 : blume 385 val fsbnM = UU.mkMap ()
476 : blume 384 val fsbnListM = UU.mkMap ()
477 : blume 385 val impexpM = UU.mkMap ()
478 : blume 384 val impexpListM = UU.mkMap ()
479 : blume 304
480 : blume 384 val stringlist = list stringListM string
481 : blume 304
482 : blume 384 fun abspath () =
483 :     SrcPath.unpickle pcmode (stringlist (), group)
484 : blume 367 handle SrcPath.Format => raise Format
485 :     | SrcPath.BadAnchor a =>
486 :     (error ["configuration anchor \"", a, "\" undefined"];
487 :     raise Format)
488 : blume 304
489 : blume 384 val symbollist = list symbolListM symbol
490 : blume 367
491 : blume 385 fun symbolset () = let
492 :     fun s #"s" = SymbolSet.addList (SymbolSet.empty, symbollist ())
493 :     | s _ = raise Format
494 :     in
495 :     share ssM s
496 :     end
497 : blume 305
498 : blume 384 val filter = option ssoM symbolset
499 : blume 305
500 : blume 384 fun primitive () =
501 :     valOf (Primitive.fromIdent primconf
502 :     (String.sub (string (), 0)))
503 :     handle _ => raise Format
504 : blume 305
505 : blume 387 fun shm () = let
506 :     fun s #"a" = Sharing.SHARE true
507 :     | s #"b" = Sharing.SHARE false
508 :     | s #"c" = Sharing.DONTSHARE
509 :     | s _ = raise Format
510 :     in
511 :     nonshare s
512 :     end
513 : blume 305
514 : blume 384 fun si () = let
515 : blume 385 fun s #"s" =
516 :     let val spec = string ()
517 :     val locs = string ()
518 :     val offset = int () + offset_adjustment
519 : blume 387 val sh_mode = shm ()
520 : blume 385 val error = EM.errorNoSource grpSrcInfo locs
521 :     in
522 :     BinInfo.new { group = group,
523 :     mkStablename = mksname,
524 :     error = error,
525 :     spec = spec,
526 :     offset = offset,
527 : blume 387 sh_mode = sh_mode }
528 : blume 385 end
529 :     | s _ = raise Format
530 : blume 345 in
531 : blume 385 share siM s
532 : blume 345 end
533 : blume 306
534 : blume 384 fun sg () = getGroup' (abspath ())
535 : blume 345
536 : blume 384 val sublibs = list sgListM sg ()
537 : blume 307
538 : blume 384 fun bn () = let
539 :     fun bn' #"1" = DG.PNODE (primitive ())
540 :     | bn' #"2" = let
541 :     val n = int ()
542 :     val sy = symbol ()
543 : blume 380 val GG.GROUP { exports = slexp, ... } =
544 : blume 340 List.nth (sublibs, n) handle _ => raise Format
545 : blume 330 in
546 : blume 340 case SymbolMap.find (slexp, sy) of
547 : blume 330 SOME ((_, DG.SB_BNODE (n as DG.BNODE _)), _) => n
548 :     | _ => raise Format
549 :     end
550 : blume 384 | bn' _ = raise Format
551 :     in
552 :     share bnM bn'
553 :     end
554 : blume 306
555 : blume 330 (* this is the place where what used to be an
556 :     * SNODE changes to a BNODE! *)
557 : blume 384 fun sn () = let
558 :     fun sn' #"a" =
559 :     DG.BNODE { bininfo = si (),
560 :     localimports = snlist (),
561 :     globalimports = fsbnlist () }
562 :     | sn' _ = raise Format
563 :     in
564 :     share snM sn'
565 :     end
566 : blume 306
567 : blume 384 and snlist () = list snListM sn ()
568 : blume 306
569 : blume 330 (* this one changes from farsbnode to plain farbnode *)
570 : blume 384 and sbn () = let
571 :     fun sbn' #"a" = bn ()
572 :     | sbn' #"b" = sn ()
573 :     | sbn' _ = raise Format
574 :     in
575 :     share sbnM sbn'
576 :     end
577 : blume 306
578 : blume 385 and fsbn () = let
579 :     fun f #"f" = (filter (), sbn ())
580 :     | f _ = raise Format
581 :     in
582 :     share fsbnM f
583 :     end
584 : blume 306
585 : blume 384 and fsbnlist () = list fsbnListM fsbn ()
586 :    
587 :     fun impexp () = let
588 : blume 385 fun ie #"i" =
589 :     let val sy = symbol ()
590 :     val (f, n) = fsbn () (* really reads farbnodes! *)
591 :     val e = bn2env n
592 :     (* put a filter in front to avoid having the FCTENV
593 :     * being queried needlessly (this avoids spurious
594 :     * module loadings) *)
595 :     val e' = DAEnv.FILTER (SymbolSet.singleton sy, e)
596 :     in
597 :     (* coerce to farsbnodes *)
598 :     (sy, ((f, DG.SB_BNODE n), e'))
599 :     end
600 :     | ie _ = raise Format
601 : blume 330 in
602 : blume 385 share impexpM ie
603 : blume 330 end
604 :    
605 : blume 384 val impexplist = list impexpListM impexp
606 :    
607 : blume 330 fun r_exports () =
608 : blume 384 foldl SymbolMap.insert' SymbolMap.empty (impexplist ())
609 : blume 330
610 : blume 384 val stringlist = list stringListM string
611 : blume 330
612 : blume 384 fun privileges () =
613 :     StringSet.addList (StringSet.empty, stringlist ())
614 :    
615 : blume 306 val exports = r_exports ()
616 : blume 384 val required = privileges ()
617 : blume 308 val simap = genStableInfoMap (exports, group)
618 : blume 306 in
619 :     GG.GROUP { exports = exports,
620 : blume 348 kind = GG.STABLELIB simap,
621 : blume 306 required = required,
622 : blume 308 grouppath = group,
623 : blume 348 sublibs = sublibs }
624 : blume 306 end
625 : blume 304 in
626 : blume 361 SOME (SafeIO.perform { openIt = BinIO.openIn o mksname,
627 : blume 345 closeIt = BinIO.closeIn,
628 :     work = work,
629 :     cleanup = fn () => () })
630 :     handle Format => NONE
631 : blume 346 | IO.Io _ => NONE
632 : blume 345 end
633 : blume 304 end
634 : blume 309
635 :     end (* local *)

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