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/bootstrap/btcompile.sml
ViewVC logotype

Diff of /sml/trunk/src/cm/bootstrap/btcompile.sml

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

revision 568, Tue Mar 7 03:59:09 2000 UTC revision 569, Tue Mar 7 04:01:07 2000 UTC
# Line 6  Line 6 
6   *   *
7   * Author: Matthias Blume (blume@kurims.kyoto-u.ac.jp)   * Author: Matthias Blume (blume@kurims.kyoto-u.ac.jp)
8   *)   *)
9    local
10        structure EM = GenericVC.ErrorMsg
11        structure E = GenericVC.Environment
12        structure SE = GenericVC.CMStaticEnv
13        structure BE = GenericVC.BareEnvironment
14        structure PS = GenericVC.PersStamps
15        structure CoerceEnv = GenericVC.CoerceEnv
16        structure GG = GroupGraph
17        structure DG = DependencyGraph
18    in
19  functor BootstrapCompileFn (structure MachDepVC : MACHDEP_VC  functor BootstrapCompileFn (structure MachDepVC : MACHDEP_VC
20                              val os : SMLofNJ.SysInfo.os_kind                              val os : SMLofNJ.SysInfo.os_kind
21                              val load_plugin : string -> bool) :> sig                              val load_plugin : string -> bool) :> sig
22      val make' : string option -> bool      val make' : string option -> bool
23      val make : unit -> bool      val make : unit -> bool
     val deliver' : string option -> bool  
     val deliver : unit -> bool  
24      val reset : unit -> unit      val reset : unit -> unit
25      val symval : string -> { get: unit -> int option, set: int option -> unit }      val symval : string -> { get: unit -> int option, set: int option -> unit }
26  end = struct  end = struct
   
     structure EM = GenericVC.ErrorMsg  
     structure E = GenericVC.Environment  
     structure SE = GenericVC.CMStaticEnv  
     structure BE = GenericVC.BareEnvironment  
     structure PS = GenericVC.PersStamps  
     structure CoerceEnv = GenericVC.CoerceEnv  
27      structure SSV = SpecificSymValFn (structure MachDepVC = MachDepVC      structure SSV = SpecificSymValFn (structure MachDepVC = MachDepVC
28                                        val os = os)                                        val os = os)
29      structure P = OS.Path      structure P = OS.Path
# Line 33  Line 34 
34      val osname = FilenamePolicy.kind2name os      val osname = FilenamePolicy.kind2name os
35      val archos = concat [arch, "-", osname]      val archos = concat [arch, "-", osname]
36    
37      fun init_servers (GroupGraph.GROUP { grouppath, ... }) =      fun init_servers (GG.GROUP { grouppath, ... }) =
38          Servers.cmb { archos = archos,          Servers.cmb { archos = archos,
39                        root = SrcPath.descr grouppath }                        root = SrcPath.descr grouppath }
40    
# Line 59  Line 60 
60                       end                       end
61                       val getII = Compile.getII)                       val getII = Compile.getII)
62    
63        structure VerifyStable = VerStabFn (structure Stabilize = Stabilize)
64    
65      (* ... and Parse *)      (* ... and Parse *)
66      structure Parse = ParseFn (structure Stabilize = Stabilize      structure Parse = ParseFn (structure Stabilize = Stabilize
67                                 val evictStale = Compile.evictStale                                 val evictStale = Compile.evictStale
# Line 82  Line 85 
85          MkBootList.group listName g          MkBootList.group listName g
86      end      end
87    
88      fun mk_compile deliver root dbopt = let      fun mk_compile { deliver, root, dirbase = dbopt, paranoid } = let
89    
90          val dirbase = getOpt (dbopt, BtNames.dirbaseDefault)          val dirbase = getOpt (dbopt, BtNames.dirbaseDefault)
91          val pcmodespec = BtNames.pcmodespec          val pcmodespec = BtNames.pcmodespec
# Line 137  Line 140 
140    
141              val { core = core_n, pervasive = perv_n, others, src } = arg              val { core = core_n, pervasive = perv_n, others, src } = arg
142    
143                fun recompInitGroup () = let
144              val ovldR = GenericVC.Control.overloadKW              val ovldR = GenericVC.Control.overloadKW
145              val savedOvld = !ovldR              val savedOvld = !ovldR
146              val _ = ovldR := true              val _ = ovldR := true
# Line 146  Line 150 
150               * brewed pervasive env, core env, and primitives *)               * brewed pervasive env, core env, and primitives *)
151              val core = valOf (sbnode ginfo_nocore core_n)              val core = valOf (sbnode ginfo_nocore core_n)
152              val corenv =              val corenv =
153                  BE.mkenv { static = CoerceEnv.es2bs (#env (#statenv core ())),                      BE.mkenv { static = CoerceEnv.es2bs
154                                              (#env (#statenv core ())),
155                             symbolic = #symenv core (),                             symbolic = #symenv core (),
156                             dynamic = BE.dynamicPart BE.emptyEnv }                                 dynamic = emptydyn }
157    
158              (* The following is a bit of a hack (but corenv is a hack anyway):                  (* The following is a bit of a hack (but corenv is a hack
159               * As soon as we have core available, we have to patch the                   * anyway): As soon as we have core available, we have to
160               * ginfo to include the correct corenv (because virtually                   * patch the ginfo to include the correct corenv (because
161               * everybody else needs access to corenv). *)                   * virtually everybody else needs access to corenv). *)
162              val param = mkParam corenv              val param = mkParam corenv
163              val ginfo =              val ginfo =
164                  { param = param, groupreg = groupreg, errcons = errcons }                  { param = param, groupreg = groupreg, errcons = errcons }
# Line 184  Line 189 
189                        [(PervCoreAccess.pervStrSym, mkie (perv_n, pervasive)),                        [(PervCoreAccess.pervStrSym, mkie (perv_n, pervasive)),
190                         (PervCoreAccess.coreStrSym, mkie (core_n, core))]                         (PervCoreAccess.coreStrSym, mkie (core_n, core))]
191              end              end
192                in
193              val init_group = GroupGraph.GROUP                  (GG.GROUP { exports = foldl add_exports special_exports others,
                 { exports = foldl add_exports special_exports others,  
194                    kind = GroupGraph.LIB (StringSet.empty, []),                    kind = GroupGraph.LIB (StringSet.empty, []),
195                    required = StringSet.singleton "primitive",                    required = StringSet.singleton "primitive",
196                    grouppath = initgspec,                    grouppath = initgspec,
197                    sublibs = [] }                              sublibs = [] },
198                     corenv)
199              val _ = ovldR := savedOvld                  before (ovldR := savedOvld)
200                end
201    
202              (* At this point we check if there is a usable stable version              (* just go and load the stable init group or signal failure *)
203               * of the init group.  If so, we continue to use that. *)              fun loadInitGroup () = let
204              val (stab, init_group, deliver) = let                  val coresym = PervCoreAccess.coreStrSym
205                  fun nostabinit () =                  val lsarg =
206                      if deliver then                      { getGroup = fn _ => raise Fail "CMB: initial getGroup",
                         let val stabarg = { group = init_group,  
207                                              anyerrors = ref false }                                              anyerrors = ref false }
208                          in                          in
209                              case Stabilize.stabilize ginfo stabarg of                  case Stabilize.loadStable ginfo_nocore lsarg initgspec of
210                                  SOME g => (SOME true, g, true)                      NONE => NONE
211                                (* if we cannot stabilize the init group, then                    | SOME (g as GG.GROUP { exports, ... }) =>
212                                 * as a first remedy we turn delivery off *)                          (case SymbolMap.find (exports, coresym) of
213                                | NONE => (NONE, init_group, false)                               SOME ((_, DG.SB_BNODE (_, ii)), _) => let
214                          end                                   val stat = #env (#statenv ii ())
215                      else (NONE, init_group, false)                                   val sym = #symenv ii ()
216              in                                   val corenv =
217                  if VerifyStable.verify ginfo init_group then let                                       BE.mkenv { static = CoerceEnv.es2bs stat,
218                      fun load () =                                                  symbolic = sym,
219                          Stabilize.loadStable ginfo                                                  dynamic = emptydyn }
                           { getGroup = fn _ =>  
                                raise Fail "CMB: initial getGroup",  
                             anyerrors = ref false }  
                           initgspec  
220                  in                  in
221                      case load () of                                   SOME (g, corenv)
                         NONE => nostabinit ()  
                       | SOME g =>  
                             (if deliver then SOME true else NONE, g, deliver)  
222                  end                  end
223                  else nostabinit ()                             | _ => NONE)
224              end              end
225    
226                (* Don't try to load the stable init group. Instead, recompile
227                 * directly. *)
228                fun dontLoadInitGroup () = let
229                    val (g0, corenv) = recompInitGroup ()
230                    val stabarg = { group = g0, anyerrors = ref false }
231                in
232                    if deliver then
233                        case Stabilize.stabilize ginfo_nocore stabarg of
234                            SOME g => (g, corenv)
235                          | NONE => raise Fail "CMB: cannot stabilize init group"
236                    else (g0, corenv)
237                end
238    
239                (* Try loading the init group from the stable file if possible;
240                 * recompile if loading fails *)
241                fun tryLoadInitGroup () =
242                    case loadInitGroup () of
243                        SOME g => g
244                      | NONE => dontLoadInitGroup ()
245    
246                (* Ok, now, based on "paranoid" and stable verification,
247                 * call the appropriate function(s) to get the init group. *)
248                val (init_group, corenv) =
249                    if paranoid then let
250                        val export_nodes = core_n :: perv_n :: others
251                        val ver_arg = (initgspec, export_nodes, [],
252                                       SrcPathSet.empty)
253                        val em = StableMap.empty
254                    in
255                        if VerifyStable.verify' ginfo_nocore em ver_arg then
256                            tryLoadInitGroup ()
257                        else dontLoadInitGroup ()
258                    end
259                    else tryLoadInitGroup ()
260    
261                (* now we finally build the real param and ginfo that we can
262                 * use throughout the rest... *)
263                val param = mkParam corenv
264                val ginfo =
265                    { param = param, errcons = errcons, groupreg = groupreg }
266    
267                val stab = if deliver then SOME true else NONE
268    
269              val gr = GroupReg.new ()              val gr = GroupReg.new ()
270              val _ = GroupReg.register gr (initgspec, src)              val _ = GroupReg.register gr (initgspec, src)
271    
# Line 236  Line 276 
276                    stabflag = stab,                    stabflag = stab,
277                    group = maingspec,                    group = maingspec,
278                    init_group = init_group,                    init_group = init_group,
279                    paranoid = true }                    paranoid = paranoid }
280          in          in
281              Servers.dirbase dirbase;              Servers.dirbase dirbase;
             Parse.reset ();  
282              case Parse.parse parse_arg of              case Parse.parse parse_arg of
283                  NONE => NONE                  NONE => NONE
284                | SOME (g, gp) => let                | SOME (g, gp) => let
# Line 260  Line 299 
299                                                 stablelibs                                                 stablelibs
300                              fun writeBootList s = let                              fun writeBootList s = let
301                                  fun wr str = TextIO.output (s, str ^ "\n")                                  fun wr str = TextIO.output (s, str ^ "\n")
302                                    val numitems = length bootitems
303                                    fun biggerlen (s, n) = Int.max (size s, n)
304                                    val maxlen = foldl biggerlen 0 bootitems
305                              in                              in
306                                    wr (concat ["%", Int.toString numitems,
307                                                " ", Int.toString maxlen]);
308                                  app wr bootitems                                  app wr bootitems
309                              end                              end
310                              fun writePid s i = let                              fun writePid s i = let
# Line 319  Line 363 
363            | NONE => NONE            | NONE => NONE
364      end      end
365    
366      fun compile deliver dbopt =      fun compile dbopt =
367          case mk_compile deliver NONE dbopt of          case mk_compile { deliver = true, root = NONE,
368                              dirbase = dbopt, paranoid = true } of
369              NONE => false              NONE => false
370            | SOME (_, thunk) => thunk ()            | SOME (_, thunk) => thunk ()
371    
372      local      local
373          fun slave (dirbase, root) =          fun slave (dirbase, root) =
374              case mk_compile false (SOME root) (SOME dirbase) of              case mk_compile { deliver = false, root = SOME root,
375                                  dirbase = SOME dirbase, paranoid = false } of
376                  NONE => NONE                  NONE => NONE
377                | SOME ((g, gp, pcmode), _) => let                | SOME ((g, gp, pcmode), _) => let
378                      val trav = Compile.newSbnodeTraversal () gp                      val trav = Compile.newSbnodeTraversal () gp
# Line 342  Line 388 
388          (Compile.reset ();          (Compile.reset ();
389           Parse.reset ())           Parse.reset ())
390    
391      val make' = compile false      val make' = compile
392      fun make () = make' NONE      fun make () = make' NONE
     fun deliver' arg =  
         SafeIO.perform { openIt = fn () => (),  
                          closeIt = reset,  
                          work = fn () => compile true arg,  
                          cleanup = fn _ => () }  
     fun deliver () = deliver' NONE  
393      val symval = SSV.symval      val symval = SSV.symval
394  end  end
395    end (* local *)

Legend:
Removed from v.568  
changed lines
  Added in v.569

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