Mercurial > urweb

annotate src/especialize.sml @ 1361:7a436b6267ab

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Fix soundness bug in Effectize, where it missed some functions that might have effectful RPCs
author Adam Chlipala <adam@chlipala.net>
date Thu, 23 Dec 2010 18:07:05 -0500
parents ccf1d445b794
children fd34210bc3e5
rev   line source
adamc@1272 1 (* Copyright (c) 2008-2010, Adam Chlipala
adamc@443 2 * All rights reserved.
adamc@443 3 *
adamc@443 4 * Redistribution and use in source and binary forms, with or without
adamc@443 5 * modification, are permitted provided that the following conditions are met:
adamc@443 6 *
adamc@443 7 * - Redistributions of source code must retain the above copyright notice,
adamc@443 8 * this list of conditions and the following disclaimer.
adamc@443 9 * - Redistributions in binary form must reproduce the above copyright notice,
adamc@443 10 * this list of conditions and the following disclaimer in the documentation
adamc@443 11 * and/or other materials provided with the distribution.
adamc@443 12 * - The names of contributors may not be used to endorse or promote products
adamc@443 13 * derived from this software without specific prior written permission.
adamc@443 14 *
adamc@443 15 * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
adamc@443 16 * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
adamc@443 17 * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
adamc@443 18 * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
adamc@443 19 * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
adamc@443 20 * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
adamc@443 21 * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
adamc@443 22 * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
adamc@443 23 * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
adamc@443 24 * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
adamc@443 25 * POSSIBILITY OF SUCH DAMAGE.
adamc@443 26 *)
adamc@443 27
adamc@443 28 structure ESpecialize :> ESPECIALIZE = struct
adamc@443 29
adamc@443 30 open Core
adamc@443 31
adamc@443 32 structure E = CoreEnv
adamc@443 33 structure U = CoreUtil
adamc@443 34
adamc@479 35 type skey = exp
adamc@453 36
adamc@453 37 structure K = struct
adam@1314 38 type ord_key = con list * exp list
adam@1314 39 fun compare ((cs1, es1), (cs2, es2)) = Order.join (Order.joinL U.Con.compare (cs1, cs2),
adam@1314 40 fn () => Order.joinL U.Exp.compare (es1, es2))
adamc@443 41 end
adamc@443 42
adamc@453 43 structure KM = BinaryMapFn(K)
adamc@443 44 structure IM = IntBinaryMap
adamc@482 45 structure IS = IntBinarySet
adamc@443 46
adamc@626 47 val freeVars = U.Exp.foldB {kind = fn (_, _, xs) => xs,
adamc@488 48 con = fn (_, _, xs) => xs,
adamc@488 49 exp = fn (bound, e, xs) =>
adamc@488 50 case e of
adamc@488 51 ERel x =>
adamc@488 52 if x >= bound then
adamc@488 53 IS.add (xs, x - bound)
adamc@488 54 else
adamc@488 55 xs
adamc@488 56 | _ => xs,
adamc@488 57 bind = fn (bound, b) =>
adamc@488 58 case b of
adamc@488 59 U.Exp.RelE _ => bound + 1
adamc@488 60 | _ => bound}
adamc@488 61 0 IS.empty
adamc@479 62
adamc@1120 63 fun isPolyT (t, _) =
adamc@1120 64 case t of
adamc@1120 65 TFun (_, ran) => isPolyT ran
adamc@1120 66 | TCFun _ => true
adamc@1120 67 | TKFun _ => true
adamc@1120 68 | _ => false
adamc@1120 69
adamc@1120 70 fun isPoly (d, _) =
adamc@1120 71 case d of
adamc@1120 72 DVal (_, _, t, _, _) => isPolyT t
adamc@1120 73 | DValRec vis => List.exists (isPolyT o #3) vis
adamc@1120 74 | _ => false
adamc@522 75
adamc@488 76 fun positionOf (v : int, ls) =
adamc@488 77 let
adamc@488 78 fun pof (pos, ls) =
adamc@488 79 case ls of
adamc@488 80 [] => raise Fail "Defunc.positionOf"
adamc@488 81 | v' :: ls' =>
adamc@488 82 if v = v' then
adamc@488 83 pos
adamc@488 84 else
adamc@488 85 pof (pos + 1, ls')
adamc@488 86 in
adamc@488 87 pof (0, ls)
adamc@488 88 end
adamc@488 89
adamc@1079 90 fun squish fvs =
adamc@626 91 U.Exp.mapB {kind = fn _ => fn k => k,
adamc@488 92 con = fn _ => fn c => c,
adamc@488 93 exp = fn bound => fn e =>
adamc@479 94 case e of
adamc@488 95 ERel x =>
adamc@488 96 if x >= bound then
adamc@1079 97 ERel (positionOf (x - bound, fvs) + bound)
adamc@488 98 else
adamc@488 99 e
adamc@488 100 | _ => e,
adamc@488 101 bind = fn (bound, b) =>
adamc@488 102 case b of
adamc@488 103 U.Exp.RelE _ => bound + 1
adamc@488 104 | _ => bound}
adamc@488 105 0
adamc@453 106
adamc@443 107 type func = {
adamc@443 108 name : string,
adamc@453 109 args : int KM.map,
adamc@443 110 body : exp,
adamc@443 111 typ : con,
adamc@443 112 tag : string
adamc@443 113 }
adamc@443 114
adamc@443 115 type state = {
adamc@443 116 maxName : int,
adamc@443 117 funcs : func IM.map,
adamc@1079 118 decls : (string * int * con * exp * string) list,
adamc@1080 119 specialized : IS.set
adamc@443 120 }
adamc@443 121
adamc@488 122 fun default (_, x, st) = (x, st)
adamc@443 123
adamc@800 124 structure SS = BinarySetFn(struct
adamc@800 125 type ord_key = string
adamc@800 126 val compare = String.compare
adamc@800 127 end)
adamc@800 128
adamc@800 129 val mayNotSpec = ref SS.empty
adamc@800 130
adam@1289 131 val functionInside = U.Con.exists {kind = fn _ => false,
adam@1289 132 con = fn TFun _ => true
adam@1289 133 | CFfi ("Basis", "transaction") => true
adam@1289 134 | CFfi ("Basis", "eq") => true
adam@1289 135 | CFfi ("Basis", "num") => true
adam@1289 136 | CFfi ("Basis", "ord") => true
adam@1289 137 | CFfi ("Basis", "show") => true
adam@1289 138 | CFfi ("Basis", "read") => true
adam@1289 139 | CFfi ("Basis", "sql_injectable_prim") => true
adam@1289 140 | CFfi ("Basis", "sql_injectable") => true
adam@1289 141 | _ => false}
adam@1289 142
adamc@1080 143 fun specialize' (funcs, specialized) file =
adamc@443 144 let
adamc@488 145 fun bind (env, b) =
adamc@488 146 case b of
adamc@521 147 U.Decl.RelE xt => xt :: env
adamc@521 148 | _ => env
adamc@488 149
adamc@1080 150 fun exp (env, e as (_, loc), st : state) =
adamc@482 151 let
adamc@721 152 (*val () = Print.prefaces "exp" [("e", CorePrint.p_exp CoreEnv.empty
adamc@721 153 (e, ErrorMsg.dummySpan))]*)
adamc@721 154
adamc@1080 155 fun getApp (e, _) =
adamc@482 156 case e of
adamc@488 157 ENamed f => SOME (f, [])
adamc@482 158 | EApp (e1, e2) =>
adamc@1080 159 (case getApp e1 of
adamc@482 160 NONE => NONE
adamc@488 161 | SOME (f, xs) => SOME (f, xs @ [e2]))
adamc@482 162 | _ => NONE
adamc@1080 163
adamc@1080 164 val getApp = fn e => case getApp e of
adamc@1080 165 v as SOME (_, _ :: _) => v
adamc@1080 166 | _ => NONE
adamc@1080 167
adamc@1080 168 fun default () =
adamc@1080 169 case #1 e of
adamc@1080 170 EPrim _ => (e, st)
adamc@1080 171 | ERel _ => (e, st)
adamc@1080 172 | ENamed _ => (e, st)
adamc@1080 173 | ECon (_, _, _, NONE) => (e, st)
adamc@1080 174 | ECon (dk, pc, cs, SOME e) =>
adamc@1080 175 let
adamc@1080 176 val (e, st) = exp (env, e, st)
adamc@1080 177 in
adamc@1080 178 ((ECon (dk, pc, cs, SOME e), loc), st)
adamc@1080 179 end
adamc@1080 180 | EFfi _ => (e, st)
adamc@1080 181 | EFfiApp (m, x, es) =>
adamc@1080 182 let
adamc@1080 183 val (es, st) = ListUtil.foldlMap (fn (e, st) => exp (env, e, st)) st es
adamc@1080 184 in
adamc@1080 185 ((EFfiApp (m, x, es), loc), st)
adamc@1080 186 end
adamc@1080 187 | EApp (e1, e2) =>
adamc@1080 188 let
adamc@1080 189 val (e1, st) = exp (env, e1, st)
adamc@1080 190 val (e2, st) = exp (env, e2, st)
adamc@1080 191 in
adamc@1080 192 ((EApp (e1, e2), loc), st)
adamc@1080 193 end
adamc@1080 194 | EAbs (x, d, r, e) =>
adamc@1080 195 let
adamc@1080 196 val (e, st) = exp ((x, d) :: env, e, st)
adamc@1080 197 in
adamc@1080 198 ((EAbs (x, d, r, e), loc), st)
adamc@1080 199 end
adamc@1080 200 | ECApp (e, c) =>
adamc@1080 201 let
adamc@1080 202 val (e, st) = exp (env, e, st)
adamc@1080 203 in
adamc@1080 204 ((ECApp (e, c), loc), st)
adamc@1080 205 end
adamc@1185 206 | ECAbs _ => (e, st)
adamc@1120 207 | EKAbs _ => (e, st)
adamc@1080 208 | EKApp (e, k) =>
adamc@1080 209 let
adamc@1080 210 val (e, st) = exp (env, e, st)
adamc@1080 211 in
adamc@1080 212 ((EKApp (e, k), loc), st)
adamc@1080 213 end
adamc@1080 214 | ERecord fs =>
adamc@1080 215 let
adamc@1080 216 val (fs, st) = ListUtil.foldlMap (fn ((c1, e, c2), st) =>
adamc@1080 217 let
adamc@1080 218 val (e, st) = exp (env, e, st)
adamc@1080 219 in
adamc@1080 220 ((c1, e, c2), st)
adamc@1080 221 end) st fs
adamc@1080 222 in
adamc@1080 223 ((ERecord fs, loc), st)
adamc@1080 224 end
adamc@1080 225 | EField (e, c, cs) =>
adamc@1080 226 let
adamc@1080 227 val (e, st) = exp (env, e, st)
adamc@1080 228 in
adamc@1080 229 ((EField (e, c, cs), loc), st)
adamc@1080 230 end
adamc@1080 231 | EConcat (e1, c1, e2, c2) =>
adamc@1080 232 let
adamc@1080 233 val (e1, st) = exp (env, e1, st)
adamc@1080 234 val (e2, st) = exp (env, e2, st)
adamc@1080 235 in
adamc@1080 236 ((EConcat (e1, c1, e2, c2), loc), st)
adamc@1080 237 end
adamc@1080 238 | ECut (e, c, cs) =>
adamc@1080 239 let
adamc@1080 240 val (e, st) = exp (env, e, st)
adamc@1080 241 in
adamc@1080 242 ((ECut (e, c, cs), loc), st)
adamc@1080 243 end
adamc@1080 244 | ECutMulti (e, c, cs) =>
adamc@1080 245 let
adamc@1080 246 val (e, st) = exp (env, e, st)
adamc@1080 247 in
adamc@1080 248 ((ECutMulti (e, c, cs), loc), st)
adamc@1080 249 end
adamc@1080 250
adamc@1080 251 | ECase (e, pes, cs) =>
adamc@1080 252 let
adamc@1080 253 val (e, st) = exp (env, e, st)
adamc@1080 254 val (pes, st) = ListUtil.foldlMap (fn ((p, e), st) =>
adamc@1080 255 let
adamc@1080 256 val (e, st) = exp (E.patBindsL p @ env, e, st)
adamc@1080 257 in
adamc@1080 258 ((p, e), st)
adamc@1080 259 end) st pes
adamc@1080 260 in
adamc@1080 261 ((ECase (e, pes, cs), loc), st)
adamc@1080 262 end
adamc@1080 263
adamc@1080 264 | EWrite e =>
adamc@1080 265 let
adamc@1080 266 val (e, st) = exp (env, e, st)
adamc@1080 267 in
adamc@1080 268 ((EWrite e, loc), st)
adamc@1080 269 end
adamc@1080 270 | EClosure (n, es) =>
adamc@1080 271 let
adamc@1080 272 val (es, st) = ListUtil.foldlMap (fn (e, st) => exp (env, e, st)) st es
adamc@1080 273 in
adamc@1080 274 ((EClosure (n, es), loc), st)
adamc@1080 275 end
adamc@1080 276 | ELet (x, t, e1, e2) =>
adamc@1080 277 let
adamc@1080 278 val (e1, st) = exp (env, e1, st)
adamc@1080 279 val (e2, st) = exp ((x, t) :: env, e2, st)
adamc@1080 280 in
adamc@1080 281 ((ELet (x, t, e1, e2), loc), st)
adamc@1080 282 end
adamc@1080 283 | EServerCall (n, es, t) =>
adamc@1080 284 let
adamc@1080 285 val (es, st) = ListUtil.foldlMap (fn (e, st) => exp (env, e, st)) st es
adamc@1080 286 in
adamc@1080 287 ((EServerCall (n, es, t), loc), st)
adamc@1080 288 end
adamc@482 289 in
adamc@482 290 case getApp e of
adamc@1080 291 NONE => default ()
adamc@488 292 | SOME (f, xs) =>
adamc@485 293 case IM.find (#funcs st, f) of
adamc@1272 294 NONE => ((*print ("No find: " ^ Int.toString f ^ "\n");*) default ())
adamc@485 295 | SOME {name, args, body, typ, tag} =>
adamc@488 296 let
adamc@1080 297 val (xs, st) = ListUtil.foldlMap (fn (e, st) => exp (env, e, st)) st xs
adamc@1080 298
adamc@721 299 (*val () = Print.prefaces "Consider" [("e", CorePrint.p_exp CoreEnv.empty
adamc@721 300 (e, ErrorMsg.dummySpan))]*)
adamc@721 301
adamc@488 302 val loc = ErrorMsg.dummySpan
adamc@488 303
adamc@1080 304 fun findSplit av (xs, typ, fxs, fvs, fin) =
adamc@488 305 case (#1 typ, xs) of
adamc@488 306 (TFun (dom, ran), e :: xs') =>
adamc@1078 307 let
adamc@1079 308 val av = case #1 e of
adamc@1079 309 ERel _ => av
adamc@1079 310 | _ => false
adamc@1078 311 in
adamc@1079 312 if functionInside dom orelse (av andalso case #1 e of
adamc@1079 313 ERel _ => true
adamc@1079 314 | _ => false) then
adamc@1079 315 findSplit av (xs',
adamc@1079 316 ran,
adamc@1079 317 e :: fxs,
adamc@1080 318 IS.union (fvs, freeVars e),
adamc@1080 319 fin orelse functionInside dom)
adamc@1078 320 else
adamc@1080 321 (rev fxs, xs, fvs, fin)
adamc@1078 322 end
adamc@1080 323 | _ => (rev fxs, xs, fvs, fin)
adamc@488 324
adamc@1080 325 val (fxs, xs, fvs, fin) = findSplit true (xs, typ, [], IS.empty, false)
adamc@1079 326
adam@1355 327 fun valueish (e, _) =
adam@1355 328 case e of
adam@1355 329 EPrim _ => true
adam@1355 330 | ERel _ => true
adam@1355 331 | ENamed _ => true
adam@1355 332 | ECon (_, _, _, NONE) => true
adam@1355 333 | ECon (_, _, _, SOME e) => valueish e
adam@1355 334 | EFfi (_, _) => true
adam@1355 335 | EAbs _ => true
adam@1355 336 | ECAbs _ => true
adam@1355 337 | EKAbs _ => true
adam@1355 338 | ECApp (e, _) => valueish e
adam@1355 339 | EKApp (e, _) => valueish e
adam@1355 340 | ERecord xes => List.all (valueish o #2) xes
adam@1355 341 | _ => false
adam@1355 342
adam@1314 343 val vts = map (fn n => #2 (List.nth (env, n))) (IS.listItems fvs)
adamc@1079 344 val fxs' = map (squish (IS.listItems fvs)) fxs
adamc@488 345 in
adam@1355 346 (*Print.prefaces "Func" [("name", Print.PD.string name),
adam@1355 347 ("e", CorePrint.p_exp CoreEnv.empty e),
adam@1355 348 ("fxs'", Print.p_list (CorePrint.p_exp CoreEnv.empty) fxs')];*)
adamc@1080 349 if not fin
adamc@1080 350 orelse List.all (fn (ERel _, _) => true
adamc@1080 351 | _ => false) fxs'
adam@1355 352 orelse List.exists (not o valueish) fxs'
adamc@1079 353 orelse (IS.numItems fvs >= length fxs
adamc@1079 354 andalso IS.exists (fn n => functionInside (#2 (List.nth (env, n)))) fvs) then
adamc@1083 355 ((*Print.prefaces "No" [("name", Print.PD.string name),
adamc@1120 356 ("f", Print.PD.string (Int.toString f)),
adamc@1083 357 ("fxs'",
adamc@1083 358 Print.p_list (CorePrint.p_exp CoreEnv.empty) fxs')];*)
adamc@1083 359 default ())
adamc@488 360 else
adam@1314 361 case (KM.find (args, (vts, fxs')),
adamc@1083 362 SS.member (!mayNotSpec, name) (*orelse IS.member (#specialized st, f)*)) of
adamc@800 363 (SOME f', _) =>
adamc@485 364 let
adamc@488 365 val e = (ENamed f', loc)
adamc@488 366 val e = IS.foldr (fn (arg, e) => (EApp (e, (ERel arg, loc)), loc))
adamc@488 367 e fvs
adamc@1079 368 val e = foldl (fn (arg, e) => (EApp (e, arg), loc))
adamc@488 369 e xs
adamc@488 370 in
adamc@488 371 (*Print.prefaces "Brand new (reuse)"
adamc@721 372 [("e'", CorePrint.p_exp CoreEnv.empty e)];*)
adamc@1080 373 (e, st)
adamc@488 374 end
adamc@1083 375 | (_, true) => ((*Print.prefaces ("No!(" ^ name ^ ")")
adamc@818 376 [("fxs'",
adamc@818 377 Print.p_list (CorePrint.p_exp CoreEnv.empty) fxs')];*)
adamc@1080 378 default ())
adamc@800 379 | (NONE, false) =>
adamc@488 380 let
adamc@800 381 (*val () = Print.prefaces "New one"
adamc@800 382 [("f", Print.PD.string (Int.toString f)),
adamc@800 383 ("mns", Print.p_list Print.PD.string
adamc@800 384 (SS.listItems (!mayNotSpec)))]*)
adamc@800 385
adamc@818 386 (*val () = Print.prefaces ("Yes(" ^ name ^ ")")
adamc@818 387 [("fxs'",
adamc@818 388 Print.p_list (CorePrint.p_exp CoreEnv.empty) fxs')]*)
adamc@818 389
adamc@1079 390 fun subBody (body, typ, fxs') =
adamc@1079 391 case (#1 body, #1 typ, fxs') of
adamc@488 392 (_, _, []) => SOME (body, typ)
adamc@1079 393 | (EAbs (_, _, _, body'), TFun (_, typ'), x :: fxs'') =>
adamc@488 394 let
adamc@1079 395 val body'' = E.subExpInExp (0, x) body'
adamc@488 396 in
adamc@488 397 subBody (body'',
adamc@488 398 typ',
adamc@1079 399 fxs'')
adamc@488 400 end
adamc@488 401 | _ => NONE
adamc@488 402 in
adamc@1079 403 case subBody (body, typ, fxs') of
adamc@1080 404 NONE => default ()
adamc@488 405 | SOME (body', typ') =>
adamc@488 406 let
adamc@488 407 val f' = #maxName st
adam@1314 408 val args = KM.insert (args, (vts, fxs'), f')
adamc@488 409 val funcs = IM.insert (#funcs st, f, {name = name,
adamc@488 410 args = args,
adamc@488 411 body = body,
adamc@488 412 typ = typ,
adamc@488 413 tag = tag})
adamc@1079 414
adamc@488 415 val st = {
adamc@488 416 maxName = f' + 1,
adamc@488 417 funcs = funcs,
adamc@1079 418 decls = #decls st,
adamc@1080 419 specialized = IS.add (#specialized st, f')
adamc@488 420 }
adamc@487 421
adamc@488 422 (*val () = Print.prefaces "specExp"
adamc@488 423 [("f", CorePrint.p_exp env (ENamed f, loc)),
adamc@488 424 ("f'", CorePrint.p_exp env (ENamed f', loc)),
adamc@488 425 ("xs", Print.p_list (CorePrint.p_exp env) xs),
adamc@488 426 ("fxs'", Print.p_list
adamc@488 427 (CorePrint.p_exp E.empty) fxs'),
adamc@488 428 ("e", CorePrint.p_exp env (e, loc))]*)
adamc@488 429 val (body', typ') = IS.foldl (fn (n, (body', typ')) =>
adamc@488 430 let
adamc@521 431 val (x, xt) = List.nth (env, n)
adamc@488 432 in
adamc@488 433 ((EAbs (x, xt, typ', body'),
adamc@488 434 loc),
adamc@488 435 (TFun (xt, typ'), loc))
adamc@488 436 end)
adamc@488 437 (body', typ') fvs
adamc@800 438 val mns = !mayNotSpec
adamc@1080 439 (*val () = mayNotSpec := SS.add (mns, name)*)
adamc@1272 440 (*val () = print ("NEW: " ^ name ^ "__" ^ Int.toString f' ^ "\n");*)
adamc@1272 441 val body' = ReduceLocal.reduceExp body'
adamc@1080 442 (*val () = Print.preface ("PRE", CorePrint.p_exp CoreEnv.empty body')*)
adamc@1080 443 val (body', st) = exp (env, body', st)
adamc@800 444 val () = mayNotSpec := mns
adamc@482 445
adamc@488 446 val e' = (ENamed f', loc)
adamc@488 447 val e' = IS.foldr (fn (arg, e) => (EApp (e, (ERel arg, loc)), loc))
adamc@488 448 e' fvs
adamc@1079 449 val e' = foldl (fn (arg, e) => (EApp (e, arg), loc))
adamc@488 450 e' xs
adamc@488 451 (*val () = Print.prefaces "Brand new"
adamc@721 452 [("e'", CorePrint.p_exp CoreEnv.empty e'),
adamc@1080 453 ("e", CorePrint.p_exp CoreEnv.empty e),
adamc@721 454 ("body'", CorePrint.p_exp CoreEnv.empty body')]*)
adamc@488 455 in
adamc@1080 456 (e',
adamc@488 457 {maxName = #maxName st,
adamc@488 458 funcs = #funcs st,
adamc@1079 459 decls = (name, f', typ', body', tag) :: #decls st,
adamc@1079 460 specialized = #specialized st})
adamc@488 461 end
adamc@485 462 end
adamc@488 463 end
adamc@485 464 end
adamc@482 465
adamc@521 466 fun doDecl (d, (st : state, changed)) =
adamc@488 467 let
adamc@521 468 (*val befor = Time.now ()*)
adamc@482 469
adamc@453 470 val funcs = #funcs st
adamc@453 471 val funcs =
adamc@453 472 case #1 d of
adamc@453 473 DValRec vis =>
adamc@453 474 foldl (fn ((x, n, c, e, tag), funcs) =>
adamc@453 475 IM.insert (funcs, n, {name = x,
adamc@453 476 args = KM.empty,
adamc@453 477 body = e,
adamc@453 478 typ = c,
adamc@453 479 tag = tag}))
adamc@453 480 funcs vis
adamc@453 481 | _ => funcs
adamc@453 482
adamc@453 483 val st = {maxName = #maxName st,
adamc@453 484 funcs = funcs,
adamc@1079 485 decls = [],
adamc@1079 486 specialized = #specialized st}
adamc@453 487
adamc@482 488 (*val () = Print.prefaces "decl" [("d", CorePrint.p_decl CoreEnv.empty d)]*)
adamc@521 489
adamc@1080 490 val () = mayNotSpec := SS.empty
adamc@1080 491
adamc@522 492 val (d', st) =
adamc@522 493 if isPoly d then
adamc@522 494 (d, st)
adamc@522 495 else
adamc@1080 496 case #1 d of
adamc@1080 497 DVal (x, n, t, e, s) =>
adamc@1080 498 let
adamc@1080 499 val (e, st) = exp ([], e, st)
adamc@1080 500 in
adamc@1080 501 ((DVal (x, n, t, e, s), #2 d), st)
adamc@1080 502 end
adamc@1080 503 | DValRec vis =>
adamc@1080 504 let
adamc@1120 505 (*val () = Print.preface ("Visiting", Print.p_list (fn vi =>
adamc@1120 506 Print.PD.string (#1 vi ^ "__"
adamc@1120 507 ^ Int.toString
adamc@1120 508 (#2 vi)))
adamc@1120 509 vis)*)
adamc@1120 510
adamc@1080 511 val (vis, st) = ListUtil.foldlMap (fn ((x, n, t, e, s), st) =>
adamc@1080 512 let
adamc@1120 513 val () = mayNotSpec := SS.empty
adamc@1080 514 val (e, st) = exp ([], e, st)
adamc@1080 515 in
adamc@1080 516 ((x, n, t, e, s), st)
adamc@1080 517 end) st vis
adamc@1080 518 in
adamc@1080 519 ((DValRec vis, #2 d), st)
adamc@1080 520 end
adamc@1080 521 | DTable (s, n, t, s1, e1, t1, e2, t2) =>
adamc@1080 522 let
adamc@1080 523 val (e1, st) = exp ([], e1, st)
adamc@1080 524 val (e2, st) = exp ([], e2, st)
adamc@1080 525 in
adamc@1080 526 ((DTable (s, n, t, s1, e1, t2, e2, t2), #2 d), st)
adamc@1080 527 end
adamc@1080 528 | DView (x, n, s, e, t) =>
adamc@1080 529 let
adamc@1080 530 val (e, st) = exp ([], e, st)
adamc@1080 531 in
adamc@1080 532 ((DView (x, n, s, e, t), #2 d), st)
adamc@1080 533 end
adamc@1080 534 | DTask (e1, e2) =>
adamc@1080 535 let
adamc@1080 536 val (e1, st) = exp ([], e1, st)
adamc@1080 537 val (e2, st) = exp ([], e2, st)
adamc@1080 538 in
adamc@1080 539 ((DTask (e1, e2), #2 d), st)
adamc@1080 540 end
adamc@1080 541 | _ => (d, st)
adamc@1080 542
adamc@1080 543 val () = mayNotSpec := SS.empty
adamc@521 544
adamc@482 545 (*val () = print "/decl\n"*)
adamc@443 546
adamc@443 547 val funcs = #funcs st
adamc@443 548 val funcs =
adamc@443 549 case #1 d of
adamc@443 550 DVal (x, n, c, e as (EAbs _, _), tag) =>
adamc@443 551 IM.insert (funcs, n, {name = x,
adamc@453 552 args = KM.empty,
adamc@443 553 body = e,
adamc@443 554 typ = c,
adamc@443 555 tag = tag})
adamc@469 556 | DVal (_, n, _, (ENamed n', _), _) =>
adamc@469 557 (case IM.find (funcs, n') of
adamc@469 558 NONE => funcs
adamc@469 559 | SOME v => IM.insert (funcs, n, v))
adamc@443 560 | _ => funcs
adamc@443 561
adamc@453 562 val (changed, ds) =
adamc@443 563 case #decls st of
adamc@453 564 [] => (changed, [d'])
adamc@453 565 | vis =>
adamc@453 566 (true, case d' of
adamc@453 567 (DValRec vis', _) => [(DValRec (vis @ vis'), ErrorMsg.dummySpan)]
adamc@453 568 | _ => [(DValRec vis, ErrorMsg.dummySpan), d'])
adamc@443 569 in
adamc@802 570 (*Print.prefaces "doDecl" [("d", CorePrint.p_decl E.empty d),
adamc@802 571 ("d'", CorePrint.p_decl E.empty d')];*)
adamc@521 572 (ds, ({maxName = #maxName st,
adamc@453 573 funcs = funcs,
adamc@1079 574 decls = [],
adamc@1079 575 specialized = #specialized st}, changed))
adamc@443 576 end
adamc@443 577
adamc@1120 578 (*val () = Print.preface ("RESET", CorePrint.p_file CoreEnv.empty file)*)
adamc@1079 579 val (ds, (st, changed)) = ListUtil.foldlMapConcat doDecl
adamc@521 580 ({maxName = U.File.maxName file + 1,
adamc@1080 581 funcs = funcs,
adamc@1079 582 decls = [],
adamc@1079 583 specialized = specialized},
adamc@488 584 false)
adamc@488 585 file
adamc@443 586 in
adamc@1120 587 (*print ("Changed = " ^ Bool.toString changed ^ "\n");*)
adamc@1080 588 (changed, ds, #funcs st, #specialized st)
adamc@443 589 end
adamc@443 590
adamc@1080 591 fun specializeL (funcs, specialized) file =
adamc@453 592 let
adamc@721 593 val file = ReduceLocal.reduce file
adamc@520 594 (*val file = ReduceLocal.reduce file*)
adamc@1080 595 val (changed, file, funcs, specialized) = specialize' (funcs, specialized) file
adamc@520 596 (*val file = ReduceLocal.reduce file
adamc@520 597 val file = CoreUntangle.untangle file
adamc@488 598 val file = Shake.shake file*)
adamc@453 599 in
adamc@488 600 (*print "Round over\n";*)
adamc@453 601 if changed then
adamc@520 602 let
adamc@721 603 (*val file = ReduceLocal.reduce file*)
adamc@802 604 (*val () = Print.prefaces "Pre-untangle" [("file", CorePrint.p_file CoreEnv.empty file)]*)
adamc@520 605 val file = CoreUntangle.untangle file
adamc@802 606 (*val () = Print.prefaces "Post-untangle" [("file", CorePrint.p_file CoreEnv.empty file)]*)
adamc@520 607 val file = Shake.shake file
adamc@520 608 in
adamc@520 609 (*print "Again!\n";*)
adamc@1080 610 (*Print.prefaces "Again" [("file", CorePrint.p_file CoreEnv.empty file)];*)
adamc@1080 611 specializeL (funcs, specialized) file
adamc@520 612 end
adamc@453 613 else
adamc@453 614 file
adamc@453 615 end
adamc@453 616
adamc@1080 617 val specialize = specializeL (IM.empty, IS.empty)
adamc@1079 618
adamc@443 619 end