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

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