@ -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
| FieldAccess field_name
-> Typ . Fieldname . pp fmt field_name
| ArrayAccess _
-> F . fprintf fmt " [_] "
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_sep _ _ = F . fprintf fmt " . " in
F . pp_print_list ~ pp_sep pp_access 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,6 +109,72 @@ module Raw = struct
| _
-> None
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 -> 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
| Exp . Var id -> (
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 )
| Exp . Lvar pvar when Pvar . is_ssa_frontend_tmp pvar -> (
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 )
| Exp . Lvar pvar
-> ( base_of_pvar pvar typ , accesses ) :: acc
| Exp . Lfield ( root_exp , fld , root_exp_typ )
-> let field_access = FieldAccess fld 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 . mk ( Tarray ( typ , None , 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 -> 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 rec is_prefix_path path1 path2 =
if phys_equal path1 path2 then true
else
match ( path1 , path2 ) with
| [] , _
-> true
| _ , []
-> false
| access1 :: p1 , access2 :: p2
-> equal_access access1 access2 && is_prefix_path p1 p2
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 pp fmt = function
| base , []
-> pp_base fmt base
@ -116,112 +182,52 @@ module Raw = struct
-> 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 equal = [ % compare . equal : t ]
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 . 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
| Exp . Var id -> (
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 )
| Exp . Lvar pvar when Pvar . is_ssa_frontend_tmp pvar -> (
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 )
| Exp . Lvar pvar
-> ( base_of_pvar pvar typ , accesses ) :: acc
| Exp . Lfield ( root_exp , fld , root_exp_typ )
-> let field_access = FieldAccess fld 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 . mk ( Tarray ( typ , None , 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 . 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 with_base base = function
| Exact ( _ , accesses )
-> Exact ( base , accesses )
| Abstracted ( _ , accesses )
-> Abstracted ( base , accesses )
let rec is_prefix_path path1 path2 =
if phys_equal path1 path2 then true
else
match ( path1 , path2 ) with
| [] , _
-> true
| _ , []
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 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 raw_access_path = extract access_path in
match raw_access_path with
| ( Var . LogicalVar id , _ ) , _ when Ident . is_footprint id
-> Some ( Ident . get_stamp id )
| _
-> None
let is_exact = function Exact _ -> true | Abstracted _ -> false
let ( < = ) ~ lhs ~ rhs =
match ( lhs , rhs ) with
| Abstracted _ , Exact _
-> false
| access1 :: p1 , access2 :: p2
-> equal_access access1 access2 && is_prefix_path p1 p2
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 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 raw_access_path = extract access_path in
match raw_access_path with
| ( Var . LogicalVar id , _ ) , _ when Ident . is_footprint id
-> Some ( Ident . get_stamp id )
| _
-> None
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 fmt = function
| Exact access_path
-> Raw . pp fmt access_path
| Abstracted access_path
-> F . fprintf fmt " %a* " Raw . pp access_path
| Exact lhs_ap , Exact rhs_ap
-> Raw . equal lhs_ap rhs_ap
| ( Exact lhs_ap | Abstracted lhs_ap ) , Abstracted rhs_ap
-> Raw . is_prefix rhs_ap lhs_ap
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
7 years ago
committed by
Facebook Github Bot