You can not select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
133 lines
4.3 KiB
133 lines
4.3 KiB
(*
|
|
* Copyright (c) Facebook, Inc. and its affiliates.
|
|
*
|
|
* This source code is licensed under the MIT license found in the
|
|
* LICENSE file in the root directory of this source tree.
|
|
*)
|
|
|
|
(** Extension point rewriter for debug trace logging
|
|
|
|
This ppx rewriter declares a [--debug] command line option, to be passed
|
|
by the build system in debug but not optimized build modes. Setting the
|
|
[PPX_TRACE_ENABLED] environment variable to [1] or [true] has the same
|
|
effect as passing [--debug].
|
|
|
|
It rewrites [\[%Trace.info f\]] to a call
|
|
[\[Trace.info mod_name fun_name f\]] where [mod_name] and [fun_name] are
|
|
the enclosing module and function names in the parsetree. This is only
|
|
done in debug mode, if [--debug] is not passed, then [\[%Trace.info f\]]
|
|
is rewritten to [()].
|
|
|
|
Similarly, [\[%Trace.call\]] is rewritten to a call to [Trace.call] or
|
|
[()], and [\[%Trace.retn\]] to a call to [Trace.retn] or [Fn.id].
|
|
|
|
For example, this enables writing
|
|
|
|
{[
|
|
[%Trace.call fun {pf} -> pf "%a" pp_arg_type arg]
|
|
;
|
|
func arg
|
|
|>
|
|
[%Trace.retn fun {pf} -> pf "%a" pp_result_type]
|
|
]}
|
|
|
|
to trace calls to [f] in debug mode while completely compiling out the
|
|
debug code in non-debug builds.
|
|
|
|
This mechanism can also be used e.g. to dynamically check assertions
|
|
only in debug mode.
|
|
|
|
Additionally, [\[%debug\]] is rewritten to the compile-time boolean
|
|
constant determined by whether or not [--debug] is passed. *)
|
|
|
|
open Ppxlib
|
|
open Ast_builder.Default
|
|
module Ast_mapper = Selected_ast.Ast.Ast_mapper
|
|
|
|
let debug =
|
|
ref
|
|
( match Sys.getenv_opt "PPX_TRACE_ENABLED" with
|
|
| Some ("1" | "true") -> true
|
|
| _ -> false )
|
|
|
|
;;
|
|
Driver.add_arg "--debug" (Arg.Set debug) ~doc:"Enable debug tracing output"
|
|
|
|
let rec get_fun_name pat =
|
|
match pat.ppat_desc with
|
|
| Ppat_var {txt; _} -> txt
|
|
| Ppat_alias (pat, _) | Ppat_constraint (pat, _) -> get_fun_name pat
|
|
| _ ->
|
|
Location.raise_errorf ~loc:pat.ppat_loc
|
|
"Unexpected pattern in binding containing [%%Trace]: %a"
|
|
(fun f p ->
|
|
Ocaml_common.Pprintast.pattern f
|
|
(Selected_ast.To_ocaml.copy_pattern p) )
|
|
pat
|
|
|
|
let vb_stack_with, vb_stack_top =
|
|
let stack = ref [] in
|
|
let with_ x ~f =
|
|
stack := x :: !stack ;
|
|
let r = f () in
|
|
stack := List.tl !stack ;
|
|
r
|
|
in
|
|
let top () = List.hd !stack in
|
|
(with_, top)
|
|
|
|
let mapper =
|
|
let value_binding (m : Ast_mapper.mapper) vb =
|
|
vb_stack_with vb.pvb_pat ~f:(fun () ->
|
|
Ast_mapper.default_mapper.value_binding m vb )
|
|
in
|
|
let expr (m : Ast_mapper.mapper) exp =
|
|
let append_here_args args =
|
|
let mod_name = evar ~loc:Location.none "Caml.__MODULE__" in
|
|
let fun_name =
|
|
estring ~loc:Location.none (get_fun_name (vb_stack_top ()))
|
|
in
|
|
(Nolabel, mod_name) :: (Nolabel, fun_name) :: args
|
|
in
|
|
match exp.pexp_desc with
|
|
| Pexp_extension ({txt= "debug"; loc}, PStr []) -> ebool ~loc !debug
|
|
| Pexp_extension
|
|
( { txt=
|
|
( "Trace.info" | "Trace.infok" | "Trace.printf"
|
|
| "Trace.fprintf" | "Trace.kprintf" ) as txt
|
|
; loc }
|
|
, PStr [{pstr_desc= Pstr_eval (arg, []); _}] ) ->
|
|
if not !debug then eunit ~loc:exp.pexp_loc
|
|
else
|
|
let args =
|
|
match arg.pexp_desc with
|
|
| Pexp_apply (op, args) -> (Nolabel, op) :: args
|
|
| _ -> [(Nolabel, arg)]
|
|
in
|
|
pexp_apply ~loc:exp.pexp_loc (evar ~loc txt)
|
|
(append_here_args args)
|
|
| Pexp_extension
|
|
( {txt= "Trace.call"; loc= call_loc}
|
|
, PStr [{pstr_desc= Pstr_eval (call_fun, []); _}] ) ->
|
|
if not !debug then eunit ~loc:exp.pexp_loc
|
|
else
|
|
pexp_apply ~loc:exp.pexp_loc
|
|
(evar ~loc:call_loc "Trace.call")
|
|
(append_here_args [(Nolabel, call_fun)])
|
|
| Pexp_extension
|
|
( {txt= "Trace.retn"; loc= retn_loc}
|
|
, PStr [{pstr_desc= Pstr_eval (retn_fun, []); _}] ) ->
|
|
if not !debug then evar ~loc:exp.pexp_loc "Fn.id"
|
|
else
|
|
pexp_apply ~loc:exp.pexp_loc
|
|
(evar ~loc:retn_loc "Trace.retn")
|
|
(append_here_args [(Nolabel, retn_fun)])
|
|
| _ -> Ast_mapper.default_mapper.expr m exp
|
|
in
|
|
{Ast_mapper.default_mapper with expr; value_binding}
|
|
|
|
let impl = Selected_ast.Ast.map_structure mapper
|
|
|
|
;;
|
|
Driver.register_transformation "trace" ~impl
|