hphp/hack/src/shape_analysis/shape_analysis_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 Shape_analysis_types
  11 module LMap = Local_id.Map
  12 module Cont = Typing_continuations
  13
  14 let var_counter : int ref = ref 0
  15
  16 let fresh_var () : entity_ =
  17   var_counter := !var_counter + 1;
  18   Variable !var_counter
  19
  20 let union_continuation_at_lid ~pos ~origin (entity1 : entity) (entity2 : entity)
  21     : decorated_constraint list * entity =
  22   match (entity1, entity2) with
  23   | (Some left, Some right) ->
  24     let join = fresh_var () in
  25     let join_constraint =
  26       { hack_pos = pos; origin; constraint_ = Joins { left; right; join } }
  27     in
  28     ([join_constraint], Some join)
  29   | (entity, None)
  30   | (None, entity) ->
  31     ([], entity)
  32
  33 let union_continuation
  34     ~pos ~origin (constraints : decorated_constraint list) cont1 cont2 =
  35   let union_continuation_at_lid constraints _lid entity1_opt entity2_opt :
  36       decorated_constraint list * entity option =
  37     match (entity1_opt, entity2_opt) with
  38     | (Some entity1, Some entity2) ->
  39       let (new_constraints, entity) =
  40         union_continuation_at_lid ~pos ~origin entity1 entity2
  41       in
  42       (new_constraints @ constraints, Some entity)
  43     | (Some entity, None)
  44     | (None, Some entity) ->
  45       (constraints, Some entity)
  46     | (None, None) -> (constraints, None)
  47   in
  48   let (constraints, cont) =
  49     LMap.merge_env constraints cont1 cont2 ~combine:union_continuation_at_lid
  50   in
  51   (constraints, cont)
  52
  53 module LEnv = struct
  54   type t = lenv
  55
  56   let init bindings : t = Cont.Map.add Cont.Next bindings Cont.Map.empty
  57
  58   let get_local_in_continuation lenv cont lid : entity =
  59     let open Option.Monad_infix in
  60     lenv |> Cont.Map.find_opt cont >>= LMap.find_opt lid |> Option.join
  61
  62   let get_local lenv : LMap.key -> entity =
  63     get_local_in_continuation lenv Cont.Next
  64
  65   let set_local_in_continuation lenv cont lid entity : t =
  66     let update_cont = function
  67       | None -> None
  68       | Some lenv_per_cont -> Some (LMap.add lid entity lenv_per_cont)
  69     in
  70     Cont.Map.update cont update_cont lenv
  71
  72   let set_local lenv lid entity : t =
  73     set_local_in_continuation lenv Cont.Next lid entity
  74
  75   let drop_cont lenv cont : t = Cont.Map.remove cont lenv
  76
  77   let drop_conts lenv conts : t = List.fold ~f:drop_cont ~init:lenv conts
  78
  79   let replace_cont lenv cont_key cont_opt : t =
  80     match cont_opt with
  81     | None -> drop_cont lenv cont_key
  82     | Some cont -> Cont.Map.add cont_key cont lenv
  83
  84   let restore_cont_from lenv ~from cont_key : t =
  85     let ctxopt = Cont.Map.find_opt cont_key from in
  86     replace_cont lenv cont_key ctxopt
  87
  88   let restore_conts_from lenv ~from conts : t =
  89     List.fold ~f:(restore_cont_from ~from) ~init:lenv conts
  90
  91   let union ~pos ~origin (lenv1 : t) (lenv2 : t) : decorated_constraint list * t
  92       =
  93     let combine constraints _ cont1 cont2 =
  94       let (constraints, cont) =
  95         union_continuation ~pos ~origin constraints cont1 cont2
  96       in
  97       (constraints, Some cont)
  98     in
  99     Cont.Map.union_env [] lenv1 lenv2 ~combine
 100
 101   let refresh (lenv : t) : constraint_ list * t =
 102     let refresh_local constraints _ = function
 103       | Some entity_ ->
 104         let var = fresh_var () in
 105         (Subsets (entity_, var) :: constraints, Some var)
 106       | None -> (constraints, None)
 107     in
 108     let refresh_cont constraints _ cont =
 109       LMap.map_env refresh_local constraints cont
 110     in
 111     Cont.Map.map_env refresh_cont [] lenv
 112 end
 113
 114 let init tast_env constraints bindings ~return =
 115   { constraints; lenv = LEnv.init bindings; return; tast_env }
 116
 117 let add_constraint env constraint_ =
 118   { env with constraints = constraint_ :: env.constraints }
 119
 120 let reset_constraints env = { env with constraints = [] }
 121
 122 let get_local env = LEnv.get_local env.lenv
 123
 124 let set_local env lid entity =
 125   let lenv = LEnv.set_local env.lenv lid entity in
 126   { env with lenv }
 127
 128 let union ~pos ~origin (parent_env : env) (env1 : env) (env2 : env) : env =
 129   let (points_to_constraints, lenv) =
 130     LEnv.union ~pos ~origin env1.lenv env2.lenv
 131   in
 132   let constraints =
 133     points_to_constraints
 134     @ env1.constraints
 135     @ env2.constraints
 136     @ parent_env.constraints
 137   in
 138   { parent_env with lenv; constraints }
 139
 140 let drop_cont env cont =
 141   let lenv = LEnv.drop_cont env.lenv cont in
 142   { env with lenv }
 143
 144 let drop_conts env conts =
 145   let lenv = LEnv.drop_conts env.lenv conts in
 146   { env with lenv }
 147
 148 let replace_cont env cont_key cont_opt =
 149   let lenv = LEnv.replace_cont env.lenv cont_key cont_opt in
 150   { env with lenv }
 151
 152 let restore_conts_from env ~from conts : env =
 153   let lenv = LEnv.restore_conts_from env.lenv ~from conts in
 154   { env with lenv }
 155
 156 let stash_and_do env conts f : env =
 157   let parent_locals = env.lenv in
 158   let env = drop_conts env conts in
 159   let env = f env in
 160   restore_conts_from env ~from:parent_locals conts
 161
 162 let union_cont_opt
 163     ~pos ~origin (constraints : decorated_constraint list) cont_opt1 cont_opt2 =
 164   match (cont_opt1, cont_opt2) with
 165   | (None, opt)
 166   | (opt, None) ->
 167     (constraints, opt)
 168   | (Some cont1, Some cont2) ->
 169     let (constraints, cont) =
 170       union_continuation ~pos ~origin constraints cont1 cont2
 171     in
 172     (constraints, Some cont)
 173
 174 (* Union a list of continuations *)
 175 let union_conts ~pos ~origin (env : env) lenv cont_keys =
 176   let union_two (constraints, cont_opt1) cont_key =
 177     let cont_opt2 = Cont.Map.find_opt cont_key lenv in
 178     union_cont_opt ~pos ~origin constraints cont_opt1 cont_opt2
 179   in
 180   let (constraints, cont_opt) =
 181     List.fold cont_keys ~f:union_two ~init:(env.constraints, None)
 182   in
 183   let env = { env with constraints } in
 184   (env, cont_opt)
 185
 186 (* Union a list of source continuations and store the result in a
 187  * destination continuation. *)
 188 let union_conts_and_update ~pos ~origin (env : env) ~from_conts ~to_cont =
 189   let lenv = env.lenv in
 190   let (env, unioned_cont) = union_conts ~pos ~origin env lenv from_conts in
 191   replace_cont env to_cont unioned_cont
 192
 193 let update_next_from_conts ~pos ~origin (env : env) from_conts =
 194   union_conts_and_update ~pos ~origin env ~from_conts ~to_cont:Cont.Next
 195
 196 let save_and_merge_next_in_cont ~pos ~origin (env : env) to_cont =
 197   let from_conts = [Cont.Next; to_cont] in
 198   union_conts_and_update ~pos ~origin env ~from_conts ~to_cont
 199
 200 let move_and_merge_next_in_cont ~pos ~origin (env : env) cont_key =
 201   let env = save_and_merge_next_in_cont ~pos ~origin env cont_key in
 202   drop_cont env Cont.Next
 203
 204 let loop_continuation
 205     ~pos ~origin cont_key ~env_before_iteration ~env_after_iteration =
 206   let decorate constraint_ = { hack_pos = pos; origin; constraint_ } in
 207   let cont_before_iteration_opt =
 208     Cont.Map.find_opt cont_key env_before_iteration.lenv
 209   in
 210   let cont_after_iteration_opt =
 211     Cont.Map.find_opt cont_key env_after_iteration.lenv
 212   in
 213   let new_constraints =
 214     let combine constraints _key entity_before_opt entity_after_opt =
 215       let new_constraints =
 216         match (entity_before_opt, entity_after_opt) with
 217         | (Some (Some entity_before), Some (Some entity_after)) ->
 218           [decorate @@ Subsets (entity_after, entity_before)]
 219         | _ -> []
 220       in
 221       let constraints = new_constraints @ constraints in
 222       (constraints, None)
 223     in
 224     match (cont_before_iteration_opt, cont_after_iteration_opt) with
 225     | (Some cont_before_iteration, Some cont_after_iteration) ->
 226       fst
 227       @@ LMap.merge_env [] cont_before_iteration cont_after_iteration ~combine
 228     | _ -> []
 229   in
 230   {
 231     env_after_iteration with
 232     constraints = new_constraints @ env_after_iteration.constraints;
 233   }
 234
 235 let refresh ~pos ~origin (env : env) : env =
 236   let (redirection_constraints, lenv) = LEnv.refresh env.lenv in
 237   let decorate constraint_ = { hack_pos = pos; origin; constraint_ } in
 238   let redirection_constraints = List.map ~f:decorate redirection_constraints in
 239   { env with lenv; constraints = redirection_constraints @ env.constraints }