![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to interact.sml CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [Research Unix] / researchv10no / cmd / sml / src / build|
Return to interact.sml CVS log | Up to [Research Unix] / researchv10no / cmd / sml / src / build |
1.1 root 1: (* Copyright 1989 by AT&T Bell Laboratories *)
2: functor Interact(structure Machm : CODEGENERATOR
3: structure Importer: IMPORTER
4: ) : sig end =
5: struct
6: (* structure Reopener = Reopen(struct structure C=Machine and Machm=Machm end) *)
7:
8: open ErrorMsg Access Basics BareAbsyn Lambda PrintUtil ProcessFile
9:
10: exception Stop
11: val printDepth = System.Control.Print.printDepth
12: val saveLambda = System.Control.saveLambda
13: val bucket = ref (Lambda.RECORD [])
14: val _ = System.Control.prLambda :=
15: fn () => (MCprint.printLexp (!bucket); newline())
16: fun spoolLambda l = if !saveLambda then bucket := l else ()
17: val lambda = ref (Lambda.RECORD [])
18: val vars = ref (nil : int list)
19: fun prLambda () = (MCprint.printLexp(!lambda); newline())
20: fun prFun lv = (MCprint.printFun(!lambda) lv; newline())
21: fun timemsg (s : string) =
22: let val printit = !System.Control.timings
23: in if printit then (print s; newline()) else ();
24: printit
25: end
26:
27: (* functions for retrieving new bound lvars from declaration abstract syntax *)
28:
29: fun smash f l = fold (fn (a,c) => f a @ c) l []
30:
31: fun patvars (VARpat(VALvar{access=LVAR v,...})) = [v]
32: | patvars (VARpat(VALvar{access=INLINE _,...})) = []
33: | patvars (VARpat _ ) = impossible "non-LVAR in translate.patvars"
34: | patvars (RECORDpat{fields,...}) = smash (fn (_,p) => patvars p) fields
35: | patvars (APPpat(_,p)) = patvars p
36: | patvars (CONSTRAINTpat(p,_)) = patvars p
37: | patvars (LAYEREDpat(p,q)) = patvars p @ patvars q
38: | patvars _ = []
39:
40: fun getvars (VALdec vbl) = smash (fn VB{pat,...} => patvars pat) vbl
41: | getvars (a as VALRECdec rvbl) =
42: smash (fn RVB{var=VALvar{access=LVAR(var),...},exp,...} => [var]
43: | _ => impossible "#738 in translate")
44: rvbl
45: | getvars (LOCALdec (localdec,visibledec)) = getvars visibledec
46: | getvars (EXCEPTIONdec ebl) =
47: map (fn EBgen{exn=DATACON{rep=VARIABLE(LVAR v),...},...} => v
48: | EBdef{exn=DATACON{rep=VARIABLE(LVAR v),...},...} => v
49: | _ => impossible "in getvars EXCEPTIONdec")
50: ebl
51: | getvars (SEQdec decl) = smash getvars decl
52: | getvars (DATATYPEdec _) = []
53: | getvars (ABSTYPEdec{body,...}) = getvars body
54: | getvars (TYPEdec _) = []
55: | getvars (STRdec sbl) =
56: map (fn STRB{strvar=STRvar{access=LVAR(v),...},...} => v
57: | _ => impossible "getvars(STRdec)/fn"
58: ) sbl
59: | getvars (ABSdec sbl) =
60: map (fn STRB{strvar=STRvar{access=LVAR(v),...},...} => v
61: | _ => impossible "getvars(ABSdec)/fn"
62: ) sbl
63: | getvars (FCTdec fbl) =
64: map (fn FCTB{fctvar=FCTvar{name,access=LVAR(v),...},...} => v
65: | _ => impossible "getvars(FCTdec)/fn"
66: ) fbl
67: | getvars (OPENdec _) = []
68: | getvars (SIGdec _) = []
69: | getvars (IMPORTdec _) = impossible "getvars(IMPORTdec)"
70: | getvars (MARKdec (dec,_,_)) = getvars dec
71:
72: open System.Timer
73: val update = System.Stats.update
74:
75: (* set up top-level runtime environment, represented as intmap *)
76: exception Runbind
77: val t = Intmap.new(32, Runbind) : System.Unsafe.object Intmap.intmap
78: val bind = Intmap.add t (* add runtime binding *)
79: val unbind = Intmap.rem t (* remove runtime binding *)
80: val _ = System.Unsafe.lookup_r := Intmap.map t
81: val lookup = System.Unsafe.lookup
82:
83: fun parse(lex : Lex.lexer) =
84: let val ref linenum = ErrorMsg.lineNum
85: val timer = start_timer()
86: fun moretops() = case !(#nextToken lex)
87: of Token.SEMICOLON => nil
88: | Token.EOF => nil
89: | Token.IMPORT => nil
90: | _ => tops()
91: and tops() =
92: let val e0 = Env.current()
93: in while !(#nextToken lex) = Token.SEMICOLON
94: do (#advance lex)();
95: case Parse.interdec lex
96: of x as BareAbsyn.IMPORTdec _ => [x]
97: | OPENdec strvars =>
98: (Env.resetEnv e0;
99: SEQdec(map Misc.dumpStructure strvars) ::
100: moretops())
101: | y => y :: moretops()
102: end
103: val absyn = (ErrorMsg.anyErrors := false;
104: case tops() of [dec] => dec
105: | seq => Absyn.SEQdec seq)
106: val time = check_timer timer
107: val lines = !ErrorMsg.lineNum - linenum
108: in update(System.Stats.parse,time);
109: System.Stats.lines := !System.Stats.lines + lines;
110: timemsg ("parse, " ^ Integer.makestring lines
111: ^ " lines, " ^ makestring time ^ "s")
112: orelse debugmsg "parse";
113: if !System.Control.debugging
114: then (PrintAbsyn.printDec(absyn,0,!printDepth); newline())
115: else ();
116: if !anyErrors then raise Stop else ();
117: absyn
118: end
119:
120: fun translate absyn =
121: let val timer = start_timer()
122: val newlvars = getvars absyn
123: val (absyn', profileList) = Prof.instrumDec(absyn)
124: val lambda' = FN(mkLvar(), Translate.transDec absyn'
125: (Lambda.RECORD (map Lambda.VAR newlvars)))
126: val lambda = Prof.bindLambda(lambda',profileList)
127: val time = check_timer timer
128: in update(System.Stats.translate,time);
129: timemsg ("translate, " ^ makestring time ^ "s")
130: orelse debugmsg "translate";
131: if !anyErrors then raise Stop else ();
132: (newlvars, lambda)
133: end
134:
135: fun opt lambda =
136: let val timer = start_timer()
137: val lambda = if !CGoptions.reduce then Opt.reduce lambda else lambda
138: val _ = if !anyErrors then raise Stop else ()
139: val lambda = if !CGoptions.hoist then Opt.hoist lambda else lambda
140: val time = check_timer timer
141: in update(System.Stats.codeopt,time);
142: timemsg ("codeopt, " ^ makestring time ^ "s")
143: orelse debugmsg "codeopt";
144: lambda
145: end
146:
147: fun codegen lambda =
148: let val timer = start_timer()
149: val executable =
150: (if !anyErrors then raise Stop else ();
151: debugmsg "about to boot";
152: (System.Unsafe.boot :
153: string -> ((int->System.Unsafe.object) ->
154: ((unit -> System.Unsafe.object Array.array) *
155: ByteArray.bytearray Array.array)))
156: (Machm.generate lambda))
157: val time = check_timer timer
158: in update(System.Stats.codegen,time);
159: timemsg ("codegen, " ^ makestring time ^ "s")
160: orelse debugmsg "codegen";
161: if !anyErrors then raise Stop else ();
162: executable
163: end
164:
165: fun exec executable =
166: let val timer = start_timer()
167: val result = executable lookup
168: val time = check_timer timer
169: in update(System.Stats.execution,time);
170: timemsg ("execution, " ^ makestring time ^ "s")
171: orelse debugmsg "execution";
172: result
173: end
174:
175:
176: (* toplevel loop *)
177: (* initialize static environment *)
178: val (vCore,vInitial,vMath) = bootEnv load
179: val pervasiveEnv = Env.closeCurrentNewEnv()
180: val _ = Env.resetEnv pervasiveEnv
181: val _ = Env.commit()
182:
183: (* Build an environment (record) of the interactive compilation functions
184: to pass to the Importer, so that it can compile and run things. *)
185:
186: val toplevelFns =
187: Importer.TOPLEVEL_FNS{bind=bind, lookup=lookup,
188: parse=parse, getvars=getvars, opt=opt
189: }
190:
191: fun toploop(lex : Lex.lexer) =
192: let val _ = #prompt lex := !System.Control.primaryPrompt
193: val absyn = parse lex
194: in (case absyn
195: of IMPORTdec fnames =>
196: let fun doit f = Importer.getAndExecModule(
197: f, pervasiveEnv, toplevelFns
198: )
199: in app doit fnames
200: handle Importer.Import verdict =>
201: (print("IMPORT failed (" ^ verdict ^ ")\n"); raise Stop)
202: end
203: | _ => (* normal program *)
204: let val (newlvars,lambda) = translate absyn
205: val oldlvars =
206: EnvAccess.staleLvars(Env.current(),Env.previous())
207: val lambda = opt(Opt.closetop(lambda, ProcessFile.getCore()))
208: val executable =
209: if !System.Control.interp then Interp.interp lambda
210: else codegen lambda
211: val (result',profile) = exec executable
212: val result =
213: (System.Control.ProfileInternals.add profile;
214: System.Control.ProfileInternals.setOther ();
215: System.Unsafe.isolate result' before
216: System.Control.ProfileInternals.setToplevel ())
217: fun bindlvars (i,v::r) = (bind(v,result sub i);
218: bindlvars (i+1,r))
219: | bindlvars (_,nil) = ()
220: in bindlvars(0,newlvars); (* add new runtime bindings *)
221: app unbind oldlvars; (* remove stale runtime bindings *)
222: spoolLambda lambda; (* save lambda code *)
223: PrintDec.printDec lookup absyn; (* print result *)
224: Env.consolidate(); (* consolidate static environment *)
225: Env.commit() (* accept static bindings *)
226: end);
227: toploop lex
228: end
229:
230: fun use_source(fname,stream) =
231: let val _ = print("[opening " ^ fname ^ "]\n")
232: val interactive = is_term_in stream
233: val lex = Lex.mkLex{stream=stream, interactive=interactive}
234: val oldinteractive = !System.interactive
235: val oldfile = !ErrorMsg.fileName
236: val oldlinenum = !ErrorMsg.lineNum
237: in ErrorMsg.fileName := fname; ErrorMsg.lineNum := 1;
238: System.interactive := interactive;
239: toploop lex
240: handle exn =>
241: (print("[closing " ^ fname ^ "]\n");
242: close_in stream handle Io _ => ();
243: ErrorMsg.fileName := oldfile;
244: ErrorMsg.lineNum := oldlinenum;
245: System.interactive := oldinteractive;
246: case exn
247: of Parse.Eof => ()
248: | Stop => (Env.restore(); Env.openScope(); raise Syntax)
249: | _ => (Env.restore(); Env.openScope(); raise exn))
250: end
251:
252: fun use_file fname =
253: use_source(fname,(open_in fname handle e as Io _ =>
254: (print("[cannot open " ^ fname ^ "]\n"); raise e)))
255:
256: fun use_stream s = use_source("<instream>",s)
257:
258: (* outer interactive loop, with error handling *)
259: fun interact() =
260: let val lex = Lex.mkLex{stream=std_in, interactive=true}
261: fun restart() = (Env.restore(); Env.openScope();
262: input std_in (can_input std_in);
263: interact())
264: in ErrorMsg.fileName := "std_in"; ErrorMsg.lineNum := 1;
265: toploop lex
266: handle Parse.Eof => ()
267: | f => if !System.interactive
268: then case f
269: of Stop => restart()
270: | Syntax => restart()
271: | Io s => (print("uncaught exception Io \""
272: ^ s ^ "\"\n");
273: restart())
274: | _ => (print("uncaught exception "
275: ^ System.exn_name f ^ "\n");
276: restart())
277: else (print("uncaught exception "
278: ^ System.exn_name f ^ "\n");())
279: end
280:
281: (* bind runtime boot structures: Core, Math, and Initial *)
282: val {core,math,initial} = !System.Unsafe.pstruct
283: val _ = (bind(vCore,core); bind(vInitial,initial); bind(vMath,math))
284:
285: val _ =
286: (IO.use_f := use_file;
287: IO.use_s := use_stream;
288: System.Control.ProfileInternals.setToplevel ();
289: print "Go for it\n";
290: interact())
291:
292: end (* functor Interact *)
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.