Fix PR#7113: -safe-string can break GADT compatibility check

Changes

@@ -458,6 +458,7 @@ Bug fixes:
 - PR#7108: ocamldoc, have -html preserve custom/extended html generators
   (Armaël Guéneau)
 - PR#7096: ocamldoc uses an incorrect subscript/superscript style
+- PR#7113: -safe-string can break GADT compatibility check
 - PR#7115: shadowing in a branch of a GADT match breaks unused variable
   warning (Alain Frisch, report by Valentin Gatien-Baron)
 - PR#7133: Jump labels in assembly end up as symbols in the executable on OS X

testsuite/tests/typing-safe-linking/Makefile

@@ -0,0 +1,16 @@
+# Check safety of linking
+
+SOURCES = a.ml b_bad.ml
+OBJECTS = $(SOURCES:%.ml=%.cmo)
+
+all: a.cmo
+	@printf " ... testing 'b_bad.ml'"
+	@$(OCAMLC) -c -safe-string -warn-error +8 b_bad.ml 2> /dev/null \
+	 && echo " => failed" || echo " => passed"
+
+clean:
+	@rm -f *.cmo *.cmi
+
+BASEDIR=../..
+include $(BASEDIR)/makefiles/Makefile.common
+

testsuite/tests/typing-safe-linking/a.ml

@@ -0,0 +1,5 @@
+ type _ t =
+     X of string
+   | Y : bytes t 
+
+let y : string t = Y

testsuite/tests/typing-safe-linking/b_bad.ml

@@ -0,0 +1,4 @@
+let f : string A.t -> unit = function
+    A.X s -> print_endline s
+
+let () = f A.y

testsuite/typing

@@ -30,6 +30,7 @@ tests/typing-private-bugs
 tests/typing-recmod
 tests/typing-recordarg
 tests/typing-rectypes-bugs
+tests/typing-safe-linking
 tests/typing-short-paths
 tests/typing-signatures
 tests/typing-sigsubst

typing/ctype.ml

@@ -1933,6 +1933,13 @@ let non_aliasable p decl =
   (* in_pervasives p ||  (subsumed by in_current_module) *)
   in_current_module p && decl.type_newtype_level = None
 
+(* PR#7113: -safe-string should be a global property *)
+let compatible_paths p1 p2 =
+  let open Predef in
+  Path.same p1 p2 ||
+  Path.same p1 path_bytes && Path.same p2 path_string ||
+  Path.same p1 path_string && Path.same p2 path_bytes
+
 (* Check for datatypes carefully; see PR#6348 *)
 let rec expands_to_datatype env ty =
   let ty = repr ty in
@@ -2071,7 +2078,7 @@ and mcomp_type_decl type_pairs env p1 p2 tl1 tl2 =
   try
     let decl = Env.find_type p1 env in
     let decl' = Env.find_type p2 env in
-    if Path.same p1 p2 then begin
+    if compatible_paths p1 p2 then begin
       let inj =
         try List.map Variance.(mem Inj) (Env.find_type p1 env).type_variance
         with Not_found -> List.map (fun _ -> false) tl1