Mercurial > urweb

annotate src/especialize.sml @ 1634:f4cb4eebf7ae

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