Mercurial > urweb

annotate src/especialize.sml @ 1665:f9ffe8497742

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Fix channel delivery to handle sending of messages for channels whose clients haven't connected yet
author Adam Chlipala <adam@chlipala.net>
date Sun, 08 Jan 2012 15:47:05 -0500
parents 0577be31a435
children 833402503855
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
adam@1663 183 val (es, st) = ListUtil.foldlMap (fn ((e, t), st) =>
adam@1663 184 let
adam@1663 185 val (e, st) = exp (env, e, st)
adam@1663 186 in
adam@1663 187 ((e, t), st)
adam@1663 188 end) st es
adamc@1080 189 in
adamc@1080 190 ((EFfiApp (m, x, es), loc), st)
adamc@1080 191 end
adamc@1080 192 | EApp (e1, e2) =>
adamc@1080 193 let
adamc@1080 194 val (e1, st) = exp (env, e1, st)
adamc@1080 195 val (e2, st) = exp (env, e2, st)
adamc@1080 196 in
adamc@1080 197 ((EApp (e1, e2), loc), st)
adamc@1080 198 end
adamc@1080 199 | EAbs (x, d, r, e) =>
adamc@1080 200 let
adamc@1080 201 val (e, st) = exp ((x, d) :: env, e, st)
adamc@1080 202 in
adamc@1080 203 ((EAbs (x, d, r, e), loc), st)
adamc@1080 204 end
adamc@1080 205 | ECApp (e, c) =>
adamc@1080 206 let
adamc@1080 207 val (e, st) = exp (env, e, st)
adamc@1080 208 in
adamc@1080 209 ((ECApp (e, c), loc), st)
adamc@1080 210 end
adamc@1185 211 | ECAbs _ => (e, st)
adamc@1120 212 | EKAbs _ => (e, st)
adamc@1080 213 | EKApp (e, k) =>
adamc@1080 214 let
adamc@1080 215 val (e, st) = exp (env, e, st)
adamc@1080 216 in
adamc@1080 217 ((EKApp (e, k), loc), st)
adamc@1080 218 end
adamc@1080 219 | ERecord fs =>
adamc@1080 220 let
adamc@1080 221 val (fs, st) = ListUtil.foldlMap (fn ((c1, e, c2), st) =>
adamc@1080 222 let
adamc@1080 223 val (e, st) = exp (env, e, st)
adamc@1080 224 in
adamc@1080 225 ((c1, e, c2), st)
adamc@1080 226 end) st fs
adamc@1080 227 in
adamc@1080 228 ((ERecord fs, loc), st)
adamc@1080 229 end
adamc@1080 230 | EField (e, c, cs) =>
adamc@1080 231 let
adamc@1080 232 val (e, st) = exp (env, e, st)
adamc@1080 233 in
adamc@1080 234 ((EField (e, c, cs), loc), st)
adamc@1080 235 end
adamc@1080 236 | EConcat (e1, c1, e2, c2) =>
adamc@1080 237 let
adamc@1080 238 val (e1, st) = exp (env, e1, st)
adamc@1080 239 val (e2, st) = exp (env, e2, st)
adamc@1080 240 in
adamc@1080 241 ((EConcat (e1, c1, e2, c2), loc), st)
adamc@1080 242 end
adamc@1080 243 | ECut (e, c, cs) =>
adamc@1080 244 let
adamc@1080 245 val (e, st) = exp (env, e, st)
adamc@1080 246 in
adamc@1080 247 ((ECut (e, c, cs), loc), st)
adamc@1080 248 end
adamc@1080 249 | ECutMulti (e, c, cs) =>
adamc@1080 250 let
adamc@1080 251 val (e, st) = exp (env, e, st)
adamc@1080 252 in
adamc@1080 253 ((ECutMulti (e, c, cs), loc), st)
adamc@1080 254 end
adamc@1080 255
adamc@1080 256 | ECase (e, pes, cs) =>
adamc@1080 257 let
adamc@1080 258 val (e, st) = exp (env, e, st)
adamc@1080 259 val (pes, st) = ListUtil.foldlMap (fn ((p, e), st) =>
adamc@1080 260 let
adamc@1080 261 val (e, st) = exp (E.patBindsL p @ env, e, st)
adamc@1080 262 in
adamc@1080 263 ((p, e), st)
adamc@1080 264 end) st pes
adamc@1080 265 in
adamc@1080 266 ((ECase (e, pes, cs), loc), st)
adamc@1080 267 end
adamc@1080 268
adamc@1080 269 | EWrite e =>
adamc@1080 270 let
adamc@1080 271 val (e, st) = exp (env, e, st)
adamc@1080 272 in
adamc@1080 273 ((EWrite e, loc), st)
adamc@1080 274 end
adamc@1080 275 | EClosure (n, es) =>
adamc@1080 276 let
adamc@1080 277 val (es, st) = ListUtil.foldlMap (fn (e, st) => exp (env, e, st)) st es
adamc@1080 278 in
adamc@1080 279 ((EClosure (n, es), loc), st)
adamc@1080 280 end
adamc@1080 281 | ELet (x, t, e1, e2) =>
adamc@1080 282 let
adamc@1080 283 val (e1, st) = exp (env, e1, st)
adamc@1080 284 val (e2, st) = exp ((x, t) :: env, e2, st)
adamc@1080 285 in
adamc@1080 286 ((ELet (x, t, e1, e2), loc), st)
adamc@1080 287 end
adamc@1080 288 | EServerCall (n, es, t) =>
adamc@1080 289 let
adamc@1080 290 val (es, st) = ListUtil.foldlMap (fn (e, st) => exp (env, e, st)) st es
adamc@1080 291 in
adamc@1080 292 ((EServerCall (n, es, t), loc), st)
adamc@1080 293 end
adamc@482 294 in
adamc@482 295 case getApp e of
adamc@1080 296 NONE => default ()
adamc@488 297 | SOME (f, xs) =>
adamc@485 298 case IM.find (#funcs st, f) of
adamc@1272 299 NONE => ((*print ("No find: " ^ Int.toString f ^ "\n");*) default ())
adamc@485 300 | SOME {name, args, body, typ, tag} =>
adamc@488 301 let
adamc@1080 302 val (xs, st) = ListUtil.foldlMap (fn (e, st) => exp (env, e, st)) st xs
adamc@1080 303
adamc@721 304 (*val () = Print.prefaces "Consider" [("e", CorePrint.p_exp CoreEnv.empty
adamc@721 305 (e, ErrorMsg.dummySpan))]*)
adamc@721 306
adamc@488 307 val loc = ErrorMsg.dummySpan
adamc@488 308
adamc@1080 309 fun findSplit av (xs, typ, fxs, fvs, fin) =
adamc@488 310 case (#1 typ, xs) of
adamc@488 311 (TFun (dom, ran), e :: xs') =>
adamc@1078 312 let
adamc@1079 313 val av = case #1 e of
adamc@1079 314 ERel _ => av
adamc@1079 315 | _ => false
adamc@1078 316 in
adamc@1079 317 if functionInside dom orelse (av andalso case #1 e of
adamc@1079 318 ERel _ => true
adamc@1079 319 | _ => false) then
adamc@1079 320 findSplit av (xs',
adamc@1079 321 ran,
adamc@1079 322 e :: fxs,
adamc@1080 323 IS.union (fvs, freeVars e),
adamc@1080 324 fin orelse functionInside dom)
adamc@1078 325 else
adamc@1080 326 (rev fxs, xs, fvs, fin)
adamc@1078 327 end
adamc@1080 328 | _ => (rev fxs, xs, fvs, fin)
adamc@488 329
adamc@1080 330 val (fxs, xs, fvs, fin) = findSplit true (xs, typ, [], IS.empty, false)
adamc@1079 331
adam@1382 332 fun valueish (all as (e, _)) =
adam@1355 333 case e of
adam@1355 334 EPrim _ => true
adam@1355 335 | ERel _ => true
adam@1355 336 | ENamed _ => true
adam@1355 337 | ECon (_, _, _, NONE) => true
adam@1355 338 | ECon (_, _, _, SOME e) => valueish e
adam@1355 339 | EFfi (_, _) => true
adam@1355 340 | EAbs _ => true
adam@1355 341 | ECAbs _ => true
adam@1355 342 | EKAbs _ => true
adam@1355 343 | ECApp (e, _) => valueish e
adam@1355 344 | EKApp (e, _) => valueish e
adam@1383 345 | EApp (e1, e2) => valueish e1 andalso valueish e2
adam@1355 346 | ERecord xes => List.all (valueish o #2) xes
adam@1383 347 | EField (e, _, _) => valueish e
adam@1355 348 | _ => false
adam@1355 349
adam@1314 350 val vts = map (fn n => #2 (List.nth (env, n))) (IS.listItems fvs)
adamc@1079 351 val fxs' = map (squish (IS.listItems fvs)) fxs
adam@1362 352
adam@1362 353 val p_bool = Print.PD.string o Bool.toString
adamc@488 354 in
adam@1355 355 (*Print.prefaces "Func" [("name", Print.PD.string name),
adam@1355 356 ("e", CorePrint.p_exp CoreEnv.empty e),
adam@1355 357 ("fxs'", Print.p_list (CorePrint.p_exp CoreEnv.empty) fxs')];*)
adamc@1080 358 if not fin
adamc@1080 359 orelse List.all (fn (ERel _, _) => true
adamc@1080 360 | _ => false) fxs'
adam@1355 361 orelse List.exists (not o valueish) fxs'
adamc@1079 362 orelse (IS.numItems fvs >= length fxs
adamc@1079 363 andalso IS.exists (fn n => functionInside (#2 (List.nth (env, n)))) fvs) then
adamc@1083 364 ((*Print.prefaces "No" [("name", Print.PD.string name),
adamc@1120 365 ("f", Print.PD.string (Int.toString f)),
adamc@1083 366 ("fxs'",
adam@1362 367 Print.p_list (CorePrint.p_exp CoreEnv.empty) fxs'),
adam@1362 368 ("b1", p_bool (not fin)),
adam@1362 369 ("b2", p_bool (List.all (fn (ERel _, _) => true
adam@1362 370 | _ => false) fxs')),
adam@1382 371 ("b3", p_bool (List.exists (not o valueish) fxs')),
adam@1382 372 ("b4", p_bool (IS.numItems fvs >= length fxs
adam@1362 373 andalso IS.exists (fn n => functionInside (#2 (List.nth (env, n)))) fvs))];*)
adamc@1083 374 default ())
adamc@488 375 else
adam@1314 376 case (KM.find (args, (vts, fxs')),
adamc@1083 377 SS.member (!mayNotSpec, name) (*orelse IS.member (#specialized st, f)*)) of
adamc@800 378 (SOME f', _) =>
adamc@485 379 let
adamc@488 380 val e = (ENamed f', loc)
adamc@488 381 val e = IS.foldr (fn (arg, e) => (EApp (e, (ERel arg, loc)), loc))
adamc@488 382 e fvs
adamc@1079 383 val e = foldl (fn (arg, e) => (EApp (e, arg), loc))
adamc@488 384 e xs
adamc@488 385 in
adamc@488 386 (*Print.prefaces "Brand new (reuse)"
adamc@721 387 [("e'", CorePrint.p_exp CoreEnv.empty e)];*)
adamc@1080 388 (e, st)
adamc@488 389 end
adamc@1083 390 | (_, true) => ((*Print.prefaces ("No!(" ^ name ^ ")")
adamc@818 391 [("fxs'",
adamc@818 392 Print.p_list (CorePrint.p_exp CoreEnv.empty) fxs')];*)
adamc@1080 393 default ())
adamc@800 394 | (NONE, false) =>
adamc@488 395 let
adamc@800 396 (*val () = Print.prefaces "New one"
adamc@800 397 [("f", Print.PD.string (Int.toString f)),
adamc@800 398 ("mns", Print.p_list Print.PD.string
adamc@800 399 (SS.listItems (!mayNotSpec)))]*)
adamc@800 400
adamc@818 401 (*val () = Print.prefaces ("Yes(" ^ name ^ ")")
adamc@818 402 [("fxs'",
adamc@818 403 Print.p_list (CorePrint.p_exp CoreEnv.empty) fxs')]*)
adamc@818 404
adamc@1079 405 fun subBody (body, typ, fxs') =
adamc@1079 406 case (#1 body, #1 typ, fxs') of
adamc@488 407 (_, _, []) => SOME (body, typ)
adamc@1079 408 | (EAbs (_, _, _, body'), TFun (_, typ'), x :: fxs'') =>
adamc@488 409 let
adamc@1079 410 val body'' = E.subExpInExp (0, x) body'
adamc@488 411 in
adamc@488 412 subBody (body'',
adamc@488 413 typ',
adamc@1079 414 fxs'')
adamc@488 415 end
adamc@488 416 | _ => NONE
adamc@488 417 in
adamc@1079 418 case subBody (body, typ, fxs') of
adamc@1080 419 NONE => default ()
adamc@488 420 | SOME (body', typ') =>
adamc@488 421 let
adamc@488 422 val f' = #maxName st
adam@1314 423 val args = KM.insert (args, (vts, fxs'), f')
adamc@488 424 val funcs = IM.insert (#funcs st, f, {name = name,
adamc@488 425 args = args,
adamc@488 426 body = body,
adamc@488 427 typ = typ,
adamc@488 428 tag = tag})
adamc@1079 429
adamc@488 430 val st = {
adamc@488 431 maxName = f' + 1,
adamc@488 432 funcs = funcs,
adamc@1079 433 decls = #decls st,
adamc@1080 434 specialized = IS.add (#specialized st, f')
adamc@488 435 }
adamc@487 436
adamc@488 437 (*val () = Print.prefaces "specExp"
adamc@488 438 [("f", CorePrint.p_exp env (ENamed f, loc)),
adamc@488 439 ("f'", CorePrint.p_exp env (ENamed f', loc)),
adamc@488 440 ("xs", Print.p_list (CorePrint.p_exp env) xs),
adamc@488 441 ("fxs'", Print.p_list
adamc@488 442 (CorePrint.p_exp E.empty) fxs'),
adamc@488 443 ("e", CorePrint.p_exp env (e, loc))]*)
adamc@488 444 val (body', typ') = IS.foldl (fn (n, (body', typ')) =>
adamc@488 445 let
adamc@521 446 val (x, xt) = List.nth (env, n)
adamc@488 447 in
adamc@488 448 ((EAbs (x, xt, typ', body'),
adamc@488 449 loc),
adamc@488 450 (TFun (xt, typ'), loc))
adamc@488 451 end)
adamc@488 452 (body', typ') fvs
adamc@800 453 val mns = !mayNotSpec
adamc@1080 454 (*val () = mayNotSpec := SS.add (mns, name)*)
adamc@1272 455 (*val () = print ("NEW: " ^ name ^ "__" ^ Int.toString f' ^ "\n");*)
adamc@1272 456 val body' = ReduceLocal.reduceExp body'
adamc@1080 457 (*val () = Print.preface ("PRE", CorePrint.p_exp CoreEnv.empty body')*)
adamc@1080 458 val (body', st) = exp (env, body', st)
adamc@800 459 val () = mayNotSpec := mns
adamc@482 460
adamc@488 461 val e' = (ENamed f', loc)
adamc@488 462 val e' = IS.foldr (fn (arg, e) => (EApp (e, (ERel arg, loc)), loc))
adamc@488 463 e' fvs
adamc@1079 464 val e' = foldl (fn (arg, e) => (EApp (e, arg), loc))
adamc@488 465 e' xs
adam@1362 466
adamc@488 467 (*val () = Print.prefaces "Brand new"
adamc@721 468 [("e'", CorePrint.p_exp CoreEnv.empty e'),
adamc@1080 469 ("e", CorePrint.p_exp CoreEnv.empty e),
adamc@721 470 ("body'", CorePrint.p_exp CoreEnv.empty body')]*)
adamc@488 471 in
adamc@1080 472 (e',
adamc@488 473 {maxName = #maxName st,
adamc@488 474 funcs = #funcs st,
adamc@1079 475 decls = (name, f', typ', body', tag) :: #decls st,
adamc@1079 476 specialized = #specialized st})
adamc@488 477 end
adamc@485 478 end
adamc@488 479 end
adamc@485 480 end
adamc@482 481
adamc@521 482 fun doDecl (d, (st : state, changed)) =
adamc@488 483 let
adamc@521 484 (*val befor = Time.now ()*)
adamc@482 485
adamc@453 486 val funcs = #funcs st
adamc@453 487 val funcs =
adamc@453 488 case #1 d of
adamc@453 489 DValRec vis =>
adamc@453 490 foldl (fn ((x, n, c, e, tag), funcs) =>
adamc@453 491 IM.insert (funcs, n, {name = x,
adamc@453 492 args = KM.empty,
adamc@453 493 body = e,
adamc@453 494 typ = c,
adamc@453 495 tag = tag}))
adamc@453 496 funcs vis
adamc@453 497 | _ => funcs
adamc@453 498
adamc@453 499 val st = {maxName = #maxName st,
adamc@453 500 funcs = funcs,
adamc@1079 501 decls = [],
adamc@1079 502 specialized = #specialized st}
adamc@453 503
adamc@482 504 (*val () = Print.prefaces "decl" [("d", CorePrint.p_decl CoreEnv.empty d)]*)
adamc@521 505
adamc@1080 506 val () = mayNotSpec := SS.empty
adamc@1080 507
adamc@522 508 val (d', st) =
adamc@522 509 if isPoly d then
adamc@522 510 (d, st)
adamc@522 511 else
adamc@1080 512 case #1 d of
adamc@1080 513 DVal (x, n, t, e, s) =>
adamc@1080 514 let
adam@1362 515 (*val () = Print.preface ("Visiting", Print.box [Print.PD.string (x ^ "__" ^ Int.toString n),
adam@1362 516 Print.space,
adam@1362 517 Print.PD.string ":",
adam@1362 518 Print.space,
adam@1362 519 CorePrint.p_con CoreEnv.empty t])*)
adam@1362 520
adamc@1080 521 val (e, st) = exp ([], e, st)
adamc@1080 522 in
adamc@1080 523 ((DVal (x, n, t, e, s), #2 d), st)
adamc@1080 524 end
adamc@1080 525 | DValRec vis =>
adamc@1080 526 let
adamc@1120 527 (*val () = Print.preface ("Visiting", Print.p_list (fn vi =>
adam@1362 528 Print.box [Print.PD.string (#1 vi ^ "__"
adam@1362 529 ^ Int.toString
adam@1362 530 (#2 vi)),
adam@1362 531 Print.space,
adam@1362 532 Print.PD.string ":",
adam@1362 533 Print.space,
adam@1362 534 CorePrint.p_con CoreEnv.empty (#3 vi)])
adamc@1120 535 vis)*)
adamc@1120 536
adamc@1080 537 val (vis, st) = ListUtil.foldlMap (fn ((x, n, t, e, s), st) =>
adamc@1080 538 let
adamc@1120 539 val () = mayNotSpec := SS.empty
adamc@1080 540 val (e, st) = exp ([], e, st)
adamc@1080 541 in
adamc@1080 542 ((x, n, t, e, s), st)
adamc@1080 543 end) st vis
adamc@1080 544 in
adamc@1080 545 ((DValRec vis, #2 d), st)
adamc@1080 546 end
adamc@1080 547 | DTable (s, n, t, s1, e1, t1, e2, t2) =>
adamc@1080 548 let
adamc@1080 549 val (e1, st) = exp ([], e1, st)
adamc@1080 550 val (e2, st) = exp ([], e2, st)
adamc@1080 551 in
adamc@1080 552 ((DTable (s, n, t, s1, e1, t2, e2, t2), #2 d), st)
adamc@1080 553 end
adamc@1080 554 | DView (x, n, s, e, t) =>
adamc@1080 555 let
adamc@1080 556 val (e, st) = exp ([], e, st)
adamc@1080 557 in
adamc@1080 558 ((DView (x, n, s, e, t), #2 d), st)
adamc@1080 559 end
adamc@1080 560 | DTask (e1, e2) =>
adamc@1080 561 let
adamc@1080 562 val (e1, st) = exp ([], e1, st)
adamc@1080 563 val (e2, st) = exp ([], e2, st)
adamc@1080 564 in
adamc@1080 565 ((DTask (e1, e2), #2 d), st)
adamc@1080 566 end
adamc@1080 567 | _ => (d, st)
adamc@1080 568
adamc@1080 569 val () = mayNotSpec := SS.empty
adamc@521 570
adamc@482 571 (*val () = print "/decl\n"*)
adamc@443 572
adamc@443 573 val funcs = #funcs st
adamc@443 574 val funcs =
adamc@443 575 case #1 d of
adamc@443 576 DVal (x, n, c, e as (EAbs _, _), tag) =>
adamc@443 577 IM.insert (funcs, n, {name = x,
adamc@453 578 args = KM.empty,
adamc@443 579 body = e,
adamc@443 580 typ = c,
adamc@443 581 tag = tag})
adamc@469 582 | DVal (_, n, _, (ENamed n', _), _) =>
adamc@469 583 (case IM.find (funcs, n') of
adamc@469 584 NONE => funcs
adamc@469 585 | SOME v => IM.insert (funcs, n, v))
adamc@443 586 | _ => funcs
adamc@443 587
adamc@453 588 val (changed, ds) =
adamc@443 589 case #decls st of
adamc@453 590 [] => (changed, [d'])
adamc@453 591 | vis =>
adamc@453 592 (true, case d' of
adamc@453 593 (DValRec vis', _) => [(DValRec (vis @ vis'), ErrorMsg.dummySpan)]
adamc@453 594 | _ => [(DValRec vis, ErrorMsg.dummySpan), d'])
adamc@443 595 in
adamc@802 596 (*Print.prefaces "doDecl" [("d", CorePrint.p_decl E.empty d),
adamc@802 597 ("d'", CorePrint.p_decl E.empty d')];*)
adamc@521 598 (ds, ({maxName = #maxName st,
adamc@453 599 funcs = funcs,
adamc@1079 600 decls = [],
adamc@1079 601 specialized = #specialized st}, changed))
adamc@443 602 end
adamc@443 603
adamc@1120 604 (*val () = Print.preface ("RESET", CorePrint.p_file CoreEnv.empty file)*)
adamc@1079 605 val (ds, (st, changed)) = ListUtil.foldlMapConcat doDecl
adamc@521 606 ({maxName = U.File.maxName file + 1,
adamc@1080 607 funcs = funcs,
adamc@1079 608 decls = [],
adamc@1079 609 specialized = specialized},
adamc@488 610 false)
adamc@488 611 file
adamc@443 612 in
adamc@1120 613 (*print ("Changed = " ^ Bool.toString changed ^ "\n");*)
adamc@1080 614 (changed, ds, #funcs st, #specialized st)
adamc@443 615 end
adamc@443 616
adamc@1080 617 fun specializeL (funcs, specialized) file =
adamc@453 618 let
adamc@721 619 val file = ReduceLocal.reduce file
adamc@520 620 (*val file = ReduceLocal.reduce file*)
adamc@1080 621 val (changed, file, funcs, specialized) = specialize' (funcs, specialized) file
adamc@520 622 (*val file = ReduceLocal.reduce file
adamc@520 623 val file = CoreUntangle.untangle file
adamc@488 624 val file = Shake.shake file*)
adamc@453 625 in
adamc@488 626 (*print "Round over\n";*)
adamc@453 627 if changed then
adamc@520 628 let
adamc@721 629 (*val file = ReduceLocal.reduce file*)
adamc@802 630 (*val () = Print.prefaces "Pre-untangle" [("file", CorePrint.p_file CoreEnv.empty file)]*)
adamc@520 631 val file = CoreUntangle.untangle file
adamc@802 632 (*val () = Print.prefaces "Post-untangle" [("file", CorePrint.p_file CoreEnv.empty file)]*)
adamc@520 633 val file = Shake.shake file
adamc@520 634 in
adamc@520 635 (*print "Again!\n";*)
adamc@1080 636 (*Print.prefaces "Again" [("file", CorePrint.p_file CoreEnv.empty file)];*)
adamc@1080 637 specializeL (funcs, specialized) file
adamc@520 638 end
adamc@453 639 else
adamc@453 640 file
adamc@453 641 end
adamc@453 642
adamc@1080 643 val specialize = specializeL (IM.empty, IS.empty)
adamc@1079 644
adamc@443 645 end