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

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

Parent Directory Parent Directory | Revision Log Revision Log


Revision 163 - (view) (download)

1 : monnier 16 (* COPYRIGHT (c) 1996 Bell Laboratories *)
2 :     (* specialize.sml *)
3 :    
4 :     (* minimal type derivation, type specialization, and lifting of
5 :     structure access (not supported yet) and type application *)
6 :    
7 :     signature SPECIALIZE =
8 :     sig
9 : monnier 45 val specialize : FLINT.prog -> FLINT.prog
10 : monnier 16 end (* signature SPECIALIZE *)
11 :    
12 :     structure Specialize : SPECIALIZE =
13 :     struct
14 :    
15 :     local structure LD = LtyDef
16 :     structure LT = LtyExtern
17 :     structure DI = DebIndex
18 :     structure PT = PrimTyc
19 : monnier 45 structure PF = PFlatten
20 :     open FLINT
21 : monnier 16 in
22 :    
23 :     val say = Control.Print.say
24 :     fun bug s = ErrorMsg.impossible ("Specialize: " ^ s)
25 : monnier 45 fun mkv _ = LambdaVar.mkLvar()
26 :     val ident = fn le : FLINT.lexp => le
27 : monnier 16 fun tvar i = LT.tcc_var(DI.innermost, i)
28 :    
29 : monnier 45 val tk_tbx = LT.tkc_box (* the special boxed tkind *)
30 : monnier 16 val tk_tmn = LT.tkc_mono
31 :     val tk_eqv = LT.tk_eqv
32 :    
33 :     (* checking the equivalence of two tyc sequences *)
34 :     val tc_eqv = LT.tc_eqv
35 :     fun tcs_eqv (xs, ys) =
36 :     let fun teq(a::r, b::s) = if tc_eqv(a, b) then teq(r, s) else false
37 :     | teq([],[]) = true
38 :     | teq _ = bug "unexpected cases in tcs_eqv"
39 :     in teq(xs, ys)
40 :     end
41 :    
42 : monnier 45 (* accounting functions; how many functions have been specialized *)
43 :     fun mk_click () =
44 :     let val x = ref 0
45 :     fun click () = (x := (!x) + 1)
46 :     fun num_click () = !x
47 :     in (click, num_click)
48 :     end
49 :    
50 : monnier 16 (****************************************************************************
51 :     * UTILITY FUNCTIONS FOR KIND AND TYPE BOUNDS *
52 :     ****************************************************************************)
53 :    
54 :     (*
55 :     * Bnd is a lattice on the type hierarchy, used to infer minimum type bounds;
56 :     * Right now, we only deal with first-order kinds. All higher-order kinds
57 :     * will be assigned KTOP.
58 :     *)
59 :     datatype bnd
60 :     = KBOX
61 :     | KTOP
62 : monnier 45 | TBND of tyc
63 : monnier 16
64 :     type bnds = bnd list
65 :    
66 :     (** THE FOLLOWING FUNCTION IS NOT FULLY DEFINED *)
67 :     fun kBnd kenv tc =
68 :     (if LT.tcp_var tc then
69 :     (let val (i,j) = LT.tcd_var tc
70 :     val (_,ks) = List.nth(kenv, i-1)
71 :     handle _ => bug "unexpected case A in kBnd"
72 : monnier 45 val (_,k) = List.nth(ks, j)
73 : monnier 16 handle _ => bug "unexpected case B in kBnd"
74 :     in if tk_eqv(tk_tbx, k) then KBOX else KTOP
75 :     end)
76 :     else if LT.tcp_prim tc then
77 :     (let val p = LT.tcd_prim tc
78 :     in if PT.unboxed p then KTOP else KBOX
79 :     end)
80 :     else KBOX)
81 :    
82 :     fun kmBnd kenv (tc, KTOP) = KTOP
83 :     | kmBnd kenv (tc, KBOX) = kBnd kenv tc
84 :     | kmBnd kenv (tc, TBND _) = bug "unexpected cases in kmBnd"
85 :    
86 :     fun tBnd kenv tc = TBND tc
87 :    
88 :     fun tmBnd kenv (tc, KTOP) = KTOP
89 :     | tmBnd kenv (tc, KBOX) = kBnd kenv tc
90 :     | tmBnd kenv (tc, x as TBND t) =
91 :     if tc_eqv(tc, t) then x else kmBnd kenv (tc, kBnd kenv t)
92 :    
93 :    
94 : monnier 45 datatype spkind
95 :     = FULL
96 :     | PART of bool list (* filter indicator; which one is gone *)
97 :    
98 :     datatype spinfo
99 :     = NOSP
100 :     | NARROW of (tvar * tkind) list
101 :     | PARTSP of {ntvks: (tvar * tkind) list, nts: tyc list,
102 :     masks: bool list}
103 :     | FULLSP of tyc list * lvar list
104 :    
105 : monnier 16 (*
106 : monnier 45 * Given a list of default kinds, and a list of bnd information, a depth,
107 :     * and the (tyc list * lvar list) list info in the itable, returns the
108 :     * the spinfo.
109 : monnier 16 *)
110 : monnier 45 fun bndGen(oks, bnds, d, info) =
111 :     let (** pass 1 **)
112 :     fun g ((TBND _)::bs, r, z) = g(bs, false::r, z)
113 :     | g (_::bs, r, _) = g(bs, true::r, false)
114 :     | g ([], r, z) = if z then FULL else PART (rev r)
115 :     val spk = g(bnds, [], true)
116 : monnier 16
117 : monnier 45 val adj = case spk of FULL => (fn tc => tc)
118 :     | _ => (fn tc => LT.tc_adj(tc, d, DI.next d))
119 :     (* if not full-specializations, we push depth one-level down *)
120 :    
121 :     (** pass 2 **)
122 :     val n = length oks
123 :    
124 :     (* invariants: n = length bnds = length (the-resulting-ts) *)
125 :     fun h([], [], i, [], ts, _) =
126 :     (case info of [(_, xs)] => FULLSP(rev ts, xs)
127 :     | _ => bug "unexpected case in bndGen 3")
128 :     | h([], [], i, ks, ts, b) =
129 :     if b then NOSP else
130 :     if i = n then NARROW (rev ks)
131 :     else (case spk
132 :     of PART masks =>
133 :     PARTSP {ntvks=rev ks, nts=rev ts, masks=masks}
134 :     | _ => bug "unexpected case 1 in bndGen")
135 :     | h(ok::oks, KTOP::bs, i, ks, ts, b) =
136 :     h(oks, bs, i+1, ok::ks, (tvar i)::ts, b)
137 : monnier 24 | h(ok::oks, (TBND tc)::bs, i, ks, ts, b) =
138 :     h(oks, bs, i, ks, (adj tc)::ts, false)
139 : monnier 45 | h((tv,ok)::oks, KBOX::bs, i, ks, ts, b) =
140 : monnier 16 let (* val nk = if tk_eqv(tk_tbx, ok) then ok else tk_tbx *)
141 : monnier 45 val (nk, b) =
142 :     if tk_eqv(tk_tmn, ok) then (tk_tbx, false) else (ok, b)
143 :     in h(oks, bs, i+1, (tv,nk)::ks, (tvar i)::ts, b)
144 : monnier 16 end
145 : monnier 45 | h _ = bug "unexpected cases 2 in bndGen"
146 : monnier 16
147 : monnier 45
148 :     in h(oks, bnds, 0, [], [], true)
149 : monnier 16 end
150 :    
151 :    
152 :     (****************************************************************************
153 :     * UTILITY FUNCTIONS FOR INFO ENVIRONMENTS *
154 :     ****************************************************************************)
155 :    
156 :     (*
157 : monnier 45 * We maintain a table mapping each lvar to its definition depth,
158 :     * its type, and a list of its uses, indexed by its specific type
159 :     * instances.
160 : monnier 16 *)
161 :     exception ITABLE
162 :     exception DTABLE
163 :    
164 : monnier 45 datatype dinfo
165 :     = ESCAPE
166 :     | NOCSTR
167 :     | CSTR of bnds
168 :    
169 : monnier 16 type depth = DI.depth
170 : monnier 45 type info = (tyc list * lvar list) list
171 :     type itable = info Intmap.intmap (* lvar -> (tyc list * lvar) *)
172 :     type dtable = (depth * dinfo) Intmap.intmap
173 :     datatype infoEnv = IENV of (itable * (tvar * tkind) list) list * dtable
174 : monnier 16
175 : monnier 45 (****************************************************************************
176 :     * UTILITY FUNCTIONS FOR TYPE SPECIALIZATIONS *
177 :     ****************************************************************************)
178 : monnier 16 (** initializing a new info environment : unit -> infoEnv *)
179 :     fun initInfoEnv () =
180 :     let val itable : itable = Intmap.new (32, ITABLE)
181 :     val dtable : dtable = Intmap.new(32, DTABLE)
182 :     in IENV ([(itable,[])], dtable)
183 :     end
184 :    
185 :     (** register a definition of sth interesting into the info environment *)
186 :     fun entDtable (IENV(_, dtable), v, ddinfo) = Intmap.add dtable (v, ddinfo)
187 :    
188 :     (** mark an lvar in the dtable as escape *)
189 :     fun escDtable (IENV(_, dtable), v) =
190 :     ((case Intmap.map dtable v
191 :     of (_, ESCAPE) => ()
192 :     | (d, _) => Intmap.add dtable (v, (d, ESCAPE)))
193 :     handle _ => ())
194 :    
195 :     (*
196 :     * Register a dtable entry; modify the least upper bound of a particular
197 :     * type binding; notice I am only moving kind info upwards, not type
198 : monnier 45 * info, I could move type info upwards though.
199 : monnier 16 *)
200 :     fun regDtable (IENV(kenv, dtable), v, infos) =
201 :     let val (dd, dinfo) =
202 :     ((Intmap.map dtable v) handle _ =>
203 :     bug "unexpected cases in regDtable")
204 :     in (case dinfo
205 :     of ESCAPE => ()
206 :     | _ =>
207 : monnier 45 let fun h ((ts, _), ESCAPE) = ESCAPE
208 :     | h ((ts, _), NOCSTR) = CSTR (map (kBnd kenv) ts)
209 :     | h ((ts, _), CSTR bnds) =
210 :     let val nbnds = ListPair.map (kmBnd kenv) (ts, bnds)
211 :     in CSTR nbnds
212 :     end
213 :     val ndinfo = foldr h dinfo infos
214 :     in Intmap.add dtable (v, (dd, ndinfo))
215 :     end)
216 :     end (* function regDtable *)
217 : monnier 16
218 :     (*
219 :     * Calculate the least upper bound of all type instances;
220 :     * this should take v out of the current dtable !
221 :     *)
222 :     fun sumDtable(IENV(kenv, dtable), v, infos) =
223 :     let val (dd, dinfo) =
224 :     ((Intmap.map dtable v) handle _ =>
225 :     bug "unexpected cases in sumDtable")
226 :     in (case dinfo
227 :     of ESCAPE => (dd, ESCAPE)
228 :     | _ =>
229 :     (let fun h ((ts, _), ESCAPE) = ESCAPE
230 :     | h ((ts, _), NOCSTR) = CSTR (map (tBnd kenv) ts)
231 :     | h ((ts, _), CSTR bnds) =
232 :     let val nbnds = ListPair.map (tmBnd kenv) (ts, bnds)
233 :     in CSTR nbnds
234 :     end
235 :     val ndinfo = foldr h dinfo infos
236 :     in (dd, ndinfo)
237 :     end))
238 :     end
239 :    
240 :     (** look and add a new type instance into the itable *)
241 : monnier 45 fun lookItable (IENV (itabs,dtab), d, v, ts, getlty) =
242 : monnier 16 let val (dd, _) =
243 :     ((Intmap.map dtab v) handle _ => bug "unexpected cases in lookItable")
244 :    
245 :     val nd = Int.max(dd, LT.tcs_depth(ts, d))
246 :    
247 :     val (itab,_) = ((List.nth(itabs, d-nd)) handle _ =>
248 :     bug "unexpected itables in lookItable")
249 :    
250 :     val nts = map (fn t => LT.tc_adj(t, d, nd)) ts
251 :     val xi = (Intmap.map itab v) handle _ => []
252 :    
253 : monnier 45 fun h ((ots,xs)::r) = if tcs_eqv(ots, nts) then (map VAR xs) else h r
254 :     | h [] = let val oldt = getlty (VAR v) (*** old type is ok ***)
255 :     val bb = LT.lt_inst(oldt, ts)
256 :     val nvs = map mkv bb
257 :     val _ = Intmap.add itab (v, (nts, nvs)::xi)
258 :     in map VAR nvs
259 : monnier 16 end
260 :     in h xi
261 :     end
262 :    
263 :     (** push a new layer of type abstraction : infoEnv -> infoEnv *)
264 : monnier 45 fun pushItable (IENV(itables, dtable), tvks) =
265 : monnier 16 let val nt : itable = Intmap.new(32, ITABLE)
266 : monnier 45 in (IENV((nt,tvks)::itables, dtable))
267 : monnier 16 end
268 :    
269 :     (*
270 :     * Pop off a layer when exiting a type abstaction, adjust the dtable properly,
271 :     * and generate the proper headers: infoEnv -> (lexp -> lexp)
272 :     *)
273 :     fun popItable (IENV([], _)) =
274 :     bug "unexpected empty information env in popItable"
275 :     | popItable (ienv as IENV((nt,_)::_, _)) =
276 :     let val infos = Intmap.intMapToList nt
277 :     fun h ((v,info), hdr) =
278 :     let val _ = regDtable(ienv, v, info)
279 : monnier 45 fun g ((ts, xs), e) = LET(xs, TAPP(VAR v, ts), e)
280 : monnier 16 in fn e => foldr g (hdr e) info
281 :     end
282 :     in foldr h ident infos
283 :     end
284 :    
285 :     (* Check out a escaped variable from the info env, build the header properly *)
286 :     fun chkOutEsc (IENV([], _), v) =
287 :     bug "unexpected empty information env in chkOut"
288 :     | chkOutEsc (ienv as IENV((nt,_)::_, _), v) =
289 :     let val info = (Intmap.map nt v) handle _ => []
290 : monnier 45 fun g ((ts, xs), e) = LET(xs, TAPP(VAR v, ts), e)
291 : monnier 16 val hdr = fn e => foldr g e info
292 :     val _ = Intmap.rmv nt v (* so that v won't be considered again *)
293 :     in hdr
294 :     end
295 :    
296 : monnier 45 fun chkOutEscs (ienv, vs) =
297 :     foldr (fn (v,h) => (chkOutEsc(ienv, v)) o h) ident vs
298 :    
299 : monnier 16 (*
300 :     * Check out a regular variable from the info env, build the header
301 :     * properly, of course, adjust the corresponding dtable entry.
302 :     *)
303 :     fun chkOutNorm (IENV([], _), v, oks, d) =
304 :     bug "unexpected empty information env in chkOut"
305 :    
306 :     | chkOutNorm (ienv as IENV((nt,_)::_, dtable), v, oks, d) =
307 :     let val info = (Intmap.map nt v) handle _ => []
308 : monnier 45 val (_, dinfo) = sumDtable(ienv, v, info)
309 :     val spinfo =
310 : monnier 16 (case dinfo
311 : monnier 45 of ESCAPE => NOSP
312 : monnier 16 | NOCSTR => (* must be a dead function, let's double check *)
313 : monnier 45 (case info of [] => NOSP
314 : monnier 16 | _ => bug "unexpected cases in chkOutNorm")
315 : monnier 45 | CSTR bnds => bndGen(oks, bnds, d, info))
316 : monnier 16
317 : monnier 45 fun mkhdr((ts, xs), e) =
318 :     (case spinfo
319 :     of FULLSP _ => e
320 :     | PARTSP {masks, ...} =>
321 :     let fun h([], [], z) = rev z
322 :     | h(a::r, b::s, z) =
323 :     if b then h(r, s, a::z) else h(r, s, z)
324 :     | h _ = bug "unexpected cases in tapp"
325 :     in LET(xs, TAPP(VAR v, h(ts, masks, [])), e)
326 :     end
327 :     | _ => LET(xs, TAPP(VAR v, ts), e))
328 :     val hdr = fn e => foldr mkhdr e info
329 : monnier 16 val _ = Intmap.rmv nt v (* so that v won't be considered again *)
330 : monnier 45 in (hdr, spinfo)
331 : monnier 16 end
332 :    
333 :     (****************************************************************************
334 : monnier 45 * MAIN FUNCTION *
335 : monnier 16 ****************************************************************************)
336 :    
337 : monnier 45 fun specialize fdec =
338 : monnier 16 let
339 :    
340 : monnier 45 val (click, num_click) = mk_click ()
341 : monnier 16
342 : monnier 45 (* In pass1, we calculate the old type of each variables in the FLINT
343 :     * expression. The reason we can't merge this with the main pass is
344 :     * that the main pass traverse the code in different order.
345 :     * There must be a simpler way, but I didn't find one yet (ZHONG).
346 :     *)
347 : monnier 69 val {getLty=getLtyGen, cleanUp} = Recover.recover(fdec, false)
348 : monnier 16
349 : monnier 45 (* transform: infoEnv * DI.depth * lty cvt * tyc cvt
350 :     * (value -> lty) * bool -> (lexp -> lexp)
351 :     * where type 'a cvt = DI.depth -> 'a -> 'a
352 :     * The 2nd argument is the depth of the resulting expression.
353 :     * The 3rd and 4th arguments are used to encode the type translations.
354 :     * The 5th argument is the depth information in the original code,
355 :     * it is useful for the getlty.
356 :     * The 6th argument is a flag that indicates whether we need to
357 :     * flatten the return results of the current function.
358 :     *)
359 :     fun transform (ienv, d, ltfg, tcfg, gtd, did_flat) =
360 :     let val ltf = ltfg d
361 :     val tcf = tcfg d
362 :     val getlty = getLtyGen gtd
363 : monnier 16
364 : monnier 45 (* we chkin and chkout polymorphic values only *)
365 :     fun chkin v = entDtable (ienv, v, (d, ESCAPE))
366 :     fun chkout v = chkOutEsc (ienv, v)
367 :     fun chkins vs = app chkin vs
368 :     fun chkouts vs = chkOutEscs (ienv, vs)
369 : monnier 16
370 : monnier 45 (* lpvar : value -> value *)
371 :     fun lpvar (u as (VAR v)) = (escDtable(ienv, v); u)
372 :     | lpvar u = u
373 : monnier 16
374 : monnier 45 (* lpvars : value list -> value list *)
375 :     fun lpvars vs = map lpvar vs
376 : monnier 16
377 : monnier 45 (* lpprim : primop -> primop *)
378 :     fun lpprim (d, po, lt, ts) = (d, po, ltf lt, map tcf ts)
379 : monnier 16
380 : monnier 45 (* lpdc : dcon -> dcon *)
381 :     fun lpdc (s, rep, lt) = (s, rep, ltf lt)
382 : monnier 16
383 : monnier 45 (* lplet : lvar * lexp -> (lexp -> lexp) *)
384 :     fun lplet (v, e, cont) =
385 :     let val _ = chkin v
386 :     val ne = loop e
387 :     in cont ((chkout v) ne)
388 :     end
389 : monnier 16
390 : monnier 45 (* lplets : lvar list * lexp -> (lexp -> lexp) *)
391 :     and lplets (vs, e, cont) =
392 :     let val _ = chkins vs
393 :     val ne = loop e
394 :     in cont ((chkouts vs) ne)
395 :     end
396 : monnier 16
397 : monnier 45 (* lpcon : con * lexp -> con * lexp *)
398 :     and lpcon (DATAcon (dc, ts, v), e) =
399 :     (DATAcon (lpdc dc, map tcf ts, v), lplet(v, e, fn x => x))
400 :     | lpcon (c, e) = (c, loop e)
401 : monnier 16
402 : monnier 45 (* lpfd : fundec -> fundec *** requires REWORK *** *)
403 :     and lpfd (fk as FK_FCT, f, vts, be) =
404 :     (fk, f, map (fn (v,t) => (v, ltf t)) vts,
405 :     lplets (map #1 vts, be, fn e => e))
406 :     | lpfd (fk as FK_FUN {fixed=fflag,isrec,known,inline}, f, vts, be) =
407 :     let (** first get the original arg and res types of f *)
408 :     val (fflag', atys, rtys) = LT.ltd_arrow (getlty (VAR f))
409 : monnier 16
410 : monnier 45 (** just a sanity check; should turn it off later **)
411 :     val (b1,b2) =
412 :     if LT.ff_eqv (fflag, fflag') then LT.ffd_fspec fflag
413 :     else bug "unexpected code in lpfd"
414 :    
415 : monnier 16
416 : monnier 45 (** get the newly specialized types **)
417 :     val (natys, nrtys) = (map ltf atys, map ltf rtys)
418 : monnier 16
419 : monnier 45 (** do we need flatten the arguments and the results *)
420 :     val ((arg_raw, arg_ltys, _), unflatten) =
421 :     PF.v_unflatten (natys, b1)
422 : monnier 16
423 : monnier 45 val (body_raw, body_ltys, ndid_flat) = PF.t_flatten (nrtys, b2)
424 : monnier 16
425 : monnier 45 (** process the function body *)
426 :     val nbe =
427 :     if ndid_flat = did_flat then loop be
428 :     else transform (ienv, d, ltfg, tcfg, gtd, ndid_flat) be
429 :    
430 :     val (arg_lvs, nnbe) = unflatten (map #1 vts, nbe)
431 :    
432 :     (** fix the isrec information *)
433 :     val nisrec = case isrec of NONE => NONE
434 :     | SOME _ => SOME body_ltys
435 :     val nfixed = LT.ffc_fspec(fflag, (arg_raw, body_raw))
436 :     val nfk = FK_FUN {isrec=nisrec, fixed=nfixed,
437 :     known=known, inline=inline}
438 :    
439 :     in (nfk, f, ListPair.zip(arg_lvs, arg_ltys), nnbe)
440 :     end
441 :    
442 :     (* lptf : tfundec * lexp -> lexp *** Invariant: ne2 has been processed *)
443 :     and lptf ((v, tvks, e1), ne2) =
444 :     let val nienv = pushItable(ienv, tvks)
445 :     val nd = DI.next d
446 :     val ne1 = transform (nienv, nd, ltfg, tcfg, DI.next gtd, false) e1
447 :     val hdr = popItable nienv
448 :     in TFN((v, tvks, hdr ne1), ne2)
449 :     end
450 :    
451 :     (* loop : lexp -> lexp *)
452 :     and loop le =
453 :     (case le
454 :     of RET vs =>
455 :     if did_flat then
456 :     let val vts = map (ltf o getlty) vs
457 :     val ((_,_,ndid_flat),flatten) = PF.v_flatten(vts, false)
458 :     in if ndid_flat then
459 :     let val (nvs, hdr) = flatten vs
460 :     in hdr(RET nvs)
461 :     end
462 :     else RET(lpvars vs)
463 :     end
464 :     else RET(lpvars vs)
465 :     | LET(vs, e1, e2) =>
466 :     let (* first get the original types *)
467 :     val vtys = map (ltf o getlty o VAR) vs
468 :     (* second get the newly specialized types *)
469 :     val ((_, _, ndid_flat), unflatten) =
470 :     PF.v_unflatten(vtys, false)
471 :     (* treat the let type as always "cooked" *)
472 :     val _ = chkins vs
473 :     val ne2 = loop e2
474 :     val ne2 = (chkouts vs) ne2
475 :     val (nvs, ne2) = unflatten(vs, ne2)
476 :    
477 :     val ne1 =
478 :     if ndid_flat = did_flat then loop e1
479 :     else transform (ienv, d, ltfg, tcfg, gtd, ndid_flat) e1
480 :     in LET(nvs, ne1, ne2)
481 :     end
482 :    
483 :     | FIX(fdecs, e) => FIX(map lpfd fdecs, loop e)
484 :     | APP(v, vs) =>
485 :     let val vty = getlty v
486 :     in if LT.ltp_fct vty then APP(lpvar v, lpvars vs)
487 :     else
488 :     let (** first get the original arg and res types of v *)
489 :     val (fflag, atys, rtys) = LT.ltd_arrow vty
490 :     val (b1, b2) = LT.ffd_fspec fflag
491 :    
492 :     (** get the newly specialized types **)
493 :     val (natys, nrtys) = (map ltf atys, map ltf rtys)
494 :    
495 :     val (nvs, hdr1) = (#2 (PF.v_flatten (natys, b1))) vs
496 :     val hdr2 =
497 :     if did_flat then ident
498 :     else (let val ((_, _, ndid_flat), unflatten) =
499 :     PF.v_unflatten(nrtys, b2)
500 :     val fvs = map mkv nrtys
501 :     in if ndid_flat then
502 :     let val (nvs, xe) =
503 :     unflatten(fvs, RET (map VAR fvs))
504 :     in fn le => LET(nvs, le, xe)
505 :     end
506 :     else ident
507 :     end)
508 :     in hdr1 (APP(lpvar v, lpvars nvs))
509 :     end
510 :     end
511 :    
512 :     | TFN((v, tvks, e1), e2) =>
513 :     let val _ = entDtable(ienv, v, (d,NOCSTR))
514 :     val ne2 = loop e2
515 :     val ks = map #2 tvks
516 :     val (hdr2, spinfo) = chkOutNorm(ienv, v, tvks, d)
517 :     val ne2 = hdr2 ne2
518 :     in (case spinfo
519 :     of NOSP => lptf((v, tvks, e1), ne2)
520 :     | NARROW ntvks => lptf((v, ntvks, e1), ne2)
521 :     | PARTSP {ntvks, nts, ...} =>
522 :     (* assume nts is already shifted one level down *)
523 :     let val nienv = pushItable(ienv, ntvks)
524 :     val xd = DI.next d
525 :     fun nltfg nd lt =
526 :     let val lt1 = LT.lt_sp_sink(ks, lt, d, nd)
527 :     val lt2 = ltfg (DI.next nd) lt1
528 :     in (LT.lt_sp_adj(ks, lt2, nts, nd-xd, 0))
529 :     end
530 :     fun ntcfg nd tc =
531 :     let val tc1 = LT.tc_sp_sink(ks, tc, d, nd)
532 :     val tc2 = tcfg (DI.next nd) tc1
533 :     in (LT.tc_sp_adj(ks, tc2, nts, nd-xd, 0))
534 :     end
535 :     val ne1 =
536 :     transform (nienv, xd, nltfg, ntcfg,
537 :     DI.next gtd, false) e1
538 :     val hdr0 = popItable nienv
539 :     in TFN((v, ntvks, hdr0 ne1), ne2)
540 :     end
541 :     | FULLSP (nts, xs) =>
542 :     let fun nltfg nd lt =
543 :     (LT.lt_sp_adj(ks, ltfg (DI.next nd) lt,
544 :     nts, nd-d, 0))
545 :     fun ntcfg nd tc =
546 :     (LT.tc_sp_adj(ks, tcfg (DI.next nd) tc,
547 :     nts, nd-d, 0))
548 :     val ne1 = transform (ienv, d, nltfg, ntcfg,
549 :     DI.next gtd, false) e1
550 :     in click(); LET(xs, ne1, ne2)
551 :     end)
552 :     end (* case TFN *)
553 :    
554 :     | TAPP(u as VAR v, ts) =>
555 :     let val nts = map tcf ts
556 :     val vs = lookItable(ienv, d, v, nts, getlty)
557 :     in if did_flat then
558 :     let val vts = LT.lt_inst(ltf (getlty u), nts)
559 :     val ((_,_,ndid_flat),flatten) =
560 :     PF.v_flatten(vts, false)
561 :     in if ndid_flat then
562 :     let val (nvs, hdr) = flatten vs
563 :     in hdr(RET nvs)
564 :     end
565 :     else RET vs
566 :     end
567 :     else RET vs
568 :     end
569 :    
570 :     | SWITCH (v, csig, cases, opp) =>
571 :     SWITCH(lpvar v, csig, map lpcon cases,
572 :     case opp of NONE => NONE | SOME e => SOME(loop e))
573 :     | CON (dc, ts, u, v, e) =>
574 :     lplet (v, e, fn ne => CON(lpdc dc, map tcf ts, lpvar u, v, ne))
575 :    
576 :     | RECORD (rk as RK_VECTOR t, vs, v, e) =>
577 :     lplet (v, e, fn ne => RECORD(RK_VECTOR (tcf t),
578 :     lpvars vs, v, ne))
579 :     | RECORD(rk, vs, v, e) =>
580 :     lplet (v, e, fn ne => RECORD(rk, lpvars vs, v, ne))
581 :     | SELECT (u, i, v, e) =>
582 :     lplet (v, e, fn ne => SELECT(lpvar u, i, v, ne))
583 :    
584 :     | RAISE (sv, ts) =>
585 :     let val nts = map ltf ts
586 :     val nsv = lpvar sv
587 :     in if did_flat then
588 :     let val (_, nnts, _) = PF.t_flatten(nts, false)
589 :     in RAISE(nsv, nnts)
590 :     end
591 :     else
592 :     RAISE(nsv, nts)
593 :     end
594 :     | HANDLE (e, v) => HANDLE(loop e, lpvar v)
595 :    
596 :     | BRANCH (p, vs, e1, e2) =>
597 :     BRANCH(lpprim p, lpvars vs, loop e1, loop e2)
598 :     | PRIMOP (p, vs, v, e) =>
599 :     lplet (v, e, fn ne => PRIMOP(lpprim p, lpvars vs, v, ne))
600 :     | _ => bug "unexpected lexps in loop")
601 :     in loop
602 :     end (* function transform *)
603 :    
604 :     in
605 :     (case fdec
606 :     of (fk as FK_FCT, f, vts, e) =>
607 :     let val tcfg = fn (d : DI.depth) => fn (x : LD.tyc) => x
608 :     val ltfg = fn (d : DI.depth) => fn (x : LD.lty) => x
609 : monnier 16 val ienv = initInfoEnv()
610 :     val d = DI.top
611 : monnier 45 val _ = app (fn (x,_) => entDtable(ienv, x, (d, ESCAPE))) vts
612 :     val ne = transform (ienv, d, ltfg, tcfg, d, false) e
613 :     val hdr = chkOutEscs (ienv, map #1 vts)
614 :     val nfdec = (fk, f, vts, hdr ne) before (cleanUp())
615 : monnier 163 in if (num_click()) > 0 then (* LContract.lcontract *) nfdec
616 : monnier 45 (* if we did specialize, we run a round of lcontract on the result *)
617 :     else nfdec
618 : monnier 16 end
619 : monnier 45 | _ => bug "non FK_FCT program in specialize")
620 :     end (* function specialize *)
621 : monnier 16
622 :     end (* toplevel local *)
623 :     end (* structure Specialize *)
624 :    
625 : monnier 93
626 :     (*
627 : monnier 113 * $Log$
628 : monnier 93 *)

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