Commit | Line | Data |
---|---|---|
7f918cf1 CE |
1 | (* Copyright (C) 1999-2006, 2008 Henry Cejtin, Matthew Fluet, Suresh |
2 | * Jagannathan, and Stephen Weeks. | |
3 | * Copyright (C) 1997-2000 NEC Research Institute. | |
4 | * | |
5 | * MLton is released under a BSD-style license. | |
6 | * See the file MLton-LICENSE for details. | |
7 | *) | |
8 | ||
9 | structure MLtonCont:> MLTON_CONT = | |
10 | struct | |
11 | ||
12 | structure Thread = | |
13 | struct | |
14 | open Primitive.MLton.Thread | |
15 | val savedPre = fn () => savedPre Primitive.MLton.GCState.gcState | |
16 | end | |
17 | ||
18 | fun die (s: string): 'a = | |
19 | (PrimitiveFFI.Stdio.print s | |
20 | ; PrimitiveFFI.Posix.Process.exit 1 | |
21 | ; let exception DieFailed | |
22 | in raise DieFailed | |
23 | end) | |
24 | ||
25 | type 'a t = (unit -> 'a) -> unit | |
26 | ||
27 | fun callcc (f: 'a t -> 'a): 'a = | |
28 | if MLtonThread.amInSignalHandler () | |
29 | then die "MLton.Cont.callcc can not be used in a signal handler\n" | |
30 | else | |
31 | let | |
32 | datatype 'a state = | |
33 | Original of 'a t -> 'a | |
34 | | Copy of unit -> 'a | |
35 | | Clear | |
36 | val r: 'a state ref = ref (Original f) | |
37 | val _ = Thread.atomicBegin () (* Match 1 *) | |
38 | val _ = Thread.copyCurrent () | |
39 | in | |
40 | case (!r before r := Clear) of | |
41 | Clear => raise Fail "MLton.Cont.callcc: Clear" | |
42 | | Copy v => | |
43 | let | |
44 | val _ = Thread.atomicEnd () (* Match 2 *) | |
45 | in | |
46 | v () | |
47 | end | |
48 | | Original f => | |
49 | let | |
50 | val t = Thread.savedPre () | |
51 | val _ = Thread.atomicEnd () (* Match 1 *) | |
52 | in | |
53 | f (fn v => | |
54 | let | |
55 | val _ = Thread.atomicBegin () (* Match 2 *) | |
56 | val _ = r := Copy v | |
57 | val new = Thread.copy t | |
58 | val _ = Thread.atomicBegin () (* Match 3 *) | |
59 | in | |
60 | Thread.switchTo new (* Match 3 *) | |
61 | end) | |
62 | end | |
63 | end | |
64 | ||
65 | fun ('a, 'b) throw' (k: 'a t, v: unit -> 'a): 'b = | |
66 | (k v; raise Fail "MLton.Cont.throw': return from continuation") | |
67 | ||
68 | fun ('a, 'b) throw (k: 'a t, v: 'a): 'b = throw' (k, fn () => v) | |
69 | ||
70 | fun prepend (k, f) v = throw' (k, f o v) | |
71 | ||
72 | local | |
73 | val thRef: (unit -> unit) option ref = ref NONE | |
74 | val base: Thread.preThread = | |
75 | let | |
76 | val () = Thread.copyCurrent () | |
77 | in | |
78 | case !thRef of | |
79 | NONE => Thread.savedPre () | |
80 | | SOME th => | |
81 | let | |
82 | val () = thRef := NONE | |
83 | val () = Thread.atomicEnd () (* Match 1 *) | |
84 | val _ = (th () ; Exit.topLevelSuffix ()) | |
85 | handle exn => MLtonExn.topLevelHandler exn | |
86 | in | |
87 | raise Fail "MLton.Cont.isolate: return from (wrapped) func" | |
88 | end | |
89 | end | |
90 | in | |
91 | val isolate: ('a -> unit) -> 'a t = | |
92 | fn (f: 'a -> unit) => | |
93 | fn (v: unit -> 'a) => | |
94 | let | |
95 | val _ = Thread.atomicBegin () (* Match 1 *) | |
96 | val _ = Thread.atomicBegin () (* Match 2 *) | |
97 | val () = thRef := SOME (f o v) | |
98 | val new = Thread.copy base | |
99 | in | |
100 | Thread.switchTo new (* Match 2 *) | |
101 | end | |
102 | end | |
103 | ||
104 | end |