Mercurial > urweb

annotate src/especialize.sml @ 1739:c414850f206f

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Add support for -boot flag, which allows in-tree execution of Ur/Web The boot flag rewrites most hardcoded paths to point to the build directory, and also forces static compilation. This is convenient for developing Ur/Web, or if you cannot 'sudo make install' Ur/Web. The following changes were made: * Header files were moved to include/urweb instead of include; this lets FFI users point their C_INCLUDE_PATH at this directory at write <urweb/urweb.h>. For internal Ur/Web executables, we simply pass -I$PATH/include/urweb as normal. * Differentiate between LIB and SRCLIB; SRCLIB is Ur and JavaScript source files, while LIB is compiled products from libtool. For in-tree compilation these live in different places. * No longer reference Config for paths; instead use Settings; these settings can be changed dynamically by Compiler.enableBoot () (TODO: add a disableBoot function.) * config.h is now generated directly in include/urweb/config.h, for consistency's sake (especially since it gets installed along with the rest of the headers!) * All of the autotools build products got updated. * The linkStatic field in protocols now only contains the name of the build product, and not the absolute path. Future users have to be careful not to reference the Settings files to early, lest they get an old version (this was the source of two bugs during development of this patch.)
author Edward Z. Yang <ezyang@mit.edu>
date Wed, 02 May 2012 17:17:57 -0400
parents 3cfc79f92db7
children 92cfc69419bd
rev   line source
adam@1677 1 (* Copyright (c) 2008-2012, 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@1289 125 val functionInside = U.Con.exists {kind = fn _ => false,
adam@1289 126 con = fn TFun _ => true
adam@1289 127 | CFfi ("Basis", "transaction") => true
adam@1289 128 | CFfi ("Basis", "eq") => true
adam@1289 129 | CFfi ("Basis", "num") => true
adam@1289 130 | CFfi ("Basis", "ord") => true
adam@1289 131 | CFfi ("Basis", "show") => true
adam@1289 132 | CFfi ("Basis", "read") => true
adam@1289 133 | CFfi ("Basis", "sql_injectable_prim") => true
adam@1289 134 | CFfi ("Basis", "sql_injectable") => true
adam@1289 135 | _ => false}
adam@1289 136
adam@1675 137 fun getApp (e, _) =
adam@1675 138 case e of
adam@1675 139 ENamed f => SOME (f, [])
adam@1675 140 | EApp (e1, e2) =>
adam@1675 141 (case getApp e1 of
adam@1675 142 NONE => NONE
adam@1675 143 | SOME (f, xs) => SOME (f, xs @ [e2]))
adam@1675 144 | _ => NONE
adam@1675 145
adam@1675 146 val getApp = fn e => case getApp e of
adam@1675 147 v as SOME (_, _ :: _) => v
adam@1675 148 | _ => NONE
adam@1675 149
adam@1675 150 val maxInt = Option.getOpt (Int.maxInt, 9999)
adam@1675 151
adam@1675 152 fun calcConstArgs enclosingFunction e =
adam@1675 153 let
adam@1675 154 fun ca depth e =
adam@1675 155 case #1 e of
adam@1675 156 EPrim _ => maxInt
adam@1675 157 | ERel _ => maxInt
adam@1675 158 | ENamed n => if n = enclosingFunction then 0 else maxInt
adam@1675 159 | ECon (_, _, _, NONE) => maxInt
adam@1675 160 | ECon (_, _, _, SOME e) => ca depth e
adam@1675 161 | EFfi _ => maxInt
adam@1675 162 | EFfiApp (_, _, ecs) => foldl (fn ((e, _), d) => Int.min (ca depth e, d)) maxInt ecs
adam@1675 163 | EApp (e1, e2) =>
adam@1675 164 let
adam@1675 165 fun default () = Int.min (ca depth e1, ca depth e2)
adam@1675 166 in
adam@1675 167 case getApp e of
adam@1675 168 NONE => default ()
adam@1675 169 | SOME (f, args) =>
adam@1675 170 if f <> enclosingFunction then
adam@1675 171 default ()
adam@1675 172 else
adam@1675 173 let
adam@1675 174 fun visitArgs (count, args) =
adam@1675 175 case args of
adam@1675 176 [] => count
adam@1675 177 | arg :: args' =>
adam@1675 178 let
adam@1675 179 fun default () = foldl (fn (e, d) => Int.min (ca depth e, d)) count args
adam@1675 180 in
adam@1675 181 case #1 arg of
adam@1675 182 ERel n =>
adam@1676 183 if n = depth - 1 - count then
adam@1675 184 visitArgs (count + 1, args')
adam@1675 185 else
adam@1675 186 default ()
adam@1675 187 | _ => default ()
adam@1675 188 end
adam@1675 189 in
adam@1675 190 visitArgs (0, args)
adam@1675 191 end
adam@1675 192 end
adam@1675 193 | EAbs (_, _, _, e1) => ca (depth + 1) e1
adam@1675 194 | ECApp (e1, _) => ca depth e1
adam@1675 195 | ECAbs (_, _, e1) => ca depth e1
adam@1675 196 | EKAbs (_, e1) => ca depth e1
adam@1675 197 | EKApp (e1, _) => ca depth e1
adam@1675 198 | ERecord xets => foldl (fn ((_, e, _), d) => Int.min (ca depth e, d)) maxInt xets
adam@1675 199 | EField (e1, _, _) => ca depth e1
adam@1675 200 | EConcat (e1, _, e2, _) => Int.min (ca depth e1, ca depth e2)
adam@1675 201 | ECut (e1, _, _) => ca depth e1
adam@1675 202 | ECutMulti (e1, _, _) => ca depth e1
adam@1675 203 | ECase (e1, pes, _) => foldl (fn ((p, e), d) => Int.min (ca (depth + E.patBindsN p) e, d)) (ca depth e1) pes
adam@1675 204 | EWrite e1 => ca depth e1
adam@1675 205 | EClosure (_, es) => foldl (fn (e, d) => Int.min (ca depth e, d)) maxInt es
adam@1675 206 | ELet (_, _, e1, e2) => Int.min (ca depth e1, ca (depth + 1) e2)
adam@1675 207 | EServerCall (_, es, _) => foldl (fn (e, d) => Int.min (ca depth e, d)) maxInt es
adam@1675 208
adam@1675 209 fun enterAbs depth e =
adam@1675 210 case #1 e of
adam@1675 211 EAbs (_, _, _, e1) => enterAbs (depth + 1) e1
adam@1675 212 | _ => ca depth e
adam@1675 213 in
adam@1677 214 enterAbs 0 e
adam@1675 215 end
adam@1675 216
adam@1675 217
adamc@1080 218 fun specialize' (funcs, specialized) file =
adamc@443 219 let
adamc@488 220 fun bind (env, b) =
adamc@488 221 case b of
adamc@521 222 U.Decl.RelE xt => xt :: env
adamc@521 223 | _ => env
adamc@488 224
adamc@1080 225 fun exp (env, e as (_, loc), st : state) =
adamc@482 226 let
adamc@721 227 (*val () = Print.prefaces "exp" [("e", CorePrint.p_exp CoreEnv.empty
adamc@721 228 (e, ErrorMsg.dummySpan))]*)
adamc@721 229
adamc@1080 230 fun default () =
adamc@1080 231 case #1 e of
adamc@1080 232 EPrim _ => (e, st)
adamc@1080 233 | ERel _ => (e, st)
adamc@1080 234 | ENamed _ => (e, st)
adamc@1080 235 | ECon (_, _, _, NONE) => (e, st)
adamc@1080 236 | ECon (dk, pc, cs, SOME e) =>
adamc@1080 237 let
adamc@1080 238 val (e, st) = exp (env, e, st)
adamc@1080 239 in
adamc@1080 240 ((ECon (dk, pc, cs, SOME e), loc), st)
adamc@1080 241 end
adamc@1080 242 | EFfi _ => (e, st)
adamc@1080 243 | EFfiApp (m, x, es) =>
adamc@1080 244 let
adam@1663 245 val (es, st) = ListUtil.foldlMap (fn ((e, t), st) =>
adam@1663 246 let
adam@1663 247 val (e, st) = exp (env, e, st)
adam@1663 248 in
adam@1663 249 ((e, t), st)
adam@1663 250 end) st es
adamc@1080 251 in
adamc@1080 252 ((EFfiApp (m, x, es), loc), st)
adamc@1080 253 end
adamc@1080 254 | EApp (e1, e2) =>
adamc@1080 255 let
adamc@1080 256 val (e1, st) = exp (env, e1, st)
adamc@1080 257 val (e2, st) = exp (env, e2, st)
adamc@1080 258 in
adamc@1080 259 ((EApp (e1, e2), loc), st)
adamc@1080 260 end
adamc@1080 261 | EAbs (x, d, r, e) =>
adamc@1080 262 let
adamc@1080 263 val (e, st) = exp ((x, d) :: env, e, st)
adamc@1080 264 in
adamc@1080 265 ((EAbs (x, d, r, e), loc), st)
adamc@1080 266 end
adamc@1080 267 | ECApp (e, c) =>
adamc@1080 268 let
adamc@1080 269 val (e, st) = exp (env, e, st)
adamc@1080 270 in
adamc@1080 271 ((ECApp (e, c), loc), st)
adamc@1080 272 end
adamc@1185 273 | ECAbs _ => (e, st)
adamc@1120 274 | EKAbs _ => (e, st)
adamc@1080 275 | EKApp (e, k) =>
adamc@1080 276 let
adamc@1080 277 val (e, st) = exp (env, e, st)
adamc@1080 278 in
adamc@1080 279 ((EKApp (e, k), loc), st)
adamc@1080 280 end
adamc@1080 281 | ERecord fs =>
adamc@1080 282 let
adamc@1080 283 val (fs, st) = ListUtil.foldlMap (fn ((c1, e, c2), st) =>
adamc@1080 284 let
adamc@1080 285 val (e, st) = exp (env, e, st)
adamc@1080 286 in
adamc@1080 287 ((c1, e, c2), st)
adamc@1080 288 end) st fs
adamc@1080 289 in
adamc@1080 290 ((ERecord fs, loc), st)
adamc@1080 291 end
adamc@1080 292 | EField (e, c, cs) =>
adamc@1080 293 let
adamc@1080 294 val (e, st) = exp (env, e, st)
adamc@1080 295 in
adamc@1080 296 ((EField (e, c, cs), loc), st)
adamc@1080 297 end
adamc@1080 298 | EConcat (e1, c1, e2, c2) =>
adamc@1080 299 let
adamc@1080 300 val (e1, st) = exp (env, e1, st)
adamc@1080 301 val (e2, st) = exp (env, e2, st)
adamc@1080 302 in
adamc@1080 303 ((EConcat (e1, c1, e2, c2), loc), st)
adamc@1080 304 end
adamc@1080 305 | ECut (e, c, cs) =>
adamc@1080 306 let
adamc@1080 307 val (e, st) = exp (env, e, st)
adamc@1080 308 in
adamc@1080 309 ((ECut (e, c, cs), loc), st)
adamc@1080 310 end
adamc@1080 311 | ECutMulti (e, c, cs) =>
adamc@1080 312 let
adamc@1080 313 val (e, st) = exp (env, e, st)
adamc@1080 314 in
adamc@1080 315 ((ECutMulti (e, c, cs), loc), st)
adamc@1080 316 end
adamc@1080 317
adamc@1080 318 | ECase (e, pes, cs) =>
adamc@1080 319 let
adamc@1080 320 val (e, st) = exp (env, e, st)
adamc@1080 321 val (pes, st) = ListUtil.foldlMap (fn ((p, e), st) =>
adamc@1080 322 let
adamc@1080 323 val (e, st) = exp (E.patBindsL p @ env, e, st)
adamc@1080 324 in
adamc@1080 325 ((p, e), st)
adamc@1080 326 end) st pes
adamc@1080 327 in
adamc@1080 328 ((ECase (e, pes, cs), loc), st)
adamc@1080 329 end
adamc@1080 330
adamc@1080 331 | EWrite e =>
adamc@1080 332 let
adamc@1080 333 val (e, st) = exp (env, e, st)
adamc@1080 334 in
adamc@1080 335 ((EWrite e, loc), st)
adamc@1080 336 end
adamc@1080 337 | EClosure (n, es) =>
adamc@1080 338 let
adamc@1080 339 val (es, st) = ListUtil.foldlMap (fn (e, st) => exp (env, e, st)) st es
adamc@1080 340 in
adamc@1080 341 ((EClosure (n, es), loc), st)
adamc@1080 342 end
adamc@1080 343 | ELet (x, t, e1, e2) =>
adamc@1080 344 let
adamc@1080 345 val (e1, st) = exp (env, e1, st)
adamc@1080 346 val (e2, st) = exp ((x, t) :: env, e2, st)
adamc@1080 347 in
adamc@1080 348 ((ELet (x, t, e1, e2), loc), st)
adamc@1080 349 end
adamc@1080 350 | EServerCall (n, es, t) =>
adamc@1080 351 let
adamc@1080 352 val (es, st) = ListUtil.foldlMap (fn (e, st) => exp (env, e, st)) st es
adamc@1080 353 in
adamc@1080 354 ((EServerCall (n, es, t), loc), st)
adamc@1080 355 end
adamc@482 356 in
adamc@482 357 case getApp e of
adamc@1080 358 NONE => default ()
adamc@488 359 | SOME (f, xs) =>
adamc@485 360 case IM.find (#funcs st, f) of
adamc@1272 361 NONE => ((*print ("No find: " ^ Int.toString f ^ "\n");*) default ())
adam@1675 362 | SOME {name, args, body, typ, tag, constArgs} =>
adamc@488 363 let
adamc@1080 364 val (xs, st) = ListUtil.foldlMap (fn (e, st) => exp (env, e, st)) st xs
adamc@1080 365
adamc@721 366 (*val () = Print.prefaces "Consider" [("e", CorePrint.p_exp CoreEnv.empty
adamc@721 367 (e, ErrorMsg.dummySpan))]*)
adamc@721 368
adamc@488 369 val loc = ErrorMsg.dummySpan
adamc@488 370
adam@1677 371 val oldXs = xs
adam@1677 372
adam@1675 373 fun findSplit av (constArgs, xs, typ, fxs, fvs) =
adamc@488 374 case (#1 typ, xs) of
adamc@488 375 (TFun (dom, ran), e :: xs') =>
adam@1675 376 if constArgs > 0 then
adam@1677 377 if functionInside dom then
adam@1677 378 (rev (e :: fxs), xs', IS.union (fvs, freeVars e))
adam@1677 379 else
adam@1677 380 findSplit av (constArgs - 1,
adam@1677 381 xs',
adam@1677 382 ran,
adam@1677 383 e :: fxs,
adam@1677 384 IS.union (fvs, freeVars e))
adam@1675 385 else
adam@1677 386 ([], oldXs, IS.empty)
adam@1677 387 | _ => ([], oldXs, IS.empty)
adamc@488 388
adam@1675 389 val (fxs, xs, fvs) = findSplit true (constArgs, xs, typ, [], IS.empty)
adam@1355 390
adam@1314 391 val vts = map (fn n => #2 (List.nth (env, n))) (IS.listItems fvs)
adamc@1079 392 val fxs' = map (squish (IS.listItems fvs)) fxs
adam@1362 393
adam@1362 394 val p_bool = Print.PD.string o Bool.toString
adamc@488 395 in
adam@1355 396 (*Print.prefaces "Func" [("name", Print.PD.string name),
adam@1355 397 ("e", CorePrint.p_exp CoreEnv.empty e),
adam@1355 398 ("fxs'", Print.p_list (CorePrint.p_exp CoreEnv.empty) fxs')];*)
adam@1675 399 if List.all (fn (ERel _, _) => true
adam@1675 400 | _ => false) fxs' then
adam@1675 401 default ()
adamc@488 402 else
adam@1667 403 case KM.find (args, (vts, fxs')) of
adam@1667 404 SOME f' =>
adamc@485 405 let
adamc@488 406 val e = (ENamed f', loc)
adamc@488 407 val e = IS.foldr (fn (arg, e) => (EApp (e, (ERel arg, loc)), loc))
adamc@488 408 e fvs
adamc@1079 409 val e = foldl (fn (arg, e) => (EApp (e, arg), loc))
adamc@488 410 e xs
adamc@488 411 in
adamc@488 412 (*Print.prefaces "Brand new (reuse)"
adamc@721 413 [("e'", CorePrint.p_exp CoreEnv.empty e)];*)
adamc@1080 414 (e, st)
adamc@488 415 end
adam@1667 416 | NONE =>
adamc@488 417 let
adamc@800 418 (*val () = Print.prefaces "New one"
adam@1667 419 [("name", Print.PD.string name),
adam@1667 420 ("f", Print.PD.string (Int.toString f)),
adam@1667 421 ("|fvs|", Print.PD.string (Int.toString (IS.numItems fvs))),
adam@1667 422 ("|fxs|", Print.PD.string (Int.toString (length fxs))),
adam@1667 423 ("spec", Print.PD.string (Bool.toString (IS.member (#specialized st, f))))]*)
adamc@800 424
adamc@818 425 (*val () = Print.prefaces ("Yes(" ^ name ^ ")")
adamc@818 426 [("fxs'",
adamc@818 427 Print.p_list (CorePrint.p_exp CoreEnv.empty) fxs')]*)
adamc@818 428
adam@1675 429 (*val () = Print.prefaces name
adam@1675 430 [("Available", Print.PD.string (Int.toString constArgs)),
adam@1675 431 ("Used", Print.PD.string (Int.toString (length fxs'))),
adam@1675 432 ("fxs'",
adam@1675 433 Print.p_list (CorePrint.p_exp CoreEnv.empty) fxs')]*)
adam@1675 434
adamc@1079 435 fun subBody (body, typ, fxs') =
adamc@1079 436 case (#1 body, #1 typ, fxs') of
adamc@488 437 (_, _, []) => SOME (body, typ)
adamc@1079 438 | (EAbs (_, _, _, body'), TFun (_, typ'), x :: fxs'') =>
adamc@488 439 let
adamc@1079 440 val body'' = E.subExpInExp (0, x) body'
adamc@488 441 in
adamc@488 442 subBody (body'',
adamc@488 443 typ',
adamc@1079 444 fxs'')
adamc@488 445 end
adamc@488 446 | _ => NONE
adamc@488 447 in
adamc@1079 448 case subBody (body, typ, fxs') of
adamc@1080 449 NONE => default ()
adamc@488 450 | SOME (body', typ') =>
adamc@488 451 let
adamc@488 452 val f' = #maxName st
adam@1314 453 val args = KM.insert (args, (vts, fxs'), f')
adamc@488 454 val funcs = IM.insert (#funcs st, f, {name = name,
adamc@488 455 args = args,
adamc@488 456 body = body,
adamc@488 457 typ = typ,
adam@1675 458 tag = tag,
adam@1675 459 constArgs = calcConstArgs f body})
adamc@1079 460
adamc@488 461 val st = {
adamc@488 462 maxName = f' + 1,
adamc@488 463 funcs = funcs,
adamc@1079 464 decls = #decls st,
adamc@1080 465 specialized = IS.add (#specialized st, f')
adamc@488 466 }
adamc@487 467
adamc@488 468 (*val () = Print.prefaces "specExp"
adamc@488 469 [("f", CorePrint.p_exp env (ENamed f, loc)),
adamc@488 470 ("f'", CorePrint.p_exp env (ENamed f', loc)),
adamc@488 471 ("xs", Print.p_list (CorePrint.p_exp env) xs),
adamc@488 472 ("fxs'", Print.p_list
adamc@488 473 (CorePrint.p_exp E.empty) fxs'),
adamc@488 474 ("e", CorePrint.p_exp env (e, loc))]*)
adamc@488 475 val (body', typ') = IS.foldl (fn (n, (body', typ')) =>
adamc@488 476 let
adamc@521 477 val (x, xt) = List.nth (env, n)
adamc@488 478 in
adamc@488 479 ((EAbs (x, xt, typ', body'),
adamc@488 480 loc),
adamc@488 481 (TFun (xt, typ'), loc))
adamc@488 482 end)
adamc@488 483 (body', typ') fvs
adamc@1272 484 (*val () = print ("NEW: " ^ name ^ "__" ^ Int.toString f' ^ "\n");*)
adamc@1272 485 val body' = ReduceLocal.reduceExp body'
adamc@1080 486 (*val () = Print.preface ("PRE", CorePrint.p_exp CoreEnv.empty body')*)
adamc@1080 487 val (body', st) = exp (env, body', st)
adamc@482 488
adamc@488 489 val e' = (ENamed f', loc)
adamc@488 490 val e' = IS.foldr (fn (arg, e) => (EApp (e, (ERel arg, loc)), loc))
adamc@488 491 e' fvs
adamc@1079 492 val e' = foldl (fn (arg, e) => (EApp (e, arg), loc))
adamc@488 493 e' xs
adam@1362 494
adamc@488 495 (*val () = Print.prefaces "Brand new"
adamc@721 496 [("e'", CorePrint.p_exp CoreEnv.empty e'),
adamc@1080 497 ("e", CorePrint.p_exp CoreEnv.empty e),
adamc@721 498 ("body'", CorePrint.p_exp CoreEnv.empty body')]*)
adamc@488 499 in
adamc@1080 500 (e',
adamc@488 501 {maxName = #maxName st,
adamc@488 502 funcs = #funcs st,
adamc@1079 503 decls = (name, f', typ', body', tag) :: #decls st,
adamc@1079 504 specialized = #specialized st})
adamc@488 505 end
adamc@485 506 end
adamc@488 507 end
adamc@485 508 end
adamc@482 509
adamc@521 510 fun doDecl (d, (st : state, changed)) =
adamc@488 511 let
adamc@521 512 (*val befor = Time.now ()*)
adamc@482 513
adamc@453 514 val funcs = #funcs st
adamc@453 515 val funcs =
adamc@453 516 case #1 d of
adamc@453 517 DValRec vis =>
adamc@453 518 foldl (fn ((x, n, c, e, tag), funcs) =>
adamc@453 519 IM.insert (funcs, n, {name = x,
adamc@453 520 args = KM.empty,
adamc@453 521 body = e,
adamc@453 522 typ = c,
adam@1675 523 tag = tag,
adam@1675 524 constArgs = calcConstArgs n e}))
adamc@453 525 funcs vis
adamc@453 526 | _ => funcs
adamc@453 527
adamc@453 528 val st = {maxName = #maxName st,
adamc@453 529 funcs = funcs,
adamc@1079 530 decls = [],
adamc@1079 531 specialized = #specialized st}
adamc@453 532
adamc@482 533 (*val () = Print.prefaces "decl" [("d", CorePrint.p_decl CoreEnv.empty d)]*)
adamc@521 534
adamc@522 535 val (d', st) =
adamc@522 536 if isPoly d then
adamc@522 537 (d, st)
adamc@522 538 else
adamc@1080 539 case #1 d of
adamc@1080 540 DVal (x, n, t, e, s) =>
adamc@1080 541 let
adam@1362 542 (*val () = Print.preface ("Visiting", Print.box [Print.PD.string (x ^ "__" ^ Int.toString n),
adam@1362 543 Print.space,
adam@1362 544 Print.PD.string ":",
adam@1362 545 Print.space,
adam@1362 546 CorePrint.p_con CoreEnv.empty t])*)
adam@1362 547
adamc@1080 548 val (e, st) = exp ([], e, st)
adamc@1080 549 in
adamc@1080 550 ((DVal (x, n, t, e, s), #2 d), st)
adamc@1080 551 end
adamc@1080 552 | DValRec vis =>
adamc@1080 553 let
adamc@1120 554 (*val () = Print.preface ("Visiting", Print.p_list (fn vi =>
adam@1362 555 Print.box [Print.PD.string (#1 vi ^ "__"
adam@1362 556 ^ Int.toString
adam@1362 557 (#2 vi)),
adam@1362 558 Print.space,
adam@1362 559 Print.PD.string ":",
adam@1362 560 Print.space,
adam@1362 561 CorePrint.p_con CoreEnv.empty (#3 vi)])
adamc@1120 562 vis)*)
adamc@1120 563
adamc@1080 564 val (vis, st) = ListUtil.foldlMap (fn ((x, n, t, e, s), st) =>
adamc@1080 565 let
adamc@1080 566 val (e, st) = exp ([], e, st)
adamc@1080 567 in
adamc@1080 568 ((x, n, t, e, s), st)
adamc@1080 569 end) st vis
adamc@1080 570 in
adamc@1080 571 ((DValRec vis, #2 d), st)
adamc@1080 572 end
adamc@1080 573 | DTable (s, n, t, s1, e1, t1, e2, t2) =>
adamc@1080 574 let
adamc@1080 575 val (e1, st) = exp ([], e1, st)
adamc@1080 576 val (e2, st) = exp ([], e2, st)
adamc@1080 577 in
adamc@1080 578 ((DTable (s, n, t, s1, e1, t2, e2, t2), #2 d), st)
adamc@1080 579 end
adamc@1080 580 | DView (x, n, s, e, t) =>
adamc@1080 581 let
adamc@1080 582 val (e, st) = exp ([], e, st)
adamc@1080 583 in
adamc@1080 584 ((DView (x, n, s, e, t), #2 d), st)
adamc@1080 585 end
adamc@1080 586 | DTask (e1, e2) =>
adamc@1080 587 let
adamc@1080 588 val (e1, st) = exp ([], e1, st)
adamc@1080 589 val (e2, st) = exp ([], e2, st)
adamc@1080 590 in
adamc@1080 591 ((DTask (e1, e2), #2 d), st)
adamc@1080 592 end
adamc@1080 593 | _ => (d, st)
adamc@1080 594
adamc@482 595 (*val () = print "/decl\n"*)
adamc@443 596
adamc@443 597 val funcs = #funcs st
adamc@443 598 val funcs =
adamc@443 599 case #1 d of
adamc@443 600 DVal (x, n, c, e as (EAbs _, _), tag) =>
adamc@443 601 IM.insert (funcs, n, {name = x,
adamc@453 602 args = KM.empty,
adamc@443 603 body = e,
adamc@443 604 typ = c,
adam@1675 605 tag = tag,
adam@1675 606 constArgs = calcConstArgs n e})
adamc@469 607 | DVal (_, n, _, (ENamed n', _), _) =>
adamc@469 608 (case IM.find (funcs, n') of
adamc@469 609 NONE => funcs
adamc@469 610 | SOME v => IM.insert (funcs, n, v))
adamc@443 611 | _ => funcs
adamc@443 612
adamc@453 613 val (changed, ds) =
adamc@443 614 case #decls st of
adamc@453 615 [] => (changed, [d'])
adamc@453 616 | vis =>
adamc@453 617 (true, case d' of
adamc@453 618 (DValRec vis', _) => [(DValRec (vis @ vis'), ErrorMsg.dummySpan)]
adamc@453 619 | _ => [(DValRec vis, ErrorMsg.dummySpan), d'])
adamc@443 620 in
adamc@802 621 (*Print.prefaces "doDecl" [("d", CorePrint.p_decl E.empty d),
adamc@802 622 ("d'", CorePrint.p_decl E.empty d')];*)
adamc@521 623 (ds, ({maxName = #maxName st,
adamc@453 624 funcs = funcs,
adamc@1079 625 decls = [],
adamc@1079 626 specialized = #specialized st}, changed))
adamc@443 627 end
adamc@443 628
adamc@1120 629 (*val () = Print.preface ("RESET", CorePrint.p_file CoreEnv.empty file)*)
adamc@1079 630 val (ds, (st, changed)) = ListUtil.foldlMapConcat doDecl
adamc@521 631 ({maxName = U.File.maxName file + 1,
adamc@1080 632 funcs = funcs,
adamc@1079 633 decls = [],
adamc@1079 634 specialized = specialized},
adamc@488 635 false)
adamc@488 636 file
adamc@443 637 in
adamc@1120 638 (*print ("Changed = " ^ Bool.toString changed ^ "\n");*)
adamc@1080 639 (changed, ds, #funcs st, #specialized st)
adamc@443 640 end
adamc@443 641
adamc@1080 642 fun specializeL (funcs, specialized) file =
adamc@453 643 let
adamc@721 644 val file = ReduceLocal.reduce file
adamc@520 645 (*val file = ReduceLocal.reduce file*)
adamc@1080 646 val (changed, file, funcs, specialized) = specialize' (funcs, specialized) file
adamc@520 647 (*val file = ReduceLocal.reduce file
adamc@520 648 val file = CoreUntangle.untangle file
adamc@488 649 val file = Shake.shake file*)
adamc@453 650 in
adamc@488 651 (*print "Round over\n";*)
adamc@453 652 if changed then
adamc@520 653 let
adamc@721 654 (*val file = ReduceLocal.reduce file*)
adamc@802 655 (*val () = Print.prefaces "Pre-untangle" [("file", CorePrint.p_file CoreEnv.empty file)]*)
adamc@520 656 val file = CoreUntangle.untangle file
adamc@802 657 (*val () = Print.prefaces "Post-untangle" [("file", CorePrint.p_file CoreEnv.empty file)]*)
adamc@520 658 val file = Shake.shake file
adamc@520 659 in
adamc@520 660 (*print "Again!\n";*)
adamc@1080 661 (*Print.prefaces "Again" [("file", CorePrint.p_file CoreEnv.empty file)];*)
adamc@1080 662 specializeL (funcs, specialized) file
adamc@520 663 end
adamc@453 664 else
adamc@453 665 file
adamc@453 666 end
adamc@453 667
adamc@1080 668 val specialize = specializeL (IM.empty, IS.empty)
adamc@1079 669
adamc@443 670 end