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

Parent Directory | Revision Log

---

Revision 360 - (view) (download)

1 :	blume	360	functor LinkCM (structure HostMachDepVC : MACHDEP_VC) = struct
2 :
3 :			local
4 :			structure YaccTool = YaccTool
5 :			structure LexTool = LexTool
6 :			structure BurgTool = BurgTool
7 :
8 :			structure E = GenericVC.Environment
9 :			structure SE = GenericVC.StaticEnv
10 :			structure ER = GenericVC.EnvRef
11 :			structure BE = GenericVC.BareEnvironment
12 :			structure CMSE = GenericVC.CMStaticEnv
13 :			structure S = GenericVC.Symbol
14 :			structure CoerceEnv = GenericVC.CoerceEnv
15 :			structure EM = GenericVC.ErrorMsg
16 :
17 :			val os = SMLofNJ.SysInfo.getOSKind ()
18 :
19 :			structure SSV =
20 :			SpecificSymValFn (structure MachDepVC = HostMachDepVC
21 :			val os = os)
22 :
23 :			val warmup_hook = ref (NONE: E.dynenv option)
24 :
25 :			(* Instantiate the persistent state functor; this includes
26 :			* the binfile cache and the dynamic value cache *)
27 :			structure FullPersstate =
28 :			FullPersstateFn (structure MachDepVC = HostMachDepVC
29 :			val warmup_hook = warmup_hook)
30 :
31 :			(* Create two arguments appropriate for being passed to
32 :			* CompileGenericFn. One instantiation of that functor
33 :			* is responsible for "recompile" traversals, the other one
34 :			* does "link" traversals. Notice how the two share the same
35 :			* underlying state. *)
36 :			structure Recomp = RecompFn (structure PS = FullPersstate)
37 :			structure Exec = ExecFn (structure PS = FullPersstate)
38 :
39 :			(* make the two traversals *)
40 :			structure RT = CompileGenericFn (structure CT = Recomp)
41 :			structure ET = CompileGenericFn (structure CT = Exec)
42 :
43 :			(* The StabilizeFn functor needs a way of converting bnodes to
44 :			* dependency-analysis environments. This can be achieved quite
45 :			* conveniently by a "recompile" traversal for bnodes. *)
46 :			fun bn2statenv gp i = #1 (#stat (valOf (RT.bnode gp i)))
47 :			handle Option => raise Fail "bn2statenv"
48 :
49 :			(* exec_group is basically the same as ET.group with
50 :			* two additional actions to be taken:
51 :			* 1. Before executing the code, we announce the priviliges
52 :			* that are being invoked. (For the time being, we assume
53 :			* that everybody has every conceivable privilege, but at the
54 :			* very least we announce which ones are being made use of.)
55 :			* 2. After we are done we must make the values of "shared"
56 :			* compilation units permanent. *)
57 :			fun exec_group gp (g as GroupGraph.GROUP { required = rq, ... }) =
58 :			(if StringSet.isEmpty rq then ()
59 :			else Say.say ("$Execute: required privileges are:\n" ::
60 :			map (fn s => (" " ^ s ^ "\n")) (StringSet.listItems rq));
61 :			ET.group gp g
62 :			before FullPersstate.rememberShared ())
63 :
64 :			fun recomp_runner gp g = isSome (RT.group gp g)
65 :
66 :			(* This function combines the actions of "recompile" and "exec".
67 :			* When successful, it combines the results (thus forming a full
68 :			* environment) and adds it to the toplevel environment. *)
69 :			fun make_runner gp g =
70 :			case RT.group gp g of
71 :			NONE => false
72 :			| SOME { stat, sym} =>
73 :			(case exec_group gp g of
74 :			NONE => false
75 :			| SOME dyn => let
76 :			val delta = E.mkenv { static = stat, symbolic = sym,
77 :			dynamic = dyn }
78 :			val base = #get ER.topLevel ()
79 :			val new = BE.concatEnv (CoerceEnv.e2b delta, base)
80 :			in
81 :			#set ER.topLevel new;
82 :			Say.vsay ["[New bindings added.]\n"];
83 :			true
84 :			end)
85 :
86 :			fun al_loadit gp m =
87 :			case RT.impexpmap gp m of
88 :			NONE => NONE
89 :			| SOME { stat, sym } => let
90 :			fun exec () =
91 :			ET.impexpmap gp m
92 :			before FullPersstate.rememberShared ()
93 :			in
94 :			case exec () of
95 :			NONE => NONE
96 :			| SOME dyn => let
97 :			val e = E.mkenv { static = stat, symbolic = sym,
98 :			dynamic =dyn }
99 :			val be = GenericVC.CoerceEnv.e2b e
100 :			in
101 :			SOME be
102 :			end
103 :			end
104 :
105 :			val al_greg = GroupReg.new ()
106 :
107 :			(* Instantiate the stabilization mechanism. *)
108 :			structure Stabilize =
109 :			StabilizeFn (val bn2statenv = bn2statenv
110 :			val getPid = FullPersstate.pid_fetch_sml
111 :			val warmup = FullPersstate.new_bininfo
112 :			val recomp = recomp_runner)
113 :
114 :			(* Access to the stabilization mechanism is integrated into the
115 :			* parser. I'm not sure if this is the cleanest way, but it works
116 :			* well enough. *)
117 :			structure Parse = ParseFn (structure Stabilize = Stabilize)
118 :
119 :			local
120 :			type kernelValues =
121 :			{ primconf : Primitive.configuration,
122 :			pervasive : E.environment,
123 :			corenv : BE.staticEnv,
124 :			pervcorepids : PidSet.set }
125 :
126 :			val fnpolicy = FilenamePolicy.colocate
127 :			{ os = os, arch = HostMachDepVC.architecture }
128 :
129 :			val pcmodeRef = ref (PathConfig.hardwire [])
130 :
131 :			val theValues = ref (NONE: kernelValues option)
132 :
133 :			in
134 :			fun param () = let
135 :			val v = valOf (!theValues)
136 :			handle Option =>
137 :			raise Fail "CMBoot: theParam not initialized"
138 :			in
139 :			{ primconf = #primconf v,
140 :			fnpolicy = fnpolicy,
141 :			pcmode = !pcmodeRef,
142 :			symenv = SSV.env,
143 :			keep_going = EnvConfig.getSet StdConfig.keep_going NONE,
144 :			pervasive = #pervasive v,
145 :			corenv = #corenv v,
146 :			pervcorepids = #pervcorepids v }
147 :			end
148 :
149 :			fun autoload s = let
150 :			val c = SrcPath.cwdContext ()
151 :			val pcmode = !pcmodeRef
152 :			val p = SrcPath.standard pcmode { context = c, spec = s }
153 :			in
154 :			case Parse.parse (SOME al_greg) (param ()) NONE p of
155 :			NONE => false
156 :			| SOME (g, _) =>
157 :			(AutoLoad.register (GenericVC.EnvRef.topLevel, g);
158 :			true)
159 :			end
160 :
161 :			fun al_ginfo () = { param = param (),
162 :			groupreg = al_greg,
163 :			errcons = EM.defaultConsumer () }
164 :
165 :			val al_manager =
166 :			AutoLoad.mkManager (fn m => al_loadit (al_ginfo ()) m)
167 :
168 :			fun al_manager' (ast, _, ter) = al_manager (ast, ter)
169 :
170 :			fun initTheValues bootdir = let
171 :			val pcmode = PathConfig.bootcfg bootdir
172 :			val _ = pcmodeRef := pcmode
173 :			val initgspec =
174 :			SrcPath.standard pcmode { context = SrcPath.cwdContext (),
175 :			spec = BtNames.initgspec }
176 :			val ginfo = { param = { primconf = Primitive.primEnvConf,
177 :			fnpolicy = fnpolicy,
178 :			pcmode = pcmode,
179 :			symenv = SSV.env,
180 :			keep_going = false,
181 :			pervasive = E.emptyEnv,
182 :			corenv = BE.staticPart BE.emptyEnv,
183 :			pervcorepids = PidSet.empty },
184 :			groupreg = GroupReg.new (),
185 :			errcons = EM.defaultConsumer () }
186 :			in
187 :			case BuildInitDG.build ginfo initgspec of
188 :			NONE => raise Fail "CMBoot: BuiltInitDG.build"
189 :			| SOME { rts, core, pervasive, primitives, ... } => let
190 :			fun get n = let
191 :			val { stat = (s, sp), sym = (sy, syp), ctxt } =
192 :			valOf (RT.sbnode ginfo n)
193 :			val d = Exec.env2result (valOf (ET.sbnode ginfo n))
194 :			val env = E.mkenv { static = s, symbolic = sy,
195 :			dynamic = d }
196 :			val pidInfo = { statpid = sp, sympid = syp,
197 :			ctxt = ctxt }
198 :			in
199 :			(env, pidInfo)
200 :			end
201 :			fun getPspec (name, n) = let
202 :			val (env, pidInfo) = get n
203 :			in
204 :			{ name = name, env = env, pidInfo = pidInfo }
205 :			end
206 :
207 :			val (core, corePidInfo) = get core
208 :			val corenv = CoerceEnv.es2bs (E.staticPart core)
209 :			val (rts, _) = get rts
210 :			val (pervasive0, pervPidInfo) = get pervasive
211 :			val pspecs = map getPspec primitives
212 :			val core_symdyn =
213 :			E.mkenv { static = E.staticPart E.emptyEnv,
214 :			dynamic = E.dynamicPart core,
215 :			symbolic = E.symbolicPart core }
216 :			val pervasive = E.layerEnv (pervasive0, core_symdyn)
217 :			val pervcorepids =
218 :			PidSet.addList (PidSet.empty,
219 :			[#statpid corePidInfo,
220 :			#statpid pervPidInfo,
221 :			#sympid pervPidInfo])
222 :			in
223 :			#set ER.core corenv;
224 :			#set ER.pervasive pervasive;
225 :			#set ER.topLevel BE.emptyEnv;
226 :			theValues :=
227 :			SOME { primconf = Primitive.configuration pspecs,
228 :			pervasive = pervasive,
229 :			corenv = corenv,
230 :			pervcorepids = pervcorepids };
231 :			HostMachDepVC.Interact.installCompManager
232 :			(SOME al_manager');
233 :			autoload "basis.cm";
234 :			()
235 :			end
236 :			end
237 :			end
238 :
239 :			fun stabilize_runner gp g = true
240 :			in
241 :			structure CM = struct
242 :
243 :			fun run sflag f s = let
244 :			val c = SrcPath.cwdContext ()
245 :			val p = SrcPath.native { context = c, spec = s }
246 :			in
247 :			case Parse.parse NONE (param ()) sflag p of
248 :			NONE => false
249 :			| SOME (g, gp) => f gp g
250 :			end
251 :
252 :			fun stabilize recursively = run (SOME recursively) stabilize_runner
253 :			val recomp = run NONE recomp_runner
254 :			val make = run NONE make_runner
255 :			val autoload = autoload
256 :			end
257 :
258 :			structure CMB = struct
259 :			structure BootstrapCompile =
260 :			BootstrapCompileFn (structure MachDepVC = HostMachDepVC
261 :			val os = os)
262 :			val make' = BootstrapCompile.compile
263 :			fun make () = make' NONE
264 :			fun setRetargetPervStatEnv x = ()
265 :			fun wipeOut () = ()
266 :			end
267 :
268 :			fun init (bootdir, de) =
269 :			(warmup_hook := SOME de;
270 :			initTheValues bootdir;
271 :			warmup_hook := NONE)
272 :			end
273 :			end
274 :
275 :			signature CMTOOLS = sig end
276 :			signature COMPILATION_MANAGER = sig end

---

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