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

SCM Repository

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

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

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 345, Sun Jun 20 11:55:26 1999 UTC revision 391, Fri Jul 30 07:23:56 1999 UTC
# Line 13  Line 13 
13      structure SM = GenericVC.SourceMap      structure SM = GenericVC.SourceMap
14      structure GP = GeneralParams      structure GP = GeneralParams
15      structure E = GenericVC.Environment      structure E = GenericVC.Environment
16        structure Pid = GenericVC.PersStamps
17    
18      type statenvgetter = GP.info -> DG.bnode -> E.staticEnv      type statenvgetter = GP.info -> DG.bnode -> E.staticEnv
19      type recomp = GP.info -> GG.group -> bool      type recomp = GP.info -> GG.group -> bool
20        type pid = Pid.persstamp
21  in  in
22    
23  signature STABILIZE = sig  signature STABILIZE = sig
24    
25      val loadStable :      val loadStable :
26          GP.info * (AbsPath.t -> GG.group option) * bool ref ->          GP.info * (SrcPath.t -> GG.group option) * bool ref ->
27          AbsPath.t -> GG.group option          SrcPath.t -> GG.group option
28    
29      val stabilize :      val stabilize :
30          GP.info -> { group: GG.group, anyerrors: bool ref } ->          GP.info -> { group: GG.group, anyerrors: bool ref } ->
# Line 30  Line 32 
32  end  end
33    
34  functor StabilizeFn (val bn2statenv : statenvgetter  functor StabilizeFn (val bn2statenv : statenvgetter
35                         val transfer_state : SmlInfo.info * BinInfo.info -> unit
36                       val recomp: recomp) :> STABILIZE = struct                       val recomp: recomp) :> STABILIZE = struct
37    
38      datatype pitem =      structure PU = PickleUtil
39          PSS of SymbolSet.set      structure UU = UnpickleUtil
       | PS of Symbol.symbol  
       | PSN of DG.snode  
   
     datatype uitem =  
         USS of SymbolSet.set  
       | US of Symbol.symbol  
       | UBN of DG.bnode  
   
     fun compare (PS s, PS s') = SymbolOrdKey.compare (s, s')  
       | compare (PS _, _) = GREATER  
       | compare (_, PS _) = LESS  
       | compare (PSS s, PSS s') = SymbolSet.compare (s, s')  
       | compare (PSS _, _) = GREATER  
       | compare (_, PSS _) = LESS  
       | compare (PSN (DG.SNODE n), PSN (DG.SNODE n')) =  
         SmlInfo.compare (#smlinfo n, #smlinfo n')  
40    
41      structure Map =      infix 3 $
42          BinaryMapFn (struct      infixr 4 &
43                           type ord_key = pitem      val op & = PU.&
44                           val compare = compare      val % = PU.%
45    
46        (* type info *)
47        val (BN, SN, SBN, SS, SI, FSBN, IMPEXP, SHM) = (1, 2, 3, 4, 5, 6, 7, 8)
48    
49        structure SSMap = BinaryMapFn
50            (struct
51                 type ord_key = SymbolSet.set
52                 val compare = SymbolSet.compare
53          end)          end)
54    
55        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            end)
61    
62        type 'a maps = { ss: 'a SSMap.map, sn: 'a SNMap.map }
63    
64        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      fun genStableInfoMap (exports, group) = let      fun genStableInfoMap (exports, group) = let
73          (* find all the exported bnodes that are in the same group: *)          (* find all the exported bnodes that are in the same group: *)
74          fun add (((_, DG.SB_BNODE (n as DG.BNODE b)), _), m) = let          fun add (((_, DG.SB_BNODE (n as DG.BNODE b)), _), m) = let
75              val i = #bininfo b              val i = #bininfo b
76          in          in
77              if AbsPath.compare (BinInfo.group i, group) = EQUAL then              if SrcPath.compare (BinInfo.group i, group) = EQUAL then
78                  IntBinaryMap.insert (m, BinInfo.offset i, n)                  IntBinaryMap.insert (m, BinInfo.offset i, n)
79              else m              else m
80          end          end
# Line 71  Line 83 
83          SymbolMap.foldl add IntBinaryMap.empty exports          SymbolMap.foldl add IntBinaryMap.empty exports
84      end      end
85    
     fun deleteFile n = OS.FileSys.remove n handle _ => ()  
   
86      fun stabilize gp { group = g as GG.GROUP grec, anyerrors } = let      fun stabilize gp { group = g as GG.GROUP grec, anyerrors } = let
87    
88          val primconf = #primconf (#param gp)          val primconf = #primconf (#param gp)
89          val policy = #fnpolicy (#param gp)          val policy = #fnpolicy (#param gp)
90    
91          val grouppath = #grouppath grec          val grouppath = #grouppath grec
         val groupdir = AbsPath.dir grouppath  
92    
93          fun doit granted = let          fun doit wrapped = let
94    
95              val _ =              val _ =
96                  if StringSet.isEmpty granted then ()                  if StringSet.isEmpty wrapped then ()
97                  else                  else
98                      Say.say ("$Stabilize: wrapping the following privileges:\n"                      Say.say ("$Stabilize: wrapping the following privileges:\n"
99                               :: map (fn s => ("  " ^ s ^ "\n"))                               :: map (fn s => ("  " ^ s ^ "\n"))
100                                      (StringSet.listItems granted))                                      (StringSet.listItems wrapped))
101    
102              val bname = AbsPath.name o SmlInfo.binpath              val bname = SmlInfo.binname
103              val bsz = OS.FileSys.fileSize o bname              val bsz = OS.FileSys.fileSize o bname
104    
105              fun cpb s i = let              fun cpb s i = let
106                    val N = 4096
107                  fun copy ins = let                  fun copy ins = let
108                      fun cp () =                      fun cp () =
109                          if BinIO.endOfStream ins then ()                          if BinIO.endOfStream ins then ()
110                          else (BinIO.output (s, BinIO.input ins); cp ())                          else (BinIO.output (s, BinIO.inputN (ins, N));
111                                  cp ())
112                  in                  in
113                      cp ()                      cp ()
114                  end                  end
# Line 111  Line 122 
122              val grpSrcInfo = (#errcons gp, anyerrors)              val grpSrcInfo = (#errcons gp, anyerrors)
123    
124              val exports = #exports grec              val exports = #exports grec
125              val islib = #islib grec              val required = StringSet.difference (#required grec, wrapped)
             val required = StringSet.difference (#required grec, granted)  
126              val sublibs = #sublibs grec              val sublibs = #sublibs grec
127    
128              (* The format of a stable archive is the following:              (* The format of a stable archive is the following:
# Line 134  Line 144 
144              fun oneB i (sy, ((_, DG.SB_BNODE (DG.BNODE n)), _), m) =              fun oneB i (sy, ((_, DG.SB_BNODE (DG.BNODE n)), _), m) =
145                  StableMap.insert (m, #bininfo n, (i, sy))                  StableMap.insert (m, #bininfo n, (i, sy))
146                | oneB i (_, _, m) = m                | oneB i (_, _, m) = m
147              fun oneSL ((_, g as GG.GROUP { exports, ... }), (m, i)) =              fun oneSL ((g as GG.GROUP { exports, ... }), (m, i)) =
148                  (SymbolMap.foldli (oneB i) m exports, i + 1)                  (SymbolMap.foldli (oneB i) m exports, i + 1)
149              val inverseMap = #1 (foldl oneSL (StableMap.empty, 0) sublibs)              val inverseMap = #1 (foldl oneSL (StableMap.empty, 0) sublibs)
150    
# Line 155  Line 165 
165                  (reg, get)                  (reg, get)
166              end              end
167    
168              fun w_list w_item [] k m =              val int = PU.w_int
169                  "0" :: k m              val symbol = PU.w_symbol
170                | w_list w_item [a] k m =              val share = PU.ah_share
171                  "1" :: w_item a k m              val option = PU.w_option
172                | w_list w_item [a, b] k m =              val list = PU.w_list
173                  "2" :: w_item a (w_item b k) m              val string = PU.w_string
174                | w_list w_item [a, b, c] k m =              val bool = PU.w_bool
175                  "3" :: w_item a (w_item b (w_item c k)) m              val int = PU.w_int
               | w_list w_item [a, b, c, d] k m =  
                 "4" :: w_item a (w_item b (w_item c (w_item d k))) m  
               | w_list w_item (a :: b :: c :: d :: e :: r) k m =  
                 "5" :: w_item a (w_item b (w_item c (w_item d (w_item e  
                                                      (w_list w_item r k))))) m  
   
             fun w_option w_item NONE k m = "n" :: k m  
               | w_option w_item (SOME i) k m = "s" :: w_item i k m  
   
             fun int_encode i = let  
                 (* this is the same mechanism that's also used in  
                  * TopLevel/batch/binfile.sml (maybe we should share it) *)  
                 val n = Word32.fromInt i  
                 val // = LargeWord.div  
                 val %% = LargeWord.mod  
                 val !! = LargeWord.orb  
                 infix // %% !!  
                 val toW8 = Word8.fromLargeWord  
                 fun r (0w0, l) = Word8Vector.fromList l  
                   | r (n, l) =  
                     r (n // 0w128, toW8 ((n %% 0w128) !! 0w128) :: l)  
             in  
                 Byte.bytesToString (r (n // 0w128, [toW8 (n %% 0w128)]))  
             end  
   
             fun w_int i k m = int_encode i :: k m  
   
             fun w_share w C v k (i, m) =  
                 case Map.find (m, C v) of  
                     SOME i' => "o" :: w_int i' k (i, m)  
                   | NONE => "n" :: w v k (i + 1, Map.insert (m, C v, i))  
   
             fun w_symbol_raw s k m = let  
                 val ns = case Symbol.nameSpace s of  
                     Symbol.SIGspace => "'"  
                   | Symbol.FCTspace => "("  
                   | Symbol.FSIGspace => ")"  
                   | Symbol.STRspace => ""  
                   | _ => GenericVC.ErrorMsg.impossible "stabilize:w_symbol"  
             in  
                 ns :: Symbol.name s :: "." :: k m  
             end  
   
             val w_symbol = w_share w_symbol_raw PS  
   
             val w_ss = w_share (w_list w_symbol o SymbolSet.listItems) PSS  
   
             val w_filter = w_option w_ss  
   
             fun w_string s k m = let  
                 fun esc #"\\" = "\\\\"  
                   | esc #"\"" = "\\\""  
                   | esc c = String.str c  
             in  
                 String.translate esc s :: "\"" :: k m  
             end  
   
             fun w_sharing NONE k m = "n" :: k m  
               | w_sharing (SOME true) k m = "t" :: k m  
               | w_sharing (SOME false) k m = "f" :: k m  
176    
177              fun w_si i k = let              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    
184                val filter = option symbolset
185    
186                fun shm (Sharing.SHARE true) = %SHM "a"
187                  | shm (Sharing.SHARE false) = %SHM "b"
188                  | shm Sharing.DONTSHARE = %SHM "c"
189    
190                fun si i = let
191                  (* FIXME: this is not a technical flaw, but perhaps one                  (* FIXME: this is not a technical flaw, but perhaps one
192                   * that deserves fixing anyway:  If we only look at spec,                   * that deserves fixing anyway:  If we only look at spec,
193                   * then we are losing information about sub-grouping                   * then we are losing information about sub-grouping
194                   * within libraries.  However, the spec in BinInfo.info                   * within libraries.  However, the spec in BinInfo.info
195                   * is only used for diagnostics and has no impact on the                   * is only used for diagnostics and has no impact on the
196                   * operation of CM itself. *)                   * operation of CM itself. *)
197                  val spec = AbsPath.spec (SmlInfo.sourcepath i)                  val spec = SrcPath.specOf (SmlInfo.sourcepath i)
198                  val locs = SmlInfo.errorLocation gp i                  val locs = SmlInfo.errorLocation gp i
199                  val offset = registerOffset (i, bsz i)                  val offset = registerOffset (i, bsz i)
200                    val sh_mode = SmlInfo.sh_mode i
201                    val op $ = PU.$ SI
202              in              in
203                  w_string spec                  "s" $ string spec & string locs & int offset & shm sh_mode
                    (w_string locs  
                          (w_int offset  
                                (w_sharing (SmlInfo.share i) k)))  
204              end              end
205    
206              fun w_primitive p k m =              fun primitive p =
207                  String.str (Primitive.toIdent primconf p) :: k m                  string (String.str (Primitive.toIdent primconf p))
208    
209              fun warn_relabs p abs = let              fun warn_relabs p abs = let
210                  val relabs = if abs then "absolute" else "relative"                  val relabs = if abs then "absolute" else "relative"
211                  fun ppb pps =                  fun ppb pps =
212                      (PP.add_newline pps;                      (PP.add_newline pps;
213                       PP.add_string pps (AbsPath.name p);                       PP.add_string pps (SrcPath.descr p);
214                       PP.add_newline pps;                       PP.add_newline pps;
215                       PP.add_string pps                       PP.add_string pps
216      "(This means that in order to be able to use the result of stabilization";      "(This means that in order to be able to use the result of stabilization";
# Line 260  Line 222 
222              in              in
223                  EM.errorNoFile (#errcons gp, anyerrors) SM.nullRegion                  EM.errorNoFile (#errcons gp, anyerrors) SM.nullRegion
224                      EM.WARN                      EM.WARN
225                      (concat [AbsPath.name grouppath,                      (concat [SrcPath.descr grouppath,
226                               ": library referred to by ", relabs,                               ": library referred to by ", relabs,
227                               " pathname:"])                               " pathname:"])
228                      ppb                      ppb
229              end              end
230    
231              fun w_abspath p k m =              fun abspath p = let
232                  w_list w_string (AbsPath.pickle (warn_relabs p) (p, groupdir))                  val pp = SrcPath.pickle (warn_relabs p) (p, grouppath)
233                                  k m              in
234                    list string pp
235                end
236    
237              fun w_bn (DG.PNODE p) k m = "p" :: w_primitive p k m              val op $ = PU.$ BN
238                | w_bn (DG.BNODE { bininfo = i, ... }) k m = let              fun bn (DG.PNODE p) = "1" $ primitive p
239                  | bn (DG.BNODE { bininfo = i, ... }) = let
240                      val (n, sy) = valOf (StableMap.find (inverseMap, i))                      val (n, sy) = valOf (StableMap.find (inverseMap, i))
241                  in                  in
242                      "b" :: w_int n (w_symbol sy k) m                      "2" $ int n & symbol sy
243                  end                  end
244    
245              fun w_sn_raw (DG.SNODE n) k =              fun sn n = let
246                  w_si (#smlinfo n)                  fun raw_sn (DG.SNODE n) =
247                       (w_list w_sn (#localimports n)                      "a" $ si (#smlinfo n) & list sn (#localimports n) &
248                               (w_list w_fsbn (#globalimports n) k))                      list fsbn (#globalimports n)
249                in
250              and w_sn n = w_share w_sn_raw PSN n                  share SNs raw_sn n
251                end
             and w_sbn (DG.SB_BNODE n) k m = "b" :: w_bn n k m  
               | w_sbn (DG.SB_SNODE n) k m = "s" :: w_sn n k m  
252    
253              and w_fsbn (f, n) k = w_filter f (w_sbn n k)              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              fun w_impexp (s, (n, _)) k = w_symbol s (w_fsbn n k)              and fsbn (f, n) = let
262                    val op $ = PU.$ FSBN
263                in
264                    "f" $ filter f & sbn n
265                end
266    
267              fun w_exports e = w_list w_impexp (SymbolMap.listItemsi e)              fun impexp (s, (n, _)) = let
268                    val op $ = PU.$ IMPEXP
269                in
270                    "i" $ symbol s & fsbn n
271                end
272    
273              fun w_bool true k m = "t" :: k m              fun w_exports e = list impexp (SymbolMap.listItemsi e)
               | w_bool false k m = "f" :: k m  
274    
275              fun w_privileges p = w_list w_string (StringSet.listItems p)              fun privileges p = list string (StringSet.listItems p)
276    
277              fun pickle_group () = let              fun group () = let
278                  fun w_sg (p, _) = w_abspath p                  fun sg (GG.GROUP { grouppath, ... }) = abspath grouppath
                 fun k0 m = []  
                 val m0 = (0, Map.empty)  
279              in              in
280                  (* Pickle the sublibs first because we need to already                  (* Pickle the sublibs first because we need to already
281                   * have them back when we unpickle BNODEs. *)                   * have them back when we unpickle BNODEs. *)
282                  concat (w_list w_sg sublibs                  list sg sublibs & w_exports exports & privileges required
                             (w_exports exports  
                                 (w_bool islib  
                                     (w_privileges required k0))) m0)  
283              end              end
284    
285              val pickle = pickle_group ()              val pickle = PU.pickle initMap (group ())
286              val sz = size pickle              val sz = size pickle
287              val offset_adjustment = sz + 4              val offset_adjustment = sz + 4
288    
289              fun mkStableGroup spath = let              fun mkStableGroup mksname = let
290                  val m = ref SmlInfoMap.empty                  val m = ref SmlInfoMap.empty
291                  fun sn (DG.SNODE (n as { smlinfo, ... })) =                  fun sn (DG.SNODE (n as { smlinfo, ... })) =
292                      case SmlInfoMap.find (!m, smlinfo) of                      case SmlInfoMap.find (!m, smlinfo) of
# Line 325  Line 296 
296                              val gi = map fsbn (#globalimports n)                              val gi = map fsbn (#globalimports n)
297                              val sourcepath = SmlInfo.sourcepath smlinfo                              val sourcepath = SmlInfo.sourcepath smlinfo
298                              (* FIXME: see the comment near the other                              (* FIXME: see the comment near the other
299                               * occurence of AbsPath.spec... *)                               * occurence of SrcPath.spec... *)
300                              val spec = AbsPath.spec sourcepath                              val spec = SrcPath.specOf sourcepath
301                              val offset =                              val offset =
302                                  getOffset smlinfo + offset_adjustment                                  getOffset smlinfo + offset_adjustment
303                              val share = SmlInfo.share smlinfo                              val sh_mode = SmlInfo.sh_mode smlinfo
304                              val locs = SmlInfo.errorLocation gp smlinfo                              val locs = SmlInfo.errorLocation gp smlinfo
305                              val error = EM.errorNoSource grpSrcInfo locs                              val error = EM.errorNoSource grpSrcInfo locs
306                              val i = BinInfo.new { group = grouppath,                              val i = BinInfo.new { group = grouppath,
307                                                    stablepath = spath,                                                    mkStablename = mksname,
308                                                    spec = spec,                                                    spec = spec,
309                                                    offset = offset,                                                    offset = offset,
310                                                    share = share,                                                    sh_mode = sh_mode,
311                                                    error = error }                                                    error = error }
312                              val n = DG.BNODE { bininfo = i,                              val n = DG.BNODE { bininfo = i,
313                                                 localimports = li,                                                 localimports = li,
314                                                 globalimports = gi }                                                 globalimports = gi }
315                          in                          in
316                                transfer_state (smlinfo, i);
317                              m := SmlInfoMap.insert (!m, smlinfo, n);                              m := SmlInfoMap.insert (!m, smlinfo, n);
318                              n                              n
319                          end                          end
# Line 357  Line 329 
329                  val simap = genStableInfoMap (exports, grouppath)                  val simap = genStableInfoMap (exports, grouppath)
330              in              in
331                  GG.GROUP { exports = exports,                  GG.GROUP { exports = exports,
332                             islib = islib,                             kind = GG.STABLELIB simap,
333                             required = required,                             required = required,
334                             grouppath = grouppath,                             grouppath = grouppath,
335                             sublibs = sublibs,                             sublibs = sublibs }
                            stableinfo = GG.STABLE simap }  
336              end              end
337    
338              fun writeInt32 (s, i) = let              fun writeInt32 (s, i) = let
# Line 373  Line 344 
344              val memberlist = rev (!members)              val memberlist = rev (!members)
345    
346              val gpath = #grouppath grec              val gpath = #grouppath grec
347              val spath = FilenamePolicy.mkStablePath policy gpath              fun mksname () = FilenamePolicy.mkStableName policy gpath
             fun delete () = deleteFile (AbsPath.name spath)  
348              fun work outs =              fun work outs =
349                  (Say.vsay ["[stabilizing ", AbsPath.name gpath, "]\n"];                  (Say.vsay ["[stabilizing ", SrcPath.descr gpath, "]\n"];
350                   writeInt32 (outs, sz);                   writeInt32 (outs, sz);
351                   BinIO.output (outs, Byte.stringToBytes pickle);                   BinIO.output (outs, Byte.stringToBytes pickle);
352                   app (cpb outs) memberlist;                   app (cpb outs) memberlist;
353                   mkStableGroup spath)                   mkStableGroup mksname)
354          in          in
355              SOME (SafeIO.perform { openIt = fn () => AbsPath.openBinOut spath,              SOME (SafeIO.perform { openIt = AutoDir.openBinOut o mksname,
356                                     closeIt = BinIO.closeOut,                                     closeIt = BinIO.closeOut,
357                                     work = work,                                     work = work,
358                                     cleanup = delete })                                     cleanup = fn () =>
359                                        (OS.FileSys.remove (mksname ())
360                                         handle _ => ()) })
361              handle exn => NONE              handle exn => NONE
362          end          end
363      in      in
364          case #stableinfo grec of          case #kind grec of
365              GG.STABLE _ => SOME g              GG.STABLELIB _ => SOME g
366            | GG.NONSTABLE granted =>            | GG.NOLIB => EM.impossible "stabilize: no library"
367              | GG.LIB wrapped =>
368                  if not (recomp gp g) then                  if not (recomp gp g) then
369                      (anyerrors := true; NONE)                      (anyerrors := true; NONE)
370                  else let                  else let
371                      fun notStable (_, GG.GROUP { stableinfo, ... }) =                      fun notStable (GG.GROUP { kind, ... }) =
372                          case stableinfo of                          case kind of GG.STABLELIB _ => false | _ => true
                             GG.STABLE _ => false  
                           | GG.NONSTABLE _ => true  
373                  in                  in
374                      case List.filter notStable (#sublibs grec) of                      case List.filter notStable (#sublibs grec) of
375                          [] => doit granted                          [] => doit wrapped
376                        | l => let                        | l => let
377                              val grammar = case l of [_] => " is" | _ => "s are"                              val grammar = case l of [_] => " is" | _ => "s are"
378                              fun ppb pps = let                              fun ppb pps = let
379                                  fun loop [] = ()                                  fun loop [] = ()
380                                    | loop ((p, GG.GROUP { grouppath, ... })                                    | loop (GG.GROUP { grouppath, ... } :: t) =
                                           :: t) =  
381                                      (PP.add_string pps                                      (PP.add_string pps
382                                          (AbsPath.name grouppath);                                          (SrcPath.descr grouppath);
                                      PP.add_string pps " (";  
                                      PP.add_string pps (AbsPath.name p);  
                                      PP.add_string pps ")";  
383                                       PP.add_newline pps;                                       PP.add_newline pps;
384                                       loop t)                                       loop t)
385                              in                              in
# Line 424  Line 391 
391                                  loop l                                  loop l
392                              end                              end
393                              val errcons = #errcons gp                              val errcons = #errcons gp
394                              val gname = AbsPath.name (#grouppath grec)                              val gdescr = SrcPath.descr (#grouppath grec)
395                          in                          in
396                              EM.errorNoFile (errcons, anyerrors) SM.nullRegion                              EM.errorNoFile (errcons, anyerrors) SM.nullRegion
397                                 EM.COMPLAIN                                 EM.COMPLAIN
398                                 (gname ^ " cannot be stabilized")                                 (gdescr ^ " cannot be stabilized")
399                                 ppb;                                 ppb;
400                              NONE                              NONE
401                          end                          end
# Line 437  Line 404 
404    
405      fun loadStable (gp, getGroup, anyerrors) group = let      fun loadStable (gp, getGroup, anyerrors) group = let
406    
407          val groupdir = AbsPath.dir group          val es2bs = GenericVC.CoerceEnv.es2bs
408          fun bn2env n = Statenv2DAEnv.cvtMemo (fn () => bn2statenv gp n)          fun bn2env n =
409                Statenv2DAEnv.cvtMemo (fn () => es2bs (bn2statenv gp n))
410    
411          val errcons = #errcons gp          val errcons = #errcons gp
412          val grpSrcInfo = (errcons, anyerrors)          val grpSrcInfo = (errcons, anyerrors)
413          val gname = AbsPath.name group          val gdescr = SrcPath.descr group
414          fun error l = EM.errorNoFile (errcons, anyerrors) SM.nullRegion          fun error l = EM.errorNoFile (errcons, anyerrors) SM.nullRegion
415              EM.COMPLAIN (concat (gname :: ": " :: l)) EM.nullErrorBody              EM.COMPLAIN (concat ("(stable) " :: gdescr :: ": " :: l))
416                EM.nullErrorBody
417    
418          exception Format          exception Format = UU.Format
419    
420          val pcmode = #pcmode (#param gp)          val pcmode = #pcmode (#param gp)
421          val policy = #fnpolicy (#param gp)          val policy = #fnpolicy (#param gp)
422          val primconf = #primconf (#param gp)          val primconf = #primconf (#param gp)
423          val spath = FilenamePolicy.mkStablePath policy group          fun mksname () = FilenamePolicy.mkStableName policy group
         val _ = Say.vsay ["[checking stable ", gname, "]\n"]  
424    
425          fun work s = let          fun work s = let
426    
427              fun getGroup' p =              fun getGroup' p =
428                  case getGroup p of                  case getGroup p of
429                      SOME g => g                      SOME g => g
430                    | NONE => (error ["unable to find ", AbsPath.name p];                    | NONE => (error ["unable to find ", SrcPath.descr p];
431                               raise Format)                               raise Format)
432    
433              (* for getting sharing right... *)              (* for getting sharing right... *)
434              val m = ref IntBinaryMap.empty              val m = ref IntBinaryMap.empty
435              val next = ref 0              val next = ref 0
436    
437                val pset = ref PidSet.empty
438    
439              fun bytesIn n = let              fun bytesIn n = let
440                  val bv = BinIO.inputN (s, n)                  val bv = BinIO.inputN (s, n)
441              in              in
# Line 474  Line 444 
444              end              end
445    
446              val sz = LargeWord.toIntX (Pack32Big.subVec (bytesIn 4, 0))              val sz = LargeWord.toIntX (Pack32Big.subVec (bytesIn 4, 0))
447              val pickle = bytesIn sz              val pickle = Byte.bytesToString (bytesIn sz)
448              val offset_adjustment = sz + 4              val offset_adjustment = sz + 4
449    
450              val rd = let              val session = UU.mkSession (UU.stringGetter pickle)
                 val pos = ref 0  
                 fun rd () = let  
                     val p = !pos  
                 in  
                     pos := p + 1;  
                     Byte.byteToChar (Word8Vector.sub (pickle, p))  
                     handle _ => raise Format  
                 end  
             in  
                 rd  
             end  
   
             fun r_list r () =  
                 case rd () of  
                     #"0" => []  
                   | #"1" => [r ()]  
                   | #"2" => [r (), r ()]  
                   | #"3" => [r (), r (), r ()]  
                   | #"4" => [r (), r (), r (), r ()]  
                   | #"5" => r () :: r () :: r () :: r () :: r () :: r_list r ()  
                   | _ => raise Format  
   
             fun r_bool () =  
                 case rd () of  
                     #"t" => true  
                   | #"f" => false  
                   | _ => raise Format  
451    
452              fun r_option r_item () =              fun list m r = UU.r_list session m r
453                  case rd () of              fun option m r = UU.r_option session m r
454                      #"n" => NONE              val int = UU.r_int session
455                    | #"s" => SOME (r_item ())              fun share m r = UU.share session m r
456                    | _ => raise Format              fun nonshare r = UU.nonshare session r
457                val string = UU.r_string session
458                val symbol = UU.r_symbol session
459                val bool = UU.r_bool session
460    
461                val stringListM = UU.mkMap ()
462                val symbolListM = UU.mkMap ()
463                val stringListM = UU.mkMap ()
464                val ssM = UU.mkMap ()
465                val ssoM = UU.mkMap ()
466                val boolOptionM = UU.mkMap ()
467                val siM = UU.mkMap ()
468                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                val fsbnM = UU.mkMap ()
474                val fsbnListM = UU.mkMap ()
475                val impexpM = UU.mkMap ()
476                val impexpListM = UU.mkMap ()
477    
478                val stringlist = list stringListM string
479    
480                fun abspath () =
481                    SrcPath.unpickle pcmode (stringlist (), group)
482                    handle SrcPath.Format => raise Format
483                         | SrcPath.BadAnchor a =>
484                           (error ["configuration anchor \"", a, "\" undefined"];
485                            raise Format)
486    
487              fun r_int () = let              val symbollist = list symbolListM symbol
                 fun loop n = let  
                     val w8 = Byte.charToByte (rd ())  
                     val n' =  
                         n * 0w128 + Word8.toLargeWord (Word8.andb (w8, 0w127))  
                 in  
                     if Word8.andb (w8, 0w128) = 0w0 then n' else loop n'  
                 end  
             in  
                 LargeWord.toIntX (loop 0w0)  
             end  
   
             fun r_share r_raw C unC () =  
                 case rd () of  
                     #"o" => (case IntBinaryMap.find (!m, r_int ()) of  
                                  SOME x => unC x  
                                | NONE => raise Format)  
                   | #"n" => let  
                         val i = !next  
                         val _ = next := i + 1  
                         val v = r_raw ()  
                     in  
                         m := IntBinaryMap.insert (!m, i, C v);  
                         v  
                     end  
                   | _ => raise Format  
488    
489              fun r_string () = let              fun symbolset () = let
490                  fun loop l =                  fun s #"s" = SymbolSet.addList (SymbolSet.empty, symbollist ())
491                      case rd () of                    | s _ = raise Format
                         #"\"" => String.implode (rev l)  
                       | #"\\" => loop (rd () :: l)  
                       | c => loop (c :: l)  
492              in              in
493                  loop []                  share ssM s
494              end              end
495    
496              fun r_abspath () =              val filter = option ssoM symbolset
                 case AbsPath.unpickle pcmode (r_list r_string (), groupdir) of  
                     SOME p => p  
                   | NONE => raise Format  
497    
498              val r_symbol = let              fun primitive () =
499                  fun r_symbol_raw () = let                  valOf (Primitive.fromIdent primconf
500                      val (ns, first) =                            (String.sub (string (), 0)))
501                          case rd () of                  handle _ => raise Format
                             #"`" => (Symbol.sigSymbol, rd ())  
                           | #"(" => (Symbol.fctSymbol, rd ())  
                           | #")" => (Symbol.fsigSymbol, rd ())  
                           | c => (Symbol.strSymbol, c)  
                     fun loop (#".", l) = String.implode (rev l)  
                       | loop (c, l) = loop (rd (), c :: l)  
                 in  
                     ns (loop (first, []))  
                 end  
                 fun unUS (US x) = x  
                   | unUS _ = raise Format  
             in  
                 r_share r_symbol_raw US unUS  
             end  
502    
503              val r_ss = let              fun shm () = let
504                  fun r_ss_raw () =                  fun s #"a" = Sharing.SHARE true
505                      SymbolSet.addList (SymbolSet.empty, r_list r_symbol ())                    | s #"b" = Sharing.SHARE false
506                  fun unUSS (USS s) = s                    | s #"c" = Sharing.DONTSHARE
507                    | unUSS _ = raise Format                    | s _ = raise Format
508              in              in
509                  r_share r_ss_raw USS unUSS                  nonshare s
510              end              end
511    
512              val r_filter = r_option r_ss              fun si () = let
513                    fun s #"s" =
514              fun r_primitive () =                      let val spec = string ()
515                  case Primitive.fromIdent primconf (rd ()) of                          val locs = string ()
516                      NONE => raise Format                          val offset = int () + offset_adjustment
517                    | SOME p => p                          val sh_mode = shm ()
   
             fun r_sharing () =  
                 case rd () of  
                     #"n" => NONE  
                   | #"t" => SOME true  
                   | #"f" => SOME false  
                   | _ => raise Format  
   
             fun r_si () = let  
                 val spec = r_string ()  
                 val locs = r_string ()  
                 val offset = r_int () + offset_adjustment  
                 val share = r_sharing ()  
518                  val error = EM.errorNoSource grpSrcInfo locs                  val error = EM.errorNoSource grpSrcInfo locs
519              in              in
520                  BinInfo.new { group = group,                  BinInfo.new { group = group,
521                                stablepath = spath,                                        mkStablename = mksname,
522                                error = error,                                error = error,
523                                spec = spec,                                spec = spec,
524                                offset = offset,                                offset = offset,
525                                share = share }                                        sh_mode = sh_mode }
526              end              end
527                      | s _ = raise Format
             fun r_sg () = let  
                 val p = r_abspath ()  
528              in              in
529                  (p, getGroup' p)                  share siM s
530              end              end
531    
532              val sublibs = r_list r_sg ()              fun sg () = getGroup' (abspath ())
533    
534              fun r_bn () =              val sublibs = list sgListM sg ()
535                  case rd () of  
536                      #"p" => DG.PNODE (r_primitive ())              fun bn () = let
537                    | #"b" => let                  fun bn' #"1" = DG.PNODE (primitive ())
538                          val n = r_int ()                    | bn' #"2" = let
539                          val sy = r_symbol ()                          val n = int ()
540                          val (_, GG.GROUP { exports = slexp, ... }) =                          val sy = symbol ()
541                            val GG.GROUP { exports = slexp, ... } =
542                              List.nth (sublibs, n) handle _ => raise Format                              List.nth (sublibs, n) handle _ => raise Format
543                      in                      in
544                          case SymbolMap.find (slexp, sy) of                          case SymbolMap.find (slexp, sy) of
545                              SOME ((_, DG.SB_BNODE (n as DG.BNODE _)), _) => n                              SOME ((_, DG.SB_BNODE (n as DG.BNODE _)), _) => n
546                            | _ => raise Format                            | _ => raise Format
547                      end                      end
548                    | _ => raise Format                    | bn' _ = raise Format
549                in
550                    share bnM bn'
551                end
552    
553              (* this is the place where what used to be an              (* this is the place where what used to be an
554               * SNODE changes to a BNODE! *)               * SNODE changes to a BNODE! *)
555              fun r_sn_raw () =              fun sn () = let
556                  DG.BNODE { bininfo = r_si (),                  fun sn' #"a" =
557                             localimports = r_list r_sn (),                      DG.BNODE { bininfo = si (),
558                             globalimports = r_list r_fsbn () }                                 localimports = snlist (),
559                                   globalimports = fsbnlist () }
560                      | sn' _ = raise Format
561                in
562                    share snM sn'
563                end
564    
565              and r_sn () =              and snlist () = list snListM sn ()
                 r_share r_sn_raw UBN (fn (UBN n) => n | _ => raise Format) ()  
566    
567              (* this one changes from farsbnode to plain farbnode *)              (* this one changes from farsbnode to plain farbnode *)
568              and r_sbn () =              and sbn () = let
569                  case rd () of                  fun sbn' #"a" = bn ()
570                      #"b" => r_bn ()                    | sbn' #"b" = sn ()
571                    | #"s" => r_sn ()                    | sbn' _ = raise Format
572                    | _ => raise Format              in
573                    share sbnM sbn'
574                end
575    
576                and fsbn () = let
577                    fun f #"f" = (filter (), sbn ())
578                      | f _ = raise Format
579                in
580                    share fsbnM f
581                end
582    
583              and r_fsbn () = (r_filter (), r_sbn ())              and fsbnlist () = list fsbnListM fsbn ()
584    
585              fun r_impexp () = let              fun impexp () = let
586                  val sy = r_symbol ()                  fun ie #"i" =
587                  val (f, n) = r_fsbn ()  (* really reads farbnodes! *)                      let val sy = symbol ()
588                            val (f, n) = fsbn () (* really reads farbnodes! *)
589                  val e = bn2env n                  val e = bn2env n
590                  (* put a filter in front to avoid having the FCTENV being                          (* put a filter in front to avoid having the FCTENV
591                   * queried needlessly (this avoids spurious module loadings) *)                           * being queried needlessly (this avoids spurious
592                             * module loadings) *)
593                  val e' = DAEnv.FILTER (SymbolSet.singleton sy, e)                  val e' = DAEnv.FILTER (SymbolSet.singleton sy, e)
594              in              in
595                  (sy, ((f, DG.SB_BNODE n), e')) (* coerce to farsbnodes *)                          (* coerce to farsbnodes *)
596                            (sy, ((f, DG.SB_BNODE n), e'))
597                        end
598                      | ie _ = raise Format
599                in
600                    share impexpM ie
601              end              end
602    
603                val impexplist = list impexpListM impexp
604    
605              fun r_exports () =              fun r_exports () =
606                  foldl SymbolMap.insert' SymbolMap.empty (r_list r_impexp ())                  foldl SymbolMap.insert' SymbolMap.empty (impexplist ())
607    
608                val stringlist = list stringListM string
609    
610              fun r_privileges () =              fun privileges () =
611                  StringSet.addList (StringSet.empty, r_list r_string ())                  StringSet.addList (StringSet.empty, stringlist ())
612    
613              val exports = r_exports ()              val exports = r_exports ()
614              val islib = r_bool ()              val required = privileges ()
             val required = r_privileges ()  
615              val simap = genStableInfoMap (exports, group)              val simap = genStableInfoMap (exports, group)
616          in          in
617              GG.GROUP { exports = exports,              GG.GROUP { exports = exports,
618                         islib = islib,                         kind = GG.STABLELIB simap,
619                         required = required,                         required = required,
620                         grouppath = group,                         grouppath = group,
621                         sublibs = sublibs,                         sublibs = sublibs }
                        stableinfo = GG.STABLE simap }  
622          end          end
623      in      in
624          SOME (SafeIO.perform { openIt = fn () => AbsPath.openBinIn spath,          SOME (SafeIO.perform { openIt = BinIO.openIn o mksname,
625                                 closeIt = BinIO.closeIn,                                 closeIt = BinIO.closeIn,
626                                 work = work,                                 work = work,
627                                 cleanup = fn () => () })                                 cleanup = fn () => () })
628          handle Format => NONE          handle Format => NONE
629                 | IO.Io _ => NONE
630      end      end
631  end  end
632    

Legend:
Removed from v.345  
changed lines
  Added in v.391

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