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/interact/compile.sml
ViewVC logotype

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

Parent Directory Parent Directory | Revision Log Revision Log


Revision 21 - (view) (download)

1 : monnier 21 (* COPYRIGHT (c) 1996 Bell Laboratories *)
2 :     (* compile.sml *)
3 :    
4 :     local
5 :     exception Compile of string
6 :     in
7 :    
8 :     functor CompileF(structure Machm : CODEGENERATOR
9 :     exception SilentException
10 :     structure SCS : sig type staticEnv
11 :     val SC : StaticEnv.staticEnv->staticEnv
12 :     val unSC : staticEnv->StaticEnv.staticEnv
13 :     end
14 :     structure Pickles :
15 :     sig type pickle
16 :     type hash
17 :     val pickUnpick : SCS.staticEnv * StaticEnv.staticEnv ->
18 :     {hash: hash, pickle: pickle,
19 :     exportLvars: Lambda.lvar list,
20 :     exportPid: PersStamps.persstamp option,
21 :     newenv: StaticEnv.staticEnv}
22 :     end
23 :     val mkMkStamp : unit -> unit -> Stamps.stamp
24 :     ) : COMPILE0 =
25 :     struct
26 :    
27 :     local structure P = FrontEnd
28 :     structure EM = ErrorMsg
29 :     structure SE = StaticEnv
30 :     structure EU = ElabUtil
31 :     structure LV = LambdaVar
32 :     in
33 :    
34 :     type lvar = LV.lvar
35 :     type absyn = Absyn.dec
36 :     type lambda = Lambda.lexp
37 :     type pid = PersStamps.persstamp
38 :     type obj = Unsafe.Object.object
39 :     type csegments = { c0: Word8Vector.vector, cn: Word8Vector.vector list , name : string option ref}
40 :     type compInfo = EU.compInfo
41 :    
42 :     structure SCS= SCS
43 :     type pickle = Pickles.pickle
44 :     type hash = Pickles.hash
45 :    
46 :     val debugging = ref false
47 :     fun bug s = ErrorMsg.impossible ("Compile:" ^ s)
48 :     val say = Control.Print.say
49 :    
50 :     fun debugmsg msg =
51 :     if !debugging then (say msg; say "\n"; Control.Print.flush()) else ()
52 :    
53 :     val architecture = Machm.architecture
54 :    
55 :     exception Compile = Compile
56 :    
57 :     fun fail s = raise (Compile s)
58 :    
59 :     val parsePhase = Stats.makePhase "Compiler 010 Parse"
60 :    
61 :     fun parse source =
62 :     let val parser = P.parse source
63 :     val _ = (CheckLty.fname_ref := #fileOpened(source))
64 :    
65 :     fun loop asts =
66 :     case parser()
67 :     of P.EOF => Ast.SeqDec(rev asts)
68 :     | P.ABORT => fail "syntax error"
69 :     | P.ERROR => fail "syntax error"
70 :     | P.PARSE ast => loop(ast::asts)
71 :    
72 :     in loop nil
73 :     end
74 :    
75 :     val parse = Stats.doPhase parsePhase parse
76 :    
77 :     fun parseOne (source: Source.inputSource) =
78 :     let val parser = P.parse source
79 :     val parser = Stats.doPhase parsePhase parser (* for correct timing *)
80 :     in fn () =>
81 :     case parser ()
82 :     of P.EOF => NONE
83 :     | P.ABORT => fail "syntax error"
84 :     | P.ERROR => fail "syntax error"
85 :     | P.PARSE ast => SOME ast
86 :     end
87 :    
88 :     fun showPid pid = (say(PersStamps.toHex pid); say "\n")
89 :    
90 :     fun mkCompInfo(source: Source.inputSource,
91 :     coreEnv: StaticEnv.staticEnv,
92 :     transform : Absyn.dec -> Absyn.dec) : ElabUtil.compInfo =
93 :     let val {error,errorMatch,anyErrors} = ErrorMsg.errors source
94 :     val _ = LV.clear()
95 :     in {mkStamp = mkMkStamp(),
96 :     mkLvar = (fn NONE => LV.mkLvar ()
97 :     | SOME sym => LV.namedLvar sym),
98 :     error = error,
99 :     errorMatch = errorMatch,
100 :     anyErrors = anyErrors,
101 :     coreEnv = coreEnv,
102 :     transform = transform,
103 :     sourceName = #fileOpened source}
104 :     end
105 :    
106 :     fun anyErrors({anyErrors=ref b,...}:compInfo) = b
107 :    
108 :     val pickUnpick =
109 :     Stats.doPhase(Stats.makePhase "Compiler 036 pickUnpick") Pickles.pickUnpick
110 :    
111 :     val fixityparse =
112 :     Stats.doPhase(Stats.makePhase "Compiler ?#? fixityparse")
113 :     FixityParse.fixityparse
114 :    
115 :     (* ZIDO: PWLE: Also added "val lazycomp". *)
116 :    
117 :     val lazycomp =
118 :     Stats.doPhase(Stats.makePhase "Compiler ?#? lazycomp") LazyComp.lazycomp
119 :    
120 :     (* ZIDO: PWLE: Also added "val lazycomp". *)
121 :    
122 :     fun elaborate {ast, compenv, compInfo as {anyErrors,...}: EU.compInfo} =
123 :     let val compenv' = SCS.unSC compenv
124 :     val (absyn,newenv) = ElabTop.elabTop(ast,compenv',compInfo)
125 :     val _ = debugmsg "--elaborate: elabTop done!"
126 :     val (absyn,newenv) =
127 :     if !anyErrors then (Absyn.SEQdec nil, StaticEnv.empty)
128 :     else (absyn, newenv)
129 :    
130 :     val _ = debugmsg "--elaborate: calling pickleEnv"
131 :    
132 :     val {hash,pickle,exportLvars,exportPid,newenv} = pickUnpick(compenv,newenv)
133 :     (* val _ = debugmsg ("--elaborate: Pickled: |pickle| = "
134 :     ^Int.toString(Word8Vector.length pickle)) *)
135 :    
136 :     in (* app showPid exportPids; *)
137 :     {absyn=absyn, newenv=SCS.SC newenv,
138 :     exportPid=exportPid, exportLvars=exportLvars,
139 :     staticPid = hash, pickle=pickle}
140 :     end
141 :    
142 :     val elaborate =
143 :     Stats.doPhase(Stats.makePhase "Compiler 030 Elaborate") elaborate
144 :    
145 :     fun makePid (context, se) =
146 :     let val bare = CoerceEnv.es2bs
147 :     in #hash (PickMod.pickleEnv (context, bare se))
148 :     end
149 :    
150 :     fun instrument{source,compenv, compInfo as {coreEnv,...}: EU.compInfo} =
151 :     SProf.instrumDec (coreEnv, compInfo) source
152 :     o TProf.instrumDec (coreEnv, compInfo)
153 :    
154 :     fun translate{absyn,exportLvars,exportPid : pid option,
155 :     newstatenv,oldstatenv,compInfo} =
156 :     (*** statenv used for printing Absyn in messages ***)
157 :     let val statenv = StaticEnv.atop (SCS.unSC newstatenv, SCS.unSC oldstatenv)
158 :     val {genLambda,importPids} =
159 :     Translate.transDec(absyn,exportLvars,statenv,compInfo)
160 :     in {genLambda=genLambda, imports=importPids}
161 :     end
162 :    
163 :     val translate =
164 :     Stats.doPhase (Stats.makePhase "Compiler 040 Translate") translate
165 :    
166 :     fun symDelta (NONE, _) = SymbolicEnv.empty
167 :     | symDelta (_, NONE) = SymbolicEnv.empty
168 :     | symDelta (SOME pid, SOME l) = SymbolicEnv.singleton (pid, l)
169 :    
170 :     fun inline { genLambda, imports, symenv } =
171 :     genLambda (map (SymbolicEnv.look symenv) imports)
172 :    
173 :     (*
174 :     * This is the real splitter, but we are not going to use it just yet (BLUME)
175 :     *
176 :     * fun split {enable = false, lambda} =
177 :     * {lambda_e = lambda, lambda_i = NONE}
178 :     * | split {enable = true, lambda} =
179 :     * case LambdaSplit.split lambda
180 :     * of NONE => {lambda_e = lambda, lambda_i = NONE}
181 :     * | SOME {inline, expan} =>
182 :     * {lambda_e = expan, lambda_i = SOME inline}
183 :     *
184 :     *)
185 :    
186 :     (* `conservative' splitting (i.e., none) *)
187 :     fun split { lambda, enable } =
188 :     let val (lambda_e, lambda_i) =
189 :     (* act as if it were always disabled *)
190 :     (lambda, NONE)
191 :     in { lambda_e = lambda_e, lambda_i = lambda_i }
192 :     end
193 :    
194 :     (* FIX: should just pass the compInfo parameter of Machm.codegen *)
195 :     fun codegen{lambda,
196 :     compInfo={error,anyErrors,errorMatch,sourceName,...}: EU.compInfo} =
197 :     let val v = Machm.codegen({error=error,anyErrors=anyErrors,errorMatch=errorMatch},
198 :     FLINTComp.flintcomp lambda)
199 :     in
200 :     (#name v) := SOME(sourceName); v
201 :     end
202 :    
203 :     val codegen = Stats.doPhase (Stats.makePhase "Compiler 140 CodeGen") codegen
204 :    
205 :     fun csegsize { c0, cn , name} =
206 :     foldl (fn (x, y) => (Word8Vector.length x) + y) (Word8Vector.length c0) cn
207 :    
208 :     val addCode = Stats.addStat (Stats.makeStat "Code Size")
209 :    
210 :     val codegen = fn x =>
211 :     let val c = codegen x
212 :     in addCode(csegsize c); c
213 :     end
214 :    
215 :     type ovec = obj vector
216 :    
217 :     val mkCodeV : Word8Vector.vector * string option -> (Word8Vector.vector * (ovec -> obj)) =
218 :     Unsafe.CInterface.c_function "SMLNJ-RunT" "mkCode"
219 :     val mkCodeO : Word8Vector.vector * string option -> (Word8Vector.vector * (obj -> obj)) =
220 :     Unsafe.CInterface.c_function "SMLNJ-RunT" "mkCode"
221 :    
222 :     fun applyCode { c0, cn , name} =
223 :     let val s = case (!name) of NONE => "EMPTY COMMENT <-- check"
224 :     | SOME(str) => str
225 :     in
226 :     foldl (fn (c, r) => (#2 (mkCodeO (c,NONE))) o r) (#2 (mkCodeV (c0,SOME(s)))) cn
227 :     end
228 :    
229 :     fun execute{executable,imports,exportPid,dynenv} =
230 :     let val result =
231 :     executable (Vector.fromList (map (DynamicEnv.look dynenv) imports)
232 :     handle DynamicEnv.Unbound =>
233 :     (app (fn p => (print "lookup ";
234 :     print(PersStamps.toHex p);
235 :     print "\n")) imports;
236 :     fail "imported objects not found or inconsistent"))
237 :     in case exportPid
238 :     of NONE => DynamicEnv.empty
239 :     | SOME p => DynamicEnv.singleton (p, result)
240 :     end
241 :    
242 :     val execute = Stats.doPhase (Stats.makePhase "Execute") execute
243 :    
244 :     exception TopLevelCallcc
245 :     exception TopLevelException of exn
246 :     exception SilentException = SilentException (* raised by CM *)
247 :    
248 :     local val cont_stack = ref (nil : unit ref list)
249 :     in
250 :     fun isolate f x = (* Just like f x, except that it catches
251 :     top-level callcc's *)
252 :     let val r = ref()
253 :     val _ = cont_stack := r :: !cont_stack;
254 :     fun pop_stack() =
255 :     case !cont_stack
256 :     of r' :: rest => (cont_stack := rest;
257 :     if r<>r' then raise TopLevelCallcc else ())
258 :     | _ => raise TopLevelCallcc (* can this ever happen? *)
259 :     val a = f x
260 :     handle e => (pop_stack();
261 :     raise (case e of TopLevelException x => x | e => e))
262 :     in pop_stack (); a
263 :     end
264 :     end (* local of cont_stack *)
265 :    
266 :     end (* local of CompileF *)
267 :     end (* functor CompileF *)
268 :    
269 :     end (* local of exception Compile *)
270 :    

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