Les exécutions échouent si elles durent plus d'une seconde. Timeout paramétrable

dans options.ml

src/options.ml

@@ -39,3 +39,4 @@ let naive_regalloc = ref true
 let rig_dump : string option ref = ref None
 let handwritten_lexer = ref Config.lex_hand
 let alpaga_parser = ref Config.alpaga_parser
+let timeout = ref 1.0

src/report.ml

@@ -77,19 +77,54 @@ let record_compile_result ?error:(error=None) ?data:(data=[]) step =
   results := !results @ [CompRes { step; error; data}]
 
 
+let kill pid sign =
+  try Unix.kill pid sign with
+  | Unix.Unix_error (e,f,p) ->
+    begin match e with
+      | ESRCH -> ()
+      | _ -> Printf.printf "%s\n" ((Unix.error_message e)^"|"^f^"|"^p)
+    end
+  | e -> raise e
+
+let run_exn_to_error f x =
+  try f x with
+  | e -> Error (Printexc.to_string e)
+
+let timeout (f: 'a -> 'b res) (arg: 'a) (time: float) : ('b * string) res =
+  let pipe_r,pipe_w = Unix.pipe () in
+  (match Unix.fork () with
+   | 0 ->
+     let r =
+       run_exn_to_error f arg >>= fun v ->
+       OK (v, Format.flush_str_formatter ()) in
+     let oc = Unix.out_channel_of_descr pipe_w in
+     Marshal.to_channel oc r [];
+     close_out oc;
+     exit 0
+   | pid0 ->
+     (match Unix.fork () with
+      | 0 -> Unix.sleepf time;
+        kill pid0 Sys.sigkill;
+        let oc = Unix.out_channel_of_descr pipe_w in
+        Marshal.to_channel oc (Error (Printf.sprintf "Timeout after %f seconds." time)) [];
+        close_out oc;
+        exit 0
+      | pid1 -> let ic = Unix.in_channel_of_descr pipe_r in
+        let result = Marshal.from_channel ic in
+        result ))
+
 let run step flag eval p =
   if flag then begin
     let starttime = Unix.gettimeofday () in
-    let res = match eval Format.str_formatter p !heapsize !params with
-      | exception e ->
-        Error (Printexc.to_string e)
-      | e -> e in
+    let res = timeout
+        (fun (p, params) -> eval Format.str_formatter p !heapsize params)
+        (p, !params)
+        !Options.timeout in
     let timerun = Unix.gettimeofday () -. starttime in
-    let output = Format.flush_str_formatter () in
-    let rres = { step ; retval = None; output; error = None; time = timerun} in
+    let rres = { step ; retval = None; output=""; error = None; time = timerun} in
     let rres =
     begin match res with
-      | OK v ->  { rres with retval = v }
+      | OK (v, output) ->  { rres with retval = v; output }
       | Error msg -> { rres with error = Some msg }
     end in
     results := !results @ [RunRes rres];
@@ -99,7 +134,7 @@ let run step flag eval p =
           Printf.sprintf "With parameters : [%s]<br>\n" (String.concat"," (List.map string_of_int !params))
           ^ Printf.sprintf "Mem size : %d bytes<br>\n" !heapsize
           ^ Printf.sprintf "Return value : %s<br>\n" (match rres.retval with | Some v -> string_of_int v | _ -> "none")
-          ^ Printf.sprintf "Output : <pre style=\"padding: 1em; background-color: #ccc;\">%s</pre>\n" output
+          ^ Printf.sprintf "Output : <pre style=\"padding: 1em; background-color: #ccc;\">%s</pre>\n" rres.output
           ^
           (match rres.error with
            | Some msg -> Printf.sprintf "Error : <pre style=\"padding: 1em; background-color: #fcc;\">\n%s</pre>\n" msg