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 453, Tue Oct 26 06:24:34 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          structure Compile =
43              CompileFn (structure MachDepVC = HostMachDepVC
44                         val compile_there = Servers.compile)
45    
46        structure Link =        structure Link =
47            LinkFn (structure MachDepVC = HostMachDepVC            LinkFn (structure MachDepVC = HostMachDepVC
48                    val system_values = system_values)                    val system_values = system_values)
49    
50        structure Compile =        structure BFC =
51            CompileFn (structure MachDepVC = HostMachDepVC)            BfcFn (structure MachDepVC = HostMachDepVC)
52    
53        structure AutoLoad = AutoLoadFn        structure AutoLoad = AutoLoadFn
54            (structure C = Compile            (structure C = Compile
55             structure L = Link)             structure L = Link
56               structure BFC = BFC)
57    
58        fun recomp_runner gp g = let        fun recomp_runner gp g = let
59            val { group, ... } = Compile.newTraversal (Link.evict, g)            fun store _ = ()
60              val { group, ... } = Compile.newTraversal (Link.evict, store, g)
61        in        in
62            isSome (group gp) before Link.cleanup ()            isSome (Servers.withServers (fn () => group gp))
63              before Link.cleanup gp
64        end        end
65    
66        (* This function combines the actions of "recompile" and "exec".        (* This function combines the actions of "recompile" and "exec".
67         * When successful, it combines the results (thus forming a full         * When successful, it combines the results (thus forming a full
68         * environment) and adds it to the toplevel environment. *)         * environment) and adds it to the toplevel environment. *)
69        fun make_runner gp g = let        fun make_runner gp g = let
70            val { group = c_group, ... } = Compile.newTraversal (Link.evict, g)            val { store, get } = BFC.new ()
71            val { group = l_group, ... } = Link.newTraversal g            val { group = c_group, ... } =
72                  Compile.newTraversal (Link.evict, store, g)
73              val { group = l_group, ... } = Link.newTraversal (g, get)
74            val GroupGraph.GROUP { required = rq, ... } = g            val GroupGraph.GROUP { required = rq, ... } = g
75        in        in
76            case c_group gp of            case Servers.withServers (fn () => c_group gp) of
77                NONE => false                NONE => false
78              | SOME { stat, sym} =>              | SOME { stat, sym} =>
79                    (* Before executing the code, we announce the priviliges                    (* Before executing the code, we announce the priviliges
# Line 71  Line 81 
81                     * that everybody has every conceivable privilege, but at                     * that everybody has every conceivable privilege, but at
82                     * the very least we announce which ones are being made                     * the very least we announce which ones are being made
83                     * use of.) *)                     * use of.) *)
84                    (Link.cleanup ();                    (Link.cleanup gp;
85                     if StringSet.isEmpty rq then ()                     if StringSet.isEmpty rq then ()
86                     else Say.say ("$Execute: required privileges are:\n" ::                     else Say.say ("$Execute: required privileges are:\n" ::
87                       map (fn s => ("  " ^ s ^ "\n")) (StringSet.listItems rq));                       map (fn s => ("  " ^ s ^ "\n")) (StringSet.listItems rq));
# Line 93  Line 103 
103    
104        (* Instantiate the stabilization mechanism. *)        (* Instantiate the stabilization mechanism. *)
105        structure Stabilize =        structure Stabilize =
106            StabilizeFn (val recomp = recomp_runner            StabilizeFn (structure MachDepVC = HostMachDepVC
107                         val writeBFC = Compile.writeBFC                         fun recomp gp g = let
108                         val sizeBFC = Compile.sizeBFC                             val GroupGraph.GROUP { grouppath, ... } = g
109                         val getII = Compile.getII                             val { store, get } = BFC.new ()
110                         val destroy_state = Link.evict)                             val { group, ... } =
111                                   Compile.newTraversal (Link.evict, store, g)
112                           in
113                               case Servers.withServers (fn () => group gp) of
114                                   NONE => NONE
115                                 | SOME _ => SOME get
116                           end
117                           fun destroy_state gp i =
118                               (Compile.evict i;
119                                Link.evict gp i)
120                           val getII = Compile.getII)
121    
122        (* Access to the stabilization mechanism is integrated into the        (* Access to the stabilization mechanism is integrated into the
123         * 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 161 
161            end            end
162    
163            fun initPaths () = let            fun initPaths () = let
164                val lpcth = EnvConfig.getSet StdConfig.local_pathconfig NONE                val lpcth = #get StdConfig.local_pathconfig ()
165                val p = case lpcth () of                val p = case lpcth () of
166                    NONE => []                    NONE => []
167                  | SOME f => [f]                  | SOME f => [f]
168                val p = EnvConfig.getSet StdConfig.pathcfgspec NONE :: p                val p = #get StdConfig.pathcfgspec () :: p
169                fun processOne f = PathConfig.processSpecFile (pcmode, f)                fun processOne f = PathConfig.processSpecFile (pcmode, f)
170                    handle _ => ()                    handle _ => ()
171            in            in
# Line 160  Line 180 
180                { primconf = #primconf v,                { primconf = #primconf v,
181                  fnpolicy = fnpolicy,                  fnpolicy = fnpolicy,
182                  pcmode = pcmode,                  pcmode = pcmode,
183                  symenv = SSV.env,                  symval = SSV.symval,
184                  keep_going = EnvConfig.getSet StdConfig.keep_going NONE,                  keep_going = #get StdConfig.keep_going (),
185                  pervasive = #pervasive v,                  pervasive = #pervasive v,
186                  corenv = #corenv v,                  corenv = #corenv v,
187                  pervcorepids = #pervcorepids v }                  pervcorepids = #pervcorepids v }
# Line 190  Line 210 
210                val c = SrcPath.cwdContext ()                val c = SrcPath.cwdContext ()
211                val p = SrcPath.standard pcmode { context = c, spec = s }                val p = SrcPath.standard pcmode { context = c, spec = s }
212            in            in
213                  Servers.cm p;
214                case Parse.parse NONE (param ()) sflag p of                case Parse.parse NONE (param ()) sflag p of
215                    NONE => false                    NONE => false
216                  | SOME (g, gp) => f gp g                  | SOME (g, gp) =>
217                          SafeIO.perform { openIt = fn () => (),
218                                           closeIt = Servers.reset,
219                                           work = fn () => f gp g,
220                                           cleanup = fn () => () }
221              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            end
230    
231            fun stabilize_runner gp g = true            fun stabilize_runner gp g = true
# Line 201  Line 234 
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                  fun shutdown () = OS.Process.exit OS.Process.success
239                  fun say_ok () = Say.say ["SLAVE: ok\n"]
240                  fun say_error () = Say.say ["SLAVE: error\n"]
241                  fun say_pong () = Say.say ["SLAVE: pong\n"]
242    
243                  val touch = HostMachDepVC.Interact.useStream o TextIO.openString
244    
245                  fun waitForStart () = let
246                      val line = TextIO.inputLine TextIO.stdIn
247                  in
248                      if line = "" then shutdown ()
249                      else case String.tokens Char.isSpace line of
250                          ["cm", d, f] => do_cm (d, f)
251                        | ["cmb", archos, d, db] => do_cmb (archos, d, db)
252                        | ["ping"] => (say_pong (); waitForStart ())
253                        | ["finish"] => (say_ok (); waitForStart ())
254                        | ["shutdown"] => shutdown ()
255                        | _ => (say_error (); waitForStart ())
256                  end handle _ => (say_error (); waitForStart ())
257    
258                  and do_cmb (archos, d, db) = let
259                      val _ = OS.FileSys.chDir d
260                      val c = SrcPath.cwdContext ()
261                      val slave = CMBSlave.slave { load = autoload, touch = touch }
262                  in
263                      case slave archos db of
264                          NONE => (say_error (); waitForStart ())
265                        | SOME (g, trav) => let
266                              val _ = say_ok ()
267                              val index = Reachable.snodeMap g
268                          in
269                              workLoop (index, trav, c)
270                          end
271                  end handle _ => (say_error (); waitForStart ())
272    
273                  and do_cm (d, f) = let
274                      val _ = OS.FileSys.chDir d
275                      val c = SrcPath.cwdContext ()
276                      val p = SrcPath.native { context = c, spec = f }
277                  in
278                      case Parse.parse NONE (param ()) NONE p of
279                          NONE => (say_error (); waitForStart ())
280                        | SOME (g, gp) => let
281                              val _ = say_ok ()
282                              val index = Reachable.snodeMap g
283                              val trav = Compile.newSbnodeTraversal () gp
284                              fun trav' sbn = isSome (trav sbn)
285                          in
286                              workLoop (index, trav', c)
287                          end
288                  end handle _ => (say_error (); waitForStart ())
289    
290                  and workLoop (index, trav, c) = let
291                      fun f2sn f =
292                          SrcPathMap.find (index,
293                                           SrcPath.native { context = c,
294                                                            spec = f })
295                      fun loop () = let
296                          val line = TextIO.inputLine TextIO.stdIn
297                      in
298                          if line = "" then shutdown ()
299                          else case String.tokens Char.isSpace line of
300                              ["compile", f] => let
301                                  val p = SrcPath.native { context = c, spec = f }
302                              in
303                                  case SrcPathMap.find (index, p) of
304                                      NONE => (say_error (); loop ())
305                                    | SOME sn => let
306                                          val sbn = DG.SB_SNODE sn
307                                      in
308                                          if trav sbn then (say_ok (); loop ())
309                                          else (say_error (); loop ())
310                                      end handle _ => (say_error (); loop ())
311                              end
312                            | ["cm", d, f] => do_cm (d, f)
313                            | ["cmb", archos, d, db] => do_cmb (archos, d, db)
314                            | ["finish"] => (say_ok (); waitForStart ())
315                            | ["ping"] => (say_pong (); loop ())
316                            | ["shutdown"] => shutdown ()
317                            | _ => (say_error (); loop ())
318                      end handle _ => (say_error (); loop ())
319                  in
320                      loop ()
321                  end
322              in
323                  ignore (Signals.setHandler (Signals.sigINT, Signals.IGNORE));
324                  say_ok ();                (* announce readiness *)
325                  waitForStart () handle _ => ();
326                  OS.Process.exit OS.Process.failure
327              end
328    
329            fun reset () =            fun reset () =
330                (Compile.reset ();                (Compile.reset ();
331                 Link.reset ();                 Link.reset ();
# Line 239  Line 364 
364                val ginfo = { param = { primconf = Primitive.primEnvConf,                val ginfo = { param = { primconf = Primitive.primEnvConf,
365                                        fnpolicy = fnpolicy,                                        fnpolicy = fnpolicy,
366                                        pcmode = pcmode,                                        pcmode = pcmode,
367                                        symenv = SSV.env,                                        symval = SSV.symval,
368                                        keep_going = false,                                        keep_going = false,
369                                        pervasive = E.emptyEnv,                                        pervasive = E.emptyEnv,
370                                        corenv = BE.staticPart BE.emptyEnv,                                        corenv = BE.staticPart BE.emptyEnv,
# Line 256  Line 381 
381                         * been cheating, and if we ever have to try and                         * been cheating, and if we ever have to try and
382                         * fetch assembly.sig or core.sml in a separate                         * fetch assembly.sig or core.sml in a separate
383                         * traversal, it will fail. *)                         * traversal, it will fail. *)
384                        val sbnode = Compile.newSbnodeTraversal (fn _ => ())                        val sbnode = Compile.newSbnodeTraversal ()
385                        fun get n = let                        fun get n = let
386                            val { ii, ctxt } = valOf (sbnode ginfo n)                            val { ii, ctxt } = valOf (sbnode ginfo n)
387                            val { statpid, statenv, symenv, sympid } = ii                            val { statpid, statenv, symenv, sympid } = ii
# Line 330  Line 455 
455                                     make = make,                                     make = make,
456                                     autoload = autoload,                                     autoload = autoload,
457                                     reset = reset,                                     reset = reset,
458                                     verbose =                                     verbose = StdConfig.verbose,
459                                        EnvConfig.getSet StdConfig.verbose,                                     debug = StdConfig.debug,
460                                     debug =                                     keep_going = StdConfig.keep_going,
461                                        EnvConfig.getSet StdConfig.debug,                                     warn_obsolete = StdConfig.warn_obsolete,
462                                     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,  
463                                     setAnchor = setAnchor,                                     setAnchor = setAnchor,
464                                     cancelAnchor = cancelAnchor,                                     cancelAnchor = cancelAnchor,
465                                     resetPathConfig = resetPathConfig,                                     resetPathConfig = resetPathConfig,
466                                     synchronize = SrcPath.sync,                                     synchronize = SrcPath.sync,
467                                     showPending = showPending })                                     showPending = showPending,
468                                       listLibs = listLibs,
469                                       dismissLib = dismissLib,
470                                       symval = SSV.symval,
471                                       server_start = Servers.start,
472                                       server_stop = Servers.stop,
473                                       server_kill = Servers.kill })
474    
475                    end                    end
476            end            end
# Line 354  Line 480 
480          (system_values := de;          (system_values := de;
481           initTheValues (bootdir, er);           initTheValues (bootdir, er);
482           Cleanup.install initPaths)           Cleanup.install initPaths)
483    
484        fun procCmdLine () = let
485            fun p (f, "sml") = HostMachDepVC.Interact.useFile f
486              | p (f, "sig") = HostMachDepVC.Interact.useFile f
487              | p (f, "cm") = ignore (make f)
488              | p (f, e) =
489                    (print (concat ["!* unable to process `", f,
490                                    "' (unknown extension `", e, "')\n"]))
491            fun c f = (f, String.map Char.toLower
492                              (getOpt (OS.Path.ext f, "<none>")))
493        in
494            case SMLofNJ.getArgs () of
495                ["@CMslave"] => (#set StdConfig.verbose false; slave ())
496              | l => app (p o c) l
497        end
498    end    end
499  end  end

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

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