Mercurial > urweb

annotate src/especialize.sml @ 1380:ede95ecb4000

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Thanks to Vag Vagoff, catch some cases of an obsolete notation for guarded types in the manual
author Adam Chlipala <adam@chlipala.net>
date Thu, 06 Jan 2011 08:55:53 -0500
parents fd34210bc3e5
children 5cb95fb7d4d5
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@1362 340 | EApp (e, (ERel _, _)) =>
adam@1362 341 let
adam@1362 342 fun valueishf (e, _) =
adam@1362 343 case e of
adam@1362 344 ENamed _ => true
adam@1362 345 | EApp (e, (ERel _, _)) => valueishf e
adam@1362 346 | _ => false
adam@1362 347 in
adam@1362 348 valueishf e
adam@1362 349 end
adam@1355 350 | ERecord xes => List.all (valueish o #2) xes
adam@1355 351 | _ => false
adam@1355 352
adam@1314 353 val vts = map (fn n => #2 (List.nth (env, n))) (IS.listItems fvs)
adamc@1079 354 val fxs' = map (squish (IS.listItems fvs)) fxs
adam@1362 355
adam@1362 356 val p_bool = Print.PD.string o Bool.toString
adamc@488 357 in
adam@1355 358 (*Print.prefaces "Func" [("name", Print.PD.string name),
adam@1355 359 ("e", CorePrint.p_exp CoreEnv.empty e),
adam@1355 360 ("fxs'", Print.p_list (CorePrint.p_exp CoreEnv.empty) fxs')];*)
adamc@1080 361 if not fin
adamc@1080 362 orelse List.all (fn (ERel _, _) => true
adamc@1080 363 | _ => false) fxs'
adam@1355 364 orelse List.exists (not o valueish) fxs'
adamc@1079 365 orelse (IS.numItems fvs >= length fxs
adamc@1079 366 andalso IS.exists (fn n => functionInside (#2 (List.nth (env, n)))) fvs) then
adamc@1083 367 ((*Print.prefaces "No" [("name", Print.PD.string name),
adamc@1120 368 ("f", Print.PD.string (Int.toString f)),
adamc@1083 369 ("fxs'",
adam@1362 370 Print.p_list (CorePrint.p_exp CoreEnv.empty) fxs'),
adam@1362 371 ("b1", p_bool (not fin)),
adam@1362 372 ("b2", p_bool (List.all (fn (ERel _, _) => true
adam@1362 373 | _ => false) fxs')),
adam@1362 374 ("b2", p_bool (List.exists (not o valueish) fxs')),
adam@1362 375 ("b3", p_bool (IS.numItems fvs >= length fxs
adam@1362 376 andalso IS.exists (fn n => functionInside (#2 (List.nth (env, n)))) fvs))];*)
adamc@1083 377 default ())
adamc@488 378 else
adam@1314 379 case (KM.find (args, (vts, fxs')),
adamc@1083 380 SS.member (!mayNotSpec, name) (*orelse IS.member (#specialized st, f)*)) of
adamc@800 381 (SOME f', _) =>
adamc@485 382 let
adamc@488 383 val e = (ENamed f', loc)
adamc@488 384 val e = IS.foldr (fn (arg, e) => (EApp (e, (ERel arg, loc)), loc))
adamc@488 385 e fvs
adamc@1079 386 val e = foldl (fn (arg, e) => (EApp (e, arg), loc))
adamc@488 387 e xs
adamc@488 388 in
adamc@488 389 (*Print.prefaces "Brand new (reuse)"
adamc@721 390 [("e'", CorePrint.p_exp CoreEnv.empty e)];*)
adamc@1080 391 (e, st)
adamc@488 392 end
adamc@1083 393 | (_, true) => ((*Print.prefaces ("No!(" ^ name ^ ")")
adamc@818 394 [("fxs'",
adamc@818 395 Print.p_list (CorePrint.p_exp CoreEnv.empty) fxs')];*)
adamc@1080 396 default ())
adamc@800 397 | (NONE, false) =>
adamc@488 398 let
adamc@800 399 (*val () = Print.prefaces "New one"
adamc@800 400 [("f", Print.PD.string (Int.toString f)),
adamc@800 401 ("mns", Print.p_list Print.PD.string
adamc@800 402 (SS.listItems (!mayNotSpec)))]*)
adamc@800 403
adamc@818 404 (*val () = Print.prefaces ("Yes(" ^ name ^ ")")
adamc@818 405 [("fxs'",
adamc@818 406 Print.p_list (CorePrint.p_exp CoreEnv.empty) fxs')]*)
adamc@818 407
adamc@1079 408 fun subBody (body, typ, fxs') =
adamc@1079 409 case (#1 body, #1 typ, fxs') of
adamc@488 410 (_, _, []) => SOME (body, typ)
adamc@1079 411 | (EAbs (_, _, _, body'), TFun (_, typ'), x :: fxs'') =>
adamc@488 412 let
adamc@1079 413 val body'' = E.subExpInExp (0, x) body'
adamc@488 414 in
adamc@488 415 subBody (body'',
adamc@488 416 typ',
adamc@1079 417 fxs'')
adamc@488 418 end
adamc@488 419 | _ => NONE
adamc@488 420 in
adamc@1079 421 case subBody (body, typ, fxs') of
adamc@1080 422 NONE => default ()
adamc@488 423 | SOME (body', typ') =>
adamc@488 424 let
adamc@488 425 val f' = #maxName st
adam@1314 426 val args = KM.insert (args, (vts, fxs'), f')
adamc@488 427 val funcs = IM.insert (#funcs st, f, {name = name,
adamc@488 428 args = args,
adamc@488 429 body = body,
adamc@488 430 typ = typ,
adamc@488 431 tag = tag})
adamc@1079 432
adamc@488 433 val st = {
adamc@488 434 maxName = f' + 1,
adamc@488 435 funcs = funcs,
adamc@1079 436 decls = #decls st,
adamc@1080 437 specialized = IS.add (#specialized st, f')
adamc@488 438 }
adamc@487 439
adamc@488 440 (*val () = Print.prefaces "specExp"
adamc@488 441 [("f", CorePrint.p_exp env (ENamed f, loc)),
adamc@488 442 ("f'", CorePrint.p_exp env (ENamed f', loc)),
adamc@488 443 ("xs", Print.p_list (CorePrint.p_exp env) xs),
adamc@488 444 ("fxs'", Print.p_list
adamc@488 445 (CorePrint.p_exp E.empty) fxs'),
adamc@488 446 ("e", CorePrint.p_exp env (e, loc))]*)
adamc@488 447 val (body', typ') = IS.foldl (fn (n, (body', typ')) =>
adamc@488 448 let
adamc@521 449 val (x, xt) = List.nth (env, n)
adamc@488 450 in
adamc@488 451 ((EAbs (x, xt, typ', body'),
adamc@488 452 loc),
adamc@488 453 (TFun (xt, typ'), loc))
adamc@488 454 end)
adamc@488 455 (body', typ') fvs
adamc@800 456 val mns = !mayNotSpec
adamc@1080 457 (*val () = mayNotSpec := SS.add (mns, name)*)
adamc@1272 458 (*val () = print ("NEW: " ^ name ^ "__" ^ Int.toString f' ^ "\n");*)
adamc@1272 459 val body' = ReduceLocal.reduceExp body'
adamc@1080 460 (*val () = Print.preface ("PRE", CorePrint.p_exp CoreEnv.empty body')*)
adamc@1080 461 val (body', st) = exp (env, body', st)
adamc@800 462 val () = mayNotSpec := mns
adamc@482 463
adamc@488 464 val e' = (ENamed f', loc)
adamc@488 465 val e' = IS.foldr (fn (arg, e) => (EApp (e, (ERel arg, loc)), loc))
adamc@488 466 e' fvs
adamc@1079 467 val e' = foldl (fn (arg, e) => (EApp (e, arg), loc))
adamc@488 468 e' xs
adam@1362 469
adamc@488 470 (*val () = Print.prefaces "Brand new"
adamc@721 471 [("e'", CorePrint.p_exp CoreEnv.empty e'),
adamc@1080 472 ("e", CorePrint.p_exp CoreEnv.empty e),
adamc@721 473 ("body'", CorePrint.p_exp CoreEnv.empty body')]*)
adamc@488 474 in
adamc@1080 475 (e',
adamc@488 476 {maxName = #maxName st,
adamc@488 477 funcs = #funcs st,
adamc@1079 478 decls = (name, f', typ', body', tag) :: #decls st,
adamc@1079 479 specialized = #specialized st})
adamc@488 480 end
adamc@485 481 end
adamc@488 482 end
adamc@485 483 end
adamc@482 484
adamc@521 485 fun doDecl (d, (st : state, changed)) =
adamc@488 486 let
adamc@521 487 (*val befor = Time.now ()*)
adamc@482 488
adamc@453 489 val funcs = #funcs st
adamc@453 490 val funcs =
adamc@453 491 case #1 d of
adamc@453 492 DValRec vis =>
adamc@453 493 foldl (fn ((x, n, c, e, tag), funcs) =>
adamc@453 494 IM.insert (funcs, n, {name = x,
adamc@453 495 args = KM.empty,
adamc@453 496 body = e,
adamc@453 497 typ = c,
adamc@453 498 tag = tag}))
adamc@453 499 funcs vis
adamc@453 500 | _ => funcs
adamc@453 501
adamc@453 502 val st = {maxName = #maxName st,
adamc@453 503 funcs = funcs,
adamc@1079 504 decls = [],
adamc@1079 505 specialized = #specialized st}
adamc@453 506
adamc@482 507 (*val () = Print.prefaces "decl" [("d", CorePrint.p_decl CoreEnv.empty d)]*)
adamc@521 508
adamc@1080 509 val () = mayNotSpec := SS.empty
adamc@1080 510
adamc@522 511 val (d', st) =
adamc@522 512 if isPoly d then
adamc@522 513 (d, st)
adamc@522 514 else
adamc@1080 515 case #1 d of
adamc@1080 516 DVal (x, n, t, e, s) =>
adamc@1080 517 let
adam@1362 518 (*val () = Print.preface ("Visiting", Print.box [Print.PD.string (x ^ "__" ^ Int.toString n),
adam@1362 519 Print.space,
adam@1362 520 Print.PD.string ":",
adam@1362 521 Print.space,
adam@1362 522 CorePrint.p_con CoreEnv.empty t])*)
adam@1362 523
adamc@1080 524 val (e, st) = exp ([], e, st)
adamc@1080 525 in
adamc@1080 526 ((DVal (x, n, t, e, s), #2 d), st)
adamc@1080 527 end
adamc@1080 528 | DValRec vis =>
adamc@1080 529 let
adamc@1120 530 (*val () = Print.preface ("Visiting", Print.p_list (fn vi =>
adam@1362 531 Print.box [Print.PD.string (#1 vi ^ "__"
adam@1362 532 ^ Int.toString
adam@1362 533 (#2 vi)),
adam@1362 534 Print.space,
adam@1362 535 Print.PD.string ":",
adam@1362 536 Print.space,
adam@1362 537 CorePrint.p_con CoreEnv.empty (#3 vi)])
adamc@1120 538 vis)*)
adamc@1120 539
adamc@1080 540 val (vis, st) = ListUtil.foldlMap (fn ((x, n, t, e, s), st) =>
adamc@1080 541 let
adamc@1120 542 val () = mayNotSpec := SS.empty
adamc@1080 543 val (e, st) = exp ([], e, st)
adamc@1080 544 in
adamc@1080 545 ((x, n, t, e, s), st)
adamc@1080 546 end) st vis
adamc@1080 547 in
adamc@1080 548 ((DValRec vis, #2 d), st)
adamc@1080 549 end
adamc@1080 550 | DTable (s, n, t, s1, e1, t1, e2, t2) =>
adamc@1080 551 let
adamc@1080 552 val (e1, st) = exp ([], e1, st)
adamc@1080 553 val (e2, st) = exp ([], e2, st)
adamc@1080 554 in
adamc@1080 555 ((DTable (s, n, t, s1, e1, t2, e2, t2), #2 d), st)
adamc@1080 556 end
adamc@1080 557 | DView (x, n, s, e, t) =>
adamc@1080 558 let
adamc@1080 559 val (e, st) = exp ([], e, st)
adamc@1080 560 in
adamc@1080 561 ((DView (x, n, s, e, t), #2 d), st)
adamc@1080 562 end
adamc@1080 563 | DTask (e1, e2) =>
adamc@1080 564 let
adamc@1080 565 val (e1, st) = exp ([], e1, st)
adamc@1080 566 val (e2, st) = exp ([], e2, st)
adamc@1080 567 in
adamc@1080 568 ((DTask (e1, e2), #2 d), st)
adamc@1080 569 end
adamc@1080 570 | _ => (d, st)
adamc@1080 571
adamc@1080 572 val () = mayNotSpec := SS.empty
adamc@521 573
adamc@482 574 (*val () = print "/decl\n"*)
adamc@443 575
adamc@443 576 val funcs = #funcs st
adamc@443 577 val funcs =
adamc@443 578 case #1 d of
adamc@443 579 DVal (x, n, c, e as (EAbs _, _), tag) =>
adamc@443 580 IM.insert (funcs, n, {name = x,
adamc@453 581 args = KM.empty,
adamc@443 582 body = e,
adamc@443 583 typ = c,
adamc@443 584 tag = tag})
adamc@469 585 | DVal (_, n, _, (ENamed n', _), _) =>
adamc@469 586 (case IM.find (funcs, n') of
adamc@469 587 NONE => funcs
adamc@469 588 | SOME v => IM.insert (funcs, n, v))
adamc@443 589 | _ => funcs
adamc@443 590
adamc@453 591 val (changed, ds) =
adamc@443 592 case #decls st of
adamc@453 593 [] => (changed, [d'])
adamc@453 594 | vis =>
adamc@453 595 (true, case d' of
adamc@453 596 (DValRec vis', _) => [(DValRec (vis @ vis'), ErrorMsg.dummySpan)]
adamc@453 597 | _ => [(DValRec vis, ErrorMsg.dummySpan), d'])
adamc@443 598 in
adamc@802 599 (*Print.prefaces "doDecl" [("d", CorePrint.p_decl E.empty d),
adamc@802 600 ("d'", CorePrint.p_decl E.empty d')];*)
adamc@521 601 (ds, ({maxName = #maxName st,
adamc@453 602 funcs = funcs,
adamc@1079 603 decls = [],
adamc@1079 604 specialized = #specialized st}, changed))
adamc@443 605 end
adamc@443 606
adamc@1120 607 (*val () = Print.preface ("RESET", CorePrint.p_file CoreEnv.empty file)*)
adamc@1079 608 val (ds, (st, changed)) = ListUtil.foldlMapConcat doDecl
adamc@521 609 ({maxName = U.File.maxName file + 1,
adamc@1080 610 funcs = funcs,
adamc@1079 611 decls = [],
adamc@1079 612 specialized = specialized},
adamc@488 613 false)
adamc@488 614 file
adamc@443 615 in
adamc@1120 616 (*print ("Changed = " ^ Bool.toString changed ^ "\n");*)
adamc@1080 617 (changed, ds, #funcs st, #specialized st)
adamc@443 618 end
adamc@443 619
adamc@1080 620 fun specializeL (funcs, specialized) file =
adamc@453 621 let
adamc@721 622 val file = ReduceLocal.reduce file
adamc@520 623 (*val file = ReduceLocal.reduce file*)
adamc@1080 624 val (changed, file, funcs, specialized) = specialize' (funcs, specialized) file
adamc@520 625 (*val file = ReduceLocal.reduce file
adamc@520 626 val file = CoreUntangle.untangle file
adamc@488 627 val file = Shake.shake file*)
adamc@453 628 in
adamc@488 629 (*print "Round over\n";*)
adamc@453 630 if changed then
adamc@520 631 let
adamc@721 632 (*val file = ReduceLocal.reduce file*)
adamc@802 633 (*val () = Print.prefaces "Pre-untangle" [("file", CorePrint.p_file CoreEnv.empty file)]*)
adamc@520 634 val file = CoreUntangle.untangle file
adamc@802 635 (*val () = Print.prefaces "Post-untangle" [("file", CorePrint.p_file CoreEnv.empty file)]*)
adamc@520 636 val file = Shake.shake file
adamc@520 637 in
adamc@520 638 (*print "Again!\n";*)
adamc@1080 639 (*Print.prefaces "Again" [("file", CorePrint.p_file CoreEnv.empty file)];*)
adamc@1080 640 specializeL (funcs, specialized) file
adamc@520 641 end
adamc@453 642 else
adamc@453 643 file
adamc@453 644 end
adamc@453 645
adamc@1080 646 val specialize = specializeL (IM.empty, IS.empty)
adamc@1079 647
adamc@443 648 end