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
19open Asttypes
20open Lambda
21
22type function_label = string
23
24type 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
34and uconstant =
35  | Uconst_ref of string * ustructured_constant option
36  | Uconst_int of int
37  | Uconst_ptr of int
38
39and ulambda =
40    Uvar of Ident.t
41  | Uconst of uconstant
42  | Udirect_apply of function_label * ulambda list * Debuginfo.t
43  | Ugeneric_apply of ulambda * ulambda list * Debuginfo.t
44  | Uclosure of ufunction list * ulambda list
45  | Uoffset of ulambda * int
46  | Ulet of mutable_flag * value_kind * Ident.t * ulambda * ulambda
47  | Uletrec of (Ident.t * ulambda) list * ulambda
48  | Uprim of primitive * ulambda list * Debuginfo.t
49  | Uswitch of ulambda * ulambda_switch
50  | Ustringswitch of ulambda * (string * ulambda) list * ulambda option
51  | Ustaticfail of int * ulambda list
52  | Ucatch of int * Ident.t list * ulambda * ulambda
53  | Utrywith of ulambda * Ident.t * ulambda
54  | Uifthenelse of ulambda * ulambda * ulambda
55  | Usequence of ulambda * ulambda
56  | Uwhile of ulambda * ulambda
57  | Ufor of Ident.t * ulambda * ulambda * direction_flag * ulambda
58  | Uassign of Ident.t * ulambda
59  | Usend of meth_kind * ulambda * ulambda * ulambda list * Debuginfo.t
60  | Uunreachable
61
62and ufunction = {
63  label  : function_label;
64  arity  : int;
65  params : Ident.t list;
66  body   : ulambda;
67  dbg    : Debuginfo.t;
68  env    : Ident.t option;
69}
70
71and ulambda_switch =
72  { us_index_consts: int array;
73    us_actions_consts : ulambda array;
74    us_index_blocks: int array;
75    us_actions_blocks: ulambda array}
76
77(* Description of known functions *)
78
79type function_description =
80  { fun_label: function_label;          (* Label of direct entry point *)
81    fun_arity: int;                     (* Number of arguments *)
82    mutable fun_closed: bool;           (* True if environment not used *)
83    mutable fun_inline: (Ident.t list * ulambda) option;
84    mutable fun_float_const_prop: bool  (* Can propagate FP consts *)
85  }
86
87(* Approximation of values *)
88
89type value_approximation =
90    Value_closure of function_description * value_approximation
91  | Value_tuple of value_approximation array
92  | Value_unknown
93  | Value_const of uconstant
94  | Value_global_field of string * int
95
96(* Preallocated globals *)
97
98type preallocated_block = {
99  symbol : string;
100  exported : bool;
101  tag : int;
102  size : int;
103}
104
105type preallocated_constant = {
106  symbol : string;
107  exported : bool;
108  definition : ustructured_constant;
109}
110
111(* Comparison functions for constants.  We must not use Pervasives.compare
112   because it compares "0.0" and "-0.0" equal.  (PR#6442) *)
113
114let compare_floats x1 x2 =
115  Int64.compare (Int64.bits_of_float x1) (Int64.bits_of_float x2)
116
117let rec compare_float_lists l1 l2 =
118  match l1, l2 with
119  | [], [] -> 0
120  | [], _::_ -> -1
121  | _::_, [] -> 1
122  | h1::t1, h2::t2 ->
123      let c = compare_floats h1 h2 in
124      if c <> 0 then c else compare_float_lists t1 t2
125
126let compare_constants c1 c2 =
127  match c1, c2 with
128  | Uconst_ref(lbl1, _c1), Uconst_ref(lbl2, _c2) -> String.compare lbl1 lbl2
129      (* Same labels -> same constants.
130         Different labels -> different constants, even if the contents
131           match, because of string constants that must not be
132           reshared. *)
133  | Uconst_int n1, Uconst_int n2 -> Pervasives.compare n1 n2
134  | Uconst_ptr n1, Uconst_ptr n2 -> Pervasives.compare n1 n2
135  | Uconst_ref _, _ -> -1
136  | Uconst_int _, Uconst_ref _ -> 1
137  | Uconst_int _, Uconst_ptr _ -> -1
138  | Uconst_ptr _, _ -> 1
139
140let rec compare_constant_lists l1 l2 =
141  match l1, l2 with
142  | [], [] -> 0
143  | [], _::_ -> -1
144  | _::_, [] -> 1
145  | h1::t1, h2::t2 ->
146      let c = compare_constants h1 h2 in
147      if c <> 0 then c else compare_constant_lists t1 t2
148
149let rank_structured_constant = function
150  | Uconst_float _ -> 0
151  | Uconst_int32 _ -> 1
152  | Uconst_int64 _ -> 2
153  | Uconst_nativeint _ -> 3
154  | Uconst_block _ -> 4
155  | Uconst_float_array _ -> 5
156  | Uconst_string _ -> 6
157  | Uconst_closure _ -> 7
158
159let compare_structured_constants c1 c2 =
160  match c1, c2 with
161  | Uconst_float x1, Uconst_float x2 -> compare_floats x1 x2
162  | Uconst_int32 x1, Uconst_int32 x2 -> Int32.compare x1 x2
163  | Uconst_int64 x1, Uconst_int64 x2 -> Int64.compare x1 x2
164  | Uconst_nativeint x1, Uconst_nativeint x2 -> Nativeint.compare x1 x2
165  | Uconst_block(t1, l1), Uconst_block(t2, l2) ->
166      let c = t1 - t2 (* no overflow possible here *) in
167      if c <> 0 then c else compare_constant_lists l1 l2
168  | Uconst_float_array l1, Uconst_float_array l2 ->
169      compare_float_lists l1 l2
170  | Uconst_string s1, Uconst_string s2 -> String.compare s1 s2
171  | Uconst_closure (_,lbl1,_), Uconst_closure (_,lbl2,_) ->
172      String.compare lbl1 lbl2
173  | _, _ ->
174    (* no overflow possible here *)
175    rank_structured_constant c1 - rank_structured_constant c2
176