hphp/hack/src/ifc/ifc_env.ml

   1 (*
   2  * Copyright (c) Facebook, Inc. and its affiliates.
   3  *
   4  * This source code is licensed under the MIT license found in the
   5  * LICENSE file in the "hack" directory of this source tree.
   6  *
   7  *)
   8
   9 open Hh_prelude
  10 open Ifc_types
  11 module Utils = Ifc_utils
  12 module K = Typing_cont_key
  13
  14 (* See ifc_env.mli for the docmentation *)
  15
  16 (* Only elementary logic about the environments should
  17    be in this file to avoid circular dependencies;
  18    use higher-order functions to parameterize complex
  19    behavior! *)
  20
  21 (* - Read-only environments (renv) - *)
  22
  23 let new_policy_var { re_scope; re_pvar_counters; _ } prefix =
  24   let prefix = String.lstrip ~drop:(Char.equal '\\') prefix in
  25   let suffix =
  26     match Caml.Hashtbl.find_opt re_pvar_counters prefix with
  27     | Some counter ->
  28       incr counter;
  29       "'" ^ string_of_int !counter
  30     | None ->
  31       Caml.Hashtbl.add re_pvar_counters prefix (ref 0);
  32       ""
  33   in
  34   Pfree_var (prefix ^ suffix, re_scope)
  35
  36 let new_renv scope decl_env saved_tenv ctx =
  37   {
  38     re_scope = scope;
  39     re_decl = decl_env;
  40     re_pvar_counters = Caml.Hashtbl.create 10;
  41     re_tenv = saved_tenv;
  42     (* the fields below are initialized with dummy values *)
  43     re_this = None;
  44     re_ret = ();
  45     re_gpc = pbot;
  46     re_exn = ();
  47     re_ctx = ctx;
  48   }
  49
  50 let prep_renv renv this_ty_opt ret_ty exn_ty gpc_pol =
  51   {
  52     re_scope = renv.re_scope;
  53     re_decl = renv.re_decl;
  54     re_pvar_counters = renv.re_pvar_counters;
  55     re_tenv = renv.re_tenv;
  56     re_this = this_ty_opt;
  57     re_ret = ret_ty;
  58     re_gpc = gpc_pol;
  59     re_exn = exn_ty;
  60     re_ctx = renv.re_ctx;
  61   }
  62
  63 (* - Read/write environments (env) - *)
  64
  65 type yes = unit
  66
  67 type no = unit
  68
  69 type ('has_locals, 'can_throw) env = {
  70   e_nxt: cont;
  71   e_exn: cont option;
  72   e_acc: prop list;
  73   e_deps: SSet.t;
  74 }
  75
  76 type blank_env = (no, no) env
  77
  78 type stmt_env = (yes, no) env
  79
  80 type expr_env = (yes, yes) env
  81
  82 let empty_cont = { k_pc = PSet.empty; k_vars = LMap.empty }
  83
  84 let empty_env =
  85   { e_nxt = empty_cont; e_exn = None; e_acc = []; e_deps = SSet.empty }
  86
  87 let prep_stmt env cont = { env with e_nxt = cont; e_exn = None }
  88
  89 let prep_expr env = { env with e_exn = None }
  90
  91 let get_lpc env = env.e_nxt.k_pc
  92
  93 let get_gpc renv env = PSet.add renv.re_gpc (get_lpc env)
  94
  95 let get_deps env = env.e_deps
  96
  97 let get_constraints env = env.e_acc
  98
  99 let get_locals env = env.e_nxt.k_vars
 100
 101 let get_next env = env.e_nxt
 102
 103 (* Not exported, see with_pc, with_pc_deps, and throw *)
 104 let set_pc env pc = { env with e_nxt = { env.e_nxt with k_pc = pc } }
 105
 106 let with_pc env pc (fn : stmt_env -> blank_env * 'a) =
 107   let env = set_pc env pc in
 108   (* there is nothing to restore in the resulting env because
 109      fn returns a blank env (i.e., with e_nxt cleared) *)
 110   fn env
 111
 112 let with_pc_deps env deps = with_pc env (PSet.union (get_lpc env) deps)
 113
 114 let acc env update = { env with e_acc = update env.e_acc }
 115
 116 let add_dep env name = { env with e_deps = SSet.add name env.e_deps }
 117
 118 let close_expr env =
 119   let out_throw =
 120     match env.e_exn with
 121     | None -> KMap.empty
 122     | Some cont -> KMap.singleton K.Catch cont
 123   in
 124   let env = prep_stmt env env.e_nxt in
 125   (env, out_throw)
 126
 127 (* To merge contexts we need to compute union types for local variables;
 128    we don't want to be smart here, to avoid lagging behind the fancy
 129    heuristics in the Hack typechecker, so we are instead very dumb!
 130    This lack of sophistication is mitigated by the logic in the IFC
 131    analysis that keeps looking for better types in the annotated AST *)
 132 let union_types t1 t2 =
 133   if phys_equal t1 t2 then
 134     t1
 135   else
 136     Tunion [t1; t2]
 137
 138 (* Merge two local envs, if a variable appears only in one local
 139    env, it will not appear in the result env *)
 140 let merge_cont cont1 cont2 =
 141   let combine _ = Utils.combine_opts false union_types in
 142   let k_vars = LMap.merge combine cont1.k_vars cont2.k_vars in
 143   let k_pc = PSet.union cont1.k_pc cont2.k_pc in
 144   { k_vars; k_pc }
 145
 146 let merge_cont_opt = Utils.combine_opts true merge_cont
 147
 148 let throw env deps =
 149   let env = set_pc env (PSet.union (get_lpc env) deps) in
 150   { env with e_exn = merge_cont_opt env.e_exn (Some (get_next env)) }
 151
 152 let analyze_lambda_body env fn =
 153   let e_nxt = get_next env in
 154   let e_exn = env.e_exn in
 155   let env = fn env in
 156   { env with e_nxt; e_exn }
 157
 158 let get_local_type env lid = LMap.find_opt lid env.e_nxt.k_vars
 159
 160 let set_local_type env lid pty =
 161   let k_vars = LMap.add lid pty env.e_nxt.k_vars in
 162   { env with e_nxt = { env.e_nxt with k_vars } }
 163
 164 let set_local_type_opt env lid pty =
 165   let k_vars = LMap.update lid (fun _ -> pty) env.e_nxt.k_vars in
 166   { env with e_nxt = { env.e_nxt with k_vars } }
 167
 168 (* - Outcomes - *)
 169
 170 let merge_out out1 out2 = KMap.merge (fun _ -> merge_cont_opt) out1 out2
 171
 172 let close_stmt ?(merge = KMap.empty) env k =
 173   let out = KMap.singleton k (get_next env) in
 174   let out = merge_out out merge in
 175   let env = { env with e_nxt = empty_cont; e_exn = None } in
 176   (env, out)
 177
 178 let strip_cont out k = (KMap.remove k out, KMap.find_opt k out)
 179
 180 let merge_in_next out k =
 181   let (out, cont_k) = strip_cont out k in
 182   let (out, cont_next) = strip_cont out K.Next in
 183   match merge_cont_opt cont_k cont_next with
 184   | None -> out
 185   | Some cont -> KMap.add K.Next cont out
 186
 187 let merge_next_in out k =
 188   let (out, cont_k) = strip_cont out k in
 189   let (out, cont_next) = strip_cont out K.Next in
 190   match merge_cont_opt cont_k cont_next with
 191   | None -> out
 192   | Some cont -> KMap.add k cont out