Commit 4dedd34d authored by Wilke Pierre's avatar Wilke Pierre
Browse files

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

dans options.ml
parent ccb1a057
...@@ -39,3 +39,4 @@ let naive_regalloc = ref true ...@@ -39,3 +39,4 @@ let naive_regalloc = ref true
let rig_dump : string option ref = ref None let rig_dump : string option ref = ref None
let handwritten_lexer = ref Config.lex_hand let handwritten_lexer = ref Config.lex_hand
let alpaga_parser = ref Config.alpaga_parser let alpaga_parser = ref Config.alpaga_parser
let timeout = ref 1.0
...@@ -77,19 +77,54 @@ let record_compile_result ?error:(error=None) ?data:(data=[]) step = ...@@ -77,19 +77,54 @@ let record_compile_result ?error:(error=None) ?data:(data=[]) step =
results := !results @ [CompRes { step; error; data}] 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 = let run step flag eval p =
if flag then begin if flag then begin
let starttime = Unix.gettimeofday () in let starttime = Unix.gettimeofday () in
let res = match eval Format.str_formatter p !heapsize !params with let res = timeout
| exception e -> (fun (p, params) -> eval Format.str_formatter p !heapsize params)
Error (Printexc.to_string e) (p, !params)
| e -> e in !Options.timeout in
let timerun = Unix.gettimeofday () -. starttime 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 = let rres =
begin match res with 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 } | Error msg -> { rres with error = Some msg }
end in end in
results := !results @ [RunRes rres]; results := !results @ [RunRes rres];
...@@ -99,7 +134,7 @@ let run step flag eval p = ...@@ -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 "With parameters : [%s]<br>\n" (String.concat"," (List.map string_of_int !params))
^ Printf.sprintf "Mem size : %d bytes<br>\n" !heapsize ^ 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 "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 (match rres.error with
| Some msg -> Printf.sprintf "Error : <pre style=\"padding: 1em; background-color: #fcc;\">\n%s</pre>\n" msg | Some msg -> Printf.sprintf "Error : <pre style=\"padding: 1em; background-color: #fcc;\">\n%s</pre>\n" msg
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment