@ -29,59 +29,60 @@ module CItvs = PrettyPrintable.MakePPMonoMap (AbstractValue) (CItv)
(* * A mash-up of several arithmetic domains. At the moment they are independent, i.e. we don't use
(* * A mash-up of several arithmetic domains. At the moment they are independent, i.e. we don't use
facts deduced by one domain to inform another . * )
facts deduced by one domain to inform another . * )
type t =
type t =
{ satisfiable : bool
{ is_un sat: bool
(* * If [ tru e] then [formula] could still be unsatisfiable ( asking that question is
(* * If [ fals e] then [formula] could still be unsatisfiable ( asking that question is
expensive ) .
expensive ) .
If [ fals e] then the other components of the record can be arbitrary . * )
If [ tru e] then the other components of the record can be arbitrary . * )
; bo_itvs : BoItvs . t
; bo_itvs : BoItvs . t
; citvs : CItvs . t
; citvs : CItvs . t
; formula : Formula . t }
; formula : Formula . t }
let pp fmt { satisfiable ; bo_itvs ; citvs ; formula } =
let pp fmt { is_un sat; bo_itvs ; citvs ; formula } =
F . fprintf fmt " @[<hv> sat:%b,@;bo: @[%a@],@;citv: @[%a@],@;formula: @[%a@]@]" satisfiable BoItvs . pp
F . fprintf fmt " @[<hv> un sat:%b,@;bo: @[%a@],@;citv: @[%a@],@;formula: @[%a@]@]" is_un sat BoItvs . pp
bo_itvs CItvs . pp citvs Formula . pp formula
bo_itvs CItvs . pp citvs Formula . pp formula
let true _ = { satisfiable= tru e; bo_itvs = BoItvs . empty ; citvs = CItvs . empty ; formula = Formula . ttrue }
let true _ = { is_unsat= fals e; bo_itvs = BoItvs . empty ; citvs = CItvs . empty ; formula = Formula . ttrue }
let false _ = { satisfiable= fals e; bo_itvs = BoItvs . empty ; citvs = CItvs . empty ; formula = Formula . ttrue }
let false _ = { is_unsat= tru e; bo_itvs = BoItvs . empty ; citvs = CItvs . empty ; formula = Formula . ttrue }
let and_nonnegative v ( { satisfiable ; bo_itvs ; citvs ; formula } as phi ) =
let and_nonnegative v ( { is_un sat; bo_itvs ; citvs ; formula } as phi ) =
if not satisfiable then phi
if is_u nsat then phi
else
else
{ satisfiable
{ is_un sat
; bo_itvs = BoItvs . add v Itv . ItvPure . nat bo_itvs
; bo_itvs = BoItvs . add v Itv . ItvPure . nat bo_itvs
; citvs = CItvs . add v CItv . zero_inf citvs
; citvs = CItvs . add v CItv . zero_inf citvs
; formula = Formula . ( aand ( mk_less_equal Term . zero ( Term . of_absval v ) ) formula ) }
; formula = Formula . ( aand ( mk_less_equal Term . zero ( Term . of_absval v ) ) formula ) }
let and_positive v ( { satisfiable ; bo_itvs ; citvs ; formula } as phi ) =
let and_positive v ( { is_un sat; bo_itvs ; citvs ; formula } as phi ) =
if not satisfiable then phi
if is_u nsat then phi
else
else
{ satisfiable
{ is_un sat
; bo_itvs = BoItvs . add v Itv . ItvPure . pos bo_itvs
; bo_itvs = BoItvs . add v Itv . ItvPure . pos bo_itvs
; citvs = CItvs . add v ( CItv . ge_to IntLit . one ) citvs
; citvs = CItvs . add v ( CItv . ge_to IntLit . one ) citvs
; formula = Formula . ( aand ( mk_less_than Term . zero ( Term . of_absval v ) ) formula ) }
; formula = Formula . ( aand ( mk_less_than Term . zero ( Term . of_absval v ) ) formula ) }
let and_eq_int v i ( { satisfiable ; bo_itvs ; citvs ; formula } as phi ) =
let and_eq_int v i ( { is_un sat; bo_itvs ; citvs ; formula } as phi ) =
if not satisfiable then phi
if is_u nsat then phi
else
else
{ satisfiable
{ is_un sat
; bo_itvs = BoItvs . add v ( Itv . ItvPure . of_int_lit i ) bo_itvs
; bo_itvs = BoItvs . add v ( Itv . ItvPure . of_int_lit i ) bo_itvs
; citvs = CItvs . add v ( CItv . equal_to i ) citvs
; citvs = CItvs . add v ( CItv . equal_to i ) citvs
; formula = Formula . ( aand ( mk_equal ( Term . of_absval v ) ( Term . of_intlit i ) ) formula ) }
; formula = Formula . ( aand ( mk_equal ( Term . of_absval v ) ( Term . of_intlit i ) ) formula ) }
let simplify ~ keep { satisfiable ; bo_itvs ; citvs ; formula } =
let simplify ~ keep { is_un sat; bo_itvs ; citvs ; formula } =
if not satisfiable then false _
if is_u nsat then false _
else
else
let is_in_keep v _ = AbstractValue . Set . mem v keep in
let is_in_keep v _ = AbstractValue . Set . mem v keep in
{ satisfiable
let formula = Formula . simplify ~ keep formula in
{ is_unsat = is_unsat | | Formula . is_literal_false formula
; bo_itvs = BoItvs . filter is_in_keep bo_itvs
; bo_itvs = BoItvs . filter is_in_keep bo_itvs
; citvs = CItvs . filter is_in_keep citvs
; citvs = CItvs . filter is_in_keep citvs
; formula = Formula . simplify ~ keep formula }
; formula }
let subst_find_or_new subst addr_callee =
let subst_find_or_new subst addr_callee =
@ -186,7 +187,7 @@ let and_formula_callee subst formula_caller formula_callee =
let and_callee subst phi ~ callee : phi_callee =
let and_callee subst phi ~ callee : phi_callee =
if ( not phi . satisfiable ) | | not phi_callee . satisfiable then ( subst , false _ )
if phi . is_unsat | | phi_callee . is_unsat then ( subst , false _ )
else
else
match and_bo_itvs_callee subst phi . bo_itvs phi_callee . bo_itvs with
match and_bo_itvs_callee subst phi . bo_itvs phi_callee . bo_itvs with
| exception Contradiction ->
| exception Contradiction ->
@ -201,9 +202,9 @@ let and_callee subst phi ~callee:phi_callee =
let subst , formula' = and_formula_callee subst phi . formula phi_callee . formula in
let subst , formula' = and_formula_callee subst phi . formula phi_callee . formula in
L . d_printfln " conjoined formula post call: %a@ \n " Formula . pp formula' ;
L . d_printfln " conjoined formula post call: %a@ \n " Formula . pp formula' ;
let formula' = Formula . normalize formula' in
let formula' = Formula . normalize formula' in
let satisfiable = not ( Formula . is_literal_false formula' ) in
let is_unsat = Formula . is_literal_false formula' in
if not satisfiable then L . d_printfln " contradiction found by formulas " ;
if is_u nsat then L . d_printfln " contradiction found by formulas " ;
( subst , { satisfiable ; bo_itvs = bo_itvs' ; citvs = citvs' ; formula = formula' } ) )
( subst , { is_un sat; bo_itvs = bo_itvs' ; citvs = citvs' ; formula = formula' } ) )
(* * {2 Operations} *)
(* * {2 Operations} *)
@ -254,10 +255,10 @@ let eval_formula_binop binop_addr binop op_lhs op_rhs formula =
aand ( mk_equal ( Term . of_absval binop_addr ) t_binop ) formula
aand ( mk_equal ( Term . of_absval binop_addr ) t_binop ) formula
let eval_binop binop_addr binop op_lhs op_rhs ( { satisfiable ; bo_itvs ; citvs ; formula } as phi ) =
let eval_binop binop_addr binop op_lhs op_rhs ( { is_un sat; bo_itvs ; citvs ; formula } as phi ) =
if not phi. satisfiable then phi
if phi. is_un sat then phi
else
else
{ satisfiable
{ is_un sat
; bo_itvs = eval_bo_itv_binop binop_addr binop op_lhs op_rhs bo_itvs
; bo_itvs = eval_bo_itv_binop binop_addr binop op_lhs op_rhs bo_itvs
; citvs = eval_citv_binop binop_addr binop op_lhs op_rhs citvs
; citvs = eval_citv_binop binop_addr binop op_lhs op_rhs citvs
; formula = eval_formula_binop binop_addr binop op_lhs op_rhs formula }
; formula = eval_formula_binop binop_addr binop op_lhs op_rhs formula }
@ -286,10 +287,10 @@ let eval_formula_unop unop_addr (unop : Unop.t) addr formula =
aand ( mk_equal ( Term . of_absval unop_addr ) t_unop ) formula
aand ( mk_equal ( Term . of_absval unop_addr ) t_unop ) formula
let eval_unop unop_addr unop addr ( { satisfiable ; bo_itvs ; citvs ; formula } as phi ) =
let eval_unop unop_addr unop addr ( { is_un sat; bo_itvs ; citvs ; formula } as phi ) =
if not phi. satisfiable then phi
if phi. is_un sat then phi
else
else
{ satisfiable
{ is_un sat
; bo_itvs = eval_bo_itv_unop unop_addr unop addr bo_itvs
; bo_itvs = eval_bo_itv_unop unop_addr unop addr bo_itvs
; citvs = eval_citv_unop unop_addr unop addr citvs
; citvs = eval_citv_unop unop_addr unop addr citvs
; formula = eval_formula_unop unop_addr unop addr formula }
; formula = eval_formula_unop unop_addr unop addr formula }
@ -304,7 +305,7 @@ let prune_bo_with_bop ~negated v_opt arith bop arith' phi =
| None ->
| None ->
phi
phi
| Some ( _ , Bottom ) ->
| Some ( _ , Bottom ) ->
{ phi with satisfiable= fals e}
{ phi with is_unsat= tru e}
| Some ( v , NonBottom arith_pruned ) ->
| Some ( v , NonBottom arith_pruned ) ->
{ phi with bo_itvs = BoItvs . add v arith_pruned phi . bo_itvs }
{ phi with bo_itvs = BoItvs . add v arith_pruned phi . bo_itvs }
@ -327,10 +328,10 @@ let record_citv_abduced addr_opt arith_opt citvs =
CItvs . add addr arith citvs
CItvs . add addr arith citvs
let bind_ satisfiable phi ~ f = if phi . satisfiable then f phi else phi
let bind_ is_un sat phi ~ f = if phi . is_unsat then phi else f phi
let prune_binop ~ negated bop lhs_op rhs_op ( { satisfiable ; bo_itvs = _ ; citvs ; formula } as phi ) =
let prune_binop ~ negated bop lhs_op rhs_op ( { is_un sat; bo_itvs = _ ; citvs ; formula } as phi ) =
if not satisfiable then phi
if is_u nsat then phi
else
else
let value_lhs_opt , arith_lhs_opt , bo_itv_lhs , t_lhs = eval_operand phi lhs_op in
let value_lhs_opt , arith_lhs_opt , bo_itv_lhs , t_lhs = eval_operand phi lhs_op in
let value_rhs_opt , arith_rhs_opt , bo_itv_rhs , t_rhs = eval_operand phi rhs_op in
let value_rhs_opt , arith_rhs_opt , bo_itv_rhs , t_rhs = eval_operand phi rhs_op in
@ -346,38 +347,38 @@ let prune_binop ~negated bop lhs_op rhs_op ({satisfiable; bo_itvs= _; citvs; for
in
in
{ phi with citvs }
{ phi with citvs }
in
in
let satisfiable =
let is_un sat =
match Itv . ItvPure . arith_binop bop bo_itv_lhs bo_itv_rhs | > Itv . ItvPure . to_boolean with
match Itv . ItvPure . arith_binop bop bo_itv_lhs bo_itv_rhs | > Itv . ItvPure . to_boolean with
| False ->
| False ->
negated
| True ->
not negated
not negated
| True ->
negated
| Top ->
| Top ->
true
| Bottom ->
false
false
| Bottom ->
true
in
in
if not satisfiable then L . d_printfln " contradiction detected by inferbo intervals " ;
if is_u nsat then L . d_printfln " contradiction detected by inferbo intervals " ;
let phi = { phi with satisfiable } in
let phi = { phi with is_un sat} in
let phi =
let phi =
bind_ satisfiable phi ~ f : ( fun phi ->
bind_ is_un sat phi ~ f : ( fun phi ->
prune_bo_with_bop ~ negated value_lhs_opt bo_itv_lhs bop bo_itv_rhs phi )
prune_bo_with_bop ~ negated value_lhs_opt bo_itv_lhs bop bo_itv_rhs phi )
in
in
let phi =
let phi =
Option . value_map ( Binop . symmetric bop ) ~ default : phi ~ f : ( fun bop' ->
Option . value_map ( Binop . symmetric bop ) ~ default : phi ~ f : ( fun bop' ->
bind_ satisfiable phi ~ f : ( fun phi ->
bind_ is_un sat phi ~ f : ( fun phi ->
prune_bo_with_bop ~ negated value_rhs_opt bo_itv_rhs bop' bo_itv_lhs phi ) )
prune_bo_with_bop ~ negated value_rhs_opt bo_itv_rhs bop' bo_itv_lhs phi ) )
in
in
if not phi. satisfiable then phi
if phi. is_un sat then phi
else
else
let f_positive = Formula . of_term_binop bop t_lhs t_rhs in
let f_positive = Formula . of_term_binop bop t_lhs t_rhs in
let formula =
let formula =
let f = if negated then Formula . nnot f_positive else f_positive in
let f = if negated then Formula . nnot f_positive else f_positive in
Formula . aand f formula | > Formula . normalize
Formula . aand f formula | > Formula . normalize
in
in
let satisfiable = not ( Formula . is_literal_false formula ) in
let is_unsat = Formula . is_literal_false formula in
if not satisfiable then L . d_printfln " contradiction detected by formulas " ;
if is_u nsat then L . d_printfln " contradiction detected by formulas " ;
{ phi with satisfiable ; formula }
{ phi with is_un sat; formula }
(* * {2 Queries} *)
(* * {2 Queries} *)
@ -388,9 +389,14 @@ let is_known_zero phi v =
| | BoItvs . find_opt v phi . bo_itvs | > Option . value_map ~ default : false ~ f : Itv . ItvPure . is_zero
| | BoItvs . find_opt v phi . bo_itvs | > Option . value_map ~ default : false ~ f : Itv . ItvPure . is_zero
let is_unsat_cheap phi = ( not phi . satisfiable ) | | Formula . is_literal_false phi . formula
let is_unsat_cheap phi = phi . is_unsat | | Formula . is_literal_false phi . formula
let is_unsat_expensive phi =
let is_unsat_expensive phi =
(* note: contradictions are detected eagerly for all sub-domains except formula, so just
(* note: contradictions are detected eagerly for all sub-domains except formula, so just
evaluate that one * )
evaluate that one * )
is_unsat_cheap phi | | Formula . normalize phi . formula | > Formula . is_literal_false
if is_unsat_cheap phi then ( phi , true )
else
let formula = Formula . normalize phi . formula in
let is_unsat = Formula . is_literal_false formula in
let phi = { phi with is_unsat ; formula } in
( phi , is_unsat )