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 (* The "lambda" intermediate code *)
17
18 open Asttypes
19
20 type compile_time_constant =
21 | Big_endian
22 | Word_size
23 | Int_size
24 | Max_wosize
25 | Ostype_unix
26 | Ostype_win32
27 | Ostype_cygwin
28 | Backend_type
29
30 type immediate_or_pointer =
31 | Immediate
32 | Pointer
33
34 type initialization_or_assignment =
35 | Assignment
36 (* Initialization of in heap values, like [caml_initialize] C primitive. The
37 field should not have been read before and initialization should happen
38 only once. *)
39 | Heap_initialization
40 (* Initialization of roots only. Compiles to a simple store.
41 No checks are done to preserve GC invariants. *)
42 | Root_initialization
43
44 type is_safe =
45 | Safe
46 | Unsafe
47
48 type primitive =
49 | Pidentity
50 | Pbytes_to_string
51 | Pbytes_of_string
52 | Pignore
53 | Prevapply
54 | Pdirapply
55 (* Globals *)
56 | Pgetglobal of Ident.t
57 | Psetglobal of Ident.t
58 (* Operations on heap blocks *)
59 | Pmakeblock of int * mutable_flag * block_shape
60 | Pfield of int
61 | Pfield_computed
62 | Psetfield of int * immediate_or_pointer * initialization_or_assignment
63 | Psetfield_computed of immediate_or_pointer * initialization_or_assignment
64 | Pfloatfield of int
65 | Psetfloatfield of int * initialization_or_assignment
66 | Pduprecord of Types.record_representation * int
67 (* External call *)
68 | Pccall of Primitive.description
69 (* Exceptions *)
70 | Praise of raise_kind
71 (* Boolean operations *)
72 | Psequand | Psequor | Pnot
73 (* Integer operations *)
74 | Pnegint | Paddint | Psubint | Pmulint
75 | Pdivint of is_safe | Pmodint of is_safe
76 | Pandint | Porint | Pxorint
77 | Plslint | Plsrint | Pasrint
78 | Pintcomp of integer_comparison
79 | Poffsetint of int
80 | Poffsetref of int
81 (* Float operations *)
82 | Pintoffloat | Pfloatofint
83 | Pnegfloat | Pabsfloat
84 | Paddfloat | Psubfloat | Pmulfloat | Pdivfloat
85 | Pfloatcomp of float_comparison
86 (* String operations *)
87 | Pstringlength | Pstringrefu | Pstringrefs
88 | Pbyteslength | Pbytesrefu | Pbytessetu | Pbytesrefs | Pbytessets
89 (* Array operations *)
90 | Pmakearray of array_kind * mutable_flag
91 | Pduparray of array_kind * mutable_flag
92 (** For [Pduparray], the argument must be an immutable array.
93 The arguments of [Pduparray] give the kind and mutability of the
94 array being *produced* by the duplication. *)
95 | Parraylength of array_kind
96 | Parrayrefu of array_kind
97 | Parraysetu of array_kind
98 | Parrayrefs of array_kind
99 | Parraysets of array_kind
100 (* Test if the argument is a block or an immediate integer *)
101 | Pisint
102 (* Test if the (integer) argument is outside an interval *)
103 | Pisout
104 (* Operations on boxed integers (Nativeint.t, Int32.t, Int64.t) *)
105 | Pbintofint of boxed_integer
106 | Pintofbint of boxed_integer
107 | Pcvtbint of boxed_integer (*source*) * boxed_integer (*destination*)
108 | Pnegbint of boxed_integer
109 | Paddbint of boxed_integer
110 | Psubbint of boxed_integer
111 | Pmulbint of boxed_integer
112 | Pdivbint of { size : boxed_integer; is_safe : is_safe }
113 | Pmodbint of { size : boxed_integer; is_safe : is_safe }
114 | Pandbint of boxed_integer
115 | Porbint of boxed_integer
116 | Pxorbint of boxed_integer
117 | Plslbint of boxed_integer
118 | Plsrbint of boxed_integer
119 | Pasrbint of boxed_integer
120 | Pbintcomp of boxed_integer * integer_comparison
121 (* Operations on Bigarrays: (unsafe, #dimensions, kind, layout) *)
122 | Pbigarrayref of bool * int * bigarray_kind * bigarray_layout
123 | Pbigarrayset of bool * int * bigarray_kind * bigarray_layout
124 (* size of the nth dimension of a Bigarray *)
125 | Pbigarraydim of int
126 (* load/set 16,32,64 bits from a string: (unsafe)*)
127 | Pstring_load_16 of bool
128 | Pstring_load_32 of bool
129 | Pstring_load_64 of bool
130 | Pbytes_load_16 of bool
131 | Pbytes_load_32 of bool
132 | Pbytes_load_64 of bool
133 | Pbytes_set_16 of bool
134 | Pbytes_set_32 of bool
135 | Pbytes_set_64 of bool
136 (* load/set 16,32,64 bits from a
137 (char, int8_unsigned_elt, c_layout) Bigarray.Array1.t : (unsafe) *)
138 | Pbigstring_load_16 of bool
139 | Pbigstring_load_32 of bool
140 | Pbigstring_load_64 of bool
141 | Pbigstring_set_16 of bool
142 | Pbigstring_set_32 of bool
143 | Pbigstring_set_64 of bool
144 (* Compile time constants *)
145 | Pctconst of compile_time_constant
146 (* byte swap *)
147 | Pbswap16
148 | Pbbswap of boxed_integer
149 (* Integer to external pointer *)
150 | Pint_as_pointer
151 (* Inhibition of optimisation *)
152 | Popaque
153
154 and integer_comparison =
155 Ceq | Cne | Clt | Cgt | Cle | Cge
156
157 and float_comparison =
158 CFeq | CFneq | CFlt | CFnlt | CFgt | CFngt | CFle | CFnle | CFge | CFnge
159
160 and array_kind =
161 Pgenarray | Paddrarray | Pintarray | Pfloatarray
162
163 and value_kind =
164 Pgenval | Pfloatval | Pboxedintval of boxed_integer | Pintval
165
166 and block_shape =
167 value_kind list option
168
169 and boxed_integer = Primitive.boxed_integer =
170 Pnativeint | Pint32 | Pint64
171
172 and bigarray_kind =
173 Pbigarray_unknown
174 | Pbigarray_float32 | Pbigarray_float64
175 | Pbigarray_sint8 | Pbigarray_uint8
176 | Pbigarray_sint16 | Pbigarray_uint16
177 | Pbigarray_int32 | Pbigarray_int64
178 | Pbigarray_caml_int | Pbigarray_native_int
179 | Pbigarray_complex32 | Pbigarray_complex64
180
181 and bigarray_layout =
182 Pbigarray_unknown_layout
183 | Pbigarray_c_layout
184 | Pbigarray_fortran_layout
185
186 and raise_kind =
187 | Raise_regular
188 | Raise_reraise
189 | Raise_notrace
190
191 val equal_primitive : primitive -> primitive -> bool
192
193 val equal_value_kind : value_kind -> value_kind -> bool
194
195 val equal_boxed_integer : boxed_integer -> boxed_integer -> bool
196
197 type structured_constant =
198 Const_base of constant
199 | Const_pointer of int
200 | Const_block of int * structured_constant list
201 | Const_float_array of string list
202 | Const_immstring of string
203
204 type inline_attribute =
205 | Always_inline (* [@inline] or [@inline always] *)
206 | Never_inline (* [@inline never] *)
207 | Unroll of int (* [@unroll x] *)
208 | Default_inline (* no [@inline] attribute *)
209
210 val equal_inline_attribute : inline_attribute -> inline_attribute -> bool
211
212 type specialise_attribute =
213 | Always_specialise (* [@specialise] or [@specialise always] *)
214 | Never_specialise (* [@specialise never] *)
215 | Default_specialise (* no [@specialise] attribute *)
216
217 val equal_specialise_attribute
218 : specialise_attribute
219 -> specialise_attribute
220 -> bool
221
222 type local_attribute =
223 | Always_local (* [@local] or [@local always] *)
224 | Never_local (* [@local never] *)
225 | Default_local (* [@local maybe] or no [@local] attribute *)
226
227 type function_kind = Curried | Tupled
228
229 type let_kind = Strict | Alias | StrictOpt | Variable
230 (* Meaning of kinds for let x = e in e':
231 Strict: e may have side-effects; always evaluate e first
232 (If e is a simple expression, e.g. a variable or constant,
233 we may still substitute e'[x/e].)
234 Alias: e is pure, we can substitute e'[x/e] if x has 0 or 1 occurrences
235 in e'
236 StrictOpt: e does not have side-effects, but depend on the store;
237 we can discard e if x does not appear in e'
238 Variable: the variable x is assigned later in e'
239 *)
240
241 type meth_kind = Self | Public | Cached
242
243 val equal_meth_kind : meth_kind -> meth_kind -> bool
244
245 type shared_code = (int * int) list (* stack size -> code label *)
246
247 type function_attribute = {
248 inline : inline_attribute;
249 specialise : specialise_attribute;
250 local: local_attribute;
251 is_a_functor: bool;
252 stub: bool;
253 }
254
255 type lambda =
256 Lvar of Ident.t
257 | Lconst of structured_constant
258 | Lapply of lambda_apply
259 | Lfunction of lfunction
260 | Llet of let_kind * value_kind * Ident.t * lambda * lambda
261 | Lletrec of (Ident.t * lambda) list * lambda
262 | Lprim of primitive * lambda list * Location.t
263 | Lswitch of lambda * lambda_switch * Location.t
264 (* switch on strings, clauses are sorted by string order,
265 strings are pairwise distinct *)
266 | Lstringswitch of
267 lambda * (string * lambda) list * lambda option * Location.t
268 | Lstaticraise of int * lambda list
269 | Lstaticcatch of lambda * (int * (Ident.t * value_kind) list) * lambda
270 | Ltrywith of lambda * Ident.t * lambda
271 (* Lifthenelse (e, t, f) evaluates t if e evaluates to 0, and
272 evaluates f if e evaluates to any other value *)
273 | Lifthenelse of lambda * lambda * lambda
274 | Lsequence of lambda * lambda
275 | Lwhile of lambda * lambda
276 | Lfor of Ident.t * lambda * lambda * direction_flag * lambda
277 | Lassign of Ident.t * lambda
278 | Lsend of meth_kind * lambda * lambda * lambda list * Location.t
279 | Levent of lambda * lambda_event
280 | Lifused of Ident.t * lambda
281
282 and lfunction =
283 { kind: function_kind;
284 params: (Ident.t * value_kind) list;
285 return: value_kind;
286 body: lambda;
287 attr: function_attribute; (* specified with [@inline] attribute *)
288 loc : Location.t; }
289
290 and lambda_apply =
291 { ap_func : lambda;
292 ap_args : lambda list;
293 ap_loc : Location.t;
294 ap_should_be_tailcall : bool; (* true if [@tailcall] was specified *)
295 ap_inlined : inline_attribute; (* specified with the [@inlined] attribute *)
296 ap_specialised : specialise_attribute; }
297
298 and lambda_switch =
299 { sw_numconsts: int; (* Number of integer cases *)
300 sw_consts: (int * lambda) list; (* Integer cases *)
301 sw_numblocks: int; (* Number of tag block cases *)
302 sw_blocks: (int * lambda) list; (* Tag block cases *)
303 sw_failaction : lambda option} (* Action to take if failure *)
304 and lambda_event =
305 { lev_loc: Location.t;
306 lev_kind: lambda_event_kind;
307 lev_repr: int ref option;
308 lev_env: Env.t }
309
310 and lambda_event_kind =
311 Lev_before
312 | Lev_after of Types.type_expr
313 | Lev_function
314 | Lev_pseudo
315 | Lev_module_definition of Ident.t
316
317 type program =
318 { module_ident : Ident.t;
319 main_module_block_size : int;
320 required_globals : Ident.Set.t; (* Modules whose initializer side effects
321 must occur before [code]. *)
322 code : lambda }
323 (* Lambda code for the middle-end.
324 * In the closure case the code is a sequence of assignments to a
325 preallocated block of size [main_module_block_size] using
326 (Setfield(Getglobal(module_ident))). The size is used to preallocate
327 the block.
328 * In the flambda case the code is an expression returning a block
329 value of size [main_module_block_size]. The size is used to build
330 the module root as an initialize_symbol
331 Initialize_symbol(module_name, 0,
332 [getfield 0; ...; getfield (main_module_block_size - 1)])
333 *)
334
335 (* Sharing key *)
336 val make_key: lambda -> lambda option
337
338 val const_unit: structured_constant
339 val lambda_unit: lambda
340 val name_lambda: let_kind -> lambda -> (Ident.t -> lambda) -> lambda
341 val name_lambda_list: lambda list -> (lambda list -> lambda) -> lambda
342
343 val iter_head_constructor: (lambda -> unit) -> lambda -> unit
344 (** [iter_head_constructor f lam] apply [f] to only the first level of
345 sub expressions of [lam]. It does not recursively traverse the
346 expression.
347 *)
348
349 val shallow_iter:
350 tail:(lambda -> unit) ->
351 non_tail:(lambda -> unit) ->
352 lambda -> unit
353 (** Same as [iter_head_constructor], but use a different callback for
354 sub-terms which are in tail position or not. *)
355
356 val transl_prim: string -> string -> lambda
357 (** Translate a value from a persistent module. For instance:
358
359 {[
360 transl_internal_value "CamlinternalLazy" "force"
361 ]}
362 *)
363
364 val free_variables: lambda -> Ident.Set.t
365
366 val transl_module_path: Location.t -> Env.t -> Path.t -> lambda
367 val transl_value_path: Location.t -> Env.t -> Path.t -> lambda
368 val transl_extension_path: Location.t -> Env.t -> Path.t -> lambda
369 val transl_class_path: Location.t -> Env.t -> Path.t -> lambda
370
371 val make_sequence: ('a -> lambda) -> 'a list -> lambda
372
373 val subst: (Ident.t -> Types.value_description -> Env.t -> Env.t) ->
374 lambda Ident.Map.t -> lambda -> lambda
375 (** [subst env_update_fun s lt] applies a substitution [s] to the lambda-term
376 [lt].
377
378 Assumes that the image of the substitution is out of reach
379 of the bound variables of the lambda-term (no capture).
380
381 [env_update_fun] is used to refresh the environment contained in debug
382 events. *)
383
384 val rename : Ident.t Ident.Map.t -> lambda -> lambda
385 (** A version of [subst] specialized for the case where we're just renaming
386 idents. *)
387
388 val map : (lambda -> lambda) -> lambda -> lambda
389 (** Bottom-up rewriting, applying the function on
390 each node from the leaves to the root. *)
391
392 val shallow_map : (lambda -> lambda) -> lambda -> lambda
393 (** Rewrite each immediate sub-term with the function. *)
394
395 val bind : let_kind -> Ident.t -> lambda -> lambda -> lambda
396 val bind_with_value_kind:
397 let_kind -> (Ident.t * value_kind) -> lambda -> lambda -> lambda
398
399 val negate_integer_comparison : integer_comparison -> integer_comparison
400 val swap_integer_comparison : integer_comparison -> integer_comparison
401
402 val negate_float_comparison : float_comparison -> float_comparison
403 val swap_float_comparison : float_comparison -> float_comparison
404
405 val default_function_attribute : function_attribute
406 val default_stub_attribute : function_attribute
407
408 val function_is_curried : lfunction -> bool
409
410 (***********************)
411 (* For static failures *)
412 (***********************)
413
414 (* Get a new static failure ident *)
415 val next_raise_count : unit -> int
416
417 val staticfail : lambda (* Anticipated static failure *)
418
419 (* Check anticipated failure, substitute its final value *)
420 val is_guarded: lambda -> bool
421 val patch_guarded : lambda -> lambda -> lambda
422
423 val raise_kind: raise_kind -> string
424
425 val merge_inline_attributes
426 : inline_attribute
427 -> inline_attribute
428 -> inline_attribute option
429
430 val reset: unit -> unit
431