![[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.