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

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

Parent Directory Parent Directory | Revision Log Revision Log


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

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