Mercurial > urweb

comparison src/especialize.sml @ 482:9117a7bf229c

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Especialize working reasonably well; need to add new closure representation pass
author Adam Chlipala <adamc@hcoop.net>
date Sun, 09 Nov 2008 11:53:52 -0500
parents 40c737913075
children a0f47540d8ad
comparison
equal deleted inserted replaced
481:2280193bf298 482:9117a7bf229c
39 val compare = Order.joinL U.Exp.compare 39 val compare = Order.joinL U.Exp.compare
40 end 40 end
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 45
45 val sizeOf = U.Exp.fold {kind = fn (_, n) => n, 46 val sizeOf = U.Exp.fold {kind = fn (_, n) => n,
46 con = fn (_, n) => n, 47 con = fn (_, n) => n,
47 exp = fn (_, n) => n + 1} 48 exp = fn (_, n) => n + 1}
48 0 49 0
99 } 100 }
100 101
101 fun kind (k, st) = (k, st) 102 fun kind (k, st) = (k, st)
102 fun con (c, st) = (c, st) 103 fun con (c, st) = (c, st)
103 104
104 fun exp (e, st : state) =
105 let
106 fun getApp e =
107 case e of
108 ENamed f => SOME (f, [], [])
109 | EField ((ERecord xes, _), (CName x, _), _) =>
110 (case List.find (fn ((CName x', _), _,_) => x' = x
111 | _ => false) xes of
112 NONE => NONE
113 | SOME (_, (e, _), _) => getApp e)
114 | EApp (e1, e2) =>
115 (case getApp (#1 e1) of
116 NONE => NONE
117 | SOME (f, xs, xs') =>
118 let
119 val k =
120 if List.null xs' then
121 skeyIn e2
122 else
123 NONE
124 in
125 case k of
126 NONE => SOME (f, xs, xs' @ [e2])
127 | SOME k => SOME (f, xs @ [k], xs')
128 end)
129 | _ => NONE
130 in
131 case getApp e of
132 NONE => (e, st)
133 | SOME (f, [], xs') => (#1 (foldl (fn (arg, e) => (EApp (e, arg), ErrorMsg.dummySpan))
134 (ENamed f, ErrorMsg.dummySpan) xs'), st)
135 | SOME (f, xs, xs') =>
136 case IM.find (#funcs st, f) of
137 NONE =>
138 let
139 val e = foldl (fn (arg, e) => (EApp (e, skeyOut arg), ErrorMsg.dummySpan))
140 (ENamed f, ErrorMsg.dummySpan) xs
141 in
142 (#1 (foldl (fn (arg, e) => (EApp (e, arg), ErrorMsg.dummySpan))
143 e xs'), st)
144 end
145 | SOME {name, args, body, typ, tag} =>
146 case KM.find (args, xs) of
147 SOME f' => ((*Print.prefaces "Pre-existing" [("e", CorePrint.p_exp CoreEnv.empty (e, ErrorMsg.dummySpan))];*)
148 (#1 (foldl (fn (e, arg) => (EApp (e, arg), ErrorMsg.dummySpan))
149 (ENamed f', ErrorMsg.dummySpan) xs'),
150 st))
151 | NONE =>
152 let
153 (*val () = Print.prefaces "New" [("e", CorePrint.p_exp CoreEnv.empty (e, ErrorMsg.dummySpan))]*)
154
155 fun subBody (body, typ, xs) =
156 case (#1 body, #1 typ, xs) of
157 (_, _, []) => SOME (body, typ)
158 | (EAbs (_, _, _, body'), TFun (_, typ'), x :: xs) =>
159 let
160 val body'' = E.subExpInExp (0, skeyOut x) body'
161 in
162 (*Print.prefaces "espec" [("body'", CorePrint.p_exp CoreEnv.empty body'),
163 ("body''", CorePrint.p_exp CoreEnv.empty body'')];*)
164 subBody (body'',
165 typ',
166 xs)
167 end
168 | _ => NONE
169 in
170 case subBody (body, typ, xs) of
171 NONE => (e, st)
172 | SOME (body', typ') =>
173 let
174 val f' = #maxName st
175 (*val () = print ("f' = " ^ Int.toString f' ^ "\n")*)
176 val funcs = IM.insert (#funcs st, f, {name = name,
177 args = KM.insert (args, xs, f'),
178 body = body,
179 typ = typ,
180 tag = tag})
181 val st = {
182 maxName = f' + 1,
183 funcs = funcs,
184 decls = #decls st
185 }
186
187 val (body', st) = specExp st body'
188 val e' = foldl (fn (e, arg) => (EApp (e, arg), ErrorMsg.dummySpan))
189 (ENamed f', ErrorMsg.dummySpan) xs'
190 in
191 (#1 e',
192 {maxName = #maxName st,
193 funcs = #funcs st,
194 decls = (name, f', typ', body', tag) :: #decls st})
195 end
196 end
197 end
198
199 and specExp st = U.Exp.foldMap {kind = kind, con = con, exp = exp} st
200
201 fun decl (d, st) = (d, st)
202
203 val specDecl = U.Decl.foldMap {kind = kind, con = con, exp = exp, decl = decl}
204
205 fun specialize' file = 105 fun specialize' file =
206 let 106 let
107 fun default (_, fs) = fs
108
109 fun actionableExp (e, fs) =
110 case e of
111 ERecord xes =>
112 foldl (fn (((CName s, _), e, _), fs) =>
113 if s = "Action" orelse s = "Link" then
114 let
115 fun findHead (e, _) =
116 case e of
117 ENamed n => IS.add (fs, n)
118 | EApp (e, _) => findHead e
119 | _ => fs
120 in
121 findHead e
122 end
123 else
124 fs
125 | (_, fs) => fs)
126 fs xes
127 | _ => fs
128
129 val actionable =
130 U.File.fold {kind = default,
131 con = default,
132 exp = actionableExp,
133 decl = default}
134 IS.empty file
135
136 fun exp (e, st : state) =
137 let
138 fun getApp e =
139 case e of
140 ENamed f => SOME (f, [], [])
141 | EApp (e1, e2) =>
142 (case getApp (#1 e1) of
143 NONE => NONE
144 | SOME (f, xs, xs') =>
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 in
158 case getApp e of
159 NONE => (e, st)
160 | SOME (f, [], []) => (e, st)
161 | SOME (f, [], xs') =>
162 (case IM.find (#funcs st, f) of
163 NONE => (e, st)
164 | SOME {typ, body, ...} =>
165 let
166 val functionInside = U.Con.exists {kind = fn _ => false,
167 con = fn TFun _ => true
168 | CFfi ("Basis", "transaction") => true
169 | _ => false}
170
171 fun hasFunarg (t, xs) =
172 case (t, xs) of
173 ((TFun (dom, ran), _), _ :: xs) =>
174 functionInside dom
175 orelse hasFunarg (ran, xs)
176 | _ => false
177 in
178 if List.all (fn (ERel _, _) => false | _ => true) xs'
179 andalso not (IS.member (actionable, f))
180 andalso hasFunarg (typ, xs') then
181 (#1 (foldl (fn (arg, e) => (EApp (e, arg), ErrorMsg.dummySpan))
182 body xs'),
183 st)
184 else
185 (e, st)
186 end)
187 | SOME (f, xs, xs') =>
188 case IM.find (#funcs st, f) of
189 NONE => (e, st)
190 | SOME {name, args, body, typ, tag} =>
191 case KM.find (args, xs) of
192 SOME f' => (#1 (foldl (fn (arg, e) => (EApp (e, arg), ErrorMsg.dummySpan))
193 (ENamed f', ErrorMsg.dummySpan) xs'),
194 st)
195 | NONE =>
196 let
197 fun subBody (body, typ, xs) =
198 case (#1 body, #1 typ, xs) of
199 (_, _, []) => SOME (body, typ)
200 | (EAbs (_, _, _, body'), TFun (_, typ'), x :: xs) =>
201 let
202 val body'' = E.subExpInExp (0, skeyOut x) body'
203 in
204 subBody (body'',
205 typ',
206 xs)
207 end
208 | _ => NONE
209 in
210 case subBody (body, typ, xs) of
211 NONE => (e, st)
212 | SOME (body', typ') =>
213 let
214 val f' = #maxName st
215 val funcs = IM.insert (#funcs st, f, {name = name,
216 args = KM.insert (args,
217 xs, f'),
218 body = body,
219 typ = typ,
220 tag = tag})
221 val st = {
222 maxName = f' + 1,
223 funcs = funcs,
224 decls = #decls st
225 }
226
227 val (body', st) = specExp st body'
228 val e' = foldl (fn (arg, e) => (EApp (e, arg), ErrorMsg.dummySpan))
229 (ENamed f', ErrorMsg.dummySpan) xs'
230 in
231 (#1 e',
232 {maxName = #maxName st,
233 funcs = #funcs st,
234 decls = (name, f', typ', body', tag) :: #decls st})
235 end
236 end
237 end
238
239 and specExp st = U.Exp.foldMap {kind = kind, con = con, exp = exp} st
240
241 fun decl (d, st) = (d, st)
242
243 val specDecl = U.Decl.foldMap {kind = kind, con = con, exp = exp, decl = decl}
244
245
246
207 fun doDecl (d, (st : state, changed)) = 247 fun doDecl (d, (st : state, changed)) =
208 let 248 let
209 val funcs = #funcs st 249 val funcs = #funcs st
210 val funcs = 250 val funcs =
211 case #1 d of 251 case #1 d of
221 261
222 val st = {maxName = #maxName st, 262 val st = {maxName = #maxName st,
223 funcs = funcs, 263 funcs = funcs,
224 decls = []} 264 decls = []}
225 265
266 (*val () = Print.prefaces "decl" [("d", CorePrint.p_decl CoreEnv.empty d)]*)
226 val (d', st) = specDecl st d 267 val (d', st) = specDecl st d
268 (*val () = print "/decl\n"*)
227 269
228 val funcs = #funcs st 270 val funcs = #funcs st
229 val funcs = 271 val funcs =
230 case #1 d of 272 case #1 d of
231 DVal (x, n, c, e as (EAbs _, _), tag) => 273 DVal (x, n, c, e as (EAbs _, _), tag) =>
265 fun specialize file = 307 fun specialize file =
266 let 308 let
267 val (changed, file) = specialize' file 309 val (changed, file) = specialize' file
268 in 310 in
269 if changed then 311 if changed then
270 specialize file 312 specialize (ReduceLocal.reduce file)
271 else 313 else
272 file 314 file
273 end 315 end
274 316
275 317