bug 539

git-svn-id: http://caml.inria.fr/svn/ocaml/trunk@3773 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02

9 files changed, 213 insertions, 119 deletions

diff --git a/Makefile b/Makefile
index 7d51a6bf4..013db17cf 100644
--- a/Makefile
+++ b/Makefile
@@ -203,6 +203,7 @@ cleanboot:
 	rm -rf boot/Saved/Saved.prev/*
 
 # Compile the native-code compiler
+opt-core:runtimeopt ocamlopt libraryopt
 opt: runtimeopt ocamlopt libraryopt otherlibrariesopt camlp4opt
 
 # Native-code versions of the tools
diff --git a/asmcomp/cmmgen.ml b/asmcomp/cmmgen.ml
index 3adc93320..dedabf5bb 100644
--- a/asmcomp/cmmgen.ml
+++ b/asmcomp/cmmgen.ml
@@ -1370,10 +1370,10 @@ and transl_switch arg index cases = match Array.length cases with
       end
     done ;
     inters := (0, !this_high, !this_act) :: !inters ;
-
     bind "switcher" arg
       (fun a ->
         SwitcherBlocks.zyva
+          (0,n_index-1)
           (fun i -> Cconst_int i)
           a
           (Array.of_list !inters) actions)
diff --git a/boot/ocamlc b/boot/ocamlc
index 1dd1a6437..e6b6cb8fe 100755
--- a/boot/ocamlc
+++ b/boot/ocamlc
diff --git a/boot/ocamllex b/boot/ocamllex
index 05a07a419..0ce58e018 100755
--- a/boot/ocamllex
+++ b/boot/ocamllex
diff --git a/bytecomp/matching.ml b/bytecomp/matching.ml
index 86c6d7e03..c81d744ef 100644
--- a/bytecomp/matching.ml
+++ b/bytecomp/matching.ml
@@ -1409,6 +1409,15 @@ open Switch
 
 let lambda_of_int i =  Lconst (Const_base (Const_int i))
 
+let rec last def = function
+| [] -> def
+| [x,_] -> x
+| _::rem -> last def rem
+
+let get_edges low high l = match l with
+| [] -> low, high
+| (x,_)::_ -> x, last high l
+
   
 let as_interval_canfail fail low high l =
   let store = mk_store equal_action in
@@ -1453,7 +1462,7 @@ let as_interval_canfail fail low high l =
             nofail_rec i i index rem in
 
   ignore (store.act_store fail) ; (* fail has action index 0 *)
-  let r = init_rec (sort_lambda_list l) in
+  let r = init_rec l in
   Array.of_list r,  store.act_get ()
 
 let as_interval_nofail l =
@@ -1469,21 +1478,25 @@ let as_interval_nofail l =
         else
           (cur_low, cur_high, cur_act)::
           i_rec i i act_index rem in
-  let inters = match sort_lambda_list l with
+  let inters = match l with
   | (i,act)::rem ->
       let act_index = store.act_store act in
       i_rec i i act_index rem
   | _ -> assert false in
+
   Array.of_list inters, store.act_get ()
 
-let as_interval fail low high l = match fail with
-| None -> as_interval_nofail l
-| Some act -> as_interval_canfail act low high l
+let as_interval fail low high l =
+  let l = sort_lambda_list l in
+  get_edges low high l,
+  (match fail with
+  | None -> as_interval_nofail l
+  | Some act -> as_interval_canfail act low high l)
 
 let call_switcher konst fail arg low high int_lambda_list =
-  let cases, actions =
+  let edges, (cases, actions) =
     as_interval fail low high int_lambda_list in
-  Switcher.zyva konst arg cases actions
+  Switcher.zyva edges konst arg cases actions
 
 
 let exists_ctx ok ctx =
@@ -1735,7 +1748,7 @@ let combine_constructor arg ex_pat cstr partial ctx def
   end
 
 let make_test_sequence_variant_constant fail arg int_lambda_list =
-  let cases, actions =
+  let _, (cases, actions) =
     as_interval fail min_int max_int int_lambda_list in
   Switcher.test_sequence
     (fun i -> Lconst (Const_base (Const_int i))) arg cases actions
@@ -1745,6 +1758,7 @@ let call_switcher_variant_constant fail arg int_lambda_list =
     (fun i -> Lconst (Const_base (Const_int i)))
     fail arg min_int max_int int_lambda_list
 
+
 let call_switcher_variant_constr fail arg int_lambda_list =
   let v = Ident.create "variant" in
   Llet(Alias, v, Lprim(Pfield 0, [arg]),
diff --git a/bytecomp/switch.ml b/bytecomp/switch.ml
index 7d500c08b..216261b90 100644
--- a/bytecomp/switch.ml
+++ b/bytecomp/switch.ml
@@ -306,19 +306,36 @@ let make_key  cases =
   make_one l h act::make_rec (Array.length cases-2) l 
                        
 
-let same_act t =
-  let len = Array.length t in
-  let a = get_act t (len-1) in
-  let rec do_rec i =
-    if i < 0 then true
-    else
-      let b = get_act t i in
-      b=a && do_rec (i-1) in
-  do_rec (len-2)
+    let same_act t =
+      let len = Array.length t in
+      let a = get_act t (len-1) in
+      let rec do_rec i =
+        if i < 0 then true
+        else
+          let b = get_act t i in
+          b=a && do_rec (i-1) in
+      do_rec (len-2)
+
+
+(*
+  Intervall test x in [l,h] works by checking x-l in [0,h-l]
+   * This may be false for arithmetic modulo 2^31
+   * Subtracting l may change the relative ordering of values
+     and invalid the invariant that matched values are given in
+     increasing order
 
+   To avoid this, interval check is allowed only when the
+   integers indeed present in the whole case interval are
+   in [-2^16 ; 2^16]
 
+   This condition is checked by zyva
+*)
   
-    let rec opt_count top cases =
+let inter_limit = 1 lsl 16
+ 
+let ok_inter = ref false
+
+let rec opt_count top cases =
       let key = make_key cases in
       try
         let r = Hashtbl.find t key in
@@ -340,58 +357,10 @@ let same_act t =
           Hashtbl.add t key r ;
           r
 
-and divide top cases =
-  let lcases = Array.length cases in
-  let m = lcases/2 in
-  let _,left,right = coupe cases m in
-  let ci = {n=1 ; ni=0}
-  and cm = {n=1 ; ni=0}
-  and _,(cml,cleft) = opt_count false left
-  and _,(cmr,cright) = opt_count false right in
-  add_test ci cleft ;
-  add_test ci cright ;
-  if less_tests cml cmr then
-    add_test cm cmr
-  else
-    add_test cm cml ;
-  Sep m,(cm, ci)
-
-and heuristic top cases =
-  let lcases = Array.length cases in
-
-  let sep,csep = divide false cases
-
-  and inter,cinter =
-    let _,_,act0 = cases.(0)
-    and _,_,act1 = cases.(lcases-1) in
-    if act0 = act1 then begin
-      let low, high, inside, outside = coupe_inter 1 (lcases-2) cases in
-      let _,(cmi,cinside) = opt_count false inside
-      and _,(cmo,coutside) = opt_count false outside
-      and cmij = {n=1 ; ni=(if low=high then 0 else 1)}
-      and cij = {n=1 ; ni=(if low=high then 0 else 1)} in
-      add_test cij cinside ;
-      add_test cij coutside ;
-      if less_tests cmi cmo then
-        add_test cmij cmo
-      else
-        add_test cmij cmi ;
-      Inter (1,lcases-2),(cmij,cij)
-    end else
-      Inter (-1,-1),(too_much, too_much) in
-  if less2tests csep cinter then
-    sep,csep
-  else
-    inter,cinter
-
-
-and enum top cases =
-  let lcases = Array.length cases in
-  let lim, with_sep =
-    let best = ref (-1) and best_cost = ref (too_much,too_much) in
-
-    for i = 1 to lcases-(1) do
-      let _,left,right = coupe cases i in
+    and divide top cases =
+      let lcases = Array.length cases in
+      let m = lcases/2 in
+      let _,left,right = coupe cases m in
       let ci = {n=1 ; ni=0}
       and cm = {n=1 ; ni=0}
       and _,(cml,cleft) = opt_count false left
@@ -402,49 +371,100 @@ and enum top cases =
         add_test cm cmr
       else
         add_test cm cml ;
-      
-      if
-        less2tests (cm,ci) !best_cost
-      then begin
-        if top then
-          Printf.fprintf stderr "Get it: %d\n" i ;
-        best := i ;
-        best_cost := (cm,ci)
-      end
-    done ;
-    !best, !best_cost in
-  let ilow, ihigh, with_inter =
-    if lcases <= 2 then
-      -1,-1,(too_much,too_much)
-    else
-      let rlow = ref (-1) and rhigh = ref (-1)
-      and best_cost= ref (too_much,too_much) in
-      for i=1 to lcases-2 do
-        for j=i to lcases-2 do
-          let low, high, inside, outside = coupe_inter i j cases in
-          let _,(cmi,cinside) = opt_count false inside
-          and _,(cmo,coutside) = opt_count false outside
-          and cmij = {n=1 ; ni=(if low=high then 0 else 1)}
-          and cij = {n=1 ; ni=(if low=high then 0 else 1)} in
-          add_test cij cinside ;
-          add_test cij coutside ;
-          if less_tests cmi cmo then
-            add_test cmij cmo
+      Sep m,(cm, ci)
+
+    and heuristic top cases =
+      let lcases = Array.length cases in
+
+      let sep,csep = divide false cases
+
+      and inter,cinter =
+        if !ok_inter then begin
+          let _,_,act0 = cases.(0)
+          and _,_,act1 = cases.(lcases-1) in
+          if act0 = act1 then begin
+            let low, high, inside, outside = coupe_inter 1 (lcases-2) cases in
+            let _,(cmi,cinside) = opt_count false inside
+            and _,(cmo,coutside) = opt_count false outside
+            and cmij = {n=1 ; ni=(if low=high then 0 else 1)}
+            and cij = {n=1 ; ni=(if low=high then 0 else 1)} in
+            add_test cij cinside ;
+            add_test cij coutside ;
+            if less_tests cmi cmo then
+              add_test cmij cmo
+            else
+              add_test cmij cmi ;
+            Inter (1,lcases-2),(cmij,cij)
+          end else
+            Inter (-1,-1),(too_much, too_much)
+        end else
+            Inter (-1,-1),(too_much, too_much) in          
+      if less2tests csep cinter then
+        sep,csep
+      else
+        inter,cinter
+
+
+    and enum top cases =
+      let lcases = Array.length cases in
+      let lim, with_sep =
+        let best = ref (-1) and best_cost = ref (too_much,too_much) in
+
+        for i = 1 to lcases-(1) do
+          let _,left,right = coupe cases i in
+          let ci = {n=1 ; ni=0}
+          and cm = {n=1 ; ni=0}
+          and _,(cml,cleft) = opt_count false left
+          and _,(cmr,cright) = opt_count false right in
+          add_test ci cleft ;
+          add_test ci cright ;
+          if less_tests cml cmr then
+            add_test cm cmr
           else
-            add_test cmij cmi ;
-          if less2tests (cmij,cij) !best_cost then begin
-            rlow := i ;
-            rhigh := j ;
-            best_cost := (cmij,cij)
+            add_test cm cml ;
+          
+          if
+            less2tests (cm,ci) !best_cost
+          then begin
+            if top then
+              Printf.fprintf stderr "Get it: %d\n" i ;
+            best := i ;
+            best_cost := (cm,ci)
           end
-        done
-      done ;
-      !rlow, !rhigh, !best_cost in
-  let r = ref (Inter (ilow,ihigh)) and rc = ref with_inter in
-  if less2tests with_sep !rc then begin
-    r := Sep lim ; rc := with_sep
-  end ;
-  !r, !rc
+        done ;
+        !best, !best_cost in
+      let ilow, ihigh, with_inter =
+        if not !ok_inter then
+          -1,-1,(too_much,too_much)
+        else
+          let rlow = ref (-1) and rhigh = ref (-1)
+          and best_cost= ref (too_much,too_much) in
+          for i=1 to lcases-2 do
+            for j=i to lcases-2 do
+              let low, high, inside, outside = coupe_inter i j cases in
+              let _,(cmi,cinside) = opt_count false inside
+              and _,(cmo,coutside) = opt_count false outside
+              and cmij = {n=1 ; ni=(if low=high then 0 else 1)}
+              and cij = {n=1 ; ni=(if low=high then 0 else 1)} in
+              add_test cij cinside ;
+              add_test cij coutside ;
+              if less_tests cmi cmo then
+                add_test cmij cmo
+              else
+                add_test cmij cmi ;
+              if less2tests (cmij,cij) !best_cost then begin
+                rlow := i ;
+                rhigh := j ;
+                best_cost := (cmij,cij)
+              end
+            done
+          done ;
+          !rlow, !rhigh, !best_cost in
+      let r = ref (Inter (ilow,ihigh)) and rc = ref with_inter in
+      if less2tests with_sep !rc then begin
+        r := Sep lim ; rc := with_sep
+      end ;
+      !r, !rc
 
 let make_if_test konst test arg i ifso ifnot =
   Arg.make_if
@@ -731,13 +751,21 @@ let make_clusters ({cases=cases ; actions=actions} as s) n_clusters k =
 ;;
 
   
-let zyva konst arg cases actions = 
+let zyva (low,high) konst arg cases actions = 
+  let lcases = Array.length cases in
+  ok_inter := (abs low <= inter_limit && abs high <= inter_limit) ;
+
   let s = {cases=cases ; actions=actions} in
+(*
+  pcases stderr cases ;
+  prerr_endline "" ;
+*)
   let n_clusters,k = comp_clusters s in
   let clusters = make_clusters s n_clusters k in
   c_test konst {arg=arg ; off=0} clusters
 
 and test_sequence konst arg cases actions =
+  ok_inter := false ;
   let s =
     {cases=cases ;
     actions=Array.map (fun act -> (fun _ -> act)) actions} in
diff --git a/bytecomp/switch.mli b/bytecomp/switch.mli
index a0b34a87a..73799daa0 100644
--- a/bytecomp/switch.mli
+++ b/bytecomp/switch.mli
@@ -67,6 +67,7 @@ module Make :
   functor (Arg : S) ->
     sig
       val zyva :
+          (int * int) -> 
           (int -> Arg.act) ->
            Arg.act ->
            (int * int * int) array ->
diff --git a/camlp4/man/Makefile b/camlp4/man/Makefile
index 60baa6c19..14d221c41 100644
--- a/camlp4/man/Makefile
+++ b/camlp4/man/Makefile
@@ -15,11 +15,11 @@ get_promote:
 
 install:
 	-$(MKDIR) $(MANDIR)
-	cp $(TARGET) $(MANDIR)/.
-	cd $(MANDIR); rm -f camlp4o.1; ln -s $(TARGET) camlp4o.1
-	cd $(MANDIR); rm -f camlp4r.1; ln -s $(TARGET) camlp4r.1
-	cd $(MANDIR); rm -f mkcamlp4.1; ln -s $(TARGET) mkcamlp4.1
-	cd $(MANDIR); rm -f ocpp.1; ln -s $(TARGET) ocpp.1
+	-cp $(TARGET) $(MANDIR)/.
+	-cd $(MANDIR); rm -f camlp4o.1; ln -s $(TARGET) camlp4o.1
+	-cd $(MANDIR); rm -f camlp4r.1; ln -s $(TARGET) camlp4r.1
+	-cd $(MANDIR); rm -f mkcamlp4.1; ln -s $(TARGET) mkcamlp4.1
+	-cd $(MANDIR); rm -f ocpp.1; ln -s $(TARGET) ocpp.1
 
 camlp4.1: camlp4.1.tpl
 	sed -e "s'LIBDIR'$(LIBDIR)'g" camlp4.1.tpl > camlp4.1
diff --git a/test/Moretest/morematch.ml b/test/Moretest/morematch.ml
index 34d9866d2..ca87fd3da 100644
--- a/test/Moretest/morematch.ml
+++ b/test/Moretest/morematch.ml
@@ -974,5 +974,55 @@ test "habert" habert (A ex0) 1 ;
 test "habert" habert (B ex0) 1 ;
 test "habert" habert (A ex1) 2 ;
 test "habert" habert (B ex1) 3 ;
-()
+
+(* Problems with interval test in arithmetic mod 2^31, bug #359 *)
+(* From manuel Fahndrich *)
+
+type type_expr = [
+  | `TTuple of type_expr list
+  | `TConstr of type_expr list
+  | `TVar of string
+  | `TVariant of string list
+  | `TBlock of int
+  | `TCopy of type_expr
+  ] 
+
+and recurs_type_expr = [
+  | `TTuple of type_expr list
+  | `TConstr of type_expr list
+  | `TVariant of string list
+  ] 
+
+
+let rec maf te =
+    match te with
+    | `TCopy te -> 1
+    | `TVar _ -> 2
+    | `TBlock _ -> 2
+    | #recurs_type_expr as desc ->
+
+        let te =
+          (match desc with
+            `TTuple tl ->
+              4
+          | `TConstr tl ->
+              5
+          | `TVariant (row) ->
+              6
+                )
+        in
+
+        te
+;;
+
+let base = `TBlock 0
 ;;
+
+test "maf" maf (`TCopy base) 1 ;
+test "maf" maf (`TVar "test") 2 ;
+test "maf" maf (`TBlock 0) 2 ;
+test "maf" maf (`TTuple []) 4 ;
+test "maf" maf (`TConstr []) 5 ;
+test "maf" maf (`TVariant []) 6
+;;
+