137 lines
4.9 KiB
OCaml
137 lines
4.9 KiB
OCaml
(***********************************************************************)
|
|
(* *)
|
|
(* Objective Caml *)
|
|
(* *)
|
|
(* Xavier Leroy, 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 Q Public License version 1.0. *)
|
|
(* *)
|
|
(***********************************************************************)
|
|
|
|
(* $Id$ *)
|
|
|
|
(* The "trace" facility *)
|
|
|
|
open Formatmsg
|
|
open Misc
|
|
open Longident
|
|
open Types
|
|
open Printval
|
|
open Toploop
|
|
|
|
type codeptr = Obj.t
|
|
|
|
type traced_function =
|
|
{ path: Path.t; (* Name under which it is traced *)
|
|
closure: Obj.t; (* Its function closure (patched) *)
|
|
actual_code: codeptr; (* Its original code pointer *)
|
|
instrumented_fun: codeptr -> Obj.t -> Obj.t -> Obj.t }
|
|
(* Printing function *)
|
|
|
|
let traced_functions = ref ([] : traced_function list)
|
|
|
|
(* Check if a function is already traced *)
|
|
|
|
let is_traced clos =
|
|
let rec is_traced = function
|
|
[] -> None
|
|
| tf :: rem -> if tf.closure == clos then Some tf.path else is_traced rem
|
|
in is_traced !traced_functions
|
|
|
|
(* Get or overwrite the code pointer of a closure *)
|
|
|
|
let get_code_pointer cls = Obj.field cls 0
|
|
|
|
let set_code_pointer cls ptr = Obj.set_field cls 0 ptr
|
|
|
|
(* Call a traced function (use old code pointer, but new closure as
|
|
environment so that recursive calls are also traced).
|
|
It is necessary to wrap Meta.invoke_traced_function in an ML function
|
|
so that the RETURN at the end of the ML wrapper takes us to the
|
|
code of the function. *)
|
|
|
|
let invoke_traced_function codeptr env arg =
|
|
Meta.invoke_traced_function codeptr env arg
|
|
|
|
let print_label l =
|
|
if l <> "" then begin
|
|
print_string l;
|
|
print_char ':'
|
|
end
|
|
|
|
(* If a function returns a functional value, wrap it into a trace code *)
|
|
|
|
let rec instrument_result env name clos_typ =
|
|
match (Ctype.repr(Ctype.expand_head env clos_typ)).desc with
|
|
Tarrow(l, 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_result" in
|
|
let trace_res = instrument_result env starred_name t2 in
|
|
(fun clos_val ->
|
|
Obj.repr (fun arg ->
|
|
open_box 2;
|
|
Printtyp.longident starred_name;
|
|
print_string " <--"; print_space();
|
|
print_label l;
|
|
print_value !toplevel_env arg t1;
|
|
close_box(); print_newline();
|
|
try
|
|
let res = (Obj.magic clos_val : Obj.t -> Obj.t) arg in
|
|
open_box 2;
|
|
Printtyp.longident starred_name;
|
|
print_string " -->"; print_space();
|
|
print_value !toplevel_env res t2;
|
|
close_box(); print_newline();
|
|
trace_res res
|
|
with exn ->
|
|
open_box 2;
|
|
Printtyp.longident starred_name; print_string " raises";
|
|
print_space(); print_exception (Obj.repr exn); close_box();
|
|
print_newline();
|
|
raise exn))
|
|
| _ -> (fun v -> v)
|
|
|
|
(* Same as instrument_result, but for a toplevel closure (modified in place) *)
|
|
|
|
let instrument_closure env name clos_typ =
|
|
match (Ctype.repr(Ctype.expand_head env clos_typ)).desc with
|
|
Tarrow(l, t1, t2) ->
|
|
let trace_res = instrument_result env name t2 in
|
|
(fun actual_code closure arg ->
|
|
open_box 2;
|
|
Printtyp.longident name; print_string " <--"; print_space();
|
|
print_label l;
|
|
print_value !toplevel_env arg t1;
|
|
close_box(); print_newline();
|
|
try
|
|
let res = invoke_traced_function actual_code closure arg in
|
|
open_box 2;
|
|
Printtyp.longident name; print_string " -->"; print_space();
|
|
print_value !toplevel_env res t2;
|
|
close_box(); print_newline();
|
|
trace_res res
|
|
with exn ->
|
|
open_box 2;
|
|
Printtyp.longident name; print_string " raises";
|
|
print_space(); print_exception (Obj.repr exn); close_box();
|
|
print_newline();
|
|
raise exn)
|
|
| _ -> assert false
|
|
|
|
(* Given the address of a closure, find its tracing info *)
|
|
|
|
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
|
|
|
|
(* Trace the application of an (instrumented) closure to an argument *)
|
|
|
|
let print_trace clos arg =
|
|
let f = find_traced_closure clos !traced_functions in
|
|
f.instrumented_fun f.actual_code clos arg
|