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 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