Skip to content
GitLab
Menu
Projects
Groups
Snippets
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Contribute to GitLab
Sign in / Register
Toggle navigation
Menu
Open sidebar
Iris
RefinedC
Commits
74189201
Commit
74189201
authored
Nov 23, 2021
by
Michael Sammler
Browse files
improve liWand performance
parent
7b665ce0
Pipeline
#57781
passed with stage
in 25 minutes and 39 seconds
Changes
3
Pipelines
2
Show whitespace changes
Inline
Side-by-side
theories/lithium/benchmarks/dune
0 → 100644
View file @
74189201
(coq.theory
(name refinedc.lithium.benchmarks)
(package refinedc)
(flags -w -notation-overridden -w -redundant-canonical-projection)
(synopsis "Lithium benchmarks")
(theories refinedc.lithium))
theories/lithium/benchmarks/liWand.v
0 → 100644
View file @
74189201
Require
Import
iris
.
base_logic
.
lib
.
iprop
.
Require
Import
iris
.
proofmode
.
proofmode
.
Require
Import
refinedc
.
lithium
.
base
.
Require
Import
refinedc
.
lithium
.
tactics
.
Axiom
falso
:
False
.
Goal
∀
Σ
(
P
:
nat
→
iProp
Σ
),
ltac
:
(
let
x
:
=
eval
simpl
in
([
∗
list
]
i
∈
seq
0
100
,
P
i
)%
I
in
exact
x
)
-
∗
ltac
:
(
let
x
:
=
eval
simpl
in
([
∗
list
]
i
∈
seq
0
100
,
P
i
)%
I
in
exact
x
).
intros
Σ
P
.
iStartProof
.
(* Set Ltac Profiling. *)
(* Reset Ltac Profile. *)
time
"liWand"
repeat
(
liEnforceInvariant
;
liWand
).
(* Show Ltac Profile. *)
destruct
falso
.
Time
Qed
.
theories/lithium/interpreter.v
View file @
74189201
...
@@ -2,8 +2,6 @@ From iris.proofmode Require Import coq_tactics reduction.
...
@@ -2,8 +2,6 @@ From iris.proofmode Require Import coq_tactics reduction.
From
refinedc
.
lithium
Require
Import
base
infrastructure
classes
simpl_classes
tactics_extend
.
From
refinedc
.
lithium
Require
Import
base
infrastructure
classes
simpl_classes
tactics_extend
.
(** * Definitions of markers for controling the state *)
(** * Definitions of markers for controling the state *)
Definition
IPM_STATE
{
PROP
:
bi
}
(
n
:
positive
)
:
=
envs
PROP
.
Arguments
IPM_STATE
:
simpl
never
.
Notation
"'HIDDEN'"
:
=
(
Envs
_
_
_
)
(
only
printing
).
Notation
"'HIDDEN'"
:
=
(
Envs
_
_
_
)
(
only
printing
).
Definition
LET_ID
{
A
}
(
x
:
A
)
:
A
:
=
x
.
Definition
LET_ID
{
A
}
(
x
:
A
)
:
A
:
=
x
.
...
@@ -121,46 +119,37 @@ Section coq_tactics.
...
@@ -121,46 +119,37 @@ Section coq_tactics.
-
by
iApply
HQ
.
-
by
iApply
HQ
.
Qed
.
Qed
.
(* TODO: have a generic super intros which does simplification along
Lemma
tac_do_simplify_hyp
(
P
:
iProp
Σ
)
(
SH
:
SimplifyHyp
P
(
Some
0
%
N
))
Δ
T
:
the awy in an efficient manner and which subsumes SimplifyHypPlace, SimplifyHypVal and SimplImpl*)
envs_entails
Δ
(
SH
T
).(
i2p_P
)
→
Lemma
tac_do_intro
i
(
P
:
iProp
Σ
)
T
Δ
o
{
SH
:
SimplifyHyp
P
o
}
:
match
o
,
envs_app
false
(
Esnoc
Enil
i
P
)
Δ
with
|
Some
0
%
N
,
_
=>
envs_entails
Δ
(
SH
T
).(
i2p_P
)
|
_
,
None
=>
False
|
_
,
Some
Δ
'
=>
envs_entails
Δ
'
T
end
→
envs_entails
Δ
(
P
-
∗
T
).
envs_entails
Δ
(
P
-
∗
T
).
Proof
.
Proof
.
rewrite
envs_entails_eq
=>
HP
.
iIntros
"Henv Hl"
.
rewrite
envs_entails_eq
=>
HP
.
iIntros
"Henv Hl"
.
destruct
o
as
[[|?]
|].
{
iDestruct
(
HP
with
"Henv"
)
as
"HP"
.
iDestruct
(
HP
with
"Henv"
)
as
"HP"
.
iDestruct
(
i2p_proof
with
"HP Hl"
)
as
"$"
.
iDestruct
(
i2p_proof
with
"HP Hl"
)
as
"$"
.
}
all
:
case_match
=>
//.
all
:
rewrite
envs_app_sound
//=
;
simpl
.
all
:
iDestruct
(
"Henv"
with
"[$]"
)
as
"Henv"
.
all
:
by
iDestruct
(
HP
with
"Henv"
)
as
"$"
.
Qed
.
Qed
.
Lemma
tac_do_intro_intuit
i
(
P
P'
:
iProp
Σ
)
T
Δ
o
`
{!
IntroPersistent
P
P'
}
{
SH
:
SimplifyHyp
P
o
}
:
Lemma
tac_do_intro
i
n'
(
P
:
iProp
Σ
)
n
Γ
s
Γ
p
T
:
match
o
,
envs_app
true
(
Esnoc
Enil
i
P'
)
Δ
with
env_lookup
i
Γ
s
=
None
→
|
Some
0
%
N
,
_
=>
envs_entails
Δ
(
SH
T
).(
i2p_P
)
env_lookup
i
Γ
p
=
None
→
|
_
,
None
=>
False
envs_entails
(
Envs
Γ
p
(
Esnoc
Γ
s
i
P
)
n'
)
T
→
|
_
,
Some
Δ
'
=>
envs_entails
Δ
'
T
envs_entails
(
Envs
Γ
p
Γ
s
n
)
(
P
-
∗
T
).
end
→
envs_entails
Δ
(
P
-
∗
T
).
Proof
.
Proof
.
revert
select
(
IntroPersistent
_
_
)
=>
Hpers
.
rewrite
envs_entails_eq
=>
Hs
Hp
HP
.
iIntros
"Henv Hl"
.
rewrite
envs_entails_eq
=>
HP
.
iIntros
"Henv HP"
.
rewrite
(
envs_app_sound
(
Envs
Γ
p
Γ
s
n
)
(
Envs
Γ
p
(
Esnoc
Γ
s
i
P
)
n
)
false
(
Esnoc
Enil
i
P
))
//
;
simplify_option_eq
=>
//.
destruct
o
as
[[|?]
|].
{
iApply
HP
.
iApply
"Henv"
.
iFrame
.
iDestruct
(
HP
with
"Henv"
)
as
"HSH"
.
Qed
.
iDestruct
(
i2p_proof
with
"HSH HP"
)
as
"$"
.
}
Lemma
tac_do_intro_intuit
i
n'
(
P
P'
:
iProp
Σ
)
T
n
Γ
s
Γ
p
(
Hpers
:
IntroPersistent
P
P'
)
:
all
:
case_match
=>
//.
env_lookup
i
Γ
s
=
None
→
all
:
iDestruct
(@
ip_persistent
_
_
_
Hpers
with
"HP"
)
as
"#HP'"
.
env_lookup
i
Γ
p
=
None
→
all
:
rewrite
envs_app_sound
//=
;
simpl
.
envs_entails
(
Envs
(
Esnoc
Γ
p
i
P'
)
Γ
s
n'
)
T
→
all
:
iDestruct
(
"Henv"
with
"[$]"
)
as
"Henv"
.
envs_entails
(
Envs
Γ
p
Γ
s
n
)
(
P
-
∗
T
).
all
:
by
iDestruct
(
HP
with
"Henv"
)
as
"$"
.
Proof
.
rewrite
envs_entails_eq
=>
Hs
Hp
HP
.
iIntros
"Henv HP"
.
iDestruct
(@
ip_persistent
_
_
_
Hpers
with
"HP"
)
as
"#HP'"
.
rewrite
(
envs_app_sound
(
Envs
Γ
p
Γ
s
n
)
(
Envs
(
Esnoc
Γ
p
i
P'
)
Γ
s
n
)
true
(
Esnoc
Enil
i
P'
))
//
;
simplify_option_eq
=>
//.
iApply
HP
.
iApply
"Henv"
.
iModIntro
.
by
iSplit
.
Qed
.
Qed
.
Lemma
tac_true
Δ
:
Lemma
tac_true
Δ
:
...
@@ -245,11 +234,10 @@ Ltac li_pm_reduce_val v :=
...
@@ -245,11 +234,10 @@ Ltac li_pm_reduce_val v :=
let
v
:
=
reduction
.
pm_eval
v
in
v
.
let
v
:
=
reduction
.
pm_eval
v
in
v
.
Ltac
li_pm_reduce
:
=
Ltac
li_pm_reduce
:
=
match
goal
with
match
goal
with
|
H
:
IPM_STATE
_
|-
_
=>
|
H
:
=
Envs
_
_
_
|-
?u
=>
match
goal
with
|-
?u
=>
let
u
:
=
eval
cbv
[
H
]
in
u
in
let
u
:
=
eval
cbv
[
H
]
in
u
in
let
u
:
=
li_pm_reduce_val
u
in
change
u
let
u
:
=
li_pm_reduce_val
u
in
end
change
u
|
|-
?u
=>
|
|-
?u
=>
let
u
:
=
li_pm_reduce_val
u
in
let
u
:
=
li_pm_reduce_val
u
in
change
u
change
u
...
@@ -261,7 +249,6 @@ Local Tactic Notation "liChangeState" hyp(H) constr(Δ) :=
...
@@ -261,7 +249,6 @@ Local Tactic Notation "liChangeState" hyp(H) constr(Δ) :=
|
@
Envs
?PROP
_
_
?n
=>
|
@
Envs
?PROP
_
_
?n
=>
let
H'
:
=
fresh
"IPM_JANNO"
in
let
H'
:
=
fresh
"IPM_JANNO"
in
pose
(
H'
:
=
Δ
)
;
pose
(
H'
:
=
Δ
)
;
change
(
envs
PROP
)
with
(@
IPM_STATE
PROP
n
)
in
H'
;
clear
H
;
clear
H
;
rename
H'
into
H
rename
H'
into
H
end
.
end
.
...
@@ -271,16 +258,15 @@ Ltac liEnforceInvariant :=
...
@@ -271,16 +258,15 @@ Ltac liEnforceInvariant :=
|
|-
@
envs_entails
?PROP
?
Δ
?P
=>
|
|-
@
envs_entails
?PROP
?
Δ
?P
=>
let
with_H
tac
:
=
let
with_H
tac
:
=
match
goal
with
match
goal
with
|
[
H
:
IPM_STATE
_
|-
_
]
=>
|
[
H
:
=
Envs
_
_
_
|-
_
]
=>
lazymatch
Δ
with
H
=>
tac
H
|
_
=>
unify
Δ
(
H
)
;
tac
H
end
lazymatch
Δ
with
H
=>
tac
H
|
_
=>
unify
Δ
(
H
)
;
tac
H
end
|
[
H
:
IPM_STATE
_
|-
_
]
=>
|
[
H
:
=
Envs
_
_
_
|-
_
]
=>
liChangeState
H
Δ
;
tac
H
liChangeState
H
Δ
;
tac
H
|
_
=>
|
_
=>
match
Δ
with
match
Δ
with
|
Envs
_
_
?c
=>
|
Envs
_
_
?c
=>
let
H
:
=
fresh
"IPM_JANNO"
in
let
H
:
=
fresh
"IPM_JANNO"
in
pose
(
H
:
=
Δ
)
;
pose
(
H
:
=
Δ
)
;
change
(
envs
PROP
)
with
(@
IPM_STATE
PROP
c
)
in
H
;
hnf
in
(
value
of
H
)
;
hnf
in
(
value
of
H
)
;
tac
H
tac
H
end
end
...
@@ -292,7 +278,7 @@ Ltac liEnforceInvariant :=
...
@@ -292,7 +278,7 @@ Ltac liEnforceInvariant :=
Ltac
liFresh
:
=
Ltac
liFresh
:
=
lazymatch
goal
with
lazymatch
goal
with
|
[
H
:
IPM_STATE
?n
|-
_
]
=>
|
[
H
:
=
Envs
_
_
?n
|-
_
]
=>
let
do_incr
:
=
let
do_incr
:
=
lazymatch
goal
with
lazymatch
goal
with
|
H
:
=
@
Envs
?PROP
?p1
?p2
?c
|-
envs_entails
?H'
?Q
=>
|
H
:
=
@
Envs
?PROP
?p1
?p2
?c
|-
envs_entails
?H'
?Q
=>
...
@@ -300,7 +286,6 @@ Ltac liFresh :=
...
@@ -300,7 +286,6 @@ Ltac liFresh :=
let
c'
:
=
eval
vm_compute
in
(
Pos
.
succ
c
)
in
let
c'
:
=
eval
vm_compute
in
(
Pos
.
succ
c
)
in
let
H2
:
=
fresh
"IPM_INTERNAL"
in
let
H2
:
=
fresh
"IPM_INTERNAL"
in
pose
(
H2
:
=
@
Envs
PROP
p1
p2
c'
)
;
pose
(
H2
:
=
@
Envs
PROP
p1
p2
c'
)
;
change
(
envs
PROP
)
with
(@
IPM_STATE
PROP
c'
)
in
H2
;
change_no_check
(@
envs_entails
PROP
H2
Q
)
;
change_no_check
(@
envs_entails
PROP
H2
Q
)
;
clear
H
;
rename
H2
into
H
clear
H
;
rename
H2
into
H
end
end
...
@@ -322,7 +307,7 @@ Ltac liUnfoldLetGoal :=
...
@@ -322,7 +307,7 @@ Ltac liUnfoldLetGoal :=
Ltac
liUnfoldLetsInContext
:
=
Ltac
liUnfoldLetsInContext
:
=
repeat
match
goal
with
repeat
match
goal
with
|
H
:
=
LET_ID
_
|-
_
=>
unfold
LET_ID
in
H
;
unfold
H
;
clear
H
|
H
:
=
LET_ID
_
|-
_
=>
unfold
LET_ID
in
H
;
unfold
H
;
clear
H
|
H
:
IPM_STATE
_
|-
_
=>
unfold
H
;
clear
H
|
H
:
=
Envs
_
_
_
|-
_
=>
unfold
H
;
clear
H
end
.
end
.
(** * Management of evars *)
(** * Management of evars *)
...
@@ -443,7 +428,6 @@ Ltac liCheckOwnInContext P :=
...
@@ -443,7 +428,6 @@ Ltac liCheckOwnInContext P :=
end
in
end
in
match
goal
with
match
goal
with
|
H
:
=
Envs
?
Δ
i
?
Δ
s
_
|-
_
=>
|
H
:
=
Envs
?
Δ
i
?
Δ
s
_
|-
_
=>
lazymatch
(
type
of
H
)
with
|
IPM_STATE
_
=>
idtac
end
;
first
[
go
Δ
s
|
go
Δ
i
]
first
[
go
Δ
s
|
go
Δ
i
]
end
.
end
.
Global
Hint
Extern
1
(
CheckOwnInContext
?P
)
=>
(
liCheckOwnInContext
P
;
constructor
;
exact
:
I
)
:
typeclass_instances
.
Global
Hint
Extern
1
(
CheckOwnInContext
?P
)
=>
(
liCheckOwnInContext
P
;
constructor
;
exact
:
I
)
:
typeclass_instances
.
...
@@ -756,7 +740,7 @@ Ltac liSep :=
...
@@ -756,7 +740,7 @@ Ltac liSep :=
|
bi_emp
=>
notypeclasses
refine
(
tac_sep_emp
_
_
_
)
|
bi_emp
=>
notypeclasses
refine
(
tac_sep_emp
_
_
_
)
|
(
⌜
_
⌝
)%
I
=>
notypeclasses
refine
(
tac_do_intro_pure_and
_
_
_
_
)
|
(
⌜
_
⌝
)%
I
=>
notypeclasses
refine
(
tac_do_intro_pure_and
_
_
_
_
)
(* TODO: Is this really the right thing to do? *)
(* TODO: Is this really the right thing to do? *)
|
(
□
?P
)%
I
=>
notypeclasses
refine
(
tac_do_intro_intuit_sep
_
_
_
_
_
)
|
(
□
?P
)%
I
=>
notypeclasses
refine
(
tac_do_intro_intuit_sep
_
_
_
_
_
)
;
[
li_pm_reduce
|]
|
match
?x
with
_
=>
_
end
=>
fail
"should not have match in sep"
|
match
?x
with
_
=>
_
end
=>
fail
"should not have match in sep"
|
?P
=>
first
[
|
?P
=>
first
[
convert_to_i2p
P
ltac
:
(
fun
converted
=>
convert_to_i2p
P
ltac
:
(
fun
converted
=>
...
@@ -772,11 +756,22 @@ Ltac liSep :=
...
@@ -772,11 +756,22 @@ Ltac liSep :=
end
.
end
.
Ltac
liWand
:
=
Ltac
liWand
:
=
let
wand_intro
:
=
let
wand_intro
P
:
=
let
H
:
=
liFresh
in
first
[
first
[
simple
notypeclasses
refine
(
tac_do_intro_intuit
H
_
_
_
_
_
_
)
;
[
shelve
|
shelve
|
solve
[
refine
_
]
|
solve
[
refine
_
]
|
li_pm_reduce
]
let
SH
:
=
constr
:
(
_
:
SimplifyHyp
P
(
Some
0
%
N
))
in
|
simple
notypeclasses
refine
(
tac_do_intro
H
_
_
_
_
_
)
;
[
shelve
|
solve
[
refine
_
]
|
li_pm_reduce
]
simple
notypeclasses
refine
(
tac_do_simplify_hyp
P
SH
_
_
_
)
|
let
P'
:
=
open_constr
:
(
_
)
in
let
ip
:
=
constr
:
(
_
:
IntroPersistent
P
P'
)
in
let
n
:
=
lazymatch
goal
with
|
[
H
:
=
Envs
_
_
?n
|-
_
]
=>
constr
:
(
n
)
end
in
let
H
:
=
constr
:
(
IAnon
n
)
in
let
n'
:
=
eval
vm_compute
in
(
Pos
.
succ
n
)
in
simple
notypeclasses
refine
(
tac_do_intro_intuit
H
n'
P
P'
_
_
_
_
ip
_
_
_
)
;
[
reduction
.
pm_reflexivity
..|]
|
let
n
:
=
lazymatch
goal
with
|
[
H
:
=
Envs
_
_
?n
|-
_
]
=>
constr
:
(
n
)
end
in
let
H
:
=
constr
:
(
IAnon
n
)
in
let
n'
:
=
eval
vm_compute
in
(
Pos
.
succ
n
)
in
simple
notypeclasses
refine
(
tac_do_intro
H
n'
P
_
_
_
_
_
_
_
)
;
[
reduction
.
pm_reflexivity
..|]
]
in
]
in
lazymatch
goal
with
lazymatch
goal
with
|
|-
envs_entails
_
(
bi_wand
?P
_
)
=>
|
|-
envs_entails
_
(
bi_wand
?P
_
)
=>
...
@@ -786,7 +781,7 @@ Ltac liWand :=
...
@@ -786,7 +781,7 @@ Ltac liWand :=
|
bi_emp
=>
notypeclasses
refine
(
tac_wand_emp
_
_
_
)
|
bi_emp
=>
notypeclasses
refine
(
tac_wand_emp
_
_
_
)
|
bi_pure
_
=>
notypeclasses
refine
(
tac_do_intro_pure
_
_
_
_
)
|
bi_pure
_
=>
notypeclasses
refine
(
tac_do_intro_pure
_
_
_
_
)
|
match
?x
with
_
=>
_
end
=>
fail
"should not have match in wand "
|
match
?x
with
_
=>
_
end
=>
fail
"should not have match in wand "
|
_
=>
wand_intro
|
_
=>
wand_intro
P
end
end
end
.
end
.
...
...
Write
Preview
Supports
Markdown
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