summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--demo/tree.ur2
-rw-r--r--src/compiler.sig2
-rw-r--r--src/compiler.sml10
-rw-r--r--src/demo.sig1
-rw-r--r--src/demo.sml26
-rw-r--r--src/especialize.sml119
-rw-r--r--tests/espec.ur56
-rw-r--r--tests/espec.urp3
-rw-r--r--tests/espec.urs1
9 files changed, 90 insertions, 130 deletions
diff --git a/demo/tree.ur b/demo/tree.ur
index 0a13e470..6cb5051c 100644
--- a/demo/tree.ur
+++ b/demo/tree.ur
@@ -4,9 +4,9 @@ table t : { Id : int, Parent : option int, Nam : string }
CONSTRAINT F FOREIGN KEY Parent REFERENCES t (Id) ON DELETE CASCADE
open TreeFun.Make(struct
- val tab = t
con id = #Id
con parent = #Parent
+ val tab = t
end)
fun row r = <xml>
diff --git a/src/compiler.sig b/src/compiler.sig
index 1a41eaea..2b08bff4 100644
--- a/src/compiler.sig
+++ b/src/compiler.sig
@@ -152,4 +152,6 @@ signature COMPILER = sig
val toChecknest : (string, Cjr.file) transform
val toSqlify : (string, Cjr.file) transform
+ val debug : bool ref
+
end
diff --git a/src/compiler.sml b/src/compiler.sml
index 256162ce..baf8ddac 100644
--- a/src/compiler.sml
+++ b/src/compiler.sml
@@ -71,10 +71,20 @@ type ('src, 'dst) transform = {
time : 'src * pmap -> 'dst option * pmap
}
+val debug = ref false
+
fun transform (ph : ('src, 'dst) phase) name = {
func = fn input => let
+ val () = if !debug then
+ print ("Starting " ^ name ^ "....\n")
+ else
+ ()
val v = #func ph input
in
+ if !debug then
+ print ("Finished " ^ name ^ ".\n")
+ else
+ ();
if ErrorMsg.anyErrors () then
NONE
else
diff --git a/src/demo.sig b/src/demo.sig
index 4bb4a19e..5f5fa2bb 100644
--- a/src/demo.sig
+++ b/src/demo.sig
@@ -28,5 +28,6 @@
signature DEMO = sig
val make : {prefix : string, dirname : string, guided : bool} -> unit
+ val make' : {prefix : string, dirname : string, guided : bool} -> bool
end
diff --git a/src/demo.sml b/src/demo.sml
index c5480a93..55615173 100644
--- a/src/demo.sml
+++ b/src/demo.sml
@@ -27,7 +27,7 @@
structure Demo :> DEMO = struct
-fun make {prefix, dirname, guided} =
+fun make' {prefix, dirname, guided} =
let
val prose = OS.Path.joinDirFile {dir = dirname,
file = "prose"}
@@ -430,13 +430,23 @@ fun make {prefix, dirname, guided} =
TextIO.closeOut outf;
- Compiler.compiler (OS.Path.base fname)
- end;
-
- TextIO.output (demosOut, "\n</body></html>\n");
- TextIO.closeOut demosOut;
-
- prettyPrint ()
+ let
+ val b = Compiler.compile (OS.Path.base fname)
+ in
+ TextIO.output (demosOut, "\n</body></html>\n");
+ TextIO.closeOut demosOut;
+ if b then
+ prettyPrint ()
+ else
+ ();
+ b
+ end
+ end
end
+fun make args = if make' args then
+ ()
+ else
+ OS.Process.exit OS.Process.failure
+
end
diff --git a/src/especialize.sml b/src/especialize.sml
index 7cadb905..46105d90 100644
--- a/src/especialize.sml
+++ b/src/especialize.sml
@@ -79,14 +79,14 @@ fun positionOf (v : int, ls) =
pof (0, ls)
end
-fun squish (untouched, fvs) =
+fun squish fvs =
U.Exp.mapB {kind = fn _ => fn k => k,
con = fn _ => fn c => c,
exp = fn bound => fn e =>
case e of
ERel x =>
if x >= bound then
- ERel (positionOf (x - bound, fvs) + bound + untouched)
+ ERel (positionOf (x - bound, fvs) + bound)
else
e
| _ => e,
@@ -107,7 +107,8 @@ type func = {
type state = {
maxName : int,
funcs : func IM.map,
- decls : (string * int * con * exp * string) list
+ decls : (string * int * con * exp * string) list,
+ specialized : bool IM.map
}
fun default (_, x, st) = (x, st)
@@ -119,7 +120,7 @@ structure SS = BinarySetFn(struct
val mayNotSpec = ref SS.empty
-fun specialize' file =
+fun specialize' specialized file =
let
fun bind (env, b) =
case b of
@@ -165,51 +166,45 @@ fun specialize' file =
| _ => false}
val loc = ErrorMsg.dummySpan
- fun hasFuncArg t =
- case #1 t of
- TFun (dom, ran) => functionInside dom orelse hasFuncArg ran
- | _ => false
-
- fun findSplit hfa (xs, typ, fxs, fvs, ts) =
+ fun findSplit av (xs, typ, fxs, fvs) =
case (#1 typ, xs) of
(TFun (dom, ran), e :: xs') =>
let
- val isVar = case #1 e of
- ERel _ => true
- | _ => false
- val hfa = hfa andalso isVar
+ val av = case #1 e of
+ ERel _ => av
+ | _ => false
in
- if hfa orelse functionInside dom then
- findSplit hfa (xs',
- ran,
- (true, e) :: fxs,
- IS.union (fvs, freeVars e),
- ts)
+ if functionInside dom orelse (av andalso case #1 e of
+ ERel _ => true
+ | _ => false) then
+ findSplit av (xs',
+ ran,
+ e :: fxs,
+ IS.union (fvs, freeVars e))
else
- findSplit hfa (xs', ran, (false, e) :: fxs, fvs, dom :: ts)
+ (rev fxs, xs, fvs)
end
- | _ => (List.revAppend (fxs, map (fn e => (false, e)) xs), fvs, rev ts)
+ | _ => (rev fxs, xs, fvs)
+
+ val (fxs, xs, fvs) = findSplit true (xs, typ, [], IS.empty)
- val (xs, fvs, ts) = findSplit (hasFuncArg typ) (xs, typ, [], IS.empty, [])
- val fxs = List.mapPartial (fn (true, e) => SOME e | _ => NONE) xs
- val untouched = length (List.filter (fn (false, _) => true | _ => false) xs)
- val squish = squish (untouched, IS.listItems fvs)
- val fxs' = map squish fxs
+ val fxs' = map (squish (IS.listItems fvs)) fxs
in
(*Print.preface ("fxs'", Print.p_list (CorePrint.p_exp CoreEnv.empty) fxs');*)
- if List.all (fn (false, _) => true
- | (true, (ERel _, _)) => true
- | _ => false) xs then
+ if List.all (fn (ERel _, _) => true
+ | _ => false) fxs'
+ orelse (IS.numItems fvs >= length fxs
+ andalso IS.exists (fn n => functionInside (#2 (List.nth (env, n)))) fvs) then
(e, st)
else
- case (KM.find (args, fxs'), SS.member (!mayNotSpec, name)) of
+ case (KM.find (args, fxs'),
+ SS.member (!mayNotSpec, name) orelse IM.find (#specialized st, f) = SOME true) of
(SOME f', _) =>
let
val e = (ENamed f', loc)
val e = IS.foldr (fn (arg, e) => (EApp (e, (ERel arg, loc)), loc))
e fvs
- val e = foldl (fn ((false, arg), e) => (EApp (e, arg), loc)
- | (_, e) => e)
+ val e = foldl (fn (arg, e) => (EApp (e, arg), loc))
e xs
in
(*Print.prefaces "Brand new (reuse)"
@@ -231,24 +226,20 @@ fun specialize' file =
[("fxs'",
Print.p_list (CorePrint.p_exp CoreEnv.empty) fxs')]*)
- fun subBody (body, typ, xs) =
- case (#1 body, #1 typ, xs) of
+ fun subBody (body, typ, fxs') =
+ case (#1 body, #1 typ, fxs') of
(_, _, []) => SOME (body, typ)
- | (EAbs (_, _, _, body'), TFun (_, typ'), (b, x) :: xs) =>
+ | (EAbs (_, _, _, body'), TFun (_, typ'), x :: fxs'') =>
let
- val body'' =
- if b then
- E.subExpInExp (0, squish x) body'
- else
- body'
+ val body'' = E.subExpInExp (0, x) body'
in
subBody (body'',
typ',
- xs)
+ fxs'')
end
| _ => NONE
in
- case subBody (body, typ, xs) of
+ case subBody (body, typ, fxs') of
NONE => (e, st)
| SOME (body', typ') =>
let
@@ -259,10 +250,17 @@ fun specialize' file =
body = body,
typ = typ,
tag = tag})
+
+ val specialized = IM.insert (#specialized st, f', false)
+ val specialized = case IM.find (specialized, f) of
+ NONE => specialized
+ | SOME _ => IM.insert (specialized, f, true)
+
val st = {
maxName = f' + 1,
funcs = funcs,
- decls = #decls st
+ decls = #decls st,
+ specialized = specialized
}
(*val () = Print.prefaces "specExp"
@@ -272,12 +270,6 @@ fun specialize' file =
("fxs'", Print.p_list
(CorePrint.p_exp E.empty) fxs'),
("e", CorePrint.p_exp env (e, loc))]*)
-
- val (body', typ') = foldr (fn (t, (body', typ')) =>
- ((EAbs ("x", t, typ', body'), loc),
- (TFun (t, typ'), loc)))
- (body', typ') ts
-
val (body', typ') = IS.foldl (fn (n, (body', typ')) =>
let
val (x, xt) = List.nth (env, n)
@@ -296,8 +288,7 @@ fun specialize' file =
val e' = (ENamed f', loc)
val e' = IS.foldr (fn (arg, e) => (EApp (e, (ERel arg, loc)), loc))
e' fvs
- val e' = foldl (fn ((false, arg), e) => (EApp (e, arg), loc)
- | (_, e) => e)
+ val e' = foldl (fn (arg, e) => (EApp (e, arg), loc))
e' xs
(*val () = Print.prefaces "Brand new"
[("e'", CorePrint.p_exp CoreEnv.empty e'),
@@ -307,7 +298,8 @@ fun specialize' file =
(#1 e',
{maxName = #maxName st,
funcs = #funcs st,
- decls = (name, f', typ', body', tag) :: #decls st})
+ decls = (name, f', typ', body', tag) :: #decls st,
+ specialized = #specialized st})
end
end
end
@@ -336,7 +328,8 @@ fun specialize' file =
val st = {maxName = #maxName st,
funcs = funcs,
- decls = []}
+ decls = [],
+ specialized = #specialized st}
(*val () = Print.prefaces "decl" [("d", CorePrint.p_decl CoreEnv.empty d)]*)
@@ -381,25 +374,27 @@ fun specialize' file =
("d'", CorePrint.p_decl E.empty d')];*)
(ds, ({maxName = #maxName st,
funcs = funcs,
- decls = []}, changed))
+ decls = [],
+ specialized = #specialized st}, changed))
end
- val (ds, (_, changed)) = ListUtil.foldlMapConcat doDecl
+ val (ds, (st, changed)) = ListUtil.foldlMapConcat doDecl
({maxName = U.File.maxName file + 1,
funcs = IM.empty,
- decls = []},
+ decls = [],
+ specialized = specialized},
false)
file
in
- (changed, ds)
+ (changed, ds, #specialized st)
end
-fun specialize file =
+fun specializeL specialized file =
let
val file = ReduceLocal.reduce file
(*val () = Print.prefaces "Intermediate" [("file", CorePrint.p_file CoreEnv.empty file)]*)
(*val file = ReduceLocal.reduce file*)
- val (changed, file) = specialize' file
+ val (changed, file, specialized) = specialize' specialized file
(*val file = ReduceLocal.reduce file
val file = CoreUntangle.untangle file
val file = Shake.shake file*)
@@ -414,10 +409,12 @@ fun specialize file =
val file = Shake.shake file
in
(*print "Again!\n";*)
- specialize file
+ specializeL specialized file
end
else
file
end
+val specialize = specializeL IM.empty
+
end
diff --git a/tests/espec.ur b/tests/espec.ur
deleted file mode 100644
index 37b22a36..00000000
--- a/tests/espec.ur
+++ /dev/null
@@ -1,56 +0,0 @@
-fun foo (wrap : xbody -> transaction page) = wrap <xml>
- <a link={foo wrap}>Foo</a>
-</xml>
-
-fun bar (wrap : xbody -> transaction page) (n : int) = wrap <xml>
- <a link={bar wrap n}>Bar</a>; {[n]}
-</xml>
-
-fun baz (n : int) (wrap : xbody -> transaction page) = wrap <xml>
- <a link={baz n wrap}>Baz</a>; {[n]}
-</xml>
-
-fun middle (n : int) (wrap : xbody -> transaction page) (m : int) = wrap <xml>
- <a link={middle n wrap m}>Middle</a>; {[n]}; {[m]}
-</xml>
-
-fun crazy (f : int -> int) (b : bool) (wrap : xbody -> transaction page) (m : int) = wrap <xml>
- <a link={crazy f b wrap m}>Crazy</a>; {[b]}; {[f m]}
-</xml>
-
-fun wild (q : bool) (f : int -> int) (n : float) (wrap : xbody -> transaction page) (m : int) = wrap <xml>
- <a link={wild q f n wrap m}>Wild</a>; {[n]}; {[f m]}; {[q]}
-</xml>
-
-fun wrap x = return <xml><body>{x}</body></xml>
-
-fun wrapN n x = return <xml><body>{[n]}; {x}</body></xml>
-
-fun foo2 (wrap : xbody -> transaction page) = wrap <xml>
- <a link={foo2 wrap}>Foo</a>
-</xml>
-
-fun foo3 (n : int) = wrap <xml>
- <a link={foo2 (wrapN n)}>Foo</a>
-</xml>
-
-fun bar2 (n : int) (wrap : xbody -> transaction page) = wrap <xml>
- <a link={bar2 n wrap}>Bar</a>; n={[n]}
-</xml>
-
-fun bar3 (n : int) = wrap <xml>
- <a link={bar2 88 (wrapN n)}>Bar</a>
-</xml>
-
-
-fun main () = return <xml><body>
- <a link={foo wrap}>Foo</a>
- <a link={bar wrap 32}>Bar</a>
- <a link={baz 18 wrap}>Baz</a>
- <a link={middle 1 wrap 2}>Middle</a>
- <a link={crazy (fn n => 2 * n) False wrap 2}>Crazy</a>
- <a link={wild True (fn n => 2 * n) 1.23 wrap 2}>Wild</a>
- <hr/>
- <a link={foo3 15}>Foo3</a>
- <a link={bar3 44}>Bar3</a>
-</body></xml>
diff --git a/tests/espec.urp b/tests/espec.urp
deleted file mode 100644
index 045fb1e0..00000000
--- a/tests/espec.urp
+++ /dev/null
@@ -1,3 +0,0 @@
-debug
-
-espec
diff --git a/tests/espec.urs b/tests/espec.urs
deleted file mode 100644
index 6ac44e0b..00000000
--- a/tests/espec.urs
+++ /dev/null
@@ -1 +0,0 @@
-val main : unit -> transaction page
generated by cgit v1.2.3 (git 2.39.1) at 2024-05-14 01:45:03 +0000