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.

205 lines
5.6 KiB

(*
* Copyright (c) 2016 - present Facebook, Inc.
* All rights reserved.
*
* This source code is licensed under the BSD style license found in the
* LICENSE file in the root directory of this source tree. An additional grant
* of patent rights can be found in the PATENTS file in the same directory.
*)
open! Utils
module F = Format
type base = Var.t * Typ.t
type access =
| FieldAccess of Ident.fieldname * Typ.t
| ArrayAccess of Typ.t
type raw = base * access list
type t =
| Exact of raw
| Abstracted of raw
let base_compare ((var1, typ1) as base1) ((var2, typ2) as base2) =
if base1 == base2
then 0
else
let n = Var.compare var1 var2 in
if n <> 0
then n
else Typ.array_sensitive_compare typ1 typ2
let base_equal base1 base2 =
base_compare base1 base2 = 0
let access_compare access1 access2 =
if access1 == access2
then
0
else
match access1, access2 with
| FieldAccess (f1, typ1), FieldAccess (f2, typ2) ->
let n = Ident.compare_fieldname f1 f2 in
if n <> 0
then n
else Typ.compare typ1 typ2
| ArrayAccess typ1, ArrayAccess typ2 ->
Typ.compare typ1 typ2
| FieldAccess _, _ -> 1
| _, FieldAccess _ -> -1
let access_equal access1 access2 =
access_compare access1 access2 = 0
let raw_compare ((base1, accesses1) as ap1) ((base2, accesses2) as ap2) =
if ap1 == ap2
then 0
else
let n = base_compare base1 base2 in
if n <> 0
then n
else if accesses1 == accesses2
then 0
else IList.compare access_compare accesses1 accesses2
let raw_equal ap1 ap2 =
raw_compare ap1 ap2 = 0
let compare ap1 ap2 =
if ap1 == ap2
then
0
else
match ap1, ap2 with
| Exact ap1, Exact ap2 | Abstracted ap1, Abstracted ap2 -> raw_compare ap1 ap2
| Exact _, Abstracted _ -> 1
| Abstracted _, Exact _ -> (-1)
let equal ap1 ap2 =
compare ap1 ap2 = 0
let base_of_pvar pvar typ =
Var.of_pvar pvar, typ
let base_of_id id typ =
Var.of_id id, typ
let of_pvar pvar typ =
base_of_pvar pvar typ, []
let of_id id typ =
base_of_id id typ, []
let of_exp exp0 typ0 ~(f_resolve_id : Var.t -> raw option) =
(* [typ] is the type of the last element of the access path (e.g., typeof(g) for x.f.g) *)
let rec of_exp_ exp typ accesses acc =
match exp with
| Exp.Var id ->
begin
match f_resolve_id (Var.of_id id) with
| Some (base, base_accesses) -> (base, base_accesses @ accesses) :: acc
| None -> (base_of_id id typ, accesses) :: acc
end
| Exp.Lvar pvar when Pvar.is_frontend_tmp pvar ->
begin
match f_resolve_id (Var.of_pvar pvar) with
| Some (base, base_accesses) -> (base, base_accesses @ accesses) :: acc
| None -> (base_of_pvar pvar typ, accesses) :: acc
end
| Exp.Lvar pvar ->
(base_of_pvar pvar typ, accesses) :: acc
| Exp.Lfield (root_exp, fld, root_exp_typ) ->
let field_access = FieldAccess (fld, typ) in
of_exp_ root_exp root_exp_typ (field_access :: accesses) acc
| Exp.Lindex (root_exp, _) ->
let array_access = ArrayAccess typ in
let array_typ = Typ.Tarray (typ, None) in
of_exp_ root_exp array_typ (array_access :: accesses) acc
| Exp.Cast (cast_typ, cast_exp) ->
of_exp_ cast_exp cast_typ [] acc
| Exp.UnOp (_, unop_exp, _) ->
of_exp_ unop_exp typ [] acc
| Exp.Exn exn_exp ->
of_exp_ exn_exp typ [] acc
| Exp.BinOp (_, exp1, exp2) ->
of_exp_ exp1 typ [] acc
|> of_exp_ exp2 typ []
| Exp.Const _ | Closure _ | Sizeof _ ->
(* trying to make access path from an invalid expression *)
acc in
of_exp_ exp0 typ0 [] []
let of_lhs_exp lhs_exp typ ~(f_resolve_id : Var.t -> raw option) =
match of_exp lhs_exp typ ~f_resolve_id with
| [lhs_ap] -> Some lhs_ap
| _ -> None
let append (base, old_accesses) new_accesses =
base, old_accesses @ new_accesses
let with_base_var var = function
| Exact ((_, base_typ), accesses) -> Exact ((var, base_typ), accesses)
| Abstracted ((_, base_typ), accesses) -> Abstracted ((var, base_typ), accesses)
let rec is_prefix_path path1 path2 =
if path1 == path2
then true
else
match path1, path2 with
| [], _ -> true
| _, [] -> false
| access1 :: p1, access2 :: p2 -> access_equal access1 access2 && is_prefix_path p1 p2
let is_prefix ((base1, path1) as ap1) ((base2, path2) as ap2) =
if ap1 == ap2
then true
else
base_equal base1 base2 && is_prefix_path path1 path2
let extract = function
| Exact ap | Abstracted ap -> ap
let is_exact = function
| Exact _ -> true
| Abstracted _ -> false
let (<=) ~lhs ~rhs =
match lhs, rhs with
| Abstracted _, Exact _ -> false
| Exact lhs_ap, Exact rhs_ap -> raw_equal lhs_ap rhs_ap
| (Exact lhs_ap | Abstracted lhs_ap), Abstracted rhs_ap -> is_prefix rhs_ap lhs_ap
let pp_base fmt (pvar, _) =
Var.pp fmt pvar
let pp_access fmt = function
| FieldAccess (field_name, _) -> Ident.pp_fieldname fmt field_name
| ArrayAccess _ -> F.fprintf fmt "[_]"
let pp_access_list fmt accesses =
let pp_sep _ _ = F.fprintf fmt "." in
F.pp_print_list ~pp_sep pp_access fmt accesses
let pp_raw fmt = function
| base, [] -> pp_base fmt base
| base, accesses -> F.fprintf fmt "%a.%a" pp_base base pp_access_list accesses
let pp fmt = function
| Exact access_path -> pp_raw fmt access_path
| Abstracted access_path -> F.fprintf fmt "%a*" pp_raw access_path
module BaseMap = PrettyPrintable.MakePPMap(struct
type t = base
let compare = base_compare
let pp_key = pp_base
end)
module AccessMap = PrettyPrintable.MakePPMap(struct
type t = access
let compare = access_compare
let pp_key = pp_access
end)