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

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