Diff of /sml/branches/SMLNJ/src/compiler/FLINT/opt/specialize.sml

Parent Directory | Revision Log | Patch

	revision 23, Thu Mar 12 00:49:56 1998 UTC	revision 24, Thu Mar 12 00:49:58 1998 UTC
#	Line 6	Line 6
6
7	signature SPECIALIZE =	signature SPECIALIZE =
8	sig	sig
9	val specialize : FLINT.prog -> FLINT.prog	val specLexp : Lambda.lexp -> Lambda.lexp
10
11	end (* signature SPECIALIZE *)	end (* signature SPECIALIZE *)
12
13	structure Specialize : SPECIALIZE =	structure Specialize : SPECIALIZE =
#	Line 16	Line 17
17	structure LT = LtyExtern	structure LT = LtyExtern
18	structure DI = DebIndex	structure DI = DebIndex
19	structure PT = PrimTyc	structure PT = PrimTyc
20	structure PF = PFlatten	open Lambda
	open FLINT
21	in	in
22
23	val say = Control.Print.say	val say = Control.Print.say
24	fun bug s = ErrorMsg.impossible ("Specialize: " ^ s)	fun bug s = ErrorMsg.impossible ("Specialize: " ^ s)
25	fun mkv _ = LambdaVar.mkLvar()	val mkv = LambdaVar.mkLvar
26	val ident = fn le : FLINT.lexp => le	val ident = fn le : Lambda.lexp => le
27	fun tvar i = LT.tcc_var(DI.innermost, i)	fun tvar i = LT.tcc_var(DI.innermost, i)
28
29	val tk_tbx = LT.tkc_box (* the special boxed tkind *)	fun mktvs ks =
30		let fun h (_::r, i, z) = h(r, i+1, (tvar i)::z)
31		| h ([], _, z) = rev z
32		in h (ks, 0, [])
33		end
34
35		(* the special box tkind *)
36		val tk_tbx = LT.tkc_box
37	val tk_tmn = LT.tkc_mono	val tk_tmn = LT.tkc_mono
38	val tk_eqv = LT.tk_eqv	val tk_eqv = LT.tk_eqv
39
#	Line 39	Line 46
46	in teq(xs, ys)	in teq(xs, ys)
47	end	end
48
	(* accounting functions; how many functions have been specialized *)
	fun mk_click () =
	let val x = ref 0
	fun click () = (x := (!x) + 1)
	fun num_click () = !x
	in (click, num_click)
	end
49	(****************************************************************************	(****************************************************************************
50	*                  UTILITY FUNCTIONS FOR KIND AND TYPE BOUNDS              *	*                  UTILITY FUNCTIONS FOR KIND AND TYPE BOUNDS              *
51	****************************************************************************)	****************************************************************************)
#	Line 59	Line 58
58	datatype bnd	datatype bnd
59	= KBOX	= KBOX
60	| KTOP	| KTOP
61	| TBND of tyc	| TBND of LD.tyc
62
63	type bnds = bnd list	type bnds = bnd list
64
65		datatype dinfo
66		= ESCAPE
67		| NOCSTR
68		| CSTR of bnds
69
70	(** THE FOLLOWING FUNCTION IS NOT FULLY DEFINED *)	(** THE FOLLOWING FUNCTION IS NOT FULLY DEFINED *)
71	fun kBnd kenv tc =	fun kBnd kenv tc =
72	(if LT.tcp_var tc then	(if LT.tcp_var tc then
73	(let val (i,j) = LT.tcd_var tc	(let val (i,j) = LT.tcd_var tc
74	val (_,ks) = List.nth(kenv, i-1)	val (_,ks) = List.nth(kenv, i-1)
75	handle _ => bug "unexpected case A in kBnd"	handle _ => bug "unexpected case A in kBnd"
76	val (_,k) = List.nth(ks, j)	val k = List.nth(ks, j)
77	handle _ => bug "unexpected case B in kBnd"	handle _ => bug "unexpected case B in kBnd"
78	in if tk_eqv(tk_tbx, k) then KBOX else KTOP	in if tk_eqv(tk_tbx, k) then KBOX else KTOP
79	end)	end)
#	Line 90	Line 94
94	| tmBnd kenv (tc, x as TBND t) =	| tmBnd kenv (tc, x as TBND t) =
95	if tc_eqv(tc, t) then x else kmBnd kenv (tc, kBnd kenv t)	if tc_eqv(tc, t) then x else kmBnd kenv (tc, kBnd kenv t)
96
	datatype spkind
	= FULL
	| PART of bool list (* filter indicator; which one is gone *)
	datatype spinfo
	= NOSP
	| NARROW of (tvar * tkind) list
	| PARTSP of {ntvks: (tvar * tkind) list, nts: tyc list,
	masks: bool list}
	| FULLSP of tyc list * lvar list
97	(*	(*
98	* Given a list of default kinds, and a list of bnd information, a depth,	* Given a list of bnd information, return a list of filter info;
99	* and the (tyc list * lvar list) list info in the itable, returns the	* if all bounds are of TBND form, we got a full specialization,
100	* the spinfo.	* we return NONE.
101	*)	*)
102	fun bndGen(oks, bnds, d, info) =	fun bndFlt bnds =
103	let (** pass 1 **)	let fun h ((TBND _)::bs, r, z) = h(bs, false::r, z)
104	fun g ((TBND _)::bs, r, z) = g(bs, false::r, z)	| h (_::bs, r, _) = h(bs, true::r, false)
105	| g (_::bs, r, _) = g(bs, true::r, false)	| h ([], r, z) = if z then NONE else SOME (rev r)
106	| g ([], r, z) = if z then FULL else PART (rev r)	in h(bnds, [], true)
107	val spk = g(bnds, [], true)	end
108
109	val adj = case spk of FULL => (fn tc => tc)	(*
110		* Given a list of default kinds, and a list of bnd information, and a
111		* flag indicating whether it is full specialization;
112		* two pieces of information: resOp of (tkind list option * tyc list) option
113		* and the filterOp of (bool list) option
114		*)
115		fun bndGen(oks, bnds, fltOp, d) =
116		let val adj = case fltOp of NONE => (fn tc => tc)
117	| _ => (fn tc => LT.tc_adj(tc, d, DI.next d))	| _ => (fn tc => LT.tc_adj(tc, d, DI.next d))
118	(* if not full-specializations, we push depth one-level down *)	(* no full-specializations, so we push one-level down *)
	(** pass 2 **)
	val n = length oks
119
120	(* invariants: n = length bnds = length (the-resulting-ts) *)	fun h([], [], i, [], ts, b) = (NONE, rev ts, b)
121	fun h([], [], i, [], ts, _) =	| h([], [], i, ks, ts, b) = (SOME(rev ks), rev ts, b)
	(case info of [(_, xs)] => FULLSP(rev ts, xs)
	| _ => bug "unexpected case in bndGen 3")
	| h([], [], i, ks, ts, b) =
	if b then NOSP else
	if i = n then NARROW (rev ks)
	else (case spk
	of PART masks =>
	PARTSP {ntvks=rev ks, nts=rev ts, masks=masks}
	| _ => bug "unexpected case 1 in bndGen")
	| h(ok::oks, KTOP::bs, i, ks, ts, b) =
	h(oks, bs, i+1, ok::ks, (tvar i)::ts, b)
122	| h(ok::oks, (TBND tc)::bs, i, ks, ts, b) =	| h(ok::oks, (TBND tc)::bs, i, ks, ts, b) =
123	h(oks, bs, i, ks, (adj tc)::ts, false)	h(oks, bs, i, ks, (adj tc)::ts, false)
124	| h((tv,ok)::oks, KBOX::bs, i, ks, ts, b) =	| h(ok::oks, KTOP::bs, i, ks, ts, b) =
125		h(oks, bs, i+1, ok::ks, (tvar i)::ts, b)
126		| h(ok::oks, KBOX::bs, i, ks, ts, b) =
127	let (* val nk = if tk_eqv(tk_tbx, ok) then ok else tk_tbx *)	let (* val nk = if tk_eqv(tk_tbx, ok) then ok else tk_tbx *)
128	val (nk, b) =	val nk = if tk_eqv(tk_tmn, ok) then tk_tbx else ok
129	if tk_eqv(tk_tmn, ok) then (tk_tbx, false) else (ok, b)	in h(oks, bs, i+1, nk::ks, (tvar i)::ts, b)
	in h(oks, bs, i+1, (tv,nk)::ks, (tvar i)::ts, b)
130	end	end
131	| h _ = bug "unexpected cases 2 in bndGen"	| h _ = bug "unexpected cases in bndGen"
132
133	in h(oks, bnds, 0, [], [], true)	val (ksOp, ts, boring) = h(oks, bnds, 0, [], [], true)
134		in if boring then ((ksOp, NONE), NONE)
135		else ((ksOp, SOME ts), SOME fltOp)
136	end	end
137
138
#	Line 154	Line 141
141	****************************************************************************)	****************************************************************************)
142
143	(*	(*
144	* We maintain a table mapping each lvar to its definition depth,	* We maintain a table mapping each lvar to a list of its use,
145	* its type, and a list of its uses, indexed by its specific type	* indexed by its specific type instances.
	* instances.
146	*)	*)
147	exception ITABLE	exception ITABLE
148	exception DTABLE	exception DTABLE
149
	datatype dinfo
	= ESCAPE
	| NOCSTR
	| CSTR of bnds
150	type depth = DI.depth	type depth = DI.depth
151	type info = (tyc list * lvar list) list	type tkind = LD.tkind
152	type itable = info Intmap.intmap   (* lvar -> (tyc list * lvar) *)	type info = (tyc list * lvar) list
153		type itable = info Intmap.intmap
154	type dtable = (depth * dinfo) Intmap.intmap	type dtable = (depth * dinfo) Intmap.intmap
155	datatype infoEnv = IENV of (itable * (tvar * tkind) list) list * dtable	datatype infoEnv = IENV of (itable * tkind list) list * dtable
156
	(****************************************************************************
	*              UTILITY FUNCTIONS FOR TYPE SPECIALIZATIONS                  *
	****************************************************************************)
157	(** initializing a new info environment : unit -> infoEnv *)	(** initializing a new info environment : unit -> infoEnv *)
158	fun initInfoEnv () =	fun initInfoEnv () =
159	let val itable : itable = Intmap.new (32, ITABLE)	let val itable : itable = Intmap.new (32, ITABLE)
#	Line 195	Line 174
174	(*	(*
175	* Register a dtable entry; modify the least upper bound of a particular	* Register a dtable entry; modify the least upper bound of a particular
176	* type binding; notice I am only moving kind info upwards, not type	* type binding; notice I am only moving kind info upwards, not type
177	* info, I could move type info upwards though.	* info, I could move type info upwards though, but it is just some
178		* extra complications.
179	*)	*)
180	fun regDtable (IENV(kenv, dtable), v, infos) =	fun regDtable (IENV(kenv, dtable), v, infos) =
181	let val (dd, dinfo) =	let val (dd, dinfo) =
#	Line 204	Line 184
184	in (case dinfo	in (case dinfo
185	of ESCAPE => ()	of ESCAPE => ()
186	| _ =>	| _ =>
187	let fun h ((ts, _), ESCAPE) = ESCAPE	(let fun h ((ts, _), ESCAPE) = ESCAPE
188	| h ((ts, _), NOCSTR) = CSTR (map (kBnd kenv) ts)	| h ((ts, _), NOCSTR) = CSTR (map (kBnd kenv) ts)
189	| h ((ts, _), CSTR bnds) =	| h ((ts, _), CSTR bnds) =
190	let val nbnds = ListPair.map (kmBnd kenv) (ts, bnds)	let val nbnds = ListPair.map (kmBnd kenv) (ts, bnds)
#	Line 212	Line 192
192	end	end
193	val ndinfo = foldr h dinfo infos	val ndinfo = foldr h dinfo infos
194	in Intmap.add dtable (v, (dd, ndinfo))	in Intmap.add dtable (v, (dd, ndinfo))
195	end)	end))
196	end (* function regDtable *)	end
197
198	(*	(*
199	* Calculate the least upper bound of all type instances;	* Calculate the least upper bound of all type instances;
#	Line 238	Line 218
218	end	end
219
220	(** look and add a new type instance into the itable *)	(** look and add a new type instance into the itable *)
221	fun lookItable (IENV (itabs,dtab), d, v, ts, getlty) =	fun lookItable (IENV (itabs,dtab), d, v, ts) =
222	let val (dd, _) =	let val (dd, _) =
223	((Intmap.map dtab v) handle _ => bug "unexpected cases in lookItable")	((Intmap.map dtab v) handle _ => bug "unexpected cases in lookItable")
224
#	Line 250	Line 230
230	val nts = map (fn t => LT.tc_adj(t, d, nd)) ts	val nts = map (fn t => LT.tc_adj(t, d, nd)) ts
231	val xi = (Intmap.map itab v) handle _ => []	val xi = (Intmap.map itab v) handle _ => []
232
233	fun h ((ots,xs)::r) = if tcs_eqv(ots, nts) then (map VAR xs) else h r	fun h ((ots,x)::r) = if tcs_eqv(ots, nts) then (VAR x) else h r
234	| h [] = let val oldt = getlty (VAR v)	| h [] = let val nv =  mkv()
235	val bb = LT.lt_inst(oldt, ts)	val _ = Intmap.add itab (v, (nts, nv)::xi)
236	val nvs =  map mkv  bb	in VAR nv
	val _ = Intmap.add itab (v, (nts, nvs)::xi)
	in map VAR nvs
237	end	end
238	in h xi	in h xi
239	end	end
240
241	(** push a new layer of type abstraction : infoEnv -> infoEnv *)	(** push a new layer of type abstraction : infoEnv -> infoEnv *)
242	fun pushItable (IENV(itables, dtable), tvks) =	fun pushItable (IENV(itables, dtable), ks) =
243	let val nt : itable = Intmap.new(32, ITABLE)	let val nt : itable = Intmap.new(32, ITABLE)
244	in (IENV((nt,tvks)::itables, dtable))	in (IENV((nt,ks)::itables, dtable))
245	end	end
246
247	(*	(*
#	Line 276	Line 254
254	let val infos = Intmap.intMapToList nt	let val infos = Intmap.intMapToList nt
255	fun h ((v,info), hdr) =	fun h ((v,info), hdr) =
256	let val _ = regDtable(ienv, v, info)	let val _ = regDtable(ienv, v, info)
257	fun g ((ts, xs), e) = LET(xs, TAPP(VAR v, ts), e)	fun g ((ts, x), e) = LET(x, TAPP(VAR v, ts), e)
258	in fn e => foldr g (hdr e) info	in fn e => foldr g (hdr e) info
259	end	end
260	in foldr h ident infos	in foldr h ident infos
#	Line 287	Line 265
265	bug "unexpected empty information env in chkOut"	bug "unexpected empty information env in chkOut"
266	| chkOutEsc (ienv as IENV((nt,_)::_, _), v) =	| chkOutEsc (ienv as IENV((nt,_)::_, _), v) =
267	let val info = (Intmap.map nt v) handle _ => []	let val info = (Intmap.map nt v) handle _ => []
268	fun g ((ts, xs), e) = LET(xs, TAPP(VAR v, ts), e)	fun g ((ts, x), e) = LET(x, TAPP(VAR v, ts), e)
269	val hdr = fn e => foldr g e info	val hdr = fn e => foldr g e info
270	val _ = Intmap.rmv nt v  (* so that v won't be considered again *)	val _ = Intmap.rmv nt v  (* so that v won't be considered again *)
271	in hdr	in hdr
272	end	end
273
	fun chkOutEscs (ienv, vs) =
	foldr (fn (v,h) => (chkOutEsc(ienv, v)) o h) ident vs
274	(*	(*
275	* Check out a regular variable from the info env, build the header	* Check out a regular variable from the info env, build the header
276	* properly, of course, adjust the corresponding dtable entry.	* properly, of course, adjust the corresponding dtable entry.
#	Line 305	Line 280
280
281	| chkOutNorm (ienv as IENV((nt,_)::_, dtable), v, oks, d) =	| chkOutNorm (ienv as IENV((nt,_)::_, dtable), v, oks, d) =
282	let val info = (Intmap.map nt v) handle _ => []	let val info = (Intmap.map nt v) handle _ => []
283	val (_, dinfo) = sumDtable(ienv, v, info)	val (dd, dinfo) = sumDtable(ienv, v, info)
284	val spinfo =	val (resOp, filterOp) =
285	(case dinfo	(case dinfo
286	of ESCAPE => NOSP	of ESCAPE => ((NONE,NONE), NONE)
287	| NOCSTR => (* must be a dead function, let's double check *)	| NOCSTR => (* must be a dead function, let's double check *)
288	(case info of [] => NOSP	(case info of [] => ((NONE,NONE), NONE)
289	| _ => bug "unexpected cases in chkOutNorm")	| _ => bug "unexpected cases in chkOutNorm")
290	| CSTR bnds => bndGen(oks, bnds, d, info))	| CSTR bnds => bndGen(oks, bnds, bndFlt bnds, d))
291
292	fun mkhdr((ts, xs), e) =	fun tapp(e, ts, NONE) = TAPP(e, ts)
293	(case spinfo	| tapp(e, ts, SOME (NONE)) = SVAL e
294	of FULLSP _ => e	| tapp(e, ts, SOME (SOME flags)) =
	| PARTSP {masks, ...} =>
295	let fun h([], [], z) = rev z	let fun h([], [], z) = rev z
296	| h(a::r, b::s, z) =	| h(a::r, b::s, z) =
297	if b then h(r, s, a::z) else h(r, s, z)	if b then h(r, s, a::z) else h(r, s, z)
298	| h _ = bug "unexpected cases in tapp"	| h _ = bug "unexpected cases in tapp"
299	in LET(xs, TAPP(VAR v, h(ts, masks, [])), e)	in TAPP(e, h(ts, flags, []))
300	end	end
301	| _ => LET(xs, TAPP(VAR v, ts), e))
302	val hdr = fn e => foldr mkhdr e info	fun g ((ts, x), e) = LET(x, tapp(VAR v, ts, filterOp), e)
303		val hdr = fn e => foldr g e info
304	val _ = Intmap.rmv nt v  (* so that v won't be considered again *)	val _ = Intmap.rmv nt v  (* so that v won't be considered again *)
305	in (hdr, spinfo)	in (hdr, resOp)
306	end	end
307
308	(****************************************************************************	(****************************************************************************
309	*                         MAIN FUNCTION                                    *	*                         MAIN FUNCTIONS                                   *
310	****************************************************************************)	****************************************************************************)
311
312	fun specialize fdec =	(*
313	let	* Function transform has the following type:
314		*
315	val (click, num_click) = mk_click ()	*    infoEnv * lty cvt * tyc cvt * DI.depth -> (lexp -> lexp)
316		*
	(* In pass1, we calculate the old type of each variables in the FLINT
	* expression. The reason we can't merge this with the main pass is
	* that the main pass traverse the code in different order.
	* There must be a simpler way, but I didn't find one yet (ZHONG).
	*)
	val {getLty=getLtyGen, cleanUp} = Recover.recover fdec
	(* transform: infoEnv * DI.depth * lty cvt * tyc cvt
	* (value -> lty) * bool -> (lexp -> lexp)
317	*            where type 'a cvt = DI.depth -> 'a -> 'a	*            where type 'a cvt = DI.depth -> 'a -> 'a
318	* The 2nd argument is the depth of the resulting expression.	*
319	* The 3rd and 4th arguments are used to encode the type translations.	* The 2nd and 3rd arguments are used to encode the necessary type
320	* The 5th argument is the depth information in the original code,	* translations. The 4th argument is the depth the resulting expression
321	*    it is useful for the getlty.	* will be at.
	* The 6th argument is a flag that indicates whether we need to
	* flatten the return results of the current function.
322	*)	*)
323	fun transform (ienv, d, ltfg, tcfg, gtd, did_flat) =	fun transform (ienv, ltf, tcf, d) =
324	let val ltf = ltfg d	let
	val tcf = tcfg d
	val getlty = getLtyGen gtd
	(* we chkin and chkout polymorphic values only *)
	fun chkin v = entDtable (ienv, v, (d, ESCAPE))
	fun chkout v = chkOutEsc (ienv, v)
	fun chkins vs = app chkin vs
	fun chkouts vs = chkOutEscs (ienv, vs)
	(* lpvar : value -> value *)
	fun lpvar (u as (VAR v)) = (escDtable(ienv, v); u)
	| lpvar u = u
	(* lpvars : value list -> value list *)
	fun lpvars vs = map lpvar vs
	(* lpprim : primop -> primop *)
	fun lpprim (d, po, lt, ts) = (d, po, ltf lt, map tcf ts)
	(* lpdc : dcon -> dcon *)
	fun lpdc (s, rep, lt) = (s, rep, ltf lt)
	(* lplet : lvar * lexp -> (lexp -> lexp) *)
	fun lplet (v, e, cont) =
	let val _ = chkin v
	val ne = loop e
	in cont ((chkout v) ne)
	end
	(* lplets : lvar list * lexp -> (lexp -> lexp) *)
	and lplets (vs, e, cont) =
	let val _ = chkins vs
	val ne = loop e
	in cont ((chkouts vs) ne)
	end
	(* lpcon : con * lexp -> con * lexp *)
	and lpcon (DATAcon (dc, ts, v), e) =
	(DATAcon (lpdc dc, map tcf ts, v), lplet(v, e, fn x => x))
	| lpcon (c, e) = (c, loop e)
	(* lpfd : fundec -> fundec *** requires REWORK *** *)
	and lpfd (fk as FK_FCT, f, vts, be) =
	(fk, f, map (fn (v,t) => (v, ltf t)) vts,
	lplets (map #1 vts, be, fn e => e))
	| lpfd (fk as FK_FUN {fixed=(b1,b2),isrec,known,inline}, f, vts, be) =
	let (** first get the original arg and res types of f *)
	val ((b1',b2'), atys, rtys) = LT.ltd_arrow (getlty (VAR f))
	(** just a sanity check; should turn it off later **)
	val _ = if (b1=b1') andalso (b2=b2') then ()
	else bug "unexpected code in lpfd"
	(** get the newly specialized types **)
	val (natys, nrtys) = (map ltf atys, map ltf rtys)
	(** do we need flatten the arguments and the results *)
	val ((arg_raw, arg_ltys, _), unflatten) =
	PF.v_unflatten (natys, b1)
	val (body_raw, body_ltys, ndid_flat) = PF.t_flatten (nrtys, b2)
	(** process the function body *)
	val nbe =
	if ndid_flat = did_flat then loop be
	else transform (ienv, d, ltfg, tcfg, gtd, ndid_flat) be
	val (arg_lvs, nnbe) = unflatten (map #1 vts, nbe)
325
326	(** fix the isrec information *)	fun lpsv sv =
327	val nisrec = case isrec of NONE => NONE	(case sv
328	| SOME _ => SOME body_ltys	of (INT _ | WORD _ | INT32 _ | WORD32 _ | REAL _ | STRING _) => sv
329	val nfk = FK_FUN {isrec=nisrec, fixed=(arg_raw, body_raw),	| VAR v => (escDtable(ienv, v); sv)
330	known=known, inline=inline}	| PRIM (p, lt, ts) => PRIM(p, ltf d lt, map (tcf d) ts)
331		(* I don't think this is really necessary because all primops
332		have closed types, but probably it is quite cheap *)
333		| GENOP(dict, p, lt, ts) => GENOP(dict, p, ltf d lt, map (tcf d) ts))
334
335	in (nfk, f, ListPair.zip(arg_lvs, arg_ltys), nnbe)	fun loop le =
336	end	(case le
337		of SVAL sv => SVAL(lpsv sv)
338		| TAPP(VAR v, ts) =>
339		(SVAL(lookItable(ienv, d, v, map (tcf d) ts)))
340		| TAPP(sv, ts) => TAPP(lpsv sv, map (tcf d) ts)
341
342	(* lptf : tfundec * lexp -> lexp *** Invariant: ne2 has been processed *)	| TFN(ks, e) =>
343	and lptf ((v, tvks, e1), ne2) =	let val nienv = pushItable(ienv, ks)
	let val nienv = pushItable(ienv, tvks)
344	val nd = DI.next d	val nd = DI.next d
345	val ne1 = transform (nienv, nd, ltfg, tcfg, DI.next gtd, false) e1	val ne = transform (nienv, ltf, tcf, nd) e
346	val hdr = popItable nienv	val hdr = popItable nienv
347	in TFN((v, tvks, hdr ne1), ne2)	in TFN(ks, hdr ne)
	end
	(* loop : lexp -> lexp *)
	and loop le =
	(case le
	of RET vs =>
	if did_flat then
	let val vts = map (ltf o getlty) vs
	val ((_,_,ndid_flat),flatten) = PF.v_flatten(vts, false)
	in if ndid_flat then
	let val (nvs, hdr) = flatten vs
	in hdr(RET nvs)
	end
	else RET(lpvars vs)
	end
	else RET(lpvars vs)
	| LET(vs, e1, e2) =>
	let (* first get the original types *)
	val vtys = map (ltf o getlty o VAR) vs
	(* second get the newly specialized types *)
	val ((_, _, ndid_flat), unflatten) =
	PF.v_unflatten(vtys, false)
	(* treat the let type as always "cooked" *)
	val _ = chkins vs
	val ne2 = loop e2
	val ne2 = (chkouts vs) ne2
	val (nvs, ne2) = unflatten(vs, ne2)
	val ne1 =
	if ndid_flat = did_flat then loop e1
	else transform (ienv, d, ltfg, tcfg, gtd, ndid_flat) e1
	in LET(nvs, ne1, ne2)
	end
	| FIX(fdecs, e) => FIX(map lpfd fdecs, loop e)
	| APP(v, vs) =>
	let val vty =getlty v
	in if LT.ltp_fct vty then APP(lpvar v, lpvars vs)
	else
	let (** first get the original arg and res types of v *)
	val ((b1,b2), atys, rtys) = LT.ltd_arrow (getlty v)
	(** get the newly specialized types **)
	val (natys, nrtys) = (map ltf atys, map ltf rtys)
	val (nvs, hdr1) = (#2 (PF.v_flatten (atys, b1))) vs
	val hdr2 =
	if did_flat then ident
	else (let val ((_, _, ndid_flat), unflatten) =
	PF.v_unflatten(nrtys, b2)
	val fvs = map mkv nrtys
	in if ndid_flat then
	let val (nvs, xe) =
	unflatten(fvs, RET (map VAR fvs))
	in fn le => LET(nvs, le, xe)
	end
	else ident
	end)
	in hdr1 (APP(lpvar v, lpvars nvs))
	end
348	end	end
349
350	| TFN((v, tvks, e1), e2) =>	| LET(v, e1 as TFN(ks, be1), e2) =>
351	let val _ = entDtable(ienv, v, (d,NOCSTR))	let val _ = entDtable(ienv, v, (d,NOCSTR))
352	val ne2 = loop e2	val ne2 = loop e2
353	val ks = map #2 tvks	val (hdr, resOp) = chkOutNorm(ienv, v, ks, d)
354	val (hdr2, spinfo) = chkOutNorm(ienv, v, tvks, d)	val ne1 =
355	val ne2 = hdr2 ne2	(case resOp
356	in (case spinfo	of (NONE, NONE) => loop e1
357	of NOSP => lptf((v, tvks, e1), ne2)	| (SOME nks, NONE) => loop(TFN(nks, be1))
358	| NARROW ntvks => lptf((v, ntvks, e1), ne2)	| (NONE, SOME nts) =>
359	| PARTSP {ntvks, nts, ...} =>	let fun nltf nd lt =
360	(* assume nts is already shifted one level down *)	(LT.lt_sp_adj(ks, ltf (DI.next nd) lt, nts, nd-d, 0))
361	let val nienv = pushItable(ienv, ntvks)	fun ntcf nd tc =
362		(LT.tc_sp_adj(ks, tcf (DI.next nd) tc, nts, nd-d, 0))
363		in transform (ienv, nltf, ntcf, d) be1
364		end
365		(** this unfortunately relies on the value restrictions *)
366
367		| (SOME nks, SOME nts) =>
368		(** assume nts is already shifted one level down *)
369		let val nienv = pushItable(ienv, nks)
370	val xd = DI.next d	val xd = DI.next d
371	fun nltfg nd lt =
372		fun nltf nd lt =
373	let val lt1 = LT.lt_sp_sink(ks, lt, d, nd)	let val lt1 = LT.lt_sp_sink(ks, lt, d, nd)
374	val lt2 = ltfg (DI.next nd) lt1	val lt2 = ltf (DI.next nd) lt1
375	in (LT.lt_sp_adj(ks, lt2, nts, nd-xd, 0))	in (LT.lt_sp_adj(ks, lt2, nts, nd-xd, 0))
376	end	end
377	fun ntcfg nd tc =	fun ntcf nd tc =
378	let val tc1 = LT.tc_sp_sink(ks, tc, d, nd)	let val tc1 = LT.tc_sp_sink(ks, tc, d, nd)
379	val tc2 = tcfg (DI.next nd) tc1	val tc2 = tcf (DI.next nd) tc1
380	in (LT.tc_sp_adj(ks, tc2, nts, nd-xd, 0))	in (LT.tc_sp_adj(ks, tc2, nts, nd-xd, 0))
381	end	end
382	val ne1 =	val nbe1 = transform (nienv, nltf, ntcf, xd) be1
	transform (nienv, xd, nltfg, ntcfg,
	DI.next gtd, false) e1
383	val hdr0 = popItable nienv	val hdr0 = popItable nienv
384	in TFN((v, ntvks, hdr0 ne1), ne2)	in (TFN(nks, hdr0 nbe1))
	end
	| FULLSP (nts, xs) =>
	let fun nltfg nd lt =
	(LT.lt_sp_adj(ks, ltfg (DI.next nd) lt,
	nts, nd-d, 0))
	fun ntcfg nd tc =
	(LT.tc_sp_adj(ks, tcfg (DI.next nd) tc,
	nts, nd-d, 0))
	val ne1 = transform (ienv, d, nltfg, ntcfg,
	DI.next gtd, false) e1
	in click(); LET(xs, ne1, ne2)
385	end)	end)
386	end  (* case TFN *)	in LET(v, ne1, hdr ne2)
387		end
388
389	| TAPP(VAR v, ts) =>	| LET(v, e1, e2) =>
390	RET (lookItable(ienv, d, v, map tcf ts, getlty))	let val _ = entDtable(ienv, v, (d,ESCAPE))
391		val ne2 = loop e2
392		val hdr = chkOutEsc(ienv, v)
393		in LET(v, loop e1, hdr ne2)
394		end
395
396		| FN(v, t, e) =>
397		let val _ = entDtable(ienv, v, (d,ESCAPE))
398		val ne = loop e
399		val hdr = chkOutEsc(ienv, v)
400		in FN(v, ltf d t, hdr ne)
401		end
402
403		| FIX(vs, ts, es, eb) => FIX(vs, map (ltf d) ts, map loop es, loop eb)
404		(* ASSUMPTIONS WE MADE HERE: all lvars defined in vs can't be
405		polymorphic functions, that is, all ltys in ts must be
406		monomorphic types *)
407
408		| APP(sv1, sv2) => APP(lpsv sv1, lpsv sv2)
409
410		| PACK (lt, ts, nts, sv) =>
411		PACK(ltf d lt, map (tcf d) ts, map (tcf d) nts, lpsv sv)
412
413		| CON ((s,r,lt), ts, sv) =>
414		CON((s, r, ltf d lt), map (tcf d) ts, lpsv sv)
415
416		| DECON ((s,r,lt), ts, sv) =>
417		DECON((s, r, ltf d lt), map (tcf d) ts, lpsv sv)
418
419		| SWITCH (sv, reps, cases, opp) =>
420		let val nsv = lpsv sv
421		val ncases = map (fn (c, x) => (c, loop x)) cases
422		val nopp = (case opp of NONE => NONE
423		| SOME x => SOME(loop x))
424		in SWITCH(nsv, reps, ncases, nopp)
425		end
426
427		| RECORD vs => RECORD (map lpsv vs)
428		| SRECORD vs => SRECORD (map lpsv vs)
429		| VECTOR (vs, t) => VECTOR(map lpsv vs, tcf d t)
430		| SELECT (i, sv) => SELECT(i, lpsv sv)
431		| ETAG (sv, t) => ETAG(lpsv sv, ltf d t)
432		| RAISE (sv, t) => RAISE(lpsv sv, ltf d t)
433		| HANDLE (e, sv) => HANDLE(loop e, lpsv sv)
434		| _ => bug "unexpected lambda expression in transform")
435
	| SWITCH (v, csig, cases, opp) =>
	SWITCH(lpvar v, csig, map lpcon cases,
	case opp of NONE => NONE | SOME e => SOME(loop e))
	| CON (dc, ts, u, v, e) =>
	lplet (v, e, fn ne => CON(lpdc dc, map tcf ts, lpvar u, v, ne))
	| RECORD (rk as RK_VECTOR t, vs, v, e) =>
	lplet (v, e, fn ne => RECORD(RK_VECTOR (tcf t),
	lpvars vs, v, ne))
	| RECORD(rk, vs, v, e) =>
	lplet (v, e, fn ne => RECORD(rk, lpvars vs, v, ne))
	| SELECT (u, i, v, e) =>
	lplet (v, e, fn ne => SELECT(lpvar u, i, v, ne))
	| RAISE (sv, ts) =>
	let val nts = map ltf ts
	val nsv = lpvar sv
	in if did_flat then
	let val (_, nnts, _) = PF.t_flatten(nts, false)
	in RAISE(nsv, nnts)
	end
	else
	RAISE(nsv, nts)
	end
	| HANDLE (e, v) => HANDLE(loop e, lpvar v)
	| BRANCH (p, vs, e1, e2) =>
	BRANCH(lpprim p, lpvars vs, loop e1, loop e2)
	| PRIMOP (p, vs, v, e) =>
	lplet (v, e, fn ne => PRIMOP(lpprim p, lpvars vs, v, ne))
	| _ => bug "unexpected lexps in loop")
436	in loop	in loop
437	end (* function transform *)	end (* function transform *)
438
439	in	(* Definition of the main function *)
440	(case fdec	fun specLexp (FN(v, t, e)) =
441	of (fk as FK_FCT, f, vts, e) =>	let val tcf = fn (d : DI.depth) => fn (x : LD.tyc) => x
442	let val tcfg = fn (d : DI.depth) => fn (x : LD.tyc) => x	val ltf = fn (d : DI.depth) => fn (x : LD.lty) => x
	val ltfg = fn (d : DI.depth) => fn (x : LD.lty) => x
443	val ienv = initInfoEnv()	val ienv = initInfoEnv()
444	val d = DI.top	val d = DI.top
445	val _ = app (fn (x,_) => entDtable(ienv, x, (d, ESCAPE))) vts	val _ = entDtable(ienv, v, (d, ESCAPE))
446	val ne = transform (ienv, d, ltfg, tcfg, d, false) e	val ne = transform (ienv, ltf, tcf, d) e
447	val hdr = chkOutEscs (ienv, map #1 vts)	val hdr = chkOutEsc(ienv, v)
448	val nfdec = (fk, f, vts, hdr ne) before (cleanUp())
449	in if (num_click()) > 0 then LContract.lcontract nfdec	(*** invariant: itable should be empty ! ***)
450	(* if we did specialize, we run a round of lcontract on the result *)	in FN(v, t, hdr ne)
	else nfdec
451	end	end
452	| _ => bug "non FK_FCT program in specialize")	| specLexp _ = bug "unexpected lambda expressions specLexp"
	end (* function specialize *)
453
454	end (* toplevel local *)	end (* toplevel local *)
455	end (* structure Specialize *)	end (* structure Specialize *)

---

Colored Diff Long Colored Diff Unidiff Context Diff Side by Side

Legend: Removed from v.23   changed lines   Added in v.24

---

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