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