Cmm arithmetic optimisations.

Constant additions and tagging operations are moved out of
subexpressions when possible. Often they can be merged.

From Stephen Dolan:
  https://github.com/ocaml/ocaml/pull/17

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

4 files changed, 52 insertions, 42 deletions

diff --git a/Changes b/Changes
index 81336bf653..0fae9015b5 100644
--- a/Changes
+++ b/Changes
@@ -27,6 +27,8 @@ Compilers:
   (Frédéric Bour, review by Gabriel Scherer)
 - PR#6737: fix Typedtree attributes on (fun x -> body) expressions
 - PR#6679: fix pprintast printing of constraints in type declarations
+- some cmm optimizations of integer operations with constants
+  (Stephen Dolan, review by Pierre Chambart)
 
 Runtime system:
 - PR#6517: use ISO C99 types {,u}int{32,64}_t in preference to our homegrown
diff --git a/asmcomp/cmmgen.ml b/asmcomp/cmmgen.ml
index 08c851fb17..e483189b15 100644
--- a/asmcomp/cmmgen.ml
+++ b/asmcomp/cmmgen.ml
@@ -88,70 +88,68 @@ let rec add_const c n =
   if n = 0 then c
   else match c with
   | Cconst_int x when no_overflow_add x n -> Cconst_int (x + n)
+  | Cop(Caddi, ([Cconst_int x; c] | [c; Cconst_int x])) when no_overflow_add n x ->
+      let d = n + x in
+      if d == 0 then c else Cop(Caddi, [c; Cconst_int d])
   | Cop(Csubi, [Cconst_int x; c]) when no_overflow_add n x ->
       Cop(Csubi, [Cconst_int (n + x); c])
   | Cop(Csubi, [c; Cconst_int x]) when no_overflow_sub n x ->
       add_const c (n - x)
   | c -> Cop(Caddi, [c; Cconst_int n])
 
-let incr_int = function
-    Cconst_int n when n < max_int -> Cconst_int(n+1)
-  | Cop(Caddi, [c; Cconst_int n]) when n < max_int -> add_const c (n + 1)
-  | c -> add_const c 1
+let incr_int c = add_const c 1
+let decr_int c = add_const c (-1)
 
-let decr_int = function
-    Cconst_int n when n > min_int -> Cconst_int(n-1)
-  | Cop(Caddi, [c; Cconst_int n]) when n > min_int -> add_const c (n - 1)
-  | c -> add_const c (-1)
-
-let add_int c1 c2 =
+let rec add_int c1 c2 =
   match (c1, c2) with
-    (Cop(Caddi, [c1; Cconst_int n1]),
-     Cop(Caddi, [c2; Cconst_int n2])) when no_overflow_add n1 n2 ->
-      add_const (Cop(Caddi, [c1; c2])) (n1 + n2)
+  | (Cconst_int n, c) | (c, Cconst_int n) ->
+      add_const c n
   | (Cop(Caddi, [c1; Cconst_int n1]), c2) ->
-      add_const (Cop(Caddi, [c1; c2])) n1
+      add_const (add_int c1 c2) n1
   | (c1, Cop(Caddi, [c2; Cconst_int n2])) ->
-      add_const (Cop(Caddi, [c1; c2])) n2
-  | (Cconst_int _, _) ->
-      Cop(Caddi, [c2; c1])
+      add_const (add_int c1 c2) n2
   | (_, _) ->
       Cop(Caddi, [c1; c2])
 
-let sub_int c1 c2 =
+let rec sub_int c1 c2 =
   match (c1, c2) with
-    (Cop(Caddi, [c1; Cconst_int n1]),
-     Cop(Caddi, [c2; Cconst_int n2])) when no_overflow_sub n1 n2 ->
-      add_const (Cop(Csubi, [c1; c2])) (n1 - n2)
-  | (Cop(Caddi, [c1; Cconst_int n1]), c2) ->
-      add_const (Cop(Csubi, [c1; c2])) n1
+  | (c1, Cconst_int n2) when n2 <> min_int ->
+      add_const c1 (-n2)
   | (c1, Cop(Caddi, [c2; Cconst_int n2])) when n2 <> min_int ->
-      add_const (Cop(Csubi, [c1; c2])) (-n2)
-  | (c1, Cconst_int n) when n <> min_int ->
-      add_const c1 (-n)
+      add_const (sub_int c1 c2) (-n2)
+  | (Cop(Caddi, [c1; Cconst_int n1]), c2) ->
+      add_const (sub_int c1 c2) n1
   | (c1, c2) ->
       Cop(Csubi, [c1; c2])
 
-let mul_int c1 c2 =
+let rec lsl_int c1 c2 =
   match (c1, c2) with
-    (c, Cconst_int 0) | (Cconst_int 0, c) ->
+  | (Cop(Clsl, [c; Cconst_int n1]), Cconst_int n2)
+    when n1 > 0 && n2 > 0 && n1 + n2 < size_int * 8 ->
+      Cop(Clsl, [c; Cconst_int (n1 + n2)])
+  | (Cop(Caddi, [c1; Cconst_int n1]), Cconst_int n2)
+    when no_overflow_lsl n1 n2 ->
+      add_const (lsl_int c1 c2) (n1 lsl n2)
+  | (_, _) ->
+      Cop(Clsl, [c1; c2])
+
+let rec mul_int c1 c2 =
+  match (c1, c2) with
+  | (c, Cconst_int 0) | (Cconst_int 0, c) ->
       Cconst_int 0
   | (c, Cconst_int 1) | (Cconst_int 1, c) ->
       c
   | (c, Cconst_int(-1)) | (Cconst_int(-1), c) ->
       sub_int (Cconst_int 0) c
   | (c, Cconst_int n) | (Cconst_int n, c) when n = 1 lsl Misc.log2 n->
-      Cop(Clsl, [c; Cconst_int(Misc.log2 n)])
+      lsl_int c (Cconst_int (Misc.log2 n))
+  | (Cop(Caddi, [c; Cconst_int n]), Cconst_int k) |
+    (Cconst_int k, Cop(Caddi, [c; Cconst_int n]))
+    when no_overflow_mul n k ->
+      add_const (mul_int c (Cconst_int k)) (n * k)
   | (c1, c2) ->
       Cop(Cmuli, [c1; c2])
 
-let lsl_int c1 c2 =
-  match (c1, c2) with
-    (Cop(Clsl, [c; Cconst_int n1]), Cconst_int n2)
-    when n1 > 0 && n2 > 0 && n1 + n2 < size_int * 8 ->
-      Cop(Clsl, [c; Cconst_int (n1 + n2)])
-  | (_, _) ->
-      Cop(Clsl, [c1; c2])
 
 let ignore_low_bit_int = function
     Cop(Caddi, [(Cop(Clsl, [_; Cconst_int n]) as c); Cconst_int 1]) when n > 0
@@ -205,6 +203,11 @@ let untag_int = function
   | Cop(Cor, [c; Cconst_int 1]) -> Cop(Casr, [c; Cconst_int 1])
   | c -> Cop(Casr, [c; Cconst_int 1])
 
+let mul_int_tagged c1 c2 =
+  match (c1, c2) with
+  | (Cconst_int n1, c2) -> incr_int (mul_int (untag_int c1) (decr_int c2))
+  | (_, _) -> incr_int (mul_int (decr_int c1) (untag_int c2))
+
 (* Turning integer divisions into multiply-high then shift.
    The [division_parameters] function is used in module Emit for
    those target platforms that support this optimization. *)
@@ -1580,7 +1583,7 @@ and transl_prim_1 p arg dbg =
         | Ostype_cygwin -> const_of_bool (Sys.os_type = "Cygwin")
       end
   | Poffsetint n ->
-      if no_overflow_lsl n then
+      if no_overflow_lsl n 1 then
         add_const (transl arg) (n lsl 1)
       else
         transl_prim_2 Paddint arg (Uconst (Uconst_int n))
@@ -1682,7 +1685,7 @@ and transl_prim_2 p arg1 arg2 dbg =
   | Psubint ->
       incr_int(sub_int (transl arg1) (transl arg2))
   | Pmulint ->
-      incr_int(mul_int (decr_int(transl arg1)) (untag_int(transl arg2)))
+      mul_int_tagged (transl arg1) (transl arg2)
   | Pdivint ->
       tag_int(div_int (untag_int(transl arg1)) (untag_int(transl arg2)) dbg)
   | Pmodint ->
diff --git a/utils/misc.ml b/utils/misc.ml
index 997508f854..0f94be92a9 100644
--- a/utils/misc.ml
+++ b/utils/misc.ml
@@ -176,7 +176,9 @@ let no_overflow_add a b = (a lxor b) lor (a lxor (lnot (a+b))) < 0
 
 let no_overflow_sub a b = (a lxor (lnot b)) lor (b lxor (a-b)) < 0
 
-let no_overflow_lsl a = min_int asr 1 <= a && a <= max_int asr 1
+let no_overflow_mul a b = b <> 0 && (a * b) / b = a
+
+let no_overflow_lsl a k = 0 <= k && k < Sys.word_size && min_int asr k <= a && a <= max_int asr k
 
 (* String operations *)
 
diff --git a/utils/misc.mli b/utils/misc.mli
index 853e7cde6b..48bbb46beb 100644
--- a/utils/misc.mli
+++ b/utils/misc.mli
@@ -80,9 +80,12 @@ val no_overflow_add: int -> int -> bool
 val no_overflow_sub: int -> int -> bool
         (* [no_overflow_add n1 n2] returns [true] if the computation of
            [n1 - n2] does not overflow. *)
-val no_overflow_lsl: int -> bool
-        (* [no_overflow_add n] returns [true] if the computation of
-           [n lsl 1] does not overflow. *)
+val no_overflow_mul: int -> int -> bool
+        (* [no_overflow_mul n1 n2] returns [true] if the computation of
+           [n1 * n2] does not overflow. *)
+val no_overflow_lsl: int -> int -> bool
+        (* [no_overflow_lsl n k] returns [true] if the computation of
+           [n lsl k] does not overflow. *)
 
 val chop_extension_if_any: string -> string
         (* Like Filename.chop_extension but returns the initial file