flambda-backend: Fix incorrect sort assumption in lambda for `bop_exp…

…`s in letops (#1793)

asmcomp/cmm_helpers.ml

@@ -2254,7 +2254,13 @@ let tuplify_function arity return =
     else get_field_gen Asttypes.Mutable (Cvar arg) i (dbg ())
          :: access_components(i+1)
   in
-  let fun_name = "caml_tuplify" ^ Int.to_string arity in
+  let fun_name =
+    "caml_tuplify" ^ Int.to_string arity
+    ^
+    match return with
+    | [| Val |] -> ""
+    | _ -> "_R" ^ machtype_identifier return
+  in
   let fun_dbg = placeholder_fun_dbg ~human_name:fun_name in
   Cfunction
    {fun_name;

lambda/translcore.ml

@@ -1696,8 +1696,8 @@ and transl_letop ~scopes loc env let_ ands param param_sort case case_sort
           transl_ident (of_location ~scopes and_.bop_op_name.loc) env
             and_.bop_op_type and_.bop_op_path and_.bop_op_val Id_value
         in
-        let exp = transl_exp ~scopes Sort.for_bop_exp and_.bop_exp in
-        let right_layout = layout_exp Sort.for_bop_exp and_.bop_exp in
+        let exp = transl_exp ~scopes and_.bop_exp_sort and_.bop_exp in
+        let right_layout = layout_exp and_.bop_exp_sort and_.bop_exp in
         let result_layout =
           function2_return_layout env and_.bop_loc and_.bop_op_return_sort
             and_.bop_op_type
@@ -1724,8 +1724,8 @@ and transl_letop ~scopes loc env let_ ands param param_sort case case_sort
       let_.bop_op_type let_.bop_op_path let_.bop_op_val Id_value
   in
   let exp =
-    loop (layout_exp Sort.for_bop_exp let_.bop_exp)
-      (transl_exp ~scopes Sort.for_bop_exp let_.bop_exp) ands
+    loop (layout_exp let_.bop_exp_sort let_.bop_exp)
+      (transl_exp ~scopes let_.bop_exp_sort let_.bop_exp) ands
   in
   let func =
     let arg_layout =

testsuite/tests/typing-layouts-float64/unboxed_floats_alpha.ml

@@ -289,3 +289,24 @@ let test6 () =
   print_floatu "Test 6, -46.88" result
 
 let _ = test6 ()
+
+(*****************************)
+(* Test 7: letop with floats *)
+
+let ( let* ) x f = f Float_u.(x + (of_float 1.5))
+
+let _ =
+  let* x = Float_u.of_float 42.0 in
+  print_floatu "Test 7, 36.50" Float_u.(x - of_float 7.0)
+
+let ( let* ) x (f : _ -> float#) = f x
+let ( and* ) x y = Float_u.(x, to_float (y - (of_float 1.2)))
+let _ =
+  let result =
+    let* x = 42.0
+    and* y = Float_u.of_float 3.3
+    and* z = Float_u.of_float (-10.7) in
+    Float_u.of_float (x +. y +. z)
+  in
+  print_floatu "Test 7, 32.20" result
+

testsuite/tests/typing-layouts-float64/unboxed_floats_alpha.reference

@@ -86,3 +86,5 @@ Test 5, pi+e+1: 6.86
 Test 6, 0.17: 0.17
 Test 6, 34.00: 34.00
 Test 6, -46.88: -46.88
+Test 7, 36.50: 36.50
+Test 7, 32.20: 32.20

testsuite/tests/typing-layouts/basics_alpha.ml

@@ -7,6 +7,7 @@ type t_any   : any
 type t_value : value
 type t_imm   : immediate
 type t_imm64 : immediate64
+type t_float64 : float64
 type t_void  : void
 
 type void_variant = VV of t_void
@@ -18,6 +19,7 @@ type t_any : any
 type t_value : value
 type t_imm : immediate
 type t_imm64 : immediate64
+type t_float64 : float64
 type t_void : void
 type void_variant = VV of t_void
 type void_record = { vr_void : t_void; vr_int : int; }
@@ -1256,11 +1258,11 @@ Error: Non-value layout void detected in [Typeopt.layout] as sort for type
 (**********************************************)
 (* Test 28: Exotic layouts in letop and andop *)
 
-(* CR layouts: this must be [let rec] and [and] so that we can test the
-   type-checker, as opposed to the value-kind check. After we have proper
-   support for a non-value argument type, remove the [rec], throughout
-   this test.
-*)
+(* CR layouts v5: the void parts of this test use [let rec] and [and] so that we
+   can test the type-checker as opposed to the value-kind check.  Once void is
+   properly supported, they don't need to be recursive anymore. *)
+
+(* 28.1: non-value letop arg *)
 let rec ( let* ) (x : t_void) f = ()
 
 and q () =
@@ -1275,6 +1277,18 @@ Error: Non-value layout void detected in [Typeopt.layout] as sort for type
        t_void. Please report this error to the Jane Street compilers team.
 |}]
 
+let ( let* ) (x : t_float64) f = ()
+
+let q () =
+  let* x = assert false in
+  ()
+
+[%%expect{|
+val ( let* ) : t_float64 -> 'a -> unit = <fun>
+val q : unit -> unit = <fun>
+|}]
+
+(* 28.2: non-value letop binder arg without and *)
 let rec ( let* ) x (f : t_void -> _) = ()
 
 and q () =
@@ -1289,6 +1303,18 @@ Error: Non-value layout void detected in [Typeopt.layout] as sort for type
        t_void. Please report this error to the Jane Street compilers team.
 |}]
 
+let ( let* ) x (f : t_float64 -> _) = ()
+
+let q () =
+  let* x = assert false in
+  ()
+
+[%%expect{|
+val ( let* ) : 'a -> (t_float64 -> 'b) -> unit = <fun>
+val q : unit -> unit = <fun>
+|}]
+
+(* 28.3: non-value letop binder result *)
 let rec ( let* ) x (f : _ -> t_void) = ()
 
 and q () =
@@ -1303,6 +1329,18 @@ Error: Non-value layout void detected in [Typeopt.layout] as sort for type
        t_void. Please report this error to the Jane Street compilers team.
 |}]
 
+let ( let* ) x (f : _ -> t_float64) = ()
+
+let q () =
+  let* x = assert false in
+  assert false
+
+[%%expect{|
+val ( let* ) : 'a -> ('b -> t_float64) -> unit = <fun>
+val q : unit -> unit = <fun>
+|}]
+
+(* 28.4: non-value letop result *)
 let rec ( let* ) x f : t_void = assert false
 
 and q () =
@@ -1317,6 +1355,18 @@ Error: Non-value layout void detected in [Typeopt.layout] as sort for type
        t_void. Please report this error to the Jane Street compilers team.
 |}]
 
+let ( let* ) x f : t_float64 = assert false
+
+let q () =
+  let* x = 5 in
+  ()
+
+[%%expect{|
+val ( let* ) : 'a -> 'b -> t_float64 = <fun>
+val q : unit -> t_float64 = <fun>
+|}]
+
+(* 28.5: non-value andop second arg *)
 let rec ( let* ) x f = ()
 and ( and* ) x1 (x2 : t_void) = ()
 and q () =
@@ -1333,6 +1383,21 @@ Error: Non-value layout void detected in [Typeopt.layout] as sort for type
        t_void. Please report this error to the Jane Street compilers team.
 |}]
 
+let ( let* ) x f = ()
+let ( and* ) x1 (x2 : t_float64) = ()
+let q () =
+    let* x = 5
+    and* y = assert false
+    in
+    ()
+
+[%%expect{|
+val ( let* ) : 'a -> 'b -> unit = <fun>
+val ( and* ) : 'a -> t_float64 -> unit = <fun>
+val q : unit -> unit = <fun>
+|}]
+
+(* 28.5: non-value andop first arg *)
 let rec ( let* ) x f = ()
 and ( and* ) (x1 : t_void) x2 = ()
 and q () =
@@ -1349,6 +1414,21 @@ Error: Non-value layout void detected in [Typeopt.layout] as sort for type
        t_void. Please report this error to the Jane Street compilers team.
 |}]
 
+let ( let* ) x f = ()
+let ( and* ) (x1 : t_float64) x2 = ()
+let q () =
+    let* x = assert false
+    and* y = 5
+    in
+    ()
+
+[%%expect{|
+val ( let* ) : 'a -> 'b -> unit = <fun>
+val ( and* ) : t_float64 -> 'a -> unit = <fun>
+val q : unit -> unit = <fun>
+|}]
+
+(* 28.6: non-value andop result *)
 let rec ( let* ) x f = ()
 and ( and* ) x1 x2 : t_void = assert false
 and q () =
@@ -1365,6 +1445,21 @@ Error: Non-value layout void detected in [Typeopt.layout] as sort for type
        t_void. Please report this error to the Jane Street compilers team.
 |}]
 
+let ( let* ) (x : (_ : float64))  f = ()
+let ( and* ) x1 x2 : t_float64 = assert false
+let q () =
+    let* x = 5
+    and* y = 5
+    in
+    ()
+
+[%%expect{|
+val ( let* ) : 'b ('a : float64). 'a -> 'b -> unit = <fun>
+val ( and* ) : 'a -> 'b -> t_float64 = <fun>
+val q : unit -> unit = <fun>
+|}]
+
+(* 28.7: non-value letop binder arg with and *)
 (* CR layouts v5: when we allow non-values in tuples, this next one should
    type-check *)
 let rec ( let* ) x f = ()
@@ -1384,6 +1479,26 @@ Error: This pattern matches values of type t_void
        t_void has layout void, which is not a sublayout of value.
 |}]
 
+let ( let* ) x f = ()
+let ( and* ) x1 x2 = assert false
+let q () =
+    let* x : t_float64 = assert false
+    and* y = 5
+    in
+    ()
+
+[%%expect{|
+val ( let* ) : 'a -> 'b -> unit = <fun>
+val ( and* ) : 'a -> 'b -> 'c = <fun>
+Line 4, characters 9-22:
+4 |     let* x : t_float64 = assert false
+             ^^^^^^^^^^^^^
+Error: This pattern matches values of type t_float64
+       but a pattern was expected which matches values of type ('a : value)
+       t_float64 has layout float64, which is not a sublayout of value.
+|}]
+
+
 (*******************************************)
 (* Test 29: [external]s default to [value] *)
 

typing/layouts.ml

@@ -219,7 +219,6 @@ module Sort = struct
   let for_lazy_body = value
   let for_tuple_element = value
   let for_instance_var = value
-  let for_bop_exp = value
   let for_class_arg = value
   let for_method = value
   let for_initializer = value

typing/layouts.mli

@@ -82,7 +82,6 @@ module Sort : sig
      sorts in the code. *)
   val for_class_arg : t
   val for_instance_var : t
-  val for_bop_exp : t
   val for_lazy_body : t
   val for_tuple_element : t
   val for_record : t

typing/typecore.ml

@@ -5879,7 +5879,10 @@ and type_expect_
       let ty_result =
         newvar (Layout.of_sort ~why:Function_result op_result_sort)
       in
-      let ty_andops = newvar (Layout.of_new_sort_var ~why:Function_argument) in
+      let sort_andops = Sort.new_var () in
+      let ty_andops =
+        newvar (Layout.of_sort ~why:Function_argument sort_andops)
+      in
       let ty_op =
         newty (Tarrow(arrow_desc, newmono ty_andops,
           newty (Tarrow(arrow_desc, newmono ty_func,
@@ -5897,8 +5900,8 @@ and type_expect_
         generalize_structure ty_func_result;
         generalize_structure ty_result
       end;
-      let exp, ands =
-        type_andops env slet.pbop_exp sands ty_andops
+      let exp, exp_sort, ands =
+        type_andops env slet.pbop_exp sands sort_andops ty_andops
       in
       let body_env = Env.add_escape_lock Letop env in
       let body_env = Env.add_share_lock Letop body_env in
@@ -5922,6 +5925,7 @@ and type_expect_
           bop_op_type = op_type;
           bop_op_return_sort = op_result_sort;
           bop_exp = exp;
+          bop_exp_sort = exp_sort;
           bop_loc = slet.pbop_loc; }
       in
       let warnings = Warnings.backup () in
@@ -7685,19 +7689,24 @@ and type_let
   let new_env = add_module_variables new_env mvs in
   (l, new_env)
 
-and type_andops env sarg sands expected_ty =
-  let rec loop env let_sarg rev_sands expected_ty =
+and type_andops env sarg sands expected_sort expected_ty =
+  (* Pass arguments to [loop] to avoid allocating closure; [env] and [let_sarg]
+     get passed down unchanged. *)
+  let rec loop env let_sarg rev_sands expected_sort expected_ty =
     match rev_sands with
     | [] ->
         type_expect env mode_legacy let_sarg
           (mk_expected expected_ty),
+        expected_sort,
         []
     | { pbop_op = sop; pbop_exp = sexp; pbop_loc = loc; _ } :: rest ->
         if !Clflags.principal then begin_def ();
         let op_path, op_desc = type_binding_op_ident env sop in
         let op_type = op_desc.val_type in
-        let ty_arg = newvar (Layout.of_new_sort_var ~why:Function_argument) in
-        let ty_rest = newvar (Layout.of_new_sort_var ~why:Function_argument) in
+        let sort_arg = Sort.new_var () in
+        let ty_arg = newvar (Layout.of_sort ~why:Function_argument sort_arg) in
+        let sort_rest = Sort.new_var () in
+        let ty_rest = newvar (Layout.of_sort ~why:Function_argument sort_rest) in
         let op_result_sort = Sort.new_var () in
         let ty_result =
           newvar (Layout.of_sort ~why:Function_result op_result_sort)
@@ -7720,7 +7729,9 @@ and type_andops env sarg sands expected_ty =
           generalize_structure ty_arg;
           generalize_structure ty_result
         end;
-        let let_arg, rest = loop env let_sarg rest ty_rest in
+        let let_arg, sort_let_arg, rest =
+          loop env let_sarg rest sort_rest ty_rest
+        in
         let exp =
           type_expect env mode_legacy sexp (mk_expected ty_arg)
         in
@@ -7736,12 +7747,15 @@ and type_andops env sarg sands expected_ty =
             bop_op_type = op_type;
             bop_op_return_sort = op_result_sort;
             bop_exp = exp;
+            bop_exp_sort = sort_arg;
             bop_loc = loc }
         in
-        let_arg, andop :: rest
+        let_arg, sort_let_arg, andop :: rest
+  in
+  let let_arg, sort_let_arg, rev_ands =
+    loop env sarg (List.rev sands) expected_sort expected_ty
   in
-  let let_arg, rev_ands = loop env sarg (List.rev sands) expected_ty in
-  let_arg, List.rev rev_ands
+  let_arg, sort_let_arg, List.rev rev_ands
 
 (* Can be re-inlined when we upstream immutable arrays *)
 and type_generic_array

typing/typedtree.ml

@@ -245,6 +245,7 @@ and binding_op =
     bop_op_type : Types.type_expr;
     bop_op_return_sort : sort;
     bop_exp : expression;
+    bop_exp_sort : sort;
     bop_loc : Location.t;
   }
 

typing/typedtree.mli

@@ -431,6 +431,7 @@ and binding_op =
        It is always an instance of [bop_op_val.val_type] *)
     bop_op_return_sort : Layouts.sort;
     bop_exp : expression;
+    bop_exp_sort : Layouts.sort;
     bop_loc : Location.t;
   }