Source file `slicing_request.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
(**************************************************************************)
(*                                                                        *)
(*  SPDX-License-Identifier LGPL-2.1                                      *)
(*  Copyright (C)                                                         *)
(*  CEA (Commissariat à l'énergie atomique et aux énergies alternatives)  *)
(*                                                                        *)
(**************************************************************************)

open Server

let package =
  Package.package ~plugin:"slicing" ~name:"slicing" ~title:"Slicing" ()

(* ----- Slicing functions -------------------------------------------------- *)

let mk_selection fselect = fselect Api.Select.empty_selects ~spare:false

let kf_of_varinfo vi =
  try Globals.Functions.get vi
  with Not_found -> Data.failure "%a is not a function" Printer.pp_varinfo vi

let select_kf_aux fselect marker  =
  match (marker: Printer_tag.localizable) with
  | PVDecl (_, Kglobal, vi)
  | PLval (_, _, (Var vi, NoOffset)) ->
    mk_selection fselect (kf_of_varinfo vi)
  | marker ->
    Data.failure "Marker %a is not a function" Printer_tag.pp_localizable marker

let select_calls_to = select_kf_aux Api.Select.select_func_calls_to
let select_calls_into = select_kf_aux Api.Select.select_func_calls_into
let select_result = select_kf_aux Api.Select.select_func_return

(* ----- Slicing statements ------------------------------------------------- *)

let select_stmt_aux fselect marker =
  let kinstr = Printer_tag.ki_of_localizable marker in
  let kf = Printer_tag.kf_of_localizable marker in
  match kf, kinstr with
  | Some kf, Kstmt stmt ->
    mk_selection fselect stmt kf
  | _ ->
    Data.failure "No statement related to marker %a"
      Printer_tag.pp_localizable marker

let select_stmt = select_stmt_aux Api.Select.select_stmt
let select_stmt_control = select_stmt_aux Api.Select.select_stmt_ctrl

(* ----- Slicing lvalues ---------------------------------------------------- *)

let lval_of_marker = function
  | Printer_tag.PLval (Some kf, Kstmt stmt, lval) ->
    (* For dubious reasons, Api.Select requires strings instead of the lvalue.
       Thus, we convert the lval into string, so that it may be parsed back… *)
    let lval_str = Pretty_utils.to_string Printer.pp_lval lval in
    let lval_str_set = Datatype.String.Set.singleton lval_str in
    (kf, stmt, lval_str_set)
  | marker ->
    Data.failure "Marker %a is not an lvalue" Printer_tag.pp_localizable marker

let mk_selection_lval fselect =
  let pdg_mark = Api.Mark.make ~ctrl:true ~addr:true ~data:true in
  fselect Api.Select.empty_selects pdg_mark

let select_lval marker =
  let kf, stmt, lval = lval_of_marker marker in
  mk_selection_lval
    Api.Select.select_stmt_lval lval ~before:true stmt ~eval:stmt kf

let empty = Datatype.String.Set.empty

let select_lval_reads marker =
  let kf, stmt, lval = lval_of_marker marker in
  mk_selection_lval
    Api.Select.select_func_lval_rw ~rd:lval ~wr:empty ~eval:stmt kf

let select_lval_writes marker =
  let kf, stmt, lval = lval_of_marker marker in
  mk_selection_lval
    Api.Select.select_func_lval_rw ~rd:empty ~wr:lval ~eval:stmt kf

(* ----- Slicing requests --------------------------------------------------- *)

let mk_slice build_selection = fun marker ->
  let selection = build_selection marker in
  Api.Project.reset_slicing ();
  Api.Request.add_persistent_selection selection;
  Api.Request.apply_all_internal ();
  if SlicingParameters.Mode.Callers.get () then
    Api.Slice.remove_uncalled ();
  let project_name = SlicingParameters.ProjectName.get () in
  let suffix = SlicingParameters.ExportedProjectPostfix.get () in
  let project = Api.Project.extract (project_name ^ suffix) in
  project.name, project.pid

module Output = Data.Jpair (Data.Jstring) (Data.Jint)

(* All requests below are EXEC requests from an AST marker to the name and id
   of the new project containing the sliced AST. *)
let register_request ~name ~descr select =
  Request.register ~package ~kind:`EXEC ~name ~descr:(Markdown.plain descr)
    ~input:(module Kernel_ast.Marker) ~output:(module Output)
    (mk_slice select)

let () = register_request
    ~name:"sliceCallsTo"
    ~descr:"Slice effects of the given function"
    select_calls_to

let () = register_request
    ~name:"sliceCallsInto"
    ~descr:"Slice entrance into the given function"
    select_calls_into

let () = register_request
    ~name:"sliceResult"
    ~descr:"Slice the returned value of the given function"
    select_result

let () = register_request
    ~name:"sliceStmt"
    ~descr:"Slice effects of the given statement"
    select_stmt

let () = register_request
    ~name:"sliceStmtCtrl"
    ~descr:"Slice accessibility of the given statement"
    select_stmt_control

let () = register_request
    ~name:"sliceLval"
    ~descr:"Slice the given lvalue"
    select_lval

let () = register_request
    ~name:"sliceLvalReads"
    ~descr:"Slice read accesses of the given lvalue"
    select_lval_reads

let () = register_request
    ~name:"sliceLvalWrites"
    ~descr:"Slice write accesses of the given lvalue"
    select_lval_writes