1(**************************************************************************)
2(*                                                                        *)
3(*                                 OCaml                                  *)
4(*                                                                        *)
5(*                       Pierre Chambart, OCamlPro                        *)
6(*           Mark Shinwell and Leo White, Jane Street Europe              *)
7(*                                                                        *)
8(*   Copyright 2013--2016 OCamlPro SAS                                    *)
9(*   Copyright 2014--2016 Jane Street Group LLC                           *)
10(*                                                                        *)
11(*   All rights reserved.  This file is distributed under the terms of    *)
12(*   the GNU Lesser General Public License version 2.1, with the          *)
13(*   special exception on linking described in the file LICENSE.          *)
14(*                                                                        *)
15(**************************************************************************)
16
17[@@@ocaml.warning "+a-4-9-30-40-41-42"]
18
19type allocation_point =
20  | Symbol of Symbol.t
21  | Variable of Variable.t
22
23type allocated_const =
24  | Normal of Allocated_const.t
25  | Array of Lambda.array_kind * Asttypes.mutable_flag * Variable.t list
26  | Duplicate_array of Lambda.array_kind * Asttypes.mutable_flag * Variable.t
27
28type constant_defining_value =
29  | Allocated_const of allocated_const
30  | Block of Tag.t * Variable.t list
31  | Set_of_closures of Flambda.set_of_closures
32  | Project_closure of Flambda.project_closure
33  | Move_within_set_of_closures of Flambda.move_within_set_of_closures
34  | Project_var of Flambda.project_var
35  | Field of Variable.t * int
36  | Symbol_field of Symbol.t * int
37  | Const of Flambda.const
38  | Symbol of Symbol.t
39  | Variable of Variable.t
40
41type initialize_symbol_field = Variable.t option
42
43type definitions = {
44  variable : constant_defining_value Variable.Tbl.t;
45  initialize_symbol : initialize_symbol_field list Symbol.Tbl.t;
46  symbol : Flambda.constant_defining_value Symbol.Tbl.t;
47}
48
49let print_constant_defining_value ppf = function
50  | Allocated_const (Normal const) -> Allocated_const.print ppf const
51  | Allocated_const (Array (_, _, vars)) ->
52    Format.fprintf ppf "[| %a |]"
53      (Format.pp_print_list Variable.print) vars
54  | Allocated_const (Duplicate_array (_, _, var)) ->
55    Format.fprintf ppf "dup_array(%a)" Variable.print var
56  | Block (tag, vars) ->
57    Format.fprintf ppf "[|%a: %a|]"
58      Tag.print tag
59      (Format.pp_print_list Variable.print) vars
60  | Set_of_closures set -> Flambda.print_set_of_closures ppf set
61  | Project_closure project -> Flambda.print_project_closure ppf project
62  | Move_within_set_of_closures move ->
63    Flambda.print_move_within_set_of_closures ppf move
64  | Project_var project -> Flambda.print_project_var ppf project
65  | Field (var, field) -> Format.fprintf ppf "%a.(%d)" Variable.print var field
66  | Symbol_field (sym, field) ->
67    Format.fprintf ppf "%a.(%d)" Symbol.print sym field
68  | Const const -> Flambda.print_const ppf const
69  | Symbol symbol -> Symbol.print ppf symbol
70  | Variable var -> Variable.print ppf var
71
72let rec resolve_definition
73    (definitions: definitions)
74    (var: Variable.t)
75    (def: constant_defining_value)
76    ~the_dead_constant : allocation_point =
77  match def with
78  | Allocated_const _
79  | Block _
80  | Set_of_closures _
81  | Project_closure _
82  | Const _
83  | Move_within_set_of_closures _ ->
84    Variable var
85  | Project_var {var} ->
86    fetch_variable definitions (Var_within_closure.unwrap var)
87      ~the_dead_constant
88  | Variable v ->
89    fetch_variable definitions v
90      ~the_dead_constant
91  | Symbol sym -> Symbol sym
92  | Field (v, n) ->
93    begin match fetch_variable definitions v ~the_dead_constant with
94    | Symbol s ->
95      fetch_symbol_field definitions s n ~the_dead_constant
96    | Variable v ->
97      fetch_variable_field definitions v n ~the_dead_constant
98    end
99  | Symbol_field (symbol, field) ->
100    fetch_symbol_field definitions symbol field ~the_dead_constant
101
102and fetch_variable
103    (definitions: definitions)
104    (var: Variable.t)
105    ~the_dead_constant : allocation_point =
106  match Variable.Tbl.find definitions.variable var with
107  | exception Not_found -> Variable var
108  | def -> resolve_definition definitions var def ~the_dead_constant
109
110and fetch_variable_field
111    (definitions: definitions)
112    (var: Variable.t)
113    (field: int)
114    ~the_dead_constant : allocation_point =
115  match Variable.Tbl.find definitions.variable var with
116  | Block (_, fields) ->
117    begin match List.nth fields field with
118    | exception Not_found -> Symbol the_dead_constant
119    | v -> fetch_variable definitions v ~the_dead_constant
120    end
121  | exception Not_found ->
122    Misc.fatal_errorf "No definition for field access to %a" Variable.print var
123  | Symbol _ | Variable _ | Project_var _ | Field _ | Symbol_field _ ->
124    (* Must have been resolved *)
125    assert false
126  | Const _ | Allocated_const _
127  | Set_of_closures _ | Project_closure _ | Move_within_set_of_closures _ ->
128    Symbol the_dead_constant
129
130and fetch_symbol_field
131    (definitions: definitions)
132    (sym: Symbol.t)
133    (field: int)
134    ~the_dead_constant : allocation_point =
135  match Symbol.Tbl.find definitions.symbol sym with
136  | Block (_, fields) ->
137    begin match List.nth fields field with
138    | exception Not_found -> Symbol the_dead_constant
139    | Symbol s -> Symbol s
140    | Const _ -> Symbol sym
141    end
142  | exception Not_found ->
143    begin match Symbol.Tbl.find definitions.initialize_symbol sym with
144      | fields ->
145        begin match List.nth fields field with
146        | None ->
147          Misc.fatal_errorf "Constant field access to an inconstant %a"
148            Symbol.print sym
149        | Some v ->
150          fetch_variable definitions v ~the_dead_constant
151        end
152      | exception Not_found ->
153        Misc.fatal_errorf "No definition for field access to %a"
154          Symbol.print sym
155    end
156  | Allocated_const _ | Set_of_closures _ | Project_closure _ ->
157    Symbol the_dead_constant
158
159let run variable initialize_symbol symbol ~the_dead_constant =
160  let definitions = { variable; initialize_symbol; symbol; } in
161  Variable.Tbl.fold (fun var definition result ->
162      let definition =
163        resolve_definition definitions var definition ~the_dead_constant
164      in
165      Variable.Map.add var definition result)
166    definitions.variable
167    Variable.Map.empty
168