diff --git a/src/debugger/inspect/inspect.ml b/src/debugger/inspect/inspect.ml index b6c37fc..f70dd00 100644 --- a/src/debugger/inspect/inspect.ml +++ b/src/debugger/inspect/inspect.ml @@ -1,4 +1,7 @@ open Debug_types +open Value_basic +open Value_simple +open Value_func type raw_value = Scene.obj * Types.type_expr @@ -11,7 +14,53 @@ type t = ; get_indexed : int -> t Lwt.t ; list_named : (string * t) list Lwt.t > +class opaque_block_value ~scene ~rv ~size = + object + inherit value + method! num_indexed = size + + method! get_indexed (idx : int) : value Lwt.t = + let%lwt fldval = Scene.get_field scene rv idx in + dyn_adopt scene fldval + + method to_short_string = "«opaque block»" + end + let () = + (Value_basic.dyn_adopter := + fun scene obj -> + let%lwt tag = Scene.get_tag scene obj in + if tag = Obj.string_tag then + let%lwt obj = Scene.marshal_obj scene obj in + Lwt.return (new string_value (Obj.magic obj)) + else if tag = Obj.int_tag then + let%lwt obj = Scene.marshal_obj scene obj in + Lwt.return (new int_value (Obj.magic obj)) + else if tag = Obj.double_tag then + let%lwt obj = Scene.marshal_obj scene obj in + Lwt.return (new float_value (Obj.magic obj)) + else if tag = Obj.closure_tag then + let%lwt pc, loc = + if Scene.is_block obj then + let%lwt pc, loc = Scene.get_closure_code scene obj in + Lwt.return (Some pc, loc) + else Lwt.return (None, None) + in + Lwt.return (new func_value ?pc ?loc ()) + else if tag = Obj.double_array_tag then + (* TODO: *) + Lwt.return unknown_value + else if tag = Obj.lazy_tag then (* TODO: *) + Lwt.return unknown_value + else if tag = Obj.abstract_tag then + Lwt.return unknown_value (* TODO: distinct abstract_value output? *) + else if tag = Obj.custom_tag then + Lwt.return unknown_value (* TODO: distinct custom_value output? can maybe extract identifier from custom_operations? *) + else if Scene.is_block obj then + let%lwt size = Scene.get_size scene obj in + Lwt.return (new opaque_block_value ~scene ~rv:obj ~size) + else Lwt.return unknown_value); + Value_basic.adopters := [ Value_simple.adopter; @@ -26,6 +75,8 @@ let () = let scope scene frame kind = match kind with - | `Stack -> (new Value_scope.local_scope_value ~scene ~frame ~kind:`Stack () :> t) - | `Heap -> (new Value_scope.local_scope_value ~scene ~frame ~kind:`Heap () :> t) + | `Stack -> + (new Value_scope.local_scope_value ~scene ~frame ~kind:`Stack () :> t) + | `Heap -> + (new Value_scope.local_scope_value ~scene ~frame ~kind:`Heap () :> t) | `Global -> (new Value_scope.global_scope_value ~scene ~frame () :> t) diff --git a/src/debugger/inspect/scene.ml b/src/debugger/inspect/scene.ml index 4f62830..28cd958 100644 --- a/src/debugger/inspect/scene.ml +++ b/src/debugger/inspect/scene.ml @@ -6,7 +6,6 @@ open Instruct open Debug_types type t = Controller.t * int64 - type obj = Local of Obj.t | Remote of Wire_protocol.remote_value let from_controller c = (c, c.time) @@ -146,13 +145,15 @@ let get_field (c, time) rv index = Lwt.return (Local (Obj.repr v))) let get_tag (c, time) rv = - match rv with - | Local v -> Lwt.return (Obj.tag v) - | Remote rv -> - _lock_conn (c, time) (fun conn -> - let%lwt hdr = Wire_protocol.get_header conn rv in - let tag = hdr land 0xff in - Lwt.return tag) + if not (is_block rv) then Lwt.return Obj.int_tag + else + match rv with + | Local v -> Lwt.return (Obj.tag v) + | Remote rv -> + _lock_conn (c, time) (fun conn -> + let%lwt hdr = Wire_protocol.get_header conn rv in + let tag = hdr land 0xff in + Lwt.return tag) let get_size (c, time) rv = match rv with diff --git a/src/debugger/inspect/value_basic.ml b/src/debugger/inspect/value_basic.ml index 1dd67be..463bc61 100644 --- a/src/debugger/inspect/value_basic.ml +++ b/src/debugger/inspect/value_basic.ml @@ -61,6 +61,12 @@ let adopters = value option Lwt.t) list) +let dyn_adopter: (Scene.t -> Scene.obj -> value Lwt.t) ref = + ref (fun _scene _obj -> Lwt.return unknown_value) + +let dyn_adopt scene obj = + (!dyn_adopter) scene obj + let adopt scene typenv obj ty = let rec resolve_type ty = match Types.get_desc ty with @@ -86,4 +92,4 @@ let adopt scene typenv obj ty = try%lwt !adopters |> List.to_seq |> Lwt_seq.find_map_s (fun adopter -> adopter scene typenv obj ty) - with Not_found -> Lwt.return unknown_value + with Not_found -> dyn_adopt scene obj