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 383, Tue Jul 20 06:05:56 1999 UTC revision 384, Wed Jul 21 08:54:00 1999 UTC
# Line 35  Line 35 
35                       val transfer_state : SmlInfo.info * BinInfo.info -> unit                       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
40        | PS of Symbol.symbol  
41        | PSN of DG.snode      infix 3 $
42        infixr 4 &
43        val op & = PU.&
44        val % = PU.%
45    
46      datatype uitem =      datatype uitem =
47          USS of SymbolSet.set          USS of SymbolSet.set
48        | US of Symbol.symbol        | US of Symbol.symbol
49        | UBN of DG.bnode        | UBN of DG.bnode
50    
51      fun compare (PS s, PS s') = SymbolOrdKey.compare (s, s')      structure SNMap = BinaryMapFn
52        | compare (PS _, _) = GREATER          (struct
53        | compare (_, PS _) = LESS               type ord_key = DG.snode
54        | compare (PSS s, PSS s') = SymbolSet.compare (s, s')               fun compare (DG.SNODE n, DG.SNODE n') =
       | compare (PSS _, _) = GREATER  
       | compare (_, PSS _) = LESS  
       | compare (PSN (DG.SNODE n), PSN (DG.SNODE n')) =  
55          SmlInfo.compare (#smlinfo n, #smlinfo n')          SmlInfo.compare (#smlinfo n, #smlinfo n')
   
     structure Map =  
         BinaryMapFn (struct  
                          type ord_key = pitem  
                          val compare = compare  
56          end)          end)
57    
58        val initMap = SNMap.empty
59        val SNs = { find = SNMap.find, insert = SNMap.insert }
60    
61      fun genStableInfoMap (exports, group) = let      fun genStableInfoMap (exports, group) = let
62          (* find all the exported bnodes that are in the same group: *)          (* find all the exported bnodes that are in the same group: *)
63          fun add (((_, DG.SB_BNODE (n as DG.BNODE b)), _), m) = let          fun add (((_, DG.SB_BNODE (n as DG.BNODE b)), _), m) = let
# Line 156  Line 154 
154                  (reg, get)                  (reg, get)
155              end              end
156    
157              fun w_list w_item [] k m =              val int = PU.w_int
158                  "0" :: k m              val symbol = PU.w_symbol
159                | w_list w_item [a] k m =              val share = PU.ah_share
160                  "1" :: w_item a k m              val option = PU.w_option
161                | w_list w_item [a, b] k m =              val list = PU.w_list
162                  "2" :: w_item a (w_item b k) m              val string = PU.w_string
163                | w_list w_item [a, b, c] k m =              val bool = PU.w_bool
164                  "3" :: w_item a (w_item b (w_item c k)) m              val int = PU.w_int
165                | w_list w_item [a, b, c, d] k m =  
166                  "4" :: w_item a (w_item b (w_item c (w_item d k))) m              val symbolset = list symbol o SymbolSet.listItems
167                | w_list w_item (a :: b :: c :: d :: e :: r) k m =  
168                  "5" :: w_item a (w_item b (w_item c (w_item d (w_item e              val filter = option symbolset
169                                                       (w_list w_item r k))))) m  
170                val sh = option bool        (* sharing *)
             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  
171    
172              fun w_si i k = let              fun si i = let
173                  (* FIXME: this is not a technical flaw, but perhaps one                  (* FIXME: this is not a technical flaw, but perhaps one
174                   * that deserves fixing anyway:  If we only look at spec,                   * that deserves fixing anyway:  If we only look at spec,
175                   * then we are losing information about sub-grouping                   * then we are losing information about sub-grouping
# Line 236  Line 180 
180                  val locs = SmlInfo.errorLocation gp i                  val locs = SmlInfo.errorLocation gp i
181                  val offset = registerOffset (i, bsz i)                  val offset = registerOffset (i, bsz i)
182              in              in
183                  w_string spec                  string spec & string locs & int offset & sh (SmlInfo.share i)
                    (w_string locs  
                          (w_int offset  
                                (w_sharing (SmlInfo.share i) k)))  
184              end              end
185    
186              fun w_primitive p k m =              fun primitive p =
187                  String.str (Primitive.toIdent primconf p) :: k m                  string (String.str (Primitive.toIdent primconf p))
188    
189              fun warn_relabs p abs = let              fun warn_relabs p abs = let
190                  val relabs = if abs then "absolute" else "relative"                  val relabs = if abs then "absolute" else "relative"
# Line 267  Line 208 
208                      ppb                      ppb
209              end              end
210    
211              fun w_abspath p k m =              fun abspath p = let
212                  w_list w_string (SrcPath.pickle (warn_relabs p) (p, grouppath))                  val pp = SrcPath.pickle (warn_relabs p) (p, grouppath)
213                                  k m              in
214                    list string pp
215                end
216    
217              fun w_bn (DG.PNODE p) k m = "p" :: w_primitive p k m              val BN = 1
218                | w_bn (DG.BNODE { bininfo = i, ... }) k m = let              val op $ = PU.$ BN
219                fun bn (DG.PNODE p) = "1" $ primitive p
220                  | bn (DG.BNODE { bininfo = i, ... }) = let
221                      val (n, sy) = valOf (StableMap.find (inverseMap, i))                      val (n, sy) = valOf (StableMap.find (inverseMap, i))
222                  in                  in
223                      "b" :: w_int n (w_symbol sy k) m                      "2" $ int n & symbol sy
224                  end                  end
225    
226              fun w_bool true k m = "t" :: k m              local
227                | w_bool false k m = "f" :: k m                  val SN = 2
228                    val SBN = 3
229              fun w_sn_raw (DG.SNODE n) k =              in
230                  w_si (#smlinfo n)                  fun sn n = let
231                       (w_list w_sn (#localimports n)                      fun raw_sn (DG.SNODE n) =
232                                    (w_list w_fsbn (#globalimports n) k))                          "a" $ si (#smlinfo n) & list sn (#localimports n) &
233                                  list fsbn (#globalimports n)
234              and w_sn n = w_share w_sn_raw PSN n                  in
235                        share SNs raw_sn n
236                    end
237    
238              and w_sbn (DG.SB_BNODE n) k m = "b" :: w_bn n k m                  and sbn x = let
239                | w_sbn (DG.SB_SNODE n) k m = "s" :: w_sn n k m                      val op $ = PU.$ SBN
240                    in
241                        case x of
242                            DG.SB_BNODE n => "a" $ bn n
243                          | DG.SB_SNODE n => "b" $ sn n
244                    end
245    
246              and w_fsbn (f, n) k = w_filter f (w_sbn n k)                  and fsbn (f, n) = filter f & sbn n
247                end
248    
249              fun w_impexp (s, (n, _)) k = w_symbol s (w_fsbn n k)              fun impexp (s, (n, _)) = symbol s & fsbn n
250    
251              fun w_exports e = w_list w_impexp (SymbolMap.listItemsi e)              fun w_exports e = list impexp (SymbolMap.listItemsi e)
252    
253              fun w_privileges p = w_list w_string (StringSet.listItems p)              fun privileges p = list string (StringSet.listItems p)
254    
255              fun pickle_group () = let              fun group () = let
256                  fun w_sg (GG.GROUP { grouppath, ... }) = w_abspath grouppath                  fun sg (GG.GROUP { grouppath, ... }) = abspath grouppath
                 fun k0 m = []  
                 val m0 = (0, Map.empty)  
257              in              in
258                  (* Pickle the sublibs first because we need to already                  (* Pickle the sublibs first because we need to already
259                   * have them back when we unpickle BNODEs. *)                   * have them back when we unpickle BNODEs. *)
260                  concat (w_list w_sg sublibs                  list sg sublibs & w_exports exports & privileges required
                             (w_exports exports  
                                  (w_privileges required k0)) m0)  
261              end              end
262    
263              val pickle = pickle_group ()              val pickle = PU.pickle initMap (group ())
264              val sz = size pickle              val sz = size pickle
265              val offset_adjustment = sz + 4              val offset_adjustment = sz + 4
266    
# Line 444  Line 393 
393              EM.COMPLAIN (concat ("(stable) " :: gdescr :: ": " :: l))              EM.COMPLAIN (concat ("(stable) " :: gdescr :: ": " :: l))
394              EM.nullErrorBody              EM.nullErrorBody
395    
396          exception Format          exception Format = UU.Format
397    
398          val pcmode = #pcmode (#param gp)          val pcmode = #pcmode (#param gp)
399          val policy = #fnpolicy (#param gp)          val policy = #fnpolicy (#param gp)
# Line 473  Line 422 
422              end              end
423    
424              val sz = LargeWord.toIntX (Pack32Big.subVec (bytesIn 4, 0))              val sz = LargeWord.toIntX (Pack32Big.subVec (bytesIn 4, 0))
425              val pickle = bytesIn sz              val pickle = Byte.bytesToString (bytesIn sz)
426              val offset_adjustment = sz + 4              val offset_adjustment = sz + 4
427    
428              val rd = let              val session = UU.mkSession (UU.stringReader 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  
   
             fun r_option r_item () =  
                 case rd () of  
                     #"n" => NONE  
                   | #"s" => SOME (r_item ())  
                   | _ => raise Format  
429    
430              fun r_int () = let              fun list m r = UU.r_list session m r
431                  fun loop n = let              fun option m r = UU.r_option session m r
432                      val w8 = Byte.charToByte (rd ())              val int = UU.r_int session
433                      val n' =              fun share m r = UU.share session m r
434                          n * 0w128 + Word8.toLargeWord (Word8.andb (w8, 0w127))              val string = UU.r_string session
435                  in              val symbol = UU.r_symbol session
436                      if Word8.andb (w8, 0w128) = 0w0 then n' else loop n'              val bool = UU.r_bool session
437                  end  
438              in              val stringListM = UU.mkMap ()
439                  LargeWord.toIntX (loop 0w0)              val symbolListM = UU.mkMap ()
440              end              val stringListM = UU.mkMap ()
441                val ssoM = UU.mkMap ()
442              fun r_share r_raw C unC () =              val boolOptionM = UU.mkMap ()
443                  case rd () of              val sgListM = UU.mkMap ()
444                      #"o" => (case IntBinaryMap.find (!m, r_int ()) of              val snM = UU.mkMap ()
445                                   SOME x => unC x              val snListM = UU.mkMap ()
446                                 | NONE => raise Format)              val bnM = UU.mkMap ()
447                    | #"n" => let              val sbnM = UU.mkMap ()
448                          val i = !next              val fsbnListM = UU.mkMap ()
449                          val _ = next := i + 1              val impexpListM = UU.mkMap ()
                         val v = r_raw ()  
                     in  
                         m := IntBinaryMap.insert (!m, i, C v);  
                         v  
                     end  
                   | _ => raise Format  
450    
451              fun r_string () = let              val stringlist = list stringListM string
                 fun loop l =  
                     case rd () of  
                         #"\"" => String.implode (rev l)  
                       | #"\\" => loop (rd () :: l)  
                       | c => loop (c :: l)  
             in  
                 loop []  
             end  
452    
453              fun r_abspath () =              fun abspath () =
454                  SrcPath.unpickle pcmode (r_list r_string (), group)                  SrcPath.unpickle pcmode (stringlist (), group)
455                  handle SrcPath.Format => raise Format                  handle SrcPath.Format => raise Format
456                       | SrcPath.BadAnchor a =>                       | SrcPath.BadAnchor a =>
457                         (error ["configuration anchor \"", a, "\" undefined"];                         (error ["configuration anchor \"", a, "\" undefined"];
458                          raise Format)                          raise Format)
459    
460                val symbollist = list symbolListM symbol
461    
462              val r_symbol = let              fun symbolset () =
463                  fun r_symbol_raw () = let                  SymbolSet.addList (SymbolSet.empty, symbollist ())
464                      val (ns, first) =  
465                          case rd () of              val filter = option ssoM symbolset
466                              #"'" => (Symbol.sigSymbol, rd ())  
467                            | #"(" => (Symbol.fctSymbol, rd ())              fun primitive () =
468                            | #")" => (Symbol.fsigSymbol, rd ())                  valOf (Primitive.fromIdent primconf
469                            | c => (Symbol.strSymbol, c)                            (String.sub (string (), 0)))
470                      fun loop (#".", l) = String.implode (rev l)                  handle _ => raise Format
                       | 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  
   
             val r_ss = let  
                 fun r_ss_raw () =  
                     SymbolSet.addList (SymbolSet.empty, r_list r_symbol ())  
                 fun unUSS (USS s) = s  
                   | unUSS _ = raise Format  
             in  
                 r_share r_ss_raw USS unUSS  
             end  
   
             val r_filter = r_option r_ss  
   
             fun r_primitive () =  
                 case Primitive.fromIdent primconf (rd ()) of  
                     NONE => raise Format  
                   | SOME p => p  
   
             fun r_sharing () =  
                 case rd () of  
                     #"n" => NONE  
                   | #"t" => SOME true  
                   | #"f" => SOME false  
                   | _ => raise Format  
471    
472              fun r_si () = let              val sh = option boolOptionM bool
473                  val spec = r_string ()  
474                  val locs = r_string ()              fun si () = let
475                  val offset = r_int () + offset_adjustment                  val spec = string ()
476                  val share = r_sharing ()                  val locs = string ()
477                    val offset = int () + offset_adjustment
478                    val share = sh ()
479                  val error = EM.errorNoSource grpSrcInfo locs                  val error = EM.errorNoSource grpSrcInfo locs
480              in              in
481                  BinInfo.new { group = group,                  BinInfo.new { group = group,
# Line 613  Line 486 
486                                share = share }                                share = share }
487              end              end
488    
489              fun r_sg () = getGroup' (r_abspath ())              fun sg () = getGroup' (abspath ())
490    
491              val sublibs = r_list r_sg ()              val sublibs = list sgListM sg ()
492    
493              fun r_bn () =              fun bn () = let
494                  case rd () of                  fun bn' #"1" = DG.PNODE (primitive ())
495                      #"p" => DG.PNODE (r_primitive ())                    | bn' #"2" = let
496                    | #"b" => let                          val n = int ()
497                          val n = r_int ()                          val sy = symbol ()
                         val sy = r_symbol ()  
498                          val GG.GROUP { exports = slexp, ... } =                          val GG.GROUP { exports = slexp, ... } =
499                              List.nth (sublibs, n) handle _ => raise Format                              List.nth (sublibs, n) handle _ => raise Format
500                      in                      in
# Line 630  Line 502 
502                              SOME ((_, DG.SB_BNODE (n as DG.BNODE _)), _) => n                              SOME ((_, DG.SB_BNODE (n as DG.BNODE _)), _) => n
503                            | _ => raise Format                            | _ => raise Format
504                      end                      end
505                    | _ => raise Format                    | bn' _ = raise Format
506                in
507                    share bnM bn'
508                end
509    
510              (* this is the place where what used to be an              (* this is the place where what used to be an
511               * SNODE changes to a BNODE! *)               * SNODE changes to a BNODE! *)
512              fun r_sn_raw () =              fun sn () = let
513                  DG.BNODE { bininfo = r_si (),                  fun sn' #"a" =
514                             localimports = r_list r_sn (),                      DG.BNODE { bininfo = si (),
515                             globalimports = r_list r_fsbn () }                                 localimports = snlist (),
516                                   globalimports = fsbnlist () }
517                      | sn' _ = raise Format
518                in
519                    share snM sn'
520                end
521    
522              and r_sn () =              and snlist () = list snListM sn ()
                 r_share r_sn_raw UBN (fn (UBN n) => n | _ => raise Format) ()  
523    
524              (* this one changes from farsbnode to plain farbnode *)              (* this one changes from farsbnode to plain farbnode *)
525              and r_sbn () =              and sbn () = let
526                  case rd () of                  fun sbn' #"a" = bn ()
527                      #"b" => r_bn ()                    | sbn' #"b" = sn ()
528                    | #"s" => r_sn ()                    | sbn' _ = raise Format
529                    | _ => raise Format              in
530                    share sbnM sbn'
531                end
532    
533              and r_fsbn () = (r_filter (), r_sbn ())              and fsbn () = (filter (), sbn ())
534    
535              fun r_impexp () = let              and fsbnlist () = list fsbnListM fsbn ()
536                  val sy = r_symbol ()  
537                  val (f, n) = r_fsbn ()  (* really reads farbnodes! *)              fun impexp () = let
538                    val sy = symbol ()
539                    val (f, n) = fsbn ()    (* really reads farbnodes! *)
540                  val e = bn2env n                  val e = bn2env n
541                  (* put a filter in front to avoid having the FCTENV being                  (* put a filter in front to avoid having the FCTENV being
542                   * queried needlessly (this avoids spurious module loadings) *)                   * queried needlessly (this avoids spurious module loadings) *)
# Line 662  Line 545 
545                  (sy, ((f, DG.SB_BNODE n), e')) (* coerce to farsbnodes *)                  (sy, ((f, DG.SB_BNODE n), e')) (* coerce to farsbnodes *)
546              end              end
547    
548                val impexplist = list impexpListM impexp
549    
550              fun r_exports () =              fun r_exports () =
551                  foldl SymbolMap.insert' SymbolMap.empty (r_list r_impexp ())                  foldl SymbolMap.insert' SymbolMap.empty (impexplist ())
552    
553                val stringlist = list stringListM string
554    
555              fun r_privileges () =              fun privileges () =
556                  StringSet.addList (StringSet.empty, r_list r_string ())                  StringSet.addList (StringSet.empty, stringlist ())
557    
558              val exports = r_exports ()              val exports = r_exports ()
559              val required = r_privileges ()              val required = privileges ()
560              val simap = genStableInfoMap (exports, group)              val simap = genStableInfoMap (exports, group)
561          in          in
562              GG.GROUP { exports = exports,              GG.GROUP { exports = exports,

Legend:
Removed from v.383  
changed lines
  Added in v.384

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