Project

General

Profile

Revision 4cec0e67

View differences:

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 (nb-1) (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
(* compile-command:"make -C .." *)

Also available in: Unified diff