[Caml-list] Continuations: an implementation

[Christophe Raffalli <Christophe.Raffalli@univ-savoie.fr>]

[-- Attachment #1: Type: text/plain, Size: 2826 bytes --]

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
---------------------------------------------

[-- Attachment #2: Type: application/pgp-signature, Size: 252 bytes --]