Skip to content
This repository
tag: v454
Fetching contributors…

Octocat-spinner-32-eaf2f5

Cannot retrieve contributors at this time

file 727 lines (658 sloc) 20.444 kb
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726
(*
Copyright © 2011 MLstate

This file is part of OPA.

OPA is free software: you can redistribute it and/or modify it under the
terms of the GNU Affero General Public License, version 3, as published by
the Free Software Foundation.

OPA is distributed in the hope that it will be useful, but WITHOUT ANY
WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for
more details.

You should have received a copy of the GNU Affero General Public License
along with OPA. If not, see <http://www.gnu.org/licenses/>.
*)

(*
This module manage asynchronous operations.
See scheduler.mli for more information.

@author Cedric Soulas
*)

#<Debugvar:SCHEDULER_DEBUG>

module C = Connection
module L = SchedulerLog
module K = SchedulerKer
module E = SchedulerExc
module Job = SchedulerJob
module NA = NetAddr

type t = {
  stats : NetStats.t;
  mutable operation : K.Operation.t;
  priority : K.Priority.t;
  descriptor : K.Descriptor.t;
  compute : K.Compute.t;
  finalise : K.Finalise.t;
  counter : K.Counter.t;
  mutable at_exit : K.Compute.t option; (* none => already transfer to compute field, some => pending exiting computation *)
}

type async_key = K.Priority.key

type connection_info = {
  addr : NetAddr.t; (* the connection type *)
  conn_id : int (* the unique id of the connection *)
}

exception StopTimer
exception Busy_direction = K.Operation.Busy_direction
exception Timeout = K.Priority.Timeout
exception Connection_closed
exception Syscall
exception LimitExceeded
exception Empty
exception Unbound_key

(* ============================== *)
(* Connections *)
(* ============================== *)

let make_connection sched ?(register=true) addr =
  #<If> L.info_new_conn "make_connection" addr #<End>;
  let id =
    if register then
      K.Descriptor.add sched.descriptor (NA.get_fd addr)
    else
      -1
  in
  {
    addr = addr;
    conn_id = id;
  }

let nb_of_connection sched = K.Descriptor.length sched.descriptor

let check_connection sched conn =
  let fd = NA.get_fd conn.addr in
  match K.Descriptor.mem sched.descriptor fd conn.conn_id with
  | K.Descriptor.Alive -> true
  | K.Descriptor.Replaced | K.Descriptor.Closed -> false

let remove_connection sched conn =
  if check_connection sched conn then begin
    let fd = NA.get_fd conn.addr in
    #<If> L.info_conn "remove_connection" conn.addr #<End>;
    K.Descriptor.remove sched.descriptor fd;
    K.Operation.remove_id sched.operation fd;
    C.close conn.addr;
  end

let get_connection_addr conn = conn.addr

let get_connection_fd conn = NA.get_fd conn.addr

let get_connection_inet_addr conn =
  NA.get_addr (get_connection_addr conn)

let get_connection_secured_from_normal conn secured_fd =
  let addr = NA.secured_from_normal secured_fd conn.addr in
  {conn with addr = addr}

(* ============================== *)
(* In / Out Operations *)
(* ============================== *)

let get_err_cont sched conn err_cont =
  Option.default
    (function
     | Connection_closed ->
         #<If> L.info_conn "connection_closed" conn.addr #<End>;
         remove_connection sched conn
     | Syscall ->
         #<If> L.info_conn "syscall" conn.addr #<End>;
         remove_connection sched conn
     | Timeout | _ -> ()
    ) err_cont

let write sched conn ?(block_size=32768) ?timeout buf ?err_cont finalize =
  #<If> L.info_conn "write" conn.addr #<End>;
  let error = get_err_cont sched conn err_cont in
  let buflen = String.length buf in
  let decide (nwrite, pos) =
    if nwrite = 0 then
      Job.Error Connection_closed
    else
      let to_write = min block_size (buflen - pos) in
      if to_write > 0 then Job.Execute (pos, to_write, buf)
      else Job.Finalize buflen
  in
  let execute (pos, to_write, buf) =
    try
      let n = C.write conn.addr ~pos buf to_write in
      NetStats.register_send ~size:to_write ~conn:conn.addr sched.stats;
      n, pos + n
    with
    | C.Busy ->
        #<If> L.info_conn "write" ~s:"busy" conn.addr #<End>;
        -1, pos
  in
  let _ =
  Job.make
    sched.operation
    sched.priority
    sched.counter
    (NA.get_fd conn.addr)
    K.Operation.Out
    timeout
    decide
    execute
    error
    finalize
    (-1, 0)
  in
  ()

let write_to sched conn addr ?(block_size=4096) ?timeout buf ?err_cont finalize =
  #<If> L.info_conn "write_to" conn.addr #<End>;
  let error = get_err_cont sched conn err_cont in
  let buflen = String.length buf in
  let decide (nwrite, pos) =
    if nwrite = 0 then
      Job.Error Connection_closed
    else
      let to_write = min block_size (buflen - pos) in
      if to_write > 0 then Job.Execute (pos, to_write, buf)
      else Job.Finalize buflen
  in
  let execute (pos, to_write, buf) =
    try
      let n = C.write_to conn.addr addr ~pos buf to_write in
      NetStats.register_send ~size:to_write ~conn:conn.addr sched.stats;
      n, pos + n
    with
    | C.Busy ->
        #<If> L.info_conn "write_to" ~s:"busy" conn.addr #<End>;
        -1, pos
    | e -> raise e
  in
  let _ =
  Job.make
    sched.operation
    sched.priority
    sched.counter
    (NA.get_fd conn.addr)
    K.Operation.Out
    timeout
    decide
    execute
    error
    finalize
    (-1, 0)
  in
  ()

let read_more sched conn ?read_max ?(block_size=32768) ?timeout buf ?(size_max=(-1)) ?err_cont finalize =
  (* TODO: read_max and size_max (windows) unused *)
  #<If> L.info_conn "read_more" conn.addr #<End>;
  let _ = read_max in
  let _ = size_max in
  let decide (nb_read, buf) =
    if nb_read = -1 then Job.Execute buf
    else if nb_read = 0 then Job.Error Connection_closed
    else Job.Finalize (nb_read, buf)
  in
  let execute buf =
    try
      let nread, buf = C.read_more conn.addr buf block_size in
      NetStats.register_recv ~size:nread ~conn:conn.addr sched.stats;
      nread, buf
    with
    | C.Busy ->
        #<If> L.info_conn "read" ~s:"busy" conn.addr #<End>;
        (-1, buf)
    | e -> raise e
  in
  let error = get_err_cont sched conn err_cont in
  let _ =
  Job.make
    sched.operation
    sched.priority
    sched.counter
    (NA.get_fd conn.addr)
    K.Operation.In
    timeout
    decide
    execute
    error
    finalize
    (-1, buf)
  in
  ()

let read_content sched conn ?read_max ?(block_size=32768) ?timeout content ?(size_max=(-1)) ?err_cont finalize =
  (* TODO: read_max and size_max (windows) unused *)
  #<If> L.info_conn "read_content" conn.addr #<End>;
  let _ = read_max in
  let _ = size_max in
  let decide (nb_read, content) =
    if nb_read = -1 then Job.Execute content
    else if nb_read = 0 then Job.Error Connection_closed
    else Job.Finalize (nb_read, content)
  in
  let execute content =
    try
      let nread, buf = C.read_content conn.addr content block_size in
      NetStats.register_recv ~size:nread ~conn:conn.addr sched.stats;
      nread, buf
    with
    | C.Busy ->
        #<If> L.info_conn "read" ~s:"busy" conn.addr #<End>;
        (-1, content)
    | e -> raise e
  in
  let error = get_err_cont sched conn err_cont in
  let _ =
  Job.make
    sched.operation
    sched.priority
    sched.counter
    (NA.get_fd conn.addr)
    K.Operation.In
    timeout
    decide
    execute
    error
    finalize
    (-1, content)
  in
  ()

let read_more2 sched conn ?read_max ?timeout buf ?(size_max=(-1)) ?err_cont finalize =
  (* TODO: read_max and size_max (windows) unused *)
  #<If> L.info_conn "read_more2" conn.addr #<End>;
  let _ = read_max in
  let _ = size_max in
  let decide (nb_read, buf) =
    if nb_read = -1 then Job.Execute buf
    else if nb_read = 0 then Job.Error Connection_closed
    else Job.Finalize (nb_read, buf)
  in
  let execute buf =
    try
      let nread, buf = C.read_more2 conn.addr buf in
      NetStats.register_recv ~size:nread ~conn:conn.addr sched.stats;
      nread, buf
    with
    | C.Busy ->
        #<If> L.info_conn "read" ~s:"busy" conn.addr #<End>;
        (-1, buf)
    | e -> raise e
  in
  let error = get_err_cont sched conn err_cont in
  let _ =
  Job.make
    sched.operation
    sched.priority
    sched.counter
    (NA.get_fd conn.addr)
    K.Operation.In
    timeout
    decide
    execute
    error
    finalize
    (-1, buf)
  in
  ()

let read sched conn ?timeout ?err_cont finalize =
  #<If> L.info_conn "read" conn.addr #<End>;
  let decide (nb_read, str) =
    if nb_read = -1 then Job.Execute ()
    else if nb_read = 0 then Job.Error Connection_closed
    else Job.Finalize (nb_read, str)
  in
  let execute () =
    try
      let nread, buf = C.read conn.addr in
      NetStats.register_recv ~size:nread ~conn:conn.addr sched.stats;
      nread, buf
    with
    | C.Busy ->
        #<If> L.info_conn "read" ~s:"busy" conn.addr #<End>;
        (-1, "")
  in
  let error = get_err_cont sched conn err_cont in
  let _ =
  Job.make
    sched.operation
    sched.priority
    sched.counter
    (NA.get_fd conn.addr)
    K.Operation.In
    timeout
    decide
    execute
    error
    finalize
    (-1, "")
  in
  ()

let read_from sched conn ?timeout ?err_cont finalize =
  #<If> L.info_conn "read_from" conn.addr #<End>;
  let no_result = (-1, Unix.ADDR_UNIX "[no source]", "") (* FIXME: what should be the non-existant value for the address? *) in
  let decide (nb_read, addr, str) =
    if nb_read = -1 then Job.Execute ()
    else if nb_read = 0 then Job.Error Connection_closed
    else Job.Finalize (nb_read, addr, str)
  in
  let execute () =
    try
      let nread, addr, buf = C.read_from conn.addr in
      NetStats.register_recv ~size:nread ~conn:conn.addr sched.stats;
      nread, addr, buf
    with
    | C.Busy ->
        #<If> L.info_conn "read_from" ~s:"busy" conn.addr #<End>;
        no_result
    | e -> raise e
  in
  let error = get_err_cont sched conn err_cont in
  let _ =
  Job.make
    sched.operation
    sched.priority
    sched.counter
    (NA.get_fd conn.addr)
    K.Operation.In
    timeout
    decide
    execute
    error
    finalize
    no_result
  in
  ()

let read_until sched conn read_cond ?(block_size=32768) ?timeout ?err_cont finalize =
  #<If> L.info_conn "read_until" conn.addr #<End>;
  let rec aux_more (_, buff) =
    let nb_read = FBuffer.length buff in
    let str = FBuffer.contents buff in
    if read_cond (nb_read, str) then
      finalize (nb_read, str)
    else
      read_more sched conn ?timeout ~block_size ?err_cont buff aux_more
  in
  let aux (nb_read, str) =
    if read_cond (nb_read, str) then
      finalize (nb_read, str)
    else begin
      let buff = FBuffer.make (block_size*2) in
      let buff = FBuffer.add buff str in
      read_more sched conn ?timeout ~block_size ?err_cont buff aux_more
    end
  in
  read sched conn ?timeout ?err_cont aux

let read_min sched conn read_min =
  #<If> L.info_conn "read_min" conn.addr #<End>;
  let read_cond (nb_read, _) = nb_read >= read_min in
  read_until sched conn read_cond

let read_lines sched conn =
  #<If> L.info_conn "read_lines" conn.addr #<End>;
  let read_cond (_, str) =
    let l = String.length str in
    str.[l - 2] = '\r' && str.[l - 1] = '\n'
  in
  read_until sched conn read_cond

let read_all sched conn ?(read_max=Some max_int) ?(block_size=32768) ?timeout ?(buf=FBuffer.make 0) ?(size_max=(-1)) ?err_cont finalize =
  let decide (nb_read, nb_part_read, buf) =
    #<If> L.info_conn "read_all" conn.addr #<End>;
    let to_read = min block_size (Option.default max_int read_max - nb_read) in
    let buf_len = FBuffer.length buf in
    if size_max > 0 && buf_len > size_max then
      raise LimitExceeded
    else
      if (nb_part_read = -1)
        || (read_max <> None && nb_part_read > 0 && nb_read < Option.default max_int read_max)
      then begin
        #<If> L.info_conn "read_all" ~s:(Printf.sprintf "%d" nb_read) conn.addr #<End>;
        Job.Execute (nb_read, to_read, buf)
      end else begin
        #<If> L.info_conn "read_all" ~s:"finalize" conn.addr #<End>;
        Job.Finalize (nb_read, buf)
      end
  in
  let execute (nb_read_before, to_read, buf) =
    try
      let (nb_read, buf) = C.read_more conn.addr buf to_read in
      NetStats.register_recv ~size:nb_read ~conn:conn.addr sched.stats;
      nb_read_before + nb_read, nb_read, buf
    with
    | C.Busy ->
        #<If> L.info_conn "read_all" ~s:"busy" conn.addr #<End>;
        nb_read_before, -1, buf
  in
  let finalize v =
    finalize v;
    remove_connection sched conn
  in
  let error = Option.default (fun _ -> ()) err_cont in
  let _ =
  Job.make
    sched.operation
    sched.priority
    sched.counter
    (NA.get_fd conn.addr)
    K.Operation.In
    timeout
    decide
    execute
    error
    finalize
    (0, -1, buf)
  in
  ()

let listen sched conn ?timeout ?err_cont execute =
  #<If> L.info_conn "listen" conn.addr #<End>;
  let decide () = Job.Execute () in
  (* Can't use the get_err_cont because it remove the
listen connection when the client disconnect *)
  let error = Option.default (fun _ -> ()) err_cont in
  let finalize () = assert false in (* never finalize *)
  Job.make
    sched.operation
    sched.priority
    sched.counter
    ~force_polling:true
    (NA.get_fd conn.addr)
    K.Operation.In
    timeout
    decide
    execute
    error
    finalize
    ()

let poll direction _label sched conn ?timeout ?err_cont finalize =
  #<If> L.info_conn _label conn.addr #<End>;
  let error = get_err_cont sched conn err_cont in
  let decide is_first =
    if is_first then Job.Execute ()
    else Job.Finalize ()
  in
  let execute () = false in (* directly finalize *)
  let _ =
  Job.make
    sched.operation
    sched.priority
    sched.counter
    ~force_polling:true
    (NA.get_fd conn.addr)
    direction
    timeout
    decide
    execute
    error
    finalize
    true
  in
  ()

let listen_once = poll K.Operation.In "listen_once"
let connect = poll K.Operation.Out "connect"

(* ============================== *)
(* Async calculations *)
(* ============================== *)

let sleep sched time timer_fun =
  #<If> L.info "sleep" ~s:(Printf.sprintf "%d" (Time.in_milliseconds time)) #<End>;
  let key = K.Counter.get_next_int sched.counter in
  K.Priority.add sched.priority key time timer_fun;
  key

let timer sched time timer_fun =
  let rec f() =
    try
      timer_fun ();
      ignore(sleep sched time f)
    with
      | StopTimer -> ()
      | Sys.Break as e -> raise e
      | e -> (* maybe move it in the E. module *)
          let message = Printf.sprintf "Timer function exception: (%s)" (Printexc.to_string e) in
          L.error "timer" message;
  in
  ignore(sleep sched time f)

let push sched f =
  K.Compute.push sched.compute f

(* ============================== *)
(* Wait *)
(* ============================== *)

(* Private function *)
let incr_level sched =
  #<If> L.incr_level () #<End>;
  K.Counter.incr_level sched.counter

(* Private function *)
let decr_level sched =
  #<If> L.decr_level () #<End>;
  K.Counter.decr_level sched.counter

let abort sched key =
  if K.Priority.mem sched.priority key then begin
    #<If> L.info "abort priority" ~s:(Printf.sprintf "%d" key) #<End>;
    K.Priority.remove sched.priority key
  end;
  if K.Operation.mem_key sched.operation key then begin
    #<If> L.info "abort operation" ~s:(Printf.sprintf "%d" key) #<End>;
    K.Operation.remove sched.operation key
  end

let do_wait sched ~block =

  if not (K.Finalise.is_empty sched.finalise) then begin
    #<If> L.info "finalise" ~s:(Printf.sprintf "%d callbacks" (K.Finalise.length sched.finalise)) #<End>;
    K.Finalise.process_all sched.finalise
  end;

  if not (K.Compute.is_empty sched.compute) then begin
    #<If> L.info "compute" #<End>;
    K.Compute.process sched.compute
  end;
  let tout = K.Priority.process sched.priority in (* in milliseconds *)

  let nothing_to_do =
    K.Compute.is_empty sched.compute
    && K.Finalise.is_empty sched.finalise
  in

  if (not (K.Operation.is_empty sched.operation)) || (nothing_to_do && tout != -1) then
    begin
    let block = block && nothing_to_do in
    let tout = if block then tout else 0 in
    #<If> L.info "priority" ~s:(Printf.sprintf "%d ms" tout) #<End>;
    let ids = K.Operation.wait sched.operation tout in
    #<If> L.info "operation" ~s:(Printf.sprintf "%d event(s)" (Array.length ids)) #<End>;

    let errors = K.Operation.process_all sched.operation ids in
    let nb_errors = List.length errors in
    if nb_errors != 0 then begin
      #<If> L.info "operation" ~s:(Printf.sprintf "%d errors" nb_errors) #<End>;
      List.iter
        (fun id -> K.Operation.process_id_error sched.operation id Connection_closed)
        errors
    end;
  end

let is_empty sched =
  (K.Operation.is_empty sched.operation) && (K.Priority.is_empty sched.priority) &&
    (K.Compute.is_empty sched.compute) && (K.Finalise.is_empty sched.finalise)

let wait sched ~block=
  if not (is_empty sched) then
    begin
      incr_level sched;
      do_wait sched ~block;
      decr_level sched
    end;
  not (is_empty sched)

let flush ?(f = fun _ -> ()) sched =
  while not (is_empty sched) do
    #<If> L.info "flush" #<End>;
    incr_level sched;
    do_wait sched ~block:true;
    decr_level sched;
    f()
  done

let loop_until sched condition =
  while (not (condition ())) do
    if (is_empty sched) then
      raise Empty
    else begin
      #<If> L.info "loop_until" #<End>;
      incr_level sched;
      do_wait sched ~block:false;
      decr_level sched
    end
  done

let finalise sched f v = K.Finalise.add sched.finalise f v

(* ============================== *)
(* Misc *)
(* ============================== *)

(* This function is intended to be in Runtime when introduced *)
let invoke_on_exit _stats () =
  #<If:SERVER_STATS>
    Logger.log "Server statistics:\n%s" (NetStats.to_string _stats)
  #<End>

let empty_sched stats =
  {
    stats = stats;
    operation = K.Operation.make ();
    priority = K.Priority.make ();
    descriptor = K.Descriptor.make ();
    compute = K.Compute.make ();
    finalise = K.Finalise.make ();
    counter = K.Counter.make ();
    at_exit = Some(K.Compute.make ());
  }

(* at_exit handling *)
let do_at_exit_time_limit = 10.0 (* take at most N s for do_at_exit *)
let at_exit sched f =
  (* if we already have done the transfer *)
  let here = match sched.at_exit with
  | None -> sched.compute
  | Some(here) -> here
  in K.Compute.push here f

let do_at_exit sched time_limit =
  let log = Logger.debug "Processing Scheduler.at_exit %s" in
  match sched.at_exit with
  | None -> log "Warning: at_exit called twice"
  | Some(sched_at_exit) ->
    sched.at_exit <- None;
    if not(K.Compute.is_empty sched_at_exit) then (
      log (Printf.sprintf "(at most %1.2f seconds)" time_limit);
    (* NEED A REVIEW TO KNOWN WHY A EMTPY SCHEDULER HERE IS NOT WORKING
PROBABLY BECAUSE THE SCHEDULER IS A GLOBAL VALUE AT EVERY PLACE BUT HERE
=> every K.Truc must proposed an eraser and must be called here *)
      K.Compute.clear sched.compute;
      K.Compute.rev_transfer ~src:sched_at_exit ~dest:sched.compute;
      K.Priority.clear sched.priority;
      sched.operation <- K.Operation.make ();

      let time_limit = Unix.gettimeofday () +. time_limit in
      while not(is_empty sched) && (Unix.gettimeofday()<time_limit) do
        do_wait sched ~block:false;
      done;
      if not(is_empty sched)
      then log "stopped because too long"
      else log "finished"
    )
(* end at_exit handling *)


let make ?(is_server=false) () =
  #<If> L.info "make" #<End>;
  let _ = is_server in
  let stats = NetStats.make () in
  let sched = empty_sched stats in
  Pervasives.at_exit (invoke_on_exit stats);
  Pervasives.at_exit (fun () -> do_at_exit sched do_at_exit_time_limit(* time limited *));
  sched


let run sched =
  let rec aux () =
    try
      flush sched
    with
    | Failure "Interrupted system call" -> aux()
    | e -> E.print_exc (L.error "run") e; aux ()
  in
  aux ()

let default = make ~is_server:true ()

(* Print a more helpful message when encountering Unix errors *)
let _ =
  Printexc.register_printer
    (function
     | Unix.Unix_error (err,fct,param) ->
         Some (Printf.sprintf "System error: %s (at %s(%s))"
                 (Unix.error_message err) fct param)
     | _ -> None)
Something went wrong with that request. Please try again.