Mercurial > urweb

annotate src/especialize.sml @ 2258:b1ba35ce2613

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Fix bug where pure caching didn't treat FFI applications as effectful.
author Ziv Scully <ziv@mit.edu>
date Sun, 27 Sep 2015 17:02:14 -0400
parents 32784d27b5bc
children
rev   line source
adam@1848 1 (* Copyright (c) 2008-2013, 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,
adam@1675 112 tag : string,
adam@1675 113 constArgs : int (* What length prefix of the arguments never vary across recursive calls? *)
adamc@443 114 }
adamc@443 115
adamc@443 116 type state = {
adamc@443 117 maxName : int,
adamc@443 118 funcs : func IM.map,
adamc@1079 119 decls : (string * int * con * exp * string) list,
adamc@1080 120 specialized : IS.set
adamc@443 121 }
adamc@443 122
adamc@488 123 fun default (_, x, st) = (x, st)
adamc@443 124
adam@1863 125 fun functionInside known =
adam@1863 126 U.Con.exists {kind = fn _ => false,
adam@1863 127 con = fn TFun _ => true
adam@1863 128 | TCFun _ => true
adam@1863 129 | CFfi ("Basis", "transaction") => true
adam@1863 130 | CFfi ("Basis", "eq") => true
adam@1863 131 | CFfi ("Basis", "num") => true
adam@1863 132 | CFfi ("Basis", "ord") => true
adam@1863 133 | CFfi ("Basis", "show") => true
adam@1863 134 | CFfi ("Basis", "read") => true
adam@1863 135 | CFfi ("Basis", "sql_injectable_prim") => true
adam@1863 136 | CFfi ("Basis", "sql_injectable") => true
adam@1863 137 | CNamed n => IS.member (known, n)
adam@1863 138 | _ => false}
adam@1289 139
adam@1675 140 fun getApp (e, _) =
adam@1675 141 case e of
adam@1675 142 ENamed f => SOME (f, [])
adam@1675 143 | EApp (e1, e2) =>
adam@1675 144 (case getApp e1 of
adam@1675 145 NONE => NONE
adam@1675 146 | SOME (f, xs) => SOME (f, xs @ [e2]))
adam@1675 147 | _ => NONE
adam@1675 148
adam@1675 149 val getApp = fn e => case getApp e of
adam@1675 150 v as SOME (_, _ :: _) => v
adam@1675 151 | _ => NONE
adam@1675 152
adam@1675 153 val maxInt = Option.getOpt (Int.maxInt, 9999)
adam@1675 154
adam@1766 155 fun calcConstArgs enclosingFunctions e =
adam@1675 156 let
adam@1675 157 fun ca depth e =
adam@1675 158 case #1 e of
adam@1675 159 EPrim _ => maxInt
adam@1675 160 | ERel _ => maxInt
adam@1766 161 | ENamed n => if IS.member (enclosingFunctions, n) then 0 else maxInt
adam@1675 162 | ECon (_, _, _, NONE) => maxInt
adam@1675 163 | ECon (_, _, _, SOME e) => ca depth e
adam@1675 164 | EFfi _ => maxInt
adam@1675 165 | EFfiApp (_, _, ecs) => foldl (fn ((e, _), d) => Int.min (ca depth e, d)) maxInt ecs
adam@1675 166 | EApp (e1, e2) =>
adam@1675 167 let
adam@1675 168 fun default () = Int.min (ca depth e1, ca depth e2)
adam@1675 169 in
adam@1675 170 case getApp e of
adam@1675 171 NONE => default ()
adam@1675 172 | SOME (f, args) =>
adam@1766 173 if not (IS.member (enclosingFunctions, f)) then
adam@1675 174 default ()
adam@1675 175 else
adam@1675 176 let
adam@1675 177 fun visitArgs (count, args) =
adam@1675 178 case args of
adam@1675 179 [] => count
adam@1675 180 | arg :: args' =>
adam@1675 181 let
adam@1675 182 fun default () = foldl (fn (e, d) => Int.min (ca depth e, d)) count args
adam@1675 183 in
adam@1675 184 case #1 arg of
adam@1675 185 ERel n =>
adam@1676 186 if n = depth - 1 - count then
adam@1675 187 visitArgs (count + 1, args')
adam@1675 188 else
adam@1675 189 default ()
adam@1675 190 | _ => default ()
adam@1675 191 end
adam@1675 192 in
adam@1675 193 visitArgs (0, args)
adam@1675 194 end
adam@1675 195 end
adam@1675 196 | EAbs (_, _, _, e1) => ca (depth + 1) e1
adam@1675 197 | ECApp (e1, _) => ca depth e1
adam@1675 198 | ECAbs (_, _, e1) => ca depth e1
adam@1675 199 | EKAbs (_, e1) => ca depth e1
adam@1675 200 | EKApp (e1, _) => ca depth e1
adam@1675 201 | ERecord xets => foldl (fn ((_, e, _), d) => Int.min (ca depth e, d)) maxInt xets
adam@1675 202 | EField (e1, _, _) => ca depth e1
adam@1675 203 | EConcat (e1, _, e2, _) => Int.min (ca depth e1, ca depth e2)
adam@1675 204 | ECut (e1, _, _) => ca depth e1
adam@1675 205 | ECutMulti (e1, _, _) => ca depth e1
adam@1675 206 | ECase (e1, pes, _) => foldl (fn ((p, e), d) => Int.min (ca (depth + E.patBindsN p) e, d)) (ca depth e1) pes
adam@1675 207 | EWrite e1 => ca depth e1
adam@1675 208 | EClosure (_, es) => foldl (fn (e, d) => Int.min (ca depth e, d)) maxInt es
adam@1675 209 | ELet (_, _, e1, e2) => Int.min (ca depth e1, ca (depth + 1) e2)
adam@1848 210 | EServerCall (_, es, _, _) => foldl (fn (e, d) => Int.min (ca depth e, d)) maxInt es
adam@1675 211
adam@1675 212 fun enterAbs depth e =
adam@1675 213 case #1 e of
adam@1675 214 EAbs (_, _, _, e1) => enterAbs (depth + 1) e1
adam@1675 215 | _ => ca depth e
adam@1675 216 in
adam@1677 217 enterAbs 0 e
adam@1675 218 end
adam@1675 219
adam@1675 220
adam@1863 221 fun optionExists p opt =
adam@1863 222 case opt of
adam@1863 223 NONE => false
adam@1863 224 | SOME v => p v
adam@1863 225
adamc@1080 226 fun specialize' (funcs, specialized) file =
adamc@443 227 let
adam@1863 228 val known = foldl (fn (d, known) =>
adam@1863 229 case #1 d of
adam@1863 230 DCon (_, n, _, c) =>
adam@1863 231 if functionInside known c then
adam@1863 232 IS.add (known, n)
adam@1863 233 else
adam@1863 234 known
adam@1863 235 | DDatatype dts =>
adam@1863 236 if List.exists (List.exists (optionExists (functionInside known) o #3) o #4) dts then
adam@1863 237 foldl (fn (dt, known) => IS.add (known, #2 dt)) known dts
adam@1863 238 else
adam@1863 239 known
adam@1863 240 | _ => known)
adam@1863 241 IS.empty file
adam@1863 242
adamc@488 243 fun bind (env, b) =
adamc@488 244 case b of
adamc@521 245 U.Decl.RelE xt => xt :: env
adamc@521 246 | _ => env
adamc@488 247
adamc@1080 248 fun exp (env, e as (_, loc), st : state) =
adamc@482 249 let
adamc@721 250 (*val () = Print.prefaces "exp" [("e", CorePrint.p_exp CoreEnv.empty
adamc@721 251 (e, ErrorMsg.dummySpan))]*)
adamc@721 252
adamc@1080 253 fun default () =
adamc@1080 254 case #1 e of
adamc@1080 255 EPrim _ => (e, st)
adamc@1080 256 | ERel _ => (e, st)
adamc@1080 257 | ENamed _ => (e, st)
adamc@1080 258 | ECon (_, _, _, NONE) => (e, st)
adamc@1080 259 | ECon (dk, pc, cs, SOME e) =>
adamc@1080 260 let
adamc@1080 261 val (e, st) = exp (env, e, st)
adamc@1080 262 in
adamc@1080 263 ((ECon (dk, pc, cs, SOME e), loc), st)
adamc@1080 264 end
adamc@1080 265 | EFfi _ => (e, st)
adamc@1080 266 | EFfiApp (m, x, es) =>
adamc@1080 267 let
adam@1663 268 val (es, st) = ListUtil.foldlMap (fn ((e, t), st) =>
adam@1663 269 let
adam@1663 270 val (e, st) = exp (env, e, st)
adam@1663 271 in
adam@1663 272 ((e, t), st)
adam@1663 273 end) st es
adamc@1080 274 in
adamc@1080 275 ((EFfiApp (m, x, es), loc), st)
adamc@1080 276 end
adamc@1080 277 | EApp (e1, e2) =>
adamc@1080 278 let
adamc@1080 279 val (e1, st) = exp (env, e1, st)
adamc@1080 280 val (e2, st) = exp (env, e2, st)
adamc@1080 281 in
adamc@1080 282 ((EApp (e1, e2), loc), st)
adamc@1080 283 end
adamc@1080 284 | EAbs (x, d, r, e) =>
adamc@1080 285 let
adamc@1080 286 val (e, st) = exp ((x, d) :: env, e, st)
adamc@1080 287 in
adamc@1080 288 ((EAbs (x, d, r, e), loc), st)
adamc@1080 289 end
adamc@1080 290 | ECApp (e, c) =>
adamc@1080 291 let
adamc@1080 292 val (e, st) = exp (env, e, st)
adamc@1080 293 in
adamc@1080 294 ((ECApp (e, c), loc), st)
adamc@1080 295 end
adamc@1185 296 | ECAbs _ => (e, st)
adamc@1120 297 | EKAbs _ => (e, st)
adamc@1080 298 | EKApp (e, k) =>
adamc@1080 299 let
adamc@1080 300 val (e, st) = exp (env, e, st)
adamc@1080 301 in
adamc@1080 302 ((EKApp (e, k), loc), st)
adamc@1080 303 end
adamc@1080 304 | ERecord fs =>
adamc@1080 305 let
adamc@1080 306 val (fs, st) = ListUtil.foldlMap (fn ((c1, e, c2), st) =>
adamc@1080 307 let
adamc@1080 308 val (e, st) = exp (env, e, st)
adamc@1080 309 in
adamc@1080 310 ((c1, e, c2), st)
adamc@1080 311 end) st fs
adamc@1080 312 in
adamc@1080 313 ((ERecord fs, loc), st)
adamc@1080 314 end
adamc@1080 315 | EField (e, c, cs) =>
adamc@1080 316 let
adamc@1080 317 val (e, st) = exp (env, e, st)
adamc@1080 318 in
adamc@1080 319 ((EField (e, c, cs), loc), st)
adamc@1080 320 end
adamc@1080 321 | EConcat (e1, c1, e2, c2) =>
adamc@1080 322 let
adamc@1080 323 val (e1, st) = exp (env, e1, st)
adamc@1080 324 val (e2, st) = exp (env, e2, st)
adamc@1080 325 in
adamc@1080 326 ((EConcat (e1, c1, e2, c2), loc), st)
adamc@1080 327 end
adamc@1080 328 | ECut (e, c, cs) =>
adamc@1080 329 let
adamc@1080 330 val (e, st) = exp (env, e, st)
adamc@1080 331 in
adamc@1080 332 ((ECut (e, c, cs), loc), st)
adamc@1080 333 end
adamc@1080 334 | ECutMulti (e, c, cs) =>
adamc@1080 335 let
adamc@1080 336 val (e, st) = exp (env, e, st)
adamc@1080 337 in
adamc@1080 338 ((ECutMulti (e, c, cs), loc), st)
adamc@1080 339 end
adamc@1080 340
adamc@1080 341 | ECase (e, pes, cs) =>
adamc@1080 342 let
adamc@1080 343 val (e, st) = exp (env, e, st)
adamc@1080 344 val (pes, st) = ListUtil.foldlMap (fn ((p, e), st) =>
adamc@1080 345 let
adamc@1080 346 val (e, st) = exp (E.patBindsL p @ env, e, st)
adamc@1080 347 in
adamc@1080 348 ((p, e), st)
adamc@1080 349 end) st pes
adamc@1080 350 in
adamc@1080 351 ((ECase (e, pes, cs), loc), st)
adamc@1080 352 end
adamc@1080 353
adamc@1080 354 | EWrite e =>
adamc@1080 355 let
adamc@1080 356 val (e, st) = exp (env, e, st)
adamc@1080 357 in
adamc@1080 358 ((EWrite e, loc), st)
adamc@1080 359 end
adamc@1080 360 | EClosure (n, es) =>
adamc@1080 361 let
adamc@1080 362 val (es, st) = ListUtil.foldlMap (fn (e, st) => exp (env, e, st)) st es
adamc@1080 363 in
adamc@1080 364 ((EClosure (n, es), loc), st)
adamc@1080 365 end
adamc@1080 366 | ELet (x, t, e1, e2) =>
adamc@1080 367 let
adamc@1080 368 val (e1, st) = exp (env, e1, st)
adamc@1080 369 val (e2, st) = exp ((x, t) :: env, e2, st)
adamc@1080 370 in
adamc@1080 371 ((ELet (x, t, e1, e2), loc), st)
adamc@1080 372 end
adam@1848 373 | EServerCall (n, es, t, fm) =>
adamc@1080 374 let
adamc@1080 375 val (es, st) = ListUtil.foldlMap (fn (e, st) => exp (env, e, st)) st es
adamc@1080 376 in
adam@1848 377 ((EServerCall (n, es, t, fm), loc), st)
adamc@1080 378 end
adamc@482 379 in
adamc@482 380 case getApp e of
adamc@1080 381 NONE => default ()
adamc@488 382 | SOME (f, xs) =>
adamc@485 383 case IM.find (#funcs st, f) of
adamc@1272 384 NONE => ((*print ("No find: " ^ Int.toString f ^ "\n");*) default ())
adam@1675 385 | SOME {name, args, body, typ, tag, constArgs} =>
adamc@488 386 let
adamc@1080 387 val (xs, st) = ListUtil.foldlMap (fn (e, st) => exp (env, e, st)) st xs
adamc@1080 388
adam@1861 389 (*val () = Print.prefaces "Consider" [("e", CorePrint.p_exp CoreEnv.empty e)]*)
adamc@721 390
adamc@488 391 val loc = ErrorMsg.dummySpan
adamc@488 392
adam@1677 393 val oldXs = xs
adam@1677 394
adam@1861 395 fun findSplit av (initialPart, constArgs, xs, typ, fxs, fvs) =
adam@1861 396 let
adam@1861 397 fun default () =
adam@1861 398 if initialPart then
adam@1861 399 ([], oldXs, IS.empty)
adam@1677 400 else
adam@1861 401 (rev fxs, xs, fvs)
adam@1861 402 in
adam@1861 403 case (#1 typ, xs) of
adam@1861 404 (TFun (dom, ran), e :: xs') =>
adam@1861 405 if constArgs > 0 then
adam@1861 406 let
adam@1863 407 val fi = functionInside known dom
adam@1861 408 in
adam@1861 409 if initialPart orelse fi then
adam@1861 410 findSplit av (not fi andalso initialPart,
adam@1861 411 constArgs - 1,
adam@1861 412 xs',
adam@1861 413 ran,
adam@1861 414 e :: fxs,
adam@1861 415 IS.union (fvs, freeVars e))
adam@1861 416 else
adam@1861 417 default ()
adam@1861 418 end
adam@1861 419 else
adam@1861 420 default ()
adam@1861 421 | _ => default ()
adam@1861 422 end
adamc@488 423
adam@1861 424 val (fxs, xs, fvs) = findSplit true (true, constArgs, xs, typ, [], IS.empty)
adam@1355 425
adam@1314 426 val vts = map (fn n => #2 (List.nth (env, n))) (IS.listItems fvs)
adamc@1079 427 val fxs' = map (squish (IS.listItems fvs)) fxs
adam@1362 428
adam@1362 429 val p_bool = Print.PD.string o Bool.toString
adamc@488 430 in
adam@1355 431 (*Print.prefaces "Func" [("name", Print.PD.string name),
adam@1355 432 ("e", CorePrint.p_exp CoreEnv.empty e),
adam@1355 433 ("fxs'", Print.p_list (CorePrint.p_exp CoreEnv.empty) fxs')];*)
adam@1675 434 if List.all (fn (ERel _, _) => true
adam@1675 435 | _ => false) fxs' then
adam@1675 436 default ()
adamc@488 437 else
adam@1667 438 case KM.find (args, (vts, fxs')) of
adam@1667 439 SOME f' =>
adamc@485 440 let
adamc@488 441 val e = (ENamed f', loc)
adamc@488 442 val e = IS.foldr (fn (arg, e) => (EApp (e, (ERel arg, loc)), loc))
adamc@488 443 e fvs
adamc@1079 444 val e = foldl (fn (arg, e) => (EApp (e, arg), loc))
adamc@488 445 e xs
adamc@488 446 in
adamc@488 447 (*Print.prefaces "Brand new (reuse)"
adamc@721 448 [("e'", CorePrint.p_exp CoreEnv.empty e)];*)
adamc@1080 449 (e, st)
adamc@488 450 end
adam@1667 451 | NONE =>
adamc@488 452 let
adamc@800 453 (*val () = Print.prefaces "New one"
adam@1667 454 [("name", Print.PD.string name),
adam@1667 455 ("f", Print.PD.string (Int.toString f)),
adam@1667 456 ("|fvs|", Print.PD.string (Int.toString (IS.numItems fvs))),
adam@1667 457 ("|fxs|", Print.PD.string (Int.toString (length fxs))),
adam@1766 458 ("fxs'", Print.p_list (CorePrint.p_exp CoreEnv.empty) fxs'),
adam@1667 459 ("spec", Print.PD.string (Bool.toString (IS.member (#specialized st, f))))]*)
adamc@800 460
adamc@818 461 (*val () = Print.prefaces ("Yes(" ^ name ^ ")")
adamc@818 462 [("fxs'",
adamc@818 463 Print.p_list (CorePrint.p_exp CoreEnv.empty) fxs')]*)
adamc@818 464
adam@1675 465 (*val () = Print.prefaces name
adam@1675 466 [("Available", Print.PD.string (Int.toString constArgs)),
adam@1675 467 ("Used", Print.PD.string (Int.toString (length fxs'))),
adam@1675 468 ("fxs'",
adam@1675 469 Print.p_list (CorePrint.p_exp CoreEnv.empty) fxs')]*)
adam@1675 470
adamc@1079 471 fun subBody (body, typ, fxs') =
adamc@1079 472 case (#1 body, #1 typ, fxs') of
adamc@488 473 (_, _, []) => SOME (body, typ)
adamc@1079 474 | (EAbs (_, _, _, body'), TFun (_, typ'), x :: fxs'') =>
adamc@488 475 let
adamc@1079 476 val body'' = E.subExpInExp (0, x) body'
adamc@488 477 in
adamc@488 478 subBody (body'',
adamc@488 479 typ',
adamc@1079 480 fxs'')
adamc@488 481 end
adamc@488 482 | _ => NONE
adamc@488 483 in
adamc@1079 484 case subBody (body, typ, fxs') of
adamc@1080 485 NONE => default ()
adamc@488 486 | SOME (body', typ') =>
adamc@488 487 let
adamc@488 488 val f' = #maxName st
adam@1314 489 val args = KM.insert (args, (vts, fxs'), f')
adamc@488 490 val funcs = IM.insert (#funcs st, f, {name = name,
adamc@488 491 args = args,
adamc@488 492 body = body,
adamc@488 493 typ = typ,
adam@1675 494 tag = tag,
adam@1766 495 constArgs = calcConstArgs (IS.singleton f) body})
adamc@1079 496
adamc@488 497 val st = {
adamc@488 498 maxName = f' + 1,
adamc@488 499 funcs = funcs,
adamc@1079 500 decls = #decls st,
adamc@1080 501 specialized = IS.add (#specialized st, f')
adamc@488 502 }
adamc@487 503
adamc@488 504 (*val () = Print.prefaces "specExp"
adamc@488 505 [("f", CorePrint.p_exp env (ENamed f, loc)),
adamc@488 506 ("f'", CorePrint.p_exp env (ENamed f', loc)),
adamc@488 507 ("xs", Print.p_list (CorePrint.p_exp env) xs),
adamc@488 508 ("fxs'", Print.p_list
adamc@488 509 (CorePrint.p_exp E.empty) fxs'),
adamc@488 510 ("e", CorePrint.p_exp env (e, loc))]*)
adamc@488 511 val (body', typ') = IS.foldl (fn (n, (body', typ')) =>
adamc@488 512 let
adamc@521 513 val (x, xt) = List.nth (env, n)
adamc@488 514 in
adamc@488 515 ((EAbs (x, xt, typ', body'),
adamc@488 516 loc),
adamc@488 517 (TFun (xt, typ'), loc))
adamc@488 518 end)
adamc@488 519 (body', typ') fvs
adam@1861 520 (*val () = print ("NEW: " ^ name ^ "__" ^ Int.toString f' ^ "\n")*)
adamc@1272 521 val body' = ReduceLocal.reduceExp body'
adamc@1080 522 (*val () = Print.preface ("PRE", CorePrint.p_exp CoreEnv.empty body')*)
adamc@1080 523 val (body', st) = exp (env, body', st)
adamc@482 524
adamc@488 525 val e' = (ENamed f', loc)
adamc@488 526 val e' = IS.foldr (fn (arg, e) => (EApp (e, (ERel arg, loc)), loc))
adamc@488 527 e' fvs
adamc@1079 528 val e' = foldl (fn (arg, e) => (EApp (e, arg), loc))
adamc@488 529 e' xs
adam@1362 530
adamc@488 531 (*val () = Print.prefaces "Brand new"
adamc@721 532 [("e'", CorePrint.p_exp CoreEnv.empty e'),
adamc@1080 533 ("e", CorePrint.p_exp CoreEnv.empty e),
adamc@721 534 ("body'", CorePrint.p_exp CoreEnv.empty body')]*)
adamc@488 535 in
adamc@1080 536 (e',
adamc@488 537 {maxName = #maxName st,
adamc@488 538 funcs = #funcs st,
adamc@1079 539 decls = (name, f', typ', body', tag) :: #decls st,
adamc@1079 540 specialized = #specialized st})
adamc@488 541 end
adamc@485 542 end
adamc@488 543 end
adamc@485 544 end
adamc@482 545
adamc@521 546 fun doDecl (d, (st : state, changed)) =
adamc@488 547 let
adamc@521 548 (*val befor = Time.now ()*)
adamc@482 549
adamc@453 550 val funcs = #funcs st
adamc@453 551 val funcs =
adamc@453 552 case #1 d of
adamc@453 553 DValRec vis =>
adam@1766 554 let
adam@1766 555 val fs = foldl (fn ((_, n, _, _, _), fs) => IS.add (fs, n)) IS.empty vis
adam@1766 556 val constArgs = foldl (fn ((_, _, _, e, _), constArgs) =>
adam@1766 557 Int.min (constArgs, calcConstArgs fs e))
adam@1766 558 maxInt vis
adam@1766 559 in
adam@1861 560 (*Print.prefaces "ConstArgs" [("d", CorePrint.p_decl CoreEnv.empty d),
adam@1861 561 ("ca", Print.PD.string (Int.toString constArgs))];*)
adam@1766 562 foldl (fn ((x, n, c, e, tag), funcs) =>
adam@1766 563 IM.insert (funcs, n, {name = x,
adam@1766 564 args = KM.empty,
adam@1766 565 body = e,
adam@1766 566 typ = c,
adam@1766 567 tag = tag,
adam@1766 568 constArgs = constArgs}))
adam@1766 569 funcs vis
adam@1766 570 end
adamc@453 571 | _ => funcs
adamc@453 572
adamc@453 573 val st = {maxName = #maxName st,
adamc@453 574 funcs = funcs,
adamc@1079 575 decls = [],
adamc@1079 576 specialized = #specialized st}
adamc@453 577
adamc@482 578 (*val () = Print.prefaces "decl" [("d", CorePrint.p_decl CoreEnv.empty d)]*)
adamc@521 579
adamc@522 580 val (d', st) =
adamc@522 581 if isPoly d then
adamc@522 582 (d, st)
adamc@522 583 else
adamc@1080 584 case #1 d of
adamc@1080 585 DVal (x, n, t, e, s) =>
adamc@1080 586 let
adam@1362 587 (*val () = Print.preface ("Visiting", Print.box [Print.PD.string (x ^ "__" ^ Int.toString n),
adam@1362 588 Print.space,
adam@1362 589 Print.PD.string ":",
adam@1362 590 Print.space,
adam@1362 591 CorePrint.p_con CoreEnv.empty t])*)
adam@1362 592
adamc@1080 593 val (e, st) = exp ([], e, st)
adamc@1080 594 in
adamc@1080 595 ((DVal (x, n, t, e, s), #2 d), st)
adamc@1080 596 end
adamc@1080 597 | DValRec vis =>
adamc@1080 598 let
adamc@1120 599 (*val () = Print.preface ("Visiting", Print.p_list (fn vi =>
adam@1362 600 Print.box [Print.PD.string (#1 vi ^ "__"
adam@1362 601 ^ Int.toString
adam@1362 602 (#2 vi)),
adam@1362 603 Print.space,
adam@1362 604 Print.PD.string ":",
adam@1362 605 Print.space,
adam@1362 606 CorePrint.p_con CoreEnv.empty (#3 vi)])
adamc@1120 607 vis)*)
adamc@1120 608
adamc@1080 609 val (vis, st) = ListUtil.foldlMap (fn ((x, n, t, e, s), st) =>
adamc@1080 610 let
adamc@1080 611 val (e, st) = exp ([], e, st)
adamc@1080 612 in
adamc@1080 613 ((x, n, t, e, s), st)
adamc@1080 614 end) st vis
adamc@1080 615 in
adamc@1080 616 ((DValRec vis, #2 d), st)
adamc@1080 617 end
adamc@1080 618 | DTable (s, n, t, s1, e1, t1, e2, t2) =>
adamc@1080 619 let
adamc@1080 620 val (e1, st) = exp ([], e1, st)
adamc@1080 621 val (e2, st) = exp ([], e2, st)
adamc@1080 622 in
adamc@1080 623 ((DTable (s, n, t, s1, e1, t2, e2, t2), #2 d), st)
adamc@1080 624 end
adamc@1080 625 | DView (x, n, s, e, t) =>
adamc@1080 626 let
adamc@1080 627 val (e, st) = exp ([], e, st)
adamc@1080 628 in
adamc@1080 629 ((DView (x, n, s, e, t), #2 d), st)
adamc@1080 630 end
adamc@1080 631 | DTask (e1, e2) =>
adamc@1080 632 let
adamc@1080 633 val (e1, st) = exp ([], e1, st)
adamc@1080 634 val (e2, st) = exp ([], e2, st)
adamc@1080 635 in
adamc@1080 636 ((DTask (e1, e2), #2 d), st)
adamc@1080 637 end
adamc@1080 638 | _ => (d, st)
adamc@1080 639
adamc@482 640 (*val () = print "/decl\n"*)
adamc@443 641
adamc@443 642 val funcs = #funcs st
adamc@443 643 val funcs =
adamc@443 644 case #1 d of
adamc@443 645 DVal (x, n, c, e as (EAbs _, _), tag) =>
adam@1861 646 ((*Print.prefaces "ConstArgs[2]" [("d", CorePrint.p_decl CoreEnv.empty d),
adam@1861 647 ("ca", Print.PD.string (Int.toString (calcConstArgs (IS.singleton n) e)))];*)
adamc@443 648 IM.insert (funcs, n, {name = x,
adamc@453 649 args = KM.empty,
adamc@443 650 body = e,
adamc@443 651 typ = c,
adam@1675 652 tag = tag,
adam@1861 653 constArgs = calcConstArgs (IS.singleton n) e}))
adamc@469 654 | DVal (_, n, _, (ENamed n', _), _) =>
adamc@469 655 (case IM.find (funcs, n') of
adamc@469 656 NONE => funcs
adamc@469 657 | SOME v => IM.insert (funcs, n, v))
adamc@443 658 | _ => funcs
adamc@443 659
adamc@453 660 val (changed, ds) =
adamc@443 661 case #decls st of
adamc@453 662 [] => (changed, [d'])
adamc@453 663 | vis =>
adamc@453 664 (true, case d' of
adamc@453 665 (DValRec vis', _) => [(DValRec (vis @ vis'), ErrorMsg.dummySpan)]
adamc@453 666 | _ => [(DValRec vis, ErrorMsg.dummySpan), d'])
adamc@443 667 in
adamc@802 668 (*Print.prefaces "doDecl" [("d", CorePrint.p_decl E.empty d),
adamc@802 669 ("d'", CorePrint.p_decl E.empty d')];*)
adamc@521 670 (ds, ({maxName = #maxName st,
adamc@453 671 funcs = funcs,
adamc@1079 672 decls = [],
adamc@1079 673 specialized = #specialized st}, changed))
adamc@443 674 end
adamc@443 675
adamc@1120 676 (*val () = Print.preface ("RESET", CorePrint.p_file CoreEnv.empty file)*)
adamc@1079 677 val (ds, (st, changed)) = ListUtil.foldlMapConcat doDecl
adamc@521 678 ({maxName = U.File.maxName file + 1,
adamc@1080 679 funcs = funcs,
adamc@1079 680 decls = [],
adamc@1079 681 specialized = specialized},
adamc@488 682 false)
adamc@488 683 file
adamc@443 684 in
adamc@1120 685 (*print ("Changed = " ^ Bool.toString changed ^ "\n");*)
adamc@1080 686 (changed, ds, #funcs st, #specialized st)
adamc@443 687 end
adamc@443 688
adamc@1080 689 fun specializeL (funcs, specialized) file =
adamc@453 690 let
adamc@721 691 val file = ReduceLocal.reduce file
adamc@520 692 (*val file = ReduceLocal.reduce file*)
adamc@1080 693 val (changed, file, funcs, specialized) = specialize' (funcs, specialized) file
adamc@520 694 (*val file = ReduceLocal.reduce file
adamc@520 695 val file = CoreUntangle.untangle file
adamc@488 696 val file = Shake.shake file*)
adamc@453 697 in
adamc@488 698 (*print "Round over\n";*)
adamc@453 699 if changed then
adamc@520 700 let
adamc@721 701 (*val file = ReduceLocal.reduce file*)
adamc@802 702 (*val () = Print.prefaces "Pre-untangle" [("file", CorePrint.p_file CoreEnv.empty file)]*)
adamc@520 703 val file = CoreUntangle.untangle file
adamc@802 704 (*val () = Print.prefaces "Post-untangle" [("file", CorePrint.p_file CoreEnv.empty file)]*)
adamc@520 705 val file = Shake.shake file
adamc@520 706 in
adamc@520 707 (*print "Again!\n";*)
adamc@1080 708 (*Print.prefaces "Again" [("file", CorePrint.p_file CoreEnv.empty file)];*)
adamc@1080 709 specializeL (funcs, specialized) file
adamc@520 710 end
adamc@453 711 else
adamc@453 712 file
adamc@453 713 end
adamc@453 714
adamc@1080 715 val specialize = specializeL (IM.empty, IS.empty)
adamc@1079 716
adamc@443 717 end