diff --git a/sledge/cli/domain_itv.ml b/sledge/cli/domain_itv.ml index fc31eb884..5bb89b956 100644 --- a/sledge/cli/domain_itv.ml +++ b/sledge/cli/domain_itv.ml @@ -47,7 +47,6 @@ let pp fs = in bindings >> Array.pp "@," (pp_pair Var.print Interval.print) fs -let report_fmt_thunk = Fun.flip pp let init _gs = Abstract1.top (Lazy.force man) (Environment.make [||] [||]) let apron_var_of_name = (fun nm -> "%" ^ nm) >> Apron.Var.of_string let apron_var_of_reg = Llair.Reg.name >> apron_var_of_name @@ -187,17 +186,22 @@ let exec_move move_vec q = let exec_inst i q = match (i : Llair.inst) with - | Move {reg_exps; loc= _} -> Some (exec_move reg_exps q) + | Move {reg_exps; loc= _} -> Ok (exec_move reg_exps q) | Store {ptr; exp; len= _; loc= _} -> ( match Llair.Reg.of_exp ptr with - | Some reg -> Some (assign reg exp q) - | None -> Some q ) - | Load {reg; ptr; len= _; loc= _} -> Some (assign reg ptr q) - | Nondet {reg= Some reg; msg= _; loc= _} -> Some (exec_kill reg q) - | Nondet {reg= None; msg= _; loc= _} | Alloc _ | Free _ -> Some q - | Abort _ -> None - | Intrinsic {reg= Some reg; _} -> Some (exec_kill reg q) - | Intrinsic {reg= None; _} -> Some q + | Some reg -> Ok (assign reg exp q) + | None -> Ok q ) + | Load {reg; ptr; len= _; loc= _} -> Ok (assign reg ptr q) + | Nondet {reg= Some reg; msg= _; loc= _} -> Ok (exec_kill reg q) + | Nondet {reg= None; msg= _; loc= _} | Alloc _ | Free _ -> Ok q + | Intrinsic {reg= Some reg; _} -> Ok (exec_kill reg q) + | Intrinsic {reg= None; _} -> Ok q + | Abort {loc} -> + Error + { Alarm.kind= Abort + ; loc + ; pp_action= Fun.flip Llair.Inst.pp i + ; pp_state= Fun.flip pp q } type from_call = {areturn: Llair.Reg.t option; caller_q: t} [@@deriving sexp_of] diff --git a/sledge/src/alarm.ml b/sledge/src/alarm.ml new file mode 100644 index 000000000..1e1f4d8d8 --- /dev/null +++ b/sledge/src/alarm.ml @@ -0,0 +1,25 @@ +(* + * Copyright (c) Facebook, Inc. and its affiliates. + * + * This source code is licensed under the MIT license found in the + * LICENSE file in the root directory of this source tree. + *) + +type kind = Abort | Invalid_memory_access + +let pp_kind fs = function + | Abort -> Format.fprintf fs "Abort" + | Invalid_memory_access -> Format.fprintf fs "Invalid memory access" + +type t = + { kind: kind + ; loc: Llair.Loc.t + ; pp_action: Format.formatter -> unit + ; pp_state: Format.formatter -> unit } + +let pp fs {kind; loc; pp_action} = + Format.fprintf fs "%a %a@;<1 2>@[%t@]" Llair.Loc.pp loc pp_kind kind + pp_action + +let pp_trace fs alarm = + Format.fprintf fs "%a@;<1 2>@[{ %t@ }@]" pp alarm alarm.pp_state diff --git a/sledge/src/alarm.mli b/sledge/src/alarm.mli new file mode 100644 index 000000000..b64e7cb17 --- /dev/null +++ b/sledge/src/alarm.mli @@ -0,0 +1,20 @@ +(* + * Copyright (c) Facebook, Inc. and its affiliates. + * + * This source code is licensed under the MIT license found in the + * LICENSE file in the root directory of this source tree. + *) + +type kind = Abort | Invalid_memory_access + +type t = + { kind: kind + ; loc: Llair.Loc.t + ; pp_action: Format.formatter -> unit + ; pp_state: Format.formatter -> unit } + +val pp : t pp +(** print an alarm for the user report *) + +val pp_trace : t pp +(** print an error for the debug trace *) diff --git a/sledge/src/control.ml b/sledge/src/control.ml index f02c48e9f..2e3f34db2 100644 --- a/sledge/src/control.ml +++ b/sledge/src/control.ml @@ -499,17 +499,11 @@ module Make (Opts : Domain_intf.Opts) (Dom : Domain_intf.Dom) = struct | Throw {exc} -> exec_throw stk state block exc | Unreachable -> Work.skip - let exec_inst : - Llair.block - -> Llair.inst - -> Dom.t - -> (Dom.t, Dom.t * Llair.inst) result = + let exec_inst : Llair.block -> Llair.inst -> Dom.t -> Dom.t Or_alarm.t = fun block inst state -> [%Trace.info "@\n@[%a@]@\n%a" Dom.pp state Llair.Inst.pp inst] ; Report.step_inst block inst ; Dom.exec_inst inst state - |> function - | Some state -> Result.Ok state | None -> Result.Error (state, inst) let exec_block : Llair.program -> Stack.t -> Dom.t -> Llair.block -> Work.x = @@ -528,8 +522,8 @@ module Make (Opts : Domain_intf.Opts) (Dom : Domain_intf.Dom) = struct state with | Ok state -> exec_term pgm stk state block - | Error (state, inst) -> - Report.invalid_access_inst (Dom.report_fmt_thunk state) inst ; + | Error alarm -> + Report.alarm alarm ; Work.skip let harness : Llair.program -> Work.t option = diff --git a/sledge/src/domain_intf.ml b/sledge/src/domain_intf.ml index 03b4de3c1..28eb833bc 100644 --- a/sledge/src/domain_intf.ml +++ b/sledge/src/domain_intf.ml @@ -10,14 +10,13 @@ module type Dom = sig type t [@@deriving compare, equal, sexp_of] val pp : t pp - val report_fmt_thunk : t -> Format.formatter -> unit val init : Llair.GlobalDefn.t iarray -> t val join : t -> t -> t option val dnf : t -> t list val exec_assume : t -> Llair.Exp.t -> t option val exec_kill : Llair.Reg.t -> t -> t val exec_move : (Llair.Reg.t * Llair.Exp.t) iarray -> t -> t - val exec_inst : Llair.inst -> t -> t option + val exec_inst : Llair.inst -> t -> t Or_alarm.t type from_call [@@deriving sexp_of] diff --git a/sledge/src/domain_relation.ml b/sledge/src/domain_relation.ml index dcde0dd50..aab6d660a 100644 --- a/sledge/src/domain_relation.ml +++ b/sledge/src/domain_relation.ml @@ -31,7 +31,6 @@ module Make (State_domain : State_domain_sig) = struct let pp fs (entry, curr) = Format.fprintf fs "@[%a%a@]" pp_entry entry State_domain.pp curr - let report_fmt_thunk (_, curr) fs = State_domain.pp fs curr let init globals = embed (State_domain.init globals) let join (entry_a, current_a) (entry_b, current_b) = @@ -51,6 +50,7 @@ module Make (State_domain : State_domain_sig) = struct (entry, State_domain.exec_move reg_exps current) let exec_inst inst (entry, current) = + let open Or_alarm.Import in let+ next = State_domain.exec_inst inst current in (entry, next) diff --git a/sledge/src/domain_sh.ml b/sledge/src/domain_sh.ml index 7fb38ed91..ac970b1e0 100644 --- a/sledge/src/domain_sh.ml +++ b/sledge/src/domain_sh.ml @@ -13,7 +13,6 @@ open Fol type t = Sh.t [@@deriving compare, equal, sexp] let pp fs q = Format.fprintf fs "@[{ %a@ }@]" Sh.pp q -let report_fmt_thunk = Fun.flip pp (* set by cli *) let simplify_states = ref true @@ -55,25 +54,37 @@ let exec_move res q = |> simplify let exec_inst inst pre = + let alarm kind = + { Alarm.kind + ; loc= Llair.Inst.loc inst + ; pp_action= Fun.flip Llair.Inst.pp inst + ; pp_state= Fun.flip pp pre } + in + let or_alarm = function + | Some post -> Ok post + | None -> Error (alarm Invalid_memory_access) + in ( match (inst : Llair.inst) with | Move {reg_exps; _} -> - Some + Ok (Exec.move pre (IArray.map reg_exps ~f:(fun (r, e) -> (X.reg r, X.term e)))) | Load {reg; ptr; len; _} -> Exec.load pre ~reg:(X.reg reg) ~ptr:(X.term ptr) ~len:(X.term len) + |> or_alarm | Store {ptr; exp; len; _} -> Exec.store pre ~ptr:(X.term ptr) ~exp:(X.term exp) ~len:(X.term len) + |> or_alarm | Alloc {reg; num; len; _} -> - Exec.alloc pre ~reg:(X.reg reg) ~num:(X.term num) ~len - | Free {ptr; _} -> Exec.free pre ~ptr:(X.term ptr) - | Nondet {reg; _} -> Some (Exec.nondet pre (Option.map ~f:X.reg reg)) - | Abort _ -> Exec.abort pre + Exec.alloc pre ~reg:(X.reg reg) ~num:(X.term num) ~len |> or_alarm + | Free {ptr; _} -> Exec.free pre ~ptr:(X.term ptr) |> or_alarm + | Nondet {reg; _} -> Ok (Exec.nondet pre (Option.map ~f:X.reg reg)) + | Abort _ -> Error (alarm Abort) | Intrinsic {reg; name; args; _} -> let areturn = Option.map ~f:X.reg reg in let actuals = IArray.map ~f:X.term args in - Exec.intrinsic pre areturn name actuals ) - |> Option.map ~f:simplify + Exec.intrinsic pre areturn name actuals |> or_alarm ) + |> Or_alarm.map ~f:simplify let value_determined_by ctx us a = List.exists (Context.class_of ctx a) ~f:(fun b -> diff --git a/sledge/src/domain_unit.ml b/sledge/src/domain_unit.ml index 36bb89895..48fbece28 100644 --- a/sledge/src/domain_unit.ml +++ b/sledge/src/domain_unit.ml @@ -10,13 +10,12 @@ type t = unit [@@deriving compare, equal, sexp] let pp fs () = Format.pp_print_string fs "()" -let report_fmt_thunk () fs = pp fs () let init _ = () let join () () = Some () let exec_assume () _ = Some () let exec_kill _ () = () let exec_move _ () = () -let exec_inst _ () = Some () +let exec_inst _ () = Ok () type from_call = unit [@@deriving compare, equal, sexp] diff --git a/sledge/src/domain_used_globals.ml b/sledge/src/domain_used_globals.ml index e50c63fce..72fcc9ac1 100644 --- a/sledge/src/domain_used_globals.ml +++ b/sledge/src/domain_used_globals.ml @@ -10,7 +10,6 @@ type t = Llair.Global.Set.t [@@deriving compare, equal, sexp] let pp = Llair.Global.Set.pp -let report_fmt_thunk = Fun.flip pp let empty = Llair.Global.Set.empty let init globals = @@ -39,10 +38,10 @@ let exec_move reg_exps st = let exec_inst inst st = [%Trace.call fun {pf} -> pf "@ pre:{%a} %a" pp st Llair.Inst.pp inst] ; - Some (Llair.Inst.fold_exps ~f:used_globals inst st) + Ok (Llair.Inst.fold_exps ~f:used_globals inst st) |> [%Trace.retn fun {pf} -> - Option.iter ~f:(fun uses -> pf "post:{%a}" pp uses)] + Or_alarm.iter ~f:(fun uses -> pf "post:{%a}" pp uses)] type from_call = t [@@deriving sexp] diff --git a/sledge/src/exec.ml b/sledge/src/exec.ml index 0ec8e0a8d..bca3ad7e8 100644 --- a/sledge/src/exec.ml +++ b/sledge/src/exec.ml @@ -737,7 +737,6 @@ let store pre ~ptr ~exp ~len = exec_spec pre (store_spec ptr exp len) let alloc pre ~reg ~num ~len = exec_spec pre (alloc_spec reg num len) let free pre ~ptr = exec_spec pre (free_spec ptr) let nondet pre = function Some reg -> kill pre reg | None -> pre -let abort _ = None let intrinsic : Sh.t diff --git a/sledge/src/exec.mli b/sledge/src/exec.mli index 00942a8b3..5541d162e 100644 --- a/sledge/src/exec.mli +++ b/sledge/src/exec.mli @@ -17,7 +17,6 @@ val store : Sh.t -> ptr:Term.t -> exp:Term.t -> len:Term.t -> Sh.t option val alloc : Sh.t -> reg:Var.t -> num:Term.t -> len:int -> Sh.t option val free : Sh.t -> ptr:Term.t -> Sh.t option val nondet : Sh.t -> Var.t option -> Sh.t -val abort : Sh.t -> Sh.t option val intrinsic : Sh.t -> Var.t option -> Llair.Intrinsic.t -> Term.t iarray -> Sh.t option diff --git a/sledge/src/or_alarm.ml b/sledge/src/or_alarm.ml new file mode 100644 index 000000000..6caae1470 --- /dev/null +++ b/sledge/src/or_alarm.ml @@ -0,0 +1,21 @@ +(* + * Copyright (c) Facebook, Inc. and its affiliates. + * + * This source code is licensed under the MIT license found in the + * LICENSE file in the root directory of this source tree. + *) + +module T = struct + type 'a t = ('a, Alarm.t) result +end + +include Stdlib.Result + +include Monad.Make (struct + include T + + let return = Result.ok + let bind = Result.bind +end) + +let iter x ~f = iter f x diff --git a/sledge/src/or_alarm.mli b/sledge/src/or_alarm.mli new file mode 100644 index 000000000..47733ffa0 --- /dev/null +++ b/sledge/src/or_alarm.mli @@ -0,0 +1,12 @@ +(* + * Copyright (c) Facebook, Inc. and its affiliates. + * + * This source code is licensed under the MIT license found in the + * LICENSE file in the root directory of this source tree. + *) + +type 'a t = ('a, Alarm.t) result + +include Monad.S with type 'a t := 'a t + +val iter : 'a t -> f:('a -> unit) -> unit diff --git a/sledge/src/report.ml b/sledge/src/report.ml index 90f0ced9e..00e231928 100644 --- a/sledge/src/report.ml +++ b/sledge/src/report.ml @@ -7,6 +7,14 @@ (** Issue reporting *) +let alarm_count = ref 0 + +let alarm alrm = + Int.incr alarm_count ; + Format.printf "@\n@[%a@]@." Alarm.pp alrm ; + [%Trace.printf "@\n@[%a@]@." Alarm.pp_trace alrm] ; + Stop.on_alarm () + let unknown_call call = [%Trace.kprintf Stop.on_unknown_call @@ -20,24 +28,6 @@ let unknown_call call = | _ -> () ) call Llair.Term.pp call] -let invalid_access_count = ref 0 - -let invalid_access fmt_thunk pp access loc = - Int.incr invalid_access_count ; - let rep fs = - Format.fprintf fs "%a Invalid memory access@;<1 2>@[%a@]" Llair.Loc.pp - (loc access) pp access - in - Format.printf "@\n@[%t@]@." rep ; - [%Trace.printf "@\n@[%t@;<1 2>@[{ %t@ }@]@]@." rep fmt_thunk] ; - Stop.on_invalid_access () - -let invalid_access_inst fmt_thunk inst = - invalid_access fmt_thunk Llair.Inst.pp inst Llair.Inst.loc - -let invalid_access_term fmt_thunk term = - invalid_access fmt_thunk Llair.Term.pp term Llair.Term.loc - (** Functional statistics *) let solver_steps = ref 0 @@ -95,8 +85,8 @@ let pp_status ppf stat = | UnknownError msg -> pf "Unknown error: %s" msg let safe_or_unsafe () = - if !invalid_access_count = 0 then Safe {bound= !bound} - else Unsafe {alarms= !invalid_access_count; bound= !bound} + if !alarm_count = 0 then Safe {bound= !bound} + else Unsafe {alarms= !alarm_count; bound= !bound} type gc_stats = {allocated: float; promoted: float; peak_size: float} [@@deriving sexp] diff --git a/sledge/src/report.mli b/sledge/src/report.mli index 7a23cc508..3a3bb4f12 100644 --- a/sledge/src/report.mli +++ b/sledge/src/report.mli @@ -13,8 +13,7 @@ val step_inst : Llair.block -> Llair.inst -> unit val step_term : Llair.block -> unit val hit_bound : int -> unit val unknown_call : Llair.term -> unit -val invalid_access_inst : (Format.formatter -> unit) -> Llair.inst -> unit -val invalid_access_term : (Format.formatter -> unit) -> Llair.term -> unit +val alarm : Alarm.t -> unit type status = | Safe of {bound: int} diff --git a/sledge/src/stop.ml b/sledge/src/stop.ml index db4f3377c..29794ad94 100644 --- a/sledge/src/stop.ml +++ b/sledge/src/stop.ml @@ -8,4 +8,4 @@ (** Stop analysis when encountering issues *) let on_unknown_call _ = [%Trace.kprintf (fun _ -> assert false) ""] -let on_invalid_access _ = [%Trace.kprintf (fun _ -> assert false) ""] +let on_alarm _ = [%Trace.kprintf (fun _ -> assert false) ""] diff --git a/sledge/src/stop.mli b/sledge/src/stop.mli index 6f9b4e6c6..d78875ed6 100644 --- a/sledge/src/stop.mli +++ b/sledge/src/stop.mli @@ -8,4 +8,4 @@ (** Stop analysis when encountering issues *) val on_unknown_call : 'a -> unit -val on_invalid_access : 'a -> unit +val on_alarm : 'a -> unit