Mercurial > urweb

comparison src/especialize.sml @ 721:9864b64b1700

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Classes as optional arguments to Basis.tag
author Adam Chlipala <adamc@hcoop.net>
date Sun, 12 Apr 2009 14:19:15 -0400
parents 230654093b51
children dc3fc3f3b834
comparison
equal deleted inserted replaced
720:acb8537f58f0 721:9864b64b1700
112 112
113 fun default (_, x, st) = (x, st) 113 fun default (_, x, st) = (x, st)
114 114
115 fun specialize' file = 115 fun specialize' file =
116 let 116 let
117 fun default' (_, fs) = fs
118
119 fun actionableExp (e, fs) =
120 case e of
121 ERecord xes =>
122 foldl (fn (((CName s, _), e, _), fs) =>
123 if s = "Action" orelse s = "Link" then
124 let
125 fun findHead (e, _) =
126 case e of
127 ENamed n => IS.add (fs, n)
128 | EApp (e, _) => findHead e
129 | _ => fs
130 in
131 findHead e
132 end
133 else
134 fs
135 | (_, fs) => fs)
136 fs xes
137 | _ => fs
138
139 val actionable =
140 U.File.fold {kind = default',
141 con = default',
142 exp = actionableExp,
143 decl = default'}
144 IS.empty file
145
146 fun bind (env, b) = 117 fun bind (env, b) =
147 case b of 118 case b of
148 U.Decl.RelE xt => xt :: env 119 U.Decl.RelE xt => xt :: env
149 | _ => env 120 | _ => env
150 121
151 fun exp (env, e, st : state) = 122 fun exp (env, e, st : state) =
152 let 123 let
124 (*val () = Print.prefaces "exp" [("e", CorePrint.p_exp CoreEnv.empty
125 (e, ErrorMsg.dummySpan))]*)
126
153 fun getApp e = 127 fun getApp e =
154 case e of 128 case e of
155 ENamed f => SOME (f, []) 129 ENamed f => SOME (f, [])
156 | EApp (e1, e2) => 130 | EApp (e1, e2) =>
157 (case getApp (#1 e1) of 131 (case getApp (#1 e1) of
158 NONE => NONE 132 NONE => NONE
159 | SOME (f, xs) => SOME (f, xs @ [e2])) 133 | SOME (f, xs) => SOME (f, xs @ [e2]))
160 | _ => NONE 134 | _ => NONE
161 in 135 in
162 case getApp e of 136 case getApp e of
163 NONE => (e, st) 137 NONE => ((*Print.prefaces "No" [("e", CorePrint.p_exp CoreEnv.empty
138 (e, ErrorMsg.dummySpan))];*)
139 (e, st))
164 | SOME (f, xs) => 140 | SOME (f, xs) =>
165 case IM.find (#funcs st, f) of 141 case IM.find (#funcs st, f) of
166 NONE => (e, st) 142 NONE => (e, st)
167 | SOME {name, args, body, typ, tag} => 143 | SOME {name, args, body, typ, tag} =>
168 let 144 let
145 (*val () = Print.prefaces "Consider" [("e", CorePrint.p_exp CoreEnv.empty
146 (e, ErrorMsg.dummySpan))]*)
147
169 val functionInside = U.Con.exists {kind = fn _ => false, 148 val functionInside = U.Con.exists {kind = fn _ => false,
170 con = fn TFun _ => true 149 con = fn TFun _ => true
171 | CFfi ("Basis", "transaction") => true 150 | CFfi ("Basis", "transaction") => true
172 | _ => false} 151 | _ => false}
173 val loc = ErrorMsg.dummySpan 152 val loc = ErrorMsg.dummySpan
206 e fvs 185 e fvs
207 val e = foldl (fn (arg, e) => (EApp (e, arg), loc)) 186 val e = foldl (fn (arg, e) => (EApp (e, arg), loc))
208 e xs 187 e xs
209 in 188 in
210 (*Print.prefaces "Brand new (reuse)" 189 (*Print.prefaces "Brand new (reuse)"
211 [("e'", CorePrint.p_exp env e)];*) 190 [("e'", CorePrint.p_exp CoreEnv.empty e)];*)
212 (#1 e, st) 191 (#1 e, st)
213 end 192 end
214 | NONE => 193 | NONE =>
215 let 194 let
216 fun subBody (body, typ, fxs') = 195 fun subBody (body, typ, fxs') =
265 val e' = IS.foldr (fn (arg, e) => (EApp (e, (ERel arg, loc)), loc)) 244 val e' = IS.foldr (fn (arg, e) => (EApp (e, (ERel arg, loc)), loc))
266 e' fvs 245 e' fvs
267 val e' = foldl (fn (arg, e) => (EApp (e, arg), loc)) 246 val e' = foldl (fn (arg, e) => (EApp (e, arg), loc))
268 e' xs 247 e' xs
269 (*val () = Print.prefaces "Brand new" 248 (*val () = Print.prefaces "Brand new"
270 [("e'", CorePrint.p_exp env e'), 249 [("e'", CorePrint.p_exp CoreEnv.empty e'),
271 ("e", CorePrint.p_exp env (e, loc)), 250 ("e", CorePrint.p_exp CoreEnv.empty (e, loc)),
272 ("body'", CorePrint.p_exp env body')]*) 251 ("body'", CorePrint.p_exp CoreEnv.empty body')]*)
273 in 252 in
274 (#1 e', 253 (#1 e',
275 {maxName = #maxName st, 254 {maxName = #maxName st,
276 funcs = #funcs st, 255 funcs = #funcs st,
277 decls = (name, f', typ', body', tag) :: #decls st}) 256 decls = (name, f', typ', body', tag) :: #decls st})
356 (changed, ds) 335 (changed, ds)
357 end 336 end
358 337
359 fun specialize file = 338 fun specialize file =
360 let 339 let
361 (*val () = Print.prefaces "Intermediate" [("file", CorePrint.p_file CoreEnv.empty file)];*) 340 val file = ReduceLocal.reduce file
341 (*val () = Print.prefaces "Intermediate" [("file", CorePrint.p_file CoreEnv.empty file)]*)
362 (*val file = ReduceLocal.reduce file*) 342 (*val file = ReduceLocal.reduce file*)
363 val (changed, file) = specialize' file 343 val (changed, file) = specialize' file
364 (*val file = ReduceLocal.reduce file 344 (*val file = ReduceLocal.reduce file
365 val file = CoreUntangle.untangle file 345 val file = CoreUntangle.untangle file
366 val file = Shake.shake file*) 346 val file = Shake.shake file*)
367 in 347 in
368 (*print "Round over\n";*) 348 (*print "Round over\n";*)
369 if changed then 349 if changed then
370 let 350 let
371 val file = ReduceLocal.reduce file 351 (*val file = ReduceLocal.reduce file*)
372 val file = CoreUntangle.untangle file 352 val file = CoreUntangle.untangle file
373 val file = Shake.shake file 353 val file = Shake.shake file
374 in 354 in
375 (*print "Again!\n";*) 355 (*print "Again!\n";*)
376 specialize file 356 specialize file