OCaml пишет функцию тайм-аута с использованием Async

Question

Я пытаюсь написать функцию, которая пытается оценить функцию, но останавливается после определенного времени ожидания.

Я пытался использовать Deferred.any, который возвращает отложенное, которое выполняется, когда выполняется одно из базовых отложенных.

type 'a output = OK of 'a | Exn of exn

let fun_test msg f eq (inp,ans) =
   let outp = wait_for (Deferred.any
     [ return (try OK (f inp) with e -> Exn e)
     ; (after (Core.Std.sec 0.0) >>| (fun () -> Exn TIMEOUT))])
   in {msg = msg;inp = inp;outp = outp;ans = ans;pass = eq outp ans}

Я не был уверен, как извлечь значение из отложенной монады, поэтому я написал функцию wait_for, которая просто вращается, пока не будет определено базовое значение.

let rec wait_for x =
   match Deferred.peek x with
      | None -> wait_for x
      | Some done -> done;;

Это не сработало. Прочитав главу об асинхронном реальном мире OCaml, я понял, что мне нужно запустить планировщик. Однако я не уверен, куда бы я позвонил Schedule.go в моем коде. Я не вижу, где тип go : ?raise_unhandled_exn:bool -> unit -> Core.Std.never_returns будет соответствовать коду, где вы на самом деле хотите, чтобы ваш асинхронный код возвращался. Документация для go говорит "Асинхронные программы не выходят до shutdown называется."

Я начинал сомневаться, что принял совершенно неправильный подход к проблеме, пока не нашел очень похожее решение этой же проблемы на этом веб-сайте Корнелла.

let timeout (thunk:unit -> 'a Deferred.t) (n:float) : ('a option) Deferred.t
  = Deferred.any 
    [ after (sec n) >>| (fun () -> None) ; 
      thunk () >>= (fun x -> Some x) ]

Во всяком случае, я не совсем уверен, мое использование wait_for верно. Есть ли канонический способ извлечь значение из отложенной монады? И как мне запустить планировщик?

Обновление: я пытался написать функцию тайм-аута, используя только Core.Std.Thread а также Core.Std.Mutex,

  let rec wait_for lck ptr =
    Core.Std.Thread.delay 0.25;
    Core.Std.Mutex.lock lck;
    (match !ptr with
     | None -> Core.Std.Mutex.unlock lck; wait_for lck ptr
     | Some x -> Core.Std.Mutex.unlock lck; x);;

  let timeout t f =
    let lck = Core.Std.Mutex.create () in
    let ptr = ref None in
    let _ = Core.Std.Thread.create
      (fun () -> Core.Std.Thread.delay t;
                 Core.Std.Mutex.lock lck;
                 (match !ptr with
                  | None -> ptr := Some (Exn TIMEOUT)
                  | Some _ -> ());
                 Core.Std.Mutex.unlock lck;) () in
    let _ = Core.Std.Thread.create
      (fun () -> let x = f () in
                 Core.Std.Mutex.lock lck;
                 (match !ptr with
                  | None -> ptr := Some x
                  | Some _ -> ());
                 Core.Std.Mutex.unlock lck;) () in
    wait_for lck ptr

Я думаю, что это довольно близко к работе. Это работает на вычислениях как let rec loop x = print_string ".\n"; loop x, но это не работает на вычислениях вроде let rec loop x = loop x, Я считаю, что проблема сейчас заключается в том, что если вычисление f () цикл бесконечен, тогда его поток никогда не прерывается, поэтому ни один из других потоков не может заметить, что время ожидания истекло. Если потоку IO нравится печатать строку, то поток действительно вытесняется. Также я не знаю, как убить поток, я не смог найти такую ​​функцию в документации для Core.Std.Thread

Answer 1

Решение, которое я придумал,

let kill pid sign = 
  try Unix.kill pid sign with
  | Unix.Unix_error (e,f,p) -> debug_print ((Unix.error_message e)^"|"^f^"|"^p)
  | e -> raise e;;


let timeout f arg time default = 
  let pipe_r,pipe_w = Unix.pipe () in
  (match Unix.fork () with
   | 0 -> let x = Some (f arg) in
          let oc = Unix.out_channel_of_descr pipe_w in
          Marshal.to_channel oc x [];
          close_out oc;
          exit 0
   | pid0 -> 
      (match Unix.fork () with
       | 0 -> Unix.sleep time;
              kill pid0 Sys.sigkill;
              let oc = Unix.out_channel_of_descr pipe_w in
              Marshal.to_channel oc default [];
              close_out oc;
              exit 0
       | pid1 -> let ic = Unix.in_channel_of_descr pipe_r in
                 let result = (Marshal.from_channel ic : 'b option) in
                 result ));;

Я думаю, что я мог бы создать два процесса зомби с этим, хотя. Но это единственное решение, которое работает на let rec loop x = loop x при компиляции с использованием ocamlopt (Решение с использованием Unix.alarm данный здесь работает при компиляции с ocamlc но не при компиляции с ocamlopt).