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 open Misc
17 open Asttypes
18
19 type 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
29 type immediate_or_pointer =
30 | Immediate
31 | Pointer
32
33 type initialization_or_assignment =
34 | Assignment
35 | Heap_initialization
36 | Root_initialization
37
38 type is_safe =
39 | Safe
40 | Unsafe
41
42 type primitive =
43 | Pidentity
44 | Pbytes_to_string
45 | Pbytes_of_string
46 | Pignore
47 | Prevapply
48 | Pdirapply
49 (* Globals *)
50 | Pgetglobal of Ident.t
51 | Psetglobal of Ident.t
52 (* Operations on heap blocks *)
53 | Pmakeblock of int * mutable_flag * block_shape
54 | Pfield of int
55 | Pfield_computed
56 | Psetfield of int * immediate_or_pointer * initialization_or_assignment
57 | Psetfield_computed of immediate_or_pointer * initialization_or_assignment
58 | Pfloatfield of int
59 | Psetfloatfield of int * initialization_or_assignment
60 | Pduprecord of Types.record_representation * int
61 (* Force lazy values *)
62 (* External call *)
63 | Pccall of Primitive.description
64 (* Exceptions *)
65 | Praise of raise_kind
66 (* Boolean operations *)
67 | Psequand | Psequor | Pnot
68 (* Integer operations *)
69 | Pnegint | Paddint | Psubint | Pmulint
70 | Pdivint of is_safe | Pmodint of is_safe
71 | Pandint | Porint | Pxorint
72 | Plslint | Plsrint | Pasrint
73 | Pintcomp of integer_comparison
74 | Poffsetint of int
75 | Poffsetref of int
76 (* Float operations *)
77 | Pintoffloat | Pfloatofint
78 | Pnegfloat | Pabsfloat
79 | Paddfloat | Psubfloat | Pmulfloat | Pdivfloat
80 | Pfloatcomp of float_comparison
81 (* String operations *)
82 | Pstringlength | Pstringrefu | Pstringrefs
83 | Pbyteslength | Pbytesrefu | Pbytessetu | Pbytesrefs | Pbytessets
84 (* Array operations *)
85 | Pmakearray of array_kind * mutable_flag
86 | Pduparray of array_kind * mutable_flag
87 | Parraylength of array_kind
88 | Parrayrefu of array_kind
89 | Parraysetu of array_kind
90 | Parrayrefs of array_kind
91 | Parraysets of array_kind
92 (* Test if the argument is a block or an immediate integer *)
93 | Pisint
94 (* Test if the (integer) argument is outside an interval *)
95 | Pisout
96 (* Operations on boxed integers (Nativeint.t, Int32.t, Int64.t) *)
97 | Pbintofint of boxed_integer
98 | Pintofbint of boxed_integer
99 | Pcvtbint of boxed_integer (*source*) * boxed_integer (*destination*)
100 | Pnegbint of boxed_integer
101 | Paddbint of boxed_integer
102 | Psubbint of boxed_integer
103 | Pmulbint of boxed_integer
104 | Pdivbint of { size : boxed_integer; is_safe : is_safe }
105 | Pmodbint of { size : boxed_integer; is_safe : is_safe }
106 | Pandbint of boxed_integer
107 | Porbint of boxed_integer
108 | Pxorbint of boxed_integer
109 | Plslbint of boxed_integer
110 | Plsrbint of boxed_integer
111 | Pasrbint of boxed_integer
112 | Pbintcomp of boxed_integer * integer_comparison
113 (* Operations on Bigarrays: (unsafe, #dimensions, kind, layout) *)
114 | Pbigarrayref of bool * int * bigarray_kind * bigarray_layout
115 | Pbigarrayset of bool * int * bigarray_kind * bigarray_layout
116 (* size of the nth dimension of a Bigarray *)
117 | Pbigarraydim of int
118 (* load/set 16,32,64 bits from a string: (unsafe)*)
119 | Pstring_load_16 of bool
120 | Pstring_load_32 of bool
121 | Pstring_load_64 of bool
122 | Pbytes_load_16 of bool
123 | Pbytes_load_32 of bool
124 | Pbytes_load_64 of bool
125 | Pbytes_set_16 of bool
126 | Pbytes_set_32 of bool
127 | Pbytes_set_64 of bool
128 (* load/set 16,32,64 bits from a
129 (char, int8_unsigned_elt, c_layout) Bigarray.Array1.t : (unsafe) *)
130 | Pbigstring_load_16 of bool
131 | Pbigstring_load_32 of bool
132 | Pbigstring_load_64 of bool
133 | Pbigstring_set_16 of bool
134 | Pbigstring_set_32 of bool
135 | Pbigstring_set_64 of bool
136 (* Compile time constants *)
137 | Pctconst of compile_time_constant
138 (* byte swap *)
139 | Pbswap16
140 | Pbbswap of boxed_integer
141 (* Integer to external pointer *)
142 | Pint_as_pointer
143 (* Inhibition of optimisation *)
144 | Popaque
145
146 and integer_comparison =
147 Ceq | Cne | Clt | Cgt | Cle | Cge
148
149 and float_comparison =
150 CFeq | CFneq | CFlt | CFnlt | CFgt | CFngt | CFle | CFnle | CFge | CFnge
151
152 and value_kind =
153 Pgenval | Pfloatval | Pboxedintval of boxed_integer | Pintval
154
155 and block_shape =
156 value_kind list option
157
158 and array_kind =
159 Pgenarray | Paddrarray | Pintarray | Pfloatarray
160
161 and boxed_integer = Primitive.boxed_integer =
162 Pnativeint | Pint32 | Pint64
163
164 and bigarray_kind =
165 Pbigarray_unknown
166 | Pbigarray_float32 | Pbigarray_float64
167 | Pbigarray_sint8 | Pbigarray_uint8
168 | Pbigarray_sint16 | Pbigarray_uint16
169 | Pbigarray_int32 | Pbigarray_int64
170 | Pbigarray_caml_int | Pbigarray_native_int
171 | Pbigarray_complex32 | Pbigarray_complex64
172
173 and bigarray_layout =
174 Pbigarray_unknown_layout
175 | Pbigarray_c_layout
176 | Pbigarray_fortran_layout
177
178 and raise_kind =
179 | Raise_regular
180 | Raise_reraise
181 | Raise_notrace
182
183 let equal_boxed_integer x y =
184 match x, y with
185 | Pnativeint, Pnativeint
186 | Pint32, Pint32
187 | Pint64, Pint64 ->
188 true
189 | (Pnativeint | Pint32 | Pint64), _ ->
190 false
191
192 let equal_primitive =
193 (* Should be implemented like [equal_value_kind] of [equal_boxed_integer],
194 i.e. by matching over the various constructors but the type has more
195 than 100 constructors... *)
196 (=)
197
198 let equal_value_kind x y =
199 match x, y with
200 | Pgenval, Pgenval -> true
201 | Pfloatval, Pfloatval -> true
202 | Pboxedintval bi1, Pboxedintval bi2 -> equal_boxed_integer bi1 bi2
203 | Pintval, Pintval -> true
204 | (Pgenval | Pfloatval | Pboxedintval _ | Pintval), _ -> false
205
206
207 type structured_constant =
208 Const_base of constant
209 | Const_pointer of int
210 | Const_block of int * structured_constant list
211 | Const_float_array of string list
212 | Const_immstring of string
213
214 type inline_attribute =
215 | Always_inline (* [@inline] or [@inline always] *)
216 | Never_inline (* [@inline never] *)
217 | Unroll of int (* [@unroll x] *)
218 | Default_inline (* no [@inline] attribute *)
219
220 let equal_inline_attribute x y =
221 match x, y with
222 | Always_inline, Always_inline
223 | Never_inline, Never_inline
224 | Default_inline, Default_inline
225 ->
226 true
227 | Unroll u, Unroll v ->
228 u = v
229 | (Always_inline | Never_inline | Unroll _ | Default_inline), _ ->
230 false
231
232 type specialise_attribute =
233 | Always_specialise (* [@specialise] or [@specialise always] *)
234 | Never_specialise (* [@specialise never] *)
235 | Default_specialise (* no [@specialise] attribute *)
236
237 let equal_specialise_attribute x y =
238 match x, y with
239 | Always_specialise, Always_specialise
240 | Never_specialise, Never_specialise
241 | Default_specialise, Default_specialise ->
242 true
243 | (Always_specialise | Never_specialise | Default_specialise), _ ->
244 false
245
246 type local_attribute =
247 | Always_local (* [@local] or [@local always] *)
248 | Never_local (* [@local never] *)
249 | Default_local (* [@local maybe] or no [@local] attribute *)
250
251 type function_kind = Curried | Tupled
252
253 type let_kind = Strict | Alias | StrictOpt | Variable
254
255 type meth_kind = Self | Public | Cached
256
257 let equal_meth_kind x y =
258 match x, y with
259 | Self, Self -> true
260 | Public, Public -> true
261 | Cached, Cached -> true
262 | (Self | Public | Cached), _ -> false
263
264 type shared_code = (int * int) list
265
266 type function_attribute = {
267 inline : inline_attribute;
268 specialise : specialise_attribute;
269 local: local_attribute;
270 is_a_functor: bool;
271 stub: bool;
272 }
273
274 type lambda =
275 Lvar of Ident.t
276 | Lconst of structured_constant
277 | Lapply of lambda_apply
278 | Lfunction of lfunction
279 | Llet of let_kind * value_kind * Ident.t * lambda * lambda
280 | Lletrec of (Ident.t * lambda) list * lambda
281 | Lprim of primitive * lambda list * Location.t
282 | Lswitch of lambda * lambda_switch * Location.t
283 | Lstringswitch of
284 lambda * (string * lambda) list * lambda option * Location.t
285 | Lstaticraise of int * lambda list
286 | Lstaticcatch of lambda * (int * (Ident.t * value_kind) list) * lambda
287 | Ltrywith of lambda * Ident.t * lambda
288 | Lifthenelse of lambda * lambda * lambda
289 | Lsequence of lambda * lambda
290 | Lwhile of lambda * lambda
291 | Lfor of Ident.t * lambda * lambda * direction_flag * lambda
292 | Lassign of Ident.t * lambda
293 | Lsend of meth_kind * lambda * lambda * lambda list * Location.t
294 | Levent of lambda * lambda_event
295 | Lifused of Ident.t * lambda
296
297 and lfunction =
298 { kind: function_kind;
299 params: (Ident.t * value_kind) list;
300 return: value_kind;
301 body: lambda;
302 attr: function_attribute; (* specified with [@inline] attribute *)
303 loc: Location.t; }
304
305 and lambda_apply =
306 { ap_func : lambda;
307 ap_args : lambda list;
308 ap_loc : Location.t;
309 ap_should_be_tailcall : bool;
310 ap_inlined : inline_attribute;
311 ap_specialised : specialise_attribute; }
312
313 and lambda_switch =
314 { sw_numconsts: int;
315 sw_consts: (int * lambda) list;
316 sw_numblocks: int;
317 sw_blocks: (int * lambda) list;
318 sw_failaction : lambda option}
319
320 and lambda_event =
321 { lev_loc: Location.t;
322 lev_kind: lambda_event_kind;
323 lev_repr: int ref option;
324 lev_env: Env.t }
325
326 and lambda_event_kind =
327 Lev_before
328 | Lev_after of Types.type_expr
329 | Lev_function
330 | Lev_pseudo
331 | Lev_module_definition of Ident.t
332
333 type program =
334 { module_ident : Ident.t;
335 main_module_block_size : int;
336 required_globals : Ident.Set.t;
337 code : lambda }
338
339 let const_unit = Const_pointer 0
340
341 let lambda_unit = Lconst const_unit
342
343 let default_function_attribute = {
344 inline = Default_inline;
345 specialise = Default_specialise;
346 local = Default_local;
347 is_a_functor = false;
348 stub = false;
349 }
350
351 let default_stub_attribute =
352 { default_function_attribute with stub = true }
353
354 (* Build sharing keys *)
355 (*
356 Those keys are later compared with Stdlib.compare.
357 For that reason, they should not include cycles.
358 *)
359
360 exception Not_simple
361
362 let max_raw = 32
363
364 let make_key e =
365 let count = ref 0 (* Used for controlling size *)
366 and make_key = Ident.make_key_generator () in
367 (* make_key is used for normalizing let-bound variables *)
368 let rec tr_rec env e =
369 incr count ;
370 if !count > max_raw then raise Not_simple ; (* Too big ! *)
371 match e with
372 | Lvar id ->
373 begin
374 try Ident.find_same id env
375 with Not_found -> e
376 end
377 | Lconst (Const_base (Const_string _)) ->
378 (* Mutable constants are not shared *)
379 raise Not_simple
380 | Lconst _ -> e
381 | Lapply ap ->
382 Lapply {ap with ap_func = tr_rec env ap.ap_func;
383 ap_args = tr_recs env ap.ap_args;
384 ap_loc = Location.none}
385 | Llet (Alias,_k,x,ex,e) -> (* Ignore aliases -> substitute *)
386 let ex = tr_rec env ex in
387 tr_rec (Ident.add x ex env) e
388 | Llet ((Strict | StrictOpt),_k,x,ex,Lvar v) when Ident.same v x ->
389 tr_rec env ex
390 | Llet (str,k,x,ex,e) ->
391 (* Because of side effects, keep other lets with normalized names *)
392 let ex = tr_rec env ex in
393 let y = make_key x in
394 Llet (str,k,y,ex,tr_rec (Ident.add x (Lvar y) env) e)
395 | Lprim (p,es,_) ->
396 Lprim (p,tr_recs env es, Location.none)
397 | Lswitch (e,sw,loc) ->
398 Lswitch (tr_rec env e,tr_sw env sw,loc)
399 | Lstringswitch (e,sw,d,_) ->
400 Lstringswitch
401 (tr_rec env e,
402 List.map (fun (s,e) -> s,tr_rec env e) sw,
403 tr_opt env d,
404 Location.none)
405 | Lstaticraise (i,es) ->
406 Lstaticraise (i,tr_recs env es)
407 | Lstaticcatch (e1,xs,e2) ->
408 Lstaticcatch (tr_rec env e1,xs,tr_rec env e2)
409 | Ltrywith (e1,x,e2) ->
410 Ltrywith (tr_rec env e1,x,tr_rec env e2)
411 | Lifthenelse (cond,ifso,ifnot) ->
412 Lifthenelse (tr_rec env cond,tr_rec env ifso,tr_rec env ifnot)
413 | Lsequence (e1,e2) ->
414 Lsequence (tr_rec env e1,tr_rec env e2)
415 | Lassign (x,e) ->
416 Lassign (x,tr_rec env e)
417 | Lsend (m,e1,e2,es,_loc) ->
418 Lsend (m,tr_rec env e1,tr_rec env e2,tr_recs env es,Location.none)
419 | Lifused (id,e) -> Lifused (id,tr_rec env e)
420 | Lletrec _|Lfunction _
421 | Lfor _ | Lwhile _
422 (* Beware: (PR#6412) the event argument to Levent
423 may include cyclic structure of type Type.typexpr *)
424 | Levent _ ->
425 raise Not_simple
426
427 and tr_recs env es = List.map (tr_rec env) es
428
429 and tr_sw env sw =
430 { sw with
431 sw_consts = List.map (fun (i,e) -> i,tr_rec env e) sw.sw_consts ;
432 sw_blocks = List.map (fun (i,e) -> i,tr_rec env e) sw.sw_blocks ;
433 sw_failaction = tr_opt env sw.sw_failaction ; }
434
435 and tr_opt env = function
436 | None -> None
437 | Some e -> Some (tr_rec env e) in
438
439 try
440 Some (tr_rec Ident.empty e)
441 with Not_simple -> None
442
443 (***************)
444
445 let name_lambda strict arg fn =
446 match arg with
447 Lvar id -> fn id
448 | _ ->
449 let id = Ident.create_local "let" in
450 Llet(strict, Pgenval, id, arg, fn id)
451
452 let name_lambda_list args fn =
453 let rec name_list names = function
454 [] -> fn (List.rev names)
455 | (Lvar _ as arg) :: rem ->
456 name_list (arg :: names) rem
457 | arg :: rem ->
458 let id = Ident.create_local "let" in
459 Llet(Strict, Pgenval, id, arg, name_list (Lvar id :: names) rem) in
460 name_list [] args
461
462
463 let iter_opt f = function
464 | None -> ()
465 | Some e -> f e
466
467 let shallow_iter ~tail ~non_tail:f = function
468 Lvar _
469 | Lconst _ -> ()
470 | Lapply{ap_func = fn; ap_args = args} ->
471 f fn; List.iter f args
472 | Lfunction{body} ->
473 f body
474 | Llet(_str, _k, _id, arg, body) ->
475 f arg; tail body
476 | Lletrec(decl, body) ->
477 tail body;
478 List.iter (fun (_id, exp) -> f exp) decl
479 | Lprim (Pidentity, [l], _) ->
480 tail l
481 | Lprim (Psequand, [l1; l2], _)
482 | Lprim (Psequor, [l1; l2], _) ->
483 f l1;
484 tail l2
485 | Lprim(_p, args, _loc) ->
486 List.iter f args
487 | Lswitch(arg, sw,_) ->
488 f arg;
489 List.iter (fun (_key, case) -> tail case) sw.sw_consts;
490 List.iter (fun (_key, case) -> tail case) sw.sw_blocks;
491 iter_opt tail sw.sw_failaction
492 | Lstringswitch (arg,cases,default,_) ->
493 f arg ;
494 List.iter (fun (_,act) -> tail act) cases ;
495 iter_opt tail default
496 | Lstaticraise (_,args) ->
497 List.iter f args
498 | Lstaticcatch(e1, _, e2) ->
499 tail e1; tail e2
500 | Ltrywith(e1, _, e2) ->
501 f e1; tail e2
502 | Lifthenelse(e1, e2, e3) ->
503 f e1; tail e2; tail e3
504 | Lsequence(e1, e2) ->
505 f e1; tail e2
506 | Lwhile(e1, e2) ->
507 f e1; f e2
508 | Lfor(_v, e1, e2, _dir, e3) ->
509 f e1; f e2; f e3
510 | Lassign(_, e) ->
511 f e
512 | Lsend (_k, met, obj, args, _) ->
513 List.iter f (met::obj::args)
514 | Levent (e, _evt) ->
515 tail e
516 | Lifused (_v, e) ->
517 tail e
518
519 let iter_head_constructor f l =
520 shallow_iter ~tail:f ~non_tail:f l
521
522 let rec free_variables = function
523 | Lvar id -> Ident.Set.singleton id
524 | Lconst _ -> Ident.Set.empty
525 | Lapply{ap_func = fn; ap_args = args} ->
526 free_variables_list (free_variables fn) args
527 | Lfunction{body; params} ->
528 Ident.Set.diff (free_variables body)
529 (Ident.Set.of_list (List.map fst params))
530 | Llet(_str, _k, id, arg, body) ->
531 Ident.Set.union
532 (free_variables arg)
533 (Ident.Set.remove id (free_variables body))
534 | Lletrec(decl, body) ->
535 let set = free_variables_list (free_variables body) (List.map snd decl) in
536 Ident.Set.diff set (Ident.Set.of_list (List.map fst decl))
537 | Lprim(_p, args, _loc) ->
538 free_variables_list Ident.Set.empty args
539 | Lswitch(arg, sw,_) ->
540 let set =
541 free_variables_list
542 (free_variables_list (free_variables arg)
543 (List.map snd sw.sw_consts))
544 (List.map snd sw.sw_blocks)
545 in
546 begin match sw.sw_failaction with
547 | None -> set
548 | Some failaction -> Ident.Set.union set (free_variables failaction)
549 end
550 | Lstringswitch (arg,cases,default,_) ->
551 let set =
552 free_variables_list (free_variables arg)
553 (List.map snd cases)
554 in
555 begin match default with
556 | None -> set
557 | Some default -> Ident.Set.union set (free_variables default)
558 end
559 | Lstaticraise (_,args) ->
560 free_variables_list Ident.Set.empty args
561 | Lstaticcatch(body, (_, params), handler) ->
562 Ident.Set.union
563 (Ident.Set.diff
564 (free_variables handler)
565 (Ident.Set.of_list (List.map fst params)))
566 (free_variables body)
567 | Ltrywith(body, param, handler) ->
568 Ident.Set.union
569 (Ident.Set.remove
570 param
571 (free_variables handler))
572 (free_variables body)
573 | Lifthenelse(e1, e2, e3) ->
574 Ident.Set.union
575 (Ident.Set.union (free_variables e1) (free_variables e2))
576 (free_variables e3)
577 | Lsequence(e1, e2) ->
578 Ident.Set.union (free_variables e1) (free_variables e2)
579 | Lwhile(e1, e2) ->
580 Ident.Set.union (free_variables e1) (free_variables e2)
581 | Lfor(v, lo, hi, _dir, body) ->
582 let set = Ident.Set.union (free_variables lo) (free_variables hi) in
583 Ident.Set.union set (Ident.Set.remove v (free_variables body))
584 | Lassign(id, e) ->
585 Ident.Set.add id (free_variables e)
586 | Lsend (_k, met, obj, args, _) ->
587 free_variables_list
588 (Ident.Set.union (free_variables met) (free_variables obj))
589 args
590 | Levent (lam, _evt) ->
591 free_variables lam
592 | Lifused (_v, e) ->
593 (* Shouldn't v be considered a free variable ? *)
594 free_variables e
595
596 and free_variables_list set exprs =
597 List.fold_left (fun set expr -> Ident.Set.union (free_variables expr) set)
598 set exprs
599
600 (* Check if an action has a "when" guard *)
601 let raise_count = ref 0
602
603 let next_raise_count () =
604 incr raise_count ;
605 !raise_count
606
607 (* Anticipated staticraise, for guards *)
608 let staticfail = Lstaticraise (0,[])
609
610 let rec is_guarded = function
611 | Lifthenelse(_cond, _body, Lstaticraise (0,[])) -> true
612 | Llet(_str, _k, _id, _lam, body) -> is_guarded body
613 | Levent(lam, _ev) -> is_guarded lam
614 | _ -> false
615
616 let rec patch_guarded patch = function
617 | Lifthenelse (cond, body, Lstaticraise (0,[])) ->
618 Lifthenelse (cond, body, patch)
619 | Llet(str, k, id, lam, body) ->
620 Llet (str, k, id, lam, patch_guarded patch body)
621 | Levent(lam, ev) ->
622 Levent (patch_guarded patch lam, ev)
623 | _ -> fatal_error "Lambda.patch_guarded"
624
625 (* Translate an access path *)
626
627 let rec transl_address loc = function
628 | Env.Aident id ->
629 if Ident.global id
630 then Lprim(Pgetglobal id, [], loc)
631 else Lvar id
632 | Env.Adot(addr, pos) ->
633 Lprim(Pfield pos, [transl_address loc addr], loc)
634
635 let transl_path find loc env path =
636 match find path env with
637 | exception Not_found ->
638 fatal_error ("Cannot find address for: " ^ (Path.name path))
639 | addr -> transl_address loc addr
640
641 (* Translation of identifiers *)
642
643 let transl_module_path loc env path =
644 transl_path Env.find_module_address loc env path
645
646 let transl_value_path loc env path =
647 transl_path Env.find_value_address loc env path
648
649 let transl_extension_path loc env path =
650 transl_path Env.find_constructor_address loc env path
651
652 let transl_class_path loc env path =
653 transl_path Env.find_class_address loc env path
654
655 let transl_prim mod_name name =
656 let pers = Ident.create_persistent mod_name in
657 let env = Env.add_persistent_structure pers Env.empty in
658 let lid = Longident.Ldot (Longident.Lident mod_name, name) in
659 match Env.find_value_by_name lid env with
660 | path, _ -> transl_value_path Location.none env path
661 | exception Not_found ->
662 fatal_error ("Primitive " ^ name ^ " not found.")
663
664 (* Compile a sequence of expressions *)
665
666 let rec make_sequence fn = function
667 [] -> lambda_unit
668 | [x] -> fn x
669 | x::rem ->
670 let lam = fn x in Lsequence(lam, make_sequence fn rem)
671
672 (* Apply a substitution to a lambda-term.
673 Assumes that the image of the substitution is out of reach
674 of the bound variables of the lambda-term (no capture). *)
675
676 let subst update_env s lam =
677 let rec subst s lam =
678 let remove_list l s =
679 List.fold_left (fun s (id, _kind) -> Ident.Map.remove id s) s l
680 in
681 match lam with
682 | Lvar id as l ->
683 begin try Ident.Map.find id s with Not_found -> l end
684 | Lconst _ as l -> l
685 | Lapply ap ->
686 Lapply{ap with ap_func = subst s ap.ap_func;
687 ap_args = subst_list s ap.ap_args}
688 | Lfunction lf ->
689 let s =
690 List.fold_right
691 (fun (id, _) s -> Ident.Map.remove id s)
692 lf.params s
693 in
694 Lfunction {lf with body = subst s lf.body}
695 | Llet(str, k, id, arg, body) ->
696 Llet(str, k, id, subst s arg, subst (Ident.Map.remove id s) body)
697 | Lletrec(decl, body) ->
698 let s =
699 List.fold_left (fun s (id, _) -> Ident.Map.remove id s)
700 s decl
701 in
702 Lletrec(List.map (subst_decl s) decl, subst s body)
703 | Lprim(p, args, loc) -> Lprim(p, subst_list s args, loc)
704 | Lswitch(arg, sw, loc) ->
705 Lswitch(subst s arg,
706 {sw with sw_consts = List.map (subst_case s) sw.sw_consts;
707 sw_blocks = List.map (subst_case s) sw.sw_blocks;
708 sw_failaction = subst_opt s sw.sw_failaction; },
709 loc)
710 | Lstringswitch (arg,cases,default,loc) ->
711 Lstringswitch
712 (subst s arg,List.map (subst_strcase s) cases,subst_opt s default,loc)
713 | Lstaticraise (i,args) -> Lstaticraise (i, subst_list s args)
714 | Lstaticcatch(body, (id, params), handler) ->
715 Lstaticcatch(subst s body, (id, params),
716 subst (remove_list params s) handler)
717 | Ltrywith(body, exn, handler) ->
718 Ltrywith(subst s body, exn, subst (Ident.Map.remove exn s) handler)
719 | Lifthenelse(e1, e2, e3) -> Lifthenelse(subst s e1, subst s e2, subst s e3)
720 | Lsequence(e1, e2) -> Lsequence(subst s e1, subst s e2)
721 | Lwhile(e1, e2) -> Lwhile(subst s e1, subst s e2)
722 | Lfor(v, lo, hi, dir, body) ->
723 Lfor(v, subst s lo, subst s hi, dir,
724 subst (Ident.Map.remove v s) body)
725 | Lassign(id, e) ->
726 assert(not (Ident.Map.mem id s));
727 Lassign(id, subst s e)
728 | Lsend (k, met, obj, args, loc) ->
729 Lsend (k, subst s met, subst s obj, subst_list s args, loc)
730 | Levent (lam, evt) ->
731 let lev_env =
732 Ident.Map.fold (fun id _ env ->
733 match Env.find_value (Path.Pident id) evt.lev_env with
734 | exception Not_found -> env
735 | vd -> update_env id vd env
736 ) s evt.lev_env
737 in
738 Levent (subst s lam, { evt with lev_env })
739 | Lifused (v, e) -> Lifused (v, subst s e)
740 and subst_list s l = List.map (subst s) l
741 and subst_decl s (id, exp) = (id, subst s exp)
742 and subst_case s (key, case) = (key, subst s case)
743 and subst_strcase s (key, case) = (key, subst s case)
744 and subst_opt s = function
745 | None -> None
746 | Some e -> Some (subst s e)
747 in
748 subst s lam
749
750 let rename idmap lam =
751 let update_env oldid vd env =
752 let newid = Ident.Map.find oldid idmap in
753 Env.add_value newid vd env
754 in
755 let s = Ident.Map.map (fun new_id -> Lvar new_id) idmap in
756 subst update_env s lam
757
758 let shallow_map f = function
759 | Lvar _
760 | Lconst _ as lam -> lam
761 | Lapply { ap_func; ap_args; ap_loc; ap_should_be_tailcall;
762 ap_inlined; ap_specialised } ->
763 Lapply {
764 ap_func = f ap_func;
765 ap_args = List.map f ap_args;
766 ap_loc;
767 ap_should_be_tailcall;
768 ap_inlined;
769 ap_specialised;
770 }
771 | Lfunction { kind; params; return; body; attr; loc; } ->
772 Lfunction { kind; params; return; body = f body; attr; loc; }
773 | Llet (str, k, v, e1, e2) ->
774 Llet (str, k, v, f e1, f e2)
775 | Lletrec (idel, e2) ->
776 Lletrec (List.map (fun (v, e) -> (v, f e)) idel, f e2)
777 | Lprim (p, el, loc) ->
778 Lprim (p, List.map f el, loc)
779 | Lswitch (e, sw, loc) ->
780 Lswitch (f e,
781 { sw_numconsts = sw.sw_numconsts;
782 sw_consts = List.map (fun (n, e) -> (n, f e)) sw.sw_consts;
783 sw_numblocks = sw.sw_numblocks;
784 sw_blocks = List.map (fun (n, e) -> (n, f e)) sw.sw_blocks;
785 sw_failaction = Option.map f sw.sw_failaction;
786 },
787 loc)
788 | Lstringswitch (e, sw, default, loc) ->
789 Lstringswitch (
790 f e,
791 List.map (fun (s, e) -> (s, f e)) sw,
792 Option.map f default,
793 loc)
794 | Lstaticraise (i, args) ->
795 Lstaticraise (i, List.map f args)
796 | Lstaticcatch (body, id, handler) ->
797 Lstaticcatch (f body, id, f handler)
798 | Ltrywith (e1, v, e2) ->
799 Ltrywith (f e1, v, f e2)
800 | Lifthenelse (e1, e2, e3) ->
801 Lifthenelse (f e1, f e2, f e3)
802 | Lsequence (e1, e2) ->
803 Lsequence (f e1, f e2)
804 | Lwhile (e1, e2) ->
805 Lwhile (f e1, f e2)
806 | Lfor (v, e1, e2, dir, e3) ->
807 Lfor (v, f e1, f e2, dir, f e3)
808 | Lassign (v, e) ->
809 Lassign (v, f e)
810 | Lsend (k, m, o, el, loc) ->
811 Lsend (k, f m, f o, List.map f el, loc)
812 | Levent (l, ev) ->
813 Levent (f l, ev)
814 | Lifused (v, e) ->
815 Lifused (v, f e)
816
817 let map f =
818 let rec g lam = f (shallow_map g lam) in
819 g
820
821 (* To let-bind expressions to variables *)
822
823 let bind_with_value_kind str (var, kind) exp body =
824 match exp with
825 Lvar var' when Ident.same var var' -> body
826 | _ -> Llet(str, kind, var, exp, body)
827
828 let bind str var exp body =
829 bind_with_value_kind str (var, Pgenval) exp body
830
831 let negate_integer_comparison = function
832 | Ceq -> Cne
833 | Cne -> Ceq
834 | Clt -> Cge
835 | Cle -> Cgt
836 | Cgt -> Cle
837 | Cge -> Clt
838
839 let swap_integer_comparison = function
840 | Ceq -> Ceq
841 | Cne -> Cne
842 | Clt -> Cgt
843 | Cle -> Cge
844 | Cgt -> Clt
845 | Cge -> Cle
846
847 let negate_float_comparison = function
848 | CFeq -> CFneq
849 | CFneq -> CFeq
850 | CFlt -> CFnlt
851 | CFnlt -> CFlt
852 | CFgt -> CFngt
853 | CFngt -> CFgt
854 | CFle -> CFnle
855 | CFnle -> CFle
856 | CFge -> CFnge
857 | CFnge -> CFge
858
859 let swap_float_comparison = function
860 | CFeq -> CFeq
861 | CFneq -> CFneq
862 | CFlt -> CFgt
863 | CFnlt -> CFngt
864 | CFle -> CFge
865 | CFnle -> CFnge
866 | CFgt -> CFlt
867 | CFngt -> CFnlt
868 | CFge -> CFle
869 | CFnge -> CFnle
870
871 let raise_kind = function
872 | Raise_regular -> "raise"
873 | Raise_reraise -> "reraise"
874 | Raise_notrace -> "raise_notrace"
875
876 let merge_inline_attributes attr1 attr2 =
877 match attr1, attr2 with
878 | Default_inline, _ -> Some attr2
879 | _, Default_inline -> Some attr1
880 | _, _ ->
881 if attr1 = attr2 then Some attr1
882 else None
883
884 let function_is_curried func =
885 match func.kind with
886 | Curried -> true
887 | Tupled -> false
888
889 let reset () =
890 raise_count := 0
891