Home My Page Projects Code Snippets Project Openings SML/NJ
Summary Activity Forums Tracker Lists Tasks Docs Surveys News SCM Files

SCM Repository

[smlnj] Annotation of /sml/trunk/compiler/TopLevel/main/compile.sml
ViewVC logotype

Annotation of /sml/trunk/compiler/TopLevel/main/compile.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 167 - (view) (download)
Original Path: sml/branches/SMLNJ/src/compiler/TopLevel/main/compile.sml

1 : monnier 16 (* COPYRIGHT (c) 1996 Bell Laboratories *)
2 :     (* compile.sml *)
3 :    
4 :     local
5 :     exception Compile of string
6 :     in
7 :    
8 :     functor CompileF(structure M : CODEGENERATOR
9 :     structure CC : CCONFIG) : COMPILE0 =
10 :     struct
11 :    
12 :     local structure FE = FrontEnd
13 :     structure PS = PersStamps
14 :     structure EM = ErrorMsg
15 :     structure SE = StaticEnv
16 : monnier 100 structure DE = DynamicEnv
17 : monnier 16 structure A = Absyn
18 :     structure DA = Access
19 :     structure CB = CompBasic
20 :     structure ST = Stats
21 :     structure CI = Unsafe.CInterface
22 : monnier 100 structure W8V = Word8Vector
23 :     structure V = Vector
24 : monnier 16 in
25 :    
26 :     val debugging = Control.CG.compdebugging
27 :     val say = Control.Print.say
28 :     fun bug s = EM.impossible ("Compile:" ^ s)
29 :     fun debugmsg msg =
30 :     if !debugging then (say msg; say "\n"; Control.Print.flush()) else ()
31 :    
32 :     exception Compile = Compile (* raised during compilation only *)
33 :     exception SilentException = CC.SilentException (* raised by CM *)
34 :     exception TopLevelException of exn (* raised during executation only *)
35 :     exception TopLevelCallcc (* raised during executation only *)
36 :     val architecture = M.architecture (* machine architecture *)
37 :    
38 :     (** important intermediate formats used during the compilations *)
39 :     type source = CB.source (* the input file *)
40 :     type ast = CB.ast (* concrete syntax *)
41 :     type absyn = CB.absyn (* abstract syntax *)
42 :     type flint = CB.flint (* intermediate code *)
43 :     type csegments = CB.csegments (* binary code segments *)
44 :     type executable = CB.executable (* machine executables *)
45 :     type object = CB.object (* runtime object *)
46 :    
47 :     (** environments and contexts used during the compilation *)
48 :     type statenv = SE.staticEnv (* static env : symbol -> binding *)
49 : monnier 100 type dynenv = DE.dynenv (* dynamic env : pid -> object *)
50 : monnier 16 type symenv = SymbolicEnv.symenv (* symbolic env : pid -> flint *)
51 :    
52 :     type compInfo = CB.compInfo (* general compilation utilities *)
53 :     fun mkCompInfo (s, se, tr) = CB.mkCompInfo (s, se, tr, CC.mkMkStamp)
54 :     val anyErrors = CB.anyErrors
55 :    
56 : monnier 93 type cmstatenv = CC.cmstatenv (* compressed static environment *)
57 :     val toCM = CC.toCM
58 :     val fromCM = CC.fromCM
59 : monnier 16
60 :     type lvar = DA.lvar (* local id *)
61 :     type pid = PS.persstamp (* persistant id *)
62 : monnier 100 type import = pid * CB.importTree (* import specification *)
63 : monnier 16 type pickle = CC.pickle (* pickled format *)
64 :     type hash = CC.hash (* environment hash id *)
65 :    
66 :     fun fail s = raise (Compile s)
67 :    
68 :     (*****************************************************************************
69 :     * PARSING *
70 :     *****************************************************************************)
71 :    
72 :     (** take the input source and turn it into the concrete syntax *)
73 : monnier 69 val parsePhase = ST.makePhase "Compiler 010 parse"
74 : monnier 16 fun parseOne (source : source) =
75 :     let val parser = FE.parse source
76 :     val parser = ST.doPhase parsePhase parser (* for correct timing *)
77 :     in fn () =>
78 :     case parser ()
79 :     of FE.EOF => NONE
80 :     | FE.ABORT => fail "syntax error"
81 :     | FE.ERROR => fail "syntax error"
82 :     | FE.PARSE ast => SOME ast
83 :     end
84 :    
85 :     fun parse (source : source) =
86 :     let val parser = FE.parse source
87 :     val parser = ST.doPhase parsePhase parser (* for correct timing *)
88 :     fun loop asts =
89 :     case parser()
90 :     of FE.EOF => Ast.SeqDec(rev asts)
91 :     | FE.ABORT => fail "syntax error"
92 :     | FE.ERROR => fail "syntax error"
93 :     | FE.PARSE ast => loop(ast::asts)
94 :     in loop nil
95 :     end
96 :    
97 :    
98 :     (*****************************************************************************
99 :     * ELABORATION *
100 :     *****************************************************************************)
101 :    
102 :     (** several preprocessing phases done after parsing or after elaborations *)
103 : monnier 106 (*
104 : monnier 45 val fixityparse = (* ST.doPhase (ST.makePhase "Compiler 005 fixityparse") *)
105 :     FixityParse.fixityparse
106 :     val lazycomp = (* ST.doPhase (ST.makePhase "Compiler 006 lazycomp") *)
107 :     LazyComp.lazycomp
108 : monnier 106 *)
109 : monnier 16 val pickUnpick =
110 : monnier 69 ST.doPhase (ST.makePhase "Compiler 036 pickunpick") CC.pickUnpick
111 : monnier 16
112 :     (** take ast, do semantic checks, and output the new env, absyn and pickles *)
113 :     fun elaborate {ast=ast, statenv=senv, compInfo=cinfo} =
114 :     let (** the following should go away soon; it needs clean up **)
115 : monnier 93 val bsenv = fromCM senv
116 : monnier 106 (* lazycomp folded into elaborate phase
117 :     val ast = fixityparse {ast=ast,env=bsenv,error=#error cinfo}
118 :     val ast = lazycomp ast
119 :     *)
120 : monnier 16 val (absyn, nenv) = ElabTop.elabTop(ast, bsenv, cinfo)
121 :     val (absyn, nenv) =
122 :     if anyErrors (cinfo) then (A.SEQdec nil, SE.empty) else (absyn, nenv)
123 :     val {hash,pickle,exportLvars,exportPid,newenv} = pickUnpick(senv,nenv)
124 : monnier 93 in {absyn=absyn, newstatenv=toCM newenv, exportPid=exportPid,
125 : monnier 16 exportLvars=exportLvars, staticPid = hash, pickle=pickle}
126 :     end (* function elaborate *)
127 :    
128 : monnier 69 val elaborate = ST.doPhase(ST.makePhase "Compiler 030 elaborate") elaborate
129 : monnier 16
130 :     (*****************************************************************************
131 :     * ABSYN INSTRUMENTATION *
132 :     *****************************************************************************)
133 :    
134 :     (** instrumenting the abstract syntax to do time- and space-profiling *)
135 :     fun instrument {source, compInfo as {coreEnv,...}: compInfo} =
136 :     SProf.instrumDec (coreEnv, compInfo) source
137 :     o TProf.instrumDec (coreEnv, compInfo)
138 :    
139 : monnier 69 val instrument = ST.doPhase (ST.makePhase "Compiler 039 instrument") instrument
140 : monnier 16
141 :    
142 :     (*****************************************************************************
143 :     * TRANSLATION INTO FLINT *
144 :     *****************************************************************************)
145 :    
146 :     (** take the abstract syntax tree, generate the flint intermediate code *)
147 :     fun translate{absyn, exportLvars, newstatenv, oldstatenv, compInfo} =
148 :     (*** statenv used for printing Absyn in messages ***)
149 : monnier 93 let val statenv = SE.atop (fromCM newstatenv, fromCM oldstatenv)
150 : monnier 16 val {flint, imports} =
151 :     Translate.transDec(absyn, exportLvars, statenv, compInfo)
152 :     in {flint=flint, imports=imports}
153 :     end
154 :    
155 : monnier 69 val translate = ST.doPhase (ST.makePhase "Compiler 040 translate") translate
156 : monnier 16
157 :    
158 :     (*****************************************************************************
159 :     * CODE GENERATION *
160 :     *****************************************************************************)
161 :    
162 :     (** take the flint code and generate the machine binary code *)
163 :     local
164 : monnier 113 val inline = LSplitInline.inline
165 :     (* fun inline (flint, imports, symenv) = flint *)
166 : monnier 16 (*
167 : monnier 100 let val importExps = map (SymbolicEnv.look symenv) (map #1 imports)
168 : monnier 16 in (* optimize flint based on the knowledge of importExps *)
169 :     bug "inline not implemented yet"
170 :     end
171 :     *)
172 :    
173 :     fun split (flint, enable) =
174 :     if false (* enable *) then (case NONE (* FLINTSplit.split flint *)
175 :     of NONE => (flint, NONE)
176 :     | SOME x => x)
177 :     else (flint, NONE)
178 :    
179 :    
180 : monnier 100 val w8vLen = W8V.length
181 :     fun csegsize {c0, cn, data, name} =
182 :     foldl (fn (x, y) => (w8vLen x) + y) (w8vLen c0 + w8vLen data) cn
183 :    
184 : monnier 16 val addCode = ST.addStat (ST.makeStat "Code Size")
185 :     in
186 : monnier 113 fun codegen { flint: flint, imports: import list, symenv: symenv,
187 :     splitting: bool, compInfo: compInfo } = let
188 :     (* hooks for cross-module inlining and specialization *)
189 :     val (flint, revisedImports) = inline (flint, imports, symenv)
190 :     val (flint, inlineExp : flint option) = split(flint, splitting)
191 :    
192 :     (* from optimized FLINT code, generate the machine code *)
193 :     val csegs = M.flintcomp(flint, compInfo)
194 :     in
195 :     addCode(csegsize csegs);
196 :     { csegments=csegs, inlineExp=inlineExp, imports = revisedImports }
197 :     end
198 : monnier 16 end (* local codegen *)
199 :    
200 : monnier 69 (*
201 : monnier 16 val codegen = ST.doPhase (ST.makePhase "Compiler 140 CodeGen") codegen
202 : monnier 69 *)
203 : monnier 16
204 :     (*****************************************************************************
205 :     * COMPILATION *
206 :     * = ELABORATION + TRANSLATION TO FLINT + CODE GENERATION *
207 :     * used by interact/evalloop.sml, batch/batchutil.sml, batch/cmsa.sml only *
208 :     *****************************************************************************)
209 :     (** compiling the ast into the binary code = elab + translate + codegen *)
210 :     fun compile {source=source, ast=ast, statenv=oldstatenv, symenv=symenv,
211 :     compInfo=cinfo, checkErr=check, runtimePid=runtimePid,
212 :     splitting=splitting} =
213 :     let val {absyn, newstatenv, exportLvars, exportPid, staticPid, pickle} =
214 :     (elaborate {ast=ast, statenv=oldstatenv, compInfo=cinfo})
215 :     before (check "elaborate")
216 :    
217 :     val absyn =
218 :     (instrument {source=source, compInfo=cinfo} absyn)
219 :     before (check "instrument")
220 :    
221 :     val {flint, imports} =
222 :     (translate {absyn=absyn, exportLvars=exportLvars,
223 :     newstatenv=newstatenv, oldstatenv=oldstatenv,
224 :     compInfo=cinfo})
225 :     before check "translate"
226 :    
227 :     (** the following is a special hook for the case of linking the
228 : monnier 93 runtime vector when compiling PervEnv/core.sml. (ZHONG)
229 : monnier 16 *)
230 :     val imports =
231 :     (case (runtimePid, imports)
232 :     of (NONE, _) => imports
233 : monnier 100 | (SOME p, [(_,tr)]) => [(p, tr)]
234 : monnier 16 | _ => raise Compile "core compilation failed")
235 :    
236 : monnier 113 val { csegments, inlineExp, imports = revisedImports } =
237 :     codegen { flint = flint, imports = imports, symenv = symenv,
238 :     splitting = splitting, compInfo = cinfo }
239 :     before (check "codegen")
240 : monnier 16 (*
241 :     * interp mode was currently turned off.
242 :     *
243 :     * if !Control.interp then Interp.interp flint
244 :     * else codegen {flint=flint, splitting=splitting, compInfo=cinfo})
245 :     *)
246 :    
247 : monnier 113 in
248 :     { csegments = csegments,
249 :     newstatenv = newstatenv,
250 :     absyn = absyn,
251 :     exportPid = exportPid,
252 :     exportLvars = exportLvars,
253 :     staticPid = staticPid,
254 :     pickle = pickle,
255 :     inlineExp = inlineExp,
256 :     imports = revisedImports }
257 : monnier 16 end (* function compile *)
258 :    
259 :     (*****************************************************************************
260 :     * OTHER UTILITY FUNCTIONS *
261 :     *****************************************************************************)
262 :    
263 :     (** build the new symbolic environment *)
264 :     fun mksymenv (NONE, _) = SymbolicEnv.empty
265 :     | mksymenv (_, NONE) = SymbolicEnv.empty
266 :     | mksymenv (SOME pid, SOME l) = SymbolicEnv.singleton (pid, l)
267 :    
268 :     (** turn the byte-vector-like code segments into an executable closure *)
269 :     local
270 : monnier 100 type w8v = W8V.vector
271 :     val vzero = V.fromList []
272 : monnier 16 val mkCodeV : w8v * string option -> (w8v * executable) =
273 :     CI.c_function "SMLNJ-RunT" "mkCode"
274 :     val mkCodeO : w8v * string option -> (w8v * (object -> object)) =
275 :     CI.c_function "SMLNJ-RunT" "mkCode"
276 :     in
277 : monnier 100 fun mkexec {c0: w8v, cn: w8v list, data : w8v, name: string option ref} =
278 : monnier 16 let val s = case !name of NONE => "EMPTY COMMENT <-- check"
279 :     | SOME s => s
280 : monnier 100 val nex =
281 :     let val (_, dt) = mkCodeV(data, NONE)
282 :     val (_, ex) = mkCodeV(c0, SOME s)
283 :     in fn ivec => ex (V.concat [ivec, V.fromList [dt vzero]])
284 :     end
285 :     in foldl (fn (c, r) => (#2 (mkCodeO (c,NONE))) o r) nex cn
286 : monnier 16 end
287 :     end (* local *)
288 :    
289 :     (** just like f x, except that it catches top-level callcc's *)
290 :     local
291 :     val cont_stack = ref (nil : unit ref list)
292 :     in
293 :     fun isolate f x = (* Just like *)
294 :     let val r = ref()
295 :     val _ = cont_stack := r :: !cont_stack;
296 :     fun pop_stack() =
297 :     case !cont_stack
298 :     of r' :: rest => (cont_stack := rest;
299 :     if r<>r' then raise TopLevelCallcc else ())
300 :     | _ => raise TopLevelCallcc (* can this ever happen? *)
301 :     val a = f x
302 :     handle e => (pop_stack();
303 :     raise (case e of TopLevelException x => x | e => e))
304 :     in pop_stack (); a
305 :     end
306 :     end (* local of cont_stack *)
307 :    
308 :     (*****************************************************************************
309 :     * EXECUTING THE EXECUTABLE *
310 :     *****************************************************************************)
311 :    
312 :     (** perform the execution of the excutable, output the new dynenv *)
313 :     fun execute{executable, imports, exportPid, dynenv} =
314 : monnier 100 let val args : object V.vector =
315 :     let fun selObj (obj, i) =
316 :     ((V.sub (Unsafe.Object.toTuple obj, i)) handle _ =>
317 :     bug "unexpected linkage interface in execute")
318 :    
319 :     fun getObj ((p, n), zs) =
320 :     let fun get (obj, CB.ITNODE [], z) = obj::z
321 :     | get (obj, CB.ITNODE xl, z) =
322 :     let fun g ((i, n), x) = get (selObj(obj, i), n, x)
323 :     in foldr g z xl
324 :     end
325 :     val obj =
326 :     ((DE.look dynenv p) handle DE.Unbound =>
327 :     (say ("lookup " ^ (PS.toHex p) ^ "\n");
328 :     fail "imported objects not found or inconsistent"))
329 :     in get(obj, n, zs)
330 :     end
331 :    
332 :     in Vector.fromList (foldr getObj [] imports)
333 :     end
334 :     val result : object = executable args
335 : monnier 16 in case exportPid
336 : monnier 100 of NONE => DE.empty
337 :     | SOME p => DE.singleton (p, result)
338 : monnier 16 end
339 :    
340 :     val execute = ST.doPhase (ST.makePhase "Execute") execute
341 :    
342 :     end (* local of CompileF *)
343 :     end (* functor CompileF *)
344 :    
345 :     end (* local of exception Compile *)
346 :    
347 : monnier 93
348 :     (*
349 : monnier 167 * $Log: compile.sml,v $
350 :     * Revision 1.5 1998/06/02 17:39:29 george
351 :     * Changes to integrate CM functionality into the compiler --- blume
352 :     *
353 : monnier 93 *)

root@smlnj-gforge.cs.uchicago.edu
ViewVC Help
Powered by ViewVC 1.0.0