rewrite the printing of Lazy values in toplevel/genprintval.ml

The code previously used Lazy.is_val to know whether the value was
already-evaluated (and, in this case, Lazy.force to extract this value
and print it more precisely). But it lies inside a functor that is
instantiated over different implementations of Obj, while
Lazy.{is_val,force} force the use of the Obj module of the standard
library. This could cause segfaults when this code is called from the
debugger, which instantiates it with a different Obj module talking
over a socket.

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

1 files changed, 37 insertions, 14 deletions

diff --git a/toplevel/genprintval.ml b/toplevel/genprintval.ml
index e03771b53..286890d11 100644
--- a/toplevel/genprintval.ml
+++ b/toplevel/genprintval.ml
@@ -299,17 +299,40 @@ module Make(O : OBJ)(EVP : EVALPATH with type valu = O.t) = struct
                 Oval_array []
           | Tconstr (path, [ty_arg], _)
             when Path.same path Predef.path_lazy_t ->
-             if not (Lazy.is_val (O.obj obj)) then Oval_stuff "<lazy>"
+             let obj_tag = O.tag obj in
+             (* Lazy values are represented in three possible ways:
+
+                1. a lazy thunk that is not yet forced has tag
+                   Obj.lazy_tag
+
+                2. a lazy thunk that has just been forced has tag
+                   Obj.forward_tag; its first field is the forced
+                   result, which we can print
+
+                3. when the GC moves a forced trunk with forward_tag,
+                   or when a thunk is directly created from a value,
+                   we get a third representation where the value is
+                   directly exposed, without the Obj.forward_tag
+                   (if its own tag is not ambiguous, that is neither
+                   lazy_tag nor forward_tag)
+
+                Note that using Lazy.is_val and Lazy.force would be
+                unsafe, because they use the Obj.* functions rather
+                than the O.* functions of the functor argument, and
+                would thus crash if called from the toplevel
+                (debugger/printval instantiates Genprintval.Make with
+                an Obj module talking over a socket).
+              *)
+             if obj_tag = Obj.lazy_tag then Oval_stuff "<lazy>"
              else begin
                  let forced_obj =
-                   (* we know that (Lazy.is_val (O.obj obj)),
-                      forcing will not block *)
-                   Lazy.force (O.obj obj) in
+                   if obj_tag = Obj.forward_tag then O.field obj 0 else obj
+                 in
                  (* calling oneself recursively on forced_obj risks
-                    having a false positive for cycle detection; indeed,
-                    if the value has been created with Lazy.from_val,
-                    it may be stored as-is instead of being wrapped in a
-                    forward pointer. It means that, for (lazy "foo"), we have
+                    having a false positive for cycle detection;
+                    indeed, in case (3) above, the value is stored
+                    as-is instead of being wrapped in a forward
+                    pointer. It means that, for (lazy "foo"), we have
                       forced_obj == obj
                     and it is easy to wrongly print (lazy <cycle>) in such
                     a case (PR#6669).
@@ -321,12 +344,12 @@ module Make(O : OBJ)(EVP : EVALPATH with type valu = O.t) = struct
                     itself. For this reason, we still "nest"
                     (detect head cycles) on forward tags.
                   *)
-                 let maybe_nest tree_of_val =
-                   if O.tag obj = Obj.forward_tag
-                   then nest tree_of_val
-                   else tree_of_val in
-                 let v = maybe_nest tree_of_val depth forced_obj ty_arg in
-                  Oval_constr (Oide_ident "lazy", [v])
+                 let v =
+                   if obj_tag = Obj.forward_tag
+                   then nest tree_of_val depth forced_obj ty_arg
+                   else      tree_of_val depth forced_obj ty_arg
+                 in
+                 Oval_constr (Oide_ident "lazy", [v])
                end
           | Tconstr(path, ty_list, _) -> begin
               try