![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to importer.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 / sepcomp|
Return to importer.sml CVS log | Up to [Research Unix] / researchv10no / cmd / sml / src / sepcomp |
1.1 root 1: (* Copyright 1989 by AT&T Bell Laboratories *)
2: (* importer.sml 608567950 46 20 100444 17742 `*)
3: (* Importer: Isolation of Mads' original code from Interact() into a separate
4: functor. Numerous extensions, Make system, etc. etc. (NICK) *)
5:
6: functor Importer(structure FilePaths: FILEPATHS
7: val fileExtension: string
8: structure ModuleComp: MODULE_COMPILER
9: sharing ModuleComp.Lambda = Lambda
10: and ModuleComp.Absyn = BareAbsyn
11: and type ModuleComp.lvar = Access.lvar)
12: : IMPORTER =
13: struct
14:
15: open PrintUtil Access Basics Stampset Env
16:
17: val gcmessages = System.Control.Runtime.gcmessages
18: (* The message "Major collection... abandoned" is
19: annoying me, so I'm hosing it. NICK *)
20:
21: fun all pred list =
22: fold (fn (this, res) => pred this andalso res) list true
23:
24: val DEBUG = false
25: val debug =
26: if DEBUG then fn str => output std_out ("<" ^ str ^ ">\n")
27: else fn _ => ()
28:
29: val TRACE_IO = false
30: val open_in =
31: if TRACE_IO
32: then fn name => (debug("open_in \\" ^ name ^ "\\"); open_in name)
33: else open_in
34:
35: val open_out =
36: if TRACE_IO
37: then (fn name => (debug("open_out \\" ^ name ^ "\\"); open_out name))
38: else open_out
39:
40: exception Import of string
41: (* A single exception for any failure to
42: import (barring compiler bugs). compSource
43: requires a protective coating so that it
44: doesn't leave the global static environment
45: in a funny state. *)
46:
47:
48: (* Feedback messages. If anybody's interested, files which may
49: cause failures, or may cause nested reads, are done as:
50:
51: [reading fred.sml]
52: [closing fred.sml]
53:
54: Ones which shouldn't (eg. reading from a binary) produce:
55:
56: [reading fred.bin... done]
57: *)
58:
59: fun reading(file, indent) =
60: (tab indent; print("[reading " ^ file ^ "]\n"))
61: fun reading1(file, indent) =
62: (tab indent; print("[reading " ^ file ^ "... "); flush_out std_out)
63: fun writing(file, indent) =
64: (tab indent; print("[writing " ^ file ^ "]\n"))
65: fun writing1(file, indent) =
66: (tab indent; print("[writing " ^ file ^ "... "); flush_out std_out)
67: fun closing(file, indent) =
68: (tab indent; print("[closing " ^ file ^ "]\n"))
69: fun done() = print "done]\n"
70:
71: fun fail(msg, verdict) =
72: (print("import: " ^ msg ^ "\n"); raise Import verdict)
73:
74: (* impliedPath: derived from FilePaths.impliedPath, but catches
75: ImpliedPath if a "~"-filename fails to translate. *)
76:
77: fun impliedPath(oldPath, oldName) =
78: FilePaths.impliedPath(oldPath, oldName)
79: handle FilePaths.ImpliedPath =>
80: fail("couldn't translate path in: " ^ oldName, "open")
81:
82: type LambDynModule = ModuleComp.LambDynModule
83: type CodeDynModule = ModuleComp.CodeDynModule
84: type lvar = Access.lvar
85:
86: datatype ToplevelFns =
87: TOPLEVEL_FNS of
88: {bind: lvar * System.Unsafe.object -> unit,
89: lookup: lvar -> System.Unsafe.object,
90: parse: Lex.lexer -> BareAbsyn.dec,
91: getvars: BareAbsyn.dec -> lvar list,
92: opt: Lambda.lexp -> Lambda.lexp}
93:
94: datatype statModule =
95: STATmodule of {table: symtable, lvars: Basics.Access.lvar list}
96:
97:
98: (* Rename the lvars, and shift the stamps, of the static module.
99: Only signature and functor bindings are accepted.
100: For each functor binding, a fresh lvar will be chosen; hence
101: at run-time, several imports of the same functor will presumably
102: lead to a new copy of the code of that functor *)
103:
104: fun importModule(STATmodule{table,lvars}) : lvar list =
105: let val newlvars = map (fn _ => mkLvar()) lvars
106: fun lookup x =
107: let fun f(a::ar, b::br) = if a=x then b else f(ar,br)
108: | f _ = ErrorMsg.impossible "importModule 1"
109: in f(lvars,newlvars)
110: end
111: fun renBinding(SIGbind(SIGvar{name,binding})) =
112: SIGbind(SIGvar
113: {name=name,
114: binding=ModUtil.shiftSigStamps(newStampsets(),binding)})
115: | renBinding(FCTbind(FCTvar{name,access=LVAR lvar, binding})) =
116: FCTbind(FCTvar{name = name, access= LVAR(lookup lvar),
117: binding = ModUtil.shiftFctStamps binding})
118: | renBinding _ = ErrorMsg.impossible "importModule 2"
119: in IntStrMap.app (fn (i,s,b) => add(i,s,renBinding b)) table;
120: newlvars
121: end
122:
123: (* New code (NICK) - I store the static information (StatModule) and
124: dynamic information (CodeDynModule) in one object, so that I can blast
125: out the entire thing as a single object into a file. Foo.sml now gets
126: compiled into Foo.vax/Foo.m68/..., which contains
127: both. The object stored in the file is a pair: the first element is a
128: "version number" for the data structures, the second is whatever needs
129: storing (currently a record of {statModule, dynModule, imports}).
130: If this version number changes, I have to recompile. *)
131:
132: type BinFormat = {statModule: statModule,
133: dynModule: CodeDynModule,
134: imports: string list}
135:
136: val blastRead: instream -> BinFormat = System.Unsafe.blast_read
137: val blastWrite: (outstream * BinFormat) -> unit = System.Unsafe.blast_write
138:
139: val blastWrite = (* Silent version. *)
140: fn (stream, obj) =>
141: let val oldmsgs = !gcmessages
142: in gcmessages := 0;
143: blastWrite(stream, obj);
144: gcmessages := oldmsgs
145: end
146:
147: val BIN_VERSION = System.version ^ " - LAMBDA v0 " ^ fileExtension^ "\n"
148: (* This is stored as the first line of the
149: binary file. Be sure to increment it whenever the structure
150: of any of the stored data objects changes. It cannot
151: contain any \n characters, except at the end where
152: one is required. *)
153:
154: fun tryOpenIn filename: instream option =
155: SOME(open_in filename) handle Io _ => NONE
156:
157: fun createBinary(indent, filename,
158: statModule: statModule,
159: dynModule: CodeDynModule,
160: imports: string list) : unit =
161: let val fullName = filename ^ ".bin"
162: val outstream =
163: open_out fullName
164: handle Io _ => fail("couldn't open " ^ fullName ^ " for output",
165: "open")
166: in writing1(fullName, indent);
167: output outstream BIN_VERSION;
168: blastWrite(outstream,
169: {statModule=statModule,
170: dynModule=dynModule,
171: imports=imports});
172: close_out outstream;
173: done()
174: end
175:
176: val statPrinter: statModule -> string = (fn _ => "")
177: (* this definition causes createTextual to have no effect *)
178:
179: fun createTextual(indent, filename, statModule): unit =
180: case statPrinter statModule (* currently always "" *)
181: of "" => () (* Do NOTHING if the print function is a dummy *)
182: | text =>
183: let val fullName = filename ^ ".lstat"
184: val outstream =
185: open_out fullName
186: handle Io _ =>
187: fail("couldn't open " ^ fullName ^ " for output", "open")
188: in writing1(fullName, indent);
189: output outstream text;
190: close_out outstream;
191: done()
192: end
193:
194: (* We must do a syntactic check that the source declarations in a module
195: are just functor and signature declarations (or sequences thereof),
196: otherwise the renaming routines will fall over later. Importer is the
197: place to do it, where we still have a fighting chance of a putting
198: out a decent diagnostic message. We don't allow IMPORT - that should
199: have been dealt with earlier. *)
200:
201: fun kosherModuleDecl dec =
202: case dec
203: of BareAbsyn.FCTdec _ => true
204: | BareAbsyn.SIGdec _ => true
205: | BareAbsyn.SEQdec decs => (* ALL must be kosher. *)
206: all kosherModuleDecl decs
207: | _ => false
208:
209: fun badModuleDecl() = ErrorMsg.condemn "expecting SIGNATURE/FUNCTOR/IMPORT"
210:
211: (* uptodate should be memo'd sometime, since it's quite expensive. *)
212: fun uptodate (path, myBinTime) name =
213: let val {newPath, validName} = impliedPath(path, name)
214: val _ = debug("uptodate(quotedName=" ^ name
215: ^ ", validName=" ^ name ^ ")?")
216: val trySml = tryOpenIn(validName ^ ".sml")
217: val tryBin = tryOpenIn(validName ^ ".bin")
218: in case (trySml, tryBin)
219: of (SOME source, SOME binary) =>
220: let val srcTime = mtime source
221: val binTime = mtime binary
222: val _ = debug("uptodate(" ^ validName ^ "):\
223: \ src time = " ^ makestring srcTime
224: ^ ", bin time = " ^ makestring binTime)
225: in if srcTime >= binTime (* binary out of date *)
226: orelse binTime >= myBinTime
227: (* Some other branch of the Make
228: task compiled this under me...? *)
229: then (close_in source; close_in binary; false)
230: else (* source is older; check imports *)
231: let val _ = close_in source
232: val fullName = validName ^ ".bin"
233: val binVersion = input_line binary
234: in if binVersion <> BIN_VERSION
235: then (close_in binary; false)
236: (* can't trust "imports" : chicken out *)
237: else let val {imports, ...} =
238: blastRead binary before close_in binary
239: in all (uptodate (newPath, myBinTime)) imports
240: end
241: end
242: end
243:
244: | (SOME source, NONE) => (* No bin: force recompile *)
245: (close_in source; false)
246:
247: | (NONE, SOME binary) => (* No source: trust for now... *)
248: (close_in binary; true)
249:
250: | (NONE, NONE) =>
251: fail("cannot find source or binary\
252: \ of required module " ^ validName,
253: "open")
254: end (* uptodate *)
255:
256: fun getModule(name,pervasives,TOPLEVEL_FNS{bind,lookup,parse,getvars,opt})
257: : statModule * CodeDynModule =
258: let fun getModule'(parents, indent, path, name) =
259: (* "parents" is a depth-first list of filenames used for
260: a circularity check. "indent" is for cosmetic purposes. *)
261: let val {validName as filename, newPath as path} = impliedPath(path, name)
262: val _ = if exists (fn x => x = filename) parents
263: then fail("self-referential import of " ^ validName, "open")
264: else ()
265: val parents = filename :: parents
266: val _ = debug("getModule'(name=" ^ name ^ ")")
267:
268: fun compSource0(source: instream) : statModule * CodeDynModule =
269: let val lex = Lex.mkLex{stream=source,interactive=false}
270: fun loop(dynModule, lvars, imports)
271: : LambDynModule * lvar list * string list =
272: (case parse lex (* (Lex.toplevel := true; parse()) *)
273: of BareAbsyn.IMPORTdec names =>
274: let fun loop'([], dynMod, lvars, imports) =
275: (dynMod, lvars, imports)
276: | loop'(name::rest, dynMod, lvars, imports)=
277: let val {newPath, ...} = impliedPath(path, name)
278: val (stat, codeDyn) =
279: getModule'(parents, indent+2,
280: newPath, name)
281: val newLvars = importModule stat
282: val lambDyn = ModuleComp.abstractDynModule
283: (codeDyn, newLvars)
284: val dynMod' = ModuleComp.importDynModule
285: (lambDyn, dynMod)
286: in loop'(rest, dynMod', lvars @ newLvars,
287: name :: imports)
288: end
289: in loop(loop'(names, dynModule, lvars, imports))
290: end
291:
292: | absyn => (* normal program *)
293: if kosherModuleDecl absyn
294: then let val newLvars = getvars absyn
295: val newMod = ModuleComp.addDeclaration
296: (absyn, newLvars, dynModule)
297: handle ModuleComp.AddDeclaration =>
298: fail("error during translate",
299: "translate")
300: in loop(newMod, lvars @ newLvars, imports)
301: end
302: else badModuleDecl())
303:
304: handle Parse.Eof => (dynModule, lvars, imports)
305: | Import x => raise Import x
306: (* Resignal nested Import probs. *)
307: | Io x => raise Import("unexpected: Io(" ^ x ^ ")")
308: | exn => raise Import("compile-time exception: "
309: ^ System.exn_name exn)
310:
311: val (lambDynModule, lvars, imports) =
312: loop(ModuleComp.emptyDynModule, [], [])
313: val statModule= STATmodule{table=Env.popModule(pervasives),
314: lvars=lvars}
315: val dynModule = ModuleComp.compileDynModule opt lambDynModule
316: handle ModuleComp.CompileDynModule =>
317: fail("code generation failed", "codegen")
318: in createBinary(indent, filename, statModule,
319: dynModule, imports)
320: handle Import _ => (); (* make failed writes nonfatal... *)
321: createTextual(indent, filename, statModule) (* no-op *)
322: handle Import _ => ();
323: (statModule, dynModule)
324: end (* fun compSource *)
325:
326: fun compSource(source) =
327: let val _ = debug(filename ^ ": source only")
328: val fullName = filename ^ ".sml"
329: val _ = reading(fullName, indent)
330:
331: val oldfile = !ErrorMsg.fileName
332: val oldlinenum = !ErrorMsg.lineNum
333: val oldinteractive = !System.interactive
334: val savedEnv = Env.current()
335: fun cleanup () =
336: (closing(fullName, indent);
337: close_in source;
338: ErrorMsg.fileName := oldfile;
339: ErrorMsg.lineNum := oldlinenum;
340: System.interactive := oldinteractive;
341: Env.resetEnv savedEnv)
342: in ErrorMsg.fileName := fullName;
343: ErrorMsg.lineNum := 1;
344: System.interactive := false;
345: Env.resetEnv pervasives;
346: (compSource0(source) before cleanup())
347: handle exp => (cleanup(); raise exp)
348: end
349:
350: in case (tryOpenIn(filename ^ ".sml"), tryOpenIn(filename ^ ".bin"))
351: of (SOME source, NONE) => (* Source only: Compile! *)
352: compSource(source)
353: | (SOME source, SOME binary) =>
354: let val srcTime = mtime source
355: val binTime = mtime binary
356: val _ = debug(filename ^ ": src dated " ^ makestring srcTime
357: ^ ", bin dated " ^ makestring binTime)
358: in if srcTime >= binTime (* (">=" for safety) *)
359: then (* binary out of date? *)
360: (tab indent;
361: print("[" ^ filename ^ ".bin is out of date;\
362: \ recompiling]\n");
363: close_in binary;
364: compSource(source))
365: else (* bin is newer: what about the things imported? *)
366: let val _ = debug(filename ^ ": checking imports")
367: val fullName = filename ^ ".bin"
368: val _ = reading1(fullName, indent)
369: val binVersion = input_line binary
370: in if (binVersion <> BIN_VERSION)
371: then (print "]\n";
372: tab indent;
373: print("[" ^ fullName ^ " is the wrong format;\
374: \ recompiling]\n");
375: closing(fullName, indent);
376: close_in binary;
377: compSource(source))
378: else let val {statModule, dynModule, imports} =
379: blastRead binary
380: fun allOk imports =
381: all (uptodate (path, binTime)) imports
382: handle exn =>
383: (print "]\n";
384: closing(fullName, indent);
385: close_in binary;
386: close_in source;
387: raise exn)
388: in if not(allOk imports)
389: then (print "]\n";
390: tab indent;
391: print("[import(s) of " ^ filename
392: ^ " are out of date; recompiling]\n");
393: closing(fullName, indent);
394: close_in binary;
395: compSource(source))
396: else (* All OK: use the binary. *)
397: (debug(filename ^ ": all up to date");
398: close_in source;
399: close_in binary;
400: done();
401: (statModule, dynModule))
402: end
403: end
404: end
405:
406: | (NONE, SOME binary) =>
407: let val _ = debug(filename ^ ": binary only")
408: val fullName = filename ^ ".bin"
409: val _ = reading1(fullName, indent)
410: val binVersion = input_line binary
411: in if binVersion = BIN_VERSION
412: then let val {statModule, dynModule, ...} = blastRead binary
413: in close_in binary;
414: done();
415: (statModule, dynModule)
416: end
417: else (print "]\n"; (* Outstanding message... *)
418: tab indent;
419: print("[" ^ fullName ^ " is the wrong format;\
420: \ recompiling]\n");
421: closing(fullName, indent);
422: close_in binary;
423: case tryOpenIn(filename ^ ".sml")
424: of SOME source =>
425: compSource(source)
426: | NONE =>
427: fail(fullName ^ " is out of date, and can't\
428: \ open " ^ filename ^ ".sml",
429: "open"))
430: end
431:
432: | (NONE, NONE) => fail("cannot open " ^ filename ^ ".sml", "open")
433: end (* getModule' *)
434: in getModule'([],0,FilePaths.defaultPath,name)
435: end (* getModule *)
436:
437: fun getAndExecModule(filename, pervasives,
438: toplevelFns as TOPLEVEL_FNS{bind, lookup, ...}) : unit =
439: let val (statModule as STATmodule{table, ...}, compDynModule) =
440: getModule(filename, pervasives, toplevelFns)
441: in let val newlvars = importModule statModule
442: (* adds the static bindings of the module to the
443: static environment*)
444:
445: val result =
446: ModuleComp.executeDynModule compDynModule lookup
447: handle exn => (* Local handle for module execution (NICK). *)
448: fail("execution of module raised exception "
449: ^ System.exn_name exn
450: ^ "\n\t(static bindings of module take no effect)\n",
451: "uncaught exception")
452:
453: fun bindlvars (i,v::r) =
454: (bind(v,result sub i);
455: bindlvars (i+1,r))
456: | bindlvars (_,nil) = ()
457:
458: in bindlvars(0,newlvars); (* add new runtime bindings *)
459: Env.commit(); (* accept static bindings *)
460: PrintDec.printBindingTbl table
461: end
462: handle (* Exceptions other than ones raised through module execution. *)
463: Interrupt => raise Interrupt
464: | exn => ErrorMsg.impossible("addAndExecModule: exn ("
465: ^ System.exn_name exn ^ ")??")
466: end
467:
468: end (* functor Importer *)
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.