From 4dedd34d7e7c57f226a86b20365ff3008e479fe6 Mon Sep 17 00:00:00 2001
From: Pierre Wilke <pierre.wilke@centralesupelec.fr>
Date: Thu, 11 Mar 2021 11:32:00 +0100
Subject: [PATCH] =?UTF-8?q?Les=20ex=C3=A9cutions=20=C3=A9chouent=20si=20el?=
=?UTF-8?q?les=20durent=20plus=20d'une=20seconde.=20Timeout=20param=C3=A9t?=
=?UTF-8?q?rable=20dans=20options.ml?=
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit
---
src/options.ml | 1 +
src/report.ml | 51 ++++++++++++++++++++++++++++++++++++++++++--------
2 files changed, 44 insertions(+), 8 deletions(-)
diff --git a/src/options.ml b/src/options.ml
index 5b3df95..d3966f5 100644
--- a/src/options.ml
+++ b/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
diff --git a/src/report.ml b/src/report.ml
index 94d927d..ba312d9 100644
--- a/src/report.ml
+++ b/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
--
GitLab