Browse thread
[Caml-list] Continuations
-
Ceri Storey
- Eric Merritt
- Christophe Raffalli
-
Michaël_Grünewald
- Christophe Raffalli
[
Home
]
[ Index:
by date
|
by threads
]
[ Message by date: previous | next ] [ Message in thread: previous | next ] [ Thread: previous | next ]
[ Message by date: previous | next ] [ Message in thread: previous | next ] [ Thread: previous | next ]
| Date: | -- (:) |
| From: | Christophe Raffalli <Christophe.Raffalli@u...> |
| Subject: | [Caml-list] Continuations: an implementation |
Here is an implementation of callcc for OCaml using fork.
The only problems are:
- I did not test it (but it should work)
- The limited number of fork calls
Note: the implementation of fork on Linux, makes a minimum of page copying, so
it should be reasonably fast
-- callcc.mli --
(* callcc fn: standard callcc, uses exit code 3 for internal use. *)
val callcc : (('a -> 'b) -> 'a) -> 'a
----------------
-- callcc.ml ---
open Unix
open Sys
let all_signals = [
sigabrt; (* Abnormal termination *)
sigalrm; (* Timeout *)
sigfpe; (* Arithmetic exception *)
sighup; (* Hangup on controlling terminal *)
sigill; (* In id hardware instruction *)
sigint; (* Interactive interrupt (ctrl-C) *)
sigkill; (* Termination (cannot be ignored) *)
sigpipe; (* Broken pipe *)
sigquit; (* Interactive termination *)
sigsegv; (* In id memory reference *)
sigterm; (* Termination *)
sigusr1; (* Application-defined signal 1 *)
sigusr2; (* Application-defined signal 2 *)
(* sigchld; Child process terminated, do not ignore that one !*)
sigcont; (* Continue *)
sigstop; (* Stop *)
sigtstp; (* Interactive stop *)
sigttin; (* Terminal read from background process *)
sigttou; (* Terminal write from background process *)
sigvtalrm; (* Timeout in virtual time *)
sigprof (* Profiling interrupt *)
]
let ignore_all_signals () =
let previous = List.map (fun s -> try signal s Signal_ignore with Sys_error
_ -> Signal_ignore) all_signals in
fun () ->
List.iter2 (fun s b -> try set_signal s b with Sys_error _ -> ())
all_signals previous
let callcc (fn : ('a -> 'b) -> 'a) =
let filename = Filename.temp_file "callcc" "val" in
let gn (x : 'a) =
let ch = open_out filename in
Marshal.to_channel ch x [Marshal.Closures];
close_out ch;
exit 3
in
let restore_signals = ignore_all_signals () in
let pid = fork () in
if pid = 0 then begin
restore_signals ();
fn gn
end else
let rec kn pid =
match waitpid [] pid with
_, WEXITED 3 ->
let ch = open_in filename in
let r = Marshal.from_channel ch in
close_in ch;
remove filename;
let pid = fork () in
if pid = 0 then (restore_signals (); r) else kn pid
| _, WEXITED n -> exit n
| _, _ -> exit 1
in kn pid
----------------
--
Christophe Raffalli
Université de Savoie
Batiment Le Chablais, bureau 21
73376 Le Bourget-du-Lac Cedex
tél: (33) 4 79 75 81 03
fax: (33) 4 79 75 87 42
mail: Christophe.Raffalli@univ-savoie.fr
www: http://www.lama.univ-savoie.fr/~RAFFALLI
---------------------------------------------
IMPORTANT: this mail is signed using PGP/MIME
At least Enigmail/Mozilla, mutt or evolution
can check this signature
---------------------------------------------