Merge pull request xapi-project#32 from DeliZhangX/private/deliz/CA-248467-PR

CA-248467: message-cli tail --follow causes VM reboot too slow

Author: Jon Ludlam

switch/switch_main.ml

@@ -212,9 +212,6 @@ let make_server config =
     Lwt_condition.broadcast queues_c ();
     return () in
 
-  (* Held while processing a non-blocking request *)
-  let m = Lwt_mutex.create () in
-
   (* (Response.t * Body.t) Lwt.t *)
   let callback (_, conn_id) req body =
     (* Make sure we replay the log before processing requests *)
@@ -254,7 +251,7 @@ let make_server config =
         | _, _ -> return () )
       >>= fun () ->
 
-      Lwt_mutex.with_lock m
+      Lwt_mutex.with_lock Switch_main_helper.m
         (fun () ->
           process_request conn_id_s !queues session request
           >>= fun (op_opt, response) ->
@@ -280,7 +277,7 @@ let make_server config =
           info "Session %s cleaning up" session;
           let qs = Q.owned_queues !queues session in
           let ops = Q.StringSet.fold (fun x ops -> Q.Directory.remove !queues x :: ops) qs [] in
-          Lwt_mutex.with_lock m
+          Lwt_mutex.with_lock Switch_main_helper.m
             (fun () ->
               perform ops
             ) in

switch/switch_main_helper.ml

@@ -0,0 +1,20 @@
+(*
+ * Copyright (c) Citrix Systems Inc.
+ *
+ * Permission to use, copy, modify, and distribute this software for any
+ * purpose with or without fee is hereby granted, provided that the above
+ * copyright notice and this permission notice appear in all copies.
+ *
+ * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
+ * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
+ * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
+ * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
+ * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
+ * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
+ * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
+ *)
+open Lwt
+
+(* Held while processing a non-blocking request *)
+let m = Lwt_mutex.create ()
+

switch/trace.ml

@@ -42,7 +42,7 @@ let get from timeout : (int64 * Protocol.Event.t) list Lwt.t =
   let sleep = Lwt_unix.sleep timeout in
   let rec wait_for_data () =
     if !next_id <= from then
-      Lwt_condition.wait c >>= wait_for_data
+      Lwt_condition.wait ?mutex:(Some Switch_main_helper.m) c >>= wait_for_data
     else return ()
   in
   (* Wait until some data is available ie. when next_id > from (or timeout) *)