Project

General

Profile

Statistics
| Branch: | Tag: | Revision:

lustrec / src / mutation.ml @ 4cec0e67

History | View | Annotate | Download (7.58 KB)

1
open Corelang
2
open Log
3
open Format
4

    
5
let random_seed = ref 0
6
let threshold_delay = 95
7
let threshold_inc_int = 97
8
let threshold_dec_int = 97
9
let threshold_random_int = 96
10
let threshold_switch_int = 100 (* not implemented yet *)
11
let threshold_random_float = 100 (* not used yet *)
12
let threshold_negate_bool_var = 95
13
let threshold_arith_op = 95
14
let threshold_rel_op = 95
15
let threshold_bool_op = 95
16

    
17
let int_consts = ref []
18

    
19
(************************************************************************************)
20
(*                    Gathering constants in the code                               *)
21
(************************************************************************************)
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)
25

    
26
type records = {
27
  consts: IntSet.t;
28
  nb_boolexpr: int;
29
  nb_pre: int;
30
  nb_op: int OpCount.t;
31
}
32

    
33
let empty_records = 
34
  {consts=IntSet.empty; nb_boolexpr=0; nb_pre=0; nb_op=OpCount.empty}
35

    
36
let records = ref empty_records
37

    
38
let merge_records records_list = 
39
  let merge_record r1 r2 =
40
    {
41
      consts = IntSet.union r1.consts r2.consts;
42

    
43
      nb_boolexpr = r1.nb_boolexpr + r2.nb_boolexpr;
44
      nb_pre = r1.nb_pre + r2.nb_pre;
45

    
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]
85

    
86
let compute_records_eq eq = compute_records_expr eq.eq_rhs
87

    
88
let compute_records_node nd = 
89
  merge_records (List.map compute_records_eq nd.node_eqs)
90

    
91
let compute_records_top_decl td =
92
  match td.top_decl_desc with
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)
99

    
100
(***************************************************************)
101

    
102

    
103
(*****************************************************************)
104
(*                  Random mutation                              *)
105
(*****************************************************************)
106

    
107
let rdm_mutate_int i = 
108
  if Random.int 100 > threshold_inc_int then
109
    i+1
110
  else if Random.int 100 > threshold_dec_int then
111
    i-1
112
  else if Random.int 100 > threshold_random_int then
113
    Random.int 10
114
  else if Random.int 100 > threshold_switch_int then
115
    let idx = Random.int (List.length !int_consts) in
116
    List.nth !int_consts idx
117
  else
118
    i
119
  
120
let rdm_mutate_float f =
121
  if Random.int 100 > threshold_random_float then
122
    Random.float 10.
123
  else 
124
    f
125

    
126
let rdm_mutate_op op = 
127
match op with
128
| "+" | "-" | "*" | "/" when Random.int 100 > threshold_arith_op ->
129
  let filtered = List.filter (fun x -> x <> op) ["+"; "-"; "*"; "/"] in
130
  List.nth filtered (Random.int 3)
131
| "&&" | "||" | "xor" | "impl" when Random.int 100 > threshold_bool_op ->
132
  let filtered = List.filter (fun x -> x <> op) ["&&"; "||"; "xor"; "impl"] in
133
  List.nth filtered (Random.int 3)
134
| "<" | "<=" | ">" | ">=" | "!=" | "=" when Random.int 100 > threshold_rel_op ->
135
  let filtered = List.filter (fun x -> x <> op) ["<"; "<="; ">"; ">="; "!="; "="] in
136
  List.nth filtered (Random.int 5)
137
| _ -> op
138

    
139

    
140
let rdm_mutate_var expr = 
141
  match (Types.repr expr.expr_type).Types.tdesc with 
142
  | Types.Tbool ->
143
    (* if Random.int 100 > threshold_negate_bool_var then *)
144
      mkpredef_unary_call Location.dummy_loc "not" expr
145
    (* else  *)
146
    (*   expr *)
147
  | _ -> expr
148
    
149
let rdm_mutate_pre orig_expr e = 
150
  if Random.int 100 <= threshold_delay then
151
    (* We do not nothing *)
152
    Expr_pre e 
153
  else (* We add a pre *)
154
    Expr_pre ({orig_expr with expr_desc = Expr_pre e}) 
155

    
156

    
157
let rdm_mutate_const_value c =
158
  match c with
159
  | Const_int i -> Const_int (rdm_mutate_int i)
160
  | Const_real s -> Const_real s (* those are string, let's leave them *)
161
  | Const_float f -> Const_float (rdm_mutate_float f)
162
  | Const_array _
163
  | Const_tag _ -> c
164

    
165
let rdm_mutate_const c =
166
  { c with const_value = rdm_mutate_const_value c.const_value }
167

    
168

    
169
let select_in_list list rdm_mutate_elem = 
170
  let selected = Random.int (List.length list) in
171
  let new_list, _ = 
172
    List.fold_right
173
      (fun elem (res, cpt) -> if cpt = selected then (rdm_mutate_elem elem)::res, cpt+1  else elem::res, cpt+1)
174
      list 
175
      ([], 0)
176
  in
177
  new_list
178

    
179
let rec rdm_mutate_expr expr =
180
  match expr.expr_desc with
181
  | Expr_ident id -> rdm_mutate_var expr
182
  | _ -> (
183
    let new_desc = match expr.expr_desc with
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)
190
  (* Other constructs are kept.
191
  | Expr_fby of expr * expr
192
  | Expr_array of expr list
193
  | Expr_access of expr * Dimension.dim_expr
194
  | Expr_power of expr * Dimension.dim_expr
195
  | Expr_when of expr * ident * label
196
  | Expr_merge of ident * (label * expr) list
197
  | Expr_uclock of expr * int
198
  | Expr_dclock of expr * int
199
  | Expr_phclock of expr * rat *)
200
  | _ -> expr.expr_desc
201

    
202
    in
203
    { expr with expr_desc = new_desc }
204
  )
205

    
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 =
223
  match td.top_decl_desc with
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)}
226
  | _ -> td
227
    
228
(* Create a single mutant with the provided random seed *)
229
let rdm_mutate_prog prog = 
230
  select_in_list prog rdm_mutate_top_decl
231

    
232
let rdm_mutate nb prog = 
233
  let rec iterate nb res =
234
    incr random_seed;
235
    if nb <= 0 then
236
      res
237
    else (
238
      Random.init !random_seed;
239
      let new_mutant = rdm_mutate_prog prog in
240
      if List.mem new_mutant res then (
241
	iterate nb res
242
      )
243
      else (
244
	report ~level:1 (fun fmt -> fprintf fmt "%i mutants remaining@." nb); 
245
	iterate (nb-1) (new_mutant::res)
246
      )
247
    )
248
  in
249
  iterate nb []
250

    
251

    
252

    
253
let mutate nb prog =
254
  records := compute_records prog;
255
  rdm_mutate nb prog
256

    
257
(* Local Variables: *)
258
(* compile-command:"make -C .." *)
259
(* End: *)
260

    
261