PR#6501: harden the native-code generator against certain uses of "%identity".

Technically: when a C-- let-bound variable is assigned to, update its type
so that it is the lub of the types of the initial value and all values
assigned to it, with the type ordering Int <: Addr.


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

5 files changed, 28 insertions, 3 deletions

diff --git a/Changes b/Changes
index 09dcb99dca..98b4f3eb62 100644
--- a/Changes
+++ b/Changes
@@ -1,6 +1,11 @@
 Next version:
 -------------
 
+Compilers:
+- PR#6501: harden the native-code generator against certain uses of "%identity"
+  (Xavier Leroy, report by Antoine Miné).
+
+
 Ocaml 4.02.0:
 -------------
 
diff --git a/asmcomp/reg.ml b/asmcomp/reg.ml
index ef6db5cb6e..c699c424da 100644
--- a/asmcomp/reg.ml
+++ b/asmcomp/reg.ml
@@ -32,7 +32,7 @@ end
 type t =
   { mutable raw_name: Raw_name.t;
     stamp: int;
-    typ: Cmm.machtype_component;
+    mutable typ: Cmm.machtype_component;
     mutable loc: location;
     mutable spill: bool;
     mutable part: int option;
diff --git a/asmcomp/reg.mli b/asmcomp/reg.mli
index e3cb2d9520..f705c209ee 100644
--- a/asmcomp/reg.mli
+++ b/asmcomp/reg.mli
@@ -20,7 +20,7 @@ end
 type t =
   { mutable raw_name: Raw_name.t;       (* Name *)
     stamp: int;                         (* Unique stamp *)
-    typ: Cmm.machtype_component;        (* Type of contents *)
+    mutable typ: Cmm.machtype_component;(* Type of contents *)
     mutable loc: location;              (* Actual location *)
     mutable spill: bool;                (* "true" to force stack allocation  *)
     mutable part: int option;           (* Zero-based index of part of value *)
diff --git a/asmcomp/selectgen.ml b/asmcomp/selectgen.ml
index 50a38a244e..a57f5b1913 100644
--- a/asmcomp/selectgen.ml
+++ b/asmcomp/selectgen.ml
@@ -393,6 +393,24 @@ method insert_moves src dst =
     self#insert_move src.(i) dst.(i)
   done
 
+(* Adjust the types of destination pseudoregs for a [Cassign] assignment.
+   The type inferred at [let] binding might be [Int] while we assign
+   something of type [Addr] (PR#6501). *)
+
+method adjust_type src dst =
+  let ts = src.typ and td = dst.typ in
+  if ts <> td then
+    match ts, td with
+    | Addr, Int -> dst.typ <- Addr
+    | Int, Addr -> ()
+    | _, _ -> fatal_error("Selection.adjust_type: bad assignment to "
+                                                           ^ Reg.name dst)
+
+method adjust_types src dst =
+  for i = 0 to min (Array.length src) (Array.length dst) - 1 do
+    self#adjust_type src.(i) dst.(i)
+  done
+
 (* Insert moves and stack offsets for function arguments and results *)
 
 method insert_move_args arg loc stacksize =
@@ -459,7 +477,7 @@ method emit_expr env exp =
           fatal_error ("Selection.emit_expr: unbound var " ^ Ident.name v) in
       begin match self#emit_expr env e1 with
         None -> None
-      | Some r1 -> self#insert_moves r1 rv; Some [||]
+      | Some r1 -> self#adjust_types r1 rv; self#insert_moves r1 rv; Some [||]
       end
   | Ctuple [] ->
       Some [||]
diff --git a/asmcomp/selectgen.mli b/asmcomp/selectgen.mli
index 0de9038215..499b9ea0fe 100644
--- a/asmcomp/selectgen.mli
+++ b/asmcomp/selectgen.mli
@@ -97,6 +97,8 @@ class virtual selector_generic : object
   method insert_move_args : Reg.t array -> Reg.t array -> int -> unit
   method insert_move_results : Reg.t array -> Reg.t array -> int -> unit
   method insert_moves : Reg.t array -> Reg.t array -> unit
+  method adjust_type : Reg.t -> Reg.t -> unit
+  method adjust_types : Reg.t array -> Reg.t array -> unit
   method emit_expr :
     (Ident.t, Reg.t array) Tbl.t -> Cmm.expression -> Reg.t array option
   method emit_tail : (Ident.t, Reg.t array) Tbl.t -> Cmm.expression -> unit