1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
|
(**************************************************************************)
(* *)
(* OCaml *)
(* *)
(* 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 GNU Lesser General Public License version 2.1, with the *)
(* special exception on linking described in the file LICENSE. *)
(* *)
(**************************************************************************)
(* The "trace" facility *)
open Format
open Misc
open Longident
open Types
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 ppf l =
if l <> Asttypes.Nolabel then fprintf ppf "%s:" (Printtyp.string_of_label l)
(* If a function returns a functional value, wrap it into a trace code *)
let rec instrument_result env name ppf 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 _ -> fatal_error "Trace.instrument_result" in
let trace_res = instrument_result env starred_name ppf t2 in
(fun clos_val ->
Obj.repr (fun arg ->
if not !may_trace then
(Obj.magic clos_val : Obj.t -> Obj.t) arg
else begin
may_trace := false;
try
fprintf ppf "@[<2>%a <--@ %a%a@]@."
Printtyp.longident starred_name
print_label l
(print_value !toplevel_env arg) t1;
may_trace := true;
let res = (Obj.magic clos_val : Obj.t -> Obj.t) arg in
may_trace := false;
fprintf ppf "@[<2>%a -->@ %a@]@."
Printtyp.longident starred_name
(print_value !toplevel_env res) t2;
may_trace := true;
trace_res res
with exn ->
may_trace := false;
fprintf ppf "@[<2>%a raises@ %a@]@."
Printtyp.longident starred_name
(print_value !toplevel_env (Obj.repr exn)) Predef.type_exn;
may_trace := true;
raise exn
end))
| _ -> (fun v -> v)
(* Same as instrument_result, but for a toplevel closure (modified in place) *)
exception Dummy
let _ = Dummy
let instrument_closure env name ppf clos_typ =
match (Ctype.repr(Ctype.expand_head env clos_typ)).desc with
| Tarrow(l, t1, t2, _) ->
let trace_res = instrument_result env name ppf t2 in
(fun actual_code closure arg ->
if not !may_trace then begin
try invoke_traced_function actual_code closure arg
with Dummy -> assert false
(* do not remove handler, prevents tail-call to invoke_traced_ *)
end else begin
may_trace := false;
try
fprintf ppf "@[<2>%a <--@ %a%a@]@."
Printtyp.longident name
print_label l
(print_value !toplevel_env arg) t1;
may_trace := true;
let res = invoke_traced_function actual_code closure arg in
may_trace := false;
fprintf ppf "@[<2>%a -->@ %a@]@."
Printtyp.longident name
(print_value !toplevel_env res) t2;
may_trace := true;
trace_res res
with exn ->
may_trace := false;
fprintf ppf "@[<2>%a raises@ %a@]@."
Printtyp.longident name
(print_value !toplevel_env (Obj.repr exn)) Predef.type_exn;
may_trace := true;
raise exn
end)
| _ -> 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
|
