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
|
(**************************************************************************)
(* *)
(* 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"]
module Constant_defining_value = Flambda.Constant_defining_value
let update_constant_for_sharing sharing_symbol_tbl const
: Flambda.constant_defining_value =
let substitute_symbol sym =
match Symbol.Tbl.find sharing_symbol_tbl sym with
| exception Not_found -> sym
| symbol -> symbol
in
match (const:Flambda.constant_defining_value) with
| Allocated_const _ -> const
| Block (tag, fields) ->
let subst_field (field:Flambda.constant_defining_value_block_field) :
Flambda.constant_defining_value_block_field =
match field with
| Const _ -> field
| Symbol sym ->
Symbol (substitute_symbol sym)
in
let fields = List.map subst_field fields in
Block (tag, fields)
| Set_of_closures set_of_closures ->
Set_of_closures (
Flambda_iterators.map_symbols_on_set_of_closures
~f:substitute_symbol set_of_closures
)
| Project_closure (sym, closure_id) ->
Project_closure (substitute_symbol sym, closure_id)
let cannot_share (const : Flambda.constant_defining_value) =
match const with
(* Strings and float arrays are mutable; we never share them. *)
| Allocated_const ((String _) | (Float_array _)) -> true
| Allocated_const _ | Set_of_closures _ | Project_closure _ | Block _ ->
false
let share_definition constant_to_symbol_tbl sharing_symbol_tbl
symbol def end_symbol =
let def = update_constant_for_sharing sharing_symbol_tbl def in
if cannot_share def || Symbol.equal symbol end_symbol then
(* The symbol exported by the unit (end_symbol), cannot be removed
from the module. We prevent it from being shared to avoid that. *)
Some def
else
begin match Constant_defining_value.Tbl.find constant_to_symbol_tbl def with
| exception Not_found ->
Constant_defining_value.Tbl.add constant_to_symbol_tbl def symbol;
Some def
| equal_symbol ->
Symbol.Tbl.add sharing_symbol_tbl symbol equal_symbol;
None
end
let rec end_symbol (program : Flambda.program_body) =
match program with
| End symbol -> symbol
| Let_symbol (_, _, program)
| Let_rec_symbol (_, program)
| Initialize_symbol (_, _, _, program)
| Effect (_, program) ->
end_symbol program
let share_constants (program : Flambda.program) =
let end_symbol = end_symbol program.program_body in
let sharing_symbol_tbl = Symbol.Tbl.create 42 in
let constant_to_symbol_tbl = Constant_defining_value.Tbl.create 42 in
let rec loop (program : Flambda.program_body) : Flambda.program_body =
match program with
| Let_symbol (symbol,def,program) ->
begin match
share_definition constant_to_symbol_tbl sharing_symbol_tbl symbol
def end_symbol
with
| None ->
loop program
| Some def' ->
Let_symbol (symbol,def',loop program)
end
| Let_rec_symbol (defs,program) ->
let defs =
List.map (fun (symbol, def) ->
let def = update_constant_for_sharing sharing_symbol_tbl def in
symbol, def)
defs
in
Let_rec_symbol (defs, loop program)
| Initialize_symbol (symbol,tag,fields,program) ->
let fields =
List.map (fun field ->
Flambda_iterators.map_symbols
~f:(fun symbol ->
try Symbol.Tbl.find sharing_symbol_tbl symbol with
| Not_found -> symbol)
field)
fields
in
Initialize_symbol (symbol,tag,fields,loop program)
| Effect (expr,program) ->
let expr =
Flambda_iterators.map_symbols
~f:(fun symbol ->
try Symbol.Tbl.find sharing_symbol_tbl symbol with
| Not_found -> symbol)
expr
in
Effect (expr, loop program)
| End root -> End root
in
{ program with
program_body = loop program.program_body;
}
|
