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 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