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 879 - (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 : monnier 16 in
16 :    
17 :     exception Interrupt
18 : monnier 47 type lvar = Access.lvar
19 : monnier 16
20 : monnier 47 type interactParams =
21 : blume 879 { compManagerHook :
22 :     (Ast.dec * EnvRef.envref * EnvRef.envref -> unit) option ref,
23 :     baseEnvRef : EnvRef.envref,
24 :     localEnvRef : EnvRef.envref,
25 :     transform : Absyn.dec -> Absyn.dec,
26 :     instrument : { source: Source.inputSource,
27 :     compenv: StaticEnv.staticEnv }
28 :     -> Absyn.dec -> Absyn.dec,
29 :     perform : CodeObj.executable -> CodeObj.executable,
30 :     isolate : CodeObj.executable -> CodeObj.executable,
31 :     printer : E.environment -> PP.ppstream
32 :     -> (Absyn.dec * lvar list) -> unit }
33 : monnier 16
34 :     val stdParams : interactParams =
35 :     {compManagerHook = ref NONE,
36 :     baseEnvRef = EnvRef.pervasive,
37 :     localEnvRef = EnvRef.topLevel,
38 :     transform = (fn x => x),
39 :     instrument = (fn _ => fn x => x),
40 :     perform = (fn x => x),
41 : blume 879 isolate = Isolate.isolate,
42 : monnier 16 printer = PPDec.ppDec}
43 :    
44 :     (* toplevel loop *)
45 :    
46 :     val say = Control.Print.say
47 :     fun debugmsg msg =
48 :     if !Control.debugging then (say (msg ^ "\n"); Control.Print.flush()) else ()
49 :    
50 :     exception EndOfFile
51 :    
52 :     fun interruptable f x =
53 :     let val oldcont = !U.topLevelCont
54 :     in U.topLevelCont :=
55 :     SMLofNJ.Cont.callcc
56 :     (fn k => (SMLofNJ.Cont.callcc(fn k' => (SMLofNJ.Cont.throw k k'));
57 :     raise Interrupt));
58 :     (f x before U.topLevelCont := oldcont)
59 :     handle e => (U.topLevelCont := oldcont; raise e)
60 :     end
61 :    
62 :     (*
63 :     * The baseEnv and localEnv are purposely refs so that a top-level command
64 :     * can re-assign either one of them, and the next iteration of the loop
65 :     * will see the new value. It's also important that the toplevelenv
66 :     * continuation NOT see the "fetched" environment, but only the ref;
67 :     * then, if the user "filters" the environment ref, a smaller image
68 :     * can be written.
69 :     *)
70 :    
71 :     fun evalLoop ({compManagerHook, baseEnvRef, localEnvRef, perform,
72 :     isolate, printer, instrument, transform} : interactParams)
73 :     (source: Source.inputSource) : unit =
74 :    
75 : blume 879 let val parser = SmlFile.parseOne source
76 :     val cinfo = C.mkCompInfo { source = source, transform = transform }
77 : monnier 16
78 : monnier 47 fun checkErrors s =
79 : blume 879 if CompInfo.anyErrors cinfo then raise EM.Error else ()
80 : monnier 16
81 :     fun oneUnit () = (* perform one transaction *)
82 : monnier 47 case parser ()
83 :     of NONE => raise EndOfFile
84 :     | SOME ast =>
85 :     let val _ = case !compManagerHook
86 :     of NONE => ()
87 :     | SOME cm => cm (ast, baseEnvRef, localEnvRef)
88 : monnier 16
89 : monnier 47 val {static=statenv, dynamic=dynenv, symbolic=symenv} =
90 : blume 587 E.layerEnv(#get localEnvRef (), #get baseEnvRef ())
91 : monnier 16
92 : blume 818 val splitting = Control.LambdaSplitting.get ()
93 : monnier 47 val {csegments, newstatenv, absyn, exportPid, exportLvars,
94 :     imports, inlineExp, ...} =
95 : blume 587 C.compile {source=source, ast=ast,
96 :     statenv=statenv,
97 :     symenv=symenv,
98 :     compInfo=cinfo,
99 :     checkErr=checkErrors,
100 : monnier 47 splitting=splitting}
101 :     (** returning absyn and exportLvars here is a bad idea,
102 :     they hold on things unnecessarily; this must be
103 :     fixed in the long run. (ZHONG)
104 :     *)
105 : monnier 16
106 : blume 879 val executable = Execute.mkexec csegments before checkErrors ()
107 : monnier 47 val executable = isolate (interruptable (perform executable))
108 : monnier 16
109 : monnier 47 val _ = (PC.current := Profile.otherIndex)
110 :     val newdynenv =
111 : blume 879 Execute.execute{executable=executable, imports=imports,
112 :     exportPid=exportPid, dynenv=dynenv}
113 : monnier 47 val _ = (PC.current := Profile.compileIndex)
114 : monnier 16
115 : blume 879 val newenv =
116 :     E.mkenv { static = newstatenv,
117 :     dynamic = newdynenv,
118 :     symbolic = SymbolicEnv.mk (exportPid,inlineExp) }
119 : monnier 47 val newLocalEnv = E.concatEnv(newenv, #get localEnvRef ())
120 :     (* refetch localEnvRef because execution may
121 :     have changed its contents *)
122 : monnier 16
123 : monnier 47 in PrettyPrint.with_pp (#errConsumer source)
124 :     (fn ppstrm => printer
125 : blume 587 (E.layerEnv(newLocalEnv, #get baseEnvRef ()))
126 : monnier 47 ppstrm (absyn, exportLvars));
127 :     #set localEnvRef newLocalEnv
128 :     end
129 : monnier 16
130 :     fun loop() = (oneUnit(); loop())
131 :     in interruptable loop ()
132 :     end (* function evalLoop *)
133 :    
134 :     (*** interactive loop, with error handling ***)
135 :     fun interact (interactParams) : unit =
136 :     let val source = Source.newSource("stdIn",1,TextIO.stdIn,true,
137 : monnier 47 EM.defaultConsumer());
138 :     fun flush'() =
139 :     case TextIO.canInput(TextIO.stdIn, 4096)
140 :     of NONE => ()
141 :     | (SOME 0) => ()
142 :     | (SOME _) => (ignore (TextIO.input TextIO.stdIn); flush'())
143 : monnier 16
144 : monnier 47 fun flush() = (#anyErrors source := false;
145 :     flush'() handle IO.Io _ => ())
146 : monnier 16
147 : monnier 47 local val p1 = Substring.isPrefix "TopLevel/interact/evalloop.sml:"
148 :     val p2 = Substring.isPrefix "TopLevel/main/compile.sml:"
149 :     val p3 = Substring.isPrefix "MiscUtil/util/stats.sml:"
150 :     in fun edit [s] = [s]
151 :     | edit nil = nil
152 :     | edit (s::r) =
153 :     let val s' = Substring.all s
154 :     in if p1 s' orelse p2 s' orelse p3 s'
155 :     then edit r else s :: edit r
156 :     end
157 : monnier 16 end
158 :    
159 : monnier 47 fun showhist' [s] = say(concat[" raised at: ", s, "\n"])
160 :     | showhist' (s::r) = (showhist' r;
161 :     say (concat[" ", s, "\n"]))
162 :     | showhist' [] = ()
163 : monnier 16
164 : blume 879 fun exnMsg (CompileExn.Compile s) = concat["Compile: \"", s, "\""]
165 :     | exnMsg (Isolate.TopLevelException e) = exnMsg e
166 : monnier 47 | exnMsg exn = General.exnMessage exn
167 : monnier 16
168 : blume 879 fun showhist (Isolate.TopLevelException e) = showhist e
169 : monnier 47 | showhist e = showhist' (edit(SMLofNJ.exnHistory e))
170 : monnier 16
171 : blume 675 fun loop () = let
172 : blume 678 fun non_bt_hdl e =
173 :     case e of
174 :     EndOfFile => (say "\n")
175 :     | Interrupt => (say "\nInterrupt\n";
176 :     flush(); loop())
177 :     (* | EM.Error => (flush(); loop()) *)
178 : blume 879 | CompileExn.Compile "syntax error" => (flush(); loop())
179 :     | CompileExn.Compile s =>
180 : blume 678 (say(concat["\nuncaught exception Compile: \"",
181 :     s,"\"\n"]);
182 :     flush(); loop())
183 : blume 879 | Isolate.TopLevelException Isolate.TopLevelCallcc =>
184 : blume 678 (say("Error: throw from one top-level expression \
185 :     \into another\n");
186 :     flush (); loop ())
187 : blume 879 | Isolate.TopLevelException EM.Error =>
188 : blume 678 (flush (); loop ())
189 : blume 879 | Isolate.TopLevelException exn => let
190 : blume 678 val msg = exnMsg exn
191 :     val name = exnName exn
192 :     in
193 :     if (msg = name)
194 :     then say (concat
195 :     ["\nuncaught exception ",
196 :     exnName exn, "\n"])
197 :     else say (concat
198 :     ["\nuncaught exception ", exnName exn,
199 :     " [", exnMsg exn, "]\n"]);
200 :     showhist exn;
201 :     flush();
202 :     loop()
203 :     end
204 :     | exn => (say (concat["\nuncaught exception ",
205 :     exnMsg exn, "\n"]);
206 :     showhist exn;
207 :     flush();
208 :     loop())
209 :     fun bt_hdl (e, []) = non_bt_hdl e
210 :     | bt_hdl (e, hist) =
211 :     (say (concat ("\n*** BACK-TRACE ***\n" :: hist));
212 :     say "\n";
213 :     non_bt_hdl e)
214 : blume 675 in
215 : blume 678 SMLofNJ.Internals.BTrace.bthandle
216 :     { work = fn () => evalLoop interactParams source,
217 :     hdl = bt_hdl }
218 : blume 675 end
219 :     in loop()
220 : monnier 16 end (* fun interact *)
221 :    
222 :     fun isTermIn f =
223 :     let val (rd, buf) = TextIO.StreamIO.getReader(TextIO.getInstream f)
224 : monnier 47 val isTTY =
225 :     case rd
226 :     of TextPrimIO.RD{ioDesc = SOME iod, ...} =>
227 :     (OS.IO.kind iod = OS.IO.Kind.tty)
228 :     | _ => false
229 : monnier 16
230 : monnier 145 (* val buf = if (buf = "") then NONE else SOME buf *)
231 : monnier 16 in (* since getting the reader will have terminated the stream, we need
232 : monnier 47 * to build a new stream. *)
233 :     TextIO.setInstream(f, TextIO.StreamIO.mkInstream(rd, buf));
234 :     isTTY
235 : monnier 16 end
236 :    
237 :     fun evalStream interactParams
238 :     (fname:string,stream:TextIO.instream) : unit =
239 :     let val interactive = isTermIn stream
240 : monnier 47 val source = Source.newSource(fname,1,stream,interactive,
241 :     EM.defaultConsumer())
242 : monnier 16 in evalLoop interactParams source
243 : monnier 47 handle exn =>
244 :     (Source.closeSource source;
245 :     case exn
246 :     of EndOfFile => ()
247 : blume 879 | Isolate.TopLevelException e => raise e
248 : monnier 47 | _ => raise exn)
249 : monnier 16 end
250 :    
251 :     end (* top-level local *)
252 :     end (* functor EvalLoopF *)

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