Ekdohibs
/
ocaml
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

MAJ de la trace vis-a-vis du nouveau format de fermetures 

git-svn-id: http://caml.inria.fr/svn/ocaml/trunk@2092 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02
master
Xavier Leroy 1998-09-07 07:55:38 +00:00
parent a94bf88c24
commit c07dfb6f0d
3 changed files with 95 additions and 60 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

29
toplevel/topdirs.ml
View File

@ -162,6 +162,10 @@ let _ = Hashtbl.add directive_table "remove_printer"
external current_environment: unit -> Obj.t = "get_current_environment"
let tracing_function_ptr =
get_code_pointer
(Obj.repr (fun arg -> Trace.print_trace (current_environment()) arg))
let dir_trace lid =
try
let (path, desc) = Env.lookup_value lid !toplevel_env in
@ -174,7 +178,8 @@ let dir_trace lid =
| _ ->
let clos = eval_path path in
(* Nothing to do if it's not a closure *)
if Obj.is_block clos & Obj.tag clos = 250 then begin
if Obj.is_block clos &&
(Obj.tag clos = 250 || Obj.tag clos = 249) then begin
match is_traced clos with
Some opath ->
Printtyp.path path;
@ -183,20 +188,16 @@ let dir_trace lid =
print_newline()
| None ->
(* Instrument the old closure *)
let old_clos = copy_closure clos in
traced_functions :=
{ path = path;
closure = clos;
initial_closure = old_clos;
actual_code = get_code_pointer clos;
instrumented_fun =
instrument_closure !toplevel_env lid
desc.val_type
old_clos}
instrument_closure !toplevel_env lid desc.val_type }
:: !traced_functions;
(* Redirect the code field of the old closure *)
overwrite_closure clos
(Obj.repr (fun arg ->
Trace.print_trace (current_environment()) arg));
(* Redirect the code field of the closure to point
to the instrumentation function *)
set_code_pointer clos tracing_function_ptr;
Printtyp.longident lid; print_string " is now traced.";
print_newline()
end else begin
@ -217,7 +218,7 @@ let dir_untrace lid =
[]
| f :: rem ->
if Path.same f.path path then begin
overwrite_closure (eval_path path) f.initial_closure;
set_code_pointer (eval_path path) f.actual_code;
Printtyp.longident lid; print_string " is no longer traced.";
print_newline();
rem
@ -230,9 +231,9 @@ let dir_untrace lid =
let dir_untrace_all () =
List.iter
(fun f ->
overwrite_closure (eval_path f.path) f.initial_closure;
Printtyp.path f.path; print_string " is no longer traced.";
print_newline())
set_code_pointer (eval_path f.path) f.actual_code;
Printtyp.path f.path; print_string " is no longer traced.";
print_newline())
!traced_functions;
traced_functions := []

108
toplevel/trace.ml
View File

@ -20,11 +20,14 @@ open Types
open Printval
open Toploop
type codeptr = Obj.t
type traced_function =
{ path: Path.t;
closure: Obj.t;
initial_closure: Obj.t;
instrumented_fun: Obj.t }
{ 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)
@ -36,62 +39,89 @@ let is_traced clos =
| tf :: rem -> if tf.closure == clos then Some tf.path else is_traced rem
in is_traced !traced_functions
(* Make a copy of a closure *)
(* Get or overwrite the code pointer of a closure *)
let copy_closure cls =
let sz = Obj.size cls in
let nw = Obj.new_block 250 sz in
for i = 0 to sz - 1 do Obj.set_field nw i (Obj.field cls i) done;
nw
let get_code_pointer cls = Obj.field cls 0
(* Overwrite the code field of a closure by another *)
let set_code_pointer cls ptr = Obj.set_field cls 0 ptr
let overwrite_closure dst src =
Obj.set_field dst 0 (Obj.field src 0)
(* 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. *)
(* Return a closure that performs as the given closure, but also
traces its execution. *)
let invoke_traced_function codeptr env arg =
Meta.invoke_traced_function codeptr env arg
let rec instrument_closure env name clos_typ =
(* 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(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 env starred_name t2 in
| 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 ->
Obj.repr (fun arg ->
open_box 2;
Printtyp.longident name; print_string " <--"; print_space();
print_value !toplevel_env arg t1; close_box(); print_newline();
Printtyp.longident starred_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
let res = (Obj.magic clos_val : Obj.t -> Obj.t) arg in
open_box 2;
Printtyp.longident name; print_string " -->"; print_space();
print_value !toplevel_env res t2; close_box(); print_newline();
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 name; print_string " raises"; print_space();
print_exception (Obj.repr exn); close_box(); print_newline();
Printtyp.longident starred_name; print_string " raises";
print_space(); print_exception (Obj.repr exn); close_box();
print_newline();
raise exn))
| _ ->
(fun v -> v)
| _ -> (fun v -> v)
(* Given the address of a closure, find its instrumented version
and call it *)
(* 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(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_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
[] -> 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 =
(Obj.magic
(find_traced_closure clos !traced_functions).instrumented_fun :
Obj.t -> Obj.t)
arg
let f = find_traced_closure clos !traced_functions in
f.instrumented_fun f.actual_code clos arg

18
toplevel/trace.mli
View File

@ -13,16 +13,20 @@
(* The "trace" facility *)
type codeptr
type traced_function =
{ path: Path.t;
closure: Obj.t;
initial_closure: Obj.t;
instrumented_fun: Obj.t }
{ 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 *)
val traced_functions: traced_function list ref
val is_traced: Obj.t -> Path.t option
val copy_closure: Obj.t -> Obj.t
val overwrite_closure: Obj.t -> Obj.t -> unit
val get_code_pointer: Obj.t -> codeptr
val set_code_pointer: Obj.t -> codeptr -> unit
val instrument_closure:
Env.t -> Longident.t -> Types.type_expr -> Obj.t -> Obj.t
Env.t -> Longident.t -> Types.type_expr ->
codeptr -> Obj.t -> Obj.t -> Obj.t
val print_trace: Obj.t -> Obj.t -> Obj.t