Expanding the usual compiler's type-based optimisations to private abbreviations.

git-svn-id: http://caml.inria.fr/svn/ocaml/trunk@8474 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02

9 files changed, 72 insertions, 14 deletions

diff --git a/Changes b/Changes
index 154b9c677a..41fa2e5516 100644
--- a/Changes
+++ b/Changes
@@ -1,9 +1,12 @@
 Objective Caml 3.11.0:
 ----------------------
 
+Language features:
+- Introduction of private abbreviation types, for abstracting the actual
+  manifest type in type abbreviations.
+
 Standard library:
-- Scanf
-    debunking of meta format implementation.
+- Scanf library: debunking of meta format implementation.
 
 Objective Caml 3.10.0:
 ----------------------
diff --git a/boot/ocamlc b/boot/ocamlc
index e9536bf757..6285c507d6 100755
--- a/boot/ocamlc
+++ b/boot/ocamlc
diff --git a/boot/ocamldep b/boot/ocamldep
index 8a3a3575f2..bed3b40ce2 100755
--- a/boot/ocamldep
+++ b/boot/ocamldep
diff --git a/boot/ocamllex b/boot/ocamllex
index e5d020e8f6..4020c03139 100755
--- a/boot/ocamllex
+++ b/boot/ocamllex
diff --git a/bytecomp/typeopt.ml b/bytecomp/typeopt.ml
index a7ee4cf1a5..c685d40d78 100644
--- a/bytecomp/typeopt.ml
+++ b/bytecomp/typeopt.ml
@@ -24,14 +24,14 @@ open Lambda
 
 let has_base_type exp base_ty_path =
   let exp_ty =
-    Ctype.expand_head exp.exp_env (Ctype.correct_levels exp.exp_type) in
+    Ctype.expand_head_opt exp.exp_env (Ctype.correct_levels exp.exp_type) in
   match Ctype.repr exp_ty with
     {desc = Tconstr(p, _, _)} -> Path.same p base_ty_path
   | _ -> false
 
 let maybe_pointer exp =
   let exp_ty =
-    Ctype.expand_head exp.exp_env (Ctype.correct_levels exp.exp_type) in
+    Ctype.expand_head_opt exp.exp_env (Ctype.correct_levels exp.exp_type) in
   match (Ctype.repr exp_ty).desc with
     Tconstr(p, args, abbrev) ->
       not (Path.same p Predef.path_int) &&
@@ -50,7 +50,7 @@ let maybe_pointer exp =
   | _ -> true
 
 let array_element_kind env ty =
-  let ty = Ctype.repr (Ctype.expand_head env ty) in
+  let ty = Ctype.repr (Ctype.expand_head_opt env ty) in
   match ty.desc with
     Tvar ->
       Pgenarray
@@ -85,7 +85,7 @@ let array_element_kind env ty =
       Paddrarray
 
 let array_kind_gen ty env =
-  let array_ty = Ctype.expand_head env (Ctype.correct_levels ty) in
+  let array_ty = Ctype.expand_head_opt env (Ctype.correct_levels ty) in
   match (Ctype.repr array_ty).desc with
     Tconstr(p, [elt_ty], _) | Tpoly({desc = Tconstr(p, [elt_ty], _)}, _)
     when Path.same p Predef.path_array ->
@@ -125,7 +125,7 @@ let layout_table =
    "fortran_layout", Pbigarray_fortran_layout]
 
 let bigarray_kind_and_layout exp =
-  let ty = Ctype.repr (Ctype.expand_head exp.exp_env exp.exp_type) in
+  let ty = Ctype.repr (Ctype.expand_head_opt exp.exp_env exp.exp_type) in
   match ty.desc with
     Tconstr(p, [caml_type; elt_type; layout_type], abbrev) ->
       (bigarray_decode_type elt_type kind_table Pbigarray_unknown,
diff --git a/typing/ctype.ml b/typing/ctype.ml
index 69ae27b27f..0ff1ba45fa 100644
--- a/typing/ctype.ml
+++ b/typing/ctype.ml
@@ -575,7 +575,7 @@ let rec generalize_spine ty =
       generalize_spine ty'
   | _ -> ()
 
-let try_expand_once' = (* Forward declaration *)
+let forward_try_expand_once = (* Forward declaration *)
   ref (fun env ty -> raise Cannot_expand)
 
 (*
@@ -597,7 +597,7 @@ let rec update_level env level ty =
       Tconstr(p, tl, abbrev)  when level < Path.binding_time p ->
         (* Try first to replace an abbreviation by its expansion. *)
         begin try
-          link_type ty (!try_expand_once' env ty);
+          link_type ty (!forward_try_expand_once env ty);
           update_level env level ty
         with Cannot_expand ->
           (* +++ Levels should be restored... *)
@@ -1067,7 +1067,7 @@ let check_abbrev_env env =
    4. The expansion requires the expansion of another abbreviation,
       and this other expansion fails.
 *)
-let expand_abbrev env ty =
+let expand_abbrev_gen find_type_expansion env ty =
   check_abbrev_env env;
   match ty with
     {desc = Tconstr (path, args, abbrev); level = level} ->
@@ -1086,7 +1086,7 @@ let expand_abbrev env ty =
           ty
       | None ->
           let (params, body) =
-            try Env.find_type_expansion path env with Not_found ->
+            try find_type_expansion path env with Not_found ->
               raise Cannot_expand
           in
           let ty' = subst env level abbrev (Some ty) params args body in
@@ -1101,6 +1101,8 @@ let expand_abbrev env ty =
   | _ ->
       assert false
 
+let expand_abbrev = expand_abbrev_gen Env.find_type_expansion
+
 let safe_abbrev env ty =
   let snap = Btype.snapshot () in
   try ignore (expand_abbrev env ty); true
@@ -1114,7 +1116,7 @@ let try_expand_once env ty =
     Tconstr _ -> repr (expand_abbrev env ty)
   | _ -> raise Cannot_expand
 
-let _ = try_expand_once' := try_expand_once
+let _ = forward_try_expand_once := try_expand_once
 
 (* Fully expand the head of a type.
    Raise Cannot_expand if the type cannot be expanded.
@@ -1142,6 +1144,34 @@ let expand_head env ty =
     Btype.backtrack snap;
     repr ty
 
+(* Implementing function [expand_head_opt], the compiler's own version of
+   [expand_head] used for type-based optimisations.
+   [expand_head_opt] uses [Env.find_type_expansion_opt] to access the
+   normally hidden manifest type information of private abstract types. *)
+
+let expand_abbrev_opt = expand_abbrev_gen Env.find_type_expansion_opt
+
+let try_expand_once_opt env ty =
+  let ty = repr ty in
+  match ty.desc with
+    Tconstr _ -> repr (expand_abbrev_opt env ty)
+  | _ -> raise Cannot_expand
+
+let rec try_expand_head_opt env ty =
+  let ty' = try_expand_once_opt env ty in
+  begin try
+    try_expand_head_opt env ty'
+  with Cannot_expand ->
+    ty'
+  end
+
+let expand_head_opt env ty =
+  let snap = Btype.snapshot () in
+  try try_expand_head_opt env ty
+  with Cannot_expand | Unify _ -> (* expand_head shall never fail *)
+    Btype.backtrack snap;
+    repr ty
+
 (* Make sure that the type parameters of the type constructor [ty]
    respect the type constraints *)
 let enforce_constraints env ty =
diff --git a/typing/ctype.mli b/typing/ctype.mli
index ffc8b872e2..87d43aa463 100644
--- a/typing/ctype.mli
+++ b/typing/ctype.mli
@@ -131,6 +131,9 @@ val apply:
 
 val expand_head_once: Env.t -> type_expr -> type_expr
 val expand_head: Env.t -> type_expr -> type_expr
+val expand_head_opt: Env.t -> type_expr -> type_expr
+(** The compiler's own version of [expand_head] necessary for type-based
+    optimisations. *)
 val full_expand: Env.t -> type_expr -> type_expr
 
 val enforce_constraints: Env.t -> type_expr -> unit
diff --git a/typing/env.ml b/typing/env.ml
index bfa73e7d5a..2075f8cf38 100644
--- a/typing/env.ml
+++ b/typing/env.ml
@@ -259,11 +259,30 @@ and find_class =
 and find_cltype =
   find (fun env -> env.cltypes) (fun sc -> sc.comp_cltypes)
 
+(* Find the manifest type associated to a type when appropriate:
+   - the type should be public or should have a private row,
+   - the type should have an associated manifest type. *)
 let find_type_expansion path env =
   let decl = find_type path env in
   match decl.type_manifest with
-  | Some body when decl.type_private = Public || Btype.has_constr_row body ->
-      (decl.type_params, body)
+  | Some body when decl.type_private = Public
+              || Btype.has_constr_row body -> (decl.type_params, body)
+  (* The manifest type of Private abstract data types without
+     private row are still considered unknown to the type system.
+     Hence, this case is caught by the following clause that also handles
+     purely abstract data types without manifest type definition. *)
+  | _ -> raise Not_found
+
+(* Find the manifest type information associated to a type, i.e.
+   the necessary information for the compiler's type-based optimisations.
+   In particular, the manifest type associated to a private abstract type
+   is revealed for the sake of compiler's type-based optimisations. *)
+let find_type_expansion_opt path env =
+  let decl = find_type path env in
+  match decl.type_manifest with
+  (* The manifest type of Private abstract data types can still get
+     an approximation using their manifest type. *)
+  | Some body -> (decl.type_params, body)
   | _ -> raise Not_found
 
 let find_modtype_expansion path env =
diff --git a/typing/env.mli b/typing/env.mli
index e27dcfceea..404f9b8870 100644
--- a/typing/env.mli
+++ b/typing/env.mli
@@ -32,6 +32,9 @@ val find_class: Path.t -> t -> class_declaration
 val find_cltype: Path.t -> t -> cltype_declaration
 
 val find_type_expansion: Path.t -> t -> type_expr list * type_expr
+val find_type_expansion_opt: Path.t -> t -> type_expr list * type_expr
+(* Find the manifest type information associated to a type for the sake
+   of the compiler's type-based optimisations. *)
 val find_modtype_expansion: Path.t -> t -> Types.module_type
 
 (* Lookup by long identifiers *)