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/main/cm-boot.sml
ViewVC logotype

Diff of /sml/trunk/src/cm/main/cm-boot.sml

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

revision 536, Fri Feb 18 16:51:54 2000 UTC revision 537, Fri Feb 18 17:20:16 2000 UTC
# Line 1  Line 1 
1  (*  (*
2   * This is the module that actually puts together the contents of the   * This is the module that actually puts together the contents of the
3   * structure CM that people find at the top-level.  A "minimal" structure   * structure CM that people find in full-cm.cm.  A "minimal" structure
4   * CM is defined in CmHook, but it needs to be initialized at bootstrap   * CM is defined in CmHook, but it needs to be initialized at bootstrap
5   * time.   * time.
6   *   *
# Line 41  Line 41 
41            CompileFn (structure MachDepVC = HostMachDepVC            CompileFn (structure MachDepVC = HostMachDepVC
42                       val compile_there = Servers.compile o SrcPath.descr)                       val compile_there = Servers.compile o SrcPath.descr)
43    
44          structure BFC =
45              BfcFn (structure MachDepVC = HostMachDepVC)
46    
47        structure Link =        structure Link =
48            LinkFn (structure MachDepVC = HostMachDepVC            LinkFn (structure MachDepVC = HostMachDepVC
49                      structure BFC = BFC
50                    val system_values = system_values)                    val system_values = system_values)
51    
       structure BFC =  
           BfcFn (structure MachDepVC = HostMachDepVC)  
   
52        structure AutoLoad = AutoLoadFn        structure AutoLoad = AutoLoadFn
53            (structure C = Compile            (structure C = Compile
54             structure L = Link             structure L = Link
55             structure BFC = BFC)             structure BFC = BFC)
56    
57          val mkBootList = #l o MkBootList.group (fn p => p)
58    
59        fun init_servers (GroupGraph.GROUP { grouppath, ... }) =        fun init_servers (GroupGraph.GROUP { grouppath, ... }) =
60            Servers.cm { archos = my_archos, project = SrcPath.descr grouppath }            Servers.cm { archos = my_archos, project = SrcPath.descr grouppath }
61    
# Line 79  Line 82 
82            case Servers.withServers (fn () => c_group gp) of            case Servers.withServers (fn () => c_group gp) of
83                NONE => false                NONE => false
84              | SOME { stat, sym} =>              | SOME { stat, sym} =>
85                    (* Before executing the code, we announce the priviliges                    (* Before executing the code, we announce the privileges
86                     * that are being invoked.  (For the time being, we assume                     * that are being invoked.  (For the time being, we assume
87                     * that everybody has every conceivable privilege, but at                     * that everybody has every conceivable privilege, but at
88                     * the very least we announce which ones are being made                     * the very least we announce which ones are being made
# Line 122  Line 125 
125                                 NONE => NONE                                 NONE => NONE
126                               | SOME _ => SOME get                               | SOME _ => SOME get
127                         end                         end
                        fun destroy_state gp i =  
                            (Compile.evict i;  
                             Link.evict gp i)  
128                         val getII = Compile.getII)                         val getII = Compile.getII)
129    
130        (* Access to the stabilization mechanism is integrated into the        (* Access to the stabilization mechanism is integrated into the
131         * parser. I'm not sure if this is the cleanest way, but it works         * parser. I'm not sure if this is the cleanest way, but it works
132         * well enough. *)         * well enough. *)
133        structure Parse = ParseFn (structure Stabilize = Stabilize        structure Parse = ParseFn (structure Stabilize = Stabilize
134                                     fun evictStale () =
135                                         (Compile.evictStale ();
136                                          Link.evictStale ())
137                                   val pending = AutoLoad.getPending)                                   val pending = AutoLoad.getPending)
138    
139        local        local
140            type kernelValues =            type kernelValues =
141                { primconf : Primitive.configuration,                { corenv : BE.environment,
142                  pervasive : E.environment,                  init_group : GroupGraph.group }
                 corenv : BE.staticEnv,  
                 pervcorepids : PidSet.set }  
143    
144            val fnpolicy = FilenamePolicy.colocate            val fnpolicy = FilenamePolicy.colocate
145                { os = os, arch = HostMachDepVC.architecture }                { os = os, arch = HostMachDepVC.architecture }
# Line 184  Line 185 
185                app processOne p                app processOne p
186            end            end
187    
188              fun getTheValues () = valOf (!theValues)
189                  handle Option => raise Fail "CMBoot: theParam not initialized"
190    
191            fun param () = let            fun param () = let
192                val v = valOf (!theValues)                val v = getTheValues ()
                   handle Option =>  
                       raise Fail "CMBoot: theParam not initialized"  
193            in            in
194                { primconf = #primconf v,                { fnpolicy = fnpolicy,
                 fnpolicy = fnpolicy,  
195                  pcmode = pcmode,                  pcmode = pcmode,
196                  symval = SSV.symval,                  symval = SSV.symval,
197                  keep_going = #get StdConfig.keep_going (),                  keep_going = #get StdConfig.keep_going (),
198                  pervasive = #pervasive v,                  corenv = #corenv v }
                 corenv = #corenv v,  
                 pervcorepids = #pervcorepids v }  
199            end            end
200    
201              val init_group = #init_group o getTheValues
202    
203            fun dropPickles () =            fun dropPickles () =
204                if #get StdConfig.conserve_memory () then                if #get StdConfig.conserve_memory () then
205                    Parse.dropPickles ()                    Parse.dropPickles ()
206                else ()                else ()
207    
208            fun autoload s = let            fun parse_arg (gr, sflag, p) =
209                  { load_plugin = load_plugin, gr = gr, param = param (),
210                    stabflag = sflag, group = p, init_group = init_group (),
211                    paranoid = false }
212    
213              and autoload s = let
214                val p = mkStdSrcPath s                val p = mkStdSrcPath s
215            in            in
216                (case Parse.parse load_plugin (SOME al_greg) (param ()) NONE p of                (case Parse.parse (parse_arg (al_greg, NONE, p)) of
217                     NONE => false                     NONE => false
218                   | SOME (g, _) =>                   | SOME (g, _) =>
219                         (AutoLoad.register (GenericVC.EnvRef.topLevel, g);                         (AutoLoad.register (GenericVC.EnvRef.topLevel, g);
# Line 217  Line 223 
223    
224            and run sflag f s = let            and run sflag f s = let
225                val p = mkStdSrcPath s                val p = mkStdSrcPath s
226                  val gr = GroupReg.new ()
227            in            in
228                (case Parse.parse load_plugin NONE (param ()) sflag p of                (case Parse.parse (parse_arg (gr, sflag, p)) of
229                     NONE => false                     NONE => false
230                   | SOME (g, gp) => f gp g)                   | SOME (g, gp) => f gp g)
231                before dropPickles ()                before dropPickles ()
# Line 242  Line 249 
249            val recomp = run NONE recomp_runner            val recomp = run NONE recomp_runner
250            val make = run NONE (make_runner true)            val make = run NONE (make_runner true)
251    
252              (* I would have liked to express this using "run", but "run"
253               * thinks it has to return a bool... *)
254              fun mk_standalone sflag s = let
255                  val p = mkStdSrcPath s
256                  val gr = GroupReg.new ()
257              in
258                  (case Parse.parse (parse_arg (gr, sflag, p)) of
259                       NONE => NONE
260                     | SOME (g, gp) =>
261                       if isSome sflag orelse recomp_runner gp g then
262                           SOME (mkBootList g)
263                       else NONE)
264                  before dropPickles ()
265              end
266    
267            fun slave () = let            fun slave () = let
268                fun parse p =                val gr = GroupReg.new ()
269                    Parse.parse load_plugin NONE (param ()) NONE p                fun parse p = Parse.parse (parse_arg (gr, NONE, p))
270            in            in
271                Slave.slave { pcmode = pcmode,                Slave.slave { pcmode = pcmode,
272                              parse = parse,                              parse = parse,
# Line 296  Line 318 
318                    app (fn (x, d) => PathConfig.set (pcmode, x, d)) pairList                    app (fn (x, d) => PathConfig.set (pcmode, x, d)) pairList
319                end                end
320                val initgspec = mkStdSrcPath BtNames.initgspec                val initgspec = mkStdSrcPath BtNames.initgspec
321                val ginfo = { param = { primconf = Primitive.primEnvConf,                val ginfo = { param = { fnpolicy = fnpolicy,
                                       fnpolicy = fnpolicy,  
322                                        pcmode = pcmode,                                        pcmode = pcmode,
323                                        symval = SSV.symval,                                        symval = SSV.symval,
324                                        keep_going = false,                                        keep_going = false,
325                                        pervasive = E.emptyEnv,                                        corenv = BE.emptyEnv },
                                       corenv = BE.staticPart BE.emptyEnv,  
                                       pervcorepids = PidSet.empty },  
326                              groupreg = GroupReg.new (),                              groupreg = GroupReg.new (),
327                              errcons = EM.defaultConsumer () }                              errcons = EM.defaultConsumer () }
328            in                fun loadInitGroup () =
329                case BuildInitDG.build ginfo initgspec of                    Stabilize.loadStable ginfo
330                    NONE => raise Fail "CMBoot: BuiltInitDG.build"                      { getGroup = fn _ => raise Fail "CMBoot: initial getGroup",
331                  | SOME { rts, core, pervasive, primitives, ... } => let                        anyerrors = ref false }
332                        (* It is absolutely crucial that we don't finish the                      initgspec
333                         * recomp traversal until we are done with all            in
334                         * nodes of the InitDG.  This is because we have                case loadInitGroup () of
335                         * been cheating, and if we ever have to try and                    NONE => raise Fail "CMBoot: unable to load init group"
336                         * fetch assembly.sig or core.sml in a separate                  | SOME init_group => let
337                         * traversal, it will fail. *)                        val _ = Compile.reset ()
338                        val sbnode = Compile.newSbnodeTraversal ()                        val _ = Link.reset ()
339                        fun get n = let  
340                            val { statpid, statenv, symenv, sympid } =                        val { exports = ctm, ... } =
341                                valOf (sbnode ginfo n)                            Compile.newTraversal (fn _ => fn _ => (),
342                            (* We have not implemented the "sbnode" part                                                  fn _ => (),
343                             * in the Link module.                                                  init_group)
344                             * But at boot time any relevant value should be                        val { exports = ltm, ... } = Link.newTraversal
345                             * available as a sysval, so there is no problem.                            (init_group, fn _ => raise Fail "init: get bfc?")
346                             *  
347                             * WARNING!  HACK!                        fun getSymTrav (tr_m, sy) =
348                             * We are cheating somewhat by taking advantage                            case SymbolMap.find (tr_m, sy) of
349                             * of the fact that the staticPid is always                                NONE => raise Fail "init: bogus init group (1)"
350                             * the same as the exportPid if the latter exists.                              | SOME tr => tr
351                             *)  
352                            val d = case Link.sysval (SOME statpid) of                        val core_ct = getSymTrav (ctm, PervCoreAccess.coreStrSym)
353                                SOME d => d                        val core_lt = getSymTrav (ltm, PervCoreAccess.coreStrSym)
354                              | NONE => emptydyn                        val perv_ct = getSymTrav (ctm, PervCoreAccess.pervStrSym)
355                            val { env = static, ctxt } = statenv ()                        val perv_lt = getSymTrav (ltm, PervCoreAccess.pervStrSym)
356                            val env = E.mkenv { static = static,  
357                                                symbolic = symenv (),                        fun doTrav t =
358                                                dynamic = d }                            case t ginfo of
359                            val pidInfo =                                SOME r => r
360                                { statpid = statpid, sympid = sympid,                              | NONE => raise Fail "init: bogus init group (2)"
361                                  ctxt = ctxt }  
362                        in                        val { stat = corestat, sym = coresym } = doTrav core_ct
363                            (env, pidInfo)                        val coredyn = doTrav core_lt
364                        end                        val { stat = pervstat, sym = pervsym } = doTrav perv_ct
365                        fun getPspec (name, n) = let                        val pervdyn = doTrav perv_lt
366                            val (env, pidInfo) = get n  
367                        in                        val corenv =
368                            { name = name, env = env, pidInfo = pidInfo }                            BE.mkenv { static = CoerceEnv.es2bs corestat,
369                        end                                       symbolic = coresym,
370                                         dynamic = coredyn }
                       val (core, corePidInfo) = get core  
                       val corenv = CoerceEnv.es2bs (E.staticPart core)  
                       val (rts, _) = get rts  
                       val (pervasive0, pervPidInfo) = get pervasive  
                       val pspecs = map getPspec primitives  
371                        val core_symdyn =                        val core_symdyn =
372                            E.mkenv { static = E.staticPart E.emptyEnv,                            E.mkenv { static = E.staticPart E.emptyEnv,
373                                      dynamic = E.dynamicPart core,                                      dynamic = coredyn, symbolic = coresym }
374                                      symbolic = E.symbolicPart core }  
375                        val pervasive = E.layerEnv (pervasive0, core_symdyn)                        val pervasive = E.mkenv { static = pervstat,
376                        val pervcorepids =                                                  symbolic = pervsym,
377                            PidSet.addList (PidSet.empty,                                                  dynamic = pervdyn }
378                                            [#statpid corePidInfo,  
                                            #statpid pervPidInfo,  
                                            #sympid pervPidInfo])  
379                        fun bare_autoload x =                        fun bare_autoload x =
380                            (Say.say                            (Say.say
381                              ["!* ", x,                              ["!* ", x,
# Line 375  Line 387 
387                        val standard_preload =                        val standard_preload =
388                            Preload.preload { make = make, autoload = autoload }                            Preload.preload { make = make, autoload = autoload }
389                    in                    in
390                        Compile.reset ();                        #set ER.core (BE.staticPart corenv);
391                        Link.reset ();                        #set ER.pervasive (E.layerEnv (pervasive, core_symdyn));
                       #set ER.core corenv;  
                       #set ER.pervasive pervasive;  
392                        #set ER.topLevel BE.emptyEnv;                        #set ER.topLevel BE.emptyEnv;
393                        theValues :=                        theValues := SOME { corenv = corenv,
394                          SOME { primconf = Primitive.configuration pspecs,                                            init_group = init_group };
                                pervasive = pervasive,  
                                corenv = corenv,  
                                pervcorepids = pervcorepids };  
395                        case er of                        case er of
396                            BARE =>                            BARE =>
397                                (bare_preload BtNames.bare_preloads;                                (bare_preload BtNames.bare_preloads;
# Line 479  Line 486 
486    
487          val symval = SSV.symval          val symval = SSV.symval
488          val load_plugin = load_plugin          val load_plugin = load_plugin
489            val mk_standalone = mk_standalone
490      end      end
491    
492      structure Tools = ToolsFn (val load_plugin = load_plugin      structure Tools = ToolsFn (val load_plugin = load_plugin

Legend:
Removed from v.536  
changed lines
  Added in v.537

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