bundles/menhirLib/menhir-20120123/src/inliner.ml

   1 (**************************************************************************)
   2 (*                                                                        *)
   3 (*  Menhir                                                                *)
   4 (*                                                                        *)
   5 (*  François Pottier, INRIA Rocquencourt                                  *)
   6 (*  Yann Régis-Gianas, PPS, Université Paris Diderot                      *)
   7 (*                                                                        *)
   8 (*  Copyright 2005-2008 Institut National de Recherche en Informatique    *)
   9 (*  et en Automatique. All rights reserved. This file is distributed      *)
  10 (*  under the terms of the Q Public License version 1.0, with the change  *)
  11 (*  described in file LICENSE.                                            *)
  12 (*                                                                        *)
  13 (**************************************************************************)
  14
  15 open IL
  16 open CodeBits
  17
  18 (* In the following, we only inline global functions. In order to
  19    avoid unintended capture, as we traverse terms, we keep track of
  20    local identifiers that hide global ones. The following little class
  21    helps do that. (The pathological case where a local binding hides a
  22    global one probably does not arise very often. Fortunately,
  23    checking against it in this way is quite cheap, and lets me sleep
  24    safely.) *)
  25
  26 class locals table = object(self)
  27
  28   method pvar (locals : StringSet.t) (id : string) =
  29     if Hashtbl.mem table id then StringSet.add id locals else locals
  30
  31 end
  32
  33 (* Here is the inliner. *)
  34
  35 let inline ({ valdefs = defs } as p : program) =
  36
  37   (* Create a table of all global definitions. *)
  38
  39   let before, table = Traverse.tabulate_defs defs in
  40
  41   (* Prepare to count how many times each function is used, including
  42      inside its own definition. The public functions serve as starting
  43      points for this discovery phase. *)
  44
  45   let queue : valdef Queue.t =
  46     Queue.create()
  47   and usage : int StringMap.t ref =
  48     ref StringMap.empty
  49   in
  50
  51   (* [visit] is called at every identifier occurrence. *)
  52
  53   let visit locals id =
  54     if StringSet.mem id locals then
  55       (* This is a local identifier. Do nothing. *)
  56       ()
  57     else
  58       try
  59         let _, def = Hashtbl.find table id in
  60
  61         (* This is a globally defined identifier. Increment its usage
  62            count. If it was never visited, enqueue its definition for
  63            exploration. *)
  64
  65         let n =
  66           try
  67             StringMap.find id !usage
  68           with Not_found ->
  69             Queue.add def queue;
  70             0
  71         in
  72         usage := StringMap.add id (n + 1) !usage
  73
  74       with Not_found ->
  75         (* This identifier is not global. It is either local or a
  76            reference to some external library, e.g. ocaml's standard
  77            library. *)
  78         ()
  79   in
  80
  81   (* Look for occurrences of identifiers inside expressions. *)
  82
  83   let o =
  84     object
  85         inherit [ StringSet.t, unit ] Traverse.fold
  86         inherit locals table
  87         method evar locals () id =
  88           visit locals id
  89     end
  90   in
  91
  92   (* Initialize the queue with all public definitions, and work from
  93      there. We assume that the left-hand side of every definition is
  94      a variable. *)
  95
  96   List.iter (fun { valpublic = public; valpat = p } ->
  97     if public then
  98       visit StringSet.empty (pat2var p)
  99   ) defs;
 100   Misc.qfold (o#valdef StringSet.empty) () queue;
 101   let usage = !usage in
 102
 103   (* Now, inline every function that is called at most once. At the
 104      same time, every function that is never called is dropped. The
 105      public functions again serve as starting points for the
 106      traversal. *)
 107
 108   let queue : valdef Queue.t =
 109     Queue.create()
 110   and emitted =
 111     ref StringSet.empty
 112   in
 113
 114   let enqueue def =
 115     let id = pat2var def.valpat in
 116     if not (StringSet.mem id !emitted) then begin
 117       emitted := StringSet.add id !emitted;
 118       Queue.add def queue
 119     end
 120   in
 121
 122   (* A simple application is an application of a variable to a number
 123      of variables, constants, or record accesses out of variables. *)
 124
 125   let rec is_simple_arg = function
 126     | EVar _
 127     | EData (_, [])
 128     | ERecordAccess (EVar _, _) ->
 129         true
 130     | EMagic e ->
 131         is_simple_arg e
 132     | _ ->
 133         false
 134   in
 135
 136   let is_simple_app = function
 137     | EApp (EVar _, actuals) ->
 138         List.for_all is_simple_arg actuals
 139     | _ ->
 140         false
 141   in
 142
 143   (* Taking a fresh instance of a type scheme. Ugly. *)
 144
 145   let instance =
 146     let count = ref 0 in
 147     let fresh tv =
 148       incr count;
 149       tv, Printf.sprintf "freshtv%d" !count
 150     in
 151     fun scheme ->
 152       let mapping = List.map fresh scheme.quantifiers in
 153       let rec sub typ =
 154         match typ with
 155         | TypTextual _ ->
 156             typ
 157         | TypVar v ->
 158             begin try
 159               TypVar (List.assoc v mapping)
 160             with Not_found ->
 161               typ
 162             end
 163         | TypApp (f, typs) ->
 164             TypApp (f, List.map sub typs)
 165         | TypTuple typs ->
 166             TypTuple (List.map sub typs)
 167         | TypArrow (typ1, typ2) ->
 168             TypArrow (sub typ1, sub typ2)
 169       in
 170       sub scheme.body
 171   in
 172
 173   (* Destructuring a type annotation. *)
 174
 175   let rec annotate formals body typ =
 176     match formals, typ with
 177     | [], _ ->
 178         [], EAnnot (body, type2scheme typ)
 179     | formal :: formals, TypArrow (targ, tres) ->
 180         let formals, body = annotate formals body tres in
 181         PAnnot (formal, targ) :: formals, body
 182     | _ :: _, _ ->
 183         (* Type annotation has insufficient arity. *)
 184         assert false
 185   in
 186
 187   (* The heart of the inliner: rewriting a function call to a [let]
 188      expression.
 189
 190      If there was a type annotation at the function definition site,
 191      it is dropped, provided [--infer] was enabled. Otherwise, it is
 192      kept, because, due to the presence of [EMagic] expressions in the
 193      code, dropping a type annotation could cause an ill-typed program
 194      to become apparently well-typed. Keeping a type annotation
 195      requires taking a fresh instance of the type scheme, because
 196      OCaml doesn't have support for locally and existentially bound
 197      type variables. Yuck. *)
 198
 199   let inline formals actuals body oscheme =
 200     assert (List.length actuals = List.length formals);
 201     match oscheme with
 202     | Some scheme
 203       when not Settings.infer ->
 204
 205         let formals, body = annotate formals body (instance scheme) in
 206         mlet formals actuals body
 207
 208     | _ ->
 209         mlet formals actuals body
 210   in
 211
 212   (* Look for occurrences of identifiers inside expressions, branches,
 213      etc. and replace them with their definitions if they have only
 214      one use site or if their definitions are sufficiently simple. *)
 215
 216   let o =
 217     object (self)
 218       inherit [ StringSet.t ] Traverse.map as super
 219       inherit locals table
 220       method eapp locals e actuals =
 221         match e with
 222         | EVar id when
 223             (Hashtbl.mem table id) &&       (* a global identifier *)
 224             (not (StringSet.mem id locals)) (* not hidden by a local identifier *)
 225           ->
 226
 227             let _, def = Hashtbl.find table id in (* cannot fail, thanks to the above check *)
 228
 229             let formals, body, oscheme =
 230               match def with
 231               | { valval = EFun (formals, body) } ->
 232                   formals, body, None
 233               | { valval = EAnnot (EFun (formals, body), scheme) } ->
 234                   formals, body, Some scheme
 235               | { valval = _ } ->
 236                   (* The definition is not a function definition. This should not
 237                      happen in the kind of code that we generate. *)
 238                   assert false
 239             in
 240
 241             assert (StringMap.mem id usage);
 242             if StringMap.find id usage = 1 || is_simple_app body then
 243
 244               (* The definition can be inlined, with beta reduction. *)
 245
 246               inline formals (self#exprs locals actuals) (EComment (id, self#expr locals body)) oscheme
 247
 248             else begin
 249
 250               (* The definition cannot be inlined. *)
 251
 252               enqueue def;
 253               super#eapp locals e actuals
 254
 255             end
 256
 257         | _ ->
 258             (* The thing in function position is not a reference to a global. *)
 259             super#eapp locals e actuals
 260
 261     end
 262   in
 263
 264   (* Initialize the queue with all public definitions, and work from
 265      there. *)
 266
 267   List.iter (function { valpublic = public } as def ->
 268     if public then
 269       enqueue def
 270   ) defs;
 271
 272   let valdefs =
 273     Misc.qfold (fun defs def ->
 274       o#valdef StringSet.empty def :: defs
 275     ) [] queue
 276   in
 277
 278   Error.logC 1 (fun f ->
 279     Printf.fprintf f "%d functions before inlining, %d functions after inlining.\n"
 280        before (List.length valdefs));
 281
 282   Time.tick "Inlining";
 283
 284   { p with valdefs = valdefs }
 285
 286 (* The external entry point. *)
 287
 288 let inline p =
 289   if Settings.code_inlining then inline p else p
 290