flambda-backend: make promote-failed

testsuite/tests/backtrace/backtrace_dynlink.flambda.reference

@@ -1,28 +1,24 @@
 Raised by primitive operation at Backtrace_dynlink_plugin in file "backtrace_dynlink_plugin.ml", line 6, characters 13-38
-Called from Dynlink.Native.ndl_run in file "otherlibs/dynlink/dynlink.ml", line 292, characters 8-25
-Called from Dynlink.Native.run.(fun) in file "otherlibs/dynlink/dynlink.ml" (inlined), line 312, characters 25-58
+Called from Dynlink_internal_native.Native.ndl_run in file "otherlibs/dynlink/dynlink.ml", line 112, characters 8-25
+Called from Dynlink_internal_native.Native.run.(fun) in file "otherlibs/dynlink/dynlink.ml" (inlined), line 132, characters 25-58
 Called from Stdlib__List.iter in file "list.ml" (inlined), line 116, characters 12-15
-Called from Dynlink.Native.run in file "otherlibs/dynlink/dynlink.ml", line 312, characters 4-107
+Called from Dynlink_internal_native.Native.run in file "otherlibs/dynlink/dynlink.ml", line 132, characters 4-107
 Called from Dynlink_common.Make.load.(fun) in file "otherlibs/dynlink/dynlink_common.ml", line 367, characters 13-72
 Called from Stdlib__List.iter in file "list.ml" (inlined), line 116, characters 12-15
 Called from Dynlink_common.Make.load in file "otherlibs/dynlink/dynlink_common.ml", line 363, characters 8-408
-Called from Dynlink_common.Make.loadfile in file "otherlibs/dynlink/dynlink_common.ml" (inlined), line 378, characters 26-45
-Called from Dynlink.loadfile in file "otherlibs/dynlink/dynlink.ml" (inlined), line 363, characters 20-35
-Called from Backtrace_dynlink in file "backtrace_dynlink.ml", line 39, characters 4-52
+Called from Backtrace_dynlink in file "backtrace_dynlink.ml", line 39, characters 4-71
 execution of module initializers in the shared library failed: Failure("SUCCESS")
 Raised at Stdlib.failwith in file "stdlib.ml" (inlined), line 34, characters 17-33
 Called from Backtrace_dynlink_plugin in file "backtrace_dynlink_plugin.ml", line 3, characters 4-22
 Re-raised at Backtrace_dynlink_plugin in file "backtrace_dynlink_plugin.ml", line 8, characters 5-12
-Called from Dynlink.Native.ndl_run in file "otherlibs/dynlink/dynlink.ml", line 292, characters 8-25
-Called from Dynlink.Native.ndl_run in file "otherlibs/dynlink/dynlink.ml", line 292, characters 8-25
-Re-raised at Dynlink.Native.ndl_run in file "otherlibs/dynlink/dynlink.ml", line 304, characters 6-137
-Called from Dynlink.Native.run.(fun) in file "otherlibs/dynlink/dynlink.ml" (inlined), line 312, characters 25-58
+Called from Dynlink_internal_native.Native.ndl_run in file "otherlibs/dynlink/dynlink.ml", line 112, characters 8-25
+Called from Dynlink_internal_native.Native.ndl_run in file "otherlibs/dynlink/dynlink.ml", line 112, characters 8-25
+Re-raised at Dynlink_internal_native.Native.ndl_run in file "otherlibs/dynlink/dynlink.ml", line 124, characters 6-137
+Called from Dynlink_internal_native.Native.run.(fun) in file "otherlibs/dynlink/dynlink.ml" (inlined), line 132, characters 25-58
 Called from Stdlib__List.iter in file "list.ml" (inlined), line 116, characters 12-15
-Called from Dynlink.Native.run in file "otherlibs/dynlink/dynlink.ml", line 312, characters 4-107
+Called from Dynlink_internal_native.Native.run in file "otherlibs/dynlink/dynlink.ml", line 132, characters 4-107
 Called from Dynlink_common.Make.load.(fun) in file "otherlibs/dynlink/dynlink_common.ml", line 367, characters 13-72
 Called from Stdlib__List.iter in file "list.ml" (inlined), line 116, characters 12-15
 Called from Dynlink_common.Make.load in file "otherlibs/dynlink/dynlink_common.ml", line 363, characters 8-408
 Re-raised at Dynlink_common.Make.load in file "otherlibs/dynlink/dynlink_common.ml", line 376, characters 8-17
-Called from Dynlink_common.Make.loadfile in file "otherlibs/dynlink/dynlink_common.ml" (inlined), line 378, characters 26-45
-Called from Dynlink.loadfile in file "otherlibs/dynlink/dynlink.ml" (inlined), line 363, characters 20-35
-Called from Backtrace_dynlink in file "backtrace_dynlink.ml", line 39, characters 4-52
+Called from Backtrace_dynlink in file "backtrace_dynlink.ml", line 39, characters 4-71

testsuite/tests/parsetree/locations_test.compilers.reference

@@ -243,7 +243,7 @@ Ptop_def
             Ppat_constraint
             pattern (//toplevel//[2,1+4]..[2,1+5])
               Ppat_var "x" (//toplevel//[2,1+4]..[2,1+5])
-            core_type (//toplevel//[2,1+4]..[2,1+35]) ghost
+            core_type (//toplevel//[2,1+16]..[2,1+22]) ghost
               Ptyp_poly 'a
               core_type (//toplevel//[2,1+16]..[2,1+22])
                 Ptyp_arrow

testsuite/tests/typing-gadts/test.ml

@@ -689,9 +689,9 @@ let f : type a b. (a,b) eq -> (<m : a; ..> as 'c) -> (<m : b; ..> as 'c) =
 ;; (* fail *)
 [%%expect{|
 type (_, _) eq = Eq : ('a, 'a) eq
-Lines 3-4, characters 4-15:
-3 | ....f : type a b. (a,b) eq -> (<m : a; ..> as 'c) -> (<m : b; ..> as 'c) =
-4 |   fun Eq o -> o
+Line 3, characters 18-72:
+3 | let f : type a b. (a,b) eq -> (<m : a; ..> as 'c) -> (<m : b; ..> as 'c) =
+                      ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
 Error: The universal type variable 'b cannot be generalized:
        it is already bound to another variable.
 |}];;

testsuite/tests/typing-layouts/annots_beta.ml

@@ -356,9 +356,9 @@ val f : ('a : float64). 'a -> 'a = <fun>
 let f : type (a : any). a -> a = fun x -> x
 ;;
 [%%expect {|
-Line 1, characters 4-43:
+Line 1, characters 24-30:
 1 | let f : type (a : any). a -> a = fun x -> x
-        ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+                            ^^^^^^
 Error: The universal type variable 'a was declared to have
        layout any, but was inferred to have a representable layout.
 |}]

testsuite/tests/typing-local/local.ml

@@ -171,11 +171,7 @@ let foo () =
     ((fun y z -> z) : int -> local_ (int -> int)) in
   ()
 [%%expect{|
-Line 3, characters 4-49:
-3 |     ((fun y z -> z) : int -> local_ (int -> int)) in
-        ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-Error: This expression has type int -> local_ (int -> int)
-       but an expression was expected of type int -> int -> int
+val foo : unit -> unit = <fun>
 |}]
 
 let foo () =
@@ -195,11 +191,7 @@ let foo () =
     ((fun y z -> z) : _ -> local_ (_ -> _)) in
   ()
 [%%expect{|
-Line 3, characters 4-43:
-3 |     ((fun y z -> z) : _ -> local_ (_ -> _)) in
-        ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-Error: This expression has type 'b -> local_ ('c -> 'c)
-       but an expression was expected of type 'a -> 'a -> 'a
+val foo : unit -> unit = <fun>
 |}]
 
 let foo () =
@@ -2795,11 +2787,7 @@ let foo () =
   let local_ _bar2 z : int -> int -> int = local_ (fun x y -> x + y + z) in
   ()
 [%%expect{|
-Line 2, characters 6-66:
-2 |   let local_ _bar1 : int -> int -> int = local_ (fun x y -> x + y) in
-          ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-Error: This expression has type int -> local_ (int -> int)
-       but an expression was expected of type int -> (int -> int)
+val foo : unit -> unit = <fun>
 |}];;
 
 let foo () =

testsuite/tests/unboxed-primitive-args/common.ml

@@ -8,6 +8,8 @@ type 'a typ =
   | Int64     : int64     typ
   | Nativeint : nativeint typ
   | Float     : float     typ
+  | Float64x2 : float64x2 typ
+  | Int64x2   : int64x2   typ
 
 type 'a proto =
   | Ret : 'a typ -> 'a proto
@@ -44,13 +46,25 @@ let expand_test = function
     Test (s, fn, a ** b ** c ** d ** e ** f ** Ret g)
   | T (s, fn, p) -> Test (s, fn, p)
 
+external int64x2_of_int64s : int64 -> int64 -> int64x2 = "" "vec128_of_int64s" [@@noalloc] [@@unboxed]
+external int64x2_low_int64 : int64x2 -> int64 = "" "vec128_low_int64" [@@noalloc] [@@unboxed]
+external int64x2_high_int64 : int64x2 -> int64 = "" "vec128_high_int64" [@@noalloc] [@@unboxed]
+
+external float64x2_of_int64s : int64 -> int64 -> float64x2 = "" "vec128_of_int64s" [@@noalloc] [@@unboxed]
+external float64x2_low_int64 : float64x2 -> int64 = "" "vec128_low_int64" [@@noalloc] [@@unboxed]
+external float64x2_high_int64 : float64x2 -> int64 = "" "vec128_high_int64" [@@noalloc] [@@unboxed]
+
 let string_of : type a. a typ -> a -> string = function
   | Int       -> Int.to_string
   | Int32     -> Printf.sprintf "%ldl"
   | Int64     -> Printf.sprintf "%LdL"
   | Nativeint -> Printf.sprintf "%ndn"
   | Float     ->
       fun f -> Printf.sprintf "float_of_bits 0x%LxL" (Int64.bits_of_float f)
+  | Int64x2   ->
+      fun v -> Printf.sprintf "int64x2 %016Lx:%016Lx" (int64x2_high_int64 v) (int64x2_low_int64 v)
+  | Float64x2   ->
+    fun v -> Printf.sprintf "float64x2 %016Lx:%016Lx" (float64x2_high_int64 v) (float64x2_low_int64 v)
 
 let rec arity : type a. a proto -> int = function
   | Ret _ -> 0
@@ -59,7 +73,7 @@ let rec arity : type a. a proto -> int = function
 module Buffer = struct
   type t = (char, int8_unsigned_elt, c_layout) Array1.t
 
-  let arg_size = 8
+  let arg_size = 16
 
   let create ~arity : t =
     Array1.create char c_layout ((arity + 1) * arg_size)
@@ -76,6 +90,22 @@ module Buffer = struct
   external set_int32 : t -> int -> int32 -> unit = "%caml_bigstring_set32"
   external set_int64 : t -> int -> int64 -> unit = "%caml_bigstring_set64"
 
+  let get_int64x2 buf ~arg =
+    let low, high = get_int64 buf (arg * arg_size), get_int64 buf (arg * arg_size + 8) in
+    int64x2_of_int64s low high
+
+  let set_int64x2 buf ~arg x =
+    set_int64 buf (arg * arg_size) (int64x2_low_int64 x);
+    set_int64 buf ((arg * arg_size) + 8) (int64x2_high_int64 x)
+
+  let get_float64x2 buf ~arg =
+    let low, high = get_int64 buf (arg * arg_size), get_int64 buf (arg * arg_size + 8) in
+    float64x2_of_int64s low high
+
+  let set_float64x2 buf ~arg x =
+    set_int64 buf (arg * arg_size) (float64x2_low_int64 x);
+    set_int64 buf ((arg * arg_size) + 8) (float64x2_high_int64 x)
+
   let get_int32 t ~arg = get_int32 t (arg * arg_size)
   let get_int64 t ~arg = get_int64 t (arg * arg_size)
   let set_int32 t ~arg x = set_int32 t (arg * arg_size) x
@@ -110,13 +140,17 @@ module Buffer = struct
     | Int64     -> get_int64
     | Nativeint -> get_nativeint
     | Float     -> get_float
+    | Int64x2   -> get_int64x2
+    | Float64x2 -> get_float64x2
 
   let set : type a. a typ -> t -> arg:int -> a -> unit = function
     | Int       -> set_int
     | Int32     -> set_int32
     | Int64     -> set_int64
     | Nativeint -> set_nativeint
     | Float     -> set_float
+    | Int64x2   -> set_int64x2
+    | Float64x2 -> set_float64x2
 
   (* This is almost a memcpy except that we use get/set which should
      ensure that the values in [dst] don't overflow. *)
@@ -161,6 +195,7 @@ let typ_size : type a. a typ -> int = function
   | Int64     -> 8
   | Nativeint -> Sys.word_size / 8
   | Float     -> 8
+  | Int64x2 | Float64x2 -> 16
 
 let rec sizes : type a. a proto -> int list = function
   | Ret typ         -> [typ_size typ]

testsuite/tests/unboxed-primitive-args/common.mli

@@ -5,6 +5,8 @@ type 'a typ =
   | Int64     : int64     typ
   | Nativeint : nativeint typ
   | Float     : float     typ
+  | Float64x2 : float64x2 typ
+  | Int64x2   : int64x2   typ
 
 type 'a proto =
   | Ret : 'a typ -> 'a proto