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/FLINT/opt/lift.sml
ViewVC logotype

Annotation of /sml/trunk/src/compiler/FLINT/opt/lift.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 220 - (view) (download)

1 : monnier 197 (* COPYRIGHT (c) 1997, 1998 YALE FLINT PROJECT *)
2 :     (* lift.sml *)
3 :    
4 :     signature LIFT =
5 :     sig
6 :    
7 :     val typeLift: FLINT.prog -> FLINT.prog
8 :     val wellFormed: FLINT.prog -> bool
9 :     end
10 :    
11 :    
12 :    
13 :     structure Lift:LIFT =
14 :     struct
15 :    
16 :     local structure LE = LtyExtern
17 :     structure DI = DebIndex
18 :     structure PT = PrimTyc
19 :     (* structure DA = Access *)
20 :     structure LB = LtyBasic
21 :     structure LD = LtyDef
22 : monnier 220 structure CTRL = FLINT_Control
23 : monnier 197 open LtyKernel
24 :     open FLINT
25 :     open Access
26 :     in
27 :    
28 :    
29 :     (***** Utility functions *****)
30 :    
31 :    
32 :     exception PartialTypeApp
33 :     exception VarNotFound
34 :     exception LiftTypeUnknown
35 :     exception DonotLift
36 :     exception FTABLE
37 :     exception LiftCompileError
38 :     exception VENV
39 :     exception FENV
40 :     exception abstract
41 :    
42 :     fun bug s = ErrorMsg.impossible ("Lift: " ^ s)
43 :    
44 :    
45 :     val mkv = LambdaVar.mkLvar
46 :    
47 :     val wellfixed = ref true
48 :     val welltapped = ref true
49 :     val tappLifted = ref 0
50 :    
51 :     type depth = int
52 :     type tdepth = int
53 :     type num = int
54 :     type abstract = bool
55 :    
56 :     type var = (lty * lvar list * depth * tdepth * abstract * num)
57 :     type venv = var Intmap.intmap
58 :    
59 :     type freevar = (lvar * lty)
60 :     type fenv = (freevar Intmap.intmap) list
61 :    
62 :    
63 :    
64 :     datatype Ltype = Tfn | Tapp
65 :     type header = (Ltype * lvar * lexp) list
66 :    
67 :     datatype env = Ienv of venv * fenv
68 :    
69 :     (* Utility functions *)
70 :    
71 :     val ABS = true
72 :     val NOABS = false
73 :     val fkfct = {isrec=NONE, known=false, inline=IH_SAFE, cconv=CC_FCT}
74 :    
75 :     fun adjust(t, ntd, otd) = LE.lt_adj(t, otd, ntd)
76 :    
77 :     fun findEnv(v, Ienv(venv,fenvs)) =
78 :     (Intmap.map venv v) handle _ => (print (Int.toString v); bug "findEnv: var not found" )
79 :    
80 :     fun getVar (v, Ienv(venv,fenv :: fenvs), t, td, td') =
81 :     ((let
82 :     val (v', nt') = (Intmap.map fenv v)
83 :     in (v', nt', nil)
84 :     end) handle _ => let val v' = mkv()
85 :     val nt' = adjust(t, td, td')
86 :     val _ = Intmap.add fenv (v, (v', nt'))
87 :    
88 :     in (v', nt', [v])
89 :     end )
90 :     | getVar _ = bug "unexpected freevariableEnv in getVar"
91 :    
92 :     fun newVar(v, env, td) =
93 :     let
94 :     val (t, vs, td', d', abs, _) = findEnv(v,env)
95 :     val exp = if (abs andalso (d' > 0) andalso (td' < td)) then
96 :     let
97 :     val (v', t', fv) = getVar(v, env, t, td, td')
98 :     in
99 :     (v', t', fv)
100 :     end
101 :     else
102 :     (v, adjust(t, td, td'), nil)
103 :     in
104 :     exp
105 :     end
106 :    
107 :    
108 :     fun pushFenv (Ienv(venv,fenvs)) =
109 :     let val nt = Intmap.new(32,FTABLE)
110 :     in Ienv(venv, nt::fenvs)
111 :     end
112 :    
113 :     fun popFenv (Ienv(venv, fenv::fenvs)) = Ienv(venv,fenvs)
114 :     | popFenv _ = raise LiftCompileError
115 :    
116 :     fun addEnv (Ienv(venv,fenvs), vs, ts, fvs, td, d, abs) =
117 :     let
118 :     fun f (v, t) = Intmap.add venv (v, (t, fvs, td, d, abs, 0))
119 :     fun zip([], [], acc) = acc
120 :     | zip (a::r, a'::r', acc) = zip (r, r', (a, a')::acc)
121 :     | zip _ = raise LiftCompileError
122 :     in
123 :     map f (zip (vs, ts, nil))
124 :     end
125 :    
126 :     fun rmEnv(Ienv(venv,fenvs), v) = Intmap.rmv venv v
127 :    
128 :    
129 :     fun getFreeVar(fvs, Ienv(venv, fenv::fenvs)) =
130 :     let
131 :     fun f(v) = (Intmap.map fenv v) handle _ => bug "freevar not found"
132 :     in
133 :     map f fvs
134 :     end
135 :     | getFreeVar _ = bug "unexpected freevariableEnv in getFreeVar"
136 :    
137 :    
138 :     fun writeLambda([], exp) = exp
139 :     | writeLambda(fvs, exp) =
140 :     let fun g(fvs', exp') =
141 :     let val newvar = mkv()
142 :     val fund = {isrec = NONE, cconv = CC_FUN(FF_VAR(true,true)), known = false,
143 :     inline = IH_SAFE }
144 :     in FIX([(fund, newvar, fvs', exp')], RET [VAR newvar])
145 :     end
146 :     in
147 :     if ( (List.length fvs) <= 9) then
148 :     g(fvs, exp)
149 :     else
150 :     let
151 :     fun f(x,e) = ([x], e)
152 :     in
153 :     foldr (g o f) exp fvs
154 :     end
155 :     end
156 :    
157 :    
158 :     fun writeApp(v, vs) =
159 :     if ( (List.length vs) <= 9 ) then
160 :     APP(v, vs)
161 :     else
162 :     let fun f([], e) = let val newvar = mkv()
163 :     in (RET [VAR newvar], newvar)
164 :     end
165 :     | f(v::vs, e) = let val (e', v') = f(vs, e)
166 :     val newvar = mkv()
167 :     in (LET([v'], APP(VAR newvar,[v]), e'), newvar)
168 :     end
169 :     val (e',v') = f(List.tl vs, RET [])
170 :     in
171 :     LET([v'], APP(v, [List.hd vs]), e')
172 :     end
173 :    
174 :    
175 :     fun writeHeader(hd, exp) =
176 :     let
177 :     fun f ((Tapp, v, e), e') = LET([v], e, e')
178 :     | f ((Tfn, v, TFN(e, e')), e'') = TFN(e,e'')
179 :     | f _ = bug "unexpected header in writeHeader"
180 :     val hds = foldr f exp hd
181 :     in
182 :     hds
183 :     end
184 :    
185 :    
186 :     (* The way renaming is done is that if rename is true and d > 0
187 :     and td < td' then change var *)
188 :    
189 :     fun initInfoEnv () =
190 :     let val venv : venv = Intmap.new(32, VENV)
191 :     val fenv = Intmap.new(32, FENV)
192 :     in
193 :     Ienv (venv, [fenv])
194 :     end
195 :    
196 :    
197 :     fun wellFormed (fdec : fundec) =
198 :     case fdec of
199 :     (fk as {cconv = CC_FCT, ...}, v, vts, e) =>
200 :     let
201 :     fun formed (RET _, d) = true
202 :     | formed (LET(vs, e1, e2), d) = formed(e1, d) andalso formed(e2, d)
203 :     | formed (APP(v, vs), d) = true
204 :     | formed (TAPP(v, ts), d) = (case d of 0 => true
205 :     | _ => false )
206 :     | formed (RECORD(rk, vs, v, e), d) = formed(e, d)
207 :     | formed (SELECT(v, i, l, e), d) = formed(e, d)
208 :     | formed (RAISE _, d) = true
209 :     | formed (HANDLE(e, v), d) = formed(e, d)
210 :     | formed (BRANCH(pr, vs, e1, e2), d) = formed(e1, d) andalso formed(e2, d)
211 :     | formed (PRIMOP(pr, vs, l, e), d) = formed(e, d)
212 :     | formed (SWITCH(v, a, ces, eopt), d) =
213 :     let val b1 = case eopt of NONE => true
214 :     | SOME e => formed(e, d)
215 :     fun f(c,e) = (e,d)
216 :     val es = map f ces
217 :     val b2 = map formed es
218 :     val b = foldr (fn (x,y) => x andalso y) b1 b2
219 :     in
220 :     b
221 :     end
222 :     | formed (CON(dc, ts, v, l, e), d) = formed(e, d)
223 : monnier 220 | formed (TFN((tfk, l, ts, e1), e2), d) =
224 :     formed(e1, d) andalso formed(e2, d)
225 : monnier 197 | formed (FIX(fds, e), d) =
226 :     let
227 :     val b1 = formed(e, d)
228 :     val b2 = case fds of
229 :     ({cconv = CC_FCT, ...}, l, vs, e')::r => map formed [(e', d)]
230 :     | _ => let fun f (v1, v2, v3, v4) = (v4, d + 1)
231 :     val es = map f fds
232 :     val b' = map formed es
233 :     in
234 :     b'
235 :     end
236 :     val b = foldr (fn (x,y) => x andalso y) b1 b2
237 :     in
238 :     b
239 :     end
240 :     in
241 :     formed(e, 0)
242 :     end
243 :     | _ => bug "non FCT program in Lift"
244 :    
245 :    
246 :     fun lift (e, env, td, d, ad, rename) =
247 :     let
248 :     fun comb((v,t,fv,hd), (l1,l2,l3,l4)) = (v::l1, t::l2, fv@l3,hd@l4)
249 :    
250 :     fun ltInst(lt, ts) =
251 :     ( case LE.lt_inst(lt, ts) of
252 :     [x] => x
253 :     | _ => bug "unexpected case in ltInst" )
254 :    
255 :     fun arglty(lt, ts) =
256 :     let
257 :     val (_, atys, _) = LE.ltd_arrow(ltInst(lt, ts))
258 :     in
259 :     case atys of
260 :     [x] => x
261 :     | _ => bug "unexpected case in arglty"
262 :     end
263 :    
264 :     fun reslty(lt, ts) =
265 :     let
266 :     val (_, _, rtys) = LE.ltd_arrow(ltInst(lt, ts))
267 :     in
268 :     case rtys of
269 :     [x] => x
270 :     | _ => bug "unexpected case in reslty"
271 :     end
272 :    
273 :     fun loopc env (VAR v) =
274 :     let
275 :     val (v', t, fv) = newVar(v, env, td) (* Not checking for poly *)
276 :    
277 :     in
278 :     (VAR v', t, fv, nil) (* Check whether this is t or t' *)
279 :     end
280 :     | loopc env v =
281 :     let
282 :     val t =
283 :     case v of
284 :     INT _ => LE.ltc_int
285 :     | WORD _ => LE.ltc_int
286 :     | (INT32 _ | WORD32 _) => LE.ltc_int32
287 :     | REAL _ => LE.ltc_real
288 :     | STRING _ => LE.ltc_string
289 :     in
290 :     (v, t, nil, nil)
291 :     end
292 :    
293 :     fun lpacc env (LVAR v) =
294 :     let val (VAR v', _, fv, _) = loopc env (VAR v)
295 :     in (LVAR v', fv)
296 :     end
297 :     | lpacc env (PATH(a,i)) =
298 :     let val (a', fvs) = lpacc env a
299 :     in (PATH(a',i), fvs)
300 :     end
301 :     | lpacc env a = (a, nil)
302 :    
303 :     fun lpcon env (EXN a) =
304 :     let val (a', fv) = lpacc env a
305 :     in (EXN(a'), fv)
306 :     end
307 :     | lpcon env (SUSP NONE) = (SUSP(NONE), nil)
308 :     | lpcon env (SUSP (SOME (a', a''))) =
309 :     let
310 :     val (a1, fv1) = lpacc env a'
311 :     val (a2, fv2) = lpacc env a''
312 :     in
313 :     (SUSP(SOME (a', a'')), fv1 @ fv2)
314 :     end
315 :     | lpcon env a = (a, nil)
316 :    
317 :     fun loope(RET vs, env, d, ad) =
318 :     let
319 :     val vls = map (loopc env) vs
320 :     val (vs, ts, fvs, hd) = foldr comb (nil, nil, nil, nil) vls
321 :     in
322 :     (RET vs, ts, fvs, hd)
323 :     end
324 :     | loope (LET(vs, e1, e2), env, d, ad) =
325 :     let
326 :     val (e', ts, fvs, hd) = loope(e1, env, d, ad)
327 :     val _ = addEnv(env, vs, ts, fvs, td, d, ABS)
328 :     val (e'', ts', fvs', hd') = loope(e2, env, d, ad)
329 :     in
330 :     (LET(vs, e', e''), ts', fvs@fvs', hd@hd')
331 :     end
332 :     | loope (APP(v1,vs), env, d, ad) =
333 :     let
334 :     val (v1', t, fvs, hd) = loopc env v1
335 :     val vls = map (loopc env) vs
336 :     val (vs', ts', fvs', hd') = foldr comb (nil, nil, nil, nil) vls
337 :     val nt = #2(LE.ltd_fkfun t)
338 :     in
339 :     (APP(v1', vs'), nt, fvs@fvs', hd@hd')
340 :     end
341 :     | loope (e as TAPP(v,tycs), env as Ienv(venv,fenvs), d, ad) =
342 :     let
343 :     val (v', nt', fv', hd) = loopc env v (* fv' and hd are nil *)
344 :     val nt = LE.lt_inst (nt', tycs)
345 :     val len1 = List.length tycs
346 :     in
347 :     case d of
348 :     0 => (e, nt, fv', hd)
349 :     | _ => case v of
350 :     VAR v'' =>
351 :     let
352 :     val (t', fvs', len2, vd, _, _) =
353 :     (Intmap.map venv v'') handle _ =>
354 :     bug "Tapp var not found"
355 :     in
356 :     if ((len1 = len2) orelse (vd = 0))then
357 :     let
358 :     val newvar = mkv()
359 :     val hd' = (Tapp, newvar, TAPP(v,tycs))
360 :     fun f(x) = loopc env (VAR x)
361 :     val (exp, fvs) = case fvs' of
362 :     [] => (RET([VAR newvar]), nil)
363 :     | _ => let val fvs'' = map f fvs'
364 :     val (r1, r2, r3, r4) = foldr comb (nil,nil,nil,nil) fvs''
365 :     in
366 :     (writeApp(VAR newvar, r1), r3)
367 :     end
368 :     in
369 :     ( tappLifted := !tappLifted + 1;
370 :     (exp, nt, fv'@fvs, [hd']) )
371 :     end
372 :     else
373 :     ( welltapped := false;
374 :     tappLifted := 0;
375 :     raise PartialTypeApp )
376 :     end
377 :     | _ => (e, nt, fv', hd)
378 :     end
379 : monnier 220 | loope (e as TFN((tfk,v,tvs,e1),e2), env as Ienv(venv,fenvs), d, ad) =
380 : monnier 197 (case d of
381 :     0 =>
382 :     let
383 :     val (e1', nt', fv', hd') = lift(e1, env, DI.next td, d, ad, true)
384 :     val ks = map (fn (t,k) => k) tvs
385 :     val nt = LE.ltc_poly(ks, nt')
386 :    
387 :     (* Hack for Tapp.Stores the number of tvs instead of td *)
388 :    
389 :     val _ = addEnv(env, [v], [nt], fv', (List.length tvs), d, NOABS)
390 :    
391 :     val (e2', nt'', fv'', hd'') = loope(e2, env, d, ad)
392 :     in
393 : monnier 220 (TFN((tfk,v,tvs,e1'),e2'), nt'', fv'@fv'', hd'@hd'')
394 : monnier 197 end
395 :     | _ =>
396 :     let
397 :     val env' = pushFenv(env)
398 :     val (e1', nt', fvs, hd) = lift(e1, env', DI.next td, d, DI.next ad, true)
399 :     val freevars = getFreeVar(fvs, env')
400 :     val ks = map (fn (t,k) => k) tvs
401 :     val nt = LE.ltc_poly(ks, nt')
402 :    
403 :     (* Hack for Tapp. Stores the number of tvs *)
404 :    
405 :     val _ = addEnv(env, [v], [nt], fvs, (List.length tvs), d, NOABS)
406 :    
407 :     val(e2', nt'', fvs', hd') = loope(e2, env, d, ad)
408 :     val exp = writeLambda(freevars, e1')
409 :     val exp' = writeHeader(hd, exp)
410 : monnier 220 val hd = (Tfn, v, TFN((tfk,v,tvs,exp'),RET [])) :: hd'
411 : monnier 197 in
412 :     (e2', nt'', fvs', hd)
413 :     end )
414 :     | loope(SWITCH(v, a, cels, eopt), env, d, ad) =
415 :     let
416 :     val (v', nt, fv, hd) = loopc env v
417 :     fun f(c,e) =
418 :     let
419 :     val _ =
420 :     case c of
421 :     DATAcon((_, _, lt), ts, v) =>
422 :     addEnv(env, [v], [arglty(lt,ts)], nil, td, d, ABS)
423 :     | _ => [()]
424 :     val (e', nt', fvs, hds) = loope(e, env, d, ad)
425 :     in
426 :     ((c,e'), nt', fvs, hds)
427 :     end
428 :     val ls = map f cels
429 :     val (cels', nt', fvs', hds') = foldr comb (nil,nil,nil,nil) ls
430 :     val (exp, t, f, h) =
431 :     case eopt of
432 :     NONE => (SWITCH(v',a,cels',eopt), List.hd nt', fv@fvs', hd@hds')
433 :     | SOME(eopt') =>
434 :     let
435 :     val (eopt'', nt'', fvs'', hd'') = loope(eopt', env, d, ad)
436 :     in
437 :     (SWITCH(v',a,cels',SOME(eopt'')), List.hd nt', fv@fvs'@fvs'', hd@hds'@hd'')
438 :     end
439 :    
440 :     in
441 :     (exp, t, f, h)
442 :     end
443 :     | loope (CON(dcons,tcs,vl,v,e), env, d, ad) =
444 :     let
445 :     val (s, cr, lt) = dcons
446 :     val (cr', fv) = lpcon env cr
447 :     val nt = reslty(lt, tcs)
448 :    
449 :     val (vl', nt', fvs', hd') = loopc env vl
450 :    
451 :     val _ = addEnv(env, [v], [nt], nil, td, d, true)
452 :     val (e'', nt'', fvs'', hd'') = loope(e, env, d, ad)
453 :     in
454 :     (CON((s, cr', lt),tcs,vl',v,e''), nt'', fv@fvs'@fvs'', hd'@hd'')
455 :     end
456 :     | loope (RECORD(rk,vls,v,e), env, d, ad) =
457 :     let
458 :     val ls = map (loopc env) vls
459 :     val (vls', nt', fvs', hd') = foldr comb (nil,nil,nil,nil) ls
460 :     val nt = LE.ltc_rkind(rk, nt')
461 :    
462 :     val _ = addEnv(env, [v], [nt], fvs', td, d, true)
463 :     val (e', nt'', fvs'', hd'') = loope(e, env, d, ad)
464 :     in
465 :     (RECORD(rk, vls', v, e'), nt'', fvs'@fvs'', hd'@hd'')
466 :     end
467 :     | loope (SELECT(v,i,l,e), env, d, ad) =
468 :     let val (v', nt', fvs', hd') = loopc env v
469 :     val nt = LE.ltd_rkind(nt', i)
470 :     val _ = addEnv(env, [l], [nt], fvs', td, d, true)
471 :     val (e', nt'', fvs'', hd'') = loope(e, env, d, ad)
472 :     in
473 :     (SELECT(v',i,l,e'), nt'', fvs'@fvs'', hd'@hd'')
474 :     end
475 :     | loope (RAISE(v,ls), env, d, ad) =
476 :     let val (v', nt', fvs', hd') = loopc env v
477 :     in (RAISE(v',ls), ls, fvs', hd')
478 :     end
479 :     | loope (HANDLE(e,v), env, d, ad) =
480 :     let val (v', nt', fvs', hd') = loopc env v
481 :     val (e', nt'', fvs'', hd'') = loope(e, env, d, ad)
482 :     in
483 :     (HANDLE(e',v'), nt'', fvs'@fvs'', hd'@hd'')
484 :     end
485 :     | loope (BRANCH(pr,vl,e1,e2), env, d, ad) =
486 :     let val ls = map (loopc env) vl
487 :     val (vls', nt', fvs', hd') = foldr comb (nil,nil,nil,nil) ls
488 :     val (e1', nt'', fvs'', hd'') = loope(e1, env, d, ad)
489 :     val (e2', nt''', fvs''', hd''') = loope(e2, env, d, ad)
490 :     in
491 :     (BRANCH(pr,vls',e1',e2'), nt''', fvs'@fvs''@fvs''', hd'@hd''@hd''')
492 :     end
493 :     | loope (PRIMOP(pr,vl,l,e), env, d, ad) =
494 :     let
495 :     val ls = map (loopc env) vl
496 :     val (vls', nt', fvs', hd') = foldr comb (nil,nil,nil,nil) ls
497 :     val (_, _, lt, ts) = pr
498 :     val nt = reslty(lt, ts)
499 :    
500 :     val _ = addEnv(env, [l], [nt], fvs', td, d, ABS)
501 :     val (e', nt'', fvs'', hd'') = loope(e, env, d, ad)
502 :     in
503 :     (PRIMOP(pr,vls',l,e'), nt'', fvs'@fvs'', hd'@hd'')
504 :     end
505 :     | loope(e as FIX([({cconv = CC_FCT, ...}, v, lvs, e1)],e2), env, d, ad) =
506 :     let
507 :     val vs = map #1 lvs
508 :     val ts = map #2 lvs
509 :     val _ = if d > 0 then
510 :     wellfixed := false
511 :     else
512 :     ()
513 :     val _ = addEnv(env, vs, ts, nil, td, 0, NOABS)
514 :     val (e', nt', fvs', hd') = loope(e1, env, 0, DI.next ad)
515 :     val nt = LE.ltc_fkfun(fkfct, ts, nt')
516 :     val _ = addEnv(env, [v], [nt], fvs', td, 0, NOABS)
517 :     val (e'', nt'', fvs'', hd'') = loope(e2, env, d, ad)
518 :     in
519 :     (FIX([(fkfct, v, lvs, e')], e''), nt'', fvs'@fvs'', hd'@hd'')
520 :     end
521 :     | loope(e as FIX([(fk, v, lvs, e1)], e2), env, d, ad) =
522 :     (case fk of
523 :     {isrec = NONE, cconv = CC_FUN _, ...} =>
524 :     let
525 :     val vs = map #1 lvs
526 :     val ts = map #2 lvs
527 :     val _ = addEnv(env, vs, ts, nil, td, DI.next d, ABS)
528 :     val (e', nt', fvs', hd') = loope(e1, env, DI.next d, DI.next ad)
529 :     val nt = LE.ltc_fkfun(fk, ts, nt')
530 :     val abs = if d > 0 then true else false
531 :     val _ = addEnv(env, [v], [nt], fvs', td, d, ABS)
532 :     val (e'', nt'', fvs'', hd'') = loope(e2, env, d, ad)
533 :     val ne' = FIX([(fk,v,lvs,e')], e'')
534 :     val (ne,hd) = case d of
535 :     0 => (writeHeader(hd'@hd'', ne'), nil)
536 :     | _ => (ne', hd'@hd'')
537 :     in (ne, nt'', fvs'@fvs'', hd)
538 :     end
539 :     | {isrec = SOME(rts,_), cconv = CC_FUN _, ...} =>
540 :     let
541 :     val vs = map (#1) lvs
542 :     val ts = map (#2) lvs
543 :     val _ = addEnv(env, [v], [LE.ltc_fkfun(fk, ts, rts)], nil,
544 :     td, DI.next d, ABS)
545 :     val _ = addEnv(env, vs, ts, nil, td, DI.next d, ABS)
546 :     val (e', nt', fvs', hd') = loope(e1, env, DI.next d, DI.next ad)
547 :    
548 :     (* Check to see that the new value is inserted *)
549 :    
550 :     val _ = addEnv(env, [v], [LE.ltc_fkfun(fk, ts, rts)], nil,
551 :     td, d, ABS)
552 :     (* The depth is changed for correct behaviour *)
553 :    
554 :     val (e'', nt'', fvs'', hd'') = loope(e2, env, d, ad)
555 :     val ne' = FIX([(fk,v,lvs,e')], e'')
556 :     val (ne,hd) = case d of
557 :     0 => (writeHeader(hd'@hd'', ne'), nil)
558 :     | _ => (ne', hd'@hd'')
559 :     in (ne, nt'', fvs'@fvs'', hd)
560 :     end
561 :     | _ => bug "unexpected fundec in main loop" )
562 :     | loope(e as FIX(fds, e2), env, d, ad) =
563 :     let
564 :     fun h d' ((fk as {isrec = SOME(rts,_), ...}, f, lvs, e1):fundec) =
565 :     addEnv(env, [f], [LE.ltc_fkfun(fk, map #2 lvs, rts)], nil, td, d', ABS)
566 :     | h d fk = bug "unexpected non-recursive fkind in loop"
567 :     fun g((fk, f, lvs, e):fundec) =
568 :     let
569 :     val _ = addEnv(env, map #1 lvs, map #2 lvs, nil, td, DI.next d, ABS)
570 :     val (e', nt', fvs', hd') = loope(e, env, DI.next d, DI.next ad)
571 :     in
572 :     ( (fk, f, lvs, e'), [LE.ltc_fkfun(fk, map #2 lvs, nt')], fvs', hd')
573 :     end
574 :     val _ = map (h (DI.next d)) fds
575 :     val rets = map g fds
576 :     val (fds, nts, fvs, hds) = foldr comb (nil,nil,nil,nil) rets
577 :    
578 :     (* Check to see that the correct value is inserted *)
579 :    
580 :     val _ = map (h d) fds
581 :     val (e'', nt'', fvs'', hd'') = loope(e2, env, d, ad)
582 :     val ne' = FIX(fds, e'')
583 :     in
584 :     case d of
585 :     0 => (writeHeader(hds@hd'', ne'), nt'', fvs@fvs'', nil)
586 :     | _ => (ne', nt'', fvs@fvs'', hds@hd'')
587 :     end
588 :    
589 :     in loope(e, env, d, ad)
590 :     end
591 :    
592 :    
593 :     fun typeLift fdec:fundec =
594 :     (* if !Control.CG.lifttype then *)
595 :     case fdec of
596 :     (fk as {cconv = CC_FCT, ...}, v, vts, e) =>
597 :     let
598 :     val env = initInfoEnv()
599 :     val d = 0 (* DI.top ?? *)
600 :     val td = 0 (* DI.top ?? *)
601 :     val ad = 0 (* DI.top ?? *)
602 :     val rename = false
603 :     val vs = map #1 vts
604 :     val ts = map #2 vts
605 :     val _ = addEnv(env, vs, ts, nil, td, d, NOABS)
606 :     val (ne, _, _, _) = ( lift(e, env, td, d, ad, rename) )
607 :     handle PartialTypeApp =>
608 :     ( print "\n*** No Typelifting ";
609 :     print " Partial Type App ***\n";
610 :     (e, nil, nil, nil) )
611 :     val _ = if !wellfixed then
612 :     ()
613 :     else
614 :     () (* print "\n *** Functor at d > 0 *** \n" *)
615 :     val _ = if !CTRL.saytappinfo then
616 :     (print "\n *** No. of Tapps lifted ";
617 :     print (" " ^ (Int.toString (!tappLifted)) ^ " \n") )
618 :     else
619 :     ()
620 :     in
621 :     ( tappLifted := 0;
622 :     wellfixed := true;
623 :     welltapped := true;
624 :     (fk, v, vts, ne) )
625 :     end
626 :     | _ => bug "non FCT program in Lift"
627 :     (* else fdec *)
628 :    
629 :     end
630 :     end
631 :    

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