1 (**************************************************************************)
2 (* *)
3 (* OCaml *)
4 (* *)
5 (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
6 (* *)
7 (* Copyright 1996 Institut National de Recherche en Informatique et *)
8 (* en Automatique. *)
9 (* *)
10 (* All rights reserved. This file is distributed under the terms of *)
11 (* the GNU Lesser General Public License version 2.1, with the *)
12 (* special exception on linking described in the file LICENSE. *)
13 (* *)
14 (**************************************************************************)
15
16 (* The "trace" facility *)
17
18 open Format
19 open Misc
20 open Longident
21 open Types
22 open Toploop
23
24 type codeptr = Obj.t
25
26 type traced_function =
27 { path: Path.t; (* Name under which it is traced *)
28 closure: Obj.t; (* Its function closure (patched) *)
29 actual_code: codeptr; (* Its original code pointer *)
30 instrumented_fun: codeptr -> Obj.t -> Obj.t -> Obj.t }
31 (* Printing function *)
32
33 let traced_functions = ref ([] : traced_function list)
34
35 (* Check if a function is already traced *)
36
37 let is_traced clos =
38 let rec is_traced = function
39 [] -> None
40 | tf :: rem -> if tf.closure == clos then Some tf.path else is_traced rem
41 in is_traced !traced_functions
42
43 (* Get or overwrite the code pointer of a closure *)
44
45 let get_code_pointer cls = Obj.field cls 0
46
47 let set_code_pointer cls ptr = Obj.set_field cls 0 ptr
48
49 (* Call a traced function (use old code pointer, but new closure as
50 environment so that recursive calls are also traced).
51 It is necessary to wrap Meta.invoke_traced_function in an ML function
52 so that the RETURN at the end of the ML wrapper takes us to the
53 code of the function. *)
54
55 let invoke_traced_function codeptr env arg =
56 Meta.invoke_traced_function codeptr env arg
57
58 let print_label ppf l =
59 if l <> Asttypes.Nolabel then fprintf ppf "%s:" (Printtyp.string_of_label l)
60
61 (* If a function returns a functional value, wrap it into a trace code *)
62
63 let rec instrument_result env name ppf clos_typ =
64 match (Ctype.repr(Ctype.expand_head env clos_typ)).desc with
65 | Tarrow(l, t1, t2, _) ->
66 let starred_name =
67 match name with
68 | Lident s -> Lident(s ^ "*")
69 | Ldot(lid, s) -> Ldot(lid, s ^ "*")
70 | Lapply _ -> fatal_error "Trace.instrument_result" in
71 let trace_res = instrument_result env starred_name ppf t2 in
72 (fun clos_val ->
73 Obj.repr (fun arg ->
74 if not !may_trace then
75 (Obj.magic clos_val : Obj.t -> Obj.t) arg
76 else begin
77 may_trace := false;
78 try
79 fprintf ppf "@[<2>%a <--@ %a%a@]@."
80 Printtyp.longident starred_name
81 print_label l
82 (print_value !toplevel_env arg) t1;
83 may_trace := true;
84 let res = (Obj.magic clos_val : Obj.t -> Obj.t) arg in
85 may_trace := false;
86 fprintf ppf "@[<2>%a -->@ %a@]@."
87 Printtyp.longident starred_name
88 (print_value !toplevel_env res) t2;
89 may_trace := true;
90 trace_res res
91 with exn ->
92 may_trace := false;
93 fprintf ppf "@[<2>%a raises@ %a@]@."
94 Printtyp.longident starred_name
95 (print_value !toplevel_env (Obj.repr exn)) Predef.type_exn;
96 may_trace := true;
97 raise exn
98 end))
99 | _ -> (fun v -> v)
100
101 (* Same as instrument_result, but for a toplevel closure (modified in place) *)
102
103 exception Dummy
104 let _ = Dummy
105
106 let instrument_closure env name ppf clos_typ =
107 match (Ctype.repr(Ctype.expand_head env clos_typ)).desc with
108 | Tarrow(l, t1, t2, _) ->
109 let trace_res = instrument_result env name ppf t2 in
110 (fun actual_code closure arg ->
111 if not !may_trace then begin
112 try invoke_traced_function actual_code closure arg
113 with Dummy -> assert false
114 (* do not remove handler, prevents tail-call to invoke_traced_ *)
115 end else begin
116 may_trace := false;
117 try
118 fprintf ppf "@[<2>%a <--@ %a%a@]@."
119 Printtyp.longident name
120 print_label l
121 (print_value !toplevel_env arg) t1;
122 may_trace := true;
123 let res = invoke_traced_function actual_code closure arg in
124 may_trace := false;
125 fprintf ppf "@[<2>%a -->@ %a@]@."
126 Printtyp.longident name
127 (print_value !toplevel_env res) t2;
128 may_trace := true;
129 trace_res res
130 with exn ->
131 may_trace := false;
132 fprintf ppf "@[<2>%a raises@ %a@]@."
133 Printtyp.longident name
134 (print_value !toplevel_env (Obj.repr exn)) Predef.type_exn;
135 may_trace := true;
136 raise exn
137 end)
138 | _ -> assert false
139
140 (* Given the address of a closure, find its tracing info *)
141
142 let rec find_traced_closure clos = function
143 | [] -> fatal_error "Trace.find_traced_closure"
144 | f :: rem -> if f.closure == clos then f else find_traced_closure clos rem
145
146 (* Trace the application of an (instrumented) closure to an argument *)
147
148 let print_trace clos arg =
149 let f = find_traced_closure clos !traced_functions in
150 f.instrumented_fun f.actual_code clos arg
151