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 399, Thu Aug 26 09:55:09 1999 UTC revision 450, Fri Oct 22 17:10:09 1999 UTC
# Line 38  Line 38 
38        val emptydyn = E.dynamicPart E.emptyEnv        val emptydyn = E.dynamicPart E.emptyEnv
39        val system_values = ref emptydyn        val system_values = ref emptydyn
40    
41          structure Compile =
42              CompileFn (structure MachDepVC = HostMachDepVC
43                         val compile_there = Servers.compile)
44    
45        structure Link =        structure Link =
46            LinkFn (structure MachDepVC = HostMachDepVC            LinkFn (structure MachDepVC = HostMachDepVC
47                    val system_values = system_values)                    val system_values = system_values)
48    
49        structure Compile =        structure BFC =
50            CompileFn (structure MachDepVC = HostMachDepVC)            BfcFn (structure MachDepVC = HostMachDepVC)
51    
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)
56    
57        fun recomp_runner gp g = let        fun recomp_runner gp g = let
58            val { group, ... } = Compile.newTraversal (Link.evict, g)            fun store _ = ()
59              val { group, ... } = Compile.newTraversal (Link.evict, store, g)
60        in        in
61            isSome (group gp) before Link.cleanup ()            isSome (Servers.withServers (fn () => group gp))
62              before Link.cleanup gp
63        end        end
64    
65        (* This function combines the actions of "recompile" and "exec".        (* This function combines the actions of "recompile" and "exec".
66         * When successful, it combines the results (thus forming a full         * When successful, it combines the results (thus forming a full
67         * environment) and adds it to the toplevel environment. *)         * environment) and adds it to the toplevel environment. *)
68        fun make_runner gp g = let        fun make_runner gp g = let
69            val { group = c_group, ... } = Compile.newTraversal (Link.evict, g)            val { store, get } = BFC.new ()
70            val { group = l_group, ... } = Link.newTraversal g            val { group = c_group, ... } =
71                  Compile.newTraversal (Link.evict, store, g)
72              val { group = l_group, ... } = Link.newTraversal (g, get)
73            val GroupGraph.GROUP { required = rq, ... } = g            val GroupGraph.GROUP { required = rq, ... } = g
74        in        in
75            case c_group gp of            case Servers.withServers (fn () => c_group gp) of
76                NONE => false                NONE => false
77              | SOME { stat, sym} =>              | SOME { stat, sym} =>
78                    (* Before executing the code, we announce the priviliges                    (* Before executing the code, we announce the priviliges
# Line 71  Line 80 
80                     * that everybody has every conceivable privilege, but at                     * that everybody has every conceivable privilege, but at
81                     * the very least we announce which ones are being made                     * the very least we announce which ones are being made
82                     * use of.) *)                     * use of.) *)
83                    (Link.cleanup ();                    (Link.cleanup gp;
84                     if StringSet.isEmpty rq then ()                     if StringSet.isEmpty rq then ()
85                     else Say.say ("$Execute: required privileges are:\n" ::                     else Say.say ("$Execute: required privileges are:\n" ::
86                       map (fn s => ("  " ^ s ^ "\n")) (StringSet.listItems rq));                       map (fn s => ("  " ^ s ^ "\n")) (StringSet.listItems rq));
# Line 93  Line 102 
102    
103        (* Instantiate the stabilization mechanism. *)        (* Instantiate the stabilization mechanism. *)
104        structure Stabilize =        structure Stabilize =
105            StabilizeFn (val recomp = recomp_runner            StabilizeFn (structure MachDepVC = HostMachDepVC
106                         val writeBFC = Compile.writeBFC                         fun recomp gp g = let
107                         val sizeBFC = Compile.sizeBFC                             val { store, get } = BFC.new ()
108                         val getII = Compile.getII                             val { group, ... } =
109                         val destroy_state = Link.evict)                                 Compile.newTraversal (Link.evict, store, g)
110                           in
111                               case Servers.withServers (fn () => group gp) of
112                                   NONE => NONE
113                                 | SOME _ => SOME get
114                           end
115                           fun destroy_state gp i =
116                               (Compile.evict i; Link.evict gp i)
117                           val getII = Compile.getII)
118    
119        (* Access to the stabilization mechanism is integrated into the        (* Access to the stabilization mechanism is integrated into the
120         * 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 141  Line 158 
158            end            end
159    
160            fun initPaths () = let            fun initPaths () = let
161                val lpcth = EnvConfig.getSet StdConfig.local_pathconfig NONE                val lpcth = #get StdConfig.local_pathconfig ()
162                val p = case lpcth () of                val p = case lpcth () of
163                    NONE => []                    NONE => []
164                  | SOME f => [f]                  | SOME f => [f]
165                val p = EnvConfig.getSet StdConfig.pathcfgspec NONE :: p                val p = #get StdConfig.pathcfgspec () :: p
166                fun processOne f = PathConfig.processSpecFile (pcmode, f)                fun processOne f = PathConfig.processSpecFile (pcmode, f)
167                    handle _ => ()                    handle _ => ()
168            in            in
# Line 160  Line 177 
177                { primconf = #primconf v,                { primconf = #primconf v,
178                  fnpolicy = fnpolicy,                  fnpolicy = fnpolicy,
179                  pcmode = pcmode,                  pcmode = pcmode,
180                  symenv = SSV.env,                  symval = SSV.symval,
181                  keep_going = EnvConfig.getSet StdConfig.keep_going NONE,                  keep_going = #get StdConfig.keep_going (),
182                  pervasive = #pervasive v,                  pervasive = #pervasive v,
183                  corenv = #corenv v,                  corenv = #corenv v,
184                  pervcorepids = #pervcorepids v }                  pervcorepids = #pervcorepids v }
# Line 192  Line 209 
209            in            in
210                case Parse.parse NONE (param ()) sflag p of                case Parse.parse NONE (param ()) sflag p of
211                    NONE => false                    NONE => false
212                  | SOME (g, gp) => f gp g                  | SOME (g, gp) =>
213                          (Servers.cm p;
214                           f gp g
215                           before Servers.waitforall ())
216              end
217    
218              val listLibs = Parse.listLibs
219              fun dismissLib l = let
220                  val c = SrcPath.cwdContext ()
221                  val p = SrcPath.standard pcmode { context = c, spec = l }
222              in
223                  Parse.dismissLib p
224            end            end
225    
226            fun stabilize_runner gp g = true            fun stabilize_runner gp g = true
# Line 201  Line 229 
229            val recomp = run NONE recomp_runner            val recomp = run NONE recomp_runner
230            val make = run NONE make_runner            val make = run NONE make_runner
231    
232              fun slave () = let
233                  fun shutdown () = OS.Process.exit OS.Process.success
234                  fun say_ok () = Say.say ["SLAVE: ok\n"]
235                  fun say_error () = Say.say ["SLAVE: error\n"]
236    
237                  fun waitForStart () = let
238                      val line = TextIO.inputLine TextIO.stdIn
239                  in
240                      if line = "" then shutdown ()
241                      else case String.tokens Char.isSpace line of
242                          ["cm", d, f] => do_cm (d, f)
243                        | ["cmb", d, db] => do_cmb (d, db)
244                        | ["shutdown"] => shutdown ()
245                        | _ => (say_error (); waitForStart ())
246                  end handle _ => (say_error (); waitForStart ())
247    
248                  and do_cmb (d, db) = let
249                      val _ = OS.FileSys.chDir d
250                      val c = SrcPath.cwdContext ()
251                  in
252                      case CMBSlave.slave make db of
253                          NONE => (say_error (); waitForStart ())
254                        | SOME (g, gp, trav) => let
255                              val _ = say_ok ()
256                              val index = Reachable.snodeMap g
257                          in
258                              workLoop (index, trav, gp, c)
259                          end
260                  end handle _ => (say_error (); waitForStart ())
261    
262                  and do_cm (d, f) = let
263                      val _ = OS.FileSys.chDir d
264                      val c = SrcPath.cwdContext ()
265                      val p = SrcPath.native { context = c, spec = f }
266                  in
267                      case Parse.parse NONE (param ()) NONE p of
268                          NONE => (say_error (); waitForStart ())
269                        | SOME (g, gp) => let
270                              val _ = say_ok ()
271                              val index = Reachable.snodeMap g
272                              val trav = Compile.newSbnodeTraversal () gp
273                              fun trav' sbn = isSome (trav sbn)
274                          in
275                              workLoop (index, trav', gp, c)
276                          end
277                  end handle _ => (say_error (); waitForStart ())
278    
279                  and workLoop (index, trav, gp, c) = let
280                      fun loop () = let
281                          val line = TextIO.inputLine TextIO.stdIn
282                      in
283                          if line = "" then shutdown ()
284                          else case String.tokens Char.isSpace line of
285                              ["compile", f] => let
286                                  val p = SrcPath.native { context = c, spec = f }
287                              in
288                                  case SrcPathMap.find (index, p) of
289                                      NONE => (say_error (); loop ())
290                                    | SOME sn => let
291                                          val sbn = DependencyGraph.SB_SNODE sn
292                                      in
293                                          if trav sbn then (say_ok (); loop ())
294                                          else (say_error (); loop ())
295                                      end
296                              end
297                            | ["cm", d, f] => do_cm (d, f)
298                            | ["finish"] => (say_ok (); waitForStart ())
299                            | ["shutdown"] => shutdown ()
300                            | _ => (say_error (); loop ())
301                      end handle _ => (say_error (); loop ())
302                  in
303                      loop ()
304                  end
305              in
306                  say_ok ();                (* announce readiness *)
307                  waitForStart ()
308              end
309    
310            fun reset () =            fun reset () =
311                (Compile.reset ();                (Compile.reset ();
312                 Link.reset ();                 Link.reset ();
# Line 239  Line 345 
345                val ginfo = { param = { primconf = Primitive.primEnvConf,                val ginfo = { param = { primconf = Primitive.primEnvConf,
346                                        fnpolicy = fnpolicy,                                        fnpolicy = fnpolicy,
347                                        pcmode = pcmode,                                        pcmode = pcmode,
348                                        symenv = SSV.env,                                        symval = SSV.symval,
349                                        keep_going = false,                                        keep_going = false,
350                                        pervasive = E.emptyEnv,                                        pervasive = E.emptyEnv,
351                                        corenv = BE.staticPart BE.emptyEnv,                                        corenv = BE.staticPart BE.emptyEnv,
# Line 256  Line 362 
362                         * been cheating, and if we ever have to try and                         * been cheating, and if we ever have to try and
363                         * fetch assembly.sig or core.sml in a separate                         * fetch assembly.sig or core.sml in a separate
364                         * traversal, it will fail. *)                         * traversal, it will fail. *)
365                        val sbnode = Compile.newSbnodeTraversal (fn _ => ())                        val sbnode = Compile.newSbnodeTraversal ()
366                        fun get n = let                        fun get n = let
367                            val { ii, ctxt } = valOf (sbnode ginfo n)                            val { ii, ctxt } = valOf (sbnode ginfo n)
368                            val { statpid, statenv, symenv, sympid } = ii                            val { statpid, statenv, symenv, sympid } = ii
# Line 330  Line 436 
436                                     make = make,                                     make = make,
437                                     autoload = autoload,                                     autoload = autoload,
438                                     reset = reset,                                     reset = reset,
439                                     verbose =                                     verbose = StdConfig.verbose,
440                                        EnvConfig.getSet StdConfig.verbose,                                     debug = StdConfig.debug,
441                                     debug =                                     keep_going = StdConfig.keep_going,
442                                        EnvConfig.getSet StdConfig.debug,                                     warn_obsolete = StdConfig.warn_obsolete,
443                                     keep_going =                                     parse_caching = StdConfig.parse_caching,
                                       EnvConfig.getSet StdConfig.keep_going,  
                                    warn_obsolete =  
                                       EnvConfig.getSet StdConfig.warn_obsolete,  
                                    parse_caching =  
                                       EnvConfig.getSet StdConfig.parse_caching,  
444                                     setAnchor = setAnchor,                                     setAnchor = setAnchor,
445                                     cancelAnchor = cancelAnchor,                                     cancelAnchor = cancelAnchor,
446                                     resetPathConfig = resetPathConfig,                                     resetPathConfig = resetPathConfig,
447                                     synchronize = SrcPath.sync,                                     synchronize = SrcPath.sync,
448                                     showPending = showPending })                                     showPending = showPending,
449                                       listLibs = listLibs,
450                                       dismissLib = dismissLib,
451                                       symval = SSV.symval,
452                                       server_start = Servers.start,
453                                       server_stop = Servers.stop,
454                                       server_kill = Servers.kill })
455    
456                    end                    end
457            end            end
# Line 354  Line 461 
461          (system_values := de;          (system_values := de;
462           initTheValues (bootdir, er);           initTheValues (bootdir, er);
463           Cleanup.install initPaths)           Cleanup.install initPaths)
464    
465        fun procCmdLine () = let
466            fun p (f, "sml") = HostMachDepVC.Interact.useFile f
467              | p (f, "sig") = HostMachDepVC.Interact.useFile f
468              | p (f, "cm") = ignore (make f)
469              | p (f, e) =
470                    (print (concat ["!* unable to process `", f,
471                                    "' (unknown extension `", e, "')\n"]))
472            fun c f = (f, String.map Char.toLower
473                              (getOpt (OS.Path.ext f, "<none>")))
474        in
475            case SMLofNJ.getArgs () of
476                ["@CMslave"] => slave ()
477              | l => app (p o c) l
478        end
479    end    end
480  end  end

Legend:
Removed from v.399  
changed lines
  Added in v.450

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