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

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