Add a float64 layout and float# type. (#1528)

Author: ccasin

backend/cmmgen.ml

@@ -391,6 +391,21 @@ let is_strict : kind_for_unboxing -> bool = function
   | Boxed_integer _ | Boxed_float | Boxed_vector _ -> false
   | Any -> true
 
+(* [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 rec is_unboxed_number_cmm = function
     | Cop(Calloc mode, [Cconst_natint (hdr, _); _], dbg)
       when Nativeint.equal hdr float_header ->
@@ -906,13 +921,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 ->
@@ -945,12 +955,8 @@ and transl_ccall env prim args dbg =
         (ty1 :: tys, arg' :: args')
   in
   let typ_res, wrap_result =
-    (* 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 *)
     match prim.prim_native_repr_res with
-    | _, 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 ->

middle_end/flambda2/from_lambda/closure_conversion.ml

@@ -465,11 +465,9 @@ let close_c_call acc env ~loc ~let_bound_ids_with_kinds
   in
   let kind_of_primitive_native_repr
       ((_, repr) : Primitive.mode * Primitive.native_repr) =
-    (* CR layouts v2: This match will be extended with [| Same_as_ocaml_repr
-       Float64 -> K.naked_float] in the PR that adds Float64. *)
     match repr with
-    | Same_as_ocaml_repr Value -> K.value
-    | Same_as_ocaml_repr Void -> assert false
+    | Same_as_ocaml_repr sort ->
+      K.With_subkind.(kind (from_lambda (Typeopt.layout_of_const_sort sort)))
     | Unboxed_float -> K.naked_float
     | Unboxed_integer Pnativeint -> K.naked_nativeint
     | Unboxed_integer Pint32 -> K.naked_int32

ocaml/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;

ocaml/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 ->

ocaml/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

ocaml/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; _} ->

ocaml/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

ocaml/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

ocaml/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

ocaml/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;

ocaml/lambda/transl_array_comprehension.ml

@@ -43,7 +43,7 @@ type error =
 
 exception Error of Location.t * error
 
-(* CR layouts v2: This is used as part of the "void safety check" in the case of
+(* CR layouts v7: This is used as part of the "void safety check" in the case of
    [Tstr_eval], where we want to allow any sort (see comment on that case of
    typemod).  Remove when we remove the safety check.
 

ocaml/lambda/translcore.ml

@@ -416,6 +416,8 @@ let lookup_primitive loc poly pos p =
     | "%obj_magic" -> Primitive(Pobj_magic Lambda.layout_any_value, 1)
     | "%array_to_iarray" -> Primitive (Parray_to_iarray, 1)
     | "%array_of_iarray" -> Primitive (Parray_of_iarray, 1)
+    | "%unbox_float" -> Primitive(Punbox_float, 1)
+    | "%box_float" -> Primitive(Pbox_float mode, 1)
     | s when String.length s > 0 && s.[0] = '%' ->
        raise(Error(loc, Unknown_builtin_primitive s))
     | _ -> External p
@@ -513,7 +515,7 @@ let glb_array_set_type t1 t2 =
   | Pfloatarray_set, Pfloatarray -> Pfloatarray_set
 
 (* Specialize a primitive from available type information. *)
-(* CR layouts v2: This function had a loc argument added just to support the void
+(* CR layouts v7: This function had a loc argument added just to support the void
    check error message.  Take it out when we remove that. *)
 let specialize_primitive env loc ty ~has_constant_constructor prim =
   let param_tys =

ocaml/lambda/translmod.ml

@@ -56,6 +56,7 @@ type const_layout =
   | Void
   | Immediate64
   | Immediate
+  | Float64
 
 type label = string
 

ocaml/lambda/translprim.ml

@@ -80,6 +80,7 @@ let builtin_attrs =
   ; "ppwarning"; "ocaml.ppwarning"
   ; "explicit_arity"; "ocaml.explicit_arity"
   ; "warn_on_literal_pattern"; "ocaml.warn_on_literal_pattern"
+  ; "float64"; "ocaml.float64"
   ; "immediate"; "ocaml.immediate"
   ; "immediate64"; "ocaml.immediate64"
   ; "void"; "ocaml.void"
@@ -460,6 +461,7 @@ let layout ~legacy_immediate attrs =
          | "ocaml.any"|"any" -> Some (a, Any)
          | "ocaml.immediate"|"immediate" -> Some (a, Immediate)
          | "ocaml.immediate64"|"immediate64" -> Some (a, Immediate64)
+         | "ocaml.float64"|"float64" -> Some (a, Float64)
          | _ -> None
         ) attrs
   in
@@ -478,7 +480,7 @@ let layout ~legacy_immediate attrs =
      | Immediate | Immediate64 ->
         check  (legacy_immediate
              || Language_extension.(is_at_least Layouts Beta))
-     | Any | Void ->
+     | Any | Void | Float64 ->
         check Language_extension.(is_at_least Layouts Alpha)
 
 (* The "ocaml.boxed (default)" and "ocaml.unboxed (default)"

ocaml/parsing/asttypes.mli

@@ -757,15 +757,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

ocaml/parsing/builtin_attributes.ml

@@ -50,7 +50,7 @@ end
 let check_noalloc name f =
   let a0 = Gc.allocated_bytes () in
   let a1 = Gc.allocated_bytes () in
-  let _x = f () in
+  let _x = (f[@inlined never]) () in
   let a2 = Gc.allocated_bytes () in
   let alloc = (a2 -. 2. *. a1 +. a0) in
 

ocaml/parsing/parser.mly

@@ -24,7 +24,7 @@ let f () =
 let () =
   let a0 = Gc.allocated_bytes () in
   let a1 = Gc.allocated_bytes () in
-  let _x = f () in
+  let _x = (f[@inlined never]) () in
   let a2 = Gc.allocated_bytes () in
   let alloc = (a2 -. 2. *. a1 +. a0) in
   assert(alloc = 0.)