Unit testing OCaml使用Async编写超时函数

我正在尝试编写一个函数，该函数尝试对函数求值，但在特定超时后停止

我尝试使用了

Deferred.any

，它返回一个Deferred，当一个基础Deferred被满足时，它就会被满足

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}

我不知道如何从延迟的monad中提取一个值，所以我编写了一个函数“wait_for”，它只会旋转，直到确定底层值

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

这不起作用。读完之后，我意识到我需要启动调度程序。但是，我不确定在哪里调用我的代码中的

Schedule.go

。我看不出类型

go:？raise\u unhandled\u exn:bool->unit->Core.Std.never\u returns

将适合您实际希望异步代码返回的代码。

go

的文档中说“异步程序在调用

shutdown

之前不会退出。”

我开始怀疑我对这个问题采取了完全错误的方法，直到我在网上找到了一个非常类似的解决方案

无论如何，我不太确定我使用的

wait\u for

是否正确。有没有一种规范的方法可以从延迟的monad中提取值？还有，如何启动调度程序

更新： 我尝试只使用

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”；循环x

，但它不适用于类似于

let rec loop x=loop x

的计算。我认为现在的问题是，如果计算

f（）

无限循环，那么它的线程永远不会被抢占，因此其他线程都不会注意到超时已经过期。如果线程不喜欢打印字符串，那么线程会被抢占。另外，我不知道如何终止线程，我在

中找不到这样的函数。我提出的解决方案是

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 ));;

---

我想我可能用这个创建了两个僵尸进程。但是，当使用

ocamlopt

编译时，它是唯一能在

let rec loop x=loop x

上工作的解决方案（使用

Unix.alarm

的解决方案在使用

ocamlc

编译时有效，但在使用

ocamlopt

编译时无效）。

可能是一些提示（可能您已经阅读过）：.我对

async

感到相当失望，于是切换到

lwt

。我在密码里什么也没找到。据我所知，

Command.async

需要一个函数，返回一个

延迟单位.t

和

Command.run

返回

（）

。我在寻找一个函数，让我运行一个异步计算和块，直到它返回结果。。。。我尝试了timeout.ml，但令人惊讶的是，我在执行它时没有看到任何超时…相关：

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 ));;