let related_nodes_of_nodes kind result nodes =
let initial_nodes =
List.map (fun n -> n.Todolist.node, n.Todolist.kf) nodes
in
let rec aux first result = function
| [] -> result
| { Todolist.node = node; kf = kf; pdg = pdg;
callstack_length = callstack_length; from_deep = from_deep }
:: todolist
->
let elt = node, kf in
let found, result =
check_and_add first elt kind pdg callstack_length result
in
let todolist =
if found then begin
todolist
end else begin
Security_slicing_parameters.debug
~level:2 "considering node %a (in %s)"
(!Pdg.pretty_node false) node
(Kernel_function.get_name kf);
(* intraprocedural related_nodes *)
let related_nodes = one_step_related_nodes kind pdg node in
Security_slicing_parameters.debug ~level:3
"intraprocedural part done";
let todolist =
List.fold_left
(fun todo n ->
Todolist.add n kf pdg callstack_length false todo)
todolist
related_nodes
in
(* interprocedural part *)
let backward_from_deep compute_nodes =
(* [TODO optimisation:]
en fait, regarder from_deep:
si vrai, faire pour chaque caller
sinon, faire uniquement pour le caller d'oł on vient *)
match kind, callstack_length with
| (Direct | Indirect_Backward), 0 ->
(* input of a deep security annotation: foreach call
to [kf], compute its related nodes *)
let do_caller todolist (caller, callsites) =
(* Format.printf "[security of %s] search callers in %s
for zone %a@." (Kernel_function.get_name kf)
(Kernel_function.get_name caller)
Locations.Zone.pretty zone;*)
let pdg_caller = !Pdg.get caller in
let do_call todolist callsite =
match kind with
| Direct | Indirect_Backward ->
let nodes = compute_nodes pdg_caller callsite in
List.fold_left
(add_from_deep caller) todolist nodes
| Forward _ ->
todolist (* not considered here, see at end *)
in
List.fold_left do_call todolist callsites
in
List.fold_left do_caller todolist (!Value.callers kf)
| _ ->
todolist
in
let todolist =
match !Pdg.node_key node with
| Key.SigKey (Signature.In Signature.InCtrl) ->
assert false
| Key.SigKey (Signature.In (Signature.InImpl zone)) ->
let compute_nodes pdg_caller callsite =
let nodes, _undef_zone =
!Pdg.find_location_nodes_at_stmt
pdg_caller callsite ~before:true zone
(* TODO : use undef_zone (see FS#201)? *)
in
let nodes = List.map (fun (n, _z_part) -> n) nodes in
(* TODO : use _z_part ? *)
nodes
in
backward_from_deep compute_nodes
| Key.SigKey key ->
let compute_nodes pdg_caller callsite =
[ match key with
| Signature.In (Signature.InNum n) ->
!Pdg.find_call_input_node pdg_caller callsite n
| Signature.Out Signature.OutRet ->
!Pdg.find_call_output_node pdg_caller callsite
| Signature.In
(Signature.InCtrl | Signature.InImpl _)
| Signature.Out _ ->
assert false ]
in
backward_from_deep compute_nodes
| Key.SigCallKey(id, key) ->
(* the node is a call: search the related nodes inside the
called function (see FS#155) *)
if from_deep then
(* already come from a deeper annotation:
do not go again inside it *)
todolist
else
let stmt = Key.call_from_id id in
let called_kfs =
Kernel_function.Set.elements
(try Value.call_to_kernel_function stmt
with Value.Not_a_call -> assert false)
in
let todolist =
List.fold_left
(fun todolist called_kf ->
(* foreach called kf *)
(*Format.printf
"[security] search inside %s (from %s)@."
(Kernel_function.get_name called_kf)
(Kernel_function.get_name kf);*)
let called_pdg = !Pdg.get called_kf in
let nodes = match kind, key with
| (Direct | Indirect_Backward),
Signature.Out out_key ->
let nodes, _undef_zone =
!Pdg.find_output_nodes called_pdg out_key
(* TODO: use undef_zone (see FS#201) *)
in
let nodes =
List.map (fun (n, _z_part) -> n) nodes in
(* TODO : use _z_part ? *)
nodes
| _, Signature.In (Signature.InNum n) ->
search_input kind called_kf
(lazy [!Pdg.find_input_node called_pdg n])
| _, Signature.In Signature.InCtrl ->
search_input kind called_kf
(lazy
[!Pdg.find_entry_point_node called_pdg])
| _, Signature.In (Signature.InImpl _) ->
assert false
| Forward _, Signature.Out _ ->
[]
in
List.fold_left
(fun todo n ->
(*Format.printf "node %a inside %s@."
(!Pdg.pretty_node false) n
(Kernel_function.get_name called_kf);*)
Todolist.add
n called_kf called_pdg
(callstack_length + 1) false todo)
todolist
nodes)
todolist
called_kfs
in
(match kind with
| Direct | Indirect_Backward ->
todolist
| Forward _ ->
List.fold_left
(fun todolist called_kf ->
let compute_from_stmt fold =
fold
(fun (n, kfn) _ acc ->
if kfn == kf then n :: acc else acc)
in
let from_stmt =
compute_from_stmt M.fold result [] in
let from_stmt =
(* initial nodes may be not in results *)
compute_from_stmt
(fun f e acc ->
List.fold_left
(fun acc e -> f e [] acc) acc e)
initial_nodes
from_stmt
in
let called_pdg = !Pdg.get called_kf in
let nodes =
!Pdg.find_in_nodes_to_select_for_this_call
pdg from_stmt stmt called_pdg
in
List.fold_left
(fun todo n ->
Todolist.add
n called_kf called_pdg
(callstack_length + 1) false todo)
todolist
nodes)
todolist
called_kfs)
| Key.CallStmt _ | Key.VarDecl _ ->
assert false
| Key.Stmt _ | Key.Label _ ->
todolist
in
(* [TODO optimisation:] voir commentaire plus haut *)
match kind with
| (Direct | Indirect_Backward) -> todolist
| Forward _ -> forward_caller kf node todolist
end
in
(* recursive call *)
aux false result todolist
in
aux true result nodes