flambda-backend: Add a float64 layout and float# type. (#1528)

Author: ccasin

asmcomp/cmm_helpers.ml

@@ -2210,7 +2210,7 @@ let send_function (arity, result, mode) =
   let fun_name = send_function_name arity result mode in
   let fun_args =
     [obj, typ_val; tag, typ_int; cache, typ_addr]
-    @ List.map (fun id -> (id, typ_val)) (List.tl args) in
+    @ List.combine (List.tl args) arity in
   let fun_dbg = placeholder_fun_dbg ~human_name:fun_name in
   Cfunction
    {fun_name;

asmcomp/cmmgen.ml

@@ -334,6 +334,21 @@ let join_unboxed_number_kind ~strict k1 k2 =
       k
   | _, _ -> No_unboxing
 
+(* [exttype_of_sort] and [machtype_of_sort] should be kept in sync with
+   [Typeopt.layout_of_const_sort]. *)
+(* CR layouts v5: Void case should probably be typ_void *)
+let exttype_of_sort (s : Layouts.Sort.const) =
+  match s with
+  | Value -> XInt
+  | Float64 -> XFloat
+  | Void -> Misc.fatal_error "Cmmgen.exttype_of_sort: void encountered"
+
+let machtype_of_sort (s : Layouts.Sort.const) =
+  match s with
+  | Value -> typ_val
+  | Float64 -> typ_float
+  | Void -> Misc.fatal_error "Cmmgen.machtype_of_sort: void encountered"
+
 let is_unboxed_number_cmm ~strict cmm =
   let r = ref No_result in
   let notify k =
@@ -828,13 +843,8 @@ and transl_make_array dbg env kind mode args =
 
 and transl_ccall env prim args dbg =
   let transl_arg native_repr arg =
-    (* CR layouts v2: This match to be extended with
-         | Same_as_ocaml_repr Float64 -> (XFloat, transl env arg)
-       in the PR that adds Float64 *)
     match native_repr with
-    | Same_as_ocaml_repr Value ->
-        (XInt, transl env arg)
-    | Same_as_ocaml_repr Void -> assert false
+    | Same_as_ocaml_repr sort -> (exttype_of_sort sort, transl env arg)
     | Unboxed_float ->
         (XFloat, transl_unbox_float dbg env arg)
     | Unboxed_integer bi ->
@@ -864,11 +874,7 @@ and transl_ccall env prim args dbg =
   in
   let typ_res, wrap_result =
     match prim.prim_native_repr_res with
-    (* CR layouts v2: This match to be extended with
-         | Same_as_ocaml_repr Float64 -> (typ_float, fun x -> x)
-       in the PR that adds Float64 *)
-    | _, Same_as_ocaml_repr Value -> (typ_val, fun x -> x)
-    | _, Same_as_ocaml_repr Void -> assert false
+    | _, Same_as_ocaml_repr sort -> (machtype_of_sort sort, fun x -> x)
     (* TODO: Allow Alloc_local on suitably typed C stubs *)
     | _, Unboxed_float -> (typ_float, box_float dbg alloc_heap)
     | _, Unboxed_integer Pint64 when size_int = 4 ->

boot/menhir/parser.ml

@@ -980,15 +980,15 @@ let mk_directive ~loc name arg =
 let check_layout loc id =
   begin
     match id with
-    | ("any" | "value" | "void" | "immediate64" | "immediate") -> ()
+    | ("any" | "value" | "void" | "immediate64" | "immediate" | "float64") -> ()
     | _ -> expecting loc "layout"
   end;
   let loc = make_loc loc in
   Attr.mk ~loc (mkloc id loc) (PStr [])
 
 (* Unboxed literals *)
 
-(* CR layouts v2: The [unboxed_*] functions will both be improved and lose
+(* CR layouts v2.5: The [unboxed_*] functions will both be improved and lose
    their explicit assert once we have real unboxed literals in Jane syntax; they
    may also get re-inlined at that point *)
 let unboxed_literals_extension = Language_extension.Layouts

boot/ocamlc

@@ -648,6 +648,7 @@ let layout_module = Pvalue Pgenval
 let layout_module_field = Pvalue Pgenval
 let layout_functor = Pvalue Pgenval
 let layout_boxed_float = Pvalue Pfloatval
+let layout_unboxed_float = Punboxed_float
 let layout_string = Pvalue Pgenval
 let layout_boxedint bi = Pvalue (Pboxedintval bi)
 
@@ -1459,6 +1460,7 @@ let primitive_result_layout (p : primitive) =
   | Pccall { prim_native_repr_res = _, Same_as_ocaml_repr s; _} ->
       begin match s with
       | Value -> layout_any_value
+      | Float64 -> layout_unboxed_float
       | Void -> assert false
       end
   | Pccall { prim_native_repr_res = _, Unboxed_integer bi; _} ->

boot/ocamllex

@@ -535,6 +535,7 @@ val layout_functor : layout
 val layout_module_field : layout
 val layout_string : layout
 val layout_boxed_float : layout
+val layout_unboxed_float : layout
 val layout_boxedint : boxed_integer -> layout
 (* A layout that is Pgenval because it is the field of a block *)
 val layout_field : layout

lambda/lambda.ml

@@ -106,7 +106,7 @@ exception Error of Location.t * error
 
 let dbg = false
 
-(* CR layouts v2: When we're ready to allow non-values, these can be deleted or
+(* CR layouts v5: When we're ready to allow non-values, these can be deleted or
    changed to check for void. *)
 let layout_must_be_value loc layout =
   match Layout.(sub layout (value ~why:V1_safety_check)) with
@@ -1772,7 +1772,7 @@ let get_pat_args_constr p rem =
     List.iteri
       (fun i arg -> layout_must_be_value arg.pat_loc cstr_arg_layouts.(i))
       args;
-      (* CR layouts v2: This sanity check will have to go (or be replaced with a
+      (* CR layouts v5: This sanity check will have to go (or be replaced with a
          void-specific check) when we have other non-value sorts *)
     args @ rem
   | _ -> assert false
@@ -1784,7 +1784,7 @@ let get_expr_args_constr ~scopes head (arg, _mut, sort, layout) rem =
     | _ -> fatal_error "Matching.get_expr_args_constr"
   in
   let loc = head_loc ~scopes head in
-  (* CR layouts v2: This sanity check should be removed or changed to
+  (* CR layouts v5: This sanity check should be removed or changed to
      specifically check for void when we add other non-value sorts. *)
   Array.iter (fun layout -> layout_must_be_value head.pat_loc layout)
     cstr.cstr_arg_layouts;
@@ -3999,7 +3999,7 @@ let for_multiple_match ~scopes ~return_layout loc paraml mode pat_act_list parti
        partial)
 
 (* Error report *)
-(* CR layouts v2: This file didn't use to have the report_error infrastructure -
+(* CR layouts v5: This file didn't use to have the report_error infrastructure -
    I added it only for the void sanity checking in this module, which I'm not
    sure is even needed.  Reevaluate. *)
 open Format

lambda/lambda.mli

@@ -445,11 +445,6 @@ end
 
     This function returns both a pair of said CPSed Lambda term and the let
     bindings generated by this term (as an [Iterator_bindings.t], which see). *)
-(* CR layouts v2: the value that is passed to this function for [transl_exp]
-   (and all the other [~transl_exp] parameters in this file) must only be called
-   on expressions whose types have sort value.  Probably [transl_exp] will have
-   been updated to allow other sorts by the time we allow array elements other
-   than value, but check that.  *)
 let iterator ~transl_exp ~scopes ~loc
     : comprehension_iterator -> (lambda -> lambda) * Iterator_bindings.t
     = function
@@ -832,6 +827,8 @@ let comprehension
               ~array_sizing
               ~array
               ~index
+              (* CR layouts v4: Ensure that the [transl_exp] here can cope
+                 with non-values. *)
               ~body:(transl_exp ~scopes Sort.for_array_element comp_body)),
          (* If it was dynamically grown, cut it down to size *)
          match array_sizing with

lambda/matching.ml

@@ -43,8 +43,8 @@ let layout_must_be_value loc layout =
   | Ok _ -> ()
   | Error e -> raise (Error (loc, Non_value_layout e))
 
-(* CR layouts v2: In the places where this is used, we will want to allow
-   #float, but not void yet (e.g., the left of a semicolon and loop bodies).  we
+(* CR layouts v7: In the places where this is used, we will want to allow
+   float#, but not void yet (e.g., the left of a semicolon and loop bodies).  we
    still default to value before checking for void, to allow for sort variables
    arising in situations like
 
@@ -860,7 +860,7 @@ and transl_exp0 ~in_new_scope ~scopes sort e =
       | _ ->
           let oid = Ident.create_local "open" in
           let body, _ =
-            (* CR layouts v2: Currently we only allow values at the top of a
+            (* CR layouts v5: Currently we only allow values at the top of a
                module.  When that changes, some adjustments may be needed
                here. *)
             List.fold_left (fun (body, pos) id ->
@@ -900,7 +900,7 @@ and transl_exp0 ~in_new_scope ~scopes sort e =
            (We could probably calculate the layouts of these variables here
            rather than requiring them all to be value, but that would be even
            more hacky.) *)
-        (* CR layouts v2: if we get close to releasing other layout somebody
+        (* CR layouts v2.5: if we get close to releasing other layout somebody
            actually might put in a probe, check with the middle-end team about
            the status of fixing this. *)
         let path = Path.Pident id in
@@ -1411,7 +1411,7 @@ and transl_record ~scopes loc env mode fields repres opt_init_expr =
   then begin
     (* Allocate new record with given fields (and remaining fields
        taken from init_expr if any *)
-    (* CR layouts v2: currently we raise if a non-value field is detected.
+    (* CR layouts v5: currently we raise if a non-value field is detected.
        relax that. *)
     let init_id = Ident.create_local "init" in
     let lv =
@@ -1498,7 +1498,7 @@ and transl_record ~scopes loc env mode fields repres opt_init_expr =
        of the copy *)
     let copy_id = Ident.create_local "newrecord" in
     let update_field cont (lbl, definition) =
-      (* CR layouts v2: remove this check to allow non-value fields.  Even
+      (* CR layouts v5: remove this check to allow non-value fields.  Even
          in the current version we can reasonably skip it because if we built
          the init record, we must have already checked for void. *)
       layout_must_be_value lbl.lbl_loc lbl.lbl_layout;