anil.recoil.org
My working unpac repository
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
18open Asttypes
19
20type 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 | Standard_library_default
30
31type immediate_or_pointer =
32 | Immediate
33 (* The value must be immediate. *)
34 | Pointer
35 (* The value may be a pointer or an immediate. *)
36
37type initialization_or_assignment =
38 | Assignment
39 (* Initialization of in heap values, like [caml_initialize] C primitive. The
40 field should not have been read before and initialization should happen
41 only once. *)
42 | Heap_initialization
43 (* Initialization of roots only. Compiles to a simple store.
44 No checks are done to preserve GC invariants. *)
45 | Root_initialization
46
47type is_safe =
48 | Safe
49 | Unsafe
50
51type lazy_block_tag =
52 | Lazy_tag
53 | Forward_tag
54
55type primitive =
56 | Pbytes_to_string
57 | Pbytes_of_string
58 | Pignore
59 (* Globals *)
60 | Pgetglobal of Ident.t
61 | Psetglobal of Ident.t
62 (* Operations on heap blocks *)
63 | Pmakeblock of int * mutable_flag * block_shape
64 | Pmakelazyblock of lazy_block_tag
65 | Pfield of int * immediate_or_pointer * mutable_flag
66 | Pfield_computed
67 | Psetfield of int * immediate_or_pointer * initialization_or_assignment
68 | Psetfield_computed of immediate_or_pointer * initialization_or_assignment
69 | Pfloatfield of int
70 | Psetfloatfield of int * initialization_or_assignment
71 | Pduprecord of Types.record_representation * int
72 (* Context switches *)
73 | Prunstack
74 | Pperform
75 | Presume
76 | Preperform
77 (* External call *)
78 | Pccall of Primitive.description
79 (* Exceptions *)
80 | Praise of raise_kind
81 (* Boolean operations *)
82 | Psequand | Psequor | Pnot
83 (* Integer operations *)
84 | Pnegint | Paddint | Psubint | Pmulint
85 | Pdivint of is_safe | Pmodint of is_safe
86 | Pandint | Porint | Pxorint
87 | Plslint | Plsrint | Pasrint
88 | Pintcomp of integer_comparison
89 (* Comparisons that return int (not bool like above) for ordering *)
90 | Pcompare_ints | Pcompare_floats | Pcompare_bints of boxed_integer
91 | Poffsetint of int
92 | Poffsetref of int
93 (* Float operations *)
94 | Pintoffloat | Pfloatofint
95 | Pnegfloat | Pabsfloat
96 | Paddfloat | Psubfloat | Pmulfloat | Pdivfloat
97 | Pfloatcomp of float_comparison
98 (* String operations *)
99 | Pstringlength | Pstringrefu | Pstringrefs
100 | Pbyteslength | Pbytesrefu | Pbytessetu | Pbytesrefs | Pbytessets
101 (* Array operations *)
102 | Pmakearray of array_kind * mutable_flag
103 | Pduparray of array_kind * mutable_flag
104 (** For [Pduparray], the argument must be an immutable array.
105 The arguments of [Pduparray] give the kind and mutability of the
106 array being *produced* by the duplication. *)
107 | Parraylength of array_kind
108 | Parrayrefu of array_kind
109 | Parraysetu of array_kind
110 | Parrayrefs of array_kind
111 | Parraysets of array_kind
112 (* Test if the argument is a block or an immediate integer *)
113 | Pisint
114 (* Test if the (integer) argument is outside an interval *)
115 | Pisout
116 (* Operations on boxed integers (Nativeint.t, Int32.t, Int64.t) *)
117 | Pbintofint of boxed_integer
118 | Pintofbint of boxed_integer
119 | Pcvtbint of boxed_integer (*source*) * boxed_integer (*destination*)
120 | Pnegbint of boxed_integer
121 | Paddbint of boxed_integer
122 | Psubbint of boxed_integer
123 | Pmulbint of boxed_integer
124 | Pdivbint of { size : boxed_integer; is_safe : is_safe }
125 | Pmodbint of { size : boxed_integer; is_safe : is_safe }
126 | Pandbint of boxed_integer
127 | Porbint of boxed_integer
128 | Pxorbint of boxed_integer
129 | Plslbint of boxed_integer
130 | Plsrbint of boxed_integer
131 | Pasrbint of boxed_integer
132 | Pbintcomp of boxed_integer * integer_comparison
133 (* Operations on Bigarrays: (unsafe, #dimensions, kind, layout) *)
134 | Pbigarrayref of bool * int * bigarray_kind * bigarray_layout
135 | Pbigarrayset of bool * int * bigarray_kind * bigarray_layout
136 (* size of the nth dimension of a Bigarray *)
137 | Pbigarraydim of int
138 (* load/set 16,32,64 bits from a string: (unsafe)*)
139 | Pstring_load_16 of bool
140 | Pstring_load_32 of bool
141 | Pstring_load_64 of bool
142 | Pbytes_load_16 of bool
143 | Pbytes_load_32 of bool
144 | Pbytes_load_64 of bool
145 | Pbytes_set_16 of bool
146 | Pbytes_set_32 of bool
147 | Pbytes_set_64 of bool
148 (* load/set 16,32,64 bits from a
149 (char, int8_unsigned_elt, c_layout) Bigarray.Array1.t : (unsafe) *)
150 | Pbigstring_load_16 of bool
151 | Pbigstring_load_32 of bool
152 | Pbigstring_load_64 of bool
153 | Pbigstring_set_16 of bool
154 | Pbigstring_set_32 of bool
155 | Pbigstring_set_64 of bool
156 (* Compile time constants *)
157 | Pctconst of compile_time_constant
158 (* byte swap *)
159 | Pbswap16
160 | Pbbswap of boxed_integer
161 (* Integer to external pointer *)
162 | Pint_as_pointer
163 (* Atomic operations *)
164 | Patomic_load
165 (* Inhibition of optimisation *)
166 | Popaque
167 (* Fetching domain-local state *)
168 | Pdls_get
169 (* Poll for runtime actions. May run pending actions such as signal
170 handlers, finalizers, memprof callbacks, etc, as well as GCs and
171 GC slices, so should not be moved or optimised away. *)
172 | Ppoll
173
174and integer_comparison =
175 Ceq | Cne | Clt | Cgt | Cle | Cge
176
177and float_comparison =
178 CFeq | CFneq | CFlt | CFnlt | CFgt | CFngt | CFle | CFnle | CFge | CFnge
179
180and array_kind =
181 Pgenarray | Paddrarray | Pintarray | Pfloatarray
182
183and value_kind =
184 Pgenval | Pfloatval | Pboxedintval of boxed_integer | Pintval
185
186and block_shape =
187 value_kind list option
188
189and boxed_integer = Primitive.boxed_integer =
190 Pnativeint | Pint32 | Pint64
191
192and bigarray_kind =
193 Pbigarray_unknown
194 | Pbigarray_float16 | Pbigarray_float32 | Pbigarray_float64
195 | Pbigarray_sint8 | Pbigarray_uint8
196 | Pbigarray_sint16 | Pbigarray_uint16
197 | Pbigarray_int32 | Pbigarray_int64
198 | Pbigarray_caml_int | Pbigarray_native_int
199 | Pbigarray_complex32 | Pbigarray_complex64
200
201and bigarray_layout =
202 Pbigarray_unknown_layout
203 | Pbigarray_c_layout
204 | Pbigarray_fortran_layout
205
206and raise_kind =
207 | Raise_regular
208 | Raise_reraise
209 | Raise_notrace
210
211val equal_primitive : primitive -> primitive -> bool
212
213val equal_value_kind : value_kind -> value_kind -> bool
214
215val equal_boxed_integer : boxed_integer -> boxed_integer -> bool
216
217type structured_constant =
218 Const_int of int
219 | Const_char of char
220 | Const_float of string
221 | Const_int32 of int32
222 | Const_int64 of int64
223 | Const_nativeint of nativeint
224 | Const_block of int * structured_constant list
225 | Const_float_array of string list
226 | Const_immstring of string
227
228type tailcall_attribute =
229 | Tailcall_expectation of bool
230 (* [@tailcall] and [@tailcall true] have [true],
231 [@tailcall false] has [false] *)
232 | Default_tailcall (* no [@tailcall] attribute *)
233
234type inline_attribute =
235 | Always_inline (* [@inline] or [@inline always] *)
236 | Never_inline (* [@inline never] *)
237 | Hint_inline (* [@inline hint] *)
238 | Unroll of int (* [@unroll x] *)
239 | Default_inline (* no [@inline] attribute *)
240
241val equal_inline_attribute : inline_attribute -> inline_attribute -> bool
242
243type specialise_attribute =
244 | Always_specialise (* [@specialise] or [@specialise always] *)
245 | Never_specialise (* [@specialise never] *)
246 | Default_specialise (* no [@specialise] attribute *)
247
248val equal_specialise_attribute
249 : specialise_attribute
250 -> specialise_attribute
251 -> bool
252
253type local_attribute =
254 | Always_local (* [@local] or [@local always] *)
255 | Never_local (* [@local never] *)
256 | Default_local (* [@local maybe] or no [@local] attribute *)
257
258type poll_attribute =
259 | Error_poll (* [@poll error] *)
260 | Default_poll (* no [@poll] attribute *)
261
262type function_kind = Curried | Tupled
263
264type let_kind = Strict | Alias | StrictOpt
265(* Meaning of kinds for let x = e in e':
266 Strict: e may have side-effects; always evaluate e first
267 (If e is a simple expression, e.g. a variable or constant,
268 we may still substitute e'[x/e].)
269 Alias: e is pure, we can substitute e'[x/e] if x has 0 or 1 occurrences
270 in e'
271 StrictOpt: e does not have side-effects, but depend on the store;
272 we can discard e if x does not appear in e'
273 *)
274
275type meth_kind = Self | Public | Cached
276
277val equal_meth_kind : meth_kind -> meth_kind -> bool
278
279type shared_code = (int * int) list (* stack size -> code label *)
280
281type function_attribute = {
282 inline : inline_attribute;
283 specialise : specialise_attribute;
284 local: local_attribute;
285 poll: poll_attribute;
286 is_a_functor: bool;
287 stub: bool;
288 tmc_candidate: bool;
289 (* [simplif.ml] (in the `simplif` function within `simplify_lets`) attempts to
290 fuse nested functions, rewriting e.g. [fun x -> fun y -> e] to
291 [fun x y -> e]. This fusion is allowed only when the [may_fuse_arity] field
292 on *both* functions involved is [true]. *)
293 may_fuse_arity: bool;
294}
295
296type scoped_location = Debuginfo.Scoped_location.t
297
298type lambda =
299 Lvar of Ident.t
300 | Lmutvar of Ident.t
301 | Lconst of structured_constant
302 | Lapply of lambda_apply
303 | Lfunction of lfunction
304 | Llet of let_kind * value_kind * Ident.t * lambda * lambda
305 | Lmutlet of value_kind * Ident.t * lambda * lambda
306 | Lletrec of rec_binding list * lambda
307 | Lprim of primitive * lambda list * scoped_location
308 | Lswitch of lambda * lambda_switch * scoped_location
309(* switch on strings, clauses are sorted by string order,
310 strings are pairwise distinct *)
311 | Lstringswitch of
312 lambda * (string * lambda) list * lambda option * scoped_location
313 | Lstaticraise of int * lambda list
314 | Lstaticcatch of lambda * (int * (Ident.t * value_kind) list) * lambda
315 | Ltrywith of lambda * Ident.t * lambda
316(* Lifthenelse (e, t, f) evaluates t if e evaluates to 0, and
317 evaluates f if e evaluates to any other value *)
318 | Lifthenelse of lambda * lambda * lambda
319 | Lsequence of lambda * lambda
320 | Lwhile of lambda * lambda
321 | Lfor of Ident.t * lambda * lambda * direction_flag * lambda
322 | Lassign of Ident.t * lambda
323 | Lsend of meth_kind * lambda * lambda * lambda list * scoped_location
324 | Levent of lambda * lambda_event
325 | Lifused of Ident.t * lambda
326
327and rec_binding = {
328 id : Ident.t;
329 def : lfunction;
330 (* Generic recursive bindings have been removed from Lambda in 5.2.
331 [Value_rec_compiler.compile_letrec] deals with transforming generic
332 definitions into basic Lambda code. *)
333}
334
335and lfunction = private
336 { kind: function_kind;
337 params: (Ident.t * value_kind) list;
338 return: value_kind;
339 body: lambda;
340 attr: function_attribute; (* specified with [@inline] attribute *)
341 loc : scoped_location; }
342
343and lambda_apply =
344 { ap_func : lambda;
345 ap_args : lambda list;
346 ap_loc : scoped_location;
347 ap_tailcall : tailcall_attribute;
348 ap_inlined : inline_attribute; (* specified with the [@inlined] attribute *)
349 ap_specialised : specialise_attribute; }
350
351and lambda_switch =
352 { sw_numconsts: int; (* Number of integer cases *)
353 sw_consts: (int * lambda) list; (* Integer cases *)
354 sw_numblocks: int; (* Number of tag block cases *)
355 sw_blocks: (int * lambda) list; (* Tag block cases *)
356 sw_failaction : lambda option} (* Action to take if failure *)
357
358and lambda_event =
359 { lev_loc: scoped_location;
360 lev_kind: lambda_event_kind;
361 lev_repr: int ref option;
362 lev_env: Env.t }
363
364and lambda_event_kind =
365 Lev_before
366 | Lev_after of Types.type_expr
367 | Lev_function
368 | Lev_pseudo
369
370type program =
371 { module_ident : Ident.t;
372 main_module_block_size : int;
373 required_globals : Ident.Set.t; (* Modules whose initializer side effects
374 must occur before [code]. *)
375 code : lambda }
376(* Lambda code for the middle-end.
377 * In the closure case the code is a sequence of assignments to a
378 preallocated block of size [main_module_block_size] using
379 (Setfield(Getglobal(module_ident))). The size is used to preallocate
380 the block.
381 * In the flambda case the code is an expression returning a block
382 value of size [main_module_block_size]. The size is used to build
383 the module root as an initialize_symbol
384 Initialize_symbol(module_name, 0,
385 [getfield 0; ...; getfield (main_module_block_size - 1)])
386*)
387
388(* Sharing key *)
389val make_key: lambda -> lambda option
390
391val const_unit: structured_constant
392val const_int : int -> structured_constant
393val lambda_unit: lambda
394
395val lambda_of_const : Asttypes.constant -> lambda
396
397(** [dummy_constant] produces a plecholder value with a recognizable
398 bit pattern (currently 0xBBBB in its tagged form) *)
399val dummy_constant: lambda
400val name_lambda: let_kind -> lambda -> (Ident.t -> lambda) -> lambda
401val name_lambda_list: lambda list -> (lambda list -> lambda) -> lambda
402
403val lfunction :
404 kind:function_kind ->
405 params:(Ident.t * value_kind) list ->
406 return:value_kind ->
407 body:lambda ->
408 attr:function_attribute -> (* specified with [@inline] attribute *)
409 loc:scoped_location ->
410 lambda
411
412val lfunction' :
413 kind:function_kind ->
414 params:(Ident.t * value_kind) list ->
415 return:value_kind ->
416 body:lambda ->
417 attr:function_attribute -> (* specified with [@inline] attribute *)
418 loc:scoped_location ->
419 lfunction
420
421
422val iter_head_constructor: (lambda -> unit) -> lambda -> unit
423(** [iter_head_constructor f lam] apply [f] to only the first level of
424 sub expressions of [lam]. It does not recursively traverse the
425 expression.
426*)
427
428val shallow_iter:
429 tail:(lambda -> unit) ->
430 non_tail:(lambda -> unit) ->
431 lambda -> unit
432(** Same as [iter_head_constructor], but use a different callback for
433 sub-terms which are in tail position or not. *)
434
435val transl_prim: string -> string -> lambda
436(** Translate a value from a persistent module. For instance:
437
438 {[
439 transl_prim "CamlinternalLazy" "force"
440 ]}
441*)
442
443val is_evaluated : lambda -> bool
444(** [is_evaluated lam] returns [true] if [lam] is either a constant, a variable
445 or a function abstract. *)
446
447val free_variables: lambda -> Ident.Set.t
448
449val transl_module_path: scoped_location -> Env.t -> Path.t -> lambda
450val transl_value_path: scoped_location -> Env.t -> Path.t -> lambda
451val transl_extension_path: scoped_location -> Env.t -> Path.t -> lambda
452val transl_class_path: scoped_location -> Env.t -> Path.t -> lambda
453
454val make_sequence: ('a -> lambda) -> 'a list -> lambda
455
456val subst:
457 (Ident.t -> Types.value_description -> Env.t -> Env.t) ->
458 ?freshen_bound_variables:bool ->
459 lambda Ident.Map.t -> lambda -> lambda
460(** [subst update_env ?freshen_bound_variables s lt]
461 applies a substitution [s] to the lambda-term [lt].
462
463 Assumes that the image of the substitution is out of reach
464 of the bound variables of the lambda-term (no capture).
465
466 [update_env] is used to refresh the environment contained in debug
467 events.
468
469 [freshen_bound_variables], which defaults to [false], freshens
470 the bound variables within [lt].
471 *)
472
473val rename : Ident.t Ident.Map.t -> lambda -> lambda
474(** A version of [subst] specialized for the case where we're just renaming
475 idents. *)
476
477val duplicate_function : lfunction -> lfunction
478(** Duplicate a term, freshening all locally-bound identifiers. *)
479
480val map : (lambda -> lambda) -> lambda -> lambda
481 (** Bottom-up rewriting, applying the function on
482 each node from the leaves to the root. *)
483
484val map_lfunction : (lambda -> lambda) -> lfunction -> lfunction
485 (** Apply the given transformation on the function's body *)
486
487val shallow_map : (lambda -> lambda) -> lambda -> lambda
488 (** Rewrite each immediate sub-term with the function. *)
489
490val bind : let_kind -> Ident.t -> lambda -> lambda -> lambda
491val bind_with_value_kind:
492 let_kind -> (Ident.t * value_kind) -> lambda -> lambda -> lambda
493
494val negate_integer_comparison : integer_comparison -> integer_comparison
495val swap_integer_comparison : integer_comparison -> integer_comparison
496
497val negate_float_comparison : float_comparison -> float_comparison
498val swap_float_comparison : float_comparison -> float_comparison
499
500val default_function_attribute : function_attribute
501val default_stub_attribute : function_attribute
502
503val function_is_curried : lfunction -> bool
504val find_exact_application :
505 function_kind -> arity:int -> lambda list -> lambda list option
506
507val max_arity : unit -> int
508 (** Maximal number of parameters for a function, or in other words,
509 maximal length of the [params] list of a [lfunction] record.
510 This is unlimited ([max_int]) for bytecode, but limited
511 (currently to 126) for native code. *)
512
513val tag_of_lazy_tag : lazy_block_tag -> int
514
515(***********************)
516(* For static failures *)
517(***********************)
518
519(* Get a new static failure ident *)
520val next_raise_count : unit -> int
521
522val staticfail : lambda (* Anticipated static failure *)
523
524(* Check anticipated failure, substitute its final value *)
525val is_guarded: lambda -> bool
526val patch_guarded : lambda -> lambda -> lambda
527
528val raise_kind: raise_kind -> string
529
530val merge_inline_attributes
531 : inline_attribute
532 -> inline_attribute
533 -> inline_attribute option
534
535val reset: unit -> unit