1 (**************************************************************************)
2 (* *)
3 (* OCaml *)
4 (* *)
5 (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
6 (* *)
7 (* Copyright 1996 Institut National de Recherche en Informatique et *)
8 (* en Automatique. *)
9 (* *)
10 (* All rights reserved. This file is distributed under the terms of *)
11 (* the GNU Lesser General Public License version 2.1, with the *)
12 (* special exception on linking described in the file LICENSE. *)
13 (* *)
14 (**************************************************************************)
15
16 (* A variant of the "lambda" code with direct / indirect calls explicit
17 and closures explicit too *)
18
19 open Asttypes
20 open Lambda
21
22 type function_label = string
23
24 type ustructured_constant =
25 | Uconst_float of float
26 | Uconst_int32 of int32
27 | Uconst_int64 of int64
28 | Uconst_nativeint of nativeint
29 | Uconst_block of int * uconstant list
30 | Uconst_float_array of float list
31 | Uconst_string of string
32 | Uconst_closure of ufunction list * string * uconstant list
33
34 and uconstant =
35 | Uconst_ref of string * ustructured_constant option
36 | Uconst_int of int
37 | Uconst_ptr of int
38
39 and uphantom_defining_expr =
40 | Uphantom_const of uconstant
41 | Uphantom_var of Backend_var.t
42 | Uphantom_offset_var of { var : Backend_var.t; offset_in_words : int; }
43 | Uphantom_read_field of { var : Backend_var.t; field : int; }
44 | Uphantom_read_symbol_field of { sym : string; field : int; }
45 | Uphantom_block of { tag : int; fields : Backend_var.t list; }
46
47 and ulambda =
48 Uvar of Backend_var.t
49 | Uconst of uconstant
50 | Udirect_apply of function_label * ulambda list * Debuginfo.t
51 | Ugeneric_apply of ulambda * ulambda list * Debuginfo.t
52 | Uclosure of ufunction list * ulambda list
53 | Uoffset of ulambda * int
54 | Ulet of mutable_flag * value_kind * Backend_var.With_provenance.t
55 * ulambda * ulambda
56 | Uphantom_let of Backend_var.With_provenance.t
57 * uphantom_defining_expr option * ulambda
58 | Uletrec of (Backend_var.With_provenance.t * ulambda) list * ulambda
59 | Uprim of Clambda_primitives.primitive * ulambda list * Debuginfo.t
60 | Uswitch of ulambda * ulambda_switch * Debuginfo.t
61 | Ustringswitch of ulambda * (string * ulambda) list * ulambda option
62 | Ustaticfail of int * ulambda list
63 | Ucatch of
64 int *
65 (Backend_var.With_provenance.t * value_kind) list *
66 ulambda *
67 ulambda
68 | Utrywith of ulambda * Backend_var.With_provenance.t * ulambda
69 | Uifthenelse of ulambda * ulambda * ulambda
70 | Usequence of ulambda * ulambda
71 | Uwhile of ulambda * ulambda
72 | Ufor of Backend_var.With_provenance.t * ulambda * ulambda
73 * direction_flag * ulambda
74 | Uassign of Backend_var.t * ulambda
75 | Usend of meth_kind * ulambda * ulambda * ulambda list * Debuginfo.t
76 | Uunreachable
77
78 and ufunction = {
79 label : function_label;
80 arity : int;
81 params : (Backend_var.With_provenance.t * value_kind) list;
82 return : value_kind;
83 body : ulambda;
84 dbg : Debuginfo.t;
85 env : Backend_var.t option;
86 }
87
88 and ulambda_switch =
89 { us_index_consts: int array;
90 us_actions_consts : ulambda array;
91 us_index_blocks: int array;
92 us_actions_blocks: ulambda array}
93
94 (* Description of known functions *)
95
96 type function_description =
97 { fun_label: function_label; (* Label of direct entry point *)
98 fun_arity: int; (* Number of arguments *)
99 mutable fun_closed: bool; (* True if environment not used *)
100 mutable fun_inline: (Backend_var.With_provenance.t list * ulambda) option;
101 mutable fun_float_const_prop: bool (* Can propagate FP consts *)
102 }
103
104 (* Approximation of values *)
105
106 type value_approximation =
107 Value_closure of function_description * value_approximation
108 | Value_tuple of value_approximation array
109 | Value_unknown
110 | Value_const of uconstant
111 | Value_global_field of string * int
112
113 (* Preallocated globals *)
114
115 type usymbol_provenance = {
116 original_idents : Ident.t list;
117 module_path : Path.t;
118 }
119
120 type uconstant_block_field =
121 | Uconst_field_ref of string
122 | Uconst_field_int of int
123
124 type preallocated_block = {
125 symbol : string;
126 exported : bool;
127 tag : int;
128 fields : uconstant_block_field option list;
129 provenance : usymbol_provenance option;
130 }
131
132 type preallocated_constant = {
133 symbol : string;
134 exported : bool;
135 definition : ustructured_constant;
136 provenance : usymbol_provenance option;
137 }
138
139 type with_constants =
140 ulambda * preallocated_block list * preallocated_constant list
141
142 (* Comparison functions for constants. We must not use Stdlib.compare
143 because it compares "0.0" and "-0.0" equal. (PR#6442) *)
144
145 let compare_floats x1 x2 =
146 Int64.compare (Int64.bits_of_float x1) (Int64.bits_of_float x2)
147
148 let rec compare_float_lists l1 l2 =
149 match l1, l2 with
150 | [], [] -> 0
151 | [], _::_ -> -1
152 | _::_, [] -> 1
153 | h1::t1, h2::t2 ->
154 let c = compare_floats h1 h2 in
155 if c <> 0 then c else compare_float_lists t1 t2
156
157 let compare_constants c1 c2 =
158 match c1, c2 with
159 | Uconst_ref(lbl1, _c1), Uconst_ref(lbl2, _c2) -> String.compare lbl1 lbl2
160 (* Same labels -> same constants.
161 Different labels -> different constants, even if the contents
162 match, because of string constants that must not be
163 reshared. *)
164 | Uconst_int n1, Uconst_int n2 -> Stdlib.compare n1 n2
165 | Uconst_ptr n1, Uconst_ptr n2 -> Stdlib.compare n1 n2
166 | Uconst_ref _, _ -> -1
167 | Uconst_int _, Uconst_ref _ -> 1
168 | Uconst_int _, Uconst_ptr _ -> -1
169 | Uconst_ptr _, _ -> 1
170
171 let rec compare_constant_lists l1 l2 =
172 match l1, l2 with
173 | [], [] -> 0
174 | [], _::_ -> -1
175 | _::_, [] -> 1
176 | h1::t1, h2::t2 ->
177 let c = compare_constants h1 h2 in
178 if c <> 0 then c else compare_constant_lists t1 t2
179
180 let rank_structured_constant = function
181 | Uconst_float _ -> 0
182 | Uconst_int32 _ -> 1
183 | Uconst_int64 _ -> 2
184 | Uconst_nativeint _ -> 3
185 | Uconst_block _ -> 4
186 | Uconst_float_array _ -> 5
187 | Uconst_string _ -> 6
188 | Uconst_closure _ -> 7
189
190 let compare_structured_constants c1 c2 =
191 match c1, c2 with
192 | Uconst_float x1, Uconst_float x2 -> compare_floats x1 x2
193 | Uconst_int32 x1, Uconst_int32 x2 -> Int32.compare x1 x2
194 | Uconst_int64 x1, Uconst_int64 x2 -> Int64.compare x1 x2
195 | Uconst_nativeint x1, Uconst_nativeint x2 -> Nativeint.compare x1 x2
196 | Uconst_block(t1, l1), Uconst_block(t2, l2) ->
197 let c = t1 - t2 (* no overflow possible here *) in
198 if c <> 0 then c else compare_constant_lists l1 l2
199 | Uconst_float_array l1, Uconst_float_array l2 ->
200 compare_float_lists l1 l2
201 | Uconst_string s1, Uconst_string s2 -> String.compare s1 s2
202 | Uconst_closure (_,lbl1,_), Uconst_closure (_,lbl2,_) ->
203 String.compare lbl1 lbl2
204 | _, _ ->
205 (* no overflow possible here *)
206 rank_structured_constant c1 - rank_structured_constant c2
207