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/branches/SMLNJ/src/compiler/TopLevel/main/compile.sml
ViewVC logotype

Annotation of /sml/branches/SMLNJ/src/compiler/TopLevel/main/compile.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 69 - (view) (download)

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

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