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/compiler/TopLevel/bootstrap/boot.sml
ViewVC logotype

Annotation of /sml/trunk/src/compiler/TopLevel/bootstrap/boot.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 16 - (view) (download)

1 : monnier 16 (* Copyright 1996 by Bell Laboratories *)
2 :     (* boot.sml *)
3 :    
4 :     signature BOOTENV =
5 :     sig
6 :     val makePervEnv: unit -> Environment.environment
7 :     end (* signature BOOTENV *)
8 :    
9 :    
10 :     functor BootEnvF (VC: VISCOMP): BOOTENV =
11 :     struct
12 :    
13 :     local
14 :     structure SS = Substring
15 :     structure C = VC.Compile
16 :     structure BU = VC.BatchUtil
17 :     structure SE = StaticEnv
18 :     structure SC = SCStaticEnv
19 :     open ErrorMsg Modules ModuleUtil
20 :     in
21 :    
22 :     fun bug s = ErrorMsg.impossible ("BootEnvF: " ^ s);
23 :     val say = Control.Print.say
24 :     val flush = Control.Print.flush
25 :    
26 :    
27 :     type scsenv = SC.staticEnv
28 :     type pid = PersStamps.persstamp
29 :     type symenv = SymbolicEnv.symenv
30 :    
31 :     type loadres = {scsenv: scsenv,
32 :     exportPid: pid option}
33 :    
34 :     infix //
35 :     val op // = SC.atop
36 :    
37 :     fun loadcomp (env,fname) : loadres =
38 :     let val _ = say (concat ["[Elaborating ", fname, "]\n"])
39 :     val stream = TextIO.openIn fname
40 :     val source = Source.newSource (
41 :     fname, 1, stream, false, ErrorMsg.defaultConsumer ())
42 :     val ast = C.parse source
43 :     val cinfo = C.mkCompInfo(source, #get EnvRef.core (), fn x=>x)
44 :     val {absyn, newstatenv=newenv, exportPid, ...} =
45 :     C.elaborate{statenv=env, compInfo = cinfo, ast=ast}
46 :    
47 :     (* ZHONG commented this out, because why bother ?
48 :    
49 :     val showenv = StaticEnv.atop(SC.unSC newenv, SC.unSC env)
50 :     fun show (Absyn.SEQdec decs) = app show decs
51 :     | show (Absyn.MARKdec (d,_)) = show d
52 :     | show absyn =
53 :     PrettyPrint.with_pp (ErrorMsg.defaultConsumer ())
54 :     (fn ppstrm =>
55 :     PPDec.ppDec {static = showenv,
56 :     dynamic = DynamicEnv.empty,
57 :     symbolic = SymbolicEnv.empty}
58 :     ppstrm (absyn,[]))
59 :     *)
60 :     in (* show absyn handle _ => say "ppDec raised exception\n"; *)
61 :     TextIO.closeIn stream;
62 :     {scsenv = newenv, exportPid = exportPid}
63 :     end
64 :    
65 :     datatype runDynEnv
66 :     = NILrde
67 :     | CONSrde of Word8Vector.vector * Unsafe.Object.object * runDynEnv
68 :    
69 :     val a_pstruct: runDynEnv ref = Unsafe.cast Unsafe.pStruct
70 :    
71 :     fun readfile fname =
72 :     let val f = TextIO.openIn fname
73 :     fun g () =
74 :     case TextIO.inputLine f
75 :     of "" => nil
76 :     | line => substring (line, 0, size line - 1) :: g ()
77 :     in g () before TextIO.closeIn f
78 :     end
79 :    
80 :     (* read a file from the bin directory *)
81 :     fun readBinFile(bindir, file) =
82 :     let val path = OS.Path.joinDirFile { dir = bindir, file = file }
83 :     in readfile path
84 :     end
85 :    
86 :     (* some standard pathnames (in OS independent syntax) *)
87 :     local
88 :     fun bootFile f = OS.Path.joinDirFile { dir = "0-Boot", file = f }
89 :     in
90 :     val assembly_sig = bootFile "assembly.sig"
91 :     val dummy_sml = bootFile "dummy.sml"
92 :     val core_sml = bootFile "core.sml"
93 :     end (* local *)
94 :    
95 :     fun scsenvSize env = StaticEnv.fold (fn(_,n) => n+1) 0 (SCStaticEnv.unSC env)
96 :    
97 :     fun newBootEnv (load, bindir) =
98 :     let val bootFiles = readBinFile(bindir,"BOOTSRC")
99 :     val prim = SCStaticEnv.SC PrimEnv.primEnv
100 :     val pids = ref (nil : pid list)
101 :    
102 :     fun ld(fname,env) =
103 :     let val {scsenv = env, exportPid = p} = load(env,fname)
104 :     in case p
105 :     of NONE => ()
106 :     | SOME p => pids := p :: !pids;
107 :     env
108 :     end
109 :    
110 :     fun many(files,baseEnv) =
111 :     let fun many'([],env) = env
112 :     | many'(fname::rest,env) =
113 :     many'(rest,ld(fname,env//baseEnv)//env)
114 :     in many'(files,SCStaticEnv.empty)
115 :     end
116 :    
117 :     val sig_prim = ld(assembly_sig,prim) // prim
118 :     val dummy_env = ld(dummy_sml,sig_prim) // sig_prim
119 :     val core_env = ld(core_sml,dummy_env)
120 :     val _ = #set EnvRef.core (SCStaticEnv.unSC core_env)
121 :     val _ = VC.Boot.coreEnvRef := { static = core_env // dummy_env,
122 :     dynamic = DynamicEnv.empty,
123 :     symbolic = SymbolicEnv.empty }
124 :     val env = many(bootFiles,(core_env // sig_prim))
125 :     val pervFiles = readBinFile(bindir,"PERVSRC")
126 :     val resultEnv = many(pervFiles,env)
127 :    
128 :     in (resultEnv, rev (!pids))
129 :     end
130 :    
131 :     fun sname "mipsel" = "MipsLittle"
132 :     | sname "mipseb" = "MipsBig"
133 :     | sname "vax" = "Vax"
134 :     | sname "sparc" = "Sparc"
135 :     | sname "hppa" = "Hppa"
136 :     | sname "rs6000" = "RS6000"
137 :     | sname "x86" = "X86"
138 :     | sname "m86" = "M86"
139 :     | sname "alpha32" = "Alpha32"
140 :     | sname "alpha32x" = "Alpha32X"
141 :     | sname a = (say ("Don't Recognize architecture "^a^"\n");
142 :     raise Match)
143 :    
144 :     fun ends_with(ab,b) =
145 :     let val abs = size ab and bs = size b
146 :     in abs >= bs andalso substring (ab, abs - bs, bs) = b
147 :     end
148 :    
149 :     (* elabCompiler accumulates compiler environment atop the pervasive env *)
150 :     fun elabCompiler (load, pervEnv, bindir) =
151 :     let val srclist = readBinFile(bindir, "SRCLIST")
152 :     (* don't elaborate the last file! it's the glue that hasn't
153 :     * finished executing.
154 :     *)
155 :     fun allFiles (oldenv, pids, fname :: (rest as _ :: _)) =
156 :     let val {scsenv, exportPid} = load(oldenv,fname)
157 :     val pids = case exportPid
158 :     of NONE => pids
159 :     | SOME p => p::pids
160 :     in allFiles (scsenv // oldenv, pids, rest)
161 :     end
162 :     | allFiles (oldenv, pids, _) = (oldenv, rev pids)
163 :    
164 :     in allFiles (pervEnv, [], srclist)
165 :     end
166 :     handle ex => (say (concat ["\nuncaught exception",
167 :     General.exnMessage ex , "\n"]);
168 :     flush ();
169 :     raise ex)
170 :    
171 :     val bindir = ref ("bin." ^ VC.architecture)
172 :     val full = ref false
173 :    
174 :     val _ =
175 :     let fun bootArg s =
176 :     let val s' = #2 (SS.position "@SMLboot=" (SS.all s))
177 :     in if SS.size s' = String.size s
178 :     then SOME (SS.string (SS.triml 9 s'))
179 :     else NONE
180 :     end
181 :     fun f [] = ()
182 :     | f ("@SMLfull" :: rest) = (full := true; f rest)
183 :     | f (arg :: rest) =
184 :     (case bootArg arg
185 :     of SOME fname => bindir := fname
186 :     | NONE => ();
187 :     f rest)
188 :     in f (SMLofNJ.getAllArgs ())
189 :     end
190 :    
191 :     fun basename s = #file(OS.Path.splitDirFile s)
192 :    
193 :     fun targetNamer bindir s =
194 :     OS.Path.joinDirFile
195 :     { dir = bindir,
196 :     file = OS.Path.joinBaseExt { base= basename s, ext = SOME "bin" } }
197 :    
198 :     fun nocheck _ = ()
199 :    
200 :     fun makePervEnv () =
201 :     let val tnamer = targetNamer (!bindir)
202 :    
203 :     val theSymEnv = ref SymbolicEnv.empty
204 :    
205 :     fun getbin (env0: scsenv,sourcename) : loadres =
206 :     let val _ =
207 :     say (concat ["Loading static bin for ", sourcename, "\n"])
208 :     val f = BinIO.openIn (tnamer sourcename)
209 :    
210 :     val cu = BU.readUnit { name=tnamer sourcename,
211 :     stream = f,
212 :     pids2iid = fn _ => (),
213 :     senv = env0,
214 :     keep_code = false }
215 :     val exportPid = BU.exportCU cu
216 :     val senv = BU.senvCU cu
217 :     val symenv = BU.symenvCU cu
218 :    
219 :     in theSymEnv := SymbolicEnv.atop (symenv, !theSymEnv);
220 :     BinIO.closeIn f;
221 :     { scsenv = senv, exportPid = exportPid }
222 :     end
223 :    
224 :     fun getVisComp env0 =
225 :     let val srcname = VC.architecture ^ "vis.sml"
226 :     val files = readBinFile(!bindir, "SRCLIST")
227 :     fun f (env, fname :: rest) =
228 :     let val {scsenv, ...} = getbin(env,fname)
229 :     val env'' = scsenv // env
230 :     in if ends_with (fname, srcname)
231 :     then env''
232 :     else f (env'', rest)
233 :     end
234 :     | f (_,nil) = bug "getVisComp"
235 :     in f (env0, files)
236 :     end
237 :    
238 :     val ((pervStatEnv, pids), visCompEnv) =
239 :     if List.exists (fn s => s="@SMLelab") (SMLofNJ.getAllArgs()) then
240 :     let val _ = say "\nNow elaborating boot directory\n"
241 :     val savedOverloadKW = !VC.Control.overloadKW
242 :     val _ = VC.Control.overloadKW := true
243 :     val (pSE, pids) = newBootEnv (loadcomp, !bindir)
244 :     val (vSE, morepids) =
245 :     elabCompiler (loadcomp, pSE, !bindir)
246 :     in VC.Control.overloadKW := savedOverloadKW;
247 :     ((pSE, pids @ morepids), vSE)
248 :     end
249 :     else
250 :     let val _ = say "trying bin files\n"
251 :     val (pSE, pids) = newBootEnv(getbin, !bindir)
252 :     in ((pSE, pids), getVisComp pSE)
253 :     end
254 :    
255 :     val pervStatEnv = SE.consolidate(SC.unSC pervStatEnv)
256 :     val visCompEnv = SE.consolidate(SC.unSC visCompEnv)
257 :    
258 :     val vcSym = Symbol.strSymbol (sname (VC.architecture) ^ "VisComp")
259 :     val vcBind as Bindings.STRbind(vcStr) =
260 :     SE.look(visCompEnv, vcSym)
261 :    
262 :     (* extract all the signature names from Compiler structure *)
263 :     val vcSigNames = getSignatureNames vcStr
264 :    
265 :     val pervStatEnv = if !full then visCompEnv else pervStatEnv
266 :    
267 :     val compSym = Symbol.strSymbol "Compiler"
268 :     val pervStatEnv = SE.bind(compSym, vcBind, pervStatEnv)
269 :    
270 :     val pervStatEnv =
271 :     foldl (fn (name,env) =>
272 :     SE.bind(name,SE.look(visCompEnv,name),env))
273 :     pervStatEnv vcSigNames
274 :    
275 :     (*
276 :     * translate run-time system's dynamic env into compiler's dynamic
277 :     * env. `m' is the map from pids to inlinable lambda expressions.
278 :     *)
279 :     fun trans_rde NILrde = DynamicEnv.empty
280 :     | trans_rde (CONSrde (spid, obj, rest)) =
281 :     let val pid = PersStamps.fromBytes spid
282 :     in DynamicEnv.bind (pid, obj, trans_rde rest)
283 :     end
284 :    
285 :     fun rebindlast (NILrde, pids, env) = (pids, env)
286 :     | rebindlast (CONSrde (_, a, rde), pids, env) =
287 :     case rebindlast (rde, pids, env)
288 :     of (pid :: pids', env') =>
289 :     let val _ = ((DynamicEnv.look env' pid; ())
290 :     handle DynamicEnv.Unbound =>
291 :     say "rebindlast: %%%% new pid\n")
292 :    
293 :     val env'' = DynamicEnv.bind (pid, a, env')
294 :     in case rde
295 :     of CONSrde (_, _, NILrde) =>
296 :     (* hack for testing new pervasive modules *)
297 :     VC.Boot.coreEnvRef:=
298 :     { static = #static (!VC.Boot.coreEnvRef),
299 :     dynamic = env'',
300 :     symbolic = SymbolicEnv.empty }
301 :     | _ => ();
302 :     (pids', env'')
303 :     end
304 :     | z as (nil, env') => z
305 :    
306 :     val ps = !a_pstruct before a_pstruct := NILrde
307 :     (* val (nil,env) = rebindlast(ps, pids, trans_rde (m, ps)) *)
308 :     val ([], env) = rebindlast (ps, pids, trans_rde ps)
309 :    
310 :     (* (* hack for testing new pervasive modules *)
311 :     val _ = VC.Boot.coreEnvRef :=
312 :     { static = #static (!VC.Boot.coreEnvRef),
313 :     dynamic = env,
314 :     symbolic = !theSymEnv } *)
315 :    
316 :     in
317 :     say "Using runtime's dynEnv\n";
318 :     { static = pervStatEnv, dynamic = env, symbolic = !theSymEnv }
319 :     end handle e => (say "\nuncaught exception ";
320 :     say (General.exnMessage e);
321 :     say "\n";
322 :     raise e)
323 :    
324 :     end (* local *)
325 :     end (* functor BootEnvF *)
326 :    

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