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 380, Fri Jul 9 05:22:18 1999 UTC revision 456, Wed Oct 27 15:09:58 1999 UTC
# Line 28  Line 28 
28        structure BF = HostMachDepVC.Binfile        structure BF = HostMachDepVC.Binfile
29        structure P = OS.Path        structure P = OS.Path
30        structure F = OS.FileSys        structure F = OS.FileSys
31          structure DG = DependencyGraph
32    
33        val os = SMLofNJ.SysInfo.getOSKind ()        val os = SMLofNJ.SysInfo.getOSKind ()
34    
# Line 38  Line 39 
39        val emptydyn = E.dynamicPart E.emptyEnv        val emptydyn = E.dynamicPart E.emptyEnv
40        val system_values = ref emptydyn        val system_values = ref emptydyn
41    
42        (* Instantiate the persistent state functor; this includes        structure Compile =
43         * the binfile cache and the dynamic value cache *)            CompileFn (structure MachDepVC = HostMachDepVC
44        structure FullPersstate =                       val compile_there = Servers.compile)
           FullPersstateFn (structure MachDepVC = HostMachDepVC  
                            val system_values = system_values)  
45    
46        (* Building "Exec" will automatically also build "Recomp" and        structure Link =
47         * "RecompTraversal"... *)            LinkFn (structure MachDepVC = HostMachDepVC
48        local                    val system_values = system_values)
           structure E = ExecFn (structure PS = FullPersstate)  
       in  
           structure Recomp = E.Recomp  
           structure RT = E.RecompTraversal  
           structure Exec = E.Exec  
       end  
49    
50        structure ET = CompileGenericFn (structure CT = Exec)        structure BFC =
51              BfcFn (structure MachDepVC = HostMachDepVC)
52    
53        structure AutoLoad = AutoLoadFn        structure AutoLoad = AutoLoadFn
54            (structure RT = RT            (structure C = Compile
55             structure ET = ET)             structure L = Link
56               structure BFC = BFC)
57        (* The StabilizeFn functor needs a way of converting bnodes to  
58         * dependency-analysis environments.  This can be achieved quite        fun init_servers (GroupGraph.GROUP { grouppath, ... }) =
59         * conveniently by a "recompile" traversal for bnodes. *)            Servers.cm grouppath
60        fun bn2statenv gp i = #1 (#stat (valOf (RT.bnode' gp i)))  
61            handle Option => raise Fail "bn2statenv"        fun recomp_runner gp g = let
62              val _ = init_servers g
63        (* exec_group is basically the same as ET.group with            fun store _ = ()
64         * one additional actions to be taken:            val { group, ... } = Compile.newTraversal (Link.evict, store, g)
65         *      Before executing the code, we announce the priviliges        in
66         *      that are being invoked.  (For the time being, we assume            isSome (Servers.withServers (fn () => group gp))
67         *      that everybody has every conceivable privilege, but at the            before Link.cleanup gp
68         *      very least we announce which ones are being made use of.) *)        end
       fun exec_group gp (g as GroupGraph.GROUP { required = rq, ... }) =  
           (if StringSet.isEmpty rq then ()  
            else Say.say ("$Execute: required privileges are:\n" ::  
                      map (fn s => ("  " ^ s ^ "\n")) (StringSet.listItems rq));  
            ET.group gp g)  
   
       fun recomp_runner gp g = isSome (RT.group gp g)  
69    
70        (* This function combines the actions of "recompile" and "exec".        (* This function combines the actions of "recompile" and "exec".
71         * When successful, it combines the results (thus forming a full         * When successful, it combines the results (thus forming a full
72         * environment) and adds it to the toplevel environment. *)         * environment) and adds it to the toplevel environment. *)
73        fun make_runner gp g =        fun make_runner gp g = let
74            case RT.group gp g of            val { store, get } = BFC.new ()
75              val _ = init_servers g
76              val { group = c_group, ... } =
77                  Compile.newTraversal (Link.evict, store, g)
78              val { group = l_group, ... } = Link.newTraversal (g, get)
79              val GroupGraph.GROUP { required = rq, ... } = g
80          in
81              case Servers.withServers (fn () => c_group gp) of
82                NONE => false                NONE => false
83              | SOME { stat, sym} =>              | SOME { stat, sym} =>
84                    (case exec_group gp g of                    (* Before executing the code, we announce the priviliges
85                       * that are being invoked.  (For the time being, we assume
86                       * that everybody has every conceivable privilege, but at
87                       * the very least we announce which ones are being made
88                       * use of.) *)
89                      (Link.cleanup gp;
90                       if StringSet.isEmpty rq then ()
91                       else Say.say ("$Execute: required privileges are:\n" ::
92                         map (fn s => ("  " ^ s ^ "\n")) (StringSet.listItems rq));
93                       case l_group gp of
94                         NONE => false                         NONE => false
95                       | SOME dyn => let                       | SOME dyn => let
96                             val delta = E.mkenv { static = stat, symbolic = sym,                             val delta = E.mkenv { static = stat, symbolic = sym,
# Line 99  Line 102 
102                             Say.vsay ["[New bindings added.]\n"];                             Say.vsay ["[New bindings added.]\n"];
103                             true                             true
104                         end)                         end)
105          end
106    
107        val al_greg = GroupReg.new ()        val al_greg = GroupReg.new ()
108    
109        (* Instantiate the stabilization mechanism. *)        (* Instantiate the stabilization mechanism. *)
110        structure Stabilize =        structure Stabilize =
111            StabilizeFn (val bn2statenv = bn2statenv            StabilizeFn (structure MachDepVC = HostMachDepVC
112                         val recomp = recomp_runner                         fun recomp gp g = let
113                         val transfer_state = FullPersstate.transfer_state)                             val { store, get } = BFC.new ()
114                               val _ = init_servers g
115                               val { group, ... } =
116                                   Compile.newTraversal (Link.evict, store, g)
117                           in
118                               case Servers.withServers (fn () => group gp) of
119                                   NONE => NONE
120                                 | SOME _ => SOME get
121                           end
122                           fun destroy_state gp i =
123                               (Compile.evict i;
124                                Link.evict gp i)
125                           val getII = Compile.getII)
126    
127        (* Access to the stabilization mechanism is integrated into the        (* Access to the stabilization mechanism is integrated into the
128         * 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
# Line 150  Line 166 
166            end            end
167    
168            fun initPaths () = let            fun initPaths () = let
169                val lpcth = EnvConfig.getSet StdConfig.local_pathconfig NONE                val lpcth = #get StdConfig.local_pathconfig ()
170                val p = case lpcth () of                val p = case lpcth () of
171                    NONE => []                    NONE => []
172                  | SOME f => [f]                  | SOME f => [f]
173                val p = EnvConfig.getSet StdConfig.pathcfgspec NONE :: p                val p = #get StdConfig.pathcfgspec () :: p
174                fun processOne f = PathConfig.processSpecFile (pcmode, f)                fun processOne f = PathConfig.processSpecFile (pcmode, f)
175                    handle _ => ()                    handle _ => ()
176            in            in
# Line 169  Line 185 
185                { primconf = #primconf v,                { primconf = #primconf v,
186                  fnpolicy = fnpolicy,                  fnpolicy = fnpolicy,
187                  pcmode = pcmode,                  pcmode = pcmode,
188                  symenv = SSV.env,                  symval = SSV.symval,
189                  keep_going = EnvConfig.getSet StdConfig.keep_going NONE,                  keep_going = #get StdConfig.keep_going (),
190                  pervasive = #pervasive v,                  pervasive = #pervasive v,
191                  corenv = #corenv v,                  corenv = #corenv v,
192                  pervcorepids = #pervcorepids v }                  pervcorepids = #pervcorepids v }
# Line 204  Line 220 
220                  | SOME (g, gp) => f gp g                  | SOME (g, gp) => f gp g
221            end            end
222    
223              val listLibs = Parse.listLibs
224              fun dismissLib l = let
225                  val c = SrcPath.cwdContext ()
226                  val p = SrcPath.standard pcmode { context = c, spec = l }
227              in
228                  Parse.dismissLib p
229              end
230    
231            fun stabilize_runner gp g = true            fun stabilize_runner gp g = true
232    
233            fun stabilize recursively = run (SOME recursively) stabilize_runner            fun stabilize recursively = run (SOME recursively) stabilize_runner
234            val recomp = run NONE recomp_runner            val recomp = run NONE recomp_runner
235            val make = run NONE make_runner            val make = run NONE make_runner
236    
237              fun slave () = let
238    
239                  val dbr = ref BtNames.dirbaseDefault
240    
241                  fun shutdown () = OS.Process.exit OS.Process.success
242                  fun say_ok () = Say.say ["SLAVE: ok\n"]
243                  fun say_error () = Say.say ["SLAVE: error\n"]
244                  fun say_pong () = Say.say ["SLAVE: pong\n"]
245    
246                  val touch = HostMachDepVC.Interact.useStream o TextIO.openString
247    
248                  fun waitForStart () = let
249                      val line = TextIO.inputLine TextIO.stdIn
250                  in
251                      if line = "" then shutdown ()
252                      else case String.tokens Char.isSpace line of
253                          ["cm", d, f] => do_cm (d, f)
254                        | ["cmb", archos, d, f] => do_cmb (archos, d, f)
255                        | ["ping"] => (say_pong (); waitForStart ())
256                        | ["finish"] => (say_ok (); waitForStart ())
257                        | ["dirbase", db] =>
258                              (say_ok (); dbr := db; waitForStart ())
259                        | ["shutdown"] => shutdown ()
260                        | _ => (say_error (); waitForStart ())
261                  end handle _ => (say_error (); waitForStart ())
262    
263                  and do_cmb (archos, d, f) = let
264                      val _ = OS.FileSys.chDir d
265                      val c = SrcPath.cwdContext ()
266                      val slave = CMBSlave.slave { load = autoload, touch = touch }
267                  in
268                      case slave archos (!dbr, f) of
269                          NONE => (say_error (); waitForStart ())
270                        | SOME (g, trav) => let
271                              val _ = say_ok ()
272                              val index = Reachable.snodeMap g
273                          in
274                              workLoop (index, trav, c)
275                          end
276                  end handle _ => (say_error (); waitForStart ())
277    
278                  and do_cm (d, f) = let
279                      val _ = OS.FileSys.chDir d
280                      val c = SrcPath.cwdContext ()
281                      val p = SrcPath.native { context = c, spec = f }
282                  in
283                      case Parse.parse NONE (param ()) NONE p of
284                          NONE => (say_error (); waitForStart ())
285                        | SOME (g, gp) => let
286                              val _ = say_ok ()
287                              val index = Reachable.snodeMap g
288                              val trav = Compile.newSbnodeTraversal () gp
289                              fun trav' sbn = isSome (trav sbn)
290                          in
291                              workLoop (index, trav', c)
292                          end
293                  end handle _ => (say_error (); waitForStart ())
294    
295                  and workLoop (index, trav, c) = let
296                      fun f2sn f =
297                          SrcPathMap.find (index,
298                                           SrcPath.native { context = c,
299                                                            spec = f })
300                      fun loop () = let
301                          val line = TextIO.inputLine TextIO.stdIn
302                      in
303                          if line = "" then shutdown ()
304                          else case String.tokens Char.isSpace line of
305                              ["compile", f] => let
306                                  val p = SrcPath.native { context = c, spec = f }
307                              in
308                                  case SrcPathMap.find (index, p) of
309                                      NONE => (say_error (); loop ())
310                                    | SOME sn => let
311                                          val sbn = DG.SB_SNODE sn
312                                      in
313                                          if trav sbn then (say_ok (); loop ())
314                                          else (say_error (); loop ())
315                                      end
316                              end
317                            | ["cm", d, f] => do_cm (d, f)
318                            | ["cmb", archos, d, f] => do_cmb (archos, d, f)
319                            | ["finish"] => (say_ok (); waitForStart ())
320                            | ["dirbase", db] =>
321                                  (say_ok (); dbr := db; waitForStart ())
322                            | ["ping"] => (say_pong (); loop ())
323                            | ["shutdown"] => shutdown ()
324                            | _ => (say_error (); loop ())
325                      end handle _ => (say_error (); loop ())
326                  in
327                      loop ()
328                  end
329              in
330                  ignore (Signals.setHandler (Signals.sigINT, Signals.IGNORE));
331                  say_ok ();                (* announce readiness *)
332                  waitForStart () handle _ => ();
333                  OS.Process.exit OS.Process.failure
334              end
335    
336            fun reset () =            fun reset () =
337                (FullPersstate.reset ();                (Compile.reset ();
338                 RT.reset ();                 Link.reset ();
                ET.reset ();  
                Recomp.reset ();  
                Exec.reset ();  
339                 AutoLoad.reset ();                 AutoLoad.reset ();
340                 Parse.reset ();                 Parse.reset ();
341                 SmlInfo.forgetAllBut SrcPathSet.empty)                 SmlInfo.forgetAllBut SrcPathSet.empty)
# Line 251  Line 371 
371                val ginfo = { param = { primconf = Primitive.primEnvConf,                val ginfo = { param = { primconf = Primitive.primEnvConf,
372                                        fnpolicy = fnpolicy,                                        fnpolicy = fnpolicy,
373                                        pcmode = pcmode,                                        pcmode = pcmode,
374                                        symenv = SSV.env,                                        symval = SSV.symval,
375                                        keep_going = false,                                        keep_going = false,
376                                        pervasive = E.emptyEnv,                                        pervasive = E.emptyEnv,
377                                        corenv = BE.staticPart BE.emptyEnv,                                        corenv = BE.staticPart BE.emptyEnv,
# Line 268  Line 388 
388                         * been cheating, and if we ever have to try and                         * been cheating, and if we ever have to try and
389                         * fetch assembly.sig or core.sml in a separate                         * fetch assembly.sig or core.sml in a separate
390                         * traversal, it will fail. *)                         * traversal, it will fail. *)
391                        val rtts = RT.start ()                        val sbnode = Compile.newSbnodeTraversal ()
392                        fun get n = let                        fun get n = let
393                            val { stat = (s, sp), sym = (sy, syp), ctxt, bfc } =                            val { ii, ctxt } = valOf (sbnode ginfo n)
394                                valOf (RT.sbnode rtts ginfo n)                            val { statpid, statenv, symenv, sympid } = ii
395                            (* Since we cannot start another recomp traversal,                            (* We have not implemented the "sbnode" part
396                             * we must also avoid exec traversals (because they                             * in the Link module.
                            * would internally trigger recomp traversals).  
397                             * But at boot time any relevant value should be                             * But at boot time any relevant value should be
398                             * available as a sysval, so there is no problem. *)                             * available as a sysval, so there is no problem.
399                            val d =                             *
400                                case Option.map (FullPersstate.sysval o                             * WARNING!  HACK!
401                                                 BF.exportPidOf) bfc of                             * We are cheating somewhat by taking advantage
402                                    SOME (SOME d) => d                             * of the fact that the staticPid is always
403                                  | _ => emptydyn                             * the same as the exportPid if the latter exists.
404                            val env = E.mkenv { static = s, symbolic = sy,                             *)
405                              val d = case Link.sysval (SOME statpid) of
406                                  SOME d => d
407                                | NONE => emptydyn
408                              val env = E.mkenv { static = statenv (),
409                                                  symbolic = symenv (),
410                                                dynamic = d }                                                dynamic = d }
411                            val pidInfo = { statpid = sp, sympid = syp,                            val pidInfo = { statpid = statpid,
412                                              sympid = sympid,
413                                            ctxt = ctxt }                                            ctxt = ctxt }
414                        in                        in
415                            (env, pidInfo)                            (env, pidInfo)
# Line 311  Line 436 
436                                             #statpid pervPidInfo,                                             #statpid pervPidInfo,
437                                             #sympid pervPidInfo])                                             #sympid pervPidInfo])
438                    in                    in
439                        (* Nobody is going to try and share this state --                        Compile.reset ();
440                         * or, rather, this state is shared via access                        Link.reset ();
                        * to "primitives".  Therefore, we don't call  
                        * RT.finish and ET.finish and reset the state. *)  
                       FullPersstate.reset ();  
441                        #set ER.core corenv;                        #set ER.core corenv;
442                        #set ER.pervasive pervasive;                        #set ER.pervasive pervasive;
443                        #set ER.topLevel BE.emptyEnv;                        #set ER.topLevel BE.emptyEnv;
# Line 340  Line 462 
462                                     make = make,                                     make = make,
463                                     autoload = autoload,                                     autoload = autoload,
464                                     reset = reset,                                     reset = reset,
465                                     verbose =                                     verbose = StdConfig.verbose,
466                                        EnvConfig.getSet StdConfig.verbose,                                     debug = StdConfig.debug,
467                                     debug =                                     keep_going = StdConfig.keep_going,
468                                        EnvConfig.getSet StdConfig.debug,                                     warn_obsolete = StdConfig.warn_obsolete,
469                                     keep_going =                                     parse_caching = StdConfig.parse_caching,
                                       EnvConfig.getSet StdConfig.keep_going,  
                                    parse_caching =  
                                       EnvConfig.getSet StdConfig.parse_caching,  
470                                     setAnchor = setAnchor,                                     setAnchor = setAnchor,
471                                     cancelAnchor = cancelAnchor,                                     cancelAnchor = cancelAnchor,
472                                     resetPathConfig = resetPathConfig,                                     resetPathConfig = resetPathConfig,
473                                     synchronize = SrcPath.sync,                                     synchronize = SrcPath.sync,
474                                     showPending = showPending })                                     showPending = showPending,
475                                       listLibs = listLibs,
476                                       dismissLib = dismissLib,
477                                       symval = SSV.symval,
478                                       server_start = Servers.start,
479                                       server_stop = Servers.stop,
480                                       server_kill = Servers.kill })
481    
482                    end                    end
483            end            end
# Line 362  Line 487 
487          (system_values := de;          (system_values := de;
488           initTheValues (bootdir, er);           initTheValues (bootdir, er);
489           Cleanup.install initPaths)           Cleanup.install initPaths)
490    
491        fun procCmdLine () = let
492            fun p (f, "sml") = HostMachDepVC.Interact.useFile f
493              | p (f, "sig") = HostMachDepVC.Interact.useFile f
494              | p (f, "cm") = ignore (make f)
495              | p (f, e) =
496                    (print (concat ["!* unable to process `", f,
497                                    "' (unknown extension `", e, "')\n"]))
498            fun c f = (f, String.map Char.toLower
499                              (getOpt (OS.Path.ext f, "<none>")))
500        in
501            case SMLofNJ.getArgs () of
502                ["@CMslave"] => (#set StdConfig.verbose false; slave ())
503              | l => app (p o c) l
504        end
505    end    end
506  end  end

Legend:
Removed from v.380  
changed lines
  Added in v.456

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