Mercurial > urweb
changeset 1185:338be96f8533
Undo an Especialize change that turned out to be unecessary
| author | Adam Chlipala <adamc@hcoop.net> |
|---|---|
| date | Tue, 16 Mar 2010 10:09:01 -0400 |
| parents | d6f0e972b706 |
| children | a4ac900d3085 |
| files | src/compiler.sml src/core_util.sig src/core_util.sml src/especialize.sml src/unpoly.sml tests/unpoly.ur tests/unpoly.urp tests/unpoly.urs |
| diffstat | 8 files changed, 82 insertions(+), 61 deletions(-) [+] |
line wrap: on
line diff
--- a/src/compiler.sml Tue Mar 09 18:43:29 2010 -0500 +++ b/src/compiler.sml Tue Mar 16 10:09:01 2010 -0400 @@ -1085,7 +1085,7 @@ val toMono_shake2 = transform mono_shake "mono_shake2" o toMono_reduce2 val toMono_opt4 = transform mono_opt "mono_opt4" o toMono_shake2 val toMono_reduce3 = transform mono_reduce "mono_reduce3" o toMono_opt4 -val toFuse2 = transform fuse "shake2" o toMono_reduce3 +val toFuse2 = transform fuse "fuse2" o toMono_reduce3 val toUntangle3 = transform untangle "untangle3" o toFuse2 val toMono_shake3 = transform mono_shake "mono_shake3" o toUntangle3
--- a/src/core_util.sig Tue Mar 09 18:43:29 2010 -0500 +++ b/src/core_util.sig Tue Mar 16 10:09:01 2010 -0400 @@ -73,6 +73,11 @@ val exists : {kind : Core.kind' -> bool, con : Core.con' -> bool} -> Core.con -> bool + + val existsB : {kind : 'context * Core.kind' -> bool, + con : 'context * Core.con' -> bool, + bind : 'context * binder -> 'context} + -> 'context -> Core.con -> bool val foldMap : {kind : Core.kind' * 'state -> Core.kind' * 'state, con : Core.con' * 'state -> Core.con' * 'state}
--- a/src/core_util.sml Tue Mar 09 18:43:29 2010 -0500 +++ b/src/core_util.sml Tue Mar 16 10:09:01 2010 -0400 @@ -1,4 +1,4 @@ -(* Copyright (c) 2008, Adam Chlipala +(* Copyright (c) 2008-2010, Adam Chlipala * All rights reserved. * * Redistribution and use in source and binary forms, with or without @@ -375,6 +375,21 @@ S.Return _ => true | S.Continue _ => false +fun existsB {kind, con, bind} ctx c = + case mapfoldB {kind = fn ctx => fn k => fn () => + if kind (ctx, k) then + S.Return () + else + S.Continue (k, ()), + con = fn ctx => fn c => fn () => + if con (ctx, c) then + S.Return () + else + S.Continue (c, ()), + bind = bind} ctx c () of + S.Return _ => true + | S.Continue _ => false + fun foldMap {kind, con} s c = case mapfold {kind = fn k => fn s => S.Continue (kind (k, s)), con = fn c => fn s => S.Continue (con (c, s))} c s of
--- a/src/especialize.sml Tue Mar 09 18:43:29 2010 -0500 +++ b/src/especialize.sml Tue Mar 16 10:09:01 2010 -0400 @@ -1,4 +1,4 @@ -(* Copyright (c) 2008-2010, Adam Chlipala +(* Copyright (c) 2008-2009, Adam Chlipala * All rights reserved. * * Redistribution and use in source and binary forms, with or without @@ -43,13 +43,6 @@ structure IM = IntBinaryMap structure IS = IntBinarySet -val isOpen = U.Exp.exists {kind = fn _ => false, - con = fn c => - case c of - CRel _ => true - | _ => false, - exp = fn _ => false} - val freeVars = U.Exp.foldB {kind = fn (_, _, xs) => xs, con = fn (_, _, xs) => xs, exp = fn (bound, e, xs) => @@ -136,37 +129,6 @@ fun specialize' (funcs, specialized) file = let - fun functionInside functiony = U.Con.exists {kind = fn _ => false, - con = fn TFun _ => true - | CFfi ("Basis", "transaction") => true - | CFfi ("Basis", "eq") => true - | CFfi ("Basis", "num") => true - | CFfi ("Basis", "ord") => true - | CFfi ("Basis", "show") => true - | CFfi ("Basis", "read") => true - | CFfi ("Basis", "sql_injectable_prim") => true - | CFfi ("Basis", "sql_injectable") => true - | CNamed n => IS.member (functiony, n) - | _ => false} - - val functiony = foldl (fn ((d, _), functiony) => - case d of - DCon (_, n, _, c) => - if functionInside functiony c then - IS.add (functiony, n) - else - functiony - | DDatatype dts => - if List.exists (fn (_, _, _, cs) => - List.exists (fn (_, _, SOME c) => functionInside functiony c - | _ => false) cs) dts then - IS.addList (functiony, map #2 dts) - else - functiony - | _ => functiony) IS.empty file - - val functionInside = functionInside functiony - fun bind (env, b) = case b of U.Decl.RelE xt => xt :: env @@ -228,12 +190,7 @@ in ((ECApp (e, c), loc), st) end - | ECAbs (x, k, e) => - let - val (e, st) = exp (env, e, st) - in - ((ECAbs (x, k, e), loc), st) - end + | ECAbs _ => (e, st) | EKAbs _ => (e, st) | EKApp (e, k) => let @@ -329,7 +286,17 @@ (*val () = Print.prefaces "Consider" [("e", CorePrint.p_exp CoreEnv.empty (e, ErrorMsg.dummySpan))]*) - + val functionInside = U.Con.exists {kind = fn _ => false, + con = fn TFun _ => true + | CFfi ("Basis", "transaction") => true + | CFfi ("Basis", "eq") => true + | CFfi ("Basis", "num") => true + | CFfi ("Basis", "ord") => true + | CFfi ("Basis", "show") => true + | CFfi ("Basis", "read") => true + | CFfi ("Basis", "sql_injectable_prim") => true + | CFfi ("Basis", "sql_injectable") => true + | _ => false} val loc = ErrorMsg.dummySpan fun findSplit av (xs, typ, fxs, fvs, fin) = @@ -361,13 +328,10 @@ if not fin orelse List.all (fn (ERel _, _) => true | _ => false) fxs' - orelse List.exists isOpen fxs' orelse (IS.numItems fvs >= length fxs andalso IS.exists (fn n => functionInside (#2 (List.nth (env, n)))) fvs) then ((*Print.prefaces "No" [("name", Print.PD.string name), ("f", Print.PD.string (Int.toString f)), - ("xs", - Print.p_list (CorePrint.p_exp CoreEnv.empty) xs), ("fxs'", Print.p_list (CorePrint.p_exp CoreEnv.empty) fxs')];*) default ())
--- a/src/unpoly.sml Tue Mar 09 18:43:29 2010 -0500 +++ b/src/unpoly.sml Tue Mar 16 10:09:01 2010 -0400 @@ -1,4 +1,4 @@ -(* Copyright (c) 2008, Adam Chlipala +(* Copyright (c) 2008-2010, Adam Chlipala * All rights reserved. * * Redistribution and use in source and binary forms, with or without @@ -46,11 +46,15 @@ val liftConInExp = E.liftConInExp val subConInExp = E.subConInExp -val isOpen = U.Con.exists {kind = fn _ => false, - con = fn c => - case c of - CRel _ => true - | _ => false} +val isOpen = U.Con.existsB {kind = fn _ => false, + con = fn (n, c) => + case c of + CRel n' => n' >= n + | _ => false, + bind = fn (n, b) => + case b of + U.Con.RelC _ => n + 1 + | _ => n} 0 fun unpolyNamed (xn, rep) = U.Exp.map {kind = fn k => k, @@ -142,9 +146,11 @@ | _ => NONE in (*Print.prefaces "specialize" - [("t", CorePrint.p_con CoreEnv.empty t), - ("e", CorePrint.p_exp CoreEnv.empty e), - ("|cargs|", Print.PD.string (Int.toString (length cargs)))];*) + [("n", Print.PD.string (Int.toString n)), + ("nold", Print.PD.string (Int.toString n_old)), + ("t", CorePrint.p_con CoreEnv.empty t), + ("e", CorePrint.p_exp CoreEnv.empty e), + ("|cargs|", Print.PD.string (Int.toString (length cargs)))];*) Option.map (fn (t, e) => (x, n, n_old, t, e, s)) (trim (t, e, cargs)) end @@ -285,7 +291,7 @@ val irregular = U.Exp.existsB {kind = kind, con = con, exp = exp, bind = bind} 0 in if List.exists (fn x => irregular (deAbs (#4 x, cargs))) vis then - (print "Poppycock!\n"; (d, st)) + (d, st) else (d, {funcs = foldl (fn (vi, funcs) => IM.insert (funcs, #2 vi, {kinds = cargs,
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/tests/unpoly.ur Tue Mar 16 10:09:01 2010 -0400 @@ -0,0 +1,28 @@ +val current = return (Some "1") +fun resolve (_ : string) = return (Some "2") + +fun checkDeps deps = + u <- current; + List.foldlM (fn s (good, errs) => + v' <- resolve s; + case v' of + None => + return (False, <xml> + {errs} + Unknown library path <tt>{[s]}</tt>.<br/> + </xml>) + | Some v' => + b <- return True; + if b then + return (good, errs) + else + return (False, <xml> + {errs} + Access denied to <tt>{[s]}</tt>.<br/> + </xml>)) (True, <xml/>) deps + +fun main () = + p <- checkDeps ("a" :: "b" :: []); + return <xml><body> + {p.2} + </body></xml>