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 107 - (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 : monnier 45 structure C = VC.Compile
16 : monnier 106 structure BF = VC.Binfile
17 : monnier 16 structure SE = StaticEnv
18 : monnier 93 structure CM = CMStaticEnv
19 : monnier 16 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 : monnier 93 type scsenv = CM.staticEnv
28 : monnier 16 type pid = PersStamps.persstamp
29 :     type symenv = SymbolicEnv.symenv
30 :    
31 :     type loadres = {scsenv: scsenv,
32 :     exportPid: pid option}
33 :    
34 :     infix //
35 : monnier 93 val op // = CM.atop
36 : monnier 16
37 : monnier 45 fun loadcomp (env,fname) : loadres =
38 : monnier 16 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 : monnier 45 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 : monnier 93 val showenv = StaticEnv.atop(CM.unCM newenv, CM.unCM env)
50 : monnier 16 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 : monnier 45 *)
60 :     in (* show absyn handle _ => say "ppDec raised exception\n"; *)
61 : monnier 16 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 : monnier 93 fun bootFile f = OS.Path.toString{
89 :     isAbs=false, vol="", arcs=["PervEnv", "Boot", f]
90 :     }
91 : monnier 16 in
92 :     val assembly_sig = bootFile "assembly.sig"
93 :     val dummy_sml = bootFile "dummy.sml"
94 :     val core_sml = bootFile "core.sml"
95 :     end (* local *)
96 :    
97 : monnier 93 fun scsenvSize env = StaticEnv.fold (fn(_,n) => n+1) 0 (CMStaticEnv.unCM env)
98 : monnier 16
99 :     fun newBootEnv (load, bindir) =
100 :     let val bootFiles = readBinFile(bindir,"BOOTSRC")
101 : monnier 93 val prim = CMStaticEnv.CM PrimEnv.primEnv
102 : monnier 16 val pids = ref (nil : pid list)
103 :    
104 :     fun ld(fname,env) =
105 :     let val {scsenv = env, exportPid = p} = load(env,fname)
106 :     in case p
107 :     of NONE => ()
108 :     | SOME p => pids := p :: !pids;
109 :     env
110 :     end
111 :    
112 :     fun many(files,baseEnv) =
113 :     let fun many'([],env) = env
114 :     | many'(fname::rest,env) =
115 :     many'(rest,ld(fname,env//baseEnv)//env)
116 : monnier 93 in many'(files,CMStaticEnv.empty)
117 : monnier 16 end
118 :    
119 :     val sig_prim = ld(assembly_sig,prim) // prim
120 :     val dummy_env = ld(dummy_sml,sig_prim) // sig_prim
121 :     val core_env = ld(core_sml,dummy_env)
122 : monnier 93 val _ = #set EnvRef.core (CMStaticEnv.unCM core_env)
123 : monnier 16 val _ = VC.Boot.coreEnvRef := { static = core_env // dummy_env,
124 :     dynamic = DynamicEnv.empty,
125 :     symbolic = SymbolicEnv.empty }
126 :     val env = many(bootFiles,(core_env // sig_prim))
127 :     val pervFiles = readBinFile(bindir,"PERVSRC")
128 :     val resultEnv = many(pervFiles,env)
129 :    
130 :     in (resultEnv, rev (!pids))
131 :     end
132 :    
133 :     fun sname "mipsel" = "MipsLittle"
134 :     | sname "mipseb" = "MipsBig"
135 :     | sname "vax" = "Vax"
136 :     | sname "sparc" = "Sparc"
137 :     | sname "hppa" = "Hppa"
138 :     | sname "rs6000" = "RS6000"
139 :     | sname "x86" = "X86"
140 :     | sname "m86" = "M86"
141 :     | sname "alpha32" = "Alpha32"
142 :     | sname "alpha32x" = "Alpha32X"
143 :     | sname a = (say ("Don't Recognize architecture "^a^"\n");
144 :     raise Match)
145 :    
146 :     fun ends_with(ab,b) =
147 :     let val abs = size ab and bs = size b
148 :     in abs >= bs andalso substring (ab, abs - bs, bs) = b
149 :     end
150 :    
151 :     (* elabCompiler accumulates compiler environment atop the pervasive env *)
152 : monnier 45 fun elabCompiler (load, pervEnv, bindir) =
153 : monnier 16 let val srclist = readBinFile(bindir, "SRCLIST")
154 :     (* don't elaborate the last file! it's the glue that hasn't
155 :     * finished executing.
156 :     *)
157 :     fun allFiles (oldenv, pids, fname :: (rest as _ :: _)) =
158 :     let val {scsenv, exportPid} = load(oldenv,fname)
159 :     val pids = case exportPid
160 :     of NONE => pids
161 :     | SOME p => p::pids
162 :     in allFiles (scsenv // oldenv, pids, rest)
163 :     end
164 :     | allFiles (oldenv, pids, _) = (oldenv, rev pids)
165 :    
166 :     in allFiles (pervEnv, [], srclist)
167 :     end
168 :     handle ex => (say (concat ["\nuncaught exception",
169 :     General.exnMessage ex , "\n"]);
170 :     flush ();
171 :     raise ex)
172 :    
173 : monnier 45 val bindir = ref ("bin." ^ VC.architecture)
174 : monnier 16 val full = ref false
175 :    
176 :     val _ =
177 :     let fun bootArg s =
178 :     let val s' = #2 (SS.position "@SMLboot=" (SS.all s))
179 :     in if SS.size s' = String.size s
180 :     then SOME (SS.string (SS.triml 9 s'))
181 :     else NONE
182 :     end
183 :     fun f [] = ()
184 :     | f ("@SMLfull" :: rest) = (full := true; f rest)
185 :     | f (arg :: rest) =
186 :     (case bootArg arg
187 :     of SOME fname => bindir := fname
188 :     | NONE => ();
189 :     f rest)
190 :     in f (SMLofNJ.getAllArgs ())
191 :     end
192 :    
193 :     fun basename s = #file(OS.Path.splitDirFile s)
194 :    
195 :     fun targetNamer bindir s =
196 :     OS.Path.joinDirFile
197 :     { dir = bindir,
198 :     file = OS.Path.joinBaseExt { base= basename s, ext = SOME "bin" } }
199 :    
200 :     fun nocheck _ = ()
201 :    
202 :     fun makePervEnv () =
203 :     let val tnamer = targetNamer (!bindir)
204 :    
205 :     val theSymEnv = ref SymbolicEnv.empty
206 :    
207 :     fun getbin (env0: scsenv,sourcename) : loadres =
208 :     let val _ =
209 :     say (concat ["Loading static bin for ", sourcename, "\n"])
210 :     val f = BinIO.openIn (tnamer sourcename)
211 :    
212 : monnier 106 val bfc = BF.read { name=tnamer sourcename,
213 :     stream = f,
214 :     senv = env0,
215 :     keep_code = false }
216 :     val exportPid = BF.exportPidOf bfc
217 :     val senv = BF.senvOf bfc
218 :     val symenv = BF.symenvOf bfc
219 : monnier 16
220 :     in theSymEnv := SymbolicEnv.atop (symenv, !theSymEnv);
221 :     BinIO.closeIn f;
222 :     { scsenv = senv, exportPid = exportPid }
223 :     end
224 :    
225 :     fun getVisComp env0 =
226 : monnier 45 let val srcname = VC.architecture ^ "vis.sml"
227 : monnier 16 val files = readBinFile(!bindir, "SRCLIST")
228 :     fun f (env, fname :: rest) =
229 :     let val {scsenv, ...} = getbin(env,fname)
230 :     val env'' = scsenv // env
231 :     in if ends_with (fname, srcname)
232 :     then env''
233 :     else f (env'', rest)
234 :     end
235 :     | f (_,nil) = bug "getVisComp"
236 :     in f (env0, files)
237 :     end
238 :    
239 :     val ((pervStatEnv, pids), visCompEnv) =
240 :     if List.exists (fn s => s="@SMLelab") (SMLofNJ.getAllArgs()) then
241 :     let val _ = say "\nNow elaborating boot directory\n"
242 :     val savedOverloadKW = !VC.Control.overloadKW
243 :     val _ = VC.Control.overloadKW := true
244 : monnier 45 val (pSE, pids) = newBootEnv (loadcomp, !bindir)
245 :     val (vSE, morepids) =
246 :     elabCompiler (loadcomp, pSE, !bindir)
247 : monnier 16 in VC.Control.overloadKW := savedOverloadKW;
248 :     ((pSE, pids @ morepids), vSE)
249 :     end
250 :     else
251 :     let val _ = say "trying bin files\n"
252 :     val (pSE, pids) = newBootEnv(getbin, !bindir)
253 :     in ((pSE, pids), getVisComp pSE)
254 :     end
255 :    
256 : monnier 93 val pervStatEnv = SE.consolidate(CM.unCM pervStatEnv)
257 :     val visCompEnv = SE.consolidate(CM.unCM visCompEnv)
258 : monnier 16
259 : monnier 45 val vcSym = Symbol.strSymbol (sname (VC.architecture) ^ "VisComp")
260 : monnier 16 val vcBind as Bindings.STRbind(vcStr) =
261 :     SE.look(visCompEnv, vcSym)
262 :    
263 :     (* extract all the signature names from Compiler structure *)
264 :     val vcSigNames = getSignatureNames vcStr
265 :    
266 :     val pervStatEnv = if !full then visCompEnv else pervStatEnv
267 :    
268 :     val compSym = Symbol.strSymbol "Compiler"
269 :     val pervStatEnv = SE.bind(compSym, vcBind, pervStatEnv)
270 :    
271 :     val pervStatEnv =
272 :     foldl (fn (name,env) =>
273 :     SE.bind(name,SE.look(visCompEnv,name),env))
274 :     pervStatEnv vcSigNames
275 :    
276 :     (*
277 :     * translate run-time system's dynamic env into compiler's dynamic
278 :     * env. `m' is the map from pids to inlinable lambda expressions.
279 :     *)
280 :     fun trans_rde NILrde = DynamicEnv.empty
281 :     | trans_rde (CONSrde (spid, obj, rest)) =
282 :     let val pid = PersStamps.fromBytes spid
283 :     in DynamicEnv.bind (pid, obj, trans_rde rest)
284 :     end
285 :    
286 :     fun rebindlast (NILrde, pids, env) = (pids, env)
287 :     | rebindlast (CONSrde (_, a, rde), pids, env) =
288 :     case rebindlast (rde, pids, env)
289 :     of (pid :: pids', env') =>
290 :     let val _ = ((DynamicEnv.look env' pid; ())
291 :     handle DynamicEnv.Unbound =>
292 :     say "rebindlast: %%%% new pid\n")
293 :    
294 :     val env'' = DynamicEnv.bind (pid, a, env')
295 :     in case rde
296 :     of CONSrde (_, _, NILrde) =>
297 :     (* hack for testing new pervasive modules *)
298 :     VC.Boot.coreEnvRef:=
299 :     { static = #static (!VC.Boot.coreEnvRef),
300 :     dynamic = env'',
301 :     symbolic = SymbolicEnv.empty }
302 :     | _ => ();
303 :     (pids', env'')
304 :     end
305 :     | z as (nil, env') => z
306 :    
307 :     val ps = !a_pstruct before a_pstruct := NILrde
308 :     (* val (nil,env) = rebindlast(ps, pids, trans_rde (m, ps)) *)
309 :     val ([], env) = rebindlast (ps, pids, trans_rde ps)
310 :    
311 :     (* (* hack for testing new pervasive modules *)
312 :     val _ = VC.Boot.coreEnvRef :=
313 :     { static = #static (!VC.Boot.coreEnvRef),
314 :     dynamic = env,
315 :     symbolic = !theSymEnv } *)
316 :    
317 :     in
318 :     say "Using runtime's dynEnv\n";
319 :     { static = pervStatEnv, dynamic = env, symbolic = !theSymEnv }
320 :     end handle e => (say "\nuncaught exception ";
321 :     say (General.exnMessage e);
322 :     say "\n";
323 :     raise e)
324 :    
325 :     end (* local *)
326 :     end (* functor BootEnvF *)
327 :    
328 : monnier 93
329 :     (*
330 :     * $Log: boot.sml,v $
331 : monnier 106 * Revision 1.2 1998/05/21 17:54:47 jhr
332 :     * Merging in Matthias's changes.
333 :     *
334 : monnier 93 * Revision 1.1.1.1 1998/04/08 18:39:15 george
335 :     * Version 110.5
336 :     *
337 :     *)

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