Mercurial > urweb

comparison src/rpcify.sml @ 956:d80734855790

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Don't try to check if functions are already tail-recursive
author Adam Chlipala <adamc@hcoop.net>
date Thu, 17 Sep 2009 17:17:49 -0400
parents 01a4d936395a
children 2831be2daf2e
comparison
equal deleted inserted replaced
955:01a4d936395a 956:d80734855790
168 val (d, st) = 168 val (d, st) =
169 case #1 d of 169 case #1 d of
170 DValRec vis => 170 DValRec vis =>
171 if List.exists (fn (_, _, _, e, _) => makesServerCall e) vis then 171 if List.exists (fn (_, _, _, e, _) => makesServerCall e) vis then
172 let 172 let
173 val all = foldl (fn ((_, n, _, _, _), all) => IS.add (all, n)) IS.empty vis 173 val rpc = foldl (fn ((_, n, _, _, _), rpc) =>
174 174 IS.add (rpc, n)) (#rpc st) vis
175 val usesRec = U.Exp.exists {kind = fn _ => false, 175
176 con = fn _ => false, 176 val (cpsed, vis') =
177 exp = fn ENamed n => IS.member (all, n) 177 foldl (fn (vi as (x, n, t, e, s), (cpsed, vis')) =>
178 | _ => false} 178 let
179 179 fun getArgs (t, acc) =
180 val noRec = not o usesRec 180 case #1 t of
181 181 TFun (dom, ran) =>
182 fun tailOnly (e, _) = 182 getArgs (ran, dom :: acc)
183 case e of 183 | _ => (rev acc, t)
184 EPrim _ => true 184 val (ts, ran) = getArgs (t, [])
185 | ERel _ => true 185 val ran = case #1 ran of
186 | ENamed _ => true 186 CApp (_, ran) => ran
187 | ECon (_, _, _, SOME e) => noRec e 187 | _ => raise Fail "Rpcify: Tail function not transactional"
188 | ECon _ => true 188 val len = length ts
189 | EFfi _ => true 189
190 | EFfiApp (_, _, es) => List.all noRec es 190 val loc = #2 e
191 | EApp (e1, e2) => noRec e2 andalso tailOnly e1 191 val args = ListUtil.mapi
192 | EAbs (_, _, _, e) => noRec e 192 (fn (i, _) =>
193 | ECApp (e1, _) => tailOnly e1 193 (ERel (len - i - 1), loc))
194 | ECAbs (_, _, e) => noRec e 194 ts
195 195 val k = (EFfi ("Basis", "return"), loc)
196 | EKAbs (_, e) => noRec e 196 val trans = (CFfi ("Basis", "transaction"), loc)
197 | EKApp (e1, _) => tailOnly e1 197 val k = (ECApp (k, trans), loc)
198 198 val k = (ECApp (k, ran), loc)
199 | ERecord xes => List.all (noRec o #2) xes 199 val k = (EApp (k, (EFfi ("Basis", "transaction_monad"),
200 | EField (e1, _, _) => noRec e1 200 loc)), loc)
201 | EConcat (e1, _, e2, _) => noRec e1 andalso noRec e2 201 val re = (ETailCall (n, args, k, ran, ran), loc)
202 | ECut (e1, _, _) => noRec e1 202 val (re, _) = foldr (fn (dom, (re, ran)) =>
203 | ECutMulti (e1, _, _) => noRec e1 203 ((EAbs ("x", dom, ran, re),
204 204 loc),
205 | ECase (e1, pes, _) => noRec e1 andalso List.all (tailOnly o #2) pes 205 (TFun (dom, ran), loc)))
206 206 (re, ran) ts
207 | EWrite e1 => noRec e1 207
208 208 val be = multiLiftExpInExp (len + 1) e
209 | EClosure (_, es) => List.all noRec es 209 val be = ListUtil.foldli
210 210 (fn (i, _, be) =>
211 | ELet (_, _, e1, e2) => noRec e1 andalso tailOnly e2 211 (EApp (be, (ERel (len - i), loc)), loc))
212 212 be ts
213 | EServerCall (_, es, (EAbs (_, _, _, e), _), _, _) => 213 val ne = (EFfi ("Basis", "bind"), loc)
214 List.all noRec es andalso tailOnly e 214 val ne = (ECApp (ne, trans), loc)
215 | EServerCall (_, es, e, _, _) => List.all noRec es andalso noRec e 215 val ne = (ECApp (ne, ran), loc)
216 216 val unit = (TRecord (CRecord ((KType, loc), []),
217 | ETailCall _ => raise Fail "Rpcify: ETailCall too early" 217 loc), loc)
218 218 val ne = (ECApp (ne, unit), loc)
219 fun tailOnlyF e = 219 val ne = (EApp (ne, (EFfi ("Basis", "transaction_monad"),
220 case #1 e of 220 loc)), loc)
221 EAbs (_, _, _, e) => tailOnlyF e 221 val ne = (EApp (ne, be), loc)
222 | ECAbs (_, _, e) => tailOnlyF e 222 val ne = (EApp (ne, (ERel 0, loc)), loc)
223 | EKAbs (_, e) => tailOnlyF e 223 val tunit = (CApp (trans, unit), loc)
224 | _ => tailOnly e 224 val kt = (TFun (ran, tunit), loc)
225 225 val ne = (EAbs ("k", kt, tunit, ne), loc)
226 val nonTail = foldl (fn ((_, n, _, e, _), nonTail) => 226 val (ne, res) = foldr (fn (dom, (ne, ran)) =>
227 if tailOnlyF e then 227 ((EAbs ("x", dom, ran, ne), loc),
228 nonTail 228 (TFun (dom, ran), loc)))
229 else 229 (ne, (TFun (kt, tunit), loc)) ts
230 IS.add (nonTail, n)) IS.empty vis 230 in
231 (IM.insert (cpsed, n, #1 re),
232 (x, n, res, ne, s) :: vis')
233 end)
234 (#cpsed st, []) vis
231 in 235 in
232 if IS.isEmpty nonTail then 236 ((DValRec (rev vis'), ErrorMsg.dummySpan),
233 (d, {exported = #exported st, 237 {exported = #exported st,
234 export_decls = #export_decls st, 238 export_decls = #export_decls st,
235 cpsed = #cpsed st, 239 cpsed = cpsed,
236 rpc = IS.union (#rpc st, all)}) 240 rpc = rpc})
237 else
238 let
239 val rpc = foldl (fn ((_, n, _, _, _), rpc) =>
240 IS.add (rpc, n)) (#rpc st) vis
241
242 val (cpsed, vis') =
243 foldl (fn (vi as (x, n, t, e, s), (cpsed, vis')) =>
244 if IS.member (nonTail, n) then
245 let
246 fun getArgs (t, acc) =
247 case #1 t of
248 TFun (dom, ran) =>
249 getArgs (ran, dom :: acc)
250 | _ => (rev acc, t)
251 val (ts, ran) = getArgs (t, [])
252 val ran = case #1 ran of
253 CApp (_, ran) => ran
254 | _ => raise Fail "Rpcify: Tail function not transactional"
255 val len = length ts
256
257 val loc = #2 e
258 val args = ListUtil.mapi
259 (fn (i, _) =>
260 (ERel (len - i - 1), loc))
261 ts
262 val k = (EFfi ("Basis", "return"), loc)
263 val trans = (CFfi ("Basis", "transaction"), loc)
264 val k = (ECApp (k, trans), loc)
265 val k = (ECApp (k, ran), loc)
266 val k = (EApp (k, (EFfi ("Basis", "transaction_monad"),
267 loc)), loc)
268 val re = (ETailCall (n, args, k, ran, ran), loc)
269 val (re, _) = foldr (fn (dom, (re, ran)) =>
270 ((EAbs ("x", dom, ran, re),
271 loc),
272 (TFun (dom, ran), loc)))
273 (re, ran) ts
274
275 val be = multiLiftExpInExp (len + 1) e
276 val be = ListUtil.foldli
277 (fn (i, _, be) =>
278 (EApp (be, (ERel (len - i), loc)), loc))
279 be ts
280 val ne = (EFfi ("Basis", "bind"), loc)
281 val ne = (ECApp (ne, trans), loc)
282 val ne = (ECApp (ne, ran), loc)
283 val unit = (TRecord (CRecord ((KType, loc), []),
284 loc), loc)
285 val ne = (ECApp (ne, unit), loc)
286 val ne = (EApp (ne, (EFfi ("Basis", "transaction_monad"),
287 loc)), loc)
288 val ne = (EApp (ne, be), loc)
289 val ne = (EApp (ne, (ERel 0, loc)), loc)
290 val tunit = (CApp (trans, unit), loc)
291 val kt = (TFun (ran, tunit), loc)
292 val ne = (EAbs ("k", kt, tunit, ne), loc)
293 val (ne, res) = foldr (fn (dom, (ne, ran)) =>
294 ((EAbs ("x", dom, ran, ne), loc),
295 (TFun (dom, ran), loc)))
296 (ne, (TFun (kt, tunit), loc)) ts
297 in
298 (IM.insert (cpsed, n, #1 re),
299 (x, n, res, ne, s) :: vis')
300 end
301 else
302 (cpsed, vi :: vis'))
303 (#cpsed st, []) vis
304 in
305 ((DValRec (rev vis'), ErrorMsg.dummySpan),
306 {exported = #exported st,
307 export_decls = #export_decls st,
308 cpsed = cpsed,
309 rpc = rpc})
310 end
311 end 241 end
312 else 242 else
313 (d, st) 243 (d, st)
314 | DVal (x, n, t, e, s) => 244 | DVal (x, n, t, e, s) =>
315 (d, 245 (d,