Mercurial > urweb

comparison src/especialize.sml @ 488:5521bb0b4014

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Get preliminary ThreadedBlog working
author Adam Chlipala <adamc@hcoop.net>
date Tue, 11 Nov 2008 15:12:24 -0500
parents 33d5bd69da00
children 3f20c22098af
comparison
equal deleted inserted replaced
487:33d5bd69da00 488:5521bb0b4014
41 41
42 structure KM = BinaryMapFn(K) 42 structure KM = BinaryMapFn(K)
43 structure IM = IntBinaryMap 43 structure IM = IntBinaryMap
44 structure IS = IntBinarySet 44 structure IS = IntBinarySet
45 45
46 val sizeOf = U.Exp.fold {kind = fn (_, n) => n, 46 val freeVars = U.Exp.foldB {kind = fn (_, xs) => xs,
47 con = fn (_, n) => n, 47 con = fn (_, _, xs) => xs,
48 exp = fn (_, n) => n + 1} 48 exp = fn (bound, e, xs) =>
49 0
50
51 val isOpen = U.Exp.existsB {kind = fn _ => false,
52 con = fn ((nc, _), c) =>
53 case c of
54 CRel n => n >= nc
55 | _ => false,
56 exp = fn ((_, ne), e) =>
57 case e of 49 case e of
58 ERel n => n >= ne 50 ERel x =>
59 | _ => false, 51 if x >= bound then
60 bind = fn ((nc, ne), b) => 52 IS.add (xs, x - bound)
53 else
54 xs
55 | _ => xs,
56 bind = fn (bound, b) =>
61 case b of 57 case b of
62 U.Exp.RelC _ => (nc + 1, ne) 58 U.Exp.RelE _ => bound + 1
63 | U.Exp.RelE _ => (nc, ne + 1) 59 | _ => bound}
64 | _ => (nc, ne)} 60 0 IS.empty
65 (0, 0) 61
66 62 fun positionOf (v : int, ls) =
67 fun baseBad (e, _) = 63 let
68 case e of 64 fun pof (pos, ls) =
69 EAbs (_, _, _, e) => sizeOf e > 20 65 case ls of
70 | ENamed _ => false 66 [] => raise Fail "Defunc.positionOf"
71 | _ => true 67 | v' :: ls' =>
72 68 if v = v' then
73 fun isBad e = 69 pos
74 case e of 70 else
75 (ERecord xes, _) => 71 pof (pos + 1, ls')
76 length xes > 10 72 in
77 orelse List.exists (fn (_, e, _) => baseBad e) xes 73 pof (0, ls)
78 | _ => baseBad e 74 end
79 75
80 fun skeyIn e = 76 fun squish fvs =
81 if isBad e orelse isOpen e then 77 U.Exp.mapB {kind = fn k => k,
82 NONE 78 con = fn _ => fn c => c,
83 else 79 exp = fn bound => fn e =>
84 SOME e 80 case e of
85 81 ERel x =>
86 fun skeyOut e = e 82 if x >= bound then
83 ERel (positionOf (x - bound, fvs) + bound)
84 else
85 e
86 | _ => e,
87 bind = fn (bound, b) =>
88 case b of
89 U.Exp.RelE _ => bound + 1
90 | _ => bound}
91 0
87 92
88 type func = { 93 type func = {
89 name : string, 94 name : string,
90 args : int KM.map, 95 args : int KM.map,
91 body : exp, 96 body : exp,
97 maxName : int, 102 maxName : int,
98 funcs : func IM.map, 103 funcs : func IM.map,
99 decls : (string * int * con * exp * string) list 104 decls : (string * int * con * exp * string) list
100 } 105 }
101 106
102 fun kind (k, st) = (k, st) 107 fun kind x = x
103 fun con (c, st) = (c, st) 108 fun default (_, x, st) = (x, st)
104 109
105 fun specialize' file = 110 fun specialize' file =
106 let 111 let
107 fun default (_, fs) = fs 112 fun default' (_, fs) = fs
108 113
109 fun actionableExp (e, fs) = 114 fun actionableExp (e, fs) =
110 case e of 115 case e of
111 ERecord xes => 116 ERecord xes =>
112 foldl (fn (((CName s, _), e, _), fs) => 117 foldl (fn (((CName s, _), e, _), fs) =>
125 | (_, fs) => fs) 130 | (_, fs) => fs)
126 fs xes 131 fs xes
127 | _ => fs 132 | _ => fs
128 133
129 val actionable = 134 val actionable =
130 U.File.fold {kind = default, 135 U.File.fold {kind = default',
131 con = default, 136 con = default',
132 exp = actionableExp, 137 exp = actionableExp,
133 decl = default} 138 decl = default'}
134 IS.empty file 139 IS.empty file
135 140
136 fun exp (e, st : state) = 141 fun bind (env, b) =
142 case b of
143 U.Decl.RelC (x, k) => E.pushCRel env x k
144 | U.Decl.NamedC (x, n, k, co) => E.pushCNamed env x n k co
145 | U.Decl.RelE (x, t) => E.pushERel env x t
146 | U.Decl.NamedE (x, n, t, eo, s) => E.pushENamed env x n t eo s
147
148 fun exp (env, e, st : state) =
137 let 149 let
138 fun getApp' e = 150 fun getApp e =
139 case e of 151 case e of
140 ENamed f => SOME (f, [], []) 152 ENamed f => SOME (f, [])
141 | EApp (e1, e2) => 153 | EApp (e1, e2) =>
142 (case getApp' (#1 e1) of 154 (case getApp (#1 e1) of
143 NONE => NONE 155 NONE => NONE
144 | SOME (f, xs, xs') => 156 | SOME (f, xs) => SOME (f, xs @ [e2]))
145 let
146 val k =
147 if List.null xs' then
148 skeyIn e2
149 else
150 NONE
151 in
152 case k of
153 NONE => SOME (f, xs, xs' @ [e2])
154 | SOME k => SOME (f, xs @ [k], xs')
155 end)
156 | _ => NONE 157 | _ => NONE
157
158 fun getApp e =
159 case getApp' e of
160 NONE => NONE
161 | SOME (f, xs, xs') =>
162 if List.all (fn (ERecord [], _) => true | _ => false) xs then
163 SOME (f, [], xs @ xs')
164 else
165 SOME (f, xs, xs')
166 in 158 in
167 case getApp e of 159 case getApp e of
168 NONE => (e, st) 160 NONE => (e, st)
169 | SOME (f, [], []) => (e, st) 161 | SOME (f, xs) =>
170 | SOME (f, [], xs') =>
171 (case IM.find (#funcs st, f) of
172 NONE => (e, st)
173 | SOME {typ, body, ...} =>
174 let
175 val functionInside = U.Con.exists {kind = fn _ => false,
176 con = fn TFun _ => true
177 | CFfi ("Basis", "transaction") => true
178 | _ => false}
179
180 fun hasFunarg (t, xs) =
181 case (t, xs) of
182 ((TFun (dom, ran), _), _ :: xs) =>
183 functionInside dom
184 orelse hasFunarg (ran, xs)
185 | _ => false
186 in
187 if List.all (fn (ERel _, _) => false | _ => true) xs'
188 andalso List.exists (fn (ERecord [], _) => false | _ => true) xs'
189 andalso not (IS.member (actionable, f))
190 andalso hasFunarg (typ, xs') then
191 let
192 val e = foldl (fn (arg, e) => (EApp (e, arg), ErrorMsg.dummySpan))
193 body xs'
194 in
195 (*Print.prefaces "Unfolded"
196 [("e", CorePrint.p_exp CoreEnv.empty e)];*)
197 (#1 e, st)
198 end
199 else
200 (e, st)
201 end)
202 | SOME (f, xs, xs') =>
203 case IM.find (#funcs st, f) of 162 case IM.find (#funcs st, f) of
204 NONE => (e, st) 163 NONE => (e, st)
205 | SOME {name, args, body, typ, tag} => 164 | SOME {name, args, body, typ, tag} =>
206 case KM.find (args, xs) of 165 let
207 SOME f' => (#1 (foldl (fn (arg, e) => (EApp (e, arg), ErrorMsg.dummySpan)) 166 val functionInside = U.Con.exists {kind = fn _ => false,
208 (ENamed f', ErrorMsg.dummySpan) xs'), 167 con = fn TFun _ => true
209 st) 168 | CFfi ("Basis", "transaction") => true
210 | NONE => 169 | _ => false}
211 let 170 val loc = ErrorMsg.dummySpan
212 fun subBody (body, typ, xs) = 171
213 case (#1 body, #1 typ, xs) of 172 fun findSplit (xs, typ, fxs, fvs) =
214 (_, _, []) => SOME (body, typ) 173 case (#1 typ, xs) of
215 | (EAbs (_, _, _, body'), TFun (_, typ'), x :: xs) => 174 (TFun (dom, ran), e :: xs') =>
216 let 175 if functionInside dom then
217 val body'' = E.subExpInExp (0, skeyOut x) body' 176 findSplit (xs',
218 in 177 ran,
219 subBody (body'', 178 e :: fxs,
220 typ', 179 IS.union (fvs, freeVars e))
221 xs) 180 else
222 end 181 (rev fxs, xs, fvs)
223 | _ => NONE 182 | _ => (rev fxs, xs, fvs)
224 in 183
225 case subBody (body, typ, xs) of 184 val (fxs, xs, fvs) = findSplit (xs, typ, [], IS.empty)
226 NONE => (e, st) 185
227 | SOME (body', typ') => 186 val fxs' = map (squish (IS.listItems fvs)) fxs
187
188 fun firstRel () =
189 case fxs' of
190 (ERel _, _) :: _ => true
191 | _ => false
192 in
193 if firstRel ()
194 orelse List.all (fn (ERel _, _) => true
195 | _ => false) fxs' then
196 (e, st)
197 else
198 case KM.find (args, fxs') of
199 SOME f' =>
228 let 200 let
229 (*val () = Print.prefaces "sub'd" 201 val e = (ENamed f', loc)
230 [("body'", CorePrint.p_exp CoreEnv.empty body')]*) 202 val e = IS.foldr (fn (arg, e) => (EApp (e, (ERel arg, loc)), loc))
231 203 e fvs
232 val f' = #maxName st 204 val e = foldl (fn (arg, e) => (EApp (e, arg), loc))
233 val funcs = IM.insert (#funcs st, f, {name = name, 205 e xs
234 args = KM.insert (args,
235 xs, f'),
236 body = body,
237 typ = typ,
238 tag = tag})
239 val st = {
240 maxName = f' + 1,
241 funcs = funcs,
242 decls = #decls st
243 }
244
245 (*val () = print ("Created " ^ Int.toString f' ^ " from "
246 ^ Int.toString f ^ "\n")
247 val () = Print.prefaces "body'"
248 [("body'", CorePrint.p_exp CoreEnv.empty body')]*)
249 val (body', st) = specExp st body'
250 (*val () = Print.prefaces "body''"
251 [("body'", CorePrint.p_exp CoreEnv.empty body')]*)
252 val e' = foldl (fn (arg, e) => (EApp (e, arg), ErrorMsg.dummySpan))
253 (ENamed f', ErrorMsg.dummySpan) xs'
254 in 206 in
255 (#1 e', 207 (*Print.prefaces "Brand new (reuse)"
256 {maxName = #maxName st, 208 [("e'", CorePrint.p_exp env e)];*)
257 funcs = #funcs st, 209 (#1 e, st)
258 decls = (name, f', typ', body', tag) :: #decls st})
259 end 210 end
260 end 211 | NONE =>
212 let
213 fun subBody (body, typ, fxs') =
214 case (#1 body, #1 typ, fxs') of
215 (_, _, []) => SOME (body, typ)
216 | (EAbs (_, _, _, body'), TFun (_, typ'), x :: fxs'') =>
217 let
218 val body'' = E.subExpInExp (0, x) body'
219 in
220 subBody (body'',
221 typ',
222 fxs'')
223 end
224 | _ => NONE
225 in
226 case subBody (body, typ, fxs') of
227 NONE => (e, st)
228 | SOME (body', typ') =>
229 let
230 val f' = #maxName st
231 val args = KM.insert (args, fxs', f')
232 val funcs = IM.insert (#funcs st, f, {name = name,
233 args = args,
234 body = body,
235 typ = typ,
236 tag = tag})
237 val st = {
238 maxName = f' + 1,
239 funcs = funcs,
240 decls = #decls st
241 }
242
243 (*val () = Print.prefaces "specExp"
244 [("f", CorePrint.p_exp env (ENamed f, loc)),
245 ("f'", CorePrint.p_exp env (ENamed f', loc)),
246 ("xs", Print.p_list (CorePrint.p_exp env) xs),
247 ("fxs'", Print.p_list
248 (CorePrint.p_exp E.empty) fxs'),
249 ("e", CorePrint.p_exp env (e, loc))]*)
250 val (body', typ') = IS.foldl (fn (n, (body', typ')) =>
251 let
252 val (x, xt) = E.lookupERel env n
253 in
254 ((EAbs (x, xt, typ', body'),
255 loc),
256 (TFun (xt, typ'), loc))
257 end)
258 (body', typ') fvs
259 val (body', st) = specExp env st body'
260
261 val e' = (ENamed f', loc)
262 val e' = IS.foldr (fn (arg, e) => (EApp (e, (ERel arg, loc)), loc))
263 e' fvs
264 val e' = foldl (fn (arg, e) => (EApp (e, arg), loc))
265 e' xs
266 (*val () = Print.prefaces "Brand new"
267 [("e'", CorePrint.p_exp env e'),
268 ("e", CorePrint.p_exp env (e, loc)),
269 ("body'", CorePrint.p_exp env body')]*)
270 in
271 (#1 e',
272 {maxName = #maxName st,
273 funcs = #funcs st,
274 decls = (name, f', typ', body', tag) :: #decls st})
275 end
276 end
277 end
261 end 278 end
262 279
263 and specExp st = U.Exp.foldMap {kind = kind, con = con, exp = exp} st 280 and specExp env = U.Exp.foldMapB {kind = kind, con = default, exp = exp, bind = bind} env
264 281
265 fun decl (d, st) = (d, st) 282 val specDecl = U.Decl.foldMapB {kind = kind, con = default, exp = exp, decl = default, bind = bind}
266 283
267 val specDecl = U.Decl.foldMap {kind = kind, con = con, exp = exp, decl = decl} 284 fun doDecl (d, (env, st : state, changed)) =
268
269
270
271 fun doDecl (d, (st : state, changed)) =
272 let 285 let
286 val env = E.declBinds env d
287
273 val funcs = #funcs st 288 val funcs = #funcs st
274 val funcs = 289 val funcs =
275 case #1 d of 290 case #1 d of
276 DValRec vis => 291 DValRec vis =>
277 foldl (fn ((x, n, c, e, tag), funcs) => 292 foldl (fn ((x, n, c, e, tag), funcs) =>
286 val st = {maxName = #maxName st, 301 val st = {maxName = #maxName st,
287 funcs = funcs, 302 funcs = funcs,
288 decls = []} 303 decls = []}
289 304
290 (*val () = Print.prefaces "decl" [("d", CorePrint.p_decl CoreEnv.empty d)]*) 305 (*val () = Print.prefaces "decl" [("d", CorePrint.p_decl CoreEnv.empty d)]*)
291 val (d', st) = specDecl st d 306 val (d', st) = specDecl env st d
292 (*val () = print "/decl\n"*) 307 (*val () = print "/decl\n"*)
293 308
294 val funcs = #funcs st 309 val funcs = #funcs st
295 val funcs = 310 val funcs =
296 case #1 d of 311 case #1 d of
312 | vis => 327 | vis =>
313 (true, case d' of 328 (true, case d' of
314 (DValRec vis', _) => [(DValRec (vis @ vis'), ErrorMsg.dummySpan)] 329 (DValRec vis', _) => [(DValRec (vis @ vis'), ErrorMsg.dummySpan)]
315 | _ => [(DValRec vis, ErrorMsg.dummySpan), d']) 330 | _ => [(DValRec vis, ErrorMsg.dummySpan), d'])
316 in 331 in
317 (ds, ({maxName = #maxName st, 332 (ds, (env,
333 {maxName = #maxName st,
318 funcs = funcs, 334 funcs = funcs,
319 decls = []}, changed)) 335 decls = []}, changed))
320 end 336 end
321 337
322 val (ds, (_, changed)) = ListUtil.foldlMapConcat doDecl 338 val (ds, (_, _, changed)) = ListUtil.foldlMapConcat doDecl
323 ({maxName = U.File.maxName file + 1, 339 (E.empty,
324 funcs = IM.empty, 340 {maxName = U.File.maxName file + 1,
325 decls = []}, false) 341 funcs = IM.empty,
326 file 342 decls = []},
343 false)
344 file
327 in 345 in
328 (changed, ds) 346 (changed, ds)
329 end 347 end
330 348
331 fun specialize file = 349 fun specialize file =
332 let 350 let
333 (*val () = Print.prefaces "Intermediate" [("file", CorePrint.p_file CoreEnv.empty file)];*) 351 (*val () = Print.prefaces "Intermediate" [("file", CorePrint.p_file CoreEnv.empty file)];*)
352 val file = ReduceLocal.reduce file
334 val (changed, file) = specialize' file 353 val (changed, file) = specialize' file
354 val file = ReduceLocal.reduce file
355 (*val file = CoreUntangle.untangle file
356 val file = Shake.shake file*)
335 in 357 in
358 (*print "Round over\n";*)
336 if changed then 359 if changed then
337 specialize (ReduceLocal.reduce file) 360 specialize file
338 else 361 else
339 file 362 file
340 end 363 end
341 364
342 end 365 end