Source file for_analyzer.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
open! Core
module Cutoff = Cutoff.For_analyzer
module Internal_node_id = Node_id

module Kind = struct
  type t =
    | Array_fold
    | At of { at : Time_ns.Alternate_sexp.t }
    | At_intervals of
        { base : Time_ns.Alternate_sexp.t
        ; interval : Time_ns.Span.t
        }
    | Bind_lhs_change
    | Bind_main
    | Const
    | Expert
    | Freeze
    | If_test_change
    | If_then_else
    | Invalid
    | Join_lhs_change
    | Join_main
    | Map
    | Snapshot of { at : Time_ns.Alternate_sexp.t }
    | Step_function
    | Uninitialized
    | Unordered_array_fold
    | Var
    | Map2
    | Map3
    | Map4
    | Map5
    | Map6
    | Map7
    | Map8
    | Map9
    | Map10
    | Map11
    | Map12
    | Map13
    | Map14
    | Map15
  [@@deriving sexp]

  let to_string t = Sexp.to_string ([%sexp_of: t] t)
end

let kind (Node.Packed.T node) : Kind.t =
  match node.kind with
  | Array_fold _ -> Array_fold
  | At { at; _ } -> At { at }
  | At_intervals { base; interval; _ } -> At_intervals { base; interval }
  | Bind_lhs_change _ -> Bind_lhs_change
  | Bind_main _ -> Bind_main
  | Const _ -> Const
  | Expert _ -> Expert
  | Freeze _ -> Freeze
  | If_test_change _ -> If_test_change
  | If_then_else _ -> If_then_else
  | Invalid -> Invalid
  | Join_lhs_change _ -> Join_lhs_change
  | Join_main _ -> Join_main
  | Map _ -> Map
  | Snapshot { at; _ } -> Snapshot { at }
  | Step_function _ -> Step_function
  | Uninitialized -> Uninitialized
  | Unordered_array_fold _ -> Unordered_array_fold
  | Var _ -> Var
  | Map2 _ -> Map2
  | Map3 _ -> Map3
  | Map4 _ -> Map4
  | Map5 _ -> Map5
  | Map6 _ -> Map6
  | Map7 _ -> Map7
  | Map8 _ -> Map8
  | Map9 _ -> Map9
  | Map10 _ -> Map10
  | Map11 _ -> Map11
  | Map12 _ -> Map12
  | Map13 _ -> Map13
  | Map14 _ -> Map14
  | Map15 _ -> Map15
;;

module Dot_user_info = struct
  include Dot_user_info

  let default ~name ~kind ~height =
    let label =
      [ name; Sexp.to_string ([%sexp_of: Kind.t] kind); sprintf "height=%d" height ]
    in
    Dot_user_info.dot ~label ~attributes:String.Map.empty
  ;;
end

module Node_id = Int

module Stabilization_num = struct
  include Stabilization_num
  include Stabilization_num.For_analyzer
end

let recomputed_at (Node.Packed.T node) = node.recomputed_at
let changed_at (Node.Packed.T node) = node.changed_at
let node_id (Node.Packed.T node) = Internal_node_id.to_string node.id |> Node_id.of_string
let cutoff (Node.Packed.T node) = Cutoff.of_cutoff node.cutoff
let user_info (Node.Packed.T node) = node.user_info
let height (Node.Packed.T node) = node.height
let iteri_children (Node.Packed.T node) = Node.iteri_children node

let maybe_iter_on_bind_nodes_created_on_rhs (Node.Packed.T node) ~f =
  match node.kind with
  | Bind_lhs_change bind -> Bind.iter_nodes_created_on_rhs bind ~f
  | _ -> ()
;;

let directly_observed = State.directly_observed

let traverse packed_list ~add_node =
  let map_of_iter iterator ~f =
    let out = ref [] in
    iterator ~f:(fun x -> out := f x :: !out);
    List.rev !out
  in
  Node.Packed.iter_descendants packed_list ~f:(fun packed_node ->
    let children =
      map_of_iter
        (fun ~f -> iteri_children packed_node ~f:(fun _ node -> f node))
        ~f:node_id
    in
    let bind_children =
      map_of_iter (maybe_iter_on_bind_nodes_created_on_rhs packed_node) ~f:node_id
    in
    let id = node_id packed_node in
    let kind = kind packed_node in
    let cutoff = cutoff packed_node in
    let user_info = user_info packed_node in
    let recomputed_at = recomputed_at packed_node in
    let changed_at = changed_at packed_node in
    let height = height packed_node in
    add_node
      ~id
      ~kind
      ~cutoff
      ~children
      ~bind_children
      ~user_info
      ~recomputed_at
      ~changed_at
      ~height)
;;