98 lines
3.1 KiB
OCaml
98 lines
3.1 KiB
OCaml
(***********************************************************************)
|
|
(* *)
|
|
(* Caml Special Light *)
|
|
(* *)
|
|
(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
|
|
(* *)
|
|
(* Copyright 1995 Institut National de Recherche en Informatique et *)
|
|
(* Automatique. Distributed only by permission. *)
|
|
(* *)
|
|
(***********************************************************************)
|
|
|
|
(* $Id$ *)
|
|
|
|
(* The "trace" facility *)
|
|
|
|
open Format
|
|
open Misc
|
|
open Longident
|
|
open Typedtree
|
|
open Printval
|
|
open Toploop
|
|
|
|
type traced_function =
|
|
{ path: Path.t;
|
|
closure: Obj.t;
|
|
initial_closure: Obj.t;
|
|
instrumented_fun: Obj.t }
|
|
|
|
let traced_functions = ref ([] : traced_function list)
|
|
|
|
(* Check if a function is already traced *)
|
|
|
|
let is_traced path =
|
|
let rec is_traced = function
|
|
[] -> false
|
|
| tf :: rem -> Path.same path tf.path or is_traced rem
|
|
in is_traced !traced_functions
|
|
|
|
(* Make a copy of a closure *)
|
|
|
|
let copy_closure cls =
|
|
let sz = Obj.size cls in
|
|
let new = Obj.new_block 250 sz in
|
|
for i = 0 to sz - 1 do Obj.set_field new i (Obj.field cls i) done;
|
|
new
|
|
|
|
(* Overwrite the code field of a closure by another *)
|
|
|
|
let overwrite_closure dst src =
|
|
Obj.set_field dst 0 (Obj.field src 0)
|
|
|
|
(* Return a closure that performs as the given closure, but also
|
|
traces its execution. *)
|
|
|
|
let rec instrument_closure name clos_typ =
|
|
match Ctype.repr clos_typ with
|
|
Tarrow(t1, t2) ->
|
|
let starred_name =
|
|
match name with
|
|
Lident s -> Lident(s ^ "*")
|
|
| Ldot(lid, s) -> Ldot(lid, s ^ "*")
|
|
| Lapply(l1, l2) -> fatal_error "Trace.instrument_closure" in
|
|
let trace_res = instrument_closure starred_name t2 in
|
|
(fun clos_val ->
|
|
Obj.repr(fun arg ->
|
|
open_hovbox 2;
|
|
Printtyp.longident name; print_string " <--"; print_space();
|
|
print_value !toplevel_env arg t1; close_box(); print_newline();
|
|
try
|
|
let res = (Obj.magic clos_val : Obj.t -> Obj.t)(arg) in
|
|
open_hovbox 2;
|
|
Printtyp.longident name; print_string " -->"; print_space();
|
|
print_value !toplevel_env res t2; close_box(); print_newline();
|
|
trace_res res
|
|
with exn ->
|
|
open_hovbox 2;
|
|
Printtyp.longident name; print_string " raises"; print_space();
|
|
print_exception (Obj.repr exn); close_box(); print_newline();
|
|
raise exn))
|
|
| _ ->
|
|
(fun v -> v)
|
|
|
|
(* Given the address of a closure, find its instrumented version
|
|
and call it *)
|
|
|
|
let rec find_traced_closure clos = function
|
|
[] ->
|
|
fatal_error "Trace.find_traced_closure"
|
|
| f :: rem ->
|
|
if f.closure == clos then f else find_traced_closure clos rem
|
|
|
|
let print_trace clos arg =
|
|
(Obj.magic
|
|
(find_traced_closure clos !traced_functions).instrumented_fun :
|
|
Obj.t -> Obj.t)
|
|
arg
|
|
|