From f8a3649190114bc7182c718837a2a1737ad676f1 Mon Sep 17 00:00:00 2001
From: Luc Maranget <luc.maranget@inria.fr>
Date: Mon, 12 May 2014 14:57:24 +0000
Subject: [PATCH] Correct PR#6412 by ruling out sharing of Levents

git-svn-id: http://caml.inria.fr/svn/ocaml/trunk@14804 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02
---
 bytecomp/lambda.ml   | 18 +++++++++++++-----
 bytecomp/matching.ml |  4 +---
 2 files changed, 14 insertions(+), 8 deletions(-)

diff --git a/bytecomp/lambda.ml b/bytecomp/lambda.ml
index 68b03d280..3c1aaf26b 100644
--- a/bytecomp/lambda.ml
+++ b/bytecomp/lambda.ml
@@ -211,16 +211,23 @@ let const_unit = Const_pointer 0
 
 let lambda_unit = Lconst const_unit
 
+(* Build sharing keys *)
+(*
+   Those keys are later compared with Pervasives.compare.
+   For that reason, they should not include cycles.
+*)
+
 exception Not_simple
 
 let max_raw = 32
 
 let make_key e =
-  let count = ref 0
+  let count = ref 0   (* Used for controling size *)
   and make_key = Ident.make_key_generator () in
+  (* make_key is used for normalizing let-bound variables *)
   let rec tr_rec env e =
     incr count ;
-    if !count > max_raw then raise Not_simple ;
+    if !count > max_raw then raise Not_simple ; (* Too big ! *)
     match e with
     | Lvar id ->
       begin
@@ -264,11 +271,12 @@ let make_key e =
         Lassign (x,tr_rec env e)
     | Lsend (m,e1,e2,es,loc) ->
         Lsend (m,tr_rec env e1,tr_rec env e2,tr_recs env es,Location.none)
-    | Levent (e,evt) ->
-        Levent (tr_rec env e,evt)
     | Lifused (id,e) -> Lifused (id,tr_rec env e)
     | Lletrec _|Lfunction _
-    | Lfor _ | Lwhile _  ->
+    | Lfor _ | Lwhile _
+(* Beware: (PR#6412) the event argument to Levent
+   may include cyclic structure of type Type.typexpr *)
+    | Levent _  ->
         raise Not_simple
 
   and tr_recs env es = List.map (tr_rec env) es
diff --git a/bytecomp/matching.ml b/bytecomp/matching.ml
index 2e2eea9a2..88a348408 100644
--- a/bytecomp/matching.ml
+++ b/bytecomp/matching.ml
@@ -531,9 +531,7 @@ let up_ok_action act1 act2 =
   try
     let raw1 = tr_raw act1
     and raw2 = tr_raw act2 in
-    match raw1, raw2 with
-    | Lstaticraise (i1,[]), Lstaticraise (i2,[]) -> i1=i2
-    | _,_ -> raw1 = raw2
+    raw1 = raw2
   with
   | Exit -> false