From dd55c293acef3b0ae2772a0ec4e6c00b29a91887 Mon Sep 17 00:00:00 2001 From: Luc Maranget Date: Apr 02 2014 13:22:21 +0000 Subject: Fix PR#6359 git-svn-id: http://caml.inria.fr/svn/ocaml/trunk@14520 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02 --- diff --git a/Makefile b/Makefile index d5dce81..70cefb9 100644 --- a/Makefile +++ b/Makefile @@ -17,7 +17,7 @@ include stdlib/StdlibModules CAMLC=boot/ocamlrun boot/ocamlc -nostdlib -I boot CAMLOPT=boot/ocamlrun ./ocamlopt -nostdlib -I stdlib -I otherlibs/dynlink -COMPFLAGS=-strict-sequence -w +33..39+48 -warn-error A -bin-annot $(INCLUDES) +COMPFLAGS=-dtypes -strict-sequence -w +33..39+48 -warn-error A -bin-annot $(INCLUDES) LINKFLAGS= CAMLYACC=boot/ocamlyacc diff --git a/asmcomp/closure.ml b/asmcomp/closure.ml index 78357d3..e317d33 100644 --- a/asmcomp/closure.ml +++ b/asmcomp/closure.ml @@ -998,7 +998,7 @@ and close_one_function fenv cenv id funct = and close_switch fenv cenv cases num_keys default = let index = Array.create num_keys 0 - and store = mk_store Lambda.same in + and store = mk_store (fun lam -> lam) Lambda.same in (* First default case *) begin match default with diff --git a/asmcomp/cmmgen.ml b/asmcomp/cmmgen.ml index a953ba9..9d51632 100644 --- a/asmcomp/cmmgen.ml +++ b/asmcomp/cmmgen.ml @@ -1062,7 +1062,7 @@ let transl_isout h arg = tag_int (Cop(Ccmpa Clt, [h ; arg])) let make_switch_gen arg cases acts = let lcases = Array.length cases in let new_cases = Array.create lcases 0 in - let store = Switch.mk_store (=) in + let store = Switch.mk_store (fun x -> x) (=) in for i = 0 to Array.length cases-1 do let act = cases.(i) in diff --git a/bytecomp/bytegen.ml b/bytecomp/bytegen.ml index 3b25c3d..9f98e3a 100644 --- a/bytecomp/bytegen.ml +++ b/bytecomp/bytegen.ml @@ -696,7 +696,7 @@ let rec comp_expr env exp sz cont = let (branch, cont1) = make_branch cont in let c = ref (discard_dead_code cont1) in (* Build indirection vectors *) - let store = mk_store Lambda.same in + let store = mk_store (fun lam -> lam) Lambda.same in let act_consts = Array.create sw.sw_numconsts 0 and act_blocks = Array.create sw.sw_numblocks 0 in begin match sw.sw_failaction with (* default is index 0 *) diff --git a/bytecomp/matching.ml b/bytecomp/matching.ml index e981483..00cc985 100644 --- a/bytecomp/matching.ml +++ b/bytecomp/matching.ml @@ -446,22 +446,39 @@ let pretty_precompiled_res first nexts = (* A slight attempt to identify semantically equivalent lambda-expressions, We could have used Lambda.same, but our goal here is also to find alpha-equivalent (simple) terms *) +(* However, PR#6359 such sharing may hinders the invariant + of lambda-code 'Bound variable are unique', when code is finaly + not shared (eg. in test trees). + As a patch we only share expresssions with no lets + (cf. calls to mk_store below) +*) + + exception Not_simple -let rec raw_rec env : lambda -> lambda = function - | Llet(Alias,x,ex, body) -> raw_rec ((x,raw_rec env ex)::env) body +let raw_rec = + let seen = ref [] in + let rec do_raw env e = match e with + | Llet(Alias,x,ex, body) -> + do_raw ((x,do_raw env ex)::env) body | Lvar id as l -> - begin try List.assoc id env with - | Not_found -> l - end + if List.mem id !seen then raise Not_simple + else + begin + seen := id :: !seen ; + try List.assoc id env with + | Not_found -> l + end | Lprim (Pfield i,args) -> - Lprim (Pfield i, List.map (raw_rec env) args) + Lprim (Pfield i, List.map (do_raw env) args) | Lconst (Const_base (Const_string _)) -> raise Not_simple (* do not share strings *) | Lconst _ as l -> l | Lstaticraise (i,args) -> - Lstaticraise (i, List.map (raw_rec env) args) - | _ -> raise Not_simple + Lstaticraise (i, List.map (do_raw env) args) + | _ -> raise Not_simple in + do_raw + let raw_action l = try raw_rec [] l with Not_simple -> l @@ -700,7 +717,7 @@ let rec explode_or_pat arg patl mk_action rem vars aliases = function let env = mk_alpha_env arg (x::aliases) vars in (omega::patl,mk_action (List.map snd env))::rem | p -> - let env = mk_alpha_env arg aliases vars in + let env = mk_alpha_env arg aliases vars in (alpha_pat env p::patl,mk_action (List.map snd env))::rem let pm_free_variables {cases=cases} = @@ -1925,6 +1942,7 @@ module SArg = struct let make_isin h arg = Lprim (Pnot,[make_isout h arg]) let make_if cond ifso ifnot = Lifthenelse (cond, ifso, ifnot) let make_switch = make_switch_switcher + let alpha act = act end module Switcher = Switch.Make(SArg) @@ -1943,7 +1961,7 @@ let get_edges low high l = match l with let as_interval_canfail fail low high l = - let store = mk_store equal_action in + let store = mk_store raw_action equal_action in let rec nofail_rec cur_low cur_high cur_act = function | [] -> if cur_high = high then @@ -1989,7 +2007,7 @@ let as_interval_canfail fail low high l = Array.of_list r, store.act_get () let as_interval_nofail l = - let store = mk_store equal_action in + let store = mk_store raw_action equal_action in let rec i_rec cur_low cur_high cur_act = function | [] -> diff --git a/bytecomp/switch.ml b/bytecomp/switch.ml index ff193ee..ccbb62c 100644 --- a/bytecomp/switch.ml +++ b/bytecomp/switch.ml @@ -16,9 +16,10 @@ exception Found of int type 'a t_store = {act_get : unit -> 'a array ; act_store : 'a -> int} -let mk_store same = +let mk_store simplif same = let r_acts = ref [] in let store act = + let act = simplif act in let rec store_rec i = function | [] -> i,[act] | act0::rem -> diff --git a/bytecomp/switch.mli b/bytecomp/switch.mli index 69fc800..7418bb6 100644 --- a/bytecomp/switch.mli +++ b/bytecomp/switch.mli @@ -19,7 +19,19 @@ type 'a t_store = {act_get : unit -> 'a array ; act_store : 'a -> int} -val mk_store : ('a -> 'a -> bool) -> 'a t_store + +(* PR6359 + Actions must be simplified so as to substitute + 'simple' bindings, ie the ones that would be + kept in equal actions. + Otherwise, there is a risk binder duplications, in case + a shared action is later unshared. (Typically in test trees) +*) + +val mk_store : + ('a -> 'a) -> (* Simplify actions *) + ('a -> 'a -> bool) -> (* equality of simplified actions *) + 'a t_store (* Arguments to the Make functor *) module type S =