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

Legend:
Removed from v.360  
changed lines
  Added in v.432

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