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

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