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

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

Parent Directory Parent Directory | Revision Log Revision Log


Revision 365 - (view) (download)

1 : blume 360 functor LinkCM (structure HostMachDepVC : MACHDEP_VC) = struct
2 :    
3 : blume 362 datatype envrequest = AUTOLOAD | BARE
4 :    
5 : blume 360 local
6 :     structure YaccTool = YaccTool
7 :     structure LexTool = LexTool
8 :     structure BurgTool = BurgTool
9 :    
10 :     structure E = GenericVC.Environment
11 :     structure SE = GenericVC.StaticEnv
12 :     structure ER = GenericVC.EnvRef
13 :     structure BE = GenericVC.BareEnvironment
14 :     structure CMSE = GenericVC.CMStaticEnv
15 :     structure S = GenericVC.Symbol
16 :     structure CoerceEnv = GenericVC.CoerceEnv
17 :     structure EM = GenericVC.ErrorMsg
18 :    
19 :     val os = SMLofNJ.SysInfo.getOSKind ()
20 :    
21 :     structure SSV =
22 :     SpecificSymValFn (structure MachDepVC = HostMachDepVC
23 :     val os = os)
24 :    
25 : blume 362 val emptydyn = E.dynamicPart E.emptyEnv
26 :     val system_values = ref emptydyn
27 : blume 360
28 :     (* Instantiate the persistent state functor; this includes
29 :     * the binfile cache and the dynamic value cache *)
30 :     structure FullPersstate =
31 :     FullPersstateFn (structure MachDepVC = HostMachDepVC
32 : blume 362 val system_values = system_values)
33 : blume 360
34 :     (* Create two arguments appropriate for being passed to
35 :     * CompileGenericFn. One instantiation of that functor
36 :     * is responsible for "recompile" traversals, the other one
37 :     * does "link" traversals. Notice how the two share the same
38 :     * underlying state. *)
39 :     structure Recomp = RecompFn (structure PS = FullPersstate)
40 :     structure Exec = ExecFn (structure PS = FullPersstate)
41 :    
42 :     (* make the two traversals *)
43 :     structure RT = CompileGenericFn (structure CT = Recomp)
44 :     structure ET = CompileGenericFn (structure CT = Exec)
45 :    
46 :     (* The StabilizeFn functor needs a way of converting bnodes to
47 :     * dependency-analysis environments. This can be achieved quite
48 :     * conveniently by a "recompile" traversal for bnodes. *)
49 :     fun bn2statenv gp i = #1 (#stat (valOf (RT.bnode gp i)))
50 :     handle Option => raise Fail "bn2statenv"
51 :    
52 :     (* exec_group is basically the same as ET.group with
53 :     * two additional actions to be taken:
54 :     * 1. Before executing the code, we announce the priviliges
55 :     * that are being invoked. (For the time being, we assume
56 :     * that everybody has every conceivable privilege, but at the
57 :     * very least we announce which ones are being made use of.)
58 :     * 2. After we are done we must make the values of "shared"
59 :     * compilation units permanent. *)
60 :     fun exec_group gp (g as GroupGraph.GROUP { required = rq, ... }) =
61 :     (if StringSet.isEmpty rq then ()
62 :     else Say.say ("$Execute: required privileges are:\n" ::
63 :     map (fn s => (" " ^ s ^ "\n")) (StringSet.listItems rq));
64 :     ET.group gp g
65 :     before FullPersstate.rememberShared ())
66 :    
67 :     fun recomp_runner gp g = isSome (RT.group gp g)
68 :    
69 :     (* This function combines the actions of "recompile" and "exec".
70 :     * When successful, it combines the results (thus forming a full
71 :     * environment) and adds it to the toplevel environment. *)
72 :     fun make_runner gp g =
73 :     case RT.group gp g of
74 :     NONE => false
75 :     | SOME { stat, sym} =>
76 :     (case exec_group gp g of
77 :     NONE => false
78 :     | SOME dyn => let
79 :     val delta = E.mkenv { static = stat, symbolic = sym,
80 :     dynamic = dyn }
81 :     val base = #get ER.topLevel ()
82 :     val new = BE.concatEnv (CoerceEnv.e2b delta, base)
83 :     in
84 :     #set ER.topLevel new;
85 :     Say.vsay ["[New bindings added.]\n"];
86 :     true
87 :     end)
88 :    
89 :     fun al_loadit gp m =
90 :     case RT.impexpmap gp m of
91 :     NONE => NONE
92 :     | SOME { stat, sym } => let
93 :     fun exec () =
94 :     ET.impexpmap gp m
95 :     before FullPersstate.rememberShared ()
96 :     in
97 :     case exec () of
98 :     NONE => NONE
99 :     | SOME dyn => let
100 :     val e = E.mkenv { static = stat, symbolic = sym,
101 :     dynamic =dyn }
102 :     val be = GenericVC.CoerceEnv.e2b e
103 :     in
104 :     SOME be
105 :     end
106 :     end
107 :    
108 :     val al_greg = GroupReg.new ()
109 :    
110 :     (* Instantiate the stabilization mechanism. *)
111 :     structure Stabilize =
112 :     StabilizeFn (val bn2statenv = bn2statenv
113 :     val getPid = FullPersstate.pid_fetch_sml
114 : blume 363 val recomp = recomp_runner
115 :     val transfer_state = FullPersstate.transfer_state)
116 : blume 360
117 :     (* Access to the stabilization mechanism is integrated into the
118 :     * parser. I'm not sure if this is the cleanest way, but it works
119 :     * well enough. *)
120 : blume 362 structure Parse = ParseFn (structure Stabilize = Stabilize
121 :     val pending = AutoLoad.getPending)
122 : blume 360
123 :     local
124 :     type kernelValues =
125 :     { primconf : Primitive.configuration,
126 :     pervasive : E.environment,
127 :     corenv : BE.staticEnv,
128 :     pervcorepids : PidSet.set }
129 :    
130 :     val fnpolicy = FilenamePolicy.colocate
131 :     { os = os, arch = HostMachDepVC.architecture }
132 :    
133 : blume 361 val pcmode = PathConfig.new ()
134 : blume 360
135 :     val theValues = ref (NONE: kernelValues option)
136 :    
137 :     in
138 : blume 365 fun setAnchor (a, s) = PathConfig.set (pcmode, a, s)
139 :    
140 : blume 361 fun initPaths () = let
141 :     val p =
142 :     case OS.Process.getEnv "HOME" of
143 :     NONE => []
144 :     | SOME h => [OS.Path.concat (h, ".smlnj-pathconfig")]
145 :     val p = EnvConfig.getSet StdConfig.pathcfgspec NONE :: p
146 :     fun processOne f = PathConfig.processSpecFile (pcmode, f)
147 :     handle _ => ()
148 :     in
149 :     app processOne p
150 :     end
151 :    
152 : blume 360 fun param () = let
153 :     val v = valOf (!theValues)
154 :     handle Option =>
155 :     raise Fail "CMBoot: theParam not initialized"
156 :     in
157 :     { primconf = #primconf v,
158 :     fnpolicy = fnpolicy,
159 : blume 361 pcmode = pcmode,
160 : blume 360 symenv = SSV.env,
161 :     keep_going = EnvConfig.getSet StdConfig.keep_going NONE,
162 :     pervasive = #pervasive v,
163 :     corenv = #corenv v,
164 :     pervcorepids = #pervcorepids v }
165 :     end
166 :    
167 :     fun autoload s = let
168 :     val c = SrcPath.cwdContext ()
169 :     val p = SrcPath.standard pcmode { context = c, spec = s }
170 :     in
171 :     case Parse.parse (SOME al_greg) (param ()) NONE p of
172 :     NONE => false
173 :     | SOME (g, _) =>
174 :     (AutoLoad.register (GenericVC.EnvRef.topLevel, g);
175 :     true)
176 :     end
177 :    
178 :     fun al_ginfo () = { param = param (),
179 :     groupreg = al_greg,
180 :     errcons = EM.defaultConsumer () }
181 :    
182 :     val al_manager =
183 :     AutoLoad.mkManager (fn m => al_loadit (al_ginfo ()) m)
184 :    
185 :     fun al_manager' (ast, _, ter) = al_manager (ast, ter)
186 :    
187 : blume 362 fun run sflag f s = let
188 :     val c = SrcPath.cwdContext ()
189 :     val p = SrcPath.standard pcmode { context = c, spec = s }
190 :     in
191 :     case Parse.parse NONE (param ()) sflag p of
192 :     NONE => false
193 :     | SOME (g, gp) => f gp g
194 :     end
195 :    
196 :     fun stabilize_runner gp g = true
197 :    
198 :     fun stabilize recursively = run (SOME recursively) stabilize_runner
199 :     val recomp = run NONE recomp_runner
200 :     val make = run NONE make_runner
201 :    
202 :     fun reset () =
203 :     (FullPersstate.reset ();
204 :     RT.resetAll ();
205 :     ET.resetAll ();
206 :     Recomp.reset ();
207 :     Exec.reset ();
208 :     AutoLoad.reset ();
209 :     SmlInfo.forgetAllBut SrcPathSet.empty)
210 :    
211 :     fun initTheValues (bootdir, er) = let
212 : blume 361 val _ = let
213 :     fun listDir ds = let
214 :     fun loop l =
215 :     case OS.FileSys.readDir ds of
216 :     "" => l
217 :     | x => loop (x :: l)
218 :     in
219 :     loop []
220 :     end
221 :     val fileList = SafeIO.perform
222 :     { openIt = fn () => OS.FileSys.openDir bootdir,
223 :     closeIt = OS.FileSys.closeDir,
224 :     work = listDir,
225 :     cleanup = fn () => () }
226 :     fun isDir x =
227 :     OS.FileSys.isDir x handle _ => false
228 :     fun subDir x = let
229 :     val d = OS.Path.concat (bootdir, x)
230 :     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 : blume 360 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 :     fun get n = let
255 :     val { stat = (s, sp), sym = (sy, syp), ctxt } =
256 :     valOf (RT.sbnode ginfo n)
257 :     val d = Exec.env2result (valOf (ET.sbnode ginfo n))
258 :     val env = E.mkenv { static = s, symbolic = sy,
259 :     dynamic = d }
260 :     val pidInfo = { statpid = sp, sympid = syp,
261 :     ctxt = ctxt }
262 :     in
263 :     (env, pidInfo)
264 :     end
265 :     fun getPspec (name, n) = let
266 :     val (env, pidInfo) = get n
267 :     in
268 :     { name = name, env = env, pidInfo = pidInfo }
269 :     end
270 :    
271 :     val (core, corePidInfo) = get core
272 :     val corenv = CoerceEnv.es2bs (E.staticPart core)
273 :     val (rts, _) = get rts
274 :     val (pervasive0, pervPidInfo) = get pervasive
275 :     val pspecs = map getPspec primitives
276 :     val core_symdyn =
277 :     E.mkenv { static = E.staticPart E.emptyEnv,
278 :     dynamic = E.dynamicPart core,
279 :     symbolic = E.symbolicPart core }
280 :     val pervasive = E.layerEnv (pervasive0, core_symdyn)
281 :     val pervcorepids =
282 :     PidSet.addList (PidSet.empty,
283 :     [#statpid corePidInfo,
284 :     #statpid pervPidInfo,
285 :     #sympid pervPidInfo])
286 :     in
287 :     #set ER.core corenv;
288 :     #set ER.pervasive pervasive;
289 :     #set ER.topLevel BE.emptyEnv;
290 :     theValues :=
291 :     SOME { primconf = Primitive.configuration pspecs,
292 :     pervasive = pervasive,
293 :     corenv = corenv,
294 :     pervcorepids = pervcorepids };
295 : blume 362 case er of
296 :     BARE =>
297 :     (make "basis.cm";
298 :     make "host-compiler.cm";
299 :     system_values := emptydyn)
300 :     | AUTOLOAD =>
301 :     (HostMachDepVC.Interact.installCompManager
302 :     (SOME al_manager');
303 :     autoload "basis.cm";
304 :     AutoLoadHook.autoloadHook := autoload)
305 : blume 360 end
306 :     end
307 :     end
308 :     in
309 :     structure CM = struct
310 : blume 362 val stabilize = stabilize
311 :     val recomp = recomp
312 :     val make = make
313 : blume 360 val autoload = autoload
314 : blume 362 val reset = reset
315 : blume 365
316 :     val verbose = EnvConfig.getSet StdConfig.verbose
317 :     val debug = EnvConfig.getSet StdConfig.debug
318 :     val keep_going = EnvConfig.getSet StdConfig.keep_going
319 :     val parse_caching = EnvConfig.getSet StdConfig.parse_caching
320 :     val setAnchor = setAnchor
321 : blume 360 end
322 :    
323 : blume 362 fun init (bootdir, de, er) =
324 :     (system_values := de;
325 :     initTheValues (bootdir, er);
326 : blume 361 Cleanup.install initPaths)
327 : blume 360 end
328 :     end

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