@ -10,35 +10,35 @@
open ! IStd
module F = Format
type _ typ = Typ . t
module Raw = struct
type _ typ = Typ . t
let compare__typ _ _ = 0
let compare__typ _ _ = 0
(* ignore types while comparing bases. we can't trust the types from all of our frontends to be
(* ignore types while comparing bases. we can't trust the types from all of our frontends to be
consistent , and the variable names should already be enough to distinguish the bases . * )
type base = Var . t * _ typ [ @@ deriving compare ]
type base = Var . t * _ typ [ @@ deriving compare ]
let equal_base = [ % compare . equal : base ]
let equal_base = [ % compare . equal : base ]
type access = ArrayAccess of Typ . t | FieldAccess of Typ . Fieldname . t [ @@ deriving compare ]
type access = ArrayAccess of Typ . t | FieldAccess of Typ . Fieldname . t [ @@ deriving compare ]
let equal_access = [ % compare . equal : access ]
let equal_access = [ % compare . equal : access ]
let equal_access_list l1 l2 = Int . equal ( List . compare compare_access l1 l2 ) 0
let equal_access_list l1 l2 = Int . equal ( List . compare compare_access l1 l2 ) 0
let pp_base fmt ( pvar , _ ) = Var . pp fmt pvar
let pp_base fmt ( pvar , _ ) = Var . pp fmt pvar
let pp_access fmt = function
let pp_access fmt = function
| FieldAccess field_name
-> Typ . Fieldname . pp fmt field_name
| ArrayAccess _
-> F . fprintf fmt " [_] "
let pp_access_list fmt accesses =
let pp_access_list fmt accesses =
let pp_sep _ _ = F . fprintf fmt " . " in
F . pp_print_list ~ pp_sep pp_access fmt accesses
module Raw = struct
type t = base * access list [ @@ deriving compare ]
let equal = [ % compare . equal : t ]
@ -109,26 +109,15 @@ module Raw = struct
| _
-> None
let pp fmt = function
| base , []
-> pp_base fmt base
| base , accesses
-> F . fprintf fmt " %a.%a " pp_base base pp_access_list accesses
end
type t = Abstracted of Raw . t | Exact of Raw . t [ @@ deriving compare ]
let base_of_pvar pvar typ = ( Var . of_pvar pvar , typ )
let equal = [ % compare . equal : t ]
let base_of_id id typ = ( Var . of_id id , typ )
let base_ of_pvar pvar typ = ( Var . of_pvar pvar , typ )
let of_pvar pvar typ = ( base_of_pvar pvar typ , [] )
let base_ of_id id typ = ( Var . of_id id , typ )
let of_id id typ = ( base_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 . t option ) =
let of_exp exp0 typ0 ~ ( f_resolve_id : Var . t -> t 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
@ -167,18 +156,12 @@ let of_exp exp0 typ0 ~(f_resolve_id: Var.t -> Raw.t option) =
in
of_exp_ exp0 typ0 [] []
let of_lhs_exp lhs_exp typ ~ ( f_resolve_id : Var . t -> Raw . t option ) =
let of_lhs_exp lhs_exp typ ~ ( f_resolve_id : Var . t -> t 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 append ( base , old_accesses ) new_accesses = ( base , old_accesses @ new_accesses )
let with_base base = function
| Exact ( _ , accesses )
-> Exact ( base , accesses )
| Abstracted ( _ , accesses )
-> Abstracted ( base , accesses )
let rec is_prefix_path path1 path2 =
let rec is_prefix_path path1 path2 =
if phys_equal path1 path2 then true
else
match ( path1 , path2 ) with
@ -189,16 +172,36 @@ let rec is_prefix_path path1 path2 =
| access1 :: p1 , access2 :: p2
-> equal_access access1 access2 && is_prefix_path p1 p2
let is_prefix ( base1 , path1 as ap1 ) ( base2 , path2 as ap2 ) =
let is_prefix ( base1 , path1 as ap1 ) ( base2 , path2 as ap2 ) =
if phys_equal ap1 ap2 then true else equal_base base1 base2 && is_prefix_path path1 path2
let extract = function Exact ap | Abstracted ap -> ap
let pp fmt = function
| base , []
-> pp_base fmt base
| base , accesses
-> F . fprintf fmt " %a.%a " pp_base base pp_access_list accesses
end
module Abs = struct
type raw = Raw . t
type t = Abstracted of Raw . t | Exact of Raw . t [ @@ deriving compare ]
let equal = [ % compare . equal : t ]
let extract = function Exact ap | Abstracted ap -> ap
let to_footprint formal_index access_path =
let with_base base = function
| Exact ( _ , accesses )
-> Exact ( base , accesses )
| Abstracted ( _ , accesses )
-> Abstracted ( base , accesses )
let to_footprint formal_index access_path =
let _ , base_typ = fst ( extract access_path ) in
with_base ( Var . of_formal_index formal_index , base_typ ) access_path
let get_footprint_index access_path =
let get_footprint_index access_path =
let raw_access_path = extract access_path in
match raw_access_path with
| ( Var . LogicalVar id , _ ) , _ when Ident . is_footprint id
@ -206,22 +209,25 @@ let get_footprint_index access_path =
| _
-> None
let is_exact = function Exact _ -> true | Abstracted _ -> false
let is_exact = function Exact _ -> true | Abstracted _ -> false
let ( < = ) ~ lhs ~ rhs =
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
-> Raw . is_prefix rhs_ap lhs_ap
let pp fmt = function
let pp fmt = function
| Exact access_path
-> Raw . pp fmt access_path
| Abstracted access_path
-> F . fprintf fmt " %a* " Raw . pp access_path
end
include Raw
module BaseMap = PrettyPrintable . MakePPMap ( struct
type t = base
@ -239,5 +245,5 @@ module AccessMap = PrettyPrintable.MakePPMap (struct
let pp = pp_access
end )
module Raw Set = PrettyPrintable . MakePPSet ( Raw )
module Raw Map = PrettyPrintable . MakePPMap ( Raw )
module = PrettyPrintable . MakePPSet ( Raw )
module = PrettyPrintable . MakePPMap ( Raw )
Sam Blackshear
8 years ago
committed by
Facebook Github Bot