[MLton-commit] r6613

[Matthew Fluet]

Derivation of isolate.

----------------------------------------------------------------------

U   mlton/trunk/basis-library/mlton/cont.sml

----------------------------------------------------------------------

Modified: mlton/trunk/basis-library/mlton/cont.sml
===================================================================
--- mlton/trunk/basis-library/mlton/cont.sml	2008-05-10 11:42:32 UTC (rev 6612)
+++ mlton/trunk/basis-library/mlton/cont.sml	2008-05-10 11:42:38 UTC (rev 6613)
@@ -56,8 +56,167 @@
                 end
        end
 
+fun ('a, 'b) throw' (k: 'a t, v: unit -> 'a): 'b =
+   (k v; raise Fail "MLton.Cont.throw': return from continuation")
+
+fun ('a, 'b) throw (k: 'a t, v: 'a): 'b = throw' (k, fn () => v)
+
+fun prepend (k, f) v = throw' (k, f o v)
+
+
+(* ********** *)
+val isolate: ('a -> unit) -> 'a t =
+   fn (f: 'a -> unit) =>
+   callcc
+   (fn k1 =>
+    let
+       val x = callcc (fn k2 => throw (k1, k2))
+       val _ = (f x ; Exit.topLevelSuffix ())
+               handle exn => MLtonExn.topLevelHandler exn
+    in
+       raise Fail "MLton.Cont.isolate: return from (wrapped) func"
+    end)
+
+(* ********** *)
 local
+val base: (unit -> unit) t =
+   callcc
+   (fn k1 =>
+    let
+       val th = callcc (fn k2 => throw (k1, k2))
+       val _ = (th () ; Exit.topLevelSuffix ())
+               handle exn => MLtonExn.topLevelHandler exn
+    in
+       raise Fail "MLton.Cont.isolate: return from (wrapped) func"
+    end)
+in
+val isolate: ('a -> unit) -> 'a t =
+   fn (f: 'a -> unit) =>
+   callcc
+   (fn k1 =>
+    let
+       val x = callcc (fn k2 => throw (k1, k2))
+    in
+       throw (base, fn () => f x)
+    end)
+end
+
+(* ********** *)
+local
+val base: (unit -> unit) t =
+   callcc
+   (fn k1 =>
+    let
+       val th = callcc (fn k2 => throw (k1, k2))
+       val _ = (th () ; Exit.topLevelSuffix ())
+               handle exn => MLtonExn.topLevelHandler exn
+    in
+       raise Fail "MLton.Cont.isolate: return from (wrapped) func"
+    end)
+in
+val isolate: ('a -> unit) -> 'a t =
+   fn (f: 'a -> unit) =>
+   callcc
+   (fn k1 =>
+    throw (base, fn () =>
+           let
+              val x = callcc (fn k2 => throw (k1, k2))
+           in
+              throw (base, fn () => f x)
+           end))
+end
+
+(* ********** *)
+local
+val base: (unit -> unit) option t =
+   let
+      val base: (unit -> unit) option t option ref = ref NONE
+      val th = callcc (fn k => (base := SOME k; NONE))
+   in
+      case th of
+         NONE => (case !base of
+                     NONE => raise Fail "MLton.Cont.isolate: missing base"
+                   | SOME base => base)
+       | SOME th => let
+                       val _ = (th () ; Exit.topLevelSuffix ())
+                               handle exn => MLtonExn.topLevelHandler exn
+                    in
+                       raise Fail "MLton.Cont.isolate: return from (wrapped) func"
+                    end
+   end
+in
+val isolate: ('a -> unit) -> 'a t =
+   fn (f: 'a -> unit) =>
+   callcc
+   (fn k1 =>
+    throw (base, SOME (fn () =>
+           let
+              val x = callcc (fn k2 => throw (k1, k2))
+           in
+              throw (base, SOME (fn () => f x))
+           end)))
+end
+
+(* ********** *)
+local
+val base: (unit -> unit) option t =
+   let
+      val base: (unit -> unit) option t ref =
+         ref (fn _ => raise Fail "MLton.Cont.isolate: missing base")
+      val th = callcc (fn k => (base := k; NONE))
+   in
+      case th of
+         NONE => !base
+       | SOME th => let
+                       val _ = (th () ; Exit.topLevelSuffix ())
+                               handle exn => MLtonExn.topLevelHandler exn
+                    in
+                       raise Fail "MLton.Cont.isolate: return from (wrapped) func"
+                    end
+   end
+in
+val isolate: ('a -> unit) -> 'a t =
+   fn (f: 'a -> unit) =>
+   fn (v: unit -> 'a) =>
+   throw (base, SOME (f o v))
+end
+
+(* ********** *)
+local
 val thunk: (unit -> unit) option ref = ref NONE
+val base: unit t =
+   let
+      val base: unit t ref =
+         ref (fn _ => raise Fail "MLton.Cont.isolate: missing base")
+      val () = callcc (fn k => base := k)
+   in
+      case !thunk of
+         NONE => !base
+       | SOME th =>
+            let
+               val _ = thunk := NONE
+               val _ = Thread.atomicEnd () (* Match 1 *)
+               val _ = (th () ; Exit.topLevelSuffix ())
+                       handle exn => MLtonExn.topLevelHandler exn
+            in
+               raise Fail "MLton.Cont.isolate: return from (wrapped) func"
+            end
+   end
+in
+val isolate: ('a -> unit) -> 'a t =
+   fn (f: 'a -> unit) =>
+   fn (v: unit -> 'a) =>
+   let
+      val _ = Thread.atomicBegin () (* Match 1 *)
+      val () = thunk := SOME (f o v)
+   in
+      throw (base, ())
+   end
+end
+
+(* ********** *)
+local
+val thunk: (unit -> unit) option ref = ref NONE
 val base: Thread.preThread =
    let
       val () = Thread.copyCurrent ()
@@ -77,22 +236,15 @@
 in
 val isolate: ('a -> unit) -> 'a t =
    fn (f: 'a -> unit) =>
-   fn (xth: unit -> 'a) =>
+   fn (v: unit -> 'a) =>
    let
       val _ = Thread.atomicBegin () (* Match 1 *)
       val _ = Thread.atomicBegin () (* Match 2 *)
-      val () = thunk := SOME (f o xth)
+      val () = thunk := SOME (f o v)
       val new = Thread.copy base
    in
       Thread.switchTo new (* Match 2 *)
    end
 end
 
-fun ('a, 'b) throw' (k: 'a t, v: unit -> 'a): 'b =
-   (k v; raise Fail "MLton.Cont.throw': return from continuation")
-
-fun ('a, 'b) throw (k: 'a t, v: 'a): 'b = throw' (k, fn () => v)
-
-fun prepend (k, f) v = throw' (k, f o v)
-
 end