tools for debugging the type checker

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

4 files changed, 140 insertions, 20 deletions

diff --git a/typing/btype.ml b/typing/btype.ml
index 3548a2194b..01bd331285 100644
--- a/typing/btype.ml
+++ b/typing/btype.ml
@@ -295,6 +295,26 @@ let rec unmark_class_type =
                   (*  Memorization of abbreviation expansion *)
                   (*******************************************)
 
+(* Search whether the expansion has been memorized. *)
+let rec find_expans p1 = function
+    Mnil -> None
+  | Mcons (p2, ty0, ty, _) when Path.same p1 p2 -> Some ty
+  | Mcons (_, _, _, rem)   -> find_expans p1 rem
+  | Mlink {contents = rem} -> find_expans p1 rem
+
+(* debug: check for cycles in abbreviation. only works with -principal
+let rec check_expans visited ty =
+  let ty = repr ty in
+  assert (not (List.memq ty visited));
+  match ty.desc with
+    Tconstr (path, args, abbrev) ->
+      begin match find_expans path !abbrev with
+        Some ty' -> check_expans (ty :: visited) ty'
+      | None -> ()
+      end
+  | _ -> ()
+*)
+
 let memo = ref []
         (* Contains the list of saved abbreviation expansions. *)
 
@@ -305,12 +325,8 @@ let cleanup_abbrev () =
 
 let memorize_abbrev mem path v v' =
         (* Memorize the expansion of an abbreviation. *)
-  (* assert
-    begin match (repr v').desc with
-      Tconstr (path', _, _) when Path.same path path'-> false
-    | _ -> true
-    end; *)
   mem := Mcons (path, v, v', !mem);
+  (* check_expans [] v; *)
   memo := mem :: !memo
 
 let rec forget_abbrev_rec mem path =
@@ -328,20 +344,17 @@ let rec forget_abbrev_rec mem path =
 let forget_abbrev mem path =
   try mem := forget_abbrev_rec !mem path with Exit -> ()
 
-let rec check_abbrev_rec path = function
+(* debug: check for invalid abbreviations
+let rec check_abbrev_rec = function
     Mnil -> true
-  | Mcons (path', _, ty, rem) ->
-      if Path.same path path' && 
-        match repr ty with
-          {desc = Tconstr(path',_,_)} -> Path.same path path'
-        | _ -> false
-      then false
-      else check_abbrev_rec path rem
+  | Mcons (_, ty1, ty2, rem) ->
+      repr ty1 != repr ty2
   | Mlink mem' ->
-      check_abbrev_rec path !mem'
+      check_abbrev_rec !mem'
 
-let check_memorized_abbrevs path =
-  List.for_all (fun mem -> check_abbrev_rec path !mem) !memo
+let check_memorized_abbrevs () =
+  List.for_all (fun mem -> check_abbrev_rec !mem) !memo
+*)
 
                   (**********************************)
                   (*  Utilities for labels          *)
@@ -406,10 +419,8 @@ let log_change ch =
 let log_type ty =
   if ty.id <= !last_snapshot then log_change (Ctype (ty, ty.desc))
 let link_type ty ty' = log_type ty; ty.desc <- Tlink ty'
-(*match repr ty' with
-    {desc=Tconstr(path,_,_)} -> assert (check_memorized_abbrevs path)
-  | _ -> ()
-*)
+  (* ; assert (check_memorized_abbrevs ()) *)
+  (*  ; check_expans [] ty' *)
 let set_level ty level =
   if ty.id <= !last_snapshot then log_change (Clevel (ty, ty.level));
   ty.level <- level
diff --git a/typing/btype.mli b/typing/btype.mli
index b1ec9a8e4b..0b3658f609 100644
--- a/typing/btype.mli
+++ b/typing/btype.mli
@@ -97,6 +97,8 @@ val unmark_class_signature: class_signature -> unit
 
 (**** Memorization of abbreviation expansion ****)
 
+val find_expans: Path.t -> abbrev_memo -> type_expr option
+        (* Look up a memorized abbreviation *)
 val cleanup_abbrev: unit -> unit
         (* Flush the cache of abbreviation expansions.
            When some types are saved (using [output_value]), this
diff --git a/typing/printtyp.ml b/typing/printtyp.ml
index 2da21c2849..c17e1fd891 100644
--- a/typing/printtyp.ml
+++ b/typing/printtyp.ml
@@ -69,6 +69,112 @@ let rec path ppf = function
   | Papply(p1, p2) ->
       fprintf ppf "%a(%a)" path p1 path p2
 
+(* Print a raw type expression, with sharing *)
+
+let raw_list pr ppf = function
+    [] -> fprintf ppf "[]"
+  | a :: l ->
+      fprintf ppf "@[<1>[%a%t]@]" pr a
+        (fun ppf -> List.iter (fun x -> fprintf ppf ";@,%a" pr x) l)
+
+let rec safe_kind_repr v = function
+    Fvar {contents=Some k}  ->
+      if List.memq k v then "Fvar loop" else
+      safe_kind_repr (k::v) k
+  | Fvar _ -> "Fvar None"
+  | Fpresent -> "Fpresent"
+  | Fabsent -> "Fabsent"
+
+let rec safe_commu_repr v = function
+    Cok -> "Cok"
+  | Cunknown -> "Cunknown"
+  | Clink r ->
+      if List.memq r v then "Clink loop" else
+      safe_commu_repr (r::v) !r
+
+let rec safe_repr v = function
+    {desc = Tlink t} when not (List.memq t v) ->
+      safe_repr (t::v) t
+  | t -> t
+
+let rec list_of_memo = function
+    Mnil -> []
+  | Mcons (p, t1, t2, rem) -> (p,t1,t2) :: list_of_memo rem
+  | Mlink rem -> list_of_memo !rem
+
+let visited = ref []
+let rec raw_type ppf ty =
+  let ty = safe_repr [] ty in
+  if List.memq ty !visited then fprintf ppf "{id=%d}" ty.id else begin
+    visited := ty :: !visited;
+    fprintf ppf "@[<1>{id=%d;level=%d;desc=@,%a}@]" ty.id ty.level
+      raw_type_desc ty.desc
+  end
+and raw_type_list tl = raw_list raw_type tl
+and raw_type_desc ppf = function
+    Tvar -> fprintf ppf "Tvar"
+  | Tarrow(l,t1,t2,c) ->
+      fprintf ppf "@[<hov1>Tarrow(%s,@,%a,@,%a,@,%s)@]"
+        l raw_type t1 raw_type t2
+        (safe_commu_repr [] c)
+  | Ttuple tl ->
+      fprintf ppf "@[<1>Ttuple@,%a@]" raw_type_list tl
+  | Tconstr (p, tl, abbrev) ->
+      fprintf ppf "@[<hov1>Tconstr(@,%a,@,%a,@,%a)@]" path p
+        raw_type_list tl
+        (raw_list (fun ppf (p,t1,t2) ->
+          fprintf ppf "@[%a,@ %a,@ %a@]" path p raw_type t1 raw_type t2))
+        (list_of_memo !abbrev)
+  | Tobject (t, nm) ->
+      fprintf ppf "@[<hov1>Tobject(@,%a,@,@[<1>ref%t@])@]" raw_type t
+        (fun ppf ->
+          match !nm with None -> fprintf ppf " None"
+          | Some(p,tl) ->
+              fprintf ppf "(Some(@,%a,@,%a))" path p raw_type_list tl)
+  | Tfield (f, k, t1, t2) ->
+      fprintf ppf "@[<hov1>Tfield(@,%s,@,%s,@,%a,@,%a)@]" f
+        (safe_kind_repr [] k)
+        raw_type t1 raw_type t2
+  | Tnil -> fprintf ppf "Tnil"  
+  | Tlink t -> fprintf ppf "@[<1>Tlink@,%a@]" raw_type t
+  | Tsubst t -> fprintf ppf "@[<1>Tsubst@,%a@]" raw_type t
+  | Tunivar -> fprintf ppf "Tunivar"
+  | Tpoly (t, tl) ->
+      fprintf ppf "@[<hov1>Tpoly(@,%a,@,%a)@]"
+        raw_type t
+        raw_type_list tl
+  | Tvariant row ->
+      fprintf ppf
+        "@[<hov1>{@[%s@,%a;@]@ @[%s@,%a;@]@ %s%b;@ %s%b;@ @[<1>%s%t@]}@]"
+        "row_fields="
+        (raw_list (fun ppf (l, f) ->
+          fprintf ppf "@[%s,@ %a@]" l raw_field f))
+        row.row_fields
+        "row_more=" raw_type row.row_more
+        "row_closed=" row.row_closed
+        "row_fixed=" row.row_fixed
+        "row_name="
+        (fun ppf ->
+          match row.row_name with None -> fprintf ppf "None"
+          | Some(p,tl) ->
+              fprintf ppf "Some(@,%a,@,%a)" path p raw_type_list tl)
+
+and raw_field ppf = function
+    Rpresent None -> fprintf ppf "Rpresent None"
+  | Rpresent (Some t) -> fprintf ppf "@[<1>Rpresent(Some@,%a)@]" raw_type t
+  | Reither (c,tl,m,e) ->
+      fprintf ppf "@[<hov1>Reither(%b,@,%a,@,%b,@,@[<1>ref%t@])@]" c
+        raw_type_list tl m
+        (fun ppf ->
+          match !e with None -> fprintf ppf " None"
+          | Some f -> fprintf ppf "@,@[<1>(%a)@]" raw_field f)
+  | Rabsent -> fprintf ppf "Rabsent"
+
+let raw_type_expr ppf t =
+  visited := [];
+  raw_type ppf t;
+  visited := []
+
 (* Print a type expression *)
 
 let names = ref ([] : (type_expr * string) list)
diff --git a/typing/printtyp.mli b/typing/printtyp.mli
index 45d8762282..c02c13f0df 100644
--- a/typing/printtyp.mli
+++ b/typing/printtyp.mli
@@ -22,6 +22,7 @@ val longident: formatter -> Longident.t -> unit
 val ident: formatter -> Ident.t -> unit
 val tree_of_path: Path.t -> out_ident
 val path: formatter -> Path.t -> unit
+val raw_type_expr: formatter -> type_expr -> unit
 val reset: unit -> unit
 val mark_loops: type_expr -> unit
 val reset_and_mark_loops: type_expr -> unit