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
16open Misc
17open Asttypes
18
19type compile_time_constant =
20 | Big_endian
21 | Word_size
22 | Int_size
23 | Max_wosize
24 | Ostype_unix
25 | Ostype_win32
26 | Ostype_cygwin
27 | Backend_type
28 | Standard_library_default
29
30type immediate_or_pointer =
31 | Immediate
32 | Pointer
33
34type initialization_or_assignment =
35 | Assignment
36 | Heap_initialization
37 | Root_initialization
38
39type is_safe =
40 | Safe
41 | Unsafe
42
43type lazy_block_tag =
44 | Lazy_tag
45 | Forward_tag
46
47let tag_of_lazy_tag = function
48 | Lazy_tag -> Config.lazy_tag
49 | Forward_tag -> Obj.forward_tag
50
51type primitive =
52 | Pbytes_to_string
53 | Pbytes_of_string
54 | Pignore
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 | Pmakelazyblock of lazy_block_tag
61 | Pfield of int * immediate_or_pointer * mutable_flag
62 | Pfield_computed
63 | Psetfield of int * immediate_or_pointer * initialization_or_assignment
64 | Psetfield_computed of immediate_or_pointer * initialization_or_assignment
65 | Pfloatfield of int
66 | Psetfloatfield of int * initialization_or_assignment
67 | Pduprecord of Types.record_representation * int
68 (* Context switches *)
69 | Prunstack
70 | Pperform
71 | Presume
72 | Preperform
73 (* External call *)
74 | Pccall of Primitive.description
75 (* Exceptions *)
76 | Praise of raise_kind
77 (* Boolean operations *)
78 | Psequand | Psequor | Pnot
79 (* Integer operations *)
80 | Pnegint | Paddint | Psubint | Pmulint
81 | Pdivint of is_safe | Pmodint of is_safe
82 | Pandint | Porint | Pxorint
83 | Plslint | Plsrint | Pasrint
84 | Pintcomp of integer_comparison
85 | Pcompare_ints | Pcompare_floats | Pcompare_bints of boxed_integer
86 | Poffsetint of int
87 | Poffsetref of int
88 (* Float operations *)
89 | Pintoffloat | Pfloatofint
90 | Pnegfloat | Pabsfloat
91 | Paddfloat | Psubfloat | Pmulfloat | Pdivfloat
92 | Pfloatcomp of float_comparison
93 (* String operations *)
94 | Pstringlength | Pstringrefu | Pstringrefs
95 | Pbyteslength | Pbytesrefu | Pbytessetu | Pbytesrefs | Pbytessets
96 (* Array operations *)
97 | Pmakearray of array_kind * mutable_flag
98 | Pduparray of array_kind * mutable_flag
99 | Parraylength of array_kind
100 | Parrayrefu of array_kind
101 | Parraysetu of array_kind
102 | Parrayrefs of array_kind
103 | Parraysets of array_kind
104 (* Test if the argument is a block or an immediate integer *)
105 | Pisint
106 (* Test if the (integer) argument is outside an interval *)
107 | Pisout
108 (* Operations on boxed integers (Nativeint.t, Int32.t, Int64.t) *)
109 | Pbintofint of boxed_integer
110 | Pintofbint of boxed_integer
111 | Pcvtbint of boxed_integer (*source*) * boxed_integer (*destination*)
112 | Pnegbint of boxed_integer
113 | Paddbint of boxed_integer
114 | Psubbint of boxed_integer
115 | Pmulbint of boxed_integer
116 | Pdivbint of { size : boxed_integer; is_safe : is_safe }
117 | Pmodbint of { size : boxed_integer; is_safe : is_safe }
118 | Pandbint of boxed_integer
119 | Porbint of boxed_integer
120 | Pxorbint of boxed_integer
121 | Plslbint of boxed_integer
122 | Plsrbint of boxed_integer
123 | Pasrbint of boxed_integer
124 | Pbintcomp of boxed_integer * integer_comparison
125 (* Operations on Bigarrays: (unsafe, #dimensions, kind, layout) *)
126 | Pbigarrayref of bool * int * bigarray_kind * bigarray_layout
127 | Pbigarrayset of bool * int * bigarray_kind * bigarray_layout
128 (* size of the nth dimension of a Bigarray *)
129 | Pbigarraydim of int
130 (* load/set 16,32,64 bits from a string: (unsafe)*)
131 | Pstring_load_16 of bool
132 | Pstring_load_32 of bool
133 | Pstring_load_64 of bool
134 | Pbytes_load_16 of bool
135 | Pbytes_load_32 of bool
136 | Pbytes_load_64 of bool
137 | Pbytes_set_16 of bool
138 | Pbytes_set_32 of bool
139 | Pbytes_set_64 of bool
140 (* load/set 16,32,64 bits from a
141 (char, int8_unsigned_elt, c_layout) Bigarray.Array1.t : (unsafe) *)
142 | Pbigstring_load_16 of bool
143 | Pbigstring_load_32 of bool
144 | Pbigstring_load_64 of bool
145 | Pbigstring_set_16 of bool
146 | Pbigstring_set_32 of bool
147 | Pbigstring_set_64 of bool
148 (* Compile time constants *)
149 | Pctconst of compile_time_constant
150 (* byte swap *)
151 | Pbswap16
152 | Pbbswap of boxed_integer
153 (* Integer to external pointer *)
154 | Pint_as_pointer
155 (* Atomic operations *)
156 | Patomic_load
157 (* Inhibition of optimisation *)
158 | Popaque
159 (* Fetching domain-local state *)
160 | Pdls_get
161 (* Poll for runtime actions *)
162 | Ppoll
163
164and integer_comparison =
165 Ceq | Cne | Clt | Cgt | Cle | Cge
166
167and float_comparison =
168 CFeq | CFneq | CFlt | CFnlt | CFgt | CFngt | CFle | CFnle | CFge | CFnge
169
170and value_kind =
171 Pgenval | Pfloatval | Pboxedintval of boxed_integer | Pintval
172
173and block_shape =
174 value_kind list option
175
176and array_kind =
177 Pgenarray | Paddrarray | Pintarray | Pfloatarray
178
179and boxed_integer = Primitive.boxed_integer =
180 Pnativeint | Pint32 | Pint64
181
182and bigarray_kind =
183 Pbigarray_unknown
184 | Pbigarray_float16 | Pbigarray_float32 | Pbigarray_float64
185 | Pbigarray_sint8 | Pbigarray_uint8
186 | Pbigarray_sint16 | Pbigarray_uint16
187 | Pbigarray_int32 | Pbigarray_int64
188 | Pbigarray_caml_int | Pbigarray_native_int
189 | Pbigarray_complex32 | Pbigarray_complex64
190
191and bigarray_layout =
192 Pbigarray_unknown_layout
193 | Pbigarray_c_layout
194 | Pbigarray_fortran_layout
195
196and raise_kind =
197 | Raise_regular
198 | Raise_reraise
199 | Raise_notrace
200
201let equal_boxed_integer = Primitive.equal_boxed_integer
202
203let equal_primitive =
204 (* Should be implemented like [equal_value_kind] of [equal_boxed_integer],
205 i.e. by matching over the various constructors but the type has more
206 than 100 constructors... *)
207 (=)
208
209let equal_value_kind x y =
210 match x, y with
211 | Pgenval, Pgenval -> true
212 | Pfloatval, Pfloatval -> true
213 | Pboxedintval bi1, Pboxedintval bi2 -> equal_boxed_integer bi1 bi2
214 | Pintval, Pintval -> true
215 | (Pgenval | Pfloatval | Pboxedintval _ | Pintval), _ -> false
216
217
218type structured_constant =
219 Const_int of int
220 | Const_char of char
221 | Const_float of string
222 | Const_int32 of int32
223 | Const_int64 of int64
224 | Const_nativeint of nativeint
225 | Const_block of int * structured_constant list
226 | Const_float_array of string list
227 | Const_immstring of string
228
229type tailcall_attribute =
230 | Tailcall_expectation of bool
231 (* [@tailcall] and [@tailcall true] have [true],
232 [@tailcall false] has [false] *)
233 | Default_tailcall (* no [@tailcall] attribute *)
234
235type inline_attribute =
236 | Always_inline (* [@inline] or [@inline always] *)
237 | Never_inline (* [@inline never] *)
238 | Hint_inline (* [@inlined hint] attribute *)
239 | Unroll of int (* [@unroll x] *)
240 | Default_inline (* no [@inline] attribute *)
241
242let equal_inline_attribute x y =
243 match x, y with
244 | Always_inline, Always_inline
245 | Never_inline, Never_inline
246 | Hint_inline, Hint_inline
247 | Default_inline, Default_inline
248 ->
249 true
250 | Unroll u, Unroll v ->
251 u = v
252 | (Always_inline | Never_inline
253 | Hint_inline | Unroll _ | Default_inline), _ ->
254 false
255
256type specialise_attribute =
257 | Always_specialise (* [@specialise] or [@specialise always] *)
258 | Never_specialise (* [@specialise never] *)
259 | Default_specialise (* no [@specialise] attribute *)
260
261let equal_specialise_attribute x y =
262 match x, y with
263 | Always_specialise, Always_specialise
264 | Never_specialise, Never_specialise
265 | Default_specialise, Default_specialise ->
266 true
267 | (Always_specialise | Never_specialise | Default_specialise), _ ->
268 false
269
270type local_attribute =
271 | Always_local (* [@local] or [@local always] *)
272 | Never_local (* [@local never] *)
273 | Default_local (* [@local maybe] or no [@local] attribute *)
274
275type poll_attribute =
276 | Error_poll (* [@poll error] *)
277 | Default_poll (* no [@poll] attribute *)
278
279type function_kind = Curried | Tupled
280
281type let_kind = Strict | Alias | StrictOpt
282
283type meth_kind = Self | Public | Cached
284
285let equal_meth_kind x y =
286 match x, y with
287 | Self, Self -> true
288 | Public, Public -> true
289 | Cached, Cached -> true
290 | (Self | Public | Cached), _ -> false
291
292type shared_code = (int * int) list
293
294type function_attribute = {
295 inline : inline_attribute;
296 specialise : specialise_attribute;
297 local: local_attribute;
298 poll: poll_attribute;
299 is_a_functor: bool;
300 stub: bool;
301 tmc_candidate: bool;
302 may_fuse_arity: bool;
303}
304
305type scoped_location = Debuginfo.Scoped_location.t
306
307type lambda =
308 Lvar of Ident.t
309 | Lmutvar of Ident.t
310 | Lconst of structured_constant
311 | Lapply of lambda_apply
312 | Lfunction of lfunction
313 | Llet of let_kind * value_kind * Ident.t * lambda * lambda
314 | Lmutlet of value_kind * Ident.t * lambda * lambda
315 | Lletrec of rec_binding list * lambda
316 | Lprim of primitive * lambda list * scoped_location
317 | Lswitch of lambda * lambda_switch * scoped_location
318 | Lstringswitch of
319 lambda * (string * lambda) list * lambda option * scoped_location
320 | Lstaticraise of int * lambda list
321 | Lstaticcatch of lambda * (int * (Ident.t * value_kind) list) * lambda
322 | Ltrywith of lambda * Ident.t * lambda
323 | Lifthenelse of lambda * lambda * lambda
324 | Lsequence of lambda * lambda
325 | Lwhile of lambda * lambda
326 | Lfor of Ident.t * lambda * lambda * direction_flag * lambda
327 | Lassign of Ident.t * lambda
328 | Lsend of meth_kind * lambda * lambda * lambda list * scoped_location
329 | Levent of lambda * lambda_event
330 | Lifused of Ident.t * lambda
331
332and rec_binding = {
333 id : Ident.t;
334 def : lfunction;
335}
336
337and lfunction =
338 { kind: function_kind;
339 params: (Ident.t * value_kind) list;
340 return: value_kind;
341 body: lambda;
342 attr: function_attribute; (* specified with [@inline] attribute *)
343 loc: scoped_location; }
344
345and lambda_apply =
346 { ap_func : lambda;
347 ap_args : lambda list;
348 ap_loc : scoped_location;
349 ap_tailcall : tailcall_attribute;
350 ap_inlined : inline_attribute;
351 ap_specialised : specialise_attribute; }
352
353and lambda_switch =
354 { sw_numconsts: int;
355 sw_consts: (int * lambda) list;
356 sw_numblocks: int;
357 sw_blocks: (int * lambda) list;
358 sw_failaction : lambda option}
359
360and lambda_event =
361 { lev_loc: scoped_location;
362 lev_kind: lambda_event_kind;
363 lev_repr: int ref option;
364 lev_env: Env.t }
365
366and lambda_event_kind =
367 Lev_before
368 | Lev_after of Types.type_expr
369 | Lev_function
370 | Lev_pseudo
371
372type program =
373 { module_ident : Ident.t;
374 main_module_block_size : int;
375 required_globals : Ident.Set.t;
376 code : lambda }
377
378let const_int n = Const_int n
379
380let const_unit = const_int 0
381
382let dummy_constant = Lconst (const_int (0xBBBB / 2))
383
384let lambda_of_const (c : Asttypes.constant) =
385 match c with
386 | Const_int n -> Lconst (Const_int n)
387 | Const_char c -> Lconst (Const_char c)
388 | Const_float f -> Lconst (Const_float f)
389 | Const_int32 n -> Lconst (Const_int32 n)
390 | Const_int64 n -> Lconst (Const_int64 n)
391 | Const_nativeint n -> Lconst (Const_nativeint n)
392 | Const_string (s, _, _) -> Lconst (Const_immstring s)
393
394let max_arity () =
395 if !Clflags.native_code then 126 else max_int
396 (* 126 = 127 (the maximal number of parameters supported in C--)
397 - 1 (the hidden parameter containing the environment) *)
398
399let lfunction' ~kind ~params ~return ~body ~attr ~loc =
400 assert (List.length params <= max_arity ());
401 { kind; params; return; body; attr; loc }
402
403let lfunction ~kind ~params ~return ~body ~attr ~loc =
404 Lfunction (lfunction' ~kind ~params ~return ~body ~attr ~loc)
405
406let lambda_unit = Lconst const_unit
407
408let default_function_attribute = {
409 inline = Default_inline;
410 specialise = Default_specialise;
411 local = Default_local;
412 poll = Default_poll;
413 is_a_functor = false;
414 stub = false;
415 tmc_candidate = false;
416 (* Plain functions ([fun] and [function]) set [may_fuse_arity] to [false] so
417 that runtime arity matches syntactic arity in more situations.
418
419 Many things compile to functions without having a notion of syntactic arity
420 that survives typechecking, e.g. functors. Multi-arg functors are compiled
421 as nested unary functions, and rely on the arity fusion in simplif to make
422 them multi-argument. So, we keep arity fusion turned on by default for now.
423 *)
424 may_fuse_arity = true;
425}
426
427let default_stub_attribute =
428 { default_function_attribute with stub = true }
429
430(* Build sharing keys *)
431(*
432 Those keys are later compared with Stdlib.compare.
433 For that reason, they should not include cycles.
434*)
435
436let max_raw = 32
437
438let make_key e =
439 let exception Not_simple in
440 let count = ref 0 (* Used for controlling size *)
441 and make_key = Ident.make_key_generator () in
442 (* make_key is used for normalizing let-bound variables *)
443 let rec tr_rec env e =
444 incr count ;
445 if !count > max_raw then raise Not_simple ; (* Too big ! *)
446 match e with
447 | Lvar id
448 | Lmutvar id ->
449 begin
450 try Ident.find_same id env
451 with Not_found -> e
452 end
453 | Lconst _ -> e
454 | Lapply ap ->
455 Lapply {ap with ap_func = tr_rec env ap.ap_func;
456 ap_args = tr_recs env ap.ap_args;
457 ap_loc = Loc_unknown}
458 | Llet (Alias,_k,x,ex,e) -> (* Ignore aliases -> substitute *)
459 let ex = tr_rec env ex in
460 tr_rec (Ident.add x ex env) e
461 | Llet ((Strict | StrictOpt),_k,x,ex,Lvar v) when Ident.same v x ->
462 tr_rec env ex
463 | Llet (str,k,x,ex,e) ->
464 (* Because of side effects, keep other lets with normalized names *)
465 let ex = tr_rec env ex in
466 let y = make_key x in
467 Llet (str,k,y,ex,tr_rec (Ident.add x (Lvar y) env) e)
468 | Lmutlet (k,x,ex,e) ->
469 let ex = tr_rec env ex in
470 let y = make_key x in
471 Lmutlet (k,y,ex,tr_rec (Ident.add x (Lmutvar y) env) e)
472 | Lprim (p,es,_) ->
473 Lprim (p,tr_recs env es, Loc_unknown)
474 | Lswitch (e,sw,loc) ->
475 Lswitch (tr_rec env e,tr_sw env sw,loc)
476 | Lstringswitch (e,sw,d,_) ->
477 Lstringswitch
478 (tr_rec env e,
479 List.map (fun (s,e) -> s,tr_rec env e) sw,
480 tr_opt env d,
481 Loc_unknown)
482 | Lstaticraise (i,es) ->
483 Lstaticraise (i,tr_recs env es)
484 | Lstaticcatch (e1,xs,e2) ->
485 Lstaticcatch (tr_rec env e1,xs,tr_rec env e2)
486 | Ltrywith (e1,x,e2) ->
487 Ltrywith (tr_rec env e1,x,tr_rec env e2)
488 | Lifthenelse (cond,ifso,ifnot) ->
489 Lifthenelse (tr_rec env cond,tr_rec env ifso,tr_rec env ifnot)
490 | Lsequence (e1,e2) ->
491 Lsequence (tr_rec env e1,tr_rec env e2)
492 | Lassign (x,e) ->
493 Lassign (x,tr_rec env e)
494 | Lsend (m,e1,e2,es,_loc) ->
495 Lsend (m,tr_rec env e1,tr_rec env e2,tr_recs env es,Loc_unknown)
496 | Lifused (id,e) -> Lifused (id,tr_rec env e)
497 | Lletrec _|Lfunction _
498 | Lfor _ | Lwhile _
499(* Beware: (PR#6412) the event argument to Levent
500 may include cyclic structure of type Type.typexpr *)
501 | Levent _ ->
502 raise Not_simple
503
504 and tr_recs env es = List.map (tr_rec env) es
505
506 and tr_sw env sw =
507 { sw with
508 sw_consts = List.map (fun (i,e) -> i,tr_rec env e) sw.sw_consts ;
509 sw_blocks = List.map (fun (i,e) -> i,tr_rec env e) sw.sw_blocks ;
510 sw_failaction = tr_opt env sw.sw_failaction ; }
511
512 and tr_opt env = function
513 | None -> None
514 | Some e -> Some (tr_rec env e) in
515
516 try
517 Some (tr_rec Ident.empty e)
518 with Not_simple -> None
519
520(***************)
521
522let name_lambda strict arg fn =
523 match arg with
524 Lvar id -> fn id
525 | _ ->
526 let id = Ident.create_local "let" in
527 Llet(strict, Pgenval, id, arg, fn id)
528
529let name_lambda_list args fn =
530 let rec name_list names = function
531 [] -> fn (List.rev names)
532 | (Lvar _ as arg) :: rem ->
533 name_list (arg :: names) rem
534 | arg :: rem ->
535 let id = Ident.create_local "let" in
536 Llet(Strict, Pgenval, id, arg, name_list (Lvar id :: names) rem) in
537 name_list [] args
538
539
540let iter_opt f = function
541 | None -> ()
542 | Some e -> f e
543
544let shallow_iter ~tail ~non_tail:f = function
545 Lvar _
546 | Lmutvar _
547 | Lconst _ -> ()
548 | Lapply{ap_func = fn; ap_args = args} ->
549 f fn; List.iter f args
550 | Lfunction{body} ->
551 f body
552 | Llet(_, _k, _id, arg, body)
553 | Lmutlet(_k, _id, arg, body) ->
554 f arg; tail body
555 | Lletrec(decl, body) ->
556 tail body;
557 List.iter (fun { def } -> f (Lfunction def)) decl
558 | Lprim (Psequand, [l1; l2], _)
559 | Lprim (Psequor, [l1; l2], _) ->
560 f l1;
561 tail l2
562 | Lprim(_p, args, _loc) ->
563 List.iter f args
564 | Lswitch(arg, sw,_) ->
565 f arg;
566 List.iter (fun (_key, case) -> tail case) sw.sw_consts;
567 List.iter (fun (_key, case) -> tail case) sw.sw_blocks;
568 iter_opt tail sw.sw_failaction
569 | Lstringswitch (arg,cases,default,_) ->
570 f arg ;
571 List.iter (fun (_,act) -> tail act) cases ;
572 iter_opt tail default
573 | Lstaticraise (_,args) ->
574 List.iter f args
575 | Lstaticcatch(e1, _, e2) ->
576 tail e1; tail e2
577 | Ltrywith(e1, _, e2) ->
578 f e1; tail e2
579 | Lifthenelse(e1, e2, e3) ->
580 f e1; tail e2; tail e3
581 | Lsequence(e1, e2) ->
582 f e1; tail e2
583 | Lwhile(e1, e2) ->
584 f e1; f e2
585 | Lfor(_v, e1, e2, _dir, e3) ->
586 f e1; f e2; f e3
587 | Lassign(_, e) ->
588 f e
589 | Lsend (_k, met, obj, args, _) ->
590 List.iter f (met::obj::args)
591 | Levent (e, _evt) ->
592 tail e
593 | Lifused (_v, e) ->
594 tail e
595
596let iter_head_constructor f l =
597 shallow_iter ~tail:f ~non_tail:f l
598
599let is_evaluated = function
600 | Lconst _ | Lvar _ | Lfunction _ -> true
601 | _ -> false
602
603let rec free_variables = function
604 | Lvar id
605 | Lmutvar id -> Ident.Set.singleton id
606 | Lconst _ -> Ident.Set.empty
607 | Lapply{ap_func = fn; ap_args = args} ->
608 free_variables_list (free_variables fn) args
609 | Lfunction{body; params} ->
610 Ident.Set.diff (free_variables body)
611 (Ident.Set.of_list (List.map fst params))
612 | Llet(_, _k, id, arg, body)
613 | Lmutlet(_k, id, arg, body) ->
614 Ident.Set.union
615 (free_variables arg)
616 (Ident.Set.remove id (free_variables body))
617 | Lletrec(decl, body) ->
618 let set =
619 free_variables_list (free_variables body)
620 (List.map (fun { def } -> Lfunction def) decl)
621 in
622 Ident.Set.diff set
623 (Ident.Set.of_list (List.map (fun { id } -> id) decl))
624 | Lprim(_p, args, _loc) ->
625 free_variables_list Ident.Set.empty args
626 | Lswitch(arg, sw,_) ->
627 let set =
628 free_variables_list
629 (free_variables_list (free_variables arg)
630 (List.map snd sw.sw_consts))
631 (List.map snd sw.sw_blocks)
632 in
633 begin match sw.sw_failaction with
634 | None -> set
635 | Some failaction -> Ident.Set.union set (free_variables failaction)
636 end
637 | Lstringswitch (arg,cases,default,_) ->
638 let set =
639 free_variables_list (free_variables arg)
640 (List.map snd cases)
641 in
642 begin match default with
643 | None -> set
644 | Some default -> Ident.Set.union set (free_variables default)
645 end
646 | Lstaticraise (_,args) ->
647 free_variables_list Ident.Set.empty args
648 | Lstaticcatch(body, (_, params), handler) ->
649 Ident.Set.union
650 (Ident.Set.diff
651 (free_variables handler)
652 (Ident.Set.of_list (List.map fst params)))
653 (free_variables body)
654 | Ltrywith(body, param, handler) ->
655 Ident.Set.union
656 (Ident.Set.remove
657 param
658 (free_variables handler))
659 (free_variables body)
660 | Lifthenelse(e1, e2, e3) ->
661 Ident.Set.union
662 (Ident.Set.union (free_variables e1) (free_variables e2))
663 (free_variables e3)
664 | Lsequence(e1, e2) ->
665 Ident.Set.union (free_variables e1) (free_variables e2)
666 | Lwhile(e1, e2) ->
667 Ident.Set.union (free_variables e1) (free_variables e2)
668 | Lfor(v, lo, hi, _dir, body) ->
669 let set = Ident.Set.union (free_variables lo) (free_variables hi) in
670 Ident.Set.union set (Ident.Set.remove v (free_variables body))
671 | Lassign(id, e) ->
672 Ident.Set.add id (free_variables e)
673 | Lsend (_k, met, obj, args, _) ->
674 free_variables_list
675 (Ident.Set.union (free_variables met) (free_variables obj))
676 args
677 | Levent (lam, _evt) ->
678 free_variables lam
679 | Lifused (_v, e) ->
680 (* Shouldn't v be considered a free variable ? *)
681 free_variables e
682
683and free_variables_list set exprs =
684 List.fold_left (fun set expr -> Ident.Set.union (free_variables expr) set)
685 set exprs
686
687(* Check if an action has a "when" guard *)
688let raise_count = ref 0
689
690let next_raise_count () =
691 incr raise_count ;
692 !raise_count
693
694(* Anticipated staticraise, for guards *)
695let staticfail = Lstaticraise (0,[])
696
697let rec is_guarded = function
698 | Lifthenelse(_cond, _body, Lstaticraise (0,[])) -> true
699 | Llet(_str, _k, _id, _lam, body) -> is_guarded body
700 | Levent(lam, _ev) -> is_guarded lam
701 | _ -> false
702
703let rec patch_guarded patch = function
704 | Lifthenelse (cond, body, Lstaticraise (0,[])) ->
705 Lifthenelse (cond, body, patch)
706 | Llet(str, k, id, lam, body) ->
707 Llet (str, k, id, lam, patch_guarded patch body)
708 | Levent(lam, ev) ->
709 Levent (patch_guarded patch lam, ev)
710 | _ -> fatal_error "Lambda.patch_guarded"
711
712(* Translate an access path *)
713
714let rec transl_address loc = function
715 | Env.Aident id ->
716 if Ident.global id
717 then Lprim(Pgetglobal id, [], loc)
718 else Lvar id
719 | Env.Adot(addr, pos) ->
720 Lprim(Pfield(pos, Pointer, Immutable),
721 [transl_address loc addr], loc)
722
723let transl_path find loc env path =
724 match find path env with
725 | exception Not_found ->
726 fatal_error ("Cannot find address for: " ^ (Path.name path))
727 | addr -> transl_address loc addr
728
729(* Translation of identifiers *)
730
731let transl_module_path loc env path =
732 transl_path Env.find_module_address loc env path
733
734let transl_value_path loc env path =
735 transl_path Env.find_value_address loc env path
736
737let transl_extension_path loc env path =
738 transl_path Env.find_constructor_address loc env path
739
740let transl_class_path loc env path =
741 transl_path Env.find_class_address loc env path
742
743let transl_prim modname field =
744 let mod_ident = Ident.create_persistent modname in
745 let env = Env.add_persistent_structure mod_ident Env.initial in
746 match Env.open_pers_signature modname env with
747 | Error `Not_found ->
748 fatal_errorf "Module %s unavailable." modname
749 | Ok env -> (
750 match Env.find_value_by_name (Longident.Lident field) env with
751 | exception Not_found ->
752 fatal_errorf "Primitive %s.%s not found." modname field
753 | path, _ -> transl_value_path Loc_unknown env path
754 )
755
756(* Compile a sequence of expressions *)
757
758let rec make_sequence fn = function
759 [] -> lambda_unit
760 | [x] -> fn x
761 | x::rem ->
762 let lam = fn x in Lsequence(lam, make_sequence fn rem)
763
764(* Apply a substitution to a lambda-term.
765 Assumes that the image of the substitution is out of reach
766 of the bound variables of the lambda-term (no capture). *)
767
768type substitution_functions = {
769 subst_lambda : lambda -> lambda;
770 subst_lfunction : lfunction -> lfunction;
771}
772
773let build_substs update_env ?(freshen_bound_variables = false) s =
774 (* [s] contains a partial substitution for the free variables of the
775 input term.
776
777 During our traversal of the term we maintain a second environment
778 [l] with all the bound variables of the input term in the current
779 scope, mapped to either themselves or freshened versions of
780 themselves when [freshen_bound_variables] is set. *)
781 let bind id l =
782 let id' = if not freshen_bound_variables then id else Ident.rename id in
783 id', Ident.Map.add id id' l
784 in
785 let bind_many ids l =
786 List.fold_right (fun (id, rhs) (ids', l) ->
787 let id', l = bind id l in
788 ((id', rhs) :: ids' , l)
789 ) ids ([], l)
790 in
791 let bind_rec ids l =
792 List.fold_right (fun rb (ids', l) ->
793 let id', l = bind rb.id l in
794 ({ rb with id = id' } :: ids' , l)
795 ) ids ([], l)
796 in
797 let rec subst s l lam =
798 match lam with
799 | Lvar id as lam ->
800 begin match Ident.Map.find id l with
801 | id' -> Lvar id'
802 | exception Not_found ->
803 (* note: as this point we know [id] is not a bound
804 variable of the input term, otherwise it would belong
805 to [l]; it is a free variable of the input term. *)
806 begin try Ident.Map.find id s with Not_found -> lam end
807 end
808 | Lmutvar id as lam ->
809 begin match Ident.Map.find id l with
810 | id' -> Lmutvar id'
811 | exception Not_found ->
812 (* Note: a mutable [id] should not appear in [s].
813 Keeping the behavior of Lvar case for now. *)
814 begin try Ident.Map.find id s with Not_found -> lam end
815 end
816 | Lconst _ as l -> l
817 | Lapply ap ->
818 Lapply{ap with ap_func = subst s l ap.ap_func;
819 ap_args = subst_list s l ap.ap_args}
820 | Lfunction lf ->
821 Lfunction (subst_lfun s l lf)
822 | Llet(str, k, id, arg, body) ->
823 let id, l' = bind id l in
824 Llet(str, k, id, subst s l arg, subst s l' body)
825 | Lmutlet(k, id, arg, body) ->
826 let id, l' = bind id l in
827 Lmutlet(k, id, subst s l arg, subst s l' body)
828 | Lletrec(decl, body) ->
829 let decl, l' = bind_rec decl l in
830 Lletrec(List.map (subst_decl s l') decl, subst s l' body)
831 | Lprim(p, args, loc) -> Lprim(p, subst_list s l args, loc)
832 | Lswitch(arg, sw, loc) ->
833 Lswitch(subst s l arg,
834 {sw with sw_consts = List.map (subst_case s l) sw.sw_consts;
835 sw_blocks = List.map (subst_case s l) sw.sw_blocks;
836 sw_failaction = subst_opt s l sw.sw_failaction; },
837 loc)
838 | Lstringswitch (arg,cases,default,loc) ->
839 Lstringswitch
840 (subst s l arg,
841 List.map (subst_strcase s l) cases,
842 subst_opt s l default,
843 loc)
844 | Lstaticraise (i,args) -> Lstaticraise (i, subst_list s l args)
845 | Lstaticcatch(body, (id, params), handler) ->
846 let params, l' = bind_many params l in
847 Lstaticcatch(subst s l body, (id, params),
848 subst s l' handler)
849 | Ltrywith(body, exn, handler) ->
850 let exn, l' = bind exn l in
851 Ltrywith(subst s l body, exn, subst s l' handler)
852 | Lifthenelse(e1, e2, e3) ->
853 Lifthenelse(subst s l e1, subst s l e2, subst s l e3)
854 | Lsequence(e1, e2) -> Lsequence(subst s l e1, subst s l e2)
855 | Lwhile(e1, e2) -> Lwhile(subst s l e1, subst s l e2)
856 | Lfor(v, lo, hi, dir, body) ->
857 let v, l' = bind v l in
858 Lfor(v, subst s l lo, subst s l hi, dir, subst s l' body)
859 | Lassign(id, e) ->
860 assert (not (Ident.Map.mem id s));
861 let id = try Ident.Map.find id l with Not_found -> id in
862 Lassign(id, subst s l e)
863 | Lsend (k, met, obj, args, loc) ->
864 Lsend (k, subst s l met, subst s l obj, subst_list s l args, loc)
865 | Levent (lam, evt) ->
866 let old_env = evt.lev_env in
867 let env_updates =
868 let find_in_old id = Env.find_value (Path.Pident id) old_env in
869 let rebind id id' new_env =
870 match find_in_old id with
871 | exception Not_found -> new_env
872 | vd -> Env.add_value id' vd new_env
873 in
874 let update_free id new_env =
875 match find_in_old id with
876 | exception Not_found -> new_env
877 | vd -> update_env id vd new_env
878 in
879 Ident.Map.merge (fun id bound free ->
880 match bound, free with
881 | Some id', _ ->
882 if Ident.equal id id' then None else Some (rebind id id')
883 | None, Some _ -> Some (update_free id)
884 | None, None -> None
885 ) l s
886 in
887 let new_env =
888 Ident.Map.fold (fun _id update env -> update env) env_updates old_env
889 in
890 Levent (subst s l lam, { evt with lev_env = new_env })
891 | Lifused (id, e) ->
892 let id = try Ident.Map.find id l with Not_found -> id in
893 Lifused (id, subst s l e)
894 and subst_list s l li = List.map (subst s l) li
895 and subst_decl s l decl = { decl with def = subst_lfun s l decl.def }
896 and subst_lfun s l lf =
897 let params, l' = bind_many lf.params l in
898 { lf with params; body = subst s l' lf.body }
899 and subst_case s l (key, case) = (key, subst s l case)
900 and subst_strcase s l (key, case) = (key, subst s l case)
901 and subst_opt s l = function
902 | None -> None
903 | Some e -> Some (subst s l e)
904 in
905 { subst_lambda = (fun lam -> subst s Ident.Map.empty lam);
906 subst_lfunction = (fun lfun -> subst_lfun s Ident.Map.empty lfun);
907 }
908
909let subst update_env ?freshen_bound_variables s =
910 (build_substs update_env ?freshen_bound_variables s).subst_lambda
911
912let rename idmap lam =
913 let update_env oldid vd env =
914 let newid = Ident.Map.find oldid idmap in
915 Env.add_value newid vd env
916 in
917 let s = Ident.Map.map (fun new_id -> Lvar new_id) idmap in
918 subst update_env s lam
919
920let duplicate_function =
921 (build_substs
922 (fun _ _ env -> env)
923 ~freshen_bound_variables:true
924 Ident.Map.empty).subst_lfunction
925
926let map_lfunction f { kind; params; return; body; attr; loc } =
927 let body = f body in
928 { kind; params; return; body; attr; loc }
929
930let shallow_map f = function
931 | Lvar _
932 | Lmutvar _
933 | Lconst _ as lam -> lam
934 | Lapply { ap_func; ap_args; ap_loc; ap_tailcall;
935 ap_inlined; ap_specialised } ->
936 Lapply {
937 ap_func = f ap_func;
938 ap_args = List.map f ap_args;
939 ap_loc;
940 ap_tailcall;
941 ap_inlined;
942 ap_specialised;
943 }
944 | Lfunction lfun ->
945 Lfunction (map_lfunction f lfun)
946 | Llet (str, k, v, e1, e2) ->
947 Llet (str, k, v, f e1, f e2)
948 | Lmutlet (k, v, e1, e2) ->
949 Lmutlet (k, v, f e1, f e2)
950 | Lletrec (idel, e2) ->
951 Lletrec
952 (List.map (fun rb ->
953 { rb with def = map_lfunction f rb.def })
954 idel,
955 f e2)
956 | Lprim (p, el, loc) ->
957 Lprim (p, List.map f el, loc)
958 | Lswitch (e, sw, loc) ->
959 Lswitch (f e,
960 { sw_numconsts = sw.sw_numconsts;
961 sw_consts = List.map (fun (n, e) -> (n, f e)) sw.sw_consts;
962 sw_numblocks = sw.sw_numblocks;
963 sw_blocks = List.map (fun (n, e) -> (n, f e)) sw.sw_blocks;
964 sw_failaction = Option.map f sw.sw_failaction;
965 },
966 loc)
967 | Lstringswitch (e, sw, default, loc) ->
968 Lstringswitch (
969 f e,
970 List.map (fun (s, e) -> (s, f e)) sw,
971 Option.map f default,
972 loc)
973 | Lstaticraise (i, args) ->
974 Lstaticraise (i, List.map f args)
975 | Lstaticcatch (body, id, handler) ->
976 Lstaticcatch (f body, id, f handler)
977 | Ltrywith (e1, v, e2) ->
978 Ltrywith (f e1, v, f e2)
979 | Lifthenelse (e1, e2, e3) ->
980 Lifthenelse (f e1, f e2, f e3)
981 | Lsequence (e1, e2) ->
982 Lsequence (f e1, f e2)
983 | Lwhile (e1, e2) ->
984 Lwhile (f e1, f e2)
985 | Lfor (v, e1, e2, dir, e3) ->
986 Lfor (v, f e1, f e2, dir, f e3)
987 | Lassign (v, e) ->
988 Lassign (v, f e)
989 | Lsend (k, m, o, el, loc) ->
990 Lsend (k, f m, f o, List.map f el, loc)
991 | Levent (l, ev) ->
992 Levent (f l, ev)
993 | Lifused (v, e) ->
994 Lifused (v, f e)
995
996let map f =
997 let rec g lam = f (shallow_map g lam) in
998 g
999
1000(* To let-bind expressions to variables *)
1001
1002let bind_with_value_kind str (var, kind) exp body =
1003 match exp with
1004 Lvar var' when Ident.same var var' -> body
1005 | _ -> Llet(str, kind, var, exp, body)
1006
1007let bind str var exp body =
1008 bind_with_value_kind str (var, Pgenval) exp body
1009
1010let negate_integer_comparison = function
1011 | Ceq -> Cne
1012 | Cne -> Ceq
1013 | Clt -> Cge
1014 | Cle -> Cgt
1015 | Cgt -> Cle
1016 | Cge -> Clt
1017
1018let swap_integer_comparison = function
1019 | Ceq -> Ceq
1020 | Cne -> Cne
1021 | Clt -> Cgt
1022 | Cle -> Cge
1023 | Cgt -> Clt
1024 | Cge -> Cle
1025
1026let negate_float_comparison = function
1027 | CFeq -> CFneq
1028 | CFneq -> CFeq
1029 | CFlt -> CFnlt
1030 | CFnlt -> CFlt
1031 | CFgt -> CFngt
1032 | CFngt -> CFgt
1033 | CFle -> CFnle
1034 | CFnle -> CFle
1035 | CFge -> CFnge
1036 | CFnge -> CFge
1037
1038let swap_float_comparison = function
1039 | CFeq -> CFeq
1040 | CFneq -> CFneq
1041 | CFlt -> CFgt
1042 | CFnlt -> CFngt
1043 | CFle -> CFge
1044 | CFnle -> CFnge
1045 | CFgt -> CFlt
1046 | CFngt -> CFnlt
1047 | CFge -> CFle
1048 | CFnge -> CFnle
1049
1050let raise_kind = function
1051 | Raise_regular -> "raise"
1052 | Raise_reraise -> "reraise"
1053 | Raise_notrace -> "raise_notrace"
1054
1055let merge_inline_attributes attr1 attr2 =
1056 match attr1, attr2 with
1057 | Default_inline, _ -> Some attr2
1058 | _, Default_inline -> Some attr1
1059 | _, _ ->
1060 if attr1 = attr2 then Some attr1
1061 else None
1062
1063let function_is_curried func =
1064 match func.kind with
1065 | Curried -> true
1066 | Tupled -> false
1067
1068let find_exact_application kind ~arity args =
1069 match kind with
1070 | Curried ->
1071 if arity <> List.length args
1072 then None
1073 else Some args
1074 | Tupled ->
1075 begin match args with
1076 | [Lprim(Pmakeblock _, tupled_args, _)] ->
1077 if arity <> List.length tupled_args
1078 then None
1079 else Some tupled_args
1080 | [Lconst(Const_block (_, const_args))] ->
1081 if arity <> List.length const_args
1082 then None
1083 else Some (List.map (fun cst -> Lconst cst) const_args)
1084 | _ -> None
1085 end
1086
1087let reset () =
1088 raise_count := 0