Revision 4cec0e67
src/mutation.ml  

17  17 
let int_consts = ref [] 
18  18  
19  19 
(************************************************************************************) 
20 
(* Gathering constants in the code *) 

21 
(************************************************************************************) 

20  22  
23 
module IntSet = Set.Make (struct type t = int let compare = compare end) 

24 
module OpCount = Map.Make (struct type t = string let compare = compare end) 

21  25  
26 
type records = { 

27 
consts: IntSet.t; 

28 
nb_boolexpr: int; 

29 
nb_pre: int; 

30 
nb_op: int OpCount.t; 

31 
} 

22  32  
23 
let mutate_pre orig_expr e = 

24 
if Random.int 100 <= threshold_delay then 

25 
(* We do not nothing *) 

26 
Expr_pre e 

27 
else (* We add a pre *) 

28 
Expr_pre ({orig_expr with expr_desc = Expr_pre e}) 

33 
let empty_records = 

34 
{consts=IntSet.empty; nb_boolexpr=0; nb_pre=0; nb_op=OpCount.empty} 

29  35  
36 
let records = ref empty_records 

30  37  
31 
let get_int_consts_const_value c =


32 
match c with


33 
 Const_int i > [i]


34 
 _ > []


38 
let merge_records records_list =


39 
let merge_record r1 r2 =


40 
{


41 
consts = IntSet.union r1.consts r2.consts;


35  42  
36 
let get_int_consts_const c = get_int_consts_const_value c.const_value 

43 
nb_boolexpr = r1.nb_boolexpr + r2.nb_boolexpr; 

44 
nb_pre = r1.nb_pre + r2.nb_pre; 

37  45  
38 
let rec get_int_consts_expr expr = 

39 
match expr.expr_desc with 

40 
 Expr_const c > get_int_consts_const_value c 

41 
 Expr_tuple l > List.flatten (List.map get_int_consts_expr l) 

42 
 Expr_ite (i,t,e) > get_int_consts_expr i @ get_int_consts_expr e @ get_int_consts_expr t 

43 
 Expr_arrow (e1, e2) > get_int_consts_expr e1 @ get_int_consts_expr e2 

44 
 Expr_pre e > get_int_consts_expr e 

45 
 Expr_appl (op_id, args, r) > get_int_consts_expr args 

46 
 _ > [] 

46 
nb_op = OpCount.merge (fun op r1opt r2opt > 

47 
match r1opt, r2opt with 

48 
 None, _ > r2opt 

49 
 _, None > r1opt 

50 
 Some x, Some y > Some (x+y) 

51 
) r1.nb_op r2.nb_op 

52 
} 

53 
in 

54 
List.fold_left merge_record empty_records records_list 

55 


56 
let compute_records_const_value c = 

57 
match c with 

58 
 Const_int i > {empty_records with consts = IntSet.singleton i} 

59 
 _ > empty_records 

60  
61 
let rec compute_records_expr expr = 

62 
let boolexpr = 

63 
if (Types.repr expr.expr_type).Types.tdesc = Types.Tbool then 

64 
{empty_records with nb_boolexpr = 1} 

65 
else 

66 
empty_records 

67 
in 

68 
let subrec = 

69 
match expr.expr_desc with 

70 
 Expr_const c > compute_records_const_value c 

71 
 Expr_tuple l > merge_records (List.map compute_records_expr l) 

72 
 Expr_ite (i,t,e) > 

73 
merge_records (List.map compute_records_expr [i;t;e]) 

74 
 Expr_arrow (e1, e2) > 

75 
merge_records (List.map compute_records_expr [e1;e2]) 

76 
 Expr_pre e > compute_records_expr e 

77 
 Expr_appl (op_id, args, r) > 

78 
merge_records ( 

79 
({empty_records with nb_op = OpCount.singleton op_id 1}) 

80 
::[compute_records_expr args] 

81 
) 

82 
 _ > empty_records 

83 
in 

84 
merge_records [boolexpr;subrec] 

47  85  
48 
let get_int_consts_eq eq = get_int_consts_expr eq.eq_rhs


86 
let compute_records_eq eq = compute_records_expr eq.eq_rhs


49  87  
50 
let get_int_consts_node nd = List.flatten (List.map get_int_consts_eq nd.node_eqs) 

88 
let compute_records_node nd = 

89 
merge_records (List.map compute_records_eq nd.node_eqs) 

51  90  
52 
let get_int_consts_top_decl td =


91 
let compute_records_top_decl td =


53  92 
match td.top_decl_desc with 
54 
 Node nd > get_int_consts_node nd 

55 
 Consts constsl > List.flatten (List.map get_int_consts_const constsl) 

56 
 _ > [] 

93 
 Node nd > compute_records_node nd 

94 
 Consts constsl > merge_records (List.map (fun c > compute_records_const_value c.const_value) constsl) 

95 
 _ > empty_records 

96  
97 
let compute_records prog = 

98 
merge_records (List.map compute_records_top_decl prog) 

57  99  
58 
let get_int_consts prog = 

59 
List.flatten (List.map get_int_consts_top_decl prog) 

60  100 
(***************************************************************) 
61  101  
62 
let mutate_int i = 

102  
103 
(*****************************************************************) 

104 
(* Random mutation *) 

105 
(*****************************************************************) 

106  
107 
let rdm_mutate_int i = 

63  108 
if Random.int 100 > threshold_inc_int then 
64  109 
i+1 
65  110 
else if Random.int 100 > threshold_dec_int then 
...  ...  
72  117 
else 
73  118 
i 
74  119 

75 
let mutate_float f = 

120 
let rdm_mutate_float f =


76  121 
if Random.int 100 > threshold_random_float then 
77  122 
Random.float 10. 
78  123 
else 
79  124 
f 
80  125  
81 
let mutate_op op = 

126 
let rdm_mutate_op op =


82  127 
match op with 
83  128 
 "+"  ""  "*"  "/" when Random.int 100 > threshold_arith_op > 
84  129 
let filtered = List.filter (fun x > x <> op) ["+"; ""; "*"; "/"] in 
...  ...  
92  137 
 _ > op 
93  138  
94  139  
95 
let mutate_var expr = 

140 
let rdm_mutate_var expr =


96  141 
match (Types.repr expr.expr_type).Types.tdesc with 
97  142 
 Types.Tbool > 
98 
if Random.int 100 > threshold_negate_bool_var then


143 
(* if Random.int 100 > threshold_negate_bool_var then *)


99  144 
mkpredef_unary_call Location.dummy_loc "not" expr 
100 
else


101 
expr


145 
(* else *)


146 
(* expr *)


102  147 
 _ > expr 
103  148 

104 
let mutate_pre orig_expr e = 

149 
let rdm_mutate_pre orig_expr e =


105  150 
if Random.int 100 <= threshold_delay then 
106  151 
(* We do not nothing *) 
107  152 
Expr_pre e 
...  ...  
109  154 
Expr_pre ({orig_expr with expr_desc = Expr_pre e}) 
110  155  
111  156  
112 
let mutate_const_value c = 

157 
let rdm_mutate_const_value c =


113  158 
match c with 
114 
 Const_int i > Const_int (mutate_int i) 

159 
 Const_int i > Const_int (rdm_mutate_int i)


115  160 
 Const_real s > Const_real s (* those are string, let's leave them *) 
116 
 Const_float f > Const_float (mutate_float f) 

161 
 Const_float f > Const_float (rdm_mutate_float f)


117  162 
 Const_array _ 
118  163 
 Const_tag _ > c 
119  164  
120 
let mutate_const c = 

121 
{ c with const_value = mutate_const_value c.const_value } 

165 
let rdm_mutate_const c =


166 
{ c with const_value = rdm_mutate_const_value c.const_value }


122  167  
123  168  
124 
let select_in_list list mutate_elem = 

169 
let select_in_list list rdm_mutate_elem =


125  170 
let selected = Random.int (List.length list) in 
126  171 
let new_list, _ = 
127  172 
List.fold_right 
128 
(fun elem (res, cpt) > if cpt = selected then (mutate_elem elem)::res, cpt+1 else elem::res, cpt+1) 

173 
(fun elem (res, cpt) > if cpt = selected then (rdm_mutate_elem elem)::res, cpt+1 else elem::res, cpt+1)


129  174 
list 
130  175 
([], 0) 
131  176 
in 
132  177 
new_list 
133  178  
134 
let rec mutate_expr expr = 

179 
let rec rdm_mutate_expr expr =


135  180 
match expr.expr_desc with 
136 
 Expr_ident id > mutate_var expr 

181 
 Expr_ident id > rdm_mutate_var expr


137  182 
 _ > ( 
138  183 
let new_desc = match expr.expr_desc with 
139 
 Expr_const c > Expr_const (mutate_const_value c) 

140 
 Expr_tuple l > Expr_tuple (List.map mutate_expr l) 

141 
 Expr_ite (i,t,e) > Expr_ite (mutate_expr i, mutate_expr t, mutate_expr e)


142 
 Expr_arrow (e1, e2) > Expr_arrow (mutate_expr e1, mutate_expr e2)


143 
 Expr_pre e > mutate_pre expr (mutate_expr e)


144 
 Expr_appl (op_id, args, r) > Expr_appl (mutate_op op_id, mutate_expr args, r)


184 
 Expr_const c > Expr_const (rdm_mutate_const_value c)


185 
 Expr_tuple l > Expr_tuple (List.map rdm_mutate_expr l)


186 
 Expr_ite (i,t,e) > Expr_ite (rdm_mutate_expr i, rdm_mutate_expr t, rdm_mutate_expr e)


187 
 Expr_arrow (e1, e2) > Expr_arrow (rdm_mutate_expr e1, rdm_mutate_expr e2)


188 
 Expr_pre e > rdm_mutate_pre expr (rdm_mutate_expr e)


189 
 Expr_appl (op_id, args, r) > Expr_appl (rdm_mutate_op op_id, rdm_mutate_expr args, r)


145  190 
(* Other constructs are kept. 
146  191 
 Expr_fby of expr * expr 
147  192 
 Expr_array of expr list 
...  ...  
158  203 
{ expr with expr_desc = new_desc } 
159  204 
) 
160  205  
161 
let mutate_eq eq = 

162 
{ eq with eq_rhs = mutate_expr eq.eq_rhs } 

163  
164 
let mutate_node nd = 

165 
{ nd with node_eqs = select_in_list nd.node_eqs mutate_eq } 

166  
167 
let mutate_top_decl td = 

206 
let rdm_mutate_eq eq = 

207 
{ eq with eq_rhs = rdm_mutate_expr eq.eq_rhs } 

208  
209 
let rdm_mutate_node nd = 

210 
{ nd with 

211 
node_eqs = 

212 
select_in_list 

213 
nd.node_eqs 

214 
(fun eq > let new_eq = rdm_mutate_eq eq in 

215 
report ~level:1 

216 
(fun fmt > fprintf fmt "mutation: %a becomes %a@." 

217 
Printers.pp_node_eq eq 

218 
Printers.pp_node_eq new_eq); 

219 
new_eq ) 

220 
} 

221  
222 
let rdm_mutate_top_decl td = 

168  223 
match td.top_decl_desc with 
169 
 Node nd > { td with top_decl_desc = Node (mutate_node nd)} 

170 
 Consts constsl > { td with top_decl_desc = Consts (List.map mutate_const constsl)} 

224 
 Node nd > { td with top_decl_desc = Node (rdm_mutate_node nd)}


225 
 Consts constsl > { td with top_decl_desc = Consts (List.map rdm_mutate_const constsl)}


171  226 
 _ > td 
172  227 

173  228 
(* Create a single mutant with the provided random seed *) 
174 
let mutate_prog prog = 

175 
select_in_list prog mutate_top_decl 

229 
let rdm_mutate_prog prog =


230 
select_in_list prog rdm_mutate_top_decl


176  231  
177 
let mutate nb prog = 

178 
int_consts := get_int_consts prog; 

232 
let rdm_mutate nb prog = 

179  233 
let rec iterate nb res = 
180  234 
incr random_seed; 
181  235 
if nb <= 0 then 
182  236 
res 
183  237 
else ( 
184  238 
Random.init !random_seed; 
185 
let new_mutant = mutate_prog prog in 

239 
let new_mutant = rdm_mutate_prog prog in


186  240 
if List.mem new_mutant res then ( 
187 
report ~level:1 (fun fmt > fprintf fmt "New mutant is not new %i@." nb); 

188  241 
iterate nb res 
189  242 
) 
190 
else 

243 
else ( 

244 
report ~level:1 (fun fmt > fprintf fmt "%i mutants remaining@." nb); 

191  245 
iterate (nb1) (new_mutant::res) 
246 
) 

192  247 
) 
193  248 
in 
194  249 
iterate nb [] 
195  250  
196  251  
197  252  
253 
let mutate nb prog = 

254 
records := compute_records prog; 

255 
rdm_mutate nb prog 

198  256  
199  257 
(* Local Variables: *) 
200  258 
(* compilecommand:"make C .." *) 
Also available in: Unified diff