Unboxed records (#98)

janestreet · Jan 30, 2025 · 2e02917 · 2e02917
1 parent 304977b
commit 2e02917
Show file tree

Hide file tree

Showing 19 changed files with 1,303 additions and 67 deletions.
diff --git a/lib/Ast.ml b/lib/Ast.ml
@@ -149,7 +149,9 @@ module Exp = struct
   let rec is_trivial exp =
     match exp.pexp_desc with
     | Pexp_constant {pconst_desc= Pconst_string (_, _, None); _} -> true
-    | Pexp_constant _ | Pexp_field _ | Pexp_ident _ | Pexp_send _ -> true
+    | Pexp_constant _ | Pexp_field _ | Pexp_unboxed_field _ | Pexp_ident _
+     |Pexp_send _ ->
+        true
     | Pexp_construct (_, exp) -> Option.for_all exp ~f:is_trivial
     | Pexp_prefix (_, e) -> is_trivial e
     | Pexp_apply
@@ -164,7 +166,7 @@ module Exp = struct
     match e.pexp_desc with
     | Pexp_prefix _ -> true
     | Pexp_apply (op, _) -> exposed_left op
-    | Pexp_field (e, _) -> exposed_left e
+    | Pexp_field (e, _) | Pexp_unboxed_field (e, _) -> exposed_left e
     | _ -> false
 
   (** [mem_cls cls exp] holds if [exp] is in the named class of expressions
@@ -202,16 +204,31 @@ module Exp = struct
      |Pexp_construct (_, None)
      |Pexp_variant (_, None)
      |Pexp_override _ | Pexp_open _ | Pexp_extension _ | Pexp_hole
-     |Pexp_record _ | Pexp_array _ | Pexp_list _
-     |Pexp_list_comprehension _ | Pexp_array_comprehension _ ->
+     |Pexp_record _ | Pexp_record_unboxed_product _ | Pexp_array _
+     |Pexp_list _ | Pexp_list_comprehension _ | Pexp_array_comprehension _
+     |Pexp_unboxed_tuple _ ->
         true
-    | Pexp_prefix (_, e) | Pexp_field (e, _) | Pexp_send (e, _) ->
+    | Pexp_prefix (_, e)
+     |Pexp_field (e, _)
+     |Pexp_unboxed_field (e, _)
+     |Pexp_send (e, _) ->
         is_simple_in_parser e
     | Pexp_infix ({txt; _}, e1, e2) ->
         String.length txt > 0
         && Char.(String.get txt 0 = '#')
         && is_simple_in_parser e1 && is_simple_in_parser e2
-    | _ -> false
+    | Pexp_indexop_access {pia_rhs= Some _; _}
+     |Pexp_construct (_, Some _)
+     |Pexp_variant (_, Some _)
+     |Pexp_unreachable | Pexp_let _ | Pexp_function _ | Pexp_fun _
+     |Pexp_apply _ | Pexp_match _ | Pexp_try _ | Pexp_tuple _
+     |Pexp_setfield _ | Pexp_ifthenelse _ | Pexp_sequence _ | Pexp_while _
+     |Pexp_for _ | Pexp_constraint _ | Pexp_coerce _ | Pexp_setinstvar _
+     |Pexp_letmodule _ | Pexp_letexception _ | Pexp_assert _ | Pexp_lazy _
+     |Pexp_poly _ | Pexp_newtype _ | Pexp_pack _ | Pexp_letopen _
+     |Pexp_letop _ | Pexp_stack _ | Pexp_beginend _ | Pexp_parens _
+     |Pexp_cons _ ->
+        false
 end
 
 module Pat = struct
@@ -240,22 +257,30 @@ module Pat = struct
      non-simple pattern. *)
   let rec is_simple_in_parser {ppat_desc; _} =
     match ppat_desc with
-    | Ppat_var _ | Ppat_record _ | Ppat_list _ | Ppat_array _ | Ppat_any
-     |Ppat_constant _
+    | Ppat_var _ | Ppat_record _ | Ppat_record_unboxed_product _
+     |Ppat_list _ | Ppat_array _ | Ppat_any | Ppat_constant _
      |Ppat_construct (_, None)
      |Ppat_variant (_, None)
-     |Ppat_type _ | Ppat_extension _ ->
+     |Ppat_type _ | Ppat_extension _ | Ppat_unboxed_tuple _ ->
         true
     | Ppat_open (_, p) -> is_simple_in_parser p
-    | _ -> false
+    | Ppat_construct (_, Some _)
+     |Ppat_variant (_, Some _)
+     |Ppat_alias _ | Ppat_interval _ | Ppat_tuple _ | Ppat_or _
+     |Ppat_constraint (_, _, _)
+     |Ppat_lazy _
+     |Ppat_unpack (_, _)
+     |Ppat_exception _ | Ppat_cons _ ->
+        false
 
   let has_trailing_attributes {ppat_desc; ppat_attributes; _} =
     match ppat_desc with
     | Ppat_construct (_, None)
      |Ppat_constant _ | Ppat_any | Ppat_var _
      |Ppat_variant (_, None)
-     |Ppat_record _ | Ppat_array _ | Ppat_list _ | Ppat_type _
-     |Ppat_unpack _ | Ppat_extension _ | Ppat_open _ | Ppat_interval _ ->
+     |Ppat_record _ | Ppat_record_unboxed_product _ | Ppat_array _
+     |Ppat_list _ | Ppat_type _ | Ppat_unpack _ | Ppat_extension _
+     |Ppat_open _ | Ppat_interval _ ->
         false
     | _ -> List.exists ppat_attributes ~f:(Fn.non Attr.is_doc)
 end
@@ -360,7 +385,8 @@ module Tyd = struct
   let is_simple x =
     match x.ptype_kind with
     | Ptype_abstract | Ptype_open -> true
-    | Ptype_variant _ | Ptype_record _ -> false
+    | Ptype_variant _ | Ptype_record _ | Ptype_record_unboxed_product _ ->
+        false
 end
 
 module Structure_item = struct
@@ -1017,7 +1043,7 @@ end = struct
              | Ptype_variant cd1N ->
                  List.exists cd1N ~f:(fun {pcd_args; pcd_res; _} ->
                      check_cstr pcd_args || Option.exists pcd_res ~f )
-             | Ptype_record ld1N ->
+             | Ptype_record ld1N | Ptype_record_unboxed_product ld1N ->
                  List.exists ld1N ~f:(fun {pld_type; _} -> typ == pld_type)
              | _ -> false )
           || Option.exists ptype_manifest ~f )
@@ -1038,7 +1064,7 @@ end = struct
       | Ppat_extension (_, PTyp t) -> assert (typ == t)
       | Ppat_unpack (_, Some (_, l, _)) ->
           assert (List.exists l ~f:(fun (_, t) -> typ == t))
-      | Ppat_record (l, _) ->
+      | Ppat_record (l, _) | Ppat_record_unboxed_product (l, _) ->
           assert (List.exists l ~f:(fun (_, t, _) -> Option.exists t ~f))
       | _ -> assert false )
     | Exp ctx -> (
@@ -1052,7 +1078,7 @@ end = struct
       | Pexp_coerce (_, Some t1, t2) -> assert (typ == t1 || typ == t2)
       | Pexp_letexception (ext, _) -> assert (check_ext ext)
       | Pexp_object _ -> assert false
-      | Pexp_record (en1, _) ->
+      | Pexp_record (en1, _) | Pexp_record_unboxed_product (en1, _) ->
           assert (
             List.exists en1 ~f:(fun (_, c, _) ->
                 Option.exists c ~f:(function
@@ -1367,7 +1393,7 @@ end = struct
             assert (List.exists p1N ~f)
         | Ppat_tuple (p1N, _) | Ppat_unboxed_tuple (p1N, _) ->
             assert (List.exists p1N ~f:(fun (_, p) -> f p))
-        | Ppat_record (p1N, _) ->
+        | Ppat_record (p1N, _) | Ppat_record_unboxed_product (p1N, _) ->
             assert (List.exists p1N ~f:(fun (_, _, x) -> Option.exists x ~f))
         | Ppat_or l -> assert (List.exists ~f:(fun p -> p == pat) l)
         | Ppat_alias (p1, _)
@@ -1390,15 +1416,17 @@ end = struct
           assert (check_comprehension comp (Pattern pat))
       | Pexp_apply _ | Pexp_array _ | Pexp_list _ | Pexp_assert _
        |Pexp_coerce _ | Pexp_constant _ | Pexp_constraint _
-       |Pexp_construct _ | Pexp_field _ | Pexp_ident _ | Pexp_ifthenelse _
-       |Pexp_lazy _ | Pexp_letexception _ | Pexp_letmodule _ | Pexp_new _
+       |Pexp_construct _ | Pexp_field _ | Pexp_unboxed_field _
+       |Pexp_ident _ | Pexp_ifthenelse _ | Pexp_lazy _
+       |Pexp_letexception _ | Pexp_letmodule _ | Pexp_new _
        |Pexp_newtype _ | Pexp_open _ | Pexp_override _ | Pexp_pack _
-       |Pexp_poly _ | Pexp_record _ | Pexp_send _ | Pexp_sequence _
-       |Pexp_setfield _ | Pexp_setinstvar _ | Pexp_tuple _
-       |Pexp_unboxed_tuple _ | Pexp_unreachable | Pexp_variant _
-       |Pexp_while _ | Pexp_hole | Pexp_beginend _ | Pexp_parens _
-       |Pexp_cons _ | Pexp_letopen _ | Pexp_indexop_access _
-       |Pexp_prefix _ | Pexp_infix _ | Pexp_stack _ ->
+       |Pexp_poly _ | Pexp_record _ | Pexp_record_unboxed_product _
+       |Pexp_send _ | Pexp_sequence _ | Pexp_setfield _ | Pexp_setinstvar _
+       |Pexp_tuple _ | Pexp_unboxed_tuple _ | Pexp_unreachable
+       |Pexp_variant _ | Pexp_while _ | Pexp_hole | Pexp_beginend _
+       |Pexp_parens _ | Pexp_cons _ | Pexp_letopen _
+       |Pexp_indexop_access _ | Pexp_prefix _ | Pexp_infix _ | Pexp_stack _
+        ->
           assert false
       | Pexp_extension (_, ext) -> assert (check_extensions ext)
       | Pexp_object {pcstr_self; _} ->
@@ -1521,7 +1549,7 @@ end = struct
             assert (List.exists e1N ~f)
         | Pexp_construct (_, e) | Pexp_variant (_, e) ->
             assert (Option.exists e ~f)
-        | Pexp_record (e1N, e0) ->
+        | Pexp_record (e1N, e0) | Pexp_record_unboxed_product (e1N, e0) ->
             assert (
               Option.exists e0 ~f
               || List.exists e1N ~f:(fun (_, _, e) -> Option.exists e ~f) )
@@ -1532,6 +1560,7 @@ end = struct
          |Pexp_stack e
          |Pexp_coerce (e, _, _)
          |Pexp_field (e, _)
+         |Pexp_unboxed_field (e, _)
          |Pexp_lazy e
          |Pexp_letexception (_, e)
          |Pexp_letmodule (_, _, _, e)
@@ -1633,7 +1662,7 @@ end = struct
     let ctx = Exp exp in
     match exp.pexp_desc with
     | Pexp_constant _ -> Exp.is_trivial exp
-    | Pexp_field _ | Pexp_ident _ | Pexp_send _
+    | Pexp_field _ | Pexp_unboxed_field _ | Pexp_ident _ | Pexp_send _
      |Pexp_construct (_, None)
      |Pexp_variant (_, None) ->
         true
@@ -1647,7 +1676,7 @@ end = struct
     | Pexp_tuple e1N | Pexp_unboxed_tuple e1N ->
         List.for_all e1N ~f:(fun (_, e) -> Exp.is_trivial e)
         && fit_margin c (width xexp)
-    | Pexp_record (e1N, e0) ->
+    | Pexp_record (e1N, e0) | Pexp_record_unboxed_product (e1N, e0) ->
         Option.for_all e0 ~f:Exp.is_trivial
         && List.for_all e1N ~f:(fun (_, c, eo) ->
                Option.is_none c && Option.for_all eo ~f:Exp.is_trivial )
@@ -1814,7 +1843,7 @@ end = struct
       | Pexp_setfield (e0, _, _) when e0 == exp -> Some (Dot, Left)
       | Pexp_setfield (_, _, e0) when e0 == exp -> Some (LessMinus, Non)
       | Pexp_setinstvar _ -> Some (LessMinus, Non)
-      | Pexp_field _ -> Some (Dot, Left)
+      | Pexp_field _ | Pexp_unboxed_field _ -> Some (Dot, Left)
       (* We use [Dot] so [x#y] has the same precedence as [x.y], it is
          different to what is done in the parser, but it is intended. *)
       | Pexp_send _ -> Some (Dot, Left)
@@ -1921,7 +1950,7 @@ end = struct
           prec_ast (Exp e)
       | Pexp_setfield _ -> Some LessMinus
       | Pexp_setinstvar _ -> Some LessMinus
-      | Pexp_field _ -> Some Dot
+      | Pexp_field _ | Pexp_unboxed_field _ -> Some Dot
       | Pexp_send _ -> Some Dot
       | _ -> None )
     | Fp _ -> None
@@ -2065,7 +2094,9 @@ end = struct
     | Pat {ppat_desc= Ppat_cons _; _}, inner -> (
       match inner with
       | Ppat_cons _ -> true
-      | Ppat_construct _ | Ppat_record _ | Ppat_variant _ -> false
+      | Ppat_construct _ | Ppat_record _ | Ppat_record_unboxed_product _
+       |Ppat_unboxed_tuple _ | Ppat_variant _ ->
+          false
       | _ -> true )
     | Fp {pparam_desc= Pparam_val (_, _, _, _); _}, Ppat_cons _ -> true
     | Pat {ppat_desc= Ppat_construct _; _}, Ppat_cons _ -> true
@@ -2249,9 +2280,10 @@ end = struct
         | Pexp_array _ | Pexp_list _ | Pexp_coerce _ | Pexp_constant _
          |Pexp_constraint _
          |Pexp_construct (_, None)
-         |Pexp_extension _ | Pexp_field _ | Pexp_for _ | Pexp_ident _
-         |Pexp_new _ | Pexp_object _ | Pexp_override _ | Pexp_pack _
-         |Pexp_poly _ | Pexp_record _ | Pexp_send _ | Pexp_unreachable
+         |Pexp_extension _ | Pexp_field _ | Pexp_unboxed_field _
+         |Pexp_for _ | Pexp_ident _ | Pexp_new _ | Pexp_object _
+         |Pexp_override _ | Pexp_pack _ | Pexp_poly _ | Pexp_record _
+         |Pexp_record_unboxed_product _ | Pexp_send _ | Pexp_unreachable
          |Pexp_variant (_, None)
          |Pexp_hole | Pexp_while _ | Pexp_beginend _ | Pexp_parens _
          |Pexp_indexop_access _ | Pexp_list_comprehension _
@@ -2331,9 +2363,10 @@ end = struct
       | Pexp_array _ | Pexp_list _ | Pexp_coerce _ | Pexp_constant _
        |Pexp_constraint _
        |Pexp_construct (_, None)
-       |Pexp_extension _ | Pexp_field _ | Pexp_for _ | Pexp_ident _
-       |Pexp_new _ | Pexp_object _ | Pexp_override _ | Pexp_pack _
-       |Pexp_poly _ | Pexp_record _ | Pexp_send _ | Pexp_unreachable
+       |Pexp_extension _ | Pexp_field _ | Pexp_unboxed_field _ | Pexp_for _
+       |Pexp_ident _ | Pexp_new _ | Pexp_object _ | Pexp_override _
+       |Pexp_pack _ | Pexp_poly _ | Pexp_record _
+       |Pexp_record_unboxed_product _ | Pexp_send _ | Pexp_unreachable
        |Pexp_variant (_, None)
        |Pexp_hole | Pexp_while _ | Pexp_beginend _ | Pexp_parens _
        |Pexp_list_comprehension _ | Pexp_array_comprehension _ ->
@@ -2562,7 +2595,7 @@ end = struct
         ; _ } )
       when exp == lhs ->
         true
-    | ( Exp {pexp_desc= Pexp_field (e, _); _}
+    | ( Exp {pexp_desc= Pexp_field (e, _) | Pexp_unboxed_field (e, _); _}
       , {pexp_desc= Pexp_construct _ | Pexp_cons _; _} )
       when e == exp ->
         true
@@ -2629,12 +2662,14 @@ end = struct
             , _ )
           when exp2 == exp ->
             false
-        | Pexp_record (flds, _)
+        | (Pexp_record (flds, _) | Pexp_record_unboxed_product (flds, _))
           when List.exists flds ~f:(fun (_, _, e0) ->
                    Option.exists e0 ~f:(fun x -> x == exp) ) ->
             exposed_right_exp Non_apply exp
             (* Non_apply is perhaps pessimistic *)
         | Pexp_record (_, Some ({pexp_desc= Pexp_prefix _; _} as e0))
+         |Pexp_record_unboxed_product
+            (_, Some ({pexp_desc= Pexp_prefix _; _} as e0))
           when e0 == exp ->
             (* don't put parens around [!e] in [{ !e with a; b }] *)
             false
@@ -2643,11 +2678,23 @@ end = struct
             , Some
                 ( { pexp_desc=
                       ( Pexp_ident _ | Pexp_constant _ | Pexp_record _
-                      | Pexp_constraint _ | Pexp_field _ )
+                      | Pexp_constraint _ | Pexp_unboxed_field _
+                      | Pexp_field _ )
+                  ; _ } as e0 ) )
+         |Pexp_record_unboxed_product
+            ( _
+            , Some
+                ( { pexp_desc=
+                      ( Pexp_ident _ | Pexp_constant _ | Pexp_record _
+                      | Pexp_constraint _ | Pexp_unboxed_field _
+                      | Pexp_field _ )
                   ; _ } as e0 ) )
           when e0 == exp ->
             false
-        | Pexp_record (_, Some e0) when e0 == exp -> true
+        | Pexp_record (_, Some e0)
+         |Pexp_record_unboxed_product (_, Some e0)
+          when e0 == exp ->
+            true
         | Pexp_override fields
           when List.exists fields ~f:(fun (_, e0) -> e0 == exp) ->
             exposed_right_exp Sequence exp

diff --git a/lib/Exposed.ml b/lib/Exposed.ml
@@ -81,7 +81,10 @@ module Right = struct
     | {ptype_cstrs= _ :: _ as cstrs; _} ->
         (* type a = ... constraint left = < ... > *)
         list ~elt:(fun (_left, right, _loc) -> core_type right) cstrs
-    | {ptype_kind= Ptype_open | Ptype_record _; _} -> false
+    | { ptype_kind=
+          Ptype_open | Ptype_record _ | Ptype_record_unboxed_product _
+      ; _ } ->
+        false
     | {ptype_kind= Ptype_abstract; ptype_manifest= None; _} -> false
     | {ptype_kind= Ptype_abstract; ptype_manifest= Some manifest; _} ->
         (* type a = < ... > *)

diff --git a/lib/Extended_ast.ml b/lib/Extended_ast.ml
@@ -181,6 +181,9 @@ module Parse = struct
       | {ppat_desc= Ppat_record (fields, flag); _} as e ->
           let fields = List.map ~f:(pat_record_field m) fields in
           {e with ppat_desc= Ppat_record (fields, flag)}
+      | {ppat_desc= Ppat_record_unboxed_product (fields, flag); _} as e ->
+          let fields = List.map ~f:(pat_record_field m) fields in
+          {e with ppat_desc= Ppat_record_unboxed_product (fields, flag)}
       (* [(module M) : (module T)] -> [(module M : T)] *)
       | { ppat_desc=
             Ppat_constraint
@@ -212,6 +215,12 @@ module Parse = struct
           { e with
             pexp_desc= Pexp_record (fields, Option.map ~f:(m.expr m) with_)
           }
+      | {pexp_desc= Pexp_record_unboxed_product (fields, with_); _} as e ->
+          let fields = List.map ~f:(record_field m) fields in
+          { e with
+            pexp_desc=
+              Pexp_record_unboxed_product
+                (fields, Option.map ~f:(m.expr m) with_) }
       (* [( + ) 1 2] -> [1 + 2] *)
       | { pexp_desc=
             Pexp_apply