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/interact/evalloop.sml
ViewVC logotype

Annotation of /sml/trunk/src/compiler/TopLevel/interact/evalloop.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 25 - (view) (download)

1 : monnier 16 (* Copyright 1996 by Bell Laboratories *)
2 :     (* evalloop.sml *)
3 :    
4 : monnier 24 signature EVALLOOP =
5 :     sig
6 :     exception Interrupt
7 :    
8 :     type obj = Unsafe.Object.object
9 :     type obvec = obj Vector.vector
10 :     type interactParams =
11 :     {compManagerHook : (Ast.dec * EnvRef.SCenvref
12 :     * EnvRef.envref -> unit) option ref,
13 :     baseEnvRef : EnvRef.SCenvref,
14 :     localEnvRef : EnvRef.envref,
15 :     transform : Absyn.dec -> Absyn.dec,
16 :     instrument : {source: Source.inputSource,
17 :     compenv: StaticEnv.staticEnv}
18 :     -> Absyn.dec -> Absyn.dec,
19 :     perform : (obvec -> obj) -> (obvec -> obj),
20 :     isolate : (obvec -> obj) -> (obvec -> obj),
21 :     printer : Environment.environment -> PrettyPrint.ppstream
22 :     -> (Absyn.dec * Lambda.lvar list) -> unit}
23 :    
24 :     val stdParams : interactParams
25 :     val interact : interactParams -> unit
26 :     val evalStream : interactParams -> string * TextIO.instream -> unit
27 :    
28 :     end (* signature EVALLOOP *)
29 :    
30 : monnier 16 functor EvalLoopF(Compile: TOP_COMPILE) : EVALLOOP =
31 :     struct
32 :    
33 :     local open Environment
34 :     structure C = Compile
35 :     structure EM = ErrorMsg
36 :     structure E = Environment
37 : monnier 24 structure EU = ElabUtil
38 : monnier 16 structure SCS = SCStaticEnv
39 :     structure T = Time
40 :     structure U = Unsafe
41 :     in
42 :    
43 :     exception Interrupt
44 : monnier 24 type obj = Unsafe.Object.object
45 :     type obvec = obj Vector.vector
46 : monnier 16
47 : monnier 24 type interactParams =
48 :     {compManagerHook : (Ast.dec * EnvRef.SCenvref
49 :     * EnvRef.envref -> unit) option ref,
50 :     baseEnvRef : EnvRef.SCenvref,
51 :     localEnvRef : EnvRef.envref,
52 :     transform : Absyn.dec -> Absyn.dec,
53 :     instrument : {source: Source.inputSource,
54 :     compenv: staticEnv}
55 :     -> Absyn.dec -> Absyn.dec,
56 :     perform : (obvec -> obj) -> (obvec -> obj),
57 :     isolate : (obvec -> obj) -> (obvec -> obj),
58 :     printer : E.environment -> PrettyPrint.ppstream
59 :     -> Absyn.dec * Lambda.lvar list -> unit}
60 :    
61 : monnier 16
62 :     val stdParams : interactParams =
63 :     {compManagerHook = ref NONE,
64 :     baseEnvRef = EnvRef.pervasive,
65 :     localEnvRef = EnvRef.topLevel,
66 :     transform = (fn x => x),
67 :     instrument = (fn _ => fn x => x),
68 :     perform = (fn x => x),
69 : monnier 24 isolate = Compile.isolate,
70 : monnier 16 printer = PPDec.ppDec}
71 :    
72 :     (* toplevel loop *)
73 :    
74 :     val say = Control.Print.say
75 :     fun debugmsg msg =
76 :     if !Control.debugging then (say (msg ^ "\n"); Control.Print.flush()) else ()
77 :    
78 :     exception EndOfFile
79 :    
80 : monnier 24 fun codegen(arg)=
81 :     let val code = C.codegen arg
82 :     val _ = debugmsg "about to boot\n"
83 :     in C.applyCode code
84 :     end
85 :    
86 : monnier 16 fun interruptable f x =
87 :     let val oldcont = !U.topLevelCont
88 :     in U.topLevelCont :=
89 :     SMLofNJ.Cont.callcc
90 :     (fn k => (SMLofNJ.Cont.callcc(fn k' => (SMLofNJ.Cont.throw k k'));
91 :     raise Interrupt));
92 :     (f x before U.topLevelCont := oldcont)
93 :     handle e => (U.topLevelCont := oldcont; raise e)
94 :     end
95 :    
96 :     (*
97 :     * The baseEnv and localEnv are purposely refs so that a top-level command
98 :     * can re-assign either one of them, and the next iteration of the loop
99 :     * will see the new value. It's also important that the toplevelenv
100 :     * continuation NOT see the "fetched" environment, but only the ref;
101 :     * then, if the user "filters" the environment ref, a smaller image
102 :     * can be written.
103 :     *)
104 :    
105 :     fun evalLoop ({compManagerHook, baseEnvRef, localEnvRef, perform,
106 :     isolate, printer, instrument, transform} : interactParams)
107 :     (source: Source.inputSource) : unit =
108 :    
109 :     let val parser = C.parseOne source
110 : monnier 24 val compInfo = C.mkCompInfo(source,#get EnvRef.core (),transform)
111 : monnier 16 val baseEnvRefunSC = EnvRef.unSC baseEnvRef
112 :    
113 : monnier 24 fun checkErrors () =
114 :     if C.anyErrors compInfo then raise EM.Error else ()
115 : monnier 16
116 : monnier 24 (*** !!! the environment conversions need a clean-up (ZHONG) !!! ***)
117 : monnier 16 fun oneUnit () = (* perform one transaction *)
118 : monnier 24 case parser ()
119 :     of NONE => raise EndOfFile
120 :     | SOME ast =>
121 :     let val _ = case !compManagerHook
122 :     of NONE => ()
123 :     | SOME cm => cm (ast, baseEnvRef, localEnvRef)
124 : monnier 16
125 : monnier 24 val {static=statenv,dynamic=dynenv, symbolic=symenv} =
126 :     E.layerEnv(#get localEnvRef (), #get baseEnvRefunSC ())
127 : monnier 16
128 : monnier 24 val {ast=ast,compenv=statenv,compInfo=compInfo} =
129 :     C.fixityparse
130 :     {ast=ast,compenv=statenv,compInfo=compInfo}
131 :     before checkErrors ()
132 :     handle C.Compile _ => raise EM.Error
133 : monnier 16
134 : monnier 24 (* ZIDO: PWLE: Added the fixityparse phase *)
135 : monnier 16
136 : monnier 24 val {ast=ast} =
137 :     C.lazycomp{ast=ast,compenv=statenv,compInfo=compInfo}
138 :     before checkErrors ()
139 :     handle C.Compile _ => raise EM.Error
140 : monnier 16
141 : monnier 24 (* ZIDO: PWLE: Added last "val" dec, the lazycomp phase *)
142 : monnier 16
143 : monnier 24 val {absyn,newenv,exportLvars,exportPid,...} =
144 :     C.elaborate{ast=ast,compenv=statenv,compInfo=compInfo}
145 :     before checkErrors ()
146 :     handle C.Compile _ => raise EM.Error
147 : monnier 16
148 : monnier 24 val absyn =
149 :     C.instrument
150 :     {compenv=statenv,source=source,compInfo=compInfo}
151 :     (instrument {compenv=statenv,source=source} absyn)
152 :    
153 :     val {genLambda,imports=importPids} =
154 :     C.translate{absyn=absyn, exportLvars=exportLvars,
155 :     exportPid=NONE,
156 :     newstatenv=newenv,
157 :     oldstatenv=statenv,
158 :     compInfo=compInfo}
159 :     before checkErrors ()
160 :    
161 :     val lambda = C.inline {genLambda = genLambda,
162 :     imports = importPids,
163 :     symenv = symenv}
164 :    
165 :     val {lambda_e, lambda_i} =
166 :     C.split{lambda = lambda,
167 :     enable = !Control.lambdaSplitEnable}
168 :    
169 :     val new_symenv = C.symDelta (exportPid, lambda_i)
170 :    
171 :     val executable =
172 :     codegen {lambda = lambda_e, compInfo=compInfo}
173 :     before checkErrors ()
174 :     (*
175 :     * interp mode is temporarily(?) turned off
176 :     *
177 :     * (if !Control.interp
178 :     * then Interp.interp lambda_e
179 :     * else codegen {lambda = lambda_e,
180 :     * compInfo=compInfo})
181 :     *)
182 :    
183 :     val executable = isolate (interruptable (perform executable))
184 :    
185 :     val new_dynenv = let
186 :     val _ = SMLofNJ.Internals.ProfControl.current
187 :     := Profile.otherIndex
188 :     val result =
189 :     C.execute{executable=executable,imports=importPids,
190 :     exportPid=exportPid,dynenv=dynenv}
191 :     in SMLofNJ.Internals.ProfControl.current := Profile.compileIndex;
192 :     result
193 :     end
194 :    
195 :     val newEnv = E.concatEnv
196 :     ({static=newenv, dynamic=new_dynenv,
197 :     symbolic=new_symenv},
198 :     #get localEnvRef ())
199 :    
200 :     (* refetch localEnvRef because execution may
201 :     have changed its contents *)
202 :    
203 :     in PrettyPrint.with_pp (#errConsumer source)
204 :     (fn ppstrm => printer
205 :     (E.layerEnv(newEnv,#get baseEnvRefunSC ()))
206 :     ppstrm (absyn, exportLvars));
207 :    
208 :     #set localEnvRef newEnv
209 :     end
210 :    
211 : monnier 16 fun loop() = (oneUnit(); loop())
212 : monnier 24
213 : monnier 16 in interruptable loop ()
214 :     end (* function evalLoop *)
215 :    
216 :     (*** interactive loop, with error handling ***)
217 :     fun interact (interactParams) : unit =
218 :     let val source = Source.newSource("stdIn",1,TextIO.stdIn,true,
219 : monnier 24 EM.defaultConsumer());
220 :     fun flush'() =
221 :     case TextIO.canInput(TextIO.stdIn, 4096)
222 :     of NONE => ()
223 :     | (SOME 0) => ()
224 :     | (SOME _) => (ignore (TextIO.input TextIO.stdIn); flush'())
225 : monnier 16
226 : monnier 24 fun flush() = (#anyErrors source := false;
227 :     flush'() handle IO.Io _ => ())
228 : monnier 16
229 : monnier 24 local val p1 = Substring.isPrefix "build/evalloop.sml:"
230 :     val p2 = Substring.isPrefix "build/compile.sml:"
231 :     val p3 = Substring.isPrefix "util/stats.sml:"
232 :     in fun edit [s] = [s]
233 :     | edit nil = nil
234 :     | edit (s::r) =
235 :     let val s' = Substring.all s
236 :     in if p1 s' orelse p2 s' orelse p3 s'
237 :     then edit r else s :: edit r
238 :     end
239 : monnier 16 end
240 :    
241 : monnier 24 fun showhist' [s] = say(concat[" raised at: ", s, "\n"])
242 :     | showhist' (s::r) = (showhist' r;
243 :     say (concat[" ", s, "\n"]))
244 :     | showhist' [] = ()
245 : monnier 16
246 : monnier 24 fun exnMsg (Compile.Compile s) = concat["Compile: \"", s, "\""]
247 :     | exnMsg (C.TopLevelException e) = exnMsg e
248 :     | exnMsg exn = General.exnMessage exn
249 : monnier 16
250 : monnier 24 fun showhist (C.TopLevelException e) = showhist e
251 :     | showhist C.SilentException = ()
252 :     | showhist e = showhist' (edit(SMLofNJ.exnHistory e))
253 : monnier 16
254 : monnier 24 fun loop () =
255 :     evalLoop interactParams source
256 :     handle EndOfFile => ()
257 :     | Interrupt => (say "\nInterrupt\n";
258 :     flush(); loop())
259 :     | EM.Error => (flush(); loop())
260 :     | C.Compile "syntax error" => (flush(); loop())
261 :     | C.Compile s =>
262 :     (say(concat["\nuncaught exception Compile: \"",
263 :     s,"\"\n"]);
264 :     flush(); loop())
265 :     | C.TopLevelException C.TopLevelCallcc =>
266 :     (say("Error: throw from one top-level expression \
267 :     \into another\n");
268 :     flush (); loop ())
269 :     | C.TopLevelException EM.Error =>
270 :     (flush (); loop ())
271 :     | C.TopLevelException C.SilentException =>
272 :     (flush (); loop ())
273 :     | C.TopLevelException exn => let
274 :     val msg = exnMsg exn
275 :     val name = exnName exn
276 :     in
277 : monnier 16 if (msg = name)
278 : monnier 24 then say (concat[
279 :     "\nuncaught exception ", exnName exn, "\n"
280 : monnier 16 ])
281 : monnier 24 else say (concat[
282 :     "\nuncaught exception ", exnName exn,
283 : monnier 16 " [", exnMsg exn, "]\n"
284 :     ]);
285 : monnier 24 showhist exn;
286 :     flush();
287 :     loop()
288 :     end
289 :     | C.SilentException => (flush (); loop ())
290 :     | exn => (
291 :     say (concat["\nuncaught exception ",
292 :     exnMsg exn, "\n"]);
293 :     showhist exn;
294 :     flush();
295 :     loop())
296 : monnier 16
297 :     in loop()
298 :     end (* fun interact *)
299 :    
300 :     fun isTermIn f =
301 :     let val (rd, buf) = TextIO.StreamIO.getReader(TextIO.getInstream f)
302 : monnier 24 val isTTY =
303 :     case rd
304 :     of TextPrimIO.RD{ioDesc = SOME iod, ...} =>
305 :     (OS.IO.kind iod = OS.IO.Kind.tty)
306 :     | _ => false
307 : monnier 16
308 : monnier 24 val buf = if (buf = "") then NONE else SOME buf
309 : monnier 16 in (* since getting the reader will have terminated the stream, we need
310 : monnier 24 * to build a new stream. *)
311 :     TextIO.setInstream(f, TextIO.StreamIO.mkInstream(rd, buf));
312 :     isTTY
313 : monnier 16 end
314 :    
315 :     fun evalStream interactParams
316 :     (fname:string,stream:TextIO.instream) : unit =
317 :     let val interactive = isTermIn stream
318 : monnier 24 val source = Source.newSource(fname,1,stream,interactive,
319 :     EM.defaultConsumer())
320 : monnier 16 in evalLoop interactParams source
321 : monnier 24 handle exn =>
322 :     (Source.closeSource source;
323 :     case exn
324 :     of EndOfFile => ()
325 :     | C.TopLevelException e => raise e
326 :     | _ => raise exn)
327 : monnier 16 end
328 :    
329 :     end (* top-level local *)
330 :     end (* functor EvalLoopF *)
331 :    

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