Skip to content
GitLab
Projects
Groups
Snippets
Help
Loading...
Help
What's new
10
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Contribute to GitLab
Sign in / Register
Toggle navigation
Open sidebar
AVA
FloVer
Commits
42885f73
Commit
42885f73
authored
Jul 20, 2018
by
Heiko Becker
Browse files
Options
Browse Files
Download
Email Patches
Plain Diff
Draft structure for new type validator/type system, incorporating Fixed-point types properly
parent
d78f37ce
Changes
19
Expand all
Hide whitespace changes
Inline
Side-by-side
Showing
19 changed files
with
2058 additions
and
1921 deletions
+2058
-1921
coq/CertificateChecker.v
coq/CertificateChecker.v
+25
-25
coq/Commands.v
coq/Commands.v
+13
-14
coq/Environments.v
coq/Environments.v
+34
-16
coq/ErrorBounds.v
coq/ErrorBounds.v
+75
-84
coq/ErrorValidation.v
coq/ErrorValidation.v
+138
-163
coq/ExpressionSemantics.v
coq/ExpressionSemantics.v
+342
-0
coq/Expressions.v
coq/Expressions.v
+913
-336
coq/FPRangeValidator.v
coq/FPRangeValidator.v
+46
-82
coq/Infra/ExpressionAbbrevs.v
coq/Infra/ExpressionAbbrevs.v
+15
-8
coq/Infra/Ltacs.v
coq/Infra/Ltacs.v
+2
-2
coq/Infra/MachineType.v
coq/Infra/MachineType.v
+35
-44
coq/Infra/Results.v
coq/Infra/Results.v
+19
-0
coq/IntervalValidation.v
coq/IntervalValidation.v
+39
-32
coq/OrderedExpressions.v
coq/OrderedExpressions.v
+0
-919
coq/RealRangeArith.v
coq/RealRangeArith.v
+90
-78
coq/RealRangeValidator.v
coq/RealRangeValidator.v
+24
-11
coq/RoundoffErrorValidator.v
coq/RoundoffErrorValidator.v
+20
-22
coq/TypeValidator.v
coq/TypeValidator.v
+223
-80
coq/ssaPrgs.v
coq/ssaPrgs.v
+5
-5
No files found.
coq/CertificateChecker.v
View file @
42885f73
...
...
@@ -7,20 +7,21 @@
From
Flover
Require
Import
Infra
.
RealSimps
Infra
.
RationalSimps
Infra
.
RealRationalProps
Infra
.
Ltacs
RealRangeArith
RealRangeValidator
RoundoffErrorValidator
Environments
Typ
ing
FPRangeValidator
ExpressionAbbrevs
Commands
.
Environments
Typ
eValidator
FPRangeValidator
ExpressionAbbrevs
Commands
.
Require
Export
Infra
.
Expression
Abbrev
s
Flover
.
Commands
Coq
.
QArith
.
QArith
.
Require
Export
Expression
Semantic
s
Flover
.
Commands
Coq
.
QArith
.
QArith
.
(
**
Certificate
checking
function
**
)
Definition
CertificateChecker
(
e
:
expr
Q
)
(
absenv
:
analysisResult
)
(
P
:
precond
)
(
defVars
:
nat
->
option
mType
)
(
fBits
:
FloverMap
.
t
N
)
:=
let
tMap
:=
(
typeMap
defVars
e
(
FloverMap
.
empty
mType
)
fBits
)
in
if
(
typeCheck
e
defVars
tMap
fBits
)
then
if
RangeValidator
e
absenv
P
NatSet
.
empty
&&
FPRangeValidator
e
absenv
tMap
NatSet
.
empty
then
RoundoffErrorValidator
e
tMap
absenv
NatSet
.
empty
else
false
else
false
.
(
P
:
precond
)
(
defVars
:
FloverMap
.
t
mType
)
:=
let
tMap
:=
(
getValidMap
defVars
e
(
FloverMap
.
empty
mType
))
in
match
tMap
with
|
Succes
tMap
=>
if
RangeValidator
e
absenv
P
NatSet
.
empty
&&
FPRangeValidator
e
absenv
tMap
NatSet
.
empty
then
RoundoffErrorValidator
e
tMap
absenv
NatSet
.
empty
else
false
|
_
=>
false
end
.
(
**
Soundness
proof
for
the
certificate
checker
.
...
...
@@ -28,22 +29,22 @@ Definition CertificateChecker (e:expr Q) (absenv:analysisResult)
the
real
valued
execution
respects
the
precondition
.
**
)
Theorem
Certificate_checking_is_sound
(
e
:
expr
Q
)
(
absenv
:
analysisResult
)
P
defVars
fBits
:
defVars:
forall
(
E1
E2
:
env
),
approxEnv
E1
defVars
absenv
(
usedVars
e
)
NatSet
.
empty
E2
->
approxEnv
E1
(
toRTMap
defVars
)
absenv
(
usedVars
e
)
NatSet
.
empty
E2
->
(
forall
v
,
NatSet
.
In
v
(
Expressions
.
usedVars
e
)
->
exists
vR
,
E1
v
=
Some
vR
/
\
(
Q2R
(
fst
(
P
v
))
<=
vR
<=
Q2R
(
snd
(
P
v
)))
%
R
)
->
(
forall
v
,
NatSet
.
In
v
(
usedVars
e
)
->
exists
m
:
mType
,
defVars
v
=
Some
m
)
->
CertificateChecker
e
absenv
P
defVars
fBits
=
true
->
exists
iv
err
vR
vF
m
,
FloverMap
.
find
(
Var
Q
v
)
defVars
=
Some
m
)
->
CertificateChecker
e
absenv
P
defVars
=
true
->
exists
Gamma
iv
err
vR
vF
m
,
FloverMap
.
find
e
absenv
=
Some
(
iv
,
err
)
/
\
eval_expr
E1
(
toRMap
defVars
)
(
toRBMap
fBits
)
(
toREval
(
toRExp
e
)
)
vR
REAL
/
\
eval_expr
E2
defVars
(
toRBMap
fBits
)
(
toRExp
e
)
vF
m
/
\
eval_expr
E1
(
toRMap
Gamma
)
(
toRExp
e
)
vR
REAL
/
\
eval_expr
E2
Gamma
(
toRExp
e
)
vF
m
/
\
(
forall
vF
m
,
eval_expr
E2
defVars
(
toRBMap
fBits
)
(
toRExp
e
)
vF
m
->
eval_expr
E2
Gamma
(
toRExp
e
)
vF
m
->
(
Rabs
(
vR
-
vF
)
<=
Q2R
err
))
%
R
.
(
**
The
proofs
is
a
simple
composition
of
the
soundness
proofs
for
the
range
...
...
@@ -52,26 +53,25 @@ Theorem Certificate_checking_is_sound (e:expr Q) (absenv:analysisResult) P
Proof
.
intros
*
approxE1E2
P_valid
types_defined
certificate_valid
.
unfold
CertificateChecker
in
certificate_valid
.
destruct
(
getValidMap
defVars
e
(
FloverMap
.
empty
mType
));
try
congruence
.
rewrite
<-
andb_lazy_alt
in
certificate_valid
.
andb_to_prop
certificate_valid
.
clear
R1
.
pose
proof
(
NatSetProps
.
empty_union_2
(
Expressions
.
usedVars
e
)
NatSet
.
empty_spec
)
as
union_empty
.
hnf
in
union_empty
.
assert
(
dVars_range_valid
NatSet
.
empty
E1
absenv
).
{
unfold
dVars_range_valid
.
intros
;
set_tac
.
}
assert
(
affine_dVars_range_valid
NatSet
.
empty
E1
absenv
1
(
FloverMap
.
empty
_
)
(
fun
_
=>
None
))
(
*
assert
(
affine_dVars_range_valid
NatSet
.
empty
E1
absenv
1
(
FloverMap
.
empty
_
)
(
fun
_
=>
None
))
as
affine_dvars_valid
.
{
unfold
affine_dVars_range_valid
.
intros
;
set_tac
.
}
intros
;
set_tac
.
}
*
)
assert
(
NatSet
.
Subset
(
usedVars
e
--
NatSet
.
empty
)
(
Expressions
.
usedVars
e
)).
{
hnf
;
intros
a
in_empty
.
set_tac
.
}
assert
(
vars_typed
(
usedVars
e
∪
NatSet
.
empty
)
defVars
).
{
unfold
vars_typed
.
intros
;
apply
types_defined
.
set_tac
.
destruct
H1
;
set_tac
.
split
;
try
auto
.
hnf
;
intros
;
set_tac
.
}
rename
R
into
validFPRanges
.
assert
(
validRanges
e
absenv
E1
defVars
(
toR
B
Map
fBit
s
))
as
valid_e
.
{
eapply
(
RangeValidator_sound
e
(
dVars
:=
NatSet
.
empty
)
(
A
:=
absenv
)
(
P
:=
P
)
(
Gamma
:=
defVars
)
(
E
:=
E1
));
assert
(
validRanges
e
absenv
E1
(
toR
T
Map
defVar
s
))
as
valid_e
.
{
eapply
(
RangeValidator_sound
e
(
dVars
:=
NatSet
.
empty
)
(
A
:=
absenv
)
(
P
:=
P
)
(
Gamma
:=
toRTMap
defVars
)
(
E
:=
E1
));
auto
.
}
pose
proof
(
validRanges_single
_
_
_
_
_
valid_e
)
as
valid_single
;
destruct
valid_single
as
[
iv_e
[
err_e
[
vR
[
map_e
[
eval_real
real_bounds_e
]]]]].
...
...
coq/Commands.v
View file @
42885f73
...
...
@@ -2,7 +2,7 @@
Formalization
of
the
Abstract
Syntax
Tree
of
a
subset
used
in
the
Flover
framework
**
)
Require
Import
Coq
.
Reals
.
Reals
Coq
.
QArith
.
QArith
.
Require
Im
port
Flover
.
Expressions
.
Require
Ex
port
Flover
.
Expression
Semantic
s
.
Require
Export
Flover
.
Infra
.
ExpressionAbbrevs
Flover
.
Infra
.
NatSet
.
(
**
...
...
@@ -20,7 +20,6 @@ Fixpoint getRetExp (V:Type) (f:cmd V) :=
|
Ret
e
=>
e
end
.
Fixpoint
toRCmd
(
f
:
cmd
Q
)
:=
match
f
with
|
Let
m
x
e
g
=>
Let
m
x
(
toRExp
e
)
(
toRCmd
g
)
...
...
@@ -49,14 +48,14 @@ Inductive sstep : cmd R -> env -> R -> cmd R -> env -> Prop :=
Define
big
step
semantics
for
the
Flover
language
,
terminating
on
a
"returned"
result
value
**
)
Inductive
bstep
:
cmd
R
->
env
->
(
nat
->
option
mType
)
->
(
expr
R
->
option
N
)
->
R
->
mType
->
Prop
:=
let_b
m
m
'
x
e
s
E
v
res
defVars
fBits
:
eval_expr
E
defVars
fBits
e
v
m
->
bstep
s
(
updEnv
x
v
E
)
(
updDefVars
x
m
defVars
)
fBits
res
m
'
->
bstep
(
Let
m
x
e
s
)
E
defVars
fBits
res
m
'
|
ret_b
m
e
E
v
defVars
fBits
:
eval_expr
E
defVars
fBits
e
v
m
->
bstep
(
Ret
e
)
E
defVars
fBits
v
m
.
Inductive
bstep
:
cmd
R
->
env
->
(
expr
R
->
option
mType
)
->
R
->
mType
->
Prop
:=
let_b
m
m
'
x
e
s
E
v
res
defVars
:
eval_expr
E
defVars
e
v
m
->
bstep
s
(
updEnv
x
v
E
)
(
updDefVars
(
Var
R
x
)
m
defVars
)
res
m
'
->
bstep
(
Let
m
x
e
s
)
E
defVars
res
m
'
|
ret_b
m
e
E
v
defVars
:
eval_expr
E
defVars
e
v
m
->
bstep
(
Ret
e
)
E
defVars
v
m
.
(
**
The
free
variables
of
a
command
are
all
used
variables
of
exprressions
...
...
@@ -88,14 +87,14 @@ Fixpoint liveVars V (f:cmd V) :NatSet.t :=
end
.
Lemma
bstep_eq_env
f
:
forall
E1
E2
Gamma
fBits
v
m
,
forall
E1
E2
Gamma
v
m
,
(
forall
x
,
E1
x
=
E2
x
)
->
bstep
f
E1
Gamma
fBits
v
m
->
bstep
f
E2
Gamma
fBits
v
m
.
bstep
f
E1
Gamma
v
m
->
bstep
f
E2
Gamma
v
m
.
Proof
.
induction
f
;
intros
*
eq_envs
bstep_E1
;
inversion
bstep_E1
;
subst
;
simpl
in
*
.
-
eapply
eval_eq_env
in
H
8
;
eauto
.
eapply
let_b
;
eauto
.
-
eapply
eval_eq_env
in
H
7
;
eauto
.
eapply
let_b
;
eauto
.
eapply
IHf
.
instantiate
(
1
:=
(
updEnv
n
v0
E1
)).
+
intros
;
unfold
updEnv
.
destruct
(
x
=?
n
);
auto
.
...
...
coq/Environments.v
View file @
42885f73
...
...
@@ -16,7 +16,7 @@ It is necessary to have this relation, since two evaluations of the very same
exprression
may
yield
different
values
for
different
machine
epsilons
(
or
environments
that
already
only
approximate
each
other
)
**
)
Inductive
approxEnv
:
env
->
(
nat
->
option
mType
)
->
analysisResult
->
NatSet
.
t
Inductive
approxEnv
:
env
->
(
expr
R
->
option
mType
)
->
analysisResult
->
NatSet
.
t
->
NatSet
.
t
->
env
->
Prop
:=
|
approxRefl
defVars
A
:
approxEnv
emptyEnv
defVars
A
NatSet
.
empty
NatSet
.
empty
emptyEnv
...
...
@@ -25,7 +25,7 @@ Inductive approxEnv : env -> (nat -> option mType) -> analysisResult -> NatSet.t
(
Rabs
(
v1
-
v2
)
<=
computeErrorR
v1
m
)
%
R
->
NatSet
.
mem
x
(
NatSet
.
union
fVars
dVars
)
=
false
->
approxEnv
(
updEnv
x
v1
E1
)
(
updDefVars
x
m
defVars
)
A
(
NatSet
.
add
x
fVars
)
dVars
(
updDefVars
(
Var
R
x
)
m
defVars
)
A
(
NatSet
.
add
x
fVars
)
dVars
(
updEnv
x
v2
E2
)
|
approxUpdBound
E1
E2
defVars
A
v1
v2
x
fVars
dVars
m
iv
err
:
approxEnv
E1
defVars
A
fVars
dVars
E2
->
...
...
@@ -33,12 +33,12 @@ Inductive approxEnv : env -> (nat -> option mType) -> analysisResult -> NatSet.t
(
Rabs
(
v1
-
v2
)
<=
Q2R
err
)
%
R
->
NatSet
.
mem
x
(
NatSet
.
union
fVars
dVars
)
=
false
->
approxEnv
(
updEnv
x
v1
E1
)
(
updDefVars
x
m
defVars
)
A
fVars
(
NatSet
.
add
x
dVars
)
(
updDefVars
(
Var
R
x
)
m
defVars
)
A
fVars
(
NatSet
.
add
x
dVars
)
(
updEnv
x
v2
E2
).
Section
RelationProperties
.
Variable
(
x
:
nat
)
(
v
:
R
)
(
E1
E2
:
env
)
(
Gamma
:
nat
->
option
mType
)
Variable
(
x
:
nat
)
(
v
:
R
)
(
E1
E2
:
env
)
(
Gamma
:
expr
R
->
option
mType
)
(
A
:
analysisResult
)
(
fVars
dVars
:
NatSet
.
t
).
Hypothesis
approxEnvs
:
approxEnv
E1
Gamma
A
fVars
dVars
E2
.
...
...
@@ -76,7 +76,7 @@ Section RelationProperties.
E1
x
=
Some
v
->
E2
x
=
Some
v2
->
NatSet
.
In
x
fVars
->
Gamma
x
=
Some
m
->
Gamma
(
Var
R
x
)
=
Some
m
->
(
Rabs
(
v
-
v2
)
<=
computeErrorR
v
m
)
%
R
.
Proof
.
induction
approxEnvs
;
...
...
@@ -87,30 +87,40 @@ Section RelationProperties.
+
unfold
updEnv
in
*
;
rewrite
Nat
.
eqb_refl
in
*
;
simpl
in
*
.
unfold
updDefVars
in
x_typed
.
rewrite
Nat
.
eqb_refl
in
x_typed
.
cbn
in
x_typed
.
rewrite
Nat
.
compare_refl
in
x_typed
.
inversion
x_typed
;
subst
.
inversion
E1_def
;
inversion
E2_def
;
subst
;
auto
.
+
unfold
updEnv
in
*
;
simpl
in
*
.
rewrite
<-
Nat
.
eqb_neq
in
x_neq
.
rewrite
x_neq
in
*
;
simpl
in
*
.
unfold
updDefVars
in
x_typed
;
rewrite
x_neq
in
x_typed
.
apply
IHa
;
auto
.
unfold
updDefVars
in
x_typed
.
cbn
in
x_typed
.
apply
Nat
.
eqb_neq
in
x_neq
.
destruct
(
x
?=
x0
)
%
nat
eqn
:?
.
*
apply
Nat
.
compare_eq
in
Heqc
;
subst
;
congruence
.
*
apply
IHa
;
auto
.
*
apply
IHa
;
auto
.
-
assert
(
x
=?
x0
=
false
)
as
x_x0_neq
.
{
rewrite
Nat
.
eqb_neq
;
hnf
;
intros
;
subst
.
set_tac
.
apply
H1
.
set_tac
.
}
unfold
updEnv
in
*
;
rewrite
x_x0_neq
in
*
.
apply
IHa
;
auto
.
unfold
updDefVars
in
x_typed
;
rewrite
x_x0_neq
in
x_typed
;
auto
.
unfold
updDefVars
in
x_typed
.
cbn
in
x_typed
.
apply
Nat
.
eqb_neq
in
x_x0_neq
.
destruct
(
x
?=
x0
)
%
nat
eqn
:?
.
*
apply
Nat
.
compare_eq
in
Heqc
;
subst
;
congruence
.
*
apply
IHa
;
auto
.
*
apply
IHa
;
auto
.
Qed
.
Lemma
approxEnv_dVar_bounded
v2
m
iv
e
:
E1
x
=
Some
v
->
E2
x
=
Some
v2
->
NatSet
.
In
x
dVars
->
Gamma
x
=
Some
m
->
Gamma
(
Var
R
x
)
=
Some
m
->
FloverMap
.
find
(
Var
Q
x
)
A
=
Some
(
iv
,
e
)
->
(
Rabs
(
v
-
v2
)
<=
Q2R
e
)
%
R
.
Proof
.
...
...
@@ -123,8 +133,12 @@ Section RelationProperties.
apply
H0
;
set_tac
.
}
unfold
updEnv
in
*
;
rewrite
x_x0_neq
in
*
.
unfold
updDefVars
in
x_typed
;
rewrite
x_x0_neq
in
x_typed
.
apply
IHa
;
auto
.
unfold
updDefVars
in
x_typed
;
cbn
in
x_typed
.
apply
Nat
.
eqb_neq
in
x_x0_neq
.
destruct
(
x
?=
x0
)
%
nat
eqn
:?
.
*
apply
Nat
.
compare_eq
in
Heqc
;
subst
;
congruence
.
*
apply
IHa
;
auto
.
*
apply
IHa
;
auto
.
-
set_tac
.
destruct
x_def
as
[
x_x0
|
[
x_neq
x_def
]];
subst
.
+
unfold
updEnv
in
*
;
...
...
@@ -134,8 +148,12 @@ Section RelationProperties.
+
unfold
updEnv
in
*
;
simpl
in
*
.
rewrite
<-
Nat
.
eqb_neq
in
x_neq
.
rewrite
x_neq
in
*
;
simpl
in
*
.
unfold
updDefVars
in
x_typed
;
rewrite
x_neq
in
x_typed
.
apply
IHa
;
auto
.
unfold
updDefVars
in
x_typed
;
cbn
in
x_typed
.
apply
Nat
.
eqb_neq
in
x_neq
.
destruct
(
x
?=
x0
)
%
nat
eqn
:?
.
*
apply
Nat
.
compare_eq
in
Heqc
;
subst
;
congruence
.
*
apply
IHa
;
auto
.
*
apply
IHa
;
auto
.
Qed
.
End
RelationProperties
.
\ No newline at end of file
coq/ErrorBounds.v
View file @
42885f73
...
...
@@ -5,11 +5,11 @@ Bounds are exprlained in section 5, Deriving Computable Error Bounds
**
)
Require
Import
Coq
.
Reals
.
Reals
Coq
.
micromega
.
Psatz
Coq
.
QArith
.
QArith
Coq
.
QArith
.
Qreals
.
Require
Import
Flover
.
Infra
.
Abbrevs
Flover
.
Infra
.
RationalSimps
Flover
.
Infra
.
RealSimps
Flover
.
Infra
.
RealRationalProps
.
Require
Import
Flover
.
Environments
Flover
.
Infra
.
ExpressionAbbrevs
.
Require
Import
Flover
.
Environments
Flover
.
Infra
.
ExpressionAbbrevs
Flover
.
ExpressionSemantics
.
Lemma
const_abs_err_bounded
(
n
:
R
)
(
nR
:
R
)
(
nF
:
R
)
(
E1
E2
:
env
)
(
m
:
mType
)
defVars
fBits
:
eval_expr
E1
(
toRMap
defVars
)
fBits
(
Const
REAL
n
)
nR
REAL
->
eval_expr
E2
defVars
fBits
(
Const
m
n
)
nF
m
->
Lemma
const_abs_err_bounded
(
n
:
R
)
(
nR
:
R
)
(
nF
:
R
)
(
E1
E2
:
env
)
(
m
:
mType
)
defVars
:
eval_expr
E1
(
toRMap
defVars
)
(
Const
REAL
n
)
nR
REAL
->
eval_expr
E2
defVars
(
Const
m
n
)
nF
m
->
(
Rabs
(
nR
-
nF
)
<=
computeErrorR
n
m
)
%
R
.
Proof
.
intros
eval_real
eval_float
.
...
...
@@ -30,19 +30,14 @@ Proof.
Qed
.
Lemma
add_abs_err_bounded
(
e1
:
expr
Q
)
(
e1R
:
R
)
(
e1F
:
R
)
(
e2
:
expr
Q
)
(
e2R
:
R
)
(
e2F
:
R
)
(
vR
:
R
)
(
vF
:
R
)
(
E1
E2
:
env
)
(
err1
err2
:
Q
)
(
m
m1
m2
:
mType
)
defVars
fBits
:
eval_expr
E1
(
toRMap
defVars
)
fBits
(
toREval
(
toRExp
e1
))
e1R
REAL
->
eval_expr
E2
defVars
fBits
(
toRExp
e1
)
e1F
m1
->
eval_expr
E1
(
toRMap
defVars
)
fBits
(
toREval
(
toRExp
e2
))
e2R
REAL
->
eval_expr
E2
defVars
fBits
(
toRExp
e2
)
e2F
m2
->
eval_expr
E1
(
toRMap
defVars
)
fBits
(
toREval
(
Binop
Plus
(
toRExp
e1
)
(
toRExp
e2
)))
vR
REAL
->
(
vR
:
R
)
(
vF
:
R
)
(
E1
E2
:
env
)
(
err1
err2
:
Q
)
(
m
m1
m2
:
mType
)
defVars
:
eval_expr
E1
(
toRMap
defVars
)
(
toREval
(
toRExp
e1
))
e1R
REAL
->
eval_expr
E2
defVars
(
toRExp
e1
)
e1F
m1
->
eval_expr
E1
(
toRMap
defVars
)
(
toREval
(
toRExp
e2
))
e2R
REAL
->
eval_expr
E2
defVars
(
toRExp
e2
)
e2F
m2
->
eval_expr
E1
(
toRMap
defVars
)
(
toREval
(
Binop
Plus
(
toRExp
e1
)
(
toRExp
e2
)))
vR
REAL
->
eval_expr
(
updEnv
2
e2F
(
updEnv
1
e1F
emptyEnv
))
(
updDefVars
2
m2
(
updDefVars
1
m1
defVars
))
(
fun
e
=>
match
e
with
|
Binop
b
(
Var
_
1
)
(
Var
_
2
)
=>
fBits
(
toRExp
(
Binop
b
e1
e2
))
|
_
=>
fBits
e
end
)
(
updDefVars
(
Var
R
2
)
m2
(
updDefVars
(
Var
R
1
)
m1
defVars
))
(
Binop
Plus
(
Var
R
1
)
(
Var
R
2
))
vF
m
->
(
Rabs
(
e1R
-
e1F
)
<=
Q2R
err1
)
%
R
->
(
Rabs
(
e2R
-
e2F
)
<=
Q2R
err2
)
%
R
->
...
...
@@ -57,25 +52,24 @@ Proof.
rewrite
delta_0_deterministic
in
plus_real
;
auto
.
rewrite
(
delta_0_deterministic
(
evalBinop
Plus
v1
v2
)
REAL
delta
);
auto
.
unfold
evalBinop
in
*
;
simpl
in
*
.
clear
delta
H2
.
rewrite
(
meps_0_deterministic
(
toRExp
e1
)
H3
e1_real
);
rewrite
(
meps_0_deterministic
(
toRExp
e2
)
H4
e2_real
).
rewrite
(
meps_0_deterministic
(
toRExp
e1
)
H3
e1_real
)
in
plus_real
.
rewrite
(
meps_0_deterministic
(
toRExp
e2
)
H4
e2_real
)
in
plus_real
.
rewrite
(
meps_0_deterministic
(
toRExp
e1
)
H5
e1_real
);
rewrite
(
meps_0_deterministic
(
toRExp
e2
)
H8
e2_real
).
rewrite
(
meps_0_deterministic
(
toRExp
e1
)
H5
e1_real
)
in
plus_real
.
rewrite
(
meps_0_deterministic
(
toRExp
e2
)
H8
e2_real
)
in
plus_real
.
(
*
Now
unfold
the
float
valued
evaluation
to
get
the
deltas
we
need
for
the
inequality
*
)
inversion
plus_float
;
subst
.
unfold
perturb
;
simpl
.
inversion
H
6
;
subst
;
inversion
H
7
;
subst
.
unfold
updEnv
in
H1
,
H1
2
;
simpl
in
*
.
symmetry
in
H1
,
H1
2
.
inversion
H1
;
inversion
H1
2
;
subst
.
inversion
H
11
;
subst
;
inversion
H
14
;
subst
.
unfold
updEnv
in
H1
,
H1
3
;
simpl
in
*
.
symmetry
in
H1
,
H1
3
.
inversion
H1
;
inversion
H1
3
;
subst
.
(
*
We
have
now
obtained
all
necessary
values
from
the
evaluations
-->
remove
them
for
readability
*
)
clear
plus_float
H4
H7
plus_real
e1_real
e1_float
e2_real
e2_float
H8
H6
H1
.
repeat
rewrite
Rmult_plus_distr_l
.
rewrite
Rmult_1_r
.
rewrite
Rsub_eq_Ropp_Rplus
.
unfold
computeErrorR
.
pose
proof
(
Rabs_triang
(
e1R
+
-
e1F
)
((
e2R
+
-
e2F
)
+
-
((
e1F
+
e2F
)
*
delta
))).
pose
proof
(
Rabs_triang
(
e1R
+
-
e1F
)
((
e2R
+
-
e2F
)
+
-
((
e1F
+
e2F
)
*
delta
0
))).
destruct
m
;
repeat
rewrite
Ropp_plus_distr
;
try
rewrite
plus_bounds_simplify
;
try
rewrite
Rplus_assoc
.
{
repeat
rewrite
<-
Rplus_assoc
.
...
...
@@ -106,24 +100,22 @@ Qed.
Copy
-
Paste
proof
with
minor
differences
,
was
easier
then
manipulating
the
evaluations
and
then
applying
the
lemma
**
)
Lemma
subtract_abs_err_bounded
(
e1
:
expr
Q
)
(
e1R
:
R
)
(
e1F
:
R
)
(
e2
:
expr
Q
)
(
e2R
:
R
)
(
e2F
:
R
)
(
vR
:
R
)
(
vF
:
R
)
(
E1
E2
:
env
)
err1
err2
(
m
m1
m2
:
mType
)
defVars
fBits
:
eval_expr
E1
(
toRMap
defVars
)
fBits
(
toREval
(
toRExp
e1
))
e1R
REAL
->
eval_expr
E2
defVars
fBits
(
toRExp
e1
)
e1F
m1
->
eval_expr
E1
(
toRMap
defVars
)
fBits
(
toREval
(
toRExp
e2
))
e2R
REAL
->
eval_expr
E2
defVars
fBits
(
toRExp
e2
)
e2F
m2
->
eval_expr
E1
(
toRMap
defVars
)
fBits
(
toREval
(
Binop
Sub
(
toRExp
e1
)
(
toRExp
e2
)))
vR
REAL
->
(
e2F
:
R
)
(
vR
:
R
)
(
vF
:
R
)
(
E1
E2
:
env
)
err1
err2
(
m
m1
m2
:
mType
)
defVars
:
eval_expr
E1
(
toRMap
defVars
)
(
toREval
(
toRExp
e1
))
e1R
REAL
->
eval_expr
E2
defVars
(
toRExp
e1
)
e1F
m1
->
eval_expr
E1
(
toRMap
defVars
)
(
toREval
(
toRExp
e2
))
e2R
REAL
->
eval_expr
E2
defVars
(
toRExp
e2
)
e2F
m2
->
eval_expr
E1
(
toRMap
defVars
)
(
toREval
(
Binop
Sub
(
toRExp
e1
)
(
toRExp
e2
)))
vR
REAL
->
eval_expr
(
updEnv
2
e2F
(
updEnv
1
e1F
emptyEnv
))
(
updDefVars
2
m2
(
updDefVars
1
m1
defVars
))
(
fun
e
=>
match
e
with
|
Binop
b
(
Var
_
1
)
(
Var
_
2
)
=>
fBits
(
toRExp
(
Binop
b
e1
e2
))
|
_
=>
fBits
e
end
)
(
updDefVars
(
Var
R
2
)
m2
(
updDefVars
(
Var
R
1
)
m1
defVars
))
(
Binop
Sub
(
Var
R
1
)
(
Var
R
2
))
vF
m
->
(
Rabs
(
e1R
-
e1F
)
<=
Q2R
err1
)
%
R
->
(
Rabs
(
e2R
-
e2F
)
<=
Q2R
err2
)
%
R
->
(
Rabs
(
vR
-
vF
)
<=
Q2R
err1
+
Q2R
err2
+
computeErrorR
(
e1F
-
e2F
)
m
)
%
R
.
Proof
.
admit
.
Admitted
.
(
*
intros
e1_real
e1_float
e2_real
e2_float
sub_real
sub_float
bound_e1
bound_e2
.
(
*
Prove
that
e1R
and
e2R
are
the
correct
values
and
that
vR
is
e1R
+
e2R
*
)
inversion
sub_real
;
subst
.
...
...
@@ -184,24 +176,23 @@ Proof.
all:
rewrite
Rabs_Ropp
,
Rabs_mult
,
<-
Rsub_eq_Ropp_Rplus
.
all:
eapply
Rmult_le_compat_l
;
try
auto
using
Rabs_pos
.
Qed
.
*
)
Lemma
mult_abs_err_bounded
(
e1
:
expr
Q
)
(
e1R
:
R
)
(
e1F
:
R
)
(
e2
:
expr
Q
)
(
e2R
:
R
)
(
e2F
:
R
)
(
vR
:
R
)
(
vF
:
R
)
(
E1
E2
:
env
)
(
m
m1
m2
:
mType
)
defVars
fBits
:
eval_expr
E1
(
toRMap
defVars
)
fBits
(
toREval
(
toRExp
e1
))
e1R
REAL
->
eval_expr
E2
defVars
fBits
(
toRExp
e1
)
e1F
m1
->
eval_expr
E1
(
toRMap
defVars
)
fBits
(
toREval
(
toRExp
e2
))
e2R
REAL
->
eval_expr
E2
defVars
fBits
(
toRExp
e2
)
e2F
m2
->
eval_expr
E1
(
toRMap
defVars
)
fBits
(
toREval
(
Binop
Mult
(
toRExp
e1
)
(
toRExp
e2
)))
vR
REAL
->
(
vR
:
R
)
(
vF
:
R
)
(
E1
E2
:
env
)
(
m
m1
m2
:
mType
)
defVars
:
eval_expr
E1
(
toRMap
defVars
)
(
toREval
(
toRExp
e1
))
e1R
REAL
->
eval_expr
E2
defVars
(
toRExp
e1
)
e1F
m1
->
eval_expr
E1
(
toRMap
defVars
)
(
toREval
(
toRExp
e2
))
e2R
REAL
->
eval_expr
E2
defVars
(
toRExp
e2
)
e2F
m2
->
eval_expr
E1
(
toRMap
defVars
)
(
toREval
(
Binop
Mult
(
toRExp
e1
)
(
toRExp
e2
)))
vR
REAL
->
eval_expr
(
updEnv
2
e2F
(
updEnv
1
e1F
emptyEnv
))
(
updDefVars
2
m2
(
updDefVars
1
m1
defVars
))
(
fun
e
=>
match
e
with
|
Binop
b
(
Var
_
1
)
(
Var
_
2
)
=>
fBits
(
toRExp
(
Binop
b
e1
e2
))
|
_
=>
fBits
e
end
)
(
updDefVars
(
Var
R
2
)
m2
(
updDefVars
(
Var
R
1
)
m1
defVars
))
(
Binop
Mult
(
Var
R
1
)
(
Var
R
2
))
vF
m
->
(
Rabs
(
vR
-
vF
)
<=
Rabs
(
e1R
*
e2R
-
e1F
*
e2F
)
+
computeErrorR
(
e1F
*
e2F
)
m
)
%
R
.
Proof
.
admit
.
Admitted
.
(
*
intros
e1_real
e1_float
e2_real
e2_float
mult_real
mult_float
.
(
*
Prove
that
e1R
and
e2R
are
the
correct
values
and
that
vR
is
e1R
*
e2R
*
)
inversion
mult_real
;
subst
;
...
...
@@ -237,24 +228,23 @@ Proof.
all:
eapply
Rplus_le_compat_l
;
try
auto
.
all:
eapply
Rmult_le_compat_l
;
try
auto
using
Rabs_pos
.
Qed
.
*
)
Lemma
div_abs_err_bounded
(
e1
:
expr
Q
)
(
e1R
:
R
)
(
e1F
:
R
)
(
e2
:
expr
Q
)
(
e2R
:
R
)
(
e2F
:
R
)
(
vR
:
R
)
(
vF
:
R
)
(
E1
E2
:
env
)
(
m
m1
m2
:
mType
)
defVars
fBits
:
eval_expr
E1
(
toRMap
defVars
)
fBits
(
toREval
(
toRExp
e1
))
e1R
REAL
->
eval_expr
E2
defVars
fBits
(
toRExp
e1
)
e1F
m1
->
eval_expr
E1
(
toRMap
defVars
)
fBits
(
toREval
(
toRExp
e2
))
e2R
REAL
->
eval_expr
E2
defVars
fBits
(
toRExp
e2
)
e2F
m2
->
eval_expr
E1
(
toRMap
defVars
)
fBits
(
toREval
(
Binop
Div
(
toRExp
e1
)
(
toRExp
e2
)))
vR
REAL
->
(
vR
:
R
)
(
vF
:
R
)
(
E1
E2
:
env
)
(
m
m1
m2
:
mType
)
defVars
:
eval_expr
E1
(
toRMap
defVars
)
(
toREval
(
toRExp
e1
))
e1R
REAL
->
eval_expr
E2
defVars
(
toRExp
e1
)
e1F
m1
->
eval_expr
E1
(
toRMap
defVars
)
(
toREval
(
toRExp
e2
))
e2R
REAL
->
eval_expr
E2
defVars
(
toRExp
e2
)
e2F
m2
->
eval_expr
E1
(
toRMap
defVars
)
(
toREval
(
Binop
Div
(
toRExp
e1
)
(
toRExp
e2
)))
vR
REAL
->
eval_expr
(
updEnv
2
e2F
(
updEnv
1
e1F
emptyEnv
))
(
updDefVars
2
m2
(
updDefVars
1
m1
defVars
))
(
fun
e
=>
match
e
with
|
Binop
b
(
Var
_
1
)
(
Var
_
2
)
=>
fBits
(
toRExp
(
Binop
b
e1
e2
))
|
_
=>
fBits
e
end
)
(
updDefVars
(
Var
R
2
)
m2
(
updDefVars
(
Var
R
1
)
m1
defVars
))
(
Binop
Div
(
Var
R
1
)
(
Var
R
2
))
vF
m
->
(
Rabs
(
vR
-
vF
)
<=
Rabs
(
e1R
/
e2R
-
e1F
/
e2F
)
+
computeErrorR
(
e1F
/
e2F
)
m
)
%
R
.
Proof
.
admit
.
Admitted
.
(
*
intros
e1_real
e1_float
e2_real
e2_float
div_real
div_float
.
(
*
Prove
that
e1R
and
e2R
are
the
correct
values
and
that
vR
is
e1R
*
e2R
*
)
inversion
div_real
;
subst
;
...
...
@@ -290,27 +280,26 @@ Proof.
all:
eapply
Rplus_le_compat_l
;
try
auto
.
all:
eapply
Rmult_le_compat_l
;
try
auto
using
Rabs_pos
.
Qed
.
*
)
Lemma
fma_abs_err_bounded
(
e1
:
expr
Q
)
(
e1R
:
R
)
(
e1F
:
R
)
(
e2
:
expr
Q
)
(
e2R
:
R
)
(
e2F
:
R
)
(
e3
:
expr
Q
)
(
e3R
:
R
)
(
e3F
:
R
)
(
vR
:
R
)
(
vF
:
R
)
(
E1
E2
:
env
)
(
m
m1
m2
m3
:
mType
)
defVars
fBits
:
eval_expr
E1
(
toRMap
defVars
)
fBits
(
toREval
(
toRExp
e1
))
e1R
REAL
->
eval_expr
E2
defVars
fBits
(
toRExp
e1
)
e1F
m1
->
eval_expr
E1
(
toRMap
defVars
)
fBits
(
toREval
(
toRExp
e2
))
e2R
REAL
->
eval_expr
E2
defVars
fBits
(
toRExp
e2
)
e2F
m2
->
eval_expr
E1
(
toRMap
defVars
)
fBits
(
toREval
(
toRExp
e3
))
e3R
REAL
->
eval_expr
E2
defVars
fBits
(
toRExp
e3
)
e3F
m3
->
eval_expr
E1
(
toRMap
defVars
)
fBits
(
toREval
(
Fma
(
toRExp
e1
)
(
toRExp
e2
)
(
toRExp
e3
)))
vR
REAL
->
(
vR
:
R
)
(
vF
:
R
)
(
E1
E2
:
env
)
(
m
m1
m2
m3
:
mType
)
defVars
:
eval_expr
E1
(
toRMap
defVars
)
(
toREval
(
toRExp
e1
))
e1R
REAL
->
eval_expr
E2
defVars
(
toRExp
e1
)
e1F
m1
->
eval_expr
E1
(
toRMap
defVars
)
(
toREval
(
toRExp
e2
))
e2R
REAL
->
eval_expr
E2
defVars
(
toRExp
e2
)
e2F
m2
->
eval_expr
E1
(
toRMap
defVars
)
(
toREval
(
toRExp
e3
))
e3R
REAL
->
eval_expr
E2
defVars
(
toRExp
e3
)
e3F
m3
->
eval_expr
E1
(
toRMap
defVars
)
(
toREval
(
Fma
(
toRExp
e1
)
(
toRExp
e2
)
(
toRExp
e3
)))
vR
REAL
->
eval_expr
(
updEnv
3
e3F
(
updEnv
2
e2F
(
updEnv
1
e1F
emptyEnv
)))
(
updDefVars
3
m3
(
updDefVars
2
m2
(
updDefVars
1
m1
defVars
)))
(
fun
e
=>
match
e
with
|
Fma
(
Var
_
1
)
(
Var
_
2
)
(
Var
_
3
)
=>
fBits
(
toRExp
(
Fma
e1
e2
e3
))
|
_
=>
fBits
e
end
)
(
updDefVars
(
Var
R
3
)
m3
(
updDefVars
(
Var
R
2
)
m2
(
updDefVars
(
Var
R
1
)
m1
defVars
)))
(
Fma
(
Var
R
1
)
(
Var
R
2
)
(
Var
R
3
))
vF
m
->
(
Rabs
(
vR
-
vF
)
<=
Rabs
((
e1R
-
e1F
)
+
(
e2R
*
e3R
-
e2F
*
e3F
))
+
computeErrorR
(
e1F
+
e2F
*
e3F
)
m
)
%
R
.
Proof
.
admit
.
Admitted
.
(
*
intros
e1_real
e1_float
e2_real
e2_float
e3_real
e3_float
fma_real
fma_float
.
inversion
fma_real
;
subst
;
assert
(
m0
=
REAL
)
by
(
eapply
toRMap_eval_REAL
;
eauto
).
...
...
@@ -363,21 +352,22 @@ Proof.
all:
apply
Rplus_le_compat_l
.
all:
rewrite
Rabs_mult
;
apply
Rmult_le_compat_l
;
auto
using
Rabs_pos
.
Qed
.
*
)
Lemma
round_abs_err_bounded
(
e
:
expr
R
)
(
nR
nF1
nF
:
R
)
(
E1
E2
:
env
)
(
err
:
R
)
(
mEps
m
:
mType
)
defVars
fBits
:
eval_expr
E1
(
toRMap
defVars
)
fBits
(
toREval
e
)
nR
REAL
->
eval_expr
E2
defVars
fBits
e
nF1
m
->
(
mEps
m
:
mType
)
defVars
:
eval_expr
E1
(
toRMap
defVars
)
(
toREval
e
)
nR
REAL
->
eval_expr
E2
defVars
e
nF1
m
->
eval_expr
(
updEnv
1
nF1
emptyEnv
)
(
updDefVars
1
m
defVars
)
(
fun
e
=>
match
e
with
|
Downcast
m
(
Var
_
1
)
=>
fBits
(
Downcast
m
e
)
|
_
=>
fBits
e
end
)
(
updDefVars
(
Var
R
1
)
m
defVars
)
(
toRExp
(
Downcast
mEps
(
Var
Q
1
)))
nF
mEps
->
(
Rabs
(
nR
-
nF1
)
<=
err
)
%
R
->
(
Rabs
(
nR
-
nF
)
<=
err
+
computeErrorR
nF1
mEps
)
%
R
.
Proof
.
admit
.
Admitted
.
(
*
intros
eval_real
eval_float
eval_float_rnd
err_bounded
.
replace
(
nR
-
nF
)
%
R
with
((
nR
-
nF1
)
+
(
nF1
-
nF
))
%
R
by
lra
.
eapply
Rle_trans
.
...
...
@@ -400,6 +390,7 @@ Proof.
rewrite
Ropp_plus_distr
,
<-
Rplus_assoc
.
rewrite
Rplus_opp_r
,
Rplus_0_l
,
Rabs_Ropp
;
auto
.
Qed
.
*
)
Lemma
err_prop_inversion_pos_real
nF
nR
err
elo
ehi
(
float_iv_pos
:
(
0
<
elo
-
err
)
%
R
)
...
...
coq/ErrorValidation.v
View file @
42885f73
This diff is collapsed.
Click to expand it.
coq/ExpressionSemantics.v
0 → 100644
View file @
42885f73
From
Coq
Require
Import
Reals
.
Reals
.
From
Flover
.
Infra
Require
Import
RealRationalProps
RationalSimps
Ltacs
.
From
Flover
.
Infra
Require
Export
ExpressionAbbrevs
.
(
**
Finally
,
define
an
error
function
that
computes
an
errorneous
value
for
a
given
type
.
For
a
fixed
-
point
datatype
,
truncation
is
used
and
any
floating
-
point
type
is
perturbed
.
As
we
need
not
compute
on
this
function
we
define
it
in
Prop
.
**
)
Definition
perturb
(
rVal
:
R
)
(
m
:
mType
)
(
delta
:
R
)
:
R
:=
match
m
with
(
*
The
Real
-
type
has
no
error
*
)
|
REAL
=>
rVal
(
*
Fixed
-
point
numbers
have
an
absolute
error
*
)
|
F
w
f
=>
rVal
+
delta
(
*
Floating
-
point
numbers
have
a
relative
error
*
)
|
_
=>
rVal
*
(
1
+
delta
)
end
.
Hint
Unfold
perturb
.
(
**
Define
expression
evaluation
relation
parametric
by
an
"error"
epsilon
.
The
result
value
exprresses
float
computations
according
to
the
IEEE
standard
,
using
a
perturbation
of
the
real
valued
computation
by
(
1
+
delta
),
where
|
delta
|
<=
machine
epsilon
.
**
)
Open
Scope
R_scope
.
Inductive
eval_expr
(
E
:
env
)
(
Gamma
:
expr
R
->
option
mType
)