Skip to content
GitLab
Projects
Groups
Snippets
Help
Loading...
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Contribute to GitLab
Sign in
Toggle navigation
why3
Project overview
Project overview
Details
Activity
Releases
Repository
Repository
Files
Commits
Branches
Tags
Contributors
Graph
Compare
Issues
125
Issues
125
List
Boards
Labels
Service Desk
Milestones
Merge Requests
15
Merge Requests
15
Operations
Operations
Incidents
Packages & Registries
Packages & Registries
Container Registry
Analytics
Analytics
Repository
Value Stream
Wiki
Wiki
Snippets
Snippets
Members
Members
Collapse sidebar
Close sidebar
Activity
Graph
Create a new issue
Commits
Issue Boards
Open sidebar
Why3
why3
Commits
4fdf05d5
Commit
4fdf05d5
authored
Jan 29, 2017
by
Andrei Paskevich
Browse files
Options
Browse Files
Download
Email Patches
Plain Diff
invariants: cap_of_term
parent
bc202df4
Changes
1
Hide whitespace changes
Inline
Side-by-side
Showing
1 changed file
with
222 additions
and
51 deletions
+222
-51
src/mlw/eval_match.ml
src/mlw/eval_match.ml
+222
-51
No files found.
src/mlw/eval_match.ml
View file @
4fdf05d5
...
...
@@ -23,18 +23,21 @@ open Pdecl
let
ls_of_rs
s
=
match
s
.
rs_logic
with
RLls
ls
->
ls
|
_
->
assert
false
let
is_projection
kn
ls
=
ls
.
ls_constr
=
0
&&
match
Mid
.
find
ls
.
ls_name
kn
with
|
{
pd_node
=
PDtype
_
}
->
true
|
_
->
false
let
is_projection
ls
=
ls
.
ls_constr
=
0
&&
try
(
restore_rs
ls
)
.
rs_field
<>
None
with
Not_found
->
false
let
find_constructors
kn
({
ts_name
=
id
}
as
ts
)
=
let
find_constructors
_ts
kn
({
ts_name
=
id
}
as
ts
)
=
let
rec
find
=
function
|
{
d_news
=
s
}
::
dl
when
not
(
Mid
.
mem
id
s
)
->
find
dl
|
{
d_node
=
Ddata
dl
}
::_
->
List
.
assq
ts
dl
|
_
->
[]
in
find
(
Mid
.
find
id
kn
)
.
pd_pure
let
find_constructors
kn
ty
=
match
ty
.
ty_node
with
|
Tyapp
(
ts
,
_
)
->
find_constructors_ts
kn
ts
|
_
->
[]
let
find_logic_definition
kn
({
ls_name
=
id
}
as
ls
)
=
let
rec
find
=
function
|
{
d_news
=
s
}
::
dl
when
not
(
Mid
.
mem
id
s
)
->
find
dl
...
...
@@ -42,17 +45,20 @@ let find_logic_definition kn ({ls_name = id} as ls) =
|
_
->
None
in
find
(
Mid
.
find
id
kn
)
.
pd_pure
let
apply_projection
kn
ls
cs
tl
=
let
ts
=
match
cs
.
ls_value
with
|
Some
{
ty_node
=
Tyapp
(
ts
,_
)
}
->
ts
let
find_constructor_fields
kn
cs
=
let
ty
=
Opt
.
get
cs
.
ls_value
in
try
List
.
assq
cs
(
find_constructors
kn
ty
)
with
Not_found
->
assert
false
let
find_projection_field
pj
tl
pjl
=
let
rec
find
tl
pjl
=
match
tl
,
pjl
with
|
t
::_,
Some
ls
::_
when
ls_equal
pj
ls
->
t
|
_
::
tl
,
_
::
pjl
->
find
tl
pjl
|
_
->
assert
false
in
let
pjl
=
try
List
.
assq
cs
(
find_constructors
kn
ts
)
with
Not_found
->
assert
false
in
let
find
acc
v
=
function
|
Some
pj
when
ls_equal
pj
ls
->
v
|
_
->
acc
in
List
.
fold_left2
find
t_true
tl
pjl
find
tl
pjl
let
apply_projection
kn
pj
cs
tl
=
find_projection_field
pj
tl
(
find_constructor_fields
kn
cs
)
(* Part I - Invariant handling *)
...
...
@@ -60,6 +66,26 @@ let ls_valid =
let
v
=
create_tvsymbol
(
id_fresh
"a"
)
in
create_psymbol
(
id_fresh
"valid"
)
[
ty_var
v
]
let
its_solid
s
=
not
s
.
its_fragile
&&
(* no need to go any further *)
List
.
for_all
(
fun
f
->
f
.
its_frozen
)
s
.
its_arg_flg
&&
List
.
for_all
(
fun
f
->
f
.
its_frozen
)
s
.
its_reg_flg
let
is_fragile_constructor
ls
=
ls
.
ls_constr
>
0
&&
match
(
Opt
.
get
ls
.
ls_value
)
.
ty_node
with
|
Tyapp
(
s
,_
)
->
not
(
its_solid
(
restore_its
s
))
|
_
->
assert
false
let
is_fragile_projection
ls
=
ls
.
ls_constr
=
0
&&
try
let
rs
=
restore_rs
ls
in
if
rs
.
rs_field
=
None
then
false
else
match
(
List
.
hd
rs
.
rs_cty
.
cty_args
)
.
pv_ity
.
ity_node
with
|
Ityreg
{
reg_its
=
s
}
|
Ityapp
(
s
,_,_
)
->
not
(
its_solid
s
)
|
_
->
assert
false
with
Not_found
->
false
(* Integer "points" represent individual values whose invariant
may be broken. The special point 0 represents any value with
verified invariant. Fresh points are assigned to values from
...
...
@@ -72,12 +98,13 @@ let ls_valid =
Recursive "caps" represent deconstructible values from which
points can be reached. Each variable is associated to a cap.
A cap is either a
zero point (committed value), a non-zero
point (a record with a breakable invariant), a constructibl
e
value (characterized by the set of possible constructors),
or
a record with an unbreakable invariant. *)
A cap is either a
committed value, a point (a non-committed
record with a breakable invariant), a constructible valu
e
(characterized by the set of possible constructors), or
a record with an unbreakable invariant. *)
type
cap
=
|
V
(* valid *)
|
P
of
int
(* point *)
|
C
of
cap
list
Mls
.
t
(* algebraic type *)
|
R
of
cap
Mls
.
t
(* record with an unbreakable invariant *)
...
...
@@ -89,7 +116,8 @@ type point = {
}
type
binding
=
|
E
of
point
(* endpoint *)
|
W
(* valid point *)
|
B
of
point
(* broken point *)
|
L
of
int
(* link *)
type
state
=
{
...
...
@@ -101,6 +129,19 @@ let new_point =
let
c
=
ref
0
in
fun
()
->
incr
c
;
!
c
let
rec
get_point
st
n
=
match
Mint
.
find_def
W
n
st
.
s_points
with
|
L
n
->
get_point
st
n
|
b
->
n
,
b
let
mkC
css
=
let
chk
_
l
=
List
.
for_all
(
function
V
->
true
|
_
->
false
)
l
in
if
Mls
.
for_all
chk
css
then
V
else
C
css
let
mkR
pjs
=
let
chk
_
c
=
match
c
with
V
->
true
|
_
->
false
in
if
Mls
.
for_all
chk
pjs
then
V
else
R
pjs
(* TODO:
- do not collapse on Eif and Ecase in k_expr when the type is fragile
*)
...
...
@@ -108,14 +149,12 @@ let new_point =
let
add_var
kn
st
v
=
let
rp
=
ref
st
.
s_points
in
let
rec
down
stem
leaf
ty
=
match
ty
.
ty_node
with
|
Tyvar
_
->
P
0
|
Tyvar
_
->
V
|
Tyapp
(
s
,
tl
)
->
let
s
=
restore_its
s
in
if
not
s
.
its_fragile
&&
(* no need to go any further *)
List
.
for_all
(
fun
f
->
f
.
its_frozen
)
s
.
its_arg_flg
&&
List
.
for_all
(
fun
f
->
f
.
its_frozen
)
s
.
its_reg_flg
then
P
0
else
let
sbs
=
List
.
fold_right2
Mtv
.
add
s
.
its_ts
.
ts_args
tl
Mtv
.
empty
in
if
its_solid
s
then
V
else
let
d
=
find_its_defn
kn
s
in
let
sbs
=
ts_match_args
s
.
its_ts
tl
in
if
s
.
its_nonfree
then
if
s
.
its_fragile
then
(* breakable record *)
let
rec
name
t
=
match
t
.
t_node
with
|
Tapp
(
pj
,
[
t
])
->
name
t
^
"_"
^
pj
.
ls_name
.
id_string
...
...
@@ -128,7 +167,7 @@ let add_var kn st v =
let
v
=
create_vsymbol
(
id_fresh
nm
)
ty
in
Mls
.
add
(
ls_of_rs
f
)
(
v
,
down
[]
(
t_var
v
)
ty
)
m
in
let
pjs
=
List
.
fold_left
add_field
Mls
.
empty
d
.
itd_fields
in
let
bd
=
E
{
p_leaf
=
leaf
;
p_stem
=
stem
;
p_fields
=
pjs
}
in
let
bd
=
B
{
p_leaf
=
leaf
;
p_stem
=
stem
;
p_fields
=
pjs
}
in
let
np
=
new_point
()
in
rp
:=
Mint
.
add
np
bd
!
rp
;
P
np
...
...
@@ -136,10 +175,8 @@ let add_var kn st v =
let
add_field
m
f
=
let
pj
=
ls_of_rs
f
in
let
ty
=
Ty
.
ty_inst
sbs
(
Opt
.
get
f
.
rs_field
)
.
pv_vs
.
vs_ty
in
match
down
stem
(
fs_app
pj
[
leaf
]
ty
)
ty
with
|
P
0
->
m
|
c
->
Mls
.
add
pj
c
m
in
let
pjs
=
List
.
fold_left
add_field
Mls
.
empty
d
.
itd_fields
in
if
Mls
.
is_empty
pjs
then
P
0
else
R
pjs
Mls
.
add
pj
(
down
stem
(
fs_app
pj
[
leaf
]
ty
)
ty
)
m
in
mkR
(
List
.
fold_left
add_field
Mls
.
empty
d
.
itd_fields
)
else
(* constructible type *)
let
add_field
m
f
=
Mpv
.
add
(
Opt
.
get
f
.
rs_field
)
(
ls_of_rs
f
)
m
in
let
pjm
=
List
.
fold_left
add_field
Mpv
.
empty
d
.
itd_fields
in
...
...
@@ -159,21 +196,16 @@ let add_var kn st v =
let
v
=
Svs
.
choose
pat
.
pat_vars
in
down
((
leaf
,
pat
)
::
stem
)
(
t_var
v
)
ty_f
in
Mls
.
add
cs
(
List
.
map2
conv_field
c
.
rs_cty
.
cty_args
tyl
)
m
in
let
css
=
List
.
fold_left
add_constr
Mls
.
empty
d
.
itd_constructors
in
let
chk
_
l
=
List
.
for_all
(
function
P
0
->
true
|
_
->
false
)
l
in
if
Mls
.
for_all
chk
css
then
P
0
else
C
css
mkC
(
List
.
fold_left
add_constr
Mls
.
empty
d
.
itd_constructors
)
in
match
down
[]
(
t_var
v
)
v
.
vs_ty
with
|
P
0
->
st
(* not broken *)
|
V
->
st
(* not broken *)
|
c
->
{
s_roots
=
Mvs
.
add
v
c
st
.
s_roots
;
s_points
=
!
rp
}
let
is_committed
{
s_points
=
sp
}
c
=
let
cap_valid
st
c
=
let
rec
down
=
function
|
P
0
->
()
|
P
n
->
begin
match
Mint
.
find_opt
n
sp
with
|
Some
(
L
n
)
->
down
(
P
n
)
|
Some
(
E
_
)
->
raise
Exit
|
None
->
()
end
|
V
->
()
|
P
n
->
if
snd
(
get_point
st
n
)
<>
W
then
raise
Exit
|
C
css
->
Mls
.
iter
(
fun
_
fl
->
List
.
iter
down
fl
)
css
|
R
pjs
->
Mls
.
iter
(
fun
_
c
->
down
c
)
pjs
in
try
down
c
;
true
with
Exit
->
false
...
...
@@ -182,27 +214,166 @@ let add_pat st c p =
let
rec
down
rt
c
p
=
match
p
.
pat_node
with
|
Pwild
->
rt
|
Pvar
v
->
Mvs
.
add
v
c
rt
|
Papp
(
cs
,
pl
)
->
begin
match
c
with
|
Papp
(
cs
,
pl
)
->
begin
match
c
with
|
C
css
->
begin
match
Mls
.
find_opt
cs
css
with
|
Some
cl
->
List
.
fold_left2
down
rt
cl
pl
|
None
->
rt
(* all fields are committed *)
end
|
_
->
assert
false
(* should never happen *)
end
|
Por
_
->
assert
(
is_committe
d
st
c
);
rt
|
Por
_
->
assert
(
cap_vali
d
st
c
);
rt
|
Pas
(
p
,
v
)
->
Mvs
.
add
v
c
(
down
rt
c
p
)
in
{
st
with
s_roots
=
down
st
.
s_roots
c
p
}
let
rec
cap_join
st
c1
c2
=
match
c1
,
c2
with
|
V
,
c
|
c
,
V
->
assert
(
cap_valid
st
c
);
V
|
P
n1
,
P
n2
->
let
n1
,
b1
=
get_point
st
n1
in
let
n2
,
b2
=
get_point
st
n2
in
if
b1
=
W
then
begin
assert
(
b2
=
W
);
V
end
else
begin
assert
(
n1
=
n2
);
P
n1
end
|
C
s1
,
C
s2
->
let
join
_
l1
l2
=
Some
(
List
.
map2
(
cap_join
st
)
l1
l2
)
in
mkC
(
Mls
.
union
join
s1
s2
)
|
R
s1
,
R
s2
->
let
join
_
c1
c2
=
Some
(
cap_join
st
c1
c2
)
in
mkR
(
Mls
.
union
join
s1
s2
)
|
_
->
assert
false
let
cap_of_term
kn
st
t
=
let
rec
unroll
t
=
function
|
(
pj
,
t0
)
::
pjl
->
let
t
=
t_app
pj
[
t
]
t0
.
t_ty
in
unroll
(
t_label_copy
t0
t
)
pjl
|
[]
->
t
in
let
rec
unwind
t
c
pjl0
=
match
c
,
pjl0
with
|
_
,
[]
->
t
,
c
|
V
,
_
->
unroll
t
pjl0
,
V
|
P
n
,
(
pj
,
t0
)
::
pjl
->
begin
match
get_point
st
n
with
|
_
,
L
_
->
assert
false
(* never *)
|
_
,
W
->
unroll
t
pjl0
,
V
|
_
,
B
p
->
let
v
,
c
=
Mls
.
find
pj
p
.
p_fields
in
unwind
(
t_label_copy
t0
(
t_var
v
))
c
pjl
end
|
C
css
,
(
pj
,
t0
)
::
pjl
when
Mls
.
cardinal
css
=
1
->
let
cs
,
fl
=
Mls
.
choose
css
in
let
c
=
apply_projection
kn
pj
cs
fl
in
let
t
=
t_app
pj
[
t
]
t0
.
t_ty
in
unwind
(
t_label_copy
t0
t
)
c
pjl
|
C
css
,
(
pj
,
t0
)
::
pjl
->
let
ty
=
Opt
.
get
t
.
t_ty
in
let
v0
=
create_vsymbol
(
id_fresh
"q"
)
(
Opt
.
get
t0
.
t_ty
)
in
let
t0
=
t_label_copy
t0
(
t_var
v0
)
and
p0
=
pat_var
v0
in
let
bb
=
match
Mls
.
choose
css
with
|
{
ls_constr
=
len
}
,
_
when
len
>
Mls
.
cardinal
css
->
let
v
=
create_vsymbol
(
id_fresh
"q"
)
ty
in
[
t_close_branch
(
pat_var
v
)
(
unroll
(
t_var
v
)
pjl0
)]
|
_
->
[]
in
let
csl
,
sbs
=
match
ty
.
ty_node
with
|
Tyapp
(
ts
,
tl
)
->
find_constructors_ts
kn
ts
,
ts_match_args
ts
tl
|
_
->
assert
false
in
let
mk_branch
cs
fl
=
let
fdl
=
List
.
assq
cs
csl
in
let
mk_pat
fd_ty
fd
=
match
fd
with
|
Some
ls
when
ls_equal
pj
ls
->
p0
|
_
->
pat_wild
(
ty_inst
sbs
fd_ty
)
in
let
pl
=
List
.
map2
mk_pat
cs
.
ls_args
fdl
in
let
c
=
find_projection_field
pj
fl
fdl
in
let
t0
,
c
=
unwind
t0
c
pjl
in
t_close_branch
(
pat_app
cs
pl
ty
)
t0
,
c
in
let
add_branch
cs
fl
(
bl
,
cj
)
=
let
b
,
c
=
mk_branch
cs
fl
in
b
::
bl
,
Some
(
match
cj
with
|
Some
cj
->
cap_join
st
c
cj
|
None
->
c
)
in
let
bl
,
c
=
Mls
.
fold
add_branch
css
(
bb
,
None
)
in
t_case
t
bl
,
Opt
.
get
c
|
R
pjs
,
(
pj
,
t0
)
::
pjl
->
let
c
=
Mls
.
find
pj
pjs
in
let
t
=
t_app
pj
[
t
]
t0
.
t_ty
in
unwind
(
t_label_copy
t0
t
)
c
pjl
in
let
rec
down
sr
pjl
t
=
match
t
.
t_node
with
|
Tvar
v
->
(* projection propagation *)
unwind
t
(
Mvs
.
find_def
V
v
sr
)
pjl
|
Tconst
_
->
(* constants are valid *)
unroll
t
pjl
,
V
|
Tapp
(
ls
,
[
t1
;
t2
])
when
ls_equal
ls
ps_equ
->
let
t1
,
c1
=
down
sr
pjl
t1
in
let
t2
,
c2
=
down
sr
pjl
t2
in
ignore
(
cap_join
st
c1
c2
);
t_label_copy
t
(
t_equ
t1
t2
)
,
V
|
Tapp
(
ls
,
[
t1
])
when
is_fragile_projection
ls
->
down
sr
((
ls
,
t
)
::
pjl
)
t1
|
Tapp
(
ls
,
tl
)
when
is_fragile_constructor
ls
->
begin
match
pjl
with
|
(
pj
,
t0
)
::
pjl
->
let
t
=
apply_projection
kn
pj
ls
tl
in
down
sr
pjl
(
t_label_copy
t0
t
)
|
[]
->
let
tl
,
cl
=
List
.
split
(
List
.
map
(
down
sr
[]
)
tl
)
in
let
t
=
t_label_copy
t
(
t_app
ls
tl
t
.
t_ty
)
in
t
,
mkC
(
Mls
.
singleton
ls
cl
)
end
|
Tapp
(
ls
,
tl
)
->
let
tl
=
List
.
map
(
fun
t
->
let
t
,
c
=
down
sr
[]
t
in
assert
(
cap_valid
st
c
);
t
)
tl
in
unroll
(
t_label_copy
t
(
t_app
ls
tl
t
.
t_ty
))
pjl
,
V
|
Tif
(
t0
,
t1
,
t2
)
->
let
t0
,
_
=
down
sr
[]
t0
in
let
t1
,
c1
=
down
sr
pjl
t1
in
let
t2
,
c2
=
down
sr
pjl
t2
in
t_label_copy
t
(
t_if
t0
t1
t2
)
,
cap_join
st
c1
c2
|
Tlet
(
t0
,
tb
)
->
let
t0
,
c0
=
down
sr
[]
t0
in
let
v
,
t1
=
t_open_bound
tb
in
let
sr
=
Mvs
.
add
v
c0
sr
in
let
t1
,
c1
=
down
sr
pjl
t1
in
t_label_copy
t
(
t_let_close
v
t0
t1
)
,
c1
|
Tcase
(
t0
,
bl
)
->
let
t0
,
c0
=
down
sr
[]
t0
in
let
mk_branch
b
=
let
p
,
t1
=
t_open_branch
b
in
let
st
=
add_pat
{
st
with
s_roots
=
sr
}
c0
p
in
let
t1
,
c1
=
down
st
.
s_roots
pjl
t1
in
t_close_branch
p
t1
,
c1
in
let
add_branch
b
(
bl
,
cj
)
=
let
b
,
c
=
mk_branch
b
in
b
::
bl
,
Some
(
match
cj
with
|
Some
cj
->
cap_join
st
c
cj
|
None
->
c
)
in
let
bl
,
c
=
List
.
fold_right
add_branch
bl
([]
,
None
)
in
t_label_copy
t
(
t_case
t0
bl
)
,
Opt
.
get
c
|
Teps
tb
->
let
v
,
f
=
t_open_bound
tb
in
let
f
,
_
=
down
sr
[]
f
in
unroll
(
t_label_copy
t
(
t_eps_close
v
f
))
pjl
,
V
|
Tquant
(
q
,
tq
)
->
let
vl
,
tt
,
t0
=
t_open_quant
tq
in
let
down
t
=
fst
(
down
sr
[]
t
)
in
let
tt
=
List
.
map
(
List
.
map
down
)
tt
in
let
tq
=
t_close_quant
vl
tt
(
down
t0
)
in
t_label_copy
t
(
t_quant
q
tq
)
,
V
|
Tbinop
(
op
,
f1
,
f2
)
->
let
f1
,
_
=
down
sr
[]
f1
in
let
f2
,
_
=
down
sr
[]
f2
in
t_label_copy
t
(
t_binary
op
f1
f2
)
,
V
|
Tnot
f
->
let
f
,
_
=
down
sr
[]
f
in
t_label_copy
t
(
t_not
f
)
,
V
|
Ttrue
|
Tfalse
->
t
,
V
in
down
st
.
s_roots
[]
t
(* Part II - EvalMatch simplification *)
(* we destruct tuples, units, and singleton records *)
let
destructible
kn
ty
=
let
cl
=
match
ty
.
ty_node
with
|
Tyapp
(
ts
,
_
)
->
find_constructors
kn
ts
|
_
->
[]
in
match
cl
with
|
[
ls
,_
]
when
is_fs_tuple
ls
->
Some
ls
|
[{
ls_args
=
[
_
]}
as
ls
,
_
]
->
Some
ls
|
[{
ls_args
=
[]
}
as
ls
,
_
]
->
Some
ls
|
_
->
None
match
find_constructors
kn
ty
with
|
[
ls
,_
]
when
is_fs_tuple
ls
->
Some
ls
|
[{
ls_args
=
[
_
]}
as
ls
,
_
]
->
Some
ls
|
[{
ls_args
=
[]
}
as
ls
,
_
]
->
Some
ls
|
_
->
None
(* we inline projections of destructed types *)
let
find_inlineable
kn
ls
=
match
ls
.
ls_args
with
...
...
@@ -285,7 +456,7 @@ let rec eval_match kn stop env t =
t_label_copy
t
(
match
t
.
t_node
with
|
Tapp
(
ls
,
[
t1
;
t2
])
when
ls_equal
ls
ps_equ
->
cs_equ
env
(
eval
env
t1
)
(
eval
env
t2
)
|
Tapp
(
ls
,
[
t1
])
when
is_projection
kn
ls
->
|
Tapp
(
ls
,
[
t1
])
when
is_projection
ls
->
let
t1
=
eval
env
t1
in
let
fn
_env
_t2
cs
tl
=
apply_projection
kn
ls
cs
tl
in
begin
try
dive_to_constructor
fn
env
t1
...
...
Write
Preview
Markdown
is supported
0%
Try again
or
attach a new file
.
Attach a file
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Cancel
Please
register
or
sign in
to comment