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 1712 - (view) (download)

1 : monnier 16 (* Copyright 1996 by Bell Laboratories *)
2 :     (* evalloop.sml *)
3 :    
4 :     functor EvalLoopF(Compile: TOP_COMPILE) : EVALLOOP =
5 :     struct
6 :    
7 :     local open Environment
8 :     structure C = Compile
9 :     structure EM = ErrorMsg
10 :     structure E = Environment
11 : monnier 47 structure PP = PrettyPrint
12 : monnier 16 structure T = Time
13 :     structure U = Unsafe
14 : monnier 47 structure PC = SMLofNJ.Internals.ProfControl
15 : macqueen 1344 structure ED = ElabDebug
16 :    
17 :     open PP
18 : monnier 16 in
19 :    
20 :     exception Interrupt
21 : monnier 47 type lvar = Access.lvar
22 : monnier 16
23 : mblume 1393 val compManagerHook :
24 :     { manageImport : Ast.dec * EnvRef.envref -> unit,
25 :     managePrint : Symbol.symbol * EnvRef.envref -> unit,
26 :     getPending : unit -> Symbol.symbol list } ref =
27 :     ref { manageImport = fn _ => (),
28 :     managePrint = fn _ => (),
29 :     getPending = fn () => [] }
30 : monnier 16
31 : mblume 1393 fun installCompManagers cm = compManagerHook := cm
32 : monnier 16
33 :     val say = Control.Print.say
34 :    
35 :     exception EndOfFile
36 :    
37 :     fun interruptable f x =
38 :     let val oldcont = !U.topLevelCont
39 :     in U.topLevelCont :=
40 :     SMLofNJ.Cont.callcc
41 :     (fn k => (SMLofNJ.Cont.callcc(fn k' => (SMLofNJ.Cont.throw k k'));
42 :     raise Interrupt));
43 :     (f x before U.topLevelCont := oldcont)
44 :     handle e => (U.topLevelCont := oldcont; raise e)
45 :     end
46 :    
47 : mblume 1448 exception ExnDuringExecution of exn
48 :    
49 : monnier 16 (*
50 :     * The baseEnv and localEnv are purposely refs so that a top-level command
51 :     * can re-assign either one of them, and the next iteration of the loop
52 :     * will see the new value. It's also important that the toplevelenv
53 :     * continuation NOT see the "fetched" environment, but only the ref;
54 :     * then, if the user "filters" the environment ref, a smaller image
55 :     * can be written.
56 :     *)
57 :    
58 : blume 905 fun evalLoop source = let
59 :     val parser = SmlFile.parseOne source
60 :     val cinfo = C.mkCompInfo { source = source, transform = fn x => x }
61 : monnier 16
62 : monnier 47 fun checkErrors s =
63 : blume 879 if CompInfo.anyErrors cinfo then raise EM.Error else ()
64 : monnier 16
65 :     fun oneUnit () = (* perform one transaction *)
66 : blume 905 case parser () of
67 :     NONE => raise EndOfFile
68 :     | SOME ast => let
69 :     val loc = EnvRef.loc ()
70 :     val base = EnvRef.base ()
71 : mblume 1393 val _ = #manageImport (!compManagerHook) (ast, loc)
72 : monnier 16
73 : mblume 1393 fun getenv () = E.layerEnv (#get loc (), #get base ())
74 :    
75 : monnier 47 val {static=statenv, dynamic=dynenv, symbolic=symenv} =
76 : mblume 1393 getenv ()
77 : monnier 16
78 : blume 818 val splitting = Control.LambdaSplitting.get ()
79 : monnier 47 val {csegments, newstatenv, absyn, exportPid, exportLvars,
80 :     imports, inlineExp, ...} =
81 : blume 905 C.compile {source=source, ast=ast,
82 :     statenv=statenv,
83 :     symenv=symenv,
84 :     compInfo=cinfo,
85 :     checkErr=checkErrors,
86 : blume 1058 splitting=splitting,
87 : blume 1137 guid = () }
88 : monnier 47 (** returning absyn and exportLvars here is a bad idea,
89 :     they hold on things unnecessarily; this must be
90 :     fixed in the long run. (ZHONG)
91 :     *)
92 : monnier 16
93 : mblume 1448 val executable = Execute.mkexec
94 :     { cs = csegments,
95 :     exnwrapper = ExnDuringExecution }
96 :     before checkErrors ()
97 : blume 905 val executable = Isolate.isolate (interruptable executable)
98 : monnier 16
99 : monnier 47 val _ = (PC.current := Profile.otherIndex)
100 :     val newdynenv =
101 : mblume 1448 Execute.execute { executable=executable, imports=imports,
102 :     exportPid=exportPid, dynenv=dynenv }
103 : monnier 47 val _ = (PC.current := Profile.compileIndex)
104 : monnier 16
105 : blume 879 val newenv =
106 :     E.mkenv { static = newstatenv,
107 :     dynamic = newdynenv,
108 :     symbolic = SymbolicEnv.mk (exportPid,inlineExp) }
109 : blume 905 val newLocalEnv = E.concatEnv (newenv, #get loc ())
110 :     (* refetch loc because execution may
111 : monnier 47 have changed its contents *)
112 : monnier 16
113 : macqueen 1344
114 :     (* start adding testing code of ppast.ppdec here *)
115 :     val debugging = ref true
116 :    
117 :     val printDepth = Control_Print.printDepth
118 :    
119 :     fun debugPrint (debugging: bool ref)
120 :     (msg: string, printfn: PP.stream -> 'a -> unit, arg: 'a) =
121 :     if (!debugging) then
122 :     with_pp (EM.defaultConsumer())
123 :     (fn ppstrm =>
124 :     (openHVBox ppstrm (PP.Rel 0);
125 :     PP.string ppstrm msg;
126 :     newline ppstrm;
127 :     openHVBox ppstrm (PP.Rel 0);
128 :     printfn ppstrm arg;
129 :     closeBox ppstrm;
130 :     newline ppstrm;
131 :     closeBox ppstrm;
132 :     flushStream ppstrm))
133 :     else ()
134 :    
135 :     fun ppAstDebug (msg,dec) =
136 :     let fun ppAstDec ppstrm d =
137 :     PPAst.ppDec (statenv,NONE) ppstrm (d,!printDepth)
138 :     in debugPrint (Control.printAst) (msg, ppAstDec, dec)
139 :     end
140 :    
141 :     fun ppAbsynDebug (msg,dec) =
142 :     let fun ppAbsynDec ppstrm d =
143 :     PPAbsyn.ppDec (statenv,NONE) ppstrm (d,!printDepth)
144 :     in debugPrint (Control.printAbsyn) (msg, ppAbsynDec, dec)
145 :     end
146 : mblume 1393
147 :     (* we install the new local env first before we go about
148 :     * printing, otherwise we find ourselves in trouble if
149 :     * the autoloader changes the the contents of loc under
150 :     * our feet... *)
151 :    
152 :     val _ = #set loc newLocalEnv
153 :    
154 :     fun look_and_load sy = let
155 :     fun look () = StaticEnv.look (E.staticPart (getenv ()), sy)
156 :     in
157 :     look ()
158 :     handle StaticEnv.Unbound =>
159 :     (#managePrint (!compManagerHook) (sy, loc);
160 :     look ())
161 :     end
162 :    
163 :     (* Notice that even through several potential rounds
164 :     * the result of get_symbols is constant (up to list
165 :     * order), so memoization (as performed by
166 :     * StaticEnv.special) is ok. *)
167 :     fun get_symbols () = let
168 :     val se = E.staticPart (getenv ())
169 :     val othersyms = #getPending (!compManagerHook) ()
170 :     in
171 :     StaticEnv.symbols se @ othersyms
172 :     end
173 :    
174 :     val ste1 = StaticEnv.special (look_and_load, get_symbols)
175 :    
176 :     val e0 = getenv ()
177 :     val e1 = E.mkenv { static = ste1,
178 :     symbolic = E.symbolicPart e0,
179 :     dynamic = E.dynamicPart e0 }
180 : blume 905 in
181 : macqueen 1344 (* testing code to print ast *)
182 :     ppAstDebug("AST::",ast);
183 :     (* testing code to print absyn *)
184 :     ppAbsynDebug("ABSYN::",absyn);
185 :    
186 :     PP.with_pp
187 : blume 905 (#errConsumer source)
188 : mblume 1393 (fn ppstrm => PPDec.ppDec e1 ppstrm (absyn, exportLvars))
189 : monnier 47 end
190 : monnier 16
191 :     fun loop() = (oneUnit(); loop())
192 : blume 905 in
193 :     interruptable loop ()
194 : monnier 16 end (* function evalLoop *)
195 :    
196 : mblume 1712 fun withErrorHandling treatasuser { thunk, flush, cont = k } =
197 :     let fun showhist' [s] = say (concat[" raised at: ", s, "\n"])
198 :     | showhist' (s::r) =
199 :     (showhist' r; say (concat [" ", s, "\n"]))
200 : blume 905 | showhist' [] = ()
201 : monnier 16
202 : mblume 1712 fun exnMsg (CompileExn.Compile s) = concat ["Compile: \"", s, "\""]
203 : blume 905 | exnMsg exn = General.exnMessage exn
204 : monnier 16
205 : mblume 1448 fun showhist e = showhist' (SMLofNJ.exnHistory e)
206 : monnier 16
207 : mblume 1712 fun user_hdl (ExnDuringExecution exn) = user_hdl exn
208 :     | user_hdl exn =
209 :     let val msg = exnMsg exn
210 :     val name = exnName exn
211 :     in if msg = name then
212 :     say (concat ["\nuncaught exception ", name, "\n"])
213 :     else say (concat ["\nuncaught exception ",
214 :     name, " [", msg, "]\n"]);
215 :     showhist exn;
216 :     flush ();
217 :     k exn
218 :     end
219 : mblume 1448
220 : mblume 1712 fun bug_hdl exn =
221 :     let val msg = exnMsg exn
222 : mblume 1448 val name = exnName exn
223 : mblume 1712 in say (concat ["\nunexpected exception (bug?) in SML/NJ: ",
224 :     name," [", msg, "]\n"]);
225 :     showhist exn;
226 :     flush();
227 :     k exn
228 : mblume 1448 end
229 :    
230 : mblume 1712 fun non_bt_hdl e =
231 :     case e of
232 :     EndOfFile => (say "\n")
233 :     | (Interrupt | ExnDuringExecution Interrupt) =>
234 :     (say "\nInterrupt\n"; flush(); k e)
235 :     | EM.Error => (flush(); k e)
236 :     | CompileExn.Compile "syntax error" => (flush(); k e)
237 :     | CompileExn.Compile s =>
238 :     (say(concat["\nuncaught exception Compile: \"", s,"\"\n"]);
239 :     flush(); k e)
240 :     | Isolate.TopLevelCallcc =>
241 :     (say("Error: throw from one top-level expression \
242 :     \into another\n");
243 :     flush (); k e)
244 :     | (Execute.Link | ExnDuringExecution Execute.Link) =>
245 :     (flush (); k e)
246 :     | ExnDuringExecution exn => user_hdl exn
247 :     | exn => if treatasuser then user_hdl exn else bug_hdl exn
248 :     in SMLofNJ.Internals.TDP.with_monitors thunk
249 :     handle e => non_bt_hdl e
250 :     end
251 : mblume 1448
252 : mblume 1712 (*** interactive loop, with error handling ***)
253 :     fun interact () =
254 :     let val source = Source.newSource ("stdIn", 1, TextIO.stdIn, true,
255 :     EM.defaultConsumer ())
256 :     fun flush' () =
257 :     case TextIO.canInput(TextIO.stdIn, 4096) of
258 :     (NONE | SOME 0) => ()
259 :     | SOME _ => (ignore (TextIO.input TextIO.stdIn); flush'())
260 : monnier 16
261 : mblume 1712 fun flush () = (#anyErrors source := false;
262 :     flush'() handle IO.Io _ => ())
263 :    
264 :     fun loop () = withErrorHandling false
265 :     { thunk = fn () => evalLoop source,
266 :     flush = flush, cont = loop o ignore }
267 :     in loop ()
268 :     end
269 :    
270 : monnier 16 fun isTermIn f =
271 :     let val (rd, buf) = TextIO.StreamIO.getReader(TextIO.getInstream f)
272 : blume 905 val isTTY =
273 :     case rd of
274 :     TextPrimIO.RD{ioDesc = SOME iod, ...} =>
275 : mblume 1712 (OS.IO.kind iod = OS.IO.Kind.tty)
276 : monnier 47 | _ => false
277 : mblume 1712 in (* since getting the reader will have terminated the stream, we need
278 :     * to build a new stream. *)
279 : blume 905 TextIO.setInstream(f, TextIO.StreamIO.mkInstream(rd, buf));
280 :     isTTY
281 : monnier 16 end
282 :    
283 : mblume 1712 fun evalStream (fname, stream) =
284 :     let val interactive = isTermIn stream
285 :     val source = Source.newSource (fname, 1, stream, interactive,
286 :     EM.defaultConsumer ())
287 :     in evalLoop source
288 :     handle exn => (Source.closeSource source;
289 :     case exn of
290 :     EndOfFile => ()
291 :     | _ => raise exn)
292 :     end
293 : monnier 16
294 :     end (* top-level local *)
295 :     end (* functor EvalLoopF *)

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