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 512, Mon Dec 13 05:43:09 1999 UTC revision 513, Thu Dec 16 03:14:18 1999 UTC
# Line 64  Line 64 
64            patchback = fn (m: map, pm) => { ss = #ss m, sn = #sn m, pm = pm } }            patchback = fn (m: map, pm) => { ss = #ss m, sn = #sn m, pm = pm } }
65    
66      infix 3 $      infix 3 $
     infixr 4 &  
     val op & = PU.&  
     val % = PU.%  
67    
68      (* type info *)      (* type info *)
69      val (BN, SN, SBN, SS, SI, FSBN, IMPEXP, SHM) = (1, 2, 3, 4, 5, 6, 7, 8)      val (BN, SN, SBN, SS, SI, FSBN, IMPEXP, SHM, G, AP,
70             PRIM, EXPORTS, PRIV) =
71            (1001, 1002, 1003, 1004, 1005, 1006, 1007, 1008, 1009, 1010,
72             1011, 1012, 1013)
73    
74      val SSs =      val SSs =
75          { find = fn (m: map, k) => SSMap.find (#ss m, k),          { find = fn (m: map, k) => SSMap.find (#ss m, k),
# Line 275  Line 275 
275    
276              fun symbolset ss = let              fun symbolset ss = let
277                  val op $ = PU.$ SS                  val op $ = PU.$ SS
278                  fun raw_ss ss = "s" $ list symbol (SymbolSet.listItems ss)                  fun raw_ss ss = "s" $ [list symbol (SymbolSet.listItems ss)]
279              in              in
280                  share SSs raw_ss ss                  share SSs raw_ss ss
281              end              end
282    
283              val filter = option symbolset              val filter = option symbolset
284    
285              fun shm (Sharing.SHARE true) = %SHM "a"              val op $ = PU.$ SHM
286                | shm (Sharing.SHARE false) = %SHM "b"              fun shm (Sharing.SHARE true) = "a" $ []
287                | shm Sharing.DONTSHARE = %SHM "c"                | shm (Sharing.SHARE false) = "b" $ []
288                  | shm Sharing.DONTSHARE = "c" $ []
289    
290              fun si i = let              fun si i = let
291                  (* FIXME: this is not a technical flaw, but perhaps one                  (* FIXME: this is not a technical flaw, but perhaps one
# Line 299  Line 300 
300                  val sh_mode = SmlInfo.sh_mode i                  val sh_mode = SmlInfo.sh_mode i
301                  val op $ = PU.$ SI                  val op $ = PU.$ SI
302              in              in
303                  "s" $ string spec & string locs & int offset & shm sh_mode                  "s" $ [string spec, string locs, int offset, shm sh_mode]
304              end              end
305    
306              fun primitive p =              fun primitive p = let
307                  string (String.str (Primitive.toIdent primconf p))                  val op $ = PU.$ PRIM
308                in
309                    "p" $ [string (String.str (Primitive.toIdent primconf p))]
310                end
311    
312              fun warn_relabs p abs = let              fun warn_relabs p abs = let
313                  val relabs = if abs then "absolute" else "relative"                  val relabs = if abs then "absolute" else "relative"
# Line 328  Line 332 
332              end              end
333    
334              fun abspath p = let              fun abspath p = let
335                    val op $ = PU.$ AP
336                  val pp = SrcPath.pickle (warn_relabs p) (p, grouppath)                  val pp = SrcPath.pickle (warn_relabs p) (p, grouppath)
337              in              in
338                  list string pp                  "p" $ [list string pp]
339              end              end
340    
341              fun sn n = let              fun sn n = let
342                  val op $ = PU.$ SN                  val op $ = PU.$ SN
343                  fun raw_sn (DG.SNODE n) =                  fun raw_sn (DG.SNODE n) =
344                      "a" $ si (#smlinfo n) & list sn (#localimports n) &                      "a" $ [si (#smlinfo n), list sn (#localimports n),
345                      list fsbn (#globalimports n)                             list fsbn (#globalimports n)]
346              in              in
347                  share SNs raw_sn n                  share SNs raw_sn n
348              end              end
# Line 349  Line 354 
354              in              in
355                  case x of                  case x of
356                      DG.SB_BNODE (DG.PNODE p, { statenv = getE, ... }) =>                      DG.SB_BNODE (DG.PNODE p, { statenv = getE, ... }) =>
357                          "1" $ primitive p                          "1" $ [primitive p]
358                    | DG.SB_BNODE (DG.BNODE { bininfo = i, ... }, _) => let                    | DG.SB_BNODE (DG.BNODE { bininfo = i, ... }, _) => let
359                          val (n, sy) = valOf (StableMap.find (inverseMap, i))                          val (n, sy) = valOf (StableMap.find (inverseMap, i))
360                      in                      in
361                          "2" $ int n & symbol sy                          "2" $ [int n, symbol sy]
362                      end                      end
363                    | DG.SB_SNODE n => "3" $ sn n                    | DG.SB_SNODE n => "3" $ [sn n]
364              end              end
365    
366              and fsbn (f, n) = let              and fsbn (f, n) = let
367                  val op $ = PU.$ FSBN                  val op $ = PU.$ FSBN
368              in              in
369                  "f" $ filter f & sbn n                  "f" $ [filter f, sbn n]
370              end              end
371    
372              (* Here is the place where we need to write interface info. *)              (* Here is the place where we need to write interface info. *)
# Line 375  Line 380 
380                  fun es2bs { env, ctxt } =                  fun es2bs { env, ctxt } =
381                      { env = GenericVC.CoerceEnv.es2bs env, ctxt = ctxt }                      { env = GenericVC.CoerceEnv.es2bs env, ctxt = ctxt }
382              in              in
383                  "i" $ symbol s & fsbn n &                  "i" $ [symbol s, fsbn n,
384                        lazy_env (es2bs o statenv) &                         lazy_env (es2bs o statenv),
385                        lazy_symenv symenv &                         lazy_symenv symenv,
386                        pid statpid &                         pid statpid,
387                        pid sympid                         pid sympid]
388              end              end
389    
390              fun w_exports e = list impexp (SymbolMap.listItemsi e)              fun w_exports e = let
391                    val op $ = PU.$ EXPORTS
392                in
393                    "e" $ [list impexp (SymbolMap.listItemsi e)]
394                end
395    
396              fun privileges p = list string (StringSet.listItems p)              fun privileges p = let
397                    val op $ = PU.$ PRIV
398                in
399                    "p" $ [list string (StringSet.listItems p)]
400                end
401    
402              fun group () = let              fun group () = let
403                    val op $ = PU.$ G
404                  fun sg (p, g) = abspath p                  fun sg (p, g) = abspath p
405              in              in
406                  (* Pickle the sublibs first because we need to already                  (* Pickle the sublibs first because we need to already
407                   * have them back when we unpickle BNODEs. *)                   * have them back when we unpickle BNODEs. *)
408                  list sg sublibs & w_exports exports & privileges required                  "g" $ [list sg sublibs, w_exports exports, privileges required]
409              end              end
410    
411              val dg_pickle =              val dg_pickle =
# Line 555  Line 569 
569                  UU.stringGetter' (SOME dg_pickle, mkPickleFetcher mksname)                  UU.stringGetter' (SOME dg_pickle, mkPickleFetcher mksname)
570              val session = UU.mkSession getter              val session = UU.mkSession getter
571    
572                val sgListM = UU.mkMap ()
573                val stringListM = UU.mkMap ()
574                val stringListM = UU.mkMap ()
575                val ssM = UU.mkMap ()
576                val ssoM = UU.mkMap ()
577                val boolOptionM = UU.mkMap ()
578                val siM = UU.mkMap ()
579                val snM = UU.mkMap ()
580                val snListM = UU.mkMap ()
581                val sbnM = UU.mkMap ()
582                val fsbnM = UU.mkMap ()
583                val fsbnListM = UU.mkMap ()
584                val impexpM = UU.mkMap ()
585                val impexpListM = UU.mkMap ()
586                val groupM = UU.mkMap ()
587                val apM = UU.mkMap ()
588                val primitiveM = UU.mkMap ()
589                val exportsM = UU.mkMap ()
590                val privilegesM = UU.mkMap ()
591    
592              fun list m r = UU.r_list session m r              fun list m r = UU.r_list session m r
593              val string = UU.r_string session              val string = UU.r_string session
             val stringListM = UU.mkMap ()  
594              val stringlist = list stringListM string              val stringlist = list stringListM string
595    
596              fun abspath () =              fun option m r = UU.r_option session m r
597                  SrcPath.unpickle pcmode (stringlist (), group)              val int = UU.r_int session
598                fun share m r = UU.share session m r
599                fun nonshare r = UU.nonshare session r
600                val bool = UU.r_bool session
601                val pid = UnpickleSymPid.r_pid (session, string)
602    
603                fun abspath () = let
604                    fun ap #"p" =
605                        (SrcPath.unpickle pcmode (stringlist (), group)
606                  handle SrcPath.Format => raise Format                  handle SrcPath.Format => raise Format
607                       | SrcPath.BadAnchor a =>                       | SrcPath.BadAnchor a =>
608                         (error ["configuration anchor \"", a, "\" undefined"];                         (error ["configuration anchor \"", a, "\" undefined"];
609                          raise Format)                            raise Format))
610                      | ap _ = raise Format
611                in
612                    share apM ap
613                end
614    
615              fun sg () = let              fun sg () = let
616                  val p = abspath ()                  val p = abspath ()
617              in              in
618                  (p, getGroup' p)                  (p, getGroup' p)
619              end              end
620              val sgListM = UU.mkMap ()  
621              val sublibs = list sgListM sg ()              fun gr #"g" =
622                    let val sublibs = list sgListM sg ()
623    
624              (* Now that we have the list of sublibs, we can build the              (* Now that we have the list of sublibs, we can build the
625               * environment for unpickling the environment list.               * environment for unpickling the environment list.
# Line 581  Line 627 
627               * export list (making SB_BNODES). *)               * export list (making SB_BNODES). *)
628              fun prim_context "pv" = SOME (E.staticPart pervasive)              fun prim_context "pv" = SOME (E.staticPart pervasive)
629                | prim_context s =                | prim_context s =
630                  SOME (E.staticPart (Primitive.env primconf                          SOME (E.staticPart
631                                  (Primitive.env primconf
632                                      (valOf (Primitive.fromIdent primconf                                      (valOf (Primitive.fromIdent primconf
633                                              (String.sub (s, 0))))))                                              (String.sub (s, 0))))))
634                  handle _ => NONE                  handle _ => NONE
# Line 590  Line 637 
637                      List.nth (sublibs, n)                      List.nth (sublibs, n)
638              in              in
639                  case SymbolMap.find (slexp, sy) of                  case SymbolMap.find (slexp, sy) of
640                      SOME ((_, DG.SB_BNODE (_, { statenv = ge, ... })), _) =>                              SOME ((_, DG.SB_BNODE (_, x)), _) =>
641                          SOME (#env (ge ()))                                  SOME (#env (#statenv x ()))
642                    | _ => NONE                    | _ => NONE
643              end handle _ => NONE              end handle _ => NONE
644    
# Line 603  Line 650 
650              val lazy_symenv = UU.r_lazy session symenv              val lazy_symenv = UU.r_lazy session symenv
651              val lazy_env = UU.r_lazy session env              val lazy_env = UU.r_lazy session env
652    
             fun option m r = UU.r_option session m r  
             val int = UU.r_int session  
             fun share m r = UU.share session m r  
             fun nonshare r = UU.nonshare session r  
             val bool = UU.r_bool session  
             val pid = UnpickleSymPid.r_pid string  
   
             val stringListM = UU.mkMap ()  
             val ssM = UU.mkMap ()  
             val ssoM = UU.mkMap ()  
             val boolOptionM = UU.mkMap ()  
             val siM = UU.mkMap ()  
             val snM = UU.mkMap ()  
             val snListM = UU.mkMap ()  
             val sbnM = UU.mkMap ()  
             val fsbnM = UU.mkMap ()  
             val fsbnListM = UU.mkMap ()  
             val impexpM = UU.mkMap ()  
             val impexpListM = UU.mkMap ()  
   
653              fun symbolset () = let              fun symbolset () = let
654                  fun s #"s" = SymbolSet.addList (SymbolSet.empty, symbollist ())                          fun s #"s" =
655                                SymbolSet.addList (SymbolSet.empty, symbollist ())
656                    | s _ = raise Format                    | s _ = raise Format
657              in              in
658                  share ssM s                  share ssM s
# Line 632  Line 660 
660    
661              val filter = option ssoM symbolset              val filter = option ssoM symbolset
662    
663              fun primitive () =                      fun primitive () = let
664                  valOf (Primitive.fromIdent primconf                          fun p #"p" =
665                                (valOf (Primitive.fromIdent primconf
666                            (String.sub (string (), 0)))                            (String.sub (string (), 0)))
667                  handle _ => raise Format                               handle _ => raise Format)
668                              | p _ = raise Format
669                        in
670                            share primitiveM p
671                        end
672    
673              fun shm () = let              fun shm () = let
674                  fun s #"a" = Sharing.SHARE true                  fun s #"a" = Sharing.SHARE true
# Line 687  Line 720 
720                          val n = int ()                          val n = int ()
721                          val sy = symbol ()                          val sy = symbol ()
722                          val (_, GG.GROUP { exports = slexp, ... }) =                          val (_, GG.GROUP { exports = slexp, ... }) =
723                              List.nth (sublibs, n) handle _ => raise Format                                      List.nth (sublibs, n)
724                                        handle _ => raise Format
725                      in                      in
726                          case SymbolMap.find (slexp, sy) of                          case SymbolMap.find (slexp, sy) of
727                              SOME ((_, DG.SB_BNODE (n as DG.BNODE _, _)), _) =>                                      SOME ((_, DG.SB_BNODE(n, _)), _) =>
728                                  n                                          (case n of
729                                                 DG.BNODE _ => n
730                                               | _ => raise Format)
731                            | _ => raise Format                            | _ => raise Format
732                      end                      end
733                    | sbn' #"3" = sn ()                    | sbn' #"3" = sn ()
# Line 712  Line 748 
748              fun impexp () = let              fun impexp () = let
749                  fun ie #"i" =                  fun ie #"i" =
750                      let val sy = symbol ()                      let val sy = symbol ()
751                          val (f, n) = fsbn () (* really reads farbnodes! *)                                  (* really reads farbnodes! *)
752                                    val (f, n) = fsbn ()
753                          val ge = lazy_env ()                          val ge = lazy_env ()
754                          fun bs2es { env, ctxt } =                          fun bs2es { env, ctxt } =
755                              { env = GenericVC.CoerceEnv.bs2es env,                              { env = GenericVC.CoerceEnv.bs2es env,
# Line 723  Line 760 
760                                     statpid = pid (),                                     statpid = pid (),
761                                     sympid = pid () }                                     sympid = pid () }
762                          val e = Statenv2DAEnv.cvtMemo (#env o ge)                          val e = Statenv2DAEnv.cvtMemo (#env o ge)
763                          (* put a filter in front to avoid having the FCTENV                                  (* put a filter in front to avoid having the
764                           * being queried needlessly (this avoids spurious                                   * FCTENV being queried needlessly (this
765                           * module loadings) *)                                   * avoids spurious module loadings) *)
766                          val e' = DAEnv.FILTER (SymbolSet.singleton sy, e)                                  val e' =
767                                        DAEnv.FILTER (SymbolSet.singleton sy, e)
768                      in                      in
769                          (sy, ((f, DG.SB_BNODE (n, ii)), e'))                          (sy, ((f, DG.SB_BNODE (n, ii)), e'))
770                      end                      end
# Line 738  Line 776 
776              val impexplist = list impexpListM impexp              val impexplist = list impexpListM impexp
777    
778              fun r_exports () = let              fun r_exports () = let
779                  val iel = impexplist ()                          fun e #"e" =
780                                foldl SymbolMap.insert'
781                                      SymbolMap.empty (impexplist ())
782                              | e _ = raise Format
783              in              in
784                  foldl SymbolMap.insert' SymbolMap.empty iel                          share exportsM e
785              end              end
786    
787              val stringlist = list stringListM string              val stringlist = list stringListM string
788    
789              fun privileges () =                      fun privileges () = let
790                            fun p #"p" =
791                  StringSet.addList (StringSet.empty, stringlist ())                  StringSet.addList (StringSet.empty, stringlist ())
792                              | p _ = raise Format
793                        in
794                            share privilegesM p
795                        end
796    
797              val exports = r_exports ()              val exports = r_exports ()
798              val required = privileges ()              val required = privileges ()
# Line 757  Line 803 
803                         grouppath = group,                         grouppath = group,
804                         sublibs = sublibs }                         sublibs = sublibs }
805          end          end
806                  | gr _ = raise Format
807            in
808                share groupM gr
809            end
810      in      in
811          SOME (SafeIO.perform { openIt = BinIO.openIn o mksname,          SOME (SafeIO.perform { openIt = BinIO.openIn o mksname,
812                                 closeIt = BinIO.closeIn,                                 closeIt = BinIO.closeIn,

Legend:
Removed from v.512  
changed lines
  Added in v.513

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