summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/compiler.sig2
-rw-r--r--src/compiler.sml9
-rw-r--r--src/rpcify.sml126
-rw-r--r--src/sources3
-rw-r--r--src/tailify.sig32
-rw-r--r--src/tailify.sml206
6 files changed, 255 insertions, 123 deletions
diff --git a/src/compiler.sig b/src/compiler.sig
index 7ce19580..c78a2773 100644
--- a/src/compiler.sig
+++ b/src/compiler.sig
@@ -86,6 +86,7 @@ signature COMPILER = sig
val reduce : (Core.file, Core.file) phase
val unpoly : (Core.file, Core.file) phase
val specialize : (Core.file, Core.file) phase
+ val tailify : (Core.file, Core.file) phase
val marshalcheck : (Core.file, Core.file) phase
val effectize : (Core.file, Core.file) phase
val monoize : (Core.file, Mono.file) phase
@@ -120,6 +121,7 @@ signature COMPILER = sig
val toSpecialize : (string, Core.file) transform
val toShake3 : (string, Core.file) transform
val toEspecialize : (string, Core.file) transform
+ val toTailify : (string, Core.file) transform
val toReduce2 : (string, Core.file) transform
val toShake4 : (string, Core.file) transform
val toMarshalcheck : (string, Core.file) transform
diff --git a/src/compiler.sml b/src/compiler.sml
index bb1a6add..67ce962e 100644
--- a/src/compiler.sml
+++ b/src/compiler.sml
@@ -779,7 +779,14 @@ val toShake3 = transform shake "shake3" o toSpecialize
val toEspecialize = transform especialize "especialize" o toShake3
-val toReduce2 = transform reduce "reduce2" o toEspecialize
+val tailify = {
+ func = Tailify.frob,
+ print = CorePrint.p_file CoreEnv.empty
+}
+
+val toTailify = transform tailify "tailify" o toEspecialize
+
+val toReduce2 = transform reduce "reduce2" o toTailify
val toShake4 = transform shake "shake4" o toReduce2
diff --git a/src/rpcify.sml b/src/rpcify.sml
index 4ed90228..0e5a1076 100644
--- a/src/rpcify.sml
+++ b/src/rpcify.sml
@@ -32,26 +32,12 @@ open Core
structure U = CoreUtil
structure E = CoreEnv
-fun multiLiftExpInExp n e =
- if n = 0 then
- e
- else
- multiLiftExpInExp (n - 1) (E.liftExpInExp 0 e)
-
structure IS = IntBinarySet
structure IM = IntBinaryMap
-structure SS = BinarySetFn(struct
- type ord_key = string
- val compare = String.compare
- end)
-
type state = {
exported : IS.set,
- export_decls : decl list,
-
- cpsed : exp' IM.map,
- rpc : IS.set
+ export_decls : decl list
}
fun frob file =
@@ -124,9 +110,7 @@ fun frob file =
(DExport (Rpc ReadWrite, n), loc) :: #export_decls st)
val st = {exported = exported,
- export_decls = export_decls,
- cpsed = #cpsed st,
- rpc = #rpc st}
+ export_decls = export_decls}
val k = (ECApp ((EFfi ("Basis", "return"), loc),
(CFfi ("Basis", "transaction"), loc)), loc)
@@ -145,11 +129,6 @@ fun frob file =
else
(e, st)
- | ENamed n =>
- (case IM.find (#cpsed st, n) of
- NONE => (e, st)
- | SOME re => (re, st))
-
| _ => (e, st)
end
@@ -159,99 +138,6 @@ fun frob file =
fun decl (d, st : state) =
let
- val makesServerCall = U.Exp.exists {kind = fn _ => false,
- con = fn _ => false,
- exp = fn EFfi ("Basis", "rpc") => true
- | ENamed n => IS.member (#rpc st, n)
- | _ => false}
-
- val (d, st) =
- case #1 d of
- DValRec vis =>
- if List.exists (fn (_, _, _, e, _) => makesServerCall e) vis then
- let
- val rpc = foldl (fn ((_, n, _, _, _), rpc) =>
- IS.add (rpc, n)) (#rpc st) vis
-
- val (cpsed, vis') =
- foldl (fn (vi as (x, n, t, e, s), (cpsed, vis')) =>
- let
- fun getArgs (t, acc) =
- case #1 t of
- TFun (dom, ran) =>
- getArgs (ran, dom :: acc)
- | _ => (rev acc, t)
- val (ts, ran) = getArgs (t, [])
- val ran = case #1 ran of
- CApp (_, ran) => ran
- | _ => raise Fail "Rpcify: Tail function not transactional"
- val len = length ts
-
- val loc = #2 e
- val args = ListUtil.mapi
- (fn (i, _) =>
- (ERel (len - i - 1), loc))
- ts
- val k = (EFfi ("Basis", "return"), loc)
- val trans = (CFfi ("Basis", "transaction"), loc)
- val k = (ECApp (k, trans), loc)
- val k = (ECApp (k, ran), loc)
- val k = (EApp (k, (EFfi ("Basis", "transaction_monad"),
- loc)), loc)
- val re = (ETailCall (n, args, k, ran, ran), loc)
- val (re, _) = foldr (fn (dom, (re, ran)) =>
- ((EAbs ("x", dom, ran, re),
- loc),
- (TFun (dom, ran), loc)))
- (re, ran) ts
-
- val be = multiLiftExpInExp (len + 1) e
- val be = ListUtil.foldli
- (fn (i, _, be) =>
- (EApp (be, (ERel (len - i), loc)), loc))
- be ts
- val ne = (EFfi ("Basis", "bind"), loc)
- val ne = (ECApp (ne, trans), loc)
- val ne = (ECApp (ne, ran), loc)
- val unit = (TRecord (CRecord ((KType, loc), []),
- loc), loc)
- val ne = (ECApp (ne, unit), loc)
- val ne = (EApp (ne, (EFfi ("Basis", "transaction_monad"),
- loc)), loc)
- val ne = (EApp (ne, be), loc)
- val ne = (EApp (ne, (ERel 0, loc)), loc)
- val tunit = (CApp (trans, unit), loc)
- val kt = (TFun (ran, tunit), loc)
- val ne = (EAbs ("k", kt, tunit, ne), loc)
- val (ne, res) = foldr (fn (dom, (ne, ran)) =>
- ((EAbs ("x", dom, ran, ne), loc),
- (TFun (dom, ran), loc)))
- (ne, (TFun (kt, tunit), loc)) ts
- in
- (IM.insert (cpsed, n, #1 re),
- (x, n, res, ne, s) :: vis')
- end)
- (#cpsed st, []) vis
- in
- ((DValRec (rev vis'), ErrorMsg.dummySpan),
- {exported = #exported st,
- export_decls = #export_decls st,
- cpsed = cpsed,
- rpc = rpc})
- end
- else
- (d, st)
- | DVal (x, n, t, e, s) =>
- (d,
- {exported = #exported st,
- export_decls = #export_decls st,
- cpsed = #cpsed st,
- rpc = if makesServerCall e then
- IS.add (#rpc st, n)
- else
- #rpc st})
- | _ => (d, st)
-
val (d, st) = U.Decl.foldMap {kind = fn x => x,
con = fn x => x,
exp = exp,
@@ -260,16 +146,12 @@ fun frob file =
in
(#export_decls st @ [d],
{exported = #exported st,
- export_decls = [],
- cpsed = #cpsed st,
- rpc = #rpc st})
+ export_decls = []})
end
val (file, _) = ListUtil.foldlMapConcat decl
{exported = IS.empty,
- export_decls = [],
- cpsed = IM.empty,
- rpc = rpcBaseIds}
+ export_decls = []}
file
in
file
diff --git a/src/sources b/src/sources
index ddc7deff..54910b8f 100644
--- a/src/sources
+++ b/src/sources
@@ -131,6 +131,9 @@ especialize.sml
rpcify.sig
rpcify.sml
+tailify.sig
+tailify.sml
+
tag.sig
tag.sml
diff --git a/src/tailify.sig b/src/tailify.sig
new file mode 100644
index 00000000..c0d1fb35
--- /dev/null
+++ b/src/tailify.sig
@@ -0,0 +1,32 @@
+(* Copyright (c) 2009, Adam Chlipala
+ * All rights reserved.
+ *
+ * Redistribution and use in source and binary forms, with or without
+ * modification, are permitted provided that the following conditions are met:
+ *
+ * - Redistributions of source code must retain the above copyright notice,
+ * this list of conditions and the following disclaimer.
+ * - Redistributions in binary form must reproduce the above copyright notice,
+ * this list of conditions and the following disclaimer in the documentation
+ * and/or other materials provided with the distribution.
+ * - The names of contributors may not be used to endorse or promote products
+ * derived from this software without specific prior written permission.
+ *
+ * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
+ * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+ * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+ * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
+ * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+ * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
+ * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+ * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
+ * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
+ * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+ * POSSIBILITY OF SUCH DAMAGE.
+ *)
+
+signature TAILIFY = sig
+
+ val frob : Core.file -> Core.file
+
+end
diff --git a/src/tailify.sml b/src/tailify.sml
new file mode 100644
index 00000000..4b086e09
--- /dev/null
+++ b/src/tailify.sml
@@ -0,0 +1,206 @@
+(* Copyright (c) 2009, Adam Chlipala
+ * All rights reserved.
+ *
+ * Redistribution and use in source and binary forms, with or without
+ * modification, are permitted provided that the following conditions are met:
+ *
+ * - Redistributions of source code must retain the above copyright notice,
+ * this list of conditions and the following disclaimer.
+ * - Redistributions in binary form must reproduce the above copyright notice,
+ * this list of conditions and the following disclaimer in the documentation
+ * and/or other materials provided with the distribution.
+ * - The names of contributors may not be used to endorse or promote products
+ * derived from this software without specific prior written permission.
+ *
+ * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
+ * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+ * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+ * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
+ * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+ * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
+ * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+ * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
+ * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
+ * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+ * POSSIBILITY OF SUCH DAMAGE.
+ *)
+
+structure Tailify :> TAILIFY = struct
+
+open Core
+
+structure U = CoreUtil
+structure E = CoreEnv
+
+fun multiLiftExpInExp n e =
+ if n = 0 then
+ e
+ else
+ multiLiftExpInExp (n - 1) (E.liftExpInExp 0 e)
+
+structure IS = IntBinarySet
+structure IM = IntBinaryMap
+
+type state = {
+ cpsed : exp' IM.map,
+ rpc : IS.set
+}
+
+fun frob file =
+ let
+ fun exp (e, st : state) =
+ case e of
+ ENamed n =>
+ (case IM.find (#cpsed st, n) of
+ NONE => (e, st)
+ | SOME re => (re, st))
+
+ | _ => (e, st)
+
+ and doExp (e, st) = U.Exp.foldMap {kind = fn x => x,
+ con = fn x => x,
+ exp = exp} st (ReduceLocal.reduceExp e)
+
+ fun decl (d, st : state) =
+ let
+ fun makesServerCall b (e, _) =
+ case e of
+ EServerCall _ => true
+ | ETailCall _ => raise Fail "Tailify: ETailCall too early"
+ | ENamed n => IS.member (#rpc st, n)
+
+ | EPrim _ => false
+ | ERel n => List.nth (b, n)
+ | ECon (_, _, _, NONE) => false
+ | ECon (_, _, _, SOME e) => makesServerCall b e
+ | EFfi _ => false
+ | EFfiApp (_, _, es) => List.exists (makesServerCall b) es
+ | EApp (e1, e2) => makesServerCall b e1 orelse makesServerCall b e2
+ | EAbs (_, _, _, e1) => makesServerCall (false :: b) e1
+ | ECApp (e1, _) => makesServerCall b e1
+ | ECAbs (_, _, e1) => makesServerCall b e1
+
+ | EKAbs (_, e1) => makesServerCall b e1
+ | EKApp (e1, _) => makesServerCall b e1
+
+ | ERecord xes => List.exists (fn ((CName s, _), e, _) =>
+ not (String.isPrefix "On" s) andalso makesServerCall b e
+ | (_, e, _) => makesServerCall b e) xes
+ | EField (e1, _, _) => makesServerCall b e1
+ | EConcat (e1, _, e2, _) => makesServerCall b e1 orelse makesServerCall b e2
+ | ECut (e1, _, _) => makesServerCall b e1
+ | ECutMulti (e1, _, _) => makesServerCall b e1
+
+ | ECase (e1, pes, _) => makesServerCall b e1
+ orelse List.exists (fn (p, e) =>
+ makesServerCall (List.tabulate (E.patBindsN p,
+ fn _ => false) @ b)
+ e) pes
+
+ | EWrite e1 => makesServerCall b e1
+
+ | EClosure (_, es) => List.exists (makesServerCall b) es
+
+ | ELet (_, _, e1, e2) => makesServerCall (makesServerCall b e1 :: b) e2
+
+ val makesServerCall = makesServerCall []
+
+ val (d, st) =
+ case #1 d of
+ DValRec vis =>
+ if List.exists (fn (_, _, _, e, _) => makesServerCall e) vis then
+ let
+ val rpc = foldl (fn ((_, n, _, _, _), rpc) =>
+ IS.add (rpc, n)) (#rpc st) vis
+
+ val (cpsed, vis') =
+ foldl (fn (vi as (x, n, t, e, s), (cpsed, vis')) =>
+ let
+ fun getArgs (t, acc) =
+ case #1 t of
+ TFun (dom, ran) =>
+ getArgs (ran, dom :: acc)
+ | _ => (rev acc, t)
+ val (ts, ran) = getArgs (t, [])
+ val ran = case #1 ran of
+ CApp (_, ran) => ran
+ | _ => raise Fail "Rpcify: Tail function not transactional"
+ val len = length ts
+
+ val loc = #2 e
+ val args = ListUtil.mapi
+ (fn (i, _) =>
+ (ERel (len - i - 1), loc))
+ ts
+ val k = (EFfi ("Basis", "return"), loc)
+ val trans = (CFfi ("Basis", "transaction"), loc)
+ val k = (ECApp (k, trans), loc)
+ val k = (ECApp (k, ran), loc)
+ val k = (EApp (k, (EFfi ("Basis", "transaction_monad"),
+ loc)), loc)
+ val re = (ETailCall (n, args, k, ran, ran), loc)
+ val (re, _) = foldr (fn (dom, (re, ran)) =>
+ ((EAbs ("x", dom, ran, re),
+ loc),
+ (TFun (dom, ran), loc)))
+ (re, ran) ts
+
+ val be = multiLiftExpInExp (len + 1) e
+ val be = ListUtil.foldli
+ (fn (i, _, be) =>
+ (EApp (be, (ERel (len - i), loc)), loc))
+ be ts
+ val ne = (EFfi ("Basis", "bind"), loc)
+ val ne = (ECApp (ne, trans), loc)
+ val ne = (ECApp (ne, ran), loc)
+ val unit = (TRecord (CRecord ((KType, loc), []),
+ loc), loc)
+ val ne = (ECApp (ne, unit), loc)
+ val ne = (EApp (ne, (EFfi ("Basis", "transaction_monad"),
+ loc)), loc)
+ val ne = (EApp (ne, be), loc)
+ val ne = (EApp (ne, (ERel 0, loc)), loc)
+ val tunit = (CApp (trans, unit), loc)
+ val kt = (TFun (ran, tunit), loc)
+ val ne = (EAbs ("k", kt, tunit, ne), loc)
+ val (ne, res) = foldr (fn (dom, (ne, ran)) =>
+ ((EAbs ("x", dom, ran, ne), loc),
+ (TFun (dom, ran), loc)))
+ (ne, (TFun (kt, tunit), loc)) ts
+ in
+ (IM.insert (cpsed, n, #1 re),
+ (x, n, res, ne, s) :: vis')
+ end)
+ (#cpsed st, []) vis
+ in
+ ((DValRec (rev vis'), ErrorMsg.dummySpan),
+ {cpsed = cpsed,
+ rpc = rpc})
+ end
+ else
+ (d, st)
+ | DVal (x, n, t, e, s) =>
+ (d,
+ {cpsed = #cpsed st,
+ rpc = if makesServerCall e then
+ IS.add (#rpc st, n)
+ else
+ #rpc st})
+ | _ => (d, st)
+ in
+ U.Decl.foldMap {kind = fn x => x,
+ con = fn x => x,
+ exp = exp,
+ decl = fn x => x}
+ st d
+ end
+
+ val (file, _) = ListUtil.foldlMap decl
+ {cpsed = IM.empty,
+ rpc = IS.empty}
+ file
+ in
+ file
+ end
+
+end
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-27 03:12:14 +0000