Home My Page Projects Code Snippets Project Openings SML/NJ
Summary Activity Forums Tracker Lists Tasks Docs Surveys News SCM Files

SCM Repository

[smlnj] Annotation of /sml/trunk/src/cm/main/cm-boot.sml
ViewVC logotype

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

Parent Directory Parent Directory | Revision Log Revision Log


Revision 400 - (view) (download)

1 : blume 375 (*
2 :     * This is the module that actually puts together the contents of the
3 :     * structure CM that people find at the top-level. The "real" structure
4 :     * CM is defined in CmHook, but it needs to be initialized at bootstrap
5 :     * time -- and _that_ is what's done here.
6 :     *
7 :     * Copyright (c) 1999 by Lucent Bell Laboratories
8 :     *
9 :     * author: Matthias Blume (blume@cs.princeton.edu)
10 :     *)
11 :     functor LinkCM (structure HostMachDepVC : MACHDEP_VC) = struct
12 :    
13 :     datatype envrequest = AUTOLOAD | BARE
14 :    
15 :     local
16 :     structure YaccTool = YaccTool
17 :     structure LexTool = LexTool
18 :     structure BurgTool = BurgTool
19 :    
20 :     structure E = GenericVC.Environment
21 :     structure SE = GenericVC.StaticEnv
22 :     structure ER = GenericVC.EnvRef
23 :     structure BE = GenericVC.BareEnvironment
24 :     structure CMSE = GenericVC.CMStaticEnv
25 :     structure S = GenericVC.Symbol
26 :     structure CoerceEnv = GenericVC.CoerceEnv
27 :     structure EM = GenericVC.ErrorMsg
28 :     structure BF = HostMachDepVC.Binfile
29 : blume 380 structure P = OS.Path
30 :     structure F = OS.FileSys
31 : blume 375
32 :     val os = SMLofNJ.SysInfo.getOSKind ()
33 :    
34 :     structure SSV =
35 :     SpecificSymValFn (structure MachDepVC = HostMachDepVC
36 :     val os = os)
37 :    
38 :     val emptydyn = E.dynamicPart E.emptyEnv
39 :     val system_values = ref emptydyn
40 :    
41 : blume 400 structure Compile =
42 :     CompileFn (structure MachDepVC = HostMachDepVC)
43 :    
44 : blume 399 structure Link =
45 :     LinkFn (structure MachDepVC = HostMachDepVC
46 : blume 400 val getBFC = Compile.getBFC
47 : blume 399 val system_values = system_values)
48 : blume 375
49 :     structure AutoLoad = AutoLoadFn
50 : blume 399 (structure C = Compile
51 :     structure L = Link)
52 : blume 375
53 : blume 399 fun recomp_runner gp g = let
54 :     val { group, ... } = Compile.newTraversal (Link.evict, g)
55 :     in
56 : blume 400 isSome (group gp) before Link.cleanup gp
57 : blume 399 end
58 : blume 375
59 :     (* This function combines the actions of "recompile" and "exec".
60 :     * When successful, it combines the results (thus forming a full
61 :     * environment) and adds it to the toplevel environment. *)
62 : blume 399 fun make_runner gp g = let
63 :     val { group = c_group, ... } = Compile.newTraversal (Link.evict, g)
64 :     val { group = l_group, ... } = Link.newTraversal g
65 :     val GroupGraph.GROUP { required = rq, ... } = g
66 :     in
67 :     case c_group gp of
68 : blume 375 NONE => false
69 :     | SOME { stat, sym} =>
70 : blume 399 (* Before executing the code, we announce the priviliges
71 :     * that are being invoked. (For the time being, we assume
72 :     * that everybody has every conceivable privilege, but at
73 :     * the very least we announce which ones are being made
74 :     * use of.) *)
75 : blume 400 (Link.cleanup gp;
76 : blume 399 if StringSet.isEmpty rq then ()
77 :     else Say.say ("$Execute: required privileges are:\n" ::
78 :     map (fn s => (" " ^ s ^ "\n")) (StringSet.listItems rq));
79 :     case l_group gp of
80 : blume 375 NONE => false
81 :     | SOME dyn => let
82 :     val delta = E.mkenv { static = stat, symbolic = sym,
83 :     dynamic = dyn }
84 :     val base = #get ER.topLevel ()
85 :     val new = BE.concatEnv (CoerceEnv.e2b delta, base)
86 :     in
87 :     #set ER.topLevel new;
88 :     Say.vsay ["[New bindings added.]\n"];
89 :     true
90 :     end)
91 : blume 399 end
92 : blume 375
93 :     val al_greg = GroupReg.new ()
94 :    
95 :     (* Instantiate the stabilization mechanism. *)
96 :     structure Stabilize =
97 : blume 399 StabilizeFn (val recomp = recomp_runner
98 :     val writeBFC = Compile.writeBFC
99 :     val sizeBFC = Compile.sizeBFC
100 :     val getII = Compile.getII
101 : blume 400 fun destroy_state gp i = (Compile.evict i; Link.evict gp i))
102 : blume 375
103 :     (* Access to the stabilization mechanism is integrated into the
104 :     * parser. I'm not sure if this is the cleanest way, but it works
105 :     * well enough. *)
106 :     structure Parse = ParseFn (structure Stabilize = Stabilize
107 :     val pending = AutoLoad.getPending)
108 :    
109 :     local
110 :     type kernelValues =
111 :     { primconf : Primitive.configuration,
112 :     pervasive : E.environment,
113 :     corenv : BE.staticEnv,
114 :     pervcorepids : PidSet.set }
115 :    
116 :     val fnpolicy = FilenamePolicy.colocate
117 :     { os = os, arch = HostMachDepVC.architecture }
118 :    
119 :     val pcmode = PathConfig.new ()
120 :    
121 :     val theValues = ref (NONE: kernelValues option)
122 :    
123 :     in
124 : blume 377 fun setAnchor (a, s) =
125 :     (PathConfig.set (pcmode, a, s); SrcPath.sync ())
126 :     (* cancelling anchors cannot affect the order of existing paths
127 :     * (it may invalidate some paths; but all other ones stay as
128 :     * they are) *)
129 : blume 375 fun cancelAnchor a = PathConfig.cancel (pcmode, a)
130 : blume 377 (* same goes for reset because it just cancels all anchors... *)
131 : blume 375 fun resetPathConfig () = PathConfig.reset pcmode
132 :    
133 :     fun showPending () = let
134 :     fun one (s, _) = let
135 :     val nss = Symbol.nameSpaceToString (Symbol.nameSpace s)
136 :     val n = Symbol.name s
137 :     in
138 :     Say.say [" ", nss, " ", n, "\n"]
139 :     end
140 :     in
141 :     SymbolMap.appi one (AutoLoad.getPending ())
142 :     end
143 :    
144 :     fun initPaths () = let
145 :     val lpcth = EnvConfig.getSet StdConfig.local_pathconfig NONE
146 :     val p = case lpcth () of
147 :     NONE => []
148 :     | SOME f => [f]
149 :     val p = EnvConfig.getSet StdConfig.pathcfgspec NONE :: p
150 :     fun processOne f = PathConfig.processSpecFile (pcmode, f)
151 :     handle _ => ()
152 :     in
153 :     app processOne p
154 :     end
155 :    
156 :     fun param () = let
157 :     val v = valOf (!theValues)
158 :     handle Option =>
159 :     raise Fail "CMBoot: theParam not initialized"
160 :     in
161 :     { primconf = #primconf v,
162 :     fnpolicy = fnpolicy,
163 :     pcmode = pcmode,
164 :     symenv = SSV.env,
165 :     keep_going = EnvConfig.getSet StdConfig.keep_going NONE,
166 :     pervasive = #pervasive v,
167 :     corenv = #corenv v,
168 :     pervcorepids = #pervcorepids v }
169 :     end
170 :    
171 :     fun autoload s = let
172 :     val c = SrcPath.cwdContext ()
173 :     val p = SrcPath.standard pcmode { context = c, spec = s }
174 :     in
175 :     case Parse.parse (SOME al_greg) (param ()) NONE p of
176 :     NONE => false
177 :     | SOME (g, _) =>
178 :     (AutoLoad.register (GenericVC.EnvRef.topLevel, g);
179 :     true)
180 :     end
181 :    
182 :     fun al_ginfo () = { param = param (),
183 :     groupreg = al_greg,
184 :     errcons = EM.defaultConsumer () }
185 :    
186 :     val al_manager = AutoLoad.mkManager al_ginfo
187 :    
188 :     fun al_manager' (ast, _, ter) = al_manager (ast, ter)
189 :    
190 :     fun run sflag f s = let
191 :     val c = SrcPath.cwdContext ()
192 :     val p = SrcPath.standard pcmode { context = c, spec = s }
193 :     in
194 :     case Parse.parse NONE (param ()) sflag p of
195 :     NONE => false
196 :     | SOME (g, gp) => f gp g
197 :     end
198 :    
199 :     fun stabilize_runner gp g = true
200 :    
201 :     fun stabilize recursively = run (SOME recursively) stabilize_runner
202 :     val recomp = run NONE recomp_runner
203 :     val make = run NONE make_runner
204 :    
205 :     fun reset () =
206 : blume 399 (Compile.reset ();
207 :     Link.reset ();
208 : blume 375 AutoLoad.reset ();
209 :     Parse.reset ();
210 :     SmlInfo.forgetAllBut SrcPathSet.empty)
211 :    
212 :     fun initTheValues (bootdir, er) = let
213 :     val _ = let
214 :     fun listDir ds = let
215 :     fun loop l =
216 : blume 380 case F.readDir ds of
217 : blume 375 "" => l
218 :     | x => loop (x :: l)
219 :     in
220 :     loop []
221 :     end
222 :     val fileList = SafeIO.perform
223 : blume 380 { openIt = fn () => F.openDir bootdir,
224 :     closeIt = F.closeDir,
225 : blume 375 work = listDir,
226 :     cleanup = fn () => () }
227 : blume 380 fun isDir x = F.isDir x handle _ => false
228 : blume 375 fun subDir x = let
229 : blume 380 val d = P.concat (bootdir, x)
230 : blume 375 in
231 :     if isDir d then SOME (x, d) else NONE
232 :     end
233 :     val pairList = List.mapPartial subDir fileList
234 :     in
235 :     app (fn (x, d) => PathConfig.set (pcmode, x, d)) pairList
236 :     end
237 :     val initgspec =
238 :     SrcPath.standard pcmode { context = SrcPath.cwdContext (),
239 :     spec = BtNames.initgspec }
240 :     val ginfo = { param = { primconf = Primitive.primEnvConf,
241 :     fnpolicy = fnpolicy,
242 :     pcmode = pcmode,
243 :     symenv = SSV.env,
244 :     keep_going = false,
245 :     pervasive = E.emptyEnv,
246 :     corenv = BE.staticPart BE.emptyEnv,
247 :     pervcorepids = PidSet.empty },
248 :     groupreg = GroupReg.new (),
249 :     errcons = EM.defaultConsumer () }
250 :     in
251 :     case BuildInitDG.build ginfo initgspec of
252 :     NONE => raise Fail "CMBoot: BuiltInitDG.build"
253 :     | SOME { rts, core, pervasive, primitives, ... } => let
254 :     (* It is absolutely crucial that we don't finish the
255 :     * recomp traversal until we are done with all
256 :     * nodes of the InitDG. This is because we have
257 :     * been cheating, and if we ever have to try and
258 :     * fetch assembly.sig or core.sml in a separate
259 :     * traversal, it will fail. *)
260 : blume 400 val sbnode = Compile.newSbnodeTraversal ()
261 : blume 375 fun get n = let
262 : blume 399 val { ii, ctxt } = valOf (sbnode ginfo n)
263 :     val { statpid, statenv, symenv, sympid } = ii
264 :     (* We have not implemented the "sbnode" part
265 :     * in the Link module.
266 : blume 375 * But at boot time any relevant value should be
267 : blume 399 * available as a sysval, so there is no problem.
268 :     *
269 :     * WARNING! HACK!
270 :     * We are cheating somewhat by taking advantage
271 :     * of the fact that the staticPid is always
272 :     * the same as the exportPid if the latter exists.
273 :     *)
274 :     val d = case Link.sysval (SOME statpid) of
275 :     SOME d => d
276 :     | NONE => emptydyn
277 :     val env = E.mkenv { static = statenv (),
278 :     symbolic = symenv (),
279 : blume 375 dynamic = d }
280 : blume 399 val pidInfo = { statpid = statpid,
281 :     sympid = sympid,
282 : blume 375 ctxt = ctxt }
283 :     in
284 :     (env, pidInfo)
285 :     end
286 :     fun getPspec (name, n) = let
287 :     val (env, pidInfo) = get n
288 :     in
289 :     { name = name, env = env, pidInfo = pidInfo }
290 :     end
291 :    
292 :     val (core, corePidInfo) = get core
293 :     val corenv = CoerceEnv.es2bs (E.staticPart core)
294 :     val (rts, _) = get rts
295 :     val (pervasive0, pervPidInfo) = get pervasive
296 :     val pspecs = map getPspec primitives
297 :     val core_symdyn =
298 :     E.mkenv { static = E.staticPart E.emptyEnv,
299 :     dynamic = E.dynamicPart core,
300 :     symbolic = E.symbolicPart core }
301 :     val pervasive = E.layerEnv (pervasive0, core_symdyn)
302 :     val pervcorepids =
303 :     PidSet.addList (PidSet.empty,
304 :     [#statpid corePidInfo,
305 :     #statpid pervPidInfo,
306 :     #sympid pervPidInfo])
307 :     in
308 : blume 399 Compile.reset ();
309 :     Link.reset ();
310 : blume 375 #set ER.core corenv;
311 :     #set ER.pervasive pervasive;
312 :     #set ER.topLevel BE.emptyEnv;
313 :     theValues :=
314 :     SOME { primconf = Primitive.configuration pspecs,
315 :     pervasive = pervasive,
316 :     corenv = corenv,
317 :     pervcorepids = pervcorepids };
318 :     case er of
319 :     BARE =>
320 :     (make "basis.cm";
321 :     make "host-compiler.cm";
322 :     system_values := emptydyn)
323 :     | AUTOLOAD =>
324 :     (HostMachDepVC.Interact.installCompManager
325 :     (SOME al_manager');
326 :     autoload "basis.cm";
327 :     autoload "host-cm.cm";
328 :     CmHook.init
329 :     { stabilize = stabilize,
330 :     recomp = recomp,
331 :     make = make,
332 :     autoload = autoload,
333 :     reset = reset,
334 :     verbose =
335 :     EnvConfig.getSet StdConfig.verbose,
336 :     debug =
337 :     EnvConfig.getSet StdConfig.debug,
338 :     keep_going =
339 :     EnvConfig.getSet StdConfig.keep_going,
340 : blume 397 warn_obsolete =
341 :     EnvConfig.getSet StdConfig.warn_obsolete,
342 : blume 375 parse_caching =
343 :     EnvConfig.getSet StdConfig.parse_caching,
344 :     setAnchor = setAnchor,
345 :     cancelAnchor = cancelAnchor,
346 :     resetPathConfig = resetPathConfig,
347 :     synchronize = SrcPath.sync,
348 :     showPending = showPending })
349 :    
350 :     end
351 :     end
352 :     end
353 :     in
354 :     fun init (bootdir, de, er) =
355 :     (system_values := de;
356 :     initTheValues (bootdir, er);
357 :     Cleanup.install initPaths)
358 :     end
359 :     end

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