1(**************************************************************************) 2 3external mycallback1 : ('a -> 'b) -> 'a -> 'b = "mycallback1" 4external mycallback2 : ('a -> 'b -> 'c) -> 'a -> 'b -> 'c = "mycallback2" 5external mycallback3 : ('a -> 'b -> 'c -> 'd) -> 'a -> 'b -> 'c -> 'd 6 = "mycallback3" 7external mycallback4 : 8 ('a -> 'b -> 'c -> 'd -> 'e) -> 'a -> 'b -> 'c -> 'd -> 'e = "mycallback4" 9 10let rec tak (x, y, z as _tuple) = 11 if x > y then tak(tak (x-1, y, z), tak (y-1, z, x), tak (z-1, x, y)) 12 else z 13 14let tak2 x (y, z) = tak (x, y, z) 15 16let tak3 x y z = tak (x, y, z) 17 18let tak4 x y z u = tak (x, y, z + u) 19 20let raise_exit () = (raise Exit : unit) 21 22let trapexit () = 23 begin try 24 mycallback1 raise_exit () 25 with Exit -> 26 () 27 end; 28 tak (18, 12, 6) 29 30external mypushroot : 'a -> ('b -> 'c) -> 'b -> 'a = "mypushroot" 31external mycamlparam : 'a -> ('b -> 'c) -> 'b -> 'a = "mycamlparam" 32 33let tripwire f = 34 let s = String.make 5 'a' in 35 f s trapexit () 36 37(* Test callbacks performed to handle signals *) 38 39let sighandler signo = 40(* 41 print_string "Got signal, triggering garbage collection..."; 42 print_newline(); 43*) 44 (* Thoroughly wipe the minor heap *) 45 ignore (tak (18, 12, 6)) 46 47external unix_getpid : unit -> int = "unix_getpid" [@@noalloc] 48external unix_kill : int -> int -> unit = "unix_kill" [@@noalloc] 49 50let callbacksig () = 51 let pid = unix_getpid() in 52 (* Allocate a block in the minor heap *) 53 let s = String.make 5 'b' in 54 (* Send a signal to self. We want s to remain in a register and 55 not be spilled on the stack, hence we declare unix_kill 56 [@@noalloc]. *) 57 unix_kill pid Sys.sigusr1; 58 (* Allocate some more so that the signal will be tested *) 59 let u = (s, s) in 60 fst u 61 62let _ = 63 print_int(mycallback1 tak (18, 12, 6)); print_newline(); 64 print_int(mycallback2 tak2 18 (12, 6)); print_newline(); 65 print_int(mycallback3 tak3 18 12 6); print_newline(); 66 print_int(mycallback4 tak4 18 12 3 3); print_newline(); 67 print_int(trapexit ()); print_newline(); 68 print_string(tripwire mypushroot); print_newline(); 69 print_string(tripwire mycamlparam); print_newline(); 70 Sys.set_signal Sys.sigusr1 (Sys.Signal_handle sighandler); 71 print_string(callbacksig ()); print_newline() 72