Commit aba710e2 authored by Armillon Damien's avatar Armillon Damien
Browse files

Merge remote-tracking branch 'le-remote-d-origine/master'

parents 15868ca6 7d7716e2
No preview for this file type
......@@ -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 3.0
open Batteries
open BatList
open BatEnum
open Prog
open Linear
open Rtl
......
......@@ -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
......
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