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
Open sidebar
Why3
why3
Commits
4fdf05d5
Commit
4fdf05d5
authored
Jan 29, 2017
by
Andrei Paskevich
Browse files
invariants: cap_of_term
parent
bc202df4
Changes
1
Hide whitespace changes
Inline
Sidebyside
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
nonzero
point (a
record with a breakable invariant), a constructible
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 noncommitted
record with a breakable invariant), a constructible
value
(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