camlp4/Camlp4Filters/Camlp4Profiler.ml

   1 (* camlp4r *)
   2 (****************************************************************************)
   3 (*                                                                          *)
   4 (*                              Objective Caml                              *)
   5 (*                                                                          *)
   6 (*                            INRIA Rocquencourt                            *)
   7 (*                                                                          *)
   8 (*  Copyright   2006    Institut National de Recherche en Informatique et   *)
   9 (*  en Automatique.  All rights reserved.  This file is distributed under   *)
  10 (*  the terms of the GNU Library General Public License, with the special   *)
  11 (*  exception on linking described in LICENSE at the top of the Objective   *)
  12 (*  Caml source tree.                                                       *)
  13 (*                                                                          *)
  14 (****************************************************************************)
  15
  16 (* Authors:
  17  * - Nicolas Pouillard: initial version
  18  *)
  19
  20 open Camlp4;
  21
  22 module Id = struct
  23   value name    = "Camlp4Profiler";
  24   value version = "$Id$";
  25 end;
  26
  27 module Make (AstFilters : Camlp4.Sig.AstFilters) = struct
  28   open AstFilters;
  29   open Ast;
  30
  31   value decorate_binding decorate_fun = object
  32     inherit Ast.map as super;
  33     method binding =
  34       fun
  35       [ <:binding@_loc< $lid:id$ = $(<:expr< fun [ $_$ ] >> as e)$ >> ->
  36           <:binding< $lid:id$ = $decorate_fun id e$ >>
  37       | b -> super#binding b ];
  38   end#binding;
  39
  40   value decorate decorate_fun = object (o)
  41     inherit Ast.map as super;
  42     method str_item =
  43       fun
  44       [ <:str_item@_loc< value $rec:r$ $b$ >> ->
  45           <:str_item< value $rec:r$ $decorate_binding decorate_fun b$ >>
  46       | st -> super#str_item st ];
  47     method expr =
  48       fun
  49       [ <:expr@_loc< let $rec:r$ $b$ in $e$ >> ->
  50           <:expr< let $rec:r$ $decorate_binding decorate_fun b$ in $o#expr e$ >>
  51       | <:expr@_loc< fun [ $_$ ] >> as e -> decorate_fun "<fun>" e
  52       | e -> super#expr e ];
  53   end;
  54
  55   value decorate_this_expr e id =
  56     let buf = Buffer.create 42 in
  57     let _loc = Ast.loc_of_expr e in
  58     let () = Format.bprintf buf "%s @@ %a@?" id Loc.dump _loc in
  59     let s = Buffer.contents buf in
  60     <:expr< let () = Camlp4prof.count $`str:s$ in $e$ >>;
  61
  62   value rec decorate_fun id =
  63     let decorate = decorate decorate_fun in
  64     let decorate_expr = decorate#expr in
  65     let decorate_match_case = decorate#match_case in
  66     fun
  67     [ <:expr@_loc< fun $p$ -> $e$ >> ->
  68         <:expr< fun $p$ -> $decorate_fun id e$ >>
  69     | <:expr@_loc< fun [ $m$ ] >> ->
  70         decorate_this_expr <:expr< fun [ $decorate_match_case m$ ] >> id
  71     | e -> decorate_this_expr (decorate_expr e) id ];
  72
  73   register_str_item_filter (decorate decorate_fun)#str_item;
  74
  75 end;
  76
  77 let module M = Camlp4.Register.AstFilter Id Make in ();