![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to moduleComp.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 moduleComp.sml CVS log | Up to [Research Unix] / researchv10no / cmd / sml / src / sepcomp |
1.1 root 1: (* Copyright 1989 by AT&T Bell Laboratories *)
2: (* moduleComp.sml *)
3: (* Modules compiler for New Jersey ML. Nick Rothwell, LFCS, January 1989. *)
4: (* New version, doing proper lambda nesting for declarations and imports,
5: rather than the old clatty concatenation stuff. *)
6:
7: functor ModuleComp(structure Absyn: BAREABSYN
8: sharing Absyn = BareAbsyn
9: structure Lambda: LAMBDA
10: structure Opt: OPT sharing Opt.L = Lambda
11: structure Machm: CODEGENERATOR
12: ): MODULE_COMPILER =
13: struct
14: structure Lambda = Lambda
15: structure Absyn = Absyn
16:
17: val bug = ErrorMsg.impossible
18:
19: (* Warning: if DEBUG is true, then exportFn tends to grab the whole
20: compiler. --Appel *)
21: val DEBUG = false
22:
23: type lvar = Access.lvar
24: type lexp = Lambda.lexp
25: type code = string
26:
27: fun assert(msg, cond) =
28: if cond then () else bug("assert: " ^ msg)
29:
30: fun pr s = (output std_out s; flush_out std_out)
31:
32: fun debug s = if DEBUG then pr s else ()
33:
34:
35: abstype LambDynModule =
36: LAMBDYNMODULE of {entry: Entry, lvars: lvar list} list
37: (* These are in reverse order of declaration. *)
38: and CodeDynModule =
39: CODEDYNMODULE of {self: code, subModules: CodeDynModule list}
40: (* The code is for a function:
41: "(M1, ..., Mn) -> looker -> array*rubbish"
42: where each Mi is a "looker -> array*rubbish" *)
43:
44: and Entry = LAMBDAentry of lexp->lexp (* unclosed *)
45: | IMPORTentry of CodeDynModule
46: with
47: val emptyDynModule = LAMBDYNMODULE []
48:
49: exception AddDeclaration
50: fun addDeclaration(dec, lvars, LAMBDYNMODULE entries) =
51: let
52: val newEntry =
53: {entry=LAMBDAentry(Translate.transDec dec), lvars=rev lvars}
54: in
55: if !ErrorMsg.anyErrors then
56: raise AddDeclaration
57: else
58: LAMBDYNMODULE(newEntry :: entries)
59: end
60:
61: fun importDynModule(LAMBDYNMODULE inner, LAMBDYNMODULE outer) =
62: LAMBDYNMODULE(inner @ outer)
63:
64: fun abstractDynModule(codeDynModule, lvars) =
65: LAMBDYNMODULE [{entry=IMPORTentry codeDynModule, lvars=lvars}]
66:
67: (* compiler: takes a LambDynModule to a CodeDynModule. We tie together
68: all the lambdas as a set of nested LET declarations. Where we import
69: already-compiled modules, these are abstracted to be arguments to the
70: final lambda expression. *)
71:
72: fun inventLvar name =
73: let
74: val saving = !System.Control.saveLvarNames
75: val _ = (System.Control.saveLvarNames := true)
76: val lvar = Access.namedLvar(Symbol.symbol(name ^ ":"))
77: val _ = (System.Control.saveLvarNames := saving)
78: in
79: lvar
80: end
81:
82: (* Some local lambda-building stuff. This should probably go in a wee
83: structure of its own. *)
84:
85: local
86: open Lambda
87: in
88: fun apply(lvar1, lvar2) = APP(VAR lvar1, VAR lvar2)
89:
90: fun let_1(lvar, exp1, exp2) = APP(FN(lvar, exp2), exp1)
91:
92: fun fn_N(name, lvars, exp) =
93: let
94: val vecLvar = inventLvar name
95: val vecExp = VAR vecLvar
96: fun doit(lv :: rest, n) =
97: let_1(lv, SELECT(n, vecExp), doit(rest, n+1))
98: | doit(nil, _) = exp
99: in
100: FN(vecLvar, doit(lvars, 0))
101: end
102:
103: fun let_N(name, lvars, exp1, exp2) =
104: APP(fn_N(name, lvars, exp2), exp1)
105:
106: fun record lvars = RECORD(map VAR lvars)
107: end
108:
109: (* foldLambda: takes a list of entries (assumed to be in same order
110: as the actual module declarations), and generates one big lambda.
111: We close it later. foldLambda returns
112: {lambda, imports, importLvars}. *)
113:
114: fun foldLambda({entry=LAMBDAentry thisFn, lvars} :: rest,
115: looker, allVars
116: ) =
117: let
118: val {lambda=next, imports, importLvars} =
119: foldLambda(rest, looker, lvars @ allVars)
120: in
121: {lambda=thisFn next, (* apply this fn->lambda to the
122: argument (that's how transDec
123: works...) *)
124: imports=imports,
125: importLvars=importLvars
126: }
127: end
128:
129: | foldLambda({entry=IMPORTentry subMod, lvars} :: rest,
130: looker, allVars
131: ) =
132: let
133: val modLvar =
134: inventLvar("importModule/" ^ makestring(length rest))
135: val {lambda=next, imports, importLvars} =
136: foldLambda(rest, looker, lvars @ allVars)
137: in
138: {lambda=let_N("importEntry", lvars, apply(modLvar,looker), next),
139: imports=subMod :: imports,
140: importLvars = modLvar :: importLvars
141: }
142: end
143:
144: | foldLambda(nil, _, allVars) =
145: {lambda=record(rev allVars), imports=nil, importLvars=nil}
146: (* Make sure the lvars comprising
147: the eventual record are the
148: right way round!! *)
149:
150: (* codegen compiles a lambda to a machine-code string. *)
151:
152: exception Codegen
153: fun codegen lambda: string =
154: let
155: val _ = debug "codegen...";
156: val executable = Machm.generate lambda
157: val _ = debug("done (" ^ makestring(size executable) ^ ").\n");
158: in
159: if !ErrorMsg.anyErrors then raise Codegen else executable
160: end
161:
162: fun spaces n =
163: let
164: fun spaces'(0, sp) = debug sp
165: | spaces'(n, sp) = spaces'(n-1, " " ^ sp)
166: in
167: spaces'(n, "")
168: end
169:
170: fun printCodeDynModule indent (CODEDYNMODULE{self, subModules}) =
171: (spaces indent;
172: debug("CodeDynModule, self=[..." ^ makestring(size self) ^ "...]\n");
173: spaces indent;
174: debug "sub-modules=(\n";
175: app (printCodeDynModule(indent+3)) subModules;
176: spaces indent;
177: debug ")\n"
178: )
179:
180: val printNums = app (fn i: int => debug(makestring i ^ " "))
181:
182: fun printLambEntry{entry=LAMBDAentry lexpFn, lvars} =
183: (debug "*LAMBDA*\n";
184: MCprint.printLexp(lexpFn(record nil));
185: debug ";\n lvars=[ ";
186: printNums lvars;
187: debug "].\n"
188: )
189: | printLambEntry{entry=IMPORTentry dyn, lvars} =
190: (debug "*IMPORT*\n";
191: printCodeDynModule 6 dyn;
192: debug " lvars=[ ";
193: printNums lvars;
194: debug "].\n"
195: )
196:
197: exception CompileDynModule
198: fun compileDynModule opt (LAMBDYNMODULE entries): CodeDynModule =
199: let
200: val _ =
201: if DEBUG then (debug "compileDynModule:\n";
202: app printLambEntry entries
203: )
204: else ()
205:
206: val looker = inventLvar "looker"
207:
208: val {lambda=openLambda, imports, importLvars} =
209: foldLambda(rev entries, looker, nil)
210: (* reverse "entries" because a LambDynModule has the most
211: recent declaration at the front, and we want to nest the
212: lambda with the old stuff outermost - as well as get the
213: correct ordering of the lvars in the final result. *)
214:
215: val _ = if !ErrorMsg.anyErrors then raise CompileDynModule else ()
216: (* Just check for any errors during last part of transDec. *)
217:
218: val closedLambda =
219: Opt.bareCloseTop{lambda=openLambda,
220: looker=looker,
221: extras=ProcessFile.getCore(),
222: keepFree=looker :: importLvars
223: }
224: (* Close the lambda, using the already-generated looker lvar -
225: this had to be generated in advance, since each imported
226: module is activated as M(looker). We DON'T want to close
227: with respect to the modLvars, since we're just about to
228: lambda-bind these. Keep the looker's lvar free as well,
229: otherwise it tries to find itself... Gnnnh! *)
230:
231: val finalLambda =
232: fn_N("imports", importLvars, closedLambda)
233: (* That's what we want: "fn (M1, ..., Mn) => fn looker => ..."
234: where the Mi's we apply to are each a "fn looker => ...".
235: In fact, I suspect that "imports" and "importLvars" are
236: both in reverse order, but as long as they're
237: coherent... *)
238:
239: val _ =
240: if DEBUG then (debug "Final (unopt) lambda:\n";
241: MCprint.printLexp finalLambda;
242: debug ".\n"
243: )
244: else ()
245:
246: val optLambda = opt finalLambda
247:
248: val code =
249: codegen optLambda
250: handle Codegen => raise CompileDynModule
251: in
252: CODEDYNMODULE{self=code, subModules=imports}
253: end
254:
255: (* primeDynModule: returns a "fn lookup => ...result...". If the module
256: doesn't import anything, then we just apply the code to NIL. If the
257: module imports M1...Mn, then we prime these, and build an array of
258: them. *)
259:
260: type object = System.Unsafe.object
261: type looker = lvar -> object
262: type result = object array
263: type module = looker -> result
264:
265: fun primeDynModule(CODEDYNMODULE{self, subModules}): module =
266: let
267: val me: module array -> looker -> result =
268: System.Unsafe.boot self
269:
270: val subModules: module array =
271: arrayoflist(map primeDynModule subModules)
272: in
273: me subModules
274: end
275:
276: fun debugLooker looker =
277: fn lvar: int => (debug("[looker(" ^ makestring lvar ^ ")]\n");
278: looker lvar
279: )
280:
281: fun executeDynModule codeDynModule looker: object array =
282: let
283: val _ = debug "priming... "
284: val primed = primeDynModule codeDynModule
285: val _ = debug "executing... "
286: val result = primed(if DEBUG then debugLooker looker else looker)
287: in
288: debug "done\n";
289: result
290: end
291: end
292: end;
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.