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

Parent Directory | Revision Log

---

Revision 197 - (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 :			structure CTRL = Control.FLINT
23 :			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 :			| formed (TFN((l, ts, e1), e2), d) = formed(e1, d) andalso formed(e2, d)
224 :			| formed (FIX(fds, e), d) =
225 :			let
226 :			val b1 = formed(e, d)
227 :			val b2 = case fds of
228 :			({cconv = CC_FCT, ...}, l, vs, e')::r => map formed [(e', d)]
229 :			| _ => let fun f (v1, v2, v3, v4) = (v4, d + 1)
230 :			val es = map f fds
231 :			val b' = map formed es
232 :			in
233 :			b'
234 :			end
235 :			val b = foldr (fn (x,y) => x andalso y) b1 b2
236 :			in
237 :			b
238 :			end
239 :			in
240 :			formed(e, 0)
241 :			end
242 :			| _ => bug "non FCT program in Lift"
243 :
244 :
245 :			fun lift (e, env, td, d, ad, rename) =
246 :			let
247 :			fun comb((v,t,fv,hd), (l1,l2,l3,l4)) = (v::l1, t::l2, fv@l3,hd@l4)
248 :
249 :			fun ltInst(lt, ts) =
250 :			( case LE.lt_inst(lt, ts) of
251 :			[x] => x
252 :			| _ => bug "unexpected case in ltInst" )
253 :
254 :			fun arglty(lt, ts) =
255 :			let
256 :			val (_, atys, _) = LE.ltd_arrow(ltInst(lt, ts))
257 :			in
258 :			case atys of
259 :			[x] => x
260 :			| _ => bug "unexpected case in arglty"
261 :			end
262 :
263 :			fun reslty(lt, ts) =
264 :			let
265 :			val (_, _, rtys) = LE.ltd_arrow(ltInst(lt, ts))
266 :			in
267 :			case rtys of
268 :			[x] => x
269 :			| _ => bug "unexpected case in reslty"
270 :			end
271 :
272 :			fun loopc env (VAR v) =
273 :			let
274 :			val (v', t, fv) = newVar(v, env, td) (* Not checking for poly *)
275 :
276 :			in
277 :			(VAR v', t, fv, nil) (* Check whether this is t or t' *)
278 :			end
279 :			| loopc env v =
280 :			let
281 :			val t =
282 :			case v of
283 :			INT _ => LE.ltc_int
284 :			| WORD _ => LE.ltc_int
285 :			| (INT32 _ | WORD32 _) => LE.ltc_int32
286 :			| REAL _ => LE.ltc_real
287 :			| STRING _ => LE.ltc_string
288 :			in
289 :			(v, t, nil, nil)
290 :			end
291 :
292 :			fun lpacc env (LVAR v) =
293 :			let val (VAR v', _, fv, _) = loopc env (VAR v)
294 :			in (LVAR v', fv)
295 :			end
296 :			| lpacc env (PATH(a,i)) =
297 :			let val (a', fvs) = lpacc env a
298 :			in (PATH(a',i), fvs)
299 :			end
300 :			| lpacc env a = (a, nil)
301 :
302 :			fun lpcon env (EXN a) =
303 :			let val (a', fv) = lpacc env a
304 :			in (EXN(a'), fv)
305 :			end
306 :			| lpcon env (SUSP NONE) = (SUSP(NONE), nil)
307 :			| lpcon env (SUSP (SOME (a', a''))) =
308 :			let
309 :			val (a1, fv1) = lpacc env a'
310 :			val (a2, fv2) = lpacc env a''
311 :			in
312 :			(SUSP(SOME (a', a'')), fv1 @ fv2)
313 :			end
314 :			| lpcon env a = (a, nil)
315 :
316 :			fun loope(RET vs, env, d, ad) =
317 :			let
318 :			val vls = map (loopc env) vs
319 :			val (vs, ts, fvs, hd) = foldr comb (nil, nil, nil, nil) vls
320 :			in
321 :			(RET vs, ts, fvs, hd)
322 :			end
323 :			| loope (LET(vs, e1, e2), env, d, ad) =
324 :			let
325 :			val (e', ts, fvs, hd) = loope(e1, env, d, ad)
326 :			val _ = addEnv(env, vs, ts, fvs, td, d, ABS)
327 :			val (e'', ts', fvs', hd') = loope(e2, env, d, ad)
328 :			in
329 :			(LET(vs, e', e''), ts', fvs@fvs', hd@hd')
330 :			end
331 :			| loope (APP(v1,vs), env, d, ad) =
332 :			let
333 :			val (v1', t, fvs, hd) = loopc env v1
334 :			val vls = map (loopc env) vs
335 :			val (vs', ts', fvs', hd') = foldr comb (nil, nil, nil, nil) vls
336 :			val nt = #2(LE.ltd_fkfun t)
337 :			in
338 :			(APP(v1', vs'), nt, fvs@fvs', hd@hd')
339 :			end
340 :			| loope (e as TAPP(v,tycs), env as Ienv(venv,fenvs), d, ad) =
341 :			let
342 :			val (v', nt', fv', hd) = loopc env v (* fv' and hd are nil *)
343 :			val nt = LE.lt_inst (nt', tycs)
344 :			val len1 = List.length tycs
345 :			in
346 :			case d of
347 :			0 => (e, nt, fv', hd)
348 :			| _ => case v of
349 :			VAR v'' =>
350 :			let
351 :			val (t', fvs', len2, vd, _, _) =
352 :			(Intmap.map venv v'') handle _ =>
353 :			bug "Tapp var not found"
354 :			in
355 :			if ((len1 = len2) orelse (vd = 0))then
356 :			let
357 :			val newvar = mkv()
358 :			val hd' = (Tapp, newvar, TAPP(v,tycs))
359 :			fun f(x) = loopc env (VAR x)
360 :			val (exp, fvs) = case fvs' of
361 :			[] => (RET([VAR newvar]), nil)
362 :			| _ => let val fvs'' = map f fvs'
363 :			val (r1, r2, r3, r4) = foldr comb (nil,nil,nil,nil) fvs''
364 :			in
365 :			(writeApp(VAR newvar, r1), r3)
366 :			end
367 :			in
368 :			( tappLifted := !tappLifted + 1;
369 :			(exp, nt, fv'@fvs, [hd']) )
370 :			end
371 :			else
372 :			( welltapped := false;
373 :			tappLifted := 0;
374 :			raise PartialTypeApp )
375 :			end
376 :			| _ => (e, nt, fv', hd)
377 :			end
378 :			| loope (e as TFN((v,tvs,e1),e2), env as Ienv(venv,fenvs), d, ad) =
379 :			(case d of
380 :			0 =>
381 :			let
382 :			val (e1', nt', fv', hd') = lift(e1, env, DI.next td, d, ad, true)
383 :			val ks = map (fn (t,k) => k) tvs
384 :			val nt = LE.ltc_poly(ks, nt')
385 :
386 :			(* Hack for Tapp.Stores the number of tvs instead of td *)
387 :
388 :			val _ = addEnv(env, [v], [nt], fv', (List.length tvs), d, NOABS)
389 :
390 :			val (e2', nt'', fv'', hd'') = loope(e2, env, d, ad)
391 :			in
392 :			(TFN((v,tvs,e1'),e2'), nt'', fv'@fv'', hd'@hd'')
393 :			end
394 :			| _ =>
395 :			let
396 :			val env' = pushFenv(env)
397 :			val (e1', nt', fvs, hd) = lift(e1, env', DI.next td, d, DI.next ad, true)
398 :			val freevars = getFreeVar(fvs, env')
399 :			val ks = map (fn (t,k) => k) tvs
400 :			val nt = LE.ltc_poly(ks, nt')
401 :
402 :			(* Hack for Tapp. Stores the number of tvs *)
403 :
404 :			val _ = addEnv(env, [v], [nt], fvs, (List.length tvs), d, NOABS)
405 :
406 :			val(e2', nt'', fvs', hd') = loope(e2, env, d, ad)
407 :			val exp = writeLambda(freevars, e1')
408 :			val exp' = writeHeader(hd, exp)
409 :			val hd = (Tfn, v, TFN((v,tvs,exp'),RET [])) :: hd'
410 :			in
411 :			(e2', nt'', fvs', hd)
412 :			end )
413 :			| loope(SWITCH(v, a, cels, eopt), env, d, ad) =
414 :			let
415 :			val (v', nt, fv, hd) = loopc env v
416 :			fun f(c,e) =
417 :			let
418 :			val _ =
419 :			case c of
420 :			DATAcon((_, _, lt), ts, v) =>
421 :			addEnv(env, [v], [arglty(lt,ts)], nil, td, d, ABS)
422 :			| _ => [()]
423 :			val (e', nt', fvs, hds) = loope(e, env, d, ad)
424 :			in
425 :			((c,e'), nt', fvs, hds)
426 :			end
427 :			val ls = map f cels
428 :			val (cels', nt', fvs', hds') = foldr comb (nil,nil,nil,nil) ls
429 :			val (exp, t, f, h) =
430 :			case eopt of
431 :			NONE => (SWITCH(v',a,cels',eopt), List.hd nt', fv@fvs', hd@hds')
432 :			| SOME(eopt') =>
433 :			let
434 :			val (eopt'', nt'', fvs'', hd'') = loope(eopt', env, d, ad)
435 :			in
436 :			(SWITCH(v',a,cels',SOME(eopt'')), List.hd nt', fv@fvs'@fvs'', hd@hds'@hd'')
437 :			end
438 :
439 :			in
440 :			(exp, t, f, h)
441 :			end
442 :			| loope (CON(dcons,tcs,vl,v,e), env, d, ad) =
443 :			let
444 :			val (s, cr, lt) = dcons
445 :			val (cr', fv) = lpcon env cr
446 :			val nt = reslty(lt, tcs)
447 :
448 :			val (vl', nt', fvs', hd') = loopc env vl
449 :
450 :			val _ = addEnv(env, [v], [nt], nil, td, d, true)
451 :			val (e'', nt'', fvs'', hd'') = loope(e, env, d, ad)
452 :			in
453 :			(CON((s, cr', lt),tcs,vl',v,e''), nt'', fv@fvs'@fvs'', hd'@hd'')
454 :			end
455 :			| loope (RECORD(rk,vls,v,e), env, d, ad) =
456 :			let
457 :			val ls = map (loopc env) vls
458 :			val (vls', nt', fvs', hd') = foldr comb (nil,nil,nil,nil) ls
459 :			val nt = LE.ltc_rkind(rk, nt')
460 :
461 :			val _ = addEnv(env, [v], [nt], fvs', td, d, true)
462 :			val (e', nt'', fvs'', hd'') = loope(e, env, d, ad)
463 :			in
464 :			(RECORD(rk, vls', v, e'), nt'', fvs'@fvs'', hd'@hd'')
465 :			end
466 :			| loope (SELECT(v,i,l,e), env, d, ad) =
467 :			let val (v', nt', fvs', hd') = loopc env v
468 :			val nt = LE.ltd_rkind(nt', i)
469 :			val _ = addEnv(env, [l], [nt], fvs', td, d, true)
470 :			val (e', nt'', fvs'', hd'') = loope(e, env, d, ad)
471 :			in
472 :			(SELECT(v',i,l,e'), nt'', fvs'@fvs'', hd'@hd'')
473 :			end
474 :			| loope (RAISE(v,ls), env, d, ad) =
475 :			let val (v', nt', fvs', hd') = loopc env v
476 :			in (RAISE(v',ls), ls, fvs', hd')
477 :			end
478 :			| loope (HANDLE(e,v), env, d, ad) =
479 :			let val (v', nt', fvs', hd') = loopc env v
480 :			val (e', nt'', fvs'', hd'') = loope(e, env, d, ad)
481 :			in
482 :			(HANDLE(e',v'), nt'', fvs'@fvs'', hd'@hd'')
483 :			end
484 :			| loope (BRANCH(pr,vl,e1,e2), env, d, ad) =
485 :			let val ls = map (loopc env) vl
486 :			val (vls', nt', fvs', hd') = foldr comb (nil,nil,nil,nil) ls
487 :			val (e1', nt'', fvs'', hd'') = loope(e1, env, d, ad)
488 :			val (e2', nt''', fvs''', hd''') = loope(e2, env, d, ad)
489 :			in
490 :			(BRANCH(pr,vls',e1',e2'), nt''', fvs'@fvs''@fvs''', hd'@hd''@hd''')
491 :			end
492 :			| loope (PRIMOP(pr,vl,l,e), env, d, ad) =
493 :			let
494 :			val ls = map (loopc env) vl
495 :			val (vls', nt', fvs', hd') = foldr comb (nil,nil,nil,nil) ls
496 :			val (_, _, lt, ts) = pr
497 :			val nt = reslty(lt, ts)
498 :
499 :			val _ = addEnv(env, [l], [nt], fvs', td, d, ABS)
500 :			val (e', nt'', fvs'', hd'') = loope(e, env, d, ad)
501 :			in
502 :			(PRIMOP(pr,vls',l,e'), nt'', fvs'@fvs'', hd'@hd'')
503 :			end
504 :			| loope(e as FIX([({cconv = CC_FCT, ...}, v, lvs, e1)],e2), env, d, ad) =
505 :			let
506 :			val vs = map #1 lvs
507 :			val ts = map #2 lvs
508 :			val _ = if d > 0 then
509 :			wellfixed := false
510 :			else
511 :			()
512 :			val _ = addEnv(env, vs, ts, nil, td, 0, NOABS)
513 :			val (e', nt', fvs', hd') = loope(e1, env, 0, DI.next ad)
514 :			val nt = LE.ltc_fkfun(fkfct, ts, nt')
515 :			val _ = addEnv(env, [v], [nt], fvs', td, 0, NOABS)
516 :			val (e'', nt'', fvs'', hd'') = loope(e2, env, d, ad)
517 :			in
518 :			(FIX([(fkfct, v, lvs, e')], e''), nt'', fvs'@fvs'', hd'@hd'')
519 :			end
520 :			| loope(e as FIX([(fk, v, lvs, e1)], e2), env, d, ad) =
521 :			(case fk of
522 :			{isrec = NONE, cconv = CC_FUN _, ...} =>
523 :			let
524 :			val vs = map #1 lvs
525 :			val ts = map #2 lvs
526 :			val _ = addEnv(env, vs, ts, nil, td, DI.next d, ABS)
527 :			val (e', nt', fvs', hd') = loope(e1, env, DI.next d, DI.next ad)
528 :			val nt = LE.ltc_fkfun(fk, ts, nt')
529 :			val abs = if d > 0 then true else false
530 :			val _ = addEnv(env, [v], [nt], fvs', td, d, ABS)
531 :			val (e'', nt'', fvs'', hd'') = loope(e2, env, d, ad)
532 :			val ne' = FIX([(fk,v,lvs,e')], e'')
533 :			val (ne,hd) = case d of
534 :			0 => (writeHeader(hd'@hd'', ne'), nil)
535 :			| _ => (ne', hd'@hd'')
536 :			in (ne, nt'', fvs'@fvs'', hd)
537 :			end
538 :			| {isrec = SOME(rts,_), cconv = CC_FUN _, ...} =>
539 :			let
540 :			val vs = map (#1) lvs
541 :			val ts = map (#2) lvs
542 :			val _ = addEnv(env, [v], [LE.ltc_fkfun(fk, ts, rts)], nil,
543 :			td, DI.next d, ABS)
544 :			val _ = addEnv(env, vs, ts, nil, td, DI.next d, ABS)
545 :			val (e', nt', fvs', hd') = loope(e1, env, DI.next d, DI.next ad)
546 :
547 :			(* Check to see that the new value is inserted *)
548 :
549 :			val _ = addEnv(env, [v], [LE.ltc_fkfun(fk, ts, rts)], nil,
550 :			td, d, ABS)
551 :			(* The depth is changed for correct behaviour *)
552 :
553 :			val (e'', nt'', fvs'', hd'') = loope(e2, env, d, ad)
554 :			val ne' = FIX([(fk,v,lvs,e')], e'')
555 :			val (ne,hd) = case d of
556 :			0 => (writeHeader(hd'@hd'', ne'), nil)
557 :			| _ => (ne', hd'@hd'')
558 :			in (ne, nt'', fvs'@fvs'', hd)
559 :			end
560 :			| _ => bug "unexpected fundec in main loop" )
561 :			| loope(e as FIX(fds, e2), env, d, ad) =
562 :			let
563 :			fun h d' ((fk as {isrec = SOME(rts,_), ...}, f, lvs, e1):fundec) =
564 :			addEnv(env, [f], [LE.ltc_fkfun(fk, map #2 lvs, rts)], nil, td, d', ABS)
565 :			| h d fk = bug "unexpected non-recursive fkind in loop"
566 :			fun g((fk, f, lvs, e):fundec) =
567 :			let
568 :			val _ = addEnv(env, map #1 lvs, map #2 lvs, nil, td, DI.next d, ABS)
569 :			val (e', nt', fvs', hd') = loope(e, env, DI.next d, DI.next ad)
570 :			in
571 :			( (fk, f, lvs, e'), [LE.ltc_fkfun(fk, map #2 lvs, nt')], fvs', hd')
572 :			end
573 :			val _ = map (h (DI.next d)) fds
574 :			val rets = map g fds
575 :			val (fds, nts, fvs, hds) = foldr comb (nil,nil,nil,nil) rets
576 :
577 :			(* Check to see that the correct value is inserted *)
578 :
579 :			val _ = map (h d) fds
580 :			val (e'', nt'', fvs'', hd'') = loope(e2, env, d, ad)
581 :			val ne' = FIX(fds, e'')
582 :			in
583 :			case d of
584 :			0 => (writeHeader(hds@hd'', ne'), nt'', fvs@fvs'', nil)
585 :			| _ => (ne', nt'', fvs@fvs'', hds@hd'')
586 :			end
587 :
588 :			in loope(e, env, d, ad)
589 :			end
590 :
591 :
592 :			fun typeLift fdec:fundec =
593 :			(* if !Control.CG.lifttype then *)
594 :			case fdec of
595 :			(fk as {cconv = CC_FCT, ...}, v, vts, e) =>
596 :			let
597 :			val env = initInfoEnv()
598 :			val d = 0 (* DI.top ?? *)
599 :			val td = 0 (* DI.top ?? *)
600 :			val ad = 0 (* DI.top ?? *)
601 :			val rename = false
602 :			val vs = map #1 vts
603 :			val ts = map #2 vts
604 :			val _ = addEnv(env, vs, ts, nil, td, d, NOABS)
605 :			val (ne, _, _, _) = ( lift(e, env, td, d, ad, rename) )
606 :			handle PartialTypeApp =>
607 :			( print "\n*** No Typelifting ";
608 :			print " Partial Type App ***\n";
609 :			(e, nil, nil, nil) )
610 :			val _ = if !wellfixed then
611 :			()
612 :			else
613 :			() (* print "\n *** Functor at d > 0 *** \n" *)
614 :			val _ = if !CTRL.saytappinfo then
615 :			(print "\n *** No. of Tapps lifted ";
616 :			print (" " ^ (Int.toString (!tappLifted)) ^ " \n") )
617 :			else
618 :			()
619 :			in
620 :			( tappLifted := 0;
621 :			wellfixed := true;
622 :			welltapped := true;
623 :			(fk, v, vts, ne) )
624 :			end
625 :			| _ => bug "non FCT program in Lift"
626 :			(* else fdec *)
627 :
628 :			end
629 :			end
630 :

---

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