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

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

Parent Directory Parent Directory | Revision Log Revision Log


Revision 675 - (view) (download)

1 : monnier 16 (* COPYRIGHT (c) 1996 Bell Laboratories *)
2 :     (* compile.sml *)
3 :    
4 :     functor CompileF(structure M : CODEGENERATOR
5 :     structure CC : CCONFIG) : COMPILE0 =
6 :     struct
7 :    
8 :     local structure FE = FrontEnd
9 :     structure PS = PersStamps
10 :     structure EM = ErrorMsg
11 :     structure SE = StaticEnv
12 : monnier 100 structure DE = DynamicEnv
13 : monnier 16 structure A = Absyn
14 :     structure DA = Access
15 :     structure CB = CompBasic
16 :     structure ST = Stats
17 : monnier 251 structure Obj = Unsafe.Object
18 : monnier 100 structure W8V = Word8Vector
19 : monnier 16 in
20 :    
21 : monnier 220 val say = Control_Print.say
22 : monnier 16 fun bug s = EM.impossible ("Compile:" ^ s)
23 :    
24 : monnier 422 exception Compile = SmlFile.Compile (* raised during compilation only *)
25 : monnier 16 exception SilentException = CC.SilentException (* raised by CM *)
26 :     exception TopLevelException of exn (* raised during executation only *)
27 :     exception TopLevelCallcc (* raised during executation only *)
28 :     val architecture = M.architecture (* machine architecture *)
29 :    
30 :     (** important intermediate formats used during the compilations *)
31 :     type source = CB.source (* the input file *)
32 :     type ast = CB.ast (* concrete syntax *)
33 :     type absyn = CB.absyn (* abstract syntax *)
34 :     type flint = CB.flint (* intermediate code *)
35 :     type csegments = CB.csegments (* binary code segments *)
36 :     type executable = CB.executable (* machine executables *)
37 :     type object = CB.object (* runtime object *)
38 :    
39 :     (** environments and contexts used during the compilation *)
40 :     type statenv = SE.staticEnv (* static env : symbol -> binding *)
41 : monnier 100 type dynenv = DE.dynenv (* dynamic env : pid -> object *)
42 : monnier 16 type symenv = SymbolicEnv.symenv (* symbolic env : pid -> flint *)
43 :    
44 :     type compInfo = CB.compInfo (* general compilation utilities *)
45 : blume 592 fun mkCompInfo (s, tr) = CB.mkCompInfo (s, tr, CC.mkMkStamp)
46 : monnier 16 val anyErrors = CB.anyErrors
47 :    
48 :     type lvar = DA.lvar (* local id *)
49 :     type pid = PS.persstamp (* persistant id *)
50 : monnier 100 type import = pid * CB.importTree (* import specification *)
51 : monnier 16 type pickle = CC.pickle (* pickled format *)
52 :     type hash = CC.hash (* environment hash id *)
53 :    
54 :     fun fail s = raise (Compile s)
55 :    
56 :     (*****************************************************************************
57 :     * PARSING *
58 :     *****************************************************************************)
59 :    
60 : monnier 422 val parseOne = SmlFile.parseOne
61 :     val parse = SmlFile.parse
62 : monnier 16
63 :     (*****************************************************************************
64 :     * ELABORATION *
65 :     *****************************************************************************)
66 :    
67 :     (** several preprocessing phases done after parsing or after elaborations *)
68 : monnier 106 (*
69 : monnier 45 val fixityparse = (* ST.doPhase (ST.makePhase "Compiler 005 fixityparse") *)
70 :     FixityParse.fixityparse
71 :     val lazycomp = (* ST.doPhase (ST.makePhase "Compiler 006 lazycomp") *)
72 :     LazyComp.lazycomp
73 : monnier 106 *)
74 : monnier 16 val pickUnpick =
75 : monnier 69 ST.doPhase (ST.makePhase "Compiler 036 pickunpick") CC.pickUnpick
76 : monnier 16
77 :     (** take ast, do semantic checks, and output the new env, absyn and pickles *)
78 : blume 587 fun elaborate {ast=ast, statenv=senv, compInfo=cinfo} = let
79 :    
80 :     val (absyn, nenv) = ElabTop.elabTop(ast, senv, cinfo)
81 : monnier 16 val (absyn, nenv) =
82 :     if anyErrors (cinfo) then (A.SEQdec nil, SE.empty) else (absyn, nenv)
83 : blume 587 val { hash, pickle, exportLvars, exportPid, newenv } =
84 :     pickUnpick { context = senv, env = nenv }
85 :     in {absyn=absyn, newstatenv=newenv, exportPid=exportPid,
86 :     exportLvars=exportLvars, staticPid = hash, pickle=pickle }
87 :     end (* function elaborate *)
88 : monnier 16
89 : monnier 69 val elaborate = ST.doPhase(ST.makePhase "Compiler 030 elaborate") elaborate
90 : monnier 16
91 :     (*****************************************************************************
92 :     * ABSYN INSTRUMENTATION *
93 :     *****************************************************************************)
94 :    
95 :     (** instrumenting the abstract syntax to do time- and space-profiling *)
96 : blume 592 fun instrument {source, senv, compInfo} =
97 :     SProf.instrumDec (senv, compInfo) source
98 :     o TProf.instrumDec (senv, compInfo)
99 : blume 675 o BTrace.instrument (senv, compInfo)
100 : monnier 16
101 : monnier 69 val instrument = ST.doPhase (ST.makePhase "Compiler 039 instrument") instrument
102 : monnier 16
103 :    
104 :     (*****************************************************************************
105 :     * TRANSLATION INTO FLINT *
106 :     *****************************************************************************)
107 :    
108 :     (** take the abstract syntax tree, generate the flint intermediate code *)
109 :     fun translate{absyn, exportLvars, newstatenv, oldstatenv, compInfo} =
110 :     (*** statenv used for printing Absyn in messages ***)
111 : blume 587 let val statenv = SE.atop (newstatenv, oldstatenv)
112 : monnier 16 val {flint, imports} =
113 :     Translate.transDec(absyn, exportLvars, statenv, compInfo)
114 :     in {flint=flint, imports=imports}
115 :     end
116 :    
117 : monnier 69 val translate = ST.doPhase (ST.makePhase "Compiler 040 translate") translate
118 : monnier 16
119 :    
120 :     (*****************************************************************************
121 :     * CODE GENERATION *
122 :     *****************************************************************************)
123 :    
124 :     (** take the flint code and generate the machine binary code *)
125 :     local
126 : monnier 113 val inline = LSplitInline.inline
127 :     (* fun inline (flint, imports, symenv) = flint *)
128 : monnier 16 (*
129 : monnier 100 let val importExps = map (SymbolicEnv.look symenv) (map #1 imports)
130 : monnier 16 in (* optimize flint based on the knowledge of importExps *)
131 :     bug "inline not implemented yet"
132 :     end
133 :     *)
134 :    
135 :     fun split (flint, enable) =
136 :     if false (* enable *) then (case NONE (* FLINTSplit.split flint *)
137 :     of NONE => (flint, NONE)
138 :     | SOME x => x)
139 :     else (flint, NONE)
140 :    
141 :    
142 :     val addCode = ST.addStat (ST.makeStat "Code Size")
143 :     in
144 : monnier 113 fun codegen { flint: flint, imports: import list, symenv: symenv,
145 :     splitting: bool, compInfo: compInfo } = let
146 :     (* hooks for cross-module inlining and specialization *)
147 :     val (flint, revisedImports) = inline (flint, imports, symenv)
148 : monnier 220 (* val (flint, inlineExp : flint option) = split(flint, splitting) *)
149 : monnier 113
150 :     (* from optimized FLINT code, generate the machine code *)
151 : monnier 220 val (csegs,inlineExp) = M.flintcomp(flint, compInfo)
152 : monnier 251 val codeSz =
153 :     List.foldl
154 :     (fn (co, n) => n + CodeObj.size co)
155 :     (CodeObj.size(#c0 csegs) + W8V.length(#data csegs))
156 :     (#cn csegs)
157 : monnier 113 in
158 : monnier 251 addCode codeSz;
159 : monnier 113 { csegments=csegs, inlineExp=inlineExp, imports = revisedImports }
160 :     end
161 : monnier 16 end (* local codegen *)
162 :    
163 : monnier 69 (*
164 : monnier 16 val codegen = ST.doPhase (ST.makePhase "Compiler 140 CodeGen") codegen
165 : monnier 69 *)
166 : monnier 16
167 :     (*****************************************************************************
168 :     * COMPILATION *
169 :     * = ELABORATION + TRANSLATION TO FLINT + CODE GENERATION *
170 :     * used by interact/evalloop.sml, batch/batchutil.sml, batch/cmsa.sml only *
171 :     *****************************************************************************)
172 :     (** compiling the ast into the binary code = elab + translate + codegen *)
173 : blume 587 fun compile {source=source, ast=ast, statenv, symenv=symenv,
174 :     compInfo=cinfo, checkErr=check, splitting=splitting} =
175 :     let val {absyn, newstatenv, exportLvars, exportPid, staticPid, pickle } =
176 :     elaborate {ast=ast, statenv=statenv, compInfo=cinfo }
177 :     before (check "elaborate")
178 : monnier 16
179 : blume 592 val absyn = instrument {source=source, senv = statenv,
180 :     compInfo=cinfo} absyn
181 : blume 587 before (check "instrument")
182 : monnier 16
183 : blume 587 val {flint, imports} =
184 :     translate {absyn=absyn, exportLvars=exportLvars,
185 :     newstatenv=newstatenv, oldstatenv=statenv,
186 :     compInfo=cinfo}
187 :     before check "translate"
188 : monnier 16
189 : blume 587 val { csegments, inlineExp, imports = revisedImports } =
190 :     codegen { flint = flint, imports = imports, symenv = symenv,
191 :     splitting = splitting, compInfo = cinfo }
192 :     before (check "codegen")
193 :     (*
194 :     * interp mode was currently turned off.
195 :     *
196 :     * if !Control.interp then Interp.interp flint
197 :     * else codegen {flint=flint, splitting=splitting, compInfo=cinfo})
198 :     *)
199 :     in
200 :     { csegments = csegments,
201 :     newstatenv = newstatenv,
202 :     absyn = absyn,
203 :     exportPid = exportPid,
204 :     exportLvars = exportLvars,
205 :     staticPid = staticPid,
206 :     pickle = pickle,
207 :     inlineExp = inlineExp,
208 :     imports = revisedImports }
209 :     end (* function compile *)
210 : monnier 16
211 :     (*****************************************************************************
212 :     * OTHER UTILITY FUNCTIONS *
213 :     *****************************************************************************)
214 :    
215 :     (** build the new symbolic environment *)
216 :     fun mksymenv (NONE, _) = SymbolicEnv.empty
217 :     | mksymenv (_, NONE) = SymbolicEnv.empty
218 :     | mksymenv (SOME pid, SOME l) = SymbolicEnv.singleton (pid, l)
219 :    
220 :     (** turn the byte-vector-like code segments into an executable closure *)
221 : monnier 251 fun mkexec (cs : CodeObj.csegments) = let
222 :     val ex = CodeObj.exec (#c0 cs)
223 :     val nex = if (W8V.length(#data cs) > 0)
224 :     then (fn ivec =>
225 :     ex (Obj.mkTuple(Obj.toTuple ivec @ [CodeObj.mkLiterals(#data cs)])))
226 :     else (fn ivec => ex ivec)
227 :     in
228 :     foldl (fn (c, r) => (CodeObj.exec c) o r) nex (#cn cs)
229 :     end
230 : monnier 16
231 :     (** just like f x, except that it catches top-level callcc's *)
232 :     local
233 :     val cont_stack = ref (nil : unit ref list)
234 :     in
235 :     fun isolate f x = (* Just like *)
236 :     let val r = ref()
237 :     val _ = cont_stack := r :: !cont_stack;
238 :     fun pop_stack() =
239 :     case !cont_stack
240 :     of r' :: rest => (cont_stack := rest;
241 :     if r<>r' then raise TopLevelCallcc else ())
242 :     | _ => raise TopLevelCallcc (* can this ever happen? *)
243 :     val a = f x
244 :     handle e => (pop_stack();
245 :     raise (case e of TopLevelException x => x | e => e))
246 :     in pop_stack (); a
247 :     end
248 :     end (* local of cont_stack *)
249 :    
250 :     (*****************************************************************************
251 :     * EXECUTING THE EXECUTABLE *
252 :     *****************************************************************************)
253 :    
254 :     (** perform the execution of the excutable, output the new dynenv *)
255 : monnier 251 fun execute {executable, imports, exportPid, dynenv} = let
256 :     val args : object = let
257 :     fun selObj (obj, i) = (Obj.nth(obj, i)
258 :     handle _ => bug "unexpected linkage interface in execute")
259 : monnier 100 fun getObj ((p, n), zs) =
260 :     let fun get (obj, CB.ITNODE [], z) = obj::z
261 :     | get (obj, CB.ITNODE xl, z) =
262 :     let fun g ((i, n), x) = get (selObj(obj, i), n, x)
263 :     in foldr g z xl
264 :     end
265 :     val obj =
266 :     ((DE.look dynenv p) handle DE.Unbound =>
267 :     (say ("lookup " ^ (PS.toHex p) ^ "\n");
268 :     fail "imported objects not found or inconsistent"))
269 :     in get(obj, n, zs)
270 :     end
271 : monnier 251 in
272 :     Obj.mkTuple (foldr getObj [] imports)
273 :     end
274 : monnier 100 val result : object = executable args
275 : monnier 16 in case exportPid
276 : monnier 100 of NONE => DE.empty
277 :     | SOME p => DE.singleton (p, result)
278 : monnier 16 end
279 :    
280 :     val execute = ST.doPhase (ST.makePhase "Execute") execute
281 :    
282 :     end (* local of CompileF *)
283 :     end (* functor CompileF *)
284 :    

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