Skip to content

Commit cb997c2

Browse files
akabeakabe
authored
Merge pull request #182 from akabe/feature/trace
Migrate trace directive from the ocaml compiler
2 parents 44324de + cc49ebf commit cb997c2

File tree

5 files changed

+160
-3
lines changed

5 files changed

+160
-3
lines changed

‎jupyter/src/repl/compat.cppo.ml

Lines changed: 12 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -74,3 +74,15 @@ let reset_fatal_warnings () =
7474
#else
7575
()
7676
#endif
77+
78+
#if OCAML_VERSION < (4,14,0)
79+
let types_get_desc t = t.Types.desc
80+
#else
81+
let types_get_desc = Types.get_desc
82+
#endif
83+
84+
#if OCAML_VERSION < (4,13,0)
85+
let section_trace = "Tracing"
86+
#else
87+
let section_trace = Topdirs.section_trace
88+
#endif

‎jupyter/src/repl/dir_trace.ml

Lines changed: 129 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,129 @@
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+
17+
(** The trace for OCaml 4.13.0 or above.
18+
19+
[#trace] directive implemented at
20+
21+
- [toplevel/topdirs.ml] on 4.12.0-, and
22+
- [toplevel/byte/trace.ml] and [toplevel/byte/topmain.ml] on 4.13.0+.
23+
24+
This file is a part of [toplevel/byte/topmain.ml], migrated for
25+
ocaml-jupyter. *)
26+
27+
open Types
28+
open Trace
29+
open Toploop
30+
31+
external current_environment: unit -> Obj.t = "caml_get_current_environment"
32+
33+
let tracing_function_ptr =
34+
get_code_pointer
35+
(Obj.repr (fun arg -> Trace.print_trace (current_environment()) arg))
36+
37+
let dir_trace ppf lid =
38+
match Env.find_value_by_name lid !toplevel_env with
39+
| (path, desc) -> begin
40+
(* Check if this is a primitive *)
41+
match desc.Types.val_kind with
42+
| Types.Val_prim _ ->
43+
Format.fprintf ppf
44+
"%a is an external function and cannot be traced.@."
45+
Printtyp.longident lid
46+
| _ ->
47+
let clos = Toploop.eval_value_path !toplevel_env path in
48+
(* Nothing to do if it's not a closure *)
49+
if Obj.is_block clos
50+
&& (Obj.tag clos = Obj.closure_tag || Obj.tag clos = Obj.infix_tag)
51+
&& (match
52+
Compat.types_get_desc
53+
(Ctype.expand_head !toplevel_env desc.val_type)
54+
with Tarrow _ -> true | _ -> false)
55+
then begin
56+
match is_traced clos with
57+
| Some opath ->
58+
Format.fprintf ppf "%a is already traced (under the name %a).@."
59+
Printtyp.path path
60+
Printtyp.path opath
61+
| None ->
62+
(* Instrument the old closure *)
63+
traced_functions :=
64+
{ path = path;
65+
closure = clos;
66+
actual_code = get_code_pointer clos;
67+
instrumented_fun =
68+
instrument_closure
69+
!toplevel_env lid ppf desc.val_type }
70+
:: !traced_functions;
71+
(* Redirect the code field of the closure to point
72+
to the instrumentation function *)
73+
set_code_pointer clos tracing_function_ptr;
74+
Format.fprintf ppf "%a is now traced.@." Printtyp.longident lid
75+
end else
76+
Format.fprintf ppf "%a is not a function.@." Printtyp.longident lid
77+
end
78+
| exception Not_found ->
79+
Format.fprintf ppf "Unbound value %a.@." Printtyp.longident lid
80+
81+
let dir_untrace ppf lid =
82+
match Env.find_value_by_name lid !toplevel_env with
83+
| (path, _desc) ->
84+
let rec remove = function
85+
| [] ->
86+
Format.fprintf ppf "%a was not traced.@." Printtyp.longident lid;
87+
[]
88+
| f :: rem ->
89+
if Path.same f.path path then begin
90+
set_code_pointer f.closure f.actual_code;
91+
Format.fprintf ppf "%a is no longer traced.@."
92+
Printtyp.longident lid;
93+
rem
94+
end else f :: remove rem in
95+
traced_functions := remove !traced_functions
96+
| exception Not_found ->
97+
Format.fprintf ppf "Unbound value %a.@." Printtyp.longident lid
98+
99+
let dir_untrace_all ppf () =
100+
List.iter
101+
(fun f ->
102+
set_code_pointer f.closure f.actual_code;
103+
Format.fprintf ppf "%a is no longer traced.@." Printtyp.path f.path)
104+
!traced_functions;
105+
traced_functions := []
106+
107+
let add_directives ppf =
108+
let _ = add_directive "trace"
109+
(Directive_ident (dir_trace ppf))
110+
{
111+
section = Compat.section_trace;
112+
doc = "All calls to the function \
113+
named function-name will be traced.";
114+
} in
115+
116+
let _ = add_directive "untrace"
117+
(Directive_ident (dir_untrace ppf))
118+
{
119+
section = Compat.section_trace;
120+
doc = "Stop tracing the given function.";
121+
} in
122+
123+
let _ = add_directive "untrace_all"
124+
(Directive_none (dir_untrace_all ppf))
125+
{
126+
section = Compat.section_trace;
127+
doc = "Stop tracing all functions traced so far.";
128+
} in
129+
()

‎jupyter/src/repl/dune

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -8,6 +8,7 @@
88
Lwt_async_rewrite
99
Caml_args
1010
Error
11+
Dir_trace
1112
Compat)
1213
(flags ((:include %{workspace_root}/config/ocaml_flags.sexp)))
1314
(preprocess (pps lwt_ppx))

‎jupyter/src/repl/evaluation.cppo.ml

Lines changed: 4 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -26,7 +26,7 @@ open Format
2626
open Jupyter
2727

2828
let buffer = Buffer.create 256
29-
let ppf = formatter_of_buffer buffer
29+
let buffer_ppf = formatter_of_buffer buffer
3030

3131
(** {2 Initialization} *)
3232

@@ -45,7 +45,7 @@ let init_toploop () =
4545
try
4646
Toploop.initialize_toplevel_env ()
4747
with Env.Error _ | Typetexp.Error _ as exn ->
48-
Location.report_exception ppf exn ;
48+
Location.report_exception buffer_ppf exn ;
4949
exit 2
5050

5151
let init ?(preinit = ignore) ?init_file () =
@@ -57,6 +57,7 @@ let init ?(preinit = ignore) ?init_file () =
5757
Compenv.readenv ppf Compenv.Before_link ;
5858
if not (Caml_args.prepare ppf) then exit 2 ;
5959
init_toploop () ;
60+
Dir_trace.add_directives buffer_ppf ;
6061
preinit () ;
6162
begin match init_file with
6263
| None -> ()
@@ -88,7 +89,7 @@ let eval_phrase ~filename phrase =
8889
let phrase' = Compat.preprocess_phrase ~filename phrase in (* apply PPX *)
8990
let phrase' = Lwt_async_rewrite.rewrite phrase' in
9091
Env.reset_cache_toplevel () ;
91-
let is_ok = Toploop.execute_phrase true ppf phrase' in
92+
let is_ok = Toploop.execute_phrase true buffer_ppf phrase' in
9293
let message = Buffer.contents buffer in
9394
Buffer.clear buffer ;
9495
(is_ok, message)

‎test/repl/test_evaluation.ml

Lines changed: 14 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -67,6 +67,19 @@ let test__directive ctxt =
6767
assert_equal ~ctxt ~printer:[%show: status] SHELL_OK status ;
6868
assert_equal ~ctxt ~printer:[%show: reply list] expected actual
6969

70+
(* Implementation of [#trace] directive changes after OCaml 4.13.0. *)
71+
let test__trace_directive ctxt =
72+
let status, actual = eval "let f x = x ;; #trace f ;; f 10 ;;" in
73+
let expected = [
74+
iopub_success ~count:0 "val f : 'a -> 'a = <fun>\n";
75+
iopub_success ~count:0 "f is now traced.\n";
76+
iopub_success ~count:0 "f <-- <poly>\n\
77+
f --> <poly>\n\
78+
- : int = 10\n";
79+
] in
80+
assert_equal ~ctxt ~printer:[%show: status] SHELL_OK status ;
81+
assert_equal ~ctxt ~printer:[%show: reply list] expected actual
82+
7083
let test__external_command ctxt =
7184
let status, actual = eval "Sys.command \"ls -l >/dev/null 2>/dev/null\"" in
7285
let expected = [iopub_success ~count:0 "- : int = 0\n"] in
@@ -231,6 +244,7 @@ let suite =
231244
"simple_phrase" >:: test__simple_phrase;
232245
"multiple_phrases" >:: test__multiple_phrases;
233246
"directive" >:: test__directive;
247+
"#trace directive" >:: test__trace_directive;
234248
"external_command" >:: test__external_command;
235249
"syntax_error" >:: test__syntax_error;
236250
"unbound_value" >:: test__unbound_value;

0 commit comments

Comments
 (0)