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

Parent Directory | Revision Log

---

Revision 423 - (view) (download)

1 :	monnier	215	(* copyright 1999 YALE FLINT project *)
2 :			(* monnier@cs.yale.edu *)
3 :
4 :			signature FSPLIT =
5 :			sig
6 :			type flint = FLINT.prog
7 :			val split: flint -> flint * flint option
8 :			end
9 :
10 :			structure FSplit :> FSPLIT =
11 :			struct
12 :
13 :			local
14 :			structure F = FLINT
15 :	monnier	423	structure S = IntBinarySet
16 :			structure M = IntBinaryMap
17 :	monnier	216	structure O = Option
18 :	monnier	215	structure OU = OptUtils
19 :			structure FU = FlintUtil
20 :	monnier	216	structure LT = LtyExtern
21 :	monnier	215	structure PO = PrimOp
22 :			structure PP = PPFlint
23 :	monnier	220	structure CTRL = FLINT_Control
24 :	monnier	215	in
25 :
26 :	monnier	220	val say = Control_Print.say
27 :	monnier	215	fun bug msg = ErrorMsg.impossible ("FSplit: "^msg)
28 :			fun buglexp (msg,le) = (say "\n"; PP.printLexp le; say " "; bug msg)
29 :			fun bugval (msg,v) = (say "\n"; PP.printSval v; say " "; bug msg)
30 :			fun assert p = if p then () else bug ("assertion failed")
31 :
32 :			type flint = F.prog
33 :			val mklv = LambdaVar.mkLvar
34 :			val cplv = LambdaVar.dupLvar
35 :
36 :	monnier	423	fun addv (s,F.VAR lv) = S.add(s, lv)
37 :	monnier	215	| addv (s,_) = s
38 :			fun addvs (s,vs) = foldl (fn (v,s) => addv(s, v)) s vs
39 :	monnier	423	fun rmvs (s,lvs) = foldl (fn (l,s) => S.delete(s, l)) s lvs
40 :	monnier	215
41 :	monnier	220	exception Unknown
42 :	monnier	215
43 :			fun split (fdec as (fk,f,args,body)) = let
44 :	monnier	216	val {getLty,addLty,...} = Recover.recover (fdec, false)
45 :	monnier	215
46 :	monnier	220	val m = Intmap.new(64, Unknown)
47 :			fun addpurefun f = Intmap.add m (f, false)
48 :			fun funeffect f = (Intmap.map m f) handle Uknown => true
49 :
50 :	monnier	216	(* sexp: env -> lexp -> (leE, leI, fvI, leRet)
51 :			* - env: IntSetF.set current environment
52 :			* - lexp: lexp expression to split
53 :			* - leRet: lexp the core return expression of lexp
54 :			* - leE: lexp -> lexp recursively split lexp: leE leRet == lexp
55 :			* - leI: lexp option inlinable part of lexp (if any)
56 :			* - fvI: IntSetF.set free variables of leI: FU.freevars leI == fvI
57 :			*
58 :			* sexp splits the lexp into an expansive part and an inlinable part.
59 :			* The inlinable part is guaranteed to be side-effect free.
60 :			* The expansive part doesn't bother to eliminate unused copies of
61 :			* elements copied to the inlinable part.
62 :			* If the inlinable part cannot be constructed, leI is set to F.RET[].
63 :			* This implies that fvI == S.empty, which in turn prevents us from
64 :			* mistakenly adding anything to leI.
65 :	monnier	215	*)
66 :	monnier	216	fun sexp env lexp =
67 :	monnier	220	let
68 :	monnier	216	(* non-side effecting binds are copied to leI if exported *)
69 :			fun let1 (le,lewrap,lv,vs,effect) =
70 :	monnier	423	let val (leE,leI,fvI,leRet) = sexp (S.add(env, lv)) le
71 :	monnier	216	val leE = lewrap o leE
72 :	monnier	423	in if effect orelse not (S.member(fvI, lv))
73 :	monnier	216	then (leE, leI, fvI, leRet)
74 :	monnier	423	else (leE, lewrap leI, addvs(S.delete(fvI, lv), vs), leRet)
75 :	monnier	216	end
76 :	monnier	215
77 :	monnier	216	in case lexp
78 :			(* we can completely move both RET and TAPP to the I part *)
79 :			of F.RECORD (rk,vs,lv,le as F.RET [F.VAR lv']) =>
80 :			if lv' = lv
81 :			then (fn e => e, lexp, addvs(S.empty, vs), lexp)
82 :			else (fn e => e, le, S.singleton lv', le)
83 :			| F.RET vs =>
84 :			(fn e => e, lexp, addvs(S.empty, vs), lexp)
85 :			| F.TAPP (F.VAR tf,tycs) =>
86 :			(fn e => e, lexp, S.singleton tf, lexp)
87 :	monnier	215
88 :	monnier	216	(* recursive splittable lexps *)
89 :			| F.FIX (fdecs,le) => sfix env (fdecs, le)
90 :			| F.TFN (tfdec,le) => stfn env (tfdec, le)
91 :	monnier	215
92 :	monnier	216	(* binding-lexps *)
93 :			| F.CON (dc,tycs,v,lv,le) =>
94 :			let1(le, fn e => F.CON(dc, tycs, v, lv, e), lv, [v], false)
95 :			| F.RECORD (rk,vs,lv,le) =>
96 :			let1(le, fn e => F.RECORD(rk, vs, lv, e), lv, vs, false)
97 :			| F.SELECT (v,i,lv,le) =>
98 :			let1(le, fn e => F.SELECT(v, i, lv, e), lv, [v], false)
99 :			| F.PRIMOP (po,vs,lv,le) =>
100 :			let1(le, fn e => F.PRIMOP(po, vs, lv, e), lv, vs, PO.effect(#2 po))
101 :
102 :			(* IMPROVEME: lvs should not be restricted to [lv] *)
103 :			| F.LET(lvs as [lv],body as F.TAPP (v,tycs),le) =>
104 :			let1(le, fn e => F.LET(lvs, body, e), lv, [v], false)
105 :	monnier	220	| F.LET (lvs as [lv],body as F.APP (v as F.VAR f,vs),le) =>
106 :			let1(le, fn e => F.LET(lvs, body, e), lv, v::vs, funeffect f)
107 :	monnier	216
108 :			| F.SWITCH (v,ac,[(dc as F.DATAcon(_,_,lv),le)],NONE) =>
109 :			let1(le, fn e => F.SWITCH(v, ac, [(dc, e)], NONE), lv, [v], false)
110 :
111 :			| F.LET (lvs,body,le) =>
112 :	monnier	423	let val (leE,leI,fvI,leRet) = sexp (S.union(S.addList(S.empty, lvs), env)) le
113 :	monnier	216	in (fn e => F.LET(lvs, body, leE e), leI, fvI, leRet)
114 :			end
115 :
116 :	monnier	220	(* useless sophistication *)
117 :	monnier	216	| F.APP (F.VAR f,args) =>
118 :			if funeffect f
119 :			then (fn e => e, F.RET[], S.empty, lexp)
120 :			else (fn e => e, lexp, addvs(S.singleton f, args), lexp)
121 :	monnier	220
122 :			(* other non-binding lexps result in unsplittable functions *)
123 :	monnier	216	| (F.APP _ | F.TAPP _) => bug "strange (T)APP"
124 :	monnier	220	| (F.SWITCH _ | F.RAISE _ | F.BRANCH _ | F.HANDLE _) =>
125 :	monnier	216	(fn e => e, F.RET[], S.empty, lexp)
126 :			end
127 :
128 :			(* Functions definitions fall into the following categories:
129 :			* - inlinable: if exported, copy to leI
130 :			* - (mutually) recursive: don't bother
131 :			* - non-inlinable non-recursive: split recursively *)
132 :			and sfix env (fdecs,le) =
133 :	monnier	423	let val nenv = S.union(S.addList(S.empty, map #2 fdecs), env)
134 :	monnier	216	val (leE,leI,fvI,leRet) = sexp nenv le
135 :			val nleE = fn e => F.FIX(fdecs, leE e)
136 :			in case fdecs
137 :	monnier	220	of [({inline=inl as (F.IH_ALWAYS | F.IH_MAYBE _),...},f,args,body)] =>
138 :			let val min = case inl of F.IH_MAYBE(n,_) => n | _ => 0
139 :	monnier	423	in if not(S.member(fvI, f)) orelse min > !CTRL.splitThreshold
140 :	monnier	220	then (nleE, leI, fvI, leRet)
141 :			else (nleE, F.FIX(fdecs, leI),
142 :			rmvs(S.union(fvI, FU.freevars body),
143 :			f::(map #1 args)),
144 :			leRet)
145 :			end
146 :	monnier	216	| [fdec as (fk as {cconv=F.CC_FCT,...},_,_,_)] =>
147 :			sfdec env (leE,leI,fvI,leRet) fdec
148 :
149 :			| _ => (nleE, leI, fvI, leRet)
150 :			end
151 :
152 :			and sfdec env (leE,leI,fvI,leRet) (fk,f,args,body) =
153 :	monnier	423	let val benv = S.union(S.addList(S.empty, map #1 args), env)
154 :	monnier	216	val (bodyE,bodyI,fvbI,bodyRet) = sexp benv body
155 :			in case bodyI
156 :			of F.RET[] =>
157 :			(fn e => F.FIX([(fk, f, args, bodyE bodyRet)], e),
158 :			leI, fvI, leRet)
159 :			| _ =>
160 :	monnier	423	let val fvbIs = S.listItems(S.difference(fvbI, benv))
161 :	monnier	217	val (nfk,fkE) = OU.fk_wrap(fk, NONE)
162 :
163 :	monnier	216	(* fdecE *)
164 :			val fE = cplv f
165 :			val fErets = (map F.VAR fvbIs)
166 :			val bodyE = bodyE(F.RET fErets)
167 :			(* val tmp = mklv()
168 :			val bodyE = bodyE(F.RECORD(F.RK_STRUCT, map F.VAR fvbIs,
169 :			tmp, F.RET[F.VAR tmp])) *)
170 :	monnier	217	val fdecE = (fkE, fE, args, bodyE)
171 :	monnier	216	val fElty = LT.ltc_fct(map #2 args, map getLty fErets)
172 :			val _ = addLty(fE, fElty)
173 :
174 :			(* fdecI *)
175 :			val fkI = {inline=F.IH_ALWAYS, cconv=F.CC_FCT,
176 :			known=true, isrec=NONE}
177 :			val argsI =
178 :			(map (fn lv => (lv, getLty(F.VAR lv))) fvbIs) @ args
179 :			(* val argI = mklv()
180 :			val argsI = (argI, LT.ltc_str(map (getLty o F.VAR) fvbIs))::args
181 :
182 :			val (_,bodyI) = foldl (fn (lv,(n,le)) =>
183 :			(n+1, F.SELECT(F.VAR argI, n, lv, le)))
184 :			(0, bodyI) fvbIs *)
185 :			val fdecI as (_,fI,_,_) = FU.copyfdec(fkI,f,argsI,bodyI)
186 :	monnier	220	val _ = addpurefun fI
187 :	monnier	216
188 :			(* nfdec *)
189 :			val nargs = map (fn (v,t) => (cplv v, t)) args
190 :			val argsv = map (fn (v,t) => F.VAR v) nargs
191 :			val nbody =
192 :			let val lvs = map cplv fvbIs
193 :			in F.LET(lvs, F.APP(F.VAR fE, argsv),
194 :			F.APP(F.VAR fI, (map F.VAR lvs)@argsv))
195 :	monnier	215	end
196 :	monnier	216	(* let val lv = mklv()
197 :			in F.LET([lv], F.APP(F.VAR fE, argsv),
198 :			F.APP(F.VAR fI, (F.VAR lv)::argsv))
199 :			end *)
200 :			val nfdec = (nfk, f, nargs, nbody)
201 :
202 :			(* and now, for the whole F.FIX *)
203 :			fun nleE e =
204 :			F.FIX([fdecE], F.FIX([fdecI], F.FIX([nfdec], leE e)))
205 :
206 :	monnier	423	in if not(S.member(fvI, f)) then (nleE, leI, fvI, leRet)
207 :	monnier	216	else (nleE,
208 :			F.FIX([fdecI], F.FIX([nfdec], leI)),
209 :	monnier	423	S.add(S.union(S.delete(fvI, f), S.intersection(env, fvbI)), fE),
210 :	monnier	216	leRet)
211 :			end
212 :			end
213 :	monnier	215
214 :	monnier	216	(* TFNs are kinda like FIX except there's no recursion *)
215 :	monnier	220	and stfn env (tfdec as (tfk,tf,args,body),le) =
216 :			let val (bodyE,bodyI,fvbI,bodyRet) =
217 :			if #inline tfk = F.IH_ALWAYS
218 :			then (fn e => body, body, FU.freevars body, body)
219 :			else sexp env body
220 :	monnier	423	val nenv = S.add(env, tf)
221 :	monnier	216	val (leE,leI,fvI,leRet) = sexp nenv le
222 :	monnier	423	in case (bodyI, S.listItems(S.difference(fvbI, env)))
223 :	monnier	216	of ((F.RET _ | F.RECORD(_,_,_,F.RET _)),_) =>
224 :			(* split failed *)
225 :	monnier	220	(fn e => F.TFN((tfk, tf, args, bodyE bodyRet), leE e),
226 :			leI, fvI, leRet)
227 :	monnier	216	| (_,[]) =>
228 :			(* everything was split out *)
229 :	monnier	220	let val ntfdec = ({inline=F.IH_ALWAYS}, tf, args, bodyE bodyRet)
230 :			val nlE = fn e => F.TFN(ntfdec, leE e)
231 :	monnier	423	in if not(S.member(fvI, tf)) then (nlE, leI, fvI, leRet)
232 :	monnier	220	else (nlE, F.TFN(ntfdec, leI),
233 :	monnier	423	S.delete(S.union(fvI, fvbI), tf), leRet)
234 :	monnier	216	end
235 :			| (_,fvbIs) =>
236 :			let (* tfdecE *)
237 :			val tfE = cplv tf
238 :			val tfEvs = map F.VAR fvbIs
239 :			val bodyE = bodyE(F.RET tfEvs)
240 :			val tfElty = LT.lt_nvpoly(args, map getLty tfEvs)
241 :			val _ = addLty(tfE, tfElty)
242 :	monnier	215
243 :	monnier	216	(* tfdecI *)
244 :	monnier	220	val tfkI = {inline=F.IH_ALWAYS}
245 :	monnier	216	val argsI = map (fn (v,k) => (cplv v, k)) args
246 :			val tmap = ListPair.map (fn (a1,a2) =>
247 :			(#1 a1, LT.tcc_nvar(#1 a2)))
248 :			(args, argsI)
249 :			val bodyI = FU.copy tmap M.empty
250 :			(F.LET(fvbIs, F.TAPP(F.VAR tfE, map #2 tmap),
251 :			bodyI))
252 :			(* F.TFN *)
253 :			fun nleE e =
254 :	monnier	220	F.TFN((tfk, tfE, args, bodyE),
255 :			F.TFN((tfkI, tf, argsI, bodyI), leE e))
256 :	monnier	215
257 :	monnier	423	in if not(S.member(fvI, tf)) then (nleE, leI, fvI, leRet)
258 :	monnier	216	else (nleE,
259 :	monnier	220	F.TFN((tfkI, tf, argsI, bodyI), leI),
260 :	monnier	423	S.add(S.union(S.delete(fvI, tf), S.intersection(env, fvbI)), tfE),
261 :	monnier	216	leRet)
262 :			end
263 :			end
264 :	monnier	215
265 :	monnier	216	(* here, we use B-decomposition, so the args should not be
266 :			* considered as being in scope *)
267 :			val (bodyE,bodyI,fvbI,bodyRet) = sexp S.empty body
268 :			in case (bodyI, bodyRet)
269 :			of (F.RET _,_) => ((fk, f, args, bodyE bodyRet), NONE)
270 :			| (_,F.RECORD (rk,vs,lv,F.RET[lv'])) =>
271 :	monnier	423	let val fvbIs = S.listItems fvbI
272 :	monnier	215
273 :	monnier	216	(* fdecE *)
274 :			val bodyE = bodyE(F.RECORD(rk, vs@(map F.VAR fvbIs), lv, F.RET[lv']))
275 :			val fdecE as (_,fE,_,_) = (fk, cplv f, args, bodyE)
276 :	monnier	215
277 :	monnier	216	(* fdecI *)
278 :			val argI = mklv()
279 :			val argLtys = (map getLty vs) @ (map (getLty o F.VAR) fvbIs)
280 :			val argsI = [(argI, LT.ltc_str argLtys)]
281 :			val (_,bodyI) = foldl (fn (lv,(n,le)) =>
282 :			(n+1, F.SELECT(F.VAR argI, n, lv, le)))
283 :			(length vs, bodyI) fvbIs
284 :			val fdecI as (_,fI,_,_) = FU.copyfdec (fk, f, argsI, bodyI)
285 :
286 :	monnier	215	val nargs = map (fn (v,t) => (cplv v, t)) args
287 :			in
288 :	monnier	217	(fdecE, SOME fdecI)
289 :			(* ((fk, f, nargs,
290 :	monnier	215	F.FIX([fdecE],
291 :			F.FIX([fdecI],
292 :	monnier	216	F.LET([argI],
293 :			F.APP(F.VAR fE, map (F.VAR o #1) nargs),
294 :			F.APP(F.VAR fI, [F.VAR argI]))))),
295 :	monnier	217	NONE) *)
296 :	monnier	215	end
297 :	monnier	216
298 :	monnier	382	| _ => (fdec, NONE) (* sorry, can't do that *)
299 :			(* (PPFlint.printLexp bodyRet; bug "couldn't find the returned record") *)
300 :	monnier	216
301 :	monnier	215	end
302 :
303 :			end
304 :			end

---

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