diff --git a/src/analyses/basePriv.ml b/src/analyses/basePriv.ml index 3843dda300..e42cd5a309 100644 --- a/src/analyses/basePriv.ml +++ b/src/analyses/basePriv.ml @@ -211,12 +211,12 @@ struct let thread_join ?(force=false) ask get e st = st let thread_return ask get set tid st = st - let invariant_global getg g = - match g with - | `Left _ -> (* mutex *) - Invariant.none + let invariant_global getg = function | `Right g' -> (* global *) ValueDomain.invariant_global (read_unprotected_global getg) g' + | _ -> (* mutex *) + Invariant.none + end module PerMutexOplusPriv: S = @@ -625,13 +625,11 @@ struct let get_mutex_inits' = CPA.find x get_mutex_inits in VD.join get_mutex_global_x' get_mutex_inits' - let invariant_global getg g = - match g with - | `Left (`Left _) -> (* mutex *) - Invariant.none - | `Left (`Right g') -> (* global *) - ValueDomain.invariant_global (read_unprotected_global getg) g' - | `Right _ -> (* thread *) + let invariant_global getg = function + | `Middle g -> (* global *) + ValueDomain.invariant_global (read_unprotected_global getg) g + | `Left _ + | `Right _ -> (* mutex or thread *) Invariant.none end @@ -847,16 +845,15 @@ struct open Locksets - let invariant_global getg g = - match g with - | `Left _ -> (* mutex *) - Invariant.none + let invariant_global getg = function | `Right g' -> (* global *) ValueDomain.invariant_global (fun x -> GWeak.fold (fun s' tm acc -> WeakRange.fold_weak VD.join tm acc ) (G.weak (getg (V.global x))) (VD.bot ()) ) g' + | _ -> (* mutex *) + Invariant.none let invariant_vars ask getg st = let module VS = Set.Make (CilType.Varinfo) in diff --git a/src/analyses/commonPriv.ml b/src/analyses/commonPriv.ml index 88181000b9..73a2e75de1 100644 --- a/src/analyses/commonPriv.ml +++ b/src/analyses/commonPriv.ml @@ -85,11 +85,10 @@ struct end module V = struct - (* TODO: Either3? *) - include Printable.Either (struct include Printable.Either (VMutex) (VMutexInits) let name () = "mutex" end) (VGlobal) + include Printable.Either3 (VMutex) (VMutexInits) (VGlobal) let name () = "MutexGlobals" - let mutex x: t = `Left (`Left x) - let mutex_inits: t = `Left (`Right ()) + let mutex x: t = `Left x + let mutex_inits: t = `Middle () let global x: t = `Right x end diff --git a/src/common/domains/printable.ml b/src/common/domains/printable.ml index b0755fb730..3499cfdb04 100644 --- a/src/common/domains/printable.ml +++ b/src/common/domains/printable.ml @@ -273,6 +273,40 @@ struct | `Right x -> `Right (Base2.relift x) end +module Either3 (Base1: S) (Base2: S) (Base3: S) = +struct + type t = [`Left of Base1.t | `Middle of Base2.t | `Right of Base3.t] [@@deriving eq, ord, hash] + include Std + + let pretty () (state:t) = + match state with + | `Left n -> Pretty.dprintf "%s:%a" (Base1.name ()) Base1.pretty n + | `Middle n -> Pretty.dprintf "%s:%a" (Base2.name ()) Base2.pretty n + | `Right n -> Pretty.dprintf "%s:%a" (Base3.name ()) Base3.pretty n + + let show state = + match state with + | `Left n -> (Base1.name ()) ^ ":" ^ Base1.show n + | `Middle n -> (Base2.name ()) ^ ":" ^ Base2.show n + | `Right n -> (Base3.name ()) ^ ":" ^ Base3.show n + + let name () = "either " ^ Base1.name () ^ " or " ^ Base2.name () ^ " or " ^ Base3.name () + let printXml f = function + | `Left x -> BatPrintf.fprintf f "\n\nLeft\n\n%a\n\n" Base1.printXml x + | `Middle x -> BatPrintf.fprintf f "\n\nMiddle\n\n%a\n\n" Base2.printXml x + | `Right x -> BatPrintf.fprintf f "\n\nRight\n\n%a\n\n" Base3.printXml x + + let to_yojson = function + | `Left x -> `Assoc [ Base1.name (), Base1.to_yojson x ] + | `Middle x -> `Assoc [ Base2.name (), Base2.to_yojson x ] + | `Right x -> `Assoc [ Base3.name (), Base3.to_yojson x ] + + let relift = function + | `Left x -> `Left (Base1.relift x) + | `Middle x -> `Middle (Base2.relift x) + | `Right x -> `Right (Base3.relift x) +end + module Option (Base: S) (N: Name) = struct type t = Base.t option [@@deriving eq, ord, hash] diff --git a/src/framework/constraints.ml b/src/framework/constraints.ml index b1bbc73660..b6046d023b 100644 --- a/src/framework/constraints.ml +++ b/src/framework/constraints.ml @@ -1467,14 +1467,14 @@ struct module V = struct - include Printable.Either (S.V) (Printable.Either (Printable.Prod (Node) (C)) (Printable.Prod (CilType.Fundec) (C))) + include Printable.Either3 (S.V) (Printable.Prod (Node) (C)) (Printable.Prod (CilType.Fundec) (C)) let name () = "longjmp" let s x = `Left x - let longjmpto x = `Right (`Left x) - let longjmpret x = `Right (`Right x) + let longjmpto x = `Middle x + let longjmpret x = `Right x let is_write_only = function | `Left x -> S.V.is_write_only x - | `Right _ -> false + | _ -> false end module G = @@ -1511,7 +1511,7 @@ struct begin match g with | `Left g -> S.query (conv ctx) (WarnGlobal (Obj.repr g)) - | `Right g -> + | _ -> Queries.Result.top q end | InvariantGlobal g -> @@ -1519,7 +1519,7 @@ struct begin match g with | `Left g -> S.query (conv ctx) (InvariantGlobal (Obj.repr g)) - | `Right g -> + | _ -> Queries.Result.top q end | IterSysVars (vq, vf) ->