diff options
| author |  Adam Chlipala <adam@chlipala.net> | 2013-08-10 10:13:40 -0400 |
|---|---|---|
| committer | Adam Chlipala <adam@chlipala.net> | 2013-08-10 10:13:40 -0400 |
| commit | 9734b34421533a3a70a09629b11d7e2105ef4a1a (patch) | |
| tree | 28bfd11f2f5b4745ddfdaf6c3e42e7f70fc72b59 /src | |
| parent | 93fea8aa22abe42292b2d4f8fed07900280b64be (diff) | |
Expand coverage of 'functionInside' for Especialize
Diffstat (limited to 'src')
| -rw-r--r-- | src/especialize.sig | 2 | ||||
| -rw-r--r-- | src/especialize.sml | 48 | ||||
| -rw-r--r-- | src/reduce.sml | 4 |
3 files changed, 38 insertions, 16 deletions
diff --git a/src/especialize.sig b/src/especialize.sig index ad2d15da..135e3a00 100644 --- a/src/especialize.sig +++ b/src/especialize.sig @@ -29,6 +29,6 @@ signature ESPECIALIZE = sig val specialize : Core.file -> Core.file - val functionInside : Core.con -> bool + val functionInside : IntBinarySet.set -> Core.con -> bool end diff --git a/src/especialize.sml b/src/especialize.sml index dac91535..7cf145cd 100644 --- a/src/especialize.sml +++ b/src/especialize.sml @@ -122,18 +122,20 @@ type state = { fun default (_, x, st) = (x, st) -val functionInside = U.Con.exists {kind = fn _ => false, - con = fn TFun _ => true - | TCFun _ => 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} +fun functionInside known = + U.Con.exists {kind = fn _ => false, + con = fn TFun _ => true + | TCFun _ => 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 (known, n) + | _ => false} fun getApp (e, _) = case e of @@ -216,8 +218,28 @@ fun calcConstArgs enclosingFunctions e = end +fun optionExists p opt = + case opt of + NONE => false + | SOME v => p v + fun specialize' (funcs, specialized) file = let + val known = foldl (fn (d, known) => + case #1 d of + DCon (_, n, _, c) => + if functionInside known c then + IS.add (known, n) + else + known + | DDatatype dts => + if List.exists (List.exists (optionExists (functionInside known) o #3) o #4) dts then + foldl (fn (dt, known) => IS.add (known, #2 dt)) known dts + else + known + | _ => known) + IS.empty file + fun bind (env, b) = case b of U.Decl.RelE xt => xt :: env @@ -382,7 +404,7 @@ fun specialize' (funcs, specialized) file = (TFun (dom, ran), e :: xs') => if constArgs > 0 then let - val fi = functionInside dom + val fi = functionInside known dom in if initialPart orelse fi then findSplit av (not fi andalso initialPart, diff --git a/src/reduce.sml b/src/reduce.sml index aa5408b0..933a4d94 100644 --- a/src/reduce.sml +++ b/src/reduce.sml @@ -558,7 +558,7 @@ fun kindConAndExp (namedC, namedE) = (ELet (x, t, e1', exp (UnknownE :: env') (EApp (e2', E.liftExpInExp 0 e2), loc)), loc) | EAbs (x, dom, _, b) => - if count b <= 1 orelse passive e2 orelse ESpecialize.functionInside dom then + if count b <= 1 orelse passive e2 orelse ESpecialize.functionInside IS.empty dom then let val r = exp (KnownE e2 :: env') b in @@ -798,7 +798,7 @@ fun kindConAndExp (namedC, namedE) = val t = con env t in - if notFfi t andalso (passive e1' orelse count e2 <= 1 orelse ESpecialize.functionInside t) then + if notFfi t andalso (passive e1' orelse count e2 <= 1 orelse ESpecialize.functionInside IS.empty t) then exp (KnownE e1 :: env) e2 else (ELet (x, t, e1', exp (UnknownE :: env) e2), loc) |