@ -6,32 +6,46 @@
 
			
		
	
		
			
				
					 * ) 
 
			
		
	
		
			
				
					
 
			
		
	
		
			
				
					open !  IStd  
			
		
	
		
			
				
					module  L  =  Logging  
			
		
	
		
			
				
					open  PulseBasicInterface  
			
		
	
		
			
				
					open  PulseDomainInterface  
			
		
	
		
			
				
					
 
			
		
	
		
			
				
					(* *  {2 Building arithmetic constraints}  *)  
			
		
	
		
			
				
					
 
			
		
	
		
			
				
					let  and_eq_terms  t1  t2  astate  =  
			
		
	
		
			
				
					  let  phi  =  PathCondition . and_eq  t1  t2  ( AbductiveDomain . get_path_condition  astate )  in 
 
			
		
	
		
			
				
					  AbductiveDomain . set_path_condition  phi  astate 
 
			
		
	
		
			
				
					
 
			
		
	
		
			
				
					
 
			
		
	
		
			
				
					let  and_term  t  astate  =  
			
		
	
		
			
				
					  let  phi  =  PathCondition . and_term  t  ( AbductiveDomain . get_path_condition  astate )  in 
 
			
		
	
		
			
				
					  AbductiveDomain . set_path_condition  phi  astate 
 
			
		
	
		
			
				
					
 
			
		
	
		
			
				
					
 
			
		
	
		
			
				
					let  and_nonnegative  trace  v  astate  =  
			
		
	
		
			
				
					  AddressAttributes . add_one  v  ( BoItv  Itv . ItvPure . nat )  astate 
 
			
		
	
		
			
				
					  | >  AddressAttributes . add_one  v  ( CItv  ( CItv . zero_inf ,  trace ) ) 
 
			
		
	
		
			
				
					  | >  and_term  PathCondition . Term . ( le  zero  ( of_absval  v ) ) 
 
			
		
	
		
			
				
					
 
			
		
	
		
			
				
					
 
			
		
	
		
			
				
					let  and_positive  trace  v  astate  =  
			
		
	
		
			
				
					  AddressAttributes . add_one  v  ( BoItv  Itv . ItvPure . pos )  astate 
 
			
		
	
		
			
				
					  | >  AddressAttributes . add_one  v  ( CItv  ( CItv . ge_to  IntLit . one ,  trace ) ) 
 
			
		
	
		
			
				
					  | >  and_term  PathCondition . Term . ( lt  zero  ( of_absval  v ) ) 
 
			
		
	
		
			
				
					
 
			
		
	
		
			
				
					
 
			
		
	
		
			
				
					let  and_eq_int  trace  v  i  astate  =  
			
		
	
		
			
				
					  AddressAttributes . add_one  v  ( BoItv  ( Itv . ItvPure . of_int_lit  i ) )  astate 
 
			
		
	
		
			
				
					  | >  AddressAttributes . add_one  v  ( CItv  ( CItv . equal_to  i ,  trace ) ) 
 
			
		
	
		
			
				
					  | >  and_eq_terms  ( PathCondition . Term . of_absval  v )  ( PathCondition . Term . of_intlit  i ) 
 
			
		
	
		
			
				
					
 
			
		
	
		
			
				
					
 
			
		
	
		
			
				
					(* *  {2 Operations}  *)  
			
		
	
		
			
				
					
 
			
		
	
		
			
				
					type  operand  =  LiteralOperand  of  IntLit . t  |  AbstractValueOperand  of  AbstractValue . t  
			
		
	
		
			
				
					
 
			
		
	
		
			
				
					let  eval_ arith _operand location  binop_addr  binop_hist  bop  op_lhs  op_rhs  astate  =  
			
		
	
		
			
				
					  let  arith _of_op op  astate  = 
 
			
		
	
		
			
				
					let  eval_ citv _operand location  binop_addr  binop_hist  bop  op_lhs  op_rhs  astate  =  
			
		
	
		
			
				
					  let  citv _of_op op  astate  = 
 
			
		
	
		
			
				
					    match  op  with 
 
			
		
	
		
			
				
					    |  LiteralOperand  i  -> 
 
			
		
	
		
			
				
					        Some  ( CItv . equal_to  i ) 
 
			
		
	
	
		
			
				
					
						
						
						
							
								 
						
					 
				
				@ -39,7 +53,7 @@ let eval_arith_operand location binop_addr binop_hist bop op_lhs op_rhs astate =
 
			
		
	
		
			
				
					        AddressAttributes . get_citv  v  astate  | >  Option . map  ~ f : fst 
 
			
		
	
		
			
				
					  in 
 
			
		
	
		
			
				
					  match 
 
			
		
	
		
			
				
					    Option . both  ( arith_of_op op_lhs  astate )  ( arith  _of_op op_rhs  astate ) 
 
			
		
	
		
			
				
					    Option . both  ( citv_of_op op_lhs  astate )  ( citv  _of_op op_rhs  astate ) 
 
			
		
	
		
			
				
					    | >  Option . bind  ~ f : ( fun  ( addr_lhs ,  addr_rhs )  ->  CItv . binop  bop  addr_lhs  addr_rhs ) 
 
			
		
	
		
			
				
					  with 
 
			
		
	
		
			
				
					  |  None  -> 
 
			
		
	
	
		
			
				
					
						
						
						
							
								 
						
					 
				
				@ -64,16 +78,30 @@ let eval_bo_itv_binop binop_addr bop op_lhs op_rhs astate =
 
			
		
	
		
			
				
					  AddressAttributes . add_one  binop_addr  ( BoItv  bo_itv )  astate 
 
			
		
	
		
			
				
					
 
			
		
	
		
			
				
					
 
			
		
	
		
			
				
					let  eval_path_condition_binop  binop_addr  binop  op_lhs  op_rhs  astate  =  
			
		
	
		
			
				
					  let  term_of_op  =  function 
 
			
		
	
		
			
				
					    |  LiteralOperand  i  -> 
 
			
		
	
		
			
				
					        PathCondition . Term . of_intlit  i 
 
			
		
	
		
			
				
					    |  AbstractValueOperand  v  -> 
 
			
		
	
		
			
				
					        PathCondition . Term . of_absval  v 
 
			
		
	
		
			
				
					  in 
 
			
		
	
		
			
				
					  and_eq_terms 
 
			
		
	
		
			
				
					    ( PathCondition . Term . of_absval  binop_addr ) 
 
			
		
	
		
			
				
					    ( PathCondition . Term . of_binop  binop  ( term_of_op  op_lhs )  ( term_of_op  op_rhs ) ) 
 
			
		
	
		
			
				
					    astate 
 
			
		
	
		
			
				
					
 
			
		
	
		
			
				
					
 
			
		
	
		
			
				
					let  eval_binop  location  binop  op_lhs  op_rhs  binop_hist  astate  =  
			
		
	
		
			
				
					  let  binop_addr  =  AbstractValue . mk_fresh  ()  in 
 
			
		
	
		
			
				
					  let  astate  = 
 
			
		
	
		
			
				
					    eval_arith_operand  location  binop_addr  binop_hist  binop  op_lhs  op_rhs  astate 
 
			
		
	
		
			
				
					    eval_path_condition_binop  binop_addr  binop  op_lhs  op_rhs  astate 
 
			
		
	
		
			
				
					    | >  eval_citv_operand  location  binop_addr  binop_hist  binop  op_lhs  op_rhs 
 
			
		
	
		
			
				
					    | >  eval_bo_itv_binop  binop_addr  binop  op_lhs  op_rhs 
 
			
		
	
		
			
				
					  in 
 
			
		
	
		
			
				
					  ( astate ,  ( binop_addr ,  binop_hist ) ) 
 
			
		
	
		
			
				
					
 
			
		
	
		
			
				
					
 
			
		
	
		
			
				
					let  eval_unop_arith  location  unop_addr  unop  operand_addr  unop_hist  astate  =  
			
		
	
		
			
				
					let  eval_unop_ citv  location  unop_addr  unop  operand_addr  unop_hist  astate  =  
			
		
	
		
			
				
					  match 
 
			
		
	
		
			
				
					    AddressAttributes . get_citv  operand_addr  astate 
 
			
		
	
		
			
				
					    | >  Option . bind  ~ f : ( function  a ,  _  ->  CItv . unop  unop  a ) 
 
			
		
	
	
		
			
				
					
						
						
						
							
								 
						
					 
				
				@ -93,10 +121,18 @@ let eval_unop_bo_itv unop_addr unop operand_addr astate =
 
			
		
	
		
			
				
					      AddressAttributes . add_one  unop_addr  ( BoItv  itv )  astate 
 
			
		
	
		
			
				
					
 
			
		
	
		
			
				
					
 
			
		
	
		
			
				
					let  eval_path_condition_unop  unop_addr  unop  addr  astate  =  
			
		
	
		
			
				
					  and_eq_terms 
 
			
		
	
		
			
				
					    ( PathCondition . Term . of_absval  unop_addr ) 
 
			
		
	
		
			
				
					    PathCondition . Term . ( of_unop  unop  ( of_absval  addr ) ) 
 
			
		
	
		
			
				
					    astate 
 
			
		
	
		
			
				
					
 
			
		
	
		
			
				
					
 
			
		
	
		
			
				
					let  eval_unop  location  unop  addr  unop_hist  astate  =  
			
		
	
		
			
				
					  let  unop_addr  =  AbstractValue . mk_fresh  ()  in 
 
			
		
	
		
			
				
					  let  astate  = 
 
			
		
	
		
			
				
					    eval_unop_arith  location  unop_addr  unop  addr  unop_hist  astate 
 
			
		
	
		
			
				
					    eval_path_condition_unop  unop_addr  unop  addr  astate 
 
			
		
	
		
			
				
					    | >  eval_unop_citv  location  unop_addr  unop  addr  unop_hist 
 
			
		
	
		
			
				
					    | >  eval_unop_bo_itv  unop_addr  unop  addr 
 
			
		
	
		
			
				
					  in 
 
			
		
	
		
			
				
					  ( astate ,  ( unop_addr ,  unop_hist ) ) 
 
			
		
	
	
		
			
				
					
						
							
								 
						
						
							
								 
						
						
					 
				
				@ -126,9 +162,13 @@ let eval_operand location astate = function
 
			
		
	
		
			
				
					      (  None 
 
			
		
	
		
			
				
					      ,  Some 
 
			
		
	
		
			
				
					          ( CItv . equal_to  i ,  Trace . Immediate  { location ;  history =  [ ValueHistory . Assignment  location ] } ) 
 
			
		
	
		
			
				
					      ,  Itv . ItvPure . of_int_lit  i  ) 
 
			
		
	
		
			
				
					      ,  Itv . ItvPure . of_int_lit  i 
 
			
		
	
		
			
				
					      ,  PathCondition . Term . of_intlit  i  ) 
 
			
		
	
		
			
				
					  |  AbstractValueOperand  v  -> 
 
			
		
	
		
			
				
					      ( Some  v ,  AddressAttributes . get_citv  v  astate ,  AddressAttributes . get_bo_itv  v  astate ) 
 
			
		
	
		
			
				
					      (  Some  v 
 
			
		
	
		
			
				
					      ,  AddressAttributes . get_citv  v  astate 
 
			
		
	
		
			
				
					      ,  AddressAttributes . get_bo_itv  v  astate 
 
			
		
	
		
			
				
					      ,  PathCondition . Term . of_absval  v  ) 
 
			
		
	
		
			
				
					
 
			
		
	
		
			
				
					
 
			
		
	
		
			
				
					let  record_abduced  event  location  addr_opt  orig_arith_hist_opt  arith_opt  astate  =  
			
		
	
	
		
			
				
					
						
						
						
							
								 
						
					 
				
				@ -151,38 +191,55 @@ let record_abduced event location addr_opt orig_arith_hist_opt arith_opt astate
 
			
		
	
		
			
				
					let  bind_satisfiable  ~ satisfiable  astate  ~ f  =  if  satisfiable  then  f  astate  else  ( astate ,  false )  
			
		
	
		
			
				
					
 
			
		
	
		
			
				
					let  prune_binop  ~ is_then_branch  if_kind  location  ~ negated  bop  lhs_op  rhs_op  astate  =  
			
		
	
		
			
				
					  let  value_lhs_opt ,  arith_lhs_opt ,  bo_itv_lhs  =  eval_operand  location  astate  lhs_op  in 
 
			
		
	
		
			
				
					  let  value_rhs_opt ,  arith_rhs_opt ,  bo_itv_rhs  =  eval_operand  location  astate  rhs_op  in 
 
			
		
	
		
			
				
					  match 
 
			
		
	
		
			
				
					    CItv . abduce_binop_is_true  ~ negated  bop  ( Option . map  ~ f : fst  arith_lhs_opt ) 
 
			
		
	
		
			
				
					      ( Option . map  ~ f : fst  arith_rhs_opt ) 
 
			
		
	
		
			
				
					  with 
 
			
		
	
		
			
				
					  |  Unsatisfiable  -> 
 
			
		
	
		
			
				
					      ( astate ,  false ) 
 
			
		
	
		
			
				
					  |  Satisfiable  ( abduced_lhs ,  abduced_rhs )  -> 
 
			
		
	
		
			
				
					      let  event  =  ValueHistory . Conditional  { is_then_branch ;  if_kind ;  location }  in 
 
			
		
	
		
			
				
					      let  astate  = 
 
			
		
	
		
			
				
					        record_abduced  event  location  value_lhs_opt  arith_lhs_opt  abduced_lhs  astate 
 
			
		
	
		
			
				
					        | >  record_abduced  event  location  value_rhs_opt  arith_rhs_opt  abduced_rhs 
 
			
		
	
		
			
				
					      in 
 
			
		
	
		
			
				
					      let  satisfiable  = 
 
			
		
	
		
			
				
					        match  Itv . ItvPure . arith_binop  bop  bo_itv_lhs  bo_itv_rhs  | >  Itv . ItvPure . to_boolean  with 
 
			
		
	
		
			
				
					        |  False  -> 
 
			
		
	
		
			
				
					            negated 
 
			
		
	
		
			
				
					        |  True  -> 
 
			
		
	
		
			
				
					            not  negated 
 
			
		
	
		
			
				
					        |  Top  -> 
 
			
		
	
		
			
				
					            true 
 
			
		
	
		
			
				
					        |  Bottom  -> 
 
			
		
	
		
			
				
					            false 
 
			
		
	
		
			
				
					      in 
 
			
		
	
		
			
				
					      let  astate ,  satisfiable  = 
 
			
		
	
		
			
				
					        bind_satisfiable  ~ satisfiable  astate  ~ f : ( fun  astate  -> 
 
			
		
	
		
			
				
					            prune_with_bop  ~ negated  value_lhs_opt  bo_itv_lhs  bop  bo_itv_rhs  astate  ) 
 
			
		
	
		
			
				
					      in 
 
			
		
	
		
			
				
					      Option . value_map  ( Binop . symmetric  bop )  ~ default : ( astate ,  satisfiable )  ~ f : ( fun  bop'  -> 
 
			
		
	
		
			
				
					  let  value_lhs_opt ,  arith_lhs_opt ,  bo_itv_lhs ,  path_cond_lhs  = 
 
			
		
	
		
			
				
					    eval_operand  location  astate  lhs_op 
 
			
		
	
		
			
				
					  in 
 
			
		
	
		
			
				
					  let  value_rhs_opt ,  arith_rhs_opt ,  bo_itv_rhs ,  path_cond_rhs  = 
 
			
		
	
		
			
				
					    eval_operand  location  astate  rhs_op 
 
			
		
	
		
			
				
					  in 
 
			
		
	
		
			
				
					  let  astate ,  path_condition  = 
 
			
		
	
		
			
				
					    let  path_condition  = 
 
			
		
	
		
			
				
					      let  t_positive  =  PathCondition . Term . of_binop  bop  path_cond_lhs  path_cond_rhs  in 
 
			
		
	
		
			
				
					      let  t  =  if  negated  then  PathCondition . Term . not_  t_positive  else  t_positive  in 
 
			
		
	
		
			
				
					      AbductiveDomain . get_path_condition  astate  | >  PathCondition . and_term  t 
 
			
		
	
		
			
				
					    in 
 
			
		
	
		
			
				
					    let  astate  =  AbductiveDomain . set_path_condition  path_condition  astate  in 
 
			
		
	
		
			
				
					    ( astate ,  path_condition ) 
 
			
		
	
		
			
				
					  in 
 
			
		
	
		
			
				
					  if  PathCondition . is_unsat  path_condition  then  ( 
 
			
		
	
		
			
				
					    L . d_printfln  " Contradiction detected in path condition "  ; 
 
			
		
	
		
			
				
					    ( astate ,  false )  ) 
 
			
		
	
		
			
				
					  else 
 
			
		
	
		
			
				
					    match 
 
			
		
	
		
			
				
					      CItv . abduce_binop_is_true  ~ negated  bop  ( Option . map  ~ f : fst  arith_lhs_opt ) 
 
			
		
	
		
			
				
					        ( Option . map  ~ f : fst  arith_rhs_opt ) 
 
			
		
	
		
			
				
					    with 
 
			
		
	
		
			
				
					    |  Unsatisfiable  -> 
 
			
		
	
		
			
				
					        ( astate ,  false ) 
 
			
		
	
		
			
				
					    |  Satisfiable  ( abduced_lhs ,  abduced_rhs )  -> 
 
			
		
	
		
			
				
					        let  event  =  ValueHistory . Conditional  { is_then_branch ;  if_kind ;  location }  in 
 
			
		
	
		
			
				
					        let  astate  = 
 
			
		
	
		
			
				
					          record_abduced  event  location  value_lhs_opt  arith_lhs_opt  abduced_lhs  astate 
 
			
		
	
		
			
				
					          | >  record_abduced  event  location  value_rhs_opt  arith_rhs_opt  abduced_rhs 
 
			
		
	
		
			
				
					        in 
 
			
		
	
		
			
				
					        let  satisfiable  = 
 
			
		
	
		
			
				
					          match  Itv . ItvPure . arith_binop  bop  bo_itv_lhs  bo_itv_rhs  | >  Itv . ItvPure . to_boolean  with 
 
			
		
	
		
			
				
					          |  False  -> 
 
			
		
	
		
			
				
					              negated 
 
			
		
	
		
			
				
					          |  True  -> 
 
			
		
	
		
			
				
					              not  negated 
 
			
		
	
		
			
				
					          |  Top  -> 
 
			
		
	
		
			
				
					              true 
 
			
		
	
		
			
				
					          |  Bottom  -> 
 
			
		
	
		
			
				
					              false 
 
			
		
	
		
			
				
					        in 
 
			
		
	
		
			
				
					        let  astate ,  satisfiable  = 
 
			
		
	
		
			
				
					          bind_satisfiable  ~ satisfiable  astate  ~ f : ( fun  astate  -> 
 
			
		
	
		
			
				
					              prune_with_bop  ~ negated  value_rhs_opt  bo_itv_rhs  bop'  bo_itv_lhs  astate  )  ) 
 
			
		
	
		
			
				
					              prune_with_bop  ~ negated  value_lhs_opt  bo_itv_lhs  bop  bo_itv_rhs  astate  ) 
 
			
		
	
		
			
				
					        in 
 
			
		
	
		
			
				
					        Option . value_map  ( Binop . symmetric  bop )  ~ default : ( astate ,  satisfiable )  ~ f : ( fun  bop'  -> 
 
			
		
	
		
			
				
					            bind_satisfiable  ~ satisfiable  astate  ~ f : ( fun  astate  -> 
 
			
		
	
		
			
				
					                prune_with_bop  ~ negated  value_rhs_opt  bo_itv_rhs  bop'  bo_itv_lhs  astate  )  ) 
 
			
		
	
		
			
				
					
 
			
		
	
		
			
				
					
 
			
		
	
		
			
				
					(* *  {2 Queries}  *)  
			
		
	
	
		
			
				
					
						
						
						
							
								 
						
					 
				
				@ -190,4 +247,6 @@ let prune_binop ~is_then_branch if_kind location ~negated bop lhs_op rhs_op asta
 
			
		
	
		
			
				
					let  is_known_zero  astate  v  =  
			
		
	
		
			
				
					  (  AddressAttributes . get_citv  v  astate 
 
			
		
	
		
			
				
					  | >  function  Some  ( arith ,  _ )  ->  CItv . is_equal_to_zero  arith  |  None  ->  false  ) 
 
			
		
	
		
			
				
					  | |  ( let  phi  =  AbductiveDomain . get_path_condition  astate  in 
 
			
		
	
		
			
				
					      PathCondition . is_known_zero  ( PathCondition . Term . of_absval  v )  phi  ) 
 
			
		
	
		
			
				
					  | |  Itv . ItvPure . is_zero  ( AddressAttributes . get_bo_itv  v  astate )