From 384ecb187399b114c541b9fa7c8f6c181a419545 Mon Sep 17 00:00:00 2001 From: Mindy Preston Date: Thu, 22 Dec 2016 12:39:43 -0600 Subject: [PATCH 1/2] add tailcall annotation to recursive listen call --- src/netif.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/netif.ml b/src/netif.ml index d673f01..66bbc1d 100644 --- a/src/netif.ml +++ b/src/netif.ml @@ -132,7 +132,7 @@ let rec listen t fn = | Error `Disconnected -> t.active <- false ; Error `Disconnected in process () >>= (function - | Ok () -> listen t fn + | Ok () -> (listen[@tailcall]) t fn | Error e -> Lwt.return (Error e)) | false -> Lwt.return (Ok ()) From 0a602b673981ee6f3a34df8295be34b589550538 Mon Sep 17 00:00:00 2001 From: Mindy Preston Date: Thu, 22 Dec 2016 11:41:05 -0600 Subject: [PATCH 2/2] if something cancels "listen", stop the listener Without this patch, canceling the thread produced by `Netif.listen` had no effect. After this patch, canceling `Netif.listen` causes the thread to return with `Error `Disconnected`, but does not make the underlying device unusable for future calls to `listen` or `write`. --- src/netif.ml | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/src/netif.ml b/src/netif.ml index 66bbc1d..ae75568 100644 --- a/src/netif.ml +++ b/src/netif.ml @@ -101,12 +101,16 @@ let rec read t page = | Unix.Unix_error(Unix.ENXIO, _, _) -> log "[read] device %s is down, stopping" t.id; Lwt.return (Error `Disconnected) + | Lwt.Canceled -> + log "[read] user program requested cancellation of listen on %s" t.id; + Lwt.return (Error `Canceled) | exn -> log "[read] error: %s, continuing" (Printexc.to_string exn); Lwt.return (Error `Continue)) in process () >>= function | Error `Continue -> read t page + | Error `Canceled -> Lwt.return (Error `Canceled) | Error `Disconnected -> Lwt.return (Error `Disconnected) | Ok buf -> Lwt.return (Ok buf) @@ -129,6 +133,7 @@ let rec listen t fn = let process () = read t page >|= function | Ok buf -> Lwt.async (fun () -> safe_apply fn buf) ; Ok () + | Error `Canceled -> Error `Disconnected | Error `Disconnected -> t.active <- false ; Error `Disconnected in process () >>= (function