Force normalization on access to row_desc (#10474)

* always row_repr * remove the dummy field `row_bound` Co-authored-by: Takafumi Saikawa <tscompor@gmail.com>
ocaml · Sep 10, 2021 · 7ad8c13 · 7ad8c13
1 parent 7317226
commit 7ad8c13
Show file tree

Hide file tree

Showing 23 changed files with 430 additions and 389 deletions.
diff --git a/.depend b/.depend
@@ -943,7 +943,6 @@ typing/patterns.cmo : \
     typing/ident.cmi \
     typing/env.cmi \
     typing/ctype.cmi \
-    typing/btype.cmi \
     parsing/asttypes.cmi \
     typing/patterns.cmi
 typing/patterns.cmx : \
@@ -954,7 +953,6 @@ typing/patterns.cmx : \
     typing/ident.cmx \
     typing/env.cmx \
     typing/ctype.cmx \
-    typing/btype.cmx \
     parsing/asttypes.cmi \
     typing/patterns.cmi
 typing/patterns.cmi : \

diff --git a/Changes b/Changes
@@ -612,6 +612,13 @@ OCaml 4.13.0
   (Jacques Garrigue and Takafumi Saikawa,
    review by Florian Angeletti and Gabriel Radanne)
 
+* #10474: Force normalization on access to row_desc
+  Similar to #10337. Make row_desc an abstract types, with constructor
+  create_row and accessors defined in Types rather than Btype.
+  A normalized view row_desc_repr is provided for convenience.
+  (Jacques Garrigue and Takafumi Saikawa,
+   review by Leo White and Florian Angeletti)
+
 - #10358: Use a hash table for the load path.
   (Leo White, review by Gabriel Scherer)
 

diff --git a/boot/ocamlc b/boot/ocamlc
diff --git a/lambda/matching.ml b/lambda/matching.ml
@@ -1797,7 +1797,6 @@ let get_expr_args_variant_nonconst ~scopes head (arg, _mut) rem =
   (Lprim (Pfield 1, [ arg ], loc), Alias) :: rem
 
 let divide_variant ~scopes row ctx { cases = cl; args; default = def } =
-  let row = Btype.row_repr row in
   let rec divide = function
     | [] -> { args; cells = [] }
     | ((p, patl), action) :: rem
@@ -1808,10 +1807,7 @@ let divide_variant ~scopes row ctx { cases = cl; args; default = def } =
         in
         let head = Simple.head p in
         let variants = divide rem in
-        if
-          try Btype.row_field_repr (List.assoc lab row.row_fields) = Rabsent
-          with Not_found -> true
-        then
+        if row_field lab row = Rabsent then
           variants
         else
           let tag = Btype.hash_variant lab in
@@ -2890,17 +2886,16 @@ let call_switcher_variant_constr loc fail arg int_lambda_list =
 
 let combine_variant loc row arg partial ctx def (tag_lambda_list, total1, _pats)
     =
-  let row = Btype.row_repr row in
   let num_constr = ref 0 in
-  if row.row_closed then
+  if row_closed row then
     List.iter
       (fun (_, f) ->
-        match Btype.row_field_repr f with
+        match row_field_repr f with
         | Rabsent
         | Reither (true, _ :: _, _, _) ->
             ()
         | _ -> incr num_constr)
-      row.row_fields
+      (row_fields row)
   else
     num_constr := max_int;
   let test_int_or_block arg if_int if_block =

diff --git a/ocamldoc/odoc_env.ml b/ocamldoc/odoc_env.ml
@@ -186,10 +186,15 @@ let subst_type env t =
           let new_p =
             Odoc_name.to_path (full_type_name env (Odoc_name.from_path p)) in
           r := Some (new_p, tyl)
-      | Tvariant ({row_name=Some(p, tyl)} as row) ->
-          let new_p =
-            Odoc_name.to_path (full_type_name env (Odoc_name.from_path p)) in
-          set_type_desc t (Tvariant {row with row_name=Some(new_p, tyl)})
+      | Tvariant row ->
+          begin match row_name row with
+          | Some (p, tyl) ->
+              let new_p =
+                Odoc_name.to_path (full_type_name env (Odoc_name.from_path p))
+              in
+              set_type_desc t (Tvariant (set_row_name row (Some(new_p, tyl))))
+          | None -> ()
+          end
       | _ ->
           ()
     end

diff --git a/toplevel/genprintval.ml b/toplevel/genprintval.ml
@@ -446,13 +446,12 @@ module Make(O : OBJ)(EVP : EVALPATH with type valu = O.t) = struct
                   Oval_stuff "<unknown constructor>"
               end
           | Tvariant row ->
-              let row = Btype.row_repr row in
               if O.is_block obj then
                 let tag : int = O.obj (O.field obj 0) in
                 let rec find = function
                   | (l, f) :: fields ->
                       if Btype.hash_variant l = tag then
-                        match Btype.row_field_repr f with
+                        match row_field_repr f with
                         | Rpresent(Some ty) | Reither(_,[ty],_,_) ->
                             let args =
                               nest tree_of_val (depth - 1) (O.field obj 1) ty
@@ -461,7 +460,7 @@ module Make(O : OBJ)(EVP : EVALPATH with type valu = O.t) = struct
                         | _ -> find fields
                       else find fields
                   | [] -> Oval_stuff "<variant>" in
-                find row.row_fields
+                find (row_fields row)
               else
                 let tag : int = O.obj obj in
                 let rec find = function
@@ -470,7 +469,7 @@ module Make(O : OBJ)(EVP : EVALPATH with type valu = O.t) = struct
                         Oval_variant (l, None)
                       else find fields
                   | [] -> Oval_stuff "<variant>" in
-                find row.row_fields
+                find (row_fields row)
           | Tobject (_, _) ->
               Oval_stuff "<obj>"
           | Tsubst _ | Tfield(_, _, _, _) | Tnil | Tlink _ ->

diff --git a/typing/btype.ml b/typing/btype.ml
@@ -109,48 +109,6 @@ let rec commu_repr = function
     Clink r when !r <> Cunknown -> commu_repr !r
   | c -> c
 
-let rec row_field_repr_aux tl = function
-    Reither(_, tl', _, {contents = Some fi}) ->
-      row_field_repr_aux (tl@tl') fi
-  | Reither(c, tl', m, r) ->
-      Reither(c, tl@tl', m, r)
-  | Rpresent (Some _) when tl <> [] ->
-      Rpresent (Some (List.hd tl))
-  | fi -> fi
-
-let row_field_repr fi = row_field_repr_aux [] fi
-
-let rec rev_concat l ll =
-  match ll with
-    [] -> l
-  | l'::ll -> rev_concat (l'@l) ll
-
-let rec row_repr_aux ll row =
-  match get_desc row.row_more with
-  | Tvariant row' ->
-      let f = row.row_fields in
-      row_repr_aux (if f = [] then ll else f::ll) row'
-  | _ ->
-      if ll = [] then row else
-      {row with row_fields = rev_concat row.row_fields ll}
-
-let row_repr row = row_repr_aux [] row
-
-let rec row_field tag row =
-  let rec find = function
-    | (tag',f) :: fields ->
-        if tag = tag' then row_field_repr f else find fields
-    | [] ->
-        match get_desc row.row_more with
-        | Tvariant row' -> row_field tag row'
-        | _ -> Rabsent
-  in find row.row_fields
-
-let rec row_more row =
-  match get_desc row.row_more with
-  | Tvariant row' -> row_more row'
-  | _ -> row.row_more
-
 let merge_fixed_explanation fixed1 fixed2 =
   match fixed1, fixed2 with
   | Some Univar _ as x, _ | _, (Some Univar _ as x) -> x
@@ -161,29 +119,27 @@ let merge_fixed_explanation fixed1 fixed2 =
 
 
 let fixed_explanation row =
-  let row = row_repr row in
-  match row.row_fixed with
+  match row_fixed row with
   | Some _ as x -> x
   | None ->
-      match get_desc row.row_more with
+      let ty = row_more row in
+      match get_desc ty with
       | Tvar _ | Tnil -> None
-      | Tunivar _ -> Some (Univar row.row_more)
+      | Tunivar _ -> Some (Univar ty)
       | Tconstr (p,_,_) -> Some (Reified p)
       | _ -> assert false
 
-let is_fixed row = match row.row_fixed with
+let is_fixed row = match row_fixed row with
   | None -> false
   | Some _ -> true
 
-let row_fixed row = fixed_explanation row <> None
-
+let has_fixed_explanation row = fixed_explanation row <> None
 
 let static_row row =
-  let row = row_repr row in
-  row.row_closed &&
+  row_closed row &&
   List.for_all
     (fun (_,f) -> match row_field_repr f with Reither _ -> false | _ -> true)
-    row.row_fields
+    (row_fields row)
 
 let hash_variant s =
   let accu = ref 0 in
@@ -240,14 +196,14 @@ let is_constr_row ~allow_ident t =
 
 (* TODO: where should this really be *)
 (* Set row_name in Env, cf. GPR#1204/1329 *)
-let set_row_name decl path =
+let set_static_row_name decl path =
   match decl.type_manifest with
     None -> ()
   | Some ty ->
       match get_desc ty with
         Tvariant row when static_row row ->
-          let row = {(row_repr row) with
-                     row_name = Some (path, decl.type_params)} in
+          let row =
+            set_row_name row (Some (path, decl.type_params)) in
           set_type_desc ty (Tvariant row)
       | _ -> ()
 
@@ -256,7 +212,7 @@ let set_row_name decl path =
                   (*  Utilities for type traversal  *)
                   (**********************************)
 
-let rec fold_row f init row =
+let fold_row f init row =
   let result =
     List.fold_left
       (fun init (_, fi) ->
@@ -265,13 +221,12 @@ let rec fold_row f init row =
          | Reither(_, tl, _, _) -> List.fold_left f init tl
          | _ -> init)
       init
-      row.row_fields
+      (row_fields row)
   in
-  match get_desc row.row_more with
-    Tvariant row -> fold_row f result row
+  match get_desc (row_more row) with
   | Tvar _ | Tunivar _ | Tsubst _ | Tconstr _ | Tnil ->
     begin match
-      Option.map (fun (_,l) -> List.fold_left f result l) row.row_name
+      Option.map (fun (_,l) -> List.fold_left f result l) (row_name row)
     with
     | None -> result
     | Some result -> result
@@ -427,7 +382,7 @@ let type_iterators =
     | Tpackage (p, _) ->
         it.it_path p
     | Tvariant row ->
-        Option.iter (fun (p,_) -> it.it_path p) (row_repr row).row_name
+        Option.iter (fun (p,_) -> it.it_path p) (row_name row)
     | _ -> ()
   and it_path _p = ()
   in
@@ -438,6 +393,8 @@ let type_iterators =
     it_type_declaration; it_value_description; it_signature_item; }
 
 let copy_row f fixed row keep more =
+  let Row {fields = orig_fields; fixed = orig_fixed; closed; name = orig_name} =
+    row_repr row in
   let fields = List.map
       (fun (l, fi) -> l,
         match row_field_repr fi with
@@ -448,15 +405,13 @@ let copy_row f fixed row keep more =
             let tl = List.map f tl in
             Reither(c, tl, m, e)
         | _ -> fi)
-      row.row_fields in
+      orig_fields in
   let name =
-    match row.row_name with
+    match orig_name with
     | None -> None
     | Some (path, tl) -> Some (path, List.map f tl) in
-  let row_fixed = if fixed then row.row_fixed else None in
-  { row_fields = fields; row_more = more;
-    row_bound = (); row_fixed;
-    row_closed = row.row_closed; row_name = name; }
+  let fixed = if fixed then orig_fixed else None in
+  create_row ~fields ~more ~fixed ~closed ~name
 
 let rec copy_kind = function
     Fvar{contents = Some k} -> copy_kind k

diff --git a/typing/btype.mli b/typing/btype.mli
@@ -82,20 +82,12 @@ val commu_repr: commutable -> commutable
 
 (**** polymorphic variants ****)
 
-val row_repr: row_desc -> row_desc
-        (* Return the canonical representative of a row description *)
-val row_field_repr: row_field -> row_field
-val row_field: label -> row_desc -> row_field
-        (* Return the canonical representative of a row field *)
-val row_more: row_desc -> type_expr
-        (* Return the extension variable of the row *)
-
 val is_fixed: row_desc -> bool
 (* Return whether the row is directly marked as fixed or not *)
 
-val row_fixed: row_desc -> bool
+val has_fixed_explanation: row_desc -> bool
 (* Return whether the row should be treated as fixed or not.
-   In particular, [is_fixed row] implies [row_fixed row].
+   In particular, [is_fixed row] implies [has_fixed_explanation row].
 *)
 
 val fixed_explanation: row_desc -> fixed_explanation option
@@ -122,7 +114,7 @@ val is_row_name: string -> bool
 val is_constr_row: allow_ident:bool -> type_expr -> bool
 
 (* Set the polymorphic variant row_name field *)
-val set_row_name : type_declaration -> Path.t -> unit
+val set_static_row_name: type_declaration -> Path.t -> unit
 
 (**** Utilities for type traversal ****)