package p4spectec

  1. Overview
  2. Docs
package p4spectec
Legend:
Page
Library
Module
Module type
Parameter
Class
Class type
Source

Source file config.ml

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
open Domain
open Lib
open Lang
open Sl
module DCov_single = Coverage.Dangling.Single
module DCov_multi = Coverage.Dangling.Multi
module Type = Runtime.Type
open Runtime.Testgen_neg
open Envs
module Sim = Runtime.Sim.Signature

(* Hyperparameters for the fuzzing loop *)

(* Max number of seeds per dangle *)
let samples_close_miss = 3

(* Max number of related vids to derive from per seed *)
let samples_related_vid = 10

(* Max number of close-ASTs per seed *)
let samples_derivation_source = 10

(* Max number of mutation trials per close-AST *)
let trials_mutation = 5

(* Trials per seed *)
let trials_seed = 50

(* Timeout per seed *)
let timeout_seed = 30

(* Environment for the spec *)
type specenv = {
  simulator : (module Sim.SIM);
  printer : Sl.value -> string;
  spec : Sim.spec;
  relname : string;
  tdenv : TDEnv.t;
  mixopenv : MixopEnv.t;
  includes_p4 : string list;
}

(* Storage for generated files *)

type storage = {
  dirname_gen : string;
  dirname_log : string;
  dirname_query : string;
  dirname_close_miss_p4 : string;
  dirname_welltyped_p4 : string;
  dirname_illtyped_p4 : string;
}

(* Seed for the fuzz campaign *)

type seed = { mutable cover : DCov_multi.Cover.t }

(* Configuration for the fuzz campaign *)

type t = {
  rand : int;
  modes : Modes.t;
  specenv : specenv;
  storage : storage;
  seed : seed;
}

(* Load mixop groups into the environment *)

let load_mixops (mixopenv : MixopEnv.t) (def : def) : MixopEnv.t =
  match def.it with
  | TypD (id, _, deftyp, _) -> (
      match deftyp.it with
      | VariantT typcases ->
          let nottyps = List.map (fun (nottyp, _, _) -> nottyp) typcases in
          let insert_into_groups (typed_groups : (typ list * MixIdSet.t) list)
              (nottyp : nottyp) : (typ list * MixIdSet.t) list =
            let mixop, typs = Mixfix.split nottyp.it in
            let rec insert_into_groups' typed_group = function
              | [] -> (typs, MixIdSet.singleton mixop) :: typed_group
              | (typs_found, group) :: rest ->
                  if List.equal Sl.Eq.eq_typ typs typs_found then
                    (typs, MixIdSet.add mixop group)
                    :: (List.rev typed_group @ rest)
                  else insert_into_groups' ((typs, group) :: typed_group) rest
            in
            insert_into_groups' [] typed_groups
          in
          let typed_groups_new =
            List.fold_left insert_into_groups [] nottyps
            |> List.filter (fun (_, mixop_group) ->
                   MixIdSet.cardinal mixop_group > 1)
          in
          if List.length typed_groups_new = 0 then mixopenv
          else
            let mixop_family_orig =
              MixopEnv.find_opt id mixopenv
              |> Option.value ~default:Mixops.Family.empty
            in
            let mixop_family =
              List.fold_left
                (fun mixop_family (_, mixop_group) ->
                  Mixops.Family.add mixop_group mixop_family)
                mixop_family_orig typed_groups_new
            in
            MixopEnv.add id mixop_family mixopenv
      | PlainT { it = VarT (id_alias, _); _ } ->
          let mixop_family =
            MixopEnv.find_opt id_alias mixopenv
            |> Option.value ~default:Mixops.Family.empty
          in
          MixopEnv.add id mixop_family mixopenv
      | _ -> mixopenv)
  | _ -> mixopenv

(* Load type definitions into the environment *)

let load_def (tdenv : TDEnv.t) (def : def) : TDEnv.t =
  match def.it with
  | ExternTypD (id, _) ->
      let td = Type.Typdef.Extern in
      TDEnv.add id td tdenv
  | TypD (id, tparams, deftyp, _) ->
      let td = Type.Typdef.Defined (tparams, deftyp) in
      TDEnv.add id td tdenv
  | _ -> tdenv

(* Loader *)

let load_spec (tdenv : TDEnv.t) (mixopenv : MixopEnv.t) (spec : spec) :
    TDEnv.t * MixopEnv.t =
  let tdenv = List.fold_left load_def tdenv spec in
  let mixopenv = List.fold_left load_mixops mixopenv spec in
  (tdenv, mixopenv)

(* Constructor *)

let init_specenv (spec : spec) (relname : string) (includes_p4 : string list) :
    specenv =
  let (module Simulator : Sim.SIM) = Backend_sim.Build.gen_p4_placeholder () in
  Simulator.init (Sim.SL spec);
  let simulator = (module Simulator : Sim.SIM) in
  let printer value_program =
    Simulator.Interface.unparse_program value_program
  in
  let tdenv, mixopenv = load_spec TDEnv.empty MixopEnv.empty spec in
  let spec = Sim.SL spec in
  { simulator; printer; spec; relname; tdenv; mixopenv; includes_p4 }

let init_storage (dirname_gen : string) : storage =
  Util.Filesys.mkdir dirname_gen;
  let dirname_log = dirname_gen ^ "/log" in
  Util.Filesys.mkdir dirname_log;
  let dirname_query = dirname_gen ^ "/query" in
  Util.Filesys.mkdir dirname_query;
  let dirname_close_miss_p4 = dirname_gen ^ "/closemiss" in
  Util.Filesys.mkdir dirname_close_miss_p4;
  let dirname_welltyped_p4 = dirname_gen ^ "/welltyped" in
  Util.Filesys.mkdir dirname_welltyped_p4;
  let dirname_illtyped_p4 = dirname_gen ^ "/illtyped" in
  Util.Filesys.mkdir dirname_illtyped_p4;
  {
    dirname_gen;
    dirname_log;
    dirname_query;
    dirname_close_miss_p4;
    dirname_welltyped_p4;
    dirname_illtyped_p4;
  }

let init_seed (cover : DCov_multi.t) : seed = { cover }

let init (randseed : int option) (modes : Modes.t) (specenv : specenv)
    (storage : storage) (seed : seed) =
  let rand = Option.value ~default:2025 randseed in
  Random.init rand;
  { rand; modes; specenv; storage; seed }

(* Seed updater *)

let update_hit_seed (config : t) (filename_p4 : string) (welltyped : bool)
    (iids_hit : IIdSet.t) : unit =
  let cover_seed = config.seed.cover in
  let cover_seed =
    IIdSet.fold
      (fun iid_hit cover_seed ->
        let branch : DCov_multi.Branch.t =
          DCov_multi.Cover.find iid_hit cover_seed
        in
        let branch =
          match branch.status with
          | Hit (likely, filenames_p4) ->
              let likely = likely && not welltyped in
              let filenames_p4 = filename_p4 :: filenames_p4 in
              DCov_multi.Branch.
                { branch with status = Hit (likely, filenames_p4) }
          | _ ->
              let likely = not welltyped in
              let filenames_p4 = [ filename_p4 ] in
              DCov_multi.Branch.
                { branch with status = Hit (likely, filenames_p4) }
        in
        DCov_multi.Cover.add iid_hit branch cover_seed)
      iids_hit cover_seed
  in
  config.seed.cover <- cover_seed

let update_close_miss_seed (config : t) (filename_p4 : string)
    (iids_close_miss : IIdSet.t) : unit =
  let cover_seed = config.seed.cover in
  let cover_seed =
    IIdSet.fold
      (fun iid_close_miss cover_seed ->
        let branch = DCov_multi.Cover.find iid_close_miss cover_seed in
        let branch =
          DCov_multi.Branch.{ branch with status = Miss [ filename_p4 ] }
        in
        DCov_multi.Cover.add iid_close_miss branch cover_seed)
      iids_close_miss cover_seed
  in
  config.seed.cover <- cover_seed