summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
authorGravatar Adam Chlipala <adamc@hcoop.net>2010-03-16 10:09:01 -0400
committerGravatar Adam Chlipala <adamc@hcoop.net>2010-03-16 10:09:01 -0400
commite5e7bbaaae9cde0981c77e488a29e730876964ba (patch)
tree32012eb864854a36e74947956e1133ce84cd64a7 /src
parenta00e028f21afd87ef9dd3ed143f52fe648275d45 (diff)
Undo an Especialize change that turned out to be unecessary
Diffstat (limited to 'src')
-rw-r--r--src/compiler.sml2
-rw-r--r--src/core_util.sig5
-rw-r--r--src/core_util.sml17
-rw-r--r--src/especialize.sml62
-rw-r--r--src/unpoly.sml26
5 files changed, 51 insertions, 61 deletions
diff --git a/src/compiler.sml b/src/compiler.sml
index f8c0cc34..a7a3c117 100644
--- a/src/compiler.sml
+++ b/src/compiler.sml
@@ -1085,7 +1085,7 @@ val toMono_reduce2 = transform mono_reduce "mono_reduce2" o toUntangle2
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
diff --git a/src/core_util.sig b/src/core_util.sig
index 807b477b..835577a3 100644
--- a/src/core_util.sig
+++ b/src/core_util.sig
@@ -73,6 +73,11 @@ structure Con : sig
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}
diff --git a/src/core_util.sml b/src/core_util.sml
index 599e1abc..247dd32e 100644
--- a/src/core_util.sml
+++ b/src/core_util.sml
@@ -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 @@ fun exists {kind, con} k =
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
diff --git a/src/especialize.sml b/src/especialize.sml
index b0a4a8c2..7d129b8b 100644
--- a/src/especialize.sml
+++ b/src/especialize.sml
@@ -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 KM = BinaryMapFn(K)
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 @@ 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
@@ -228,12 +190,7 @@ fun specialize' (funcs, specialized) file =
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 @@ 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) =
@@ -361,13 +328,10 @@ fun specialize' (funcs, specialized) file =
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 ())
diff --git a/src/unpoly.sml b/src/unpoly.sml
index 41532b85..324e045c 100644
--- a/src/unpoly.sml
+++ b/src/unpoly.sml
@@ -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 subConInCon = E.subConInCon
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 @@ fun exp (e, st : state) =
| _ => 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 @@ fun decl (d, st : state) =
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,