infer_clone/infer/src/base/SymOp.ml

(*
 * Copyright (c) 2009 - 2013 Monoidics ltd.
 * Copyright (c) 2013 - present Facebook, Inc.
 * All rights reserved.
 *
 * This source code is licensed under the BSD style license found in the
 * LICENSE file in the root directory of this source tree. An additional grant
 * of patent rights can be found in the PATENTS file in the same directory.
 *)

(** Symbolic Operations and Failures: the units in which analysis work is measured *)

open! IStd

module F = Format


type failure_kind =
  | FKtimeout (** max time exceeded *)
  | FKsymops_timeout of int (** max symop's exceeded *)
  | FKrecursion_timeout of int (** max recursion level exceeded *)
  | FKcrash of string (** uncaught exception or failed assertion *)

(** failure that prevented analysis from finishing *)
exception Analysis_failure_exe of failure_kind

let exn_not_failure = function
  | Analysis_failure_exe _ -> false
  | _ -> true

let try_finally ?(fail_early=false) f g =
  match f () with
  | r ->
      g () ;
      r
  | exception (Analysis_failure_exe _ as f_exn) ->
      if not fail_early then
        (try g () with _ -> ());
      raise f_exn
  | exception f_exn ->
      match g () with
      | () ->
          raise f_exn
      | exception (Analysis_failure_exe _ as g_exn) ->
          raise g_exn
      | exception _ ->
          raise f_exn

let finally_try g f = try_finally f g

let pp_failure_kind fmt = function
  | FKtimeout -> F.fprintf fmt "TIMEOUT"
  | FKsymops_timeout symops -> F.fprintf fmt "SYMOPS TIMEOUT (%d)" symops
  | FKrecursion_timeout level -> F.fprintf fmt "RECURSION TIMEOUT(%d)" level
  | FKcrash msg -> F.fprintf fmt "CRASH (%s)" msg


(** Count the number of symbolic operations *)

(** Timeout in seconds for each function *)
let timeout_seconds =
  ref
    (Option.map Config.seconds_per_iteration
       ~f:(fun sec -> sec *. (float_of_int Config.iterations)))

(** Timeout in SymOps *)
let timeout_symops =
  ref (Option.map Config.symops_per_iteration ~f:(fun symops -> symops * Config.iterations))

let get_timeout_seconds () = !timeout_seconds

(** Internal state of the module *)
type t =
  {
    mutable alarm_active : bool;
    (** Only throw timeout exception when alarm is active *)

    mutable last_wallclock : float option;
    (** last wallclock set by an alarm, if any *)

    mutable symop_count : int;
    (** Number of symop's *)

    symop_total : int ref;
    (** Counter for the total number of symop's.
        The new state created when save_state is called shares this counter
        if keep_symop_total is true. Otherwise, a new counter is created. *)
  }

let initial () : t =
  {
    alarm_active = false;
    last_wallclock = None;
    symop_count = 0;
    symop_total = ref 0;
  }

(** Global State *)
let gs : t ref = ref (initial ())

(** Restore the old state. *)
let restore_state state =
  gs := state

(** Return the old state, and revert the current state to the initial one.
    If keep_symop_total is true, share the total counter. *)
let save_state ~keep_symop_total =
  let old_state = !gs in
  let new_state =
    let st = initial () in
    if keep_symop_total
    then
      { st with symop_total = old_state.symop_total }
    else
      st in
  gs := new_state;
  old_state

(** handler for the wallclock timeout *)
let wallclock_timeout_handler = ref None

(** set the handler for the wallclock timeout *)
let set_wallclock_timeout_handler handler =
  wallclock_timeout_handler := Some handler

(** Set the wallclock alarm checked at every pay() *)
let set_wallclock_alarm nsecs =
  !gs.last_wallclock <- Some (Unix.gettimeofday () +. nsecs)

(** Unset the wallclock alarm checked at every pay() *)
let unset_wallclock_alarm () =
  !gs.last_wallclock <- None

(** if the wallclock alarm has expired, raise a timeout exception *)
let check_wallclock_alarm () =
  match !gs.last_wallclock, !wallclock_timeout_handler with
  | Some alarm_time, Some handler when Unix.gettimeofday () >= alarm_time ->
      unset_wallclock_alarm ();
      handler ()
  | _ -> ()

(** Return the time remaining before the wallclock alarm expires *)
let get_remaining_wallclock_time () =
  match !gs.last_wallclock with
  | Some alarm_time ->
      max 0.0 (alarm_time -. Unix.gettimeofday ())
  | None ->
      0.0

(** Return the total number of symop's since the beginning *)
let get_total () =
  !(!gs.symop_total)

(** Reset the total number of symop's *)
let reset_total () =
  !gs.symop_total := 0

(** Count one symop *)
let pay () =
  !gs.symop_count <- !gs.symop_count + 1;
  !gs.symop_total := !(!gs.symop_total) + 1;
  (match !timeout_symops with
   | Some symops when !gs.symop_count > symops && !gs.alarm_active ->
       raise (Analysis_failure_exe (FKsymops_timeout !gs.symop_count))
   | _ -> ()
  );
  check_wallclock_alarm ()

(** Reset the counter *)
let reset_count () =
  !gs.symop_count <- 0

(** Reset the counter and activate the alarm *)
let set_alarm () =
  reset_count ();
  !gs.alarm_active <- true

(** De-activate the alarm *)
let unset_alarm () =
  !gs.alarm_active <- false