Olivier
/
inferno-experimental
2
0
Fork 1
Code Issues 15 Pull Requests 6 Releases Wiki Activity

[WIP] Immutable equalities environment.

Browse Source
equality-constraint-env-immutable
Olivier 3 months ago
parent bbb1a1b158
commit 075dda1686
1 changed files with 112 additions and 73 deletions
Show Stats Download Patch File Download Diff File

185
src/Generalization.ml
Unescape View File

@ -74,21 +74,25 @@ module EqEnv : sig
and structure =
S of vertex Abs.structure [@@unboxed]
val add: vertex -> unit
type eqenv
val remove_edges_at_scope: scope -> unit
val init: unit -> eqenv
val add: eqenv -> vertex -> eqenv
val remove_edges_at_scope: eqenv -> scope -> eqenv
val get_rigid: int -> vertex
val is_bounded: vertex -> bool
val is_bounded: eqenv -> vertex -> bool
exception InconsistentContext
val is_consistent: eqenv -> bool
val add_equality: scope -> vertex -> vertex -> unit
val add_equality: eqenv -> scope -> vertex -> vertex -> eqenv
val eq: vertex -> vertex -> scope option
val eq: eqenv -> vertex -> vertex -> scope option
val get_structure: vertex -> vertex Abs.structure * scope
val get_structure: eqenv -> vertex -> vertex Abs.structure * scope
end = struct
@ -108,74 +112,108 @@ end = struct
(* For each equality, we store a scope, that corresponds to the scope
where the equality is well-defined. We represent our graph with a
hash-table mapping vertices to pairs of vertex and scope.
hash-table [table] mapping vertices to pairs of vertex and scope.
For every mapping (v1 -> (v2,scope)) we store a mapping
(v2 -> (v1,scope)) as well, so as to provide an undirected graph. *)
let table : (vertex, (vertex * scope) option) StructTable.t =
StructTable.create 64
type equalities_graph = (vertex, (vertex * scope) option) StructTable.t
(* Each time we add a new edge, we add its two vertices in a stack
[added_edges] with the corresponding scope. *)
type edges_stack = (scope * vertex * vertex) Stack.t
(* Each time we add a new edge, we add its two vertices in a stack with
the corresponding scope. *)
type eqenv =
| Equations of { table: equalities_graph ; added_edges : edges_stack}
| Inconsistent of scope
let stack : (scope * vertex * vertex) Stack.t =
Stack.create ()
let init () =
let table = StructTable.create 64 in
let added_edges = Stack.create () in
Equations { table; added_edges }
let table eqenv =
match eqenv with
| Equations { table ; _ } ->
table
| Inconsistent _ ->
assert false
let added_edges eqenv =
match eqenv with
| Equations { added_edges ; _ } ->
added_edges
| Inconsistent _ ->
assert false
let consistent eqenv =
match eqenv with
| Equations _ ->
true
| Inconsistent _ ->
false
(* ------------------------------------------------------------------------ *)
(* Add vertices and edges. *)
let add v =
if not (StructTable.mem table v) then
StructTable.add table v None
let add eqenv v =
if not (StructTable.mem (table eqenv) v) then
StructTable.add (table eqenv) v None;
eqenv
(* [add_directed_edge v1 v2 scope] adds an edge between [v1] and [v2] with
[scope]. If [v1] pointed to None, then remove this binding beforehand. *)
let add_directed_edge scope v1 v2 =
if StructTable.find table v1 = None then
StructTable.remove table v1;
StructTable.add table v1 (Some (v2,scope))
let add_directed_edge eqenv scope v1 v2 =
if StructTable.find (table eqenv) v1 = None then
StructTable.remove (table eqenv) v1;
StructTable.add (table eqenv) v1 (Some (v2,scope))
(* Add a binding in both ways. *)
let add_edge scope v1 v2 =
assert (StructTable.mem table v1);
assert (StructTable.mem table v2);
add_directed_edge scope v1 v2;
add_directed_edge scope v2 v1;
Stack.push (scope, v1, v2) stack
let remove_directed_edge scope v =
let add_edge eqenv scope v1 v2 =
assert (StructTable.mem (table eqenv) v1);
assert (StructTable.mem (table eqenv) v2);
add_directed_edge eqenv scope v1 v2;
add_directed_edge eqenv scope v2 v1;
Stack.push (scope, v1, v2) (added_edges eqenv);
eqenv
let remove_directed_edge eqenv scope v =
(* The last created edge should have the maximum scope and [remove_edge]
should be used to remove maximum scope. *)
assert (StructTable.find table v |> Option.get |> snd = scope);
StructTable.remove table v
assert (StructTable.find (table eqenv) v |> Option.get |> snd = scope);
StructTable.remove (table eqenv) v
let remove_edge (scope,v1,v2) =
remove_directed_edge scope v1;
remove_directed_edge scope v2
let remove_edge eqenv (scope,v1,v2) =
remove_directed_edge eqenv scope v1;
remove_directed_edge eqenv scope v2
let remove_edges_at_scope scope =
let remove_edges_at_scope eqenv scope =
let top_scope () =
let (top_scope,_,_) = Stack.top stack in
let (top_scope,_,_) = Stack.top (added_edges eqenv) in
top_scope
in
while top_scope () = scope do
remove_edge (Stack.pop stack)
done
remove_edge eqenv (Stack.pop (added_edges eqenv))
done;
eqenv
let get_rigid n =
S (Abs.Abstract n)
let is_bounded v =
StructTable.mem table v
let is_bounded eqenv v =
StructTable.mem (table eqenv) v
let is_consistent eqenv =
consistent eqenv
(* ------------------------------------------------------------------------ *)
(* Searching through the graph. *)
let get_neighbours v =
assert (StructTable.mem table v);
let vs = StructTable.find_all table v in
let get_neighbours eqenv v =
assert (StructTable.mem (table eqenv) v);
let vs = StructTable.find_all (table eqenv) v in
match vs with
(* [v] is either disconnected, and its only neighbour is None ... *)
| [None] ->
@ -193,7 +231,7 @@ end = struct
search through the graph, stopping when the predicate [stop] becomes true.
It maintains a worklist of nodes to visit, each associated with a maximum
scope encountered along the way, and a list of already visited vertices. *)
let rec search (stop : vertex -> bool) (vs : (vertex * scope) list)
let rec search eqenv (stop : vertex -> bool) (vs : (vertex * scope) list)
(visited : vertex list)
: (vertex * scope) option =
match vs with
@ -211,7 +249,7 @@ end = struct
let unexplored_neighbours =
List.filter (fun (v,_) ->
not (List.mem v visited)
) (get_neighbours v1)
) (get_neighbours eqenv v1)
in
(* ... associate the new maximum scope to them ... *)
let neighbours_scope_max =
@ -220,25 +258,25 @@ end = struct
) unexplored_neighbours
in
(* ... and call ourselves recursively with the unvisited vertices *)
search stop (neighbours_scope_max @ vs) (v1 :: visited)
search eqenv stop (neighbours_scope_max @ vs) (v1 :: visited)
let search stop v1 scope =
search stop [(v1,scope)] []
let search eqenv stop v1 scope =
search eqenv stop [(v1,scope)] []
let path_exists v1 v2 =
assert (StructTable.mem table v1);
assert (StructTable.mem table v2);
let path_exists eqenv v1 v2 =
assert (StructTable.mem (table eqenv) v1);
assert (StructTable.mem (table eqenv) v2);
let stop =
( = ) v2
in
match search stop v1 base_scope with
match search eqenv stop v1 base_scope with
| None ->
false
| Some _ ->
true
let get_structure v : vertex Abs.structure * scope =
assert (StructTable.mem table v);
let get_structure eqenv v : vertex Abs.structure * scope =
assert (StructTable.mem (table eqenv) v);
let stop v =
match v with
| S (Abs.User _) ->
@ -246,7 +284,7 @@ end = struct
| S (Abs.Abstract _) ->
false
in
match search stop v base_scope with
match search eqenv stop v base_scope with
| None ->
(* If the vertex is not connected to a structure return itself
(an abstract structure).
@ -286,7 +324,7 @@ end = struct
(* The context can become inconsistent if we try to unify two different
structures, otherwise we just add a new edge between the two vertices
we try to unify (and between their leaves if necessary). *)
let rec unify_struct mode scope
let rec unify_struct eqenv mode scope
(s1:vertex Abs.structure) (s2:vertex Abs.structure) =
match s1, s2 with
(* At least one abstract.*)
@ -294,7 +332,7 @@ end = struct
| _, Abs.Abstract _ ->
begin match mode with
| Input ->
add_edge scope (S s1) (S s2)
ignore (add_edge eqenv scope (S s1) (S s2))
| Check ->
raise Clash
end
@ -303,7 +341,7 @@ end = struct
| Abs.User v1, Abs.User v2 ->
(* Try to unify the two structures (including their leaves) ...*)
try
ignore (Struc.conjunction (unify mode scope) v1 v2)
ignore (Struc.conjunction (unify eqenv mode scope) v1 v2)
(* ... if it fails, we have an inconsistent context. *)
with S.InconsistentConjunction ->
match mode with
@ -312,36 +350,40 @@ end = struct
| Check ->
raise Clash
and unify mode scope v1 v2 =
if not (path_exists v1 v2) then
let (s1,scope1) = get_structure v1 in
let (s2,scope2) = get_structure v2 in
and unify eqenv mode scope v1 v2 =
if not (path_exists eqenv v1 v2) then
let (s1,scope1) = get_structure eqenv v1 in
let (s2,scope2) = get_structure eqenv v2 in
(* TODO : is that correct / mandatory ? *)
let scope = max scope (max scope1 scope2) in
unify_struct mode scope s1 s2
unify_struct eqenv mode scope s1 s2
(* Adding an equality amounts to unify two vertices of the graph. *)
let add_equality scope v1 v2 : unit =
unify Input scope v1 v2
let add_equality eqenv scope v1 v2 =
try
unify eqenv Input scope v1 v2;
eqenv
with InconsistentContext ->
Inconsistent scope
(* ------------------------------------------------------------------------ *)
(* Equality test. *)
let eq v1 v2 : scope option =
assert (StructTable.mem table v1);
assert (StructTable.mem table v2);
let eq eqenv v1 v2 : scope option =
assert (StructTable.mem (table eqenv) v1);
assert (StructTable.mem (table eqenv) v2);
(* The stopping condition of the search is a succeeding unification with
the vertex [v2]. *)
let stop v1 =
try
unify Check dummy_scope v1 v2;
unify eqenv Check dummy_scope v1 v2;
true
with Clash ->
false
in
(* Returns only the scope. *)
Option.map snd @@ search stop v1 base_scope
Option.map snd @@ search eqenv stop v1 base_scope
end (* EqEnv *)
@ -801,9 +843,6 @@ type variable =
let get : variable -> variable Data.data =
U.get
exception InconsistentContext =
EqEnv.InconsistentContext
exception VariableScopeEscape =
U.VariableScopeEscape

Write Preview
Loading…
Cancel
Save