## lustrec / src / mutation.ml @ 5fccce23

History | View | Annotate | Download (26.8 KB)

1 | 5487dd79 | ploc | |
---|---|---|---|

2 | (* Comments in function fold_mutate |
||

3 | |||

4 | TODO: check if we can generate more cases. The following lines were |
||

5 | cylcing and missing to detect that the enumaration was complete, |
||

6 | leading to a non terminating process. The current setting is harder |
||

7 | but may miss enumerating some cases. To be checked! |
||

8 | |||

9 | |||

10 | *) |
||

11 | |||

12 | |||

13 | 8446bf03 | ploc | open Lustre_types |

14 | 40d33d55 | xavier.thirioux | open Corelang |

15 | open Log |
||

16 | open Format |
||

17 | |||

18 | let random_seed = ref 0 |
||

19 | let threshold_delay = 95 |
||

20 | let threshold_inc_int = 97 |
||

21 | let threshold_dec_int = 97 |
||

22 | let threshold_random_int = 96 |
||

23 | let threshold_switch_int = 100 (* not implemented yet *) |
||

24 | let threshold_random_float = 100 (* not used yet *) |
||

25 | let threshold_negate_bool_var = 95 |
||

26 | let threshold_arith_op = 95 |
||

27 | let threshold_rel_op = 95 |
||

28 | let threshold_bool_op = 95 |
||

29 | |||

30 | let int_consts = ref [] |
||

31 | |||

32 | 5d5139a5 | ploc | let rename_app id = |

33 | let node = Corelang.node_from_name id in |
||

34 | let is_imported = |
||

35 | match node.top_decl_desc with |
||

36 | | ImportedNode _ -> true |
||

37 | | _ -> false |
||

38 | in |
||

39 | if !Options.no_mutation_suffix || is_imported then |
||

40 | 40d33d55 | xavier.thirioux | id |

41 | else |
||

42 | id ^ "_mutant" |
||

43 | |||

44 | (************************************************************************************) |
||

45 | (* Gathering constants in the code *) |
||

46 | (************************************************************************************) |
||

47 | |||

48 | module IntSet = Set.Make (struct type t = int let compare = compare end) |
||

49 | module OpCount = Mmap.Make (struct type t = string let compare = compare end) |
||

50 | |||

51 | type records = { |
||

52 | consts: IntSet.t; |
||

53 | 5d5139a5 | ploc | nb_consts: int; |

54 | 40d33d55 | xavier.thirioux | nb_boolexpr: int; |

55 | nb_pre: int; |
||

56 | nb_op: int OpCount.t; |
||

57 | } |
||

58 | |||

59 | let arith_op = ["+" ; "-" ; "*" ; "/"] |
||

60 | let bool_op = ["&&"; "||"; "xor"; "impl"] |
||

61 | let rel_op = ["<" ; "<=" ; ">" ; ">=" ; "!=" ; "=" ] |
||

62 | let ops = arith_op @ bool_op @ rel_op |
||

63 | let all_ops = "not" :: ops |
||

64 | |||

65 | let empty_records = |
||

66 | 5d5139a5 | ploc | {consts=IntSet.empty; nb_consts=0; nb_boolexpr=0; nb_pre=0; nb_op=OpCount.empty} |

67 | 40d33d55 | xavier.thirioux | |

68 | let records = ref empty_records |
||

69 | |||

70 | let merge_records records_list = |
||

71 | let merge_record r1 r2 = |
||

72 | { |
||

73 | consts = IntSet.union r1.consts r2.consts; |
||

74 | |||

75 | 5d5139a5 | ploc | nb_consts = r1.nb_consts + r2.nb_consts; |

76 | 40d33d55 | xavier.thirioux | nb_boolexpr = r1.nb_boolexpr + r2.nb_boolexpr; |

77 | nb_pre = r1.nb_pre + r2.nb_pre; |
||

78 | |||

79 | nb_op = OpCount.merge (fun op r1opt r2opt -> |
||

80 | match r1opt, r2opt with |
||

81 | | None, _ -> r2opt |
||

82 | | _, None -> r1opt |
||

83 | | Some x, Some y -> Some (x+y) |
||

84 | ) r1.nb_op r2.nb_op |
||

85 | } |
||

86 | in |
||

87 | List.fold_left merge_record empty_records records_list |
||

88 | |||

89 | let compute_records_const_value c = |
||

90 | match c with |
||

91 | 5d5139a5 | ploc | | Const_int i -> {empty_records with consts = IntSet.singleton i; nb_consts = 1} |

92 | 40d33d55 | xavier.thirioux | | _ -> empty_records |

93 | |||

94 | let rec compute_records_expr expr = |
||

95 | let boolexpr = |
||

96 | b7c3790e | ploc | if Types.is_bool_type expr.expr_type then |

97 | 40d33d55 | xavier.thirioux | {empty_records with nb_boolexpr = 1} |

98 | else |
||

99 | empty_records |
||

100 | in |
||

101 | let subrec = |
||

102 | match expr.expr_desc with |
||

103 | | Expr_const c -> compute_records_const_value c |
||

104 | | Expr_tuple l -> merge_records (List.map compute_records_expr l) |
||

105 | | Expr_ite (i,t,e) -> |
||

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

107 | | Expr_arrow (e1, e2) -> |
||

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

109 | | Expr_pre e -> |
||

110 | merge_records ( |
||

111 | ({empty_records with nb_pre = 1}) |
||

112 | ::[compute_records_expr e]) |
||

113 | | Expr_appl (op_id, args, r) -> |
||

114 | if List.mem op_id ops then |
||

115 | merge_records ( |
||

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

117 | ::[compute_records_expr args]) |
||

118 | else |
||

119 | compute_records_expr args |
||

120 | | _ -> empty_records |
||

121 | in |
||

122 | merge_records [boolexpr;subrec] |
||

123 | |||

124 | let compute_records_eq eq = compute_records_expr eq.eq_rhs |
||

125 | |||

126 | 333e3a25 | ploc | let compute_records_node nd = |

127 | let eqs, auts = get_node_eqs nd in |
||

128 | assert (auts=[]); (* Automaton should be expanded by now *) |
||

129 | merge_records (List.map compute_records_eq eqs) |
||

130 | 40d33d55 | xavier.thirioux | |

131 | let compute_records_top_decl td = |
||

132 | match td.top_decl_desc with |
||

133 | | Node nd -> compute_records_node nd |
||

134 | bde99c3f | xavier.thirioux | | Const cst -> compute_records_const_value cst.const_value |

135 | 40d33d55 | xavier.thirioux | | _ -> empty_records |

136 | |||

137 | let compute_records prog = |
||

138 | merge_records (List.map compute_records_top_decl prog) |
||

139 | |||

140 | (*****************************************************************) |
||

141 | (* Random mutation *) |
||

142 | (*****************************************************************) |
||

143 | |||

144 | let check_mut e1 e2 = |
||

145 | let rec eq e1 e2 = |
||

146 | match e1.expr_desc, e2.expr_desc with |
||

147 | | Expr_const c1, Expr_const c2 -> c1 = c2 |
||

148 | | Expr_ident id1, Expr_ident id2 -> id1 = id2 |
||

149 | | Expr_tuple el1, Expr_tuple el2 -> List.length el1 = List.length el2 && List.for_all2 eq el1 el2 |
||

150 | | Expr_ite (i1, t1, e1), Expr_ite (i2, t2, e2) -> eq i1 i2 && eq t1 t2 && eq e1 e2 |
||

151 | | Expr_arrow (x1, y1), Expr_arrow (x2, y2) -> eq x1 x2 && eq y1 y2 |
||

152 | | Expr_pre e1, Expr_pre e2 -> eq e1 e2 |
||

153 | | Expr_appl (id1, e1, _), Expr_appl (id2, e2, _) -> id1 = id2 && eq e1 e2 |
||

154 | | _ -> false |
||

155 | in |
||

156 | if not (eq e1 e2) then |
||

157 | Some (e1, e2) |
||

158 | else |
||

159 | None |
||

160 | |||

161 | let mk_cst_expr c = mkexpr Location.dummy_loc (Expr_const c) |
||

162 | |||

163 | let rdm_mutate_int i = |
||

164 | if Random.int 100 > threshold_inc_int then |
||

165 | i+1 |
||

166 | else if Random.int 100 > threshold_dec_int then |
||

167 | i-1 |
||

168 | else if Random.int 100 > threshold_random_int then |
||

169 | Random.int 10 |
||

170 | else if Random.int 100 > threshold_switch_int then |
||

171 | let idx = Random.int (List.length !int_consts) in |
||

172 | List.nth !int_consts idx |
||

173 | else |
||

174 | i |
||

175 | |||

176 | bde99c3f | xavier.thirioux | let rdm_mutate_real r = |

177 | 40d33d55 | xavier.thirioux | if Random.int 100 > threshold_random_float then |

178 | bde99c3f | xavier.thirioux | (* interval [0, bound] for random values *) |

179 | let bound = 10 in |
||

180 | (* max number of digits after comma *) |
||

181 | let digits = 5 in |
||

182 | (* number of digits after comma *) |
||

183 | let shift = Random.int (digits + 1) in |
||

184 | let eshift = 10. ** (float_of_int shift) in |
||

185 | let i = Random.int (1 + bound * (int_of_float eshift)) in |
||

186 | let f = float_of_int i /. eshift in |
||

187 | (Num.num_of_int i, shift, string_of_float f) |
||

188 | 40d33d55 | xavier.thirioux | else |

189 | bde99c3f | xavier.thirioux | r |

190 | 40d33d55 | xavier.thirioux | |

191 | let rdm_mutate_op op = |
||

192 | match op with |
||

193 | | "+" | "-" | "*" | "/" when Random.int 100 > threshold_arith_op -> |
||

194 | let filtered = List.filter (fun x -> x <> op) ["+"; "-"; "*"; "/"] in |
||

195 | List.nth filtered (Random.int 3) |
||

196 | | "&&" | "||" | "xor" | "impl" when Random.int 100 > threshold_bool_op -> |
||

197 | let filtered = List.filter (fun x -> x <> op) ["&&"; "||"; "xor"; "impl"] in |
||

198 | List.nth filtered (Random.int 3) |
||

199 | | "<" | "<=" | ">" | ">=" | "!=" | "=" when Random.int 100 > threshold_rel_op -> |
||

200 | let filtered = List.filter (fun x -> x <> op) ["<"; "<="; ">"; ">="; "!="; "="] in |
||

201 | List.nth filtered (Random.int 5) |
||

202 | | _ -> op |
||

203 | |||

204 | |||

205 | b7c3790e | ploc | let rdm_mutate_var expr = |

206 | if Types.is_bool_type expr.expr_type then |
||

207 | 40d33d55 | xavier.thirioux | (* if Random.int 100 > threshold_negate_bool_var then *) |

208 | bde99c3f | xavier.thirioux | let new_e = mkpredef_call expr.expr_loc "not" [expr] in |

209 | 40d33d55 | xavier.thirioux | Some (expr, new_e), new_e |

210 | (* else *) |
||

211 | b7c3790e | ploc | (* expr *) |

212 | else |
||

213 | None, expr |
||

214 | 40d33d55 | xavier.thirioux | |

215 | let rdm_mutate_pre orig_expr = |
||

216 | let new_e = Expr_pre orig_expr in |
||

217 | Some (orig_expr, {orig_expr with expr_desc = new_e}), new_e |
||

218 | |||

219 | |||

220 | let rdm_mutate_const_value c = |
||

221 | match c with |
||

222 | | Const_int i -> Const_int (rdm_mutate_int i) |
||

223 | bde99c3f | xavier.thirioux | | Const_real (n, i, s) -> let (n', i', s') = rdm_mutate_real (n, i, s) in Const_real (n', i', s') |

224 | 40d33d55 | xavier.thirioux | | Const_array _ |

225 | bde99c3f | xavier.thirioux | | Const_string _ |

226 | 0d54d8a8 | ploc | | Const_modeid _ |

227 | bde99c3f | xavier.thirioux | | Const_struct _ |

228 | 40d33d55 | xavier.thirioux | | Const_tag _ -> c |

229 | |||

230 | let rdm_mutate_const c = |
||

231 | let new_const = rdm_mutate_const_value c.const_value in |
||

232 | let mut = check_mut (mk_cst_expr c.const_value) (mk_cst_expr new_const) in |
||

233 | mut, { c with const_value = new_const } |
||

234 | |||

235 | |||

236 | let select_in_list list rdm_mutate_elem = |
||

237 | let selected = Random.int (List.length list) in |
||

238 | let mutation_opt, new_list, _ = |
||

239 | List.fold_right |
||

240 | (fun elem (mutation_opt, res, cpt) -> if cpt = selected then |
||

241 | let mutation, new_elem = rdm_mutate_elem elem in |
||

242 | Some mutation, new_elem::res, cpt+1 else mutation_opt, elem::res, cpt+1) |
||

243 | list |
||

244 | (None, [], 0) |
||

245 | in |
||

246 | match mutation_opt with |
||

247 | | Some mut -> mut, new_list |
||

248 | | _ -> assert false |
||

249 | |||

250 | |||

251 | let rec rdm_mutate_expr expr = |
||

252 | let mk_e d = { expr with expr_desc = d } in |
||

253 | match expr.expr_desc with |
||

254 | | Expr_ident id -> rdm_mutate_var expr |
||

255 | | Expr_const c -> |
||

256 | let new_const = rdm_mutate_const_value c in |
||

257 | let mut = check_mut (mk_cst_expr c) (mk_cst_expr new_const) in |
||

258 | mut, mk_e (Expr_const new_const) |
||

259 | | Expr_tuple l -> |
||

260 | let mut, l' = select_in_list l rdm_mutate_expr in |
||

261 | mut, mk_e (Expr_tuple l') |
||

262 | 2fdbc781 | ploc | | Expr_ite (i,t,e) -> ( |

263 | let mut, l = select_in_list [i; t; e] rdm_mutate_expr in |
||

264 | match l with |
||

265 | | [i'; t'; e'] -> mut, mk_e (Expr_ite (i', t', e')) |
||

266 | | _ -> assert false |
||

267 | ) |
||

268 | | Expr_arrow (e1, e2) -> ( |
||

269 | let mut, l = select_in_list [e1; e2] rdm_mutate_expr in |
||

270 | match l with |
||

271 | | [e1'; e2'] -> mut, mk_e (Expr_arrow (e1', e2')) |
||

272 | | _ -> assert false |
||

273 | ) |
||

274 | 40d33d55 | xavier.thirioux | | Expr_pre e -> |

275 | let select_pre = Random.bool () in |
||

276 | if select_pre then |
||

277 | let mut, new_expr = rdm_mutate_pre expr in |
||

278 | mut, mk_e new_expr |
||

279 | else |
||

280 | let mut, e' = rdm_mutate_expr e in |
||

281 | mut, mk_e (Expr_pre e') |
||

282 | | Expr_appl (op_id, args, r) -> |
||

283 | let select_op = Random.bool () in |
||

284 | if select_op then |
||

285 | let new_op_id = rdm_mutate_op op_id in |
||

286 | let new_e = mk_e (Expr_appl (new_op_id, args, r)) in |
||

287 | let mut = check_mut expr new_e in |
||

288 | mut, new_e |
||

289 | else |
||

290 | let mut, new_args = rdm_mutate_expr args in |
||

291 | mut, mk_e (Expr_appl (op_id, new_args, r)) |
||

292 | (* Other constructs are kept. |
||

293 | | Expr_fby of expr * expr |
||

294 | | Expr_array of expr list |
||

295 | | Expr_access of expr * Dimension.dim_expr |
||

296 | | Expr_power of expr * Dimension.dim_expr |
||

297 | | Expr_when of expr * ident * label |
||

298 | | Expr_merge of ident * (label * expr) list |
||

299 | | Expr_uclock of expr * int |
||

300 | | Expr_dclock of expr * int |
||

301 | | Expr_phclock of expr * rat *) |
||

302 | bde99c3f | xavier.thirioux | | _ -> None, expr |

303 | 40d33d55 | xavier.thirioux | |

304 | |||

305 | let rdm_mutate_eq eq = |
||

306 | let mutation, new_rhs = rdm_mutate_expr eq.eq_rhs in |
||

307 | mutation, { eq with eq_rhs = new_rhs } |
||

308 | |||

309 | bde99c3f | xavier.thirioux | let rnd_mutate_stmt stmt = |

310 | match stmt with |
||

311 | | Eq eq -> let mut, new_eq = rdm_mutate_eq eq in |
||

312 | 40d33d55 | xavier.thirioux | report ~level:1 |

313 | 5d5139a5 | ploc | (fun fmt -> fprintf fmt "mutation: %a becomes %a@ " |

314 | 40d33d55 | xavier.thirioux | Printers.pp_node_eq eq |

315 | Printers.pp_node_eq new_eq); |
||

316 | bde99c3f | xavier.thirioux | mut, Eq new_eq |

317 | | Aut aut -> assert false |
||

318 | |||

319 | let rdm_mutate_node nd = |
||

320 | let mutation, new_node_stmts = |
||

321 | select_in_list |
||

322 | nd.node_stmts rnd_mutate_stmt |
||

323 | 40d33d55 | xavier.thirioux | in |

324 | bde99c3f | xavier.thirioux | mutation, { nd with node_stmts = new_node_stmts } |

325 | 40d33d55 | xavier.thirioux | |

326 | let rdm_mutate_top_decl td = |
||

327 | match td.top_decl_desc with |
||

328 | | Node nd -> |
||

329 | let mutation, new_node = rdm_mutate_node nd in |
||

330 | mutation, { td with top_decl_desc = Node new_node} |
||

331 | bde99c3f | xavier.thirioux | | Const cst -> |

332 | let mut, new_cst = rdm_mutate_const cst in |
||

333 | mut, { td with top_decl_desc = Const new_cst } |
||

334 | 40d33d55 | xavier.thirioux | | _ -> None, td |

335 | |||

336 | (* Create a single mutant with the provided random seed *) |
||

337 | let rdm_mutate_prog prog = |
||

338 | select_in_list prog rdm_mutate_top_decl |
||

339 | |||

340 | let rdm_mutate nb prog = |
||

341 | let rec iterate nb res = |
||

342 | incr random_seed; |
||

343 | if nb <= 0 then |
||

344 | res |
||

345 | else ( |
||

346 | Random.init !random_seed; |
||

347 | let mutation, new_mutant = rdm_mutate_prog prog in |
||

348 | match mutation with |
||

349 | None -> iterate nb res |
||

350 | | Some mutation -> ( |
||

351 | if List.mem_assoc mutation res then ( |
||

352 | iterate nb res |
||

353 | ) |
||

354 | else ( |
||

355 | 5d5139a5 | ploc | report ~level:1 (fun fmt -> fprintf fmt "%i mutants remaining@ " nb); |

356 | 40d33d55 | xavier.thirioux | iterate (nb-1) ((mutation, new_mutant)::res) |

357 | ) |
||

358 | ) |
||

359 | ) |
||

360 | in |
||

361 | iterate nb [] |
||

362 | |||

363 | |||

364 | (*****************************************************************) |
||

365 | (* Random mutation *) |
||

366 | (*****************************************************************) |
||

367 | |||

368 | 4c3c6658 | ploc | type mutant_t = |

369 | | Boolexpr of int |
||

370 | | Pre of int |
||

371 | | Op of string * int * string |
||

372 | | IncrIntCst of int |
||

373 | | DecrIntCst of int |
||

374 | | SwitchIntCst of int * int |
||

375 | 40d33d55 | xavier.thirioux | |

376 | 55a8633c | ploc | (* Denotes the parent node, the equation lhs and the location of the mutation *) |

377 | type mutation_loc = ident * ident list * Location.t |
||

378 | 40d33d55 | xavier.thirioux | let target : mutant_t option ref = ref None |

379 | |||

380 | 55a8633c | ploc | let mutation_info : mutation_loc option ref = ref None |

381 | let current_node: ident option ref = ref None |
||

382 | let current_eq_lhs : ident list option ref = ref None |
||

383 | let current_loc : Location.t option ref = ref None |
||

384 | |||

385 | let set_mutation_loc () = |
||

386 | target := None; |
||

387 | match !current_node, !current_eq_lhs, !current_loc with |
||

388 | | Some n, Some elhs, Some l -> mutation_info := Some (n, elhs, l) |
||

389 | | _ -> assert false (* Those global vars should be defined during the |
||

390 | visitor pattern execution *) |
||

391 | |||

392 | 40d33d55 | xavier.thirioux | let print_directive fmt d = |

393 | match d with |
||

394 | | Pre n -> Format.fprintf fmt "pre %i" n |
||

395 | | Boolexpr n -> Format.fprintf fmt "boolexpr %i" n |
||

396 | | Op (o, i, d) -> Format.fprintf fmt "%s %i -> %s" o i d |
||

397 | | IncrIntCst n -> Format.fprintf fmt "incr int cst %i" n |
||

398 | | DecrIntCst n -> Format.fprintf fmt "decr int cst %i" n |
||

399 | | SwitchIntCst (n, m) -> Format.fprintf fmt "switch int cst %i -> %i" n m |
||

400 | |||

401 | 55a8633c | ploc | let print_directive_json fmt d = |

402 | match d with |
||

403 | | Pre _ -> Format.fprintf fmt "\"mutation\": \"pre\"" |
||

404 | | Boolexpr _ -> Format.fprintf fmt "\"mutation\": \"not\"" |
||

405 | | Op (o, _, d) -> Format.fprintf fmt "\"mutation\": \"op_conv\", \"from\": \"%s\", \"to\": \"%s\"" o d |
||

406 | | IncrIntCst n -> Format.fprintf fmt "\"mutation\": \"cst_incr\"" |
||

407 | | DecrIntCst n -> Format.fprintf fmt "\"mutation\": \"cst_decr\"" |
||

408 | | SwitchIntCst (n, m) -> Format.fprintf fmt "\"mutation\": \"cst_switch\", \"to_cst\": \"%i\"" m |
||

409 | |||

410 | let print_loc_json fmt (n,eqlhs, l) = |
||

411 | Format.fprintf fmt "\"node_id\": \"%s\", \"eq_lhs\": [%a], \"loc_line\": \"%i\"" |
||

412 | n |
||

413 | (Utils.fprintf_list ~sep:", " (fun fmt s -> Format.fprintf fmt "\"%s\"" s)) eqlhs |
||

414 | (Location.loc_line l) |
||

415 | |||

416 | 40d33d55 | xavier.thirioux | let fold_mutate_int i = |

417 | if Random.int 100 > threshold_inc_int then |
||

418 | i+1 |
||

419 | else if Random.int 100 > threshold_dec_int then |
||

420 | i-1 |
||

421 | else if Random.int 100 > threshold_random_int then |
||

422 | Random.int 10 |
||

423 | else if Random.int 100 > threshold_switch_int then |
||

424 | try |
||

425 | let idx = Random.int (List.length !int_consts) in |
||

426 | List.nth !int_consts idx |
||

427 | with _ -> i |
||

428 | else |
||

429 | i |
||

430 | |||

431 | let fold_mutate_float f = |
||

432 | if Random.int 100 > threshold_random_float then |
||

433 | Random.float 10. |
||

434 | else |
||

435 | f |
||

436 | |||

437 | let fold_mutate_op op = |
||

438 | (* match op with *) |
||

439 | (* | "+" | "-" | "*" | "/" when Random.int 100 > threshold_arith_op -> *) |
||

440 | (* let filtered = List.filter (fun x -> x <> op) ["+"; "-"; "*"; "/"] in *) |
||

441 | (* List.nth filtered (Random.int 3) *) |
||

442 | (* | "&&" | "||" | "xor" | "impl" when Random.int 100 > threshold_bool_op -> *) |
||

443 | (* let filtered = List.filter (fun x -> x <> op) ["&&"; "||"; "xor"; "impl"] in *) |
||

444 | (* List.nth filtered (Random.int 3) *) |
||

445 | (* | "<" | "<=" | ">" | ">=" | "!=" | "=" when Random.int 100 > threshold_rel_op -> *) |
||

446 | (* let filtered = List.filter (fun x -> x <> op) ["<"; "<="; ">"; ">="; "!="; "="] in *) |
||

447 | (* List.nth filtered (Random.int 5) *) |
||

448 | (* | _ -> op *) |
||

449 | match !target with |
||

450 | | Some (Op(op_orig, 0, op_new)) when op_orig = op -> ( |
||

451 | 55a8633c | ploc | set_mutation_loc (); |

452 | 40d33d55 | xavier.thirioux | op_new |

453 | ) |
||

454 | | Some (Op(op_orig, n, op_new)) when op_orig = op -> ( |
||

455 | target := Some (Op(op_orig, n-1, op_new)); |
||

456 | op |
||

457 | ) |
||

458 | | _ -> if List.mem op Basic_library.internal_funs then op else rename_app op |
||

459 | |||

460 | |||

461 | let fold_mutate_var expr = |
||

462 | (* match (Types.repr expr.expr_type).Types.tdesc with *) |
||

463 | (* | Types.Tbool -> *) |
||

464 | (* (\* if Random.int 100 > threshold_negate_bool_var then *\) *) |
||

465 | (* mkpredef_unary_call Location.dummy_loc "not" expr *) |
||

466 | (* (\* else *\) *) |
||

467 | (* (\* expr *\) *) |
||

468 | (* | _ -> |
||

469 | *)expr |
||

470 | |||

471 | let fold_mutate_boolexpr expr = |
||

472 | match !target with |
||

473 | | Some (Boolexpr 0) -> ( |
||

474 | 55a8633c | ploc | set_mutation_loc (); |

475 | |||

476 | bde99c3f | xavier.thirioux | mkpredef_call expr.expr_loc "not" [expr] |

477 | 40d33d55 | xavier.thirioux | ) |

478 | | Some (Boolexpr n) -> |
||

479 | (target := Some (Boolexpr (n-1)); expr) |
||

480 | | _ -> expr |
||

481 | |||

482 | let fold_mutate_pre orig_expr e = |
||

483 | match !target with |
||

484 | Some (Pre 0) -> ( |
||

485 | 55a8633c | ploc | set_mutation_loc (); |

486 | 40d33d55 | xavier.thirioux | Expr_pre ({orig_expr with expr_desc = Expr_pre e}) |

487 | ) |
||

488 | | Some (Pre n) -> ( |
||

489 | target := Some (Pre (n-1)); |
||

490 | Expr_pre e |
||

491 | ) |
||

492 | | _ -> Expr_pre e |
||

493 | |||

494 | let fold_mutate_const_value c = |
||

495 | match c with |
||

496 | | Const_int i -> ( |
||

497 | match !target with |
||

498 | 55a8633c | ploc | | Some (IncrIntCst 0) -> (set_mutation_loc (); Const_int (i+1)) |

499 | | Some (DecrIntCst 0) -> (set_mutation_loc (); Const_int (i-1)) |
||

500 | 5d5139a5 | ploc | | Some (SwitchIntCst (0, id)) -> |

501 | (set_mutation_loc (); Const_int id) |
||

502 | 40d33d55 | xavier.thirioux | | Some (IncrIntCst n) -> (target := Some (IncrIntCst (n-1)); c) |

503 | | Some (DecrIntCst n) -> (target := Some (DecrIntCst (n-1)); c) |
||

504 | | Some (SwitchIntCst (n, id)) -> (target := Some (SwitchIntCst (n-1, id)); c) |
||

505 | | _ -> c) |
||

506 | | _ -> c |
||

507 | |||

508 | (* |
||

509 | match c with |
||

510 | | Const_int i -> Const_int (fold_mutate_int i) |
||

511 | | Const_real s -> Const_real s (* those are string, let's leave them *) |
||

512 | | Const_float f -> Const_float (fold_mutate_float f) |
||

513 | | Const_array _ |
||

514 | | Const_tag _ -> c |
||

515 | TODO |
||

516 | |||

517 | *) |
||

518 | let fold_mutate_const c = |
||

519 | { c with const_value = fold_mutate_const_value c.const_value } |
||

520 | |||

521 | let rec fold_mutate_expr expr = |
||

522 | 55a8633c | ploc | current_loc := Some expr.expr_loc; |

523 | 40d33d55 | xavier.thirioux | let new_expr = |

524 | match expr.expr_desc with |
||

525 | | Expr_ident id -> fold_mutate_var expr |
||

526 | | _ -> ( |
||

527 | let new_desc = match expr.expr_desc with |
||

528 | | Expr_const c -> Expr_const (fold_mutate_const_value c) |
||

529 | | Expr_tuple l -> Expr_tuple (List.fold_right (fun e res -> (fold_mutate_expr e)::res) l []) |
||

530 | | Expr_ite (i,t,e) -> Expr_ite (fold_mutate_expr i, fold_mutate_expr t, fold_mutate_expr e) |
||

531 | | Expr_arrow (e1, e2) -> Expr_arrow (fold_mutate_expr e1, fold_mutate_expr e2) |
||

532 | | Expr_pre e -> fold_mutate_pre expr (fold_mutate_expr e) |
||

533 | | Expr_appl (op_id, args, r) -> Expr_appl (fold_mutate_op op_id, fold_mutate_expr args, r) |
||

534 | (* Other constructs are kept. |
||

535 | | Expr_fby of expr * expr |
||

536 | | Expr_array of expr list |
||

537 | | Expr_access of expr * Dimension.dim_expr |
||

538 | | Expr_power of expr * Dimension.dim_expr |
||

539 | | Expr_when of expr * ident * label |
||

540 | | Expr_merge of ident * (label * expr) list |
||

541 | | Expr_uclock of expr * int |
||

542 | | Expr_dclock of expr * int |
||

543 | | Expr_phclock of expr * rat *) |
||

544 | | _ -> expr.expr_desc |
||

545 | |||

546 | in |
||

547 | { expr with expr_desc = new_desc } |
||

548 | ) |
||

549 | in |
||

550 | b7c3790e | ploc | if Types.is_bool_type expr.expr_type then |

551 | 40d33d55 | xavier.thirioux | fold_mutate_boolexpr new_expr |

552 | else |
||

553 | new_expr |
||

554 | |||

555 | let fold_mutate_eq eq = |
||

556 | 55a8633c | ploc | current_eq_lhs := Some eq.eq_lhs; |

557 | 40d33d55 | xavier.thirioux | { eq with eq_rhs = fold_mutate_expr eq.eq_rhs } |

558 | |||

559 | bde99c3f | xavier.thirioux | let fold_mutate_stmt stmt = |

560 | match stmt with |
||

561 | | Eq eq -> Eq (fold_mutate_eq eq) |
||

562 | | Aut aut -> assert false |
||

563 | |||

564 | 55a8633c | ploc | let fold_mutate_node nd = |

565 | current_node := Some nd.node_id; |
||

566 | 40d33d55 | xavier.thirioux | { nd with |

567 | bde99c3f | xavier.thirioux | node_stmts = |

568 | List.fold_right (fun stmt res -> (fold_mutate_stmt stmt)::res) nd.node_stmts []; |
||

569 | 40d33d55 | xavier.thirioux | node_id = rename_app nd.node_id |

570 | } |
||

571 | |||

572 | let fold_mutate_top_decl td = |
||

573 | match td.top_decl_desc with |
||

574 | bde99c3f | xavier.thirioux | | Node nd -> { td with top_decl_desc = Node (fold_mutate_node nd)} |

575 | | Const cst -> { td with top_decl_desc = Const (fold_mutate_const cst)} |
||

576 | 40d33d55 | xavier.thirioux | | _ -> td |

577 | |||

578 | (* Create a single mutant with the provided random seed *) |
||

579 | let fold_mutate_prog prog = |
||

580 | List.fold_right (fun e res -> (fold_mutate_top_decl e)::res) prog [] |
||

581 | |||

582 | let create_mutant prog directive = |
||

583 | target := Some directive; |
||

584 | let prog' = fold_mutate_prog prog in |
||

585 | 55a8633c | ploc | let mutation_info = match !target , !mutation_info with |

586 | | None, Some mi -> mi |
||

587 | 5487dd79 | ploc | | _ -> ( |

588 | Format.eprintf "Failed when creating mutant for directive %a@.@?" print_directive directive; |
||

589 | let _ = match !target with Some dir' -> Format.eprintf "New directive %a@.@?" print_directive dir' | _ -> () in |
||

590 | assert false (* The mutation has not been performed. *) |
||

591 | ) |
||

592 | 55a8633c | ploc | |

593 | in |
||

594 | (* target := None; (* should happen only if no mutation occured during the |
||

595 | visit *)*) |
||

596 | prog', mutation_info |
||

597 | 40d33d55 | xavier.thirioux | |

598 | |||

599 | let op_mutation op = |
||

600 | let res = |
||

601 | let rem_op l = List.filter (fun e -> e <> op) l in |
||

602 | if List.mem op arith_op then rem_op arith_op else |
||

603 | if List.mem op bool_op then rem_op bool_op else |
||

604 | if List.mem op rel_op then rem_op rel_op else |
||

605 | (Format.eprintf "Failing with op %s@." op; |
||

606 | assert false |
||

607 | ) |
||

608 | in |
||

609 | (* Format.eprintf "Mutation op %s to [%a]@." op (Utils.fprintf_list ~sep:"," Format.pp_print_string) res; *) |
||

610 | res |
||

611 | |||

612 | let rec remains select list = |
||

613 | match list with |
||

614 | [] -> [] |
||

615 | | hd::tl -> if select hd then tl else remains select tl |
||

616 | |||

617 | let next_change m = |
||

618 | let res = |
||

619 | let rec first_op () = |
||

620 | try |
||

621 | let min_binding = OpCount.min_binding !records.nb_op in |
||

622 | Op (fst min_binding, 0, List.hd (op_mutation (fst min_binding))) |
||

623 | with Not_found -> first_boolexpr () |
||

624 | and first_boolexpr () = |
||

625 | if !records.nb_boolexpr > 0 then |
||

626 | Boolexpr 0 |
||

627 | else first_pre () |
||

628 | and first_pre () = |
||

629 | if !records.nb_pre > 0 then |
||

630 | Pre 0 |
||

631 | else |
||

632 | first_op () |
||

633 | and first_intcst () = |
||

634 | if IntSet.cardinal !records.consts > 0 then |
||

635 | IncrIntCst 0 |
||

636 | else |
||

637 | first_boolexpr () |
||

638 | in |
||

639 | match m with |
||

640 | | Boolexpr n -> |
||

641 | if n+1 >= !records.nb_boolexpr then |
||

642 | first_pre () |
||

643 | else |
||

644 | Boolexpr (n+1) |
||

645 | | Pre n -> |
||

646 | if n+1 >= !records.nb_pre then |
||

647 | first_op () |
||

648 | else Pre (n+1) |
||

649 | | Op (orig, id, mut_op) -> ( |
||

650 | match remains (fun x -> x = mut_op) (op_mutation orig) with |
||

651 | | next_op::_ -> Op (orig, id, next_op) |
||

652 | | [] -> if id+1 >= OpCount.find orig !records.nb_op then ( |
||

653 | match remains (fun (k1, _) -> k1 = orig) (OpCount.bindings !records.nb_op) with |
||

654 | | [] -> first_intcst () |
||

655 | | hd::_ -> Op (fst hd, 0, List.hd (op_mutation (fst hd))) |
||

656 | ) else |
||

657 | Op(orig, id+1, List.hd (op_mutation orig)) |
||

658 | ) |
||

659 | | IncrIntCst n -> |
||

660 | if n+1 >= IntSet.cardinal !records.consts then |
||

661 | DecrIntCst 0 |
||

662 | else IncrIntCst (n+1) |
||

663 | | DecrIntCst n -> |
||

664 | if n+1 >= IntSet.cardinal !records.consts then |
||

665 | SwitchIntCst (0, 0) |
||

666 | else DecrIntCst (n+1) |
||

667 | | SwitchIntCst (n, m) -> |
||

668 | if m+1 > -1 + IntSet.cardinal !records.consts then |
||

669 | SwitchIntCst (n, m+1) |
||

670 | else if n+1 >= IntSet.cardinal !records.consts then |
||

671 | SwitchIntCst (n+1, 0) |
||

672 | else first_boolexpr () |
||

673 | |||

674 | in |
||

675 | 5487dd79 | ploc | (* Format.eprintf "from: %a to: %a@." print_directive m print_directive res; *) |

676 | 40d33d55 | xavier.thirioux | res |

677 | |||

678 | let fold_mutate nb prog = |
||

679 | incr random_seed; |
||

680 | Random.init !random_seed; |
||

681 | 5d5139a5 | ploc | (* Local references to keep track of generated directives *) |

682 | |||

683 | (* build a set of integer 0, 1, ... n-1 for input n *) |
||

684 | let cpt_to_intset cpt = |
||

685 | let arr = Array.init cpt (fun x -> x) in |
||

686 | Array.fold_right IntSet.add arr IntSet.empty |
||

687 | in |
||

688 | |||

689 | let possible_const_id = cpt_to_intset !records.nb_consts in |
||

690 | (* let possible_boolexpr_id = cpt_to_intset !records.nb_boolexpr in *) |
||

691 | (* let possible_pre_id = cpt_to_intset !records.nb_pre in *) |
||

692 | |||

693 | let incremented_const_id = ref IntSet.empty in |
||

694 | let decremented_const_id = ref IntSet.empty in |
||

695 | |||

696 | let create_new_incr_decr registered build = |
||

697 | let possible = IntSet.diff possible_const_id !registered |> IntSet.elements in |
||

698 | let len = List.length possible in |
||

699 | if len <= 0 then |
||

700 | false, build (-1) (* Should not be stored *) |
||

701 | else |
||

702 | let picked = List.nth possible (Random.int (List.length possible)) in |
||

703 | registered := IntSet.add picked !registered; |
||

704 | true, build picked |
||

705 | in |
||

706 | |||

707 | |||

708 | let module DblIntSet = Set.Make (struct type t = int * int let compare = compare end) in |
||

709 | let switch_const_id = ref DblIntSet.empty in |
||

710 | let switch_set = |
||

711 | if IntSet.cardinal !records.consts <= 1 then |
||

712 | DblIntSet.empty |
||

713 | else |
||

714 | (* First element is cst id (the ith cst) while second is the |
||

715 | ith element of the set of gathered constants |
||

716 | !record.consts *) |
||

717 | IntSet.fold (fun cst_id set -> |
||

718 | 4c3c6658 | ploc | IntSet.fold (fun ith_cst set -> |

719 | DblIntSet.add (cst_id, ith_cst) set |
||

720 | ) !records.consts set |
||

721 | ) possible_const_id DblIntSet.empty |
||

722 | 5d5139a5 | ploc | in |

723 | |||

724 | let create_new_switch registered build = |
||

725 | let possible = DblIntSet.diff switch_set !registered |> DblIntSet.elements in |
||

726 | let len = List.length possible in |
||

727 | if len <= 0 then |
||

728 | false, build (-1,-1) (* Should not be stored *) |
||

729 | else |
||

730 | let picked = List.nth possible (Random.int (List.length possible)) in |
||

731 | registered := DblIntSet.add picked !registered; |
||

732 | true, build picked |
||

733 | in |
||

734 | |||

735 | 40d33d55 | xavier.thirioux | let find_next_new mutants mutant = |

736 | let rec find_next_new init current = |
||

737 | 5487dd79 | ploc | if init = current || List.mem current mutants then raise Not_found else |

738 | |||

739 | 5d5139a5 | ploc | (* TODO: check if we can generate more cases. The following lines were |

740 | cylcing and missing to detect that the enumaration was complete, |
||

741 | leading to a non terminating process. The current setting is harder |
||

742 | but may miss enumerating some cases. To be checked! *) |
||

743 | 5487dd79 | ploc | |

744 | 5d5139a5 | ploc | (* if List.mem current mutants then *) |

745 | (* find_next_new init (next_change current) *) |
||

746 | (* else *) |
||

747 | 5487dd79 | ploc | current |

748 | 40d33d55 | xavier.thirioux | in |

749 | find_next_new mutant (next_change mutant) |
||

750 | in |
||

751 | (* Creating list of nb elements of mutants *) |
||

752 | let rec create_mutants_directives rnb mutants = |
||

753 | if rnb <= 0 then mutants |
||

754 | 5487dd79 | ploc | else |

755 | (* Initial list of transformation *) |
||

756 | let rec init_list x = if x <= 0 then [0] else x::(init_list (x-1)) in |
||

757 | let init_list = init_list 5 in |
||

758 | (* We generate a random permutation of the list: the first item is the |
||

759 | transformation, the rest of the list act as fallback choices to make |
||

760 | sure we produce something *) |
||

761 | let shuffle l = |
||

762 | let nd = List.map (fun c -> Random.bits (), c) l in |
||

763 | let sond = List.sort compare nd in |
||

764 | List.map snd sond |
||

765 | in |
||

766 | let transforms = shuffle init_list in |
||

767 | let rec apply_transform transforms = |
||

768 | let f id = |
||

769 | match id with |
||

770 | 5d5139a5 | ploc | | 5 -> create_new_incr_decr incremented_const_id (fun x -> IncrIntCst x) |

771 | | 4 -> create_new_incr_decr decremented_const_id (fun x -> DecrIntCst x) |
||

772 | | 3 -> create_new_switch switch_const_id (fun (x,y) -> SwitchIntCst(x, y)) |
||

773 | 5487dd79 | ploc | | 2 -> !records.nb_pre >0, Pre (try Random.int !records.nb_pre with _ -> 0) |

774 | | 1 -> !records.nb_boolexpr > 0, Boolexpr (try Random.int !records.nb_boolexpr with _ -> 0) |
||

775 | | 0 -> let bindings = OpCount.bindings !records.nb_op in |
||

776 | let bindings_len = List.length bindings in |
||

777 | 4c3c6658 | ploc | if bindings_len > 0 then |

778 | let op, nb_op = List.nth bindings (try Random.int bindings_len with _ -> 0) in |
||

779 | let op_mut = op_mutation op in |
||

780 | let new_op = List.nth op_mut (try Random.int (List.length op_mut) with _ -> 0) in |
||

781 | true, Op (op, (try Random.int nb_op with _ -> 0), new_op) |
||

782 | else |
||

783 | false, Boolexpr 0 (* Providing a dummy construct, |
||

784 | it will be filtered out thanks |
||

785 | to the negative status (fst = |
||

786 | false) *) |
||

787 | 5487dd79 | ploc | | _ -> assert false |

788 | in |
||

789 | match transforms with |
||

790 | | [] -> assert false |
||

791 | | [hd] -> f hd |
||

792 | | hd::tl -> let ok, random_mutation = f hd in |
||

793 | if ok then |
||

794 | ok, random_mutation |
||

795 | else |
||

796 | apply_transform tl |
||

797 | 40d33d55 | xavier.thirioux | in |

798 | 5487dd79 | ploc | let ok, random_mutation = apply_transform transforms in |

799 | let stop_process () = |
||

800 | report ~level:1 (fun fmt -> fprintf fmt |
||

801 | 4c3c6658 | ploc | "Only %i mutants directives generated out of %i expected@ " |

802 | (nb-rnb) |
||

803 | nb); |
||

804 | 5487dd79 | ploc | mutants |

805 | in |
||

806 | if not ok then |
||

807 | stop_process () |
||

808 | else if List.mem random_mutation mutants then |
||

809 | 40d33d55 | xavier.thirioux | try |

810 | let new_mutant = (find_next_new mutants random_mutation) in |
||

811 | 5d5139a5 | ploc | report ~level:2 (fun fmt -> fprintf fmt " %i mutants directive generated out of %i expected@ " (nb-rnb) nb); |

812 | 5487dd79 | ploc | create_mutants_directives (rnb-1) (new_mutant::mutants) |

813 | 40d33d55 | xavier.thirioux | with Not_found -> ( |

814 | 5487dd79 | ploc | stop_process () |

815 | 40d33d55 | xavier.thirioux | ) |

816 | 5487dd79 | ploc | else ( |

817 | 40d33d55 | xavier.thirioux | create_mutants_directives (rnb-1) (random_mutation::mutants) |

818 | 5487dd79 | ploc | ) |

819 | 40d33d55 | xavier.thirioux | in |

820 | let mutants_directives = create_mutants_directives nb [] in |
||

821 | 55a8633c | ploc | List.map (fun d -> |

822 | 4c3c6658 | ploc | let mutant, loc = create_mutant prog d in |

823 | d, loc, mutant ) mutants_directives |
||

824 | 40d33d55 | xavier.thirioux | |

825 | |||

826 | let mutate nb prog = |
||

827 | records := compute_records prog; |
||

828 | (* Format.printf "Records: %i pre, %i boolexpr" (\* , %a ops *\) *) |
||

829 | (* !records.nb_pre *) |
||

830 | (* !records.nb_boolexpr *) |
||

831 | (* (\* !records.op *\) *) |
||

832 | (* ; *) |
||

833 | 55a8633c | ploc | fold_mutate nb prog |

834 | 40d33d55 | xavier.thirioux | |

835 | |||

836 | |||

837 | |||

838 | (* Local Variables: *) |
||

839 | (* compile-command:"make -C .." *) |
||

840 | (* End: *) |
||

841 | |||

842 |