rleonid / bisect_ppx / 367

Committed 30 Jan 2016 - 18:52 coverage: 75.174%. First build

Build # 367

Build Type

Pull #73

travis-ci

Committed by

aantron

Commit Message

Submit coverage reports to Coveralls

Pull Request Pull Request #73: Submit coverage reports to Coveralls

Run Details

1078 of 1434 relevant lines covered (75.17%)

188.71 hits per line

Source File
Press 'n' to go to next uncovered line, 'b' for previous

99.19

/src/syntax/instrumentPpx.ml

(*
 * This file is part of Bisect.
 * Copyright (C) 2008-2012 Xavier Clerc.
 *
 * Bisect is free software; you can redistribute it and/or modify
 * it under the terms of the GNU General Public License as published by
 * the Free Software Foundation; either version 3 of the License, or
 * (at your option) any later version.
 *
 * Bisect is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program.  If not, see <http://www.gnu.org/licenses/>.
 *)

open Parsetree
open Asttypes
open Ast_mapper
open Ast_helper

let intconst x =
  Exp.constant (Const_int x)

let lid ?(loc = Location.none) s =
  Location.mkloc (Longident.parse s) loc

let constr id =
  let t = Location.mkloc (Longident.parse id) Location.none in
  Exp.construct t None

let unitconst () = constr "()"

let strconst s =
  Exp.constant (Const_string (s, None))

let string_of_ident ident =
  String.concat "." (Longident.flatten ident.txt)

let apply_nolabs ?loc lid el =
  Exp.apply ?loc
    (Exp.ident ?loc lid)
    (List.map (fun e -> ("",e)) el)

let custom_mark_function file =
  Printf.sprintf "___bisect_mark___%s"
    (* Turn's out that the variable name syntax isn't checked again,
       so directory separtors '\' seem to be fine,
       and this extension chop might not be necessary. *)
    (Filename.chop_extension file)

let case_variable = "___bisect_matched_value___"

(* Evaluates to a point at the given location. If the point does not yet exist,
   creates it with the given kind. The point is paired with a flag indicating
   whether it exited before this function was called. *)
let get_point file ofs kind marked =
  let lst = InstrumentState.get_points_for_file file in

  let maybe_existing =
    try Some (List.find (fun p -> p.Common.offset = ofs) lst)
    with Not_found -> None
  in

  match maybe_existing with
  | Some pt -> pt, true
  | None ->
    let idx = List.length lst in
    if marked then InstrumentState.add_marked_point idx;
    let pt = { Common.offset = ofs; identifier = idx; kind = kind } in
    InstrumentState.set_points_for_file file (pt :: lst);
    pt, false

(* Creates the marking expression for given file, offset, and kind.
   Populates the 'points' global variable. *)
let marker must_be_unique file ofs kind marked =
  let { Common.identifier = idx; _ }, existing =
    get_point file ofs kind marked in
  if must_be_unique && existing then
    None
  else
    let loc = Location.none in
    let wrapped =
      apply_nolabs ~loc (lid (custom_mark_function file)) [intconst idx] in
    Some wrapped

(* Wraps an expression with a marker, returning the passed expression
   unmodified if the expression is already marked, has a ghost location,
   construct instrumentation is disabled, or a special comments indicates to
   ignore line. *)
let wrap_expr ?(must_be_unique = true) ?loc k e =
  let enabled = List.assoc k InstrumentArgs.kinds in
  let loc =
    match loc with
    | None -> e.pexp_loc
    | Some loc -> loc
  in
  if loc.Location.loc_ghost || not !enabled then
    e
  else
    let ofs = loc.Location.loc_start.Lexing.pos_cnum in
    (* Different files because of the line directive *)
    let file = loc.Location.loc_start.Lexing.pos_fname in
    let line = loc.Location.loc_start.Lexing.pos_lnum in
    let c = CommentsPpx.get file in
    let ignored =
      List.exists
        (fun (lo, hi) ->
          line >= lo && line <= hi)
        c.CommentsPpx.ignored_intervals
    in
    if ignored then
      e
    else
      let marked = List.mem line c.CommentsPpx.marked_lines in
      let marker_file = !Location.input_name in
      match marker must_be_unique marker_file ofs k marked with
      | Some w -> Exp.sequence ~loc w e
      | None   -> e

(* Given a pattern and a location, transforms the pattern into pattern list by
   eliminating all or-patterns and promoting them into separate cases. Each
   resulting case is paired with a list of locations to mark if that case is
   reached.

   The location argument to this function is used for assembling these location
   lists. It is set to the location of the nearest enclosing or-pattern clause.
   When there is no such clause, it is set to the location of the entire
   enclosing pattern. *)
let translate_pattern =
  (* n-ary Cartesion product of case patterns. Used for assembling case lists
     for "and-patterns" such as tuples and arrays. *)
  let product = function
    | [] -> []
    | cases::more ->
      let multiply product cases =
        product |> List.map (fun (marks_1, ps) ->
          cases |> List.map (fun (marks_2, p) ->
            marks_1 @ marks_2, ps @ [p]))
        |> List.flatten
      in

      let initial = cases |> List.map (fun (marks, p) -> marks, [p]) in

      List.fold_left multiply initial more
  in

  let rec translate mark p =
    let loc = p.ppat_loc in
    let attrs = p.ppat_attributes in

    match p.ppat_desc with
    | Ppat_any | Ppat_var _ | Ppat_constant _ | Ppat_interval _
    | Ppat_construct (_, None) | Ppat_variant (_, None) | Ppat_type _
    | Ppat_unpack _ | Ppat_extension _ ->
      [[mark], p]

    | Ppat_alias (p', x) ->
      translate mark p'
      |> List.map (fun (marks, p'') -> marks, Pat.alias ~loc ~attrs p'' x)

    | Ppat_tuple ps ->
      ps
      |> List.map (translate mark)
      |> product
      |> List.map (fun (marks, ps') -> marks, Pat.tuple ~loc ~attrs ps')

    | Ppat_construct (c, Some p') ->
      translate mark p'
      |> List.map (fun (marks, p'') ->
        marks, Pat.construct ~loc ~attrs c (Some p''))

    | Ppat_variant (c, Some p') ->
      translate mark p'
      |> List.map (fun (marks, p'') ->
        marks, Pat.variant ~loc ~attrs c (Some p''))

    | Ppat_record (entries, closed) ->
      let labels, ps = List.split entries in
      ps
      |> List.map (translate mark)
      |> product
      |> List.map (fun (marks, ps') ->
        marks, Pat.record ~loc ~attrs (List.combine labels ps') closed)

    | Ppat_array ps ->
      ps
      |> List.map (translate mark)
      |> product
      |> List.map (fun (marks, ps') -> marks, Pat.array ~loc ~attrs ps')

    | Ppat_or (p_1, p_2) ->
      let ps_1 = translate p_1.ppat_loc p_1 in
      let ps_2 = translate p_2.ppat_loc p_2 in
      ps_1 @ ps_2

    | Ppat_constraint (p', t) ->
      translate mark p'
      |> List.map (fun (marks, p'') -> marks, Pat.constraint_ ~loc ~attrs p'' t)

    | Ppat_lazy p' ->
      translate mark p'
      |> List.map (fun (marks, p'') -> marks, Pat.lazy_ ~loc ~attrs p'')

    (* This should be unreachable in well-formed code, but, if it is reached,
       do not generate any cases. The cases would be used in a secondary match
       expression that works on the same value as the match expression (or
       function expression) that is being instrumented. Inside that expression,
       it makes no sense to match a second time for effects such as
       exceptions. *)
    | Ppat_exception _ -> []
  in

  translate

(* Wraps a match or function case. A transformed pattern list is first created,
   where all or-patterns are promoted to top-level patterns. If there is only
   one resulting top-level pattern, wrap_case inserts a single point and marking
   expression. If there are multiple top-level patterns, wrap_case inserts a
   match expression that determines, at runtime, which one is matched, and
   increments the appropriate point counts. *)
let wrap_case k case =
  let maybe_guard =
    match case.pc_guard with
    | None -> None
    | Some guard -> Some (wrap_expr k guard)
  in

  let pattern = case.pc_lhs in
  let loc = pattern.ppat_loc in

  if !InstrumentArgs.simple_cases then
    Exp.case pattern ?guard:maybe_guard (wrap_expr ~loc k case.pc_rhs)
  else
    (* If this is an exception case, work with the pattern inside the exception
       instead. *)
    let pure_pattern, reassemble =
      match pattern.ppat_desc with
      | Ppat_exception p ->
        p, (fun p' -> {pattern with ppat_desc = Ppat_exception p'})
      | _ -> pattern, (fun p -> p)
    in

    let increments e marks =
      marks
      |> List.sort_uniq (fun l l' ->
        l.Location.loc_start.Lexing.pos_cnum -
        l'.Location.loc_start.Lexing.pos_cnum)
      |> List.fold_left (fun e l ->
        wrap_expr ~must_be_unique:false ~loc:l k e) e
    in

    match translate_pattern loc pure_pattern with
    | [] ->
      Exp.case pattern ?guard:maybe_guard (wrap_expr ~loc k case.pc_rhs)
    | [marks, _] ->
      Exp.case pattern ?guard:maybe_guard (increments case.pc_rhs marks)
    | cases ->
      let cases =
        if !InstrumentArgs.inexhaustive_matching then cases
        else cases @ [[], Pat.any ~loc ()]
      in

      let wrapped_pattern =
        Pat.alias ~loc pure_pattern (Location.mkloc case_variable loc) in

      let marks_expr =
        cases
        |> List.map (fun (marks, pattern) ->
          Exp.case pattern (increments (unitconst ()) marks))
        |> Exp.match_ ~loc (Exp.ident (lid ~loc case_variable))
      in

      (* Suppress warnings because the generated match expression will almost
         never be exhaustive. It may also have redundant cases or unused
         variables. *)
      let marks_expr =
        Exp.attr marks_expr
          (Location.mkloc "ocaml.warning" loc,
            PStr [Str.eval (strconst "-4-8-9-11-26-27-28")])
      in

      Exp.case (reassemble wrapped_pattern) ?guard:maybe_guard
        (Exp.sequence ~loc marks_expr case.pc_rhs)

let wrap_class_field_kind k = function
  | Cfk_virtual _ as cf -> cf
  | Cfk_concrete (o,e)  -> Cf.concrete o (wrap_expr k e)

let pattern_var id =
  Pat.var (Location.mkloc id Location.none)

(* This method is stateful and depends on `InstrumentState.set_points_for_file`
   having been run on all the points in the rest of the AST. *)
let faster file =
  let nb = List.length (InstrumentState.get_points_for_file file) in
  let ilid s = Exp.ident (lid s) in
  let init =
    apply_nolabs
      (lid ((!InstrumentArgs.runtime_name) ^ ".Runtime.init_with_array"))
      [strconst file; ilid "marks"]
  in
  let make = apply_nolabs (lid "Array.make") [intconst nb; intconst 0] in
  let marks =
    List.fold_left
      (fun acc (idx, nb) ->
        let mark =
          apply_nolabs (lid "Array.set") [ ilid "marks"; intconst idx; intconst nb]
        in
        Exp.sequence acc mark)
      init
      (InstrumentState.get_marked_points_assoc ()) in
  let func =
    let body =
      let if_then_else =
        Exp.ifthenelse
            (apply_nolabs (lid "<") [ilid "curr"; ilid "Pervasives.max_int"])
            (apply_nolabs (lid "Pervasives.succ") [ilid "curr"])
            (Some (ilid "curr"))
      in
      let vb =
        Vb.mk (pattern_var "curr")
              (apply_nolabs (lid "Array.get") [ilid "marks"; ilid "idx"])
      in
      Exp.let_ Nonrecursive [vb]
          (apply_nolabs
              (lid "Array.set")
              [ilid "marks"; ilid "idx"; if_then_else])
    in
    Exp.(function_ [ case (pattern_var "idx") body ])
  in
  let vb = [(Vb.mk (pattern_var "marks") make)] in
  let e =
    Exp.(let_ Nonrecursive vb (sequence marks func))
  in
  Str.value Nonrecursive [ Vb.mk (pattern_var (custom_mark_function file)) e]

(* The actual "instrumenter" object, marking expressions. *)
class instrumenter = object (self)

  inherit Ast_mapper_class.mapper as super

  method! class_expr ce =
    let loc = ce.pcl_loc in
    let ce = super#class_expr ce in
    match ce.pcl_desc with
    | Pcl_apply (ce, l) ->
        let l =
          List.map
            (fun (l, e) ->
              (l, (wrap_expr Common.Class_expr e)))
            l in
        Cl.apply ~loc ~attrs:ce.pcl_attributes ce l
    | _ ->
        ce

  method! class_field cf =
    let loc = cf.pcf_loc in
    let attrs = cf.pcf_attributes in
    let cf = super#class_field cf in
    match cf.pcf_desc with
    | Pcf_val (id, mut, cf) ->
        Cf.val_ ~loc ~attrs id mut (wrap_class_field_kind Common.Class_val cf)
    | Pcf_method (id, mut, cf) ->
        Cf.method_ ~loc ~attrs id mut
          (wrap_class_field_kind Common.Class_meth cf)
    | Pcf_initializer e ->
        Cf.initializer_ ~loc ~attrs (wrap_expr Common.Class_init e)
    | _ ->
        cf

  val mutable extension_guard = false
  val mutable attribute_guard = false

  method! expr e =
    if attribute_guard || extension_guard then
      super#expr e
    else
      let loc = e.pexp_loc in
      let attrs = e.pexp_attributes in
      let e' = super#expr e in
      match e'.pexp_desc with
      | Pexp_let (rec_flag, l, e) ->
          let l =
            List.map (fun vb ->
            {vb with pvb_expr = wrap_expr Common.Sequence vb.pvb_expr}) l in
          Exp.let_ ~loc ~attrs rec_flag l (wrap_expr Common.Sequence e)
      | Pexp_poly (e, ct) ->
          Exp.poly ~loc ~attrs (wrap_expr Common.Sequence e) ct
      | Pexp_fun (al, eo, p, e) ->
          let eo = map_opt (wrap_expr Common.Match) eo in
          Exp.fun_ ~loc ~attrs al eo p (wrap_expr Common.Match e)
      | Pexp_apply (e1, [l2, e2; l3, e3]) ->
          (match e1.pexp_desc with
          | Pexp_ident ident
            when
              List.mem (string_of_ident ident) [ "&&"; "&"; "||"; "or" ] ->
                Exp.apply ~loc ~attrs e1
                  [l2, (wrap_expr Common.Lazy_operator e2);
                  l3, (wrap_expr Common.Lazy_operator e3)]
          | Pexp_ident ident when string_of_ident ident = "|>" ->
            Exp.apply ~loc ~attrs e1
              [l2, e2; l3, (wrap_expr Common.Sequence e3)]
          | _ -> e')
      | Pexp_match (e, l) ->
          List.map (wrap_case Common.Match) l
          |> Exp.match_ ~loc ~attrs e
      | Pexp_function l ->
          List.map (wrap_case Common.Match) l
          |> Exp.function_ ~loc ~attrs
      | Pexp_try (e, l) ->
          List.map (wrap_case Common.Try) l
          |> Exp.try_ ~loc ~attrs e
      | Pexp_ifthenelse (e1, e2, e3) ->
          Exp.ifthenelse ~loc ~attrs e1 (wrap_expr Common.If_then e2)
            (match e3 with Some x -> Some (wrap_expr Common.If_then x) | None -> None)
      | Pexp_sequence (e1, e2) ->
          Exp.sequence ~loc ~attrs e1 (wrap_expr Common.Sequence e2)
      | Pexp_while (e1, e2) ->
          Exp.while_ ~loc ~attrs e1 (wrap_expr Common.While e2)
      | Pexp_for (id, e1, e2, dir, e3) ->
          Exp.for_ ~loc ~attrs id e1 e2 dir (wrap_expr Common.For e3)
      | _ -> e'

  method! structure_item si =
    let loc = si.pstr_loc in
    match si.pstr_desc with
    | Pstr_value (rec_flag, l) ->
        let l =
          List.map (fun vb ->     (* Only instrument things not excluded. *)
            { vb with pvb_expr =
                match vb.pvb_pat.ppat_desc with
                  (* Match the 'f' in 'let f x = ... ' *)
                | Ppat_var ident when Exclusions.contains
                      (ident.loc.Location.loc_start.Lexing.pos_fname)
                    ident.txt -> vb.pvb_expr
                  (* Match the 'f' in 'let f : type a. a -> string = ...' *)
                | Ppat_constraint (p,_) ->
                    begin
                      match p.ppat_desc with
                      | Ppat_var ident when Exclusions.contains
                          (ident.loc.Location.loc_start.Lexing.pos_fname)
                            ident.txt -> vb.pvb_expr
                      | _ ->
                        wrap_expr Common.Binding (self#expr vb.pvb_expr)
                    end
                | _ ->
                    wrap_expr Common.Binding (self#expr vb.pvb_expr)})
          l
        in
          Str.value ~loc rec_flag l
    | Pstr_eval (e, a) when not (attribute_guard || extension_guard) ->
        Str.eval ~loc ~attrs:a (wrap_expr Common.Toplevel_expr (self#expr e))
    | _ ->
        super#structure_item si

  (* Guard these because they can carry payloads that we
     do not want to instrument. *)
  method! extension e =
    extension_guard <- true;
    let r = super#extension e in
    extension_guard <- false;
    r

  method! attribute a =
    attribute_guard <- true;
    let r = super#attribute a in
    attribute_guard <- false;
    r

  (* Initializes storage and applies requested marks. *)
  method! structure ast =
    if extension_guard || attribute_guard then
      super#structure ast
    else
      let file = !Location.input_name in
      if file = "//toplevel//" ||
         file = "(stdin)" ||
         List.mem (Filename.basename file) [".ocamlinit"; "topfind"] then
        ast
      else
        if not (InstrumentState.is_file file) then
          begin
            (* We have to add this here, before we process the rest of the
               structure, because that may also have structures contained
               there-in, but we'll add the header after processing all of those
               declarations so that we know how many instrumentations there
               are. *)
            InstrumentState.add_file file;
            let rest = super#structure ast in
            let head = faster file in
            head :: rest
          end
        else
          super#structure ast

end

1	(*
2	* This file is part of Bisect.
3	* Copyright (C) 2008-2012 Xavier Clerc.
4	*
5	* Bisect is free software; you can redistribute it and/or modify
6	* it under the terms of the GNU General Public License as published by
7	* the Free Software Foundation; either version 3 of the License, or
8	* (at your option) any later version.
9	*
10	* Bisect is distributed in the hope that it will be useful,
11	* but WITHOUT ANY WARRANTY; without even the implied warranty of
12	* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
13	* GNU General Public License for more details.
14	*
15	* You should have received a copy of the GNU General Public License
16	* along with this program. If not, see <http://www.gnu.org/licenses/>.
17	*)
18
19	open Parsetree
20	open Asttypes
21	open Ast_mapper
22	open Ast_helper
23
24	let intconst x =
25	Exp.constant (Const_int x)	1,450×
26
27	let lid ?(loc = Location.none) s =	2,516×
28	Location.mkloc (Longident.parse s) loc	2,558×
29
30	let constr id =
31	let t = Location.mkloc (Longident.parse id) Location.none in	174×
32	Exp.construct t None	174×
33
34	let unitconst () = constr "()"	174×
35
36	let strconst s =
37	Exp.constant (Const_string (s, None))	124×
38
39	let string_of_ident ident =
40	String.concat "." (Longident.flatten ident.txt)	458×
41
42	let apply_nolabs ?loc lid el =
43	Exp.apply ?loc	1,776×
44	(Exp.ident ?loc lid)
45	(List.map (fun e -> ("",e)) el)	2,272×
46
47	let custom_mark_function file =
48	Printf.sprintf "___bisect_mark___%s"	1,364×
49	(* Turn's out that the variable name syntax isn't checked again,
50	so directory separtors '\' seem to be fine,
51	and this extension chop might not be necessary. *)
52	(Filename.chop_extension file)
53
54	let case_variable = "___bisect_matched_value___"	86×
55
56	(* Evaluates to a point at the given location. If the point does not yet exist,
57	creates it with the given kind. The point is paired with a flag indicating
58	whether it exited before this function was called. *)
59	let get_point file ofs kind marked =
60	let lst = InstrumentState.get_points_for_file file in	1,324×
61
62	let maybe_existing =	1,324×
63	try Some (List.find (fun p -> p.Common.offset = ofs) lst)	1,324×
64	with Not_found -> None	1,250×
65	in
66
67	match maybe_existing with	1,324×
68	\| Some pt -> pt, true	74×
69	\| None ->	1,250×
70	let idx = List.length lst in	1,250×
71	if marked then InstrumentState.add_marked_point idx;	2×
72	let pt = { Common.offset = ofs; identifier = idx; kind = kind } in	1,250×
73	InstrumentState.set_points_for_file file (pt :: lst);	1,250×
74	pt, false	1,250×
75
76	(* Creates the marking expression for given file, offset, and kind.
77	Populates the 'points' global variable. *)
78	let marker must_be_unique file ofs kind marked =
79	let { Common.identifier = idx; _ }, existing =	1,324×
80	get_point file ofs kind marked in	1,324×
81	if must_be_unique && existing then	934×
82	None	42×
83	else
84	let loc = Location.none in	1,282×
85	let wrapped =	1,282×
86	apply_nolabs ~loc (lid (custom_mark_function file)) [intconst idx] in	1,282×
87	Some wrapped	1,282×
88
89	(* Wraps an expression with a marker, returning the passed expression
90	unmodified if the expression is already marked, has a ghost location,
91	construct instrumentation is disabled, or a special comments indicates to
92	ignore line. *)
93	let wrap_expr ?(must_be_unique = true) ?loc k e =	1,194×
94	let enabled = List.assoc k InstrumentArgs.kinds in	1,584×
95	let loc =	1,584×
96	match loc with	1,584×
97	\| None -> e.pexp_loc	1,188×
98	\| Some loc -> loc	396×
99	in
100	if loc.Location.loc_ghost \|\| not !enabled then	1,350×
101	e	234×
102	else
103	let ofs = loc.Location.loc_start.Lexing.pos_cnum in	1,350×
104	(* Different files because of the line directive *)
105	let file = loc.Location.loc_start.Lexing.pos_fname in	1,350×
106	let line = loc.Location.loc_start.Lexing.pos_lnum in	1,350×
107	let c = CommentsPpx.get file in	1,350×
108	let ignored =	1,350×
109	List.exists	1,350×
110	(fun (lo, hi) ->
111	line >= lo && line <= hi)	82×
112	c.CommentsPpx.ignored_intervals
113	in
114	if ignored then	1,350×
115	e	26×
116	else
117	let marked = List.mem line c.CommentsPpx.marked_lines in	1,324×
118	let marker_file = !Location.input_name in	1,324×
119	match marker must_be_unique marker_file ofs k marked with	1,324×
120	\| Some w -> Exp.sequence ~loc w e	1,282×
121	\| None -> e	42×
122
123	(* Given a pattern and a location, transforms the pattern into pattern list by
124	eliminating all or-patterns and promoting them into separate cases. Each
125	resulting case is paired with a list of locations to mark if that case is
126	reached.
127
128	The location argument to this function is used for assembling these location
129	lists. It is set to the location of the nearest enclosing or-pattern clause.
130	When there is no such clause, it is set to the location of the entire
131	enclosing pattern. *)
132	let translate_pattern =
133	(* n-ary Cartesion product of case patterns. Used for assembling case lists
134	for "and-patterns" such as tuples and arrays. *)
135	let product = function	86×
136	\| [] -> []	2×
137	\| cases::more ->	30×
138	let multiply product cases =
139	product \|> List.map (fun (marks_1, ps) ->	32×
140	cases \|> List.map (fun (marks_2, p) ->	46×
141	marks_1 @ marks_2, ps @ [p]))	58×
142	\|> List.flatten	32×
143	in
144
145	let initial = cases \|> List.map (fun (marks, p) -> marks, [p]) in	30×
146
147	List.fold_left multiply initial more	30×
148	in
149
150	let rec translate mark p =	86×
151	let loc = p.ppat_loc in	536×
152	let attrs = p.ppat_attributes in	536×
153
154	match p.ppat_desc with	536×
155	\| Ppat_any \| Ppat_var _ \| Ppat_constant _ \| Ppat_interval _	2×
156	\| Ppat_construct (_, None) \| Ppat_variant (_, None) \| Ppat_type _	2×
157	\| Ppat_unpack _ \| Ppat_extension _ ->	!
158	[[mark], p]
159
160	\| Ppat_alias (p', x) ->	6×
161	translate mark p'
162	\|> List.map (fun (marks, p'') -> marks, Pat.alias ~loc ~attrs p'' x)	6×
163
164	\| Ppat_tuple ps ->	26×
165	ps
166	\|> List.map (translate mark)	26×
167	\|> product	26×
168	\|> List.map (fun (marks, ps') -> marks, Pat.tuple ~loc ~attrs ps')	26×
169
170	\| Ppat_construct (c, Some p') ->	4×
171	translate mark p'
172	\|> List.map (fun (marks, p'') ->	4×
173	marks, Pat.construct ~loc ~attrs c (Some p''))	8×
174
175	\| Ppat_variant (c, Some p') ->	8×
176	translate mark p'
177	\|> List.map (fun (marks, p'') ->	8×
178	marks, Pat.variant ~loc ~attrs c (Some p''))	10×
179
180	\| Ppat_record (entries, closed) ->	2×
181	let labels, ps = List.split entries in	2×
182	ps	2×
183	\|> List.map (translate mark)	2×
184	\|> product	2×
185	\|> List.map (fun (marks, ps') ->	2×
186	marks, Pat.record ~loc ~attrs (List.combine labels ps') closed)	8×
187
188	\| Ppat_array ps ->	4×
189	ps
190	\|> List.map (translate mark)	4×
191	\|> product	4×
192	\|> List.map (fun (marks, ps') -> marks, Pat.array ~loc ~attrs ps')	4×
193
194	\| Ppat_or (p_1, p_2) ->	102×
195	let ps_1 = translate p_1.ppat_loc p_1 in	102×
196	let ps_2 = translate p_2.ppat_loc p_2 in	102×
197	ps_1 @ ps_2	102×
198
199	\| Ppat_constraint (p', t) ->	2×
200	translate mark p'
201	\|> List.map (fun (marks, p'') -> marks, Pat.constraint_ ~loc ~attrs p'' t)	2×
202
203	\| Ppat_lazy p' ->	2×
204	translate mark p'
205	\|> List.map (fun (marks, p'') -> marks, Pat.lazy_ ~loc ~attrs p'')	2×
206
207	(* This should be unreachable in well-formed code, but, if it is reached,
208	do not generate any cases. The cases would be used in a secondary match
209	expression that works on the same value as the match expression (or
210	function expression) that is being instrumented. Inside that expression,
211	it makes no sense to match a second time for effects such as
212	exceptions. *)
213	\| Ppat_exception _ -> []	!
214	in
215
216	translate	86×
217
218	(* Wraps a match or function case. A transformed pattern list is first created,
219	where all or-patterns are promoted to top-level patterns. If there is only
220	one resulting top-level pattern, wrap_case inserts a single point and marking
221	expression. If there are multiple top-level patterns, wrap_case inserts a
222	match expression that determines, at runtime, which one is matched, and
223	increments the appropriate point counts. *)
224	let wrap_case k case =
225	let maybe_guard =	252×
226	match case.pc_guard with	252×
227	\| None -> None	234×
228	\| Some guard -> Some (wrap_expr k guard)	18×
229	in
230
231	let pattern = case.pc_lhs in	252×
232	let loc = pattern.ppat_loc in	252×
233
234	if !InstrumentArgs.simple_cases then	252×
235	Exp.case pattern ?guard:maybe_guard (wrap_expr ~loc k case.pc_rhs)	4×
236	else
237	(* If this is an exception case, work with the pattern inside the exception
238	instead. *)
239	let pure_pattern, reassemble =	248×
240	match pattern.ppat_desc with	248×
241	\| Ppat_exception p ->	2×
242	p, (fun p' -> {pattern with ppat_desc = Ppat_exception p'})	2×
243	\| _ -> pattern, (fun p -> p)	40×
244	in
245
246	let increments e marks =	248×
247	marks	378×
248	\|> List.sort_uniq (fun l l' ->	378×
249	l.Location.loc_start.Lexing.pos_cnum -	66×
250	l'.Location.loc_start.Lexing.pos_cnum)
251	\|> List.fold_left (fun e l ->	378×
252	wrap_expr ~must_be_unique:false ~loc:l k e) e	390×
253	in
254
255	match translate_pattern loc pure_pattern with	248×
256	\| [] ->	2×
257	Exp.case pattern ?guard:maybe_guard (wrap_expr ~loc k case.pc_rhs)
258	\| [marks, _] ->	204×
259	Exp.case pattern ?guard:maybe_guard (increments case.pc_rhs marks)
260	\| cases ->	42×
261	let cases =
262	if !InstrumentArgs.inexhaustive_matching then cases	18×
263	else cases @ [[], Pat.any ~loc ()]	24×
264	in
265
266	let wrapped_pattern =	42×
267	Pat.alias ~loc pure_pattern (Location.mkloc case_variable loc) in	42×
268
269	let marks_expr =	42×
270	cases	42×
271	\|> List.map (fun (marks, pattern) ->	42×
272	Exp.case pattern (increments (unitconst ()) marks))	174×
273	\|> Exp.match_ ~loc (Exp.ident (lid ~loc case_variable))	42×
274	in
275
276	(* Suppress warnings because the generated match expression will almost
277	never be exhaustive. It may also have redundant cases or unused
278	variables. *)
279	let marks_expr =	42×
280	Exp.attr marks_expr	42×
281	(Location.mkloc "ocaml.warning" loc,
282	PStr [Str.eval (strconst "-4-8-9-11-26-27-28")])
283	in
284
285	Exp.case (reassemble wrapped_pattern) ?guard:maybe_guard	42×
286	(Exp.sequence ~loc marks_expr case.pc_rhs)
287
288	let wrap_class_field_kind k = function	22×
289	\| Cfk_virtual _ as cf -> cf	2×
290	\| Cfk_concrete (o,e) -> Cf.concrete o (wrap_expr k e)	20×
291
292	let pattern_var id =
293	Pat.var (Location.mkloc id Location.none)	328×
294
295	(* This method is stateful and depends on `InstrumentState.set_points_for_file`
296	having been run on all the points in the rest of the AST. *)
297	let faster file =
298	let nb = List.length (InstrumentState.get_points_for_file file) in	82×
299	let ilid s = Exp.ident (lid s) in	82×
300	let init =	82×
301	apply_nolabs	82×
302	(lid ((!InstrumentArgs.runtime_name) ^ ".Runtime.init_with_array"))
303	[strconst file; ilid "marks"]
304	in
305	let make = apply_nolabs (lid "Array.make") [intconst nb; intconst 0] in	82×
306	let marks =	82×
307	List.fold_left	82×
308	(fun acc (idx, nb) ->
309	let mark =	2×
310	apply_nolabs (lid "Array.set") [ ilid "marks"; intconst idx; intconst nb]	2×
311	in
312	Exp.sequence acc mark)	2×
313	init
314	(InstrumentState.get_marked_points_assoc ()) in
315	let func =	82×
316	let body =	82×
317	let if_then_else =	82×
318	Exp.ifthenelse	82×
319	(apply_nolabs (lid "<") [ilid "curr"; ilid "Pervasives.max_int"])
320	(apply_nolabs (lid "Pervasives.succ") [ilid "curr"])
321	(Some (ilid "curr"))
322	in
323	let vb =	82×
324	Vb.mk (pattern_var "curr")	82×
325	(apply_nolabs (lid "Array.get") [ilid "marks"; ilid "idx"])
326	in
327	Exp.let_ Nonrecursive [vb]	82×
328	(apply_nolabs
329	(lid "Array.set")
330	[ilid "marks"; ilid "idx"; if_then_else])
331	in
332	Exp.(function_ [ case (pattern_var "idx") body ])	82×
333	in
334	let vb = [(Vb.mk (pattern_var "marks") make)] in	82×
335	let e =	82×
336	Exp.(let_ Nonrecursive vb (sequence marks func))	82×
337	in
338	Str.value Nonrecursive [ Vb.mk (pattern_var (custom_mark_function file)) e]	82×
339
340	(* The actual "instrumenter" object, marking expressions. *)
341	class instrumenter = object (self)
342
343	inherit Ast_mapper_class.mapper as super
344
345	method! class_expr ce =
346	let loc = ce.pcl_loc in	16×
347	let ce = super#class_expr ce in	16×
348	match ce.pcl_desc with	16×
349	\| Pcl_apply (ce, l) ->	2×
350	let l =
351	List.map	2×
352	(fun (l, e) ->
353	(l, (wrap_expr Common.Class_expr e)))	2×
354	l in
355	Cl.apply ~loc ~attrs:ce.pcl_attributes ce l	2×
356	\| _ ->	14×
357	ce
358
359	method! class_field cf =
360	let loc = cf.pcf_loc in	28×
361	let attrs = cf.pcf_attributes in	28×
362	let cf = super#class_field cf in	28×
363	match cf.pcf_desc with	28×
364	\| Pcf_val (id, mut, cf) ->	4×
365	Cf.val_ ~loc ~attrs id mut (wrap_class_field_kind Common.Class_val cf)
366	\| Pcf_method (id, mut, cf) ->	18×
367	Cf.method_ ~loc ~attrs id mut
368	(wrap_class_field_kind Common.Class_meth cf)
369	\| Pcf_initializer e ->	4×
370	Cf.initializer_ ~loc ~attrs (wrap_expr Common.Class_init e)
371	\| _ ->	2×
372	cf
373
374	val mutable extension_guard = false	86×
375	val mutable attribute_guard = false	86×
376
377	method! expr e =
378	if attribute_guard \|\| extension_guard then	4,012×
379	super#expr e	14×
380	else
381	let loc = e.pexp_loc in	4,008×
382	let attrs = e.pexp_attributes in	4,008×
383	let e' = super#expr e in	4,008×
384	match e'.pexp_desc with	4,008×
385	\| Pexp_let (rec_flag, l, e) ->	46×
386	let l =
387	List.map (fun vb ->	46×
388	{vb with pvb_expr = wrap_expr Common.Sequence vb.pvb_expr}) l in	42×
389	Exp.let_ ~loc ~attrs rec_flag l (wrap_expr Common.Sequence e)	46×
390	\| Pexp_poly (e, ct) ->	16×
391	Exp.poly ~loc ~attrs (wrap_expr Common.Sequence e) ct
392	\| Pexp_fun (al, eo, p, e) ->	250×
393	let eo = map_opt (wrap_expr Common.Match) eo in	250×
394	Exp.fun_ ~loc ~attrs al eo p (wrap_expr Common.Match e)	250×
395	\| Pexp_apply (e1, [l2, e2; l3, e3]) ->	240×
396	(match e1.pexp_desc with
397	\| Pexp_ident ident	22×
398	when
399	List.mem (string_of_ident ident) [ "&&"; "&"; "\|\|"; "or" ] ->	240×
400	Exp.apply ~loc ~attrs e1
401	[l2, (wrap_expr Common.Lazy_operator e2);
402	l3, (wrap_expr Common.Lazy_operator e3)]
403	\| Pexp_ident ident when string_of_ident ident = "\|>" ->	42×
404	Exp.apply ~loc ~attrs e1
405	[l2, e2; l3, (wrap_expr Common.Sequence e3)]
406	\| _ -> e')	176×
407	\| Pexp_match (e, l) ->	84×
408	List.map (wrap_case Common.Match) l
409	\|> Exp.match_ ~loc ~attrs e	84×
410	\| Pexp_function l ->	36×
411	List.map (wrap_case Common.Match) l
412	\|> Exp.function_ ~loc ~attrs	36×
413	\| Pexp_try (e, l) ->	24×
414	List.map (wrap_case Common.Try) l
415	\|> Exp.try_ ~loc ~attrs e	24×
416	\| Pexp_ifthenelse (e1, e2, e3) ->	50×
417	Exp.ifthenelse ~loc ~attrs e1 (wrap_expr Common.If_then e2)
418	(match e3 with Some x -> Some (wrap_expr Common.If_then x) \| None -> None)	2×
419	\| Pexp_sequence (e1, e2) ->	164×
420	Exp.sequence ~loc ~attrs e1 (wrap_expr Common.Sequence e2)
421	\| Pexp_while (e1, e2) ->	4×
422	Exp.while_ ~loc ~attrs e1 (wrap_expr Common.While e2)
423	\| Pexp_for (id, e1, e2, dir, e3) ->	34×
424	Exp.for_ ~loc ~attrs id e1 e2 dir (wrap_expr Common.For e3)
425	\| _ -> e'	3,060×
426
427	method! structure_item si =
428	let loc = si.pstr_loc in	456×
429	match si.pstr_desc with	456×
430	\| Pstr_value (rec_flag, l) ->	408×
431	let l =
432	List.map (fun vb -> (* Only instrument things not excluded. *)	408×
433	{ vb with pvb_expr =	412×
434	match vb.pvb_pat.ppat_desc with
435	(* Match the 'f' in 'let f x = ... ' *)
436	\| Ppat_var ident when Exclusions.contains	8×
437	(ident.loc.Location.loc_start.Lexing.pos_fname)
438	ident.txt -> vb.pvb_expr
439	(* Match the 'f' in 'let f : type a. a -> string = ...' *)
440	\| Ppat_constraint (p,_) ->	12×
441	begin
442	match p.ppat_desc with
443	\| Ppat_var ident when Exclusions.contains	2×
444	(ident.loc.Location.loc_start.Lexing.pos_fname)
445	ident.txt -> vb.pvb_expr
446	\| _ ->	10×
447	wrap_expr Common.Binding (self#expr vb.pvb_expr)
448	end
449	\| _ ->	392×
450	wrap_expr Common.Binding (self#expr vb.pvb_expr)})
451	l
452	in
453	Str.value ~loc rec_flag l	408×
454	\| Pstr_eval (e, a) when not (attribute_guard \|\| extension_guard) ->	2×
455	Str.eval ~loc ~attrs:a (wrap_expr Common.Toplevel_expr (self#expr e))
456	\| _ ->	46×
457	super#structure_item si
458
459	(* Guard these because they can carry payloads that we
460	do not want to instrument. *)
461	method! extension e =
462	extension_guard <- true;	4×
463	let r = super#extension e in	4×
464	extension_guard <- false;	4×
465	r	4×
466
467	method! attribute a =
468	attribute_guard <- true;	24×
469	let r = super#attribute a in	24×
470	attribute_guard <- false;	24×
471	r	24×
472
473	(* Initializes storage and applies requested marks. *)
474	method! structure ast =
475	if extension_guard \|\| attribute_guard then	112×
476	super#structure ast	28×
477	else
478	let file = !Location.input_name in	88×
479	if file = "//toplevel//" \|\|	88×
480	file = "(stdin)" \|\|	88×
481	List.mem (Filename.basename file) [".ocamlinit"; "topfind"] then	84×
482	ast	4×
483	else
484	if not (InstrumentState.is_file file) then	84×
485	begin	82×
486	(* We have to add this here, before we process the rest of the
487	structure, because that may also have structures contained
488	there-in, but we'll add the header after processing all of those
489	declarations so that we know how many instrumentations there
490	are. *)
491	InstrumentState.add_file file;
492	let rest = super#structure ast in	82×
493	let head = faster file in	82×
494	head :: rest	82×
495	end
496	else
497	super#structure ast	2×
498
499	end

rleonid / bisect_ppx / 367

Source File Press 'n' to go to next uncovered line, 'b' for previous

Source File
Press 'n' to go to next uncovered line, 'b' for previous