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
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
|
(**************************************************************************)
(* *)
(* OCaml *)
(* *)
(* Pierre Chambart, OCamlPro *)
(* Mark Shinwell and Leo White, Jane Street Europe *)
(* *)
(* Copyright 2013--2016 OCamlPro SAS *)
(* Copyright 2014--2016 Jane Street Group LLC *)
(* *)
(* All rights reserved. This file is distributed under the terms of *)
(* the GNU Lesser General Public License version 2.1, with the *)
(* special exception on linking described in the file LICENSE. *)
(* *)
(**************************************************************************)
[@@@ocaml.warning "+a-4-9-30-40-41-42-66"]
open! Int_replace_polymorphic_compare
type allocation_point =
| Symbol of Symbol.t
| Variable of Variable.t
type allocated_const =
| Normal of Allocated_const.t
| Array of Lambda.array_kind * Asttypes.mutable_flag * Variable.t list
| Duplicate_array of Lambda.array_kind * Asttypes.mutable_flag * Variable.t
type constant_defining_value =
| Allocated_const of allocated_const
| Block of Tag.t * Variable.t list
| Set_of_closures of Flambda.set_of_closures
| Project_closure of Flambda.project_closure
| Move_within_set_of_closures of Flambda.move_within_set_of_closures
| Project_var of Flambda.project_var
| Field of Variable.t * int
| Symbol_field of Symbol.t * int
| Const of Flambda.const
| Symbol of Symbol.t
| Variable of Variable.t
type initialize_symbol_field = Variable.t option
type definitions = {
variable : constant_defining_value Variable.Tbl.t;
initialize_symbol : initialize_symbol_field list Symbol.Tbl.t;
symbol : Flambda.constant_defining_value Symbol.Tbl.t;
}
let print_constant_defining_value ppf = function
| Allocated_const (Normal const) -> Allocated_const.print ppf const
| Allocated_const (Array (_, _, vars)) ->
Format.fprintf ppf "[| %a |]"
(Format.pp_print_list Variable.print) vars
| Allocated_const (Duplicate_array (_, _, var)) ->
Format.fprintf ppf "dup_array(%a)" Variable.print var
| Block (tag, vars) ->
Format.fprintf ppf "[|%a: %a|]"
Tag.print tag
(Format.pp_print_list Variable.print) vars
| Set_of_closures set -> Flambda.print_set_of_closures ppf set
| Project_closure project -> Flambda.print_project_closure ppf project
| Move_within_set_of_closures move ->
Flambda.print_move_within_set_of_closures ppf move
| Project_var project -> Flambda.print_project_var ppf project
| Field (var, field) -> Format.fprintf ppf "%a.(%d)" Variable.print var field
| Symbol_field (sym, field) ->
Format.fprintf ppf "%a.(%d)" Symbol.print sym field
| Const const -> Flambda.print_const ppf const
| Symbol symbol -> Symbol.print ppf symbol
| Variable var -> Variable.print ppf var
let rec resolve_definition
(definitions: definitions)
(var: Variable.t)
(def: constant_defining_value)
~the_dead_constant : allocation_point =
match def with
| Allocated_const _
| Block _
| Set_of_closures _
| Project_closure _
| Const _
| Move_within_set_of_closures _ ->
Variable var
| Project_var {var} ->
fetch_variable definitions (Var_within_closure.unwrap var)
~the_dead_constant
| Variable v ->
fetch_variable definitions v
~the_dead_constant
| Symbol sym -> Symbol sym
| Field (v, n) ->
begin match fetch_variable definitions v ~the_dead_constant with
| Symbol s ->
fetch_symbol_field definitions s n ~the_dead_constant
| Variable v ->
fetch_variable_field definitions v n ~the_dead_constant
end
| Symbol_field (symbol, field) ->
fetch_symbol_field definitions symbol field ~the_dead_constant
and fetch_variable
(definitions: definitions)
(var: Variable.t)
~the_dead_constant : allocation_point =
match Variable.Tbl.find definitions.variable var with
| exception Not_found -> Variable var
| def -> resolve_definition definitions var def ~the_dead_constant
and fetch_variable_field
(definitions: definitions)
(var: Variable.t)
(field: int)
~the_dead_constant : allocation_point =
match Variable.Tbl.find definitions.variable var with
| Block (_, fields) ->
begin match List.nth fields field with
| exception Not_found -> Symbol the_dead_constant
| v -> fetch_variable definitions v ~the_dead_constant
end
| exception Not_found ->
Misc.fatal_errorf "No definition for field access to %a" Variable.print var
| Symbol _ | Variable _ | Project_var _ | Field _ | Symbol_field _ ->
(* Must have been resolved *)
assert false
| Const _ | Allocated_const _
| Set_of_closures _ | Project_closure _ | Move_within_set_of_closures _ ->
Symbol the_dead_constant
and fetch_symbol_field
(definitions: definitions)
(sym: Symbol.t)
(field: int)
~the_dead_constant : allocation_point =
match Symbol.Tbl.find definitions.symbol sym with
| Block (_, fields) ->
begin match List.nth fields field with
| exception Not_found -> Symbol the_dead_constant
| Symbol s -> Symbol s
| Const _ -> Symbol sym
end
| exception Not_found ->
begin match Symbol.Tbl.find definitions.initialize_symbol sym with
| fields ->
begin match List.nth fields field with
| None ->
Misc.fatal_errorf "Constant field access to an inconstant %a"
Symbol.print sym
| Some v ->
fetch_variable definitions v ~the_dead_constant
end
| exception Not_found ->
Misc.fatal_errorf "No definition for field access to %a"
Symbol.print sym
end
| Allocated_const _ | Set_of_closures _ | Project_closure _ ->
Symbol the_dead_constant
let run variable initialize_symbol symbol ~the_dead_constant =
let definitions = { variable; initialize_symbol; symbol; } in
Variable.Tbl.fold (fun var definition result ->
let definition =
resolve_definition definitions var definition ~the_dead_constant
in
Variable.Map.add var definition result)
definitions.variable
Variable.Map.empty
|
