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

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