Make type_expr private

Changes

@@ -37,6 +37,10 @@ Working version
 - #9650, #9651: keep refactoring the pattern-matching compiler
   (Gabriel Scherer, review by Thomas Refis and Florian Angeletti)
 
+- #9994: Make Types.type_expr a private type, and abstract marking mechanism
+  (Jacques Garrigue and Takafumi Saikawa,
+   review by Gabriel Scherer and Leo White)
+
 - #10007: Driver.compile_common: when typing a .ml file, return the
   compilation unit signature (inferred or from the .cmi) in addition
   to the implementation and the coercion.

ocamldoc/odoc_env.ml

@@ -175,20 +175,20 @@ let subst_type env t =
       | Types.Tconstr (p, l, a) ->
           let new_p =
             Odoc_name.to_path (full_type_name env (Odoc_name.from_path p)) in
-          t.Types.desc <- Types.Tconstr (new_p, l, a)
+          Btype.set_type_desc t (Types.Tconstr (new_p, l, a))
       | Types.Tpackage (p, n, l) ->
           let new_p =
             Odoc_name.to_path (full_module_type_name env (Odoc_name.from_path p)) in
-          t.Types.desc <- Types.Tpackage (new_p, n, l)
+          Btype.set_type_desc t (Types.Tpackage (new_p, n, l))
       | Types.Tobject (_, ({contents=Some(p,tyl)} as r)) ->
           let new_p =
             Odoc_name.to_path (full_type_name env (Odoc_name.from_path p)) in
           r := Some (new_p, tyl)
       | Types.Tvariant ({Types.row_name=Some(p, tyl)} as row) ->
           let new_p =
             Odoc_name.to_path (full_type_name env (Odoc_name.from_path p)) in
-          t.Types.desc <-
-            Types.Tvariant {row with Types.row_name=Some(new_p, tyl)}
+          Btype.set_type_desc t
+            (Types.Tvariant {row with Types.row_name=Some(new_p, tyl)})
       | _ ->
           ()
     end

ocamldoc/odoc_misc.ml

@@ -509,4 +509,5 @@ let remove_option typ =
     | Types.Tlink t2
     | Types.Tsubst t2 -> iter t2.Types.desc
   in
-  { typ with Types.desc = iter typ.Types.desc }
+  Types.Private_type_expr.create (iter typ.Types.desc)
+    ~level:typ.Types.level ~scope:typ.Types.scope ~id:typ.Types.id

ocamldoc/odoc_print.ml

@@ -86,12 +86,15 @@ let simpl_class_type t =
     | Types.Cty_signature cs ->
         (* we delete vals and methods in order to not print them when
            displaying the type *)
-      let tnil =
-        { Types.desc = Types.Tnil ; Types.level = 0
-        ; Types.scope = Btype.lowest_level ; Types.id = 0 }
+      let tself =
+        let t = cs.Types.csig_self in
+        let t' = Types.Private_type_expr.create Types.Tnil
+            ~level:0 ~scope:Btype.lowest_level ~id:0 in
+        let desc = Types.Tobject (t', ref None) in
+        Types.Private_type_expr.create desc
+          ~level:t.Types.level ~scope:t.Types.scope ~id:t.Types.id
       in
-        Types.Cty_signature { Types.csig_self = { cs.Types.csig_self with
-                                                  Types.desc = Types.Tobject (tnil, ref None) };
+        Types.Cty_signature { Types.csig_self = tself;
                               csig_vars = Types.Vars.empty ;
                               csig_concr = Types.Concr.empty ;
                               csig_inher = []

typing/btype.ml

@@ -45,7 +45,8 @@ let pivot_level = 2 * lowest_level - 1
 let new_id = s_ref (-1)
 
 let newty2 level desc  =
-  incr new_id; { desc; level; scope = lowest_level; id = !new_id }
+  incr new_id;
+  Private_type_expr.create desc ~level ~scope:lowest_level ~id:!new_id
 let newgenty desc      = newty2 generic_level desc
 let newgenvar ?name () = newgenty (Tvar name)
 (*
@@ -77,7 +78,6 @@ type change =
   | Ckind of field_kind option ref * field_kind option
   | Ccommu of commutable ref * commutable
   | Cuniv of type_expr option ref * type_expr option
-  | Ctypeset of TypeSet.t ref * TypeSet.t
 
 type changes =
     Change of change * changes ref
@@ -100,19 +100,19 @@ let rec field_kind_repr =
     Fvar {contents = Some kind} -> field_kind_repr kind
   | kind                        -> kind
 
-let rec repr_link compress t d =
+let rec repr_link compress (t : type_expr) d : type_expr -> type_expr =
  function
    {desc = Tlink t' as d'} ->
      repr_link true t d' t'
  | {desc = Tfield (_, k, _, t') as d'} when field_kind_repr k = Fabsent ->
      repr_link true t d' t'
  | t' ->
      if compress then begin
-       log_change (Ccompress (t, t.desc, d)); t.desc <- d
+       log_change (Ccompress (t, t.desc, d)); Private_type_expr.set_desc t d
      end;
      t'
 
-let repr t =
+let repr (t : type_expr) =
   match t.desc with
    Tlink t' as d ->
      repr_link false t d t'
@@ -256,6 +256,20 @@ let is_constr_row ~allow_ident t =
   | Tconstr (Path.Pdot (_, s), _, _) -> is_row_name s
   | _ -> false
 
+(* TODO: where should this really be *)
+(* Set row_name in Env, cf. GPR#1204/1329 *)
+let set_row_name decl path =
+  match decl.type_manifest with
+    None -> ()
+  | Some ty ->
+      let ty = repr ty in
+      match ty.desc with
+        Tvariant row when static_row row ->
+          let row = {(row_repr row) with
+                     row_name = Some (path, decl.type_params)} in
+          Private_type_expr.set_desc ty (Tvariant row)
+      | _ -> ()
+
 
                   (**********************************)
                   (*  Utilities for type traversal  *)
@@ -538,7 +552,7 @@ end = struct
 
   (* Restore type descriptions. *)
   let cleanup { saved_desc; saved_kinds; _ } =
-    List.iter (fun (ty, desc) -> ty.desc <- desc) saved_desc;
+    List.iter (fun (ty, desc) -> Private_type_expr.set_desc ty desc) saved_desc;
     List.iter (fun r -> r := None) saved_kinds
 
   let with_scope f =
@@ -549,29 +563,28 @@ end = struct
 end
 
 (* Mark a type. *)
+
+let not_marked_node ty = ty.level >= lowest_level
+    (* type nodes with negative levels are "marked" *)
+
+let flip_mark_node ty = Private_type_expr.set_level ty (pivot_level - ty.level)
+
+let try_mark_node ty = not_marked_node ty && (flip_mark_node ty; true)
+
 let rec mark_type ty =
   let ty = repr ty in
-  if ty.level >= lowest_level then begin
-    ty.level <- pivot_level - ty.level;
+  if not_marked_node ty then begin
+    flip_mark_node ty;
     iter_type_expr mark_type ty
   end
 
-let mark_type_node ty =
-  let ty = repr ty in
-  if ty.level >= lowest_level then begin
-    ty.level <- pivot_level - ty.level;
-  end
-
 let mark_type_params ty =
   iter_type_expr mark_type ty
 
 let type_iterators =
   let it_type_expr it ty =
     let ty = repr ty in
-    if ty.level >= lowest_level then begin
-      mark_type_node ty;
-      it.it_do_type_expr it ty;
-    end
+    if try_mark_node ty then it.it_do_type_expr it ty
   in
   {type_iterators with it_type_expr}
 
@@ -580,7 +593,8 @@ let type_iterators =
 let rec unmark_type ty =
   let ty = repr ty in
   if ty.level < lowest_level then begin
-    ty.level <- pivot_level - ty.level;
+    (* flip back the marked level *)
+    flip_mark_node ty;
     iter_type_expr unmark_type ty
   end
 
@@ -708,16 +722,15 @@ let extract_label l ls = extract_label_aux [] l ls
                   (**********************************)
 
 let undo_change = function
-    Ctype  (ty, desc) -> ty.desc <- desc
-  | Ccompress  (ty, desc, _) -> ty.desc <- desc
-  | Clevel (ty, level) -> ty.level <- level
-  | Cscope (ty, scope) -> ty.scope <- scope
+    Ctype  (ty, desc) -> Private_type_expr.set_desc ty desc
+  | Ccompress  (ty, desc, _) -> Private_type_expr.set_desc ty desc
+  | Clevel (ty, level) -> Private_type_expr.set_level ty level
+  | Cscope (ty, scope) -> Private_type_expr.set_scope ty scope
   | Cname  (r, v) -> r := v
   | Crow   (r, v) -> r := v
   | Ckind  (r, v) -> r := v
   | Ccommu (r, v) -> r := v
   | Cuniv  (r, v) -> r := v
-  | Ctypeset (r, v) -> r := v
 
 type snapshot = changes ref * int
 let last_snapshot = s_ref 0
@@ -727,35 +740,40 @@ let log_type ty =
 let link_type ty ty' =
   log_type ty;
   let desc = ty.desc in
-  ty.desc <- Tlink ty';
+  Private_type_expr.set_desc ty (Tlink ty');
   (* Name is a user-supplied name for this unification variable (obtained
    * through a type annotation for instance). *)
   match desc, ty'.desc with
     Tvar name, Tvar name' ->
       begin match name, name' with
-      | Some _, None ->  log_type ty'; ty'.desc <- Tvar name
-      | None, Some _ ->  ()
+      | Some _, None -> log_type ty'; Private_type_expr.set_desc ty' (Tvar name)
+      | None, Some _ -> ()
       | Some _, Some _ ->
-          if ty.level < ty'.level then (log_type ty'; ty'.desc <- Tvar name)
-      | None, None   ->  ()
+          if ty.level < ty'.level then
+            (log_type ty'; Private_type_expr.set_desc ty' (Tvar name))
+      | None, None   -> ()
       end
   | _ -> ()
   (* ; assert (check_memorized_abbrevs ()) *)
   (*  ; check_expans [] ty' *)
+(* TODO: consider eliminating set_type_desc, replacing it with link types *)
 let set_type_desc ty td =
   if td != ty.desc then begin
     log_type ty;
-    ty.desc <- td
+    Private_type_expr.set_desc ty td
   end
-let set_level ty level =
+(* TODO: separate set_level into two specific functions: *)
+(*  set_lower_level and set_generic_level *)
+ let set_level ty level =
   if level <> ty.level then begin
     if ty.id <= !last_snapshot then log_change (Clevel (ty, ty.level));
-    ty.level <- level
+    Private_type_expr.set_level ty level
   end
+(* TODO: introduce a guard and rename it to set_higher_scope? *)
 let set_scope ty scope =
   if scope <> ty.scope then begin
     if ty.id <= !last_snapshot then log_change (Cscope (ty, ty.scope));
-    ty.scope <- scope
+    Private_type_expr.set_scope ty scope
   end
 let set_univar rty ty =
   log_change (Cuniv (rty, !rty)); rty := Some ty
@@ -767,8 +785,6 @@ let set_kind rk k =
   log_change (Ckind (rk, !rk)); rk := Some k
 let set_commu rc c =
   log_change (Ccommu (rc, !rc)); rc := c
-let set_typeset rs s =
-  log_change (Ctypeset (rs, !rs)); rs := s
 
 let snapshot () =
   let old = !last_snapshot in
@@ -817,6 +833,6 @@ let undo_compress (changes, _old) =
       List.iter
         (fun r -> match !r with
           Change (Ccompress (ty, desc, d), next) when ty.desc == d ->
-            ty.desc <- desc; r := !next
+            Private_type_expr.set_desc ty desc; r := !next
         | _ -> ())
         log

typing/btype.mli

@@ -100,6 +100,9 @@ val has_constr_row: type_expr -> bool
 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
+
 (**** Utilities for type traversal ****)
 
 val iter_type_expr: (type_expr -> unit) -> type_expr -> unit
@@ -130,7 +133,7 @@ type type_iterators =
     it_path: Path.t -> unit; }
 val type_iterators: type_iterators
         (* Iteration on arbitrary type information.
-           [it_type_expr] calls [mark_type_node] to avoid loops. *)
+           [it_type_expr] calls [mark_node] to avoid loops. *)
 val unmark_iterators: type_iterators
         (* Unmark any structure containing types. See [unmark_type] below. *)
 
@@ -164,14 +167,17 @@ end
 
 val lowest_level: int
         (* Marked type: ty.level < lowest_level *)
-val pivot_level: int
-        (* Type marking: ty.level <- pivot_level - ty.level *)
+val not_marked_node: type_expr -> bool
+        (* Return true if a type node is not yet marked *)
+val flip_mark_node: type_expr -> unit
+        (* Mark a type node. No [repr]'ing *)
+val try_mark_node: type_expr -> bool
+        (* Mark a type node if it is not yet marked.
+           Return false if it was already marked *)
 val mark_type: type_expr -> unit
-        (* Mark a type *)
-val mark_type_node: type_expr -> unit
-        (* Mark a type node (but not its sons) *)
+        (* Mark a type recursively *)
 val mark_type_params: type_expr -> unit
-        (* Mark the sons of a type node *)
+        (* Mark the sons of a type node recursively *)
 val unmark_type: type_expr -> unit
 val unmark_type_decl: type_declaration -> unit
 val unmark_extension_constructor: extension_constructor -> unit
@@ -241,7 +247,6 @@ val set_row_field: row_field option ref -> row_field -> unit
 val set_univar: type_expr option ref -> type_expr -> unit
 val set_kind: field_kind option ref -> field_kind -> unit
 val set_commu: commutable ref -> commutable -> unit
-val set_typeset: TypeSet.t ref -> TypeSet.t -> unit
         (* Set references, logging the old value *)
 
 (**** Forward declarations ****)