@ -10,7 +10,7 @@ module L = Logging
open Result . Monad_infix
(* * An abstract address in memory. *)
module Abstract Location : sig
module Abstract Address : sig
type t = private int [ @@ deriving compare ]
val equal : t -> t -> bool
@ -33,18 +33,18 @@ end = struct
let pp = F . pp_print_int
end
module Abstract Location Domain : AbstractDomain . S with type astate = Abstract Location . t = struct
type astate = Abstract Location . t
module Abstract Address Domain : AbstractDomain . S with type astate = Abstract Address . t = struct
type astate = Abstract Address . t
let ( < = ) ~ lhs ~ rhs = Abstract Location . equal lhs rhs
let ( < = ) ~ lhs ~ rhs = Abstract Address . equal lhs rhs
let join l1 l2 =
if Abstract Location . equal l1 l2 then l1 else (* TODO: scary *) Abstract Location . mk_fresh ()
if Abstract Address . equal l1 l2 then l1 else (* TODO: scary *) Abstract Address . mk_fresh ()
let widen ~ prev ~ next ~ num_iters : _ = join prev next
let pp = Abstract Location . pp
let pp = Abstract Address . pp
end
module Access = struct
@ -53,32 +53,64 @@ module Access = struct
let pp = AccessPath . pp_access
end
module MemoryEdges = AbstractDomain . InvertedMap ( Access ) ( Abstract Location Domain)
module MemoryEdges = AbstractDomain . InvertedMap ( Access ) ( Abstract Address Domain)
module MemoryDomain = struct
include AbstractDomain . InvertedMap ( Abstract Location ) ( MemoryEdges )
include AbstractDomain . InvertedMap ( Abstract Address ) ( MemoryEdges )
let add_edge loc_src access loc _end memory =
let add_edge addr_src access addr _end memory =
let edges =
match find_opt loc _src memory with Some edges -> edges | None -> MemoryEdges . empty
match find_opt addr _src memory with Some edges -> edges | None -> MemoryEdges . empty
in
add loc_src ( MemoryEdges . add access loc _end edges ) memory
add addr_src ( MemoryEdges . add access addr _end edges ) memory
let find_edge_opt loc access memory =
let find_edge_opt addr access memory =
let open Option . Monad_infix in
find_opt loc memory > > = MemoryEdges . find_opt access
find_opt addr memory > > = MemoryEdges . find_opt access
end
module AliasingDomain = AbstractDomain . InvertedMap ( Var ) ( AbstractLocationDomain )
module AbstractLocationsDomain = AbstractDomain . FiniteSet ( AbstractLocation )
module InvalidLocationsDomain = AbstractLocationsDomain
module AliasingDomain = AbstractDomain . InvertedMap ( Var ) ( AbstractAddressDomain )
type actor = { access_expr : AccessExpression . t ; location : Location . t }
let pp_actor f { access_expr ; location } =
F . fprintf f " %a@%a " AccessExpression . pp access_expr Location . pp location
module type InvalidAddressesDomain = sig
include AbstractDomain . S
val empty : astate
val add : AbstractAddress . t -> actor -> astate -> astate
val get_invalidation : AbstractAddress . t -> astate -> actor option
end
module InvalidAddressesDomain : InvalidAddressesDomain = struct
module InvalidationReason = struct
type astate = actor
let join actor _ = actor
let ( < = ) ~ lhs : _ ~ rhs : _ = true
let widen ~ prev ~ next : _ ~ num_iters : _ = prev
let pp = pp_actor
end
include AbstractDomain . Map ( AbstractAddress ) ( InvalidationReason )
let get_invalidation address invalids = find_opt address invalids
end
type t =
{ heap : MemoryDomain . astate ; stack : AliasingDomain . astate ; invalids : InvalidLocationsDomain . astate }
{ heap : MemoryDomain . astate ; stack : AliasingDomain . astate ; invalids : Invalid Addresse sDomain. astate }
let initial =
{ heap = MemoryDomain . empty ; stack = AliasingDomain . empty ; invalids = AbstractLocationsDomain . empty }
{ heap = MemoryDomain . empty ; stack = AliasingDomain . empty ; invalids = InvalidAddresse sDomain. empty }
module Domain : AbstractDomain . S with type astate = t = struct
@ -91,7 +123,7 @@ module Domain : AbstractDomain.S with type astate = t = struct
into the heap . * )
let ( < = ) ~ lhs ~ rhs =
phys_equal lhs rhs
| | Invalid Location sDomain. ( < = ) ~ lhs : lhs . invalids ~ rhs : rhs . invalids
| | Invalid Addresse sDomain. ( < = ) ~ lhs : lhs . invalids ~ rhs : rhs . invalids
&& AliasingDomain . ( < = ) ~ lhs : lhs . stack ~ rhs : rhs . stack
&& MemoryDomain . ( < = ) ~ lhs : lhs . heap ~ rhs : rhs . heap
@ -102,7 +134,7 @@ module Domain : AbstractDomain.S with type astate = t = struct
else
{ heap = MemoryDomain . join astate1 . heap astate2 . heap
; stack = AliasingDomain . join astate1 . stack astate2 . stack
; invalids = Invalid Location sDomain. join astate1 . invalids astate2 . invalids }
; invalids = Invalid Addresse sDomain. join astate1 . invalids astate2 . invalids }
let max_widening = 5
@ -116,117 +148,146 @@ module Domain : AbstractDomain.S with type astate = t = struct
else
{ heap = MemoryDomain . widen ~ num_iters ~ prev : prev . heap ~ next : next . heap
; stack = AliasingDomain . widen ~ num_iters ~ prev : prev . stack ~ next : next . stack
; invalids = Invalid Location sDomain. widen ~ num_iters ~ prev : prev . invalids ~ next : next . invalids
; invalids = Invalid Addresse sDomain. widen ~ num_iters ~ prev : prev . invalids ~ next : next . invalids
}
let pp fmt { heap ; stack ; invalids } =
F . fprintf fmt " {@[<v1> heap=@[<hv>%a@];@;stack=@[<hv>%a@];@;invalids=@[<hv>%a@];@]} "
MemoryDomain . pp heap AliasingDomain . pp stack Invalid Location sDomain. pp invalids
MemoryDomain . pp heap AliasingDomain . pp stack Invalid Addresse sDomain. pp invalids
end
include Domain
module Diagnostic = struct
(* TODO: more structured error type so that we can actually report something informative about
the variables being accessed along with a trace * )
type t = InvalidLocation of AbstractLocation . t
type t =
| AccessToInvalidAddress of
{ invalidated_at : actor
; accessed_by : actor
; address : AbstractAddress . t }
let to_string ( InvalidLocation loc ) = F . asprintf " invalid location %a " AbstractLocation . pp loc
end
let get_location ( AccessToInvalidAddress { accessed_by = { location } } ) = location
type ' a access_result = ( ' a , t * Diagnostic . t ) result
let get_message ( AccessToInvalidAddress { accessed_by ; invalidated_at ; address } ) =
let pp_debug_address f =
if Config . debug_mode then F . fprintf f " (debug: %a) " AbstractAddress . pp address
in
F . asprintf " `%a` accesses address `%a` past its lifetime%t " AccessExpression . pp
accessed_by . access_expr AccessExpression . pp invalidated_at . access_expr pp_debug_address
let get_trace ( AccessToInvalidAddress { accessed_by ; invalidated_at } ) =
[ Errlog . make_trace_element 0 invalidated_at . location
( F . asprintf " invalidated `%a` here " AccessExpression . pp invalidated_at . access_expr )
[]
; Errlog . make_trace_element 0 accessed_by . location
( F . asprintf " accessed `%a` here " AccessExpression . pp accessed_by . access_expr )
[] ]
(* * Check that the location is not known to be invalid *)
let check_loc_access loc astate =
if AbstractLocationsDomain . mem loc astate . invalids then
Error ( astate , Diagnostic . InvalidLocation loc )
else Ok astate
let get_issue_type ( AccessToInvalidAddress _ ) = IssueType . use_after_lifetime
end
type ' a access_result = ( ' a , t * Diagnostic . t ) result
(* * Walk the heap starting from [loc] and following [path]. Stop either at the element before last
and return [ new_loc ] if [ overwrite_last ] is [ Some new_loc ] , or go until the end of the path if it
is [ None ] . Create more locations into the heap as needed to follow the [ path ] . Check that each
location reached is valid . * )
let rec walk ~ overwrite_last loc path astate =
(* * Check that the address is not known to be invalid *)
let check_addr_access actor address astate =
match InvalidAddressesDomain . get_invalidation address astate . invalids with
| Some invalidated_at ->
Error
( astate , Diagnostic . AccessToInvalidAddress { invalidated_at ; accessed_by = actor ; address } )
| None ->
Ok astate
(* * Walk the heap starting from [addr] and following [path]. Stop either at the element before last
and return [ new_addr ] if [ overwrite_last ] is [ Some new_addr ] , or go until the end of the path if it
is [ None ] . Create more addresses into the heap as needed to follow the [ path ] . Check that each
address reached is valid . * )
let rec walk actor ~ overwrite_last addr path astate =
match ( path , overwrite_last ) with
| [] , None ->
Ok ( astate , loc )
Ok ( astate , addr )
| [] , Some _ ->
L . die InternalError " Cannot overwrite last location in empty path "
| [ a ] , Some new_loc ->
check_loc_access loc astate
L . die InternalError " Cannot overwrite last address in empty path"
| [ a ] , Some new_ addr ->
check_ addr_access actor addr astate
> > | fun astate ->
let heap = MemoryDomain . add_edge loc a new_loc astate . heap in
( { astate with heap } , new_loc )
let heap = MemoryDomain . add_edge addr a new_addr astate . heap in
( { astate with heap } , new_ addr )
| a :: path , _ -> (
check_ loc_access loc astate
check_ addr_access actor addr astate
> > = fun astate ->
match MemoryDomain . find_edge_opt loc a astate . heap with
match MemoryDomain . find_edge_opt addr a astate . heap with
| None ->
let loc' = AbstractLocation . mk_fresh () in
let heap = MemoryDomain . add_edge loc a loc ' astate . heap in
let addr' = AbstractAddress . mk_fresh () in
let heap = MemoryDomain . add_edge addr a addr ' astate . heap in
let astate = { astate with heap } in
walk ~ overwrite_last loc ' path astate
| Some loc ' ->
walk ~ overwrite_last loc ' path astate )
walk actor ~ overwrite_last addr ' path astate
| Some addr ' ->
walk actor ~ overwrite_last addr ' path astate )
(* * add locations to the state to give a location to the destination of the given access path *)
let walk_access_expr ? overwrite_last astate access_expr =
(* * add addresses to the state to give a address to the destination of the given access path *)
let walk_access_expr ? overwrite_last astate access_expr location =
let ( access_var , _ ) , access_list = AccessExpression . to_access_path access_expr in
match ( overwrite_last , access_list ) with
| Some new_ loc , [] ->
let stack = AliasingDomain . add access_var new_ loc astate . stack in
Ok ( { astate with stack } , new_ loc )
| Some new_ addr , [] ->
let stack = AliasingDomain . add access_var new_ addr astate . stack in
Ok ( { astate with stack } , new_ addr )
| None , _ | Some _ , _ :: _ ->
let astate , base_ loc =
let astate , base_ addr =
match AliasingDomain . find_opt access_var astate . stack with
| Some loc ->
( astate , loc )
| Some addr ->
( astate , addr )
| None ->
let loc = AbstractLocation . mk_fresh () in
let stack = AliasingDomain . add access_var loc astate . stack in
( { astate with stack } , loc )
let addr = AbstractAddress . mk_fresh () in
let stack = AliasingDomain . add access_var addr astate . stack in
( { astate with stack } , addr )
in
walk ~ overwrite_last base_loc access_list astate
let actor = { access_expr ; location } in
walk actor ~ overwrite_last base_addr access_list astate
(* * Use the stack and heap to walk the access path represented by the given expression down to an
abstract location representing what the expression points to .
abstract address representing what the expression points to .
Return an error state if it traverses some known invalid location or if the end destination is
Return an error state if it traverses some known invalid address or if the end destination is
known to be invalid . * )
let materialize_ location astate access_expr = walk_access_expr astate access_expr
let materialize_ address astate access_expr = walk_access_expr astate access_expr
(* * Use the stack and heap to walk the access path represented by the given expression down to an
abstract location representing what the expression points to , and replace that with the given
location .
abstract address representing what the expression points to , and replace that with the given
address .
Return an error state if it traverses some known invalid location . * )
let overwrite_ location astate access_expr new_loc =
walk_access_expr ~ overwrite_last : new_ loc astate access_expr
Return an error state if it traverses some known invalid address . * )
let overwrite_ address astate access_expr new_addr =
walk_access_expr ~ overwrite_last : new_ addr astate access_expr
(* * Add the given location to the set of know invalid location s. *)
let mark_invalid loc astate =
{ astate with invalids = AbstractLocationsDomain. add loc astate . invalids }
(* * Add the given address to the set of know invalid addresse s. *)
let mark_invalid actor address astate =
{ astate with invalids = InvalidAddressesDomain. add address actor astate . invalids }
let read access_expr astate =
materialize_location astate access_expr
> > = fun ( astate , loc ) -> check_loc_access loc astate > > | fun astate -> ( astate , loc )
let read location access_expr astate =
materialize_address astate access_expr location
> > = fun ( astate , addr ) ->
let actor = { access_expr ; location } in
check_addr_access actor addr astate > > | fun astate -> ( astate , addr )
let read_all access_exprs astate =
let read_all location access_exprs astate =
List . fold_result access_exprs ~ init : astate ~ f : ( fun astate access_expr ->
read access_expr astate > > | fst )
read location access_expr astate > > | fst )
let write access_expr loc astate =
overwrite_ location astate access_expr loc > > | fun ( astate , _ ) -> astate
let write location access_expr addr astate =
overwrite_ address astate access_expr addr location > > | fun ( astate , _ ) -> astate
let invalidate access_expr astate =
materialize_location astate access_expr
> > = fun ( astate , loc ) -> check_loc_access loc astate > > | mark_invalid loc
let invalidate location access_expr astate =
materialize_address astate access_expr location
> > = fun ( astate , addr ) ->
let actor = { access_expr ; location } in
check_addr_access actor addr astate > > | mark_invalid actor addr