diff options
| author |  Adam Chlipala <adamc@hcoop.net> | 2010-03-06 16:15:26 -0500 |
|---|---|---|
| committer | Adam Chlipala <adamc@hcoop.net> | 2010-03-06 16:15:26 -0500 |
| commit | 049d85f6ec161c8df0461550549ded12be9e44e8 (patch) | |
| tree | b422a4c17510b07702c1e16492d87680928a517f /src | |
| parent | e59684b553e4e30e7290c7a589cdb582e8f46907 (diff) | |
Standard library moduls Incl and Mem; tweaks to Especialize and Unpoly
Diffstat (limited to 'src')
| -rw-r--r-- | src/especialize.sml | 47 | ||||
| -rw-r--r-- | src/unpoly.sml | 16 |
2 files changed, 45 insertions, 18 deletions
diff --git a/src/especialize.sml b/src/especialize.sml index 7d129b8b..4936cc61 100644 --- a/src/especialize.sml +++ b/src/especialize.sml @@ -1,4 +1,4 @@ -(* Copyright (c) 2008-2009, Adam Chlipala +(* Copyright (c) 2008-2010, Adam Chlipala * All rights reserved. * * Redistribution and use in source and binary forms, with or without @@ -129,6 +129,37 @@ val mayNotSpec = ref SS.empty 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 @@ -286,17 +317,7 @@ fun specialize' (funcs, specialized) file = (*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) = @@ -332,6 +353,8 @@ fun specialize' (funcs, specialized) file = 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 ()) diff --git a/src/unpoly.sml b/src/unpoly.sml index 0d239cb9..41532b85 100644 --- a/src/unpoly.sml +++ b/src/unpoly.sml @@ -258,9 +258,9 @@ fun decl (d, st : state) = fun kind _ = false fun con _ = false - fun exp e = + fun exp (cn, e) = case e of - ECApp (e, c) => + orig as ECApp (e, c) => let fun isIrregular (e, pos) = case #1 e of @@ -268,20 +268,24 @@ fun decl (d, st : state) = IS.member (ns, n) andalso (case #1 c of - CRel i => i <> nargs - pos + CRel i => i <> nargs - pos + cn | _ => true) | ECApp (e, _) => isIrregular (e, pos + 1) | _ => false in isIrregular (e, 1) end - | ECAbs _ => true | _ => false - val irregular = U.Exp.exists {kind = kind, con = con, exp = exp} + fun bind (cn, b) = + case b of + U.Exp.RelC _ => cn+1 + | _ => cn + + 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 - (d, st) + (print "Poppycock!\n"; (d, st)) else (d, {funcs = foldl (fn (vi, funcs) => IM.insert (funcs, #2 vi, {kinds = cargs, |