(**************************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy and Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. *) (* *) (* All rights reserved. This file is distributed under the terms of *) (* the GNU Lesser General Public License version 2.1, with the *) (* special exception on linking described in the file LICENSE. *) (* *) (**************************************************************************) (* To print values *) open Misc open Longident open Path open Types open Data_types open Outcometree module type OBJ = sig type t val repr : 'a -> t (* [base_obj] assumes that the value has a marshallable base type. *) val base_obj : t -> 'a val obj : t -> (Obj.t, string) result val is_block : t -> bool val tag : t -> int val size : t -> int val field : t -> int -> t val double_array_tag : int val double_field : t -> int -> float end module type EVALPATH = sig type valu val eval_address: Env.address -> valu exception Error val same_value: valu -> valu -> bool end let exn_printer path ppf exn = Format_doc.fprintf ppf "" Printtyp.Doc.path path (Printexc.to_string exn) module User_printer = struct type ('a, 'b) gen = | Zero of 'b | Succ of ('a -> ('a, 'b) gen) type t = | Simple of Types.type_expr * (Obj.t -> Outcometree.out_value) | Generic of Path.t * (int -> (int -> Obj.t -> Outcometree.out_value, Obj.t -> Outcometree.out_value) gen) (* The user-defined printers. Also used for some builtin types. *) let printers = ref ([ ( Pident(Ident.create_local "print_int"), Simple (Predef.type_int, (fun x -> Oval_int (Obj.obj x : int))) ); ( Pident(Ident.create_local "print_float"), Simple (Predef.type_float, (fun x -> Oval_float (Obj.obj x : float))) ); ( Pident(Ident.create_local "print_char"), Simple (Predef.type_char, (fun x -> Oval_char (Obj.obj x : char))) ); ( Pident(Ident.create_local "print_int32"), Simple (Predef.type_int32, (fun x -> Oval_int32 (Obj.obj x : int32))) ); ( Pident(Ident.create_local "print_nativeint"), Simple (Predef.type_nativeint, (fun x -> Oval_nativeint (Obj.obj x : nativeint))) ); ( Pident(Ident.create_local "print_int64"), Simple (Predef.type_int64, (fun x -> Oval_int64 (Obj.obj x : int64)) )) ] : (Path.t * t) list) let get_printers () = !printers let user_printer path f ppf x = Format_doc.deprecated_printer (fun ppf -> try f ppf x with | exn -> Format_doc.compat1 exn_printer path ppf exn ) ppf let install_simple path ty fn = let print_val ppf obj = user_printer path fn ppf obj in let printer obj = Oval_printer (fun ppf -> print_val ppf obj) in printers := (path, Simple (ty, printer)) :: !printers let install_generic_outcometree function_path constr_path fn = printers := (function_path, Generic (constr_path, fn)) :: !printers let install_generic_format function_path ty_path fn = let rec build gp depth = match gp with | Zero fn -> let out_printer obj = let printer ppf = user_printer function_path fn ppf obj in Oval_printer printer in Zero out_printer | Succ fn -> let print_val fn_arg = let print_arg ppf o = !Oprint.out_value ppf (fn_arg (depth+1) o) in build (fn print_arg) depth in Succ print_val in printers := (function_path, Generic (ty_path, build fn)) :: !printers let remove path = let rec remove = function | [] -> raise Not_found | ((p, _) as printer) :: rem -> if Path.same p path then rem else printer :: remove rem in printers := remove !printers end module type S = sig type t val outval_of_untyped_exception : t -> Outcometree.out_value val outval_of_value : int -> int -> (int -> t -> Types.type_expr -> Outcometree.out_value option) -> Env.t -> t -> type_expr -> Outcometree.out_value end module Make(O : OBJ)(EVP : EVALPATH with type valu = O.t) = struct type t = O.t module ObjTbl = Hashtbl.Make(struct type t = O.t let equal = (==) let hash x = try Hashtbl.hash x with _exn -> 0 end) let tree_of_name (name : string) = Oide_ident (Out_type.Out_name.create name) (* Given an exception value, we cannot recover its type, hence we cannot print its arguments in general. Here, we do a feeble attempt to print integer, string and float arguments... *) let outval_of_untyped_exception_args obj start_offset = if O.size obj > start_offset then begin let list = ref [] in for i = start_offset to O.size obj - 1 do let arg = O.field obj i in if not (O.is_block arg) then list := Oval_int (O.base_obj arg : int) :: !list (* Note: this could be a char or a constant constructor... *) else if O.tag arg = Obj.string_tag then list := Oval_string ((O.base_obj arg : string), max_int, Ostr_string) :: !list else if O.tag arg = Obj.double_tag then list := Oval_float (O.base_obj arg : float) :: !list else list := Oval_constr (tree_of_name "_", []) :: !list done; List.rev !list end else [] let outval_of_untyped_exception bucket = if O.tag bucket <> 0 then let name = (O.base_obj (O.field bucket 0) : string)in Oval_constr (tree_of_name name, []) else let name = (O.base_obj(O.field(O.field bucket 0) 0) : string) in let args = if (name = "Match_failure" || name = "Assert_failure" || name = "Undefined_recursive_module") && O.size bucket = 2 && O.tag(O.field bucket 1) = 0 then outval_of_untyped_exception_args (O.field bucket 1) 0 else outval_of_untyped_exception_args bucket 1 in Oval_constr (tree_of_name name, args) let out_exn path exn = Oval_printer (fun ppf -> exn_printer path ppf exn) (* Print a constructor or label, giving it the same prefix as the type it comes from. Attempt to omit the prefix if the type comes from a module that has been opened. *) let tree_of_qualified lookup_all get_path env ty_path name = (* If [ty_path] is [M.N.t] and [name] is [Foo], we want to find a short name for [M.N.Foo] in the current typing environment. Our strategy is to try [Foo], [N.Foo] and [M.N.Foo] in turn. *) (* Start by transforming the path [M.N.t] into the Longident [M.N.Foo]. *) let lid = match Untypeast.lident_of_path ty_path with | Lident _ -> Lident name | Ldot (p,_) -> Ldot(p, Location.mknoloc name) | x -> x in (* [candidates exn M.N.Foo] is [Foo; N.Foo; M.N.Foo]. @raise [exn] on functor application. *) let candidates apply_exn lid = (* [loop M.N [Foo]] is [[Foo]; [N; Foo]; [M; N; Foo]] *) let rec loop lid suff = match lid with | Lident last -> [suff; (last :: suff)] | Ldot({txt=p; _}, {txt=s; _}) -> suff :: loop p (s :: suff) | Lapply _ -> raise apply_exn in loop lid [] (* [[]; [Foo]; [N; Foo]; [M; N; Foo]] *) |> List.filter_map Longident.unflatten in (* A shorter name is correct (matches) if one of its possible interpretations (there may be several constructors with the same name at different types in a module) has the same type path as the one we are printing. *) let matches lid = match lookup_all lid env with | Error _ -> false | Ok cstrs -> List.exists (fun (cstr, _) -> Path.same (get_path cstr) ty_path ) cstrs in let rec tree_of_lident = function | Lident name -> tree_of_name name | Ldot ({txt=lid; _}, {txt=name; _}) -> Oide_dot (tree_of_lident lid, name) | Lapply ({txt=lid1; _}, {txt=lid2; _}) -> Oide_apply (tree_of_lident lid1, tree_of_lident lid2) in let exception Functor_application in match List.find matches (candidates Functor_application lid) with | exception (Functor_application | Not_found) -> tree_of_lident lid | best_lid -> tree_of_lident best_lid let tree_of_constr = tree_of_qualified (Env.lookup_all_constructors ~use:false ~loc:Location.none Env.Positive) Data_types.cstr_res_type_path and tree_of_label = tree_of_qualified (Env.lookup_all_labels ~use:false ~loc:Location.none Env.Construct) Data_types.lbl_res_type_path (* An abstract type *) let abstract_type = let id = Ident.create_local "abstract" in let ty = Btype.newgenty (Tconstr (Pident id, [], ref Mnil)) in ty (* The main printing function *) let outval_of_value max_steps max_depth check_depth env obj ty = let printer_steps = ref max_steps in let nested_values = ObjTbl.create 8 in let nest_gen err f depth obj ty = let repr = obj in if not (O.is_block repr) || (O.tag repr >= Obj.no_scan_tag) then f depth obj ty else if ObjTbl.mem nested_values repr then err else begin ObjTbl.add nested_values repr (); let ret = f depth obj ty in ObjTbl.remove nested_values repr; ret end in let nest f = nest_gen (Oval_stuff "") f in let rec tree_of_val depth obj ty = decr printer_steps; if !printer_steps < 0 || depth < 0 then Oval_ellipsis else begin match find_user_printer depth env ty with | user_printer -> begin match O.obj obj with | Ok v -> user_printer v | Error msg -> Oval_stuff msg end | exception Not_found -> match get_desc ty with | Tvar _ | Tunivar _ -> Oval_stuff "" | Tarrow _ -> Oval_stuff "" | Ttuple(labeled_tys) -> Oval_tuple (tree_of_labeled_val_list 0 depth obj labeled_tys) | Tconstr(path, ty_list, _) -> begin match get_desc (Ctype.expand_head env ty) with | Tconstr(path, [ty_arg], _) when Path.same path Predef.path_list -> tree_of_list depth obj ty_arg | Tconstr(path, [ty_arg], _) when Path.same path Predef.path_array -> tree_of_generic_array Asttypes.Mutable depth obj ty_arg | Tconstr(path, [ty_arg], _) when Path.same path Predef.path_iarray -> tree_of_generic_array Asttypes.Immutable depth obj ty_arg | Tconstr(path, [], _) when Path.same path Predef.path_string -> Oval_string ((O.base_obj obj : string), !printer_steps, Ostr_string) | Tconstr (path, [], _) when Path.same path Predef.path_bytes -> let s = Bytes.to_string (O.base_obj obj : bytes) in Oval_string (s, !printer_steps, Ostr_bytes) | Tconstr(path, [], _) when Path.same path Predef.path_floatarray -> Oval_floatarray (O.base_obj obj : floatarray) | Tconstr (path, [ty_arg], _) when Path.same path Predef.path_lazy_t -> tree_of_lazy depth obj ty_arg | _ -> match Env.find_type path env with | exception Not_found | {type_kind = Type_abstract _; type_manifest = None} -> Oval_stuff "" | {type_kind = Type_abstract _; type_manifest = Some body; type_params} -> tree_of_val depth obj (instantiate_type env type_params ty_list body) | {type_kind = Type_variant (constr_list,rep); type_params} -> tree_of_variant depth path type_params ty_list obj constr_list rep | {type_kind = Type_record(lbl_list, rep); type_params} -> tree_of_record depth path type_params ty_list obj lbl_list rep | {type_kind = Type_open} -> tree_of_extension path ty_list depth obj end | Tvariant row -> tree_of_polyvariant depth obj row | Tobject (_, _) -> Oval_stuff "" | Tsubst _ | Tfield(_, _, _, _) | Tnil | Tlink _ -> fatal_error "Printval.outval_of_value" | Tpoly (ty, _) -> tree_of_val (depth - 1) obj ty | Tpackage _ -> Oval_stuff "" end and tree_of_list depth obj ty_arg = if not (O.is_block obj) then Oval_list [] else match check_depth depth obj ty with | Some x -> x | None -> let rec tree_of_conses tree_list depth obj ty_arg = if !printer_steps < 0 || depth < 0 then Oval_ellipsis :: tree_list else if O.is_block obj then let tree = nest tree_of_val (depth - 1) (O.field obj 0) ty_arg in let next_obj = O.field obj 1 in nest_gen (Oval_stuff "" :: tree :: tree_list) (tree_of_conses (tree :: tree_list)) depth next_obj ty_arg else tree_list in Oval_list (List.rev (tree_of_conses [] depth obj ty_arg)) and tree_of_generic_array am depth obj ty_arg = let length = O.size obj in if length = 0 then Oval_array ([], am) else match check_depth depth obj ty with | Some x -> x | None -> let rec tree_of_items tree_list i = if !printer_steps < 0 || depth < 0 then Oval_ellipsis :: tree_list else if i < length then let tree = nest tree_of_val (depth - 1) (O.field obj i) ty_arg in tree_of_items (tree :: tree_list) (i + 1) else tree_list in Oval_array (List.rev (tree_of_items [] 0), am) and tree_of_lazy depth obj ty_arg = let obj_tag = O.tag obj in (* Lazy values are represented in several possible ways: 1. a lazy thunk that is not yet forced has tag Obj.lazy_tag 1bis. a lazy thunk that is in the process of being forced has tag Obj.forcing_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 "" else if obj_tag = Obj.forcing_tag then Oval_stuff "" else begin let forced_obj = 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, 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 ) in such a case (PR#6669). Unfortunately, there is a corner-case that *is* a real cycle: using unboxed types one can define type t = T : t Lazy.t -> t [@@unboxed] let rec x = lazy (T x) which creates a Forward_tagged block that points to itself. For this reason, we still "nest" (detect head cycles) on forward tags. *) 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_lazy v end and tree_of_variant depth path type_params ty_list obj constr_list rep = let unbx = (rep = Variant_unboxed) in let tag = if unbx then Cstr_unboxed else if O.is_block obj then Cstr_block(O.tag obj) else Cstr_constant(O.base_obj obj) (* immediate *) in match Datarepr.find_constr_by_tag tag constr_list with | exception Datarepr.Constr_not_found -> Oval_stuff "" | {cd_id;cd_args;cd_res} -> let type_params = match cd_res with Some t -> begin match get_desc t with Tconstr (_,params,_) -> params | _ -> assert false end | None -> type_params in begin match cd_args with | Cstr_tuple l -> let ty_args = instantiate_types env type_params ty_list l in tree_of_constr_with_args (tree_of_constr env path) (Ident.name cd_id) false 0 depth obj ty_args unbx | Cstr_record lbls -> let r = tree_of_record_fields depth env path type_params ty_list lbls 0 obj unbx in Oval_constr(tree_of_constr env path (Ident.name cd_id), [ r ]) end and tree_of_record depth path type_params ty_list obj lbl_list rep = match check_depth depth obj ty with | Some x -> x | None -> let pos = match rep with | Record_extension _ -> 1 | _ -> 0 in let unbx = match rep with Record_unboxed _ -> true | _ -> false in tree_of_record_fields depth env path type_params ty_list lbl_list pos obj unbx and tree_of_record_fields depth env path type_params ty_list lbl_list pos obj unboxed = let rec tree_of_fields pos = function | [] -> [] | {ld_id; ld_type} :: remainder -> let ty_arg = instantiate_type env type_params ty_list ld_type in let name = Ident.name ld_id in (* PR#5722: print full module path only for first record field *) let lid = if pos = 0 then tree_of_label env path name else tree_of_name name and v = if unboxed then tree_of_val (depth - 1) obj ty_arg else begin let fld = if O.tag obj = O.double_array_tag then O.repr (O.double_field obj pos) else O.field obj pos in nest tree_of_val (depth - 1) fld ty_arg end in (lid, v) :: tree_of_fields (pos + 1) remainder in Oval_record (tree_of_fields pos lbl_list) and tree_of_polyvariant depth obj row = if O.is_block obj then let tag : int = O.base_obj (O.field obj 0) in let rec find = function | (l, f) :: fields -> if Btype.hash_variant l = tag then match row_field_repr f with | Rpresent(Some ty) | Reither(_,[ty],_) -> let args = nest tree_of_val (depth - 1) (O.field obj 1) ty in Oval_variant (l, Some args) | _ -> find fields else find fields | [] -> Oval_stuff "" in find (row_fields row) else let tag : int = O.base_obj obj in let rec find = function | (l, _) :: fields -> if Btype.hash_variant l = tag then Oval_variant (l, None) else find fields | [] -> Oval_stuff "" in find (row_fields row) and tree_of_labeled_val_list start depth obj labeled_tys = let rec tree_list i = function | [] -> [] | (label, ty) :: labeled_tys -> let tree = nest tree_of_val (depth - 1) (O.field obj i) ty in (label, tree) :: tree_list (i + 1) labeled_tys in tree_list start labeled_tys and tree_of_val_list start depth obj ty_list = let rec tree_list i = function | [] -> [] | ty :: ty_list -> let tree = nest tree_of_val (depth - 1) (O.field obj i) ty in tree :: tree_list (i + 1) ty_list in tree_list start ty_list and tree_of_constr_with_args tree_of_cstr cstr_name inlined start depth obj ty_args unboxed = let lid = tree_of_cstr cstr_name in let args = if inlined || unboxed then match ty_args with | [ty] -> [ tree_of_val (depth - 1) obj ty ] | _ -> assert false else tree_of_val_list start depth obj ty_args in Oval_constr (lid, args) and tree_of_extension type_path ty_list depth bucket = let slot = if O.tag bucket <> 0 then bucket else O.field bucket 0 in let name = (O.base_obj (O.field slot 0) : string) in try (* Attempt to recover the constructor description for the exn from its name *) let lid = try Parse.longident (Lexing.from_string name) with (* The syntactic class for extension constructor names is an extended form of constructor "Longident.t"s that also includes module application (e.g [F(X).A]) *) | Syntaxerr.Error _ | Lexer.Error _ -> raise Not_found in let cstr = Env.find_constructor_by_name lid env in let path = match cstr.cstr_tag with Cstr_extension(p, _) -> p | _ -> raise Not_found in let addr = Env.find_constructor_address path env in (* Make sure this is the right exception and not an homonym, by evaluating the exception found and comparing with the identifier contained in the exception bucket *) if not (EVP.same_value slot (EVP.eval_address addr)) then raise Not_found; let type_params = match get_desc cstr.cstr_res with Tconstr (_,params,_) -> params | _ -> assert false in let args = instantiate_types env type_params ty_list cstr.cstr_args in tree_of_constr_with_args tree_of_name name (cstr.cstr_inlined <> None) 1 depth bucket args false with Not_found | EVP.Error -> match check_depth depth bucket ty with Some x -> x | None when Path.same type_path Predef.path_exn-> outval_of_untyped_exception bucket | None -> Oval_stuff "" and instantiate_type env type_params ty_list ty = try Ctype.apply env type_params ty ty_list with Ctype.Cannot_apply -> abstract_type and instantiate_types env type_params ty_list args = List.map (instantiate_type env type_params ty_list) args and find_user_printer depth env ty : Obj.t -> _ = let rec find = function | [] -> raise Not_found | (_name, User_printer.Simple (sch, printer)) :: remainder -> if Ctype.is_moregeneral env false sch ty then printer else find remainder | (_name, User_printer.Generic (path, fn)) :: remainder -> begin match get_desc (Ctype.expand_head env ty) with | Tconstr (p, args, _) when Path.same p path -> begin try apply_generic_printer path (fn depth) args with exn -> (fun _obj -> out_exn path exn) end | _ -> find remainder end in find (User_printer.get_printers ()) and apply_generic_printer path (printer : _ User_printer.gen) args : Obj.t -> _ = match (printer, args) with | (Zero fn, []) -> (fun obj -> try fn obj with exn -> out_exn path exn) | (Succ fn, arg :: args) -> let printer = fn (fun depth obj -> (* user printers receive a whole Obj.t value, but the printers they call on their arguments is [tree_of_val], which expects a possibly-remote O.t value. *) let obj : O.t = O.repr (obj : Obj.t) in tree_of_val depth obj arg) in apply_generic_printer path printer args | _ -> (fun _obj -> let printer ppf = Format_doc.fprintf ppf "" Printtyp.Doc.path path in Oval_printer printer) in nest tree_of_val max_depth obj ty end