diff options
-rw-r--r-- | .gitignore | 5 | ||||
-rw-r--r-- | Makefile | 47 | ||||
-rw-r--r-- | arm/Archi.v | 29 | ||||
-rw-r--r-- | arm/Asm.v | 9 | ||||
-rw-r--r-- | arm/AsmToJSON.ml | 3 | ||||
-rw-r--r-- | arm/Asmgen.v | 13 | ||||
-rw-r--r-- | arm/Asmgenproof.v | 1 | ||||
-rw-r--r-- | arm/Asmgenproof1.v | 28 | ||||
-rw-r--r-- | arm/NeedOp.v | 5 | ||||
-rw-r--r-- | arm/Op.v | 39 | ||||
-rw-r--r-- | arm/PrintOp.ml | 4 | ||||
-rw-r--r-- | arm/SelectOp.vp | 10 | ||||
-rw-r--r-- | arm/SelectOpproof.v | 16 | ||||
-rw-r--r-- | arm/TargetPrinter.ml | 10 | ||||
-rw-r--r-- | arm/ValueAOp.v | 2 | ||||
-rw-r--r-- | backend/Allocation.v | 2 | ||||
-rw-r--r-- | backend/Asmexpandaux.mli | 4 | ||||
-rw-r--r-- | backend/CSEproof.v | 8 | ||||
-rw-r--r-- | backend/Cminor.v | 64 | ||||
-rw-r--r-- | backend/Cminortyping.v | 798 | ||||
-rw-r--r-- | backend/Deadcodeproof.v | 6 | ||||
-rw-r--r-- | backend/Inliningproof.v | 8 | ||||
-rw-r--r-- | backend/JsonAST.ml | 6 | ||||
-rw-r--r-- | backend/Lineartyping.v | 2 | ||||
-rw-r--r-- | backend/NeedDomain.v | 67 | ||||
-rw-r--r-- | backend/PrintAsm.ml | 3 | ||||
-rw-r--r-- | backend/PrintAsmaux.ml | 14 | ||||
-rw-r--r-- | backend/RTL.v | 2 | ||||
-rw-r--r-- | backend/RTLgenproof.v | 4 | ||||
-rw-r--r-- | backend/SelectDivproof.v | 34 | ||||
-rw-r--r-- | backend/Selection.v | 93 | ||||
-rw-r--r-- | backend/Selectionaux.ml | 109 | ||||
-rw-r--r-- | backend/Selectionproof.v | 394 | ||||
-rw-r--r-- | backend/Unusedglob.v | 2 | ||||
-rw-r--r-- | backend/Unusedglobproof.v | 8 | ||||
-rw-r--r-- | backend/ValueDomain.v | 74 | ||||
-rw-r--r-- | cfrontend/C2C.ml | 10 | ||||
-rw-r--r-- | cfrontend/Cexec.v | 1 | ||||
-rw-r--r-- | cfrontend/Clight.v | 2 | ||||
-rw-r--r-- | cfrontend/Cminorgenproof.v | 2 | ||||
-rw-r--r-- | cfrontend/Csyntax.v | 2 | ||||
-rw-r--r-- | cfrontend/SimplLocalsproof.v | 2 | ||||
-rw-r--r-- | common/AST.v | 4 | ||||
-rw-r--r-- | common/Events.v | 2 | ||||
-rw-r--r-- | common/Memdata.v | 15 | ||||
-rw-r--r-- | common/Memory.v | 44 | ||||
-rw-r--r-- | common/Memtype.v | 4 | ||||
-rw-r--r-- | common/Separation.v | 2 | ||||
-rw-r--r-- | common/Smallstep.v | 173 | ||||
-rw-r--r-- | common/Switch.v | 6 | ||||
-rw-r--r-- | common/Values.v | 126 | ||||
-rwxr-xr-x | configure | 16 | ||||
-rw-r--r-- | cparser/Cutil.ml | 2 | ||||
-rw-r--r-- | cparser/Diagnostics.ml | 8 | ||||
-rw-r--r-- | cparser/Diagnostics.mli | 8 | ||||
-rw-r--r-- | cparser/Elab.ml | 404 | ||||
-rw-r--r-- | cparser/Lexer.mll | 9 | ||||
-rw-r--r-- | cparser/Unblock.ml | 2 | ||||
-rw-r--r-- | cparser/handcrafted.messages | 4 | ||||
-rw-r--r-- | debug/Debug.ml | 6 | ||||
-rw-r--r-- | debug/Debug.mli | 4 | ||||
-rw-r--r-- | debug/DebugInformation.ml | 21 | ||||
-rw-r--r-- | debug/DebugInformation.mli | 2 | ||||
-rw-r--r-- | debug/DwarfPrinter.ml | 34 | ||||
-rw-r--r-- | debug/DwarfTypes.mli | 6 | ||||
-rw-r--r-- | debug/Dwarfgen.ml | 84 | ||||
-rw-r--r-- | doc/ccomp.1 | 14 | ||||
-rw-r--r-- | driver/Clflags.ml | 3 | ||||
-rw-r--r-- | driver/Commandline.ml | 14 | ||||
-rw-r--r-- | driver/Commandline.mli | 8 | ||||
-rw-r--r-- | driver/CommonOptions.ml | 4 | ||||
-rw-r--r-- | driver/Configuration.ml | 6 | ||||
-rw-r--r-- | driver/Driver.ml | 22 | ||||
-rw-r--r-- | driver/Frontend.ml | 30 | ||||
-rw-r--r-- | exportclight/Clightnorm.ml | 2 | ||||
-rw-r--r-- | extraction/extraction.v | 11 | ||||
-rw-r--r-- | flocq/Appli/Fappli_IEEE.v | 1920 | ||||
-rw-r--r-- | flocq/Calc/Bracket.v (renamed from flocq/Calc/Fcalc_bracket.v) | 148 | ||||
-rw-r--r-- | flocq/Calc/Div.v | 159 | ||||
-rw-r--r-- | flocq/Calc/Fcalc_digits.v | 63 | ||||
-rw-r--r-- | flocq/Calc/Fcalc_div.v | 165 | ||||
-rw-r--r-- | flocq/Calc/Fcalc_sqrt.v | 244 | ||||
-rw-r--r-- | flocq/Calc/Operations.v (renamed from flocq/Calc/Fcalc_ops.v) | 23 | ||||
-rw-r--r-- | flocq/Calc/Round.v (renamed from flocq/Calc/Fcalc_round.v) | 565 | ||||
-rw-r--r-- | flocq/Calc/Sqrt.v | 201 | ||||
-rw-r--r-- | flocq/Core/Core.v (renamed from flocq/Core/Fcore.v) | 16 | ||||
-rw-r--r-- | flocq/Core/Defs.v (renamed from flocq/Core/Fcore_defs.v) | 36 | ||||
-rw-r--r-- | flocq/Core/Digits.v (renamed from flocq/Core/Fcore_digits.v) | 211 | ||||
-rw-r--r-- | flocq/Core/FIX.v (renamed from flocq/Core/Fcore_FIX.v) | 30 | ||||
-rw-r--r-- | flocq/Core/FLT.v (renamed from flocq/Core/Fcore_FLT.v) | 182 | ||||
-rw-r--r-- | flocq/Core/FLX.v | 362 | ||||
-rw-r--r-- | flocq/Core/FTZ.v (renamed from flocq/Core/Fcore_FTZ.v) | 109 | ||||
-rw-r--r-- | flocq/Core/Fcore_FLX.v | 271 | ||||
-rw-r--r-- | flocq/Core/Float_prop.v (renamed from flocq/Core/Fcore_float_prop.v) | 228 | ||||
-rw-r--r-- | flocq/Core/Generic_fmt.v (renamed from flocq/Core/Fcore_generic_fmt.v) | 793 | ||||
-rw-r--r-- | flocq/Core/Raux.v (renamed from flocq/Core/Fcore_Raux.v) | 964 | ||||
-rw-r--r-- | flocq/Core/Round_NE.v (renamed from flocq/Core/Fcore_rnd_ne.v) | 185 | ||||
-rw-r--r-- | flocq/Core/Round_pred.v (renamed from flocq/Core/Fcore_rnd.v) | 176 | ||||
-rw-r--r-- | flocq/Core/Ulp.v (renamed from flocq/Core/Fcore_ulp.v) | 925 | ||||
-rw-r--r-- | flocq/Core/Zaux.v (renamed from flocq/Core/Fcore_Zaux.v) | 238 | ||||
-rw-r--r-- | flocq/IEEE754/Binary.v | 2814 | ||||
-rw-r--r-- | flocq/IEEE754/Bits.v (renamed from flocq/Appli/Fappli_IEEE_bits.v) | 327 | ||||
-rw-r--r-- | flocq/Prop/Div_sqrt_error.v | 872 | ||||
-rw-r--r-- | flocq/Prop/Double_rounding.v (renamed from flocq/Appli/Fappli_double_round.v) | 2598 | ||||
-rw-r--r-- | flocq/Prop/Fprop_div_sqrt_error.v | 300 | ||||
-rw-r--r-- | flocq/Prop/Mult_error.v (renamed from flocq/Prop/Fprop_mult_error.v) | 175 | ||||
-rw-r--r-- | flocq/Prop/Plus_error.v (renamed from flocq/Prop/Fprop_plus_error.v) | 394 | ||||
-rw-r--r-- | flocq/Prop/Relative.v (renamed from flocq/Prop/Fprop_relative.v) | 505 | ||||
-rw-r--r-- | flocq/Prop/Round_odd.v (renamed from flocq/Appli/Fappli_rnd_odd.v) | 618 | ||||
-rw-r--r-- | flocq/Prop/Sterbenz.v (renamed from flocq/Prop/Fprop_Sterbenz.v) | 64 | ||||
-rw-r--r-- | flocq/Version.v (renamed from flocq/Flocq_version.v) | 6 | ||||
-rw-r--r-- | lib/Coqlib.v | 131 | ||||
-rw-r--r-- | lib/Floats.v | 336 | ||||
-rw-r--r-- | lib/Heaps.v | 2 | ||||
-rw-r--r-- | lib/IEEE754_extra.v (renamed from lib/Fappli_IEEE_extra.v) | 431 | ||||
-rw-r--r-- | lib/Integers.v | 928 | ||||
-rw-r--r-- | lib/Zbits.v | 1028 | ||||
-rw-r--r-- | powerpc/Archi.v | 25 | ||||
-rw-r--r-- | powerpc/Asm.v | 16 | ||||
-rw-r--r-- | powerpc/AsmToJSON.ml | 1 | ||||
-rw-r--r-- | powerpc/Asmexpand.ml | 77 | ||||
-rw-r--r-- | powerpc/Asmgen.v | 67 | ||||
-rw-r--r-- | powerpc/Asmgenproof.v | 37 | ||||
-rw-r--r-- | powerpc/Asmgenproof1.v | 230 | ||||
-rw-r--r-- | powerpc/Machregs.v | 6 | ||||
-rw-r--r-- | powerpc/NeedOp.v | 5 | ||||
-rw-r--r-- | powerpc/Op.v | 43 | ||||
-rw-r--r-- | powerpc/PrintOp.ml | 4 | ||||
-rw-r--r-- | powerpc/SelectLongproof.v | 10 | ||||
-rw-r--r-- | powerpc/SelectOp.vp | 14 | ||||
-rw-r--r-- | powerpc/SelectOpproof.v | 21 | ||||
-rw-r--r-- | powerpc/TargetPrinter.ml | 20 | ||||
-rw-r--r-- | powerpc/ValueAOp.v | 2 | ||||
-rw-r--r-- | riscV/Archi.v | 30 | ||||
-rw-r--r-- | riscV/Asm.v | 2 | ||||
-rw-r--r-- | riscV/Asmgenproof1.v | 16 | ||||
-rw-r--r-- | riscV/SelectOp.vp | 6 | ||||
-rw-r--r-- | riscV/SelectOpproof.v | 19 | ||||
-rw-r--r-- | riscV/TargetPrinter.ml | 4 | ||||
-rw-r--r-- | runtime/Makefile | 8 | ||||
-rw-r--r-- | test/c/chomp.c | 6 | ||||
-rw-r--r-- | test/regression/Makefile | 2 | ||||
-rw-r--r-- | test/regression/Results/ifconv | 26 | ||||
-rw-r--r-- | test/regression/ifconv.c | 129 | ||||
-rw-r--r-- | x86/Asm.v | 11 | ||||
-rw-r--r-- | x86/Asmgen.v | 33 | ||||
-rw-r--r-- | x86/Asmgenproof.v | 15 | ||||
-rw-r--r-- | x86/Asmgenproof1.v | 164 | ||||
-rw-r--r-- | x86/Machregs.v | 1 | ||||
-rw-r--r-- | x86/NeedOp.v | 5 | ||||
-rw-r--r-- | x86/Op.v | 45 | ||||
-rw-r--r-- | x86/PrintOp.ml | 4 | ||||
-rw-r--r-- | x86/SelectOp.vp | 30 | ||||
-rw-r--r-- | x86/SelectOpproof.v | 26 | ||||
-rw-r--r-- | x86/TargetPrinter.ml | 14 | ||||
-rw-r--r-- | x86/ValueAOp.v | 2 | ||||
-rw-r--r-- | x86_32/Archi.v | 23 | ||||
-rw-r--r-- | x86_64/Archi.v | 23 |
158 files changed, 14486 insertions, 9521 deletions
@@ -78,5 +78,8 @@ runtime/mppa_k1c/i64_udivmod.s runtime/mppa_k1c/i64_umod.s # Test generated data /test/clightgen/*.v -# Coq cache +# Coq caches .lia.cache +.nia.cache +.nra.cache +.csdp.cache @@ -24,8 +24,8 @@ endif BACKENDLIB?=Asmgenproof0.v Asmgenproof1.v DIRS=lib common $(ARCHDIRS) backend cfrontend driver \ - flocq/Core flocq/Prop flocq/Calc flocq/Appli exportclight \ - cparser cparser/MenhirLib + flocq/Core flocq/Prop flocq/Calc flocq/IEEE754 \ + exportclight cparser cparser/MenhirLib RECDIRS=lib common $(ARCHDIRS) backend cfrontend driver flocq exportclight cparser @@ -45,20 +45,17 @@ GPATH=$(DIRS) # Flocq FLOCQ=\ - Fcore_Raux.v Fcore_Zaux.v Fcore_defs.v Fcore_digits.v \ - Fcore_float_prop.v Fcore_FIX.v Fcore_FLT.v Fcore_FLX.v \ - Fcore_FTZ.v Fcore_generic_fmt.v Fcore_rnd.v Fcore_rnd_ne.v \ - Fcore_ulp.v Fcore.v \ - Fcalc_bracket.v Fcalc_digits.v Fcalc_div.v Fcalc_ops.v \ - Fcalc_round.v Fcalc_sqrt.v \ - Fprop_div_sqrt_error.v Fprop_mult_error.v Fprop_plus_error.v \ - Fprop_relative.v Fprop_Sterbenz.v \ - Fappli_rnd_odd.v Fappli_double_round.v Fappli_IEEE.v Fappli_IEEE_bits.v + Raux.v Zaux.v Defs.v Digits.v Float_prop.v FIX.v FLT.v FLX.v FTZ.v \ + Generic_fmt.v Round_pred.v Round_NE.v Ulp.v Core.v \ + Bracket.v Div.v Operations.v Round.v Sqrt.v \ + Div_sqrt_error.v Mult_error.v Plus_error.v \ + Relative.v Sterbenz.v Round_odd.v Double_rounding.v \ + Binary.v Bits.v # General-purpose libraries (in lib/) VLIB=Axioms.v Coqlib.v Intv.v Maps.v Heaps.v Lattice.v Ordered.v \ - Iteration.v Integers.v Archi.v Fappli_IEEE_extra.v Floats.v \ + Iteration.v Zbits.v Integers.v Archi.v IEEE754_extra.v Floats.v \ Parmov.v UnionFind.v Wfsimpl.v \ Postorder.v FSetAVLplus.v IntvSets.v Decidableplus.v BoolEqual.v @@ -72,7 +69,7 @@ COMMON=Errors.v AST.v Linking.v \ # Back-end modules (in backend/, $(ARCH)/) BACKEND=\ - Cminor.v Op.v CminorSel.v OpHelpers.v OpHelpersproof.v \ + Cminor.v Cminortyping.v Op.v CminorSel.v OpHelpers.v OpHelpersproof.v \ SelectOp.v SelectDiv.v SplitLong.v SelectLong.v Selection.v \ SelectOpproof.v SelectDivproof.v SplitLongproof.v \ SelectLongproof.v Selectionproof.v \ @@ -242,24 +239,24 @@ depend1: $(FILES) exportclight/Clightdefs.v @$(COQDEP) $^ > .depend install: - install -d $(BINDIR) - install -m 0755 ./ccomp $(BINDIR) - install -d $(SHAREDIR) - install -m 0644 ./compcert.ini $(SHAREDIR) - install -d $(MANDIR)/man1 - install -m 0644 ./doc/ccomp.1 $(MANDIR)/man1 + install -d $(DESTDIR)$(BINDIR) + install -m 0755 ./ccomp $(DESTDIR)$(BINDIR) + install -d $(DESTDIR)$(SHAREDIR) + install -m 0644 ./compcert.ini $(DESTDIR)$(SHAREDIR) + install -d $(DESTDIR)$(MANDIR)/man1 + install -m 0644 ./doc/ccomp.1 $(DESTDIR)$(MANDIR)/man1 $(MAKE) -C runtime install ifeq ($(CLIGHTGEN),true) - install -m 0755 ./clightgen $(BINDIR) + install -m 0755 ./clightgen $(DESTDIR)$(BINDIR) endif ifeq ($(INSTALL_COQDEV),true) - install -d $(COQDEVDIR) + install -d $(DESTDIR)$(COQDEVDIR) for d in $(DIRS); do \ - install -d $(COQDEVDIR)/$$d && \ - install -m 0644 $$d/*.vo $(COQDEVDIR)/$$d/; \ + install -d $(DESTDIR)$(COQDEVDIR)/$$d && \ + install -m 0644 $$d/*.vo $(DESTDIR)$(COQDEVDIR)/$$d/; \ done - install -m 0644 ./VERSION $(COQDEVDIR) - @(echo "To use, pass the following to coq_makefile or add the following to _CoqProject:"; echo "-R $(COQDEVDIR) compcert") > $(COQDEVDIR)/README + install -m 0644 ./VERSION $(DESTDIR)$(COQDEVDIR) + @(echo "To use, pass the following to coq_makefile or add the following to _CoqProject:"; echo "-R $(COQDEVDIR) compcert") > $(DESTDIR)$(COQDEVDIR)/README endif diff --git a/arm/Archi.v b/arm/Archi.v index 353731e0..39a424ec 100644 --- a/arm/Archi.v +++ b/arm/Archi.v @@ -17,8 +17,8 @@ (** Architecture-dependent parameters for ARM *) Require Import ZArith. -Require Import Fappli_IEEE. -Require Import Fappli_IEEE_bits. +(*From Flocq*) +Require Import Binary Bits. Definition ptr64 := false. @@ -34,29 +34,30 @@ Proof. unfold splitlong, ptr64; congruence. Qed. -Program Definition default_pl_64 : bool * nan_pl 53 := - (false, iter_nat 51 _ xO xH). +Definition default_nan_64 : { x : binary64 | is_nan _ _ x = true } := + exist _ (B754_nan 53 1024 false (iter_nat 51 _ xO xH) (eq_refl true)) (eq_refl true). -Definition choose_binop_pl_64 (s1: bool) (pl1: nan_pl 53) (s2: bool) (pl2: nan_pl 53) := +Definition choose_binop_pl_64 (pl1 pl2 : positive) := (** Choose second NaN if pl2 is sNaN but pl1 is qNan. In all other cases, choose first NaN *) - (Pos.testbit (proj1_sig pl1) 51 && - negb (Pos.testbit (proj1_sig pl2) 51))%bool. + (Pos.testbit pl1 51 && negb (Pos.testbit pl2 51))%bool. -Program Definition default_pl_32 : bool * nan_pl 24 := - (false, iter_nat 22 _ xO xH). +Definition default_nan_32 : { x : binary32 | is_nan _ _ x = true } := + exist _ (B754_nan 24 128 false (iter_nat 22 _ xO xH) (eq_refl true)) (eq_refl true). -Definition choose_binop_pl_32 (s1: bool) (pl1: nan_pl 24) (s2: bool) (pl2: nan_pl 24) := +Definition choose_binop_pl_32 (pl1 pl2 : positive) := (** Choose second NaN if pl2 is sNaN but pl1 is qNan. In all other cases, choose first NaN *) - (Pos.testbit (proj1_sig pl1) 22 && - negb (Pos.testbit (proj1_sig pl2) 22))%bool. + (Pos.testbit pl1 22 && negb (Pos.testbit pl2 22))%bool. + +Definition fpu_returns_default_qNaN := false. Definition float_of_single_preserves_sNaN := false. Global Opaque ptr64 big_endian splitlong - default_pl_64 choose_binop_pl_64 - default_pl_32 choose_binop_pl_32 + default_nan_64 choose_binop_pl_64 + default_nan_32 choose_binop_pl_32 + fpu_returns_default_qNaN float_of_single_preserves_sNaN. (** Which ABI to use: either the standard ARM EABI with floats passed @@ -220,6 +220,7 @@ Inductive instruction : Type := | Plabel: label -> instruction (**r define a code label *) | Ploadsymbol: ireg -> ident -> ptrofs -> instruction (**r load the address of a symbol *) | Pmovite: testcond -> ireg -> shift_op -> shift_op -> instruction (**r integer conditional move *) + | Pfmovite: testcond -> freg -> freg -> freg -> instruction (**r FP conditional move *) | Pbtbl: ireg -> list label -> instruction (**r N-way branch through a jump table *) | Pbuiltin: external_function -> list (builtin_arg preg) -> builtin_res preg -> instruction (**r built-in function (pseudo) *) | Padc: ireg -> ireg -> shift_op -> instruction (**r add with carry *) @@ -783,6 +784,14 @@ Definition exec_instr (f: function) (i: instruction) (rs: regset) (m: mem) : out | None => Vundef end in Next (nextinstr (rs#r1 <- v)) m + | Pfmovite cond r1 ifso ifnot => + let v := + match eval_testcond cond rs with + | Some true => rs#ifso + | Some false => rs#ifnot + | None => Vundef + end in + Next (nextinstr (rs#r1 <- v)) m | Pbtbl r tbl => match rs#r with | Vint n => diff --git a/arm/AsmToJSON.ml b/arm/AsmToJSON.ml index 3874e141..dfad6972 100644 --- a/arm/AsmToJSON.ml +++ b/arm/AsmToJSON.ml @@ -259,7 +259,8 @@ let pp_instructions pp ic = | Pmla(r1, r2, r3, r4) -> instruction pp "Pmla" [Ireg r1; Ireg r2; Ireg r3; Ireg r4] | Pmov(r1, so) -> instruction pp "Pmov" [Ireg r1; Shift so] | Pmovite(cond, r1, so1, so2) -> instruction pp "Pmovite" [Ireg r1; Condition (TargetPrinter.condition_name cond); Shift so1; Condition (TargetPrinter.neg_condition_name cond); Shift so2] - | Pmovt(r1, n) -> instruction pp "Pmovt" [Ireg r1; Long n] + | Pfmovite(cond, r1, r2, r3) -> instruction pp "Pfmovite" [DFreg r1; Condition (TargetPrinter.condition_name cond); DFreg r2; Condition (TargetPrinter.neg_condition_name cond); DFreg r3] + | Pmovt(r1, n) -> instruction pp "Pmovt" [Ireg r1; Long n] | Pmovw(r1, n) -> instruction pp "Pmovw" [Ireg r1; Long n] | Pmul(r1, r2, r3) -> instruction pp "Pmul" [Ireg r1; Ireg r2; Ireg r3] | Pmvn(r1, so) -> instruction pp "Pmvn" [Ireg r1; Shift so] diff --git a/arm/Asmgen.v b/arm/Asmgen.v index f12ea870..1a1e7f2f 100644 --- a/arm/Asmgen.v +++ b/arm/Asmgen.v @@ -555,6 +555,19 @@ Definition transl_op do r <- ireg_of res; transl_cond cmp args (Pmovite (cond_for_cond cmp) r (SOimm Int.one) (SOimm Int.zero) :: k) + | Osel cmp ty, a1 :: a2 :: args => + match preg_of res with + | IR r => + do r1 <- ireg_of a1; do r2 <- ireg_of a2; + transl_cond cmp args + (Pmovite (cond_for_cond cmp) r (SOreg r1) (SOreg r2) :: k) + | FR r => + do r1 <- freg_of a1; do r2 <- freg_of a2; + transl_cond cmp args + (Pfmovite (cond_for_cond cmp) r r1 r2 :: k) + | _ => + Error(msg "Asmgen.Osel") + end | _, _ => Error(msg "Asmgen.transl_op") end. diff --git a/arm/Asmgenproof.v b/arm/Asmgenproof.v index 2c001f45..25f91d23 100644 --- a/arm/Asmgenproof.v +++ b/arm/Asmgenproof.v @@ -270,6 +270,7 @@ Opaque Int.eq. destruct Archi.thumb2_support; TailNoLabel. eapply tail_nolabel_trans; TailNoLabel. eapply tail_nolabel_trans. eapply transl_cond_label; eauto. TailNoLabel. + destruct (preg_of r); monadInv H; (eapply tail_nolabel_trans; [eapply transl_cond_label; eauto|TailNoLabel]). Qed. Remark transl_memory_access_label: diff --git a/arm/Asmgenproof1.v b/arm/Asmgenproof1.v index 98cd5eea..807e069d 100644 --- a/arm/Asmgenproof1.v +++ b/arm/Asmgenproof1.v @@ -16,6 +16,7 @@ Require Import Coqlib. Require Import Errors. Require Import Maps. Require Import AST. +Require Import Zbits. Require Import Integers. Require Import Floats. Require Import Values. @@ -355,7 +356,7 @@ Proof. rewrite Int.and_assoc. change 65535 with (two_p 16 - 1). rewrite Int.and_idem. apply Int.same_bits_eq; intros. rewrite Int.bits_or, Int.bits_and, Int.bits_shl, Int.testbit_repr by auto. - rewrite Int.Ztestbit_two_p_m1 by omega. change (Int.unsigned (Int.repr 16)) with 16. + rewrite Ztestbit_two_p_m1 by omega. change (Int.unsigned (Int.repr 16)) with 16. destruct (zlt i 16). rewrite andb_true_r, orb_false_r; auto. rewrite andb_false_r; simpl. rewrite Int.bits_shru by omega. @@ -1188,7 +1189,7 @@ Lemma transl_op_correct_same: forall op args res k c (rs: regset) m v, transl_op op args res k = OK c -> eval_operation ge rs#IR13 op (map rs (map preg_of args)) m = Some v -> - match op with Ocmp _ => False | Oaddrstack _ => False | _ => True end -> + match op with Ocmp _ => False | Osel _ _ => False | Oaddrstack _ => False | _ => True end -> exists rs', exec_straight ge fn c rs m k rs' m /\ rs'#(preg_of res) = v @@ -1332,6 +1333,8 @@ Transparent destroyed_by_op. intuition Simpl. (* Ocmp *) contradiction. + (* Osel *) + contradiction. Qed. Lemma transl_op_correct: @@ -1368,6 +1371,27 @@ Proof. split; intros; Simpl. destruct (eval_condition c0 rs ## (preg_of ## args) m) as [b|]; simpl; auto. destruct B as [B1 B2]; rewrite B1. destruct b; auto. +- (* Osel *) + clear SAME. simpl in H. ArgsInv. simpl in H0; inv H0. + assert (D1: data_preg (preg_of m0) = true) by auto with asmgen. + assert (D2: data_preg (preg_of m1) = true) by auto with asmgen. + destruct (preg_of res) eqn:RES; monadInv H. ++ inv EQ2. rewrite (ireg_of_eq _ _ EQ), (ireg_of_eq _ _ EQ1) in *. + exploit transl_cond_correct; eauto. instantiate (1 := rs). instantiate (1 := m). intros [rs1 [A [B C]]]. + econstructor; split. + eapply exec_straight_trans. eexact A. apply exec_straight_one. simpl; eauto. auto. + split; intros; Simpl. + rewrite ! C by auto. + destruct (eval_condition c0 rs ## (preg_of ## args) m) as [b|]; simpl; auto. + destruct B as [B1 B2]; rewrite B1. destruct b; apply Val.lessdef_normalize. ++ inv EQ2. rewrite (freg_of_eq _ _ EQ), (freg_of_eq _ _ EQ1) in *. + exploit transl_cond_correct; eauto. instantiate (1 := rs). instantiate (1 := m). intros [rs1 [A [B C]]]. + econstructor; split. + eapply exec_straight_trans. eexact A. apply exec_straight_one. simpl; eauto. auto. + split; intros; Simpl. + rewrite ! C by auto. + destruct (eval_condition c0 rs ## (preg_of ## args) m) as [b|]; simpl; auto. + destruct B as [B1 B2]; rewrite B1. destruct b; apply Val.lessdef_normalize. Qed. (** Translation of loads and stores. *) diff --git a/arm/NeedOp.v b/arm/NeedOp.v index dee7cae1..c70c7e40 100644 --- a/arm/NeedOp.v +++ b/arm/NeedOp.v @@ -83,6 +83,7 @@ Definition needs_of_operation (op: operation) (nv: nval): list nval := | Omakelong => op2 (default nv) | Olowlong | Ohighlong => op1 (default nv) | Ocmp c => needs_of_condition c + | Osel c ty => nv :: nv :: needs_of_condition c end. Definition operation_is_redundant (op: operation) (nv: nval): bool := @@ -183,6 +184,10 @@ Proof. - apply notint_sound; auto. - apply notint_sound. apply needs_of_shift_sound; auto. - apply needs_of_shift_sound; auto. +- destruct (eval_condition c args m) as [b|] eqn:EC. + erewrite needs_of_condition_sound by eauto. + apply select_sound; auto. + simpl; auto with na. Qed. Lemma operation_is_redundant_sound: @@ -140,7 +140,9 @@ Inductive operation : Type := | Olowlong: operation (**r [rd = low-word(r1)] *) | Ohighlong: operation (**r [rd = high-word(r1)] *) (*c Boolean tests: *) - | Ocmp: condition -> operation. (**r [rd = 1] if condition holds, [rd = 0] otherwise. *) + | Ocmp: condition -> operation (**r [rd = 1] if condition holds, [rd = 0] otherwise. *) + | Osel: condition -> typ -> operation. + (**r [rd = rs1] if condition holds, [rd = rs2] otherwise. *) (** Addressing modes. [r1], [r2], etc, are the arguments to the addressing. *) @@ -174,7 +176,7 @@ Defined. Definition eq_operation (x y: operation): {x=y} + {x<>y}. Proof. - generalize Int.eq_dec Ptrofs.eq_dec ident_eq; intros. + generalize Int.eq_dec Ptrofs.eq_dec ident_eq typ_eq; intros. generalize Float.eq_dec Float32.eq_dec; intros. generalize eq_shift; intro. generalize eq_condition; intro. @@ -294,6 +296,7 @@ Definition eval_operation | Olowlong, v1::nil => Some(Val.loword v1) | Ohighlong, v1::nil => Some(Val.hiword v1) | Ocmp c, _ => Some(Val.of_optbool (eval_condition c vl m)) + | Osel c ty, v1::v2::vl => Some(Val.select (eval_condition c vl m) v1 v2 ty) | _, _ => None end. @@ -419,6 +422,7 @@ Definition type_of_operation (op: operation) : list typ * typ := | Olowlong => (Tlong :: nil, Tint) | Ohighlong => (Tlong :: nil, Tint) | Ocmp c => (type_of_condition c, Tint) + | Osel c ty => (ty :: ty :: type_of_condition c, ty) end. Definition type_of_addressing (addr: addressing) : list typ := @@ -511,6 +515,7 @@ Proof with (try exact I; try reflexivity). destruct v0... destruct v0... destruct (eval_condition c vl m)... destruct b... + unfold Val.select. destruct (eval_condition c vl m). apply Val.normalize_type. exact I. Qed. End SOUNDNESS. @@ -532,7 +537,7 @@ Lemma mk_shift_amount_eq: forall n, Int.ltu n Int.iwordsize = true -> s_amount (mk_shift_amount n) = n. Proof. intros; simpl. unfold Int.modu. transitivity (Int.repr (Int.unsigned n)). - decEq. apply Zmod_small. apply Int.ltu_inv; auto. + decEq. apply Z.mod_small. apply Int.ltu_inv; auto. apply Int.repr_unsigned. Qed. @@ -682,19 +687,37 @@ Definition is_trivial_op (op: operation) : bool := (** Operations that depend on the memory state. *) +Definition condition_depends_on_memory (c: condition) : bool := + match c with + | Ccompu _ | Ccompushift _ _| Ccompuimm _ _ => true + | _ => false + end. + Definition op_depends_on_memory (op: operation) : bool := match op with - | Ocmp (Ccompu _ | Ccompushift _ _| Ccompuimm _ _) => true + | Ocmp c => condition_depends_on_memory c + | Osel c ty => condition_depends_on_memory c | _ => false end. +Lemma condition_depends_on_memory_correct: + forall c args m1 m2, + condition_depends_on_memory c = false -> + eval_condition c args m1 = eval_condition c args m2. +Proof. + intros. destruct c; simpl; auto; discriminate. +Qed. + Lemma op_depends_on_memory_correct: forall (F V: Type) (ge: Genv.t F V) sp op args m1 m2, op_depends_on_memory op = false -> eval_operation ge sp op args m1 = eval_operation ge sp op args m2. Proof. - intros until m2. destruct op; simpl; try congruence. - intros. destruct c; simpl; auto; congruence. + intros until m2. destruct op; simpl; try congruence; intros C. +- f_equal; f_equal; apply condition_depends_on_memory_correct; auto. +- destruct args; auto. destruct args; auto. + rewrite (condition_depends_on_memory_correct c args m1 m2 C). + auto. Qed. (** Global variables mentioned in an operation or addressing mode *) @@ -929,6 +952,10 @@ Proof. exploit eval_condition_inj; eauto. intros EQ; rewrite EQ. destruct b; simpl; constructor. simpl; constructor. + + apply Val.select_inject; auto. + destruct (eval_condition c vl1 m1) eqn:?; auto. + right; symmetry; eapply eval_condition_inj; eauto. Qed. Lemma eval_addressing_inj: diff --git a/arm/PrintOp.ml b/arm/PrintOp.ml index 642fff80..d74acf3f 100644 --- a/arm/PrintOp.ml +++ b/arm/PrintOp.ml @@ -129,6 +129,10 @@ let print_operation reg pp = function | Olowlong, [r1] -> fprintf pp "lowlong(%a)" reg r1 | Ohighlong, [r1] -> fprintf pp "highlong(%a)" reg r1 | Ocmp c, args -> print_condition reg pp (c, args) + | Osel (c, ty), r1::r2::args -> + fprintf pp "%a ?%s %a : %a" + (print_condition reg) (c, args) + (PrintAST.name_of_type ty) reg r1 reg r2 | _ -> fprintf pp "<bad operator>" let print_addressing reg pp = function diff --git a/arm/SelectOp.vp b/arm/SelectOp.vp index f3f01730..e3ef3eaf 100644 --- a/arm/SelectOp.vp +++ b/arm/SelectOp.vp @@ -383,6 +383,16 @@ Definition compf (c: comparison) (e1: expr) (e2: expr) := Definition compfs (c: comparison) (e1: expr) (e2: expr) := Eop (Ocmp (Ccompfs c)) (e1 ::: e2 ::: Enil). +Definition select (ty: typ) (cond: condition) (args: exprlist) (e1 e2: expr) := + if match ty with + | Tint => true + | Tfloat => true + | Tsingle => true + | _ => false + end + then Some (Eop (Osel cond ty) (e1 ::: e2 ::: args)) + else None. + (** ** Integer conversions *) Definition cast8unsigned (e: expr) := andimm (Int.repr 255) e. diff --git a/arm/SelectOpproof.v b/arm/SelectOpproof.v index 212bcfd7..f7dd8dd6 100644 --- a/arm/SelectOpproof.v +++ b/arm/SelectOpproof.v @@ -738,6 +738,22 @@ Proof. intros; red; intros. unfold compfs. TrivialExists. Qed. +Theorem eval_select: + forall le ty cond al vl a1 v1 a2 v2 a b, + select ty cond al a1 a2 = Some a -> + eval_exprlist ge sp e m le al vl -> + eval_expr ge sp e m le a1 v1 -> + eval_expr ge sp e m le a2 v2 -> + eval_condition cond vl m = Some b -> + exists v, + eval_expr ge sp e m le a v + /\ Val.lessdef (Val.select (Some b) v1 v2 ty) v. +Proof. + unfold select; intros. + destruct (match ty with Tint | Tfloat | Tsingle => true | _ => false end); inv H. + rewrite <- H3; TrivialExists. +Qed. + Theorem eval_cast8signed: unary_constructor_sound cast8signed (Val.sign_ext 8). Proof. red; intros until x. unfold cast8signed; case (cast8signed_match a); intros. diff --git a/arm/TargetPrinter.ml b/arm/TargetPrinter.ml index bf37b0e4..3a0814e1 100644 --- a/arm/TargetPrinter.ml +++ b/arm/TargetPrinter.ml @@ -148,9 +148,9 @@ struct let name_of_section = function | Section_text -> ".text" | Section_data i | Section_small_data i -> - if i then ".data" else "COMM" + if i then ".data" else common_section () | Section_const i | Section_small_const i -> - if i then ".section .rodata" else "COMM" + if i || (not !Clflags.option_fcommon) then ".section .rodata" else "COMM" | Section_string -> ".section .rodata" | Section_literal -> ".text" | Section_jumptable -> ".text" @@ -443,6 +443,12 @@ struct (condition_name cond) ireg r1 shift_op ifso; fprintf oc " mov%s %a, %a\n" (neg_condition_name cond) ireg r1 shift_op ifnot + | Pfmovite(cond, r1, ifso, ifnot) -> + fprintf oc " ite %s\n" (condition_name cond); + fprintf oc " vmov%s.f64 %a, %a\n" + (condition_name cond) freg r1 freg ifso; + fprintf oc " vmov%s.f64 %a, %a\n" + (neg_condition_name cond) freg r1 freg ifnot | Pbtbl(r, tbl) -> if !Clflags.option_mthumb then begin fprintf oc " lsl r14, %a, #2\n" ireg r; diff --git a/arm/ValueAOp.v b/arm/ValueAOp.v index e19ddd6d..a3fd9d7d 100644 --- a/arm/ValueAOp.v +++ b/arm/ValueAOp.v @@ -127,6 +127,7 @@ Definition eval_static_operation (op: operation) (vl: list aval): aval := | Olowlong, v1::nil => loword v1 | Ohighlong, v1::nil => hiword v1 | Ocmp c, _ => of_optbool (eval_static_condition c vl) + | Osel c ty, v1::v2::vl => select (eval_static_condition c vl) v1 v2 | _, _ => Vbot end. @@ -205,6 +206,7 @@ Proof. rewrite Ptrofs.add_zero_l; eauto with va. fold (Val.sub (Vint i) a1). auto with va. apply of_optbool_sound. eapply eval_static_condition_sound; eauto. + apply select_sound; auto. eapply eval_static_condition_sound; eauto. Qed. End SOUNDNESS. diff --git a/backend/Allocation.v b/backend/Allocation.v index cf62295d..13e14530 100644 --- a/backend/Allocation.v +++ b/backend/Allocation.v @@ -36,7 +36,7 @@ Require Import Op Registers RTL Locations Conventions RTLtyping LTL. - a [Lbranch s] instruction. The [block_shape] type below describes all possible cases of structural - maching between an RTL instruction and an LTL basic block. + matching between an RTL instruction and an LTL basic block. *) Inductive move: Type := diff --git a/backend/Asmexpandaux.mli b/backend/Asmexpandaux.mli index d80b4aec..e2320418 100644 --- a/backend/Asmexpandaux.mli +++ b/backend/Asmexpandaux.mli @@ -22,7 +22,7 @@ val emit: instruction -> unit val new_label: unit -> label (* Compute a fresh label *) val is_current_function_variadic: unit -> bool - (* Test wether the current function is a variadic function *) + (* Test whether the current function is a variadic function *) val get_current_function_args: unit -> typ list (* Get the types of the current function arguments *) val get_current_function_sig: unit -> signature @@ -33,4 +33,4 @@ val get_current_function: unit -> coq_function (* Get the current function *) val expand: positive -> int -> (preg -> int) -> (instruction -> unit) -> instruction list -> unit (* Expand the instruction sequence of a function. Takes the function id, the register number of the stackpointer, a - function to get the dwarf mapping of varibale names and for the expansion of simple instructions *) + function to get the dwarf mapping of variable names and for the expansion of simple instructions *) diff --git a/backend/CSEproof.v b/backend/CSEproof.v index d6bde348..a60c316b 100644 --- a/backend/CSEproof.v +++ b/backend/CSEproof.v @@ -544,7 +544,7 @@ Lemma kill_loads_after_storebytes_holds: bc sp = BCstack -> ematch bc rs ae -> approx = VA.State ae am -> - length bytes = nat_of_Z sz -> sz >= 0 -> + length bytes = Z.to_nat sz -> sz >= 0 -> numbering_holds valu ge (Vptr sp Ptrofs.zero) rs m' (kill_loads_after_storebytes approx n dst sz). Proof. @@ -557,7 +557,7 @@ Proof. simpl. rewrite negb_false_iff in H8. eapply Mem.load_storebytes_other. eauto. - rewrite H6. rewrite nat_of_Z_eq by auto. + rewrite H6. rewrite Z2Nat.id by omega. eapply pdisjoint_sound. eauto. unfold aaddressing. apply match_aptr_of_aval. eapply eval_static_addressing_sound; eauto. erewrite <- regs_valnums_sound by eauto. eauto with va. @@ -598,9 +598,9 @@ Proof. exploit Mem.storebytes_split; eauto. intros (m2 & SB2 & SB3). clear SB23. assert (L1: Z.of_nat (length bytes1) = n1). - { erewrite Mem.loadbytes_length by eauto. apply nat_of_Z_eq. unfold n1; omega. } + { erewrite Mem.loadbytes_length by eauto. apply Z2Nat.id. unfold n1; omega. } assert (L2: Z.of_nat (length bytes2) = n2). - { erewrite Mem.loadbytes_length by eauto. apply nat_of_Z_eq. unfold n2; omega. } + { erewrite Mem.loadbytes_length by eauto. apply Z2Nat.id. unfold n2; omega. } rewrite L1 in *. rewrite L2 in *. assert (LB': Mem.loadbytes m2 b2 (ofs2 + n1) n2 = Some bytes2). { rewrite <- L2. eapply Mem.loadbytes_storebytes_same; eauto. } diff --git a/backend/Cminor.v b/backend/Cminor.v index 11941da3..ca01ad50 100644 --- a/backend/Cminor.v +++ b/backend/Cminor.v @@ -591,6 +591,70 @@ Proof. red; intros; inv H; simpl; try omega; eapply external_call_trace_length; eauto. Qed. +(** This semantics is determinate. *) + +Lemma eval_expr_determ: + forall ge sp e m a v, eval_expr ge sp e m a v -> + forall v', eval_expr ge sp e m a v' -> v' = v. +Proof. + induction 1; intros v' E'; inv E'. +- congruence. +- congruence. +- assert (v0 = v1) by eauto. congruence. +- assert (v0 = v1) by eauto. assert (v3 = v2) by eauto. congruence. +- assert (vaddr0 = vaddr) by eauto. congruence. +Qed. + +Lemma eval_exprlist_determ: + forall ge sp e m al vl, eval_exprlist ge sp e m al vl -> + forall vl', eval_exprlist ge sp e m al vl' -> vl' = vl. +Proof. + induction 1; intros vl' E'; inv E'. + - auto. + - f_equal; eauto using eval_expr_determ. +Qed. + +Ltac Determ := + try congruence; + match goal with + | [ |- match_traces _ E0 E0 /\ (_ -> _) ] => + split; [constructor|intros _; Determ] + | [ H: is_call_cont ?k |- _ ] => + contradiction || (clear H; Determ) + | [ H1: eval_expr _ _ _ _ ?a ?v1, H2: eval_expr _ _ _ _ ?a ?v2 |- _ ] => + assert (v1 = v2) by (eapply eval_expr_determ; eauto); + clear H1 H2; Determ + | [ H1: eval_exprlist _ _ _ _ ?a ?v1, H2: eval_exprlist _ _ _ _ ?a ?v2 |- _ ] => + assert (v1 = v2) by (eapply eval_exprlist_determ; eauto); + clear H1 H2; Determ + | _ => idtac + end. + +Lemma semantics_determinate: + forall (p: program), determinate (semantics p). +Proof. + intros. constructor; set (ge := Genv.globalenv p); simpl; intros. +- (* determ *) + inv H; inv H0; Determ. + + subst vargs0. exploit external_call_determ. eexact H2. eexact H13. + intros (A & B). split; intros; auto. + apply B in H; destruct H; congruence. + + subst v0. assert (b0 = b) by (inv H2; inv H13; auto). subst b0; auto. + + assert (n0 = n) by (inv H2; inv H14; auto). subst n0; auto. + + exploit external_call_determ. eexact H1. eexact H7. + intros (A & B). split; intros; auto. + apply B in H; destruct H; congruence. +- (* single event *) + red; simpl. destruct 1; simpl; try omega; + eapply external_call_trace_length; eauto. +- (* initial states *) + inv H; inv H0. unfold ge0, ge1 in *. congruence. +- (* nostep final state *) + red; intros; red; intros. inv H; inv H0. +- (* final states *) + inv H; inv H0; auto. +Qed. + (** * Alternate operational semantics (big-step) *) (** We now define another semantics for Cminor without [goto] that follows diff --git a/backend/Cminortyping.v b/backend/Cminortyping.v new file mode 100644 index 00000000..ddd0f98b --- /dev/null +++ b/backend/Cminortyping.v @@ -0,0 +1,798 @@ +(* *********************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Xavier Leroy, Collège de France and Inria Paris *) +(* *) +(* Copyright Institut National de Recherche en Informatique et en *) +(* Automatique. All rights reserved. This file is distributed *) +(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* *) +(* *********************************************************************) + +Require Import Coqlib Maps Errors. +Require Import AST Integers Floats Values Memory Globalenvs Events Smallstep. +Require Import Cminor. +Require Import Unityping. + +Local Open Scope string_scope. +Local Open Scope error_monad_scope. + +(** * Type inference algorithm *) + +Definition type_constant (c: constant) : typ := + match c with + | Ointconst _ => Tint + | Ofloatconst _ => Tfloat + | Osingleconst _ => Tsingle + | Olongconst _ => Tlong + | Oaddrsymbol _ _ => Tptr + | Oaddrstack _ => Tptr + end. + +Definition type_unop (op: unary_operation) : typ * typ := + match op with + | Ocast8unsigned | Ocast8signed | Ocast16unsigned | Ocast16signed + | Onegint | Onotint => (Tint, Tint) + | Onegf | Oabsf => (Tfloat, Tfloat) + | Onegfs | Oabsfs => (Tsingle, Tsingle) + | Osingleoffloat => (Tfloat, Tsingle) + | Ofloatofsingle => (Tsingle, Tfloat) + | Ointoffloat | Ointuoffloat => (Tfloat, Tint) + | Ofloatofint | Ofloatofintu => (Tint, Tfloat) + | Ointofsingle | Ointuofsingle => (Tsingle, Tint) + | Osingleofint | Osingleofintu => (Tint, Tsingle) + | Onegl | Onotl => (Tlong, Tlong) + | Ointoflong => (Tlong, Tint) + | Olongofint | Olongofintu => (Tint, Tlong) + | Olongoffloat | Olonguoffloat => (Tfloat, Tlong) + | Ofloatoflong | Ofloatoflongu => (Tlong, Tfloat) + | Olongofsingle | Olonguofsingle => (Tsingle, Tlong) + | Osingleoflong | Osingleoflongu => (Tlong, Tsingle) + end. + +Definition type_binop (op: binary_operation) : typ * typ * typ := + match op with + | Oadd | Osub | Omul | Odiv | Odivu | Omod | Omodu + | Oand | Oor | Oxor | Oshl | Oshr | Oshru => (Tint, Tint, Tint) + | Oaddf | Osubf | Omulf | Odivf => (Tfloat, Tfloat, Tfloat) + | Oaddfs| Osubfs| Omulfs| Odivfs => (Tsingle, Tsingle, Tsingle) + | Oaddl | Osubl | Omull | Odivl | Odivlu | Omodl | Omodlu + | Oandl | Oorl | Oxorl => (Tlong, Tlong, Tlong) + | Oshll | Oshrl | Oshrlu => (Tlong, Tint, Tlong) + | Ocmp _ | Ocmpu _ => (Tint, Tint, Tint) + | Ocmpf _ => (Tfloat, Tfloat, Tint) + | Ocmpfs _ => (Tsingle, Tsingle, Tint) + | Ocmpl _ | Ocmplu _ => (Tlong, Tlong, Tint) + end. + +Module RTLtypes <: TYPE_ALGEBRA. + +Definition t := typ. +Definition eq := typ_eq. +Definition default := Tint. + +End RTLtypes. + +Module S := UniSolver(RTLtypes). + +Definition expect (e: S.typenv) (t1 t2: typ) : res S.typenv := + if typ_eq t1 t2 then OK e else Error (msg "type mismatch"). + +Fixpoint type_expr (e: S.typenv) (a: expr) (t: typ) : res S.typenv := + match a with + | Evar id => S.set e id t + | Econst c => expect e (type_constant c) t + | Eunop op a1 => + let '(targ1, tres) := type_unop op in + do e1 <- type_expr e a1 targ1; + expect e1 tres t + | Ebinop op a1 a2 => + let '(targ1, targ2, tres) := type_binop op in + do e1 <- type_expr e a1 targ1; + do e2 <- type_expr e1 a2 targ2; + expect e2 tres t + | Eload chunk a1 => + do e1 <- type_expr e a1 Tptr; + expect e1 (type_of_chunk chunk) t + end. + +Fixpoint type_exprlist (e: S.typenv) (al: list expr) (tl: list typ) : res S.typenv := + match al, tl with + | nil, nil => OK e + | a :: al, t :: tl => do e1 <- type_expr e a t; type_exprlist e1 al tl + | _, _ => Error (msg "arity mismatch") + end. + +Definition type_assign (e: S.typenv) (id: ident) (a: expr) : res S.typenv := + match a with + | Evar id' => + do (changed, e1) <- S.move e id id'; OK e1 + | Econst c => + S.set e id (type_constant c) + | Eunop op a1 => + let '(targ1, tres) := type_unop op in + do e1 <- type_expr e a1 targ1; + S.set e1 id tres + | Ebinop op a1 a2 => + let '(targ1, targ2, tres) := type_binop op in + do e1 <- type_expr e a1 targ1; + do e2 <- type_expr e1 a2 targ2; + S.set e2 id tres + | Eload chunk a1 => + do e1 <- type_expr e a1 Tptr; + S.set e1 id (type_of_chunk chunk) + end. + +Definition opt_set (e: S.typenv) (optid: option ident) (optty: option typ) : res S.typenv := + match optid, optty with + | None, _ => OK e + | Some id, Some ty => S.set e id ty + | _, _ => Error (msg "inconsistent call") + end. + +Fixpoint type_stmt (tret: option typ) (e: S.typenv) (s: stmt) : res S.typenv := + match s with + | Sskip => OK e + | Sassign id a => type_assign e id a + | Sstore chunk a1 a2 => + do e1 <- type_expr e a1 Tptr; type_expr e1 a2 (type_of_chunk chunk) + | Scall optid sg fn args => + do e1 <- type_expr e fn Tptr; + do e2 <- type_exprlist e1 args sg.(sig_args); + opt_set e2 optid sg.(sig_res) + | Stailcall sg fn args => + assertion (opt_typ_eq sg.(sig_res) tret); + do e1 <- type_expr e fn Tptr; + type_exprlist e1 args sg.(sig_args) + | Sbuiltin optid ef args => + let sg := ef_sig ef in + do e1 <- type_exprlist e args sg.(sig_args); + opt_set e1 optid sg.(sig_res) + | Sseq s1 s2 => + do e1 <- type_stmt tret e s1; type_stmt tret e1 s2 + | Sifthenelse a s1 s2 => + do e1 <- type_expr e a Tint; + do e2 <- type_stmt tret e1 s1; + type_stmt tret e2 s2 + | Sloop s1 => + type_stmt tret e s1 + | Sblock s1 => + type_stmt tret e s1 + | Sexit n => + OK e + | Sswitch sz a tbl dfl => + type_expr e a (if sz then Tlong else Tint) + | Sreturn opta => + match tret, opta with + | None, None => OK e + | Some t, Some a => type_expr e a t + | _, _ => Error (msg "inconsistent return") + end + | Slabel lbl s1 => + type_stmt tret e s1 + | Sgoto lbl => + OK e + end. + +Definition typenv := ident -> typ. + +Definition type_function (f: function) : res typenv := + do e1 <- S.set_list S.initial f.(fn_params) f.(fn_sig).(sig_args); + do e2 <- type_stmt f.(fn_sig).(sig_res) e1 f.(fn_body); + S.solve e2. + +(** * Relational specification of the type system *) + +Section SPEC. + +Variable env: ident -> typ. +Variable tret: option typ. + +Inductive wt_expr: expr -> typ -> Prop := + | wt_Evar: forall id, + wt_expr (Evar id) (env id) + | wt_Econst: forall c, + wt_expr (Econst c) (type_constant c) + | wt_Eunop: forall op a1 targ1 tres, + type_unop op = (targ1, tres) -> + wt_expr a1 targ1 -> + wt_expr (Eunop op a1) tres + | wt_Ebinop: forall op a1 a2 targ1 targ2 tres, + type_binop op = (targ1, targ2, tres) -> + wt_expr a1 targ1 -> wt_expr a2 targ2 -> + wt_expr (Ebinop op a1 a2) tres + | wt_Eload: forall chunk a1, + wt_expr a1 Tptr -> + wt_expr (Eload chunk a1) (type_of_chunk chunk). + +Definition wt_opt_assign (optid: option ident) (optty: option typ) : Prop := + match optid with Some id => optty = Some (env id) | _ => True end. + +Inductive wt_stmt: stmt -> Prop := + | wt_Sskip: + wt_stmt Sskip + | wt_Sassign: forall id a, + wt_expr a (env id) -> + wt_stmt (Sassign id a) + | wt_Sstore: forall chunk a1 a2, + wt_expr a1 Tptr -> wt_expr a2 (type_of_chunk chunk) -> + wt_stmt (Sstore chunk a1 a2) + | wt_Scall: forall optid sg a1 al, + wt_expr a1 Tptr -> list_forall2 wt_expr al sg.(sig_args) -> + wt_opt_assign optid sg.(sig_res) -> + wt_stmt (Scall optid sg a1 al) + | wt_Stailcall: forall sg a1 al, + wt_expr a1 Tptr -> list_forall2 wt_expr al sg.(sig_args) -> + sg.(sig_res) = tret -> + wt_stmt (Stailcall sg a1 al) + | wt_Sbuiltin: forall optid ef al, + list_forall2 wt_expr al (ef_sig ef).(sig_args) -> + wt_opt_assign optid (ef_sig ef).(sig_res) -> + wt_stmt (Sbuiltin optid ef al) + | wt_Sseq: forall s1 s2, + wt_stmt s1 -> wt_stmt s2 -> + wt_stmt (Sseq s1 s2) + | wt_Sifthenelse: forall a s1 s2, + wt_expr a Tint -> wt_stmt s1 -> wt_stmt s2 -> + wt_stmt (Sifthenelse a s1 s2) + | wt_Sloop: forall s1, + wt_stmt s1 -> + wt_stmt (Sloop s1) + | wt_Sblock: forall s1, + wt_stmt s1 -> + wt_stmt (Sblock s1) + | wt_Sexit: forall n, + wt_stmt (Sexit n) + | wt_Sswitch: forall (sz: bool) a tbl dfl, + wt_expr a (if sz then Tlong else Tint) -> + wt_stmt (Sswitch sz a tbl dfl) + | wt_Sreturn_none: + tret = None -> + wt_stmt (Sreturn None) + | wt_Sreturn_some: forall a t, + tret = Some t -> wt_expr a t -> + wt_stmt (Sreturn (Some a)) + | wt_Slabel: forall lbl s1, + wt_stmt s1 -> + wt_stmt (Slabel lbl s1) + | wt_Sgoto: forall lbl, + wt_stmt (Sgoto lbl). + +End SPEC. + +Inductive wt_function (env: typenv) (f: function) : Prop := + wt_function_intro: + type_function f = OK env -> (**r to ensure uniqueness of [env] *) + List.map env f.(fn_params) = f.(fn_sig).(sig_args) -> + wt_stmt env f.(fn_sig).(sig_res) f.(fn_body) -> + wt_function env f. + +Inductive wt_fundef: fundef -> Prop := + | wt_fundef_internal: forall env f, + wt_function env f -> + wt_fundef (Internal f) + | wt_fundef_external: forall ef, + wt_fundef (External ef). + +Definition wt_program (p: program): Prop := + forall i f, In (i, Gfun f) (prog_defs p) -> wt_fundef f. + +(** * Soundness of type inference *) + +Lemma expect_incr: forall te e t1 t2 e', + expect e t1 t2 = OK e' -> S.satisf te e' -> S.satisf te e. +Proof. + unfold expect; intros. destruct (typ_eq t1 t2); inv H; auto. +Qed. +Hint Resolve expect_incr: ty. + +Lemma expect_sound: forall e t1 t2 e', + expect e t1 t2 = OK e' -> t1 = t2. +Proof. + unfold expect; intros. destruct (typ_eq t1 t2); inv H; auto. +Qed. + +Lemma type_expr_incr: forall te a t e e', + type_expr e a t = OK e' -> S.satisf te e' -> S.satisf te e. +Proof. + induction a; simpl; intros until e'; intros T SAT; try (monadInv T); eauto with ty. +- destruct (type_unop u) as [targ1 tres]; monadInv T; eauto with ty. +- destruct (type_binop b) as [[targ1 targ2] tres]; monadInv T; eauto with ty. +Qed. +Hint Resolve type_expr_incr: ty. + +Lemma type_expr_sound: forall te a t e e', + type_expr e a t = OK e' -> S.satisf te e' -> wt_expr te a t. +Proof. + induction a; simpl; intros until e'; intros T SAT; try (monadInv T). +- erewrite <- S.set_sound by eauto. constructor. +- erewrite <- expect_sound by eauto. constructor. +- destruct (type_unop u) as [targ1 tres] eqn:TU; monadInv T. + erewrite <- expect_sound by eauto. econstructor; eauto with ty. +- destruct (type_binop b) as [[targ1 targ2] tres] eqn:TB; monadInv T. + erewrite <- expect_sound by eauto. econstructor; eauto with ty. +- erewrite <- expect_sound by eauto. econstructor; eauto with ty. +Qed. + +Lemma type_exprlist_incr: forall te al tl e e', + type_exprlist e al tl = OK e' -> S.satisf te e' -> S.satisf te e. +Proof. + induction al; destruct tl; simpl; intros until e'; intros T SAT; monadInv T; eauto with ty. +Qed. +Hint Resolve type_exprlist_incr: ty. + +Lemma type_exprlist_sound: forall te al tl e e', + type_exprlist e al tl = OK e' -> S.satisf te e' -> list_forall2 (wt_expr te) al tl. +Proof. + induction al; destruct tl; simpl; intros until e'; intros T SAT; monadInv T. +- constructor. +- constructor; eauto using type_expr_sound with ty. +Qed. + +Lemma type_assign_incr: forall te id a e e', + type_assign e id a = OK e' -> S.satisf te e' -> S.satisf te e. +Proof. + induction a; simpl; intros until e'; intros T SAT; try (monadInv T); eauto with ty. +- destruct (type_unop u) as [targ1 tres]; monadInv T; eauto with ty. +- destruct (type_binop b) as [[targ1 targ2] tres]; monadInv T; eauto with ty. +Qed. +Hint Resolve type_assign_incr: ty. + +Lemma type_assign_sound: forall te id a e e', + type_assign e id a = OK e' -> S.satisf te e' -> wt_expr te a (te id). +Proof. + induction a; simpl; intros until e'; intros T SAT; try (monadInv T). +- erewrite S.move_sound by eauto. constructor. +- erewrite S.set_sound by eauto. constructor. +- destruct (type_unop u) as [targ1 tres] eqn:TU; monadInv T. + erewrite S.set_sound by eauto. econstructor; eauto using type_expr_sound with ty. +- destruct (type_binop b) as [[targ1 targ2] tres] eqn:TB; monadInv T. + erewrite S.set_sound by eauto. econstructor; eauto using type_expr_sound with ty. +- erewrite S.set_sound by eauto. econstructor; eauto using type_expr_sound with ty. +Qed. + +Lemma opt_set_incr: forall te optid optty e e', + opt_set e optid optty = OK e' -> S.satisf te e' -> S.satisf te e. +Proof. + unfold opt_set; intros. destruct optid, optty; try (monadInv H); eauto with ty. +Qed. +Hint Resolve opt_set_incr: ty. + +Lemma opt_set_sound: forall te optid optty e e', + opt_set e optid optty = OK e' -> S.satisf te e' -> wt_opt_assign te optid optty. +Proof. + unfold opt_set; intros; red. destruct optid; [destruct optty |]; try (monadInv H). +- erewrite S.set_sound by eauto. auto. +- auto. +Qed. + +Lemma type_stmt_incr: forall te tret s e e', + type_stmt tret e s = OK e' -> S.satisf te e' -> S.satisf te e. +Proof. + induction s; simpl; intros e1 e2 T SAT; try (monadInv T); eauto with ty. +- destruct tret, o; try (monadInv T); eauto with ty. +Qed. +Hint Resolve type_stmt_incr: ty. + +Lemma type_stmt_sound: forall te tret s e e', + type_stmt tret e s = OK e' -> S.satisf te e' -> wt_stmt te tret s. +Proof. + induction s; simpl; intros e1 e2 T SAT; try (monadInv T). +- constructor. +- constructor; eauto using type_assign_sound. +- constructor; eauto using type_expr_sound with ty. +- constructor; eauto using type_expr_sound, type_exprlist_sound, opt_set_sound with ty. +- constructor; eauto using type_expr_sound, type_exprlist_sound with ty. +- constructor; eauto using type_exprlist_sound, opt_set_sound with ty. +- constructor; eauto with ty. +- constructor; eauto using type_expr_sound with ty. +- constructor; eauto. +- constructor; eauto. +- constructor. +- constructor; eauto using type_expr_sound with ty. +- destruct tret, o; try (monadInv T); econstructor; eauto using type_expr_sound with ty. +- constructor; eauto. +- constructor. +Qed. + +Theorem type_function_sound: forall f env, + type_function f = OK env -> wt_function env f. +Proof. + intros. generalize H; unfold type_function; intros T; monadInv T. + assert (S.satisf env x0) by (apply S.solve_sound; auto). + constructor; eauto using S.set_list_sound, type_stmt_sound with ty. +Qed. + +(** * Semantic soundness of the type system *) + +Definition wt_env (env: typenv) (e: Cminor.env) : Prop := + forall id v, e!id = Some v -> Val.has_type v (env id). + +Definition def_env (f: function) (e: Cminor.env) : Prop := + forall id, In id f.(fn_params) \/ In id f.(fn_vars) -> exists v, e!id = Some v. + +Inductive wt_cont_call: cont -> option typ -> Prop := + | wt_cont_Kstop: + wt_cont_call Kstop (Some Tint) + | wt_cont_Kcall: forall optid f sp e k tret env + (WT_FN: wt_function env f) + (WT_CONT: wt_cont env f.(fn_sig).(sig_res) k) + (WT_ENV: wt_env env e) + (DEF_ENV: def_env f e) + (WT_DEST: wt_opt_assign env optid tret), + wt_cont_call (Kcall optid f sp e k) tret + +with wt_cont: typenv -> option typ -> cont -> Prop := + | wt_cont_Kseq: forall env tret s k, + wt_stmt env tret s -> + wt_cont env tret k -> + wt_cont env tret (Kseq s k) + | wt_cont_Kblock: forall env tret k, + wt_cont env tret k -> + wt_cont env tret (Kblock k) + | wt_cont_other: forall env tret k, + wt_cont_call k tret -> + wt_cont env tret k. + +Inductive wt_state: state -> Prop := + | wt_normal_state: forall f s k sp e m env + (WT_FN: wt_function env f) + (WT_STMT: wt_stmt env f.(fn_sig).(sig_res) s) + (WT_CONT: wt_cont env f.(fn_sig).(sig_res) k) + (WT_ENV: wt_env env e) + (DEF_ENV: def_env f e), + wt_state (State f s k sp e m) + | wt_call_state: forall f args k m + (WT_FD: wt_fundef f) + (WT_ARGS: Val.has_type_list args (funsig f).(sig_args)) + (WT_CONT: wt_cont_call k (funsig f).(sig_res)), + wt_state (Callstate f args k m) + | wt_return_state: forall v k m tret + (WT_RES: Val.has_type v (match tret with None => Tint | Some t => t end)) + (WT_CONT: wt_cont_call k tret), + wt_state (Returnstate v k m). + +Lemma wt_is_call_cont: + forall env tret k, wt_cont env tret k -> is_call_cont k -> wt_cont_call k tret. +Proof. + destruct 1; intros ICC; contradiction || auto. +Qed. + +Lemma call_cont_wt: + forall env tret k, wt_cont env tret k -> wt_cont_call (call_cont k) tret. +Proof. + induction 1; simpl; auto. inversion H; subst; auto. +Qed. + +Lemma wt_env_assign: forall env id e v, + wt_env env e -> Val.has_type v (env id) -> wt_env env (PTree.set id v e). +Proof. + intros; red; intros. rewrite PTree.gsspec in H1; destruct (peq id0 id). +- congruence. +- auto. +Qed. + +Lemma def_env_assign: forall f e id v, + def_env f e -> def_env f (PTree.set id v e). +Proof. + intros; red; intros i IN. rewrite PTree.gsspec. destruct (peq i id). + exists v; auto. + auto. +Qed. + +Lemma wt_env_set_params: forall env il vl, + Val.has_type_list vl (map env il) -> wt_env env (set_params vl il). +Proof. + induction il as [ | i il]; destruct vl as [ | vl]; simpl; intros; try contradiction. +- red; intros. rewrite PTree.gempty in H0; discriminate. +- destruct H. apply wt_env_assign; auto. +Qed. + +Lemma def_set_params: forall id il vl, + In id il -> exists v, PTree.get id (set_params vl il) = Some v. +Proof. + induction il as [ | i il]; simpl; intros. +- contradiction. +- destruct vl as [ | v vl]; rewrite PTree.gsspec; destruct (peq id i). + econstructor; eauto. + apply IHil; intuition congruence. + econstructor; eauto. + apply IHil; intuition congruence. +Qed. + +Lemma wt_env_set_locals: forall env il e, + wt_env env e -> wt_env env (set_locals il e). +Proof. + induction il as [ | i il]; simpl; intros. +- auto. +- apply wt_env_assign; auto. exact I. +Qed. + +Lemma def_set_locals: forall id il e, + (exists v, PTree.get id e = Some v) \/ In id il -> + exists v, PTree.get id (set_locals il e) = Some v. +Proof. + induction il as [ | i il]; simpl; intros. +- tauto. +- rewrite PTree.gsspec; destruct (peq id i). + econstructor; eauto. + apply IHil; intuition congruence. +Qed. + +Lemma wt_find_label: forall env tret lbl s k, + wt_stmt env tret s -> wt_cont env tret k -> + match find_label lbl s k with + | Some (s', k') => wt_stmt env tret s' /\ wt_cont env tret k' + | None => True + end. +Proof. + induction s; intros k WS WK; simpl; auto. +- inv WS. assert (wt_cont env tret (Kseq s2 k)) by (constructor; auto). + specialize (IHs1 _ H1 H). destruct (find_label lbl s1 (Kseq s2 k)). + auto. apply IHs2; auto. +- inv WS. specialize (IHs1 _ H3 WK). destruct (find_label lbl s1 k). + auto. apply IHs2; auto. +- inversion WS; subst. apply IHs; auto. constructor; auto. +- inv WS. apply IHs; auto. constructor; auto. +- inv WS. destruct (ident_eq lbl l). auto. apply IHs; auto. +Qed. + +Section SUBJECT_REDUCTION. + +Variable p: program. + +Hypothesis wt_p: wt_program p. + +Let ge := Genv.globalenv p. + +Ltac VHT := + match goal with + | [ |- Val.has_type (if Archi.ptr64 then _ else _) _] => unfold Val.has_type; destruct Archi.ptr64 eqn:?; VHT + | [ |- Val.has_type (match ?v with _ => _ end) _] => destruct v; VHT + | [ |- Val.has_type (Vptr _ _) Tptr ] => apply Val.Vptr_has_type + | [ |- Val.has_type _ _ ] => exact I + | [ |- Val.has_type (?f _ _ _ _ _) _ ] => unfold f; VHT + | [ |- Val.has_type (?f _ _ _ _) _ ] => unfold f; VHT + | [ |- Val.has_type (?f _ _) _ ] => unfold f; VHT + | [ |- Val.has_type (?f _ _ _) _ ] => unfold f; VHT + | [ |- Val.has_type (?f _) _ ] => unfold f; VHT + | [ |- True ] => exact I + | [ |- ?x = ?x ] => reflexivity + | _ => idtac + end. + +Ltac VHT' := + match goal with + | [ H: None = Some _ |- _ ] => discriminate + | [ H: Some _ = Some _ |- _ ] => inv H; VHT + | [ H: match ?x with _ => _ end = Some _ |- _ ] => destruct x; VHT' + | [ H: ?f _ _ _ _ = Some _ |- _ ] => unfold f in H; VHT' + | [ H: ?f _ _ _ = Some _ |- _ ] => unfold f in H; VHT' + | [ H: ?f _ _ = Some _ |- _ ] => unfold f in H; VHT' + | [ H: ?f _ = Some _ |- _ ] => unfold f in H; VHT' + | _ => idtac + end. + +Lemma type_constant_sound: forall sp cst v, + eval_constant ge sp cst = Some v -> + Val.has_type v (type_constant cst). +Proof. + intros until v; intros EV. destruct cst; simpl in *; inv EV; VHT. +Qed. + +Lemma type_unop_sound: forall op v1 v, + eval_unop op v1 = Some v -> Val.has_type v (snd (type_unop op)). +Proof. + unfold eval_unop; intros op v1 v EV; destruct op; simpl; VHT'. +Qed. + +Lemma type_binop_sound: forall op v1 v2 m v, + eval_binop op v1 v2 m = Some v -> Val.has_type v (snd (type_binop op)). +Proof. + unfold eval_binop; intros op v1 v2 m v EV; destruct op; simpl; VHT'; + destruct (eq_block b b0); VHT. +Qed. + +Lemma wt_eval_expr: forall env sp e m a v, + eval_expr ge sp e m a v -> + forall t, + wt_expr env a t -> + wt_env env e -> + Val.has_type v t. +Proof. + induction 1; intros t WT ENV. +- inv WT. apply ENV; auto. +- inv WT. eapply type_constant_sound; eauto. +- inv WT. replace t with (snd (type_unop op)) by (rewrite H3; auto). eapply type_unop_sound; eauto. +- inv WT. replace t with (snd (type_binop op)) by (rewrite H5; auto). eapply type_binop_sound; eauto. +- inv WT. destruct vaddr; try discriminate. eapply Mem.load_type; eauto. +Qed. + +Lemma wt_eval_exprlist: forall env sp e m al vl, + eval_exprlist ge sp e m al vl -> + forall tl, + list_forall2 (wt_expr env) al tl -> + wt_env env e -> + Val.has_type_list vl tl. +Proof. + induction 1; intros tl WT ENV; inv WT; simpl. +- auto. +- split. eapply wt_eval_expr; eauto. eauto. +Qed. + +Lemma wt_find_funct: forall v fd, + Genv.find_funct ge v = Some fd -> wt_fundef fd. +Proof. + intros. eapply Genv.find_funct_prop; eauto. +Qed. + +Lemma subject_reduction: + forall st1 t st2, step ge st1 t st2 -> + forall (WT: wt_state st1), wt_state st2. +Proof. + destruct 1; intros; inv WT. +- inv WT_CONT. econstructor; eauto. inv H. +- inv WT_CONT. econstructor; eauto. inv H. +- econstructor; eauto using wt_is_call_cont. exact I. +- inv WT_STMT. econstructor; eauto using wt_Sskip. + apply wt_env_assign; auto. eapply wt_eval_expr; eauto. + apply def_env_assign; auto. +- econstructor; eauto using wt_Sskip. +- inv WT_STMT. econstructor; eauto. + eapply wt_find_funct; eauto. + eapply wt_eval_exprlist; eauto. + econstructor; eauto. +- inv WT_STMT. econstructor; eauto. + eapply wt_find_funct; eauto. + eapply wt_eval_exprlist; eauto. + rewrite H8; eapply call_cont_wt; eauto. +- inv WT_STMT. exploit external_call_well_typed; eauto. intros TRES. + econstructor; eauto using wt_Sskip. + unfold proj_sig_res in TRES; red in H5. + destruct optid. rewrite H5 in TRES. apply wt_env_assign; auto. assumption. + destruct optid. apply def_env_assign; auto. assumption. +- inv WT_STMT. econstructor; eauto. econstructor; eauto. +- inv WT_STMT. destruct b; econstructor; eauto. +- inv WT_STMT. econstructor; eauto. econstructor; eauto. constructor; auto. +- inv WT_STMT. econstructor; eauto. econstructor; eauto. +- inv WT_CONT. econstructor; eauto. inv H. +- inv WT_CONT. econstructor; eauto using wt_Sskip. inv H. +- inv WT_CONT. econstructor; eauto using wt_Sexit. inv H. +- econstructor; eauto using wt_Sexit. +- inv WT_STMT. econstructor; eauto using call_cont_wt. rewrite H0; exact I. +- inv WT_STMT. econstructor; eauto using call_cont_wt. + rewrite H2. eapply wt_eval_expr; eauto. +- inv WT_STMT. econstructor; eauto. +- inversion WT_FN; subst. + assert (WT_CK: wt_cont env (sig_res (fn_sig f)) (call_cont k)). + { constructor. eapply call_cont_wt; eauto. } + generalize (wt_find_label _ _ lbl _ _ H2 WT_CK). + rewrite H. intros [WT_STMT' WT_CONT']. econstructor; eauto. +- inv WT_FD. inversion H1; subst. econstructor; eauto. + constructor; auto. + apply wt_env_set_locals. apply wt_env_set_params. rewrite H2; auto. + red; intros. apply def_set_locals. destruct H4; auto. left; apply def_set_params; auto. +- exploit external_call_well_typed; eauto. unfold proj_sig_res. simpl in *. intros. + econstructor; eauto. +- inv WT_CONT. econstructor; eauto using wt_Sskip. + red in WT_DEST. + destruct optid. rewrite WT_DEST in WT_RES. apply wt_env_assign; auto. assumption. + destruct optid. apply def_env_assign; auto. assumption. +Qed. + +Lemma subject_reduction_star: + forall st1 t st2, star step ge st1 t st2 -> + forall (WT: wt_state st1), wt_state st2. +Proof. + induction 1; eauto using subject_reduction. +Qed. + +Lemma wt_initial_state: + forall S, initial_state p S -> wt_state S. +Proof. + intros. inv H. constructor. eapply Genv.find_funct_ptr_prop; eauto. + rewrite H3; constructor. + rewrite H3; constructor. +Qed. + +End SUBJECT_REDUCTION. + +(** * Safe expressions *) + +(** Function parameters and declared local variables are always defined + throughout the execution of a function. The following [known_idents] + data structure represents the set of those variables, with efficient membership. *) + +Definition known_idents := PTree.t unit. + +Definition is_known (ki: known_idents) (id: ident) := + match ki!id with Some _ => true | None => false end. + +Definition known_id (f: function) : known_idents := + let add (ki: known_idents) (id: ident) := PTree.set id tt ki in + List.fold_left add f.(fn_vars) + (List.fold_left add f.(fn_params) (PTree.empty unit)). + +(** A Cminor expression is safe if it always evaluates to a value, + never causing a run-time error. *) + +Definition safe_unop (op: unary_operation) : bool := + match op with + | Ointoffloat | Ointuoffloat | Ofloatofint | Ofloatofintu => false + | Ointofsingle | Ointuofsingle | Osingleofint | Osingleofintu => false + | Olongoffloat | Olonguoffloat | Ofloatoflong | Ofloatoflongu => false + | Olongofsingle | Olonguofsingle | Osingleoflong | Osingleoflongu => false + | _ => true + end. + +Definition safe_binop (op: binary_operation) : bool := + match op with + | Odiv | Odivu | Omod | Omodu => false + | Odivl | Odivlu | Omodl | Omodlu => false + | Ocmpl _ | Ocmplu _ => false + | _ => true + end. + +Fixpoint safe_expr (ki: known_idents) (a: expr) : bool := + match a with + | Evar v => is_known ki v + | Econst c => true + | Eunop op e1 => safe_unop op && safe_expr ki e1 + | Ebinop op e1 e2 => safe_binop op && safe_expr ki e1 && safe_expr ki e2 + | Eload chunk e => false + end. + +(** Soundness of [known_id]. *) + +Lemma known_id_sound_1: + forall f id x, (known_id f)!id = Some x -> In id f.(fn_params) \/ In id f.(fn_vars). +Proof. + unfold known_id. + set (add := fun (ki: known_idents) (id: ident) => PTree.set id tt ki). + intros. + assert (REC: forall l ki, (fold_left add l ki)!id = Some x -> In id l \/ ki!id = Some x). + { induction l as [ | i l ]; simpl; intros. + - auto. + - apply IHl in H0. destruct H0; auto. unfold add in H0; rewrite PTree.gsspec in H0. + destruct (peq id i); auto. } + apply REC in H. destruct H; auto. apply REC in H. destruct H; auto. + rewrite PTree.gempty in H; discriminate. +Qed. + +Lemma known_id_sound_2: + forall f id, is_known (known_id f) id = true -> In id f.(fn_params) \/ In id f.(fn_vars). +Proof. + unfold is_known; intros. destruct (known_id f)!id eqn:E; try discriminate. + eapply known_id_sound_1; eauto. +Qed. + +(** Expressions that satisfy [safe_expr] always evaluate to a value. *) + +Lemma eval_safe_expr: + forall ge f sp e m a, + def_env f e -> + safe_expr (known_id f) a = true -> + exists v, eval_expr ge sp e m a v. +Proof. + induction a; simpl; intros. + - apply known_id_sound_2 in H0. + destruct (H i H0) as [v E]. + exists v; constructor; auto. + - destruct (eval_constant ge sp c) as [v|] eqn:E. + exists v; constructor; auto. + destruct c; discriminate. + - InvBooleans. destruct IHa as [v1 E1]; auto. + destruct (eval_unop u v1) as [v|] eqn:E. + exists v; econstructor; eauto. + destruct u; discriminate. + - InvBooleans. + destruct IHa1 as [v1 E1]; auto. + destruct IHa2 as [v2 E2]; auto. + destruct (eval_binop b v1 v2 m) as [v|] eqn:E. + exists v; econstructor; eauto. + destruct b; discriminate. + - discriminate. +Qed. + + diff --git a/backend/Deadcodeproof.v b/backend/Deadcodeproof.v index 199ac922..2edc0395 100644 --- a/backend/Deadcodeproof.v +++ b/backend/Deadcodeproof.v @@ -106,7 +106,7 @@ Local Transparent Mem.loadbytes. unfold Mem.loadbytes; intros. destruct H. destruct (Mem.range_perm_dec m1 b ofs (ofs + n) Cur Readable); inv H0. rewrite pred_dec_true. econstructor; split; eauto. - apply GETN. intros. rewrite nat_of_Z_max in H. + apply GETN. intros. rewrite Z_to_nat_max in H. assert (ofs <= i < ofs + n) by xomega. apply ma_memval0; auto. red; intros; eauto. @@ -966,7 +966,7 @@ Ltac UseTransfer := intros. eapply nlive_remove; eauto. unfold adst, vanalyze; rewrite AN; eapply aaddr_arg_sound_1; eauto. erewrite Mem.loadbytes_length in H1 by eauto. - rewrite nat_of_Z_eq in H1 by omega. auto. + rewrite Z2Nat.id in H1 by omega. auto. eauto. intros (tm' & A & B). econstructor; split. @@ -993,7 +993,7 @@ Ltac UseTransfer := intros (bc & A & B & C). intros. eapply nlive_contains; eauto. erewrite Mem.loadbytes_length in H0 by eauto. - rewrite nat_of_Z_eq in H0 by omega. auto. + rewrite Z2Nat.id in H0 by omega. auto. + (* annot *) destruct (transfer_builtin_args (kill_builtin_res res ne, nm) _x2) as (ne1, nm1) eqn:TR. InvSoundState. diff --git a/backend/Inliningproof.v b/backend/Inliningproof.v index 2dcb8956..181f40bf 100644 --- a/backend/Inliningproof.v +++ b/backend/Inliningproof.v @@ -755,13 +755,13 @@ Proof. assert (2 <= sz -> (2 | n)). intros. destruct (zle sz 1). omegaContradiction. destruct (zle sz 2). auto. - destruct (zle sz 4). apply Zdivides_trans with 4; auto. exists 2; auto. - apply Zdivides_trans with 8; auto. exists 4; auto. + destruct (zle sz 4). apply Z.divide_trans with 4; auto. exists 2; auto. + apply Z.divide_trans with 8; auto. exists 4; auto. assert (4 <= sz -> (4 | n)). intros. destruct (zle sz 1). omegaContradiction. destruct (zle sz 2). omegaContradiction. destruct (zle sz 4). auto. - apply Zdivides_trans with 8; auto. exists 2; auto. + apply Z.divide_trans with 8; auto. exists 2; auto. assert (8 <= sz -> (8 | n)). intros. destruct (zle sz 1). omegaContradiction. destruct (zle sz 2). omegaContradiction. @@ -1249,7 +1249,7 @@ Proof. eapply external_call_nextblock; eauto. auto. auto. -- (* return fron noninlined function *) +- (* return from noninlined function *) inv MS0. + (* normal case *) left; econstructor; split. diff --git a/backend/JsonAST.ml b/backend/JsonAST.ml index 3469bdc6..4e57106f 100644 --- a/backend/JsonAST.ml +++ b/backend/JsonAST.ml @@ -123,15 +123,15 @@ let pp_mnemonics pp mnemonic_names = let new_line pp () = pp_print_string pp "\n" in pp_print_list ~pp_sep:new_line pp_print_string pp mnemonic_names -let jdump_magic_number = "CompCertJDUMP" ^ Version.version +let jdump_magic_number = "CompCertJDUMPRelease: " ^ Version.version let pp_ast pp pp_inst ast sourcename = let get_args () = let buf = Buffer.create 100 in Buffer.add_string buf Sys.executable_name; - for i = 1 to (Array.length !Commandline.argv - 1) do + for i = 1 to (Array.length Commandline.argv - 1) do Buffer.add_string buf " "; - Buffer.add_string buf (Responsefile.gnu_quote !Commandline.argv.(i)); + Buffer.add_string buf (Responsefile.gnu_quote Commandline.argv.(i)); done; Buffer.contents buf in let dump_compile_info pp () = diff --git a/backend/Lineartyping.v b/backend/Lineartyping.v index bc9fb3ca..1fe23a9d 100644 --- a/backend/Lineartyping.v +++ b/backend/Lineartyping.v @@ -39,7 +39,7 @@ Definition slot_valid (sl: slot) (ofs: Z) (ty: typ): bool := | Outgoing => zle 0 ofs | Incoming => In_dec Loc.eq (S Incoming ofs ty) (regs_of_rpairs (loc_parameters funct.(fn_sig))) end - && Zdivide_dec (typealign ty) ofs (typealign_pos ty). + && Zdivide_dec (typealign ty) ofs. Definition slot_writable (sl: slot) : bool := match sl with diff --git a/backend/NeedDomain.v b/backend/NeedDomain.v index d431f3d8..b35c90b2 100644 --- a/backend/NeedDomain.v +++ b/backend/NeedDomain.v @@ -16,6 +16,7 @@ Require Import Coqlib. Require Import Maps. Require Import IntvSets. Require Import AST. +Require Import Zbits. Require Import Integers. Require Import Floats. Require Import Values. @@ -300,13 +301,13 @@ Proof. rewrite Int.bits_ror. replace (((i - Int.unsigned amount) mod Int.zwordsize + Int.unsigned amount) mod Int.zwordsize) with i. auto. - apply Int.eqmod_small_eq with Int.zwordsize; auto. - apply Int.eqmod_trans with ((i - Int.unsigned amount) + Int.unsigned amount). - apply Int.eqmod_refl2; omega. - eapply Int.eqmod_trans. 2: apply Int.eqmod_mod; auto. - apply Int.eqmod_add. - apply Int.eqmod_mod; auto. - apply Int.eqmod_refl. + apply eqmod_small_eq with Int.zwordsize; auto. + apply eqmod_trans with ((i - Int.unsigned amount) + Int.unsigned amount). + apply eqmod_refl2; omega. + eapply eqmod_trans. 2: apply eqmod_mod; auto. + apply eqmod_add. + apply eqmod_mod; auto. + apply eqmod_refl. apply Z_mod_lt; auto. apply Z_mod_lt; auto. Qed. @@ -324,16 +325,16 @@ Qed. Lemma eqmod_iagree: forall m x y, - Int.eqmod (two_p (Int.size m)) x y -> + eqmod (two_p (Int.size m)) x y -> iagree (Int.repr x) (Int.repr y) m. Proof. - intros. set (p := nat_of_Z (Int.size m)). + intros. set (p := Z.to_nat (Int.size m)). generalize (Int.size_range m); intros RANGE. - assert (EQ: Int.size m = Z.of_nat p). { symmetry; apply nat_of_Z_eq. omega. } + assert (EQ: Int.size m = Z.of_nat p). { symmetry; apply Z2Nat.id. omega. } rewrite EQ in H; rewrite <- two_power_nat_two_p in H. red; intros. rewrite ! Int.testbit_repr by auto. destruct (zlt i (Int.size m)). - eapply Int.same_bits_eqmod; eauto. omega. + eapply same_bits_eqmod; eauto. omega. assert (Int.testbit m i = false) by (eapply Int.bits_size_2; omega). congruence. Qed. @@ -343,13 +344,13 @@ Definition complete_mask (m: int) := Int.zero_ext (Int.size m) Int.mone. Lemma iagree_eqmod: forall x y m, iagree x y (complete_mask m) -> - Int.eqmod (two_p (Int.size m)) (Int.unsigned x) (Int.unsigned y). + eqmod (two_p (Int.size m)) (Int.unsigned x) (Int.unsigned y). Proof. - intros. set (p := nat_of_Z (Int.size m)). + intros. set (p := Z.to_nat (Int.size m)). generalize (Int.size_range m); intros RANGE. - assert (EQ: Int.size m = Z.of_nat p). { symmetry; apply nat_of_Z_eq. omega. } + assert (EQ: Int.size m = Z.of_nat p). { symmetry; apply Z2Nat.id. omega. } rewrite EQ; rewrite <- two_power_nat_two_p. - apply Int.eqmod_same_bits. intros. apply H. omega. + apply eqmod_same_bits. intros. apply H. omega. unfold complete_mask. rewrite Int.bits_zero_ext by omega. rewrite zlt_true by omega. rewrite Int.bits_mone by omega. auto. Qed. @@ -362,7 +363,7 @@ Proof. + assert (Int.unsigned m <> 0). { red; intros; elim n. rewrite <- (Int.repr_unsigned m). rewrite H; auto. } assert (0 < Int.size m). - { apply Int.Zsize_pos'. generalize (Int.unsigned_range m); omega. } + { apply Zsize_pos'. generalize (Int.unsigned_range m); omega. } generalize (Int.size_range m); intros. f_equal. apply Int.bits_size_4. tauto. rewrite Int.bits_zero_ext by omega. rewrite zlt_true by omega. @@ -610,7 +611,7 @@ Proof. unfold modarith; intros. destruct x; simpl in *. - auto. - unfold Val.add; InvAgree. - apply eqmod_iagree. apply Int.eqmod_add; apply iagree_eqmod; auto. + apply eqmod_iagree. apply eqmod_add; apply iagree_eqmod; auto. - inv H; auto. inv H0; auto. destruct w1; auto. Qed. @@ -626,7 +627,7 @@ Lemma mul_sound: Proof. unfold mul, add; intros. destruct x; simpl in *. - auto. -- unfold Val.mul; InvAgree. apply eqmod_iagree. apply Int.eqmod_mult; apply iagree_eqmod; auto. +- unfold Val.mul; InvAgree. apply eqmod_iagree. apply eqmod_mult; apply iagree_eqmod; auto. - inv H; auto. inv H0; auto. destruct w1; auto. Qed. @@ -638,7 +639,7 @@ Proof. intros; destruct x; simpl in *. - auto. - unfold Val.neg; InvAgree. - apply eqmod_iagree. apply Int.eqmod_neg. apply iagree_eqmod; auto. + apply eqmod_iagree. apply eqmod_neg. apply iagree_eqmod; auto. - inv H; simpl; auto. Qed. @@ -785,6 +786,34 @@ Proof. inv H0. rewrite iagree_and_eq in H. rewrite H. auto. Qed. +(** The needs of a select *) + +Lemma normalize_sound: + forall v w x ty, + vagree v w x -> + vagree (Val.normalize v ty) (Val.normalize w ty) x. +Proof. + intros. destruct x; simpl in *. +- auto. +- unfold Val.normalize. destruct v. + auto. + destruct w; try contradiction. destruct ty; auto. + destruct ty; auto. + destruct ty; auto. + destruct ty; auto. + destruct ty; destruct Archi.ptr64; auto. +- apply Val.normalize_lessdef; auto. +Qed. + +Lemma select_sound: + forall ob v1 v2 w1 w2 ty x, + vagree v1 w1 x -> vagree v2 w2 x -> + vagree (Val.select ob v1 v2 ty) (Val.select ob w1 w2 ty) x. +Proof. + unfold Val.select; intros. destruct ob as [b|]; auto with na. + apply normalize_sound. destruct b; auto. +Qed. + (** The default abstraction: if the result is unused, the arguments are unused; otherwise, the arguments are needed in full. *) diff --git a/backend/PrintAsm.ml b/backend/PrintAsm.ml index 92d465d5..dd428808 100644 --- a/backend/PrintAsm.ml +++ b/backend/PrintAsm.ml @@ -40,6 +40,7 @@ module Printer(Target:TARGET) = let print_function oc name fn = Hashtbl.clear current_function_labels; + Debug.symbol_printed (extern_atom name); let (text, lit, jmptbl) = Target.get_section_names name in Target.section oc text; let alignment = @@ -117,7 +118,7 @@ module Printer(Target:TARGET) = match v.gvar_init with | [] -> () | _ -> - Debug.variable_printed (extern_atom name); + Debug.symbol_printed (extern_atom name); let sec = match C2C.atom_sections name with | [s] -> s diff --git a/backend/PrintAsmaux.ml b/backend/PrintAsmaux.ml index f9ed569f..7e075f04 100644 --- a/backend/PrintAsmaux.ml +++ b/backend/PrintAsmaux.ml @@ -289,12 +289,20 @@ let print_inline_asm print_preg oc txt sg args res = let print_version_and_options oc comment = let version_string = if Version.buildnr <> "" && Version.tag <> "" then - sprintf "%s, Build: %s, Tag: %s" Version.version Version.buildnr Version.tag + sprintf "Release: %s, Build: %s, Tag: %s" Version.version Version.buildnr Version.tag else Version.version in fprintf oc "%s File generated by CompCert %s\n" comment version_string; fprintf oc "%s Command line:" comment; - for i = 1 to Array.length Sys.argv - 1 do - fprintf oc " %s" Sys.argv.(i) + for i = 1 to Array.length Commandline.argv - 1 do + fprintf oc " %s" Commandline.argv.(i) done; fprintf oc "\n" +(** Get the name of the common section if it is used otherwise the given section + name, with bss as default *) + +let common_section ?(sec = ".bss") () = + if !Clflags.option_fcommon then + "COMM" + else + sec diff --git a/backend/RTL.v b/backend/RTL.v index 16723d96..9599a24a 100644 --- a/backend/RTL.v +++ b/backend/RTL.v @@ -73,7 +73,7 @@ Inductive instruction: Type := it transitions to [ifnot]. *) | Ijumptable: reg -> list node -> instruction (** [Ijumptable arg tbl] transitions to the node that is the [n]-th - element of the list [tbl], where [n] is the signed integer + element of the list [tbl], where [n] is the unsigned integer value of register [arg]. *) | Ireturn: option reg -> instruction. (** [Ireturn] terminates the execution of the current function diff --git a/backend/RTLgenproof.v b/backend/RTLgenproof.v index b003eb10..b94ec22f 100644 --- a/backend/RTLgenproof.v +++ b/backend/RTLgenproof.v @@ -704,7 +704,7 @@ Proof. intros; red; intros. inv TE. exploit H0; eauto. intros [rs1 [tm1 [EX1 [ME1 [RR1 [RO1 EXT1]]]]]]. exploit external_call_mem_extends; eauto. - intros [v' [tm2 [A [B [C [D E]]]]]]. + intros [v' [tm2 [A [B [C D]]]]]. exists (rs1#rd <- v'); exists tm2. (* Exec *) split. eapply star_right. eexact EX1. @@ -736,7 +736,7 @@ Proof. intros; red; intros. inv TE. exploit H3; eauto. intros [rs1 [tm1 [EX1 [ME1 [RR1 [RO1 EXT1]]]]]]. exploit external_call_mem_extends; eauto. - intros [v' [tm2 [A [B [C [D E]]]]]]. + intros [v' [tm2 [A [B [C D]]]]]. exploit function_ptr_translated; eauto. simpl. intros [tf [P Q]]. inv Q. exists (rs1#rd <- v'); exists tm2. (* Exec *) diff --git a/backend/SelectDivproof.v b/backend/SelectDivproof.v index e2249ddb..a8ee8453 100644 --- a/backend/SelectDivproof.v +++ b/backend/SelectDivproof.v @@ -12,7 +12,7 @@ (** Correctness of instruction selection for integer division *) -Require Import Zquot Coqlib. +Require Import Zquot Coqlib Zbits. Require Import AST Integers Floats Values Memory Globalenvs Events. Require Import Cminor Op CminorSel. Require Import OpHelpers OpHelpersproof. @@ -58,13 +58,13 @@ Proof. apply Z.mul_nonneg_nonneg; omega. assert (k * n <= two_p (N + l) - two_p l). apply Z.le_trans with (two_p l * n). - apply Zmult_le_compat_r. omega. omega. + apply Z.mul_le_mono_nonneg_r; omega. replace (N + l) with (l + N) by omega. rewrite two_p_is_exp. replace (two_p l * two_p N - two_p l) with (two_p l * (two_p N - 1)) by ring. - apply Zmult_le_compat_l. omega. exploit (two_p_gt_ZERO l). omega. omega. + apply Z.mul_le_mono_nonneg_l. omega. exploit (two_p_gt_ZERO l). omega. omega. omega. omega. assert (0 <= two_p (N + l) * r). apply Z.mul_nonneg_nonneg. @@ -73,7 +73,7 @@ Proof. assert (two_p (N + l) * r <= two_p (N + l) * d - two_p (N + l)). replace (two_p (N + l) * d - two_p (N + l)) with (two_p (N + l) * (d - 1)) by ring. - apply Zmult_le_compat_l. + apply Z.mul_le_mono_nonneg_l. omega. exploit (two_p_gt_ZERO (N + l)). omega. omega. assert (0 <= m * n - two_p (N + l) * q). @@ -139,13 +139,13 @@ Proof. rewrite H2. assert (k * n <= two_p (N + l)). rewrite Z.add_comm. rewrite two_p_is_exp; try omega. - apply Z.le_trans with (two_p l * n). apply Zmult_le_compat_r. omega. omega. - apply Zmult_le_compat_l. omega. exploit (two_p_gt_ZERO l). omega. omega. + apply Z.le_trans with (two_p l * n). apply Z.mul_le_mono_nonneg_r; omega. + apply Z.mul_le_mono_nonneg_l. omega. exploit (two_p_gt_ZERO l). omega. omega. assert (two_p (N + l) * r <= two_p (N + l) * d - two_p (N + l)). replace (two_p (N + l) * d - two_p (N + l)) with (two_p (N + l) * (d - 1)) by ring. - apply Zmult_le_compat_l. omega. exploit (two_p_gt_ZERO (N + l)). omega. omega. + apply Z.mul_le_mono_nonneg_l. exploit (two_p_gt_ZERO (N + l)). omega. omega. omega. omega. Qed. @@ -247,10 +247,11 @@ Proof. unfold Int.max_signed; omega. apply Zdiv_interval_1. generalize Int.min_signed_neg; omega. apply Int.half_modulus_pos. apply Int.modulus_pos. - split. apply Z.le_trans with (Int.min_signed * m). apply Zmult_le_compat_l_neg. omega. generalize Int.min_signed_neg; omega. - apply Zmult_le_compat_r. unfold n; generalize (Int.signed_range x); tauto. tauto. + split. apply Z.le_trans with (Int.min_signed * m). + apply Z.mul_le_mono_nonpos_l. generalize Int.min_signed_neg; omega. omega. + apply Z.mul_le_mono_nonneg_r. omega. unfold n; generalize (Int.signed_range x); tauto. apply Z.le_lt_trans with (Int.half_modulus * m). - apply Zmult_le_compat_r. generalize (Int.signed_range x); unfold n, Int.max_signed; omega. tauto. + apply Z.mul_le_mono_nonneg_r. tauto. generalize (Int.signed_range x); unfold n, Int.max_signed; omega. apply Zmult_lt_compat_l. generalize Int.half_modulus_pos; omega. tauto. assert (32 < Int.max_unsigned) by (compute; auto). omega. unfold Int.lt; fold n. rewrite Int.signed_zero. destruct (zlt n 0); apply Int.eqm_unsigned_repr. @@ -291,7 +292,7 @@ Proof. apply Int.eqm_sym. eapply Int.eqm_trans. apply Int.eqm_signed_unsigned. apply Int.eqm_unsigned_repr_l. apply Int.eqm_refl2. apply (f_equal (fun x => n * x / Int.modulus)). - rewrite Int.signed_repr_eq. rewrite Zmod_small by assumption. + rewrite Int.signed_repr_eq. rewrite Z.mod_small by assumption. apply zlt_false. assumption. Qed. @@ -378,7 +379,7 @@ Qed. Remark int64_shr'_div_two_p: forall x y, Int64.shr' x y = Int64.repr (Int64.signed x / two_p (Int.unsigned y)). Proof. - intros; unfold Int64.shr'. rewrite Int64.Zshiftr_div_two_p; auto. generalize (Int.unsigned_range y); omega. + intros; unfold Int64.shr'. rewrite Zshiftr_div_two_p; auto. generalize (Int.unsigned_range y); omega. Qed. Lemma divls_mul_shift_gen: @@ -401,8 +402,9 @@ Proof. unfold Int64.max_signed; omega. apply Zdiv_interval_1. generalize Int64.min_signed_neg; omega. apply Int64.half_modulus_pos. apply Int64.modulus_pos. - split. apply Z.le_trans with (Int64.min_signed * m). apply Zmult_le_compat_l_neg. omega. generalize Int64.min_signed_neg; omega. - apply Zmult_le_compat_r. unfold n; generalize (Int64.signed_range x); tauto. tauto. + split. apply Z.le_trans with (Int64.min_signed * m). + apply Z.mul_le_mono_nonpos_l. generalize Int64.min_signed_neg; omega. omega. + apply Z.mul_le_mono_nonneg_r. tauto. unfold n; generalize (Int64.signed_range x); tauto. apply Z.le_lt_trans with (Int64.half_modulus * m). apply Zmult_le_compat_r. generalize (Int64.signed_range x); unfold n, Int64.max_signed; omega. tauto. apply Zmult_lt_compat_l. generalize Int64.half_modulus_pos; omega. tauto. @@ -445,14 +447,14 @@ Proof. apply Int64.eqm_sym. eapply Int64.eqm_trans. apply Int64.eqm_signed_unsigned. apply Int64.eqm_unsigned_repr_l. apply Int64.eqm_refl2. apply (f_equal (fun x => n * x / Int64.modulus)). - rewrite Int64.signed_repr_eq. rewrite Zmod_small by assumption. + rewrite Int64.signed_repr_eq. rewrite Z.mod_small by assumption. apply zlt_false. assumption. Qed. Remark int64_shru'_div_two_p: forall x y, Int64.shru' x y = Int64.repr (Int64.unsigned x / two_p (Int.unsigned y)). Proof. - intros; unfold Int64.shru'. rewrite Int64.Zshiftr_div_two_p; auto. generalize (Int.unsigned_range y); omega. + intros; unfold Int64.shru'. rewrite Zshiftr_div_two_p; auto. generalize (Int.unsigned_range y); omega. Qed. Theorem divlu_mul_shift: diff --git a/backend/Selection.v b/backend/Selection.v index 3b0948a8..37a78853 100644 --- a/backend/Selection.v +++ b/backend/Selection.v @@ -26,7 +26,7 @@ Require String. Require Import Coqlib Maps. Require Import AST Errors Integers Globalenvs Switch. Require Cminor. -Require Import Op CminorSel OpHelpers. +Require Import Op CminorSel OpHelpers Cminortyping. Require Import SelectOp SplitLong SelectLong SelectDiv. Require Machregs. @@ -43,6 +43,12 @@ Function condexpr_of_expr (e: expr) : condexpr := | _ => CEcond (Ccompuimm Cne Int.zero) (e ::: Enil) end. +Function condition_of_expr (e: expr) : condition * exprlist := + match e with + | Eop (Ocmp c) el => (c, el) + | _ => (Ccompuimm Cne Int.zero, e ::: Enil) + end. + (** Conversion of loads and stores *) Definition load (chunk: memory_chunk) (e1: expr) := @@ -173,6 +179,10 @@ Fixpoint sel_exprlist (al: list Cminor.expr) : exprlist := | a :: bl => Econs (sel_expr a) (sel_exprlist bl) end. +Definition sel_select_opt (ty: typ) (arg1 arg2 arg3: Cminor.expr) : option expr := + let (cond, args) := condition_of_expr (sel_expr arg1) in + SelectOp.select ty cond args (sel_expr arg2) (sel_expr arg3). + (** Recognition of immediate calls and calls to built-in functions that should be inlined *) @@ -267,7 +277,6 @@ Definition sel_switch_long := (fun arg ofs => subl arg (longconst (Int64.repr ofs))) lowlong. - Definition sel_builtin_default optid ef args := OK (Sbuiltin (sel_builtin_res optid) ef (sel_builtin_args args @@ -328,11 +337,64 @@ Definition sel_builtin optid ef args := else sel_builtin_default optid ef args) | _ => sel_builtin_default optid ef args + +(** "If conversion": conversion of certain if-then-else statements + into branchless conditional move instructions. *) + +(** Recognition of "then" and "else" statements that support if-conversion. + Basically we are interested in assignments to local variables [id = e]. + However the front-end may have put [skip] statements around these + assignments. *) + +Inductive stmt_class : Type := + | SCskip + | SCassign (id: ident) (a: Cminor.expr) + | SCother. + +Function classify_stmt (s: Cminor.stmt) : stmt_class := + match s with + | Cminor.Sskip => SCskip + | Cminor.Sassign id a => SCassign id a + | Cminor.Sseq Cminor.Sskip s => classify_stmt s + | Cminor.Sseq s Cminor.Sskip => classify_stmt s + | _ => SCother + end. + +(** External heuristic to limit the amount of if-conversion performed. + Arguments are: the condition, the "then" and the "else" expressions, + and the type at which selection is done. *) + +Parameter if_conversion_heuristic: + Cminor.expr -> Cminor.expr -> Cminor.expr -> AST.typ -> bool. + +Definition if_conversion_base + (ki: known_idents) (env: typenv) + (cond: Cminor.expr) (id: ident) (ifso ifnot: Cminor.expr) : option stmt := + let ty := env id in + if is_known ki id + && safe_expr ki ifso && safe_expr ki ifnot + && if_conversion_heuristic cond ifso ifnot ty + then option_map + (fun sel => Sassign id sel) + (sel_select_opt ty cond ifso ifnot) + else None. + +Definition if_conversion + (ki: known_idents) (env: typenv) + (cond: Cminor.expr) (ifso ifnot: Cminor.stmt) : option stmt := + match classify_stmt ifso, classify_stmt ifnot with + | SCskip, SCassign id a => + if_conversion_base ki env cond id (Cminor.Evar id) a + | SCassign id a, SCskip => + if_conversion_base ki env cond id a (Cminor.Evar id) + | SCassign id1 a1, SCassign id2 a2 => + if ident_eq id1 id2 then if_conversion_base ki env cond id1 a1 a2 else None + | _, _ => None end. (** Conversion from Cminor statements to Cminorsel statements. *) -Fixpoint sel_stmt (s: Cminor.stmt) : res stmt := +Fixpoint sel_stmt (ki: known_idents) (env: typenv) (s: Cminor.stmt) : res stmt := match s with | Cminor.Sskip => OK Sskip | Cminor.Sassign id e => OK (Sassign id (sel_expr e)) @@ -357,15 +419,19 @@ Fixpoint sel_stmt (s: Cminor.stmt) : res stmt := | _ => Stailcall sg (inl _ (sel_expr fn)) (sel_exprlist args) end) | Cminor.Sseq s1 s2 => - do s1' <- sel_stmt s1; do s2' <- sel_stmt s2; + do s1' <- sel_stmt ki env s1; do s2' <- sel_stmt ki env s2; OK (Sseq s1' s2') | Cminor.Sifthenelse e ifso ifnot => - do ifso' <- sel_stmt ifso; do ifnot' <- sel_stmt ifnot; - OK (Sifthenelse (condexpr_of_expr (sel_expr e)) ifso' ifnot') + match if_conversion ki env e ifso ifnot with + | Some s => OK s + | None => + do ifso' <- sel_stmt ki env ifso; do ifnot' <- sel_stmt ki env ifnot; + OK (Sifthenelse (condexpr_of_expr (sel_expr e)) ifso' ifnot') + end | Cminor.Sloop body => - do body' <- sel_stmt body; OK (Sloop body') + do body' <- sel_stmt ki env body; OK (Sloop body') | Cminor.Sblock body => - do body' <- sel_stmt body; OK (Sblock body') + do body' <- sel_stmt ki env body; OK (Sblock body') | Cminor.Sexit n => OK (Sexit n) | Cminor.Sswitch false e cases dfl => let t := compile_switch Int.modulus dfl cases in @@ -380,7 +446,7 @@ Fixpoint sel_stmt (s: Cminor.stmt) : res stmt := | Cminor.Sreturn None => OK (Sreturn None) | Cminor.Sreturn (Some e) => OK (Sreturn (Some (sel_expr e))) | Cminor.Slabel lbl body => - do body' <- sel_stmt body; OK (Slabel lbl body') + do body' <- sel_stmt ki env body; OK (Slabel lbl body') | Cminor.Sgoto lbl => OK (Sgoto lbl) end. @@ -388,8 +454,15 @@ End SELECTION. (** Conversion of functions. *) +Definition known_id (f: Cminor.function) : known_idents := + let add (ki: known_idents) (id: ident) := PTree.set id tt ki in + List.fold_left add f.(Cminor.fn_vars) + (List.fold_left add f.(Cminor.fn_params) (PTree.empty unit)). + Definition sel_function (dm: PTree.t globdef) (hf: helper_functions) (f: Cminor.function) : res function := - do body' <- sel_stmt dm f.(Cminor.fn_body); + let ki := known_id f in + do env <- Cminortyping.type_function f; + do body' <- sel_stmt dm ki env f.(Cminor.fn_body); OK (mkfunction f.(Cminor.fn_sig) f.(Cminor.fn_params) diff --git a/backend/Selectionaux.ml b/backend/Selectionaux.ml new file mode 100644 index 00000000..52ddd799 --- /dev/null +++ b/backend/Selectionaux.ml @@ -0,0 +1,109 @@ +(* *********************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Xavier Leroy, Collège de France and Inria Paris *) +(* *) +(* Copyright Institut National de Recherche en Informatique et en *) +(* Automatique. All rights reserved. This file is distributed *) +(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* *) +(* *********************************************************************) + +open AST +open Cminor + +(* Heuristics to guide if conversion *) + +(* Estimate a cost for evaluating a safe expression. + Unsafe operators need not be estimated. + Basic integer operations (add, and, ...) have cost 1 by convention. + The other costs are rough estimates. *) + +let cost_unop = function + | Ocast8unsigned | Ocast8signed + | Ocast16unsigned | Ocast16signed + | Onegint | Onotint -> 1 + | Onegf | Oabsf -> 1 + | Onegfs | Oabsfs -> 1 + | Osingleoffloat | Ofloatofsingle -> 2 + | Ointoffloat | Ointuoffloat + | Ofloatofint | Ofloatofintu + | Ointofsingle | Ointuofsingle + | Osingleofint | Osingleofintu -> assert false + | Onegl | Onotl -> if Archi.splitlong then 2 else 1 + | Ointoflong | Olongofint | Olongofintu -> 1 + | Olongoffloat | Olonguoffloat + | Ofloatoflong | Ofloatoflongu + | Olongofsingle | Olonguofsingle + | Osingleoflong | Osingleoflongu -> assert false + +let cost_binop = function + | Oadd | Osub -> 1 + | Omul -> 2 + | Odiv | Odivu | Omod | Omodu -> assert false + | Oand | Oor | Oxor | Oshl | Oshr | Oshru -> 1 + | Oaddf | Osubf | Omulf -> 2 + | Odivf -> 10 + | Oaddfs| Osubfs| Omulfs -> 2 + | Odivfs -> 10 + | Oaddl | Osubl -> if Archi.splitlong then 3 else 1 + | Omull -> if Archi.splitlong then 6 else 2 + | Odivl | Odivlu | Omodl | Omodlu -> assert false + | Oandl | Oorl | Oxorl -> if Archi.splitlong then 2 else 1 + | Oshll | Oshrl | Oshrlu -> if Archi.splitlong then 4 else 1 + | Ocmp _ | Ocmpu _ -> 2 + | Ocmpf _ | Ocmpfs _ -> 2 + | Ocmpl _ | Ocmplu _ -> assert false + +let rec cost_expr = function + | Evar _ -> 0 + | Econst _ -> 1 + | Eunop(op, e1) -> cost_unop op + cost_expr e1 + | Ebinop(op, e1, e2) -> cost_binop op + cost_expr e1 + cost_expr e2 + | Eload(_, e1) -> assert false + +(* Does the target architecture support an efficient "conditional move" + at the given type? *) + +let fast_cmove ty = + match Configuration.arch, Configuration.model with + | "arm", _ -> + (match ty with Tint | Tfloat | Tsingle -> true | _ -> false) + | "powerpc", "e5500" -> + (match ty with Tint | Tlong -> true | _ -> false) + | "powerpc", _ -> false + | "riscV", _ -> false + | "x86", _ -> + (match ty with Tint -> true | Tlong -> Archi.ptr64 | _ -> false) + | _, _ -> + assert false + +(* The if-conversion heuristic depend on the + -fif-conversion and -ffavor-branchless flags. + +With [-fno-if-conversion] or [-0O], if-conversion is turned off entirely. +With [-ffavor-branchless], if-conversion is performed whenever semantically +correct, regardless of how much it could cost. +Otherwise (and by default), optimization is performed when it seems beneficial. + +If-conversion seems beneficial if: +- the target architecture supports an efficient "conditional move" instruction + (not an emulation that takes several instructions) +- the total cost the "then" and "else" branches is not too high +- the cost difference between the "then" and "else" branches is low enough. + +Intuition: on a modern processor, the "then" and the "else" branches +can generally be computed in parallel, there is enough ILP for that. +So, the bad case is if the most taken branch is much cheaper than the +other branch. Since our cost estimates are very imprecise, the +bound on the total cost acts as a safety guard, +*) + +let if_conversion_heuristic cond ifso ifnot ty = + if not !Clflags.option_fifconversion then false else + if !Clflags.option_ffavor_branchless then true else + if not (fast_cmove ty) then false else + let c1 = cost_expr ifso and c2 = cost_expr ifnot in + c1 + c2 <= 30 && abs (c1 - c2) <= 8 + diff --git a/backend/Selectionproof.v b/backend/Selectionproof.v index 23d10382..40db5d4b 100644 --- a/backend/Selectionproof.v +++ b/backend/Selectionproof.v @@ -15,7 +15,7 @@ Require Import FunInd. Require Import Coqlib Maps. Require Import AST Linking Errors Integers Values Memory Events Globalenvs Smallstep. -Require Import Switch Cminor Op CminorSel. +Require Import Switch Cminor Op CminorSel Cminortyping. Require Import OpHelpers OpHelpersproof. Require Import SelectOp SelectDiv SplitLong SelectLong Selection. Require Import SelectOpproof SelectDivproof SplitLongproof SelectLongproof. @@ -120,6 +120,16 @@ Let ge := Genv.globalenv prog. Let tge := Genv.globalenv tprog. Hypothesis TRANSF: match_prog prog tprog. +Lemma wt_prog : wt_program prog. +Proof. + red; intros. destruct TRANSF as [A _]. + exploit list_forall2_in_left; eauto. + intros ((i' & gd') & B & (C & D)). simpl in *. inv D. + destruct H2 as (hf & P & Q). destruct f; monadInv Q. +- monadInv EQ. econstructor; apply type_function_sound; eauto. +- constructor. +Qed. + Lemma symbols_preserved: forall (s: ident), Genv.find_symbol tge s = Genv.find_symbol ge s. Proof (Genv.find_symbol_match TRANSF). @@ -203,6 +213,25 @@ Proof. simpl. inv H0. auto. Qed. +Lemma eval_condition_of_expr: + forall a le v b, + eval_expr tge sp e m le a v -> + Val.bool_of_val v b -> + let (cond, al) := condition_of_expr a in + exists vl, + eval_exprlist tge sp e m le al vl + /\ eval_condition cond vl m = Some b. +Proof. + intros until a. functional induction (condition_of_expr a); intros. +(* compare *) + inv H. simpl in H6. inv H6. apply Val.bool_of_val_of_optbool in H0. + exists vl; auto. +(* default *) + exists (v :: nil); split. + econstructor. auto. constructor. + simpl. inv H0. auto. +Qed. + Lemma eval_load: forall le a v chunk v', eval_expr tge sp e m le a v -> @@ -461,7 +490,7 @@ Qed. End SEL_SWITCH. -Section SEL_SWITH_INT. +Section SEL_SWITCH_INT. Variable cunit: Cminor.program. Variable hf: helper_functions. @@ -507,7 +536,7 @@ Proof. unfold Int.sub. rewrite Int.unsigned_repr_eq. f_equal. f_equal. apply Int.unsigned_repr. unfold Int.max_unsigned; omega. - intros until i0; intros EVAL R. exists v; split; auto. - inv R. rewrite Zmod_small by (apply Int.unsigned_range). constructor. + inv R. rewrite Z.mod_small by (apply Int.unsigned_range). constructor. - constructor. - apply Int.unsigned_range. Qed. @@ -548,7 +577,7 @@ Proof. - apply Int64.unsigned_range. Qed. -End SEL_SWITH_INT. +End SEL_SWITCH_INT. (** Compatibility of evaluation functions with the "less defined than" relation. *) @@ -699,6 +728,29 @@ Proof. exists (v1' :: vl'); split; auto. constructor; eauto. Qed. +Lemma sel_select_opt_correct: + forall ty cond a1 a2 a sp e m vcond v1 v2 b e' m' le, + sel_select_opt ty cond a1 a2 = Some a -> + Cminor.eval_expr ge sp e m cond vcond -> + Cminor.eval_expr ge sp e m a1 v1 -> + Cminor.eval_expr ge sp e m a2 v2 -> + Val.bool_of_val vcond b -> + env_lessdef e e' -> Mem.extends m m' -> + exists v', eval_expr tge sp e' m' le a v' /\ Val.lessdef (Val.select (Some b) v1 v2 ty) v'. +Proof. + unfold sel_select_opt; intros. + destruct (condition_of_expr (sel_expr cond)) as [cnd args] eqn:C. + exploit sel_expr_correct. eexact H0. eauto. eauto. intros (vcond' & EVC & LDC). + exploit sel_expr_correct. eexact H1. eauto. eauto. intros (v1' & EV1 & LD1). + exploit sel_expr_correct. eexact H2. eauto. eauto. intros (v2' & EV2 & LD2). + assert (Val.bool_of_val vcond' b) by (inv H3; inv LDC; constructor). + exploit eval_condition_of_expr. eexact EVC. eauto. rewrite C. intros (vargs' & EVARGS & EVCOND). + exploit eval_select; eauto. intros (v' & X & Y). + exists v'; split; eauto. + eapply Val.lessdef_trans; [|eexact Y]. + apply Val.select_lessdef; auto. +Qed. + Lemma sel_builtin_arg_correct: forall sp e e' m m' a v c, env_lessdef e e' -> Mem.extends m m' -> @@ -742,37 +794,174 @@ Proof. intros. destruct oid; simpl; auto. apply set_var_lessdef; auto. Qed. +(** If-conversion *) + +Lemma classify_stmt_sound_1: + forall f sp e m s k, + classify_stmt s = SCskip -> + star Cminor.step ge (Cminor.State f s k sp e m) E0 (Cminor.State f Cminor.Sskip k sp e m). +Proof. + intros until s; functional induction (classify_stmt s); intros; try discriminate. + - apply star_refl. + - eapply star_trans; eauto. eapply star_two. constructor. constructor. + traceEq. traceEq. + - eapply star_left. constructor. + eapply star_right. eauto. constructor. + traceEq. traceEq. +Qed. + +Lemma classify_stmt_sound_2: + forall f sp e m a id v, + Cminor.eval_expr ge sp e m a v -> + forall s k, + classify_stmt s = SCassign id a -> + star Cminor.step ge (Cminor.State f s k sp e m) E0 (Cminor.State f Cminor.Sskip k sp (PTree.set id v e) m). +Proof. + intros until s; functional induction (classify_stmt s); intros; try discriminate. + - inv H0. apply star_one. constructor; auto. + - eapply star_trans; eauto. eapply star_two. constructor. constructor. + traceEq. traceEq. + - eapply star_left. constructor. + eapply star_right. eauto. constructor. + traceEq. traceEq. +Qed. + +Lemma classify_stmt_wt: + forall env tyret id a s, + classify_stmt s = SCassign id a -> + wt_stmt env tyret s -> + wt_expr env a (env id). +Proof. + intros until s; functional induction (classify_stmt s); intros CL WT; + try discriminate. +- inv CL; inv WT; auto. +- inv WT; eauto. +- inv WT; eauto. +Qed. + +Lemma eval_select_safe_exprs: + forall a1 a2 f env ty e e' m m' sp cond vb b id s, + safe_expr (known_id f) a1 = true -> + safe_expr (known_id f) a2 = true -> + option_map (fun sel => Sassign id sel) (sel_select_opt ty cond a1 a2) = Some s -> + Cminor.eval_expr ge sp e m cond vb -> Val.bool_of_val vb b -> + wt_expr env a1 ty -> + wt_expr env a2 ty -> + def_env f e -> wt_env env e -> + Cminor.eval_expr ge sp e m cond vb -> Val.bool_of_val vb b -> + env_lessdef e e' -> Mem.extends m m' -> + exists a' v1 v2 v', + s = Sassign id a' + /\ Cminor.eval_expr ge sp e m a1 v1 + /\ Cminor.eval_expr ge sp e m a2 v2 + /\ eval_expr tge sp e' m' nil a' v' + /\ Val.lessdef (if b then v1 else v2) v'. +Proof. + intros. + destruct (sel_select_opt ty cond a1 a2) as [a'|] eqn:SSO; simpl in H1; inv H1. + destruct (eval_safe_expr ge f sp e m a1) as (v1 & EV1); auto. + destruct (eval_safe_expr ge f sp e m a2) as (v2 & EV2); auto. + assert (TY1: Val.has_type v1 ty) by (eapply wt_eval_expr; eauto). + assert (TY2: Val.has_type v2 ty) by (eapply wt_eval_expr; eauto). + exploit sel_select_opt_correct; eauto. intros (v' & EV' & LD). + exists a', v1, v2, v'; intuition eauto. + apply Val.lessdef_trans with (Val.select (Some b) v1 v2 ty). + simpl. rewrite Val.normalize_idem; auto. destruct b; auto. + assumption. +Qed. + +Lemma if_conversion_correct: + forall f env tyret cond ifso ifnot s vb b k f' k' sp e m e' m', + if_conversion (known_id f) env cond ifso ifnot = Some s -> + def_env f e -> wt_env env e -> + wt_stmt env tyret ifso -> + wt_stmt env tyret ifnot -> + Cminor.eval_expr ge sp e m cond vb -> Val.bool_of_val vb b -> + env_lessdef e e' -> Mem.extends m m' -> + let s0 := if b then ifso else ifnot in + exists e1 e1', + step tge (State f' s k' sp e' m') E0 (State f' Sskip k' sp e1' m') + /\ star Cminor.step ge (Cminor.State f s0 k sp e m) E0 (Cminor.State f Cminor.Sskip k sp e1 m) + /\ env_lessdef e1 e1'. +Proof. + unfold if_conversion; intros until m'; intros IFC DE WTE WT1 WT2 EVC BOV ELD MEXT. + set (s0 := if b then ifso else ifnot). set (ki := known_id f) in *. + destruct (classify_stmt ifso) eqn:IFSO; try discriminate; + destruct (classify_stmt ifnot) eqn:IFNOT; try discriminate; + unfold if_conversion_base in IFC. +- destruct (is_known ki id && safe_expr ki (Cminor.Evar id) && safe_expr ki a + && if_conversion_heuristic cond (Cminor.Evar id) a (env id)) eqn:B; inv IFC. + InvBooleans. + exploit (eval_select_safe_exprs (Cminor.Evar id) a); eauto. + constructor. eapply classify_stmt_wt; eauto. + intros (a' & v1 & v2 & v' & A & B & C & D & E). + exists (PTree.set id (if b then v1 else v2) e), (PTree.set id v' e'). + split. subst s. constructor; auto. + split. unfold s0; destruct b. + rewrite PTree.gsident by (inv B; auto). apply classify_stmt_sound_1; auto. + eapply classify_stmt_sound_2; eauto. + apply set_var_lessdef; auto. +- destruct (is_known ki id && safe_expr ki a && safe_expr ki (Cminor.Evar id) + && if_conversion_heuristic cond a (Cminor.Evar id) (env id)) eqn:B; inv IFC. + InvBooleans. + exploit (eval_select_safe_exprs a (Cminor.Evar id)); eauto. + eapply classify_stmt_wt; eauto. constructor. + intros (a' & v1 & v2 & v' & A & B & C & D & E). + exists (PTree.set id (if b then v1 else v2) e), (PTree.set id v' e'). + split. subst s. constructor; auto. + split. unfold s0; destruct b. + eapply classify_stmt_sound_2; eauto. + rewrite PTree.gsident by (inv C; auto). apply classify_stmt_sound_1; auto. + apply set_var_lessdef; auto. +- destruct (ident_eq id id0); try discriminate. subst id0. + destruct (is_known ki id && safe_expr ki a && safe_expr ki a0 + && if_conversion_heuristic cond a a0 (env id)) eqn:B; inv IFC. + InvBooleans. + exploit (eval_select_safe_exprs a a0); eauto. + eapply classify_stmt_wt; eauto. eapply classify_stmt_wt; eauto. + intros (a' & v1 & v2 & v' & A & B & C & D & E). + exists (PTree.set id (if b then v1 else v2) e), (PTree.set id v' e'). + split. subst s. constructor; auto. + split. unfold s0; destruct b; eapply classify_stmt_sound_2; eauto. + apply set_var_lessdef; auto. +Qed. + End EXPRESSIONS. (** Semantic preservation for functions and statements. *) -Inductive match_cont: Cminor.program -> helper_functions -> Cminor.cont -> CminorSel.cont -> Prop := - | match_cont_stop: forall cunit hf, - match_cont cunit hf Cminor.Kstop Kstop - | match_cont_seq: forall cunit hf s s' k k', - sel_stmt (prog_defmap cunit) s = OK s' -> - match_cont cunit hf k k' -> - match_cont cunit hf (Cminor.Kseq s k) (Kseq s' k') - | match_cont_block: forall cunit hf k k', - match_cont cunit hf k k' -> - match_cont cunit hf (Cminor.Kblock k) (Kblock k') - | match_cont_call: forall cunit' hf' cunit hf id f sp e k f' e' k', +Inductive match_cont: Cminor.program -> helper_functions -> known_idents -> typenv -> Cminor.cont -> CminorSel.cont -> Prop := + | match_cont_seq: forall cunit hf ki env s s' k k', + sel_stmt (prog_defmap cunit) ki env s = OK s' -> + match_cont cunit hf ki env k k' -> + match_cont cunit hf ki env (Cminor.Kseq s k) (Kseq s' k') + | match_cont_block: forall cunit hf ki env k k', + match_cont cunit hf ki env k k' -> + match_cont cunit hf ki env (Cminor.Kblock k) (Kblock k') + | match_cont_other: forall cunit hf ki env k k', + match_call_cont k k' -> + match_cont cunit hf ki env k k' + +with match_call_cont: Cminor.cont -> CminorSel.cont -> Prop := + | match_cont_stop: + match_call_cont Cminor.Kstop Kstop + | match_cont_call: forall cunit hf env id f sp e k f' e' k', linkorder cunit prog -> helper_functions_declared cunit hf -> sel_function (prog_defmap cunit) hf f = OK f' -> - match_cont cunit hf k k' -> env_lessdef e e' -> - match_cont cunit' hf' (Cminor.Kcall id f sp e k) (Kcall id f' sp e' k'). - -Definition match_call_cont (k: Cminor.cont) (k': CminorSel.cont) : Prop := - forall cunit hf, match_cont cunit hf k k'. + type_function f = OK env -> + match_cont cunit hf (known_id f) env k k' -> + env_lessdef e e' -> + match_call_cont (Cminor.Kcall id f sp e k) (Kcall id f' sp e' k'). Inductive match_states: Cminor.state -> CminorSel.state -> Prop := - | match_state: forall cunit hf f f' s k s' k' sp e m e' m' + | match_state: forall cunit hf f f' s k s' k' sp e m e' m' env (LINK: linkorder cunit prog) (HF: helper_functions_declared cunit hf) (TF: sel_function (prog_defmap cunit) hf f = OK f') - (TS: sel_stmt (prog_defmap cunit) s = OK s') - (MC: match_cont cunit hf k k') + (TYF: type_function f = OK env) + (TS: sel_stmt (prog_defmap cunit) (known_id f) env s = OK s') + (MC: match_cont cunit hf (known_id f) env k k') (LD: env_lessdef e e') (ME: Mem.extends m m'), match_states @@ -794,11 +983,12 @@ Inductive match_states: Cminor.state -> CminorSel.state -> Prop := match_states (Cminor.Returnstate v k m) (Returnstate v' k' m') - | match_builtin_1: forall cunit hf ef args args' optid f sp e k m al f' e' k' m' + | match_builtin_1: forall cunit hf ef args args' optid f sp e k m al f' e' k' m' env (LINK: linkorder cunit prog) (HF: helper_functions_declared cunit hf) (TF: sel_function (prog_defmap cunit) hf f = OK f') - (MC: match_cont cunit hf k k') + (TYF: type_function f = OK env) + (MC: match_cont cunit hf (known_id f) env k k') (LDA: Val.lessdef_list args args') (LDE: env_lessdef e e') (ME: Mem.extends m m') @@ -806,11 +996,12 @@ Inductive match_states: Cminor.state -> CminorSel.state -> Prop := match_states (Cminor.Callstate (External ef) args (Cminor.Kcall optid f sp e k) m) (State f' (Sbuiltin (sel_builtin_res optid) ef al) k' sp e' m') - | match_builtin_2: forall cunit hf v v' optid f sp e k m f' e' m' k' + | match_builtin_2: forall cunit hf v v' optid f sp e k m f' e' m' k' env (LINK: linkorder cunit prog) (HF: helper_functions_declared cunit hf) (TF: sel_function (prog_defmap cunit) hf f = OK f') - (MC: match_cont cunit hf k k') + (TYF: type_function f = OK env) + (MC: match_cont cunit hf (known_id f) env k k') (LDV: Val.lessdef v v') (LDE: env_lessdef e e') (ME: Mem.extends m m'), @@ -819,23 +1010,23 @@ Inductive match_states: Cminor.state -> CminorSel.state -> Prop := (State f' Sskip k' sp (set_builtin_res (sel_builtin_res optid) v' e') m'). Remark call_cont_commut: - forall cunit hf k k', match_cont cunit hf k k' -> match_call_cont (Cminor.call_cont k) (call_cont k'). + forall cunit hf ki env k k', + match_cont cunit hf ki env k k' -> match_call_cont (Cminor.call_cont k) (call_cont k'). Proof. - induction 1; simpl; auto; red; intros. -- constructor. -- eapply match_cont_call with (hf := hf); eauto. + induction 1; simpl; auto. inversion H; subst; auto. Qed. Remark match_is_call_cont: - forall cunit hf k k', match_cont cunit hf k k' -> Cminor.is_call_cont k -> match_call_cont k k'. + forall cunit hf ki env k k', + match_cont cunit ki env hf k k' -> Cminor.is_call_cont k -> + match_call_cont k k' /\ is_call_cont k'. Proof. - destruct 1; intros; try contradiction; red; intros. -- constructor. -- eapply match_cont_call with (hf := hf); eauto. + destruct 1; intros; try contradiction. split; auto. inv H; auto. Qed. +(* Remark match_call_cont_cont: - forall k k', match_call_cont k k' -> exists cunit hf, match_cont cunit hf k k'. + forall k k', match_call_cont k k' -> exists cunit hf ki env, match_cont cunit hf ki env k k'. Proof. intros. simple refine (let cunit : Cminor.program := _ in _). econstructor. apply nil. apply nil. apply xH. @@ -843,14 +1034,58 @@ Proof. econstructor; apply xH. exists cunit, hf; auto. Qed. +*) + +Definition nolabel (s: Cminor.stmt) : Prop := + forall lbl k, Cminor.find_label lbl s k = None. +Definition nolabel' (s: stmt) : Prop := + forall lbl k, find_label lbl s k = None. + +Lemma classify_stmt_nolabel: + forall s, classify_stmt s <> SCother -> nolabel s. +Proof. + intros s. functional induction (classify_stmt s); intros. +- red; auto. +- red; auto. +- apply IHs0 in H. red; intros; simpl. apply H. +- apply IHs0 in H. red; intros; simpl. rewrite H; auto. +- congruence. +Qed. + +Lemma if_conversion_base_nolabel: forall (hf: helper_functions) ki env a id a1 a2 s, + if_conversion_base ki env a id a1 a2 = Some s -> + nolabel' s. +Proof. + unfold if_conversion_base; intros. + destruct (is_known ki id && safe_expr ki a1 && safe_expr ki a2 && + if_conversion_heuristic a a1 a2 (env id)); try discriminate. + destruct (sel_select_opt (env id) a a1 a2); inv H. + red; auto. +Qed. + +Lemma if_conversion_nolabel: forall (hf: helper_functions) ki env a s1 s2 s, + if_conversion ki env a s1 s2 = Some s -> + nolabel s1 /\ nolabel s2 /\ nolabel' s. +Proof. + unfold if_conversion; intros. + Ltac conclude := + split; [apply classify_stmt_nolabel;congruence + |split; [apply classify_stmt_nolabel;congruence + |eapply if_conversion_base_nolabel; eauto]]. + destruct (classify_stmt s1) eqn:C1; try discriminate; + destruct (classify_stmt s2) eqn:C2; try discriminate. + conclude. + conclude. + destruct (ident_eq id id0). conclude. discriminate. +Qed. Remark find_label_commut: - forall cunit hf lbl s k s' k', - match_cont cunit hf k k' -> - sel_stmt (prog_defmap cunit) s = OK s' -> + forall cunit hf ki env lbl s k s' k', + match_cont cunit hf ki env k k' -> + sel_stmt (prog_defmap cunit) ki env s = OK s' -> match Cminor.find_label lbl s k, find_label lbl s' k' with | None, None => True - | Some(s1, k1), Some(s1', k1') => sel_stmt (prog_defmap cunit) s1 = OK s1' /\ match_cont cunit hf k1 k1' + | Some(s1, k1), Some(s1', k1') => sel_stmt (prog_defmap cunit) ki env s1 = OK s1' /\ match_cont cunit hf ki env k1 k1' | _, _ => False end. Proof. @@ -867,7 +1102,11 @@ Proof. destruct (find_label lbl x (Kseq x0 k')) as [[sy ky] | ]; intuition. apply IHs2; auto. (* ifthenelse *) -- exploit (IHs1 k); eauto. +- destruct (if_conversion ki env e s1 s2) as [s|] eqn:IFC. + inv SE. exploit if_conversion_nolabel; eauto. intros (A & B & C). + rewrite A, B, C. auto. + monadInv SE; simpl. + exploit (IHs1 k); eauto. destruct (Cminor.find_label lbl s1 k) as [[sx kx] | ]; destruct (find_label lbl x k') as [[sy ky] | ]; intuition. apply IHs2; auto. @@ -896,20 +1135,22 @@ Definition measure (s: Cminor.state) : nat := Lemma sel_step_correct: forall S1 t S2, Cminor.step ge S1 t S2 -> - forall T1, match_states S1 T1 -> + forall T1, match_states S1 T1 -> wt_state S1 -> (exists T2, step tge T1 t T2 /\ match_states S2 T2) - \/ (measure S2 < measure S1 /\ t = E0 /\ match_states S2 T1)%nat. + \/ (measure S2 < measure S1 /\ t = E0 /\ match_states S2 T1)%nat + \/ (exists S3 T2, star Cminor.step ge S2 E0 S3 /\ step tge T1 t T2 /\ match_states S3 T2). Proof. - induction 1; intros T1 ME; inv ME; try (monadInv TS). + induction 1; intros T1 ME WTS; inv ME; try (monadInv TS). - (* skip seq *) inv MC. left; econstructor; split. econstructor. econstructor; eauto. + inv H. - (* skip block *) inv MC. left; econstructor; split. econstructor. econstructor; eauto. + inv H. - (* skip call *) exploit Mem.free_parallel_extends; eauto. intros [m2' [A B]]. left; econstructor; split. - econstructor. inv MC; simpl in H; simpl; auto. - eauto. + econstructor. eapply match_is_call_cont; eauto. erewrite stackspace_function_translated; eauto. econstructor; eauto. eapply match_is_call_cont; eauto. - (* assign *) @@ -935,7 +1176,7 @@ Proof. econstructor; eauto. econstructor; eauto. eapply sig_function_translated; eauto. eapply match_callstate with (cunit := cunit'); eauto. - red; intros. eapply match_cont_call with (cunit := cunit) (hf := hf); eauto. + eapply match_cont_call with (cunit := cunit) (hf := hf); eauto. + (* direct *) intros [b [U V]]. exploit sel_exprlist_correct; eauto. intros [vargs' [C D]]. @@ -945,11 +1186,11 @@ Proof. subst vf. econstructor; eauto. rewrite symbols_preserved; eauto. eapply sig_function_translated; eauto. eapply match_callstate with (cunit := cunit'); eauto. - red; intros; eapply match_cont_call with (cunit := cunit) (hf := hf); eauto. + eapply match_cont_call with (cunit := cunit) (hf := hf); eauto. + (* turned into Sbuiltin *) intros EQ. subst fd. exploit sel_builtin_args_correct; eauto. intros [vargs' [C D]]. - right; split. simpl. omega. split. auto. + right; left; split. simpl. omega. split. auto. econstructor; eauto. - (* Stailcall *) exploit Mem.free_parallel_extends; eauto. intros [m2' [P Q]]. @@ -978,7 +1219,13 @@ Proof. constructor. econstructor; eauto. constructor; auto. - (* Sifthenelse *) - exploit sel_expr_correct; eauto. intros [v' [A B]]. + simpl in TS. destruct (if_conversion (known_id f) env a s1 s2) as [s|] eqn:IFC; monadInv TS. ++ inv WTS. inv WT_FN. assert (env0 = env) by congruence. subst env0. inv WT_STMT. + exploit if_conversion_correct; eauto. + set (s0 := if b then s1 else s2). intros (e1 & e1' & A & B & C). + right; right. econstructor; econstructor. + split. eexact B. split. eexact A. econstructor; eauto. ++ exploit sel_expr_correct; eauto. intros [v' [A B]]. assert (Val.bool_of_val v' b). inv B. auto. inv H0. left; exists (State f' (if b then x else x0) k' sp e' m'); split. econstructor; eauto. eapply eval_condexpr_of_expr; eauto. @@ -990,10 +1237,13 @@ Proof. left; econstructor; split. constructor. econstructor; eauto. constructor; auto. - (* Sexit seq *) inv MC. left; econstructor; split. constructor. econstructor; eauto. + inv H. - (* Sexit0 block *) inv MC. left; econstructor; split. constructor. econstructor; eauto. + inv H. - (* SexitS block *) inv MC. left; econstructor; split. constructor. econstructor; eauto. + inv H. - (* Sswitch *) inv H0; simpl in TS. + set (ct := compile_switch Int.modulus default cases) in *. @@ -1024,10 +1274,10 @@ Proof. - (* Slabel *) left; econstructor; split. constructor. econstructor; eauto. - (* Sgoto *) - assert (sel_stmt (prog_defmap cunit) (Cminor.fn_body f) = OK (fn_body f')). - { monadInv TF; simpl; auto. } - exploit (find_label_commut cunit hf lbl (Cminor.fn_body f) (Cminor.call_cont k)). - eapply call_cont_commut; eauto. eauto. + assert (sel_stmt (prog_defmap cunit) (known_id f) env (Cminor.fn_body f) = OK (fn_body f')). + { monadInv TF; simpl. congruence. } + exploit (find_label_commut cunit hf (known_id f) env lbl (Cminor.fn_body f) (Cminor.call_cont k)). + apply match_cont_other. eapply call_cont_commut; eauto. eauto. rewrite H. destruct (find_label lbl (fn_body f') (call_cont k'0)) as [[s'' k'']|] eqn:?; intros; try contradiction. @@ -1036,13 +1286,15 @@ Proof. econstructor; eauto. econstructor; eauto. - (* internal function *) - destruct TF as (hf & HF & TF). specialize (MC cunit hf). + destruct TF as (hf & HF & TF). monadInv TF. generalize EQ; intros TF; monadInv TF. exploit Mem.alloc_extends. eauto. eauto. apply Z.le_refl. apply Z.le_refl. intros [m2' [A B]]. left; econstructor; split. econstructor; simpl; eauto. - econstructor; simpl; eauto. apply set_locals_lessdef. apply set_params_lessdef; auto. + econstructor; simpl; eauto. + apply match_cont_other; auto. + apply set_locals_lessdef. apply set_params_lessdef; auto. - (* external call *) destruct TF as (hf & HF & TF). monadInv TF. @@ -1058,13 +1310,12 @@ Proof. econstructor. eauto. eapply external_call_symbols_preserved; eauto. apply senv_preserved. econstructor; eauto. - (* return *) - apply match_call_cont_cont in MC. destruct MC as (cunit0 & hf0 & MC). inv MC. left; econstructor; split. econstructor. econstructor; eauto. destruct optid; simpl; auto. apply set_var_lessdef; auto. - (* return of an external call turned into a Sbuiltin *) - right; split. simpl; omega. split. auto. econstructor; eauto. + right; left; split. simpl; omega. split. auto. econstructor; eauto. apply sel_builtin_res_correct; auto. Qed. @@ -1080,26 +1331,35 @@ Proof. rewrite (match_program_main TRANSF). fold tge. rewrite symbols_preserved. eauto. eexact A. rewrite <- H2. eapply sig_function_translated; eauto. - econstructor; eauto. red; intros; constructor. apply Mem.extends_refl. + econstructor; eauto. constructor. apply Mem.extends_refl. Qed. Lemma sel_final_states: forall S R r, match_states S R -> Cminor.final_state S r -> final_state R r. Proof. - intros. inv H0. inv H. - apply match_call_cont_cont in MC. destruct MC as (cunit0 & hf0 & MC). - inv MC. inv LD. constructor. + intros. inv H0. inv H. inv MC. inv LD. constructor. Qed. Theorem transf_program_correct: forward_simulation (Cminor.semantics prog) (CminorSel.semantics tprog). Proof. - apply forward_simulation_opt with (match_states := match_states) (measure := measure). - apply senv_preserved. - apply sel_initial_states; auto. - apply sel_final_states; auto. - apply sel_step_correct; auto. + set (MS := fun S T => match_states S T /\ wt_state S). + apply forward_simulation_determ_star with (match_states := MS) (measure := measure). +- apply Cminor.semantics_determinate. +- apply senv_preserved. +- intros. exploit sel_initial_states; eauto. intros (T & P & Q). + exists T; split; auto; split; auto. eapply wt_initial_state. eexact wt_prog. auto. +- intros. destruct H. eapply sel_final_states; eauto. +- intros S1 t S2 A T1 [B C]. + assert (wt_state S2) by (eapply subject_reduction; eauto using wt_prog). + unfold MS. + exploit sel_step_correct; eauto. + intros [(T2 & D & E) | [(D & E & F) | (S3 & T2 & D & E & F)]]. ++ exists S2, T2. intuition auto using star_refl, plus_one. ++ subst t. exists S2, T1. intuition auto using star_refl. ++ assert (wt_state S3) by (eapply subject_reduction_star; eauto using wt_prog). + exists S3, T2. intuition auto using plus_one. Qed. End PRESERVATION. diff --git a/backend/Unusedglob.v b/backend/Unusedglob.v index 916e111b..8ac7c4ce 100644 --- a/backend/Unusedglob.v +++ b/backend/Unusedglob.v @@ -107,7 +107,7 @@ Definition used_globals (p: program) (pm: prog_map) : option IS.t := (** * Elimination of unreferenced global definitions *) -(** We also eliminate multiple definitions of the same global name, keeping ony +(** We also eliminate multiple definitions of the same global name, keeping only the last definition (in program definition order). *) Fixpoint filter_globdefs (used: IS.t) (accu defs: list (ident * globdef fundef unit)) := diff --git a/backend/Unusedglobproof.v b/backend/Unusedglobproof.v index 7899a04c..680daba7 100644 --- a/backend/Unusedglobproof.v +++ b/backend/Unusedglobproof.v @@ -1160,10 +1160,10 @@ Local Transparent Mem.loadbytes. generalize (S1 NO). unfold Mem.loadbytes. destruct Mem.range_perm_dec; intros E1; inv E1. generalize (S2 NO). unfold Mem.loadbytes. destruct Mem.range_perm_dec; intros E2; inv E2. rewrite Z.add_0_r. - apply Mem_getN_forall2 with (p := 0) (n := nat_of_Z (init_data_list_size (gvar_init v))). + apply Mem_getN_forall2 with (p := 0) (n := Z.to_nat (init_data_list_size (gvar_init v))). rewrite H3, H4. apply bytes_of_init_inject. auto. omega. - rewrite nat_of_Z_eq by (apply init_data_list_size_pos). omega. + rewrite Z2Nat.id by (apply Z.ge_le; apply init_data_list_size_pos). omega. Qed. Lemma init_mem_inj_2: @@ -1373,9 +1373,9 @@ Proof. * apply Y with id; auto. * exists gd1; auto. * exists gd2; auto. - * eapply used_not_defined_2 in GD1; eauto. eapply used_not_defined_2 in GD2; eauto. + * eapply used_not_defined_2 in GD1; [ | eauto | congruence ]. + eapply used_not_defined_2 in GD2; [ | eauto | congruence ]. tauto. - congruence. } destruct E as [g LD]. left. unfold prog_defs_names; simpl. diff --git a/backend/ValueDomain.v b/backend/ValueDomain.v index e7e44e29..f6afa836 100644 --- a/backend/ValueDomain.v +++ b/backend/ValueDomain.v @@ -11,7 +11,7 @@ (* *********************************************************************) Require Import FunInd. -Require Import Zwf Coqlib Maps Integers Floats Lattice. +Require Import Zwf Coqlib Maps Zbits Integers Floats Lattice. Require Import Compopts AST. Require Import Values Memory Globalenvs Events. Require Import Registers RTL. @@ -1492,12 +1492,12 @@ Proof. inv H; auto with va. - apply vmatch_uns. red; intros. rewrite Int.bits_rol by auto. generalize (Int.unsigned_range n); intros. - rewrite Zmod_small by omega. + rewrite Z.mod_small by omega. apply H1. omega. omega. - destruct (zlt n0 Int.zwordsize); auto with va. apply vmatch_sgn. red; intros. rewrite ! Int.bits_rol by omega. generalize (Int.unsigned_range n); intros. - rewrite ! Zmod_small by omega. + rewrite ! Z.mod_small by omega. rewrite H1 by omega. symmetry. rewrite H1 by omega. auto. - destruct (zlt n0 Int.zwordsize); auto with va. Qed. @@ -1670,7 +1670,7 @@ Proof. assert (UNS: forall i j, j <> Int.zero -> is_uns (usize j) (Int.modu i j)). { intros. apply is_uns_mon with (usize (Int.modu i j)); auto with va. - unfold usize, Int.size. apply Int.Zsize_monotone. + unfold usize, Int.size. apply Zsize_monotone. generalize (Int.unsigned_range_2 j); intros RANGE. assert (Int.unsigned j <> 0). { red; intros; elim H. rewrite <- (Int.repr_unsigned j). rewrite H0. auto. } @@ -2824,6 +2824,64 @@ Proof. intros. inv H; simpl in H0; congruence. Qed. +(** Select either returns one of its arguments, or Vundef. *) + +Definition add_undef (x: aval) := + match x with + | Vbot => ntop + | I i => + if Int.lt i Int.zero + then sgn Pbot (ssize i) + else uns Pbot (usize i) + | L _ | F _ | FS _ => ntop + | _ => x + end. + +Lemma add_undef_sound: + forall v x, vmatch v x -> vmatch v (add_undef x). +Proof. + destruct 1; simpl; auto with va. + destruct (Int.lt i Int.zero). + apply vmatch_sgn; apply is_sgn_ssize. + apply vmatch_uns; apply is_uns_usize. +Qed. + +Lemma add_undef_undef: + forall x, vmatch Vundef (add_undef x). +Proof. + destruct x; simpl; auto with va. + destruct (Int.lt n Int.zero); auto with va. +Qed. + +Lemma add_undef_normalize: + forall v x ty, vmatch v x -> vmatch (Val.normalize v ty) (add_undef x). +Proof. + intros. destruct (Val.lessdef_normalize v ty); + auto using add_undef_sound, add_undef_undef. +Qed. + +Definition select (ab: abool) (x y: aval) := + match ab with + | Bnone => ntop + | Just b | Maybe b => add_undef (if b then x else y) + | Btop => add_undef (vlub x y) + end. + +Lemma select_sound: + forall ob v w ab x y ty, + cmatch ob ab -> vmatch v x -> vmatch w y -> + vmatch (Val.select ob v w ty) (select ab x y). +Proof. + unfold Val.select, select; intros. inv H. +- auto with va. +- apply add_undef_normalize; destruct b; auto. +- apply add_undef_undef. +- apply add_undef_normalize; destruct b; auto. +- destruct ob as [b|]. ++ apply add_undef_normalize. destruct b; [apply vmatch_lub_l|apply vmatch_lub_r]; auto. ++ apply add_undef_undef. +Qed. + (** Normalization at load time *) Definition vnormalize (chunk: memory_chunk) (v: aval) := @@ -3134,7 +3192,7 @@ Proof. omega. intros (bytes1 & bytes2 & LOAD1 & LOAD2 & CONCAT). subst bytes. - exploit Mem.loadbytes_length. eexact LOAD1. change (nat_of_Z 1) with 1%nat. intros LENGTH1. + exploit Mem.loadbytes_length. eexact LOAD1. change (Z.to_nat 1) with 1%nat. intros LENGTH1. rewrite in_app_iff in IN. destruct IN. * destruct bytes1; try discriminate. destruct bytes1; try discriminate. simpl in H. destruct H; try contradiction. subst m0. @@ -3492,7 +3550,7 @@ Qed. Lemma ablock_storebytes_sound: forall m b ofs bytes m' p ab sz, Mem.storebytes m b ofs bytes = Some m' -> - length bytes = nat_of_Z sz -> + length bytes = Z.to_nat sz -> (forall b' ofs' q i, In (Fragment (Vptr b' ofs') q i) bytes -> pmatch b' ofs' p) -> bmatch m b ab -> bmatch m' b (ablock_storebytes ab p ofs sz). @@ -3509,7 +3567,7 @@ Proof. exploit ablock_storebytes_contents; eauto. intros [A B]. assert (Mem.load chunk' m b ofs' = Some v'). { rewrite <- LOAD'; symmetry. eapply Mem.load_storebytes_other; eauto. - rewrite U. rewrite LENGTH. rewrite nat_of_Z_max. right; omega. } + rewrite U. rewrite LENGTH. rewrite Z_to_nat_max. right; omega. } exploit BM2; eauto. unfold ablock_load. rewrite A. rewrite COMPAT. auto. Qed. @@ -3992,7 +4050,7 @@ Theorem storebytes_sound: Mem.storebytes m b (Ptrofs.unsigned ofs) bytes = Some m' -> mmatch m am -> pmatch b ofs p -> - length bytes = nat_of_Z sz -> + length bytes = Z.to_nat sz -> (forall b' ofs' qt i, In (Fragment (Vptr b' ofs') qt i) bytes -> pmatch b' ofs' q) -> mmatch m' (storebytes am p sz q). Proof. diff --git a/cfrontend/C2C.ml b/cfrontend/C2C.ml index 0f2e3674..37527940 100644 --- a/cfrontend/C2C.ml +++ b/cfrontend/C2C.ml @@ -109,7 +109,7 @@ let atom_location a = let comp_env : composite_env ref = ref Maps.PTree.empty -(** Hooks -- overriden in machine-dependent CPragmas module *) +(** Hooks -- overridden in machine-dependent CPragmas module *) let process_pragma_hook = ref (fun (_: string) -> false) @@ -703,12 +703,12 @@ let z_of_str hex str fst = let checkFloatOverflow f typ = match f with - | Fappli_IEEE.B754_finite _ -> () - | Fappli_IEEE.B754_zero _ -> + | Binary.B754_finite _ -> () + | Binary.B754_zero _ -> warning Diagnostics.Literal_range "magnitude of floating-point constant too small for type '%s'" typ - | Fappli_IEEE.B754_infinity _ -> + | Binary.B754_infinity _ -> warning Diagnostics.Literal_range "magnitude of floating-point constant too large for type '%s'" typ - | Fappli_IEEE.B754_nan _ -> + | Binary.B754_nan _ -> warning Diagnostics.Literal_range "floating-point converts converts to 'NaN'" let convertFloat f kind = diff --git a/cfrontend/Cexec.v b/cfrontend/Cexec.v index 823d2542..7f5fe355 100644 --- a/cfrontend/Cexec.v +++ b/cfrontend/Cexec.v @@ -292,7 +292,6 @@ Remark check_assign_copy: { assign_copy_ok ty b ofs b' ofs' } + {~ assign_copy_ok ty b ofs b' ofs' }. Proof with try (right; intuition omega). intros. unfold assign_copy_ok. - assert (alignof_blockcopy ge ty > 0) by apply alignof_blockcopy_pos. destruct (Zdivide_dec (alignof_blockcopy ge ty) (Ptrofs.unsigned ofs')); auto... destruct (Zdivide_dec (alignof_blockcopy ge ty) (Ptrofs.unsigned ofs)); auto... assert (Y: {b' <> b \/ diff --git a/cfrontend/Clight.v b/cfrontend/Clight.v index 7a4c49a2..8ab29fe9 100644 --- a/cfrontend/Clight.v +++ b/cfrontend/Clight.v @@ -84,7 +84,7 @@ Definition typeof (e: expr) : type := (** ** Statements *) (** Clight statements are similar to those of Compcert C, with the addition - of assigment (of a rvalue to a lvalue), assignment to a temporary, + of assignment (of a rvalue to a lvalue), assignment to a temporary, and function call (with assignment of the result to a temporary). The three C loops are replaced by a single infinite loop [Sloop s1 s2] that executes [s1] then [s2] repeatedly. A [continue] in [s1] diff --git a/cfrontend/Cminorgenproof.v b/cfrontend/Cminorgenproof.v index ffafc5d2..5acb996d 100644 --- a/cfrontend/Cminorgenproof.v +++ b/cfrontend/Cminorgenproof.v @@ -923,7 +923,7 @@ Remark inj_offset_aligned_block: Mem.inj_offset_aligned (align stacksize (block_alignment sz)) sz. Proof. intros; red; intros. - apply Zdivides_trans with (block_alignment sz). + apply Z.divide_trans with (block_alignment sz). unfold align_chunk. unfold block_alignment. generalize Z.divide_1_l; intro. generalize Z.divide_refl; intro. diff --git a/cfrontend/Csyntax.v b/cfrontend/Csyntax.v index 914328be..00565309 100644 --- a/cfrontend/Csyntax.v +++ b/cfrontend/Csyntax.v @@ -41,7 +41,7 @@ Inductive expr : Type := (**r binary arithmetic operation *) | Ecast (r: expr) (ty: type) (**r type cast [(ty)r] *) | Eseqand (r1 r2: expr) (ty: type) (**r sequential "and" [r1 && r2] *) - | Eseqor (r1 r2: expr) (ty: type) (**r sequential "or" [r1 && r2] *) + | Eseqor (r1 r2: expr) (ty: type) (**r sequential "or" [r1 || r2] *) | Econdition (r1 r2 r3: expr) (ty: type) (**r conditional [r1 ? r2 : r3] *) | Esizeof (ty': type) (ty: type) (**r size of a type *) | Ealignof (ty': type) (ty: type) (**r natural alignment of a type *) diff --git a/cfrontend/SimplLocalsproof.v b/cfrontend/SimplLocalsproof.v index 26d3d347..2dd34389 100644 --- a/cfrontend/SimplLocalsproof.v +++ b/cfrontend/SimplLocalsproof.v @@ -1055,7 +1055,7 @@ Proof. assert (RPDST: Mem.range_perm m bdst (Ptrofs.unsigned odst) (Ptrofs.unsigned odst + sizeof tge ty) Cur Nonempty). replace (sizeof tge ty) with (Z.of_nat (List.length bytes)). eapply Mem.range_perm_implies. eapply Mem.storebytes_range_perm; eauto. auto with mem. - rewrite LEN. apply nat_of_Z_eq. omega. + rewrite LEN. apply Z2Nat.id. omega. assert (PSRC: Mem.perm m bsrc (Ptrofs.unsigned osrc) Cur Nonempty). apply RPSRC. omega. assert (PDST: Mem.perm m bdst (Ptrofs.unsigned odst) Cur Nonempty). diff --git a/common/AST.v b/common/AST.v index 145f4919..a91138c9 100644 --- a/common/AST.v +++ b/common/AST.v @@ -432,12 +432,12 @@ Inductive external_function : Type := (** A function from the run-time library. Behaves like an external, but must not be redefined. *) | EF_vload (chunk: memory_chunk) - (** A volatile read operation. If the adress given as first argument + (** A volatile read operation. If the address given as first argument points within a volatile global variable, generate an event and return the value found in this event. Otherwise, produce no event and behave like a regular memory load. *) | EF_vstore (chunk: memory_chunk) - (** A volatile store operation. If the adress given as first argument + (** A volatile store operation. If the address given as first argument points within a volatile global variable, generate an event. Otherwise, produce no event and behave like a regular memory store. *) | EF_malloc diff --git a/common/Events.v b/common/Events.v index b2335b96..26dd505f 100644 --- a/common/Events.v +++ b/common/Events.v @@ -1208,7 +1208,7 @@ Proof. assert (RPDST: Mem.range_perm m1 bdst (Ptrofs.unsigned odst) (Ptrofs.unsigned odst + sz) Cur Nonempty). replace sz with (Z.of_nat (length bytes)). eapply Mem.range_perm_implies. eapply Mem.storebytes_range_perm; eauto. auto with mem. - rewrite LEN. apply nat_of_Z_eq. omega. + rewrite LEN. apply Z2Nat.id. omega. assert (PSRC: Mem.perm m1 bsrc (Ptrofs.unsigned osrc) Cur Nonempty). apply RPSRC. omega. assert (PDST: Mem.perm m1 bdst (Ptrofs.unsigned odst) Cur Nonempty). diff --git a/common/Memdata.v b/common/Memdata.v index a9ed48b4..7144d72c 100644 --- a/common/Memdata.v +++ b/common/Memdata.v @@ -17,6 +17,7 @@ (** In-memory representation of values. *) Require Import Coqlib. +Require Import Zbits. Require Archi. Require Import AST. Require Import Integers. @@ -50,7 +51,7 @@ Proof. Qed. Definition size_chunk_nat (chunk: memory_chunk) : nat := - nat_of_Z(size_chunk chunk). + Z.to_nat(size_chunk chunk). Lemma size_chunk_conv: forall chunk, size_chunk chunk = Z.of_nat (size_chunk_nat chunk). @@ -258,21 +259,21 @@ Lemma decode_encode_int_4: forall x, Int.repr (decode_int (encode_int 4 (Int.unsigned x))) = x. Proof. intros. rewrite decode_encode_int. transitivity (Int.repr (Int.unsigned x)). - decEq. apply Zmod_small. apply Int.unsigned_range. apply Int.repr_unsigned. + decEq. apply Z.mod_small. apply Int.unsigned_range. apply Int.repr_unsigned. Qed. Lemma decode_encode_int_8: forall x, Int64.repr (decode_int (encode_int 8 (Int64.unsigned x))) = x. Proof. intros. rewrite decode_encode_int. transitivity (Int64.repr (Int64.unsigned x)). - decEq. apply Zmod_small. apply Int64.unsigned_range. apply Int64.repr_unsigned. + decEq. apply Z.mod_small. apply Int64.unsigned_range. apply Int64.repr_unsigned. Qed. (** A length-[n] encoding depends only on the low [8*n] bits of the integer. *) Lemma bytes_of_int_mod: forall n x y, - Int.eqmod (two_p (Z.of_nat n * 8)) x y -> + eqmod (two_p (Z.of_nat n * 8)) x y -> bytes_of_int n x = bytes_of_int n y. Proof. induction n. @@ -284,7 +285,7 @@ Proof. intro EQM. simpl; decEq. apply Byte.eqm_samerepr. red. - eapply Int.eqmod_divides; eauto. apply Z.divide_factor_r. + eapply eqmod_divides; eauto. apply Z.divide_factor_r. apply IHn. destruct EQM as [k EQ]. exists k. rewrite EQ. rewrite <- Z_div_plus_full_l. decEq. change (two_p 8) with 256. ring. omega. @@ -292,7 +293,7 @@ Qed. Lemma encode_int_8_mod: forall x y, - Int.eqmod (two_p 8) x y -> + eqmod (two_p 8) x y -> encode_int 1%nat x = encode_int 1%nat y. Proof. intros. unfold encode_int. decEq. apply bytes_of_int_mod. auto. @@ -300,7 +301,7 @@ Qed. Lemma encode_int_16_mod: forall x y, - Int.eqmod (two_p 16) x y -> + eqmod (two_p 16) x y -> encode_int 2%nat x = encode_int 2%nat y. Proof. intros. unfold encode_int. decEq. apply bytes_of_int_mod. auto. diff --git a/common/Memory.v b/common/Memory.v index 2cf1c3ab..b68a5049 100644 --- a/common/Memory.v +++ b/common/Memory.v @@ -284,7 +284,7 @@ Lemma valid_access_dec: Proof. intros. destruct (range_perm_dec m b ofs (ofs + size_chunk chunk) Cur p). - destruct (Zdivide_dec (align_chunk chunk) ofs (align_chunk_pos chunk)). + destruct (Zdivide_dec (align_chunk chunk) ofs). left; constructor; auto. right; red; intro V; inv V; contradiction. right; red; intro V; inv V; contradiction. @@ -460,7 +460,7 @@ Definition loadv (chunk: memory_chunk) (m: mem) (addr: val) : option val := Definition loadbytes (m: mem) (b: block) (ofs n: Z): option (list memval) := if range_perm_dec m b ofs (ofs + n) Cur Readable - then Some (getN (nat_of_Z n) ofs (m.(mem_contents)#b)) + then Some (getN (Z.to_nat n) ofs (m.(mem_contents)#b)) else None. (** Memory stores. *) @@ -780,7 +780,7 @@ Qed. Theorem loadbytes_length: forall m b ofs n bytes, loadbytes m b ofs n = Some bytes -> - length bytes = nat_of_Z n. + length bytes = Z.to_nat n. Proof. unfold loadbytes; intros. destruct (range_perm_dec m b ofs (ofs + n) Cur Readable); try congruence. @@ -791,7 +791,7 @@ Theorem loadbytes_empty: forall m b ofs n, n <= 0 -> loadbytes m b ofs n = Some nil. Proof. - intros. unfold loadbytes. rewrite pred_dec_true. rewrite nat_of_Z_neg; auto. + intros. unfold loadbytes. rewrite pred_dec_true. rewrite Z_to_nat_neg; auto. red; intros. omegaContradiction. Qed. @@ -816,8 +816,8 @@ Proof. unfold loadbytes; intros. destruct (range_perm_dec m b ofs (ofs + n1) Cur Readable); try congruence. destruct (range_perm_dec m b (ofs + n1) (ofs + n1 + n2) Cur Readable); try congruence. - rewrite pred_dec_true. rewrite nat_of_Z_plus; auto. - rewrite getN_concat. rewrite nat_of_Z_eq; auto. + rewrite pred_dec_true. rewrite Z2Nat.inj_add by omega. + rewrite getN_concat. rewrite Z2Nat.id by omega. congruence. red; intros. assert (ofs0 < ofs + n1 \/ ofs0 >= ofs + n1) by omega. @@ -836,8 +836,8 @@ Proof. unfold loadbytes; intros. destruct (range_perm_dec m b ofs (ofs + (n1 + n2)) Cur Readable); try congruence. - rewrite nat_of_Z_plus in H; auto. rewrite getN_concat in H. - rewrite nat_of_Z_eq in H; auto. + rewrite Z2Nat.inj_add in H by omega. rewrite getN_concat in H. + rewrite Z2Nat.id in H by omega. repeat rewrite pred_dec_true. econstructor; econstructor. split. reflexivity. split. reflexivity. congruence. @@ -887,11 +887,11 @@ Proof. intros (bytes1 & bytes2 & LB1 & LB2 & APP). change 4 with (size_chunk Mint32) in LB1. exploit loadbytes_load. eexact LB1. - simpl. apply Zdivides_trans with 8; auto. exists 2; auto. + simpl. apply Z.divide_trans with 8; auto. exists 2; auto. intros L1. change 4 with (size_chunk Mint32) in LB2. exploit loadbytes_load. eexact LB2. - simpl. apply Z.divide_add_r. apply Zdivides_trans with 8; auto. exists 2; auto. exists 1; auto. + simpl. apply Z.divide_add_r. apply Z.divide_trans with 8; auto. exists 2; auto. exists 1; auto. intros L2. exists (decode_val Mint32 (if Archi.big_endian then bytes1 else bytes2)); exists (decode_val Mint32 (if Archi.big_endian then bytes2 else bytes1)). @@ -1106,7 +1106,7 @@ Proof. assert (valid_access m2 chunk b ofs Readable) by eauto with mem. unfold loadbytes. rewrite pred_dec_true. rewrite store_mem_contents; simpl. rewrite PMap.gss. - replace (nat_of_Z (size_chunk chunk)) with (length (encode_val chunk v)). + replace (Z.to_nat (size_chunk chunk)) with (length (encode_val chunk v)). rewrite getN_setN_same. auto. rewrite encode_val_length. auto. apply H. @@ -1127,10 +1127,10 @@ Proof. rewrite PMap.gsspec. destruct (peq b' b). subst b'. destruct H. congruence. destruct (zle n 0) as [z | n0]. - rewrite (nat_of_Z_neg _ z). auto. + rewrite (Z_to_nat_neg _ z). auto. destruct H. omegaContradiction. apply getN_setN_outside. rewrite encode_val_length. rewrite <- size_chunk_conv. - rewrite nat_of_Z_eq. auto. omega. + rewrite Z2Nat.id. auto. omega. auto. red; intros. eauto with mem. rewrite pred_dec_false. auto. @@ -1523,7 +1523,7 @@ Proof. destruct (range_perm_dec m1 b ofs (ofs + Z.of_nat (length bytes)) Cur Writable); try discriminate. rewrite pred_dec_true. - decEq. inv STORE2; simpl. rewrite PMap.gss. rewrite nat_of_Z_of_nat. + decEq. inv STORE2; simpl. rewrite PMap.gss. rewrite Nat2Z.id. apply getN_setN_same. red; eauto with mem. Qed. @@ -1539,7 +1539,7 @@ Proof. rewrite pred_dec_true. rewrite storebytes_mem_contents. decEq. rewrite PMap.gsspec. destruct (peq b' b). subst b'. - apply getN_setN_disjoint. rewrite nat_of_Z_eq; auto. intuition congruence. + apply getN_setN_disjoint. rewrite Z2Nat.id by omega. intuition congruence. auto. red; auto with mem. apply pred_dec_false. @@ -1644,9 +1644,9 @@ Proof. rewrite encode_val_length in SB2. simpl in SB2. exists m1; split. apply storebytes_store. exact SB1. - simpl. apply Zdivides_trans with 8; auto. exists 2; auto. + simpl. apply Z.divide_trans with 8; auto. exists 2; auto. apply storebytes_store. exact SB2. - simpl. apply Z.divide_add_r. apply Zdivides_trans with 8; auto. exists 2; auto. exists 1; auto. + simpl. apply Z.divide_add_r. apply Z.divide_trans with 8; auto. exists 2; auto. exists 1; auto. Qed. Theorem storev_int64_split: @@ -1867,7 +1867,7 @@ Proof. unfold loadbytes; intros. destruct (range_perm_dec m2 b ofs (ofs + n) Cur Readable); inv H. revert H0. injection ALLOC; intros A B. rewrite <- A; rewrite <- B; simpl. rewrite PMap.gss. - generalize (nat_of_Z n) ofs. induction n0; simpl; intros. + generalize (Z.to_nat n) ofs. induction n0; simpl; intros. contradiction. rewrite ZMap.gi in H0. destruct H0; eauto. Qed. @@ -2342,13 +2342,13 @@ Lemma loadbytes_inj: Proof. intros. unfold loadbytes in *. destruct (range_perm_dec m1 b1 ofs (ofs + len) Cur Readable); inv H0. - exists (getN (nat_of_Z len) (ofs + delta) (m2.(mem_contents)#b2)). + exists (getN (Z.to_nat len) (ofs + delta) (m2.(mem_contents)#b2)). split. apply pred_dec_true. replace (ofs + delta + len) with ((ofs + len) + delta) by omega. eapply range_perm_inj; eauto with mem. apply getN_inj; auto. - destruct (zle 0 len). rewrite nat_of_Z_eq; auto. omega. - rewrite nat_of_Z_neg. simpl. red; intros; omegaContradiction. omega. + destruct (zle 0 len). rewrite Z2Nat.id by omega. auto. + rewrite Z_to_nat_neg by omega. simpl. red; intros; omegaContradiction. Qed. (** Preservation of stores. *) @@ -4340,7 +4340,7 @@ Proof. + unfold loadbytes. destruct H. destruct (range_perm_dec m b ofs (ofs + n) Cur Readable). rewrite pred_dec_true. f_equal. - apply getN_exten. intros. rewrite nat_of_Z_eq in H by omega. + apply getN_exten. intros. rewrite Z2Nat.id in H by omega. apply unchanged_on_contents0; auto. red; intros. apply unchanged_on_perm0; auto. rewrite pred_dec_false. auto. diff --git a/common/Memtype.v b/common/Memtype.v index ae4fa5fd..53775d8b 100644 --- a/common/Memtype.v +++ b/common/Memtype.v @@ -104,7 +104,7 @@ Parameter alloc: forall (m: mem) (lo hi: Z), mem * block. (** [free m b lo hi] frees (deallocates) the range of offsets from [lo] included to [hi] excluded in block [b]. Returns the updated memory - state, or [None] if the freed addresses are not writable. *) + state, or [None] if the freed addresses are not freeable. *) Parameter free: forall (m: mem) (b: block) (lo hi: Z), option mem. (** [load chunk m b ofs] reads a memory quantity [chunk] from @@ -358,7 +358,7 @@ Axiom load_loadbytes: Axiom loadbytes_length: forall m b ofs n bytes, loadbytes m b ofs n = Some bytes -> - length bytes = nat_of_Z n. + length bytes = Z.to_nat n. Axiom loadbytes_empty: forall m b ofs n, diff --git a/common/Separation.v b/common/Separation.v index a9642d72..1493b535 100644 --- a/common/Separation.v +++ b/common/Separation.v @@ -702,7 +702,7 @@ Proof. - intros. assert (0 <= ofs < sz2) by (eapply Mem.perm_alloc_3; eauto). omega. - intros. apply Mem.perm_implies with Freeable; auto with mem. eapply Mem.perm_alloc_2; eauto. xomega. -- red; intros. apply Zdivides_trans with 8; auto. +- red; intros. apply Z.divide_trans with 8; auto. exists (8 / align_chunk chunk). destruct chunk; reflexivity. - intros. elim FRESH2. eapply Mem.valid_block_inject_2; eauto. - intros (j' & INJ' & J1 & J2 & J3). diff --git a/common/Smallstep.v b/common/Smallstep.v index c269013b..27ad0a2d 100644 --- a/common/Smallstep.v +++ b/common/Smallstep.v @@ -872,6 +872,14 @@ Proof. intros. eapply sd_determ; eauto. Qed. +Lemma sd_determ_3: + forall s t s1 s2, + Step L s t s1 -> Step L s E0 s2 -> t = E0 /\ s1 = s2. +Proof. + intros. exploit (sd_determ DET). eexact H. eexact H0. + intros [A B]. inv A. auto. +Qed. + Lemma star_determinacy: forall s t s', Star L s t s' -> forall s'', Star L s t s'' -> Star L s' E0 s'' \/ Star L s'' E0 s'. @@ -895,6 +903,171 @@ Qed. End DETERMINACY. +(** Extra simulation diagrams for determinate languages. *) + +Section FORWARD_SIMU_DETERM. + +Variable L1: semantics. +Variable L2: semantics. + +Hypothesis L1det: determinate L1. + +Variable index: Type. +Variable order: index -> index -> Prop. +Hypothesis wf_order: well_founded order. + +Variable match_states: index -> state L1 -> state L2 -> Prop. + +Hypothesis match_initial_states: + forall s1, initial_state L1 s1 -> + exists i s2, initial_state L2 s2 /\ match_states i s1 s2. + +Hypothesis match_final_states: + forall i s1 s2 r, + match_states i s1 s2 -> + final_state L1 s1 r -> + final_state L2 s2 r. + +Hypothesis simulation: + forall s1 t s1', Step L1 s1 t s1' -> + forall i s2, match_states i s1 s2 -> + exists s1'' i' s2', + Star L1 s1' E0 s1'' + /\ (Plus L2 s2 t s2' \/ (Star L2 s2 t s2' /\ order i' i)) + /\ match_states i' s1'' s2'. + +Hypothesis public_preserved: + forall id, Senv.public_symbol (symbolenv L2) id = Senv.public_symbol (symbolenv L1) id. + +Inductive match_states_later: index * nat -> state L1 -> state L2 -> Prop := +| msl_now: forall i s1 s2, + match_states i s1 s2 -> match_states_later (i, O) s1 s2 +| msl_later: forall i n s1 s1' s2, + Step L1 s1 E0 s1' -> match_states_later (i, n) s1' s2 -> match_states_later (i, S n) s1 s2. + +Lemma star_match_states_later: + forall s1 s1', Star L1 s1 E0 s1' -> + forall i s2, match_states i s1' s2 -> + exists n, match_states_later (i, n) s1 s2. +Proof. + intros s10 s10' STAR0. pattern s10, s10'; eapply star_E0_ind; eauto. + - intros s1 i s2 M. exists O; constructor; auto. + - intros s1 s1' s1'' STEP IH i s2 M. + destruct (IH i s2 M) as (n & MS). + exists (S n); econstructor; eauto. +Qed. + +Lemma forward_simulation_determ: forward_simulation L1 L2. +Proof. + apply Forward_simulation with (order0 := lex_ord order lt) (match_states0 := match_states_later); + constructor. +- apply wf_lex_ord. apply wf_order. apply lt_wf. +- intros. exploit match_initial_states; eauto. intros (i & s2 & A & B). + exists (i, O), s2; auto using msl_now. +- intros. inv H. + + eapply match_final_states; eauto. + + eelim (sd_final_nostep L1det); eauto. +- intros s1 t s1' A; destruct 1. + + exploit simulation; eauto. intros (s1'' & i' & s2' & B & C & D). + exploit star_match_states_later; eauto. intros (n & E). + exists (i', n), s2'; split; auto. + destruct C as [P | [P Q]]; auto using lex_ord_left. + + exploit sd_determ_3. eauto. eexact A. eauto. intros [P Q]; subst t s1'0. + exists (i, n), s2; split; auto. + right; split. apply star_refl. apply lex_ord_right. omega. +- exact public_preserved. +Qed. + +End FORWARD_SIMU_DETERM. + +(** A few useful special cases. *) + +Section FORWARD_SIMU_DETERM_DIAGRAMS. + +Variable L1: semantics. +Variable L2: semantics. + +Hypothesis L1det: determinate L1. + +Variable match_states: state L1 -> state L2 -> Prop. + +Hypothesis public_preserved: + forall id, Senv.public_symbol (symbolenv L2) id = Senv.public_symbol (symbolenv L1) id. + +Hypothesis match_initial_states: + forall s1, initial_state L1 s1 -> + exists s2, initial_state L2 s2 /\ match_states s1 s2. + +Hypothesis match_final_states: + forall s1 s2 r, + match_states s1 s2 -> + final_state L1 s1 r -> + final_state L2 s2 r. + +Section SIMU_DETERM_STAR. + +Variable measure: state L1 -> nat. + +Hypothesis simulation: + forall s1 t s1', Step L1 s1 t s1' -> + forall s2, match_states s1 s2 -> + exists s1'' s2', + Star L1 s1' E0 s1'' + /\ (Plus L2 s2 t s2' \/ (Star L2 s2 t s2' /\ measure s1'' < measure s1))%nat + /\ match_states s1'' s2'. + +Lemma forward_simulation_determ_star: forward_simulation L1 L2. +Proof. + apply forward_simulation_determ with + (match_states := fun i s1 s2 => i = s1 /\ match_states s1 s2) + (order := ltof _ measure). +- assumption. +- apply well_founded_ltof. +- intros. exploit match_initial_states; eauto. intros (s2 & A & B). + exists s1, s2; auto. +- intros. destruct H. eapply match_final_states; eauto. +- intros. destruct H0; subst i. + exploit simulation; eauto. intros (s1'' & s2' & A & B & C). + exists s1'', s1'', s2'. auto. +- assumption. +Qed. + +End SIMU_DETERM_STAR. + +Section SIMU_DETERM_PLUS. + +Hypothesis simulation: + forall s1 t s1', Step L1 s1 t s1' -> + forall s2, match_states s1 s2 -> + exists s1'' s2', Star L1 s1' E0 s1'' /\ Plus L2 s2 t s2' /\ match_states s1'' s2'. + +Lemma forward_simulation_determ_plus: forward_simulation L1 L2. +Proof. + apply forward_simulation_determ_star with (measure := fun _ => O). + intros. exploit simulation; eauto. intros (s1'' & s2' & A & B & C). + exists s1'', s2'; auto. +Qed. + +End SIMU_DETERM_PLUS. + +Section SIMU_DETERM_ONE. + +Hypothesis simulation: + forall s1 t s1', Step L1 s1 t s1' -> + forall s2, match_states s1 s2 -> + exists s1'' s2', Star L1 s1' E0 s1'' /\ Step L2 s2 t s2' /\ match_states s1'' s2'. + +Lemma forward_simulation_determ_one: forward_simulation L1 L2. +Proof. + apply forward_simulation_determ_plus. + intros. exploit simulation; eauto. intros (s1'' & s2' & A & B & C). + exists s1'', s2'; auto using plus_one. +Qed. + +End SIMU_DETERM_ONE. + +End FORWARD_SIMU_DETERM_DIAGRAMS. + (** * Backward simulations between two transition semantics. *) Definition safe (L: semantics) (s: state L) : Prop := diff --git a/common/Switch.v b/common/Switch.v index 0ef91d60..5a6d4c63 100644 --- a/common/Switch.v +++ b/common/Switch.v @@ -288,10 +288,10 @@ Lemma validate_jumptable_correct: Proof. intros. rewrite (validate_jumptable_correct_rec cases tbl ofs); auto. -- f_equal. f_equal. rewrite Zmod_small. omega. +- f_equal. f_equal. rewrite Z.mod_small. omega. destruct (zle ofs v). omega. assert (M: ((v - ofs) + 1 * modulus) mod modulus = (v - ofs) + modulus). - { rewrite Zmod_small. omega. omega. } + { rewrite Z.mod_small. omega. omega. } rewrite Z_mod_plus in M by auto. rewrite M in H0. omega. - generalize (Z_mod_lt (v - ofs) modulus modulus_pos). omega. Qed. @@ -331,7 +331,7 @@ Proof. rewrite (split_between_prop v _ _ _ _ _ _ EQ). assert (0 <= (v - ofs) mod modulus < modulus) by (apply Z_mod_lt; omega). destruct (zlt ((v - ofs) mod modulus) sz). - rewrite Zmod_small by omega. eapply validate_jumptable_correct; eauto. + rewrite Z.mod_small by omega. eapply validate_jumptable_correct; eauto. eapply IHt; eauto. Qed. diff --git a/common/Values.v b/common/Values.v index 127d1085..e4297183 100644 --- a/common/Values.v +++ b/common/Values.v @@ -132,6 +132,23 @@ Proof. simpl in *. InvBooleans. destruct H0. split; auto. eapply has_subtype; eauto. Qed. +Definition has_type_dec (v: val) (t: typ) : { has_type v t } + { ~ has_type v t }. +Proof. + unfold has_type; destruct v. +- auto. +- destruct t; auto. +- destruct t; auto. +- destruct t; auto. +- destruct t; auto. +- destruct t. + apply bool_dec. + auto. + apply bool_dec. + auto. + apply bool_dec. + auto. +Defined. + (** Truth values. Non-zero integers are treated as [True]. The integer 0 (also used to represent the null pointer) is [False]. Other values are neither true nor false. *) @@ -899,6 +916,55 @@ Definition offset_ptr (v: val) (delta: ptrofs) : val := | _ => Vundef end. +(** Normalize a value to the given type, turning it into Vundef if it does not + match the type. *) + +Definition normalize (v: val) (ty: typ) : val := + match v, ty with + | Vundef, _ => Vundef + | Vint _, Tint => v + | Vlong _, Tlong => v + | Vfloat _, Tfloat => v + | Vsingle _, Tsingle => v + | Vptr _ _, (Tint | Tany32) => if Archi.ptr64 then Vundef else v + | Vptr _ _, Tlong => if Archi.ptr64 then v else Vundef + | (Vint _ | Vsingle _), Tany32 => v + | _, Tany64 => v + | _, _ => Vundef + end. + +Lemma normalize_type: + forall v ty, has_type (normalize v ty) ty. +Proof. + intros; destruct v; simpl. +- auto. +- destruct ty; exact I. +- destruct ty; exact I. +- destruct ty; exact I. +- destruct ty; exact I. +- unfold has_type; destruct ty, Archi.ptr64; auto. +Qed. + +Lemma normalize_idem: + forall v ty, has_type v ty -> normalize v ty = v. +Proof. + unfold has_type, normalize; intros. destruct v. +- auto. +- destruct ty; intuition auto. +- destruct ty; intuition auto. +- destruct ty; intuition auto. +- destruct ty; intuition auto. +- destruct ty, Archi.ptr64; intuition congruence. +Qed. + +(** Select between two values based on the result of a comparison. *) + +Definition select (cmp: option bool) (v1 v2: val) (ty: typ) := + match cmp with + | Some b => normalize (if b then v1 else v2) ty + | None => Vundef + end. + (** [load_result] reflects the effect of storing a value with a given memory chunk, then reading it back with the same chunk. Depending on the chunk and the type of the value, some normalization occurs. @@ -2045,6 +2111,36 @@ Proof. intros. destruct v; simpl; auto. f_equal. apply Ptrofs.add_assoc. Qed. +Lemma lessdef_normalize: + forall v ty, lessdef (normalize v ty) v. +Proof. + intros. destruct v; simpl. + - auto. + - destruct ty; auto. + - destruct ty; auto. + - destruct ty; auto. + - destruct ty; auto. + - destruct ty, Archi.ptr64; auto. +Qed. + +Lemma normalize_lessdef: + forall v v' ty, lessdef v v' -> lessdef (normalize v ty) (normalize v' ty). +Proof. + intros. inv H; auto. +Qed. + +Lemma select_lessdef: + forall ob ob' v1 v1' v2 v2' ty, + ob = None \/ ob = ob' -> + lessdef v1 v1' -> lessdef v2 v2' -> + lessdef (select ob v1 v2 ty) (select ob' v1' v2' ty). +Proof. + intros; unfold select. destruct H. +- subst ob; auto. +- subst ob'; destruct ob as [b|]; auto. + apply normalize_lessdef. destruct b; auto. +Qed. + (** * Values and memory injections *) (** A memory injection [f] is a function from addresses to either [None] @@ -2329,6 +2425,36 @@ Proof. intros. unfold Val.hiword; inv H; auto. Qed. +Lemma normalize_inject: + forall v v' ty, inject f v v' -> inject f (normalize v ty) (normalize v' ty). +Proof. + intros. inv H. +- destruct ty; constructor. +- destruct ty; constructor. +- destruct ty; constructor. +- destruct ty; constructor. +- simpl. destruct ty. ++ destruct Archi.ptr64; econstructor; eauto. ++ auto. ++ destruct Archi.ptr64; econstructor; eauto. ++ auto. ++ destruct Archi.ptr64; econstructor; eauto. ++ econstructor; eauto. +- constructor. +Qed. + +Lemma select_inject: + forall ob ob' v1 v1' v2 v2' ty, + ob = None \/ ob = ob' -> + inject f v1 v1' -> inject f v2 v2' -> + inject f (select ob v1 v2 ty) (select ob' v1' v2' ty). +Proof. + intros; unfold select. destruct H. +- subst ob; auto. +- subst ob'; destruct ob as [b|]; auto. + apply normalize_inject. destruct b; auto. +Qed. + End VAL_INJ_OPS. End Val. @@ -541,19 +541,19 @@ missingtools=false echo "Testing Coq... " | tr -d '\n' coq_ver=$(${COQBIN}coqc -v 2>/dev/null | sed -n -e 's/The Coq Proof Assistant, version \([^ ]*\).*$/\1/p') case "$coq_ver" in - 8.6.1|8.7.0|8.7.1|8.7.2|8.8.0|8.8.1|8.8.2|8.9.0) + 8.7.0|8.7.1|8.7.2|8.8.0|8.8.1|8.8.2|8.9.0|8.9.1) echo "version $coq_ver -- good!";; ?*) echo "version $coq_ver -- UNSUPPORTED" if $ignore_coq_version; then echo "Warning: this version of Coq is unsupported, proceed at your own risks." else - echo "Error: CompCert requires one of the following Coq versions: 8.9.0, 8.8.2, 8.8.1, 8.8.0, 8.7.2, 8.7.1, 8.7.0, 8.6.1" + echo "Error: CompCert requires one of the following Coq versions: 8.9.1, 8.9.0, 8.8.2, 8.8.1, 8.8.0, 8.7.2, 8.7.1, 8.7.0" missingtools=true fi;; "") echo "NOT FOUND" - echo "Error: make sure Coq version 8.9.0 is installed." + echo "Error: make sure Coq version 8.9.1 is installed." missingtools=true;; esac @@ -601,7 +601,13 @@ case "$menhir_ver" in 20[0-9][0-9][0-9][0-9][0-9][0-9]) if test "$menhir_ver" -ge $MENHIR_REQUIRED -a "$menhir_ver" -le $MENHIR_MAX; then echo "version $menhir_ver -- good!" - menhir_includes="-I `menhir --suggest-menhirLib`" + menhir_include_dir=`menhir --suggest-menhirLib` + if test -z "$menhir_include_dir"; then + echo "Error: cannot determine the location of the Menhir API library." + echo "This can be due to an incorrect Menhir package." + echo "Consider using the OPAM package for Menhir." + missingtools=true + fi if test "$menhir_ver" -ge $MENHIR_NEW_API; then menhir_flags="--coq-lib-path compcert.cparser.MenhirLib" fi @@ -692,7 +698,7 @@ MANDIR=$sharedir/man SHAREDIR=$sharedir COQDEVDIR=$coqdevdir OCAML_OPT_COMP=$ocaml_opt_comp -MENHIR_INCLUDES=$menhir_includes +MENHIR_INCLUDES=-I "$menhir_include_dir" MENHIR_FLAGS=$menhir_flags COMPFLAGS=-bin-annot EOF diff --git a/cparser/Cutil.ml b/cparser/Cutil.ml index cf67015a..7329767a 100644 --- a/cparser/Cutil.ml +++ b/cparser/Cutil.ml @@ -947,7 +947,7 @@ let binary_conversion env t1 t2 = end | _, _ -> assert false -(* Conversion on function arguments (with protoypes) *) +(* Conversion on function arguments (with prototypes) *) let argument_conversion env t = (* Arrays and functions degrade automatically to pointers *) diff --git a/cparser/Diagnostics.ml b/cparser/Diagnostics.ml index 172affab..51dcab47 100644 --- a/cparser/Diagnostics.ml +++ b/cparser/Diagnostics.ml @@ -18,6 +18,10 @@ open Format open Commandline +(* Ensure that the error formatter is flushed at exit *) +let _ = + at_exit (pp_print_flush err_formatter) + (* Should errors be treated as fatal *) let error_fatal = ref false @@ -28,7 +32,7 @@ let max_error = ref 0 let diagnostics_show_option = ref true (* Test if color diagnostics are available by testing if stderr is a tty - and if the environment varibale TERM is set + and if the environment variable TERM is set *) let color_diagnostics = let term = try Sys.getenv "TERM" with Not_found -> "" in @@ -469,7 +473,7 @@ let raise_on_errors () = let crash exn = if Version.buildnr <> "" && Version.tag <> "" then begin let backtrace = Printexc.get_backtrace () in - eprintf "%tThis is CompCert, %s, Build:%s, Tag:%s%t\n" + eprintf "%tThis is CompCert, Release %s, Build:%s, Tag:%s%t\n" bc Version.version Version.buildnr Version.tag rsc; eprintf "Backtrace (please include this in your support request):\n%s" backtrace; diff --git a/cparser/Diagnostics.mli b/cparser/Diagnostics.mli index ded8019f..6a3c11c8 100644 --- a/cparser/Diagnostics.mli +++ b/cparser/Diagnostics.mli @@ -22,22 +22,22 @@ exception Abort (** Exception raised upon fatal errors *) val check_errors : unit -> unit - (** Check whether errors occured and raise abort if an error occured *) + (** Check whether errors occurred and raise abort if an error occurred *) type warning_type = | Unnamed (** warnings which cannot be turned off *) | Unknown_attribute (** usage of unsupported/unknown attributes *) - | Zero_length_array (** gnu extension for zero lenght arrays *) + | Zero_length_array (** gnu extension for zero length arrays *) | Celeven_extension (** C11 features *) | Gnu_empty_struct (** gnu extension for empty struct *) - | Missing_declarations (** declation which do not declare anything *) + | Missing_declarations (** declaration which do not declare anything *) | Constant_conversion (** dangerous constant conversions *) | Int_conversion (** pointer <-> int conversions *) | Varargs (** promotable vararg argument *) | Implicit_function_declaration (** deprecated implicit function declaration *) | Pointer_type_mismatch (** pointer type mismatch in ?: operator *) | Compare_distinct_pointer_types (** comparison between different pointer types *) - | Implicit_int (** implict int parameter or return type *) + | Implicit_int (** implicit int parameter or return type *) | Main_return_type (** wrong return type for main *) | Invalid_noreturn (** noreturn function containing return *) | Return_type (** void return in non-void function *) diff --git a/cparser/Elab.ml b/cparser/Elab.ml index 7a0b05de..9cca930d 100644 --- a/cparser/Elab.ml +++ b/cparser/Elab.ml @@ -295,14 +295,16 @@ let parse_int base s = | _ -> assert false in let v = ref 0L in for i = 0 to String.length s - 1 do - if !v < 0L || !v > max_val then raise Overflow; - v := Int64.mul !v (Int64.of_int base); let c = s.[i] in let digit = if c >= '0' && c <= '9' then Char.code c - 48 else if c >= 'A' && c <= 'F' then Char.code c - 55 else raise Bad_digit in if digit >= base then raise Bad_digit; + if !v < 0L || !v > max_val then raise Overflow; + (* because (2^64 - 1) % 10 = 5, not 9 *) + if base = 10 && !v = max_val && digit > 5 then raise Overflow; + v := Int64.mul !v (Int64.of_int base); v := Int64.add !v (Int64.of_int digit) done; !v @@ -939,31 +941,7 @@ and elab_name_group loc env (spec, namelist) = ((id, add_attributes_type a ty), env1) in (mmap elab_one_name env' namelist, sto) -(* Elaboration of an init-name group *) -and elab_init_name_group loc env (spec, namelist) = - let (sto, inl, noret, tydef, bty, env') = - elab_specifier ~only:(namelist=[]) loc env spec in - if noret && tydef then - error loc "'_Noreturn' can only appear on functions"; - let elab_one_name env (Init_name (Name (id, decl, attr, loc), init)) = - let ((ty, _), env1) = - elab_type_declarator loc env bty decl in - let a = elab_attributes env attr in - let has_fun_typ = is_function_type env ty in - if inl && not has_fun_typ then - error loc "'inline' can only appear on functions"; - let a' = - if noret then begin - warning loc Celeven_extension "_Noreturn functions are a C11 extension"; - if not has_fun_typ then - error loc "'_Noreturn' can only appear on functions"; - add_attributes [Attr("noreturn",[])] a - end else a in - if has_std_alignas env ty && has_fun_typ then - error loc "alignment specified for function '%s'" id; - ((id, add_attributes_type a' ty, init), env1) in - (mmap elab_one_name env' namelist, sto, tydef) (* Elaboration of a field group *) @@ -1706,7 +1684,7 @@ let elab_expr ctx loc env a = error "arithmetic on a pointer to an incomplete type %a in binary '%c'" (print_typ env) ty s in - let check_static_var id sto ty = + let check_static_var env id sto ty = if ctx.ctx_nonstatic_inline && sto = Storage_static && List.mem AConst (attributes_of_type env ty) @@ -1720,7 +1698,7 @@ let elab_expr ctx loc env a = | VARIABLE s -> begin match wrap Env.lookup_ident loc env s with | (id, Env.II_ident(sto, ty)) -> - check_static_var id sto ty; + check_static_var env id sto ty; { edesc = EVar id; etyp = ty },env | (id, Env.II_enum v) -> { edesc = EConst(CEnum(id, v)); etyp = TInt(enum_ikind, []) },env @@ -1837,7 +1815,7 @@ let elab_expr ctx loc env a = emit_elab ~linkage env loc (Gdecl(sto, id, ty, None)); { edesc = EVar id; etyp = ty },env | _ -> elab env a1 in - let bl = mmap elab env al in + let (bl, env) = mmap elab env al in (* Extract type information *) let (res, args, vararg) = match unroll env b1.etyp with @@ -1852,14 +1830,19 @@ let elab_expr ctx loc env a = (* Type-check the arguments against the prototype *) let bl',env = match args with - | None -> bl - | Some proto -> elab_arguments 1 bl proto vararg in + | None -> + List.iter (fun arg -> + let arg_typ = argument_conversion env arg.etyp in + if incomplete_type env arg_typ then + error "argument type %a is incomplete" (print_typ env) arg.etyp; + ) bl; (bl,env) + | Some proto -> elab_arguments 1 (bl, env) proto vararg in { edesc = ECall(b1, bl'); etyp = res },env | UNARY(POSINCR, a1) -> - elab_pre_post_incr_decr Opostincr "increment" a1 + elab_pre_post_incr_decr env Opostincr "increment" a1 | UNARY(POSDECR, a1) -> - elab_pre_post_incr_decr Opostdecr "decrement" a1 + elab_pre_post_incr_decr env Opostdecr "decrement" a1 (* 6.5.4 Cast operators *) @@ -2018,20 +2001,20 @@ let elab_expr ctx loc env a = end | UNARY(PREINCR, a1) -> - elab_pre_post_incr_decr Opreincr "increment" a1 + elab_pre_post_incr_decr env Opreincr "increment" a1 | UNARY(PREDECR, a1) -> - elab_pre_post_incr_decr Opredecr "decrement" a1 + elab_pre_post_incr_decr env Opredecr "decrement" a1 (* 6.5.5 to 6.5.12 Binary operator expressions *) | BINARY(MUL, a1, a2) -> - elab_binary_arithmetic "*" Omul a1 a2 + elab_binary_arithmetic env "*" Omul a1 a2 | BINARY(DIV, a1, a2) -> - elab_binary_arithmetic "/" Odiv a1 a2 + elab_binary_arithmetic env "/" Odiv a1 a2 | BINARY(MOD, a1, a2) -> - elab_binary_integer "%" Omod a1 a2 + elab_binary_integer env "%" Omod a1 a2 | BINARY(ADD, a1, a2) -> let b1,env = elab env a1 in @@ -2081,37 +2064,37 @@ let elab_expr ctx loc env a = { edesc = EBinop(Osub, b1, b2, tyop); etyp = tyres },env | BINARY(SHL, a1, a2) -> - elab_shift "<<" Oshl a1 a2 + elab_shift env "<<" Oshl a1 a2 | BINARY(SHR, a1, a2) -> - elab_shift ">>" Oshr a1 a2 + elab_shift env ">>" Oshr a1 a2 | BINARY(EQ, a1, a2) -> - elab_comparison Oeq a1 a2 + elab_comparison env Oeq a1 a2 | BINARY(NE, a1, a2) -> - elab_comparison One a1 a2 + elab_comparison env One a1 a2 | BINARY(LT, a1, a2) -> - elab_comparison Olt a1 a2 + elab_comparison env Olt a1 a2 | BINARY(GT, a1, a2) -> - elab_comparison Ogt a1 a2 + elab_comparison env Ogt a1 a2 | BINARY(LE, a1, a2) -> - elab_comparison Ole a1 a2 + elab_comparison env Ole a1 a2 | BINARY(GE, a1, a2) -> - elab_comparison Oge a1 a2 + elab_comparison env Oge a1 a2 | BINARY(BAND, a1, a2) -> - elab_binary_integer "&" Oand a1 a2 + elab_binary_integer env "&" Oand a1 a2 | BINARY(BOR, a1, a2) -> - elab_binary_integer "|" Oor a1 a2 + elab_binary_integer env "|" Oor a1 a2 | BINARY(XOR, a1, a2) -> - elab_binary_integer "^" Oxor a1 a2 + elab_binary_integer env "^" Oxor a1 a2 (* 6.5.13 and 6.5.14 Logical operator expressions *) | BINARY(AND, a1, a2) -> - elab_logical_operator "&&" Ologand a1 a2 + elab_logical_operator env "&&" Ologand a1 a2 | BINARY(OR, a1, a2) -> - elab_logical_operator "||" Ologor a1 a2 + elab_logical_operator env "||" Ologor a1 a2 (* 6.5.15 Conditional expressions *) | QUESTION(a1, a2, a3) -> @@ -2227,7 +2210,7 @@ let elab_expr ctx loc env a = { edesc = EBinop (Ocomma, b1, b2, ty2); etyp = ty2 },env (* Elaboration of pre- or post- increment/decrement *) - and elab_pre_post_incr_decr op msg a1 = + and elab_pre_post_incr_decr env op msg a1 = let b1,env = elab env a1 in if not (is_modifiable_lvalue env b1) then error "expression is not assignable"; @@ -2236,7 +2219,7 @@ let elab_expr ctx loc env a = { edesc = EUnop(op, b1); etyp = b1.etyp },env (* Elaboration of binary operators over integers *) - and elab_binary_integer msg op a1 a2 = + and elab_binary_integer env msg op a1 a2 = let b1,env = elab env a1 in let b2,env = elab env a2 in if not ((is_integer_type env b1.etyp) && (is_integer_type env b2.etyp)) then @@ -2246,7 +2229,7 @@ let elab_expr ctx loc env a = { edesc = EBinop(op, b1, b2, tyres); etyp = tyres },env (* Elaboration of binary operators over arithmetic types *) - and elab_binary_arithmetic msg op a1 a2 = + and elab_binary_arithmetic env msg op a1 a2 = let b1,env = elab env a1 in let b2,env = elab env a2 in if not ((is_arith_type env b1.etyp) && (is_arith_type env b2.etyp)) then @@ -2256,7 +2239,7 @@ let elab_expr ctx loc env a = { edesc = EBinop(op, b1, b2, tyres); etyp = tyres },env (* Elaboration of shift operators *) - and elab_shift msg op a1 a2 = + and elab_shift env msg op a1 a2 = let b1,env = elab env a1 in let b2,env = elab env a2 in if not ((is_integer_type env b1.etyp) && (is_integer_type env b2.etyp)) then @@ -2266,7 +2249,7 @@ let elab_expr ctx loc env a = { edesc = EBinop(op, b1, b2, tyres); etyp = tyres },env (* Elaboration of comparisons *) - and elab_comparison op a1 a2 = + and elab_comparison env op a1 a2 = let b1,env = elab env a1 in let b2,env = elab env a2 in let resdesc = @@ -2303,7 +2286,7 @@ let elab_expr ctx loc env a = { edesc = resdesc; etyp = TInt(IInt, []) },env (* Elaboration of && and || *) - and elab_logical_operator msg op a1 a2 = + and elab_logical_operator env msg op a1 a2 = let b1,env = elab env a1 in let b2,env = elab env a2 in if not ((is_scalar_type env b1.etyp) && (is_scalar_type env b2.etyp)) then @@ -2371,113 +2354,101 @@ let __func__type_and_init s = (* Elaboration of top-level and local definitions *) -let enter_typedefs loc env sto dl = - if sto <> Storage_default then - error loc "non-default storage class on 'typedef' definition"; - if dl = [] then - warning loc Missing_declarations "typedef requires a name"; - List.fold_left (fun env (s, ty, init) -> - if init <> NO_INIT then - error loc "initializer in typedef"; - if has_std_alignas env ty then - error loc "alignment specified for typedef '%s'" s; - List.iter - (fun a -> match class_of_attribute a with - | Attr_object | Attr_struct -> - error loc "attribute '%s' not allowed in 'typedef'" - (name_of_attribute a) - | _ -> ()) - (attributes_of_type_no_expand ty); - match previous_def Env.lookup_typedef env s with - | Some (s',ty') when Env.in_current_scope env s' -> - if equal_types env ty ty' then begin - warning loc Celeven_extension "redefinition of typedef '%s' is a C11 extension" s; - env - end else begin - error loc "typedef redefinition with different types (%a vs %a)" - (print_typ env) ty (print_typ env) ty'; - env - end - | _ -> - if redef Env.lookup_ident env s then - error loc "redefinition of '%s' as different kind of symbol" s; - let (id, env') = Env.enter_typedef env s ty in - check_reduced_alignment loc env' ty; - emit_elab env loc (Gtypedef(id, ty)); - env') env dl - -let enter_decdefs local nonstatic_inline loc env sto dl = - (* Sanity checks on storage class *) - if (sto = Storage_auto || sto = Storage_register) && not local then - fatal_error loc "illegal storage class %s on file-scoped variable" - (name_of_storage_class sto); - if sto <> Storage_default && dl = [] then - warning loc Missing_declarations "declaration does not declare anything"; - let enter_decdef (decls, env) (s, ty, init) = - let isfun = is_function_type env ty in - if sto = Storage_register && has_std_alignas env ty then - error loc "alignment specified for 'register' object '%s'" s; - if sto = Storage_extern && init <> NO_INIT then - error loc "'extern' declaration variable has an initializer"; - if local && isfun then begin - match sto with - | Storage_static -> - error loc "function declared in block scope cannot have 'static' storage class" - | Storage_auto | Storage_register -> - error loc "illegal storage class %s on function" - (name_of_storage_class sto) - | _ -> () - end; - if is_qualified_array ty then - error loc "type qualifier used in array declarator outside of function prototype"; - (* Local variable declarations with default storage are treated as 'auto'. - Local function declarations with default storage remain with - default storage. *) - let sto1 = - if local && sto = Storage_default && not isfun - then Storage_auto - else sto in - (* enter ident in environment with declared type, because - initializer can refer to the ident *) - let (id, sto', env1, ty, linkage) = - enter_or_refine_ident local loc env s sto1 ty in - if init <> NO_INIT && not local then - add_global_define loc s; - if not isfun && is_void_type env ty then - fatal_error loc "'%s' has incomplete type" s; - (* process the initializer *) - let (ty', init') = elab_initializer loc env1 s ty init in - (* update environment with refined type *) - let env2 = Env.add_ident env1 id sto' ty' in - (* check for incomplete type *) - if not isfun && wrap incomplete_type loc env ty' then - if not local && sto' = Storage_static then begin - warning loc Tentative_incomplete_static "tentative static definition with incomplete type"; - end else if local && sto' <> Storage_extern then - error loc "variable has incomplete type %a" (print_typ env) ty'; - (* check if alignment is reduced *) - check_reduced_alignment loc env ty'; - (* check for static variables in nonstatic inline functions *) - if local && nonstatic_inline - && sto' = Storage_static - && not (List.mem AConst (attributes_of_type env ty')) then - warning loc Static_in_inline "non-constant static local variable '%s' in inline function may be different in different files" s; - if local && not isfun && sto' <> Storage_extern && sto' <> Storage_static then - (* Local definition *) - ((sto', id, ty', init') :: decls, env2) +let enter_typedef loc env sto (s, ty, init) = + if init <> NO_INIT then + error loc "initializer in typedef"; + if has_std_alignas env ty then + error loc "alignment specified for typedef '%s'" s; + List.iter + (fun a -> match class_of_attribute a with + | Attr_object | Attr_struct -> + error loc "attribute '%s' not allowed in 'typedef'" + (name_of_attribute a) + | _ -> ()) + (attributes_of_type_no_expand ty); + match previous_def Env.lookup_typedef env s with + | Some (s',ty') when Env.in_current_scope env s' -> + if equal_types env ty ty' then begin + warning loc Celeven_extension "redefinition of typedef '%s' is a C11 extension" s; + env + end else begin - (* Global definition *) - emit_elab ~linkage env2 loc (Gdecl(sto', id, ty', init')); - (* Make sure the initializer is constant. *) - begin match init' with + error loc "typedef redefinition with different types (%a vs %a)" + (print_typ env) ty (print_typ env) ty'; + env + end + | _ -> + if redef Env.lookup_ident env s then + error loc "redefinition of '%s' as different kind of symbol" s; + let (id, env') = Env.enter_typedef env s ty in + check_reduced_alignment loc env' ty; + emit_elab env loc (Gtypedef(id, ty)); + env' + +let enter_decdef local nonstatic_inline loc sto (decls, env) (s, ty, init) = + let isfun = is_function_type env ty in + if sto = Storage_register && has_std_alignas env ty then + error loc "alignment specified for 'register' object '%s'" s; + if sto = Storage_extern && init <> NO_INIT then + error loc "'extern' declaration variable has an initializer"; + if local && isfun then begin + match sto with + | Storage_static -> + error loc "function declared in block scope cannot have 'static' storage class" + | Storage_auto | Storage_register -> + error loc "illegal storage class %s on function" + (name_of_storage_class sto) + | _ -> () + end; + if is_qualified_array ty then + error loc "type qualifier used in array declarator outside of function prototype"; + (* Local variable declarations with default storage are treated as 'auto'. + Local function declarations with default storage remain with + default storage. *) + let sto1 = + if local && sto = Storage_default && not isfun + then Storage_auto + else sto in + (* enter ident in environment with declared type, because + initializer can refer to the ident *) + let (id, sto', env1, ty, linkage) = + enter_or_refine_ident local loc env s sto1 ty in + if init <> NO_INIT && not local then + add_global_define loc s; + if not isfun && is_void_type env ty then + fatal_error loc "'%s' has incomplete type" s; + (* process the initializer *) + let (ty', init') = elab_initializer loc env1 s ty init in + (* update environment with refined type *) + let env2 = Env.add_ident env1 id sto' ty' in + (* check for incomplete type *) + if not isfun && wrap incomplete_type loc env ty' then + if not local && sto' = Storage_static then begin + warning loc Tentative_incomplete_static "tentative static definition with incomplete type"; + end + else if local && sto' <> Storage_extern then + error loc "variable has incomplete type %a" (print_typ env) ty'; + (* check if alignment is reduced *) + check_reduced_alignment loc env ty'; + (* check for static variables in nonstatic inline functions *) + if local && nonstatic_inline + && sto' = Storage_static + && not (List.mem AConst (attributes_of_type env ty')) then + warning loc Static_in_inline "non-constant static local variable '%s' in inline function may be different in different files" s; + if local && not isfun && sto' <> Storage_extern && sto' <> Storage_static then + (* Local definition *) + ((sto', id, ty', init') :: decls, env2) + else begin + (* Global definition *) + emit_elab ~linkage env2 loc (Gdecl(sto', id, ty', init')); + (* Make sure the initializer is constant. *) + begin match init' with | Some i when not (Ceval.is_constant_init env2 i) -> - error loc "initializer is not a compile-time constant" + error loc "initializer is not a compile-time constant" | _ -> () - end; - (decls, env2) - end in - let (decls, env') = List.fold_left enter_decdef ([], env) dl in - (List.rev decls, env') + end; + (decls, env2) + end (* Processing of K&R-style function definitions. Synopsis: T f(X1, ..., Xn) @@ -2661,7 +2632,7 @@ let elab_fundef genv spec name defs body loc = For prototyped functions this has been done by [elab_fundef_name] already, but some parameter may have been shadowed by the function name, while it should be the other way around, e.g. - [int f(int f) { return f+1; }], with [f] refering to the + [int f(int f) { return f+1; }], with [f] referring to the parameter [f] and not to the function [f] within the body of the function. *) let lenv = @@ -2733,6 +2704,51 @@ let elab_fundef genv spec name defs body loc = genv (* Definitions *) +let elab_decdef (for_loop: bool) (local: bool) (nonstatic_inline: bool) + (env: Env.t) ((spec, namelist): Cabs.init_name_group) + (loc: Cabs.cabsloc) : decl list * Env.t = + let (sto, inl, noret, tydef, bty, env') = + elab_specifier ~only:(namelist=[]) loc env spec in + (* Sanity checks on storage class *) + if tydef then begin + if sto <> Storage_default then + error loc "non-default storage class on 'typedef' definition"; + if namelist = [] then + warning loc Missing_declarations "typedef requires a name"; + end else begin + if (sto = Storage_auto || sto = Storage_register) && not local then + fatal_error loc "illegal storage class %s on file-scoped variable" + (name_of_storage_class sto); + if sto <> Storage_default && namelist = [] then + warning loc Missing_declarations "declaration does not declare anything"; + end; + let elab_one_name (decls, env) (Init_name (Name (id, decl, attr, loc), init)) = + let ((ty, _), env1) = + elab_type_declarator loc env bty decl in + let a = elab_attributes env attr in + let has_fun_typ = is_function_type env ty in + if for_loop && (has_fun_typ || sto = Storage_extern || sto = Storage_static || tydef) then + error loc "declaration of non-local variable in 'for' loop" ; + if has_fun_typ then begin + if noret then + warning loc Celeven_extension "_Noreturn functions are a C11 extension"; + end else begin + if inl then + error loc "'inline' can only appear on functions"; + if noret then + error loc "'_Noreturn' can only appear on functions"; + end; + let a' = if noret then add_attributes [Attr ("noreturn", [])] a else a in + if has_std_alignas env ty && has_fun_typ then + error loc "alignment specified for function '%s'" id; + let decl = (id, add_attributes_type a' ty, init) in + if tydef then + (decls, enter_typedef loc env1 sto decl) + else + enter_decdef local nonstatic_inline loc sto (decls, env1) decl + in + let (decls, env') = List.fold_left elab_one_name ([],env') namelist in + (List.rev decls, env') let elab_definition (for_loop: bool) (local: bool) (nonstatic_inline: bool) (env: Env.t) (def: Cabs.definition) @@ -2747,18 +2763,7 @@ let elab_definition (for_loop: bool) (local: bool) (nonstatic_inline: bool) (* "int x = 12, y[10], *z" *) | DECDEF(init_name_group, loc) -> - let ((dl, env1), sto, tydef) = - elab_init_name_group loc env init_name_group in - if for_loop then begin - let fun_declaration = List.exists (fun (_, ty, _) -> is_function_type env ty) dl in - if fun_declaration || sto = Storage_extern || sto = Storage_static || tydef then - error loc "declaration of non-local variable in 'for' loop" ; - end; - if tydef then - let env2 = enter_typedefs loc env1 sto dl - in ([], env2) - else - enter_decdefs local nonstatic_inline loc env1 sto dl + elab_decdef for_loop local nonstatic_inline env init_name_group loc (* pragma *) | PRAGMA(s, loc) -> @@ -2885,48 +2890,49 @@ let rec elab_stmt env ctx s = (* 6.8.4 Conditional statements *) | If(a, s1, s2, loc) -> - let a',env = elab_expr ctx loc env a in - if not (is_scalar_type env a'.etyp) then + let a',env' = elab_expr ctx loc (Env.new_scope env) a in + if not (is_scalar_type env' a'.etyp) then error loc "controlling expression of 'if' does not have scalar type (%a invalid)" - (print_typ env) a'.etyp; - let s1',env = elab_stmt env ctx s1 in - let s2',env = + (print_typ env') a'.etyp; + let s1' = elab_stmt_new_scope env' ctx s1 in + let s2' = match s2 with - | None -> sskip,env - | Some s2 -> elab_stmt env ctx s2 + | None -> sskip + | Some s2 -> elab_stmt_new_scope env' ctx s2 in { sdesc = Sif(a', s1', s2'); sloc = elab_loc loc },env (* 6.8.5 Iterative statements *) | WHILE(a, s1, loc) -> - let a',env = elab_expr ctx loc env a in - if not (is_scalar_type env a'.etyp) then + let a',env' = elab_expr ctx loc (Env.new_scope env) a in + if not (is_scalar_type env' a'.etyp) then error loc "controlling expression of 'while' does not have scalar type (%a invalid)" - (print_typ env) a'.etyp; - let s1',env = elab_stmt env (ctx_loop ctx) s1 in + (print_typ env') a'.etyp; + let s1' = elab_stmt_new_scope env' (ctx_loop ctx) s1 in { sdesc = Swhile(a', s1'); sloc = elab_loc loc },env | DOWHILE(a, s1, loc) -> - let s1',env = elab_stmt env (ctx_loop ctx) s1 in - let a',env = elab_expr ctx loc env a in - if not (is_scalar_type env a'.etyp) then + let s1' = elab_stmt_new_scope env (ctx_loop ctx) s1 in + let a',env' = elab_expr ctx loc (Env.new_scope env) a in + if not (is_scalar_type env' a'.etyp) then error loc "controlling expression of 'while' does not have scalar type (%a invalid)" - (print_typ env) a'.etyp; + (print_typ env') a'.etyp; { sdesc = Sdowhile(s1', a'); sloc = elab_loc loc },env | FOR(fc, a2, a3, s1, loc) -> + let env' = Env.new_scope env in let (a1', env_decls, decls') = match fc with | Some (FC_EXP a1) -> - let a1,env = elab_for_expr ctx loc env (Some a1) in + let a1,env = elab_for_expr ctx loc env' (Some a1) in (a1, env, None) | None -> - let a1,env = elab_for_expr ctx loc env None in + let a1,env = elab_for_expr ctx loc env' None in (a1, env, None) | Some (FC_DECL def) -> let (dcl, env') = elab_definition true true ctx.ctx_nonstatic_inline - (Env.new_scope env) def in + env' def in let loc = elab_loc (Cabshelper.get_definitionloc def) in (sskip, env', Some(List.map (fun d -> {sdesc = Sdecl d; sloc = loc}) dcl)) in @@ -2938,7 +2944,7 @@ let rec elab_stmt env ctx s = if not (is_scalar_type env_test a2'.etyp) then error loc "controlling expression of 'for' does not have scalar type (%a invalid)" (print_typ env) a2'.etyp; let a3',env_for = elab_for_expr ctx loc env_test a3 in - let s1',env_body = elab_stmt env_for (ctx_loop ctx) s1 in + let s1' = elab_stmt_new_scope env_for (ctx_loop ctx) s1 in let sfor = { sdesc = Sfor(a1', a2', a3', s1'); sloc = elab_loc loc } in begin match decls' with | None -> sfor,env @@ -2947,11 +2953,11 @@ let rec elab_stmt env ctx s = (* 6.8.4 Switch statement *) | SWITCH(a, s1, loc) -> - let a',env = elab_expr ctx loc env a in - if not (is_integer_type env a'.etyp) then + let a',env' = elab_expr ctx loc (Env.new_scope env) a in + if not (is_integer_type env' a'.etyp) then error loc "controlling expression of 'switch' does not have integer type (%a invalid)" - (print_typ env) a'.etyp; - let s1',env = elab_stmt env (ctx_switch ctx) s1 in + (print_typ env') a'.etyp; + let s1' = elab_stmt_new_scope env' (ctx_switch ctx) s1 in check_switch_cases s1'; { sdesc = Sswitch(a', s1'); sloc = elab_loc loc },env @@ -3025,6 +3031,10 @@ let rec elab_stmt env ctx s = | DEFINITION def -> error (Cabshelper.get_definitionloc def) "ill-placed definition"; sskip,env +(* Elaborate a statement as a block whose scope is a strict subset of the scope + of its enclosing block. *) +and elab_stmt_new_scope env ctx s = + fst (elab_stmt (Env.new_scope env) ctx s) and elab_block loc env ctx b = let b',_ = elab_block_body (Env.new_scope env) ctx b in diff --git a/cparser/Lexer.mll b/cparser/Lexer.mll index b2a668f0..7cf22eef 100644 --- a/cparser/Lexer.mll +++ b/cparser/Lexer.mll @@ -23,11 +23,18 @@ module SSet = Set.Make(String) let lexicon : (string, Cabs.cabsloc -> token) Hashtbl.t = Hashtbl.create 17 let ignored_keywords : SSet.t ref = ref SSet.empty +let reserved_keyword loc id = + Diagnostics.fatal_error (loc.Cabs.filename, loc.Cabs.lineno) + "illegal use of reserved keyword `%s'" id + let () = List.iter (fun (key, builder) -> Hashtbl.add lexicon key builder) - [ ("_Alignas", fun loc -> ALIGNAS loc); + [ + ("_Alignas", fun loc -> ALIGNAS loc); ("_Alignof", fun loc -> ALIGNOF loc); ("_Bool", fun loc -> UNDERSCORE_BOOL loc); + ("_Complex", fun loc -> reserved_keyword loc "_Complex"); + ("_Imaginary", fun loc -> reserved_keyword loc "_Imaginary"); ("__alignof", fun loc -> ALIGNOF loc); ("__alignof__", fun loc -> ALIGNOF loc); ("__asm", fun loc -> ASM loc); diff --git a/cparser/Unblock.ml b/cparser/Unblock.ml index da8049a5..66b497cc 100644 --- a/cparser/Unblock.ml +++ b/cparser/Unblock.ml @@ -340,7 +340,6 @@ and unblock_block env ctx ploc = function let unblock_fundef env f = local_variables := []; - next_scope_id := 0; curr_fun_id:= f.fd_name.stamp; (* TODO: register the parameters as being declared in function scope *) let body = unblock_stmt env [] no_loc f.fd_body in @@ -398,5 +397,6 @@ let rec unblock_glob env accu = function (* Entry point *) let program p = + next_scope_id := 0; {gloc = no_loc; gdesc = Gdecl(Storage_extern, debug_id, debug_ty, None)} :: unblock_glob (Builtins.environment()) [] p diff --git a/cparser/handcrafted.messages b/cparser/handcrafted.messages index 95077739..6d972439 100644 --- a/cparser/handcrafted.messages +++ b/cparser/handcrafted.messages @@ -4477,7 +4477,7 @@ translation_unit_file: VOID PRE_NAME TYPEDEF_NAME PACKED LPAREN CONSTANT RPAREN ## # We have just parsed a list of attribute specifiers, but we cannot -# print it because it is not available. We do not know wether it is +# print it because it is not available. We do not know whether it is # part of the declaration or whether it is part of the first K&R parameter # declaration. @@ -4599,7 +4599,7 @@ translation_unit_file: PACKED LPAREN BUILTIN_OFFSETOF XOR_ASSIGN ## Ill-formed __builtin_offsetof. -At this point, an opening paranthesis '(' is expected. +At this point, an opening parenthesis '(' is expected. #------------------------------------------------------------------------------ diff --git a/debug/Debug.ml b/debug/Debug.ml index 168df5a0..812f57cc 100644 --- a/debug/Debug.ml +++ b/debug/Debug.ml @@ -47,7 +47,7 @@ type implem = exists_section: section_name -> bool; remove_unused: ident -> unit; remove_unused_function: ident -> unit; - variable_printed: string -> unit; + symbol_printed: string -> unit; add_diab_info: section_name -> int -> int -> int -> unit; } @@ -79,7 +79,7 @@ let default_implem = exists_section = (fun _ -> true); remove_unused = (fun _ -> ()); remove_unused_function = (fun _ -> ()); - variable_printed = (fun _ -> ()); + symbol_printed = (fun _ -> ()); add_diab_info = (fun _ _ _ _ -> ()); } @@ -111,5 +111,5 @@ let compute_diab_file_enum end_l entry_l line_e = !implem.compute_diab_file_enum let compute_gnu_file_enum f = !implem.compute_gnu_file_enum f let remove_unused ident = !implem.remove_unused ident let remove_unused_function ident = !implem.remove_unused_function ident -let variable_printed ident = !implem.variable_printed ident +let symbol_printed ident = !implem.symbol_printed ident let add_diab_info sec line_start debug_info low_pc = !implem.add_diab_info sec line_start debug_info low_pc diff --git a/debug/Debug.mli b/debug/Debug.mli index 3869a056..60e2f9bc 100644 --- a/debug/Debug.mli +++ b/debug/Debug.mli @@ -46,7 +46,7 @@ type implem = exists_section: section_name -> bool; remove_unused: ident -> unit; remove_unused_function: ident -> unit; - variable_printed: string -> unit; + symbol_printed: string -> unit; add_diab_info: section_name -> int -> int -> int -> unit; } @@ -80,5 +80,5 @@ val compute_gnu_file_enum: (string -> unit) -> unit val exists_section: section_name -> bool val remove_unused: ident -> unit val remove_unused_function: ident -> unit -val variable_printed: string -> unit +val symbol_printed: string -> unit val add_diab_info: section_name -> int -> int -> int -> unit diff --git a/debug/DebugInformation.ml b/debug/DebugInformation.ml index e3f5d98e..3498a779 100644 --- a/debug/DebugInformation.ml +++ b/debug/DebugInformation.ml @@ -223,7 +223,7 @@ let name_to_definition: (string,int) Hashtbl.t = Hashtbl.create 7 (* Mapping from atom to debug id *) let atom_to_definition: (atom, int) Hashtbl.t = Hashtbl.create 7 -(* Various lookup functions for defintions *) +(* Various lookup functions for definitions *) let find_gvar_stamp id = let id = (Hashtbl.find stamp_to_definition id) in let var = Hashtbl.find definitions id in @@ -342,7 +342,7 @@ let insert_global_declaration env dec = replace_var id ({var with gvar_declaration = false;}) end end else begin - (* Implict declarations need special handling *) + (* Implicit declarations need special handling *) let id' = try Hashtbl.find name_to_definition id.name with Not_found -> let id' = next_id () in Hashtbl.add name_to_definition id.name id';id' in @@ -553,7 +553,10 @@ let close_scope atom s_id lbl = | a::rest -> a,rest | _ -> assert false (* We must have an opening scope *) end in - let new_r = ({last_r with end_addr = Some lbl;})::rest in + let new_r = if last_r.start_addr = Some lbl then + rest + else + ({last_r with end_addr = Some lbl;})::rest in Hashtbl.replace scope_ranges s_id new_r with Not_found -> () @@ -632,12 +635,12 @@ let compute_gnu_file_enum f = let all_files_iter f = StringSet.iter f !all_files -let printed_vars: StringSet.t ref = ref StringSet.empty +let printed_symbols: StringSet.t ref = ref StringSet.empty -let is_variable_printed id = StringSet.mem id !printed_vars +let is_symbol_printed id = StringSet.mem id !printed_symbols -let variable_printed id = - printed_vars := StringSet.add id !printed_vars +let symbol_printed id = + printed_symbols := StringSet.add id !printed_symbols let init name = id := 0; @@ -660,7 +663,7 @@ let init name = Hashtbl.reset scope_ranges; Hashtbl.reset label_translation; all_files := StringSet.singleton name; - printed_vars := StringSet.empty + printed_symbols := StringSet.empty let default_debug = { @@ -690,6 +693,6 @@ let default_debug = exists_section = exists_section; remove_unused = remove_unused; remove_unused_function = remove_unused_function; - variable_printed = variable_printed; + symbol_printed = symbol_printed; add_diab_info = (fun _ _ _ _ -> ()); } diff --git a/debug/DebugInformation.mli b/debug/DebugInformation.mli index 8905d8bf..0cf34756 100644 --- a/debug/DebugInformation.mli +++ b/debug/DebugInformation.mli @@ -23,7 +23,7 @@ val get_type: int -> debug_types val fold_types: (int -> debug_types -> 'a -> 'a) -> 'a -> 'a -val is_variable_printed: string -> bool +val is_symbol_printed: string -> bool val variable_location: atom -> atom -> var_location diff --git a/debug/DwarfPrinter.ml b/debug/DwarfPrinter.ml index a45fff0c..bbfcf311 100644 --- a/debug/DwarfPrinter.ml +++ b/debug/DwarfPrinter.ml @@ -241,9 +241,12 @@ module DwarfPrinter(Target: DWARF_TARGET): let abbrev = !curr_abbrev in incr curr_abbrev;abbrev - (* Mapping from abbreviation string to abbreviaton id *) + (* Mapping from abbreviation string to abbreviation id *) let abbrev_mapping: (string,int) Hashtbl.t = Hashtbl.create 7 + (* Mapping from abbreviation range id to label *) + let range_labels : (int, int) Hashtbl.t = Hashtbl.create 7 + (* Look up the id of the abbreviation and add it if it is missing *) let get_abbrev entity has_sibling = let abbrev_string = abbrev_string_of_entity entity has_sibling in @@ -439,8 +442,11 @@ module DwarfPrinter(Target: DWARF_TARGET): | Pc_pair (l,h) -> print_addr oc "DW_AT_low_pc" l; print_addr oc "DW_AT_high_pc" h - | Offset i -> fprintf oc " .4byte %a+0x%d%a\n" - label !debug_ranges_addr i print_comment "DW_AT_ranges" + | Offset i -> + let lbl = new_label () in + Hashtbl.add range_labels i lbl; + fprintf oc " .4byte %a%a\n" + label lbl print_comment "DW_AT_ranges" | _ -> () let print_compilation_unit oc tag = @@ -641,14 +647,23 @@ module DwarfPrinter(Target: DWARF_TARGET): end let print_ranges oc r = + let print_range_entry = function + | AddressRange l -> + List.iter (fun (b,e) -> + fprintf oc " %s %a\n" address label b; + fprintf oc " %s %a\n" address label e) l; + | OffsetRange (start, l) -> + List.iter (fun (b,e) -> + fprintf oc " %s %a-%a\n" address label b label start; + fprintf oc " %s %a-%a\n" address label e label start) l + in section oc Section_debug_ranges; print_label oc !debug_ranges_addr; - List.iter (fun l -> - List.iter (fun (b,e) -> - fprintf oc " %s %a\n" address label b; - fprintf oc " %s %a\n" address label e) l; - fprintf oc " %s 0\n" address; - fprintf oc " %s 0\n" address) r + List.iter (fun (lbl,l) -> + print_label oc (Hashtbl.find range_labels lbl); + print_range_entry l; + fprintf oc " %s 0\n" address; + fprintf oc " %s 0\n" address) r let print_gnu_entries oc cp (lpc,loc) s r = compute_abbrev cp; @@ -679,6 +694,7 @@ module DwarfPrinter(Target: DWARF_TARGET): (* Print the debug info and abbrev section *) let print_debug oc debug = Hashtbl.clear abbrev_mapping; + Hashtbl.clear range_labels; Hashtbl.clear loc_labels; match debug with | Diab entries -> print_diab_entries oc entries diff --git a/debug/DwarfTypes.mli b/debug/DwarfTypes.mli index 23aba448..5a2bce3b 100644 --- a/debug/DwarfTypes.mli +++ b/debug/DwarfTypes.mli @@ -272,9 +272,11 @@ type location_entry = } type dw_locations = constant option * location_entry list -type range_entry = (address * address) list +type range_entry = + | AddressRange of (address * address) list + | OffsetRange of reference * (address * address) list -type dw_ranges = range_entry list +type dw_ranges = (int * range_entry) list type dw_string = (int * string) list diff --git a/debug/Dwarfgen.ml b/debug/Dwarfgen.ml index ee568042..e1b71f13 100644 --- a/debug/Dwarfgen.ml +++ b/debug/Dwarfgen.ml @@ -72,7 +72,9 @@ let up_locs acc loc = {acc with locs = loc@acc.locs;} let up_ranges acc r = - {acc with ranges = r;} + let off, old_r = acc.ranges in + let new_r = (off +1 ), (off, r):: old_r in + (Offset off), {acc with ranges = new_r;} let empty_accu = { @@ -90,6 +92,8 @@ module Dwarfgenaux (Target: TARGET) = let subrange_type : int option ref = ref None + let current_section_start : int option ref = ref None + let encoding_of_ikind = function | IBool -> DW_ATE_boolean | IChar -> @@ -340,7 +344,7 @@ module Dwarfgenaux (Target: TARGET) = let global_variable_to_entry acc id v = let loc = match v.gvar_atom with - | Some a when is_variable_printed (extern_atom a) -> + | Some a when is_symbol_printed (extern_atom a) -> Some (LocSymbol a) | _ -> None in let var = { @@ -424,7 +428,7 @@ module Dwarfgenaux (Target: TARGET) = let acc = up_locs (up_typs acc p.formal_parameter_type) loc_list in new_entry (next_id ()) (DW_TAG_formal_parameter p),acc - let scope_range f_id id (o,dwr) = + let scope_range f_id id acc = try let r = get_scope_ranges id in let lbl l h = match l,h with @@ -435,19 +439,22 @@ module Dwarfgenaux (Target: TARGET) = | _ -> raise Not_found in begin match r with - | [] -> Empty,(o,dwr) + | [] -> Empty,acc | [a] -> let l,h = lbl a.start_addr a.end_addr in - Pc_pair (l,h),(o,dwr) + Pc_pair (l,h), acc | a::rest -> if !Clflags.option_gdwarf > 2 then let r = List.map (fun e -> lbl e.start_addr e.end_addr) r in - (Offset o), (o + 2 + 4 * (List.length r),r::dwr) - else + let r = match !current_section_start with + | None -> AddressRange r + | Some s -> OffsetRange (s, r) in + up_ranges acc r + else let l,h = lbl (List.hd (List.rev rest)).start_addr a.end_addr in - Pc_pair (l,h),(o,dwr) + Pc_pair (l,h), acc end - with Not_found -> Empty,(o,dwr) + with Not_found -> Empty, acc let rec local_variable_to_entry f_id acc v id = match v.lvar_atom with @@ -466,11 +473,10 @@ module Dwarfgenaux (Target: TARGET) = Some (new_entry id (DW_TAG_variable var)),acc and scope_to_entry f_id acc sc id = - let r,dwr = scope_range f_id id acc.ranges in + let r, acc = scope_range f_id id acc in let scope = { lexical_block_range = r; } in - let acc = up_ranges acc dwr in let vars,acc = mmap_opt (local_to_entry f_id) acc sc.scope_variables in let entry = new_entry id (DW_TAG_lexical_block scope) in add_children entry vars,acc @@ -490,7 +496,7 @@ module Dwarfgenaux (Target: TARGET) = | Scope sc -> mmap_opt (local_to_entry f_id) acc sc.scope_variables | _ -> assert false) - let function_to_entry acc id f = + let function_to_entry sec_name acc id f = let r = match f.fun_low_pc, f.fun_high_pc with | Some l,Some h -> Pc_pair (l,h) | _ -> Empty in @@ -503,8 +509,13 @@ module Dwarfgenaux (Target: TARGET) = subprogram_range = r; } in let f_id = get_opt_val f.fun_atom in + let start_sec = + try + Some (section_start (sec_name f_id)) + with Not_found -> None in + current_section_start := start_sec; let acc = match f.fun_return_type with Some s -> up_typs acc s | None -> acc in - let f_entry = new_entry id (DW_TAG_subprogram f_tag) in + let f_entry = new_entry id (DW_TAG_subprogram f_tag) in let children,acc = if !Clflags.option_gdepth > 1 then let params,acc = mmap (function_parameter_to_entry f_id) acc f.fun_parameter in @@ -514,10 +525,14 @@ module Dwarfgenaux (Target: TARGET) = [],acc in add_children f_entry (children),acc - let definition_to_entry acc id t = + let definition_to_entry sec_name acc id t = match t with - | GlobalVariable g -> global_variable_to_entry acc id g - | Function f -> function_to_entry acc id f + | GlobalVariable g -> Some (global_variable_to_entry acc id g) + | Function f -> + if is_symbol_printed f.fun_name then + Some (function_to_entry sec_name acc id f) + else + None end @@ -529,20 +544,21 @@ let diab_file_loc sec (f,l) = let prod_name = let version_string = if Version.buildnr <> "" && Version.tag <> "" then - Printf.sprintf "%s, Build: %s, Tag: %s" Version.version Version.buildnr Version.tag + Printf.sprintf "Release: %s, Build: %s, Tag: %s" Version.version Version.buildnr Version.tag else Version.version in Printf.sprintf "AbsInt Angewandte Informatik GmbH:CompCert Version %s:(%s,%s,%s,%s)" version_string Configuration.arch Configuration.system Configuration.abi Configuration.model -let diab_gen_compilation_section s defs acc = +let diab_gen_compilation_section sec_name s defs acc = let module Gen = Dwarfgenaux(struct let file_loc = diab_file_loc s let string_entry s = Simple_string s end) in let defs,accu = List.fold_left (fun (acc,bcc) (id,t) -> - let t,bcc = Gen.definition_to_entry bcc id t in - t::acc,bcc) ([],empty_accu) defs in + match Gen.definition_to_entry sec_name bcc id t with + | Some (t,bcc) -> t::acc,bcc + | None -> acc,bcc) ([],empty_accu) defs in let low_pc = section_start s and line_start,debug_start = diab_additional_section s and high_pc = section_end s in @@ -569,7 +585,7 @@ let gen_diab_debug_info sec_name var_section : debug_entries = | Function f -> sec_name (get_opt_val f.fun_atom) in let old = try StringMap.find s acc with Not_found -> [] in StringMap.add s ((id,t)::old) acc) StringMap.empty in - let entries = StringMap.fold diab_gen_compilation_section defs [] in + let entries = StringMap.fold (diab_gen_compilation_section sec_name) defs [] in Diab entries let gnu_file_loc (f,l) = @@ -579,7 +595,7 @@ let string_table: (string,int) Hashtbl.t = Hashtbl.create 7 let gnu_string_entry s = if (String.length s < 4 && Configuration.system <> "macosx") (* macosx needs debug_str *) - || Configuration.system = "cygwin" then (*Cygwin does not use the debug_str seciton*) + || Configuration.system = "cygwin" then (*Cygwin does not use the debug_str section*) Simple_string s else try @@ -592,30 +608,32 @@ let gnu_string_entry s = let gen_gnu_debug_info sec_name var_section : debug_entries = Hashtbl.clear string_table; - let r,dwr,low_pc = - try if !Clflags.option_gdwarf > 3 then + let r,accu,low_pc = + try if !Clflags.option_gdwarf > 2 then let pcs = fold_section_start (fun s low acc -> (low,section_end s)::acc) [] in match pcs with - | [] -> Empty,(0,[]),None - | [(l,h)] -> Pc_pair (l,h),(0,[]),Some l - | _ -> Offset 0,(2 + 4 * (List.length pcs),[pcs]),None + | [] -> Empty, empty_accu, None + | [(l,h)] -> Pc_pair (l,h), empty_accu, Some l + | _ -> + let off, acc = up_ranges empty_accu (AddressRange pcs) in + off, acc, None else let l = section_start ".text" and h = section_end ".text" in - Pc_pair(l,h),(0,[]),Some l - with Not_found -> Empty,(0,[]),None in - let accu = up_ranges empty_accu dwr in + Pc_pair(l,h), empty_accu,Some l + with Not_found -> Empty ,empty_accu, None in let module Gen = Dwarfgenaux (struct let file_loc = gnu_file_loc let string_entry = gnu_string_entry end) in - let defs,accu,sec = fold_definitions (fun id t (acc,bcc,sec) -> + let defs,accu,sec = fold_definitions (fun id t (acc,bcc,sec) -> let s = match t with | GlobalVariable _ -> var_section | Function f -> sec_name (get_opt_val f.fun_atom) in - let t,bcc = Gen.definition_to_entry bcc id t in - t::acc,bcc,StringSet.add s sec) ([],accu,StringSet.empty) in + match Gen.definition_to_entry sec_name bcc id t with + | Some (t,bcc) -> t::acc,bcc,StringSet.add s sec + | None -> acc, bcc, sec) ([],accu,StringSet.empty) in let types = Gen.gen_types accu.typs in let cp = { compile_unit_name = gnu_string_entry !file_name; diff --git a/doc/ccomp.1 b/doc/ccomp.1 index 374bd2e7..7ccf97c8 100644 --- a/doc/ccomp.1 +++ b/doc/ccomp.1 @@ -180,6 +180,12 @@ Set alignment of function entry points to <n> bytes. The default alignment is 16 bytes for x86 targets and 4 bytes for ARM and PowerPC. . .TP +.BR \-fcommon ", " \-fno\-common +Turn on/off placement of global variables defined without an initializer (tentative definitions) in the common section. +Disabling the use of the common section inhibits merging of tentative definitions by the linker and may lead to multiple-definition errors. +Enabled by default. +. +.TP .BR \-ffpu ", " \-fno\-fpu Turn on/off use of FP registers for some integer operations. Enabled by default. @@ -191,12 +197,12 @@ Code Generation Options (PowerPC) .TP .B \-falign\-branch\-targets <n> Set alignment of branch targets to <n> bytes. -The default alignment is 0 bytes, which deactivates alignment of branch targets. +By default alignment of branch targets is deactivated. . .TP .B \-falign\-cond\-branches <n> -Set alignment of conditional branches to <n> bytes. -The default alignment is 0 bytes, which deactivates alignment of conditional branch targets. +Set alignment of conditional branch instructions to <n> bytes. +By default alignment of conditional branches is deactivated. . .SS Code Generation Options (PowerPC with Diab Backend) @@ -424,7 +430,7 @@ Wrong return type for main. Enabled by default. .sp \fImissing\-declarations\fP: -Declations which do not declare anything. +Declarations which do not declare anything. Enabled by default. .sp \fIpointer\-type\-mismatch\fP: diff --git a/driver/Clflags.ml b/driver/Clflags.ml index 651d644e..00bbc4d5 100644 --- a/driver/Clflags.ml +++ b/driver/Clflags.ml @@ -29,10 +29,13 @@ let option_fcse = ref true let option_fredundancy = ref true let option_fpostpass = ref true let option_fpostpass_sched = ref "list" +let option_fifconversion = ref true +let option_ffavor_branchless = ref false let option_falignfunctions = ref (None: int option) let option_falignbranchtargets = ref 0 let option_faligncondbranchs = ref 0 let option_finline_asm = ref false +let option_fcommon = ref true let option_mthumb = ref (Configuration.model = "armv7m") let option_Osize = ref false let option_finline = ref true diff --git a/driver/Commandline.ml b/driver/Commandline.ml index 75ca1683..672ed834 100644 --- a/driver/Commandline.ml +++ b/driver/Commandline.ml @@ -16,7 +16,6 @@ (* Parsing of command-line flags and arguments *) open Printf -open Responsefile type pattern = | Exact of string @@ -114,14 +113,15 @@ let parse_array spec argv first last = end in parse first -let argv : string array ref = ref [||] +let argv = + try + Responsefile.expandargv Sys.argv + with Responsefile.Error msg | Sys_error msg -> + eprintf "Error while processing the command line: %s\n" msg; + exit 2 let parse_cmdline spec = - try - argv := expandargv Sys.argv; - parse_array spec !argv 1 (Array.length !argv - 1) - with Responsefile.Error s -> - raise (CmdError s) + parse_array spec argv 1 (Array.length argv - 1) let long_int_action key s = let ls = String.length s diff --git a/driver/Commandline.mli b/driver/Commandline.mli index e1b917f2..8bb6f18f 100644 --- a/driver/Commandline.mli +++ b/driver/Commandline.mli @@ -39,11 +39,11 @@ type action = patterns are tried in the order in which they appear in the list. *) exception CmdError of string -(** Raise by [parse_cmdline] when an error occured *) +(** Raise by [parse_cmdline] when an error occurred *) val parse_cmdline: (pattern * action) list -> unit -(** [parse_cmdline actions] parses the commandline and performs all [actions]. - Raises [CmdError] if an error occurred. +(** [parse_cmdline actions] parses the command line (after @-file expansion) + and performs all [actions]. Raises [CmdError] if an error occurred. *) val longopt_int: string -> (int -> unit) -> pattern * action @@ -51,5 +51,5 @@ val longopt_int: string -> (int -> unit) -> pattern * action options of the form [key=<n>] and calls [fn] with the integer argument *) -val argv: string array ref +val argv: string array (** [argv] contains the complete command line after @-file expandsion *) diff --git a/driver/CommonOptions.ml b/driver/CommonOptions.ml index 58dd4007..c151ecf2 100644 --- a/driver/CommonOptions.ml +++ b/driver/CommonOptions.ml @@ -14,9 +14,9 @@ open Clflags open Commandline (* The version string for [tool_name] *) -let version_string tool_name= +let version_string tool_name = if Version.buildnr <> "" && Version.tag <> "" then - Printf.sprintf "The CompCert %s, %s, Build: %s, Tag: %s\n" tool_name Version.version Version.buildnr Version.tag + Printf.sprintf "The CompCert %s, Release: %s, Build: %s, Tag: %s\n" tool_name Version.version Version.buildnr Version.tag else Printf.sprintf "The CompCert %s, version %s\n" tool_name Version.version diff --git a/driver/Configuration.ml b/driver/Configuration.ml index eae3aaab..dcd0d60b 100644 --- a/driver/Configuration.ml +++ b/driver/Configuration.ml @@ -13,11 +13,11 @@ open Printf let search_argv key = - let len = Array.length Sys.argv in + let len = Array.length Commandline.argv in let res: string option ref = ref None in for i = 1 to len - 2 do - if Sys.argv.(i) = key then - res := Some Sys.argv.(i + 1); + if Commandline.argv.(i) = key then + res := Some Commandline.argv.(i + 1); done; !res diff --git a/driver/Driver.ml b/driver/Driver.ml index 74e7ae77..404271cd 100644 --- a/driver/Driver.ml +++ b/driver/Driver.ml @@ -199,6 +199,9 @@ Processing options: -finline Perform inlining of functions [on] -finline-functions-called-once Integrate functions only required by their single caller [on] + -fif-conversion Perform if-conversion (generation of conditional moves) [on] + -ffavor-branchless Favor the generation of branch-free instruction sequences, + even when possibly more costly than the default [off] Code generation options: (use -fno-<opt> to turn off -f<opt>) -ffpu Use FP registers for some integer operations [on] -fsmall-data <n> Set maximal size <n> for allocation in small data area @@ -206,6 +209,7 @@ Code generation options: (use -fno-<opt> to turn off -f<opt>) -falign-functions <n> Set alignment (in bytes) of function entry points -falign-branch-targets <n> Set alignment (in bytes) of branch targets -falign-cond-branches <n> Set alignment (in bytes) of conditional branches + -fcommon Put uninitialized globals in the common section [on]. |} ^ target_help ^ toolchain_help ^ @@ -252,7 +256,8 @@ let dump_mnemonics destfile = exit 0 let optimization_options = [ - option_ftailcalls; option_fconstprop; option_fcse; option_fredundancy; option_fpostpass; option_finline_functions_called_once; + option_ftailcalls; option_fifconversion; option_fconstprop; option_fcse; + option_fpostpass; option_fredundancy; option_finline_functions_called_once; ] let set_all opts () = List.iter (fun r -> r := true) opts @@ -269,6 +274,10 @@ let cmdline_actions = [Exact("-f" ^ name ^ "="), String (fun s -> (strref := (if s == "" then "list" else s)); ref := true) ] in + let check_align n = + if n <= 0 || ((n land (n - 1)) <> 0) then + error no_loc "requested alignment %d is not a power of 2" n + in [ (* Getting help *) Exact "-help", Unit print_usage_and_exit; @@ -303,10 +312,12 @@ let cmdline_actions = Exact "-Os", Set option_Osize; Exact "-fsmall-data", Integer(fun n -> option_small_data := n); Exact "-fsmall-const", Integer(fun n -> option_small_const := n); - Exact "-ffloat-const-prop", Integer(fun n -> option_ffloatconstprop := n); - Exact "-falign-functions", Integer(fun n -> option_falignfunctions := Some n); - Exact "-falign-branch-targets", Integer(fun n -> option_falignbranchtargets := n); - Exact "-falign-cond-branches", Integer(fun n -> option_faligncondbranchs := n);] @ + Exact "-ffloat-const-prop", Integer(fun n -> option_ffloatconstprop := n); + Exact "-ffavor-branchless", Set option_ffavor_branchless; + Exact "-falign-functions", Integer(fun n -> check_align n; option_falignfunctions := Some n); + Exact "-falign-branch-targets", Integer(fun n -> check_align n; option_falignbranchtargets := n); + Exact "-falign-cond-branches", Integer(fun n -> check_align n; option_faligncondbranchs := n);] @ + f_opt "common" option_fcommon @ (* Target processor options *) (if Configuration.arch = "arm" then if Configuration.model = "armv6" then @@ -365,6 +376,7 @@ let cmdline_actions = (* Optimization options *) (* -f options: come in -f and -fno- variants *) @ f_opt "tailcalls" option_ftailcalls + @ f_opt "if-conversion" option_fifconversion @ f_opt "const-prop" option_fconstprop @ f_opt "cse" option_fcse @ f_opt "redundancy" option_fredundancy diff --git a/driver/Frontend.ml b/driver/Frontend.ml index b29bb7f3..d7162865 100644 --- a/driver/Frontend.ml +++ b/driver/Frontend.ml @@ -11,21 +11,43 @@ (* *) (* *********************************************************************) +open Printf open Clflags open Commandline open Driveraux (* Common frontend functions between clightgen and ccomp *) +(* Split the version number into major.minor *) + +let re_version = Str.regexp {|\([0-9]+\)\.\([0-9]+\)|} + +let (v_major, v_minor) = + let get n = int_of_string (Str.matched_group n Version.version) in + assert (Str.string_match re_version Version.version 0); + (get 1, get 2) + +let v_number = + assert (v_minor < 100); + 100 * v_major + v_minor + +(* Predefined macros: version numbers, C11 features *) + let predefined_macros = - [ + let macros = [ "-D__COMPCERT__"; + sprintf "-D__COMPCERT_MAJOR__=%d" v_major; + sprintf "-D__COMPCERT_MINOR__=%d" v_minor; + sprintf "-D__COMPCERT_VERSION__=%d" v_number; "-U__STDC_IEC_559_COMPLEX__"; "-D__STDC_NO_ATOMICS__"; "-D__STDC_NO_COMPLEX__"; "-D__STDC_NO_THREADS__"; "-D__STDC_NO_VLA__" - ] + ] in + if Version.buildnr = "" + then macros + else sprintf "-D__COMPCERT_BUILDNR__=%s" Version.buildnr :: macros (* From C to preprocessed C *) @@ -110,7 +132,7 @@ let gnu_prepro_opt_key key s = let gnu_prepro_opt s = prepro_options := s::!prepro_options -(* Add gnu preprocessor option s and the implict -E *) +(* Add gnu preprocessor option s and the implicit -E *) let gnu_prepro_opt_e s = prepro_options := s :: !prepro_options; option_E := true @@ -150,7 +172,7 @@ let prepro_actions = [ @ (if Configuration.gnu_toolchain then gnu_prepro_actions else []) let gnu_prepro_help = -{| -M Ouput a rule suitable for make describing the +{| -M Output a rule suitable for make describing the dependencies of the main source file -MM Like -M but do not mention system header files -MF <file> Specifies file <file> as output file for -M or -MM diff --git a/exportclight/Clightnorm.ml b/exportclight/Clightnorm.ml index 4b01d777..a0001250 100644 --- a/exportclight/Clightnorm.ml +++ b/exportclight/Clightnorm.ml @@ -133,7 +133,7 @@ let rec norm_stmt s = add_sequence sl (Sreturn(Some e')) | Sswitch(e, ls) -> let (sl, e') = norm_expr e in - add_sequence sl (Sswitch(e, norm_lbl_stmt ls)) + add_sequence sl (Sswitch(e', norm_lbl_stmt ls)) | Slabel(lbl, s1) -> Slabel(lbl, norm_stmt s1) | Sgoto lbl -> s diff --git a/extraction/extraction.v b/extraction/extraction.v index e2ffd65d..265a5967 100644 --- a/extraction/extraction.v +++ b/extraction/extraction.v @@ -73,6 +73,7 @@ Extract Constant Iteration.GenIter.iterate => (* Selection *) Extract Constant Selection.compile_switch => "Switchaux.compile_switch". +Extract Constant Selection.if_conversion_heuristic => "Selectionaux.if_conversion_heuristic". (* RTLgen *) Extract Constant RTLgen.more_likely => "RTLgenaux.more_likely". @@ -166,11 +167,11 @@ Load extractionMachdep. Extraction Blacklist List String Int. (* Cutting the dependency to R. *) -Extract Inlined Constant Fcore_defs.F2R => "fun _ -> assert false". -Extract Inlined Constant Fappli_IEEE.FF2R => "fun _ -> assert false". -Extract Inlined Constant Fappli_IEEE.B2R => "fun _ -> assert false". -Extract Inlined Constant Fappli_IEEE.round_mode => "fun _ -> assert false". -Extract Inlined Constant Fcalc_bracket.inbetween_loc => "fun _ -> assert false". +Extract Inlined Constant Defs.F2R => "fun _ -> assert false". +Extract Inlined Constant Binary.FF2R => "fun _ -> assert false". +Extract Inlined Constant Binary.B2R => "fun _ -> assert false". +Extract Inlined Constant Binary.round_mode => "fun _ -> assert false". +Extract Inlined Constant Bracket.inbetween_loc => "fun _ -> assert false". (* Needed in Coq 8.4 to avoid problems with Function definitions. *) Set Extraction AccessOpaque. diff --git a/flocq/Appli/Fappli_IEEE.v b/flocq/Appli/Fappli_IEEE.v deleted file mode 100644 index 7503dc1d..00000000 --- a/flocq/Appli/Fappli_IEEE.v +++ /dev/null @@ -1,1920 +0,0 @@ -(** -This file is part of the Flocq formalization of floating-point -arithmetic in Coq: http://flocq.gforge.inria.fr/ - -Copyright (C) 2010-2013 Sylvie Boldo -#<br /># -Copyright (C) 2010-2013 Guillaume Melquiond - -This library is free software; you can redistribute it and/or -modify it under the terms of the GNU Lesser General Public -License as published by the Free Software Foundation; either -version 3 of the License, or (at your option) any later version. - -This library is distributed in the hope that it will be useful, -but WITHOUT ANY WARRANTY; without even the implied warranty of -MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -COPYING file for more details. -*) - -(** * IEEE-754 arithmetic *) -Require Import Fcore. -Require Import Fcore_digits. -Require Import Fcalc_digits. -Require Import Fcalc_round. -Require Import Fcalc_bracket. -Require Import Fcalc_ops. -Require Import Fcalc_div. -Require Import Fcalc_sqrt. -Require Import Fprop_relative. - -Section AnyRadix. - -Inductive full_float := - | F754_zero : bool -> full_float - | F754_infinity : bool -> full_float - | F754_nan : bool -> positive -> full_float - | F754_finite : bool -> positive -> Z -> full_float. - -Definition FF2R beta x := - match x with - | F754_finite s m e => F2R (Float beta (cond_Zopp s (Zpos m)) e) - | _ => 0%R - end. - -End AnyRadix. - -Section Binary. - -Arguments exist {A P} x _. - -(** [prec] is the number of bits of the mantissa including the implicit one; - [emax] is the exponent of the infinities. - For instance, binary32 is defined by [prec = 24] and [emax = 128]. *) -Variable prec emax : Z. -Context (prec_gt_0_ : Prec_gt_0 prec). -Hypothesis Hmax : (prec < emax)%Z. - -Let emin := (3 - emax - prec)%Z. -Let fexp := FLT_exp emin prec. -Instance fexp_correct : Valid_exp fexp := FLT_exp_valid emin prec. -Instance fexp_monotone : Monotone_exp fexp := FLT_exp_monotone emin prec. - -Definition canonic_mantissa m e := - Zeq_bool (fexp (Zpos (digits2_pos m) + e)) e. - -Definition bounded m e := - andb (canonic_mantissa m e) (Zle_bool e (emax - prec)). - -Definition valid_binary x := - match x with - | F754_finite _ m e => bounded m e - | F754_nan _ pl => (Zpos (digits2_pos pl) <? prec)%Z - | _ => true - end. - -(** Basic type used for representing binary FP numbers. - Note that there is exactly one such object per FP datum. *) - -Definition nan_pl := {pl | (Zpos (digits2_pos pl) <? prec)%Z = true}. - -Inductive binary_float := - | B754_zero : bool -> binary_float - | B754_infinity : bool -> binary_float - | B754_nan : bool -> nan_pl -> binary_float - | B754_finite : bool -> - forall (m : positive) (e : Z), bounded m e = true -> binary_float. - -Definition FF2B x := - match x as x return valid_binary x = true -> binary_float with - | F754_finite s m e => B754_finite s m e - | F754_infinity s => fun _ => B754_infinity s - | F754_zero s => fun _ => B754_zero s - | F754_nan b pl => fun H => B754_nan b (exist pl H) - end. - -Definition B2FF x := - match x with - | B754_finite s m e _ => F754_finite s m e - | B754_infinity s => F754_infinity s - | B754_zero s => F754_zero s - | B754_nan b (exist pl _) => F754_nan b pl - end. - -Definition B2R f := - match f with - | B754_finite s m e _ => F2R (Float radix2 (cond_Zopp s (Zpos m)) e) - | _ => 0%R - end. - -Theorem FF2R_B2FF : - forall x, - FF2R radix2 (B2FF x) = B2R x. -Proof. -now intros [sx|sx|sx [plx Hplx]|sx mx ex Hx]. -Qed. - -Theorem B2FF_FF2B : - forall x Hx, - B2FF (FF2B x Hx) = x. -Proof. -now intros [sx|sx|sx plx|sx mx ex] Hx. -Qed. - -Theorem valid_binary_B2FF : - forall x, - valid_binary (B2FF x) = true. -Proof. -now intros [sx|sx|sx [plx Hplx]|sx mx ex Hx]. -Qed. - -Theorem FF2B_B2FF : - forall x H, - FF2B (B2FF x) H = x. -Proof. -intros [sx|sx|sx [plx Hplx]|sx mx ex Hx] H ; try easy. -simpl. apply f_equal, f_equal, eqbool_irrelevance. -apply f_equal, eqbool_irrelevance. -Qed. - -Theorem FF2B_B2FF_valid : - forall x, - FF2B (B2FF x) (valid_binary_B2FF x) = x. -Proof. -intros x. -apply FF2B_B2FF. -Qed. - -Theorem B2R_FF2B : - forall x Hx, - B2R (FF2B x Hx) = FF2R radix2 x. -Proof. -now intros [sx|sx|sx plx|sx mx ex] Hx. -Qed. - -Theorem match_FF2B : - forall {T} fz fi fn ff x Hx, - match FF2B x Hx return T with - | B754_zero sx => fz sx - | B754_infinity sx => fi sx - | B754_nan b (exist p _) => fn b p - | B754_finite sx mx ex _ => ff sx mx ex - end = - match x with - | F754_zero sx => fz sx - | F754_infinity sx => fi sx - | F754_nan b p => fn b p - | F754_finite sx mx ex => ff sx mx ex - end. -Proof. -now intros T fz fi fn ff [sx|sx|sx plx|sx mx ex] Hx. -Qed. - -Theorem canonic_canonic_mantissa : - forall (sx : bool) mx ex, - canonic_mantissa mx ex = true -> - canonic radix2 fexp (Float radix2 (cond_Zopp sx (Zpos mx)) ex). -Proof. -intros sx mx ex H. -assert (Hx := Zeq_bool_eq _ _ H). clear H. -apply sym_eq. -simpl. -pattern ex at 2 ; rewrite <- Hx. -apply (f_equal fexp). -rewrite ln_beta_F2R_Zdigits. -rewrite <- Zdigits_abs. -rewrite Zpos_digits2_pos. -now case sx. -now case sx. -Qed. - -Theorem generic_format_B2R : - forall x, - generic_format radix2 fexp (B2R x). -Proof. -intros [sx|sx|sx plx|sx mx ex Hx] ; try apply generic_format_0. -simpl. -apply generic_format_canonic. -apply canonic_canonic_mantissa. -now destruct (andb_prop _ _ Hx) as (H, _). -Qed. - -Theorem FLT_format_B2R : - forall x, - FLT_format radix2 emin prec (B2R x). -Proof with auto with typeclass_instances. -intros x. -apply FLT_format_generic... -apply generic_format_B2R. -Qed. - -Theorem B2FF_inj : - forall x y : binary_float, - B2FF x = B2FF y -> - x = y. -Proof. -intros [sx|sx|sx [plx Hplx]|sx mx ex Hx] [sy|sy|sy [ply Hply]|sy my ey Hy] ; try easy. -(* *) -intros H. -now inversion H. -(* *) -intros H. -now inversion H. -(* *) -intros H. -inversion H. -clear H. -revert Hplx. -rewrite H2. -intros Hx. -apply f_equal, f_equal, eqbool_irrelevance. -(* *) -intros H. -inversion H. -clear H. -revert Hx. -rewrite H2, H3. -intros Hx. -apply f_equal, eqbool_irrelevance. -Qed. - -Definition is_finite_strict f := - match f with - | B754_finite _ _ _ _ => true - | _ => false - end. - -Theorem B2R_inj: - forall x y : binary_float, - is_finite_strict x = true -> - is_finite_strict y = true -> - B2R x = B2R y -> - x = y. -Proof. -intros [sx|sx| |sx mx ex Hx] [sy|sy| |sy my ey Hy] ; try easy. -simpl. -intros _ _ Heq. -assert (Hs: sx = sy). -(* *) -revert Heq. clear. -case sx ; case sy ; try easy ; - intros Heq ; apply False_ind ; revert Heq. -apply Rlt_not_eq. -apply Rlt_trans with R0. -now apply F2R_lt_0_compat. -now apply F2R_gt_0_compat. -apply Rgt_not_eq. -apply Rgt_trans with R0. -now apply F2R_gt_0_compat. -now apply F2R_lt_0_compat. -assert (mx = my /\ ex = ey). -(* *) -refine (_ (canonic_unicity _ fexp _ _ _ _ Heq)). -rewrite Hs. -now case sy ; intro H ; injection H ; split. -apply canonic_canonic_mantissa. -exact (proj1 (andb_prop _ _ Hx)). -apply canonic_canonic_mantissa. -exact (proj1 (andb_prop _ _ Hy)). -(* *) -revert Hx. -rewrite Hs, (proj1 H), (proj2 H). -intros Hx. -apply f_equal. -apply eqbool_irrelevance. -Qed. - -Definition Bsign x := - match x with - | B754_nan s _ => s - | B754_zero s => s - | B754_infinity s => s - | B754_finite s _ _ _ => s - end. - -Definition sign_FF x := - match x with - | F754_nan s _ => s - | F754_zero s => s - | F754_infinity s => s - | F754_finite s _ _ => s - end. - -Theorem Bsign_FF2B : - forall x H, - Bsign (FF2B x H) = sign_FF x. -Proof. -now intros [sx|sx|sx plx|sx mx ex] H. -Qed. - -Definition is_finite f := - match f with - | B754_finite _ _ _ _ => true - | B754_zero _ => true - | _ => false - end. - -Definition is_finite_FF f := - match f with - | F754_finite _ _ _ => true - | F754_zero _ => true - | _ => false - end. - -Theorem is_finite_FF2B : - forall x Hx, - is_finite (FF2B x Hx) = is_finite_FF x. -Proof. -now intros [| | |]. -Qed. - -Theorem is_finite_FF_B2FF : - forall x, - is_finite_FF (B2FF x) = is_finite x. -Proof. -now intros [| |? []|]. -Qed. - -Theorem B2R_Bsign_inj: - forall x y : binary_float, - is_finite x = true -> - is_finite y = true -> - B2R x = B2R y -> - Bsign x = Bsign y -> - x = y. -Proof. -intros. destruct x, y; try (apply B2R_inj; now eauto). -- simpl in H2. congruence. -- symmetry in H1. apply Rmult_integral in H1. - destruct H1. apply (eq_Z2R _ 0) in H1. destruct b0; discriminate H1. - simpl in H1. pose proof (bpow_gt_0 radix2 e). - rewrite H1 in H3. apply Rlt_irrefl in H3. destruct H3. -- apply Rmult_integral in H1. - destruct H1. apply (eq_Z2R _ 0) in H1. destruct b; discriminate H1. - simpl in H1. pose proof (bpow_gt_0 radix2 e). - rewrite H1 in H3. apply Rlt_irrefl in H3. destruct H3. -Qed. - -Definition is_nan f := - match f with - | B754_nan _ _ => true - | _ => false - end. - -Definition is_nan_FF f := - match f with - | F754_nan _ _ => true - | _ => false - end. - -Theorem is_nan_FF2B : - forall x Hx, - is_nan (FF2B x Hx) = is_nan_FF x. -Proof. -now intros [| | |]. -Qed. - -Theorem is_nan_FF_B2FF : - forall x, - is_nan_FF (B2FF x) = is_nan x. -Proof. -now intros [| |? []|]. -Qed. - -(** Opposite *) - -Definition Bopp opp_nan x := - match x with - | B754_nan sx plx => - let '(sres, plres) := opp_nan sx plx in B754_nan sres plres - | B754_infinity sx => B754_infinity (negb sx) - | B754_finite sx mx ex Hx => B754_finite (negb sx) mx ex Hx - | B754_zero sx => B754_zero (negb sx) - end. - -Theorem Bopp_involutive : - forall opp_nan x, - is_nan x = false -> - Bopp opp_nan (Bopp opp_nan x) = x. -Proof. -now intros opp_nan [sx|sx|sx plx|sx mx ex Hx] ; simpl ; try rewrite Bool.negb_involutive. -Qed. - -Theorem B2R_Bopp : - forall opp_nan x, - B2R (Bopp opp_nan x) = (- B2R x)%R. -Proof. -intros opp_nan [sx|sx|sx plx|sx mx ex Hx]; apply sym_eq ; try apply Ropp_0. -simpl. destruct opp_nan. apply Ropp_0. -simpl. -rewrite <- F2R_opp. -now case sx. -Qed. - -Theorem is_finite_Bopp : - forall opp_nan x, - is_finite (Bopp opp_nan x) = is_finite x. -Proof. -intros opp_nan [| |s pl|] ; try easy. -simpl. -now case opp_nan. -Qed. - -(** Absolute value *) - -Definition Babs abs_nan (x : binary_float) : binary_float := - match x with - | B754_nan sx plx => - let '(sres, plres) := abs_nan sx plx in B754_nan sres plres - | B754_infinity sx => B754_infinity false - | B754_finite sx mx ex Hx => B754_finite false mx ex Hx - | B754_zero sx => B754_zero false - end. - -Theorem B2R_Babs : - forall abs_nan x, - B2R (Babs abs_nan x) = Rabs (B2R x). -Proof. - intros abs_nan [sx|sx|sx plx|sx mx ex Hx]; apply sym_eq ; try apply Rabs_R0. - simpl. destruct abs_nan. simpl. apply Rabs_R0. - simpl. rewrite <- F2R_abs. now destruct sx. -Qed. - -Theorem is_finite_Babs : - forall abs_nan x, - is_finite (Babs abs_nan x) = is_finite x. -Proof. - intros abs_nan [| |s pl|] ; try easy. - simpl. - now case abs_nan. -Qed. - -Theorem Bsign_Babs : - forall abs_nan x, - is_nan x = false -> - Bsign (Babs abs_nan x) = false. -Proof. - now intros abs_nan [| | |]. -Qed. - -Theorem Babs_idempotent : - forall abs_nan (x: binary_float), - is_nan x = false -> - Babs abs_nan (Babs abs_nan x) = Babs abs_nan x. -Proof. - now intros abs_nan [sx|sx|sx plx|sx mx ex Hx]. -Qed. - -Theorem Babs_Bopp : - forall abs_nan opp_nan x, - is_nan x = false -> - Babs abs_nan (Bopp opp_nan x) = Babs abs_nan x. -Proof. - now intros abs_nan opp_nan [| | |]. -Qed. - -(** Comparison - -[Some c] means ordered as per [c]; [None] means unordered. *) - -Definition Bcompare (f1 f2 : binary_float) : option comparison := - match f1, f2 with - | B754_nan _ _,_ | _,B754_nan _ _ => None - | B754_infinity true, B754_infinity true - | B754_infinity false, B754_infinity false => Some Eq - | B754_infinity true, _ => Some Lt - | B754_infinity false, _ => Some Gt - | _, B754_infinity true => Some Gt - | _, B754_infinity false => Some Lt - | B754_finite true _ _ _, B754_zero _ => Some Lt - | B754_finite false _ _ _, B754_zero _ => Some Gt - | B754_zero _, B754_finite true _ _ _ => Some Gt - | B754_zero _, B754_finite false _ _ _ => Some Lt - | B754_zero _, B754_zero _ => Some Eq - | B754_finite s1 m1 e1 _, B754_finite s2 m2 e2 _ => - match s1, s2 with - | true, false => Some Lt - | false, true => Some Gt - | false, false => - match Zcompare e1 e2 with - | Lt => Some Lt - | Gt => Some Gt - | Eq => Some (Pcompare m1 m2 Eq) - end - | true, true => - match Zcompare e1 e2 with - | Lt => Some Gt - | Gt => Some Lt - | Eq => Some (CompOpp (Pcompare m1 m2 Eq)) - end - end - end. - -Theorem Bcompare_correct : - forall f1 f2, - is_finite f1 = true -> is_finite f2 = true -> - Bcompare f1 f2 = Some (Rcompare (B2R f1) (B2R f2)). -Proof. - Ltac apply_Rcompare := - match goal with - | [ |- Some Lt = Some (Rcompare _ _) ] => f_equal; symmetry; apply Rcompare_Lt - | [ |- Some Eq = Some (Rcompare _ _) ] => f_equal; symmetry; apply Rcompare_Eq - | [ |- Some Gt = Some (Rcompare _ _) ] => f_equal; symmetry; apply Rcompare_Gt - end. - unfold Bcompare; intros. - destruct f1, f2 ; try easy. - now rewrite Rcompare_Eq. - destruct b0 ; apply_Rcompare. - now apply F2R_lt_0_compat. - now apply F2R_gt_0_compat. - destruct b ; apply_Rcompare. - now apply F2R_lt_0_compat. - now apply F2R_gt_0_compat. - simpl. - clear H H0. - apply andb_prop in e0; destruct e0; apply (canonic_canonic_mantissa false) in H. - apply andb_prop in e2; destruct e2; apply (canonic_canonic_mantissa false) in H1. - pose proof (Zcompare_spec e e1); unfold canonic, Fexp in H1, H. - assert (forall m1 m2 e1 e2, - let x := (Z2R (Zpos m1) * bpow radix2 e1)%R in - let y := (Z2R (Zpos m2) * bpow radix2 e2)%R in - (canonic_exp radix2 fexp x < canonic_exp radix2 fexp y)%Z -> (x < y)%R). - { - intros; apply Rnot_le_lt; intro; apply (ln_beta_le radix2) in H5. - apply Zlt_not_le with (1 := H4). - now apply fexp_monotone. - now apply (F2R_gt_0_compat _ (Float radix2 (Zpos m2) e2)). - } - assert (forall m1 m2 e1 e2, (Z2R (- Zpos m1) * bpow radix2 e1 < Z2R (Zpos m2) * bpow radix2 e2)%R). - { - intros; apply (Rlt_trans _ 0%R). - now apply (F2R_lt_0_compat _ (Float radix2 (Zneg m1) e0)). - now apply (F2R_gt_0_compat _ (Float radix2 (Zpos m2) e2)). - } - unfold F2R, Fnum, Fexp. - destruct b, b0; try (now apply_Rcompare; apply H5); inversion H3; - try (apply_Rcompare; apply H4; rewrite H, H1 in H7; assumption); - try (apply_Rcompare; do 2 rewrite Z2R_opp, Ropp_mult_distr_l_reverse; - apply Ropp_lt_contravar; apply H4; rewrite H, H1 in H7; assumption); - rewrite H7, Rcompare_mult_r, Rcompare_Z2R by (apply bpow_gt_0); reflexivity. -Qed. - -Theorem Bcompare_swap : - forall x y, - Bcompare y x = match Bcompare x y with Some c => Some (CompOpp c) | None => None end. -Proof. - intros. - destruct x as [ ? | [] | ? ? | [] mx ex Bx ]; - destruct y as [ ? | [] | ? ? | [] my ey By ]; simpl; try easy. -- rewrite <- (Zcompare_antisym ex ey). destruct (ex ?= ey)%Z; try easy. - now rewrite (Pcompare_antisym mx my). -- rewrite <- (Zcompare_antisym ex ey). destruct (ex ?= ey)%Z; try easy. - now rewrite Pcompare_antisym. -Qed. - -Theorem bounded_lt_emax : - forall mx ex, - bounded mx ex = true -> - (F2R (Float radix2 (Zpos mx) ex) < bpow radix2 emax)%R. -Proof. -intros mx ex Hx. -destruct (andb_prop _ _ Hx) as (H1,H2). -generalize (Zeq_bool_eq _ _ H1). clear H1. intro H1. -generalize (Zle_bool_imp_le _ _ H2). clear H2. intro H2. -generalize (ln_beta_F2R_Zdigits radix2 (Zpos mx) ex). -destruct (ln_beta radix2 (F2R (Float radix2 (Zpos mx) ex))) as (e',Ex). -unfold ln_beta_val. -intros H. -apply Rlt_le_trans with (bpow radix2 e'). -change (Zpos mx) with (Zabs (Zpos mx)). -rewrite F2R_Zabs. -apply Ex. -apply Rgt_not_eq. -now apply F2R_gt_0_compat. -apply bpow_le. -rewrite H. 2: discriminate. -revert H1. clear -H2. -rewrite Zpos_digits2_pos. -unfold fexp, FLT_exp. -generalize (Zdigits radix2 (Zpos mx)). -clearbody emin. -intros ; zify ; omega. -Qed. - -Theorem abs_B2R_lt_emax : - forall x, - (Rabs (B2R x) < bpow radix2 emax)%R. -Proof. -intros [sx|sx|sx plx|sx mx ex Hx] ; simpl ; try ( rewrite Rabs_R0 ; apply bpow_gt_0 ). -rewrite <- F2R_Zabs, abs_cond_Zopp. -now apply bounded_lt_emax. -Qed. - -Theorem bounded_canonic_lt_emax : - forall mx ex, - canonic radix2 fexp (Float radix2 (Zpos mx) ex) -> - (F2R (Float radix2 (Zpos mx) ex) < bpow radix2 emax)%R -> - bounded mx ex = true. -Proof. -intros mx ex Cx Bx. -apply andb_true_intro. -split. -unfold canonic_mantissa. -unfold canonic, Fexp in Cx. -rewrite Cx at 2. -rewrite Zpos_digits2_pos. -unfold canonic_exp. -rewrite ln_beta_F2R_Zdigits. 2: discriminate. -now apply -> Zeq_is_eq_bool. -apply Zle_bool_true. -unfold canonic, Fexp in Cx. -rewrite Cx. -unfold canonic_exp, fexp, FLT_exp. -destruct (ln_beta radix2 (F2R (Float radix2 (Zpos mx) ex))) as (e',Ex). simpl. -apply Zmax_lub. -cut (e' - 1 < emax)%Z. clear ; omega. -apply lt_bpow with radix2. -apply Rle_lt_trans with (2 := Bx). -change (Zpos mx) with (Zabs (Zpos mx)). -rewrite F2R_Zabs. -apply Ex. -apply Rgt_not_eq. -now apply F2R_gt_0_compat. -unfold emin. -generalize (prec_gt_0 prec). -clear -Hmax ; omega. -Qed. - -(** Truncation *) - -Record shr_record := { shr_m : Z ; shr_r : bool ; shr_s : bool }. - -Definition shr_1 mrs := - let '(Build_shr_record m r s) := mrs in - let s := orb r s in - match m with - | Z0 => Build_shr_record Z0 false s - | Zpos xH => Build_shr_record Z0 true s - | Zpos (xO p) => Build_shr_record (Zpos p) false s - | Zpos (xI p) => Build_shr_record (Zpos p) true s - | Zneg xH => Build_shr_record Z0 true s - | Zneg (xO p) => Build_shr_record (Zneg p) false s - | Zneg (xI p) => Build_shr_record (Zneg p) true s - end. - -Definition loc_of_shr_record mrs := - match mrs with - | Build_shr_record _ false false => loc_Exact - | Build_shr_record _ false true => loc_Inexact Lt - | Build_shr_record _ true false => loc_Inexact Eq - | Build_shr_record _ true true => loc_Inexact Gt - end. - -Definition shr_record_of_loc m l := - match l with - | loc_Exact => Build_shr_record m false false - | loc_Inexact Lt => Build_shr_record m false true - | loc_Inexact Eq => Build_shr_record m true false - | loc_Inexact Gt => Build_shr_record m true true - end. - -Theorem shr_m_shr_record_of_loc : - forall m l, - shr_m (shr_record_of_loc m l) = m. -Proof. -now intros m [|[| |]]. -Qed. - -Theorem loc_of_shr_record_of_loc : - forall m l, - loc_of_shr_record (shr_record_of_loc m l) = l. -Proof. -now intros m [|[| |]]. -Qed. - -Definition shr mrs e n := - match n with - | Zpos p => (iter_pos shr_1 p mrs, (e + n)%Z) - | _ => (mrs, e) - end. - -Lemma inbetween_shr_1 : - forall x mrs e, - (0 <= shr_m mrs)%Z -> - inbetween_float radix2 (shr_m mrs) e x (loc_of_shr_record mrs) -> - inbetween_float radix2 (shr_m (shr_1 mrs)) (e + 1) x (loc_of_shr_record (shr_1 mrs)). -Proof. -intros x mrs e Hm Hl. -refine (_ (new_location_even_correct (F2R (Float radix2 (shr_m (shr_1 mrs)) (e + 1))) (bpow radix2 e) 2 _ _ _ x (if shr_r (shr_1 mrs) then 1 else 0) (loc_of_shr_record mrs) _ _)) ; try easy. -2: apply bpow_gt_0. -2: now case (shr_r (shr_1 mrs)) ; split. -change (Z2R 2) with (bpow radix2 1). -rewrite <- bpow_plus. -rewrite (Zplus_comm 1), <- (F2R_bpow radix2 (e + 1)). -unfold inbetween_float, F2R. simpl. -rewrite Z2R_plus, Rmult_plus_distr_r. -replace (new_location_even 2 (if shr_r (shr_1 mrs) then 1%Z else 0%Z) (loc_of_shr_record mrs)) with (loc_of_shr_record (shr_1 mrs)). -easy. -clear -Hm. -destruct mrs as (m, r, s). -now destruct m as [|[m|m|]|m] ; try (now elim Hm) ; destruct r as [|] ; destruct s as [|]. -rewrite (F2R_change_exp radix2 e). -2: apply Zle_succ. -unfold F2R. simpl. -rewrite <- 2!Rmult_plus_distr_r, <- 2!Z2R_plus. -rewrite Zplus_assoc. -replace (shr_m (shr_1 mrs) * 2 ^ (e + 1 - e) + (if shr_r (shr_1 mrs) then 1%Z else 0%Z))%Z with (shr_m mrs). -exact Hl. -ring_simplify (e + 1 - e)%Z. -change (2^1)%Z with 2%Z. -rewrite Zmult_comm. -clear -Hm. -destruct mrs as (m, r, s). -now destruct m as [|[m|m|]|m] ; try (now elim Hm) ; destruct r as [|] ; destruct s as [|]. -Qed. - -Theorem inbetween_shr : - forall x m e l n, - (0 <= m)%Z -> - inbetween_float radix2 m e x l -> - let '(mrs, e') := shr (shr_record_of_loc m l) e n in - inbetween_float radix2 (shr_m mrs) e' x (loc_of_shr_record mrs). -Proof. -intros x m e l n Hm Hl. -destruct n as [|n|n]. -now destruct l as [|[| |]]. -2: now destruct l as [|[| |]]. -unfold shr. -rewrite iter_pos_nat. -rewrite Zpos_eq_Z_of_nat_o_nat_of_P. -induction (nat_of_P n). -simpl. -rewrite Zplus_0_r. -now destruct l as [|[| |]]. -rewrite iter_nat_S. -rewrite inj_S. -unfold Zsucc. -rewrite Zplus_assoc. -revert IHn0. -apply inbetween_shr_1. -clear -Hm. -induction n0. -now destruct l as [|[| |]]. -rewrite iter_nat_S. -revert IHn0. -generalize (iter_nat shr_1 n0 (shr_record_of_loc m l)). -clear. -intros (m, r, s) Hm. -now destruct m as [|[m|m|]|m] ; try (now elim Hm) ; destruct r as [|] ; destruct s as [|]. -Qed. - -Definition shr_fexp m e l := - shr (shr_record_of_loc m l) e (fexp (Zdigits2 m + e) - e). - -Theorem shr_truncate : - forall m e l, - (0 <= m)%Z -> - shr_fexp m e l = - let '(m', e', l') := truncate radix2 fexp (m, e, l) in (shr_record_of_loc m' l', e'). -Proof. -intros m e l Hm. -case_eq (truncate radix2 fexp (m, e, l)). -intros (m', e') l'. -unfold shr_fexp. -rewrite Zdigits2_Zdigits. -case_eq (fexp (Zdigits radix2 m + e) - e)%Z. -(* *) -intros He. -unfold truncate. -rewrite He. -simpl. -intros H. -now inversion H. -(* *) -intros p Hp. -assert (He: (e <= fexp (Zdigits radix2 m + e))%Z). -clear -Hp ; zify ; omega. -destruct (inbetween_float_ex radix2 m e l) as (x, Hx). -generalize (inbetween_shr x m e l (fexp (Zdigits radix2 m + e) - e) Hm Hx). -assert (Hx0 : (0 <= x)%R). -apply Rle_trans with (F2R (Float radix2 m e)). -now apply F2R_ge_0_compat. -exact (proj1 (inbetween_float_bounds _ _ _ _ _ Hx)). -case_eq (shr (shr_record_of_loc m l) e (fexp (Zdigits radix2 m + e) - e)). -intros mrs e'' H3 H4 H1. -generalize (truncate_correct radix2 _ x m e l Hx0 Hx (or_introl _ He)). -rewrite H1. -intros (H2,_). -rewrite <- Hp, H3. -assert (e'' = e'). -change (snd (mrs, e'') = snd (fst (m',e',l'))). -rewrite <- H1, <- H3. -unfold truncate. -now rewrite Hp. -rewrite H in H4 |- *. -apply (f_equal (fun v => (v, _))). -destruct (inbetween_float_unique _ _ _ _ _ _ _ H2 H4) as (H5, H6). -rewrite H5, H6. -case mrs. -now intros m0 [|] [|]. -(* *) -intros p Hp. -unfold truncate. -rewrite Hp. -simpl. -intros H. -now inversion H. -Qed. - -(** Rounding modes *) - -Inductive mode := mode_NE | mode_ZR | mode_DN | mode_UP | mode_NA. - -Definition round_mode m := - match m with - | mode_NE => ZnearestE - | mode_ZR => Ztrunc - | mode_DN => Zfloor - | mode_UP => Zceil - | mode_NA => ZnearestA - end. - -Definition choice_mode m sx mx lx := - match m with - | mode_NE => cond_incr (round_N (negb (Zeven mx)) lx) mx - | mode_ZR => mx - | mode_DN => cond_incr (round_sign_DN sx lx) mx - | mode_UP => cond_incr (round_sign_UP sx lx) mx - | mode_NA => cond_incr (round_N true lx) mx - end. - -Global Instance valid_rnd_round_mode : forall m, Valid_rnd (round_mode m). -Proof. -destruct m ; unfold round_mode ; auto with typeclass_instances. -Qed. - -Definition overflow_to_inf m s := - match m with - | mode_NE => true - | mode_NA => true - | mode_ZR => false - | mode_UP => negb s - | mode_DN => s - end. - -Definition binary_overflow m s := - if overflow_to_inf m s then F754_infinity s - else F754_finite s (match (Zpower 2 prec - 1)%Z with Zpos p => p | _ => xH end) (emax - prec). - -Definition binary_round_aux mode sx mx ex lx := - let '(mrs', e') := shr_fexp (Zpos mx) ex lx in - let '(mrs'', e'') := shr_fexp (choice_mode mode sx (shr_m mrs') (loc_of_shr_record mrs')) e' loc_Exact in - match shr_m mrs'' with - | Z0 => F754_zero sx - | Zpos m => if Zle_bool e'' (emax - prec) then F754_finite sx m e'' else binary_overflow mode sx - | _ => F754_nan false xH (* dummy *) - end. - -Theorem binary_round_aux_correct : - forall mode x mx ex lx, - inbetween_float radix2 (Zpos mx) ex (Rabs x) lx -> - (ex <= fexp (Zdigits radix2 (Zpos mx) + ex))%Z -> - let z := binary_round_aux mode (Rlt_bool x 0) mx ex lx in - valid_binary z = true /\ - if Rlt_bool (Rabs (round radix2 fexp (round_mode mode) x)) (bpow radix2 emax) then - FF2R radix2 z = round radix2 fexp (round_mode mode) x /\ - is_finite_FF z = true /\ sign_FF z = Rlt_bool x 0 - else - z = binary_overflow mode (Rlt_bool x 0). -Proof with auto with typeclass_instances. -intros m x mx ex lx Bx Ex z. -unfold binary_round_aux in z. -revert z. -rewrite shr_truncate. 2: easy. -refine (_ (round_trunc_sign_any_correct _ _ (round_mode m) (choice_mode m) _ x (Zpos mx) ex lx Bx (or_introl _ Ex))). -refine (_ (truncate_correct_partial _ _ _ _ _ _ _ Bx Ex)). -destruct (truncate radix2 fexp (Zpos mx, ex, lx)) as ((m1, e1), l1). -rewrite loc_of_shr_record_of_loc, shr_m_shr_record_of_loc. -set (m1' := choice_mode m (Rlt_bool x 0) m1 l1). -intros (H1a,H1b) H1c. -rewrite H1c. -assert (Hm: (m1 <= m1')%Z). -(* . *) -unfold m1', choice_mode, cond_incr. -case m ; - try apply Zle_refl ; - match goal with |- (m1 <= if ?b then _ else _)%Z => - case b ; [ apply Zle_succ | apply Zle_refl ] end. -assert (Hr: Rabs (round radix2 fexp (round_mode m) x) = F2R (Float radix2 m1' e1)). -(* . *) -rewrite <- (Zabs_eq m1'). -replace (Zabs m1') with (Zabs (cond_Zopp (Rlt_bool x 0) m1')). -rewrite F2R_Zabs. -now apply f_equal. -apply abs_cond_Zopp. -apply Zle_trans with (2 := Hm). -apply Zlt_succ_le. -apply F2R_gt_0_reg with radix2 e1. -apply Rle_lt_trans with (1 := Rabs_pos x). -exact (proj2 (inbetween_float_bounds _ _ _ _ _ H1a)). -(* . *) -assert (Br: inbetween_float radix2 m1' e1 (Rabs (round radix2 fexp (round_mode m) x)) loc_Exact). -now apply inbetween_Exact. -destruct m1' as [|m1'|m1']. -(* . m1' = 0 *) -rewrite shr_truncate. 2: apply Zle_refl. -generalize (truncate_0 radix2 fexp e1 loc_Exact). -destruct (truncate radix2 fexp (Z0, e1, loc_Exact)) as ((m2, e2), l2). -rewrite shr_m_shr_record_of_loc. -intros Hm2. -rewrite Hm2. -repeat split. -rewrite Rlt_bool_true. -repeat split. -apply sym_eq. -case Rlt_bool ; apply F2R_0. -rewrite <- F2R_Zabs, abs_cond_Zopp, F2R_0. -apply bpow_gt_0. -(* . 0 < m1' *) -assert (He: (e1 <= fexp (Zdigits radix2 (Zpos m1') + e1))%Z). -rewrite <- ln_beta_F2R_Zdigits, <- Hr, ln_beta_abs. -2: discriminate. -rewrite H1b. -rewrite canonic_exp_abs. -fold (canonic_exp radix2 fexp (round radix2 fexp (round_mode m) x)). -apply canonic_exp_round_ge... -rewrite H1c. -case (Rlt_bool x 0). -apply Rlt_not_eq. -now apply F2R_lt_0_compat. -apply Rgt_not_eq. -now apply F2R_gt_0_compat. -refine (_ (truncate_correct_partial _ _ _ _ _ _ _ Br He)). -2: now rewrite Hr ; apply F2R_gt_0_compat. -refine (_ (truncate_correct_format radix2 fexp (Zpos m1') e1 _ _ He)). -2: discriminate. -rewrite shr_truncate. 2: easy. -destruct (truncate radix2 fexp (Zpos m1', e1, loc_Exact)) as ((m2, e2), l2). -rewrite shr_m_shr_record_of_loc. -intros (H3,H4) (H2,_). -destruct m2 as [|m2|m2]. -elim Rgt_not_eq with (2 := H3). -rewrite F2R_0. -now apply F2R_gt_0_compat. -rewrite F2R_cond_Zopp, H3, abs_cond_Ropp, <- F2R_abs. -simpl Zabs. -case_eq (Zle_bool e2 (emax - prec)) ; intros He2. -assert (bounded m2 e2 = true). -apply andb_true_intro. -split. -unfold canonic_mantissa. -apply Zeq_bool_true. -rewrite Zpos_digits2_pos. -rewrite <- ln_beta_F2R_Zdigits. -apply sym_eq. -now rewrite H3 in H4. -discriminate. -exact He2. -apply (conj H). -rewrite Rlt_bool_true. -repeat split. -apply F2R_cond_Zopp. -now apply bounded_lt_emax. -rewrite (Rlt_bool_false _ (bpow radix2 emax)). -refine (conj _ (refl_equal _)). -unfold binary_overflow. -case overflow_to_inf. -apply refl_equal. -unfold valid_binary, bounded. -rewrite Zle_bool_refl. -rewrite Bool.andb_true_r. -apply Zeq_bool_true. -rewrite Zpos_digits2_pos. -replace (Zdigits radix2 (Zpos (match (Zpower 2 prec - 1)%Z with Zpos p => p | _ => xH end))) with prec. -unfold fexp, FLT_exp, emin. -generalize (prec_gt_0 prec). -clear -Hmax ; zify ; omega. -change 2%Z with (radix_val radix2). -case_eq (Zpower radix2 prec - 1)%Z. -simpl Zdigits. -generalize (Zpower_gt_1 radix2 prec (prec_gt_0 prec)). -clear ; omega. -intros p Hp. -apply Zle_antisym. -cut (prec - 1 < Zdigits radix2 (Zpos p))%Z. clear ; omega. -apply Zdigits_gt_Zpower. -simpl Zabs. rewrite <- Hp. -cut (Zpower radix2 (prec - 1) < Zpower radix2 prec)%Z. clear ; omega. -apply lt_Z2R. -rewrite 2!Z2R_Zpower. 2: now apply Zlt_le_weak. -apply bpow_lt. -apply Zlt_pred. -now apply Zlt_0_le_0_pred. -apply Zdigits_le_Zpower. -simpl Zabs. rewrite <- Hp. -apply Zlt_pred. -intros p Hp. -generalize (Zpower_gt_1 radix2 _ (prec_gt_0 prec)). -clear -Hp ; zify ; omega. -apply Rnot_lt_le. -intros Hx. -generalize (refl_equal (bounded m2 e2)). -unfold bounded at 2. -rewrite He2. -rewrite Bool.andb_false_r. -rewrite bounded_canonic_lt_emax with (2 := Hx). -discriminate. -unfold canonic. -now rewrite <- H3. -elim Rgt_not_eq with (2 := H3). -apply Rlt_trans with R0. -now apply F2R_lt_0_compat. -now apply F2R_gt_0_compat. -rewrite <- Hr. -apply generic_format_abs... -apply generic_format_round... -(* . not m1' < 0 *) -elim Rgt_not_eq with (2 := Hr). -apply Rlt_le_trans with R0. -now apply F2R_lt_0_compat. -apply Rabs_pos. -(* *) -apply Rlt_le_trans with (2 := proj1 (inbetween_float_bounds _ _ _ _ _ Bx)). -now apply F2R_gt_0_compat. -(* all the modes are valid *) -clear. case m. -exact inbetween_int_NE_sign. -exact inbetween_int_ZR_sign. -exact inbetween_int_DN_sign. -exact inbetween_int_UP_sign. -exact inbetween_int_NA_sign. -Qed. - -(** Multiplication *) - -Lemma Bmult_correct_aux : - forall m sx mx ex (Hx : bounded mx ex = true) sy my ey (Hy : bounded my ey = true), - let x := F2R (Float radix2 (cond_Zopp sx (Zpos mx)) ex) in - let y := F2R (Float radix2 (cond_Zopp sy (Zpos my)) ey) in - let z := binary_round_aux m (xorb sx sy) (mx * my) (ex + ey) loc_Exact in - valid_binary z = true /\ - if Rlt_bool (Rabs (round radix2 fexp (round_mode m) (x * y))) (bpow radix2 emax) then - FF2R radix2 z = round radix2 fexp (round_mode m) (x * y) /\ - is_finite_FF z = true /\ sign_FF z = xorb sx sy - else - z = binary_overflow m (xorb sx sy). -Proof. -intros m sx mx ex Hx sy my ey Hy x y. -unfold x, y. -rewrite <- F2R_mult. -simpl. -replace (xorb sx sy) with (Rlt_bool (F2R (Float radix2 (cond_Zopp sx (Zpos mx) * cond_Zopp sy (Zpos my)) (ex + ey))) 0). -apply binary_round_aux_correct. -constructor. -rewrite <- F2R_abs. -apply F2R_eq_compat. -rewrite Zabs_Zmult. -now rewrite 2!abs_cond_Zopp. -(* *) -change (Zpos (mx * my)) with (Zpos mx * Zpos my)%Z. -assert (forall m e, bounded m e = true -> fexp (Zdigits radix2 (Zpos m) + e) = e)%Z. -clear. intros m e Hb. -destruct (andb_prop _ _ Hb) as (H,_). -apply Zeq_bool_eq. -now rewrite <- Zpos_digits2_pos. -generalize (H _ _ Hx) (H _ _ Hy). -clear x y sx sy Hx Hy H. -unfold fexp, FLT_exp. -refine (_ (Zdigits_mult_ge radix2 (Zpos mx) (Zpos my) _ _)) ; try discriminate. -refine (_ (Zdigits_gt_0 radix2 (Zpos mx) _) (Zdigits_gt_0 radix2 (Zpos my) _)) ; try discriminate. -generalize (Zdigits radix2 (Zpos mx)) (Zdigits radix2 (Zpos my)) (Zdigits radix2 (Zpos mx * Zpos my)). -clear -Hmax. -unfold emin. -intros dx dy dxy Hx Hy Hxy. -zify ; intros ; subst. -omega. -(* *) -case sx ; case sy. -apply Rlt_bool_false. -now apply F2R_ge_0_compat. -apply Rlt_bool_true. -now apply F2R_lt_0_compat. -apply Rlt_bool_true. -now apply F2R_lt_0_compat. -apply Rlt_bool_false. -now apply F2R_ge_0_compat. -Qed. - -Definition Bmult mult_nan m x y := - let f pl := B754_nan (fst pl) (snd pl) in - match x, y with - | B754_nan _ _, _ | _, B754_nan _ _ => f (mult_nan x y) - | B754_infinity sx, B754_infinity sy => B754_infinity (xorb sx sy) - | B754_infinity sx, B754_finite sy _ _ _ => B754_infinity (xorb sx sy) - | B754_finite sx _ _ _, B754_infinity sy => B754_infinity (xorb sx sy) - | B754_infinity _, B754_zero _ => f (mult_nan x y) - | B754_zero _, B754_infinity _ => f (mult_nan x y) - | B754_finite sx _ _ _, B754_zero sy => B754_zero (xorb sx sy) - | B754_zero sx, B754_finite sy _ _ _ => B754_zero (xorb sx sy) - | B754_zero sx, B754_zero sy => B754_zero (xorb sx sy) - | B754_finite sx mx ex Hx, B754_finite sy my ey Hy => - FF2B _ (proj1 (Bmult_correct_aux m sx mx ex Hx sy my ey Hy)) - end. - -Theorem Bmult_correct : - forall mult_nan m x y, - if Rlt_bool (Rabs (round radix2 fexp (round_mode m) (B2R x * B2R y))) (bpow radix2 emax) then - B2R (Bmult mult_nan m x y) = round radix2 fexp (round_mode m) (B2R x * B2R y) /\ - is_finite (Bmult mult_nan m x y) = andb (is_finite x) (is_finite y) /\ - (is_nan (Bmult mult_nan m x y) = false -> - Bsign (Bmult mult_nan m x y) = xorb (Bsign x) (Bsign y)) - else - B2FF (Bmult mult_nan m x y) = binary_overflow m (xorb (Bsign x) (Bsign y)). -Proof. -intros mult_nan m [sx|sx|sx plx|sx mx ex Hx] [sy|sy|sy ply|sy my ey Hy] ; - try ( rewrite ?Rmult_0_r, ?Rmult_0_l, round_0, Rabs_R0, Rlt_bool_true ; [ now repeat constructor | apply bpow_gt_0 | now auto with typeclass_instances ] ). -simpl. -case Bmult_correct_aux. -intros H1. -case Rlt_bool. -intros (H2, (H3, H4)). -split. -now rewrite B2R_FF2B. -split. -now rewrite is_finite_FF2B. -rewrite Bsign_FF2B. auto. -intros H2. -now rewrite B2FF_FF2B. -Qed. - -Definition Bmult_FF mult_nan m x y := - let f pl := F754_nan (fst pl) (snd pl) in - match x, y with - | F754_nan _ _, _ | _, F754_nan _ _ => f (mult_nan x y) - | F754_infinity sx, F754_infinity sy => F754_infinity (xorb sx sy) - | F754_infinity sx, F754_finite sy _ _ => F754_infinity (xorb sx sy) - | F754_finite sx _ _, F754_infinity sy => F754_infinity (xorb sx sy) - | F754_infinity _, F754_zero _ => f (mult_nan x y) - | F754_zero _, F754_infinity _ => f (mult_nan x y) - | F754_finite sx _ _, F754_zero sy => F754_zero (xorb sx sy) - | F754_zero sx, F754_finite sy _ _ => F754_zero (xorb sx sy) - | F754_zero sx, F754_zero sy => F754_zero (xorb sx sy) - | F754_finite sx mx ex, F754_finite sy my ey => - binary_round_aux m (xorb sx sy) (mx * my) (ex + ey) loc_Exact - end. - -Theorem B2FF_Bmult : - forall mult_nan mult_nan_ff, - forall m x y, - mult_nan_ff (B2FF x) (B2FF y) = (let '(sr, exist plr _) := mult_nan x y in (sr, plr)) -> - B2FF (Bmult mult_nan m x y) = Bmult_FF mult_nan_ff m (B2FF x) (B2FF y). -Proof. -intros mult_nan mult_nan_ff m x y Hmult_nan. -unfold Bmult_FF. rewrite Hmult_nan. -destruct x as [sx|sx|sx [plx Hplx]|sx mx ex Hx], y as [sy|sy|sy [ply Hply]|sy my ey Hy] ; - simpl; try match goal with |- context [mult_nan ?x ?y] => - destruct (mult_nan x y) as [? []] end; - try easy. -apply B2FF_FF2B. -Qed. - -(** Normalization and rounding *) - -Definition shl_align mx ex ex' := - match (ex' - ex)%Z with - | Zneg d => (shift_pos d mx, ex') - | _ => (mx, ex) - end. - -Theorem shl_align_correct : - forall mx ex ex', - let (mx', ex'') := shl_align mx ex ex' in - F2R (Float radix2 (Zpos mx) ex) = F2R (Float radix2 (Zpos mx') ex'') /\ - (ex'' <= ex')%Z. -Proof. -intros mx ex ex'. -unfold shl_align. -case_eq (ex' - ex)%Z. -(* d = 0 *) -intros H. -repeat split. -rewrite Zminus_eq with (1 := H). -apply Zle_refl. -(* d > 0 *) -intros d Hd. -repeat split. -replace ex' with (ex' - ex + ex)%Z by ring. -rewrite Hd. -pattern ex at 1 ; rewrite <- Zplus_0_l. -now apply Zplus_le_compat_r. -(* d < 0 *) -intros d Hd. -rewrite shift_pos_correct, Zmult_comm. -change (Zpower_pos 2 d) with (Zpower radix2 (Zpos d)). -change (Zpos d) with (Zopp (Zneg d)). -rewrite <- Hd. -split. -replace (- (ex' - ex))%Z with (ex - ex')%Z by ring. -apply F2R_change_exp. -apply Zle_0_minus_le. -replace (ex - ex')%Z with (- (ex' - ex))%Z by ring. -now rewrite Hd. -apply Zle_refl. -Qed. - -Theorem snd_shl_align : - forall mx ex ex', - (ex' <= ex)%Z -> - snd (shl_align mx ex ex') = ex'. -Proof. -intros mx ex ex' He. -unfold shl_align. -case_eq (ex' - ex)%Z ; simpl. -intros H. -now rewrite Zminus_eq with (1 := H). -intros p. -clear -He ; zify ; omega. -intros. -apply refl_equal. -Qed. - -Definition shl_align_fexp mx ex := - shl_align mx ex (fexp (Zpos (digits2_pos mx) + ex)). - -Theorem shl_align_fexp_correct : - forall mx ex, - let (mx', ex') := shl_align_fexp mx ex in - F2R (Float radix2 (Zpos mx) ex) = F2R (Float radix2 (Zpos mx') ex') /\ - (ex' <= fexp (Zdigits radix2 (Zpos mx') + ex'))%Z. -Proof. -intros mx ex. -unfold shl_align_fexp. -generalize (shl_align_correct mx ex (fexp (Zpos (digits2_pos mx) + ex))). -rewrite Zpos_digits2_pos. -case shl_align. -intros mx' ex' (H1, H2). -split. -exact H1. -rewrite <- ln_beta_F2R_Zdigits. 2: easy. -rewrite <- H1. -now rewrite ln_beta_F2R_Zdigits. -Qed. - -Definition binary_round m sx mx ex := - let '(mz, ez) := shl_align_fexp mx ex in binary_round_aux m sx mz ez loc_Exact. - -Theorem binary_round_correct : - forall m sx mx ex, - let z := binary_round m sx mx ex in - valid_binary z = true /\ - let x := F2R (Float radix2 (cond_Zopp sx (Zpos mx)) ex) in - if Rlt_bool (Rabs (round radix2 fexp (round_mode m) x)) (bpow radix2 emax) then - FF2R radix2 z = round radix2 fexp (round_mode m) x /\ - is_finite_FF z = true /\ - sign_FF z = sx - else - z = binary_overflow m sx. -Proof. -intros m sx mx ex. -unfold binary_round. -generalize (shl_align_fexp_correct mx ex). -destruct (shl_align_fexp mx ex) as (mz, ez). -intros (H1, H2). -set (x := F2R (Float radix2 (cond_Zopp sx (Zpos mx)) ex)). -replace sx with (Rlt_bool x 0). -apply binary_round_aux_correct. -constructor. -unfold x. -now rewrite <- F2R_Zabs, abs_cond_Zopp. -exact H2. -unfold x. -case sx. -apply Rlt_bool_true. -now apply F2R_lt_0_compat. -apply Rlt_bool_false. -now apply F2R_ge_0_compat. -Qed. - -Definition binary_normalize mode m e szero := - match m with - | Z0 => B754_zero szero - | Zpos m => FF2B _ (proj1 (binary_round_correct mode false m e)) - | Zneg m => FF2B _ (proj1 (binary_round_correct mode true m e)) - end. - -Theorem binary_normalize_correct : - forall m mx ex szero, - if Rlt_bool (Rabs (round radix2 fexp (round_mode m) (F2R (Float radix2 mx ex)))) (bpow radix2 emax) then - B2R (binary_normalize m mx ex szero) = round radix2 fexp (round_mode m) (F2R (Float radix2 mx ex)) /\ - is_finite (binary_normalize m mx ex szero) = true /\ - Bsign (binary_normalize m mx ex szero) = - match Rcompare (F2R (Float radix2 mx ex)) 0 with - | Eq => szero - | Lt => true - | Gt => false - end - else - B2FF (binary_normalize m mx ex szero) = binary_overflow m (Rlt_bool (F2R (Float radix2 mx ex)) 0). -Proof with auto with typeclass_instances. -intros m mx ez szero. -destruct mx as [|mz|mz] ; simpl. -rewrite F2R_0, round_0, Rabs_R0, Rlt_bool_true... -split... split... -rewrite Rcompare_Eq... -apply bpow_gt_0. -(* . mz > 0 *) -generalize (binary_round_correct m false mz ez). -simpl. -case Rlt_bool_spec. -intros _ (Vz, (Rz, (Rz', Rz''))). -split. -now rewrite B2R_FF2B. -split. -now rewrite is_finite_FF2B. -rewrite Bsign_FF2B, Rz''. -rewrite Rcompare_Gt... -apply F2R_gt_0_compat. -simpl. zify; omega. -intros Hz' (Vz, Rz). -rewrite B2FF_FF2B, Rz. -apply f_equal. -apply sym_eq. -apply Rlt_bool_false. -now apply F2R_ge_0_compat. -(* . mz < 0 *) -generalize (binary_round_correct m true mz ez). -simpl. -case Rlt_bool_spec. -intros _ (Vz, (Rz, (Rz', Rz''))). -split. -now rewrite B2R_FF2B. -split. -now rewrite is_finite_FF2B. -rewrite Bsign_FF2B, Rz''. -rewrite Rcompare_Lt... -apply F2R_lt_0_compat. -simpl. zify; omega. -intros Hz' (Vz, Rz). -rewrite B2FF_FF2B, Rz. -apply f_equal. -apply sym_eq. -apply Rlt_bool_true. -now apply F2R_lt_0_compat. -Qed. - -(** Addition *) - -Definition Bplus plus_nan m x y := - let f pl := B754_nan (fst pl) (snd pl) in - match x, y with - | B754_nan _ _, _ | _, B754_nan _ _ => f (plus_nan x y) - | B754_infinity sx, B754_infinity sy => - if Bool.eqb sx sy then x else f (plus_nan x y) - | B754_infinity _, _ => x - | _, B754_infinity _ => y - | B754_zero sx, B754_zero sy => - if Bool.eqb sx sy then x else - match m with mode_DN => B754_zero true | _ => B754_zero false end - | B754_zero _, _ => y - | _, B754_zero _ => x - | B754_finite sx mx ex Hx, B754_finite sy my ey Hy => - let ez := Zmin ex ey in - binary_normalize m (Zplus (cond_Zopp sx (Zpos (fst (shl_align mx ex ez)))) (cond_Zopp sy (Zpos (fst (shl_align my ey ez))))) - ez (match m with mode_DN => true | _ => false end) - end. - -Theorem Bplus_correct : - forall plus_nan m x y, - is_finite x = true -> - is_finite y = true -> - if Rlt_bool (Rabs (round radix2 fexp (round_mode m) (B2R x + B2R y))) (bpow radix2 emax) then - B2R (Bplus plus_nan m x y) = round radix2 fexp (round_mode m) (B2R x + B2R y) /\ - is_finite (Bplus plus_nan m x y) = true /\ - Bsign (Bplus plus_nan m x y) = - match Rcompare (B2R x + B2R y) 0 with - | Eq => match m with mode_DN => orb (Bsign x) (Bsign y) - | _ => andb (Bsign x) (Bsign y) end - | Lt => true - | Gt => false - end - else - (B2FF (Bplus plus_nan m x y) = binary_overflow m (Bsign x) /\ Bsign x = Bsign y). -Proof with auto with typeclass_instances. -intros plus_nan m [sx|sx| |sx mx ex Hx] [sy|sy| |sy my ey Hy] Fx Fy ; try easy. -(* *) -rewrite Rplus_0_r, round_0, Rabs_R0, Rlt_bool_true... -simpl. -rewrite Rcompare_Eq by auto. -destruct sx, sy; try easy; now case m. -apply bpow_gt_0. -(* *) -rewrite Rplus_0_l, round_generic, Rlt_bool_true... -split... split... -simpl. unfold F2R. -erewrite <- Rmult_0_l, Rcompare_mult_r. -rewrite Rcompare_Z2R with (y:=0%Z). -destruct sy... -apply bpow_gt_0. -apply abs_B2R_lt_emax. -apply generic_format_B2R. -(* *) -rewrite Rplus_0_r, round_generic, Rlt_bool_true... -split... split... -simpl. unfold F2R. -erewrite <- Rmult_0_l, Rcompare_mult_r. -rewrite Rcompare_Z2R with (y:=0%Z). -destruct sx... -apply bpow_gt_0. -apply abs_B2R_lt_emax. -apply generic_format_B2R. -(* *) -clear Fx Fy. -simpl. -set (szero := match m with mode_DN => true | _ => false end). -set (ez := Zmin ex ey). -set (mz := (cond_Zopp sx (Zpos (fst (shl_align mx ex ez))) + cond_Zopp sy (Zpos (fst (shl_align my ey ez))))%Z). -assert (Hp: (F2R (Float radix2 (cond_Zopp sx (Zpos mx)) ex) + - F2R (Float radix2 (cond_Zopp sy (Zpos my)) ey))%R = F2R (Float radix2 mz ez)). -rewrite 2!F2R_cond_Zopp. -generalize (shl_align_correct mx ex ez). -generalize (shl_align_correct my ey ez). -generalize (snd_shl_align mx ex ez (Zle_min_l ex ey)). -generalize (snd_shl_align my ey ez (Zle_min_r ex ey)). -destruct (shl_align mx ex ez) as (mx', ex'). -destruct (shl_align my ey ez) as (my', ey'). -simpl. -intros H1 H2. -rewrite H1, H2. -clear H1 H2. -intros (H1, _) (H2, _). -rewrite H1, H2. -clear H1 H2. -rewrite <- 2!F2R_cond_Zopp. -unfold F2R. simpl. -now rewrite <- Rmult_plus_distr_r, <- Z2R_plus. -rewrite Hp. -assert (Sz: (bpow radix2 emax <= Rabs (round radix2 fexp (round_mode m) (F2R (Float radix2 mz ez))))%R -> sx = Rlt_bool (F2R (Float radix2 mz ez)) 0 /\ sx = sy). -(* . *) -rewrite <- Hp. -intros Bz. -destruct (Bool.bool_dec sx sy) as [Hs|Hs]. -(* .. *) -refine (conj _ Hs). -rewrite Hs. -apply sym_eq. -case sy. -apply Rlt_bool_true. -rewrite <- (Rplus_0_r 0). -apply Rplus_lt_compat. -now apply F2R_lt_0_compat. -now apply F2R_lt_0_compat. -apply Rlt_bool_false. -rewrite <- (Rplus_0_r 0). -apply Rplus_le_compat. -now apply F2R_ge_0_compat. -now apply F2R_ge_0_compat. -(* .. *) -elim Rle_not_lt with (1 := Bz). -generalize (bounded_lt_emax _ _ Hx) (bounded_lt_emax _ _ Hy) (andb_prop _ _ Hx) (andb_prop _ _ Hy). -intros Bx By (Hx',_) (Hy',_). -generalize (canonic_canonic_mantissa sx _ _ Hx') (canonic_canonic_mantissa sy _ _ Hy'). -clear -Bx By Hs prec_gt_0_. -intros Cx Cy. -destruct sx. -(* ... *) -destruct sy. -now elim Hs. -clear Hs. -apply Rabs_lt. -split. -apply Rlt_le_trans with (F2R (Float radix2 (cond_Zopp true (Zpos mx)) ex)). -rewrite F2R_Zopp. -now apply Ropp_lt_contravar. -apply round_ge_generic... -now apply generic_format_canonic. -pattern (F2R (Float radix2 (cond_Zopp true (Zpos mx)) ex)) at 1 ; rewrite <- Rplus_0_r. -apply Rplus_le_compat_l. -now apply F2R_ge_0_compat. -apply Rle_lt_trans with (2 := By). -apply round_le_generic... -now apply generic_format_canonic. -rewrite <- (Rplus_0_l (F2R (Float radix2 (Zpos my) ey))). -apply Rplus_le_compat_r. -now apply F2R_le_0_compat. -(* ... *) -destruct sy. -2: now elim Hs. -clear Hs. -apply Rabs_lt. -split. -apply Rlt_le_trans with (F2R (Float radix2 (cond_Zopp true (Zpos my)) ey)). -rewrite F2R_Zopp. -now apply Ropp_lt_contravar. -apply round_ge_generic... -now apply generic_format_canonic. -pattern (F2R (Float radix2 (cond_Zopp true (Zpos my)) ey)) at 1 ; rewrite <- Rplus_0_l. -apply Rplus_le_compat_r. -now apply F2R_ge_0_compat. -apply Rle_lt_trans with (2 := Bx). -apply round_le_generic... -now apply generic_format_canonic. -rewrite <- (Rplus_0_r (F2R (Float radix2 (Zpos mx) ex))). -apply Rplus_le_compat_l. -now apply F2R_le_0_compat. -(* . *) -generalize (binary_normalize_correct m mz ez szero). -case Rlt_bool_spec. -split; try easy. split; try easy. -destruct (Rcompare_spec (F2R (beta:=radix2) {| Fnum := mz; Fexp := ez |}) 0); try easy. -rewrite H1 in Hp. -apply Rplus_opp_r_uniq in Hp. -rewrite <- F2R_Zopp in Hp. -eapply canonic_unicity in Hp. -inversion Hp. destruct sy, sx, m; try discriminate H3; easy. -apply canonic_canonic_mantissa. -apply Bool.andb_true_iff in Hy. easy. -replace (-cond_Zopp sx (Z.pos mx))%Z with (cond_Zopp (negb sx) (Z.pos mx)) - by (destruct sx; auto). -apply canonic_canonic_mantissa. -apply Bool.andb_true_iff in Hx. easy. -intros Hz' Vz. -specialize (Sz Hz'). -split. -rewrite Vz. -now apply f_equal. -apply Sz. -Qed. - -(** Subtraction *) - -Definition Bminus minus_nan m x y := Bplus minus_nan m x (Bopp pair y). - -Theorem Bminus_correct : - forall minus_nan m x y, - is_finite x = true -> - is_finite y = true -> - if Rlt_bool (Rabs (round radix2 fexp (round_mode m) (B2R x - B2R y))) (bpow radix2 emax) then - B2R (Bminus minus_nan m x y) = round radix2 fexp (round_mode m) (B2R x - B2R y) /\ - is_finite (Bminus minus_nan m x y) = true /\ - Bsign (Bminus minus_nan m x y) = - match Rcompare (B2R x - B2R y) 0 with - | Eq => match m with mode_DN => orb (Bsign x) (negb (Bsign y)) - | _ => andb (Bsign x) (negb (Bsign y)) end - | Lt => true - | Gt => false - end - else - (B2FF (Bminus minus_nan m x y) = binary_overflow m (Bsign x) /\ Bsign x = negb (Bsign y)). -Proof with auto with typeclass_instances. -intros m minus_nan x y Fx Fy. -replace (negb (Bsign y)) with (Bsign (Bopp pair y)). -unfold Rminus. -erewrite <- B2R_Bopp. -apply Bplus_correct. -exact Fx. -rewrite is_finite_Bopp. auto. now destruct y as [ | | | ]. -Qed. - -(** Division *) - -Definition Fdiv_core_binary m1 e1 m2 e2 := - let d1 := Zdigits2 m1 in - let d2 := Zdigits2 m2 in - let e := (e1 - e2)%Z in - let (m, e') := - match (d2 + prec - d1)%Z with - | Zpos p => (Z.shiftl m1 (Zpos p), e + Zneg p)%Z - | _ => (m1, e) - end in - let '(q, r) := Zfast_div_eucl m m2 in - (q, e', new_location m2 r loc_Exact). - -Lemma Bdiv_correct_aux : - forall m sx mx ex sy my ey, - let x := F2R (Float radix2 (cond_Zopp sx (Zpos mx)) ex) in - let y := F2R (Float radix2 (cond_Zopp sy (Zpos my)) ey) in - let z := - let '(mz, ez, lz) := Fdiv_core_binary (Zpos mx) ex (Zpos my) ey in - match mz with - | Zpos mz => binary_round_aux m (xorb sx sy) mz ez lz - | _ => F754_nan false xH (* dummy *) - end in - valid_binary z = true /\ - if Rlt_bool (Rabs (round radix2 fexp (round_mode m) (x / y))) (bpow radix2 emax) then - FF2R radix2 z = round radix2 fexp (round_mode m) (x / y) /\ - is_finite_FF z = true /\ sign_FF z = xorb sx sy - else - z = binary_overflow m (xorb sx sy). -Proof. -intros m sx mx ex sy my ey. -replace (Fdiv_core_binary (Zpos mx) ex (Zpos my) ey) with (Fdiv_core radix2 prec (Zpos mx) ex (Zpos my) ey). -refine (_ (Fdiv_core_correct radix2 prec (Zpos mx) ex (Zpos my) ey _ _ _)) ; try easy. -destruct (Fdiv_core radix2 prec (Zpos mx) ex (Zpos my) ey) as ((mz, ez), lz). -intros (Pz, Bz). -simpl. -replace (xorb sx sy) with (Rlt_bool (F2R (Float radix2 (cond_Zopp sx (Zpos mx)) ex) * - / F2R (Float radix2 (cond_Zopp sy (Zpos my)) ey)) 0). -unfold Rdiv. -destruct mz as [|mz|mz]. -(* . mz = 0 *) -elim (Zlt_irrefl prec). -now apply Zle_lt_trans with Z0. -(* . mz > 0 *) -apply binary_round_aux_correct. -rewrite Rabs_mult, Rabs_Rinv. -now rewrite <- 2!F2R_Zabs, 2!abs_cond_Zopp. -case sy. -apply Rlt_not_eq. -now apply F2R_lt_0_compat. -apply Rgt_not_eq. -now apply F2R_gt_0_compat. -revert Pz. -generalize (Zdigits radix2 (Zpos mz)). -unfold fexp, FLT_exp. -clear. -intros ; zify ; subst. -omega. -(* . mz < 0 *) -elim Rlt_not_le with (1 := proj2 (inbetween_float_bounds _ _ _ _ _ Bz)). -apply Rle_trans with R0. -apply F2R_le_0_compat. -now case mz. -apply Rmult_le_pos. -now apply F2R_ge_0_compat. -apply Rlt_le. -apply Rinv_0_lt_compat. -now apply F2R_gt_0_compat. -(* *) -case sy ; simpl. -change (Zneg my) with (Zopp (Zpos my)). -rewrite F2R_Zopp. -rewrite <- Ropp_inv_permute. -rewrite Ropp_mult_distr_r_reverse. -case sx ; simpl. -apply Rlt_bool_false. -rewrite <- Ropp_mult_distr_l_reverse. -apply Rmult_le_pos. -rewrite <- F2R_opp. -now apply F2R_ge_0_compat. -apply Rlt_le. -apply Rinv_0_lt_compat. -now apply F2R_gt_0_compat. -apply Rlt_bool_true. -rewrite <- Ropp_0. -apply Ropp_lt_contravar. -apply Rmult_lt_0_compat. -now apply F2R_gt_0_compat. -apply Rinv_0_lt_compat. -now apply F2R_gt_0_compat. -apply Rgt_not_eq. -now apply F2R_gt_0_compat. -case sx. -apply Rlt_bool_true. -rewrite F2R_Zopp. -rewrite Ropp_mult_distr_l_reverse. -rewrite <- Ropp_0. -apply Ropp_lt_contravar. -apply Rmult_lt_0_compat. -now apply F2R_gt_0_compat. -apply Rinv_0_lt_compat. -now apply F2R_gt_0_compat. -apply Rlt_bool_false. -apply Rmult_le_pos. -now apply F2R_ge_0_compat. -apply Rlt_le. -apply Rinv_0_lt_compat. -now apply F2R_gt_0_compat. -(* *) -unfold Fdiv_core_binary, Fdiv_core. -rewrite 2!Zdigits2_Zdigits. -change 2%Z with (radix_val radix2). -destruct (Zdigits radix2 (Z.pos my) + prec - Zdigits radix2 (Z.pos mx))%Z as [|p|p]. -now rewrite Zfast_div_eucl_correct. -rewrite Z.shiftl_mul_pow2 by easy. -now rewrite Zfast_div_eucl_correct. -now rewrite Zfast_div_eucl_correct. -Qed. - -Definition Bdiv div_nan m x y := - let f pl := B754_nan (fst pl) (snd pl) in - match x, y with - | B754_nan _ _, _ | _, B754_nan _ _ => f (div_nan x y) - | B754_infinity sx, B754_infinity sy => f (div_nan x y) - | B754_infinity sx, B754_finite sy _ _ _ => B754_infinity (xorb sx sy) - | B754_finite sx _ _ _, B754_infinity sy => B754_zero (xorb sx sy) - | B754_infinity sx, B754_zero sy => B754_infinity (xorb sx sy) - | B754_zero sx, B754_infinity sy => B754_zero (xorb sx sy) - | B754_finite sx _ _ _, B754_zero sy => B754_infinity (xorb sx sy) - | B754_zero sx, B754_finite sy _ _ _ => B754_zero (xorb sx sy) - | B754_zero sx, B754_zero sy => f (div_nan x y) - | B754_finite sx mx ex _, B754_finite sy my ey _ => - FF2B _ (proj1 (Bdiv_correct_aux m sx mx ex sy my ey)) - end. - -Theorem Bdiv_correct : - forall div_nan m x y, - B2R y <> 0%R -> - if Rlt_bool (Rabs (round radix2 fexp (round_mode m) (B2R x / B2R y))) (bpow radix2 emax) then - B2R (Bdiv div_nan m x y) = round radix2 fexp (round_mode m) (B2R x / B2R y) /\ - is_finite (Bdiv div_nan m x y) = is_finite x /\ - (is_nan (Bdiv div_nan m x y) = false -> - Bsign (Bdiv div_nan m x y) = xorb (Bsign x) (Bsign y)) - else - B2FF (Bdiv div_nan m x y) = binary_overflow m (xorb (Bsign x) (Bsign y)). -Proof. -intros div_nan m x [sy|sy|sy ply|sy my ey Hy] Zy ; try now elim Zy. -revert x. -unfold Rdiv. -intros [sx|sx|sx plx|sx mx ex Hx] ; - try ( rewrite Rmult_0_l, round_0, Rabs_R0, Rlt_bool_true ; [ now repeat constructor | apply bpow_gt_0 | auto with typeclass_instances ] ). -simpl. -case Bdiv_correct_aux. -intros H1. -unfold Rdiv. -case Rlt_bool. -intros (H2, (H3, H4)). -split. -now rewrite B2R_FF2B. -split. -now rewrite is_finite_FF2B. -rewrite Bsign_FF2B. congruence. -intros H2. -now rewrite B2FF_FF2B. -Qed. - -(** Square root *) - -Definition Fsqrt_core_binary m e := - let d := Zdigits2 m in - let s := Zmax (2 * prec - d) 0 in - let e' := (e - s)%Z in - let (s', e'') := if Zeven e' then (s, e') else (s + 1, e' - 1)%Z in - let m' := - match s' with - | Zpos p => Z.shiftl m (Zpos p) - | _ => m - end in - let (q, r) := Z.sqrtrem m' in - let l := - if Zeq_bool r 0 then loc_Exact - else loc_Inexact (if Zle_bool r q then Lt else Gt) in - (q, Zdiv2 e'', l). - -Lemma Bsqrt_correct_aux : - forall m mx ex (Hx : bounded mx ex = true), - let x := F2R (Float radix2 (Zpos mx) ex) in - let z := - let '(mz, ez, lz) := Fsqrt_core_binary (Zpos mx) ex in - match mz with - | Zpos mz => binary_round_aux m false mz ez lz - | _ => F754_nan false xH (* dummy *) - end in - valid_binary z = true /\ - FF2R radix2 z = round radix2 fexp (round_mode m) (sqrt x) /\ - is_finite_FF z = true /\ sign_FF z = false. -Proof with auto with typeclass_instances. -intros m mx ex Hx. -replace (Fsqrt_core_binary (Zpos mx) ex) with (Fsqrt_core radix2 prec (Zpos mx) ex). -simpl. -refine (_ (Fsqrt_core_correct radix2 prec (Zpos mx) ex _)) ; try easy. -destruct (Fsqrt_core radix2 prec (Zpos mx) ex) as ((mz, ez), lz). -intros (Pz, Bz). -destruct mz as [|mz|mz]. -(* . mz = 0 *) -elim (Zlt_irrefl prec). -now apply Zle_lt_trans with Z0. -(* . mz > 0 *) -refine (_ (binary_round_aux_correct m (sqrt (F2R (Float radix2 (Zpos mx) ex))) mz ez lz _ _)). -rewrite Rlt_bool_false. 2: apply sqrt_ge_0. -rewrite Rlt_bool_true. -easy. -(* .. *) -rewrite Rabs_pos_eq. -refine (_ (relative_error_FLT_ex radix2 emin prec (prec_gt_0 prec) (round_mode m) (sqrt (F2R (Float radix2 (Zpos mx) ex))) _)). -fold fexp. -intros (eps, (Heps, Hr)). -rewrite Hr. -assert (Heps': (Rabs eps < 1)%R). -apply Rlt_le_trans with (1 := Heps). -fold (bpow radix2 0). -apply bpow_le. -generalize (prec_gt_0 prec). -clear ; omega. -apply Rsqr_incrst_0. -3: apply bpow_ge_0. -rewrite Rsqr_mult. -rewrite Rsqr_sqrt. -2: now apply F2R_ge_0_compat. -unfold Rsqr. -apply Rmult_ge_0_gt_0_lt_compat. -apply Rle_ge. -apply Rle_0_sqr. -apply bpow_gt_0. -now apply bounded_lt_emax. -apply Rlt_le_trans with 4%R. -apply Rsqr_incrst_1. -apply Rplus_lt_compat_l. -apply (Rabs_lt_inv _ _ Heps'). -rewrite <- (Rplus_opp_r 1). -apply Rplus_le_compat_l. -apply Rlt_le. -apply (Rabs_lt_inv _ _ Heps'). -now apply (Z2R_le 0 2). -change 4%R with (bpow radix2 2). -apply bpow_le. -generalize (prec_gt_0 prec). -clear -Hmax ; omega. -apply Rmult_le_pos. -apply sqrt_ge_0. -rewrite <- (Rplus_opp_r 1). -apply Rplus_le_compat_l. -apply Rlt_le. -apply (Rabs_lt_inv _ _ Heps'). -rewrite Rabs_pos_eq. -2: apply sqrt_ge_0. -apply Rsqr_incr_0. -2: apply bpow_ge_0. -2: apply sqrt_ge_0. -rewrite Rsqr_sqrt. -2: now apply F2R_ge_0_compat. -apply Rle_trans with (bpow radix2 emin). -unfold Rsqr. -rewrite <- bpow_plus. -apply bpow_le. -unfold emin. -clear -Hmax ; omega. -apply generic_format_ge_bpow with fexp. -intros. -apply Zle_max_r. -now apply F2R_gt_0_compat. -apply generic_format_canonic. -apply (canonic_canonic_mantissa false). -apply (andb_prop _ _ Hx). -(* .. *) -apply round_ge_generic... -apply generic_format_0. -apply sqrt_ge_0. -rewrite Rabs_pos_eq. -exact Bz. -apply sqrt_ge_0. -revert Pz. -generalize (Zdigits radix2 (Zpos mz)). -unfold fexp, FLT_exp. -clear. -intros ; zify ; subst. -omega. -(* . mz < 0 *) -elim Rlt_not_le with (1 := proj2 (inbetween_float_bounds _ _ _ _ _ Bz)). -apply Rle_trans with R0. -apply F2R_le_0_compat. -now case mz. -apply sqrt_ge_0. -(* *) -unfold Fsqrt_core, Fsqrt_core_binary. -rewrite Zdigits2_Zdigits. -destruct (if Zeven _ then _ else _) as [[|s'|s'] e''] ; try easy. -now rewrite Z.shiftl_mul_pow2. -Qed. - -Definition Bsqrt sqrt_nan m x := - let f pl := B754_nan (fst pl) (snd pl) in - match x with - | B754_nan sx plx => f (sqrt_nan x) - | B754_infinity false => x - | B754_infinity true => f (sqrt_nan x) - | B754_finite true _ _ _ => f (sqrt_nan x) - | B754_zero _ => x - | B754_finite sx mx ex Hx => - FF2B _ (proj1 (Bsqrt_correct_aux m mx ex Hx)) - end. - -Theorem Bsqrt_correct : - forall sqrt_nan m x, - B2R (Bsqrt sqrt_nan m x) = round radix2 fexp (round_mode m) (sqrt (B2R x)) /\ - is_finite (Bsqrt sqrt_nan m x) = match x with B754_zero _ => true | B754_finite false _ _ _ => true | _ => false end /\ - (is_nan (Bsqrt sqrt_nan m x) = false -> Bsign (Bsqrt sqrt_nan m x) = Bsign x). -Proof. -intros sqrt_nan m [sx|[|]| |sx mx ex Hx] ; try ( now simpl ; rewrite sqrt_0, round_0 ; intuition auto with typeclass_instances ). -simpl. -case Bsqrt_correct_aux. -intros H1 (H2, (H3, H4)). -case sx. -refine (conj _ (conj (refl_equal false) _)). -apply sym_eq. -unfold sqrt. -case Rcase_abs. -intros _. -apply round_0. -auto with typeclass_instances. -intros H. -elim Rge_not_lt with (1 := H). -now apply F2R_lt_0_compat. -easy. -split. -now rewrite B2R_FF2B. -split. -now rewrite is_finite_FF2B. -intro. rewrite Bsign_FF2B. auto. -Qed. - -End Binary. diff --git a/flocq/Calc/Fcalc_bracket.v b/flocq/Calc/Bracket.v index 03ef7bd3..83714e87 100644 --- a/flocq/Calc/Fcalc_bracket.v +++ b/flocq/Calc/Bracket.v @@ -2,9 +2,9 @@ This file is part of the Flocq formalization of floating-point arithmetic in Coq: http://flocq.gforge.inria.fr/ -Copyright (C) 2010-2013 Sylvie Boldo +Copyright (C) 2010-2018 Sylvie Boldo #<br /># -Copyright (C) 2010-2013 Guillaume Melquiond +Copyright (C) 2010-2018 Guillaume Melquiond This library is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public @@ -19,9 +19,7 @@ COPYING file for more details. (** * Locations: where a real number is positioned with respect to its rounded-down value in an arbitrary format. *) -Require Import Fcore_Raux. -Require Import Fcore_defs. -Require Import Fcore_float_prop. +Require Import Raux Defs Float_prop. Section Fcalc_bracket. @@ -146,23 +144,17 @@ assert (0 < v < 1)%R. split. unfold v, Rdiv. apply Rmult_lt_0_compat. -case l. -now apply (Z2R_lt 0 2). -now apply (Z2R_lt 0 1). -now apply (Z2R_lt 0 3). +case l ; now apply IZR_lt. apply Rinv_0_lt_compat. -now apply (Z2R_lt 0 4). +now apply IZR_lt. unfold v, Rdiv. apply Rmult_lt_reg_r with 4%R. -now apply (Z2R_lt 0 4). +now apply IZR_lt. rewrite Rmult_assoc, Rinv_l. rewrite Rmult_1_r, Rmult_1_l. -case l. -now apply (Z2R_lt 2 4). -now apply (Z2R_lt 1 4). -now apply (Z2R_lt 3 4). +case l ; now apply IZR_lt. apply Rgt_not_eq. -now apply (Z2R_lt 0 4). +now apply IZR_lt. split. apply Rplus_lt_reg_r with (d * (v - 1))%R. ring_simplify. @@ -179,7 +171,7 @@ exact Hdu. set (v := (match l with Lt => 1 | Eq => 2 | Gt => 3 end)%R). rewrite <- (Rcompare_plus_r (- (d + u) / 2)). rewrite <- (Rcompare_mult_r 4). -2: now apply (Z2R_lt 0 4). +2: now apply IZR_lt. replace (((d + u) / 2 + - (d + u) / 2) * 4)%R with ((u - d) * 0)%R by field. replace ((d + v / 4 * (u - d) + - (d + u) / 2) * 4)%R with ((u - d) * (v - 2))%R by field. rewrite Rcompare_mult_l. @@ -187,10 +179,7 @@ rewrite Rcompare_mult_l. rewrite <- (Rcompare_plus_r 2). ring_simplify (v - 2 + 2)%R (0 + 2)%R. unfold v. -case l. -exact (Rcompare_Z2R 2 2). -exact (Rcompare_Z2R 1 2). -exact (Rcompare_Z2R 3 2). +case l ; apply Rcompare_IZR. Qed. Section Fcalc_bracket_step. @@ -201,19 +190,19 @@ Variable Hstep : (0 < step)%R. Lemma ordered_steps : forall k, - (start + Z2R k * step < start + Z2R (k + 1) * step)%R. + (start + IZR k * step < start + IZR (k + 1) * step)%R. Proof. intros k. apply Rplus_lt_compat_l. apply Rmult_lt_compat_r. exact Hstep. -apply Z2R_lt. +apply IZR_lt. apply Zlt_succ. Qed. Lemma middle_range : forall k, - ((start + (start + Z2R k * step)) / 2 = start + (Z2R k / 2 * step))%R. + ((start + (start + IZR k * step)) / 2 = start + (IZR k / 2 * step))%R. Proof. intros k. field. @@ -223,10 +212,10 @@ Hypothesis (Hnb_steps : (1 < nb_steps)%Z). Lemma inbetween_step_not_Eq : forall x k l l', - inbetween (start + Z2R k * step) (start + Z2R (k + 1) * step) x l -> + inbetween (start + IZR k * step) (start + IZR (k + 1) * step) x l -> (0 < k < nb_steps)%Z -> - Rcompare x (start + (Z2R nb_steps / 2 * step))%R = l' -> - inbetween start (start + Z2R nb_steps * step) x (loc_Inexact l'). + Rcompare x (start + (IZR nb_steps / 2 * step))%R = l' -> + inbetween start (start + IZR nb_steps * step) x (loc_Inexact l'). Proof. intros x k l l' Hx Hk Hl'. constructor. @@ -237,13 +226,13 @@ apply Rlt_le_trans with (2 := proj1 Hx'). rewrite <- (Rplus_0_r start) at 1. apply Rplus_lt_compat_l. apply Rmult_lt_0_compat. -now apply (Z2R_lt 0). +now apply IZR_lt. exact Hstep. apply Rlt_le_trans with (1 := proj2 Hx'). apply Rplus_le_compat_l. apply Rmult_le_compat_r. now apply Rlt_le. -apply Z2R_le. +apply IZR_le. omega. (* . *) now rewrite middle_range. @@ -251,9 +240,9 @@ Qed. Theorem inbetween_step_Lo : forall x k l, - inbetween (start + Z2R k * step) (start + Z2R (k + 1) * step) x l -> + inbetween (start + IZR k * step) (start + IZR (k + 1) * step) x l -> (0 < k)%Z -> (2 * k + 1 < nb_steps)%Z -> - inbetween start (start + Z2R nb_steps * step) x (loc_Inexact Lt). + inbetween start (start + IZR nb_steps * step) x (loc_Inexact Lt). Proof. intros x k l Hx Hk1 Hk2. apply inbetween_step_not_Eq with (1 := Hx). @@ -264,18 +253,17 @@ apply Rlt_le_trans with (1 := proj2 Hx'). apply Rcompare_not_Lt_inv. rewrite Rcompare_plus_l, Rcompare_mult_r, Rcompare_half_l. apply Rcompare_not_Lt. -change 2%R with (Z2R 2). -rewrite <- Z2R_mult. -apply Z2R_le. +rewrite <- mult_IZR. +apply IZR_le. omega. exact Hstep. Qed. Theorem inbetween_step_Hi : forall x k l, - inbetween (start + Z2R k * step) (start + Z2R (k + 1) * step) x l -> + inbetween (start + IZR k * step) (start + IZR (k + 1) * step) x l -> (nb_steps < 2 * k)%Z -> (k < nb_steps)%Z -> - inbetween start (start + Z2R nb_steps * step) x (loc_Inexact Gt). + inbetween start (start + IZR nb_steps * step) x (loc_Inexact Gt). Proof. intros x k l Hx Hk1 Hk2. apply inbetween_step_not_Eq with (1 := Hx). @@ -286,9 +274,8 @@ apply Rlt_le_trans with (2 := proj1 Hx'). apply Rcompare_Lt_inv. rewrite Rcompare_plus_l, Rcompare_mult_r, Rcompare_half_l. apply Rcompare_Lt. -change 2%R with (Z2R 2). -rewrite <- Z2R_mult. -apply Z2R_lt. +rewrite <- mult_IZR. +apply IZR_lt. omega. exact Hstep. Qed. @@ -297,7 +284,7 @@ Theorem inbetween_step_Lo_not_Eq : forall x l, inbetween start (start + step) x l -> l <> loc_Exact -> - inbetween start (start + Z2R nb_steps * step) x (loc_Inexact Lt). + inbetween start (start + IZR nb_steps * step) x (loc_Inexact Lt). Proof. intros x l Hx Hl. assert (Hx' := inbetween_bounds_not_Eq _ _ _ _ Hx Hl). @@ -310,7 +297,7 @@ apply Rplus_lt_compat_l. rewrite <- (Rmult_1_l step) at 1. apply Rmult_lt_compat_r. exact Hstep. -now apply (Z2R_lt 1). +now apply IZR_lt. (* . *) apply Rcompare_Lt. apply Rlt_le_trans with (1 := proj2 Hx'). @@ -320,7 +307,7 @@ rewrite <- (Rmult_1_l step) at 2. rewrite Rcompare_plus_l, Rcompare_mult_r, Rcompare_half_l. rewrite Rmult_1_r. apply Rcompare_not_Lt. -apply (Z2R_le 2). +apply IZR_le. now apply (Zlt_le_succ 1). exact Hstep. Qed. @@ -328,19 +315,19 @@ Qed. Lemma middle_odd : forall k, (2 * k + 1 = nb_steps)%Z -> - (((start + Z2R k * step) + (start + Z2R (k + 1) * step))/2 = start + Z2R nb_steps /2 * step)%R. + (((start + IZR k * step) + (start + IZR (k + 1) * step))/2 = start + IZR nb_steps /2 * step)%R. Proof. intros k Hk. rewrite <- Hk. -rewrite 2!Z2R_plus, Z2R_mult. +rewrite 2!plus_IZR, mult_IZR. simpl. field. Qed. Theorem inbetween_step_any_Mi_odd : forall x k l, - inbetween (start + Z2R k * step) (start + Z2R (k + 1) * step) x (loc_Inexact l) -> + inbetween (start + IZR k * step) (start + IZR (k + 1) * step) x (loc_Inexact l) -> (2 * k + 1 = nb_steps)%Z -> - inbetween start (start + Z2R nb_steps * step) x (loc_Inexact l). + inbetween start (start + IZR nb_steps * step) x (loc_Inexact l). Proof. intros x k l Hx Hk. apply inbetween_step_not_Eq with (1 := Hx). @@ -351,9 +338,9 @@ Qed. Theorem inbetween_step_Lo_Mi_Eq_odd : forall x k, - inbetween (start + Z2R k * step) (start + Z2R (k + 1) * step) x loc_Exact -> + inbetween (start + IZR k * step) (start + IZR (k + 1) * step) x loc_Exact -> (2 * k + 1 = nb_steps)%Z -> - inbetween start (start + Z2R nb_steps * step) x (loc_Inexact Lt). + inbetween start (start + IZR nb_steps * step) x (loc_Inexact Lt). Proof. intros x k Hx Hk. apply inbetween_step_not_Eq with (1 := Hx). @@ -362,9 +349,8 @@ inversion_clear Hx as [Hl|]. rewrite Hl. rewrite Rcompare_plus_l, Rcompare_mult_r, Rcompare_half_r. apply Rcompare_Lt. -change 2%R with (Z2R 2). -rewrite <- Z2R_mult. -apply Z2R_lt. +rewrite <- mult_IZR. +apply IZR_lt. rewrite <- Hk. apply Zlt_succ. exact Hstep. @@ -372,10 +358,10 @@ Qed. Theorem inbetween_step_Hi_Mi_even : forall x k l, - inbetween (start + Z2R k * step) (start + Z2R (k + 1) * step) x l -> + inbetween (start + IZR k * step) (start + IZR (k + 1) * step) x l -> l <> loc_Exact -> (2 * k = nb_steps)%Z -> - inbetween start (start + Z2R nb_steps * step) x (loc_Inexact Gt). + inbetween start (start + IZR nb_steps * step) x (loc_Inexact Gt). Proof. intros x k l Hx Hl Hk. apply inbetween_step_not_Eq with (1 := Hx). @@ -385,28 +371,26 @@ assert (Hx' := inbetween_bounds_not_Eq _ _ _ _ Hx Hl). apply Rle_lt_trans with (2 := proj1 Hx'). apply Rcompare_not_Lt_inv. rewrite Rcompare_plus_l, Rcompare_mult_r, Rcompare_half_r. -change 2%R with (Z2R 2). -rewrite <- Z2R_mult. +rewrite <- mult_IZR. apply Rcompare_not_Lt. -apply Z2R_le. +apply IZR_le. rewrite Hk. -apply Zle_refl. +apply Z.le_refl. exact Hstep. Qed. Theorem inbetween_step_Mi_Mi_even : forall x k, - inbetween (start + Z2R k * step) (start + Z2R (k + 1) * step) x loc_Exact -> + inbetween (start + IZR k * step) (start + IZR (k + 1) * step) x loc_Exact -> (2 * k = nb_steps)%Z -> - inbetween start (start + Z2R nb_steps * step) x (loc_Inexact Eq). + inbetween start (start + IZR nb_steps * step) x (loc_Inexact Eq). Proof. intros x k Hx Hk. apply inbetween_step_not_Eq with (1 := Hx). omega. apply Rcompare_Eq. inversion_clear Hx as [Hx'|]. -rewrite Hx', <- Hk, Z2R_mult. -simpl (Z2R 2). +rewrite Hx', <- Hk, mult_IZR. field. Qed. @@ -419,17 +403,17 @@ Definition new_location_even k l := match l with loc_Exact => l | _ => loc_Inexact Lt end else loc_Inexact - match Zcompare (2 * k) nb_steps with + match Z.compare (2 * k) nb_steps with | Lt => Lt | Eq => match l with loc_Exact => Eq | _ => Gt end | Gt => Gt end. Theorem new_location_even_correct : - Zeven nb_steps = true -> + Z.even nb_steps = true -> forall x k l, (0 <= k < nb_steps)%Z -> - inbetween (start + Z2R k * step) (start + Z2R (k + 1) * step) x l -> - inbetween start (start + Z2R nb_steps * step) x (new_location_even k l). + inbetween (start + IZR k * step) (start + IZR (k + 1) * step) x l -> + inbetween start (start + IZR nb_steps * step) x (new_location_even k l). Proof. intros He x k l Hk Hx. unfold new_location_even. @@ -476,17 +460,17 @@ Definition new_location_odd k l := match l with loc_Exact => l | _ => loc_Inexact Lt end else loc_Inexact - match Zcompare (2 * k + 1) nb_steps with + match Z.compare (2 * k + 1) nb_steps with | Lt => Lt | Eq => match l with loc_Inexact l => l | loc_Exact => Lt end | Gt => Gt end. Theorem new_location_odd_correct : - Zeven nb_steps = false -> + Z.even nb_steps = false -> forall x k l, (0 <= k < nb_steps)%Z -> - inbetween (start + Z2R k * step) (start + Z2R (k + 1) * step) x l -> - inbetween start (start + Z2R nb_steps * step) x (new_location_odd k l). + inbetween (start + IZR k * step) (start + IZR (k + 1) * step) x l -> + inbetween start (start + IZR nb_steps * step) x (new_location_odd k l). Proof. intros Ho x k l Hk Hx. unfold new_location_odd. @@ -520,16 +504,16 @@ apply Hk. Qed. Definition new_location := - if Zeven nb_steps then new_location_even else new_location_odd. + if Z.even nb_steps then new_location_even else new_location_odd. Theorem new_location_correct : forall x k l, (0 <= k < nb_steps)%Z -> - inbetween (start + Z2R k * step) (start + Z2R (k + 1) * step) x l -> - inbetween start (start + Z2R nb_steps * step) x (new_location k l). + inbetween (start + IZR k * step) (start + IZR (k + 1) * step) x l -> + inbetween start (start + IZR nb_steps * step) x (new_location k l). Proof. intros x k l Hk Hx. unfold new_location. -generalize (refl_equal nb_steps) (Zle_lt_trans _ _ _ (proj1 Hk) (proj2 Hk)). +generalize (refl_equal nb_steps) (Z.le_lt_trans _ _ _ (proj1 Hk) (proj2 Hk)). pattern nb_steps at 2 3 5 ; case nb_steps. now intros _. (* . *) @@ -603,7 +587,7 @@ intros x m e l [Hx|l' Hx Hl]. rewrite Hx. split. apply Rle_refl. -apply F2R_lt_compat. +apply F2R_lt. apply Zlt_succ. split. now apply Rlt_le. @@ -613,13 +597,13 @@ Qed. (** Specialization of inbetween for two consecutive integers. *) Definition inbetween_int m x l := - inbetween (Z2R m) (Z2R (m + 1)) x l. + inbetween (IZR m) (IZR (m + 1)) x l. Theorem inbetween_float_new_location : forall x m e l k, (0 < k)%Z -> inbetween_float m e x l -> - inbetween_float (Zdiv m (Zpower beta k)) (e + k) x (new_location (Zpower beta k) (Zmod m (Zpower beta k)) l). + inbetween_float (Z.div m (Zpower beta k)) (e + k) x (new_location (Zpower beta k) (Zmod m (Zpower beta k)) l). Proof. intros x m e l k Hk Hx. unfold inbetween_float in *. @@ -630,19 +614,19 @@ apply (f_equal (fun r => F2R (Float beta (m * Zpower _ r) e))). ring. omega. assert (Hp: (Zpower beta k > 0)%Z). -apply Zlt_gt. +apply Z.lt_gt. apply Zpower_gt_0. now apply Zlt_le_weak. (* . *) rewrite 2!Hr. rewrite Zmult_plus_distr_l, Zmult_1_l. unfold F2R at 2. simpl. -rewrite Z2R_plus, Rmult_plus_distr_r. +rewrite plus_IZR, Rmult_plus_distr_r. apply new_location_correct. apply bpow_gt_0. now apply Zpower_gt_1. now apply Z_mod_lt. -rewrite <- 2!Rmult_plus_distr_r, <- 2!Z2R_plus. +rewrite <- 2!Rmult_plus_distr_r, <- 2!plus_IZR. rewrite Zmult_comm, Zplus_assoc. now rewrite <- Z_div_mod_eq. Qed. @@ -650,7 +634,7 @@ Qed. Theorem inbetween_float_new_location_single : forall x m e l, inbetween_float m e x l -> - inbetween_float (Zdiv m beta) (e + 1) x (new_location beta (Zmod m beta) l). + inbetween_float (Z.div m beta) (e + 1) x (new_location beta (Zmod m beta) l). Proof. intros x m e l Hx. replace (radix_val beta) with (Zpower beta 1). @@ -665,7 +649,7 @@ Theorem inbetween_float_ex : Proof. intros m e l. apply inbetween_ex. -apply F2R_lt_compat. +apply F2R_lt. apply Zlt_succ. Qed. @@ -682,7 +666,7 @@ apply inbetween_unique with (1 := H) (2 := H'). destruct (inbetween_float_bounds x m e l H) as (H1,H2). destruct (inbetween_float_bounds x m' e l' H') as (H3,H4). cut (m < m' + 1 /\ m' < m + 1)%Z. clear ; omega. -now split ; apply F2R_lt_reg with beta e ; apply Rle_lt_trans with x. +now split ; apply lt_F2R with beta e ; apply Rle_lt_trans with x. Qed. End Fcalc_bracket_generic. diff --git a/flocq/Calc/Div.v b/flocq/Calc/Div.v new file mode 100644 index 00000000..65195562 --- /dev/null +++ b/flocq/Calc/Div.v @@ -0,0 +1,159 @@ +(** +This file is part of the Flocq formalization of floating-point +arithmetic in Coq: http://flocq.gforge.inria.fr/ + +Copyright (C) 2010-2018 Sylvie Boldo +#<br /># +Copyright (C) 2010-2018 Guillaume Melquiond + +This library is free software; you can redistribute it and/or +modify it under the terms of the GNU Lesser General Public +License as published by the Free Software Foundation; either +version 3 of the License, or (at your option) any later version. + +This library is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +COPYING file for more details. +*) + +(** * Helper function and theorem for computing the rounded quotient of two floating-point numbers. *) + +Require Import Raux Defs Generic_fmt Float_prop Digits Bracket. + +Set Implicit Arguments. +Set Strongly Strict Implicit. + +Section Fcalc_div. + +Variable beta : radix. +Notation bpow e := (bpow beta e). + +Variable fexp : Z -> Z. + +(** Computes a mantissa of precision p, the corresponding exponent, + and the position with respect to the real quotient of the + input floating-point numbers. + +The algorithm performs the following steps: +- Shift dividend mantissa so that it has at least p2 + p digits. +- Perform the Euclidean division. +- Compute the position according to the division remainder. + +Complexity is fine as long as p1 <= 2p and p2 <= p. +*) + +Lemma mag_div_F2R : + forall m1 e1 m2 e2, + (0 < m1)%Z -> (0 < m2)%Z -> + let e := ((Zdigits beta m1 + e1) - (Zdigits beta m2 + e2))%Z in + (e <= mag beta (F2R (Float beta m1 e1) / F2R (Float beta m2 e2)) <= e + 1)%Z. +Proof. +intros m1 e1 m2 e2 Hm1 Hm2. +rewrite <- (mag_F2R_Zdigits beta m1 e1) by now apply Zgt_not_eq. +rewrite <- (mag_F2R_Zdigits beta m2 e2) by now apply Zgt_not_eq. +apply mag_div. +now apply F2R_neq_0, Zgt_not_eq. +now apply F2R_neq_0, Zgt_not_eq. +Qed. + +Definition Fdiv_core m1 e1 m2 e2 e := + let (m1', m2') := + if Zle_bool e (e1 - e2)%Z + then (m1 * Zpower beta (e1 - e2 - e), m2)%Z + else (m1, m2 * Zpower beta (e - (e1 - e2)))%Z in + let '(q, r) := Z.div_eucl m1' m2' in + (q, new_location m2' r loc_Exact). + +Theorem Fdiv_core_correct : + forall m1 e1 m2 e2 e, + (0 < m1)%Z -> (0 < m2)%Z -> + let '(m, l) := Fdiv_core m1 e1 m2 e2 e in + inbetween_float beta m e (F2R (Float beta m1 e1) / F2R (Float beta m2 e2)) l. +Proof. +intros m1 e1 m2 e2 e Hm1 Hm2. +unfold Fdiv_core. +match goal with |- context [if ?b then ?b1 else ?b2] => set (m12 := if b then b1 else b2) end. +case_eq m12 ; intros m1' m2' Hm. +assert ((F2R (Float beta m1 e1) / F2R (Float beta m2 e2) = IZR m1' / IZR m2' * bpow e)%R /\ (0 < m2')%Z) as [Hf Hm2']. +{ unfold F2R, Zminus ; simpl. + destruct (Zle_bool e (e1 - e2)) eqn:He' ; injection Hm ; intros ; subst. + - split ; try easy. + apply Zle_bool_imp_le in He'. + rewrite mult_IZR, IZR_Zpower by omega. + unfold Zminus ; rewrite 2!bpow_plus, 2!bpow_opp. + field. + repeat split ; try apply Rgt_not_eq, bpow_gt_0. + now apply IZR_neq, Zgt_not_eq. + - apply Z.leb_gt in He'. + split ; cycle 1. + { apply Z.mul_pos_pos with (1 := Hm2). + apply Zpower_gt_0 ; omega. } + rewrite mult_IZR, IZR_Zpower by omega. + unfold Zminus ; rewrite bpow_plus, bpow_opp, bpow_plus, bpow_opp. + field. + repeat split ; try apply Rgt_not_eq, bpow_gt_0. + now apply IZR_neq, Zgt_not_eq. } +clearbody m12 ; clear Hm Hm1 Hm2. +generalize (Z_div_mod m1' m2' (Z.lt_gt _ _ Hm2')). +destruct (Z.div_eucl m1' m2') as (q, r). +intros (Hq, Hr). +rewrite Hf. +unfold inbetween_float, F2R. simpl. +rewrite Hq, 2!plus_IZR, mult_IZR. +apply inbetween_mult_compat. + apply bpow_gt_0. +destruct (Z_lt_le_dec 1 m2') as [Hm2''|Hm2'']. +- replace 1%R with (IZR m2' * /IZR m2')%R. + apply new_location_correct ; try easy. + apply Rinv_0_lt_compat. + now apply IZR_lt. + constructor. + field. + now apply IZR_neq, Zgt_not_eq. + field. + now apply IZR_neq, Zgt_not_eq. +- assert (r = 0 /\ m2' = 1)%Z as [-> ->] by (clear -Hr Hm2'' ; omega). + unfold Rdiv. + rewrite Rmult_1_l, Rplus_0_r, Rinv_1, Rmult_1_r. + now constructor. +Qed. + +Definition Fdiv (x y : float beta) := + let (m1, e1) := x in + let (m2, e2) := y in + let e' := ((Zdigits beta m1 + e1) - (Zdigits beta m2 + e2))%Z in + let e := Z.min (Z.min (fexp e') (fexp (e' + 1))) (e1 - e2) in + let '(m, l) := Fdiv_core m1 e1 m2 e2 e in + (m, e, l). + +Theorem Fdiv_correct : + forall x y, + (0 < F2R x)%R -> (0 < F2R y)%R -> + let '(m, e, l) := Fdiv x y in + (e <= cexp beta fexp (F2R x / F2R y))%Z /\ + inbetween_float beta m e (F2R x / F2R y) l. +Proof. +intros [m1 e1] [m2 e2] Hm1 Hm2. +apply gt_0_F2R in Hm1. +apply gt_0_F2R in Hm2. +unfold Fdiv. +generalize (mag_div_F2R m1 e1 m2 e2 Hm1 Hm2). +set (e := Zminus _ _). +set (e' := Z.min (Z.min (fexp e) (fexp (e + 1))) (e1 - e2)). +intros [H1 H2]. +generalize (Fdiv_core_correct m1 e1 m2 e2 e' Hm1 Hm2). +destruct Fdiv_core as [m' l]. +apply conj. +apply Z.le_trans with (1 := Z.le_min_l _ _). +unfold cexp. +destruct (Zle_lt_or_eq _ _ H1) as [H|H]. +- replace (fexp (mag _ _)) with (fexp (e + 1)). + apply Z.le_min_r. + clear -H1 H2 H ; apply f_equal ; omega. +- replace (fexp (mag _ _)) with (fexp e). + apply Z.le_min_l. + clear -H1 H2 H ; apply f_equal ; omega. +Qed. + +End Fcalc_div. diff --git a/flocq/Calc/Fcalc_digits.v b/flocq/Calc/Fcalc_digits.v deleted file mode 100644 index 45133e81..00000000 --- a/flocq/Calc/Fcalc_digits.v +++ /dev/null @@ -1,63 +0,0 @@ -(** -This file is part of the Flocq formalization of floating-point -arithmetic in Coq: http://flocq.gforge.inria.fr/ - -Copyright (C) 2010-2013 Sylvie Boldo -#<br /># -Copyright (C) 2010-2013 Guillaume Melquiond - -This library is free software; you can redistribute it and/or -modify it under the terms of the GNU Lesser General Public -License as published by the Free Software Foundation; either -version 3 of the License, or (at your option) any later version. - -This library is distributed in the hope that it will be useful, -but WITHOUT ANY WARRANTY; without even the implied warranty of -MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -COPYING file for more details. -*) - -(** * Functions for computing the number of digits of integers and related theorems. *) - -Require Import Fcore_Raux. -Require Import Fcore_defs. -Require Import Fcore_float_prop. -Require Import Fcore_digits. - -Section Fcalc_digits. - -Variable beta : radix. -Notation bpow e := (bpow beta e). - -Theorem Zdigits_ln_beta : - forall n, - n <> Z0 -> - Zdigits beta n = ln_beta beta (Z2R n). -Proof. -intros n Hn. -destruct (ln_beta beta (Z2R n)) as (e, He) ; simpl. -specialize (He (Z2R_neq _ _ Hn)). -rewrite <- Z2R_abs in He. -assert (Hd := Zdigits_correct beta n). -assert (Hd' := Zdigits_gt_0 beta n). -apply Zle_antisym ; apply (bpow_lt_bpow beta). -apply Rle_lt_trans with (2 := proj2 He). -rewrite <- Z2R_Zpower by omega. -now apply Z2R_le. -apply Rle_lt_trans with (1 := proj1 He). -rewrite <- Z2R_Zpower by omega. -now apply Z2R_lt. -Qed. - -Theorem ln_beta_F2R_Zdigits : - forall m e, m <> Z0 -> - (ln_beta beta (F2R (Float beta m e)) = Zdigits beta m + e :> Z)%Z. -Proof. -intros m e Hm. -rewrite ln_beta_F2R with (1 := Hm). -apply (f_equal (fun v => Zplus v e)). -apply sym_eq. -now apply Zdigits_ln_beta. -Qed. - -End Fcalc_digits. diff --git a/flocq/Calc/Fcalc_div.v b/flocq/Calc/Fcalc_div.v deleted file mode 100644 index c8f1f9fc..00000000 --- a/flocq/Calc/Fcalc_div.v +++ /dev/null @@ -1,165 +0,0 @@ -(** -This file is part of the Flocq formalization of floating-point -arithmetic in Coq: http://flocq.gforge.inria.fr/ - -Copyright (C) 2010-2013 Sylvie Boldo -#<br /># -Copyright (C) 2010-2013 Guillaume Melquiond - -This library is free software; you can redistribute it and/or -modify it under the terms of the GNU Lesser General Public -License as published by the Free Software Foundation; either -version 3 of the License, or (at your option) any later version. - -This library is distributed in the hope that it will be useful, -but WITHOUT ANY WARRANTY; without even the implied warranty of -MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -COPYING file for more details. -*) - -(** * Helper function and theorem for computing the rounded quotient of two floating-point numbers. *) - -Require Import Fcore_Raux. -Require Import Fcore_defs. -Require Import Fcore_float_prop. -Require Import Fcore_digits. -Require Import Fcalc_bracket. -Require Import Fcalc_digits. - -Section Fcalc_div. - -Variable beta : radix. -Notation bpow e := (bpow beta e). - -(** Computes a mantissa of precision p, the corresponding exponent, - and the position with respect to the real quotient of the - input floating-point numbers. - -The algorithm performs the following steps: -- Shift dividend mantissa so that it has at least p2 + p digits. -- Perform the Euclidean division. -- Compute the position according to the division remainder. - -Complexity is fine as long as p1 <= 2p and p2 <= p. -*) - -Definition Fdiv_core prec m1 e1 m2 e2 := - let d1 := Zdigits beta m1 in - let d2 := Zdigits beta m2 in - let e := (e1 - e2)%Z in - let (m, e') := - match (d2 + prec - d1)%Z with - | Zpos p => (m1 * Zpower_pos beta p, e + Zneg p)%Z - | _ => (m1, e) - end in - let '(q, r) := Zdiv_eucl m m2 in - (q, e', new_location m2 r loc_Exact). - -Theorem Fdiv_core_correct : - forall prec m1 e1 m2 e2, - (0 < prec)%Z -> - (0 < m1)%Z -> (0 < m2)%Z -> - let '(m, e, l) := Fdiv_core prec m1 e1 m2 e2 in - (prec <= Zdigits beta m)%Z /\ - inbetween_float beta m e (F2R (Float beta m1 e1) / F2R (Float beta m2 e2)) l. -Proof. -intros prec m1 e1 m2 e2 Hprec Hm1 Hm2. -unfold Fdiv_core. -set (d1 := Zdigits beta m1). -set (d2 := Zdigits beta m2). -case_eq - (match (d2 + prec - d1)%Z with - | Zpos p => ((m1 * Zpower_pos beta p)%Z, (e1 - e2 + Zneg p)%Z) - | _ => (m1, (e1 - e2)%Z) - end). -intros m' e' Hme. -(* . the shifted mantissa m' has enough digits *) -assert (Hs: F2R (Float beta m' (e' + e2)) = F2R (Float beta m1 e1) /\ (0 < m')%Z /\ (d2 + prec <= Zdigits beta m')%Z). -replace (d2 + prec)%Z with (d2 + prec - d1 + d1)%Z by ring. -destruct (d2 + prec - d1)%Z as [|p|p] ; - unfold d1 ; - inversion Hme. -ring_simplify (e1 - e2 + e2)%Z. -repeat split. -now rewrite <- H0. -apply Zle_refl. -replace (e1 - e2 + Zneg p + e2)%Z with (e1 - Zpos p)%Z by (unfold Zminus ; simpl ; ring). -fold (Zpower beta (Zpos p)). -split. -pattern (Zpos p) at 1 ; replace (Zpos p) with (e1 - (e1 - Zpos p))%Z by ring. -apply sym_eq. -apply F2R_change_exp. -assert (0 < Zpos p)%Z by easy. -omega. -split. -apply Zmult_lt_0_compat. -exact Hm1. -now apply Zpower_gt_0. -rewrite Zdigits_mult_Zpower. -rewrite Zplus_comm. -apply Zle_refl. -apply sym_not_eq. -now apply Zlt_not_eq. -easy. -split. -now ring_simplify (e1 - e2 + e2)%Z. -assert (Zneg p < 0)%Z by easy. -omega. -(* . *) -destruct Hs as (Hs1, (Hs2, Hs3)). -rewrite <- Hs1. -generalize (Z_div_mod m' m2 (Zlt_gt _ _ Hm2)). -destruct (Zdiv_eucl m' m2) as (q, r). -intros (Hq, Hr). -split. -(* . the result mantissa q has enough digits *) -cut (Zdigits beta m' <= d2 + Zdigits beta q)%Z. omega. -unfold d2. -rewrite Hq. -assert (Hq': (0 < q)%Z). -apply Zmult_lt_reg_r with (1 := Hm2). -assert (m2 < m')%Z. -apply lt_Zdigits with beta. -now apply Zlt_le_weak. -unfold d2 in Hs3. -clear -Hprec Hs3 ; omega. -cut (q * m2 = m' - r)%Z. clear -Hr H ; omega. -rewrite Hq. -ring. -apply Zle_trans with (Zdigits beta (m2 + q + m2 * q)). -apply Zdigits_le. -rewrite <- Hq. -now apply Zlt_le_weak. -clear -Hr Hq'. omega. -apply Zdigits_mult_strong ; apply Zlt_le_weak. -now apply Zle_lt_trans with r. -exact Hq'. -(* . the location is correctly computed *) -unfold inbetween_float, F2R. simpl. -rewrite bpow_plus, Z2R_plus. -rewrite Hq, Z2R_plus, Z2R_mult. -replace ((Z2R m2 * Z2R q + Z2R r) * (bpow e' * bpow e2) / (Z2R m2 * bpow e2))%R - with ((Z2R q + Z2R r / Z2R m2) * bpow e')%R. -apply inbetween_mult_compat. -apply bpow_gt_0. -destruct (Z_lt_le_dec 1 m2) as [Hm2''|Hm2'']. -replace (Z2R 1) with (Z2R m2 * /Z2R m2)%R. -apply new_location_correct ; try easy. -apply Rinv_0_lt_compat. -now apply (Z2R_lt 0). -now constructor. -apply Rinv_r. -apply Rgt_not_eq. -now apply (Z2R_lt 0). -assert (r = 0 /\ m2 = 1)%Z by (clear -Hr Hm2'' ; omega). -rewrite (proj1 H), (proj2 H). -unfold Rdiv. -rewrite Rmult_0_l, Rplus_0_r. -now constructor. -field. -split ; apply Rgt_not_eq. -apply bpow_gt_0. -now apply (Z2R_lt 0). -Qed. - -End Fcalc_div. diff --git a/flocq/Calc/Fcalc_sqrt.v b/flocq/Calc/Fcalc_sqrt.v deleted file mode 100644 index 5f541d83..00000000 --- a/flocq/Calc/Fcalc_sqrt.v +++ /dev/null @@ -1,244 +0,0 @@ -(** -This file is part of the Flocq formalization of floating-point -arithmetic in Coq: http://flocq.gforge.inria.fr/ - -Copyright (C) 2010-2013 Sylvie Boldo -#<br /># -Copyright (C) 2010-2013 Guillaume Melquiond - -This library is free software; you can redistribute it and/or -modify it under the terms of the GNU Lesser General Public -License as published by the Free Software Foundation; either -version 3 of the License, or (at your option) any later version. - -This library is distributed in the hope that it will be useful, -but WITHOUT ANY WARRANTY; without even the implied warranty of -MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -COPYING file for more details. -*) - -(** * Helper functions and theorems for computing the rounded square root of a floating-point number. *) - -Require Import Fcore_Raux. -Require Import Fcore_defs. -Require Import Fcore_digits. -Require Import Fcore_float_prop. -Require Import Fcalc_bracket. -Require Import Fcalc_digits. - -Section Fcalc_sqrt. - -Variable beta : radix. -Notation bpow e := (bpow beta e). - -(** Computes a mantissa of precision p, the corresponding exponent, - and the position with respect to the real square root of the - input floating-point number. - -The algorithm performs the following steps: -- Shift the mantissa so that it has at least 2p-1 digits; - shift it one digit more if the new exponent is not even. -- Compute the square root s (at least p digits) of the new - mantissa, and its remainder r. -- Compute the position according to the remainder: - -- r == 0 => Eq, - -- r <= s => Lo, - -- r >= s => Up. - -Complexity is fine as long as p1 <= 2p-1. -*) - -Definition Fsqrt_core prec m e := - let d := Zdigits beta m in - let s := Zmax (2 * prec - d) 0 in - let e' := (e - s)%Z in - let (s', e'') := if Zeven e' then (s, e') else (s + 1, e' - 1)%Z in - let m' := - match s' with - | Zpos p => (m * Zpower_pos beta p)%Z - | _ => m - end in - let (q, r) := Z.sqrtrem m' in - let l := - if Zeq_bool r 0 then loc_Exact - else loc_Inexact (if Zle_bool r q then Lt else Gt) in - (q, Zdiv2 e'', l). - -Theorem Fsqrt_core_correct : - forall prec m e, - (0 < m)%Z -> - let '(m', e', l) := Fsqrt_core prec m e in - (prec <= Zdigits beta m')%Z /\ - inbetween_float beta m' e' (sqrt (F2R (Float beta m e))) l. -Proof. -intros prec m e Hm. -unfold Fsqrt_core. -set (d := Zdigits beta m). -set (s := Zmax (2 * prec - d) 0). -(* . exponent *) -case_eq (if Zeven (e - s) then (s, (e - s)%Z) else ((s + 1)%Z, (e - s - 1)%Z)). -intros s' e' Hse. -assert (He: (Zeven e' = true /\ 0 <= s' /\ 2 * prec - d <= s' /\ s' + e' = e)%Z). -revert Hse. -case_eq (Zeven (e - s)) ; intros He Hse ; inversion Hse. -repeat split. -exact He. -unfold s. -apply Zle_max_r. -apply Zle_max_l. -ring. -assert (H: (Zmax (2 * prec - d) 0 <= s + 1)%Z). -fold s. -apply Zle_succ. -repeat split. -unfold Zminus at 1. -now rewrite Zeven_plus, He. -apply Zle_trans with (2 := H). -apply Zle_max_r. -apply Zle_trans with (2 := H). -apply Zle_max_l. -ring. -clear -Hm He. -destruct He as (He1, (He2, (He3, He4))). -(* . shift *) -set (m' := match s' with - | Z0 => m - | Zpos p => (m * Zpower_pos beta p)%Z - | Zneg _ => m - end). -assert (Hs: F2R (Float beta m' e') = F2R (Float beta m e) /\ (2 * prec <= Zdigits beta m')%Z /\ (0 < m')%Z). -rewrite <- He4. -unfold m'. -destruct s' as [|p|p]. -repeat split ; try easy. -fold d. -omega. -fold (Zpower beta (Zpos p)). -split. -replace (Zpos p) with (Zpos p + e' - e')%Z by ring. -rewrite <- F2R_change_exp. -apply (f_equal (fun v => F2R (Float beta m v))). -ring. -assert (0 < Zpos p)%Z by easy. -omega. -split. -rewrite Zdigits_mult_Zpower. -fold d. -omega. -apply sym_not_eq. -now apply Zlt_not_eq. -easy. -apply Zmult_lt_0_compat. -exact Hm. -now apply Zpower_gt_0. -now elim He2. -clearbody m'. -destruct Hs as (Hs1, (Hs2, Hs3)). -generalize (Z.sqrtrem_spec m' (Zlt_le_weak _ _ Hs3)). -destruct (Z.sqrtrem m') as (q, r). -intros (Hq, Hr). -rewrite <- Hs1. clear Hs1. -split. -(* . mantissa width *) -apply Zmult_le_reg_r with 2%Z. -easy. -rewrite Zmult_comm. -apply Zle_trans with (1 := Hs2). -rewrite Hq. -apply Zle_trans with (Zdigits beta (q + q + q * q)). -apply Zdigits_le. -rewrite <- Hq. -now apply Zlt_le_weak. -omega. -replace (Zdigits beta q * 2)%Z with (Zdigits beta q + Zdigits beta q)%Z by ring. -apply Zdigits_mult_strong. -omega. -omega. -(* . round *) -unfold inbetween_float, F2R. simpl. -rewrite sqrt_mult. -2: now apply (Z2R_le 0) ; apply Zlt_le_weak. -2: apply Rlt_le ; apply bpow_gt_0. -destruct (Zeven_ex e') as (e2, Hev). -rewrite He1, Zplus_0_r in Hev. clear He1. -rewrite Hev. -replace (Zdiv2 (2 * e2)) with e2 by now case e2. -replace (2 * e2)%Z with (e2 + e2)%Z by ring. -rewrite bpow_plus. -fold (Rsqr (bpow e2)). -rewrite sqrt_Rsqr. -2: apply Rlt_le ; apply bpow_gt_0. -apply inbetween_mult_compat. -apply bpow_gt_0. -rewrite Hq. -case Zeq_bool_spec ; intros Hr'. -(* .. r = 0 *) -rewrite Hr', Zplus_0_r, Z2R_mult. -fold (Rsqr (Z2R q)). -rewrite sqrt_Rsqr. -now constructor. -apply (Z2R_le 0). -omega. -(* .. r <> 0 *) -constructor. -split. -(* ... bounds *) -apply Rle_lt_trans with (sqrt (Z2R (q * q))). -rewrite Z2R_mult. -fold (Rsqr (Z2R q)). -rewrite sqrt_Rsqr. -apply Rle_refl. -apply (Z2R_le 0). -omega. -apply sqrt_lt_1. -rewrite Z2R_mult. -apply Rle_0_sqr. -rewrite <- Hq. -apply (Z2R_le 0). -now apply Zlt_le_weak. -apply Z2R_lt. -omega. -apply Rlt_le_trans with (sqrt (Z2R ((q + 1) * (q + 1)))). -apply sqrt_lt_1. -rewrite <- Hq. -apply (Z2R_le 0). -now apply Zlt_le_weak. -rewrite Z2R_mult. -apply Rle_0_sqr. -apply Z2R_lt. -ring_simplify. -omega. -rewrite Z2R_mult. -fold (Rsqr (Z2R (q + 1))). -rewrite sqrt_Rsqr. -apply Rle_refl. -apply (Z2R_le 0). -omega. -(* ... location *) -rewrite Rcompare_half_r. -rewrite <- Rcompare_sqr. -replace ((2 * sqrt (Z2R (q * q + r))) * (2 * sqrt (Z2R (q * q + r))))%R - with (4 * Rsqr (sqrt (Z2R (q * q + r))))%R by (unfold Rsqr ; ring). -rewrite Rsqr_sqrt. -change 4%R with (Z2R 4). -rewrite <- Z2R_plus, <- 2!Z2R_mult. -rewrite Rcompare_Z2R. -replace ((q + (q + 1)) * (q + (q + 1)))%Z with (4 * (q * q) + 4 * q + 1)%Z by ring. -generalize (Zle_cases r q). -case (Zle_bool r q) ; intros Hr''. -change (4 * (q * q + r) < 4 * (q * q) + 4 * q + 1)%Z. -omega. -change (4 * (q * q + r) > 4 * (q * q) + 4 * q + 1)%Z. -omega. -rewrite <- Hq. -apply (Z2R_le 0). -now apply Zlt_le_weak. -apply Rmult_le_pos. -now apply (Z2R_le 0 2). -apply sqrt_ge_0. -rewrite <- Z2R_plus. -apply (Z2R_le 0). -omega. -Qed. - -End Fcalc_sqrt. diff --git a/flocq/Calc/Fcalc_ops.v b/flocq/Calc/Operations.v index e834c044..3416cb4e 100644 --- a/flocq/Calc/Fcalc_ops.v +++ b/flocq/Calc/Operations.v @@ -2,9 +2,9 @@ This file is part of the Flocq formalization of floating-point arithmetic in Coq: http://flocq.gforge.inria.fr/ -Copyright (C) 2010-2013 Sylvie Boldo +Copyright (C) 2009-2018 Sylvie Boldo #<br /># -Copyright (C) 2010-2013 Guillaume Melquiond +Copyright (C) 2009-2018 Guillaume Melquiond This library is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public @@ -18,9 +18,10 @@ COPYING file for more details. *) (** Basic operations on floats: alignment, addition, multiplication *) -Require Import Fcore_Raux. -Require Import Fcore_defs. -Require Import Fcore_float_prop. +Require Import Raux Defs Float_prop. + +Set Implicit Arguments. +Set Strongly Strict Implicit. Section Float_ops. @@ -28,7 +29,7 @@ Variable beta : radix. Notation bpow e := (bpow beta e). -Arguments Float {beta} Fnum Fexp. +Arguments Float {beta}. Definition Falign (f1 f2 : float beta) := let '(Float m1 e1) := f1 in @@ -54,7 +55,7 @@ Qed. Theorem Falign_spec_exp: forall f1 f2 : float beta, - snd (Falign f1 f2) = Zmin (Fexp f1) (Fexp f2). + snd (Falign f1 f2) = Z.min (Fexp f1) (Fexp f2). Proof. intros (m1,e1) (m2,e2). unfold Falign; simpl. @@ -76,7 +77,7 @@ Qed. Definition Fabs (f1 : float beta) : float beta := let '(Float m1 e1) := f1 in - Float (Zabs m1)%Z e1. + Float (Z.abs m1)%Z e1. Theorem F2R_abs : forall f1 : float beta, @@ -100,7 +101,7 @@ destruct (Falign f1 f2) as ((m1, m2), e). intros (H1, H2). rewrite H1, H2. unfold F2R. simpl. -rewrite Z2R_plus. +rewrite plus_IZR. apply Rmult_plus_distr_r. Qed. @@ -116,7 +117,7 @@ Qed. Theorem Fexp_Fplus : forall f1 f2 : float beta, - Fexp (Fplus f1 f2) = Zmin (Fexp f1) (Fexp f2). + Fexp (Fplus f1 f2) = Z.min (Fexp f1) (Fexp f2). Proof. intros f1 f2. unfold Fplus. @@ -156,7 +157,7 @@ Theorem F2R_mult : Proof. intros (m1, e1) (m2, e2). unfold Fmult, F2R. simpl. -rewrite Z2R_mult, bpow_plus. +rewrite mult_IZR, bpow_plus. ring. Qed. diff --git a/flocq/Calc/Fcalc_round.v b/flocq/Calc/Round.v index 86422247..5bde6af4 100644 --- a/flocq/Calc/Fcalc_round.v +++ b/flocq/Calc/Round.v @@ -2,9 +2,9 @@ This file is part of the Flocq formalization of floating-point arithmetic in Coq: http://flocq.gforge.inria.fr/ -Copyright (C) 2010-2013 Sylvie Boldo +Copyright (C) 2010-2018 Sylvie Boldo #<br /># -Copyright (C) 2010-2013 Guillaume Melquiond +Copyright (C) 2010-2018 Guillaume Melquiond This library is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public @@ -19,10 +19,7 @@ COPYING file for more details. (** * Helper function for computing the rounded value of a real number. *) -Require Import Fcore. -Require Import Fcore_digits. -Require Import Fcalc_bracket. -Require Import Fcalc_digits. +Require Import Core Digits Float_prop Bracket. Section Fcalc_round. @@ -35,19 +32,78 @@ Variable fexp : Z -> Z. Context { valid_exp : Valid_exp fexp }. Notation format := (generic_format beta fexp). +Theorem cexp_inbetween_float : + forall x m e l, + (0 < x)%R -> + inbetween_float beta m e x l -> + (e <= cexp beta fexp x \/ e <= fexp (Zdigits beta m + e))%Z -> + cexp beta fexp x = fexp (Zdigits beta m + e). +Proof. +intros x m e l Px Bx He. +unfold cexp. +apply inbetween_float_bounds in Bx. +assert (0 <= m)%Z as Hm. +{ apply Zlt_succ_le. + eapply gt_0_F2R. + apply Rlt_trans with (1 := Px). + apply Bx. } +destruct (Zle_lt_or_eq _ _ Hm) as [Hm'|<-]. + now erewrite <- mag_F2R_bounds_Zdigits with (1 := Hm'). +clear Hm. +assert (mag beta x <= e)%Z as Hx. +{ apply mag_le_bpow. + now apply Rgt_not_eq. + rewrite Rabs_pos_eq. + now rewrite <- F2R_bpow. + now apply Rlt_le. } +simpl in He |- *. +clear Bx. +destruct He as [He|He]. +- apply eq_sym, valid_exp with (2 := He). + now apply Z.le_trans with e. +- apply valid_exp with (1 := He). + now apply Z.le_trans with e. +Qed. + +Theorem cexp_inbetween_float_loc_Exact : + forall x m e l, + (0 <= x)%R -> + inbetween_float beta m e x l -> + (e <= cexp beta fexp x \/ l = loc_Exact <-> + e <= fexp (Zdigits beta m + e) \/ l = loc_Exact)%Z. +Proof. +intros x m e l Px Bx. +destruct Px as [Px|Px]. +- split ; (intros [H|H] ; [left|now right]). + rewrite <- cexp_inbetween_float with (1 := Px) (2 := Bx). + exact H. + now left. + rewrite cexp_inbetween_float with (1 := Px) (2 := Bx). + exact H. + now right. +- assert (H := Bx). + destruct Bx as [|c Bx _]. + now split ; right. + rewrite <- Px in Bx. + destruct Bx as [Bx1 Bx2]. + apply lt_0_F2R in Bx1. + apply gt_0_F2R in Bx2. + omega. +Qed. + (** Relates location and rounding. *) Theorem inbetween_float_round : forall rnd choice, ( forall x m l, inbetween_int m x l -> rnd x = choice m l ) -> forall x m l, - let e := canonic_exp beta fexp x in + let e := cexp beta fexp x in inbetween_float beta m e x l -> round beta fexp rnd x = F2R (Float beta (choice m l) e). Proof. intros rnd choice Hc x m l e Hl. unfold round, F2R. simpl. -apply (f_equal (fun m => (Z2R m * bpow e)%R)). +apply (f_equal (fun m => (IZR m * bpow e)%R)). apply Hc. apply inbetween_mult_reg with (bpow e). apply bpow_gt_0. @@ -61,12 +117,12 @@ Theorem inbetween_float_round_sign : ( forall x m l, inbetween_int m (Rabs x) l -> rnd x = cond_Zopp (Rlt_bool x 0) (choice (Rlt_bool x 0) m l) ) -> forall x m l, - let e := canonic_exp beta fexp x in + let e := cexp beta fexp x in inbetween_float beta m e (Rabs x) l -> round beta fexp rnd x = F2R (Float beta (cond_Zopp (Rlt_bool x 0) (choice (Rlt_bool x 0) m l)) e). Proof. intros rnd choice Hc x m l e Hx. -apply (f_equal (fun m => (Z2R m * bpow e)%R)). +apply (f_equal (fun m => (IZR m * bpow e)%R)). simpl. replace (Rlt_bool x 0) with (Rlt_bool (scaled_mantissa beta fexp x) 0). (* *) @@ -99,13 +155,13 @@ Proof. intros x m l Hl. refine (Zfloor_imp m _ _). apply inbetween_bounds with (2 := Hl). -apply Z2R_lt. +apply IZR_lt. apply Zlt_succ. Qed. Theorem inbetween_float_DN : forall x m l, - let e := canonic_exp beta fexp x in + let e := cexp beta fexp x in inbetween_float beta m e x l -> round beta fexp Zfloor x = F2R (Float beta m e). Proof. @@ -131,23 +187,23 @@ destruct (Rcase_abs x) as [Zx|Zx] . rewrite Rlt_bool_true with (1 := Zx). inversion_clear Hl ; simpl. rewrite <- (Ropp_involutive x). -rewrite H, <- Z2R_opp. -apply Zfloor_Z2R. +rewrite H, <- opp_IZR. +apply Zfloor_IZR. apply Zfloor_imp. split. apply Rlt_le. -rewrite Z2R_opp. +rewrite opp_IZR. apply Ropp_lt_cancel. now rewrite Ropp_involutive. ring_simplify (- (m + 1) + 1)%Z. -rewrite Z2R_opp. +rewrite opp_IZR. apply Ropp_lt_cancel. now rewrite Ropp_involutive. (* *) rewrite Rlt_bool_false. inversion_clear Hl ; simpl. rewrite H. -apply Zfloor_Z2R. +apply Zfloor_IZR. apply Zfloor_imp. split. now apply Rlt_le. @@ -157,7 +213,7 @@ Qed. Theorem inbetween_float_DN_sign : forall x m l, - let e := canonic_exp beta fexp x in + let e := cexp beta fexp x in inbetween_float beta m e (Rabs x) l -> round beta fexp Zfloor x = F2R (Float beta (cond_Zopp (Rlt_bool x 0) (cond_incr (round_sign_DN (Rlt_bool x 0) l) m)) e). Proof. @@ -186,7 +242,7 @@ destruct Hl' as [Hl'|(Hl1, Hl2)]. rewrite Hl'. destruct Hl ; try easy. rewrite H. -exact (Zceil_Z2R _). +exact (Zceil_IZR _). (* not Exact *) rewrite Hl2. simpl. @@ -198,7 +254,7 @@ Qed. Theorem inbetween_float_UP : forall x m l, - let e := canonic_exp beta fexp x in + let e := cexp beta fexp x in inbetween_float beta m e x l -> round beta fexp Zceil x = F2R (Float beta (cond_incr (round_UP l) m) e). Proof. @@ -227,7 +283,7 @@ unfold Zceil. apply f_equal. inversion_clear Hl ; simpl. rewrite H. -apply Zfloor_Z2R. +apply Zfloor_IZR. apply Zfloor_imp. split. now apply Rlt_le. @@ -237,10 +293,10 @@ rewrite Rlt_bool_false. simpl. inversion_clear Hl ; simpl. rewrite H. -apply Zceil_Z2R. +apply Zceil_IZR. apply Zceil_imp. split. -change (m + 1 - 1)%Z with (Zpred (Zsucc m)). +change (m + 1 - 1)%Z with (Z.pred (Z.succ m)). now rewrite <- Zpred_succ. now apply Rlt_le. now apply Rge_le. @@ -248,7 +304,7 @@ Qed. Theorem inbetween_float_UP_sign : forall x m l, - let e := canonic_exp beta fexp x in + let e := cexp beta fexp x in inbetween_float beta m e (Rabs x) l -> round beta fexp Zceil x = F2R (Float beta (cond_Zopp (Rlt_bool x 0) (cond_incr (round_sign_UP (Rlt_bool x 0) l) m)) e). Proof. @@ -273,7 +329,7 @@ intros x m l Hl. inversion_clear Hl as [Hx|l' Hx Hl']. (* Exact *) rewrite Hx. -rewrite Zrnd_Z2R... +rewrite Zrnd_IZR... (* not Exact *) unfold Ztrunc. assert (Hm: Zfloor x = m). @@ -288,10 +344,10 @@ case Rlt_bool_spec ; intros Hx' ; elim Rlt_not_le with (1 := Hx'). apply Rlt_le. apply Rle_lt_trans with (2 := proj1 Hx). -now apply (Z2R_le 0). +now apply IZR_le. elim Rle_not_lt with (1 := Hx'). apply Rlt_le_trans with (1 := proj2 Hx). -apply (Z2R_le _ 0). +apply IZR_le. now apply Zlt_le_succ. rewrite Hm. now apply Rlt_not_eq. @@ -299,7 +355,7 @@ Qed. Theorem inbetween_float_ZR : forall x m l, - let e := canonic_exp beta fexp x in + let e := cexp beta fexp x in inbetween_float beta m e x l -> round beta fexp Ztrunc x = F2R (Float beta (cond_incr (round_ZR (Zlt_bool m 0) l) m) e). Proof. @@ -324,7 +380,7 @@ apply f_equal. apply Zfloor_imp. rewrite <- Rabs_left with (1 := Zx). apply inbetween_bounds with (2 := Hl). -apply Z2R_lt. +apply IZR_lt. apply Zlt_succ. (* *) rewrite Rlt_bool_false with (1 := Zx). @@ -332,13 +388,13 @@ simpl. apply Zfloor_imp. rewrite <- Rabs_pos_eq with (1 := Zx). apply inbetween_bounds with (2 := Hl). -apply Z2R_lt. +apply IZR_lt. apply Zlt_succ. Qed. Theorem inbetween_float_ZR_sign : forall x m l, - let e := canonic_exp beta fexp x in + let e := cexp beta fexp x in inbetween_float beta m e (Rabs x) l -> round beta fexp Ztrunc x = F2R (Float beta (cond_Zopp (Rlt_bool x 0) m) e). Proof. @@ -365,7 +421,7 @@ intros choice x m l Hl. inversion_clear Hl as [Hx|l' Hx Hl']. (* Exact *) rewrite Hx. -rewrite Zrnd_Z2R... +rewrite Zrnd_IZR... (* not Exact *) unfold Znearest. assert (Hm: Zfloor x = m). @@ -373,13 +429,12 @@ apply Zfloor_imp. exact (conj (Rlt_le _ _ (proj1 Hx)) (proj2 Hx)). rewrite Zceil_floor_neq. rewrite Hm. -replace (Rcompare (x - Z2R m) (/2)) with l'. +replace (Rcompare (x - IZR m) (/2)) with l'. now case l'. rewrite <- Hl'. -rewrite Z2R_plus. -rewrite <- (Rcompare_plus_r (- Z2R m) x). +rewrite plus_IZR. +rewrite <- (Rcompare_plus_r (- IZR m) x). apply f_equal. -simpl (Z2R 1). field. rewrite Hm. now apply Rlt_not_eq. @@ -402,20 +457,19 @@ rewrite Znearest_opp. apply f_equal. inversion_clear Hl as [Hx|l' Hx Hl']. rewrite Hx. -apply Zrnd_Z2R... +apply Zrnd_IZR... assert (Hm: Zfloor (-x) = m). apply Zfloor_imp. exact (conj (Rlt_le _ _ (proj1 Hx)) (proj2 Hx)). unfold Znearest. rewrite Zceil_floor_neq. rewrite Hm. -replace (Rcompare (- x - Z2R m) (/2)) with l'. +replace (Rcompare (- x - IZR m) (/2)) with l'. now case l'. rewrite <- Hl'. -rewrite Z2R_plus. -rewrite <- (Rcompare_plus_r (- Z2R m) (-x)). +rewrite plus_IZR. +rewrite <- (Rcompare_plus_r (- IZR m) (-x)). apply f_equal. -simpl (Z2R 1). field. rewrite Hm. now apply Rlt_not_eq. @@ -426,20 +480,19 @@ rewrite Rlt_bool_false with (1 := Zx). simpl. inversion_clear Hl as [Hx|l' Hx Hl']. rewrite Hx. -apply Zrnd_Z2R... +apply Zrnd_IZR... assert (Hm: Zfloor x = m). apply Zfloor_imp. exact (conj (Rlt_le _ _ (proj1 Hx)) (proj2 Hx)). unfold Znearest. rewrite Zceil_floor_neq. rewrite Hm. -replace (Rcompare (x - Z2R m) (/2)) with l'. +replace (Rcompare (x - IZR m) (/2)) with l'. now case l'. rewrite <- Hl'. -rewrite Z2R_plus. -rewrite <- (Rcompare_plus_r (- Z2R m) x). +rewrite plus_IZR. +rewrite <- (Rcompare_plus_r (- IZR m) x). apply f_equal. -simpl (Z2R 1). field. rewrite Hm. now apply Rlt_not_eq. @@ -450,44 +503,44 @@ Qed. Theorem inbetween_int_NE : forall x m l, inbetween_int m x l -> - ZnearestE x = cond_incr (round_N (negb (Zeven m)) l) m. + ZnearestE x = cond_incr (round_N (negb (Z.even m)) l) m. Proof. intros x m l Hl. -now apply inbetween_int_N with (choice := fun x => negb (Zeven x)). +now apply inbetween_int_N with (choice := fun x => negb (Z.even x)). Qed. Theorem inbetween_float_NE : forall x m l, - let e := canonic_exp beta fexp x in + let e := cexp beta fexp x in inbetween_float beta m e x l -> - round beta fexp ZnearestE x = F2R (Float beta (cond_incr (round_N (negb (Zeven m)) l) m) e). + round beta fexp ZnearestE x = F2R (Float beta (cond_incr (round_N (negb (Z.even m)) l) m) e). Proof. -apply inbetween_float_round with (choice := fun m l => cond_incr (round_N (negb (Zeven m)) l) m). +apply inbetween_float_round with (choice := fun m l => cond_incr (round_N (negb (Z.even m)) l) m). exact inbetween_int_NE. Qed. Theorem inbetween_int_NE_sign : forall x m l, inbetween_int m (Rabs x) l -> - ZnearestE x = cond_Zopp (Rlt_bool x 0) (cond_incr (round_N (negb (Zeven m)) l) m). + ZnearestE x = cond_Zopp (Rlt_bool x 0) (cond_incr (round_N (negb (Z.even m)) l) m). Proof. intros x m l Hl. -erewrite inbetween_int_N_sign with (choice := fun x => negb (Zeven x)). +erewrite inbetween_int_N_sign with (choice := fun x => negb (Z.even x)). 2: eexact Hl. apply f_equal. case Rlt_bool. -rewrite Zeven_opp, Zeven_plus. -now case (Zeven m). +rewrite Z.even_opp, Z.even_add. +now case (Z.even m). apply refl_equal. Qed. Theorem inbetween_float_NE_sign : forall x m l, - let e := canonic_exp beta fexp x in + let e := cexp beta fexp x in inbetween_float beta m e (Rabs x) l -> - round beta fexp ZnearestE x = F2R (Float beta (cond_Zopp (Rlt_bool x 0) (cond_incr (round_N (negb (Zeven m)) l) m)) e). + round beta fexp ZnearestE x = F2R (Float beta (cond_Zopp (Rlt_bool x 0) (cond_incr (round_N (negb (Z.even m)) l) m)) e). Proof. -apply inbetween_float_round_sign with (choice := fun s m l => cond_incr (round_N (negb (Zeven m)) l) m). +apply inbetween_float_round_sign with (choice := fun s m l => cond_incr (round_N (negb (Z.even m)) l) m). exact inbetween_int_NE_sign. Qed. @@ -504,7 +557,7 @@ Qed. Theorem inbetween_float_NA : forall x m l, - let e := canonic_exp beta fexp x in + let e := cexp beta fexp x in inbetween_float beta m e x l -> round beta fexp ZnearestA x = F2R (Float beta (cond_incr (round_N (Zle_bool 0 m) l) m) e). Proof. @@ -523,11 +576,11 @@ erewrite inbetween_int_N_sign with (choice := Zle_bool 0). apply f_equal. assert (Hm: (0 <= m)%Z). apply Zlt_succ_le. -apply lt_Z2R. +apply lt_IZR. apply Rle_lt_trans with (Rabs x). apply Rabs_pos. refine (proj2 (inbetween_bounds _ _ _ _ _ Hl)). -apply Z2R_lt. +apply IZR_lt. apply Zlt_succ. rewrite Zle_bool_true with (1 := Hm). rewrite Zle_bool_false. @@ -538,7 +591,7 @@ Qed. Definition truncate_aux t k := let '(m, e, l) := t in let p := Zpower beta k in - (Zdiv m p, (e + k)%Z, new_location p (Zmod m p) l). + (Z.div m p, (e + k)%Z, new_location p (Zmod m p) l). Theorem truncate_aux_comp : forall t k1 k2, @@ -597,28 +650,28 @@ case Zlt_bool_spec ; intros Hk. unfold truncate_aux. apply generic_format_F2R. intros Hd. -unfold canonic_exp. -rewrite ln_beta_F2R_Zdigits with (1 := Hd). +unfold cexp. +rewrite mag_F2R_Zdigits with (1 := Hd). rewrite Zdigits_div_Zpower with (1 := Hm). replace (Zdigits beta m - k + (e + k))%Z with (Zdigits beta m + e)%Z by ring. unfold k. ring_simplify. -apply Zle_refl. +apply Z.le_refl. split. now apply Zlt_le_weak. apply Znot_gt_le. contradict Hd. apply Zdiv_small. apply conj with (1 := Hm). -rewrite <- Zabs_eq with (1 := Hm). +rewrite <- Z.abs_eq with (1 := Hm). apply Zpower_gt_Zdigits. apply Zlt_le_weak. -now apply Zgt_lt. +now apply Z.gt_lt. (* *) destruct (Zle_lt_or_eq _ _ Hm) as [Hm'|Hm']. apply generic_format_F2R. -unfold canonic_exp. -rewrite ln_beta_F2R_Zdigits. +unfold cexp. +rewrite mag_F2R_Zdigits. 2: now apply Zgt_not_eq. unfold k in Hk. clear -Hk. omega. @@ -633,26 +686,26 @@ Theorem truncate_correct_format : generic_format beta fexp x -> (e <= fexp (Zdigits beta m + e))%Z -> let '(m', e', l') := truncate (m, e, loc_Exact) in - x = F2R (Float beta m' e') /\ e' = canonic_exp beta fexp x. + x = F2R (Float beta m' e') /\ e' = cexp beta fexp x. Proof. intros m e Hm x Fx He. -assert (Hc: canonic_exp beta fexp x = fexp (Zdigits beta m + e)). -unfold canonic_exp, x. -now rewrite ln_beta_F2R_Zdigits. +assert (Hc: cexp beta fexp x = fexp (Zdigits beta m + e)). +unfold cexp, x. +now rewrite mag_F2R_Zdigits. unfold truncate. rewrite <- Hc. -set (k := (canonic_exp beta fexp x - e)%Z). +set (k := (cexp beta fexp x - e)%Z). case Zlt_bool_spec ; intros Hk. (* *) unfold truncate_aux. rewrite Fx at 1. -assert (H: (e + k)%Z = canonic_exp beta fexp x). +assert (H: (e + k)%Z = cexp beta fexp x). unfold k. ring. refine (conj _ H). rewrite <- H. -apply F2R_eq_compat. -replace (scaled_mantissa beta fexp x) with (Z2R (Zfloor (scaled_mantissa beta fexp x))). -rewrite Ztrunc_Z2R. +apply F2R_eq. +replace (scaled_mantissa beta fexp x) with (IZR (Zfloor (scaled_mantissa beta fexp x))). +rewrite Ztrunc_IZR. unfold scaled_mantissa. rewrite <- H. unfold x, F2R. simpl. @@ -666,7 +719,7 @@ intros H. generalize (Zpower_pos_gt_0 beta k) (Zle_bool_imp_le _ _ (radix_prop beta)). omega. rewrite scaled_mantissa_generic with (1 := Fx). -now rewrite Zfloor_Z2R. +now rewrite Zfloor_IZR. (* *) split. apply refl_equal. @@ -674,73 +727,111 @@ unfold k in Hk. omega. Qed. +Theorem truncate_correct_partial' : + forall x m e l, + (0 < x)%R -> + inbetween_float beta m e x l -> + (e <= cexp beta fexp x)%Z -> + let '(m', e', l') := truncate (m, e, l) in + inbetween_float beta m' e' x l' /\ e' = cexp beta fexp x. +Proof. +intros x m e l Hx H1 H2. +unfold truncate. +rewrite <- cexp_inbetween_float with (1 := Hx) (2 := H1) by now left. +generalize (Zlt_cases 0 (cexp beta fexp x - e)). +destruct Zlt_bool ; intros Hk. +- split. + now apply inbetween_float_new_location. + ring. +- apply (conj H1). + omega. +Qed. + Theorem truncate_correct_partial : forall x m e l, (0 < x)%R -> inbetween_float beta m e x l -> (e <= fexp (Zdigits beta m + e))%Z -> let '(m', e', l') := truncate (m, e, l) in - inbetween_float beta m' e' x l' /\ e' = canonic_exp beta fexp x. + inbetween_float beta m' e' x l' /\ e' = cexp beta fexp x. Proof. intros x m e l Hx H1 H2. -unfold truncate. -set (k := (fexp (Zdigits beta m + e) - e)%Z). -set (p := Zpower beta k). -(* *) -assert (Hx': (F2R (Float beta m e) <= x < F2R (Float beta (m + 1) e))%R). -apply inbetween_float_bounds with (1 := H1). -(* *) -assert (Hm: (0 <= m)%Z). -cut (0 < m + 1)%Z. omega. -apply F2R_lt_reg with beta e. -rewrite F2R_0. -apply Rlt_trans with (1 := Hx). -apply Hx'. -assert (He: (e + k = canonic_exp beta fexp x)%Z). -(* . *) -unfold canonic_exp. -destruct (Zle_lt_or_eq _ _ Hm) as [Hm'|Hm']. -(* .. 0 < m *) -rewrite ln_beta_F2R_bounds with (1 := Hm') (2 := Hx'). -assert (H: m <> Z0). -apply sym_not_eq. -now apply Zlt_not_eq. -rewrite ln_beta_F2R with (1 := H). -rewrite <- Zdigits_ln_beta with (1 := H). -unfold k. -ring. -(* .. m = 0 *) -rewrite <- Hm' in H2. -destruct (ln_beta beta x) as (ex, Hex). -simpl. -specialize (Hex (Rgt_not_eq _ _ Hx)). -unfold k. -ring_simplify. -rewrite <- Hm'. -simpl. -apply sym_eq. -apply valid_exp. -exact H2. -apply Zle_trans with e. -eapply bpow_lt_bpow. -apply Rle_lt_trans with (1 := proj1 Hex). -rewrite Rabs_pos_eq. -rewrite <- F2R_bpow. -rewrite <- Hm' in Hx'. -apply Hx'. -now apply Rlt_le. +apply truncate_correct_partial' with (1 := Hx) (2 := H1). +rewrite cexp_inbetween_float with (1 := Hx) (2 := H1). exact H2. -(* . *) -generalize (Zlt_cases 0 k). -case (Zlt_bool 0 k) ; intros Hk ; unfold k in Hk. -split. -now apply inbetween_float_new_location. -exact He. -split. -exact H1. -rewrite <- He. -unfold k. -omega. +now right. +Qed. + +Theorem truncate_correct' : + forall x m e l, + (0 <= x)%R -> + inbetween_float beta m e x l -> + (e <= cexp beta fexp x)%Z \/ l = loc_Exact -> + let '(m', e', l') := truncate (m, e, l) in + inbetween_float beta m' e' x l' /\ + (e' = cexp beta fexp x \/ (l' = loc_Exact /\ format x)). +Proof. +intros x m e l [Hx|Hx] H1 H2. +- destruct (Zle_or_lt e (fexp (Zdigits beta m + e))) as [H3|H3]. + + generalize (truncate_correct_partial x m e l Hx H1 H3). + destruct (truncate (m, e, l)) as [[m' e'] l']. + intros [H4 H5]. + apply (conj H4). + now left. + + destruct H2 as [H2|H2]. + generalize (truncate_correct_partial' x m e l Hx H1 H2). + destruct (truncate (m, e, l)) as [[m' e'] l']. + intros [H4 H5]. + apply (conj H4). + now left. + rewrite H2 in H1 |- *. + simpl. + generalize (Zlt_cases 0 (fexp (Zdigits beta m + e) - e)). + destruct Zlt_bool. + intros H. + apply False_ind. + omega. + intros _. + apply (conj H1). + right. + repeat split. + inversion_clear H1. + rewrite H. + apply generic_format_F2R. + intros Zm. + unfold cexp. + rewrite mag_F2R_Zdigits with (1 := Zm). + now apply Zlt_le_weak. +- assert (Hm: m = 0%Z). + cut (m <= 0 < m + 1)%Z. omega. + assert (F2R (Float beta m e) <= x < F2R (Float beta (m + 1) e))%R as Hx'. + apply inbetween_float_bounds with (1 := H1). + rewrite <- Hx in Hx'. + split. + apply le_0_F2R with (1 := proj1 Hx'). + apply gt_0_F2R with (1 := proj2 Hx'). + rewrite Hm, <- Hx in H1 |- *. + clear -H1. + destruct H1 as [_ | l' [H _] _]. + + assert (exists e', truncate (Z0, e, loc_Exact) = (Z0, e', loc_Exact)). + unfold truncate, truncate_aux. + case Zlt_bool. + rewrite Zdiv_0_l, Zmod_0_l. + eexists. + apply f_equal. + unfold new_location. + now case Z.even. + now eexists. + destruct H as [e' H]. + rewrite H. + split. + constructor. + apply eq_sym, F2R_0. + right. + repeat split. + apply generic_format_0. + + rewrite F2R_0 in H. + elim Rlt_irrefl with (1 := H). Qed. Theorem truncate_correct : @@ -750,78 +841,11 @@ Theorem truncate_correct : (e <= fexp (Zdigits beta m + e))%Z \/ l = loc_Exact -> let '(m', e', l') := truncate (m, e, l) in inbetween_float beta m' e' x l' /\ - (e' = canonic_exp beta fexp x \/ (l' = loc_Exact /\ format x)). + (e' = cexp beta fexp x \/ (l' = loc_Exact /\ format x)). Proof. -intros x m e l [Hx|Hx] H1 H2. -(* 0 < x *) -destruct (Zle_or_lt e (fexp (Zdigits beta m + e))) as [H3|H3]. -(* . enough digits *) -generalize (truncate_correct_partial x m e l Hx H1 H3). -destruct (truncate (m, e, l)) as ((m', e'), l'). -intros (H4, H5). -split. -exact H4. -now left. -(* . not enough digits but loc_Exact *) -destruct H2 as [H2|H2]. -elim (Zlt_irrefl e). -now apply Zle_lt_trans with (1 := H2). -rewrite H2 in H1 |- *. -unfold truncate. -generalize (Zlt_cases 0 (fexp (Zdigits beta m + e) - e)). -case Zlt_bool. -intros H. -apply False_ind. -omega. -intros _. -split. -exact H1. -right. -split. -apply refl_equal. -inversion_clear H1. -rewrite H. -apply generic_format_F2R. -intros Zm. -unfold canonic_exp. -rewrite ln_beta_F2R_Zdigits with (1 := Zm). -now apply Zlt_le_weak. -(* x = 0 *) -assert (Hm: m = Z0). -cut (m <= 0 < m + 1)%Z. omega. -assert (Hx': (F2R (Float beta m e) <= x < F2R (Float beta (m + 1) e))%R). -apply inbetween_float_bounds with (1 := H1). -rewrite <- Hx in Hx'. -split. -apply F2R_le_0_reg with (1 := proj1 Hx'). -apply F2R_gt_0_reg with (1 := proj2 Hx'). -rewrite Hm, <- Hx in H1 |- *. -clear -H1. -case H1. -(* . *) -intros _. -assert (exists e', truncate (Z0, e, loc_Exact) = (Z0, e', loc_Exact)). -unfold truncate, truncate_aux. -case Zlt_bool. -rewrite Zdiv_0_l, Zmod_0_l. -eexists. -apply f_equal. -unfold new_location. -now case Zeven. -now eexists. -destruct H as (e', H). -rewrite H. -split. -constructor. -apply sym_eq. -apply F2R_0. -right. -repeat split. -apply generic_format_0. -(* . *) -intros l' (H, _) _. -rewrite F2R_0 in H. -elim Rlt_irrefl with (1 := H). +intros x m e l Hx H1 H2. +apply truncate_correct' with (1 := Hx) (2 := H1). +now apply cexp_inbetween_float_loc_Exact with (2 := H1). Qed. Section round_dir. @@ -838,7 +862,7 @@ Hypothesis inbetween_int_valid : Theorem round_any_correct : forall x m e l, inbetween_float beta m e x l -> - (e = canonic_exp beta fexp x \/ (l = loc_Exact /\ format x)) -> + (e = cexp beta fexp x \/ (l = loc_Exact /\ format x)) -> round beta fexp rnd x = F2R (Float beta (choice m l) e). Proof with auto with typeclass_instances. intros x m e l Hin [He|(Hl,Hf)]. @@ -851,7 +875,7 @@ rewrite Hl. replace (choice m loc_Exact) with m. rewrite <- H. apply round_generic... -rewrite <- (Zrnd_Z2R rnd m) at 1. +rewrite <- (Zrnd_IZR rnd m) at 1. apply inbetween_int_valid. now constructor. Qed. @@ -872,6 +896,20 @@ intros (H1, H2). now apply round_any_correct. Qed. +Theorem round_trunc_any_correct' : + forall x m e l, + (0 <= x)%R -> + inbetween_float beta m e x l -> + (e <= cexp beta fexp x)%Z \/ l = loc_Exact -> + round beta fexp rnd x = let '(m', e', l') := truncate (m, e, l) in F2R (Float beta (choice m' l') e'). +Proof. +intros x m e l Hx Hl He. +generalize (truncate_correct' x m e l Hx Hl He). +destruct (truncate (m, e, l)) as [[m' e'] l']. +intros [H1 H2]. +now apply round_any_correct. +Qed. + End round_dir. Section round_dir_sign. @@ -888,7 +926,7 @@ Hypothesis inbetween_int_valid : Theorem round_sign_any_correct : forall x m e l, inbetween_float beta m e (Rabs x) l -> - (e = canonic_exp beta fexp x \/ (l = loc_Exact /\ format x)) -> + (e = cexp beta fexp x \/ (l = loc_Exact /\ format x)) -> round beta fexp rnd x = F2R (Float beta (cond_Zopp (Rlt_bool x 0) (choice (Rlt_bool x 0) m l)) e). Proof with auto with typeclass_instances. intros x m e l Hin [He|(Hl,Hf)]. @@ -915,14 +953,14 @@ now apply Rge_le. (* *) destruct (Rlt_bool_spec x 0) as [Zx|Zx]. (* . *) -apply Zopp_inj. +apply Z.opp_inj. change (- m = cond_Zopp true (choice true m loc_Exact))%Z. -rewrite <- (Zrnd_Z2R rnd (-m)) at 1. -assert (Z2R (-m) < 0)%R. -rewrite Z2R_opp. +rewrite <- (Zrnd_IZR rnd (-m)) at 1. +assert (IZR (-m) < 0)%R. +rewrite opp_IZR. apply Ropp_lt_gt_0_contravar. -apply (Z2R_lt 0). -apply F2R_gt_0_reg with beta e. +apply IZR_lt. +apply gt_0_F2R with beta e. rewrite <- H. apply Rabs_pos_lt. now apply Rlt_not_eq. @@ -930,14 +968,14 @@ rewrite <- Rlt_bool_true with (1 := H0). apply inbetween_int_valid. constructor. rewrite Rabs_left with (1 := H0). -rewrite Z2R_opp. +rewrite opp_IZR. apply Ropp_involutive. (* . *) change (m = cond_Zopp false (choice false m loc_Exact))%Z. -rewrite <- (Zrnd_Z2R rnd m) at 1. -assert (0 <= Z2R m)%R. -apply (Z2R_le 0). -apply F2R_ge_0_reg with beta e. +rewrite <- (Zrnd_IZR rnd m) at 1. +assert (0 <= IZR m)%R. +apply IZR_le. +apply ge_0_F2R with beta e. rewrite <- H. apply Rabs_pos. rewrite <- Rlt_bool_false with (1 := H0). @@ -948,29 +986,38 @@ Qed. (** Truncating a triple is sufficient to round a real number. *) -Theorem round_trunc_sign_any_correct : +Theorem round_trunc_sign_any_correct' : forall x m e l, inbetween_float beta m e (Rabs x) l -> - (e <= fexp (Zdigits beta m + e))%Z \/ l = loc_Exact -> + (e <= cexp beta fexp x)%Z \/ l = loc_Exact -> round beta fexp rnd x = let '(m', e', l') := truncate (m, e, l) in F2R (Float beta (cond_Zopp (Rlt_bool x 0) (choice (Rlt_bool x 0) m' l')) e'). Proof. intros x m e l Hl He. -generalize (truncate_correct (Rabs x) m e l (Rabs_pos _) Hl He). -destruct (truncate (m, e, l)) as ((m', e'), l'). -intros (H1, H2). +rewrite <- cexp_abs in He. +generalize (truncate_correct' (Rabs x) m e l (Rabs_pos _) Hl He). +destruct (truncate (m, e, l)) as [[m' e'] l']. +intros [H1 H2]. apply round_sign_any_correct. exact H1. -destruct H2 as [H2|(H2,H3)]. +destruct H2 as [H2|[H2 H3]]. left. -now rewrite <- canonic_exp_abs. +now rewrite <- cexp_abs. right. -split. -exact H2. -unfold Rabs in H3. -destruct (Rcase_abs x) in H3. -rewrite <- Ropp_involutive. -now apply generic_format_opp. -exact H3. +apply (conj H2). +now apply generic_format_abs_inv. +Qed. + +Theorem round_trunc_sign_any_correct : + forall x m e l, + inbetween_float beta m e (Rabs x) l -> + (e <= fexp (Zdigits beta m + e))%Z \/ l = loc_Exact -> + round beta fexp rnd x = let '(m', e', l') := truncate (m, e, l) in F2R (Float beta (cond_Zopp (Rlt_bool x 0) (choice (Rlt_bool x 0) m' l')) e'). +Proof. +intros x m e l Hl He. +apply round_trunc_sign_any_correct' with (1 := Hl). +rewrite <- cexp_abs. +apply cexp_inbetween_float_loc_Exact with (2 := Hl) (3 := He). +apply Rabs_pos. Qed. End round_dir_sign. @@ -983,47 +1030,71 @@ Definition round_DN_correct := Definition round_trunc_DN_correct := round_trunc_any_correct _ (fun m _ => m) inbetween_int_DN. +Definition round_trunc_DN_correct' := + round_trunc_any_correct' _ (fun m _ => m) inbetween_int_DN. + Definition round_sign_DN_correct := round_sign_any_correct _ (fun s m l => cond_incr (round_sign_DN s l) m) inbetween_int_DN_sign. Definition round_trunc_sign_DN_correct := round_trunc_sign_any_correct _ (fun s m l => cond_incr (round_sign_DN s l) m) inbetween_int_DN_sign. +Definition round_trunc_sign_DN_correct' := + round_trunc_sign_any_correct' _ (fun s m l => cond_incr (round_sign_DN s l) m) inbetween_int_DN_sign. + Definition round_UP_correct := round_any_correct _ (fun m l => cond_incr (round_UP l) m) inbetween_int_UP. Definition round_trunc_UP_correct := round_trunc_any_correct _ (fun m l => cond_incr (round_UP l) m) inbetween_int_UP. +Definition round_trunc_UP_correct' := + round_trunc_any_correct' _ (fun m l => cond_incr (round_UP l) m) inbetween_int_UP. + Definition round_sign_UP_correct := round_sign_any_correct _ (fun s m l => cond_incr (round_sign_UP s l) m) inbetween_int_UP_sign. Definition round_trunc_sign_UP_correct := round_trunc_sign_any_correct _ (fun s m l => cond_incr (round_sign_UP s l) m) inbetween_int_UP_sign. +Definition round_trunc_sign_UP_correct' := + round_trunc_sign_any_correct' _ (fun s m l => cond_incr (round_sign_UP s l) m) inbetween_int_UP_sign. + Definition round_ZR_correct := round_any_correct _ (fun m l => cond_incr (round_ZR (Zlt_bool m 0) l) m) inbetween_int_ZR. Definition round_trunc_ZR_correct := round_trunc_any_correct _ (fun m l => cond_incr (round_ZR (Zlt_bool m 0) l) m) inbetween_int_ZR. +Definition round_trunc_ZR_correct' := + round_trunc_any_correct' _ (fun m l => cond_incr (round_ZR (Zlt_bool m 0) l) m) inbetween_int_ZR. + Definition round_sign_ZR_correct := round_sign_any_correct _ (fun s m l => m) inbetween_int_ZR_sign. Definition round_trunc_sign_ZR_correct := round_trunc_sign_any_correct _ (fun s m l => m) inbetween_int_ZR_sign. +Definition round_trunc_sign_ZR_correct' := + round_trunc_sign_any_correct' _ (fun s m l => m) inbetween_int_ZR_sign. + Definition round_NE_correct := - round_any_correct _ (fun m l => cond_incr (round_N (negb (Zeven m)) l) m) inbetween_int_NE. + round_any_correct _ (fun m l => cond_incr (round_N (negb (Z.even m)) l) m) inbetween_int_NE. Definition round_trunc_NE_correct := - round_trunc_any_correct _ (fun m l => cond_incr (round_N (negb (Zeven m)) l) m) inbetween_int_NE. + round_trunc_any_correct _ (fun m l => cond_incr (round_N (negb (Z.even m)) l) m) inbetween_int_NE. + +Definition round_trunc_NE_correct' := + round_trunc_any_correct' _ (fun m l => cond_incr (round_N (negb (Z.even m)) l) m) inbetween_int_NE. Definition round_sign_NE_correct := - round_sign_any_correct _ (fun s m l => cond_incr (round_N (negb (Zeven m)) l) m) inbetween_int_NE_sign. + round_sign_any_correct _ (fun s m l => cond_incr (round_N (negb (Z.even m)) l) m) inbetween_int_NE_sign. Definition round_trunc_sign_NE_correct := - round_trunc_sign_any_correct _ (fun s m l => cond_incr (round_N (negb (Zeven m)) l) m) inbetween_int_NE_sign. + round_trunc_sign_any_correct _ (fun s m l => cond_incr (round_N (negb (Z.even m)) l) m) inbetween_int_NE_sign. + +Definition round_trunc_sign_NE_correct' := + round_trunc_sign_any_correct' _ (fun s m l => cond_incr (round_N (negb (Z.even m)) l) m) inbetween_int_NE_sign. Definition round_NA_correct := round_any_correct _ (fun m l => cond_incr (round_N (Zle_bool 0 m) l) m) inbetween_int_NA. @@ -1031,12 +1102,18 @@ Definition round_NA_correct := Definition round_trunc_NA_correct := round_trunc_any_correct _ (fun m l => cond_incr (round_N (Zle_bool 0 m) l) m) inbetween_int_NA. +Definition round_trunc_NA_correct' := + round_trunc_any_correct' _ (fun m l => cond_incr (round_N (Zle_bool 0 m) l) m) inbetween_int_NA. + Definition round_sign_NA_correct := round_sign_any_correct _ (fun s m l => cond_incr (round_N true l) m) inbetween_int_NA_sign. Definition round_trunc_sign_NA_correct := round_trunc_sign_any_correct _ (fun s m l => cond_incr (round_N true l) m) inbetween_int_NA_sign. +Definition round_trunc_sign_NA_correct' := + round_trunc_sign_any_correct' _ (fun s m l => cond_incr (round_N true l) m) inbetween_int_NA_sign. + End Fcalc_round_fexp. (** Specialization of truncate for FIX formats. *) @@ -1048,7 +1125,7 @@ Definition truncate_FIX t := let k := (emin - e)%Z in if Zlt_bool 0 k then let p := Zpower beta k in - (Zdiv m p, (e + k)%Z, new_location p (Zmod m p) l) + (Z.div m p, (e + k)%Z, new_location p (Zmod m p) l) else t. Theorem truncate_FIX_correct : @@ -1057,13 +1134,13 @@ Theorem truncate_FIX_correct : (e <= emin)%Z \/ l = loc_Exact -> let '(m', e', l') := truncate_FIX (m, e, l) in inbetween_float beta m' e' x l' /\ - (e' = canonic_exp beta (FIX_exp emin) x \/ (l' = loc_Exact /\ generic_format beta (FIX_exp emin) x)). + (e' = cexp beta (FIX_exp emin) x \/ (l' = loc_Exact /\ generic_format beta (FIX_exp emin) x)). Proof. intros x m e l H1 H2. unfold truncate_FIX. set (k := (emin - e)%Z). set (p := Zpower beta k). -unfold canonic_exp, FIX_exp. +unfold cexp, FIX_exp. generalize (Zlt_cases 0 k). case (Zlt_bool 0 k) ; intros Hk. (* shift *) @@ -1087,7 +1164,7 @@ rewrite H2 in H1. inversion_clear H1. rewrite H. apply generic_format_F2R. -unfold canonic_exp. +unfold cexp. omega. Qed. diff --git a/flocq/Calc/Sqrt.v b/flocq/Calc/Sqrt.v new file mode 100644 index 00000000..8843d21e --- /dev/null +++ b/flocq/Calc/Sqrt.v @@ -0,0 +1,201 @@ +(** +This file is part of the Flocq formalization of floating-point +arithmetic in Coq: http://flocq.gforge.inria.fr/ + +Copyright (C) 2010-2018 Sylvie Boldo +#<br /># +Copyright (C) 2010-2018 Guillaume Melquiond + +This library is free software; you can redistribute it and/or +modify it under the terms of the GNU Lesser General Public +License as published by the Free Software Foundation; either +version 3 of the License, or (at your option) any later version. + +This library is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +COPYING file for more details. +*) + +(** * Helper functions and theorems for computing the rounded square root of a floating-point number. *) + +Require Import Raux Defs Digits Generic_fmt Float_prop Bracket. + +Set Implicit Arguments. +Set Strongly Strict Implicit. + +Section Fcalc_sqrt. + +Variable beta : radix. +Notation bpow e := (bpow beta e). + +Variable fexp : Z -> Z. + +(** Computes a mantissa of precision p, the corresponding exponent, + and the position with respect to the real square root of the + input floating-point number. + +The algorithm performs the following steps: +- Shift the mantissa so that it has at least 2p-1 digits; + shift it one digit more if the new exponent is not even. +- Compute the square root s (at least p digits) of the new + mantissa, and its remainder r. +- Compute the position according to the remainder: + -- r == 0 => Eq, + -- r <= s => Lo, + -- r >= s => Up. + +Complexity is fine as long as p1 <= 2p-1. +*) + +Lemma mag_sqrt_F2R : + forall m1 e1, + (0 < m1)%Z -> + mag beta (sqrt (F2R (Float beta m1 e1))) = Z.div2 (Zdigits beta m1 + e1 + 1) :> Z. +Proof. +intros m1 e1 Hm1. +rewrite <- (mag_F2R_Zdigits beta m1 e1) by now apply Zgt_not_eq. +apply mag_sqrt. +now apply F2R_gt_0. +Qed. + +Definition Fsqrt_core m1 e1 e := + let d1 := Zdigits beta m1 in + let m1' := (m1 * Zpower beta (e1 - 2 * e))%Z in + let (q, r) := Z.sqrtrem m1' in + let l := + if Zeq_bool r 0 then loc_Exact + else loc_Inexact (if Zle_bool r q then Lt else Gt) in + (q, l). + +Theorem Fsqrt_core_correct : + forall m1 e1 e, + (0 < m1)%Z -> + (2 * e <= e1)%Z -> + let '(m, l) := Fsqrt_core m1 e1 e in + inbetween_float beta m e (sqrt (F2R (Float beta m1 e1))) l. +Proof. +intros m1 e1 e Hm1 He. +unfold Fsqrt_core. +set (m' := Zmult _ _). +assert (0 <= m')%Z as Hm'. +{ apply Z.mul_nonneg_nonneg. + now apply Zlt_le_weak. + apply Zpower_ge_0. } +assert (sqrt (F2R (Float beta m1 e1)) = sqrt (IZR m') * bpow e)%R as Hf. +{ rewrite <- (sqrt_Rsqr (bpow e)) by apply bpow_ge_0. + rewrite <- sqrt_mult. + unfold Rsqr, m'. + rewrite mult_IZR, IZR_Zpower by omega. + rewrite Rmult_assoc, <- 2!bpow_plus. + now replace (_ + _)%Z with e1 by ring. + now apply IZR_le. + apply Rle_0_sqr. } +generalize (Z.sqrtrem_spec m' Hm'). +destruct Z.sqrtrem as [q r]. +intros [Hq Hr]. +rewrite Hf. +unfold inbetween_float, F2R. simpl Fnum. +apply inbetween_mult_compat. +apply bpow_gt_0. +rewrite Hq. +case Zeq_bool_spec ; intros Hr'. +(* .. r = 0 *) +rewrite Hr', Zplus_0_r, mult_IZR. +fold (Rsqr (IZR q)). +rewrite sqrt_Rsqr. +now constructor. +apply IZR_le. +clear -Hr ; omega. +(* .. r <> 0 *) +constructor. +split. +(* ... bounds *) +apply Rle_lt_trans with (sqrt (IZR (q * q))). +rewrite mult_IZR. +fold (Rsqr (IZR q)). +rewrite sqrt_Rsqr. +apply Rle_refl. +apply IZR_le. +clear -Hr ; omega. +apply sqrt_lt_1. +rewrite mult_IZR. +apply Rle_0_sqr. +rewrite <- Hq. +now apply IZR_le. +apply IZR_lt. +omega. +apply Rlt_le_trans with (sqrt (IZR ((q + 1) * (q + 1)))). +apply sqrt_lt_1. +rewrite <- Hq. +now apply IZR_le. +rewrite mult_IZR. +apply Rle_0_sqr. +apply IZR_lt. +ring_simplify. +omega. +rewrite mult_IZR. +fold (Rsqr (IZR (q + 1))). +rewrite sqrt_Rsqr. +apply Rle_refl. +apply IZR_le. +clear -Hr ; omega. +(* ... location *) +rewrite Rcompare_half_r. +generalize (Rcompare_sqr (2 * sqrt (IZR (q * q + r))) (IZR q + IZR (q + 1))). +rewrite 2!Rabs_pos_eq. +intros <-. +replace ((2 * sqrt (IZR (q * q + r))) * (2 * sqrt (IZR (q * q + r))))%R + with (4 * Rsqr (sqrt (IZR (q * q + r))))%R by (unfold Rsqr ; ring). +rewrite Rsqr_sqrt. +rewrite <- plus_IZR, <- 2!mult_IZR. +rewrite Rcompare_IZR. +replace ((q + (q + 1)) * (q + (q + 1)))%Z with (4 * (q * q) + 4 * q + 1)%Z by ring. +generalize (Zle_cases r q). +case (Zle_bool r q) ; intros Hr''. +change (4 * (q * q + r) < 4 * (q * q) + 4 * q + 1)%Z. +omega. +change (4 * (q * q + r) > 4 * (q * q) + 4 * q + 1)%Z. +omega. +rewrite <- Hq. +now apply IZR_le. +rewrite <- plus_IZR. +apply IZR_le. +clear -Hr ; omega. +apply Rmult_le_pos. +now apply IZR_le. +apply sqrt_ge_0. +Qed. + +Definition Fsqrt (x : float beta) := + let (m1, e1) := x in + let e' := (Zdigits beta m1 + e1 + 1)%Z in + let e := Z.min (fexp (Z.div2 e')) (Z.div2 e1) in + let '(m, l) := Fsqrt_core m1 e1 e in + (m, e, l). + +Theorem Fsqrt_correct : + forall x, + (0 < F2R x)%R -> + let '(m, e, l) := Fsqrt x in + (e <= cexp beta fexp (sqrt (F2R x)))%Z /\ + inbetween_float beta m e (sqrt (F2R x)) l. +Proof. +intros [m1 e1] Hm1. +apply gt_0_F2R in Hm1. +unfold Fsqrt. +set (e := Z.min _ _). +assert (2 * e <= e1)%Z as He. +{ assert (e <= Z.div2 e1)%Z by apply Z.le_min_r. + rewrite (Zdiv2_odd_eqn e1). + destruct Z.odd ; omega. } +generalize (Fsqrt_core_correct m1 e1 e Hm1 He). +destruct Fsqrt_core as [m l]. +apply conj. +apply Z.le_trans with (1 := Z.le_min_l _ _). +unfold cexp. +rewrite (mag_sqrt_F2R m1 e1 Hm1). +apply Z.le_refl. +Qed. + +End Fcalc_sqrt. diff --git a/flocq/Core/Fcore.v b/flocq/Core/Core.v index 2a5a5f02..78a140e1 100644 --- a/flocq/Core/Fcore.v +++ b/flocq/Core/Core.v @@ -2,9 +2,9 @@ This file is part of the Flocq formalization of floating-point arithmetic in Coq: http://flocq.gforge.inria.fr/ -Copyright (C) 2010-2013 Sylvie Boldo +Copyright (C) 2010-2018 Sylvie Boldo #<br /># -Copyright (C) 2010-2013 Guillaume Melquiond +Copyright (C) 2010-2018 Guillaume Melquiond This library is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public @@ -18,13 +18,5 @@ COPYING file for more details. *) (** To ease the import *) -Require Export Fcore_Raux. -Require Export Fcore_defs. -Require Export Fcore_float_prop. -Require Export Fcore_rnd. -Require Export Fcore_generic_fmt. -Require Export Fcore_rnd_ne. -Require Export Fcore_FIX. -Require Export Fcore_FLX. -Require Export Fcore_FLT. -Require Export Fcore_ulp. +Require Export Raux Defs Float_prop Round_pred Generic_fmt Round_NE. +Require Export FIX FLX FLT Ulp. diff --git a/flocq/Core/Fcore_defs.v b/flocq/Core/Defs.v index 01b868ab..f5c6f33b 100644 --- a/flocq/Core/Fcore_defs.v +++ b/flocq/Core/Defs.v @@ -2,9 +2,9 @@ This file is part of the Flocq formalization of floating-point arithmetic in Coq: http://flocq.gforge.inria.fr/ -Copyright (C) 2010-2013 Sylvie Boldo +Copyright (C) 2009-2018 Sylvie Boldo #<br /># -Copyright (C) 2010-2013 Guillaume Melquiond +Copyright (C) 2009-2018 Guillaume Melquiond This library is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public @@ -18,20 +18,20 @@ COPYING file for more details. *) (** * Basic definitions: float and rounding property *) -Require Import Fcore_Raux. +Require Import Raux. Section Def. (** Definition of a floating-point number *) Record float (beta : radix) := Float { Fnum : Z ; Fexp : Z }. -Arguments Fnum {beta} f. -Arguments Fexp {beta} f. +Arguments Fnum {beta}. +Arguments Fexp {beta}. Variable beta : radix. Definition F2R (f : float beta) := - (Z2R (Fnum f) * bpow beta (Fexp f))%R. + (IZR (Fnum f) * bpow beta (Fexp f))%R. (** Requirements on a rounding mode *) Definition round_pred_total (P : R -> R -> Prop) := @@ -46,9 +46,9 @@ Definition round_pred (P : R -> R -> Prop) := End Def. -Arguments Fnum {beta} f. -Arguments Fexp {beta} f. -Arguments F2R {beta} f. +Arguments Fnum {beta}. +Arguments Fexp {beta}. +Arguments F2R {beta}. Section RND. @@ -57,45 +57,27 @@ Definition Rnd_DN_pt (F : R -> Prop) (x f : R) := F f /\ (f <= x)%R /\ forall g : R, F g -> (g <= x)%R -> (g <= f)%R. -Definition Rnd_DN (F : R -> Prop) (rnd : R -> R) := - forall x : R, Rnd_DN_pt F x (rnd x). - (** property of being a round toward +inf *) Definition Rnd_UP_pt (F : R -> Prop) (x f : R) := F f /\ (x <= f)%R /\ forall g : R, F g -> (x <= g)%R -> (f <= g)%R. -Definition Rnd_UP (F : R -> Prop) (rnd : R -> R) := - forall x : R, Rnd_UP_pt F x (rnd x). - (** property of being a round toward zero *) Definition Rnd_ZR_pt (F : R -> Prop) (x f : R) := ( (0 <= x)%R -> Rnd_DN_pt F x f ) /\ ( (x <= 0)%R -> Rnd_UP_pt F x f ). -Definition Rnd_ZR (F : R -> Prop) (rnd : R -> R) := - forall x : R, Rnd_ZR_pt F x (rnd x). - (** property of being a round to nearest *) Definition Rnd_N_pt (F : R -> Prop) (x f : R) := F f /\ forall g : R, F g -> (Rabs (f - x) <= Rabs (g - x))%R. -Definition Rnd_N (F : R -> Prop) (rnd : R -> R) := - forall x : R, Rnd_N_pt F x (rnd x). - Definition Rnd_NG_pt (F : R -> Prop) (P : R -> R -> Prop) (x f : R) := Rnd_N_pt F x f /\ ( P x f \/ forall f2 : R, Rnd_N_pt F x f2 -> f2 = f ). -Definition Rnd_NG (F : R -> Prop) (P : R -> R -> Prop) (rnd : R -> R) := - forall x : R, Rnd_NG_pt F P x (rnd x). - Definition Rnd_NA_pt (F : R -> Prop) (x f : R) := Rnd_N_pt F x f /\ forall f2 : R, Rnd_N_pt F x f2 -> (Rabs f2 <= Rabs f)%R. -Definition Rnd_NA (F : R -> Prop) (rnd : R -> R) := - forall x : R, Rnd_NA_pt F x (rnd x). - End RND. diff --git a/flocq/Core/Fcore_digits.v b/flocq/Core/Digits.v index 53743035..bed2e20a 100644 --- a/flocq/Core/Fcore_digits.v +++ b/flocq/Core/Digits.v @@ -2,9 +2,9 @@ This file is part of the Flocq formalization of floating-point arithmetic in Coq: http://flocq.gforge.inria.fr/ -Copyright (C) 2011-2013 Sylvie Boldo +Copyright (C) 2011-2018 Sylvie Boldo #<br /># -Copyright (C) 2011-2013 Guillaume Melquiond +Copyright (C) 2011-2018 Guillaume Melquiond This library is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public @@ -17,9 +17,8 @@ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the COPYING file for more details. *) -Require Import ZArith. -Require Import Zquot. -Require Import Fcore_Zaux. +Require Import ZArith Zquot. +Require Import Zaux. (** Number of bits (radix 2) of a positive integer. @@ -74,7 +73,7 @@ Qed. Theorem Zdigit_opp : forall n k, - Zdigit (-n) k = Zopp (Zdigit n k). + Zdigit (-n) k = Z.opp (Zdigit n k). Proof. intros n k. unfold Zdigit. @@ -89,11 +88,11 @@ Theorem Zdigit_ge_Zpower_pos : Proof. intros e n Hn k Hk. unfold Zdigit. -rewrite Zquot_small. +rewrite Z.quot_small. apply Zrem_0_l. split. apply Hn. -apply Zlt_le_trans with (1 := proj2 Hn). +apply Z.lt_le_trans with (1 := proj2 Hn). replace k with (e + (k - e))%Z by ring. rewrite Zpower_plus. rewrite <- (Zmult_1_r (beta ^ e)) at 1. @@ -102,8 +101,8 @@ apply (Zlt_le_succ 0). apply Zpower_gt_0. now apply Zle_minus_le_0. apply Zlt_le_weak. -now apply Zle_lt_trans with n. -generalize (Zle_lt_trans _ _ _ (proj1 Hn) (proj2 Hn)). +now apply Z.le_lt_trans with n. +generalize (Z.le_lt_trans _ _ _ (proj1 Hn) (proj2 Hn)). clear. now destruct e as [|e|e]. now apply Zle_minus_le_0. @@ -111,7 +110,7 @@ Qed. Theorem Zdigit_ge_Zpower : forall e n, - (Zabs n < Zpower beta e)%Z -> + (Z.abs n < Zpower beta e)%Z -> forall k, (e <= k)%Z -> Zdigit n k = Z0. Proof. intros e [|n|n] Hn k. @@ -119,10 +118,10 @@ easy. apply Zdigit_ge_Zpower_pos. now split. intros He. -change (Zneg n) with (Zopp (Zpos n)). +change (Zneg n) with (Z.opp (Zpos n)). rewrite Zdigit_opp. rewrite Zdigit_ge_Zpower_pos with (2 := He). -apply Zopp_0. +apply Z.opp_0. now split. Qed. @@ -134,17 +133,17 @@ Proof. intros e n He (Hn1,Hn2). unfold Zdigit. rewrite <- ZOdiv_mod_mult. -rewrite Zrem_small. +rewrite Z.rem_small. intros H. apply Zle_not_lt with (1 := Hn1). rewrite (Z.quot_rem' n (beta ^ e)). rewrite H, Zmult_0_r, Zplus_0_l. apply Zrem_lt_pos_pos. -apply Zle_trans with (2 := Hn1). +apply Z.le_trans with (2 := Hn1). apply Zpower_ge_0. now apply Zpower_gt_0. split. -apply Zle_trans with (2 := Hn1). +apply Z.le_trans with (2 := Hn1). apply Zpower_ge_0. replace (beta ^ e * beta)%Z with (beta ^ (e + 1))%Z. exact Hn2. @@ -154,12 +153,12 @@ Qed. Theorem Zdigit_not_0 : forall e n, (0 <= e)%Z -> - (Zpower beta e <= Zabs n < Zpower beta (e + 1))%Z -> + (Zpower beta e <= Z.abs n < Zpower beta (e + 1))%Z -> Zdigit n e <> Z0. Proof. intros e n He Hn. destruct (Zle_or_lt 0 n) as [Hn'|Hn']. -rewrite (Zabs_eq _ Hn') in Hn. +rewrite (Z.abs_eq _ Hn') in Hn. now apply Zdigit_not_0_pos. intros H. rewrite (Zabs_non_eq n) in Hn by now apply Zlt_le_weak. @@ -245,8 +244,8 @@ intros n k k' Hk. unfold Zdigit. rewrite ZOdiv_small_abs. apply Zrem_0_l. -apply Zlt_le_trans with (Zpower beta k'). -rewrite <- (Zabs_eq (beta ^ k')) at 2 by apply Zpower_ge_0. +apply Z.lt_le_trans with (Zpower beta k'). +rewrite <- (Z.abs_eq (beta ^ k')) at 2 by apply Zpower_ge_0. apply Zrem_lt. apply Zgt_not_eq. now apply Zpower_gt_0. @@ -266,7 +265,7 @@ Proof. intros n. induction k. apply sym_eq. -apply Zrem_1_r. +apply Z.rem_1_r. simpl Zsum_digit. rewrite IHk. unfold Zdigit. @@ -284,65 +283,35 @@ apply Zle_0_nat. easy. Qed. -Theorem Zpower_gt_id : - forall n, (n < Zpower beta n)%Z. -Proof. -intros [|n|n] ; try easy. -simpl. -rewrite Zpower_pos_nat. -rewrite Zpos_eq_Z_of_nat_o_nat_of_P. -induction (nat_of_P n). -easy. -rewrite inj_S. -change (Zpower_nat beta (S n0)) with (beta * Zpower_nat beta n0)%Z. -unfold Zsucc. -apply Zlt_le_trans with (beta * (Z_of_nat n0 + 1))%Z. -clear. -apply Zlt_0_minus_lt. -replace (beta * (Z_of_nat n0 + 1) - (Z_of_nat n0 + 1))%Z with ((beta - 1) * (Z_of_nat n0 + 1))%Z by ring. -apply Zmult_lt_0_compat. -cut (2 <= beta)%Z. omega. -apply Zle_bool_imp_le. -apply beta. -apply (Zle_lt_succ 0). -apply Zle_0_nat. -apply Zmult_le_compat_l. -now apply Zlt_le_succ. -apply Zle_trans with 2%Z. -easy. -apply Zle_bool_imp_le. -apply beta. -Qed. - Theorem Zdigit_ext : forall n1 n2, (forall k, (0 <= k)%Z -> Zdigit n1 k = Zdigit n2 k) -> n1 = n2. Proof. intros n1 n2 H. -rewrite <- (ZOmod_small_abs n1 (Zpower beta (Zmax (Zabs n1) (Zabs n2)))). -rewrite <- (ZOmod_small_abs n2 (Zpower beta (Zmax (Zabs n1) (Zabs n2)))) at 2. -replace (Zmax (Zabs n1) (Zabs n2)) with (Z_of_nat (Zabs_nat (Zmax (Zabs n1) (Zabs n2)))). +rewrite <- (ZOmod_small_abs n1 (Zpower beta (Z.max (Z.abs n1) (Z.abs n2)))). +rewrite <- (ZOmod_small_abs n2 (Zpower beta (Z.max (Z.abs n1) (Z.abs n2)))) at 2. +replace (Z.max (Z.abs n1) (Z.abs n2)) with (Z_of_nat (Z.abs_nat (Z.max (Z.abs n1) (Z.abs n2)))). rewrite <- 2!Zsum_digit_digit. -induction (Zabs_nat (Zmax (Zabs n1) (Zabs n2))). +induction (Z.abs_nat (Z.max (Z.abs n1) (Z.abs n2))). easy. simpl. rewrite H, IHn. apply refl_equal. apply Zle_0_nat. rewrite inj_Zabs_nat. -apply Zabs_eq. -apply Zle_trans with (Zabs n1). +apply Z.abs_eq. +apply Z.le_trans with (Z.abs n1). apply Zabs_pos. -apply Zle_max_l. -apply Zlt_le_trans with (Zpower beta (Zabs n2)). +apply Z.le_max_l. +apply Z.lt_le_trans with (Zpower beta (Z.abs n2)). apply Zpower_gt_id. apply Zpower_le. -apply Zle_max_r. -apply Zlt_le_trans with (Zpower beta (Zabs n1)). +apply Z.le_max_r. +apply Z.lt_le_trans with (Zpower beta (Z.abs n1)). apply Zpower_gt_id. apply Zpower_le. -apply Zle_max_l. +apply Z.le_max_l. Qed. Theorem ZOmod_plus_pow_digit : @@ -354,11 +323,11 @@ intros u v n Huv Hd. destruct (Zle_or_lt 0 n) as [Hn|Hn]. rewrite Zplus_rem with (1 := Huv). apply ZOmod_small_abs. -generalize (Zle_refl n). -pattern n at -2 ; rewrite <- Zabs_eq with (1 := Hn). +generalize (Z.le_refl n). +pattern n at -2 ; rewrite <- Z.abs_eq with (1 := Hn). rewrite <- (inj_Zabs_nat n). -induction (Zabs_nat n) as [|p IHp]. -now rewrite 2!Zrem_1_r. +induction (Z.abs_nat n) as [|p IHp]. +now rewrite 2!Z.rem_1_r. rewrite <- 2!Zsum_digit_digit. simpl Zsum_digit. rewrite inj_S. @@ -367,39 +336,39 @@ replace (Zsum_digit (Zdigit u) p + Zdigit u (Z_of_nat p) * beta ^ Z_of_nat p + (Zsum_digit (Zdigit v) p + Zdigit v (Z_of_nat p) * beta ^ Z_of_nat p))%Z with (Zsum_digit (Zdigit u) p + Zsum_digit (Zdigit v) p + (Zdigit u (Z_of_nat p) + Zdigit v (Z_of_nat p)) * beta ^ Z_of_nat p)%Z by ring. -apply (Zle_lt_trans _ _ _ (Zabs_triangle _ _)). -replace (beta ^ Zsucc (Z_of_nat p))%Z with (beta ^ Z_of_nat p + (beta - 1) * beta ^ Z_of_nat p)%Z. +apply (Z.le_lt_trans _ _ _ (Z.abs_triangle _ _)). +replace (beta ^ Z.succ (Z_of_nat p))%Z with (beta ^ Z_of_nat p + (beta - 1) * beta ^ Z_of_nat p)%Z. apply Zplus_lt_le_compat. rewrite 2!Zsum_digit_digit. apply IHp. now apply Zle_succ_le. rewrite Zabs_Zmult. -rewrite (Zabs_eq (beta ^ Z_of_nat p)) by apply Zpower_ge_0. +rewrite (Z.abs_eq (beta ^ Z_of_nat p)) by apply Zpower_ge_0. apply Zmult_le_compat_r. 2: apply Zpower_ge_0. apply Zlt_succ_le. -assert (forall u v, Zabs (Zdigit u v) < Zsucc (beta - 1))%Z. +assert (forall u v, Z.abs (Zdigit u v) < Z.succ (beta - 1))%Z. clear ; intros n k. assert (0 < beta)%Z. -apply Zlt_le_trans with 2%Z. +apply Z.lt_le_trans with 2%Z. apply refl_equal. apply Zle_bool_imp_le. apply beta. -replace (Zsucc (beta - 1)) with (Zabs beta). +replace (Z.succ (beta - 1)) with (Z.abs beta). apply Zrem_lt. now apply Zgt_not_eq. -rewrite Zabs_eq. +rewrite Z.abs_eq. apply Zsucc_pred. now apply Zlt_le_weak. assert (0 <= Z_of_nat p < n)%Z. split. apply Zle_0_nat. -apply Zgt_lt. +apply Z.gt_lt. now apply Zle_succ_gt. destruct (Hd (Z_of_nat p) H0) as [K|K] ; rewrite K. apply H. rewrite Zplus_0_r. apply H. -unfold Zsucc. +unfold Z.succ. ring_simplify. rewrite Zpower_plus. change (beta ^1)%Z with (beta * 1)%Z. @@ -422,7 +391,7 @@ rewrite <- ZOmod_plus_pow_digit by assumption. apply f_equal. destruct (Zle_or_lt 0 n) as [Hn|Hn]. apply ZOdiv_small_abs. -rewrite <- Zabs_eq. +rewrite <- Z.abs_eq. apply Zrem_lt. apply Zgt_not_eq. now apply Zpower_gt_0. @@ -562,7 +531,7 @@ rewrite Zle_bool_true. rewrite Zdigit_mod_pow by apply Hk. rewrite Zdigit_scale by apply Hk. unfold Zminus. -now rewrite Zopp_involutive, Zplus_comm. +now rewrite Z.opp_involutive, Zplus_comm. omega. Qed. @@ -608,13 +577,13 @@ Qed. Theorem Zslice_slice : forall n k1 k2 k1' k2', (0 <= k1' <= k2)%Z -> - Zslice (Zslice n k1 k2) k1' k2' = Zslice n (k1 + k1') (Zmin (k2 - k1') k2'). + Zslice (Zslice n k1 k2) k1' k2' = Zslice n (k1 + k1') (Z.min (k2 - k1') k2'). Proof. intros n k1 k2 k1' k2' Hk1'. destruct (Zle_or_lt 0 k2') as [Hk2'|Hk2']. apply Zdigit_ext. intros k Hk. -destruct (Zle_or_lt (Zmin (k2 - k1') k2') k) as [Hk'|Hk']. +destruct (Zle_or_lt (Z.min (k2 - k1') k2') k) as [Hk'|Hk']. rewrite (Zdigit_slice_out n (k1 + k1')) with (1 := Hk'). destruct (Zle_or_lt k2' k) as [Hk''|Hk'']. now apply Zdigit_slice_out. @@ -627,7 +596,7 @@ rewrite Zdigit_slice. now rewrite Zplus_assoc. zify ; omega. unfold Zslice. -rewrite Zmin_r. +rewrite Z.min_r. now rewrite Zle_bool_false. omega. Qed. @@ -659,11 +628,11 @@ replace k1 with Z0 by omega. case Zle_bool_spec ; intros Hk'. replace k with Z0 by omega. simpl. -now rewrite Zquot_1_r. -rewrite Zopp_involutive. +now rewrite Z.quot_1_r. +rewrite Z.opp_involutive. apply Zmult_1_r. rewrite Zle_bool_false by omega. -rewrite 2!Zopp_involutive, Zplus_comm. +rewrite 2!Z.opp_involutive, Zplus_comm. rewrite Zpower_plus by assumption. apply Zquot_Zquot. Qed. @@ -689,7 +658,7 @@ apply Zdigit_ext. intros k' Hk'. rewrite Zdigit_scale with (1 := Hk'). unfold Zminus. -rewrite (Zplus_comm k'), Zopp_involutive. +rewrite (Zplus_comm k'), Z.opp_involutive. destruct (Zle_or_lt k2 k') as [Hk2|Hk2]. rewrite Zdigit_slice_out with (1 := Hk2). apply sym_eq. @@ -770,7 +739,7 @@ Definition Zdigits n := Theorem Zdigits_correct : forall n, - (Zpower beta (Zdigits n - 1) <= Zabs n < Zpower beta (Zdigits n))%Z. + (Zpower beta (Zdigits n - 1) <= Z.abs n < Zpower beta (Zdigits n))%Z. Proof. cut (forall p, Zpower beta (Zdigits (Zpos p) - 1) <= Zpos p < Zpower beta (Zdigits (Zpos p)))%Z. intros H [|n|n] ; try exact (H n). @@ -779,7 +748,7 @@ intros n. simpl. (* *) assert (U: (Zpos n < Zpower beta (Z_of_nat (S (digits2_Pnat n))))%Z). -apply Zlt_le_trans with (1 := proj2 (digits2_Pnat_correct n)). +apply Z.lt_le_trans with (1 := proj2 (digits2_Pnat_correct n)). rewrite Zpower_Zpower_nat. rewrite Zabs_nat_Z_of_nat. induction (S (digits2_Pnat n)). @@ -797,7 +766,7 @@ apply Zle_0_nat. (* *) revert U. rewrite inj_S. -unfold Zsucc. +unfold Z.succ. generalize (digits2_Pnat n). intros u U. pattern (radix_val beta) at 2 4 ; replace (radix_val beta) with (Zpower beta 1) by apply Zmult_1_r. @@ -805,12 +774,12 @@ assert (V: (Zpower beta (1 - 1) <= Zpos n)%Z). now apply (Zlt_le_succ 0). generalize (conj V U). clear. -generalize (Zle_refl 1). +generalize (Z.le_refl 1). generalize 1%Z at 2 3 5 6 7 9 10. (* *) induction u. easy. -rewrite inj_S; unfold Zsucc. +rewrite inj_S; unfold Z.succ. simpl Zdigits_aux. intros v Hv U. case Zlt_bool_spec ; intros K. @@ -829,20 +798,20 @@ Qed. Theorem Zdigits_unique : forall n d, - (Zpower beta (d - 1) <= Zabs n < Zpower beta d)%Z -> + (Zpower beta (d - 1) <= Z.abs n < Zpower beta d)%Z -> Zdigits n = d. Proof. intros n d Hd. assert (Hd' := Zdigits_correct n). apply Zle_antisym. apply (Zpower_lt_Zpower beta). -now apply Zle_lt_trans with (Zabs n). +now apply Z.le_lt_trans with (Z.abs n). apply (Zpower_lt_Zpower beta). -now apply Zle_lt_trans with (Zabs n). +now apply Z.le_lt_trans with (Z.abs n). Qed. Theorem Zdigits_abs : - forall n, Zdigits (Zabs n) = Zdigits n. + forall n, Zdigits (Z.abs n) = Zdigits n. Proof. now intros [|n|n]. Qed. @@ -852,10 +821,10 @@ Theorem Zdigits_gt_0 : Proof. intros n Zn. rewrite <- (Zdigits_abs n). -assert (Hn: (0 < Zabs n)%Z). +assert (Hn: (0 < Z.abs n)%Z). destruct n ; [|easy|easy]. now elim Zn. -destruct (Zabs n) as [|p|p] ; try easy ; clear. +destruct (Z.abs n) as [|p|p] ; try easy ; clear. simpl. generalize 1%Z (radix_val beta) (refl_equal Lt : (0 < 1)%Z). induction (digits2_Pnat p). @@ -872,7 +841,7 @@ Theorem Zdigits_ge_0 : forall n, (0 <= Zdigits n)%Z. Proof. intros n. -destruct (Z_eq_dec n 0) as [H|H]. +destruct (Z.eq_dec n 0) as [H|H]. now rewrite H. apply Zlt_le_weak. now apply Zdigits_gt_0. @@ -908,8 +877,8 @@ unfold Zslice. rewrite Zle_bool_true with (1 := Hl). destruct (Zdigits_correct (Z.rem (Zscale n (- k)) (Zpower beta l))) as (H1,H2). apply Zpower_lt_Zpower with beta. -apply Zle_lt_trans with (1 := H1). -rewrite <- (Zabs_eq (beta ^ l)) at 2 by apply Zpower_ge_0. +apply Z.le_lt_trans with (1 := H1). +rewrite <- (Z.abs_eq (beta ^ l)) at 2 by apply Zpower_ge_0. apply Zrem_lt. apply Zgt_not_eq. now apply Zpower_gt_0. @@ -923,7 +892,7 @@ Proof. intros m e Hm He. assert (H := Zdigits_correct m). apply Zdigits_unique. -rewrite Z.abs_mul, Z.abs_pow, (Zabs_eq beta). +rewrite Z.abs_mul, Z.abs_pow, (Z.abs_eq beta). 2: now apply Zlt_le_weak, radix_gt_0. split. replace (Zdigits m + e - 1)%Z with (Zdigits m - 1 + e)%Z by ring. @@ -976,18 +945,18 @@ Qed. Theorem Zpower_le_Zdigits : forall e x, (e < Zdigits x)%Z -> - (Zpower beta e <= Zabs x)%Z. + (Zpower beta e <= Z.abs x)%Z. Proof. intros e x Hex. destruct (Zdigits_correct x) as [H1 H2]. -apply Zle_trans with (2 := H1). +apply Z.le_trans with (2 := H1). apply Zpower_le. clear -Hex ; omega. Qed. Theorem Zdigits_le_Zpower : forall e x, - (Zabs x < Zpower beta e)%Z -> + (Z.abs x < Zpower beta e)%Z -> (Zdigits x <= e)%Z. Proof. intros e x. @@ -998,17 +967,17 @@ Qed. Theorem Zpower_gt_Zdigits : forall e x, (Zdigits x <= e)%Z -> - (Zabs x < Zpower beta e)%Z. + (Z.abs x < Zpower beta e)%Z. Proof. intros e x Hex. destruct (Zdigits_correct x) as [H1 H2]. -apply Zlt_le_trans with (1 := H2). +apply Z.lt_le_trans with (1 := H2). now apply Zpower_le. Qed. Theorem Zdigits_gt_Zpower : forall e x, - (Zpower beta e <= Zabs x)%Z -> + (Zpower beta e <= Z.abs x)%Z -> (e < Zdigits x)%Z. Proof. intros e x Hex. @@ -1029,17 +998,17 @@ Theorem Zdigits_mult_strong : Proof. intros x y Hx Hy. apply Zdigits_le_Zpower. -rewrite Zabs_eq. -apply Zlt_le_trans with ((x + 1) * (y + 1))%Z. +rewrite Z.abs_eq. +apply Z.lt_le_trans with ((x + 1) * (y + 1))%Z. ring_simplify. -apply Zle_lt_succ, Zle_refl. +apply Zle_lt_succ, Z.le_refl. rewrite Zpower_plus by apply Zdigits_ge_0. apply Zmult_le_compat. apply Zlt_le_succ. -rewrite <- (Zabs_eq x) at 1 by easy. +rewrite <- (Z.abs_eq x) at 1 by easy. apply Zdigits_correct. apply Zlt_le_succ. -rewrite <- (Zabs_eq y) at 1 by easy. +rewrite <- (Z.abs_eq y) at 1 by easy. apply Zdigits_correct. clear -Hx ; omega. clear -Hy ; omega. @@ -1057,7 +1026,7 @@ intros x y. rewrite <- Zdigits_abs. rewrite <- (Zdigits_abs x). rewrite <- (Zdigits_abs y). -apply Zle_trans with (Zdigits (Zabs x + Zabs y + Zabs x * Zabs y)). +apply Z.le_trans with (Zdigits (Z.abs x + Z.abs y + Z.abs x * Z.abs y)). apply Zdigits_le. apply Zabs_pos. rewrite Zabs_Zmult. @@ -1097,28 +1066,28 @@ intros m e Hm He. assert (H := Zdigits_correct m). apply Zdigits_unique. destruct (Zle_lt_or_eq _ _ (proj2 He)) as [He'|He']. - rewrite Zabs_eq in H by easy. + rewrite Z.abs_eq in H by easy. destruct H as [H1 H2]. - rewrite Zabs_eq. + rewrite Z.abs_eq. split. replace (Zdigits m - e - 1)%Z with (Zdigits m - 1 - e)%Z by ring. rewrite Z.pow_sub_r. 2: apply Zgt_not_eq, radix_gt_0. 2: clear -He He' ; omega. apply Z_div_le with (2 := H1). - now apply Zlt_gt, Zpower_gt_0. + now apply Z.lt_gt, Zpower_gt_0. apply Zmult_lt_reg_r with (Zpower beta e). now apply Zpower_gt_0. - apply Zle_lt_trans with m. + apply Z.le_lt_trans with m. rewrite Zmult_comm. apply Z_mult_div_ge. - now apply Zlt_gt, Zpower_gt_0. + now apply Z.lt_gt, Zpower_gt_0. rewrite <- Zpower_plus. now replace (Zdigits m - e + e)%Z with (Zdigits m) by ring. now apply Zle_minus_le_0. apply He. apply Z_div_pos with (2 := Hm). - now apply Zlt_gt, Zpower_gt_0. + now apply Z.lt_gt, Zpower_gt_0. rewrite He'. rewrite (Zeq_minus _ (Zdigits m)) by reflexivity. simpl. @@ -1126,7 +1095,7 @@ rewrite Zdiv_small. easy. split. exact Hm. -now rewrite <- (Zabs_eq m) at 1. +now rewrite <- (Z.abs_eq m) at 1. Qed. End Fcore_digits. @@ -1143,7 +1112,7 @@ intros m. apply eq_sym, Zdigits_unique. rewrite <- Zpower_nat_Z. rewrite Nat2Z.inj_succ. -change (_ - 1)%Z with (Zpred (Zsucc (Z.of_nat (digits2_Pnat m)))). +change (_ - 1)%Z with (Z.pred (Z.succ (Z.of_nat (digits2_Pnat m)))). rewrite <- Zpred_succ. rewrite <- Zpower_nat_Z. apply digits2_Pnat_correct. @@ -1152,8 +1121,8 @@ Qed. Fixpoint digits2_pos (n : positive) : positive := match n with | xH => xH - | xO p => Psucc (digits2_pos p) - | xI p => Psucc (digits2_pos p) + | xO p => Pos.succ (digits2_pos p) + | xI p => Pos.succ (digits2_pos p) end. Theorem Zpos_digits2_pos : diff --git a/flocq/Core/Fcore_FIX.v b/flocq/Core/FIX.v index e224a64a..4e0a25e6 100644 --- a/flocq/Core/Fcore_FIX.v +++ b/flocq/Core/FIX.v @@ -2,9 +2,9 @@ This file is part of the Flocq formalization of floating-point arithmetic in Coq: http://flocq.gforge.inria.fr/ -Copyright (C) 2010-2013 Sylvie Boldo +Copyright (C) 2009-2018 Sylvie Boldo #<br /># -Copyright (C) 2010-2013 Guillaume Melquiond +Copyright (C) 2009-2018 Guillaume Melquiond This library is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public @@ -18,12 +18,7 @@ COPYING file for more details. *) (** * Fixed-point format *) -Require Import Fcore_Raux. -Require Import Fcore_defs. -Require Import Fcore_rnd. -Require Import Fcore_generic_fmt. -Require Import Fcore_ulp. -Require Import Fcore_rnd_ne. +Require Import Raux Defs Round_pred Generic_fmt Ulp Round_NE. Section RND_FIX. @@ -33,10 +28,9 @@ Notation bpow := (bpow beta). Variable emin : Z. -(* fixed-point format with exponent emin *) -Definition FIX_format (x : R) := - exists f : float beta, - x = F2R f /\ (Fexp f = emin)%Z. +Inductive FIX_format (x : R) : Prop := + FIX_spec (f : float beta) : + x = F2R f -> (Fexp f = emin)%Z -> FIX_format x. Definition FIX_exp (e : Z) := emin. @@ -49,16 +43,16 @@ unfold FIX_exp. split ; intros H. now apply Zlt_le_weak. split. -apply Zle_refl. +apply Z.le_refl. now intros _ _. Qed. Theorem generic_format_FIX : forall x, FIX_format x -> generic_format beta FIX_exp x. Proof. -intros x ((xm, xe), (Hx1, Hx2)). +intros x [[xm xe] Hx1 Hx2]. rewrite Hx1. -now apply generic_format_canonic. +now apply generic_format_canonical. Qed. Theorem FIX_format_generic : @@ -82,10 +76,11 @@ Qed. Global Instance FIX_exp_monotone : Monotone_exp FIX_exp. Proof. intros ex ey H. -apply Zle_refl. +apply Z.le_refl. Qed. -Theorem ulp_FIX: forall x, ulp beta FIX_exp x = bpow emin. +Theorem ulp_FIX : + forall x, ulp beta FIX_exp x = bpow emin. Proof. intros x; unfold ulp. case Req_bool_spec; intros Zx. @@ -96,5 +91,4 @@ intros n _; reflexivity. reflexivity. Qed. - End RND_FIX. diff --git a/flocq/Core/Fcore_FLT.v b/flocq/Core/FLT.v index 2258b1d9..bd48d4b7 100644 --- a/flocq/Core/Fcore_FLT.v +++ b/flocq/Core/FLT.v @@ -2,9 +2,9 @@ This file is part of the Flocq formalization of floating-point arithmetic in Coq: http://flocq.gforge.inria.fr/ -Copyright (C) 2010-2013 Sylvie Boldo +Copyright (C) 2009-2018 Sylvie Boldo #<br /># -Copyright (C) 2010-2013 Guillaume Melquiond +Copyright (C) 2009-2018 Guillaume Melquiond This library is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public @@ -18,15 +18,9 @@ COPYING file for more details. *) (** * Floating-point format with gradual underflow *) -Require Import Fcore_Raux. -Require Import Fcore_defs. -Require Import Fcore_rnd. -Require Import Fcore_generic_fmt. -Require Import Fcore_float_prop. -Require Import Fcore_FLX. -Require Import Fcore_FIX. -Require Import Fcore_ulp. -Require Import Fcore_rnd_ne. +Require Import Raux Defs Round_pred Generic_fmt Float_prop. +Require Import FLX FIX Ulp Round_NE. +Require Import Psatz. Section RND_FLT. @@ -38,12 +32,12 @@ Variable emin prec : Z. Context { prec_gt_0_ : Prec_gt_0 prec }. -(* floating-point format with gradual underflow *) -Definition FLT_format (x : R) := - exists f : float beta, - x = F2R f /\ (Zabs (Fnum f) < Zpower beta prec)%Z /\ (emin <= Fexp f)%Z. +Inductive FLT_format (x : R) : Prop := + FLT_spec (f : float beta) : + x = F2R f -> (Z.abs (Fnum f) < Zpower beta prec)%Z -> + (emin <= Fexp f)%Z -> FLT_format x. -Definition FLT_exp e := Zmax (e - prec) emin. +Definition FLT_exp e := Z.max (e - prec) emin. (** Properties of the FLT format *) Global Instance FLT_exp_valid : Valid_exp FLT_exp. @@ -59,17 +53,17 @@ Theorem generic_format_FLT : forall x, FLT_format x -> generic_format beta FLT_exp x. Proof. clear prec_gt_0_. -intros x ((mx, ex), (H1, (H2, H3))). +intros x [[mx ex] H1 H2 H3]. simpl in H2, H3. rewrite H1. apply generic_format_F2R. intros Zmx. -unfold canonic_exp, FLT_exp. -rewrite ln_beta_F2R with (1 := Zmx). -apply Zmax_lub with (2 := H3). +unfold cexp, FLT_exp. +rewrite mag_F2R with (1 := Zmx). +apply Z.max_lub with (2 := H3). apply Zplus_le_reg_r with (prec - ex)%Z. ring_simplify. -now apply ln_beta_le_Zpower. +now apply mag_le_Zpower. Qed. Theorem FLT_format_generic : @@ -77,32 +71,32 @@ Theorem FLT_format_generic : Proof. intros x. unfold generic_format. -set (ex := canonic_exp beta FLT_exp x). +set (ex := cexp beta FLT_exp x). set (mx := Ztrunc (scaled_mantissa beta FLT_exp x)). intros Hx. rewrite Hx. eexists ; repeat split ; simpl. -apply lt_Z2R. -rewrite Z2R_Zpower. 2: now apply Zlt_le_weak. +apply lt_IZR. +rewrite IZR_Zpower. 2: now apply Zlt_le_weak. apply Rmult_lt_reg_r with (bpow ex). apply bpow_gt_0. rewrite <- bpow_plus. -change (F2R (Float beta (Zabs mx) ex) < bpow (prec + ex))%R. +change (F2R (Float beta (Z.abs mx) ex) < bpow (prec + ex))%R. rewrite F2R_Zabs. rewrite <- Hx. destruct (Req_dec x 0) as [Hx0|Hx0]. rewrite Hx0, Rabs_R0. apply bpow_gt_0. -unfold canonic_exp in ex. -destruct (ln_beta beta x) as (ex', He). +unfold cexp in ex. +destruct (mag beta x) as (ex', He). simpl in ex. specialize (He Hx0). apply Rlt_le_trans with (1 := proj2 He). apply bpow_le. cut (ex' - prec <= ex)%Z. omega. unfold ex, FLT_exp. -apply Zle_max_l. -apply Zle_max_r. +apply Z.le_max_l. +apply Z.le_max_r. Qed. @@ -128,18 +122,18 @@ apply FLT_format_generic. apply generic_format_FLT. Qed. -Theorem canonic_exp_FLT_FLX : +Theorem cexp_FLT_FLX : forall x, (bpow (emin + prec - 1) <= Rabs x)%R -> - canonic_exp beta FLT_exp x = canonic_exp beta (FLX_exp prec) x. + cexp beta FLT_exp x = cexp beta (FLX_exp prec) x. Proof. intros x Hx. assert (Hx0: x <> 0%R). intros H1; rewrite H1, Rabs_R0 in Hx. contradict Hx; apply Rlt_not_le, bpow_gt_0. -unfold canonic_exp. +unfold cexp. apply Zmax_left. -destruct (ln_beta beta x) as (ex, He). +destruct (mag beta x) as (ex, He). unfold FLX_exp. simpl. specialize (He Hx0). cut (emin + prec - 1 < ex)%Z. omega. @@ -160,7 +154,7 @@ destruct (Req_dec x 0) as [Hx0|Hx0]. rewrite Hx0. apply generic_format_0. unfold generic_format, scaled_mantissa. -now rewrite canonic_exp_FLT_FLX. +now rewrite cexp_FLT_FLX. Qed. Theorem generic_format_FLX_FLT : @@ -173,29 +167,30 @@ unfold generic_format in Hx; rewrite Hx. apply generic_format_F2R. intros _. rewrite <- Hx. -unfold canonic_exp, FLX_exp, FLT_exp. -apply Zle_max_l. +unfold cexp, FLX_exp, FLT_exp. +apply Z.le_max_l. Qed. Theorem round_FLT_FLX : forall rnd x, (bpow (emin + prec - 1) <= Rabs x)%R -> round beta FLT_exp rnd x = round beta (FLX_exp prec) rnd x. +Proof. intros rnd x Hx. unfold round, scaled_mantissa. -rewrite canonic_exp_FLT_FLX ; trivial. +rewrite cexp_FLT_FLX ; trivial. Qed. (** Links between FLT and FIX (underflow) *) -Theorem canonic_exp_FLT_FIX : +Theorem cexp_FLT_FIX : forall x, x <> 0%R -> (Rabs x < bpow (emin + prec))%R -> - canonic_exp beta FLT_exp x = canonic_exp beta (FIX_exp emin) x. + cexp beta FLT_exp x = cexp beta (FIX_exp emin) x. Proof. intros x Hx0 Hx. -unfold canonic_exp. +unfold cexp. apply Zmax_right. unfold FIX_exp. -destruct (ln_beta beta x) as (ex, Hex). +destruct (mag beta x) as (ex, Hex). simpl. cut (ex - 1 < emin + prec)%Z. omega. apply (lt_bpow beta). @@ -214,7 +209,7 @@ rewrite Hx. apply generic_format_F2R. intros _. rewrite <- Hx. -apply Zle_max_r. +apply Z.le_max_r. Qed. Theorem generic_format_FLT_FIX : @@ -226,9 +221,37 @@ Proof with auto with typeclass_instances. apply generic_inclusion_le... intros e He. unfold FIX_exp. -apply Zmax_lub. +apply Z.max_lub. omega. -apply Zle_refl. +apply Z.le_refl. +Qed. + +Lemma negligible_exp_FLT : + exists n, negligible_exp FLT_exp = Some n /\ (n <= emin)%Z. +Proof. +case (negligible_exp_spec FLT_exp). +{ intro H; exfalso; specialize (H emin); revert H. + apply Zle_not_lt, Z.le_max_r. } +intros n Hn; exists n; split; [now simpl|]. +destruct (Z.max_spec (n - prec) emin) as [(Hm, Hm')|(Hm, Hm')]. +{ now revert Hn; unfold FLT_exp; rewrite Hm'. } +revert Hn prec_gt_0_; unfold FLT_exp, Prec_gt_0; rewrite Hm'; lia. +Qed. + +Theorem generic_format_FLT_1 (Hemin : (emin <= 0)%Z) : + generic_format beta FLT_exp 1. +Proof. +unfold generic_format, scaled_mantissa, cexp, F2R; simpl. +rewrite Rmult_1_l, (mag_unique beta 1 1). +{ unfold FLT_exp. + destruct (Z.max_spec_le (1 - prec) emin) as [(H,Hm)|(H,Hm)]; rewrite Hm; + (rewrite <- IZR_Zpower; [|unfold Prec_gt_0 in prec_gt_0_; omega]); + (rewrite Ztrunc_IZR, IZR_Zpower, <-bpow_plus; + [|unfold Prec_gt_0 in prec_gt_0_; omega]); + now replace (_ + _)%Z with Z0 by ring. } +rewrite Rabs_R1; simpl; split; [now right|]. +rewrite IZR_Zpower_pos; simpl; rewrite Rmult_1_r; apply IZR_lt. +apply (Z.lt_le_trans _ 2); [omega|]; apply Zle_bool_imp_le, beta. Qed. Theorem ulp_FLT_small: forall x, (Rabs x < bpow (emin+prec))%R -> @@ -240,7 +263,7 @@ unfold ulp; case Req_bool_spec; intros Hx2. case (negligible_exp_spec FLT_exp). intros T; specialize (T (emin-1)%Z); contradict T. apply Zle_not_lt; unfold FLT_exp. -apply Zle_trans with (2:=Z.le_max_r _ _); omega. +apply Z.le_trans with (2:=Z.le_max_r _ _); omega. assert (V:FLT_exp emin = emin). unfold FLT_exp; apply Z.max_r. unfold Prec_gt_0 in prec_gt_0_; omega. @@ -248,10 +271,10 @@ intros n H2; rewrite <-V. apply f_equal, fexp_negligible_exp_eq... omega. (* x <> 0 *) -apply f_equal; unfold canonic_exp, FLT_exp. +apply f_equal; unfold cexp, FLT_exp. apply Z.max_r. -assert (ln_beta beta x-1 < emin+prec)%Z;[idtac|omega]. -destruct (ln_beta beta x) as (e,He); simpl. +assert (mag beta x-1 < emin+prec)%Z;[idtac|omega]. +destruct (mag beta x) as (e,He); simpl. apply lt_bpow with beta. apply Rle_lt_trans with (2:=Hx). now apply He. @@ -266,8 +289,8 @@ assert (Zx : (x <> 0)%R). intros Z; contradict Hx; apply Rgt_not_le, Rlt_gt. rewrite Z, Rabs_R0; apply bpow_gt_0. rewrite ulp_neq_0 with (1 := Zx). -unfold canonic_exp, FLT_exp. -destruct (ln_beta beta x) as (e,He). +unfold cexp, FLT_exp. +destruct (mag beta x) as (e,He). apply Rle_trans with (bpow (e-1)*bpow (1-prec))%R. rewrite <- bpow_plus. right; apply f_equal. @@ -289,17 +312,68 @@ intros x; case (Req_dec x 0); intros Hx. rewrite Hx, ulp_FLT_small, Rabs_R0, Rmult_0_l; try apply bpow_gt_0. rewrite Rabs_R0; apply bpow_gt_0. rewrite ulp_neq_0; try exact Hx. -unfold canonic_exp, FLT_exp. -apply Rlt_le_trans with (bpow (ln_beta beta x)*bpow (-prec))%R. +unfold cexp, FLT_exp. +apply Rlt_le_trans with (bpow (mag beta x)*bpow (-prec))%R. apply Rmult_lt_compat_r. apply bpow_gt_0. -now apply bpow_ln_beta_gt. +now apply bpow_mag_gt. rewrite <- bpow_plus. apply bpow_le. apply Z.le_max_l. Qed. +Lemma ulp_FLT_exact_shift : + forall x e, + (x <> 0)%R -> + (emin + prec <= mag beta x)%Z -> + (emin + prec - mag beta x <= e)%Z -> + (ulp beta FLT_exp (x * bpow e) = ulp beta FLT_exp x * bpow e)%R. +Proof. +intros x e Nzx Hmx He. +unfold ulp; rewrite Req_bool_false; + [|now intro H; apply Nzx, (Rmult_eq_reg_r (bpow e)); + [rewrite Rmult_0_l|apply Rgt_not_eq, Rlt_gt, bpow_gt_0]]. +rewrite (Req_bool_false _ _ Nzx), <- bpow_plus; f_equal; unfold cexp, FLT_exp. +rewrite (mag_mult_bpow _ _ _ Nzx), !Z.max_l; omega. +Qed. + +Lemma succ_FLT_exact_shift_pos : + forall x e, + (0 < x)%R -> + (emin + prec <= mag beta x)%Z -> + (emin + prec - mag beta x <= e)%Z -> + (succ beta FLT_exp (x * bpow e) = succ beta FLT_exp x * bpow e)%R. +Proof. +intros x e Px Hmx He. +rewrite succ_eq_pos; [|now apply Rlt_le, Rmult_lt_0_compat, bpow_gt_0]. +rewrite (succ_eq_pos _ _ _ (Rlt_le _ _ Px)). +now rewrite Rmult_plus_distr_r; f_equal; apply ulp_FLT_exact_shift; [lra| |]. +Qed. +Lemma succ_FLT_exact_shift : + forall x e, + (x <> 0)%R -> + (emin + prec + 1 <= mag beta x)%Z -> + (emin + prec - mag beta x + 1 <= e)%Z -> + (succ beta FLT_exp (x * bpow e) = succ beta FLT_exp x * bpow e)%R. +Proof. +intros x e Nzx Hmx He. +destruct (Rle_or_lt 0 x) as [Px|Nx]. +{ now apply succ_FLT_exact_shift_pos; [lra|lia|lia]. } +unfold succ. +rewrite Rle_bool_false; [|assert (H := bpow_gt_0 beta e); nra]. +rewrite Rle_bool_false; [|now simpl]. +rewrite Ropp_mult_distr_l_reverse, <-Ropp_mult_distr_l_reverse; f_equal. +unfold pred_pos. +rewrite mag_mult_bpow; [|lra]. +replace (_ - 1)%Z with (mag beta (- x) - 1 + e)%Z; [|ring]; rewrite bpow_plus. +unfold Req_bool; rewrite Rcompare_mult_r; [|now apply bpow_gt_0]. +fold (Req_bool (-x) (bpow (mag beta (-x) - 1))); case Req_bool. +{ rewrite mag_opp; unfold FLT_exp; do 2 (rewrite Z.max_l; [|lia]). + replace (_ - _)%Z with (mag beta x - 1 - prec + e)%Z; [|ring]. + rewrite bpow_plus; ring. } +rewrite ulp_FLT_exact_shift; [ring|lra| |]; rewrite mag_opp; lia. +Qed. (** FLT is a nice format: it has a monotone exponent... *) Global Instance FLT_exp_monotone : Monotone_exp FLT_exp. @@ -310,7 +384,7 @@ zify ; omega. Qed. (** and it allows a rounding to nearest, ties to even. *) -Hypothesis NE_prop : Zeven beta = false \/ (1 < prec)%Z. +Hypothesis NE_prop : Z.even beta = false \/ (1 < prec)%Z. Global Instance exists_NE_FLT : Exists_NE beta FLT_exp. Proof. diff --git a/flocq/Core/FLX.v b/flocq/Core/FLX.v new file mode 100644 index 00000000..803d96ef --- /dev/null +++ b/flocq/Core/FLX.v @@ -0,0 +1,362 @@ +(** +This file is part of the Flocq formalization of floating-point +arithmetic in Coq: http://flocq.gforge.inria.fr/ + +Copyright (C) 2009-2018 Sylvie Boldo +#<br /># +Copyright (C) 2009-2018 Guillaume Melquiond + +This library is free software; you can redistribute it and/or +modify it under the terms of the GNU Lesser General Public +License as published by the Free Software Foundation; either +version 3 of the License, or (at your option) any later version. + +This library is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +COPYING file for more details. +*) + +(** * Floating-point format without underflow *) +Require Import Raux Defs Round_pred Generic_fmt Float_prop. +Require Import FIX Ulp Round_NE. +Require Import Psatz. + +Section RND_FLX. + +Variable beta : radix. + +Notation bpow e := (bpow beta e). + +Variable prec : Z. + +Class Prec_gt_0 := + prec_gt_0 : (0 < prec)%Z. + +Context { prec_gt_0_ : Prec_gt_0 }. + +Inductive FLX_format (x : R) : Prop := + FLX_spec (f : float beta) : + x = F2R f -> (Z.abs (Fnum f) < Zpower beta prec)%Z -> FLX_format x. + +Definition FLX_exp (e : Z) := (e - prec)%Z. + +(** Properties of the FLX format *) + +Global Instance FLX_exp_valid : Valid_exp FLX_exp. +Proof. +intros k. +unfold FLX_exp. +generalize prec_gt_0. +repeat split ; intros ; omega. +Qed. + +Theorem FIX_format_FLX : + forall x e, + (bpow (e - 1) <= Rabs x <= bpow e)%R -> + FLX_format x -> + FIX_format beta (e - prec) x. +Proof. +clear prec_gt_0_. +intros x e Hx [[xm xe] H1 H2]. +rewrite H1, (F2R_prec_normalize beta xm xe e prec). +now eexists. +exact H2. +now rewrite <- H1. +Qed. + +Theorem FLX_format_generic : + forall x, generic_format beta FLX_exp x -> FLX_format x. +Proof. +intros x H. +rewrite H. +eexists ; repeat split. +simpl. +apply lt_IZR. +rewrite abs_IZR. +rewrite <- scaled_mantissa_generic with (1 := H). +rewrite <- scaled_mantissa_abs. +apply Rmult_lt_reg_r with (bpow (cexp beta FLX_exp (Rabs x))). +apply bpow_gt_0. +rewrite scaled_mantissa_mult_bpow. +rewrite IZR_Zpower, <- bpow_plus. +2: now apply Zlt_le_weak. +unfold cexp, FLX_exp. +ring_simplify (prec + (mag beta (Rabs x) - prec))%Z. +rewrite mag_abs. +destruct (Req_dec x 0) as [Hx|Hx]. +rewrite Hx, Rabs_R0. +apply bpow_gt_0. +destruct (mag beta x) as (ex, Ex). +now apply Ex. +Qed. + +Theorem generic_format_FLX : + forall x, FLX_format x -> generic_format beta FLX_exp x. +Proof. +clear prec_gt_0_. +intros x [[mx ex] H1 H2]. +simpl in H2. +rewrite H1. +apply generic_format_F2R. +intros Zmx. +unfold cexp, FLX_exp. +rewrite mag_F2R with (1 := Zmx). +apply Zplus_le_reg_r with (prec - ex)%Z. +ring_simplify. +now apply mag_le_Zpower. +Qed. + +Theorem FLX_format_satisfies_any : + satisfies_any FLX_format. +Proof. +refine (satisfies_any_eq _ _ _ (generic_format_satisfies_any beta FLX_exp)). +intros x. +split. +apply FLX_format_generic. +apply generic_format_FLX. +Qed. + +Theorem FLX_format_FIX : + forall x e, + (bpow (e - 1) <= Rabs x <= bpow e)%R -> + FIX_format beta (e - prec) x -> + FLX_format x. +Proof with auto with typeclass_instances. +intros x e Hx Fx. +apply FLX_format_generic. +apply generic_format_FIX in Fx. +revert Fx. +apply generic_inclusion with (e := e)... +apply Z.le_refl. +Qed. + +(** unbounded floating-point format with normal mantissas *) +Inductive FLXN_format (x : R) : Prop := + FLXN_spec (f : float beta) : + x = F2R f -> + (x <> 0%R -> Zpower beta (prec - 1) <= Z.abs (Fnum f) < Zpower beta prec)%Z -> + FLXN_format x. + +Theorem generic_format_FLXN : + forall x, FLXN_format x -> generic_format beta FLX_exp x. +Proof. +intros x [[xm ex] H1 H2]. +destruct (Req_dec x 0) as [Zx|Zx]. +rewrite Zx. +apply generic_format_0. +specialize (H2 Zx). +apply generic_format_FLX. +rewrite H1. +eexists ; repeat split. +apply H2. +Qed. + +Theorem FLXN_format_generic : + forall x, generic_format beta FLX_exp x -> FLXN_format x. +Proof. +intros x Hx. +rewrite Hx. +simpl. +eexists. easy. +rewrite <- Hx. +intros Zx. +simpl. +split. +(* *) +apply le_IZR. +rewrite IZR_Zpower. +2: now apply Zlt_0_le_0_pred. +rewrite abs_IZR, <- scaled_mantissa_generic with (1 := Hx). +apply Rmult_le_reg_r with (bpow (cexp beta FLX_exp x)). +apply bpow_gt_0. +rewrite <- bpow_plus. +rewrite <- scaled_mantissa_abs. +rewrite <- cexp_abs. +rewrite scaled_mantissa_mult_bpow. +unfold cexp, FLX_exp. +rewrite mag_abs. +ring_simplify (prec - 1 + (mag beta x - prec))%Z. +destruct (mag beta x) as (ex,Ex). +now apply Ex. +(* *) +apply lt_IZR. +rewrite IZR_Zpower. +2: now apply Zlt_le_weak. +rewrite abs_IZR, <- scaled_mantissa_generic with (1 := Hx). +apply Rmult_lt_reg_r with (bpow (cexp beta FLX_exp x)). +apply bpow_gt_0. +rewrite <- bpow_plus. +rewrite <- scaled_mantissa_abs. +rewrite <- cexp_abs. +rewrite scaled_mantissa_mult_bpow. +unfold cexp, FLX_exp. +rewrite mag_abs. +ring_simplify (prec + (mag beta x - prec))%Z. +destruct (mag beta x) as (ex,Ex). +now apply Ex. +Qed. + +Theorem FLXN_format_satisfies_any : + satisfies_any FLXN_format. +Proof. +refine (satisfies_any_eq _ _ _ (generic_format_satisfies_any beta FLX_exp)). +split ; intros H. +now apply FLXN_format_generic. +now apply generic_format_FLXN. +Qed. + +Lemma negligible_exp_FLX : + negligible_exp FLX_exp = None. +Proof. +case (negligible_exp_spec FLX_exp). +intros _; reflexivity. +intros n H2; contradict H2. +unfold FLX_exp; unfold Prec_gt_0 in prec_gt_0_; omega. +Qed. + +Theorem generic_format_FLX_1 : + generic_format beta FLX_exp 1. +Proof. +unfold generic_format, scaled_mantissa, cexp, F2R; simpl. +rewrite Rmult_1_l, (mag_unique beta 1 1). +{ unfold FLX_exp. + rewrite <- IZR_Zpower; [|unfold Prec_gt_0 in prec_gt_0_; omega]. + rewrite Ztrunc_IZR, IZR_Zpower; [|unfold Prec_gt_0 in prec_gt_0_; omega]. + rewrite <- bpow_plus. + now replace (_ + _)%Z with Z0 by ring. } +rewrite Rabs_R1; simpl; split; [now right|]. +unfold Z.pow_pos; simpl; rewrite Zmult_1_r; apply IZR_lt. +assert (H := Zle_bool_imp_le _ _ (radix_prop beta)); omega. +Qed. + +Theorem ulp_FLX_0: (ulp beta FLX_exp 0 = 0)%R. +Proof. +unfold ulp; rewrite Req_bool_true; trivial. +rewrite negligible_exp_FLX; easy. +Qed. + +Lemma ulp_FLX_1 : ulp beta FLX_exp 1 = bpow (-prec + 1). +Proof. +unfold ulp, FLX_exp, cexp; rewrite Req_bool_false; [|apply R1_neq_R0]. +rewrite mag_1; f_equal; ring. +Qed. + +Lemma succ_FLX_1 : (succ beta FLX_exp 1 = 1 + bpow (-prec + 1))%R. +Proof. +now unfold succ; rewrite Rle_bool_true; [|apply Rle_0_1]; rewrite ulp_FLX_1. +Qed. + +Theorem eq_0_round_0_FLX : + forall rnd {Vr: Valid_rnd rnd} x, + round beta FLX_exp rnd x = 0%R -> x = 0%R. +Proof. +intros rnd Hr x. +apply eq_0_round_0_negligible_exp; try assumption. +apply FLX_exp_valid. +apply negligible_exp_FLX. +Qed. + +Theorem gt_0_round_gt_0_FLX : + forall rnd {Vr: Valid_rnd rnd} x, + (0 < x)%R -> (0 < round beta FLX_exp rnd x)%R. +Proof with auto with typeclass_instances. +intros rnd Hr x Hx. +assert (K: (0 <= round beta FLX_exp rnd x)%R). +rewrite <- (round_0 beta FLX_exp rnd). +apply round_le... now apply Rlt_le. +destruct K; try easy. +absurd (x = 0)%R. +now apply Rgt_not_eq. +apply eq_0_round_0_FLX with rnd... +Qed. + + +Theorem ulp_FLX_le : + forall x, (ulp beta FLX_exp x <= Rabs x * bpow (1-prec))%R. +Proof. +intros x; case (Req_dec x 0); intros Hx. +rewrite Hx, ulp_FLX_0, Rabs_R0. +right; ring. +rewrite ulp_neq_0; try exact Hx. +unfold cexp, FLX_exp. +replace (mag beta x - prec)%Z with ((mag beta x - 1) + (1-prec))%Z by ring. +rewrite bpow_plus. +apply Rmult_le_compat_r. +apply bpow_ge_0. +now apply bpow_mag_le. +Qed. + +Theorem ulp_FLX_ge : + forall x, (Rabs x * bpow (-prec) <= ulp beta FLX_exp x)%R. +Proof. +intros x; case (Req_dec x 0); intros Hx. +rewrite Hx, ulp_FLX_0, Rabs_R0. +right; ring. +rewrite ulp_neq_0; try exact Hx. +unfold cexp, FLX_exp. +unfold Zminus; rewrite bpow_plus. +apply Rmult_le_compat_r. +apply bpow_ge_0. +left; now apply bpow_mag_gt. +Qed. + +Lemma ulp_FLX_exact_shift : + forall x e, + (ulp beta FLX_exp (x * bpow e) = ulp beta FLX_exp x * bpow e)%R. +Proof. +intros x e. +destruct (Req_dec x 0) as [Hx|Hx]. +{ unfold ulp. + now rewrite !Req_bool_true, negligible_exp_FLX; rewrite ?Hx, ?Rmult_0_l. } +unfold ulp; rewrite Req_bool_false; + [|now intro H; apply Hx, (Rmult_eq_reg_r (bpow e)); + [rewrite Rmult_0_l|apply Rgt_not_eq, Rlt_gt, bpow_gt_0]]. +rewrite (Req_bool_false _ _ Hx), <- bpow_plus; f_equal; unfold cexp, FLX_exp. +now rewrite mag_mult_bpow; [ring|]. +Qed. + +Lemma succ_FLX_exact_shift : + forall x e, + (succ beta FLX_exp (x * bpow e) = succ beta FLX_exp x * bpow e)%R. +Proof. +intros x e. +destruct (Rle_or_lt 0 x) as [Px|Nx]. +{ rewrite succ_eq_pos; [|now apply Rmult_le_pos, bpow_ge_0]. + rewrite (succ_eq_pos _ _ _ Px). + now rewrite Rmult_plus_distr_r; f_equal; apply ulp_FLX_exact_shift. } +unfold succ. +rewrite Rle_bool_false; [|assert (H := bpow_gt_0 beta e); nra]. +rewrite Rle_bool_false; [|now simpl]. +rewrite Ropp_mult_distr_l_reverse, <-Ropp_mult_distr_l_reverse; f_equal. +unfold pred_pos. +rewrite mag_mult_bpow; [|lra]. +replace (_ - 1)%Z with (mag beta (- x) - 1 + e)%Z; [|ring]; rewrite bpow_plus. +unfold Req_bool; rewrite Rcompare_mult_r; [|now apply bpow_gt_0]. +fold (Req_bool (-x) (bpow (mag beta (-x) - 1))); case Req_bool. +{ unfold FLX_exp. + replace (_ - _)%Z with (mag beta (- x) - 1 - prec + e)%Z; [|ring]. + rewrite bpow_plus; ring. } +rewrite ulp_FLX_exact_shift; ring. +Qed. + +(** FLX is a nice format: it has a monotone exponent... *) +Global Instance FLX_exp_monotone : Monotone_exp FLX_exp. +Proof. +intros ex ey Hxy. +now apply Zplus_le_compat_r. +Qed. + +(** and it allows a rounding to nearest, ties to even. *) +Hypothesis NE_prop : Z.even beta = false \/ (1 < prec)%Z. + +Global Instance exists_NE_FLX : Exists_NE beta FLX_exp. +Proof. +destruct NE_prop as [H|H]. +now left. +right. +unfold FLX_exp. +split ; omega. +Qed. + +End RND_FLX. diff --git a/flocq/Core/Fcore_FTZ.v b/flocq/Core/FTZ.v index a2fab00b..1a93bcd9 100644 --- a/flocq/Core/Fcore_FTZ.v +++ b/flocq/Core/FTZ.v @@ -2,9 +2,9 @@ This file is part of the Flocq formalization of floating-point arithmetic in Coq: http://flocq.gforge.inria.fr/ -Copyright (C) 2010-2013 Sylvie Boldo +Copyright (C) 2009-2018 Sylvie Boldo #<br /># -Copyright (C) 2010-2013 Guillaume Melquiond +Copyright (C) 2009-2018 Guillaume Melquiond This library is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public @@ -18,13 +18,8 @@ COPYING file for more details. *) (** * Floating-point format with abrupt underflow *) -Require Import Fcore_Raux. -Require Import Fcore_defs. -Require Import Fcore_rnd. -Require Import Fcore_generic_fmt. -Require Import Fcore_float_prop. -Require Import Fcore_ulp. -Require Import Fcore_FLX. +Require Import Raux Defs Round_pred Generic_fmt. +Require Import Float_prop Ulp FLX. Section RND_FTZ. @@ -36,11 +31,12 @@ Variable emin prec : Z. Context { prec_gt_0_ : Prec_gt_0 prec }. -(* floating-point format with abrupt underflow *) -Definition FTZ_format (x : R) := - exists f : float beta, - x = F2R f /\ (x <> R0 -> Zpower beta (prec - 1) <= Zabs (Fnum f) < Zpower beta prec)%Z /\ - (emin <= Fexp f)%Z. +Inductive FTZ_format (x : R) : Prop := + FTZ_spec (f : float beta) : + x = F2R f -> + (x <> 0%R -> Zpower beta (prec - 1) <= Z.abs (Fnum f) < Zpower beta prec)%Z -> + (emin <= Fexp f)%Z -> + FTZ_format x. Definition FTZ_exp e := if Zlt_bool (e - prec) emin then (emin + prec - 1)%Z else (e - prec)%Z. @@ -73,9 +69,10 @@ Qed. Theorem FLXN_format_FTZ : forall x, FTZ_format x -> FLXN_format beta prec x. Proof. -intros x ((xm, xe), (Hx1, (Hx2, Hx3))). +intros x [[xm xe] Hx1 Hx2 Hx3]. eexists. -apply (conj Hx1 Hx2). +exact Hx1. +exact Hx2. Qed. Theorem generic_format_FTZ : @@ -83,9 +80,9 @@ Theorem generic_format_FTZ : Proof. intros x Hx. cut (generic_format beta (FLX_exp prec) x). -apply generic_inclusion_ln_beta. +apply generic_inclusion_mag. intros Zx. -destruct Hx as ((xm, xe), (Hx1, (Hx2, Hx3))). +destruct Hx as [[xm xe] Hx1 Hx2 Hx3]. simpl in Hx2, Hx3. specialize (Hx2 Zx). assert (Zxm: xm <> Z0). @@ -94,11 +91,11 @@ rewrite Hx1, Zx. apply F2R_0. unfold FTZ_exp, FLX_exp. rewrite Zlt_bool_false. -apply Zle_refl. -rewrite Hx1, ln_beta_F2R with (1 := Zxm). -cut (prec - 1 < ln_beta beta (Z2R xm))%Z. +apply Z.le_refl. +rewrite Hx1, mag_F2R with (1 := Zxm). +cut (prec - 1 < mag beta (IZR xm))%Z. clear -Hx3 ; omega. -apply ln_beta_gt_Zpower with (1 := Zxm). +apply mag_gt_Zpower with (1 := Zxm). apply Hx2. apply generic_format_FLXN. now apply FLXN_format_FTZ. @@ -108,17 +105,14 @@ Theorem FTZ_format_generic : forall x, generic_format beta FTZ_exp x -> FTZ_format x. Proof. intros x Hx. -destruct (Req_dec x 0) as [Hx3|Hx3]. +destruct (Req_dec x 0) as [->|Hx3]. exists (Float beta 0 emin). -split. -unfold F2R. simpl. -now rewrite Rmult_0_l. -split. +apply sym_eq, F2R_0. intros H. now elim H. -apply Zle_refl. -unfold generic_format, scaled_mantissa, canonic_exp, FTZ_exp in Hx. -destruct (ln_beta beta x) as (ex, Hx4). +apply Z.le_refl. +unfold generic_format, scaled_mantissa, cexp, FTZ_exp in Hx. +destruct (mag beta x) as (ex, Hx4). simpl in Hx. specialize (Hx4 Hx3). generalize (Zlt_cases (ex - prec) emin) Hx. clear Hx. @@ -129,43 +123,43 @@ rewrite Hx2, <- F2R_Zabs. rewrite <- (Rmult_1_l (bpow ex)). unfold F2R. simpl. apply Rmult_le_compat. -now apply (Z2R_le 0 1). +now apply IZR_le. apply bpow_ge_0. -apply (Z2R_le 1). +apply IZR_le. apply (Zlt_le_succ 0). -apply lt_Z2R. +apply lt_IZR. apply Rmult_lt_reg_r with (bpow (emin + prec - 1)). apply bpow_gt_0. rewrite Rmult_0_l. -change (0 < F2R (Float beta (Zabs (Ztrunc (x * bpow (- (emin + prec - 1))))) (emin + prec - 1)))%R. +change (0 < F2R (Float beta (Z.abs (Ztrunc (x * bpow (- (emin + prec - 1))))) (emin + prec - 1)))%R. rewrite F2R_Zabs, <- Hx2. now apply Rabs_pos_lt. apply bpow_le. omega. rewrite Hx2. eexists ; repeat split ; simpl. -apply le_Z2R. -rewrite Z2R_Zpower. +apply le_IZR. +rewrite IZR_Zpower. apply Rmult_le_reg_r with (bpow (ex - prec)). apply bpow_gt_0. rewrite <- bpow_plus. replace (prec - 1 + (ex - prec))%Z with (ex - 1)%Z by ring. -change (bpow (ex - 1) <= F2R (Float beta (Zabs (Ztrunc (x * bpow (- (ex - prec))))) (ex - prec)))%R. +change (bpow (ex - 1) <= F2R (Float beta (Z.abs (Ztrunc (x * bpow (- (ex - prec))))) (ex - prec)))%R. rewrite F2R_Zabs, <- Hx2. apply Hx4. apply Zle_minus_le_0. now apply (Zlt_le_succ 0). -apply lt_Z2R. -rewrite Z2R_Zpower. +apply lt_IZR. +rewrite IZR_Zpower. apply Rmult_lt_reg_r with (bpow (ex - prec)). apply bpow_gt_0. rewrite <- bpow_plus. replace (prec + (ex - prec))%Z with ex by ring. -change (F2R (Float beta (Zabs (Ztrunc (x * bpow (- (ex - prec))))) (ex - prec)) < bpow ex)%R. +change (F2R (Float beta (Z.abs (Ztrunc (x * bpow (- (ex - prec))))) (ex - prec)) < bpow ex)%R. rewrite F2R_Zabs, <- Hx2. apply Hx4. now apply Zlt_le_weak. -now apply Zge_le. +now apply Z.ge_le. Qed. Theorem FTZ_format_satisfies_any : @@ -191,11 +185,12 @@ apply generic_inclusion_ge. intros e He. unfold FTZ_exp. rewrite Zlt_bool_false. -apply Zle_refl. +apply Z.le_refl. omega. Qed. -Theorem ulp_FTZ_0: ulp beta FTZ_exp 0 = bpow (emin+prec-1). +Theorem ulp_FTZ_0 : + ulp beta FTZ_exp 0 = bpow (emin+prec-1). Proof with auto with typeclass_instances. unfold ulp; rewrite Req_bool_true; trivial. case (negligible_exp_spec FTZ_exp). @@ -230,9 +225,9 @@ case Rle_bool_spec ; intros Hx ; 4: easy. (* 1 <= |x| *) now apply Zrnd_le. -rewrite <- (Zrnd_Z2R rnd 0). +rewrite <- (Zrnd_IZR rnd 0). apply Zrnd_le... -apply Rle_trans with (Z2R (-1)). 2: now apply Z2R_le. +apply Rle_trans with (-1)%R. 2: now apply IZR_le. destruct (Rabs_ge_inv _ _ Hx) as [Hx1|Hx1]. exact Hx1. elim Rle_not_lt with (1 := Hx1). @@ -240,10 +235,10 @@ apply Rle_lt_trans with (2 := Hy). apply Rle_trans with (1 := Hxy). apply RRle_abs. (* |x| < 1 *) -rewrite <- (Zrnd_Z2R rnd 0). +rewrite <- (Zrnd_IZR rnd 0). apply Zrnd_le... -apply Rle_trans with (Z2R 1). -now apply Z2R_le. +apply Rle_trans with 1%R. +now apply IZR_le. destruct (Rabs_ge_inv _ _ Hy) as [Hy1|Hy1]. elim Rle_not_lt with (1 := Hy1). apply Rlt_le_trans with (2 := Hxy). @@ -252,12 +247,12 @@ exact Hy1. (* *) intros n. unfold Zrnd_FTZ. -rewrite Zrnd_Z2R... +rewrite Zrnd_IZR... case Rle_bool_spec. easy. -rewrite <- Z2R_abs. +rewrite <- abs_IZR. intros H. -generalize (lt_Z2R _ 1 H). +generalize (lt_IZR _ 1 H). clear. now case n ; trivial ; simpl ; intros [p|p|]. Qed. @@ -268,8 +263,8 @@ Theorem round_FTZ_FLX : round beta FTZ_exp Zrnd_FTZ x = round beta (FLX_exp prec) rnd x. Proof. intros x Hx. -unfold round, scaled_mantissa, canonic_exp. -destruct (ln_beta beta x) as (ex, He). simpl. +unfold round, scaled_mantissa, cexp. +destruct (mag beta x) as (ex, He). simpl. assert (Hx0: x <> 0%R). intros Hx0. apply Rle_not_lt with (1 := Hx). @@ -306,14 +301,14 @@ Qed. Theorem round_FTZ_small : forall x : R, (Rabs x < bpow (emin + prec - 1))%R -> - round beta FTZ_exp Zrnd_FTZ x = R0. + round beta FTZ_exp Zrnd_FTZ x = 0%R. Proof with auto with typeclass_instances. intros x Hx. destruct (Req_dec x 0) as [Hx0|Hx0]. rewrite Hx0. apply round_0... -unfold round, scaled_mantissa, canonic_exp. -destruct (ln_beta beta x) as (ex, He). simpl. +unfold round, scaled_mantissa, cexp. +destruct (mag beta x) as (ex, He). simpl. specialize (He Hx0). unfold Zrnd_FTZ. rewrite Rle_bool_false. @@ -331,7 +326,7 @@ unfold FTZ_exp. generalize (Zlt_cases (ex - prec) emin). case Zlt_bool. intros _. -apply Zle_refl. +apply Z.le_refl. intros He'. elim Rlt_not_le with (1 := Hx). apply Rle_trans with (2 := proj1 He). diff --git a/flocq/Core/Fcore_FLX.v b/flocq/Core/Fcore_FLX.v deleted file mode 100644 index 55f6db61..00000000 --- a/flocq/Core/Fcore_FLX.v +++ /dev/null @@ -1,271 +0,0 @@ -(** -This file is part of the Flocq formalization of floating-point -arithmetic in Coq: http://flocq.gforge.inria.fr/ - -Copyright (C) 2010-2013 Sylvie Boldo -#<br /># -Copyright (C) 2010-2013 Guillaume Melquiond - -This library is free software; you can redistribute it and/or -modify it under the terms of the GNU Lesser General Public -License as published by the Free Software Foundation; either -version 3 of the License, or (at your option) any later version. - -This library is distributed in the hope that it will be useful, -but WITHOUT ANY WARRANTY; without even the implied warranty of -MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -COPYING file for more details. -*) - -(** * Floating-point format without underflow *) -Require Import Fcore_Raux. -Require Import Fcore_defs. -Require Import Fcore_rnd. -Require Import Fcore_generic_fmt. -Require Import Fcore_float_prop. -Require Import Fcore_FIX. -Require Import Fcore_ulp. -Require Import Fcore_rnd_ne. - -Section RND_FLX. - -Variable beta : radix. - -Notation bpow e := (bpow beta e). - -Variable prec : Z. - -Class Prec_gt_0 := - prec_gt_0 : (0 < prec)%Z. - -Context { prec_gt_0_ : Prec_gt_0 }. - -(* unbounded floating-point format *) -Definition FLX_format (x : R) := - exists f : float beta, - x = F2R f /\ (Zabs (Fnum f) < Zpower beta prec)%Z. - -Definition FLX_exp (e : Z) := (e - prec)%Z. - -(** Properties of the FLX format *) - -Global Instance FLX_exp_valid : Valid_exp FLX_exp. -Proof. -intros k. -unfold FLX_exp. -generalize prec_gt_0. -repeat split ; intros ; omega. -Qed. - -Theorem FIX_format_FLX : - forall x e, - (bpow (e - 1) <= Rabs x <= bpow e)%R -> - FLX_format x -> - FIX_format beta (e - prec) x. -Proof. -clear prec_gt_0_. -intros x e Hx ((xm, xe), (H1, H2)). -rewrite H1, (F2R_prec_normalize beta xm xe e prec). -now eexists. -exact H2. -now rewrite <- H1. -Qed. - -Theorem FLX_format_generic : - forall x, generic_format beta FLX_exp x -> FLX_format x. -Proof. -intros x H. -rewrite H. -unfold FLX_format. -eexists ; repeat split. -simpl. -apply lt_Z2R. -rewrite Z2R_abs. -rewrite <- scaled_mantissa_generic with (1 := H). -rewrite <- scaled_mantissa_abs. -apply Rmult_lt_reg_r with (bpow (canonic_exp beta FLX_exp (Rabs x))). -apply bpow_gt_0. -rewrite scaled_mantissa_mult_bpow. -rewrite Z2R_Zpower, <- bpow_plus. -2: now apply Zlt_le_weak. -unfold canonic_exp, FLX_exp. -ring_simplify (prec + (ln_beta beta (Rabs x) - prec))%Z. -rewrite ln_beta_abs. -destruct (Req_dec x 0) as [Hx|Hx]. -rewrite Hx, Rabs_R0. -apply bpow_gt_0. -destruct (ln_beta beta x) as (ex, Ex). -now apply Ex. -Qed. - -Theorem generic_format_FLX : - forall x, FLX_format x -> generic_format beta FLX_exp x. -Proof. -clear prec_gt_0_. -intros x ((mx,ex),(H1,H2)). -simpl in H2. -rewrite H1. -apply generic_format_F2R. -intros Zmx. -unfold canonic_exp, FLX_exp. -rewrite ln_beta_F2R with (1 := Zmx). -apply Zplus_le_reg_r with (prec - ex)%Z. -ring_simplify. -now apply ln_beta_le_Zpower. -Qed. - -Theorem FLX_format_satisfies_any : - satisfies_any FLX_format. -Proof. -refine (satisfies_any_eq _ _ _ (generic_format_satisfies_any beta FLX_exp)). -intros x. -split. -apply FLX_format_generic. -apply generic_format_FLX. -Qed. - -Theorem FLX_format_FIX : - forall x e, - (bpow (e - 1) <= Rabs x <= bpow e)%R -> - FIX_format beta (e - prec) x -> - FLX_format x. -Proof with auto with typeclass_instances. -intros x e Hx Fx. -apply FLX_format_generic. -apply generic_format_FIX in Fx. -revert Fx. -apply generic_inclusion with (e := e)... -apply Zle_refl. -Qed. - -(** unbounded floating-point format with normal mantissas *) -Definition FLXN_format (x : R) := - exists f : float beta, - x = F2R f /\ (x <> R0 -> - Zpower beta (prec - 1) <= Zabs (Fnum f) < Zpower beta prec)%Z. - -Theorem generic_format_FLXN : - forall x, FLXN_format x -> generic_format beta FLX_exp x. -Proof. -intros x ((xm,ex),(H1,H2)). -destruct (Req_dec x 0) as [Zx|Zx]. -rewrite Zx. -apply generic_format_0. -specialize (H2 Zx). -apply generic_format_FLX. -rewrite H1. -eexists ; repeat split. -apply H2. -Qed. - -Theorem FLXN_format_generic : - forall x, generic_format beta FLX_exp x -> FLXN_format x. -Proof. -intros x Hx. -rewrite Hx. -simpl. -eexists ; split. split. -simpl. -rewrite <- Hx. -intros Zx. -split. -(* *) -apply le_Z2R. -rewrite Z2R_Zpower. -2: now apply Zlt_0_le_0_pred. -rewrite Z2R_abs, <- scaled_mantissa_generic with (1 := Hx). -apply Rmult_le_reg_r with (bpow (canonic_exp beta FLX_exp x)). -apply bpow_gt_0. -rewrite <- bpow_plus. -rewrite <- scaled_mantissa_abs. -rewrite <- canonic_exp_abs. -rewrite scaled_mantissa_mult_bpow. -unfold canonic_exp, FLX_exp. -rewrite ln_beta_abs. -ring_simplify (prec - 1 + (ln_beta beta x - prec))%Z. -destruct (ln_beta beta x) as (ex,Ex). -now apply Ex. -(* *) -apply lt_Z2R. -rewrite Z2R_Zpower. -2: now apply Zlt_le_weak. -rewrite Z2R_abs, <- scaled_mantissa_generic with (1 := Hx). -apply Rmult_lt_reg_r with (bpow (canonic_exp beta FLX_exp x)). -apply bpow_gt_0. -rewrite <- bpow_plus. -rewrite <- scaled_mantissa_abs. -rewrite <- canonic_exp_abs. -rewrite scaled_mantissa_mult_bpow. -unfold canonic_exp, FLX_exp. -rewrite ln_beta_abs. -ring_simplify (prec + (ln_beta beta x - prec))%Z. -destruct (ln_beta beta x) as (ex,Ex). -now apply Ex. -Qed. - -Theorem FLXN_format_satisfies_any : - satisfies_any FLXN_format. -Proof. -refine (satisfies_any_eq _ _ _ (generic_format_satisfies_any beta FLX_exp)). -split ; intros H. -now apply FLXN_format_generic. -now apply generic_format_FLXN. -Qed. - -Theorem ulp_FLX_0: (ulp beta FLX_exp 0 = 0)%R. -Proof. -unfold ulp; rewrite Req_bool_true; trivial. -case (negligible_exp_spec FLX_exp). -intros _; reflexivity. -intros n H2; contradict H2. -unfold FLX_exp; unfold Prec_gt_0 in prec_gt_0_; omega. -Qed. - -Theorem ulp_FLX_le: forall x, (ulp beta FLX_exp x <= Rabs x * bpow (1-prec))%R. -Proof. -intros x; case (Req_dec x 0); intros Hx. -rewrite Hx, ulp_FLX_0, Rabs_R0. -right; ring. -rewrite ulp_neq_0; try exact Hx. -unfold canonic_exp, FLX_exp. -replace (ln_beta beta x - prec)%Z with ((ln_beta beta x - 1) + (1-prec))%Z by ring. -rewrite bpow_plus. -apply Rmult_le_compat_r. -apply bpow_ge_0. -now apply bpow_ln_beta_le. -Qed. - - -Theorem ulp_FLX_ge: forall x, (Rabs x * bpow (-prec) <= ulp beta FLX_exp x)%R. -Proof. -intros x; case (Req_dec x 0); intros Hx. -rewrite Hx, ulp_FLX_0, Rabs_R0. -right; ring. -rewrite ulp_neq_0; try exact Hx. -unfold canonic_exp, FLX_exp. -unfold Zminus; rewrite bpow_plus. -apply Rmult_le_compat_r. -apply bpow_ge_0. -left; now apply bpow_ln_beta_gt. -Qed. - -(** FLX is a nice format: it has a monotone exponent... *) -Global Instance FLX_exp_monotone : Monotone_exp FLX_exp. -Proof. -intros ex ey Hxy. -now apply Zplus_le_compat_r. -Qed. - -(** and it allows a rounding to nearest, ties to even. *) -Hypothesis NE_prop : Zeven beta = false \/ (1 < prec)%Z. - -Global Instance exists_NE_FLX : Exists_NE beta FLX_exp. -Proof. -destruct NE_prop as [H|H]. -now left. -right. -unfold FLX_exp. -split ; omega. -Qed. - -End RND_FLX. diff --git a/flocq/Core/Fcore_float_prop.v b/flocq/Core/Float_prop.v index a183bf0a..804dd397 100644 --- a/flocq/Core/Fcore_float_prop.v +++ b/flocq/Core/Float_prop.v @@ -2,9 +2,9 @@ This file is part of the Flocq formalization of floating-point arithmetic in Coq: http://flocq.gforge.inria.fr/ -Copyright (C) 2010-2013 Sylvie Boldo +Copyright (C) 2009-2018 Sylvie Boldo #<br /># -Copyright (C) 2010-2013 Guillaume Melquiond +Copyright (C) 2009-2018 Guillaume Melquiond This library is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public @@ -18,40 +18,38 @@ COPYING file for more details. *) (** * Basic properties of floating-point formats: lemmas about mantissa, exponent... *) -Require Import Fcore_Raux. -Require Import Fcore_defs. +Require Import Raux Defs Digits. Section Float_prop. Variable beta : radix. - Notation bpow e := (bpow beta e). Theorem Rcompare_F2R : forall e m1 m2 : Z, - Rcompare (F2R (Float beta m1 e)) (F2R (Float beta m2 e)) = Zcompare m1 m2. + Rcompare (F2R (Float beta m1 e)) (F2R (Float beta m2 e)) = Z.compare m1 m2. Proof. intros e m1 m2. unfold F2R. simpl. rewrite Rcompare_mult_r. -apply Rcompare_Z2R. +apply Rcompare_IZR. apply bpow_gt_0. Qed. (** Basic facts *) -Theorem F2R_le_reg : +Theorem le_F2R : forall e m1 m2 : Z, (F2R (Float beta m1 e) <= F2R (Float beta m2 e))%R -> (m1 <= m2)%Z. Proof. intros e m1 m2 H. -apply le_Z2R. +apply le_IZR. apply Rmult_le_reg_r with (bpow e). apply bpow_gt_0. exact H. Qed. -Theorem F2R_le_compat : +Theorem F2R_le : forall m1 m2 e : Z, (m1 <= m2)%Z -> (F2R (Float beta m1 e) <= F2R (Float beta m2 e))%R. @@ -60,22 +58,22 @@ intros m1 m2 e H. unfold F2R. simpl. apply Rmult_le_compat_r. apply bpow_ge_0. -now apply Z2R_le. +now apply IZR_le. Qed. -Theorem F2R_lt_reg : +Theorem lt_F2R : forall e m1 m2 : Z, (F2R (Float beta m1 e) < F2R (Float beta m2 e))%R -> (m1 < m2)%Z. Proof. intros e m1 m2 H. -apply lt_Z2R. +apply lt_IZR. apply Rmult_lt_reg_r with (bpow e). apply bpow_gt_0. exact H. Qed. -Theorem F2R_lt_compat : +Theorem F2R_lt : forall e m1 m2 : Z, (m1 < m2)%Z -> (F2R (Float beta m1 e) < F2R (Float beta m2 e))%R. @@ -84,10 +82,10 @@ intros e m1 m2 H. unfold F2R. simpl. apply Rmult_lt_compat_r. apply bpow_gt_0. -now apply Z2R_lt. +now apply IZR_lt. Qed. -Theorem F2R_eq_compat : +Theorem F2R_eq : forall e m1 m2 : Z, (m1 = m2)%Z -> (F2R (Float beta m1 e) = F2R (Float beta m2 e))%R. @@ -96,26 +94,26 @@ intros e m1 m2 H. now apply (f_equal (fun m => F2R (Float beta m e))). Qed. -Theorem F2R_eq_reg : +Theorem eq_F2R : forall e m1 m2 : Z, F2R (Float beta m1 e) = F2R (Float beta m2 e) -> m1 = m2. Proof. intros e m1 m2 H. apply Zle_antisym ; - apply F2R_le_reg with e ; + apply le_F2R with e ; rewrite H ; apply Rle_refl. Qed. Theorem F2R_Zabs: forall m e : Z, - F2R (Float beta (Zabs m) e) = Rabs (F2R (Float beta m e)). + F2R (Float beta (Z.abs m) e) = Rabs (F2R (Float beta m e)). Proof. intros m e. unfold F2R. rewrite Rabs_mult. -rewrite <- Z2R_abs. +rewrite <- abs_IZR. simpl. apply f_equal. apply sym_eq; apply Rabs_right. @@ -125,12 +123,21 @@ Qed. Theorem F2R_Zopp : forall m e : Z, - F2R (Float beta (Zopp m) e) = Ropp (F2R (Float beta m e)). + F2R (Float beta (Z.opp m) e) = Ropp (F2R (Float beta m e)). Proof. intros m e. unfold F2R. simpl. rewrite <- Ropp_mult_distr_l_reverse. -now rewrite Z2R_opp. +now rewrite opp_IZR. +Qed. + +Theorem F2R_cond_Zopp : + forall b m e, + F2R (Float beta (cond_Zopp b m) e) = cond_Ropp b (F2R (Float beta m e)). +Proof. +intros [|] m e ; unfold F2R ; simpl. +now rewrite opp_IZR, Ropp_mult_distr_l_reverse. +apply refl_equal. Qed. (** Sign facts *) @@ -143,125 +150,125 @@ unfold F2R. simpl. apply Rmult_0_l. Qed. -Theorem F2R_eq_0_reg : +Theorem eq_0_F2R : forall m e : Z, F2R (Float beta m e) = 0%R -> m = Z0. Proof. intros m e H. -apply F2R_eq_reg with e. +apply eq_F2R with e. now rewrite F2R_0. Qed. -Theorem F2R_ge_0_reg : +Theorem ge_0_F2R : forall m e : Z, (0 <= F2R (Float beta m e))%R -> (0 <= m)%Z. Proof. intros m e H. -apply F2R_le_reg with e. +apply le_F2R with e. now rewrite F2R_0. Qed. -Theorem F2R_le_0_reg : +Theorem le_0_F2R : forall m e : Z, (F2R (Float beta m e) <= 0)%R -> (m <= 0)%Z. Proof. intros m e H. -apply F2R_le_reg with e. +apply le_F2R with e. now rewrite F2R_0. Qed. -Theorem F2R_gt_0_reg : +Theorem gt_0_F2R : forall m e : Z, (0 < F2R (Float beta m e))%R -> (0 < m)%Z. Proof. intros m e H. -apply F2R_lt_reg with e. +apply lt_F2R with e. now rewrite F2R_0. Qed. -Theorem F2R_lt_0_reg : +Theorem lt_0_F2R : forall m e : Z, (F2R (Float beta m e) < 0)%R -> (m < 0)%Z. Proof. intros m e H. -apply F2R_lt_reg with e. +apply lt_F2R with e. now rewrite F2R_0. Qed. -Theorem F2R_ge_0_compat : +Theorem F2R_ge_0 : forall f : float beta, (0 <= Fnum f)%Z -> (0 <= F2R f)%R. Proof. intros f H. rewrite <- F2R_0 with (Fexp f). -now apply F2R_le_compat. +now apply F2R_le. Qed. -Theorem F2R_le_0_compat : +Theorem F2R_le_0 : forall f : float beta, (Fnum f <= 0)%Z -> (F2R f <= 0)%R. Proof. intros f H. rewrite <- F2R_0 with (Fexp f). -now apply F2R_le_compat. +now apply F2R_le. Qed. -Theorem F2R_gt_0_compat : +Theorem F2R_gt_0 : forall f : float beta, (0 < Fnum f)%Z -> (0 < F2R f)%R. Proof. intros f H. rewrite <- F2R_0 with (Fexp f). -now apply F2R_lt_compat. +now apply F2R_lt. Qed. -Theorem F2R_lt_0_compat : +Theorem F2R_lt_0 : forall f : float beta, (Fnum f < 0)%Z -> (F2R f < 0)%R. Proof. intros f H. rewrite <- F2R_0 with (Fexp f). -now apply F2R_lt_compat. +now apply F2R_lt. Qed. -Theorem F2R_neq_0_compat : +Theorem F2R_neq_0 : forall f : float beta, (Fnum f <> 0)%Z -> (F2R f <> 0)%R. Proof. intros f H H1. apply H. -now apply F2R_eq_0_reg with (Fexp f). +now apply eq_0_F2R with (Fexp f). Qed. -Lemma Fnum_ge_0_compat: forall (f : float beta), +Lemma Fnum_ge_0: forall (f : float beta), (0 <= F2R f)%R -> (0 <= Fnum f)%Z. Proof. intros f H. case (Zle_or_lt 0 (Fnum f)); trivial. intros H1; contradict H. apply Rlt_not_le. -now apply F2R_lt_0_compat. +now apply F2R_lt_0. Qed. -Lemma Fnum_le_0_compat: forall (f : float beta), +Lemma Fnum_le_0: forall (f : float beta), (F2R f <= 0)%R -> (Fnum f <= 0)%Z. Proof. intros f H. case (Zle_or_lt (Fnum f) 0); trivial. intros H1; contradict H. apply Rlt_not_le. -now apply F2R_gt_0_compat. +now apply F2R_gt_0. Qed. (** Floats and bpow *) @@ -281,7 +288,7 @@ Theorem bpow_le_F2R : Proof. intros m e H. rewrite <- F2R_bpow. -apply F2R_le_compat. +apply F2R_le. now apply (Zlt_le_succ 0). Qed. @@ -301,7 +308,7 @@ unfold F2R. simpl. rewrite <- (Rmult_1_l (bpow e1)) at 1. apply Rmult_le_compat_r. apply bpow_ge_0. -apply (Z2R_le 1). +apply IZR_le. now apply (Zlt_le_succ 0). now apply Rlt_le. (* . *) @@ -309,14 +316,14 @@ revert H. replace e2 with (e2 - e1 + e1)%Z by ring. rewrite bpow_plus. unfold F2R. simpl. -rewrite <- (Z2R_Zpower beta (e2 - e1)). +rewrite <- (IZR_Zpower beta (e2 - e1)). intros H. apply Rmult_le_compat_r. apply bpow_ge_0. apply Rmult_lt_reg_r in H. -apply Z2R_le. +apply IZR_le. apply Zlt_le_succ. -now apply lt_Z2R. +now apply lt_IZR. apply bpow_gt_0. now apply Zle_minus_le_0. Qed. @@ -332,16 +339,16 @@ case (Zle_or_lt e1 e2); intros He. replace e2 with (e2 - e1 + e1)%Z by ring. rewrite bpow_plus. unfold F2R. simpl. -rewrite <- (Z2R_Zpower beta (e2 - e1)). +rewrite <- (IZR_Zpower beta (e2 - e1)). intros H. apply Rmult_le_compat_r. apply bpow_ge_0. apply Rmult_lt_reg_r in H. -apply Z2R_le. +apply IZR_le. rewrite (Zpred_succ (Zpower _ _)). apply Zplus_le_compat_r. apply Zlt_le_succ. -now apply lt_Z2R. +now apply lt_IZR. apply bpow_gt_0. now apply Zle_minus_le_0. intros H. @@ -352,14 +359,13 @@ now apply Zlt_le_weak. unfold F2R. simpl. apply Rmult_le_compat_r. apply bpow_ge_0. -replace 1%R with (Z2R 1) by reflexivity. -apply Z2R_le. +apply IZR_le. omega. Qed. Theorem F2R_lt_bpow : forall f : float beta, forall e', - (Zabs (Fnum f) < Zpower beta (e' - Fexp f))%Z -> + (Z.abs (Fnum f) < Zpower beta (e' - Fexp f))%Z -> (Rabs (F2R f) < bpow e')%R. Proof. intros (m, e) e' Hm. @@ -369,8 +375,8 @@ unfold F2R. simpl. apply Rmult_lt_reg_r with (bpow (-e)). apply bpow_gt_0. rewrite Rmult_assoc, <- 2!bpow_plus, Zplus_opp_r, Rmult_1_r. -rewrite <-Z2R_Zpower. 2: now apply Zle_left. -now apply Z2R_lt. +rewrite <-IZR_Zpower. 2: now apply Zle_left. +now apply IZR_lt. elim Zlt_not_le with (1 := Hm). simpl. cut (e' - e < 0)%Z. 2: omega. @@ -387,7 +393,7 @@ Theorem F2R_change_exp : Proof. intros e' m e He. unfold F2R. simpl. -rewrite Z2R_mult, Z2R_Zpower, Rmult_assoc. +rewrite mult_IZR, IZR_Zpower, Rmult_assoc. apply f_equal. pattern e at 1 ; replace e with (e - e' + e')%Z by ring. apply bpow_plus. @@ -396,7 +402,7 @@ Qed. Theorem F2R_prec_normalize : forall m e e' p : Z, - (Zabs m < Zpower beta p)%Z -> + (Z.abs m < Zpower beta p)%Z -> (bpow (e' - 1)%Z <= Rabs (F2R (Float beta m e)))%R -> F2R (Float beta m e) = F2R (Float beta (m * Zpower beta (e - e' + p)) (e' - p)). Proof. @@ -413,23 +419,23 @@ apply Rle_lt_trans with (1 := Hf). rewrite <- F2R_Zabs, Zplus_comm, bpow_plus. apply Rmult_lt_compat_r. apply bpow_gt_0. -rewrite <- Z2R_Zpower. -now apply Z2R_lt. +rewrite <- IZR_Zpower. +now apply IZR_lt. exact Hp. Qed. -(** Floats and ln_beta *) -Theorem ln_beta_F2R_bounds : +(** Floats and mag *) +Theorem mag_F2R_bounds : forall x m e, (0 < m)%Z -> (F2R (Float beta m e) <= x < F2R (Float beta (m + 1) e))%R -> - ln_beta beta x = ln_beta beta (F2R (Float beta m e)) :> Z. + mag beta x = mag beta (F2R (Float beta m e)) :> Z. Proof. intros x m e Hp (Hx,Hx2). -destruct (ln_beta beta (F2R (Float beta m e))) as (ex, He). +destruct (mag beta (F2R (Float beta m e))) as (ex, He). simpl. -apply ln_beta_unique. +apply mag_unique. assert (Hp1: (0 < F2R (Float beta m e))%R). -now apply F2R_gt_0_compat. +now apply F2R_gt_0. specialize (He (Rgt_not_eq _ _ Hp1)). rewrite Rabs_pos_eq in He. 2: now apply Rlt_le. destruct He as (He1, He2). @@ -442,22 +448,65 @@ apply Rlt_le_trans with (1 := Hx2). now apply F2R_p1_le_bpow. Qed. -Theorem ln_beta_F2R : +Theorem mag_F2R : forall m e : Z, m <> Z0 -> - (ln_beta beta (F2R (Float beta m e)) = ln_beta beta (Z2R m) + e :> Z)%Z. + (mag beta (F2R (Float beta m e)) = mag beta (IZR m) + e :> Z)%Z. Proof. intros m e H. unfold F2R ; simpl. -apply ln_beta_mult_bpow. -exact (Z2R_neq m 0 H). +apply mag_mult_bpow. +now apply IZR_neq. +Qed. + +Theorem Zdigits_mag : + forall n, + n <> Z0 -> + Zdigits beta n = mag beta (IZR n). +Proof. +intros n Hn. +destruct (mag beta (IZR n)) as (e, He) ; simpl. +specialize (He (IZR_neq _ _ Hn)). +rewrite <- abs_IZR in He. +assert (Hd := Zdigits_correct beta n). +assert (Hd' := Zdigits_gt_0 beta n). +apply Zle_antisym ; apply (bpow_lt_bpow beta). +apply Rle_lt_trans with (2 := proj2 He). +rewrite <- IZR_Zpower by omega. +now apply IZR_le. +apply Rle_lt_trans with (1 := proj1 He). +rewrite <- IZR_Zpower by omega. +now apply IZR_lt. +Qed. + +Theorem mag_F2R_Zdigits : + forall m e, m <> Z0 -> + (mag beta (F2R (Float beta m e)) = Zdigits beta m + e :> Z)%Z. +Proof. +intros m e Hm. +rewrite mag_F2R with (1 := Hm). +apply (f_equal (fun v => Zplus v e)). +apply sym_eq. +now apply Zdigits_mag. +Qed. + +Theorem mag_F2R_bounds_Zdigits : + forall x m e, (0 < m)%Z -> + (F2R (Float beta m e) <= x < F2R (Float beta (m + 1) e))%R -> + mag beta x = (Zdigits beta m + e)%Z :> Z. +Proof. +intros x m e Hm Bx. +apply mag_F2R_bounds with (1 := Hm) in Bx. +rewrite Bx. +apply mag_F2R_Zdigits. +now apply Zgt_not_eq. Qed. Theorem float_distribution_pos : forall m1 e1 m2 e2 : Z, (0 < m1)%Z -> (F2R (Float beta m1 e1) < F2R (Float beta m2 e2) < F2R (Float beta (m1 + 1) e1))%R -> - (e2 < e1)%Z /\ (e1 + ln_beta beta (Z2R m1) = e2 + ln_beta beta (Z2R m2))%Z. + (e2 < e1)%Z /\ (e1 + mag beta (IZR m1) = e2 + mag beta (IZR m2))%Z. Proof. intros m1 e1 m2 e2 Hp1 (H12, H21). assert (He: (e2 < e1)%Z). @@ -465,35 +514,35 @@ assert (He: (e2 < e1)%Z). apply Znot_ge_lt. intros H0. elim Rlt_not_le with (1 := H21). -apply Zge_le in H0. +apply Z.ge_le in H0. apply (F2R_change_exp e1 m2 e2) in H0. rewrite H0. -apply F2R_le_compat. +apply F2R_le. apply Zlt_le_succ. -apply (F2R_lt_reg e1). +apply (lt_F2R e1). now rewrite <- H0. (* . *) split. exact He. rewrite (Zplus_comm e1), (Zplus_comm e2). assert (Hp2: (0 < m2)%Z). -apply (F2R_gt_0_reg m2 e2). +apply (gt_0_F2R m2 e2). apply Rlt_trans with (2 := H12). -now apply F2R_gt_0_compat. -rewrite <- 2!ln_beta_F2R. -destruct (ln_beta beta (F2R (Float beta m1 e1))) as (e1', H1). +now apply F2R_gt_0. +rewrite <- 2!mag_F2R. +destruct (mag beta (F2R (Float beta m1 e1))) as (e1', H1). simpl. apply sym_eq. -apply ln_beta_unique. +apply mag_unique. assert (H2 : (bpow (e1' - 1) <= F2R (Float beta m1 e1) < bpow e1')%R). -rewrite <- (Zabs_eq m1), F2R_Zabs. +rewrite <- (Z.abs_eq m1), F2R_Zabs. apply H1. apply Rgt_not_eq. apply Rlt_gt. -now apply F2R_gt_0_compat. +now apply F2R_gt_0. now apply Zlt_le_weak. clear H1. -rewrite <- F2R_Zabs, Zabs_eq. +rewrite <- F2R_Zabs, Z.abs_eq. split. apply Rlt_le. apply Rle_lt_trans with (2 := H12). @@ -507,13 +556,4 @@ apply sym_not_eq. now apply Zlt_not_eq. Qed. -Theorem F2R_cond_Zopp : - forall b m e, - F2R (Float beta (cond_Zopp b m) e) = cond_Ropp b (F2R (Float beta m e)). -Proof. -intros [|] m e ; unfold F2R ; simpl. -now rewrite Z2R_opp, Ropp_mult_distr_l_reverse. -apply refl_equal. -Qed. - End Float_prop. diff --git a/flocq/Core/Fcore_generic_fmt.v b/flocq/Core/Generic_fmt.v index 668b4da2..cb37bd91 100644 --- a/flocq/Core/Fcore_generic_fmt.v +++ b/flocq/Core/Generic_fmt.v @@ -2,9 +2,9 @@ This file is part of the Flocq formalization of floating-point arithmetic in Coq: http://flocq.gforge.inria.fr/ -Copyright (C) 2010-2013 Sylvie Boldo +Copyright (C) 2009-2018 Sylvie Boldo #<br /># -Copyright (C) 2010-2013 Guillaume Melquiond +Copyright (C) 2009-2018 Guillaume Melquiond This library is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public @@ -18,10 +18,7 @@ COPYING file for more details. *) (** * What is a real number belonging to a format, and many properties. *) -Require Import Fcore_Raux. -Require Import Fcore_defs. -Require Import Fcore_rnd. -Require Import Fcore_float_prop. +Require Import Raux Defs Round_pred Float_prop. Section Generic. @@ -53,7 +50,7 @@ Proof. intros k l Hk H. apply Znot_ge_lt. intros Hl. -apply Zge_le in Hl. +apply Z.ge_le in Hl. assert (H' := proj2 (proj2 (valid_exp l) Hl) k). omega. Qed. @@ -66,24 +63,24 @@ Proof. intros k l Hk H. apply Znot_ge_lt. intros H'. -apply Zge_le in H'. -assert (Hl := Zle_trans _ _ _ H H'). +apply Z.ge_le in H'. +assert (Hl := Z.le_trans _ _ _ H H'). apply valid_exp in Hl. assert (H1 := proj2 Hl k H'). omega. Qed. -Definition canonic_exp x := - fexp (ln_beta beta x). +Definition cexp x := + fexp (mag beta x). -Definition canonic (f : float beta) := - Fexp f = canonic_exp (F2R f). +Definition canonical (f : float beta) := + Fexp f = cexp (F2R f). Definition scaled_mantissa x := - (x * bpow (- canonic_exp x))%R. + (x * bpow (- cexp x))%R. Definition generic_format (x : R) := - x = F2R (Float beta (Ztrunc (scaled_mantissa x)) (canonic_exp x)). + x = F2R (Float beta (Ztrunc (scaled_mantissa x)) (cexp x)). (** Basic facts *) Theorem generic_format_0 : @@ -91,26 +88,39 @@ Theorem generic_format_0 : Proof. unfold generic_format, scaled_mantissa. rewrite Rmult_0_l. -change (Ztrunc 0) with (Ztrunc (Z2R 0)). -now rewrite Ztrunc_Z2R, F2R_0. +now rewrite Ztrunc_IZR, F2R_0. Qed. -Theorem canonic_exp_opp : +Theorem cexp_opp : forall x, - canonic_exp (-x) = canonic_exp x. + cexp (-x) = cexp x. Proof. intros x. -unfold canonic_exp. -now rewrite ln_beta_opp. +unfold cexp. +now rewrite mag_opp. Qed. -Theorem canonic_exp_abs : +Theorem cexp_abs : forall x, - canonic_exp (Rabs x) = canonic_exp x. + cexp (Rabs x) = cexp x. Proof. intros x. -unfold canonic_exp. -now rewrite ln_beta_abs. +unfold cexp. +now rewrite mag_abs. +Qed. + +Theorem canonical_generic_format : + forall x, + generic_format x -> + exists f : float beta, + x = F2R f /\ canonical f. +Proof. +intros x Hx. +rewrite Hx. +eexists. +apply (conj eq_refl). +unfold canonical. +now rewrite <- Hx. Qed. Theorem generic_format_bpow : @@ -118,11 +128,11 @@ Theorem generic_format_bpow : generic_format (bpow e). Proof. intros e H. -unfold generic_format, scaled_mantissa, canonic_exp. -rewrite ln_beta_bpow. +unfold generic_format, scaled_mantissa, cexp. +rewrite mag_bpow. rewrite <- bpow_plus. -rewrite <- (Z2R_Zpower beta (e + - fexp (e + 1))). -rewrite Ztrunc_Z2R. +rewrite <- (IZR_Zpower beta (e + - fexp (e + 1))). +rewrite Ztrunc_IZR. rewrite <- F2R_bpow. rewrite F2R_change_exp with (1 := H). now rewrite Zmult_1_l. @@ -140,110 +150,107 @@ now apply valid_exp_. rewrite <- H. apply valid_exp. rewrite H. -apply Zle_refl. +apply Z.le_refl. Qed. Theorem generic_format_F2R : forall m e, - ( m <> 0 -> canonic_exp (F2R (Float beta m e)) <= e )%Z -> + ( m <> 0 -> cexp (F2R (Float beta m e)) <= e )%Z -> generic_format (F2R (Float beta m e)). Proof. intros m e. -destruct (Z_eq_dec m 0) as [Zm|Zm]. +destruct (Z.eq_dec m 0) as [Zm|Zm]. intros _. rewrite Zm, F2R_0. apply generic_format_0. unfold generic_format, scaled_mantissa. -set (e' := canonic_exp (F2R (Float beta m e))). +set (e' := cexp (F2R (Float beta m e))). intros He. specialize (He Zm). unfold F2R at 3. simpl. rewrite F2R_change_exp with (1 := He). -apply F2R_eq_compat. -rewrite Rmult_assoc, <- bpow_plus, <- Z2R_Zpower, <- Z2R_mult. -now rewrite Ztrunc_Z2R. +apply F2R_eq. +rewrite Rmult_assoc, <- bpow_plus, <- IZR_Zpower, <- mult_IZR. +now rewrite Ztrunc_IZR. now apply Zle_left. Qed. -Lemma generic_format_F2R': forall (x:R) (f:float beta), - F2R f = x -> ((x <> 0)%R -> - (canonic_exp x <= Fexp f)%Z) -> - generic_format x. +Lemma generic_format_F2R' : + forall (x : R) (f : float beta), + F2R f = x -> + (x <> 0%R -> (cexp x <= Fexp f)%Z) -> + generic_format x. Proof. intros x f H1 H2. rewrite <- H1; destruct f as (m,e). -apply generic_format_F2R. +apply generic_format_F2R. simpl in *; intros H3. rewrite H1; apply H2. intros Y; apply H3. -apply F2R_eq_0_reg with beta e. +apply eq_0_F2R with beta e. now rewrite H1. Qed. - -Theorem canonic_opp : +Theorem canonical_opp : forall m e, - canonic (Float beta m e) -> - canonic (Float beta (-m) e). + canonical (Float beta m e) -> + canonical (Float beta (-m) e). Proof. intros m e H. -unfold canonic. -now rewrite F2R_Zopp, canonic_exp_opp. +unfold canonical. +now rewrite F2R_Zopp, cexp_opp. Qed. -Theorem canonic_abs : +Theorem canonical_abs : forall m e, - canonic (Float beta m e) -> - canonic (Float beta (Zabs m) e). + canonical (Float beta m e) -> + canonical (Float beta (Z.abs m) e). Proof. intros m e H. -unfold canonic. -now rewrite F2R_Zabs, canonic_exp_abs. +unfold canonical. +now rewrite F2R_Zabs, cexp_abs. Qed. -Theorem canonic_0: canonic (Float beta 0 (fexp (ln_beta beta 0%R))). +Theorem canonical_0 : + canonical (Float beta 0 (fexp (mag beta 0%R))). Proof. -unfold canonic; simpl; unfold canonic_exp. -replace (F2R {| Fnum := 0; Fexp := fexp (ln_beta beta 0) |}) with 0%R. -reflexivity. -unfold F2R; simpl; ring. +unfold canonical; simpl ; unfold cexp. +now rewrite F2R_0. Qed. - - -Theorem canonic_unicity : +Theorem canonical_unique : forall f1 f2, - canonic f1 -> - canonic f2 -> + canonical f1 -> + canonical f2 -> F2R f1 = F2R f2 -> f1 = f2. Proof. intros (m1, e1) (m2, e2). -unfold canonic. simpl. +unfold canonical. simpl. intros H1 H2 H. rewrite H in H1. rewrite <- H2 in H1. clear H2. rewrite H1 in H |- *. apply (f_equal (fun m => Float beta m e2)). -apply F2R_eq_reg with (1 := H). +apply eq_F2R with (1 := H). Qed. Theorem scaled_mantissa_generic : forall x, generic_format x -> - scaled_mantissa x = Z2R (Ztrunc (scaled_mantissa x)). + scaled_mantissa x = IZR (Ztrunc (scaled_mantissa x)). Proof. intros x Hx. unfold scaled_mantissa. pattern x at 1 3 ; rewrite Hx. unfold F2R. simpl. rewrite Rmult_assoc, <- bpow_plus, Zplus_opp_r, Rmult_1_r. -now rewrite Ztrunc_Z2R. +now rewrite Ztrunc_IZR. Qed. Theorem scaled_mantissa_mult_bpow : forall x, - (scaled_mantissa x * bpow (canonic_exp x))%R = x. + (scaled_mantissa x * bpow (cexp x))%R = x. Proof. intros x. unfold scaled_mantissa. @@ -263,7 +270,7 @@ Theorem scaled_mantissa_opp : Proof. intros x. unfold scaled_mantissa. -rewrite canonic_exp_opp. +rewrite cexp_opp. now rewrite Ropp_mult_distr_l_reverse. Qed. @@ -273,7 +280,7 @@ Theorem scaled_mantissa_abs : Proof. intros x. unfold scaled_mantissa. -rewrite canonic_exp_abs, Rabs_mult. +rewrite cexp_abs, Rabs_mult. apply f_equal. apply sym_eq. apply Rabs_pos_eq. @@ -285,7 +292,7 @@ Theorem generic_format_opp : Proof. intros x Hx. unfold generic_format. -rewrite scaled_mantissa_opp, canonic_exp_opp. +rewrite scaled_mantissa_opp, cexp_opp. rewrite Ztrunc_opp. rewrite F2R_Zopp. now apply f_equal. @@ -296,7 +303,7 @@ Theorem generic_format_abs : Proof. intros x Hx. unfold generic_format. -rewrite scaled_mantissa_abs, canonic_exp_abs. +rewrite scaled_mantissa_abs, cexp_abs. rewrite Ztrunc_abs. rewrite F2R_Zabs. now apply f_equal. @@ -308,7 +315,7 @@ Proof. intros x. unfold generic_format, Rabs. case Rcase_abs ; intros _. -rewrite scaled_mantissa_opp, canonic_exp_opp, Ztrunc_opp. +rewrite scaled_mantissa_opp, cexp_opp, Ztrunc_opp. intros H. rewrite <- (Ropp_involutive x) at 1. rewrite H, F2R_Zopp. @@ -316,23 +323,23 @@ apply Ropp_involutive. easy. Qed. -Theorem canonic_exp_fexp : +Theorem cexp_fexp : forall x ex, (bpow (ex - 1) <= Rabs x < bpow ex)%R -> - canonic_exp x = fexp ex. + cexp x = fexp ex. Proof. intros x ex Hx. -unfold canonic_exp. -now rewrite ln_beta_unique with (1 := Hx). +unfold cexp. +now rewrite mag_unique with (1 := Hx). Qed. -Theorem canonic_exp_fexp_pos : +Theorem cexp_fexp_pos : forall x ex, (bpow (ex - 1) <= x < bpow ex)%R -> - canonic_exp x = fexp ex. + cexp x = fexp ex. Proof. intros x ex Hx. -apply canonic_exp_fexp. +apply cexp_fexp. rewrite Rabs_pos_eq. exact Hx. apply Rle_trans with (2 := proj1 Hx). @@ -360,7 +367,7 @@ apply Rlt_le_trans with (1 := proj2 Hx). now apply bpow_le. Qed. -Theorem scaled_mantissa_small : +Theorem scaled_mantissa_lt_1 : forall x ex, (Rabs x < bpow ex)%R -> (ex <= fexp ex)%Z -> @@ -369,62 +376,62 @@ Proof. intros x ex Ex He. destruct (Req_dec x 0) as [Zx|Zx]. rewrite Zx, scaled_mantissa_0, Rabs_R0. -now apply (Z2R_lt 0 1). +now apply IZR_lt. rewrite <- scaled_mantissa_abs. unfold scaled_mantissa. -rewrite canonic_exp_abs. -unfold canonic_exp. -destruct (ln_beta beta x) as (ex', Ex'). +rewrite cexp_abs. +unfold cexp. +destruct (mag beta x) as (ex', Ex'). simpl. specialize (Ex' Zx). apply (mantissa_small_pos _ _ Ex'). assert (ex' <= fexp ex)%Z. -apply Zle_trans with (2 := He). +apply Z.le_trans with (2 := He). apply bpow_lt_bpow with beta. now apply Rle_lt_trans with (2 := Ex). now rewrite (proj2 (proj2 (valid_exp _) He)). Qed. -Theorem abs_scaled_mantissa_lt_bpow : +Theorem scaled_mantissa_lt_bpow : forall x, - (Rabs (scaled_mantissa x) < bpow (ln_beta beta x - canonic_exp x))%R. + (Rabs (scaled_mantissa x) < bpow (mag beta x - cexp x))%R. Proof. intros x. destruct (Req_dec x 0) as [Zx|Zx]. rewrite Zx, scaled_mantissa_0, Rabs_R0. apply bpow_gt_0. -apply Rlt_le_trans with (1 := bpow_ln_beta_gt beta _). +apply Rlt_le_trans with (1 := bpow_mag_gt beta _). apply bpow_le. unfold scaled_mantissa. -rewrite ln_beta_mult_bpow with (1 := Zx). -apply Zle_refl. +rewrite mag_mult_bpow with (1 := Zx). +apply Z.le_refl. Qed. -Theorem ln_beta_generic_gt : +Theorem mag_generic_gt : forall x, (x <> 0)%R -> generic_format x -> - (canonic_exp x < ln_beta beta x)%Z. + (cexp x < mag beta x)%Z. Proof. intros x Zx Gx. apply Znot_ge_lt. -unfold canonic_exp. -destruct (ln_beta beta x) as (ex,Ex) ; simpl. +unfold cexp. +destruct (mag beta x) as (ex,Ex) ; simpl. specialize (Ex Zx). intros H. -apply Zge_le in H. -generalize (scaled_mantissa_small x ex (proj2 Ex) H). +apply Z.ge_le in H. +generalize (scaled_mantissa_lt_1 x ex (proj2 Ex) H). contradict Zx. rewrite Gx. replace (Ztrunc (scaled_mantissa x)) with Z0. apply F2R_0. -cut (Zabs (Ztrunc (scaled_mantissa x)) < 1)%Z. +cut (Z.abs (Ztrunc (scaled_mantissa x)) < 1)%Z. clear ; zify ; omega. -apply lt_Z2R. -rewrite Z2R_abs. +apply lt_IZR. +rewrite abs_IZR. now rewrite <- scaled_mantissa_generic. Qed. -Theorem mantissa_DN_small_pos : +Lemma mantissa_DN_small_pos : forall x ex, (bpow (ex - 1) <= x < bpow ex)%R -> (ex <= fexp ex)%Z -> @@ -436,7 +443,7 @@ assert (H := mantissa_small_pos x ex Hx He). split ; try apply Rlt_le ; apply H. Qed. -Theorem mantissa_UP_small_pos : +Lemma mantissa_UP_small_pos : forall x ex, (bpow (ex - 1) <= x < bpow ex)%R -> (ex <= fexp ex)%Z -> @@ -451,7 +458,7 @@ Qed. (** Generic facts about any format *) Theorem generic_format_discrete : forall x m, - let e := canonic_exp x in + let e := cexp x in (F2R (Float beta m e) < x < F2R (Float beta (m + 1) e))%R -> ~ generic_format x. Proof. @@ -459,27 +466,27 @@ intros x m e (Hx,Hx2) Hf. apply Rlt_not_le with (1 := Hx2). clear Hx2. rewrite Hf. fold e. -apply F2R_le_compat. +apply F2R_le. apply Zlt_le_succ. -apply lt_Z2R. +apply lt_IZR. rewrite <- scaled_mantissa_generic with (1 := Hf). apply Rmult_lt_reg_r with (bpow e). apply bpow_gt_0. now rewrite scaled_mantissa_mult_bpow. Qed. -Theorem generic_format_canonic : - forall f, canonic f -> +Theorem generic_format_canonical : + forall f, canonical f -> generic_format (F2R f). Proof. intros (m, e) Hf. -unfold canonic in Hf. simpl in Hf. +unfold canonical in Hf. simpl in Hf. unfold generic_format, scaled_mantissa. rewrite <- Hf. -apply F2R_eq_compat. +apply F2R_eq. unfold F2R. simpl. rewrite Rmult_assoc, <- bpow_plus, Zplus_opp_r, Rmult_1_r. -now rewrite Ztrunc_Z2R. +now rewrite Ztrunc_IZR. Qed. Theorem generic_format_ge_bpow : @@ -492,10 +499,10 @@ Theorem generic_format_ge_bpow : Proof. intros emin Emin x Hx Fx. rewrite Fx. -apply Rle_trans with (bpow (fexp (ln_beta beta x))). +apply Rle_trans with (bpow (fexp (mag beta x))). now apply bpow_le. apply bpow_le_F2R. -apply F2R_gt_0_reg with beta (canonic_exp x). +apply gt_0_F2R with beta (cexp x). now rewrite <- Fx. Qed. @@ -504,13 +511,13 @@ Theorem abs_lt_bpow_prec: (forall e, (e - prec <= fexp e)%Z) -> (* OK with FLX, FLT and FTZ *) forall x, - (Rabs x < bpow (prec + canonic_exp x))%R. + (Rabs x < bpow (prec + cexp x))%R. intros prec Hp x. case (Req_dec x 0); intros Hxz. rewrite Hxz, Rabs_R0. apply bpow_gt_0. -unfold canonic_exp. -destruct (ln_beta beta x) as (ex,Ex) ; simpl. +unfold cexp. +destruct (mag beta x) as (ex,Ex) ; simpl. specialize (Ex Hxz). apply Rlt_le_trans with (1 := proj2 Ex). apply bpow_le. @@ -526,8 +533,8 @@ Proof. intros e He. apply Znot_gt_le. contradict He. -unfold generic_format, scaled_mantissa, canonic_exp, F2R. simpl. -rewrite ln_beta_bpow, <- bpow_plus. +unfold generic_format, scaled_mantissa, cexp, F2R. simpl. +rewrite mag_bpow, <- bpow_plus. apply Rgt_not_eq. rewrite Ztrunc_floor. 2: apply bpow_ge_0. @@ -559,7 +566,7 @@ Variable rnd : R -> Z. Class Valid_rnd := { Zrnd_le : forall x y, (x <= y)%R -> (rnd x <= rnd y)%Z ; - Zrnd_Z2R : forall n, rnd (Z2R n) = n + Zrnd_IZR : forall n, rnd (IZR n) = n }. Context { valid_rnd : Valid_rnd }. @@ -571,20 +578,20 @@ intros x. destruct (Zle_or_lt (rnd x) (Zfloor x)) as [Hx|Hx]. left. apply Zle_antisym with (1 := Hx). -rewrite <- (Zrnd_Z2R (Zfloor x)). +rewrite <- (Zrnd_IZR (Zfloor x)). apply Zrnd_le. apply Zfloor_lb. right. apply Zle_antisym. -rewrite <- (Zrnd_Z2R (Zceil x)). +rewrite <- (Zrnd_IZR (Zceil x)). apply Zrnd_le. apply Zceil_ub. rewrite Zceil_floor_neq. omega. intros H. rewrite <- H in Hx. -rewrite Zfloor_Z2R, Zrnd_Z2R in Hx. -apply Zlt_irrefl with (1 := Hx). +rewrite Zfloor_IZR, Zrnd_IZR in Hx. +apply Z.lt_irrefl with (1 := Hx). Qed. Theorem Zrnd_ZR_or_AW : @@ -602,7 +609,7 @@ Qed. (** the most useful one: R -> F *) Definition round x := - F2R (Float beta (rnd (scaled_mantissa x)) (canonic_exp x)). + F2R (Float beta (rnd (scaled_mantissa x)) (cexp x)). Theorem round_bounded_large_pos : forall x ex, @@ -612,7 +619,7 @@ Theorem round_bounded_large_pos : Proof. intros x ex He Hx. unfold round, scaled_mantissa. -rewrite (canonic_exp_fexp_pos _ _ Hx). +rewrite (cexp_fexp_pos _ _ Hx). unfold F2R. simpl. destruct (Zrnd_DN_or_UP (x * bpow (- fexp ex))) as [Hr|Hr] ; rewrite Hr. (* DN *) @@ -621,11 +628,11 @@ replace (ex - 1)%Z with (ex - 1 + - fexp ex + fexp ex)%Z by ring. rewrite bpow_plus. apply Rmult_le_compat_r. apply bpow_ge_0. -assert (Hf: Z2R (Zpower beta (ex - 1 - fexp ex)) = bpow (ex - 1 + - fexp ex)). -apply Z2R_Zpower. +assert (Hf: IZR (Zpower beta (ex - 1 - fexp ex)) = bpow (ex - 1 + - fexp ex)). +apply IZR_Zpower. omega. rewrite <- Hf. -apply Z2R_le. +apply IZR_le. apply Zfloor_lub. rewrite Hf. rewrite bpow_plus. @@ -648,11 +655,11 @@ pattern ex at 3 ; replace ex with (ex - fexp ex + fexp ex)%Z by ring. rewrite bpow_plus. apply Rmult_le_compat_r. apply bpow_ge_0. -assert (Hf: Z2R (Zpower beta (ex - fexp ex)) = bpow (ex - fexp ex)). -apply Z2R_Zpower. +assert (Hf: IZR (Zpower beta (ex - fexp ex)) = bpow (ex - fexp ex)). +apply IZR_Zpower. omega. rewrite <- Hf. -apply Z2R_le. +apply IZR_le. apply Zceil_glb. rewrite Hf. unfold Zminus. @@ -671,13 +678,13 @@ Theorem round_bounded_small_pos : Proof. intros x ex He Hx. unfold round, scaled_mantissa. -rewrite (canonic_exp_fexp_pos _ _ Hx). +rewrite (cexp_fexp_pos _ _ Hx). unfold F2R. simpl. destruct (Zrnd_DN_or_UP (x * bpow (-fexp ex))) as [Hr|Hr] ; rewrite Hr. (* DN *) left. apply Rmult_eq_0_compat_r. -apply (@f_equal _ _ Z2R _ Z0). +apply IZR_eq. apply Zfloor_imp. refine (let H := _ in conj (Rlt_le _ _ (proj1 H)) (proj2 H)). now apply mantissa_small_pos. @@ -685,18 +692,18 @@ now apply mantissa_small_pos. right. pattern (bpow (fexp ex)) at 2 ; rewrite <- Rmult_1_l. apply (f_equal (fun m => (m * bpow (fexp ex))%R)). -apply (@f_equal _ _ Z2R _ 1%Z). +apply IZR_eq. apply Zceil_imp. refine (let H := _ in conj (proj1 H) (Rlt_le _ _ (proj2 H))). now apply mantissa_small_pos. Qed. -Theorem round_le_pos : +Lemma round_le_pos : forall x y, (0 < x)%R -> (x <= y)%R -> (round x <= round y)%R. Proof. intros x y Hx Hxy. -destruct (ln_beta beta x) as [ex Hex]. -destruct (ln_beta beta y) as [ey Hey]. +destruct (mag beta x) as [ex Hex]. +destruct (mag beta y) as [ey Hey]. specialize (Hex (Rgt_not_eq _ _ Hx)). specialize (Hey (Rgt_not_eq _ _ (Rlt_le_trans _ _ _ Hx Hxy))). rewrite Rabs_pos_eq in Hex. @@ -709,18 +716,18 @@ assert (He: (ex <= ey)%Z). now apply Rle_lt_trans with y. assert (Heq: fexp ex = fexp ey -> (round x <= round y)%R). intros H. - unfold round, scaled_mantissa, canonic_exp. - rewrite ln_beta_unique_pos with (1 := Hex). - rewrite ln_beta_unique_pos with (1 := Hey). + unfold round, scaled_mantissa, cexp. + rewrite mag_unique_pos with (1 := Hex). + rewrite mag_unique_pos with (1 := Hey). rewrite H. - apply F2R_le_compat. + apply F2R_le. apply Zrnd_le. apply Rmult_le_compat_r with (2 := Hxy). apply bpow_ge_0. destruct (Zle_or_lt ey (fexp ey)) as [Hy1|Hy1]. apply Heq. apply valid_exp with (1 := Hy1). - now apply Zle_trans with ey. + now apply Z.le_trans with ey. destruct (Zle_lt_or_eq _ _ He) as [He'|He']. 2: now apply Heq, f_equal. apply Rle_trans with (bpow (ey - 1)). @@ -746,7 +753,7 @@ Proof. intros x Hx. unfold round. rewrite scaled_mantissa_generic with (1 := Hx). -rewrite Zrnd_Z2R. +rewrite Zrnd_IZR. now apply sym_eq. Qed. @@ -755,8 +762,7 @@ Theorem round_0 : Proof. unfold round, scaled_mantissa. rewrite Rmult_0_l. -change 0%R with (Z2R 0). -rewrite Zrnd_Z2R. +rewrite Zrnd_IZR. apply F2R_0. Qed. @@ -774,13 +780,13 @@ apply bpow_gt_0. apply (round_bounded_large_pos); assumption. Qed. -Theorem generic_format_round_pos : +Lemma generic_format_round_pos : forall x, (0 < x)%R -> generic_format (round x). Proof. intros x Hx0. -destruct (ln_beta beta x) as (ex, Hex). +destruct (mag beta x) as (ex, Hex). specialize (Hex (Rgt_not_eq _ _ Hx0)). rewrite Rabs_pos_eq in Hex. 2: now apply Rlt_le. destruct (Zle_or_lt ex (fexp ex)) as [He|He]. @@ -798,8 +804,8 @@ apply generic_format_bpow. now apply valid_exp. apply generic_format_F2R. intros _. -rewrite (canonic_exp_fexp_pos (F2R _) _ (conj Hr1 Hr)). -rewrite (canonic_exp_fexp_pos _ _ Hex). +rewrite (cexp_fexp_pos (F2R _) _ (conj Hr1 Hr)). +rewrite (cexp_fexp_pos _ _ Hex). now apply Zeq_le. Qed. @@ -821,7 +827,7 @@ Section Zround_opp. Variable rnd : R -> Z. Context { valid_rnd : Valid_rnd rnd }. -Definition Zrnd_opp x := Zopp (rnd (-x)). +Definition Zrnd_opp x := Z.opp (rnd (-x)). Global Instance valid_rnd_opp : Valid_rnd Zrnd_opp. Proof with auto with typeclass_instances. @@ -830,14 +836,14 @@ split. intros x y Hxy. unfold Zrnd_opp. apply Zopp_le_cancel. -rewrite 2!Zopp_involutive. +rewrite 2!Z.opp_involutive. apply Zrnd_le... now apply Ropp_le_contravar. (* *) intros n. unfold Zrnd_opp. -rewrite <- Z2R_opp, Zrnd_Z2R... -apply Zopp_involutive. +rewrite <- opp_IZR, Zrnd_IZR... +apply Z.opp_involutive. Qed. Theorem round_opp : @@ -846,10 +852,10 @@ Theorem round_opp : Proof. intros x. unfold round. -rewrite <- F2R_Zopp, canonic_exp_opp, scaled_mantissa_opp. -apply F2R_eq_compat. +rewrite <- F2R_Zopp, cexp_opp, scaled_mantissa_opp. +apply F2R_eq. apply sym_eq. -exact (Zopp_involutive _). +exact (Z.opp_involutive _). Qed. End Zround_opp. @@ -860,28 +866,28 @@ Global Instance valid_rnd_DN : Valid_rnd Zfloor. Proof. split. apply Zfloor_le. -apply Zfloor_Z2R. +apply Zfloor_IZR. Qed. Global Instance valid_rnd_UP : Valid_rnd Zceil. Proof. split. apply Zceil_le. -apply Zceil_Z2R. +apply Zceil_IZR. Qed. Global Instance valid_rnd_ZR : Valid_rnd Ztrunc. Proof. split. apply Ztrunc_le. -apply Ztrunc_Z2R. +apply Ztrunc_IZR. Qed. Global Instance valid_rnd_AW : Valid_rnd Zaway. Proof. split. apply Zaway_le. -apply Zaway_Z2R. +apply Zaway_IZR. Qed. Section monotone. @@ -923,7 +929,7 @@ destruct (Rlt_or_le y 0) as [Hy|Hy]. (* . y < 0 *) rewrite <- (Ropp_involutive x), <- (Ropp_involutive y). rewrite (scaled_mantissa_opp (-x)), (scaled_mantissa_opp (-y)). -rewrite (canonic_exp_opp (-x)), (canonic_exp_opp (-y)). +rewrite (cexp_opp (-x)), (cexp_opp (-y)). apply Ropp_le_cancel. rewrite <- 2!F2R_Zopp. apply (round_le_pos (Zrnd_opp rnd) (-y) (-x)). @@ -932,16 +938,16 @@ now apply Ropp_lt_contravar. now apply Ropp_le_contravar. (* . 0 <= y *) apply Rle_trans with 0%R. -apply F2R_le_0_compat. simpl. -rewrite <- (Zrnd_Z2R rnd 0). +apply F2R_le_0. simpl. +rewrite <- (Zrnd_IZR rnd 0). apply Zrnd_le... simpl. -rewrite <- (Rmult_0_l (bpow (- fexp (ln_beta beta x)))). +rewrite <- (Rmult_0_l (bpow (- fexp (mag beta x)))). apply Rmult_le_compat_r. apply bpow_ge_0. now apply Rlt_le. -apply F2R_ge_0_compat. simpl. -rewrite <- (Zrnd_Z2R rnd 0). +apply F2R_ge_0. simpl. +rewrite <- (Zrnd_IZR rnd 0). apply Zrnd_le... apply Rmult_le_pos. exact Hy. @@ -949,9 +955,9 @@ apply bpow_ge_0. (* x = 0 *) rewrite Hx. rewrite round_0... -apply F2R_ge_0_compat. +apply F2R_ge_0. simpl. -rewrite <- (Zrnd_Z2R rnd 0). +rewrite <- (Zrnd_IZR rnd 0). apply Zrnd_le... apply Rmult_le_pos. now rewrite <- Hx. @@ -1071,8 +1077,8 @@ unfold round. rewrite scaled_mantissa_opp. rewrite <- F2R_Zopp. unfold Zceil. -rewrite Zopp_involutive. -now rewrite canonic_exp_opp. +rewrite Z.opp_involutive. +now rewrite cexp_opp. Qed. Theorem round_UP_opp : @@ -1085,7 +1091,7 @@ rewrite scaled_mantissa_opp. rewrite <- F2R_Zopp. unfold Zceil. rewrite Ropp_involutive. -now rewrite canonic_exp_opp. +now rewrite cexp_opp. Qed. Theorem round_ZR_opp : @@ -1094,7 +1100,7 @@ Theorem round_ZR_opp : Proof. intros x. unfold round. -rewrite scaled_mantissa_opp, canonic_exp_opp, Ztrunc_opp. +rewrite scaled_mantissa_opp, cexp_opp, Ztrunc_opp. apply F2R_Zopp. Qed. @@ -1123,7 +1129,7 @@ Theorem round_AW_opp : Proof. intros x. unfold round. -rewrite scaled_mantissa_opp, canonic_exp_opp, Zaway_opp. +rewrite scaled_mantissa_opp, cexp_opp, Zaway_opp. apply F2R_Zopp. Qed. @@ -1146,7 +1152,7 @@ apply round_le... now apply Rge_le. Qed. -Theorem round_ZR_pos : +Theorem round_ZR_DN : forall x, (0 <= x)%R -> round Ztrunc x = round Zfloor x. @@ -1156,13 +1162,13 @@ unfold round, Ztrunc. case Rlt_bool_spec. intros H. elim Rlt_not_le with (1 := H). -rewrite <- (Rmult_0_l (bpow (- canonic_exp x))). +rewrite <- (Rmult_0_l (bpow (- cexp x))). apply Rmult_le_compat_r with (2 := Hx). apply bpow_ge_0. easy. Qed. -Theorem round_ZR_neg : +Theorem round_ZR_UP : forall x, (x <= 0)%R -> round Ztrunc x = round Zceil x. @@ -1173,15 +1179,14 @@ case Rlt_bool_spec. easy. intros [H|H]. elim Rlt_not_le with (1 := H). -rewrite <- (Rmult_0_l (bpow (- canonic_exp x))). +rewrite <- (Rmult_0_l (bpow (- cexp x))). apply Rmult_le_compat_r with (2 := Hx). apply bpow_ge_0. rewrite <- H. -change 0%R with (Z2R 0). -now rewrite Zfloor_Z2R, Zceil_Z2R. +now rewrite Zfloor_IZR, Zceil_IZR. Qed. -Theorem round_AW_pos : +Theorem round_AW_UP : forall x, (0 <= x)%R -> round Zaway x = round Zceil x. @@ -1191,13 +1196,13 @@ unfold round, Zaway. case Rlt_bool_spec. intros H. elim Rlt_not_le with (1 := H). -rewrite <- (Rmult_0_l (bpow (- canonic_exp x))). +rewrite <- (Rmult_0_l (bpow (- cexp x))). apply Rmult_le_compat_r with (2 := Hx). apply bpow_ge_0. easy. Qed. -Theorem round_AW_neg : +Theorem round_AW_DN : forall x, (x <= 0)%R -> round Zaway x = round Zfloor x. @@ -1208,12 +1213,11 @@ case Rlt_bool_spec. easy. intros [H|H]. elim Rlt_not_le with (1 := H). -rewrite <- (Rmult_0_l (bpow (- canonic_exp x))). +rewrite <- (Rmult_0_l (bpow (- cexp x))). apply Rmult_le_compat_r with (2 := Hx). apply bpow_ge_0. rewrite <- H. -change 0%R with (Z2R 0). -now rewrite Zfloor_Z2R, Zceil_Z2R. +now rewrite Zfloor_IZR, Zceil_IZR. Qed. Theorem generic_format_round : @@ -1275,7 +1279,7 @@ Proof. intros x. rewrite <- (Ropp_involutive x). rewrite round_UP_opp. -apply Rnd_DN_UP_pt_sym. +apply Rnd_UP_pt_opp. apply generic_format_opp. apply round_DN_pt. Qed. @@ -1286,22 +1290,22 @@ Theorem round_ZR_pt : Proof. intros x. split ; intros Hx. -rewrite round_ZR_pos with (1 := Hx). +rewrite round_ZR_DN with (1 := Hx). apply round_DN_pt. -rewrite round_ZR_neg with (1 := Hx). +rewrite round_ZR_UP with (1 := Hx). apply round_UP_pt. Qed. -Theorem round_DN_small_pos : +Lemma round_DN_small_pos : forall x ex, (bpow (ex - 1) <= x < bpow ex)%R -> (ex <= fexp ex)%Z -> round Zfloor x = 0%R. Proof. intros x ex Hx He. -rewrite <- (F2R_0 beta (canonic_exp x)). +rewrite <- (F2R_0 beta (cexp x)). rewrite <- mantissa_DN_small_pos with (1 := Hx) (2 := He). -now rewrite <- canonic_exp_fexp_pos with (1 := Hx). +now rewrite <- cexp_fexp_pos with (1 := Hx). Qed. @@ -1329,7 +1333,7 @@ contradict Fx. apply generic_format_round... Qed. -Theorem round_UP_small_pos : +Lemma round_UP_small_pos : forall x ex, (bpow (ex - 1) <= x < bpow ex)%R -> (ex <= fexp ex)%Z -> @@ -1338,7 +1342,7 @@ Proof. intros x ex Hx He. rewrite <- F2R_bpow. rewrite <- mantissa_UP_small_pos with (1 := Hx) (2 := He). -now rewrite <- canonic_exp_fexp_pos with (1 := Hx). +now rewrite <- cexp_fexp_pos with (1 := Hx). Qed. Theorem generic_format_EM : @@ -1361,14 +1365,14 @@ Section round_large. Variable rnd : R -> Z. Context { valid_rnd : Valid_rnd rnd }. -Theorem round_large_pos_ge_pow : +Lemma round_large_pos_ge_bpow : forall x e, (0 < round rnd x)%R -> (bpow e <= x)%R -> (bpow e <= round rnd x)%R. Proof. intros x e Hd Hex. -destruct (ln_beta beta x) as (ex, He). +destruct (mag beta x) as (ex, He). assert (Hx: (0 < x)%R). apply Rlt_le_trans with (2 := Hex). apply bpow_gt_0. @@ -1391,95 +1395,95 @@ Qed. End round_large. -Theorem ln_beta_round_ZR : +Theorem mag_round_ZR : forall x, (round Ztrunc x <> 0)%R -> - (ln_beta beta (round Ztrunc x) = ln_beta beta x :> Z). + (mag beta (round Ztrunc x) = mag beta x :> Z). Proof with auto with typeclass_instances. intros x Zr. destruct (Req_dec x 0) as [Zx|Zx]. rewrite Zx, round_0... -apply ln_beta_unique. -destruct (ln_beta beta x) as (ex, Ex) ; simpl. +apply mag_unique. +destruct (mag beta x) as (ex, Ex) ; simpl. specialize (Ex Zx). rewrite <- round_ZR_abs. split. -apply round_large_pos_ge_pow... +apply round_large_pos_ge_bpow... rewrite round_ZR_abs. now apply Rabs_pos_lt. apply Ex. apply Rle_lt_trans with (2 := proj2 Ex). -rewrite round_ZR_pos. +rewrite round_ZR_DN. apply round_DN_pt. apply Rabs_pos. Qed. -Theorem ln_beta_round : +Theorem mag_round : forall rnd {Hrnd : Valid_rnd rnd} x, (round rnd x <> 0)%R -> - (ln_beta beta (round rnd x) = ln_beta beta x :> Z) \/ - Rabs (round rnd x) = bpow (Zmax (ln_beta beta x) (fexp (ln_beta beta x))). + (mag beta (round rnd x) = mag beta x :> Z) \/ + Rabs (round rnd x) = bpow (Z.max (mag beta x) (fexp (mag beta x))). Proof with auto with typeclass_instances. intros rnd Hrnd x. destruct (round_ZR_or_AW rnd x) as [Hr|Hr] ; rewrite Hr ; clear Hr rnd Hrnd. left. -now apply ln_beta_round_ZR. +now apply mag_round_ZR. intros Zr. destruct (Req_dec x 0) as [Zx|Zx]. rewrite Zx, round_0... -destruct (ln_beta beta x) as (ex, Ex) ; simpl. +destruct (mag beta x) as (ex, Ex) ; simpl. specialize (Ex Zx). -rewrite <- ln_beta_abs. +rewrite <- mag_abs. rewrite <- round_AW_abs. destruct (Zle_or_lt ex (fexp ex)) as [He|He]. right. -rewrite Zmax_r with (1 := He). -rewrite round_AW_pos with (1 := Rabs_pos _). +rewrite Z.max_r with (1 := He). +rewrite round_AW_UP with (1 := Rabs_pos _). now apply round_UP_small_pos. destruct (round_bounded_large_pos Zaway _ ex He Ex) as (H1,[H2|H2]). left. -apply ln_beta_unique. +apply mag_unique. rewrite <- round_AW_abs, Rabs_Rabsolu. now split. right. -now rewrite Zmax_l with (1 := Zlt_le_weak _ _ He). +now rewrite Z.max_l with (1 := Zlt_le_weak _ _ He). Qed. -Theorem ln_beta_DN : +Theorem mag_DN : forall x, (0 < round Zfloor x)%R -> - (ln_beta beta (round Zfloor x) = ln_beta beta x :> Z). + (mag beta (round Zfloor x) = mag beta x :> Z). Proof. intros x Hd. assert (0 < x)%R. apply Rlt_le_trans with (1 := Hd). apply round_DN_pt. revert Hd. -rewrite <- round_ZR_pos. +rewrite <- round_ZR_DN. intros Hd. -apply ln_beta_round_ZR. +apply mag_round_ZR. now apply Rgt_not_eq. now apply Rlt_le. Qed. -Theorem canonic_exp_DN : +Theorem cexp_DN : forall x, (0 < round Zfloor x)%R -> - canonic_exp (round Zfloor x) = canonic_exp x. + cexp (round Zfloor x) = cexp x. Proof. intros x Hd. apply (f_equal fexp). -now apply ln_beta_DN. +now apply mag_DN. Qed. Theorem scaled_mantissa_DN : forall x, (0 < round Zfloor x)%R -> - scaled_mantissa (round Zfloor x) = Z2R (Zfloor (scaled_mantissa x)). + scaled_mantissa (round Zfloor x) = IZR (Zfloor (scaled_mantissa x)). Proof. intros x Hd. unfold scaled_mantissa. -rewrite canonic_exp_DN with (1 := Hd). +rewrite cexp_DN with (1 := Hd). unfold round, F2R. simpl. now rewrite Rmult_assoc, <- bpow_plus, Zplus_opp_r, Rmult_1_r. Qed. @@ -1492,10 +1496,10 @@ Proof. intros x f Hxf. destruct (Rnd_N_pt_DN_or_UP _ _ _ Hxf). left. -apply Rnd_DN_pt_unicity with (1 := H). +apply Rnd_DN_pt_unique with (1 := H). apply round_DN_pt. right. -apply Rnd_UP_pt_unicity with (1 := H). +apply Rnd_UP_pt_unique with (1 := H). apply round_UP_pt. Qed. @@ -1516,20 +1520,20 @@ intros e x He Hx. pattern x at 2 ; rewrite Hx. unfold F2R at 2. simpl. rewrite Rmult_assoc, <- bpow_plus. -assert (H: Z2R (Zpower beta (canonic_exp x + - fexp e)) = bpow (canonic_exp x + - fexp e)). -apply Z2R_Zpower. -unfold canonic_exp. -set (ex := ln_beta beta x). +assert (H: IZR (Zpower beta (cexp x + - fexp e)) = bpow (cexp x + - fexp e)). +apply IZR_Zpower. +unfold cexp. +set (ex := mag beta x). generalize (exp_not_FTZ ex). generalize (proj2 (proj2 (valid_exp _) He) (fexp ex + 1)%Z). omega. rewrite <- H. -rewrite <- Z2R_mult, Ztrunc_Z2R. +rewrite <- mult_IZR, Ztrunc_IZR. unfold F2R. simpl. -rewrite Z2R_mult. +rewrite mult_IZR. rewrite H. rewrite Rmult_assoc, <- bpow_plus. -now ring_simplify (canonic_exp x + - fexp e + fexp e)%Z. +now ring_simplify (cexp x + - fexp e + fexp e)%Z. Qed. End not_FTZ. @@ -1550,60 +1554,60 @@ now apply Zlt_le_succ. now apply valid_exp. Qed. -Lemma canonic_exp_le_bpow : +Lemma cexp_le_bpow : forall (x : R) (e : Z), x <> 0%R -> (Rabs x < bpow e)%R -> - (canonic_exp x <= fexp e)%Z. + (cexp x <= fexp e)%Z. Proof. intros x e Zx Hx. apply monotone_exp. -now apply ln_beta_le_bpow. +now apply mag_le_bpow. Qed. -Lemma canonic_exp_ge_bpow : +Lemma cexp_ge_bpow : forall (x : R) (e : Z), (bpow (e - 1) <= Rabs x)%R -> - (fexp e <= canonic_exp x)%Z. + (fexp e <= cexp x)%Z. Proof. intros x e Hx. apply monotone_exp. rewrite (Zsucc_pred e). apply Zlt_le_succ. -now apply ln_beta_gt_bpow. +now apply mag_gt_bpow. Qed. Variable rnd : R -> Z. Context { valid_rnd : Valid_rnd rnd }. -Theorem ln_beta_round_ge : +Theorem mag_round_ge : forall x, round rnd x <> 0%R -> - (ln_beta beta x <= ln_beta beta (round rnd x))%Z. + (mag beta x <= mag beta (round rnd x))%Z. Proof with auto with typeclass_instances. intros x. destruct (round_ZR_or_AW rnd x) as [H|H] ; rewrite H ; clear H ; intros Zr. -rewrite ln_beta_round_ZR with (1 := Zr). -apply Zle_refl. -apply ln_beta_le_abs. +rewrite mag_round_ZR with (1 := Zr). +apply Z.le_refl. +apply mag_le_abs. contradict Zr. rewrite Zr. apply round_0... rewrite <- round_AW_abs. -rewrite round_AW_pos. +rewrite round_AW_UP. apply round_UP_pt. apply Rabs_pos. Qed. -Theorem canonic_exp_round_ge : +Theorem cexp_round_ge : forall x, round rnd x <> 0%R -> - (canonic_exp x <= canonic_exp (round rnd x))%Z. + (cexp x <= cexp (round rnd x))%Z. Proof with auto with typeclass_instances. intros x Zr. -unfold canonic_exp. +unfold cexp. apply monotone_exp. -now apply ln_beta_round_ge. +now apply mag_round_ge. Qed. End monotone_exp. @@ -1614,7 +1618,7 @@ Section Znearest. Variable choice : Z -> bool. Definition Znearest x := - match Rcompare (x - Z2R (Zfloor x)) (/2) with + match Rcompare (x - IZR (Zfloor x)) (/2) with | Lt => Zfloor x | Eq => if choice (Zfloor x) then Zceil x else Zfloor x | Gt => Zceil x @@ -1640,8 +1644,8 @@ Theorem Znearest_ge_floor : Proof. intros x. destruct (Znearest_DN_or_UP x) as [Hx|Hx] ; rewrite Hx. -apply Zle_refl. -apply le_Z2R. +apply Z.le_refl. +apply le_IZR. apply Rle_trans with x. apply Zfloor_lb. apply Zceil_ub. @@ -1653,11 +1657,11 @@ Theorem Znearest_le_ceil : Proof. intros x. destruct (Znearest_DN_or_UP x) as [Hx|Hx] ; rewrite Hx. -apply le_Z2R. +apply le_IZR. apply Rle_trans with x. apply Zfloor_lb. apply Zceil_ub. -apply Zle_refl. +apply Z.le_refl. Qed. Global Instance valid_rnd_N : Valid_rnd Znearest. @@ -1665,22 +1669,22 @@ Proof. split. (* *) intros x y Hxy. -destruct (Rle_or_lt (Z2R (Zceil x)) y) as [H|H]. -apply Zle_trans with (1 := Znearest_le_ceil x). -apply Zle_trans with (2 := Znearest_ge_floor y). +destruct (Rle_or_lt (IZR (Zceil x)) y) as [H|H]. +apply Z.le_trans with (1 := Znearest_le_ceil x). +apply Z.le_trans with (2 := Znearest_ge_floor y). now apply Zfloor_lub. (* . *) assert (Hf: Zfloor y = Zfloor x). apply Zfloor_imp. split. apply Rle_trans with (2 := Zfloor_lb y). -apply Z2R_le. +apply IZR_le. now apply Zfloor_le. apply Rlt_le_trans with (1 := H). -apply Z2R_le. +apply IZR_le. apply Zceil_glb. apply Rlt_le. -rewrite Z2R_plus. +rewrite plus_IZR. apply Zfloor_ub. (* . *) unfold Znearest at 1. @@ -1696,15 +1700,15 @@ elim Rlt_not_le with (1 := Hy). rewrite <- Hx. now apply Rplus_le_compat_r. replace y with x. -apply Zle_refl. -apply Rplus_eq_reg_l with (- Z2R (Zfloor x))%R. -rewrite 2!(Rplus_comm (- (Z2R (Zfloor x)))). -change (x - Z2R (Zfloor x) = y - Z2R (Zfloor x))%R. +apply Z.le_refl. +apply Rplus_eq_reg_l with (- IZR (Zfloor x))%R. +rewrite 2!(Rplus_comm (- (IZR (Zfloor x)))). +change (x - IZR (Zfloor x) = y - IZR (Zfloor x))%R. now rewrite Hy. -apply Zle_trans with (Zceil x). +apply Z.le_trans with (Zceil x). case choice. -apply Zle_refl. -apply le_Z2R. +apply Z.le_refl. +apply le_IZR. apply Rle_trans with x. apply Zfloor_lb. apply Zceil_ub. @@ -1719,79 +1723,19 @@ now apply Rplus_le_compat_r. (* *) intros n. unfold Znearest. -rewrite Zfloor_Z2R. +rewrite Zfloor_IZR. rewrite Rcompare_Lt. easy. unfold Rminus. rewrite Rplus_opp_r. apply Rinv_0_lt_compat. -now apply (Z2R_lt 0 2). -Qed. - -Theorem Rcompare_floor_ceil_mid : - forall x, - Z2R (Zfloor x) <> x -> - Rcompare (x - Z2R (Zfloor x)) (/ 2) = Rcompare (x - Z2R (Zfloor x)) (Z2R (Zceil x) - x). -Proof. -intros x Hx. -rewrite Zceil_floor_neq with (1 := Hx). -rewrite Z2R_plus. simpl. -destruct (Rcompare_spec (x - Z2R (Zfloor x)) (/ 2)) as [H1|H1|H1] ; apply sym_eq. -(* . *) -apply Rcompare_Lt. -apply Rplus_lt_reg_l with (x - Z2R (Zfloor x))%R. -replace (x - Z2R (Zfloor x) + (x - Z2R (Zfloor x)))%R with ((x - Z2R (Zfloor x)) * 2)%R by ring. -replace (x - Z2R (Zfloor x) + (Z2R (Zfloor x) + 1 - x))%R with (/2 * 2)%R by field. -apply Rmult_lt_compat_r with (2 := H1). -now apply (Z2R_lt 0 2). -(* . *) -apply Rcompare_Eq. -replace (Z2R (Zfloor x) + 1 - x)%R with (1 - (x - Z2R (Zfloor x)))%R by ring. -rewrite H1. -field. -(* . *) -apply Rcompare_Gt. -apply Rplus_lt_reg_l with (x - Z2R (Zfloor x))%R. -replace (x - Z2R (Zfloor x) + (x - Z2R (Zfloor x)))%R with ((x - Z2R (Zfloor x)) * 2)%R by ring. -replace (x - Z2R (Zfloor x) + (Z2R (Zfloor x) + 1 - x))%R with (/2 * 2)%R by field. -apply Rmult_lt_compat_r with (2 := H1). -now apply (Z2R_lt 0 2). -Qed. - -Theorem Rcompare_ceil_floor_mid : - forall x, - Z2R (Zfloor x) <> x -> - Rcompare (Z2R (Zceil x) - x) (/ 2) = Rcompare (Z2R (Zceil x) - x) (x - Z2R (Zfloor x)). -Proof. -intros x Hx. -rewrite Zceil_floor_neq with (1 := Hx). -rewrite Z2R_plus. simpl. -destruct (Rcompare_spec (Z2R (Zfloor x) + 1 - x) (/ 2)) as [H1|H1|H1] ; apply sym_eq. -(* . *) -apply Rcompare_Lt. -apply Rplus_lt_reg_l with (Z2R (Zfloor x) + 1 - x)%R. -replace (Z2R (Zfloor x) + 1 - x + (Z2R (Zfloor x) + 1 - x))%R with ((Z2R (Zfloor x) + 1 - x) * 2)%R by ring. -replace (Z2R (Zfloor x) + 1 - x + (x - Z2R (Zfloor x)))%R with (/2 * 2)%R by field. -apply Rmult_lt_compat_r with (2 := H1). -now apply (Z2R_lt 0 2). -(* . *) -apply Rcompare_Eq. -replace (x - Z2R (Zfloor x))%R with (1 - (Z2R (Zfloor x) + 1 - x))%R by ring. -rewrite H1. -field. -(* . *) -apply Rcompare_Gt. -apply Rplus_lt_reg_l with (Z2R (Zfloor x) + 1 - x)%R. -replace (Z2R (Zfloor x) + 1 - x + (Z2R (Zfloor x) + 1 - x))%R with ((Z2R (Zfloor x) + 1 - x) * 2)%R by ring. -replace (Z2R (Zfloor x) + 1 - x + (x - Z2R (Zfloor x)))%R with (/2 * 2)%R by field. -apply Rmult_lt_compat_r with (2 := H1). -now apply (Z2R_lt 0 2). +now apply IZR_lt. Qed. Theorem Znearest_N_strict : forall x, - (x - Z2R (Zfloor x) <> /2)%R -> - (Rabs (x - Z2R (Znearest x)) < /2)%R. + (x - IZR (Zfloor x) <> /2)%R -> + (Rabs (x - IZR (Znearest x)) < /2)%R. Proof. intros x Hx. unfold Znearest. @@ -1804,72 +1748,70 @@ now elim Hx. rewrite Rabs_left1. rewrite Ropp_minus_distr. rewrite Zceil_floor_neq. -rewrite Z2R_plus. -simpl. +rewrite plus_IZR. apply Ropp_lt_cancel. apply Rplus_lt_reg_l with 1%R. replace (1 + -/2)%R with (/2)%R by field. -now replace (1 + - (Z2R (Zfloor x) + 1 - x))%R with (x - Z2R (Zfloor x))%R by ring. +now replace (1 + - (IZR (Zfloor x) + 1 - x))%R with (x - IZR (Zfloor x))%R by ring. apply Rlt_not_eq. -apply Rplus_lt_reg_l with (- Z2R (Zfloor x))%R. +apply Rplus_lt_reg_l with (- IZR (Zfloor x))%R. apply Rlt_trans with (/2)%R. rewrite Rplus_opp_l. apply Rinv_0_lt_compat. -now apply (Z2R_lt 0 2). +now apply IZR_lt. now rewrite <- (Rplus_comm x). apply Rle_minus. apply Zceil_ub. Qed. -Theorem Znearest_N : +Theorem Znearest_half : forall x, - (Rabs (x - Z2R (Znearest x)) <= /2)%R. + (Rabs (x - IZR (Znearest x)) <= /2)%R. Proof. intros x. -destruct (Req_dec (x - Z2R (Zfloor x)) (/2)) as [Hx|Hx]. +destruct (Req_dec (x - IZR (Zfloor x)) (/2)) as [Hx|Hx]. assert (K: (Rabs (/2) <= /2)%R). apply Req_le. apply Rabs_pos_eq. apply Rlt_le. apply Rinv_0_lt_compat. -now apply (Z2R_lt 0 2). +now apply IZR_lt. destruct (Znearest_DN_or_UP x) as [H|H] ; rewrite H ; clear H. now rewrite Hx. rewrite Zceil_floor_neq. -rewrite Z2R_plus. -simpl. -replace (x - (Z2R (Zfloor x) + 1))%R with (x - Z2R (Zfloor x) - 1)%R by ring. +rewrite plus_IZR. +replace (x - (IZR (Zfloor x) + 1))%R with (x - IZR (Zfloor x) - 1)%R by ring. rewrite Hx. rewrite Rabs_minus_sym. now replace (1 - /2)%R with (/2)%R by field. apply Rlt_not_eq. -apply Rplus_lt_reg_l with (- Z2R (Zfloor x))%R. +apply Rplus_lt_reg_l with (- IZR (Zfloor x))%R. rewrite Rplus_opp_l, Rplus_comm. -fold (x - Z2R (Zfloor x))%R. +fold (x - IZR (Zfloor x))%R. rewrite Hx. apply Rinv_0_lt_compat. -now apply (Z2R_lt 0 2). +now apply IZR_lt. apply Rlt_le. now apply Znearest_N_strict. Qed. Theorem Znearest_imp : forall x n, - (Rabs (x - Z2R n) < /2)%R -> + (Rabs (x - IZR n) < /2)%R -> Znearest x = n. Proof. intros x n Hd. -cut (Zabs (Znearest x - n) < 1)%Z. +cut (Z.abs (Znearest x - n) < 1)%Z. clear ; zify ; omega. -apply lt_Z2R. -rewrite Z2R_abs, Z2R_minus. -replace (Z2R (Znearest x) - Z2R n)%R with (- (x - Z2R (Znearest x)) + (x - Z2R n))%R by ring. +apply lt_IZR. +rewrite abs_IZR, minus_IZR. +replace (IZR (Znearest x) - IZR n)%R with (- (x - IZR (Znearest x)) + (x - IZR n))%R by ring. apply Rle_lt_trans with (1 := Rabs_triang _ _). simpl. replace 1%R with (/2 + /2)%R by field. apply Rplus_le_lt_compat with (2 := Hd). rewrite Rabs_Ropp. -apply Znearest_N. +apply Znearest_half. Qed. Theorem round_N_pt : @@ -1880,7 +1822,7 @@ intros x. set (d := round Zfloor x). set (u := round Zceil x). set (mx := scaled_mantissa x). -set (bx := bpow (canonic_exp x)). +set (bx := bpow (cexp x)). (* . *) assert (H: (Rabs (round Znearest x - x) <= Rmin (x - d) (u - x))%R). pattern x at -1 ; rewrite <- scaled_mantissa_mult_bpow. @@ -1892,7 +1834,7 @@ rewrite <- Rmult_min_distr_r. 2: apply bpow_ge_0. apply Rmult_le_compat_r. apply bpow_ge_0. unfold Znearest. -destruct (Req_dec (Z2R (Zfloor mx)) mx) as [Hm|Hm]. +destruct (Req_dec (IZR (Zfloor mx)) mx) as [Hm|Hm]. (* .. *) rewrite Hm. unfold Rminus at 2. @@ -1903,16 +1845,16 @@ unfold Rminus at -3. rewrite Rplus_opp_r. rewrite Rabs_R0. unfold Rmin. -destruct (Rle_dec 0 (Z2R (Zceil mx) - mx)) as [H|H]. +destruct (Rle_dec 0 (IZR (Zceil mx) - mx)) as [H|H]. apply Rle_refl. apply Rle_0_minus. apply Zceil_ub. apply Rinv_0_lt_compat. -now apply (Z2R_lt 0 2). +now apply IZR_lt. (* .. *) -rewrite Rcompare_floor_ceil_mid with (1 := Hm). +rewrite Rcompare_floor_ceil_middle with (1 := Hm). rewrite Rmin_compare. -assert (H: (Rabs (mx - Z2R (Zfloor mx)) <= mx - Z2R (Zfloor mx))%R). +assert (H: (Rabs (mx - IZR (Zfloor mx)) <= mx - IZR (Zfloor mx))%R). rewrite Rabs_pos_eq. apply Rle_refl. apply Rle_0_minus. @@ -1928,7 +1870,7 @@ apply Rle_refl. apply Rle_0_minus. apply Zceil_ub. (* . *) -apply Rnd_DN_UP_pt_N with d u. +apply Rnd_N_pt_DN_UP with d u. apply generic_format_round. auto with typeclass_instances. now apply round_DN_pt. @@ -1947,63 +1889,63 @@ Proof. intros x. pattern x at 1 4 ; rewrite <- scaled_mantissa_mult_bpow. unfold round, Znearest, F2R. simpl. -destruct (Req_dec (Z2R (Zfloor (scaled_mantissa x))) (scaled_mantissa x)) as [Fx|Fx]. +destruct (Req_dec (IZR (Zfloor (scaled_mantissa x))) (scaled_mantissa x)) as [Fx|Fx]. (* *) intros _. rewrite <- Fx. -rewrite Zceil_Z2R, Zfloor_Z2R. +rewrite Zceil_IZR, Zfloor_IZR. set (m := Zfloor (scaled_mantissa x)). -now case (Rcompare (Z2R m - Z2R m) (/ 2)) ; case (choice m). +now case (Rcompare (IZR m - IZR m) (/ 2)) ; case (choice m). (* *) intros H. -rewrite Rcompare_floor_ceil_mid with (1 := Fx). +rewrite Rcompare_floor_ceil_middle with (1 := Fx). rewrite Rcompare_Eq. now case choice. -apply Rmult_eq_reg_r with (bpow (canonic_exp x)). +apply Rmult_eq_reg_r with (bpow (cexp x)). now rewrite 2!Rmult_minus_distr_r. apply Rgt_not_eq. apply bpow_gt_0. Qed. -Lemma round_N_really_small_pos : +Lemma round_N_small_pos : forall x, forall ex, - (Fcore_Raux.bpow beta (ex - 1) <= x < Fcore_Raux.bpow beta ex)%R -> + (Raux.bpow beta (ex - 1) <= x < Raux.bpow beta ex)%R -> (ex < fexp ex)%Z -> (round Znearest x = 0)%R. Proof. intros x ex Hex Hf. -unfold round, F2R, scaled_mantissa, canonic_exp; simpl. -apply (Rmult_eq_reg_r (bpow (- fexp (ln_beta beta x)))); +unfold round, F2R, scaled_mantissa, cexp; simpl. +apply (Rmult_eq_reg_r (bpow (- fexp (mag beta x)))); [|now apply Rgt_not_eq; apply bpow_gt_0]. rewrite Rmult_0_l, Rmult_assoc, <- bpow_plus. replace (_ + - _)%Z with 0%Z by ring; simpl; rewrite Rmult_1_r. -change 0%R with (Z2R 0); apply f_equal. +apply IZR_eq. apply Znearest_imp. -simpl; unfold Rminus; rewrite Ropp_0; rewrite Rplus_0_r. +unfold Rminus; rewrite Ropp_0; rewrite Rplus_0_r. assert (H : (x >= 0)%R). { apply Rle_ge; apply Rle_trans with (bpow (ex - 1)); [|exact (proj1 Hex)]. now apply bpow_ge_0. } -assert (H' : (x * bpow (- fexp (ln_beta beta x)) >= 0)%R). +assert (H' : (x * bpow (- fexp (mag beta x)) >= 0)%R). { apply Rle_ge; apply Rmult_le_pos. - now apply Rge_le. - now apply bpow_ge_0. } rewrite Rabs_right; [|exact H']. -apply (Rmult_lt_reg_r (bpow (fexp (ln_beta beta x)))); [now apply bpow_gt_0|]. +apply (Rmult_lt_reg_r (bpow (fexp (mag beta x)))); [now apply bpow_gt_0|]. rewrite Rmult_assoc, <- bpow_plus. replace (- _ + _)%Z with 0%Z by ring; simpl; rewrite Rmult_1_r. apply (Rlt_le_trans _ _ _ (proj2 Hex)). -apply Rle_trans with (bpow (fexp (ln_beta beta x) - 1)). +apply Rle_trans with (bpow (fexp (mag beta x) - 1)). - apply bpow_le. - rewrite (ln_beta_unique beta x ex); [omega|]. + rewrite (mag_unique beta x ex); [omega|]. now rewrite Rabs_right. - unfold Zminus; rewrite bpow_plus. rewrite Rmult_comm. apply Rmult_le_compat_r; [now apply bpow_ge_0|]. - unfold Fcore_Raux.bpow, Z.pow_pos; simpl. + unfold Raux.bpow, Z.pow_pos; simpl. rewrite Zmult_1_r. apply Rinv_le; [exact Rlt_0_2|]. - change 2%R with (Z2R 2); apply Z2R_le. + apply IZR_le. destruct beta as (beta_val,beta_prop). now apply Zle_bool_imp_le. Qed. @@ -2024,7 +1966,7 @@ set (f := round (Znearest (Zle_bool 0)) x). intros Rxf. destruct (Req_dec (x - round Zfloor x) (round Zceil x - x)) as [Hm|Hm]. (* *) -apply Rnd_NA_N_pt. +apply Rnd_NA_pt_N. exact generic_format_0. exact Rxf. destruct (Rle_or_lt 0 x) as [Hx|Hx]. @@ -2038,7 +1980,7 @@ apply (round_UP_pt x). apply Zfloor_lub. apply Rmult_le_pos with (1 := Hx). apply bpow_ge_0. -apply Rnd_N_pt_pos with (2 := Hx) (3 := Rxf). +apply Rnd_N_pt_ge_0 with (2 := Hx) (3 := Rxf). exact generic_format_0. (* . *) rewrite Rabs_left with (1 := Hx). @@ -2048,21 +1990,21 @@ unfold f. rewrite round_N_middle with (1 := Hm). rewrite Zle_bool_false. apply (round_DN_pt x). -apply lt_Z2R. +apply lt_IZR. apply Rle_lt_trans with (scaled_mantissa x). apply Zfloor_lb. simpl. -rewrite <- (Rmult_0_l (bpow (- canonic_exp x))). +rewrite <- (Rmult_0_l (bpow (- cexp x))). apply Rmult_lt_compat_r with (2 := Hx). apply bpow_gt_0. -apply Rnd_N_pt_neg with (3 := Rxf). +apply Rnd_N_pt_le_0 with (3 := Rxf). exact generic_format_0. now apply Rlt_le. (* *) split. apply Rxf. intros g Rxg. -rewrite Rnd_N_pt_unicity with (3 := Hm) (4 := Rxf) (5 := Rxg). +rewrite Rnd_N_pt_unique with (3 := Hm) (4 := Rxf) (5 := Rxg). apply Rle_refl. apply round_DN_pt. apply round_UP_pt. @@ -2077,25 +2019,25 @@ Theorem Znearest_opp : Znearest choice (- x) = (- Znearest (fun t => negb (choice (- (t + 1))%Z)) x)%Z. Proof with auto with typeclass_instances. intros choice x. -destruct (Req_dec (Z2R (Zfloor x)) x) as [Hx|Hx]. +destruct (Req_dec (IZR (Zfloor x)) x) as [Hx|Hx]. rewrite <- Hx. -rewrite <- Z2R_opp. -rewrite 2!Zrnd_Z2R... +rewrite <- opp_IZR. +rewrite 2!Zrnd_IZR... unfold Znearest. -replace (- x - Z2R (Zfloor (-x)))%R with (Z2R (Zceil x) - x)%R. -rewrite Rcompare_ceil_floor_mid with (1 := Hx). -rewrite Rcompare_floor_ceil_mid with (1 := Hx). +replace (- x - IZR (Zfloor (-x)))%R with (IZR (Zceil x) - x)%R. +rewrite Rcompare_ceil_floor_middle with (1 := Hx). +rewrite Rcompare_floor_ceil_middle with (1 := Hx). rewrite Rcompare_sym. rewrite <- Zceil_floor_neq with (1 := Hx). unfold Zceil. rewrite Ropp_involutive. case Rcompare ; simpl ; trivial. -rewrite Zopp_involutive. +rewrite Z.opp_involutive. case (choice (Zfloor (- x))) ; simpl ; trivial. -now rewrite Zopp_involutive. -now rewrite Zopp_involutive. +now rewrite Z.opp_involutive. +now rewrite Z.opp_involutive. unfold Zceil. -rewrite Z2R_opp. +rewrite opp_IZR. apply Rplus_comm. Qed. @@ -2106,15 +2048,30 @@ Theorem round_N_opp : Proof. intros choice x. unfold round, F2R. simpl. -rewrite canonic_exp_opp. +rewrite cexp_opp. rewrite scaled_mantissa_opp. rewrite Znearest_opp. -rewrite Z2R_opp. +rewrite opp_IZR. now rewrite Ropp_mult_distr_l_reverse. Qed. End rndN_opp. +Lemma round_N_small : + forall choice, + forall x, + forall ex, + (Raux.bpow beta (ex - 1) <= Rabs x < Raux.bpow beta ex)%R -> + (ex < fexp ex)%Z -> + (round (Znearest choice) x = 0)%R. +Proof. +intros choice x ex Hx Hex. +destruct (Rle_or_lt 0 x) as [Px|Nx]. +{ now revert Hex; apply round_N_small_pos; revert Hx; rewrite Rabs_pos_eq. } +rewrite <-(Ropp_involutive x), round_N_opp, <-Ropp_0; f_equal. +now revert Hex; apply round_N_small_pos; revert Hx; rewrite Rabs_left. +Qed. + End Format. (** Inclusion of a format into an extended format *) @@ -2125,9 +2082,9 @@ Variables fexp1 fexp2 : Z -> Z. Context { valid_exp1 : Valid_exp fexp1 }. Context { valid_exp2 : Valid_exp fexp2 }. -Theorem generic_inclusion_ln_beta : +Theorem generic_inclusion_mag : forall x, - ( x <> R0 -> (fexp2 (ln_beta beta x) <= fexp1 (ln_beta beta x))%Z ) -> + ( x <> 0%R -> (fexp2 (mag beta x) <= fexp1 (mag beta x))%Z ) -> generic_format fexp1 x -> generic_format fexp2 x. Proof. @@ -2139,7 +2096,7 @@ rewrite <- Fx. apply He. contradict Zx. rewrite Zx, scaled_mantissa_0. -apply (Ztrunc_Z2R 0). +apply Ztrunc_IZR. Qed. Theorem generic_inclusion_lt_ge : @@ -2151,12 +2108,12 @@ Theorem generic_inclusion_lt_ge : generic_format fexp2 x. Proof. intros e1 e2 He x (Hx1,Hx2). -apply generic_inclusion_ln_beta. +apply generic_inclusion_mag. intros Zx. apply He. split. -now apply ln_beta_gt_bpow. -now apply ln_beta_le_bpow. +now apply mag_gt_bpow. +now apply mag_le_bpow. Qed. Theorem generic_inclusion : @@ -2168,13 +2125,13 @@ Theorem generic_inclusion : generic_format fexp2 x. Proof with auto with typeclass_instances. intros e He x (Hx1,[Hx2|Hx2]). -apply generic_inclusion_ln_beta. -now rewrite ln_beta_unique with (1 := conj Hx1 Hx2). +apply generic_inclusion_mag. +now rewrite mag_unique with (1 := conj Hx1 Hx2). intros Fx. apply generic_format_abs_inv. rewrite Hx2. apply generic_format_bpow'... -apply Zle_trans with (1 := He). +apply Z.le_trans with (1 := He). apply generic_format_bpow_inv... rewrite <- Hx2. now apply generic_format_abs. @@ -2191,18 +2148,18 @@ Theorem generic_inclusion_le_ge : Proof. intros e1 e2 He' He x (Hx1,[Hx2|Hx2]). (* *) -apply generic_inclusion_ln_beta. +apply generic_inclusion_mag. intros Zx. apply He. split. -now apply ln_beta_gt_bpow. -now apply ln_beta_le_bpow. +now apply mag_gt_bpow. +now apply mag_le_bpow. (* *) apply generic_inclusion with (e := e2). apply He. split. apply He'. -apply Zle_refl. +apply Z.le_refl. rewrite Hx2. split. apply bpow_le. @@ -2219,13 +2176,13 @@ Theorem generic_inclusion_le : generic_format fexp2 x. Proof. intros e2 He x [Hx|Hx]. -apply generic_inclusion_ln_beta. +apply generic_inclusion_mag. intros Zx. apply He. -now apply ln_beta_le_bpow. +now apply mag_le_bpow. apply generic_inclusion with (e := e2). apply He. -apply Zle_refl. +apply Z.le_refl. rewrite Hx. split. apply bpow_le. @@ -2242,10 +2199,10 @@ Theorem generic_inclusion_ge : generic_format fexp2 x. Proof. intros e1 He x Hx. -apply generic_inclusion_ln_beta. +apply generic_inclusion_mag. intros Zx. apply He. -now apply ln_beta_gt_bpow. +now apply mag_gt_bpow. Qed. Variable rnd : R -> Z. @@ -2263,9 +2220,9 @@ revert rnd valid_rnd x Gx. refine (round_abs_abs _ (fun x y => generic_format fexp1 x -> generic_format fexp1 y) _). intros rnd valid_rnd x [Hx|Hx] Gx. (* x > 0 *) -generalize (ln_beta_generic_gt _ x (Rgt_not_eq _ _ Hx) Gx). -unfold canonic_exp. -destruct (ln_beta beta x) as (ex,Ex) ; simpl. +generalize (mag_generic_gt _ x (Rgt_not_eq _ _ Hx) Gx). +unfold cexp. +destruct (mag beta x) as (ex,Ex) ; simpl. specialize (Ex (Rgt_not_eq _ _ Hx)). intros He'. rewrite Rabs_pos_eq in Ex by now apply Rlt_le. @@ -2279,25 +2236,25 @@ apply generic_format_bpow'... apply Zlt_le_weak. apply valid_exp_large with ex... (* - x large for fexp2 *) -destruct (Zle_or_lt (canonic_exp fexp2 x) (canonic_exp fexp1 x)) as [He''|He'']. +destruct (Zle_or_lt (cexp fexp2 x) (cexp fexp1 x)) as [He''|He'']. (* - - round fexp2 x is representable for fexp1 *) rewrite round_generic... rewrite Gx. apply generic_format_F2R. fold (round fexp1 Ztrunc x). intros Zx. -unfold canonic_exp at 1. -rewrite ln_beta_round_ZR... +unfold cexp at 1. +rewrite mag_round_ZR... contradict Zx. -apply F2R_eq_0_reg with (1 := Zx). +apply eq_0_F2R with (1 := Zx). (* - - round fexp2 x has too many digits for fexp1 *) destruct (round_bounded_large_pos fexp2 rnd x ex He Ex) as (Hr1,[Hr2|Hr2]). apply generic_format_F2R. intros Zx. fold (round fexp2 rnd x). -unfold canonic_exp at 1. -rewrite ln_beta_unique_pos with (1 := conj Hr1 Hr2). -rewrite <- ln_beta_unique_pos with (1 := Ex). +unfold cexp at 1. +rewrite mag_unique_pos with (1 := conj Hr1 Hr2). +rewrite <- mag_unique_pos with (1 := Ex). now apply Zlt_le_weak. rewrite Hr2. apply generic_format_bpow'... @@ -2327,7 +2284,7 @@ apply Ropp_eq_compat. apply round_ext. clear x; intro x. unfold Znearest. -case_eq (Rcompare (x - Z2R (Zfloor x)) (/ 2)); intro C; +case_eq (Rcompare (x - IZR (Zfloor x)) (/ 2)); intro C; [|reflexivity|reflexivity]. apply Rcompare_Eq_inv in C. assert (H : negb (0 <=? - (Zfloor x + 1))%Z = (0 <=? Zfloor x)%Z); diff --git a/flocq/Core/Fcore_Raux.v b/flocq/Core/Raux.v index 77235e63..8273a55b 100644 --- a/flocq/Core/Fcore_Raux.v +++ b/flocq/Core/Raux.v @@ -2,9 +2,9 @@ This file is part of the Flocq formalization of floating-point arithmetic in Coq: http://flocq.gforge.inria.fr/ -Copyright (C) 2010-2013 Sylvie Boldo +Copyright (C) 2009-2018 Sylvie Boldo #<br /># -Copyright (C) 2010-2013 Guillaume Melquiond +Copyright (C) 2009-2018 Guillaume Melquiond This library is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public @@ -18,9 +18,9 @@ COPYING file for more details. *) (** * Missing definitions/lemmas *) -Require Export Reals. -Require Export ZArith. -Require Export Fcore_Zaux. +Require Import Psatz. +Require Export Reals ZArith. +Require Export Zaux. Section Rmissing. @@ -58,12 +58,13 @@ Theorem Rabs_minus_le: (Rabs (x-y) <= x)%R. Proof. intros x y Hx Hy. -unfold Rabs; case (Rcase_abs (x - y)); intros H. -apply Rplus_le_reg_l with x; ring_simplify; assumption. -apply Rplus_le_reg_l with (-x)%R; ring_simplify. -auto with real. +apply Rabs_le. +lra. Qed. +Theorem Rabs_eq_R0 x : (Rabs x = 0 -> x = 0)%R. +Proof. split_Rabs; lra. Qed. + Theorem Rplus_eq_reg_r : forall r r1 r2 : R, (r1 + r = r2 + r)%R -> (r1 = r2)%R. @@ -73,53 +74,6 @@ apply Rplus_eq_reg_l with r. now rewrite 2!(Rplus_comm r). Qed. -Theorem Rplus_lt_reg_l : - forall r r1 r2 : R, - (r + r1 < r + r2)%R -> (r1 < r2)%R. -Proof. -intros. -solve [ apply Rplus_lt_reg_l with (1 := H) | - apply Rplus_lt_reg_r with (1 := H) ]. -Qed. - -Theorem Rplus_lt_reg_r : - forall r r1 r2 : R, - (r1 + r < r2 + r)%R -> (r1 < r2)%R. -Proof. -intros. -apply Rplus_lt_reg_l with r. -now rewrite 2!(Rplus_comm r). -Qed. - -Theorem Rplus_le_reg_r : - forall r r1 r2 : R, - (r1 + r <= r2 + r)%R -> (r1 <= r2)%R. -Proof. -intros. -apply Rplus_le_reg_l with r. -now rewrite 2!(Rplus_comm r). -Qed. - -Theorem Rmult_lt_reg_r : - forall r r1 r2 : R, (0 < r)%R -> - (r1 * r < r2 * r)%R -> (r1 < r2)%R. -Proof. -intros. -apply Rmult_lt_reg_l with r. -exact H. -now rewrite 2!(Rmult_comm r). -Qed. - -Theorem Rmult_le_reg_r : - forall r r1 r2 : R, (0 < r)%R -> - (r1 * r <= r2 * r)%R -> (r1 <= r2)%R. -Proof. -intros. -apply Rmult_le_reg_l with r. -exact H. -now rewrite 2!(Rmult_comm r). -Qed. - Theorem Rmult_lt_compat : forall r1 r2 r3 r4, (0 <= r1)%R -> (0 <= r3)%R -> (r1 < r2)%R -> (r3 < r4)%R -> @@ -135,16 +89,6 @@ apply Rle_lt_trans with (r1 * r4)%R. + exact H12. Qed. -Theorem Rmult_eq_reg_r : - forall r r1 r2 : R, (r1 * r)%R = (r2 * r)%R -> - r <> 0%R -> r1 = r2. -Proof. -intros r r1 r2 H1 H2. -apply Rmult_eq_reg_l with r. -now rewrite 2!(Rmult_comm r). -exact H2. -Qed. - Theorem Rmult_minus_distr_r : forall r r1 r2 : R, ((r1 - r2) * r = r1 * r - r2 * r)%R. @@ -154,13 +98,18 @@ rewrite <- 3!(Rmult_comm r). apply Rmult_minus_distr_l. Qed. -Lemma Rmult_neq_reg_r: forall r1 r2 r3:R, (r2 * r1 <> r3 * r1)%R -> r2 <> r3. +Lemma Rmult_neq_reg_r : + forall r1 r2 r3 : R, (r2 * r1 <> r3 * r1)%R -> r2 <> r3. +Proof. intros r1 r2 r3 H1 H2. apply H1; rewrite H2; ring. Qed. -Lemma Rmult_neq_compat_r: forall r1 r2 r3:R, (r1 <> 0)%R -> (r2 <> r3)%R - -> (r2 *r1 <> r3*r1)%R. +Lemma Rmult_neq_compat_r : + forall r1 r2 r3 : R, + (r1 <> 0)%R -> (r2 <> r3)%R -> + (r2 * r1 <> r3 * r1)%R. +Proof. intros r1 r2 r3 H H1 H2. now apply H1, Rmult_eq_reg_r with r1. Qed. @@ -227,7 +176,6 @@ rewrite Rmax_right; trivial. now apply Ropp_le_contravar. Qed. - Theorem exp_le : forall x y : R, (x <= y)%R -> (exp x <= exp y)%R. @@ -288,6 +236,14 @@ destruct (Req_dec x 0) as [Zx|Nzx]. now apply Nzx, Rle_antisym; [|apply Rge_le]. Qed. +Lemma Rsqr_le_abs_0_alt : + forall x y, + (x² <= y² -> x <= Rabs y)%R. +Proof. +intros x y H. +apply (Rle_trans _ (Rabs x)); [apply Rle_abs|apply (Rsqr_le_abs_0 _ _ H)]. +Qed. + Theorem Rabs_le : forall x y, (-y <= x <= y)%R -> (Rabs x <= y)%R. @@ -387,187 +343,35 @@ Qed. End Rmissing. -Section Z2R. +Section IZR. -(** Z2R function (Z -> R) *) -Fixpoint P2R (p : positive) := - match p with - | xH => 1%R - | xO xH => 2%R - | xO t => (2 * P2R t)%R - | xI xH => 3%R - | xI t => (1 + 2 * P2R t)%R - end. - -Definition Z2R n := - match n with - | Zpos p => P2R p - | Zneg p => Ropp (P2R p) - | Z0 => 0%R - end. - -Theorem P2R_INR : - forall n, P2R n = INR (nat_of_P n). -Proof. -induction n ; simpl ; try ( - rewrite IHn ; - rewrite <- (mult_INR 2) ; - rewrite <- (nat_of_P_mult_morphism 2) ; - change (2 * n)%positive with (xO n)). -(* xI *) -rewrite (Rplus_comm 1). -change (nat_of_P (xO n)) with (Pmult_nat n 2). -case n ; intros ; simpl ; try apply refl_equal. -case (Pmult_nat p 4) ; intros ; try apply refl_equal. -rewrite Rplus_0_l. -apply refl_equal. -apply Rplus_comm. -(* xO *) -case n ; intros ; apply refl_equal. -(* xH *) -apply refl_equal. -Qed. - -Theorem Z2R_IZR : - forall n, Z2R n = IZR n. -Proof. -intro. -case n ; intros ; unfold Z2R. -apply refl_equal. -rewrite <- positive_nat_Z, <- INR_IZR_INZ. -apply P2R_INR. -change (IZR (Zneg p)) with (Ropp (IZR (Zpos p))). -apply Ropp_eq_compat. -rewrite <- positive_nat_Z, <- INR_IZR_INZ. -apply P2R_INR. -Qed. - -Theorem Z2R_opp : - forall n, Z2R (-n) = (- Z2R n)%R. -Proof. -intros. -repeat rewrite Z2R_IZR. -apply Ropp_Ropp_IZR. -Qed. - -Theorem Z2R_plus : - forall m n, (Z2R (m + n) = Z2R m + Z2R n)%R. -Proof. -intros. -repeat rewrite Z2R_IZR. -apply plus_IZR. -Qed. - -Theorem minus_IZR : - forall n m : Z, - IZR (n - m) = (IZR n - IZR m)%R. -Proof. -intros. -unfold Zminus. -rewrite plus_IZR. -rewrite Ropp_Ropp_IZR. -apply refl_equal. -Qed. - -Theorem Z2R_minus : - forall m n, (Z2R (m - n) = Z2R m - Z2R n)%R. -Proof. -intros. -repeat rewrite Z2R_IZR. -apply minus_IZR. -Qed. - -Theorem Z2R_mult : - forall m n, (Z2R (m * n) = Z2R m * Z2R n)%R. -Proof. -intros. -repeat rewrite Z2R_IZR. -apply mult_IZR. -Qed. - -Theorem le_Z2R : - forall m n, (Z2R m <= Z2R n)%R -> (m <= n)%Z. -Proof. -intros m n. -repeat rewrite Z2R_IZR. -apply le_IZR. -Qed. - -Theorem Z2R_le : - forall m n, (m <= n)%Z -> (Z2R m <= Z2R n)%R. -Proof. -intros m n. -repeat rewrite Z2R_IZR. -apply IZR_le. -Qed. - -Theorem lt_Z2R : - forall m n, (Z2R m < Z2R n)%R -> (m < n)%Z. -Proof. -intros m n. -repeat rewrite Z2R_IZR. -apply lt_IZR. -Qed. - -Theorem Z2R_lt : - forall m n, (m < n)%Z -> (Z2R m < Z2R n)%R. -Proof. -intros m n. -repeat rewrite Z2R_IZR. -apply IZR_lt. -Qed. - -Theorem Z2R_le_lt : - forall m n p, (m <= n < p)%Z -> (Z2R m <= Z2R n < Z2R p)%R. +Theorem IZR_le_lt : + forall m n p, (m <= n < p)%Z -> (IZR m <= IZR n < IZR p)%R. Proof. intros m n p (H1, H2). split. -now apply Z2R_le. -now apply Z2R_lt. +now apply IZR_le. +now apply IZR_lt. Qed. -Theorem le_lt_Z2R : - forall m n p, (Z2R m <= Z2R n < Z2R p)%R -> (m <= n < p)%Z. +Theorem le_lt_IZR : + forall m n p, (IZR m <= IZR n < IZR p)%R -> (m <= n < p)%Z. Proof. intros m n p (H1, H2). split. -now apply le_Z2R. -now apply lt_Z2R. -Qed. - -Theorem eq_Z2R : - forall m n, (Z2R m = Z2R n)%R -> (m = n)%Z. -Proof. -intros m n H. -apply eq_IZR. -now rewrite <- 2!Z2R_IZR. +now apply le_IZR. +now apply lt_IZR. Qed. -Theorem neq_Z2R : - forall m n, (Z2R m <> Z2R n)%R -> (m <> n)%Z. +Theorem neq_IZR : + forall m n, (IZR m <> IZR n)%R -> (m <> n)%Z. Proof. intros m n H H'. apply H. now apply f_equal. Qed. -Theorem Z2R_neq : - forall m n, (m <> n)%Z -> (Z2R m <> Z2R n)%R. -Proof. -intros m n. -repeat rewrite Z2R_IZR. -apply IZR_neq. -Qed. - -Theorem Z2R_abs : - forall z, Z2R (Zabs z) = Rabs (Z2R z). -Proof. -intros. -repeat rewrite Z2R_IZR. -now rewrite Rabs_Zabs. -Qed. - -End Z2R. +End IZR. (** Decidable comparison on reals *) Section Rcompare. @@ -691,17 +495,17 @@ contradict H. now apply Rcompare_Gt. Qed. -Theorem Rcompare_Z2R : - forall x y, Rcompare (Z2R x) (Z2R y) = Zcompare x y. +Theorem Rcompare_IZR : + forall x y, Rcompare (IZR x) (IZR y) = Z.compare x y. Proof. intros x y. case Rcompare_spec ; intros H ; apply sym_eq. apply Zcompare_Lt. -now apply lt_Z2R. +now apply lt_IZR. apply Zcompare_Eq. -now apply eq_Z2R. +now apply eq_IZR. apply Zcompare_Gt. -now apply lt_Z2R. +now apply lt_IZR. Qed. Theorem Rcompare_sym : @@ -715,6 +519,16 @@ now apply Rcompare_Eq. now apply Rcompare_Lt. Qed. +Lemma Rcompare_opp : + forall x y, + Rcompare (- x) (- y) = Rcompare y x. +Proof. +intros x y. +destruct (Rcompare_spec y x); + destruct (Rcompare_spec (- x) (- y)); + try reflexivity; exfalso; lra. +Qed. + Theorem Rcompare_plus_r : forall z x y, Rcompare (x + z) (y + z) = Rcompare x y. @@ -773,7 +587,7 @@ rewrite <- (Rcompare_mult_r (/2) (x - d)). field_simplify (x + (- x / 2 - d / 2))%R. now field_simplify ((d + u) / 2 + (- x / 2 - d / 2))%R. apply Rinv_0_lt_compat. -now apply (Z2R_lt 0 2). +now apply IZR_lt. Qed. Theorem Rcompare_half_l : @@ -784,8 +598,8 @@ rewrite <- (Rcompare_mult_r 2%R). unfold Rdiv. rewrite Rmult_assoc, Rinv_l, Rmult_1_r. now rewrite Rmult_comm. -now apply (Z2R_neq 2 0). -now apply (Z2R_lt 0 2). +now apply IZR_neq. +now apply IZR_lt. Qed. Theorem Rcompare_half_r : @@ -796,23 +610,23 @@ rewrite <- (Rcompare_mult_r 2%R). unfold Rdiv. rewrite Rmult_assoc, Rinv_l, Rmult_1_r. now rewrite Rmult_comm. -now apply (Z2R_neq 2 0). -now apply (Z2R_lt 0 2). +now apply IZR_neq. +now apply IZR_lt. Qed. Theorem Rcompare_sqr : forall x y, - (0 <= x)%R -> (0 <= y)%R -> - Rcompare (x * x) (y * y) = Rcompare x y. + Rcompare (x * x) (y * y) = Rcompare (Rabs x) (Rabs y). Proof. -intros x y Hx Hy. -destruct (Rcompare_spec x y) as [H|H|H]. +intros x y. +destruct (Rcompare_spec (Rabs x) (Rabs y)) as [H|H|H]. apply Rcompare_Lt. -now apply Rsqr_incrst_1. -rewrite H. +now apply Rsqr_lt_abs_1. +change (Rcompare (Rsqr x) (Rsqr y) = Eq). +rewrite Rsqr_abs, H, (Rsqr_abs y). now apply Rcompare_Eq. apply Rcompare_Gt. -now apply Rsqr_incrst_1. +now apply Rsqr_lt_abs_1. Qed. Theorem Rmin_compare : @@ -941,6 +755,14 @@ rewrite <- negb_Rlt_bool. now rewrite Rle_bool_true. Qed. +Lemma Rlt_bool_opp : + forall x y, + Rlt_bool (- x) (- y) = Rlt_bool y x. +Proof. +intros x y. +now unfold Rlt_bool; rewrite Rcompare_opp. +Qed. + End Rlt_bool. Section Req_bool. @@ -997,13 +819,12 @@ Definition Zfloor (x : R) := (up x - 1)%Z. Theorem Zfloor_lb : forall x : R, - (Z2R (Zfloor x) <= x)%R. + (IZR (Zfloor x) <= x)%R. Proof. intros x. unfold Zfloor. -rewrite Z2R_minus. +rewrite minus_IZR. simpl. -rewrite Z2R_IZR. apply Rplus_le_reg_r with (1 - x)%R. ring_simplify. exact (proj2 (archimed x)). @@ -1011,55 +832,54 @@ Qed. Theorem Zfloor_ub : forall x : R, - (x < Z2R (Zfloor x) + 1)%R. + (x < IZR (Zfloor x) + 1)%R. Proof. intros x. unfold Zfloor. -rewrite Z2R_minus. +rewrite minus_IZR. unfold Rminus. rewrite Rplus_assoc. rewrite Rplus_opp_l, Rplus_0_r. -rewrite Z2R_IZR. exact (proj1 (archimed x)). Qed. Theorem Zfloor_lub : forall n x, - (Z2R n <= x)%R -> + (IZR n <= x)%R -> (n <= Zfloor x)%Z. Proof. intros n x Hnx. apply Zlt_succ_le. -apply lt_Z2R. +apply lt_IZR. apply Rle_lt_trans with (1 := Hnx). -unfold Zsucc. -rewrite Z2R_plus. +unfold Z.succ. +rewrite plus_IZR. apply Zfloor_ub. Qed. Theorem Zfloor_imp : forall n x, - (Z2R n <= x < Z2R (n + 1))%R -> + (IZR n <= x < IZR (n + 1))%R -> Zfloor x = n. Proof. intros n x Hnx. apply Zle_antisym. apply Zlt_succ_le. -apply lt_Z2R. +apply lt_IZR. apply Rle_lt_trans with (2 := proj2 Hnx). apply Zfloor_lb. now apply Zfloor_lub. Qed. -Theorem Zfloor_Z2R : +Theorem Zfloor_IZR : forall n, - Zfloor (Z2R n) = n. + Zfloor (IZR n) = n. Proof. intros n. apply Zfloor_imp. split. apply Rle_refl. -apply Z2R_lt. +apply IZR_lt. apply Zlt_succ. Qed. @@ -1077,11 +897,11 @@ Definition Zceil (x : R) := (- Zfloor (- x))%Z. Theorem Zceil_ub : forall x : R, - (x <= Z2R (Zceil x))%R. + (x <= IZR (Zceil x))%R. Proof. intros x. unfold Zceil. -rewrite Z2R_opp. +rewrite opp_IZR. apply Ropp_le_cancel. rewrite Ropp_involutive. apply Zfloor_lb. @@ -1089,45 +909,45 @@ Qed. Theorem Zceil_glb : forall n x, - (x <= Z2R n)%R -> + (x <= IZR n)%R -> (Zceil x <= n)%Z. Proof. intros n x Hnx. unfold Zceil. apply Zopp_le_cancel. -rewrite Zopp_involutive. +rewrite Z.opp_involutive. apply Zfloor_lub. -rewrite Z2R_opp. +rewrite opp_IZR. now apply Ropp_le_contravar. Qed. Theorem Zceil_imp : forall n x, - (Z2R (n - 1) < x <= Z2R n)%R -> + (IZR (n - 1) < x <= IZR n)%R -> Zceil x = n. Proof. intros n x Hnx. unfold Zceil. -rewrite <- (Zopp_involutive n). +rewrite <- (Z.opp_involutive n). apply f_equal. apply Zfloor_imp. split. -rewrite Z2R_opp. +rewrite opp_IZR. now apply Ropp_le_contravar. -rewrite <- (Zopp_involutive 1). +rewrite <- (Z.opp_involutive 1). rewrite <- Zopp_plus_distr. -rewrite Z2R_opp. +rewrite opp_IZR. now apply Ropp_lt_contravar. Qed. -Theorem Zceil_Z2R : +Theorem Zceil_IZR : forall n, - Zceil (Z2R n) = n. + Zceil (IZR n) = n. Proof. intros n. unfold Zceil. -rewrite <- Z2R_opp, Zfloor_Z2R. -apply Zopp_involutive. +rewrite <- opp_IZR, Zfloor_IZR. +apply Z.opp_involutive. Qed. Theorem Zceil_le : @@ -1142,7 +962,7 @@ Qed. Theorem Zceil_floor_neq : forall x : R, - (Z2R (Zfloor x) <> x)%R -> + (IZR (Zfloor x) <> x)%R -> (Zceil x = Zfloor x + 1)%Z. Proof. intros x Hx. @@ -1156,21 +976,21 @@ apply Rle_antisym. apply Zfloor_lb. exact H. apply Rlt_le. -rewrite Z2R_plus. +rewrite plus_IZR. apply Zfloor_ub. Qed. Definition Ztrunc x := if Rlt_bool x 0 then Zceil x else Zfloor x. -Theorem Ztrunc_Z2R : +Theorem Ztrunc_IZR : forall n, - Ztrunc (Z2R n) = n. + Ztrunc (IZR n) = n. Proof. intros n. unfold Ztrunc. case Rlt_bool_spec ; intro H. -apply Zceil_Z2R. -apply Zfloor_Z2R. +apply Zceil_IZR. +apply Zfloor_IZR. Qed. Theorem Ztrunc_floor : @@ -1196,9 +1016,8 @@ unfold Ztrunc. case Rlt_bool_spec ; intro H. apply refl_equal. rewrite (Rle_antisym _ _ Hx H). -change 0%R with (Z2R 0). -rewrite Zceil_Z2R. -apply Zfloor_Z2R. +rewrite Zceil_IZR. +apply Zfloor_IZR. Qed. Theorem Ztrunc_le : @@ -1211,7 +1030,7 @@ case Rlt_bool_spec ; intro Hx. unfold Ztrunc. case Rlt_bool_spec ; intro Hy. now apply Zceil_le. -apply Zle_trans with 0%Z. +apply Z.le_trans with 0%Z. apply Zceil_glb. now apply Rlt_le. now apply Zfloor_lub. @@ -1222,14 +1041,14 @@ Qed. Theorem Ztrunc_opp : forall x, - Ztrunc (- x) = Zopp (Ztrunc x). + Ztrunc (- x) = Z.opp (Ztrunc x). Proof. intros x. unfold Ztrunc at 2. case Rlt_bool_spec ; intros Hx. rewrite Ztrunc_floor. apply sym_eq. -apply Zopp_involutive. +apply Z.opp_involutive. rewrite <- Ropp_0. apply Ropp_le_contravar. now apply Rlt_le. @@ -1242,7 +1061,7 @@ Qed. Theorem Ztrunc_abs : forall x, - Ztrunc (Rabs x) = Zabs (Ztrunc x). + Ztrunc (Rabs x) = Z.abs (Ztrunc x). Proof. intros x. rewrite Ztrunc_floor. 2: apply Rabs_pos. @@ -1251,19 +1070,19 @@ case Rlt_bool_spec ; intro H. rewrite Rabs_left with (1 := H). rewrite Zabs_non_eq. apply sym_eq. -apply Zopp_involutive. +apply Z.opp_involutive. apply Zceil_glb. now apply Rlt_le. rewrite Rabs_pos_eq with (1 := H). apply sym_eq. -apply Zabs_eq. +apply Z.abs_eq. now apply Zfloor_lub. Qed. Theorem Ztrunc_lub : forall n x, - (Z2R n <= Rabs x)%R -> - (n <= Zabs (Ztrunc x))%Z. + (IZR n <= Rabs x)%R -> + (n <= Z.abs (Ztrunc x))%Z. Proof. intros n x H. rewrite <- Ztrunc_abs. @@ -1273,15 +1092,15 @@ Qed. Definition Zaway x := if Rlt_bool x 0 then Zfloor x else Zceil x. -Theorem Zaway_Z2R : +Theorem Zaway_IZR : forall n, - Zaway (Z2R n) = n. + Zaway (IZR n) = n. Proof. intros n. unfold Zaway. case Rlt_bool_spec ; intro H. -apply Zfloor_Z2R. -apply Zceil_Z2R. +apply Zfloor_IZR. +apply Zceil_IZR. Qed. Theorem Zaway_ceil : @@ -1307,9 +1126,8 @@ unfold Zaway. case Rlt_bool_spec ; intro H. apply refl_equal. rewrite (Rle_antisym _ _ Hx H). -change 0%R with (Z2R 0). -rewrite Zfloor_Z2R. -apply Zceil_Z2R. +rewrite Zfloor_IZR. +apply Zceil_IZR. Qed. Theorem Zaway_le : @@ -1322,7 +1140,7 @@ case Rlt_bool_spec ; intro Hx. unfold Zaway. case Rlt_bool_spec ; intro Hy. now apply Zfloor_le. -apply le_Z2R. +apply le_IZR. apply Rle_trans with 0%R. apply Rlt_le. apply Rle_lt_trans with (2 := Hx). @@ -1336,7 +1154,7 @@ Qed. Theorem Zaway_opp : forall x, - Zaway (- x) = Zopp (Zaway x). + Zaway (- x) = Z.opp (Zaway x). Proof. intros x. unfold Zaway at 2. @@ -1348,14 +1166,14 @@ apply Rlt_le. now apply Ropp_0_gt_lt_contravar. rewrite Zaway_floor. apply sym_eq. -apply Zopp_involutive. +apply Z.opp_involutive. rewrite <- Ropp_0. now apply Ropp_le_contravar. Qed. Theorem Zaway_abs : forall x, - Zaway (Rabs x) = Zabs (Zaway x). + Zaway (Rabs x) = Z.abs (Zaway x). Proof. intros x. rewrite Zaway_ceil. 2: apply Rabs_pos. @@ -1365,66 +1183,126 @@ rewrite Rabs_left with (1 := H). rewrite Zabs_non_eq. apply (f_equal (fun v => - Zfloor v)%Z). apply Ropp_involutive. -apply le_Z2R. +apply le_IZR. apply Rlt_le. apply Rle_lt_trans with (2 := H). apply Zfloor_lb. rewrite Rabs_pos_eq with (1 := H). apply sym_eq. -apply Zabs_eq. -apply le_Z2R. +apply Z.abs_eq. +apply le_IZR. apply Rle_trans with (1 := H). apply Zceil_ub. Qed. End Floor_Ceil. +Theorem Rcompare_floor_ceil_middle : + forall x, + IZR (Zfloor x) <> x -> + Rcompare (x - IZR (Zfloor x)) (/ 2) = Rcompare (x - IZR (Zfloor x)) (IZR (Zceil x) - x). +Proof. +intros x Hx. +rewrite Zceil_floor_neq with (1 := Hx). +rewrite plus_IZR. +destruct (Rcompare_spec (x - IZR (Zfloor x)) (/ 2)) as [H1|H1|H1] ; apply sym_eq. +(* . *) +apply Rcompare_Lt. +apply Rplus_lt_reg_l with (x - IZR (Zfloor x))%R. +replace (x - IZR (Zfloor x) + (x - IZR (Zfloor x)))%R with ((x - IZR (Zfloor x)) * 2)%R by ring. +replace (x - IZR (Zfloor x) + (IZR (Zfloor x) + 1 - x))%R with (/2 * 2)%R by field. +apply Rmult_lt_compat_r with (2 := H1). +now apply IZR_lt. +(* . *) +apply Rcompare_Eq. +replace (IZR (Zfloor x) + 1 - x)%R with (1 - (x - IZR (Zfloor x)))%R by ring. +rewrite H1. +field. +(* . *) +apply Rcompare_Gt. +apply Rplus_lt_reg_l with (x - IZR (Zfloor x))%R. +replace (x - IZR (Zfloor x) + (x - IZR (Zfloor x)))%R with ((x - IZR (Zfloor x)) * 2)%R by ring. +replace (x - IZR (Zfloor x) + (IZR (Zfloor x) + 1 - x))%R with (/2 * 2)%R by field. +apply Rmult_lt_compat_r with (2 := H1). +now apply IZR_lt. +Qed. + +Theorem Rcompare_ceil_floor_middle : + forall x, + IZR (Zfloor x) <> x -> + Rcompare (IZR (Zceil x) - x) (/ 2) = Rcompare (IZR (Zceil x) - x) (x - IZR (Zfloor x)). +Proof. +intros x Hx. +rewrite Zceil_floor_neq with (1 := Hx). +rewrite plus_IZR. +destruct (Rcompare_spec (IZR (Zfloor x) + 1 - x) (/ 2)) as [H1|H1|H1] ; apply sym_eq. +(* . *) +apply Rcompare_Lt. +apply Rplus_lt_reg_l with (IZR (Zfloor x) + 1 - x)%R. +replace (IZR (Zfloor x) + 1 - x + (IZR (Zfloor x) + 1 - x))%R with ((IZR (Zfloor x) + 1 - x) * 2)%R by ring. +replace (IZR (Zfloor x) + 1 - x + (x - IZR (Zfloor x)))%R with (/2 * 2)%R by field. +apply Rmult_lt_compat_r with (2 := H1). +now apply IZR_lt. +(* . *) +apply Rcompare_Eq. +replace (x - IZR (Zfloor x))%R with (1 - (IZR (Zfloor x) + 1 - x))%R by ring. +rewrite H1. +field. +(* . *) +apply Rcompare_Gt. +apply Rplus_lt_reg_l with (IZR (Zfloor x) + 1 - x)%R. +replace (IZR (Zfloor x) + 1 - x + (IZR (Zfloor x) + 1 - x))%R with ((IZR (Zfloor x) + 1 - x) * 2)%R by ring. +replace (IZR (Zfloor x) + 1 - x + (x - IZR (Zfloor x)))%R with (/2 * 2)%R by field. +apply Rmult_lt_compat_r with (2 := H1). +now apply IZR_lt. +Qed. + Section Zdiv_Rdiv. Theorem Zfloor_div : forall x y, y <> Z0 -> - Zfloor (Z2R x / Z2R y) = (x / y)%Z. + Zfloor (IZR x / IZR y) = (x / y)%Z. Proof. intros x y Zy. generalize (Z_div_mod_eq_full x y Zy). intros Hx. rewrite Hx at 1. -assert (Zy': Z2R y <> R0). +assert (Zy': IZR y <> 0%R). contradict Zy. -now apply eq_Z2R. +now apply eq_IZR. unfold Rdiv. -rewrite Z2R_plus, Rmult_plus_distr_r, Z2R_mult. -replace (Z2R y * Z2R (x / y) * / Z2R y)%R with (Z2R (x / y)) by now field. +rewrite plus_IZR, Rmult_plus_distr_r, mult_IZR. +replace (IZR y * IZR (x / y) * / IZR y)%R with (IZR (x / y)) by now field. apply Zfloor_imp. -rewrite Z2R_plus. -assert (0 <= Z2R (x mod y) * / Z2R y < 1)%R. +rewrite plus_IZR. +assert (0 <= IZR (x mod y) * / IZR y < 1)%R. (* *) -assert (forall x' y', (0 < y')%Z -> 0 <= Z2R (x' mod y') * / Z2R y' < 1)%R. +assert (forall x' y', (0 < y')%Z -> 0 <= IZR (x' mod y') * / IZR y' < 1)%R. (* . *) clear. intros x y Hy. split. apply Rmult_le_pos. -apply (Z2R_le 0). +apply IZR_le. refine (proj1 (Z_mod_lt _ _ _)). -now apply Zlt_gt. +now apply Z.lt_gt. apply Rlt_le. apply Rinv_0_lt_compat. -now apply (Z2R_lt 0). -apply Rmult_lt_reg_r with (Z2R y). -now apply (Z2R_lt 0). +now apply IZR_lt. +apply Rmult_lt_reg_r with (IZR y). +now apply IZR_lt. rewrite Rmult_1_l, Rmult_assoc, Rinv_l, Rmult_1_r. -apply Z2R_lt. +apply IZR_lt. eapply Z_mod_lt. -now apply Zlt_gt. +now apply Z.lt_gt. apply Rgt_not_eq. -now apply (Z2R_lt 0). +now apply IZR_lt. (* . *) destruct (Z_lt_le_dec y 0) as [Hy|Hy]. rewrite <- Rmult_opp_opp. rewrite Ropp_inv_permute with (1 := Zy'). -rewrite <- 2!Z2R_opp. +rewrite <- 2!opp_IZR. rewrite <- Zmod_opp_opp. apply H. clear -Hy. omega. @@ -1432,7 +1310,7 @@ apply H. clear -Zy Hy. omega. (* *) split. -pattern (Z2R (x / y)) at 1 ; rewrite <- Rplus_0_r. +pattern (IZR (x / y)) at 1 ; rewrite <- Rplus_0_r. apply Rplus_le_compat_l. apply H. apply Rplus_lt_compat_l. @@ -1445,11 +1323,11 @@ Section pow. Variable r : radix. -Theorem radix_pos : (0 < Z2R r)%R. +Theorem radix_pos : (0 < IZR r)%R. Proof. destruct r as (v, Hr). simpl. -apply (Z2R_lt 0). -apply Zlt_le_trans with 2%Z. +apply IZR_lt. +apply Z.lt_le_trans with 2%Z. easy. now apply Zle_bool_imp_le. Qed. @@ -1457,14 +1335,14 @@ Qed. (** Well-used function called bpow for computing the power function #β#^e *) Definition bpow e := match e with - | Zpos p => Z2R (Zpower_pos r p) - | Zneg p => Rinv (Z2R (Zpower_pos r p)) + | Zpos p => IZR (Zpower_pos r p) + | Zneg p => Rinv (IZR (Zpower_pos r p)) | Z0 => 1%R end. -Theorem Z2R_Zpower_pos : +Theorem IZR_Zpower_pos : forall n m, - Z2R (Zpower_pos n m) = powerRZ (Z2R n) (Zpos m). + IZR (Zpower_pos n m) = powerRZ (IZR n) (Zpos m). Proof. intros. rewrite Zpower_pos_nat. @@ -1473,19 +1351,19 @@ induction (nat_of_P m). apply refl_equal. unfold Zpower_nat. simpl. -rewrite Z2R_mult. +rewrite mult_IZR. apply Rmult_eq_compat_l. exact IHn0. Qed. Theorem bpow_powerRZ : forall e, - bpow e = powerRZ (Z2R r) e. + bpow e = powerRZ (IZR r) e. Proof. destruct e ; unfold bpow. reflexivity. -now rewrite Z2R_Zpower_pos. -now rewrite Z2R_Zpower_pos. +now rewrite IZR_Zpower_pos. +now rewrite IZR_Zpower_pos. Qed. Theorem bpow_ge_0 : @@ -1517,14 +1395,14 @@ apply radix_pos. Qed. Theorem bpow_1 : - bpow 1 = Z2R r. + bpow 1 = IZR r. Proof. unfold bpow, Zpower_pos. simpl. now rewrite Zmult_1_r. Qed. -Theorem bpow_plus1 : - forall e : Z, (bpow (e + 1) = Z2R r * bpow e)%R. +Theorem bpow_plus_1 : + forall e : Z, (bpow (e + 1) = IZR r * bpow e)%R. Proof. intros. rewrite <- bpow_1. @@ -1544,9 +1422,9 @@ apply Rgt_not_eq. apply (bpow_gt_0 (Zpos p)). Qed. -Theorem Z2R_Zpower_nat : +Theorem IZR_Zpower_nat : forall e : nat, - Z2R (Zpower_nat r e) = bpow (Z_of_nat e). + IZR (Zpower_nat r e) = bpow (Z_of_nat e). Proof. intros [|e]. split. @@ -1555,10 +1433,10 @@ rewrite <- Zpower_pos_nat. now rewrite <- Zpos_eq_Z_of_nat_o_nat_of_P. Qed. -Theorem Z2R_Zpower : +Theorem IZR_Zpower : forall e : Z, (0 <= e)%Z -> - Z2R (Zpower r e) = bpow e. + IZR (Zpower r e) = bpow e. Proof. intros [|e|e] H. split. @@ -1579,8 +1457,8 @@ apply bpow_gt_0. assert (0 < e2 - e1)%Z by omega. destruct (e2 - e1)%Z ; try discriminate H0. clear. -rewrite <- Z2R_Zpower by easy. -apply (Z2R_lt 1). +rewrite <- IZR_Zpower by easy. +apply IZR_lt. now apply Zpower_gt_1. Qed. @@ -1589,7 +1467,7 @@ Theorem lt_bpow : (bpow e1 < bpow e2)%R -> (e1 < e2)%Z. Proof. intros e1 e2 H. -apply Zgt_lt. +apply Z.gt_lt. apply Znot_le_gt. intros H'. apply Rlt_not_le with (1 := H). @@ -1608,7 +1486,7 @@ intros e1 e2 H. apply Rnot_lt_le. intros H'. apply Zle_not_gt with (1 := H). -apply Zlt_gt. +apply Z.lt_gt. now apply lt_bpow. Qed. @@ -1621,7 +1499,7 @@ apply Znot_gt_le. intros H'. apply Rle_not_lt with (1 := H). apply bpow_lt. -now apply Zgt_lt. +now apply Z.gt_lt. Qed. Theorem bpow_inj : @@ -1638,15 +1516,15 @@ Qed. Theorem bpow_exp : forall e : Z, - bpow e = exp (Z2R e * ln (Z2R r)). + bpow e = exp (IZR e * ln (IZR r)). Proof. (* positive case *) -assert (forall e, bpow (Zpos e) = exp (Z2R (Zpos e) * ln (Z2R r))). +assert (forall e, bpow (Zpos e) = exp (IZR (Zpos e) * ln (IZR r))). intros e. unfold bpow. rewrite Zpower_pos_nat. -unfold Z2R at 2. -rewrite P2R_INR. +rewrite <- positive_nat_Z. +rewrite <- INR_IZR_INZ. induction (nat_of_P e). rewrite Rmult_0_l. now rewrite exp_0. @@ -1657,7 +1535,7 @@ rewrite exp_plus. rewrite Rmult_1_l. rewrite exp_ln. rewrite <- IHn. -rewrite <- Z2R_mult. +rewrite <- mult_IZR. now rewrite Zmult_comm. apply radix_pos. (* general case *) @@ -1666,31 +1544,50 @@ rewrite Rmult_0_l. now rewrite exp_0. apply H. unfold bpow. -change (Z2R (Zpower_pos r e)) with (bpow (Zpos e)). +change (IZR (Zpower_pos r e)) with (bpow (Zpos e)). rewrite H. rewrite <- exp_Ropp. rewrite <- Ropp_mult_distr_l_reverse. -now rewrite <- Z2R_opp. +now rewrite <- opp_IZR. +Qed. + +Lemma sqrt_bpow : + forall e, + sqrt (bpow (2 * e)) = bpow e. +Proof. +intro e. +change 2%Z with (1 + 1)%Z; rewrite Z.mul_add_distr_r, Z.mul_1_l, bpow_plus. +apply sqrt_square, bpow_ge_0. Qed. -(** Another well-used function for having the logarithm of a real number x to the base #β# *) -Record ln_beta_prop x := { - ln_beta_val :> Z ; - _ : (x <> 0)%R -> (bpow (ln_beta_val - 1)%Z <= Rabs x < bpow ln_beta_val)%R +Lemma sqrt_bpow_ge : + forall e, + (bpow (e / 2) <= sqrt (bpow e))%R. +Proof. +intro e. +rewrite <- (sqrt_square (bpow _)); [|now apply bpow_ge_0]. +apply sqrt_le_1_alt; rewrite <- bpow_plus; apply bpow_le. +now replace (_ + _)%Z with (2 * (e / 2))%Z by ring; apply Z_mult_div_ge. +Qed. + +(** Another well-used function for having the magnitude of a real number x to the base #β# *) +Record mag_prop x := { + mag_val :> Z ; + _ : (x <> 0)%R -> (bpow (mag_val - 1)%Z <= Rabs x < bpow mag_val)%R }. -Definition ln_beta : - forall x : R, ln_beta_prop x. +Definition mag : + forall x : R, mag_prop x. Proof. intros x. -set (fact := ln (Z2R r)). +set (fact := ln (IZR r)). (* . *) assert (0 < fact)%R. apply exp_lt_inv. rewrite exp_0. unfold fact. rewrite exp_ln. -apply (Z2R_lt 1). +apply IZR_lt. apply radix_gt_1. apply radix_pos. (* . *) @@ -1703,19 +1600,19 @@ rewrite 2!bpow_exp. fold fact. pattern x at 2 3 ; replace x with (exp (ln x * / fact * fact)). split. -rewrite Z2R_minus. +rewrite minus_IZR. apply exp_le. apply Rmult_le_compat_r. now apply Rlt_le. unfold Rminus. -rewrite Z2R_plus. +rewrite plus_IZR. rewrite Rplus_assoc. rewrite Rplus_opp_r, Rplus_0_r. apply Zfloor_lb. apply exp_increasing. apply Rmult_lt_compat_r. exact H. -rewrite Z2R_plus. +rewrite plus_IZR. apply Zfloor_ub. rewrite Rmult_assoc. rewrite Rinv_l. @@ -1748,55 +1645,55 @@ apply Zle_antisym ; assumption. Qed. -Theorem ln_beta_unique : +Theorem mag_unique : forall (x : R) (e : Z), (bpow (e - 1) <= Rabs x < bpow e)%R -> - ln_beta x = e :> Z. + mag x = e :> Z. Proof. intros x e1 He. destruct (Req_dec x 0) as [Hx|Hx]. elim Rle_not_lt with (1 := proj1 He). rewrite Hx, Rabs_R0. apply bpow_gt_0. -destruct (ln_beta x) as (e2, Hx2). +destruct (mag x) as (e2, Hx2). simpl. apply bpow_unique with (2 := He). now apply Hx2. Qed. -Theorem ln_beta_opp : +Theorem mag_opp : forall x, - ln_beta (-x) = ln_beta x :> Z. + mag (-x) = mag x :> Z. Proof. intros x. destruct (Req_dec x 0) as [Hx|Hx]. now rewrite Hx, Ropp_0. -destruct (ln_beta x) as (e, He). +destruct (mag x) as (e, He). simpl. specialize (He Hx). -apply ln_beta_unique. +apply mag_unique. now rewrite Rabs_Ropp. Qed. -Theorem ln_beta_abs : +Theorem mag_abs : forall x, - ln_beta (Rabs x) = ln_beta x :> Z. + mag (Rabs x) = mag x :> Z. Proof. intros x. unfold Rabs. case Rcase_abs ; intros _. -apply ln_beta_opp. +apply mag_opp. apply refl_equal. Qed. -Theorem ln_beta_unique_pos : +Theorem mag_unique_pos : forall (x : R) (e : Z), (bpow (e - 1) <= x < bpow e)%R -> - ln_beta x = e :> Z. + mag x = e :> Z. Proof. intros x e1 He1. -rewrite <- ln_beta_abs. -apply ln_beta_unique. +rewrite <- mag_abs. +apply mag_unique. rewrite 2!Rabs_pos_eq. exact He1. apply Rle_trans with (2 := proj1 He1). @@ -1804,14 +1701,14 @@ apply bpow_ge_0. apply Rabs_pos. Qed. -Theorem ln_beta_le_abs : +Theorem mag_le_abs : forall x y, (x <> 0)%R -> (Rabs x <= Rabs y)%R -> - (ln_beta x <= ln_beta y)%Z. + (mag x <= mag y)%Z. Proof. intros x y H0x Hxy. -destruct (ln_beta x) as (ex, Hx). -destruct (ln_beta y) as (ey, Hy). +destruct (mag x) as (ex, Hx). +destruct (mag y) as (ey, Hy). simpl. apply bpow_lt_bpow. specialize (Hx H0x). @@ -1825,13 +1722,13 @@ rewrite Hy', Rabs_R0. apply Rle_refl. Qed. -Theorem ln_beta_le : +Theorem mag_le : forall x y, (0 < x)%R -> (x <= y)%R -> - (ln_beta x <= ln_beta y)%Z. + (mag x <= mag y)%Z. Proof. intros x y H0x Hxy. -apply ln_beta_le_abs. +apply mag_le_abs. now apply Rgt_not_eq. rewrite 2!Rabs_pos_eq. exact Hxy. @@ -1840,17 +1737,17 @@ now apply Rlt_le. now apply Rlt_le. Qed. -Lemma ln_beta_lt_pos : +Lemma lt_mag : forall x y, (0 < y)%R -> - (ln_beta x < ln_beta y)%Z -> (x < y)%R. + (mag x < mag y)%Z -> (x < y)%R. Proof. intros x y Py. case (Rle_or_lt x 0); intros Px. intros H. now apply Rle_lt_trans with 0%R. -destruct (ln_beta x) as (ex, Hex). -destruct (ln_beta y) as (ey, Hey). +destruct (mag x) as (ex, Hex). +destruct (mag y) as (ey, Hey). simpl. intro H. destruct Hex as (_,Hex); [now apply Rgt_not_eq|]. @@ -1862,11 +1759,11 @@ apply Rle_trans with (bpow (ey - 1)); [|exact Hey]. now apply bpow_le; omega. Qed. -Theorem ln_beta_bpow : - forall e, (ln_beta (bpow e) = e + 1 :> Z)%Z. +Theorem mag_bpow : + forall e, (mag (bpow e) = e + 1 :> Z)%Z. Proof. intros e. -apply ln_beta_unique. +apply mag_unique. rewrite Rabs_right. replace (e + 1 - 1)%Z with e by ring. split. @@ -1877,14 +1774,14 @@ apply Rle_ge. apply bpow_ge_0. Qed. -Theorem ln_beta_mult_bpow : +Theorem mag_mult_bpow : forall x e, x <> 0%R -> - (ln_beta (x * bpow e) = ln_beta x + e :>Z)%Z. + (mag (x * bpow e) = mag x + e :>Z)%Z. Proof. intros x e Zx. -destruct (ln_beta x) as (ex, Ex) ; simpl. +destruct (mag x) as (ex, Ex) ; simpl. specialize (Ex Zx). -apply ln_beta_unique. +apply mag_unique. rewrite Rabs_mult. rewrite (Rabs_pos_eq (bpow e)) by apply bpow_ge_0. split. @@ -1899,26 +1796,26 @@ apply bpow_gt_0. apply Ex. Qed. -Theorem ln_beta_le_bpow : +Theorem mag_le_bpow : forall x e, x <> 0%R -> (Rabs x < bpow e)%R -> - (ln_beta x <= e)%Z. + (mag x <= e)%Z. Proof. intros x e Zx Hx. -destruct (ln_beta x) as (ex, Ex) ; simpl. +destruct (mag x) as (ex, Ex) ; simpl. specialize (Ex Zx). apply bpow_lt_bpow. now apply Rle_lt_trans with (Rabs x). Qed. -Theorem ln_beta_gt_bpow : +Theorem mag_gt_bpow : forall x e, (bpow e <= Rabs x)%R -> - (e < ln_beta x)%Z. + (e < mag x)%Z. Proof. intros x e Hx. -destruct (ln_beta x) as (ex, Ex) ; simpl. +destruct (mag x) as (ex, Ex) ; simpl. apply lt_bpow. apply Rle_lt_trans with (1 := Hx). apply Ex. @@ -1928,92 +1825,92 @@ rewrite Zx, Rabs_R0. apply bpow_gt_0. Qed. -Theorem ln_beta_ge_bpow : +Theorem mag_ge_bpow : forall x e, (bpow (e - 1) <= Rabs x)%R -> - (e <= ln_beta x)%Z. + (e <= mag x)%Z. Proof. intros x e H. destruct (Rlt_or_le (Rabs x) (bpow e)) as [Hxe|Hxe]. - (* Rabs x w bpow e *) - assert (ln_beta x = e :> Z) as Hln. - now apply ln_beta_unique; split. + assert (mag x = e :> Z) as Hln. + now apply mag_unique; split. rewrite Hln. now apply Z.le_refl. - (* bpow e <= Rabs x *) apply Zlt_le_weak. - now apply ln_beta_gt_bpow. + now apply mag_gt_bpow. Qed. -Theorem bpow_ln_beta_gt : +Theorem bpow_mag_gt : forall x, - (Rabs x < bpow (ln_beta x))%R. + (Rabs x < bpow (mag x))%R. Proof. intros x. destruct (Req_dec x 0) as [Zx|Zx]. rewrite Zx, Rabs_R0. apply bpow_gt_0. -destruct (ln_beta x) as (ex, Ex) ; simpl. +destruct (mag x) as (ex, Ex) ; simpl. now apply Ex. Qed. -Theorem bpow_ln_beta_le : +Theorem bpow_mag_le : forall x, (x <> 0)%R -> - (bpow (ln_beta x-1) <= Rabs x)%R. + (bpow (mag x-1) <= Rabs x)%R. Proof. intros x Hx. -destruct (ln_beta x) as (ex, Ex) ; simpl. +destruct (mag x) as (ex, Ex) ; simpl. now apply Ex. Qed. -Theorem ln_beta_le_Zpower : +Theorem mag_le_Zpower : forall m e, m <> Z0 -> - (Zabs m < Zpower r e)%Z-> - (ln_beta (Z2R m) <= e)%Z. + (Z.abs m < Zpower r e)%Z-> + (mag (IZR m) <= e)%Z. Proof. intros m e Zm Hm. -apply ln_beta_le_bpow. -exact (Z2R_neq m 0 Zm). +apply mag_le_bpow. +now apply IZR_neq. destruct (Zle_or_lt 0 e). -rewrite <- Z2R_abs, <- Z2R_Zpower with (1 := H). -now apply Z2R_lt. +rewrite <- abs_IZR, <- IZR_Zpower with (1 := H). +now apply IZR_lt. elim Zm. -cut (Zabs m < 0)%Z. +cut (Z.abs m < 0)%Z. now case m. clear -Hm H. now destruct e. Qed. -Theorem ln_beta_gt_Zpower : +Theorem mag_gt_Zpower : forall m e, m <> Z0 -> - (Zpower r e <= Zabs m)%Z -> - (e < ln_beta (Z2R m))%Z. + (Zpower r e <= Z.abs m)%Z -> + (e < mag (IZR m))%Z. Proof. intros m e Zm Hm. -apply ln_beta_gt_bpow. -rewrite <- Z2R_abs. +apply mag_gt_bpow. +rewrite <- abs_IZR. destruct (Zle_or_lt 0 e). -rewrite <- Z2R_Zpower with (1 := H). -now apply Z2R_le. +rewrite <- IZR_Zpower with (1 := H). +now apply IZR_le. apply Rle_trans with (bpow 0). apply bpow_le. now apply Zlt_le_weak. -apply (Z2R_le 1). +apply IZR_le. clear -Zm. zify ; omega. Qed. -Lemma ln_beta_mult : +Lemma mag_mult : forall x y, (x <> 0)%R -> (y <> 0)%R -> - (ln_beta x + ln_beta y - 1 <= ln_beta (x * y) <= ln_beta x + ln_beta y)%Z. + (mag x + mag y - 1 <= mag (x * y) <= mag x + mag y)%Z. Proof. intros x y Hx Hy. -destruct (ln_beta x) as (ex, Hx2). -destruct (ln_beta y) as (ey, Hy2). +destruct (mag x) as (ex, Hx2). +destruct (mag y) as (ey, Hy2). simpl. destruct (Hx2 Hx) as (Hx21,Hx22); clear Hx2. destruct (Hy2 Hy) as (Hy21,Hy22); clear Hy2. @@ -2029,26 +1926,26 @@ assert (Hxy2 : (Rabs (x * y) < bpow (ex + ey))%R). now apply Rle_trans with (bpow (ex - 1)); try apply bpow_ge_0. now apply Rle_trans with (bpow (ey - 1)); try apply bpow_ge_0. } split. -- now apply ln_beta_ge_bpow. -- apply ln_beta_le_bpow. +- now apply mag_ge_bpow. +- apply mag_le_bpow. + now apply Rmult_integral_contrapositive_currified. + assumption. Qed. -Lemma ln_beta_plus : +Lemma mag_plus : forall x y, (0 < y)%R -> (y <= x)%R -> - (ln_beta x <= ln_beta (x + y) <= ln_beta x + 1)%Z. + (mag x <= mag (x + y) <= mag x + 1)%Z. Proof. assert (Hr : (2 <= r)%Z). { destruct r as (beta_val,beta_prop). now apply Zle_bool_imp_le. } intros x y Hy Hxy. assert (Hx : (0 < x)%R) by apply (Rlt_le_trans _ _ _ Hy Hxy). -destruct (ln_beta x) as (ex,Hex); simpl. +destruct (mag x) as (ex,Hex); simpl. destruct Hex as (Hex0,Hex1); [now apply Rgt_not_eq|]. assert (Haxy : (Rabs (x + y) < bpow (ex + 1))%R). -{ rewrite bpow_plus1. +{ rewrite bpow_plus_1. apply Rlt_le_trans with (2 * bpow ex)%R. - rewrite Rabs_pos_eq. apply Rle_lt_trans with (2 * Rabs x)%R. @@ -2062,7 +1959,7 @@ assert (Haxy : (Rabs (x + y) < bpow (ex + 1))%R). now apply Rlt_le, Rplus_lt_compat. - apply Rmult_le_compat_r. now apply bpow_ge_0. - now apply (Z2R_le 2). } + now apply IZR_le. } assert (Haxy2 : (bpow (ex - 1) <= Rabs (x + y))%R). { apply (Rle_trans _ _ _ Hex0). rewrite Rabs_right; [|now apply Rgt_ge]. @@ -2071,20 +1968,20 @@ assert (Haxy2 : (bpow (ex - 1) <= Rabs (x + y))%R). apply Rplus_le_compat_l. now apply Rlt_le. } split. -- now apply ln_beta_ge_bpow. -- apply ln_beta_le_bpow. +- now apply mag_ge_bpow. +- apply mag_le_bpow. + now apply tech_Rplus; [apply Rlt_le|]. + exact Haxy. Qed. -Lemma ln_beta_minus : +Lemma mag_minus : forall x y, (0 < y)%R -> (y < x)%R -> - (ln_beta (x - y) <= ln_beta x)%Z. + (mag (x - y) <= mag x)%Z. Proof. intros x y Py Hxy. assert (Px : (0 < x)%R) by apply (Rlt_trans _ _ _ Py Hxy). -apply ln_beta_le. +apply mag_le. - now apply Rlt_Rminus. - rewrite <- (Rplus_0_r x) at 2. apply Rplus_le_compat_l. @@ -2092,19 +1989,19 @@ apply ln_beta_le. now apply Ropp_le_contravar; apply Rlt_le. Qed. -Lemma ln_beta_minus_lb : +Lemma mag_minus_lb : forall x y, (0 < x)%R -> (0 < y)%R -> - (ln_beta y <= ln_beta x - 2)%Z -> - (ln_beta x - 1 <= ln_beta (x - y))%Z. + (mag y <= mag x - 2)%Z -> + (mag x - 1 <= mag (x - y))%Z. Proof. assert (Hbeta : (2 <= r)%Z). { destruct r as (beta_val,beta_prop). now apply Zle_bool_imp_le. } intros x y Px Py Hln. -assert (Oxy : (y < x)%R); [apply ln_beta_lt_pos;[assumption|omega]|]. -destruct (ln_beta x) as (ex,Hex). -destruct (ln_beta y) as (ey,Hey). +assert (Oxy : (y < x)%R); [apply lt_mag;[assumption|omega]|]. +destruct (mag x) as (ex,Hex). +destruct (mag y) as (ey,Hey). simpl in Hln |- *. destruct Hex as (Hex,_); [now apply Rgt_not_eq|]. destruct Hey as (_,Hey); [now apply Rgt_not_eq|]. @@ -2112,9 +2009,9 @@ assert (Hbx : (bpow (ex - 2) + bpow (ex - 2) <= x)%R). { ring_simplify. apply Rle_trans with (bpow (ex - 1)). - replace (ex - 1)%Z with (ex - 2 + 1)%Z by ring. - rewrite bpow_plus1. + rewrite bpow_plus_1. apply Rmult_le_compat_r; [now apply bpow_ge_0|]. - now change 2%R with (Z2R 2); apply Z2R_le. + now apply IZR_le. - now rewrite Rabs_right in Hex; [|apply Rle_ge; apply Rlt_le]. } assert (Hby : (y < bpow (ex - 2))%R). { apply Rlt_le_trans with (bpow ey). @@ -2126,98 +2023,95 @@ assert (Hbxy : (bpow (ex - 2) <= x - y)%R). replace (bpow (ex - 2))%R with (bpow (ex - 2) + bpow (ex - 2) - bpow (ex - 2))%R by ring. now apply Rplus_le_compat. } -apply ln_beta_ge_bpow. +apply mag_ge_bpow. replace (ex - 1 - 1)%Z with (ex - 2)%Z by ring. now apply Rabs_ge; right. Qed. -Lemma ln_beta_div : +Lemma mag_div : forall x y : R, - (0 < x)%R -> (0 < y)%R -> - (ln_beta x - ln_beta y <= ln_beta (x / y) <= ln_beta x - ln_beta y + 1)%Z. + x <> 0%R -> y <> 0%R -> + (mag x - mag y <= mag (x / y) <= mag x - mag y + 1)%Z. Proof. intros x y Px Py. -destruct (ln_beta x) as (ex,Hex). -destruct (ln_beta y) as (ey,Hey). +destruct (mag x) as (ex,Hex). +destruct (mag y) as (ey,Hey). simpl. unfold Rdiv. -rewrite Rabs_right in Hex; [|now apply Rle_ge; apply Rlt_le]. -rewrite Rabs_right in Hey; [|now apply Rle_ge; apply Rlt_le]. -assert (Heiy : (bpow (- ey) < / y <= bpow (- ey + 1))%R). -{ split. +assert (Heiy : (bpow (- ey) < Rabs (/ y) <= bpow (- ey + 1))%R). +{ rewrite Rabs_Rinv by easy. + split. - rewrite bpow_opp. apply Rinv_lt_contravar. - + apply Rmult_lt_0_compat; [exact Py|]. + + apply Rmult_lt_0_compat. + now apply Rabs_pos_lt. now apply bpow_gt_0. - + apply Hey. - now apply Rgt_not_eq. + + now apply Hey. - replace (_ + _)%Z with (- (ey - 1))%Z by ring. rewrite bpow_opp. apply Rinv_le; [now apply bpow_gt_0|]. - apply Hey. - now apply Rgt_not_eq. } + now apply Hey. } split. -- apply ln_beta_ge_bpow. - apply Rabs_ge; right. +- apply mag_ge_bpow. replace (_ - _)%Z with (ex - 1 - ey)%Z by ring. unfold Zminus at 1; rewrite bpow_plus. + rewrite Rabs_mult. apply Rmult_le_compat. + now apply bpow_ge_0. + now apply bpow_ge_0. - + apply Hex. - now apply Rgt_not_eq. - + apply Rlt_le; apply Heiy. -- assert (Pxy : (0 < x * / y)%R). - { apply Rmult_lt_0_compat; [exact Px|]. - now apply Rinv_0_lt_compat. } - apply ln_beta_le_bpow. - + now apply Rgt_not_eq. - + rewrite Rabs_right; [|now apply Rle_ge; apply Rlt_le]. - replace (_ + 1)%Z with (ex + (- ey + 1))%Z by ring. + + now apply Hex. + + now apply Rlt_le; apply Heiy. +- apply mag_le_bpow. + + apply Rmult_integral_contrapositive_currified. + exact Px. + now apply Rinv_neq_0_compat. + + replace (_ + 1)%Z with (ex + (- ey + 1))%Z by ring. rewrite bpow_plus. - apply Rlt_le_trans with (bpow ex * / y)%R. - * apply Rmult_lt_compat_r; [now apply Rinv_0_lt_compat|]. - apply Hex. - now apply Rgt_not_eq. + apply Rlt_le_trans with (bpow ex * Rabs (/ y))%R. + * rewrite Rabs_mult. + apply Rmult_lt_compat_r. + apply Rabs_pos_lt. + now apply Rinv_neq_0_compat. + now apply Hex. * apply Rmult_le_compat_l; [now apply bpow_ge_0|]. apply Heiy. Qed. -Lemma ln_beta_sqrt : +Lemma mag_sqrt : forall x, (0 < x)%R -> - (2 * ln_beta (sqrt x) - 1 <= ln_beta x <= 2 * ln_beta (sqrt x))%Z. + mag (sqrt x) = Z.div2 (mag x + 1) :> Z. Proof. intros x Px. -assert (H : (bpow (2 * ln_beta (sqrt x) - 1 - 1) <= Rabs x - < bpow (2 * ln_beta (sqrt x)))%R). -{ split. - - apply Rge_le; rewrite <- (sqrt_def x) at 1; - [|now apply Rlt_le]; apply Rle_ge. - rewrite Rabs_mult. - replace (_ - _)%Z with (ln_beta (sqrt x) - 1 - + (ln_beta (sqrt x) - 1))%Z by ring. - rewrite bpow_plus. - assert (H : (bpow (ln_beta (sqrt x) - 1) <= Rabs (sqrt x))%R). - { destruct (ln_beta (sqrt x)) as (esx,Hesx); simpl. - apply Hesx. - apply Rgt_not_eq; apply Rlt_gt. - now apply sqrt_lt_R0. } - now apply Rmult_le_compat; [now apply bpow_ge_0|now apply bpow_ge_0| |]. - - rewrite <- (sqrt_def x) at 1; [|now apply Rlt_le]. - rewrite Rabs_mult. - change 2%Z with (1 + 1)%Z; rewrite Zmult_plus_distr_l; - rewrite Zmult_1_l. - rewrite bpow_plus. - assert (H : (Rabs (sqrt x) < bpow (ln_beta (sqrt x)))%R). - { destruct (ln_beta (sqrt x)) as (esx,Hesx); simpl. - apply Hesx. - apply Rgt_not_eq; apply Rlt_gt. - now apply sqrt_lt_R0. } - now apply Rmult_lt_compat; [now apply Rabs_pos|now apply Rabs_pos| |]. } +apply mag_unique. +destruct mag as [e He]. +simpl. +specialize (He (Rgt_not_eq _ _ Px)). +rewrite Rabs_pos_eq in He by now apply Rlt_le. split. -- now apply ln_beta_ge_bpow. -- now apply ln_beta_le_bpow; [now apply Rgt_not_eq|]. +- rewrite <- (Rabs_pos_eq (bpow _)) by apply bpow_ge_0. + apply Rsqr_le_abs_0. + rewrite Rsqr_sqrt by now apply Rlt_le. + apply Rle_trans with (2 := proj1 He). + unfold Rsqr ; rewrite <- bpow_plus. + apply bpow_le. + generalize (Zdiv2_odd_eqn (e + 1)). + destruct Z.odd ; intros ; omega. +- rewrite <- (Rabs_pos_eq (bpow _)) by apply bpow_ge_0. + apply Rsqr_lt_abs_0. + rewrite Rsqr_sqrt by now apply Rlt_le. + apply Rlt_le_trans with (1 := proj2 He). + unfold Rsqr ; rewrite <- bpow_plus. + apply bpow_le. + generalize (Zdiv2_odd_eqn (e + 1)). + destruct Z.odd ; intros ; omega. +Qed. + +Lemma mag_1 : mag 1 = 1%Z :> Z. +Proof. +apply mag_unique_pos; rewrite bpow_1; simpl; split; [now right|apply IZR_lt]. +assert (H := Zle_bool_imp_le _ _ (radix_prop r)); revert H. +now apply Z.lt_le_trans. Qed. End pow. @@ -2248,12 +2142,12 @@ Section cond_Ropp. Definition cond_Ropp (b : bool) m := if b then Ropp m else m. -Theorem Z2R_cond_Zopp : +Theorem IZR_cond_Zopp : forall b m, - Z2R (cond_Zopp b m) = cond_Ropp b (Z2R m). + IZR (cond_Zopp b m) = cond_Ropp b (IZR m). Proof. intros [|] m. -apply Z2R_opp. +apply opp_IZR. apply refl_equal. Qed. @@ -2286,22 +2180,6 @@ apply Ropp_involutive. apply refl_equal. Qed. -Theorem cond_Ropp_even_function : - forall {A : Type} (f : R -> A), - (forall x, f (Ropp x) = f x) -> - forall b x, f (cond_Ropp b x) = f x. -Proof. -now intros A f Hf [|] x ; simpl. -Qed. - -Theorem cond_Ropp_odd_function : - forall (f : R -> R), - (forall x, f (Ropp x) = Ropp (f x)) -> - forall b x, f (cond_Ropp b x) = cond_Ropp b (f x). -Proof. -now intros f Hf [|] x ; simpl. -Qed. - Theorem cond_Ropp_inj : forall b x y, cond_Ropp b x = cond_Ropp b y -> x = y. @@ -2391,7 +2269,7 @@ destruct (Rle_lt_dec l 0) as [Hl|Hl]. apply ub. now apply HE. left. -set (N := Zabs_nat (up (/l) - 2)). +set (N := Z.abs_nat (up (/l) - 2)). exists N. assert (HN: (INR N + 1 = IZR (up (/ l)) - 1)%R). unfold N. @@ -2399,7 +2277,7 @@ assert (HN: (INR N + 1 = IZR (up (/ l)) - 1)%R). rewrite inj_Zabs_nat. replace (IZR (up (/ l)) - 1)%R with (IZR (up (/ l) - 2) + 1)%R. apply (f_equal (fun v => IZR v + 1)%R). - apply Zabs_eq. + apply Z.abs_eq. apply Zle_minus_le_0. apply (Zlt_le_succ 1). apply lt_IZR. @@ -2484,10 +2362,10 @@ intros n; apply H. destruct K as (n, Hn). left; now exists (-Z.of_nat n)%Z. right; intros n; case (Zle_or_lt 0 n); intros M. -rewrite <- (Zabs_eq n); trivial. +rewrite <- (Z.abs_eq n); trivial. rewrite <- Zabs2Nat.id_abs. apply J. -rewrite <- (Zopp_involutive n). +rewrite <- (Z.opp_involutive n). rewrite <- (Z.abs_neq n). rewrite <- Zabs2Nat.id_abs. apply K. diff --git a/flocq/Core/Fcore_rnd_ne.v b/flocq/Core/Round_NE.v index 2d67e709..20b60ef5 100644 --- a/flocq/Core/Fcore_rnd_ne.v +++ b/flocq/Core/Round_NE.v @@ -2,9 +2,9 @@ This file is part of the Flocq formalization of floating-point arithmetic in Coq: http://flocq.gforge.inria.fr/ -Copyright (C) 2010-2013 Sylvie Boldo +Copyright (C) 2009-2018 Sylvie Boldo #<br /># -Copyright (C) 2010-2013 Guillaume Melquiond +Copyright (C) 2009-2018 Guillaume Melquiond This library is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public @@ -18,14 +18,9 @@ COPYING file for more details. *) (** * Rounding to nearest, ties to even: existence, unicity... *) -Require Import Fcore_Raux. -Require Import Fcore_defs. -Require Import Fcore_rnd. -Require Import Fcore_generic_fmt. -Require Import Fcore_float_prop. -Require Import Fcore_ulp. +Require Import Raux Defs Round_pred Generic_fmt Float_prop Ulp. -Notation ZnearestE := (Znearest (fun x => negb (Zeven x))). +Notation ZnearestE := (Znearest (fun x => negb (Z.even x))). Section Fcore_rnd_NE. @@ -38,10 +33,10 @@ Variable fexp : Z -> Z. Context { valid_exp : Valid_exp fexp }. Notation format := (generic_format beta fexp). -Notation canonic := (canonic beta fexp). +Notation canonical := (canonical beta fexp). Definition NE_prop (_ : R) f := - exists g : float beta, f = F2R g /\ canonic g /\ Zeven (Fnum g) = true. + exists g : float beta, f = F2R g /\ canonical g /\ Z.even (Fnum g) = true. Definition Rnd_NE_pt := Rnd_NG_pt format NE_prop. @@ -50,20 +45,20 @@ Definition DN_UP_parity_pos_prop := forall x xd xu, (0 < x)%R -> ~ format x -> - canonic xd -> - canonic xu -> + canonical xd -> + canonical xu -> F2R xd = round beta fexp Zfloor x -> F2R xu = round beta fexp Zceil x -> - Zeven (Fnum xu) = negb (Zeven (Fnum xd)). + Z.even (Fnum xu) = negb (Z.even (Fnum xd)). Definition DN_UP_parity_prop := forall x xd xu, ~ format x -> - canonic xd -> - canonic xu -> + canonical xd -> + canonical xu -> F2R xd = round beta fexp Zfloor x -> F2R xu = round beta fexp Zceil x -> - Zeven (Fnum xu) = negb (Zeven (Fnum xd)). + Z.even (Fnum xu) = negb (Z.even (Fnum xd)). Lemma DN_UP_parity_aux : DN_UP_parity_pos_prop -> @@ -83,18 +78,18 @@ now rewrite Ropp_involutive, Ropp_0. destruct xd as (md, ed). destruct xu as (mu, eu). simpl. -rewrite <- (Bool.negb_involutive (Zeven mu)). +rewrite <- (Bool.negb_involutive (Z.even mu)). apply f_equal. apply sym_eq. -rewrite <- (Zeven_opp mu), <- (Zeven_opp md). -change (Zeven (Fnum (Float beta (-md) ed)) = negb (Zeven (Fnum (Float beta (-mu) eu)))). +rewrite <- (Z.even_opp mu), <- (Z.even_opp md). +change (Z.even (Fnum (Float beta (-md) ed)) = negb (Z.even (Fnum (Float beta (-mu) eu)))). apply (Hpos (-x)%R _ _ Hx'). intros H. apply Hfx. rewrite <- Ropp_involutive. now apply generic_format_opp. -now apply canonic_opp. -now apply canonic_opp. +now apply canonical_opp. +now apply canonical_opp. rewrite round_DN_opp, F2R_Zopp. now apply f_equal. rewrite round_UP_opp, F2R_Zopp. @@ -102,7 +97,7 @@ now apply f_equal. Qed. Class Exists_NE := - exists_NE : Zeven beta = false \/ forall e, + exists_NE : Z.even beta = false \/ forall e, ((fexp e < e)%Z -> (fexp (e + 1) < e)%Z) /\ ((e <= fexp e)%Z -> fexp (fexp e + 1) = fexp e). Context { exists_NE_ : Exists_NE }. @@ -111,22 +106,22 @@ Theorem DN_UP_parity_generic_pos : DN_UP_parity_pos_prop. Proof with auto with typeclass_instances. intros x xd xu H0x Hfx Hd Hu Hxd Hxu. -destruct (ln_beta beta x) as (ex, Hexa). +destruct (mag beta x) as (ex, Hexa). specialize (Hexa (Rgt_not_eq _ _ H0x)). generalize Hexa. intros Hex. rewrite (Rabs_pos_eq _ (Rlt_le _ _ H0x)) in Hex. destruct (Zle_or_lt ex (fexp ex)) as [Hxe|Hxe]. (* small x *) assert (Hd3 : Fnum xd = Z0). -apply F2R_eq_0_reg with beta (Fexp xd). +apply eq_0_F2R with beta (Fexp xd). change (F2R xd = R0). rewrite Hxd. apply round_DN_small_pos with (1 := Hex) (2 := Hxe). assert (Hu3 : xu = Float beta (1 * Zpower beta (fexp ex - fexp (fexp ex + 1))) (fexp (fexp ex + 1))). -apply canonic_unicity with (1 := Hu). +apply canonical_unique with (1 := Hu). apply (f_equal fexp). rewrite <- F2R_change_exp. -now rewrite F2R_bpow, ln_beta_bpow. +now rewrite F2R_bpow, mag_bpow. now apply valid_exp. rewrite <- F2R_change_exp. rewrite F2R_bpow. @@ -172,10 +167,10 @@ rewrite Hxu. apply round_bounded_large_pos... (* - xu = bpow ex *) assert (Hu3: xu = Float beta (1 * Zpower beta (ex - fexp (ex + 1))) (fexp (ex + 1))). -apply canonic_unicity with (1 := Hu). +apply canonical_unique with (1 := Hu). apply (f_equal fexp). rewrite <- F2R_change_exp. -now rewrite F2R_bpow, ln_beta_bpow. +now rewrite F2R_bpow, mag_bpow. now apply valid_exp. rewrite <- Hu2. apply sym_eq. @@ -185,15 +180,15 @@ exact Hxe2. assert (Hd3: xd = Float beta (Zpower beta (ex - fexp ex) - 1) (fexp ex)). assert (H: F2R xd = F2R (Float beta (Zpower beta (ex - fexp ex) - 1) (fexp ex))). unfold F2R. simpl. -rewrite Z2R_minus. +rewrite minus_IZR. unfold Rminus. rewrite Rmult_plus_distr_r. -rewrite Z2R_Zpower, <- bpow_plus. +rewrite IZR_Zpower, <- bpow_plus. ring_simplify (ex - fexp ex + fexp ex)%Z. rewrite Hu2, Hud. rewrite ulp_neq_0;[idtac|now apply Rgt_not_eq]. -unfold canonic_exp. -rewrite ln_beta_unique with beta x ex. +unfold cexp. +rewrite mag_unique with beta x ex. unfold F2R. simpl. ring. rewrite Rabs_pos_eq. @@ -201,25 +196,25 @@ exact Hex. now apply Rlt_le. apply Zle_minus_le_0. now apply Zlt_le_weak. -apply canonic_unicity with (1 := Hd) (3 := H). +apply canonical_unique with (1 := Hd) (3 := H). apply (f_equal fexp). rewrite <- H. apply sym_eq. -now apply ln_beta_unique. +now apply mag_unique. rewrite Hd3, Hu3. unfold Fnum. -rewrite Zeven_mult. simpl. +rewrite Z.even_mul. simpl. unfold Zminus at 2. -rewrite Zeven_plus. +rewrite Z.even_add. rewrite eqb_sym. simpl. -fold (negb (Zeven (beta ^ (ex - fexp ex)))). +fold (negb (Z.even (beta ^ (ex - fexp ex)))). rewrite Bool.negb_involutive. -rewrite (Zeven_Zpower beta (ex - fexp ex)). 2: omega. +rewrite (Z.even_pow beta (ex - fexp ex)). 2: omega. destruct exists_NE_. rewrite H. apply Zeven_Zpower_odd with (2 := H). now apply Zle_minus_le_0. -apply Zeven_Zpower. +apply Z.even_pow. specialize (H ex). omega. (* - xu < bpow ex *) @@ -227,17 +222,17 @@ revert Hud. rewrite ulp_neq_0;[idtac|now apply Rgt_not_eq]. unfold F2R. rewrite Hd, Hu. -unfold canonic_exp. -rewrite ln_beta_unique with beta (F2R xu) ex. -rewrite ln_beta_unique with (1 := Hd4). -rewrite ln_beta_unique with (1 := Hexa). +unfold cexp. +rewrite mag_unique with beta (F2R xu) ex. +rewrite mag_unique with (1 := Hd4). +rewrite mag_unique with (1 := Hexa). intros H. replace (Fnum xu) with (Fnum xd + 1)%Z. -rewrite Zeven_plus. +rewrite Z.even_add. now apply eqb_sym. apply sym_eq. -apply eq_Z2R. -rewrite Z2R_plus. +apply eq_IZR. +rewrite plus_IZR. apply Rmult_eq_reg_r with (bpow (fexp ex)). rewrite H. simpl. ring. @@ -270,38 +265,38 @@ now apply generic_format_satisfies_any. intros x d u Hf Hd Hu. generalize (proj1 Hd). unfold generic_format. -set (ed := canonic_exp beta fexp d). +set (ed := cexp beta fexp d). set (md := Ztrunc (scaled_mantissa beta fexp d)). intros Hd1. -case_eq (Zeven md) ; [ intros He | intros Ho ]. +case_eq (Z.even md) ; [ intros He | intros Ho ]. right. exists (Float beta md ed). -unfold Fcore_generic_fmt.canonic. +unfold Generic_fmt.canonical. rewrite <- Hd1. now repeat split. left. generalize (proj1 Hu). unfold generic_format. -set (eu := canonic_exp beta fexp u). +set (eu := cexp beta fexp u). set (mu := Ztrunc (scaled_mantissa beta fexp u)). intros Hu1. rewrite Hu1. eexists ; repeat split. -unfold Fcore_generic_fmt.canonic. +unfold Generic_fmt.canonical. now rewrite <- Hu1. rewrite (DN_UP_parity_generic x (Float beta md ed) (Float beta mu eu)). simpl. now rewrite Ho. exact Hf. -unfold Fcore_generic_fmt.canonic. +unfold Generic_fmt.canonical. now rewrite <- Hd1. -unfold Fcore_generic_fmt.canonic. +unfold Generic_fmt.canonical. now rewrite <- Hu1. rewrite <- Hd1. -apply Rnd_DN_pt_unicity with (1 := Hd). +apply Rnd_DN_pt_unique with (1 := Hd). now apply round_DN_pt. rewrite <- Hu1. -apply Rnd_UP_pt_unicity with (1 := Hu). +apply Rnd_UP_pt_unique with (1 := Hu). now apply round_UP_pt. Qed. @@ -323,15 +318,16 @@ apply Hx. apply sym_eq. now apply Rnd_DN_pt_idempotent with (1 := Hd). rewrite <- Hd1. -apply Rnd_DN_pt_unicity with (1 := Hd). +apply Rnd_DN_pt_unique with (1 := Hd). now apply round_DN_pt. rewrite <- Hu1. -apply Rnd_UP_pt_unicity with (1 := Hu). +apply Rnd_UP_pt_unique with (1 := Hu). now apply round_UP_pt. Qed. Theorem Rnd_NE_pt_round : round_pred Rnd_NE_pt. +Proof. split. apply Rnd_NE_pt_total. apply Rnd_NE_pt_monotone. @@ -348,14 +344,14 @@ now apply round_N_pt. unfold NE_prop. set (mx := scaled_mantissa beta fexp x). set (xr := round beta fexp ZnearestE x). -destruct (Req_dec (mx - Z2R (Zfloor mx)) (/2)) as [Hm|Hm]. +destruct (Req_dec (mx - IZR (Zfloor mx)) (/2)) as [Hm|Hm]. (* midpoint *) left. -exists (Float beta (Ztrunc (scaled_mantissa beta fexp xr)) (canonic_exp beta fexp xr)). +exists (Float beta (Ztrunc (scaled_mantissa beta fexp xr)) (cexp beta fexp xr)). split. apply round_N_pt... split. -unfold Fcore_generic_fmt.canonic. simpl. +unfold Generic_fmt.canonical. simpl. apply f_equal. apply round_N_pt... simpl. @@ -363,23 +359,22 @@ unfold xr, round, Znearest. fold mx. rewrite Hm. rewrite Rcompare_Eq. 2: apply refl_equal. -case_eq (Zeven (Zfloor mx)) ; intros Hmx. +case_eq (Z.even (Zfloor mx)) ; intros Hmx. (* . even floor *) -change (Zeven (Ztrunc (scaled_mantissa beta fexp (round beta fexp Zfloor x))) = true). +change (Z.even (Ztrunc (scaled_mantissa beta fexp (round beta fexp Zfloor x))) = true). destruct (Rle_or_lt (round beta fexp Zfloor x) 0) as [Hr|Hr]. rewrite (Rle_antisym _ _ Hr). unfold scaled_mantissa. rewrite Rmult_0_l. -change 0%R with (Z2R 0). -now rewrite (Ztrunc_Z2R 0). +now rewrite Ztrunc_IZR. rewrite <- (round_0 beta fexp Zfloor). apply round_le... now apply Rlt_le. rewrite scaled_mantissa_DN... -now rewrite Ztrunc_Z2R. +now rewrite Ztrunc_IZR. (* . odd floor *) -change (Zeven (Ztrunc (scaled_mantissa beta fexp (round beta fexp Zceil x))) = true). -destruct (ln_beta beta x) as (ex, Hex). +change (Z.even (Ztrunc (scaled_mantissa beta fexp (round beta fexp Zceil x))) = true). +destruct (mag beta x) as (ex, Hex). specialize (Hex (Rgt_not_eq _ _ Hx)). rewrite (Rabs_pos_eq _ (Rlt_le _ _ Hx)) in Hex. destruct (Z_lt_le_dec (fexp ex) ex) as [He|He]. @@ -394,56 +389,56 @@ rewrite Rplus_opp_r in Hm. elim (Rlt_irrefl 0). rewrite Hm at 2. apply Rinv_0_lt_compat. -now apply (Z2R_lt 0 2). +now apply IZR_lt. destruct (proj2 Hu) as [Hu'|Hu']. (* ... u <> bpow *) unfold scaled_mantissa. -rewrite canonic_exp_fexp_pos with (1 := conj (proj1 Hu) Hu'). +rewrite cexp_fexp_pos with (1 := conj (proj1 Hu) Hu'). unfold round, F2R. simpl. -rewrite canonic_exp_fexp_pos with (1 := Hex). +rewrite cexp_fexp_pos with (1 := Hex). rewrite Rmult_assoc, <- bpow_plus, Zplus_opp_r, Rmult_1_r. -rewrite Ztrunc_Z2R. +rewrite Ztrunc_IZR. fold mx. rewrite Hfc. -now rewrite Zeven_plus, Hmx. +now rewrite Z.even_add, Hmx. (* ... u = bpow *) rewrite Hu'. -unfold scaled_mantissa, canonic_exp. -rewrite ln_beta_bpow. -rewrite <- bpow_plus, <- Z2R_Zpower. -rewrite Ztrunc_Z2R. -case_eq (Zeven beta) ; intros Hr. +unfold scaled_mantissa, cexp. +rewrite mag_bpow. +rewrite <- bpow_plus, <- IZR_Zpower. +rewrite Ztrunc_IZR. +case_eq (Z.even beta) ; intros Hr. destruct exists_NE_ as [Hs|Hs]. now rewrite Hs in Hr. destruct (Hs ex) as (H,_). -rewrite Zeven_Zpower. +rewrite Z.even_pow. exact Hr. omega. -assert (Zeven (Zfloor mx) = true). 2: now rewrite H in Hmx. +assert (Z.even (Zfloor mx) = true). 2: now rewrite H in Hmx. replace (Zfloor mx) with (Zceil mx + -1)%Z by omega. -rewrite Zeven_plus. +rewrite Z.even_add. apply eqb_true. unfold mx. replace (Zceil (scaled_mantissa beta fexp x)) with (Zpower beta (ex - fexp ex)). rewrite Zeven_Zpower_odd with (2 := Hr). easy. omega. -apply eq_Z2R. -rewrite Z2R_Zpower. 2: omega. +apply eq_IZR. +rewrite IZR_Zpower. 2: omega. apply Rmult_eq_reg_r with (bpow (fexp ex)). unfold Zminus. rewrite bpow_plus. rewrite Rmult_assoc, <- bpow_plus, Zplus_opp_l, Rmult_1_r. -pattern (fexp ex) ; rewrite <- canonic_exp_fexp_pos with (1 := Hex). +pattern (fexp ex) ; rewrite <- cexp_fexp_pos with (1 := Hex). now apply sym_eq. apply Rgt_not_eq. apply bpow_gt_0. generalize (proj1 (valid_exp ex) He). omega. (* .. small pos *) -assert (Zeven (Zfloor mx) = true). 2: now rewrite H in Hmx. +assert (Z.even (Zfloor mx) = true). 2: now rewrite H in Hmx. unfold mx, scaled_mantissa. -rewrite canonic_exp_fexp_pos with (1 := Hex). +rewrite cexp_fexp_pos with (1 := Hex). now rewrite mantissa_DN_small_pos. (* not midpoint *) right. @@ -456,7 +451,7 @@ rewrite Hxg. apply Hg. set (d := round beta fexp Zfloor x). set (u := round beta fexp Zceil x). -apply Rnd_N_pt_unicity with (d := d) (u := u) (4 := Hg). +apply Rnd_N_pt_unique with (d := d) (u := u) (4 := Hg). now apply round_DN_pt. now apply round_UP_pt. 2: now apply round_N_pt. @@ -467,7 +462,7 @@ intros H. apply Rmult_eq_reg_r in H. apply Hm. apply Rcompare_Eq_inv. -rewrite Rcompare_floor_ceil_mid. +rewrite Rcompare_floor_ceil_middle. now apply Rcompare_Eq. contradict Hxg. apply sym_eq. @@ -475,7 +470,7 @@ apply Rnd_N_pt_idempotent with (1 := Hg). rewrite <- (scaled_mantissa_mult_bpow beta fexp x). fold mx. rewrite <- Hxg. -change (Z2R (Zfloor mx) * bpow (canonic_exp beta fexp x))%R with d. +change (IZR (Zfloor mx) * bpow (cexp beta fexp x))%R with d. now eapply round_DN_pt. apply Rgt_not_eq. apply bpow_gt_0. @@ -487,7 +482,7 @@ Theorem round_NE_opp : Proof. intros x. unfold round. simpl. -rewrite scaled_mantissa_opp, canonic_exp_opp. +rewrite scaled_mantissa_opp, cexp_opp. rewrite Znearest_opp. rewrite <- F2R_Zopp. apply (f_equal (fun v => F2R (Float beta (-v) _))). @@ -496,8 +491,8 @@ unfold Znearest. case Rcompare ; trivial. apply (f_equal (fun (b : bool) => if b then Zceil m else Zfloor m)). rewrite Bool.negb_involutive. -rewrite Zeven_opp. -rewrite Zeven_plus. +rewrite Z.even_opp. +rewrite Z.even_add. now rewrite eqb_sym. Qed. @@ -526,7 +521,7 @@ Theorem round_NE_pt : Proof with auto with typeclass_instances. intros x. destruct (total_order_T x 0) as [[Hx|Hx]|Hx]. -apply Rnd_NG_pt_sym. +apply Rnd_NG_pt_opp_inv. apply generic_format_opp. unfold NE_prop. intros _ f ((mg,eg),(H1,(H2,H3))). @@ -534,9 +529,9 @@ exists (Float beta (- mg) eg). repeat split. rewrite H1. now rewrite F2R_Zopp. -now apply canonic_opp. +now apply canonical_opp. simpl. -now rewrite Zeven_opp. +now rewrite Z.even_opp. rewrite <- round_NE_opp. apply round_NE_pt_pos. now apply Ropp_0_gt_lt_contravar. diff --git a/flocq/Core/Fcore_rnd.v b/flocq/Core/Round_pred.v index e5091684..428a4bac 100644 --- a/flocq/Core/Fcore_rnd.v +++ b/flocq/Core/Round_pred.v @@ -2,9 +2,9 @@ This file is part of the Flocq formalization of floating-point arithmetic in Coq: http://flocq.gforge.inria.fr/ -Copyright (C) 2010-2013 Sylvie Boldo +Copyright (C) 2009-2018 Sylvie Boldo #<br /># -Copyright (C) 2010-2013 Guillaume Melquiond +Copyright (C) 2009-2018 Guillaume Melquiond This library is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public @@ -18,13 +18,30 @@ COPYING file for more details. *) (** * Roundings: properties and/or functions *) -Require Import Fcore_Raux. -Require Import Fcore_defs. +Require Import Raux Defs. Section RND_prop. Open Scope R_scope. +Definition Rnd_DN (F : R -> Prop) (rnd : R -> R) := + forall x : R, Rnd_DN_pt F x (rnd x). + +Definition Rnd_UP (F : R -> Prop) (rnd : R -> R) := + forall x : R, Rnd_UP_pt F x (rnd x). + +Definition Rnd_ZR (F : R -> Prop) (rnd : R -> R) := + forall x : R, Rnd_ZR_pt F x (rnd x). + +Definition Rnd_N (F : R -> Prop) (rnd : R -> R) := + forall x : R, Rnd_N_pt F x (rnd x). + +Definition Rnd_NG (F : R -> Prop) (P : R -> R -> Prop) (rnd : R -> R) := + forall x : R, Rnd_NG_pt F P x (rnd x). + +Definition Rnd_NA (F : R -> Prop) (rnd : R -> R) := + forall x : R, Rnd_NA_pt F x (rnd x). + Theorem round_val_of_pred : forall rnd : R -> R -> Prop, round_pred rnd -> @@ -63,7 +80,7 @@ intros x. now destruct round_val_of_pred as (f, H1). Qed. -Theorem round_unicity : +Theorem round_unique : forall rnd : R -> R -> Prop, round_pred_monotone rnd -> forall x f1 f2, @@ -87,25 +104,25 @@ apply Hx1. now apply Rle_trans with (2 := Hxy). Qed. -Theorem Rnd_DN_pt_unicity : +Theorem Rnd_DN_pt_unique : forall F : R -> Prop, forall x f1 f2 : R, Rnd_DN_pt F x f1 -> Rnd_DN_pt F x f2 -> f1 = f2. Proof. intros F. -apply round_unicity. +apply round_unique. apply Rnd_DN_pt_monotone. Qed. -Theorem Rnd_DN_unicity : +Theorem Rnd_DN_unique : forall F : R -> Prop, forall rnd1 rnd2 : R -> R, Rnd_DN F rnd1 -> Rnd_DN F rnd2 -> forall x, rnd1 x = rnd2 x. Proof. intros F rnd1 rnd2 H1 H2 x. -now eapply Rnd_DN_pt_unicity. +now eapply Rnd_DN_pt_unique. Qed. Theorem Rnd_UP_pt_monotone : @@ -118,28 +135,28 @@ apply Hy1. now apply Rle_trans with (1 := Hxy). Qed. -Theorem Rnd_UP_pt_unicity : +Theorem Rnd_UP_pt_unique : forall F : R -> Prop, forall x f1 f2 : R, Rnd_UP_pt F x f1 -> Rnd_UP_pt F x f2 -> f1 = f2. Proof. intros F. -apply round_unicity. +apply round_unique. apply Rnd_UP_pt_monotone. Qed. -Theorem Rnd_UP_unicity : +Theorem Rnd_UP_unique : forall F : R -> Prop, forall rnd1 rnd2 : R -> R, Rnd_UP F rnd1 -> Rnd_UP F rnd2 -> forall x, rnd1 x = rnd2 x. Proof. intros F rnd1 rnd2 H1 H2 x. -now eapply Rnd_UP_pt_unicity. +now eapply Rnd_UP_pt_unique. Qed. -Theorem Rnd_DN_UP_pt_sym : +Theorem Rnd_UP_pt_opp : forall F : R -> Prop, ( forall x, F x -> F (- x) ) -> forall x f : R, @@ -160,7 +177,7 @@ now apply HF. now apply Ropp_le_cancel. Qed. -Theorem Rnd_UP_DN_pt_sym : +Theorem Rnd_DN_pt_opp : forall F : R -> Prop, ( forall x, F x -> F (- x) ) -> forall x f : R, @@ -181,7 +198,7 @@ now apply HF. now apply Ropp_le_cancel. Qed. -Theorem Rnd_DN_UP_sym : +Theorem Rnd_DN_opp : forall F : R -> Prop, ( forall x, F x -> F (- x) ) -> forall rnd1 rnd2 : R -> R, @@ -191,10 +208,10 @@ Proof. intros F HF rnd1 rnd2 H1 H2 x. rewrite <- (Ropp_involutive (rnd1 (-x))). apply f_equal. -apply (Rnd_UP_unicity F (fun x => - rnd1 (-x))) ; trivial. +apply (Rnd_UP_unique F (fun x => - rnd1 (-x))) ; trivial. intros y. pattern y at 1 ; rewrite <- Ropp_involutive. -apply Rnd_DN_UP_pt_sym. +apply Rnd_UP_pt_opp. apply HF. apply H1. Qed. @@ -303,18 +320,17 @@ apply Rle_refl. (* . *) destruct (Rle_or_lt 0 x). (* positive *) -rewrite Rabs_right. -rewrite Rabs_right; auto with real. +rewrite Rabs_pos_eq with (1 := H1). +rewrite Rabs_pos_eq. now apply (proj1 (H x)). -apply Rle_ge. now apply (proj1 (H x)). (* negative *) +apply Rlt_le in H1. +rewrite Rabs_left1 with (1 := H1). rewrite Rabs_left1. -rewrite Rabs_left1 ; auto with real. apply Ropp_le_contravar. -apply (proj2 (H x)). -auto with real. -apply (proj2 (H x)) ; auto with real. +now apply (proj2 (H x)). +now apply (proj2 (H x)). Qed. Theorem Rnd_ZR_pt_monotone : @@ -385,12 +401,12 @@ Proof. intros F x fd fu f Hd Hu Hf. destruct (Rnd_N_pt_DN_or_UP F x f Hf) as [H|H]. left. -apply Rnd_DN_pt_unicity with (1 := H) (2 := Hd). +apply Rnd_DN_pt_unique with (1 := H) (2 := Hd). right. -apply Rnd_UP_pt_unicity with (1 := H) (2 := Hu). +apply Rnd_UP_pt_unique with (1 := H) (2 := Hu). Qed. -Theorem Rnd_N_pt_sym : +Theorem Rnd_N_pt_opp_inv : forall F : R -> Prop, ( forall x, F x -> F (- x) ) -> forall x f : R, @@ -449,7 +465,7 @@ apply Rminus_lt. ring_simplify. apply Rlt_minus. apply Rmult_lt_compat_l. -now apply (Z2R_lt 0 2). +now apply IZR_lt. exact Hxy. now apply Rlt_minus. apply Rle_0_minus. @@ -460,7 +476,7 @@ now apply Rlt_le. now apply Rlt_minus. Qed. -Theorem Rnd_N_pt_unicity : +Theorem Rnd_N_pt_unique : forall F : R -> Prop, forall x d u f1 f2 : R, Rnd_DN_pt F x d -> @@ -476,10 +492,10 @@ clear f1 f2. intros f1 f2 Hf1 Hf2 H12. destruct (Rnd_N_pt_DN_or_UP F x f1 Hf1) as [Hd1|Hu1] ; destruct (Rnd_N_pt_DN_or_UP F x f2 Hf2) as [Hd2|Hu2]. apply Rlt_not_eq with (1 := H12). -now apply Rnd_DN_pt_unicity with (1 := Hd1). +now apply Rnd_DN_pt_unique with (1 := Hd1). apply Hdu. -rewrite Rnd_DN_pt_unicity with (1 := Hd) (2 := Hd1). -rewrite Rnd_UP_pt_unicity with (1 := Hu) (2 := Hu2). +rewrite Rnd_DN_pt_unique with (1 := Hd) (2 := Hd1). +rewrite Rnd_UP_pt_unique with (1 := Hu) (2 := Hu2). rewrite <- (Rabs_pos_eq (x - f1)). rewrite <- (Rabs_pos_eq (f2 - x)). rewrite Rabs_minus_sym. @@ -495,7 +511,7 @@ apply Rle_trans with x. apply Hd2. apply Hu1. apply Rgt_not_eq with (1 := H12). -now apply Rnd_UP_pt_unicity with (1 := Hu2). +now apply Rnd_UP_pt_unique with (1 := Hu2). intros Hf1 Hf2. now apply Rle_antisym ; apply Rnot_lt_le ; refine (H _ _ _ _). Qed. @@ -547,7 +563,7 @@ rewrite 2!Rminus_0_r, Rabs_R0. apply Rabs_pos. Qed. -Theorem Rnd_N_pt_pos : +Theorem Rnd_N_pt_ge_0 : forall F : R -> Prop, F 0 -> forall x f, 0 <= x -> Rnd_N_pt F x f -> @@ -563,7 +579,7 @@ now rewrite Hx. exact HF. Qed. -Theorem Rnd_N_pt_neg : +Theorem Rnd_N_pt_le_0 : forall F : R -> Prop, F 0 -> forall x f, x <= 0 -> Rnd_N_pt F x f -> @@ -589,20 +605,20 @@ intros F HF0 HF x f Hxf. unfold Rabs at 1. destruct (Rcase_abs x) as [Hx|Hx]. rewrite Rabs_left1. -apply Rnd_N_pt_sym. +apply Rnd_N_pt_opp_inv. exact HF. now rewrite 2!Ropp_involutive. -apply Rnd_N_pt_neg with (3 := Hxf). +apply Rnd_N_pt_le_0 with (3 := Hxf). exact HF0. now apply Rlt_le. rewrite Rabs_pos_eq. exact Hxf. -apply Rnd_N_pt_pos with (3 := Hxf). +apply Rnd_N_pt_ge_0 with (3 := Hxf). exact HF0. now apply Rge_le. Qed. -Theorem Rnd_DN_UP_pt_N : +Theorem Rnd_N_pt_DN_UP : forall F : R -> Prop, forall x d u f : R, F f -> @@ -635,7 +651,7 @@ apply Rle_trans with (2 := Hgu). apply Hxu. Qed. -Theorem Rnd_DN_pt_N : +Theorem Rnd_N_pt_DN : forall F : R -> Prop, forall x d u : R, Rnd_DN_pt F x d -> @@ -649,14 +665,14 @@ rewrite Rabs_minus_sym. apply Rabs_pos_eq. apply Rle_0_minus. apply Hd. -apply Rnd_DN_UP_pt_N with (2 := Hd) (3 := Hu). +apply Rnd_N_pt_DN_UP with (2 := Hd) (3 := Hu). apply Hd. rewrite Hdx. apply Rle_refl. now rewrite Hdx. Qed. -Theorem Rnd_UP_pt_N : +Theorem Rnd_N_pt_UP : forall F : R -> Prop, forall x d u : R, Rnd_DN_pt F x d -> @@ -669,22 +685,22 @@ assert (Hux: (Rabs (u - x) = u - x)%R). apply Rabs_pos_eq. apply Rle_0_minus. apply Hu. -apply Rnd_DN_UP_pt_N with (2 := Hd) (3 := Hu). +apply Rnd_N_pt_DN_UP with (2 := Hd) (3 := Hu). apply Hu. now rewrite Hux. rewrite Hux. apply Rle_refl. Qed. -Definition Rnd_NG_pt_unicity_prop F P := +Definition Rnd_NG_pt_unique_prop F P := forall x d u, Rnd_DN_pt F x d -> Rnd_N_pt F x d -> Rnd_UP_pt F x u -> Rnd_N_pt F x u -> P x d -> P x u -> d = u. -Theorem Rnd_NG_pt_unicity : +Theorem Rnd_NG_pt_unique : forall (F : R -> Prop) (P : R -> R -> Prop), - Rnd_NG_pt_unicity_prop F P -> + Rnd_NG_pt_unique_prop F P -> forall x f1 f2 : R, Rnd_NG_pt F P x f1 -> Rnd_NG_pt F P x f2 -> f1 = f2. @@ -694,11 +710,11 @@ destruct H1b as [H1b|H1b]. destruct H2b as [H2b|H2b]. destruct (Rnd_N_pt_DN_or_UP _ _ _ H1a) as [H1c|H1c] ; destruct (Rnd_N_pt_DN_or_UP _ _ _ H2a) as [H2c|H2c]. -eapply Rnd_DN_pt_unicity ; eassumption. +eapply Rnd_DN_pt_unique ; eassumption. now apply (HP x f1 f2). apply sym_eq. now apply (HP x f2 f1 H2c H2a H1c H1a). -eapply Rnd_UP_pt_unicity ; eassumption. +eapply Rnd_UP_pt_unique ; eassumption. now apply H2b. apply sym_eq. now apply H1b. @@ -706,14 +722,14 @@ Qed. Theorem Rnd_NG_pt_monotone : forall (F : R -> Prop) (P : R -> R -> Prop), - Rnd_NG_pt_unicity_prop F P -> + Rnd_NG_pt_unique_prop F P -> round_pred_monotone (Rnd_NG_pt F P). Proof. intros F P HP x y f g (Hf,Hx) (Hg,Hy) [Hxy|Hxy]. now apply Rnd_N_pt_monotone with F x y. apply Req_le. rewrite <- Hxy in Hg, Hy. -eapply Rnd_NG_pt_unicity ; try split ; eassumption. +eapply Rnd_NG_pt_unique ; try split ; eassumption. Qed. Theorem Rnd_NG_pt_refl : @@ -728,7 +744,7 @@ intros f2 Hf2. now apply Rnd_N_pt_idempotent with F. Qed. -Theorem Rnd_NG_pt_sym : +Theorem Rnd_NG_pt_opp_inv : forall (F : R -> Prop) (P : R -> R -> Prop), ( forall x, F x -> F (-x) ) -> ( forall x f, P x f -> P (-x) (-f) ) -> @@ -737,7 +753,7 @@ Theorem Rnd_NG_pt_sym : Proof. intros F P HF HP x f (H1,H2). split. -now apply Rnd_N_pt_sym. +now apply Rnd_N_pt_opp_inv. destruct H2 as [H2|H2]. left. rewrite <- (Ropp_involutive x), <- (Ropp_involutive f). @@ -748,20 +764,20 @@ rewrite <- (Ropp_involutive f). rewrite <- H2 with (-f2). apply sym_eq. apply Ropp_involutive. -apply Rnd_N_pt_sym. +apply Rnd_N_pt_opp_inv. exact HF. now rewrite 2!Ropp_involutive. Qed. -Theorem Rnd_NG_unicity : +Theorem Rnd_NG_unique : forall (F : R -> Prop) (P : R -> R -> Prop), - Rnd_NG_pt_unicity_prop F P -> + Rnd_NG_pt_unique_prop F P -> forall rnd1 rnd2 : R -> R, Rnd_NG F P rnd1 -> Rnd_NG F P rnd2 -> forall x, rnd1 x = rnd2 x. Proof. intros F P HP rnd1 rnd2 H1 H2 x. -now apply Rnd_NG_pt_unicity with F P x. +now apply Rnd_NG_pt_unique with F P x. Qed. Theorem Rnd_NA_NG_pt : @@ -775,7 +791,7 @@ destruct (Rle_or_lt 0 x) as [Hx|Hx]. (* *) split ; intros (H1, H2). (* . *) -assert (Hf := Rnd_N_pt_pos F HF x f Hx H1). +assert (Hf := Rnd_N_pt_ge_0 F HF x f Hx H1). split. exact H1. destruct (Rnd_N_pt_DN_or_UP _ _ _ H1) as [H3|H3]. @@ -784,12 +800,12 @@ right. intros f2 Hxf2. specialize (H2 _ Hxf2). destruct (Rnd_N_pt_DN_or_UP _ _ _ Hxf2) as [H4|H4]. -eapply Rnd_DN_pt_unicity ; eassumption. +eapply Rnd_DN_pt_unique ; eassumption. apply Rle_antisym. rewrite Rabs_pos_eq with (1 := Hf) in H2. rewrite Rabs_pos_eq in H2. exact H2. -now apply Rnd_N_pt_pos with F x. +now apply Rnd_N_pt_ge_0 with F x. apply Rle_trans with x. apply H3. apply H4. @@ -803,8 +819,8 @@ split. exact H1. intros f2 Hxf2. destruct H2 as [H2|H2]. -assert (Hf := Rnd_N_pt_pos F HF x f Hx H1). -assert (Hf2 := Rnd_N_pt_pos F HF x f2 Hx Hxf2). +assert (Hf := Rnd_N_pt_ge_0 F HF x f Hx H1). +assert (Hf2 := Rnd_N_pt_ge_0 F HF x f2 Hx Hxf2). rewrite 2!Rabs_pos_eq ; trivial. rewrite 2!Rabs_pos_eq in H2 ; trivial. destruct (Rnd_N_pt_DN_or_UP _ _ _ Hxf2) as [H3|H3]. @@ -820,7 +836,7 @@ assert (Hx' := Rlt_le _ _ Hx). clear Hx. rename Hx' into Hx. split ; intros (H1, H2). (* . *) -assert (Hf := Rnd_N_pt_neg F HF x f Hx H1). +assert (Hf := Rnd_N_pt_le_0 F HF x f Hx H1). split. exact H1. destruct (Rnd_N_pt_DN_or_UP _ _ _ H1) as [H3|H3]. @@ -842,15 +858,15 @@ apply H3. rewrite Rabs_left1 with (1 := Hf) in H2. rewrite Rabs_left1 in H2. now apply Ropp_le_cancel. -now apply Rnd_N_pt_neg with F x. -eapply Rnd_UP_pt_unicity ; eassumption. +now apply Rnd_N_pt_le_0 with F x. +eapply Rnd_UP_pt_unique ; eassumption. (* . *) split. exact H1. intros f2 Hxf2. destruct H2 as [H2|H2]. -assert (Hf := Rnd_N_pt_neg F HF x f Hx H1). -assert (Hf2 := Rnd_N_pt_neg F HF x f2 Hx Hxf2). +assert (Hf := Rnd_N_pt_le_0 F HF x f Hx H1). +assert (Hf2 := Rnd_N_pt_le_0 F HF x f2 Hx Hxf2). rewrite 2!Rabs_left1 ; trivial. rewrite 2!Rabs_left1 in H2 ; trivial. apply Ropp_le_contravar. @@ -865,10 +881,10 @@ rewrite (H2 _ Hxf2). apply Rle_refl. Qed. -Theorem Rnd_NA_pt_unicity_prop : +Lemma Rnd_NA_pt_unique_prop : forall F : R -> Prop, F 0 -> - Rnd_NG_pt_unicity_prop F (fun a b => (Rabs a <= Rabs b)%R). + Rnd_NG_pt_unique_prop F (fun a b => (Rabs a <= Rabs b)%R). Proof. intros F HF x d u Hxd1 Hxd2 Hxu1 Hxu2 Hd Hu. apply Rle_antisym. @@ -892,7 +908,7 @@ apply HF. now apply Rlt_le. Qed. -Theorem Rnd_NA_pt_unicity : +Theorem Rnd_NA_pt_unique : forall F : R -> Prop, F 0 -> forall x f1 f2 : R, @@ -900,12 +916,12 @@ Theorem Rnd_NA_pt_unicity : f1 = f2. Proof. intros F HF x f1 f2 H1 H2. -apply (Rnd_NG_pt_unicity F _ (Rnd_NA_pt_unicity_prop F HF) x). +apply (Rnd_NG_pt_unique F _ (Rnd_NA_pt_unique_prop F HF) x). now apply -> Rnd_NA_NG_pt. now apply -> Rnd_NA_NG_pt. Qed. -Theorem Rnd_NA_N_pt : +Theorem Rnd_NA_pt_N : forall F : R -> Prop, F 0 -> forall x f : R, @@ -936,29 +952,29 @@ destruct (Rle_lt_dec 0 x) as [Hx|Hx]. (* . *) revert Hxf. rewrite Rabs_pos_eq with (1 := Hx). -rewrite 2!Rabs_pos_eq ; try ( apply (Rnd_N_pt_pos F HF x) ; assumption ). +rewrite 2!Rabs_pos_eq ; try ( apply (Rnd_N_pt_ge_0 F HF x) ; assumption ). intros Hxf. rewrite H0. apply Rplus_le_reg_r with f. ring_simplify. apply Rmult_le_compat_l with (2 := Hxf). -now apply (Z2R_le 0 2). +now apply IZR_le. (* . *) revert Hxf. apply Rlt_le in Hx. rewrite Rabs_left1 with (1 := Hx). -rewrite 2!Rabs_left1 ; try ( apply (Rnd_N_pt_neg F HF x) ; assumption ). +rewrite 2!Rabs_left1 ; try ( apply (Rnd_N_pt_le_0 F HF x) ; assumption ). intros Hxf. rewrite H0. apply Ropp_le_contravar. apply Rplus_le_reg_r with f. ring_simplify. apply Rmult_le_compat_l. -now apply (Z2R_le 0 2). +now apply IZR_le. now apply Ropp_le_cancel. Qed. -Theorem Rnd_NA_unicity : +Theorem Rnd_NA_unique : forall (F : R -> Prop), F 0 -> forall rnd1 rnd2 : R -> R, @@ -966,7 +982,7 @@ Theorem Rnd_NA_unicity : forall x, rnd1 x = rnd2 x. Proof. intros F HF rnd1 rnd2 H1 H2 x. -now apply Rnd_NA_pt_unicity with F x. +now apply Rnd_NA_pt_unique with F x. Qed. Theorem Rnd_NA_pt_monotone : @@ -975,7 +991,7 @@ Theorem Rnd_NA_pt_monotone : round_pred_monotone (Rnd_NA_pt F). Proof. intros F HF x y f g Hxf Hyg Hxy. -apply (Rnd_NG_pt_monotone F _ (Rnd_NA_pt_unicity_prop F HF) x y). +apply (Rnd_NG_pt_monotone F _ (Rnd_NA_pt_unique_prop F HF) x y). now apply -> Rnd_NA_NG_pt. now apply -> Rnd_NA_NG_pt. exact Hxy. @@ -1165,7 +1181,7 @@ intros x. destruct (proj1 (satisfies_any_imp_DN F Hany) (-x)) as (f, Hf). exists (-f). rewrite <- (Ropp_involutive x). -apply Rnd_DN_UP_pt_sym. +apply Rnd_UP_pt_opp. apply Hany. exact Hf. apply Rnd_UP_pt_monotone. diff --git a/flocq/Core/Fcore_ulp.v b/flocq/Core/Ulp.v index 4fdd319e..4f4a5674 100644 --- a/flocq/Core/Fcore_ulp.v +++ b/flocq/Core/Ulp.v @@ -2,9 +2,9 @@ This file is part of the Flocq formalization of floating-point arithmetic in Coq: http://flocq.gforge.inria.fr/ -Copyright (C) 2010-2013 Sylvie Boldo +Copyright (C) 2009-2018 Sylvie Boldo #<br /># -Copyright (C) 2010-2013 Guillaume Melquiond +Copyright (C) 2009-2018 Guillaume Melquiond This library is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public @@ -19,11 +19,7 @@ COPYING file for more details. (** * Unit in the Last Place: our definition using fexp and its properties, successor and predecessor *) Require Import Reals Psatz. -Require Import Fcore_Raux. -Require Import Fcore_defs. -Require Import Fcore_rnd. -Require Import Fcore_generic_fmt. -Require Import Fcore_float_prop. +Require Import Raux Defs Round_pred Generic_fmt Float_prop. Section Fcore_ulp. @@ -97,10 +93,12 @@ Definition ulp x := match Req_bool x 0 with | Some n => bpow (fexp n) | None => 0%R end - | false => bpow (canonic_exp beta fexp x) + | false => bpow (cexp beta fexp x) end. -Lemma ulp_neq_0 : forall x:R, (x <> 0)%R -> ulp x = bpow (canonic_exp beta fexp x). +Lemma ulp_neq_0 : + forall x, x <> 0%R -> + ulp x = bpow (cexp beta fexp x). Proof. intros x Hx. unfold ulp; case (Req_bool_spec x); trivial. @@ -118,7 +116,7 @@ case Req_bool_spec; intros H1. rewrite Req_bool_true; trivial. rewrite <- (Ropp_involutive x), H1; ring. rewrite Req_bool_false. -now rewrite canonic_exp_opp. +now rewrite cexp_opp. intros H2; apply H1; rewrite H2; ring. Qed. @@ -130,7 +128,7 @@ unfold ulp; case (Req_bool_spec x 0); intros H1. rewrite Req_bool_true; trivial. now rewrite H1, Rabs_R0. rewrite Req_bool_false. -now rewrite canonic_exp_abs. +now rewrite cexp_abs. now apply Rabs_no_R0. Qed. @@ -159,9 +157,8 @@ rewrite ulp_neq_0. unfold F2R; simpl. apply Rmult_le_compat_r. apply bpow_ge_0. -apply (Z2R_le (Zsucc 0)). -apply Zlt_le_succ. -apply F2R_gt_0_reg with beta (canonic_exp beta fexp x). +apply IZR_le, (Zlt_le_succ 0). +apply gt_0_F2R with beta (cexp beta fexp x). now rewrite <- Fx. Qed. @@ -178,8 +175,6 @@ now apply Rabs_pos_lt. now apply generic_format_abs. Qed. - -(* was ulp_DN_UP *) Theorem round_UP_DN_ulp : forall x, ~ F x -> round beta fexp Zceil x = (round beta fexp Zfloor x + ulp x)%R. @@ -189,13 +184,13 @@ rewrite ulp_neq_0. unfold round. simpl. unfold F2R. simpl. rewrite Zceil_floor_neq. -rewrite Z2R_plus. simpl. +rewrite plus_IZR. simpl. ring. intros H. apply Fx. unfold generic_format, F2R. simpl. rewrite <- H. -rewrite Ztrunc_Z2R. +rewrite Ztrunc_IZR. rewrite H. now rewrite scaled_mantissa_mult_bpow. intros V; apply Fx. @@ -210,7 +205,7 @@ Proof. intros e. rewrite ulp_neq_0. apply f_equal. -apply canonic_exp_fexp. +apply cexp_fexp. rewrite Rabs_pos_eq. split. ring_simplify (e + 1 - 1)%Z. @@ -222,7 +217,7 @@ apply Rgt_not_eq, Rlt_gt, bpow_gt_0. Qed. -Lemma generic_format_ulp_0: +Lemma generic_format_ulp_0 : F (ulp 0). Proof. unfold ulp. @@ -234,8 +229,9 @@ apply generic_format_bpow. now apply valid_exp. Qed. -Lemma generic_format_bpow_ge_ulp_0: forall e, - (ulp 0 <= bpow e)%R -> F (bpow e). +Lemma generic_format_bpow_ge_ulp_0 : + forall e, (ulp 0 <= bpow e)%R -> + F (bpow e). Proof. intros e; unfold ulp. rewrite Req_bool_true; trivial. @@ -248,7 +244,7 @@ apply generic_format_bpow. case (Zle_or_lt (e+1) (fexp (e+1))); intros H4. absurd (e+1 <= e)%Z. omega. -apply Zle_trans with (1:=H4). +apply Z.le_trans with (1:=H4). replace (fexp (e+1)) with (fexp n). now apply le_bpow with beta. now apply fexp_negligible_exp_eq. @@ -258,33 +254,36 @@ Qed. (** The three following properties are equivalent: [Exp_not_FTZ] ; forall x, F (ulp x) ; forall x, ulp 0 <= ulp x *) -Lemma generic_format_ulp: Exp_not_FTZ fexp -> - forall x, F (ulp x). +Lemma generic_format_ulp : + Exp_not_FTZ fexp -> + forall x, F (ulp x). Proof. unfold Exp_not_FTZ; intros H x. case (Req_dec x 0); intros Hx. rewrite Hx; apply generic_format_ulp_0. rewrite (ulp_neq_0 _ Hx). -apply generic_format_bpow; unfold canonic_exp. +apply generic_format_bpow. apply H. Qed. -Lemma not_FTZ_generic_format_ulp: - (forall x, F (ulp x)) -> Exp_not_FTZ fexp. +Lemma not_FTZ_generic_format_ulp : + (forall x, F (ulp x)) -> + Exp_not_FTZ fexp. Proof. intros H e. specialize (H (bpow (e-1))). rewrite ulp_neq_0 in H. 2: apply Rgt_not_eq, bpow_gt_0. -unfold canonic_exp in H. -rewrite ln_beta_bpow in H. -apply generic_format_bpow_inv' in H... +unfold cexp in H. +rewrite mag_bpow in H. +apply generic_format_bpow_inv' in H. now replace (e-1+1)%Z with e in H by ring. Qed. -Lemma ulp_ge_ulp_0: Exp_not_FTZ fexp -> - forall x, (ulp 0 <= ulp x)%R. +Lemma ulp_ge_ulp_0 : + Exp_not_FTZ fexp -> + forall x, (ulp 0 <= ulp x)%R. Proof. unfold Exp_not_FTZ; intros H x. case (Req_dec x 0); intros Hx. @@ -295,20 +294,21 @@ case negligible_exp_spec'. intros (H1,H2); rewrite H1; apply ulp_ge_0. intros (n,(H1,H2)); rewrite H1. rewrite ulp_neq_0; trivial. -apply bpow_le; unfold canonic_exp. -generalize (ln_beta beta x); intros l. +apply bpow_le; unfold cexp. +generalize (mag beta x); intros l. case (Zle_or_lt l (fexp l)); intros Hl. -rewrite (fexp_negligible_exp_eq n l); trivial; apply Zle_refl. +rewrite (fexp_negligible_exp_eq n l); trivial; apply Z.le_refl. case (Zle_or_lt (fexp n) (fexp l)); trivial; intros K. absurd (fexp n <= fexp l)%Z. omega. -apply Zle_trans with (2:= H _). +apply Z.le_trans with (2:= H _). apply Zeq_le, sym_eq, valid_exp; trivial. omega. Qed. Lemma not_FTZ_ulp_ge_ulp_0: - (forall x, (ulp 0 <= ulp x)%R) -> Exp_not_FTZ fexp. + (forall x, (ulp 0 <= ulp x)%R) -> + Exp_not_FTZ fexp. Proof. intros H e. apply generic_format_bpow_inv' with beta. @@ -318,9 +318,7 @@ rewrite <- ulp_bpow. apply H. Qed. - - -Theorem ulp_le_pos : +Lemma ulp_le_pos : forall { Hm : Monotone_exp fexp }, forall x y: R, (0 <= x)%R -> (x <= y)%R -> @@ -332,7 +330,7 @@ rewrite ulp_neq_0. rewrite ulp_neq_0. apply bpow_le. apply Hm. -now apply ln_beta_le. +now apply mag_le. apply Rgt_not_eq, Rlt_gt. now apply Rlt_le_trans with (1:=Hx). now apply Rgt_not_eq. @@ -341,7 +339,6 @@ apply ulp_ge_ulp_0. apply monotone_exp_not_FTZ... Qed. - Theorem ulp_le : forall { Hm : Monotone_exp fexp }, forall x y: R, @@ -355,26 +352,49 @@ apply ulp_le_pos; trivial. apply Rabs_pos. Qed. +(** Properties when there is no minimal exponent *) +Theorem eq_0_round_0_negligible_exp : + negligible_exp = None -> forall rnd {Vr: Valid_rnd rnd} x, + round beta fexp rnd x = 0%R -> x = 0%R. +Proof. +intros H rnd Vr x Hx. +case (Req_dec x 0); try easy; intros Hx2. +absurd (Rabs (round beta fexp rnd x) = 0%R). +2: rewrite Hx, Rabs_R0; easy. +apply Rgt_not_eq. +apply Rlt_le_trans with (bpow (mag beta x - 1)). +apply bpow_gt_0. +apply abs_round_ge_generic; try assumption. +apply generic_format_bpow. +case negligible_exp_spec'; [intros (K1,K2)|idtac]. +ring_simplify (mag beta x-1+1)%Z. +specialize (K2 (mag beta x)); now auto with zarith. +intros (n,(Hn1,Hn2)). +rewrite Hn1 in H; discriminate. +now apply bpow_mag_le. +Qed. + (** Definition and properties of pred and succ *) Definition pred_pos x := - if Req_bool x (bpow (ln_beta beta x - 1)) then - (x - bpow (fexp (ln_beta beta x - 1)))%R + if Req_bool x (bpow (mag beta x - 1)) then + (x - bpow (fexp (mag beta x - 1)))%R else (x - ulp x)%R. Definition succ x := - if (Rle_bool 0 x) then - (x+ulp x)%R - else - (- pred_pos (-x))%R. + if (Rle_bool 0 x) then + (x+ulp x)%R + else + (- pred_pos (-x))%R. Definition pred x := (- succ (-x))%R. -Theorem pred_eq_pos: - forall x, (0 <= x)%R -> (pred x = pred_pos x)%R. +Theorem pred_eq_pos : + forall x, (0 <= x)%R -> + pred x = pred_pos x. Proof. intros x Hx; unfold pred, succ. case Rle_bool_spec; intros Hx'. @@ -389,39 +409,29 @@ rewrite Ropp_0; ring. now rewrite 2!Ropp_involutive. Qed. -Theorem succ_eq_pos: - forall x, (0 <= x)%R -> (succ x = x + ulp x)%R. +Theorem succ_eq_pos : + forall x, (0 <= x)%R -> + succ x = (x + ulp x)%R. Proof. intros x Hx; unfold succ. now rewrite Rle_bool_true. Qed. -Lemma pred_eq_opp_succ_opp: forall x, pred x = (- succ (-x))%R. +Theorem succ_opp : + forall x, succ (-x) = (- pred x)%R. Proof. -reflexivity. -Qed. - -Lemma succ_eq_opp_pred_opp: forall x, succ x = (- pred (-x))%R. -Proof. -intros x; unfold pred. -now rewrite 2!Ropp_involutive. -Qed. - -Lemma succ_opp: forall x, (succ (-x) = - pred x)%R. -Proof. -intros x; rewrite succ_eq_opp_pred_opp. -now rewrite Ropp_involutive. +intros x. +now apply sym_eq, Ropp_involutive. Qed. -Lemma pred_opp: forall x, (pred (-x) = - succ x)%R. +Theorem pred_opp : + forall x, pred (-x) = (- succ x)%R. Proof. -intros x; rewrite pred_eq_opp_succ_opp. +intros x. +unfold pred. now rewrite Ropp_involutive. Qed. - - - (** pred and succ are in the format *) (* cannont be x <> ulp 0, due to the counter-example 1-bit FP format fexp: e -> e-1 *) @@ -436,7 +446,7 @@ intros x e Fx Hx' Hx. (* *) assert (1 <= Ztrunc (scaled_mantissa beta fexp x))%Z. assert (0 < Ztrunc (scaled_mantissa beta fexp x))%Z. -apply F2R_gt_0_reg with beta (canonic_exp beta fexp x). +apply gt_0_F2R with beta (cexp beta fexp x). rewrite <- Fx. apply Rle_lt_trans with (2:=Hx). apply bpow_ge_0. @@ -446,12 +456,11 @@ case (Zle_lt_or_eq _ _ H); intros Hm. pattern x at 1 ; rewrite Fx. rewrite ulp_neq_0. unfold F2R. simpl. -pattern (bpow (canonic_exp beta fexp x)) at 2 ; rewrite <- Rmult_1_l. +pattern (bpow (cexp beta fexp x)) at 2 ; rewrite <- Rmult_1_l. rewrite <- Rmult_minus_distr_r. -change 1%R with (Z2R 1). -rewrite <- Z2R_minus. -change (bpow e <= F2R (Float beta (Ztrunc (scaled_mantissa beta fexp x) - 1) (canonic_exp beta fexp x)))%R. -apply bpow_le_F2R_m1; trivial. +rewrite <- minus_IZR. +apply bpow_le_F2R_m1. +easy. now rewrite <- Fx. apply Rgt_not_eq, Rlt_gt. apply Rlt_trans with (2:=Hx), bpow_gt_0. @@ -476,27 +485,23 @@ intros x e Zx Fx Hx. pattern x at 1 ; rewrite Fx. rewrite ulp_neq_0. unfold F2R. simpl. -pattern (bpow (canonic_exp beta fexp x)) at 2 ; rewrite <- Rmult_1_l. +pattern (bpow (cexp beta fexp x)) at 2 ; rewrite <- Rmult_1_l. rewrite <- Rmult_plus_distr_r. -change 1%R with (Z2R 1). -rewrite <- Z2R_plus. -change (F2R (Float beta (Ztrunc (scaled_mantissa beta fexp x) + 1) (canonic_exp beta fexp x)) <= bpow e)%R. +rewrite <- plus_IZR. apply F2R_p1_le_bpow. -apply F2R_gt_0_reg with beta (canonic_exp beta fexp x). +apply gt_0_F2R with beta (cexp beta fexp x). now rewrite <- Fx. now rewrite <- Fx. now apply Rgt_not_eq. Qed. - - Lemma generic_format_pred_aux1: forall x, (0 < x)%R -> F x -> - x <> bpow (ln_beta beta x - 1) -> + x <> bpow (mag beta x - 1) -> F (x - ulp x). Proof. intros x Zx Fx Hx. -destruct (ln_beta beta x) as (ex, Ex). +destruct (mag beta x) as (ex, Ex). simpl in Hx. specialize (Ex (Rgt_not_eq _ _ Zx)). assert (Ex' : (bpow (ex - 1) < x < bpow ex)%R). @@ -504,20 +509,20 @@ rewrite Rabs_pos_eq in Ex. destruct Ex as (H,H'); destruct H; split; trivial. contradict Hx; easy. now apply Rlt_le. -unfold generic_format, scaled_mantissa, canonic_exp. -rewrite ln_beta_unique with beta (x - ulp x)%R ex. +unfold generic_format, scaled_mantissa, cexp. +rewrite mag_unique with beta (x - ulp x)%R ex. pattern x at 1 3 ; rewrite Fx. rewrite ulp_neq_0. unfold scaled_mantissa. -rewrite canonic_exp_fexp with (1 := Ex). +rewrite cexp_fexp with (1 := Ex). unfold F2R. simpl. rewrite Rmult_minus_distr_r. rewrite Rmult_assoc. rewrite <- bpow_plus, Zplus_opp_r, Rmult_1_r. -change (bpow 0) with (Z2R 1). -rewrite <- Z2R_minus. -rewrite Ztrunc_Z2R. -rewrite Z2R_minus. +change (bpow 0) with 1%R. +rewrite <- minus_IZR. +rewrite Ztrunc_IZR. +rewrite minus_IZR. rewrite Rmult_minus_distr_r. now rewrite Rmult_1_l. now apply Rgt_not_eq. @@ -526,7 +531,7 @@ split. apply id_m_ulp_ge_bpow; trivial. rewrite ulp_neq_0. intro H. -assert (ex-1 < canonic_exp beta fexp x < ex)%Z. +assert (ex-1 < cexp beta fexp x < ex)%Z. split ; apply (lt_bpow beta) ; rewrite <- H ; easy. clear -H0. omega. now apply Rgt_not_eq. @@ -541,13 +546,12 @@ apply Rle_0_minus. pattern x at 2; rewrite Fx. rewrite ulp_neq_0. unfold F2R; simpl. -pattern (bpow (canonic_exp beta fexp x)) at 1; rewrite <- Rmult_1_l. +pattern (bpow (cexp beta fexp x)) at 1; rewrite <- Rmult_1_l. apply Rmult_le_compat_r. apply bpow_ge_0. -replace 1%R with (Z2R 1) by reflexivity. -apply Z2R_le. +apply IZR_le. assert (0 < Ztrunc (scaled_mantissa beta fexp x))%Z. -apply F2R_gt_0_reg with beta (canonic_exp beta fexp x). +apply gt_0_F2R with beta (cexp beta fexp x). rewrite <- Fx. apply Rle_lt_trans with (2:=proj1 Ex'). apply bpow_ge_0. @@ -557,8 +561,8 @@ Qed. Lemma generic_format_pred_aux2 : forall x, (0 < x)%R -> F x -> - let e := ln_beta_val beta x (ln_beta beta x) in - x = bpow (e - 1) -> + let e := mag_val beta x (mag beta x) in + x = bpow (e - 1) -> F (x - bpow (fexp (e - 1))). Proof. intros x Zx Fx e Hx. @@ -571,7 +575,7 @@ case (Zle_lt_or_eq _ _ He); clear He; intros He. assert (f = F2R (Float beta (Zpower beta (e-1-(fexp (e-1))) -1) (fexp (e-1))))%R. unfold f; rewrite Hx. unfold F2R; simpl. -rewrite Z2R_minus, Z2R_Zpower. +rewrite minus_IZR, IZR_Zpower. rewrite Rmult_minus_distr_r, Rmult_1_l. rewrite <- bpow_plus. now replace (e - 1 - fexp (e - 1) + fexp (e - 1))%Z with (e-1)%Z by ring. @@ -580,7 +584,7 @@ rewrite H. apply generic_format_F2R. intros _. apply Zeq_le. -apply canonic_exp_fexp. +apply cexp_fexp. rewrite <- H. unfold f; rewrite Hx. rewrite Rabs_right. @@ -593,9 +597,8 @@ apply Rle_trans with (2*bpow (e - 2))%R;[right; ring|idtac]. apply Rle_trans with (bpow 1*bpow (e - 2))%R. apply Rmult_le_compat_r. apply bpow_ge_0. -replace 2%R with (Z2R 2) by reflexivity. -replace (bpow 1) with (Z2R beta). -apply Z2R_le. +replace (bpow 1) with (IZR beta). +apply IZR_le. apply <- Zle_is_le_bool. now destruct beta. simpl. @@ -619,31 +622,30 @@ rewrite Hx, He. ring. Qed. - -Theorem generic_format_succ_aux1 : +Lemma generic_format_succ_aux1 : forall x, (0 < x)%R -> F x -> F (x + ulp x). Proof. intros x Zx Fx. -destruct (ln_beta beta x) as (ex, Ex). +destruct (mag beta x) as (ex, Ex). specialize (Ex (Rgt_not_eq _ _ Zx)). assert (Ex' := Ex). rewrite Rabs_pos_eq in Ex'. destruct (id_p_ulp_le_bpow x ex) ; try easy. -unfold generic_format, scaled_mantissa, canonic_exp. -rewrite ln_beta_unique with beta (x + ulp x)%R ex. +unfold generic_format, scaled_mantissa, cexp. +rewrite mag_unique with beta (x + ulp x)%R ex. pattern x at 1 3 ; rewrite Fx. rewrite ulp_neq_0. unfold scaled_mantissa. -rewrite canonic_exp_fexp with (1 := Ex). +rewrite cexp_fexp with (1 := Ex). unfold F2R. simpl. rewrite Rmult_plus_distr_r. rewrite Rmult_assoc. rewrite <- bpow_plus, Zplus_opp_r, Rmult_1_r. -change (bpow 0) with (Z2R 1). -rewrite <- Z2R_plus. -rewrite Ztrunc_Z2R. -rewrite Z2R_plus. +change (bpow 0) with 1%R. +rewrite <- plus_IZR. +rewrite Ztrunc_IZR. +rewrite plus_IZR. rewrite Rmult_plus_distr_r. now rewrite Rmult_1_l. now apply Rgt_not_eq. @@ -667,7 +669,7 @@ replace (Ztrunc (scaled_mantissa beta fexp x)) with Z0. rewrite F2R_0. apply Rle_refl. unfold scaled_mantissa. -rewrite canonic_exp_fexp with (1 := Ex). +rewrite cexp_fexp with (1 := Ex). destruct (mantissa_small_pos beta fexp x ex) ; trivial. rewrite Ztrunc_floor. apply sym_eq. @@ -679,7 +681,7 @@ now apply Rlt_le. now apply Rlt_le. Qed. -Theorem generic_format_pred_pos : +Lemma generic_format_pred_pos : forall x, F x -> (0 < x)%R -> F (pred_pos x). Proof. @@ -689,7 +691,6 @@ now apply generic_format_pred_aux2. now apply generic_format_pred_aux1. Qed. - Theorem generic_format_succ : forall x, F x -> F (succ x). @@ -717,9 +718,7 @@ apply generic_format_succ. now apply generic_format_opp. Qed. - - -Theorem pred_pos_lt_id : +Lemma pred_pos_lt_id : forall x, (x <> 0)%R -> (pred_pos x < x)%R. Proof. @@ -754,7 +753,7 @@ apply bpow_gt_0. pattern x at 1; rewrite <- (Ropp_involutive x). apply Ropp_lt_contravar. apply pred_pos_lt_id. -now auto with real. +auto with real. Qed. @@ -766,7 +765,7 @@ intros x Zx; unfold pred. pattern x at 2; rewrite <- (Ropp_involutive x). apply Ropp_lt_contravar. apply succ_gt_id. -now auto with real. +auto with real. Qed. Theorem succ_ge_id : @@ -781,7 +780,7 @@ Qed. Theorem pred_le_id : - forall x, (pred x <= x)%R. + forall x, (pred x <= x)%R. Proof. intros x; unfold pred. pattern x at 2; rewrite <- (Ropp_involutive x). @@ -790,7 +789,7 @@ apply succ_ge_id. Qed. -Theorem pred_pos_ge_0 : +Lemma pred_pos_ge_0 : forall x, (0 < x)%R -> F x -> (0 <= pred_pos x)%R. Proof. @@ -801,8 +800,8 @@ case Req_bool_spec; intros H. apply Rle_0_minus. rewrite H. apply bpow_le. -destruct (ln_beta beta x) as (ex,Ex) ; simpl. -rewrite ln_beta_bpow. +destruct (mag beta x) as (ex,Ex) ; simpl. +rewrite mag_bpow. ring_simplify (ex - 1 + 1 - 1)%Z. apply generic_format_bpow_inv with beta; trivial. simpl in H. @@ -824,36 +823,35 @@ Qed. Lemma pred_pos_plus_ulp_aux1 : forall x, (0 < x)%R -> F x -> - x <> bpow (ln_beta beta x - 1) -> + x <> bpow (mag beta x - 1) -> ((x - ulp x) + ulp (x-ulp x) = x)%R. Proof. intros x Zx Fx Hx. replace (ulp (x - ulp x)) with (ulp x). ring. -assert (H:(x <> 0)%R) by auto with real. -assert (H':(x <> bpow (canonic_exp beta fexp x))%R). -unfold canonic_exp; intros M. -case_eq (ln_beta beta x); intros ex Hex T. -assert (Lex:(ln_beta_val beta x (ln_beta beta x) = ex)%Z). +assert (H : x <> 0%R) by now apply Rgt_not_eq. +assert (H' : x <> bpow (cexp beta fexp x)). +unfold cexp ; intros M. +case_eq (mag beta x); intros ex Hex T. +assert (Lex:(mag_val beta x (mag beta x) = ex)%Z). rewrite T; reflexivity. rewrite Lex in *. clear T; simpl in *; specialize (Hex H). -rewrite Rabs_right in Hex. -2: apply Rle_ge; apply Rlt_le; easy. -assert (ex-1 < fexp ex < ex)%Z. -split ; apply (lt_bpow beta); rewrite <- M;[idtac|easy]. -destruct (proj1 Hex);[trivial|idtac]. -contradict Hx; auto with real. +rewrite Rabs_pos_eq in Hex by now apply Rlt_le. +assert (ex - 1 < fexp ex < ex)%Z. + split ; apply (lt_bpow beta) ; rewrite <- M by easy. + lra. + apply Hex. omega. -rewrite 2!ulp_neq_0; try auto with real. +rewrite 2!ulp_neq_0 by lra. apply f_equal. -unfold canonic_exp; apply f_equal. -case_eq (ln_beta beta x); intros ex Hex T. -assert (Lex:(ln_beta_val beta x (ln_beta beta x) = ex)%Z). +unfold cexp ; apply f_equal. +case_eq (mag beta x); intros ex Hex T. +assert (Lex:(mag_val beta x (mag beta x) = ex)%Z). rewrite T; reflexivity. rewrite Lex in *; simpl in *; clear T. specialize (Hex H). -apply sym_eq, ln_beta_unique. +apply sym_eq, mag_unique. rewrite Rabs_right. rewrite Rabs_right in Hex. 2: apply Rle_ge; apply Rlt_le; easy. @@ -863,8 +861,8 @@ apply Rle_trans with (x-ulp x)%R. apply id_m_ulp_ge_bpow; trivial. rewrite ulp_neq_0; trivial. rewrite ulp_neq_0; trivial. -right; unfold canonic_exp; now rewrite Lex. -contradict Hx; auto with real. +right; unfold cexp; now rewrite Lex. +lra. apply Rle_lt_trans with (2:=proj2 Hex). rewrite <- Rplus_0_r. apply Rplus_le_compat_l. @@ -874,22 +872,19 @@ apply bpow_ge_0. apply Rle_ge. apply Rle_0_minus. rewrite Fx. -unfold F2R, canonic_exp; simpl. +unfold F2R, cexp; simpl. rewrite Lex. pattern (bpow (fexp ex)) at 1; rewrite <- Rmult_1_l. apply Rmult_le_compat_r. apply bpow_ge_0. -replace 1%R with (Z2R (Zsucc 0)) by reflexivity. -apply Z2R_le. -apply Zlt_le_succ. -apply F2R_gt_0_reg with beta (canonic_exp beta fexp x). +apply IZR_le, (Zlt_le_succ 0). +apply gt_0_F2R with beta (cexp beta fexp x). now rewrite <- Fx. Qed. - Lemma pred_pos_plus_ulp_aux2 : forall x, (0 < x)%R -> F x -> - let e := ln_beta_val beta x (ln_beta beta x) in + let e := mag_val beta x (mag beta x) in x = bpow (e - 1) -> (x - bpow (fexp (e-1)) <> 0)%R -> ((x - bpow (fexp (e-1))) + ulp (x - bpow (fexp (e-1))) = x)%R. @@ -904,9 +899,9 @@ case (Zle_lt_or_eq _ _ He); clear He; intros He. (* *) rewrite ulp_neq_0; trivial. apply f_equal. -unfold canonic_exp; apply f_equal. +unfold cexp ; apply f_equal. apply sym_eq. -apply ln_beta_unique. +apply mag_unique. rewrite Rabs_right. split. apply Rplus_le_reg_l with (bpow (fexp (e-1))). @@ -917,9 +912,8 @@ apply Rle_trans with (2*bpow (e - 2))%R;[right; ring|idtac]. apply Rle_trans with (bpow 1*bpow (e - 2))%R. apply Rmult_le_compat_r. apply bpow_ge_0. -replace 2%R with (Z2R 2) by reflexivity. -replace (bpow 1) with (Z2R beta). -apply Z2R_le. +replace (bpow 1) with (IZR beta). +apply IZR_le. apply <- Zle_is_le_bool. now destruct beta. simpl. @@ -944,7 +938,7 @@ Qed. Lemma pred_pos_plus_ulp_aux3 : forall x, (0 < x)%R -> F x -> - let e := ln_beta_val beta x (ln_beta beta x) in + let e := mag_val beta x (mag beta x) in x = bpow (e - 1) -> (x - bpow (fexp (e-1)) = 0)%R -> (ulp 0 = x)%R. @@ -967,40 +961,44 @@ apply valid_exp; omega. apply sym_eq, valid_exp; omega. Qed. - - - (** The following one is false for x = 0 in FTZ *) -Theorem pred_pos_plus_ulp : +Lemma pred_pos_plus_ulp : forall x, (0 < x)%R -> F x -> (pred_pos x + ulp (pred_pos x) = x)%R. Proof. intros x Zx Fx. unfold pred_pos. case Req_bool_spec; intros H. -case (Req_EM_T (x - bpow (fexp (ln_beta_val beta x (ln_beta beta x) -1))) 0); intros H1. +case (Req_EM_T (x - bpow (fexp (mag_val beta x (mag beta x) -1))) 0); intros H1. rewrite H1, Rplus_0_l. now apply pred_pos_plus_ulp_aux3. now apply pred_pos_plus_ulp_aux2. now apply pred_pos_plus_ulp_aux1. Qed. - - +Theorem pred_plus_ulp : + forall x, (0 < x)%R -> F x -> + (pred x + ulp (pred x))%R = x. +Proof. +intros x Hx Fx. +rewrite pred_eq_pos. +now apply pred_pos_plus_ulp. +now apply Rlt_le. +Qed. (** Rounding x + small epsilon *) -Theorem ln_beta_plus_eps: +Theorem mag_plus_eps : forall x, (0 < x)%R -> F x -> forall eps, (0 <= eps < ulp x)%R -> - ln_beta beta (x + eps) = ln_beta beta x :> Z. + mag beta (x + eps) = mag beta x :> Z. Proof. intros x Zx Fx eps Heps. -destruct (ln_beta beta x) as (ex, He). +destruct (mag beta x) as (ex, He). simpl. specialize (He (Rgt_not_eq _ _ Zx)). -apply ln_beta_unique. +apply mag_unique. rewrite Rabs_pos_eq. rewrite Rabs_pos_eq in He. split. @@ -1012,13 +1010,11 @@ now apply Rplus_lt_compat_l. pattern x at 1 ; rewrite Fx. rewrite ulp_neq_0. unfold F2R. simpl. -pattern (bpow (canonic_exp beta fexp x)) at 2 ; rewrite <- Rmult_1_l. +pattern (bpow (cexp beta fexp x)) at 2 ; rewrite <- Rmult_1_l. rewrite <- Rmult_plus_distr_r. -change 1%R with (Z2R 1). -rewrite <- Z2R_plus. -change (F2R (Float beta (Ztrunc (scaled_mantissa beta fexp x) + 1) (canonic_exp beta fexp x)) <= bpow ex)%R. +rewrite <- plus_IZR. apply F2R_p1_le_bpow. -apply F2R_gt_0_reg with beta (canonic_exp beta fexp x). +apply gt_0_F2R with beta (cexp beta fexp x). now rewrite <- Fx. now rewrite <- Fx. now apply Rgt_not_eq. @@ -1028,7 +1024,7 @@ now apply Rlt_le. apply Heps. Qed. -Theorem round_DN_plus_eps_pos: +Theorem round_DN_plus_eps_pos : forall x, (0 <= x)%R -> F x -> forall eps, (0 <= eps < ulp x)%R -> round beta fexp Zfloor (x + eps) = x. @@ -1039,8 +1035,8 @@ destruct Zx as [Zx|Zx]. pattern x at 2 ; rewrite Fx. unfold round. unfold scaled_mantissa. simpl. -unfold canonic_exp at 1 2. -rewrite ln_beta_plus_eps ; trivial. +unfold cexp at 1 2. +rewrite mag_plus_eps ; trivial. apply (f_equal (fun m => F2R (Float beta m _))). rewrite Ztrunc_floor. apply Zfloor_imp. @@ -1050,12 +1046,12 @@ apply Rmult_le_compat_r. apply bpow_ge_0. pattern x at 1 ; rewrite <- Rplus_0_r. now apply Rplus_le_compat_l. -apply Rlt_le_trans with ((x + ulp x) * bpow (- canonic_exp beta fexp x))%R. +apply Rlt_le_trans with ((x + ulp x) * bpow (- cexp beta fexp x))%R. apply Rmult_lt_compat_r. apply bpow_gt_0. now apply Rplus_lt_compat_l. rewrite Rmult_plus_distr_r. -rewrite Z2R_plus. +rewrite plus_IZR. apply Rplus_le_compat. pattern x at 1 3 ; rewrite Fx. unfold F2R. simpl. @@ -1063,7 +1059,7 @@ rewrite Rmult_assoc. rewrite <- bpow_plus. rewrite Zplus_opp_r. rewrite Rmult_1_r. -rewrite Zfloor_Z2R. +rewrite Zfloor_IZR. apply Rle_refl. rewrite ulp_neq_0. 2: now apply Rgt_not_eq. @@ -1076,24 +1072,23 @@ apply bpow_ge_0. (* . x=0 *) rewrite <- Zx, Rplus_0_l; rewrite <- Zx in Heps. case (proj1 Heps); intros P. -unfold round, scaled_mantissa, canonic_exp. +unfold round, scaled_mantissa, cexp. revert Heps; unfold ulp. rewrite Req_bool_true; trivial. case negligible_exp_spec. intros _ (H1,H2). -absurd (0 < 0)%R; auto with real. -now apply Rle_lt_trans with (1:=H1). +exfalso ; lra. intros n Hn H. -assert (fexp (ln_beta beta eps) = fexp n). +assert (fexp (mag beta eps) = fexp n). apply valid_exp; try assumption. -assert(ln_beta beta eps-1 < fexp n)%Z;[idtac|omega]. +assert(mag beta eps-1 < fexp n)%Z;[idtac|omega]. apply lt_bpow with beta. apply Rle_lt_trans with (2:=proj2 H). -destruct (ln_beta beta eps) as (e,He). +destruct (mag beta eps) as (e,He). simpl; rewrite Rabs_pos_eq in He. now apply He, Rgt_not_eq. now left. -replace (Zfloor (eps * bpow (- fexp (ln_beta beta eps)))) with 0%Z. +replace (Zfloor (eps * bpow (- fexp (mag beta eps)))) with 0%Z. unfold F2R; simpl; ring. apply sym_eq, Zfloor_imp. split. @@ -1128,8 +1123,8 @@ assert (Hd := round_DN_plus_eps_pos x Zx Fx eps Heps). rewrite round_UP_DN_ulp. rewrite Hd. rewrite 2!ulp_neq_0. -unfold canonic_exp. -now rewrite ln_beta_plus_eps. +unfold cexp. +now rewrite mag_plus_eps. now apply Rgt_not_eq. now apply Rgt_not_eq, Rplus_lt_0_compat. intros Fs. @@ -1144,24 +1139,22 @@ now apply generic_format_succ_aux1. rewrite <- Zx1, 2!Rplus_0_l. intros Heps. case (proj2 Heps). -unfold round, scaled_mantissa, canonic_exp. +unfold round, scaled_mantissa, cexp. unfold ulp. rewrite Req_bool_true; trivial. case negligible_exp_spec. -intros H2. -intros J; absurd (0 < 0)%R; auto with real. -apply Rlt_trans with eps; try assumption; apply Heps. +lra. intros n Hn H. -assert (fexp (ln_beta beta eps) = fexp n). +assert (fexp (mag beta eps) = fexp n). apply valid_exp; try assumption. -assert(ln_beta beta eps-1 < fexp n)%Z;[idtac|omega]. +assert(mag beta eps-1 < fexp n)%Z;[idtac|omega]. apply lt_bpow with beta. apply Rle_lt_trans with (2:=H). -destruct (ln_beta beta eps) as (e,He). +destruct (mag beta eps) as (e,He). simpl; rewrite Rabs_pos_eq in He. now apply He, Rgt_not_eq. now left. -replace (Zceil (eps * bpow (- fexp (ln_beta beta eps)))) with 1%Z. +replace (Zceil (eps * bpow (- fexp (mag beta eps)))) with 1%Z. unfold F2R; simpl; rewrite H0; ring. apply sym_eq, Zceil_imp. split. @@ -1316,7 +1309,7 @@ destruct Zp; trivial. generalize H0. rewrite pred_eq_pos;[idtac|now left]. unfold pred_pos. -destruct (ln_beta beta y) as (ey,Hey); simpl. +destruct (mag beta y) as (ey,Hey); simpl. case Req_bool_spec; intros Hy2. (* . *) intros Hy3. @@ -1326,7 +1319,7 @@ rewrite <- Hy2, <- Rplus_0_l, Hy3. ring. assert (Zx: (x <> 0)%R). now apply Rgt_not_eq. -destruct (ln_beta beta x) as (ex,Hex). +destruct (mag beta x) as (ex,Hex). specialize (Hex Zx). assert (ex <= ey)%Z. apply bpow_lt_bpow with beta. @@ -1347,16 +1340,16 @@ omega. absurd (0 < Ztrunc (scaled_mantissa beta fexp x) < 1)%Z. omega. split. -apply F2R_gt_0_reg with beta (canonic_exp beta fexp x). +apply gt_0_F2R with beta (cexp beta fexp x). now rewrite <- Fx. -apply lt_Z2R. -apply Rmult_lt_reg_r with (bpow (canonic_exp beta fexp x)). +apply lt_IZR. +apply Rmult_lt_reg_r with (bpow (cexp beta fexp x)). apply bpow_gt_0. -replace (Z2R (Ztrunc (scaled_mantissa beta fexp x)) * - bpow (canonic_exp beta fexp x))%R with x. +replace (IZR (Ztrunc (scaled_mantissa beta fexp x)) * + bpow (cexp beta fexp x))%R with x. rewrite Rmult_1_l. -unfold canonic_exp. -rewrite ln_beta_unique with beta x ex. +unfold cexp. +rewrite mag_unique with beta x ex. rewrite H3,<-H1, <- Hy2. apply H. exact Hex. @@ -1373,8 +1366,8 @@ assert (y = bpow (fexp ey))%R. apply Rminus_diag_uniq. rewrite Hy3. rewrite ulp_neq_0;[idtac|now apply Rgt_not_eq]. -unfold canonic_exp. -rewrite (ln_beta_unique beta y ey); trivial. +unfold cexp. +rewrite (mag_unique beta y ey); trivial. apply Hey. now apply Rgt_not_eq. contradict Hy2. @@ -1382,8 +1375,8 @@ rewrite H1. apply f_equal. apply Zplus_reg_l with 1%Z. ring_simplify. -apply trans_eq with (ln_beta beta y). -apply sym_eq; apply ln_beta_unique. +apply trans_eq with (mag beta y). +apply sym_eq; apply mag_unique. rewrite H1, Rabs_right. split. apply bpow_le. @@ -1391,7 +1384,7 @@ omega. apply bpow_lt. omega. apply Rle_ge; apply bpow_ge_0. -apply ln_beta_unique. +apply mag_unique. apply Hey. now apply Rgt_not_eq. (* *) @@ -1418,7 +1411,7 @@ rewrite <- V; apply pred_pos_ge_0; trivial. apply Rle_lt_trans with (1:=proj1 H); apply H. Qed. -Theorem succ_le_lt_aux: +Lemma succ_le_lt_aux: forall x y, F x -> F y -> (0 <= x)%R -> (x < y)%R -> @@ -1468,7 +1461,7 @@ now apply generic_format_opp. rewrite Ropp_0; now left. Qed. -Theorem le_pred_lt : +Theorem pred_ge_gt : forall x y, F x -> F y -> (x < y)%R -> @@ -1483,7 +1476,7 @@ now apply generic_format_opp. now apply Ropp_lt_contravar. Qed. -Theorem lt_succ_le : +Theorem succ_gt_ge : forall x y, (y <> 0)%R -> (x <= y)%R -> @@ -1505,12 +1498,12 @@ apply Rlt_le_trans with (2 := Hxy). now apply pred_lt_id. Qed. -Theorem succ_pred_aux : forall x, F x -> (0 < x)%R -> succ (pred x)=x. +Lemma succ_pred_pos : + forall x, F x -> (0 < x)%R -> succ (pred x) = x. Proof. intros x Fx Hx. -rewrite pred_eq_pos;[idtac|now left]. -rewrite succ_eq_pos. -2: now apply pred_pos_ge_0. +rewrite pred_eq_pos by now left. +rewrite succ_eq_pos by now apply pred_pos_ge_0. now apply pred_pos_plus_ulp. Qed. @@ -1530,7 +1523,7 @@ rewrite H1; ring. (* *) intros (n,(H1,H2)); rewrite H1. unfold pred_pos. -rewrite ln_beta_bpow. +rewrite mag_bpow. replace (fexp n + 1 - 1)%Z with (fexp n) by ring. rewrite Req_bool_true; trivial. apply Rminus_diag_eq, f_equal. @@ -1554,7 +1547,7 @@ rewrite <- Ropp_0 at 1. apply pred_opp. Qed. -Theorem pred_succ_aux : +Lemma pred_succ_pos : forall x, F x -> (0 < x)%R -> pred (succ x) = x. Proof. @@ -1570,7 +1563,7 @@ apply Rle_antisym. apply Rlt_le_trans with (1 := Hx). apply succ_ge_id. now apply generic_format_pred, generic_format_succ. -- apply le_pred_lt with (1 := Fx). +- apply pred_ge_gt with (1 := Fx). now apply generic_format_succ. apply succ_gt_id. now apply Rgt_not_eq. @@ -1582,12 +1575,12 @@ Theorem succ_pred : Proof. intros x Fx. destruct (Rle_or_lt 0 x) as [[Hx|Hx]|Hx]. -now apply succ_pred_aux. +now apply succ_pred_pos. rewrite <- Hx. rewrite pred_0, succ_opp, pred_ulp_0. apply Ropp_0. -rewrite pred_eq_opp_succ_opp, succ_opp. -rewrite pred_succ_aux. +unfold pred. +rewrite succ_opp, pred_succ_pos. apply Ropp_involutive. now apply generic_format_opp. now apply Ropp_0_gt_lt_contravar. @@ -1606,8 +1599,8 @@ Qed. Theorem round_UP_pred_plus_eps : forall x, F x -> - forall eps, (0 < eps <= if (Rle_bool x 0) then (ulp x) - else (ulp (pred x)))%R -> + forall eps, (0 < eps <= if Rle_bool x 0 then ulp x + else ulp (pred x))%R -> round beta fexp Zceil (pred x + eps) = x. Proof. intros x Fx eps Heps. @@ -1636,7 +1629,6 @@ now apply pred_ge_0. now apply generic_format_opp. Qed. - Theorem round_DN_minus_eps: forall x, F x -> forall eps, (0 < eps <= if (Rle_bool x 0) then (ulp x) @@ -1676,7 +1668,7 @@ Qed. (* was ulp_error *) Theorem error_lt_ulp : forall rnd { Zrnd : Valid_rnd rnd } x, - (x <> 0)%R -> + (x <> 0)%R -> (Rabs (round beta fexp rnd x - x) < ulp x)%R. Proof with auto with typeclass_instances. intros rnd Zrnd x Zx. @@ -1734,7 +1726,6 @@ intros Zx; left. now apply error_lt_ulp. Qed. -(* was ulp_half_error *) Theorem error_le_half_ulp : forall choice x, (Rabs (round beta fexp (Znearest choice) x - x) <= /2 * ulp x)%R. @@ -1748,7 +1739,7 @@ rewrite Rplus_opp_r, Rabs_R0. apply Rmult_le_pos. apply Rlt_le. apply Rinv_0_lt_compat. -now apply (Z2R_lt 0 2). +now apply IZR_lt. apply ulp_ge_0. (* x <> rnd x *) set (d := round beta fexp Zfloor x). @@ -1761,7 +1752,7 @@ apply (round_DN_pt beta fexp x). rewrite Rabs_left1. rewrite Ropp_minus_distr. apply Rmult_le_reg_r with 2%R. -now apply (Z2R_lt 0 2). +now apply IZR_lt. apply Rplus_le_reg_r with (d - x)%R. ring_simplify. apply Rle_trans with (1 := H). @@ -1778,7 +1769,7 @@ rewrite Hu. apply (round_UP_pt beta fexp x). rewrite Rabs_pos_eq. apply Rmult_le_reg_r with 2%R. -now apply (Z2R_lt 0 2). +now apply IZR_lt. apply Rplus_le_reg_r with (- (d + ulp x - x))%R. ring_simplify. apply Rlt_le. @@ -1789,28 +1780,40 @@ rewrite Hu. apply (round_UP_pt beta fexp x). Qed. - Theorem ulp_DN : - forall x, - (0 < round beta fexp Zfloor x)%R -> + forall x, (0 <= x)%R -> ulp (round beta fexp Zfloor x) = ulp x. Proof with auto with typeclass_instances. -intros x Hd. -rewrite 2!ulp_neq_0. -now rewrite canonic_exp_DN with (2 := Hd). -intros T; contradict Hd; rewrite T, round_0... -apply Rlt_irrefl. -now apply Rgt_not_eq. -Qed. - -Theorem round_neq_0_negligible_exp: - negligible_exp=None -> forall rnd { Zrnd : Valid_rnd rnd } x, - (x <> 0)%R -> (round beta fexp rnd x <> 0)%R. +intros x [Hx|Hx]. +- rewrite (ulp_neq_0 x) by now apply Rgt_not_eq. + destruct (round_ge_generic beta fexp Zfloor 0 x) as [Hd|Hd]. + apply generic_format_0. + now apply Rlt_le. + + rewrite ulp_neq_0 by now apply Rgt_not_eq. + now rewrite cexp_DN with (2 := Hd). + + rewrite <- Hd. + unfold cexp. + destruct (mag beta x) as [e He]. + simpl. + specialize (He (Rgt_not_eq _ _ Hx)). + apply sym_eq in Hd. + assert (H := exp_small_round_0 _ _ _ _ _ He Hd). + unfold ulp. + rewrite Req_bool_true by easy. + destruct negligible_exp_spec as [H0|k Hk]. + now elim Zlt_not_le with (1 := H0 e). + now apply f_equal, fexp_negligible_exp_eq. +- rewrite <- Hx, round_0... +Qed. + +Theorem round_neq_0_negligible_exp : + negligible_exp = None -> forall rnd { Zrnd : Valid_rnd rnd } x, + (x <> 0)%R -> (round beta fexp rnd x <> 0)%R. Proof with auto with typeclass_instances. intros H rndn Hrnd x Hx K. case negligible_exp_spec'. intros (_,Hn). -destruct (ln_beta beta x) as (e,He). +destruct (mag beta x) as (e,He). absurd (fexp e < e)%Z. apply Zle_not_lt. apply exp_small_round_0 with beta rndn x... @@ -1819,12 +1822,10 @@ intros (n,(H1,_)). rewrite H in H1; discriminate. Qed. - (** allows rnd x to be 0 *) -(* was ulp_error_f *) Theorem error_lt_ulp_round : forall { Hm : Monotone_exp fexp } rnd { Zrnd : Valid_rnd rnd } x, - ( x <> 0)%R -> + (x <> 0)%R -> (Rabs (round beta fexp rnd x - x) < ulp (round beta fexp rnd x))%R. Proof with auto with typeclass_instances. intros Hm. @@ -1847,72 +1848,34 @@ now apply valid_rnd_opp. now apply Ropp_0_gt_lt_contravar. (* 0 < x *) intros rnd Hrnd x Hx. -case (Rle_lt_or_eq_dec 0 (round beta fexp Zfloor x)). -apply round_ge_generic... -apply generic_format_0. -now left. -(* . 0 < round Zfloor x *) -intros Hx2. apply Rlt_le_trans with (ulp x). apply error_lt_ulp... now apply Rgt_not_eq. rewrite <- ulp_DN; trivial. apply ulp_le_pos. -now left. +apply round_ge_generic... +apply generic_format_0. +now apply Rlt_le. case (round_DN_or_UP beta fexp rnd x); intros V; rewrite V. apply Rle_refl. apply Rle_trans with x. apply round_DN_pt... apply round_UP_pt... -(* . 0 = round Zfloor x *) -intros Hx2. -case (round_DN_or_UP beta fexp rnd x); intros V; rewrite V; clear V. -(* .. round down -- difficult case *) -rewrite <- Hx2. -unfold Rminus; rewrite Rplus_0_l, Rabs_Ropp. -unfold ulp; rewrite Req_bool_true; trivial. -case negligible_exp_spec. -(* without minimal exponent *) -intros K; contradict Hx2. -apply Rlt_not_eq. -apply F2R_gt_0_compat; simpl. -apply Zlt_le_trans with 1%Z. -apply Pos2Z.is_pos. -apply Zfloor_lub. -simpl; unfold scaled_mantissa, canonic_exp. -destruct (ln_beta beta x) as (e,He); simpl. -apply Rle_trans with (bpow (e-1) * bpow (- fexp e))%R. -rewrite <- bpow_plus. -replace 1%R with (bpow 0) by reflexivity. -apply bpow_le. -specialize (K e); omega. -apply Rmult_le_compat_r. -apply bpow_ge_0. -rewrite <- (Rabs_pos_eq x). -now apply He, Rgt_not_eq. -now left. -(* with a minimal exponent *) -intros n Hn. -rewrite Rabs_pos_eq;[idtac|now left]. -case (Rle_or_lt (bpow (fexp n)) x); trivial. -intros K; contradict Hx2. -apply Rlt_not_eq. -apply Rlt_le_trans with (bpow (fexp n)). -apply bpow_gt_0. -apply round_ge_generic... -apply generic_format_bpow. -now apply valid_exp. -(* .. round up *) -apply Rlt_le_trans with (ulp x). -apply error_lt_ulp... -now apply Rgt_not_eq. -apply ulp_le_pos. -now left. -apply round_UP_pt... +now apply Rlt_le. +Qed. + +Lemma error_le_ulp_round : + forall { Hm : Monotone_exp fexp } rnd { Zrnd : Valid_rnd rnd } x, + (Rabs (round beta fexp rnd x - x) <= ulp (round beta fexp rnd x))%R. +Proof. +intros Mexp rnd Vrnd x. +destruct (Req_dec x 0) as [Zx|Nzx]. +{ rewrite Zx, round_0; [|exact Vrnd]. + unfold Rminus; rewrite Ropp_0, Rplus_0_l, Rabs_R0; apply ulp_ge_0. } +now apply Rlt_le, error_lt_ulp_round. Qed. (** allows both x and rnd x to be 0 *) -(* was ulp_half_error_f *) Theorem error_le_half_ulp_round : forall { Hm : Monotone_exp fexp }, forall choice x, @@ -1939,11 +1902,11 @@ apply Rle_trans with (1:=N). right; apply f_equal. rewrite ulp_neq_0; trivial. apply f_equal. -unfold canonic_exp. +unfold cexp. apply valid_exp; trivial. -assert (ln_beta beta x -1 < fexp n)%Z;[idtac|omega]. +assert (mag beta x -1 < fexp n)%Z;[idtac|omega]. apply lt_bpow with beta. -destruct (ln_beta beta x) as (e,He). +destruct (mag beta x) as (e,He). simpl. apply Rle_lt_trans with (Rabs x). now apply He. @@ -1958,42 +1921,29 @@ now right. (* *) case (round_DN_or_UP beta fexp (Znearest choice) x); intros Hx. (* . *) -case (Rle_or_lt 0 (round beta fexp Zfloor x)). -intros H; destruct H. +destruct (Rle_or_lt 0 x) as [H|H]. rewrite Hx at 2. -rewrite ulp_DN; trivial. +rewrite ulp_DN by easy. apply error_le_half_ulp. -rewrite Hx in Hfx; contradict Hfx; auto with real. -intros H. apply Rle_trans with (1:=error_le_half_ulp _ _). apply Rmult_le_compat_l. apply Rlt_le, pos_half_prf. apply ulp_le. -rewrite Hx; rewrite (Rabs_left1 x), Rabs_left; try assumption. +rewrite Rabs_left1 by now apply Rlt_le. +rewrite Hx. +rewrite Rabs_left1. apply Ropp_le_contravar. -apply (round_DN_pt beta fexp x). -case (Rle_or_lt x 0); trivial. -intros H1; contradict H. -apply Rle_not_lt. -apply round_ge_generic... +apply round_DN_pt... +apply round_le_generic... apply generic_format_0. -now left. +now apply Rlt_le. (* . *) -case (Rle_or_lt 0 (round beta fexp Zceil x)). -intros H; destruct H. +destruct (Rle_or_lt 0 x) as [H|H]. apply Rle_trans with (1:=error_le_half_ulp _ _). apply Rmult_le_compat_l. apply Rlt_le, pos_half_prf. apply ulp_le_pos; trivial. -case (Rle_or_lt 0 x); trivial. -intros H1; contradict H. -apply Rle_not_lt. -apply round_le_generic... -apply generic_format_0. -now left. rewrite Hx; apply (round_UP_pt beta fexp x). -rewrite Hx in Hfx; contradict Hfx; auto with real. -intros H. rewrite Hx at 2; rewrite <- (ulp_opp (round beta fexp Zceil x)). rewrite <- round_DN_opp. rewrite ulp_DN; trivial. @@ -2002,7 +1952,9 @@ rewrite round_N_opp. unfold Rminus. rewrite <- Ropp_plus_distr, Rabs_Ropp. apply error_le_half_ulp. -rewrite round_DN_opp; apply Ropp_0_gt_lt_contravar; apply Rlt_gt; assumption. +rewrite <- Ropp_0. +apply Ropp_le_contravar. +now apply Rlt_le. Qed. Theorem pred_le : @@ -2011,18 +1963,22 @@ Theorem pred_le : Proof. intros x y Fx Fy [Hxy| ->]. 2: apply Rle_refl. -apply le_pred_lt with (2 := Fy). +apply pred_ge_gt with (2 := Fy). now apply generic_format_pred. apply Rle_lt_trans with (2 := Hxy). apply pred_le_id. Qed. -Theorem succ_le: forall x y, - F x -> F y -> (x <= y)%R -> (succ x <= succ y)%R. +Theorem succ_le : + forall x y, F x -> F y -> (x <= y)%R -> + (succ x <= succ y)%R. Proof. intros x y Fx Fy Hxy. -rewrite 2!succ_eq_opp_pred_opp. -apply Ropp_le_contravar, pred_le; try apply generic_format_opp; try assumption. +apply Ropp_le_cancel. +rewrite <- 2!pred_opp. +apply pred_le. +now apply generic_format_opp. +now apply generic_format_opp. now apply Ropp_le_contravar. Qed. @@ -2064,8 +2020,95 @@ apply Rgt_not_le with (1 := Hxy). now apply succ_le_inv. Qed. -(* was lt_UP_le_DN *) -Theorem le_round_DN_lt_UP : +(** Adding [ulp] is a, somewhat reasonable, overapproximation of [succ]. *) +Lemma succ_le_plus_ulp : + forall { Hm : Monotone_exp fexp } x, + (succ x <= x + ulp x)%R. +Proof. +intros Mexp x. +destruct (Rle_or_lt 0 x) as [Px|Nx]; [now right; apply succ_eq_pos|]. +replace (_ + _)%R with (- (-x - ulp x))%R by ring. +unfold succ; rewrite (Rle_bool_false _ _ Nx), <-ulp_opp. +apply Ropp_le_contravar; unfold pred_pos. +destruct (Req_dec (-x) (bpow (mag beta (-x) - 1))) as [Hx|Hx]. +{ rewrite (Req_bool_true _ _ Hx). + apply (Rplus_le_reg_r x); ring_simplify; apply Ropp_le_contravar. + unfold ulp; rewrite Req_bool_false; [|lra]. + apply bpow_le, Mexp; lia. } + now rewrite (Req_bool_false _ _ Hx); right. +Qed. + +(** And it also lies in the format. *) +Lemma generic_format_plus_ulp : + forall { Hm : Monotone_exp fexp } x, + generic_format beta fexp x -> + generic_format beta fexp (x + ulp x). +Proof. +intros Mexp x Fx. +destruct (Rle_or_lt 0 x) as [Px|Nx]. +{ now rewrite <-(succ_eq_pos _ Px); apply generic_format_succ. } +apply generic_format_opp in Fx. +replace (_ + _)%R with (- (-x - ulp x))%R by ring. +apply generic_format_opp; rewrite <-ulp_opp. +destruct (Req_dec (-x) (bpow (mag beta (-x) - 1))) as [Hx|Hx]. +{ unfold ulp; rewrite Req_bool_false; [|lra]. + rewrite Hx at 1. + unfold cexp. + set (e := mag _ _). + assert (Hfe : (fexp e < e)%Z). + { now apply mag_generic_gt; [|lra|]. } + replace (e - 1)%Z with (e - 1 - fexp e + fexp e)%Z by ring. + rewrite bpow_plus. + set (m := bpow (_ - _)). + replace (_ - _)%R with ((m - 1) * bpow (fexp e))%R; [|unfold m; ring]. + case_eq (e - 1 - fexp e)%Z. + { intro He; unfold m; rewrite He; simpl; ring_simplify (1 - 1)%R. + rewrite Rmult_0_l; apply generic_format_0. } + { intros p Hp; unfold m; rewrite Hp; simpl. + pose (f := {| Defs.Fnum := (Z.pow_pos beta p - 1)%Z; + Defs.Fexp := fexp e |} : Defs.float beta). + apply (generic_format_F2R' _ _ _ f); [|intro Hm'; unfold f; simpl]. + { now unfold Defs.F2R; simpl; rewrite minus_IZR. } + unfold cexp. + replace (IZR _) with (bpow (Z.pos p)); [|now simpl]. + rewrite <-Hp. + assert (He : (1 <= e - 1 - fexp e)%Z); [lia|]. + set (e' := mag _ (_ * _)). + assert (H : (e' = e - 1 :> Z)%Z); [|rewrite H; apply Mexp; lia]. + unfold e'; apply mag_unique. + rewrite Rabs_mult, (Rabs_pos_eq (bpow _)); [|apply bpow_ge_0]. + rewrite Rabs_pos_eq; + [|apply (Rplus_le_reg_r 1); ring_simplify; + change 1%R with (bpow 0); apply bpow_le; lia]. + assert (beta_pos : (0 < IZR beta)%R). + { apply (Rlt_le_trans _ 2); [lra|]. + apply IZR_le, Z.leb_le, radix_prop. } + split. + { replace (e - 1 - 1)%Z with (e - 1 - fexp e + -1 + fexp e)%Z by ring. + rewrite bpow_plus. + apply Rmult_le_compat_r; [apply bpow_ge_0|]. + rewrite bpow_plus; simpl; unfold Z.pow_pos; simpl. + rewrite Zmult_1_r. + apply (Rmult_le_reg_r _ _ _ beta_pos). + rewrite Rmult_assoc, Rinv_l; [|lra]; rewrite Rmult_1_r. + apply (Rplus_le_reg_r (IZR beta)); ring_simplify. + apply (Rle_trans _ (2 * bpow (e - 1 - fexp e))). + { change 2%R with (1 + 1)%R; rewrite Rmult_plus_distr_r, Rmult_1_l. + apply Rplus_le_compat_l. + rewrite <-bpow_1; apply bpow_le; lia. } + rewrite Rmult_comm; apply Rmult_le_compat_l; [apply bpow_ge_0|]. + apply IZR_le, Z.leb_le, radix_prop. } + apply (Rmult_lt_reg_r (bpow (- fexp e))); [apply bpow_gt_0|]. + rewrite Rmult_assoc, <-!bpow_plus. + replace (fexp e + - fexp e)%Z with 0%Z by ring; simpl. + rewrite Rmult_1_r; unfold Zminus; lra. } + intros p Hp; exfalso; lia. } +replace (_ - _)%R with (pred_pos (-x)). +{ now apply generic_format_pred_pos; [|lra]. } +now unfold pred_pos; rewrite Req_bool_false. +Qed. + +Theorem round_DN_ge_UP_gt : forall x y, F y -> (y < round beta fexp Zceil x -> y <= round beta fexp Zfloor x)%R. Proof with auto with typeclass_instances. @@ -2078,10 +2121,9 @@ apply round_UP_pt... now apply Rlt_le. Qed. -(* was lt_DN_le_UP *) -Theorem round_UP_le_gt_DN : +Theorem round_UP_le_DN_lt : forall x y, F y -> - (round beta fexp Zfloor x < y -> round beta fexp Zceil x <= y)%R. + (round beta fexp Zfloor x < y -> round beta fexp Zceil x <= y)%R. Proof with auto with typeclass_instances. intros x y Fy Hlt. apply round_UP_pt... @@ -2092,8 +2134,6 @@ apply round_DN_pt... now apply Rlt_le. Qed. - - Theorem pred_UP_le_DN : forall x, (pred (round beta fexp Zceil x) <= round beta fexp Zfloor x)%R. Proof with auto with typeclass_instances. @@ -2115,16 +2155,26 @@ absurd (round beta fexp Zceil x <= - bpow (fexp n))%R. apply Rlt_not_le. rewrite Zx, <- Ropp_0. apply Ropp_lt_contravar, bpow_gt_0. -apply round_UP_le_gt_DN; try assumption. +apply round_UP_le_DN_lt; try assumption. apply generic_format_opp, generic_format_bpow. now apply valid_exp. assert (let u := round beta fexp Zceil x in pred u < u)%R as Hup. now apply pred_lt_id. -apply le_round_DN_lt_UP... +apply round_DN_ge_UP_gt... apply generic_format_pred... now apply round_UP_pt. Qed. +Theorem UP_le_succ_DN : + forall x, (round beta fexp Zceil x <= succ (round beta fexp Zfloor x))%R. +Proof. +intros x. +rewrite <- (Ropp_involutive x). +rewrite round_DN_opp, round_UP_opp, succ_opp. +apply Ropp_le_contravar. +apply pred_UP_le_DN. +Qed. + Theorem pred_UP_eq_DN : forall x, ~ F x -> (pred (round beta fexp Zceil x) = round beta fexp Zfloor x)%R. @@ -2132,7 +2182,7 @@ Proof with auto with typeclass_instances. intros x Fx. apply Rle_antisym. now apply pred_UP_le_DN. -apply le_pred_lt; try apply generic_format_round... +apply pred_ge_gt; try apply generic_format_round... pose proof round_DN_UP_lt _ _ _ Fx as HE. now apply Rlt_trans with (1 := proj1 HE) (2 := proj2 HE). Qed. @@ -2147,11 +2197,9 @@ rewrite succ_pred; trivial. apply generic_format_round... Qed. - -(* was betw_eq_DN *) -Theorem round_DN_eq_betw: forall x d, F d - -> (d <= x < succ d)%R - -> round beta fexp Zfloor x = d. +Theorem round_DN_eq : + forall x d, F d -> (d <= x < succ d)%R -> + round beta fexp Zfloor x = d. Proof with auto with typeclass_instances. intros x d Fd (Hxd1,Hxd2). generalize (round_DN_pt beta fexp x); intros (T1,(T2,T3)). @@ -2169,25 +2217,161 @@ apply generic_format_succ... now left. Qed. -(* was betw_eq_UP *) -Theorem round_UP_eq_betw: forall x u, F u - -> (pred u < x <= u)%R - -> round beta fexp Zceil x = u. +Theorem round_UP_eq : + forall x u, F u -> (pred u < x <= u)%R -> + round beta fexp Zceil x = u. Proof with auto with typeclass_instances. intros x u Fu Hux. rewrite <- (Ropp_involutive (round beta fexp Zceil x)). rewrite <- round_DN_opp. rewrite <- (Ropp_involutive u). apply f_equal. -apply round_DN_eq_betw; try assumption. +apply round_DN_eq; try assumption. now apply generic_format_opp. split;[now apply Ropp_le_contravar|idtac]. rewrite succ_opp. now apply Ropp_lt_contravar. Qed. +Lemma ulp_ulp_0 : forall {H : Exp_not_FTZ fexp}, + ulp (ulp 0) = ulp 0. +Proof. +intros H; case (negligible_exp_spec'). +intros (K1,K2). +replace (ulp 0) with 0%R at 1; try easy. +apply sym_eq; unfold ulp; rewrite Req_bool_true; try easy. +now rewrite K1. +intros (n,(Hn1,Hn2)). +apply Rle_antisym. +replace (ulp 0) with (bpow (fexp n)). +rewrite ulp_bpow. +apply bpow_le. +now apply valid_exp. +unfold ulp; rewrite Req_bool_true; try easy. +rewrite Hn1; easy. +now apply ulp_ge_ulp_0. +Qed. +Lemma ulp_succ_pos : forall x, F x -> (0 < x)%R -> + ulp (succ x) = ulp x \/ succ x = bpow (mag beta x). +Proof with auto with typeclass_instances. +intros x Fx Hx. +generalize (Rlt_le _ _ Hx); intros Hx'. +rewrite succ_eq_pos;[idtac|now left]. +destruct (mag beta x) as (e,He); simpl. +rewrite Rabs_pos_eq in He; try easy. +specialize (He (Rgt_not_eq _ _ Hx)). +assert (H:(x+ulp x <= bpow e)%R). +apply id_p_ulp_le_bpow; try assumption. +apply He. +destruct H;[left|now right]. +rewrite ulp_neq_0 at 1. +2: apply Rgt_not_eq, Rgt_lt, Rlt_le_trans with x... +2: rewrite <- (Rplus_0_r x) at 1; apply Rplus_le_compat_l. +2: apply ulp_ge_0. +rewrite ulp_neq_0 at 2. +2: now apply Rgt_not_eq. +f_equal; unfold cexp; f_equal. +apply trans_eq with e. +apply mag_unique_pos; split; try assumption. +apply Rle_trans with (1:=proj1 He). +rewrite <- (Rplus_0_r x) at 1; apply Rplus_le_compat_l. +apply ulp_ge_0. +now apply sym_eq, mag_unique_pos. +Qed. + + +Lemma ulp_round_pos : + forall { Not_FTZ_ : Exp_not_FTZ fexp}, + forall rnd { Zrnd : Valid_rnd rnd } x, + (0 < x)%R -> ulp (round beta fexp rnd x) = ulp x + \/ round beta fexp rnd x = bpow (mag beta x). +Proof with auto with typeclass_instances. +intros Not_FTZ_ rnd Zrnd x Hx. +case (generic_format_EM beta fexp x); intros Fx. +rewrite round_generic... +case (round_DN_or_UP beta fexp rnd x); intros Hr; rewrite Hr. +left. +apply ulp_DN; now left... +assert (M:(0 <= round beta fexp Zfloor x)%R). +apply round_ge_generic... +apply generic_format_0... +apply Rlt_le... +destruct M as [M|M]. +rewrite <- (succ_DN_eq_UP x)... +case (ulp_succ_pos (round beta fexp Zfloor x)); try intros Y. +apply generic_format_round... +assumption. +rewrite ulp_DN in Y... +now apply Rlt_le. +right; rewrite Y. +apply f_equal, mag_DN... +left; rewrite <- (succ_DN_eq_UP x)... +rewrite <- M, succ_0. +rewrite ulp_ulp_0... +case (negligible_exp_spec'). +intros (K1,K2). +absurd (x = 0)%R. +now apply Rgt_not_eq. +apply eq_0_round_0_negligible_exp with Zfloor... +intros (n,(Hn1,Hn2)). +replace (ulp 0) with (bpow (fexp n)). +2: unfold ulp; rewrite Req_bool_true; try easy. +2: now rewrite Hn1. +rewrite ulp_neq_0. +2: apply Rgt_not_eq... +unfold cexp; f_equal. +destruct (mag beta x) as (e,He); simpl. +apply sym_eq, valid_exp... +assert (e <= fexp e)%Z. +apply exp_small_round_0_pos with beta Zfloor x... +rewrite <- (Rabs_pos_eq x). +apply He, Rgt_not_eq... +apply Rlt_le... +replace (fexp n) with (fexp e); try assumption. +now apply fexp_negligible_exp_eq. +Qed. + + +Theorem ulp_round : forall { Not_FTZ_ : Exp_not_FTZ fexp}, + forall rnd { Zrnd : Valid_rnd rnd } x, + ulp (round beta fexp rnd x) = ulp x + \/ Rabs (round beta fexp rnd x) = bpow (mag beta x). +Proof with auto with typeclass_instances. +intros Not_FTZ_ rnd Zrnd x. +case (Rtotal_order x 0); intros Zx. +case (ulp_round_pos (Zrnd_opp rnd) (-x)). +now apply Ropp_0_gt_lt_contravar. +rewrite ulp_opp, <- ulp_opp. +rewrite <- round_opp, Ropp_involutive. +intros Y;now left. +rewrite mag_opp. +intros Y; right. +rewrite <- (Ropp_involutive x) at 1. +rewrite round_opp, Y. +rewrite Rabs_Ropp, Rabs_right... +apply Rle_ge, bpow_ge_0. +destruct Zx as [Zx|Zx]. +left; rewrite Zx; rewrite round_0... +rewrite Rabs_right. +apply ulp_round_pos... +apply Rle_ge, round_ge_generic... +apply generic_format_0... +now apply Rlt_le. +Qed. + +Lemma succ_round_ge_id : + forall rnd { Zrnd : Valid_rnd rnd } x, + (x <= succ (round beta fexp rnd x))%R. +Proof. +intros rnd Vrnd x. +apply (Rle_trans _ (round beta fexp Raux.Zceil x)). +{ now apply round_UP_pt. } +destruct (round_DN_or_UP beta fexp rnd x) as [Hr|Hr]; rewrite Hr. +{ now apply UP_le_succ_DN. } +apply succ_ge_id. +Qed. (** Properties of rounding to nearest and ulp *) @@ -2215,14 +2399,14 @@ assert (T: (u < (u + succ u) / 2 < succ u)%R) by lra. destruct T as (T1,T2). apply Rnd_N_pt_monotone with F v ((u + succ u) / 2)%R... apply round_N_pt... -apply Rnd_DN_pt_N with (succ u)%R. +apply Rnd_N_pt_DN with (succ u)%R. pattern u at 3; replace u with (round beta fexp Zfloor ((u + succ u) / 2)). apply round_DN_pt... -apply round_DN_eq_betw; trivial. +apply round_DN_eq; trivial. split; try left; assumption. pattern (succ u) at 2; replace (succ u) with (round beta fexp Zceil ((u + succ u) / 2)). apply round_UP_pt... -apply round_UP_eq_betw; trivial. +apply round_UP_eq; trivial. apply generic_format_succ... rewrite pred_succ; trivial. split; try left; assumption. @@ -2275,12 +2459,12 @@ Lemma round_N_eq_DN_pt: forall choice x d u, Proof with auto with typeclass_instances. intros choice x d u Hd Hu H. assert (H0:(d = round beta fexp Zfloor x)%R). -apply Rnd_DN_pt_unicity with (1:=Hd). +apply Rnd_DN_pt_unique with (1:=Hd). apply round_DN_pt... rewrite H0. apply round_N_eq_DN. rewrite <- H0. -rewrite Rnd_UP_pt_unicity with F x (round beta fexp Zceil x) u; try assumption. +rewrite Rnd_UP_pt_unique with F x (round beta fexp Zceil x) u; try assumption. apply round_UP_pt... Qed. @@ -2310,13 +2494,28 @@ Lemma round_N_eq_UP_pt: forall choice x d u, Proof with auto with typeclass_instances. intros choice x d u Hd Hu H. assert (H0:(u = round beta fexp Zceil x)%R). -apply Rnd_UP_pt_unicity with (1:=Hu). +apply Rnd_UP_pt_unique with (1:=Hu). apply round_UP_pt... rewrite H0. apply round_N_eq_UP. rewrite <- H0. -rewrite Rnd_DN_pt_unicity with F x (round beta fexp Zfloor x) d; try assumption. +rewrite Rnd_DN_pt_unique with F x (round beta fexp Zfloor x) d; try assumption. apply round_DN_pt... Qed. +Lemma round_N_plus_ulp_ge : + forall { Hm : Monotone_exp fexp } choice1 choice2 x, + let rx := round beta fexp (Znearest choice2) x in + (x <= round beta fexp (Znearest choice1) (rx + ulp rx))%R. +Proof. +intros Hm choice1 choice2 x. +simpl. +set (rx := round _ _ _ x). +assert (Vrnd1 : Valid_rnd (Znearest choice1)) by now apply valid_rnd_N. +assert (Vrnd2 : Valid_rnd (Znearest choice2)) by now apply valid_rnd_N. +apply (Rle_trans _ (succ rx)); [now apply succ_round_ge_id|]. +rewrite round_generic; [now apply succ_le_plus_ulp|now simpl|]. +now apply generic_format_plus_ulp, generic_format_round. +Qed. + End Fcore_ulp. diff --git a/flocq/Core/Fcore_Zaux.v b/flocq/Core/Zaux.v index f6731b4c..e21d93a4 100644 --- a/flocq/Core/Fcore_Zaux.v +++ b/flocq/Core/Zaux.v @@ -2,9 +2,9 @@ This file is part of the Flocq formalization of floating-point arithmetic in Coq: http://flocq.gforge.inria.fr/ -Copyright (C) 2011-2013 Sylvie Boldo +Copyright (C) 2011-2018 Sylvie Boldo #<br /># -Copyright (C) 2011-2013 Guillaume Melquiond +Copyright (C) 2011-2018 Guillaume Melquiond This library is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public @@ -17,7 +17,7 @@ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the COPYING file for more details. *) -Require Import ZArith. +Require Import ZArith Omega. Require Import Zquot. Section Zmissing. @@ -25,7 +25,7 @@ Section Zmissing. (** About Z *) Theorem Zopp_le_cancel : forall x y : Z, - (-y <= -x)%Z -> Zle x y. + (-y <= -x)%Z -> Z.le x y. Proof. intros x y Hxy. apply Zplus_le_reg_r with (-x - y)%Z. @@ -37,7 +37,7 @@ Theorem Zgt_not_eq : (y < x)%Z -> (x <> y)%Z. Proof. intros x y H Hn. -apply Zlt_irrefl with x. +apply Z.lt_irrefl with x. now rewrite Hn at 1. Qed. @@ -69,29 +69,8 @@ End Proof_Irrelevance. Section Even_Odd. -(** Zeven, used for rounding to nearest, ties to even *) -Definition Zeven (n : Z) := - match n with - | Zpos (xO _) => true - | Zneg (xO _) => true - | Z0 => true - | _ => false - end. - -Theorem Zeven_mult : - forall x y, Zeven (x * y) = orb (Zeven x) (Zeven y). -Proof. -now intros [|[xp|xp|]|[xp|xp|]] [|[yp|yp|]|[yp|yp|]]. -Qed. - -Theorem Zeven_opp : - forall x, Zeven (- x) = Zeven x. -Proof. -now intros [|[n|n|]|[n|n|]]. -Qed. - Theorem Zeven_ex : - forall x, exists p, x = (2 * p + if Zeven x then 0 else 1)%Z. + forall x, exists p, x = (2 * p + if Z.even x then 0 else 1)%Z. Proof. intros [|[n|n|]|[n|n|]]. now exists Z0. @@ -105,37 +84,6 @@ now exists (Zneg n). now exists (-1)%Z. Qed. -Theorem Zeven_2xp1 : - forall n, Zeven (2 * n + 1) = false. -Proof. -intros n. -destruct (Zeven_ex (2 * n + 1)) as (p, Hp). -revert Hp. -case (Zeven (2 * n + 1)) ; try easy. -intros H. -apply False_ind. -omega. -Qed. - -Theorem Zeven_plus : - forall x y, Zeven (x + y) = Bool.eqb (Zeven x) (Zeven y). -Proof. -intros x y. -destruct (Zeven_ex x) as (px, Hx). -rewrite Hx at 1. -destruct (Zeven_ex y) as (py, Hy). -rewrite Hy at 1. -replace (2 * px + (if Zeven x then 0 else 1) + (2 * py + (if Zeven y then 0 else 1)))%Z - with (2 * (px + py) + ((if Zeven x then 0 else 1) + (if Zeven y then 0 else 1)))%Z by ring. -case (Zeven x) ; case (Zeven y). -rewrite Zplus_0_r. -now rewrite Zeven_mult. -apply Zeven_2xp1. -apply Zeven_2xp1. -replace (2 * (px + py) + (1 + 1))%Z with (2 * (px + py + 1))%Z by ring. -now rewrite Zeven_mult. -Qed. - End Even_Odd. Section Zpower. @@ -145,12 +93,12 @@ Theorem Zpower_plus : Zpower n (k1 + k2) = (Zpower n k1 * Zpower n k2)%Z. Proof. intros n k1 k2 H1 H2. -now apply Zpower_exp ; apply Zle_ge. +now apply Zpower_exp ; apply Z.le_ge. Qed. Theorem Zpower_Zpower_nat : forall b e, (0 <= e)%Z -> - Zpower b e = Zpower_nat b (Zabs_nat e). + Zpower b e = Zpower_nat b (Z.abs_nat e). Proof. intros b [|e|e] He. apply refl_equal. @@ -181,40 +129,14 @@ rewrite Zpower_nat_S. now apply Zmult_lt_0_compat. Qed. -Theorem Zeven_Zpower : - forall b e, (0 < e)%Z -> - Zeven (Zpower b e) = Zeven b. -Proof. -intros b e He. -case_eq (Zeven b) ; intros Hb. -(* b even *) -replace e with (e - 1 + 1)%Z by ring. -rewrite Zpower_exp. -rewrite Zeven_mult. -replace (Zeven (b ^ 1)) with true. -apply Bool.orb_true_r. -unfold Zpower, Zpower_pos. simpl. -now rewrite Zmult_1_r. -omega. -discriminate. -(* b odd *) -rewrite Zpower_Zpower_nat. -induction (Zabs_nat e). -easy. -unfold Zpower_nat. simpl. -rewrite Zeven_mult. -now rewrite Hb. -now apply Zlt_le_weak. -Qed. - Theorem Zeven_Zpower_odd : - forall b e, (0 <= e)%Z -> Zeven b = false -> - Zeven (Zpower b e) = false. + forall b e, (0 <= e)%Z -> Z.even b = false -> + Z.even (Zpower b e) = false. Proof. intros b e He Hb. destruct (Z_le_lt_eq_dec _ _ He) as [He'|He']. rewrite <- Hb. -now apply Zeven_Zpower. +now apply Z.even_pow. now rewrite <- He'. Qed. @@ -239,7 +161,7 @@ Variable r : radix. Theorem radix_gt_0 : (0 < r)%Z. Proof. -apply Zlt_le_trans with 2%Z. +apply Z.lt_le_trans with 2%Z. easy. apply Zle_bool_imp_le. apply r. @@ -248,7 +170,7 @@ Qed. Theorem radix_gt_1 : (1 < r)%Z. Proof. destruct r as (v, Hr). simpl. -apply Zlt_le_trans with 2%Z. +apply Z.lt_le_trans with 2%Z. easy. now apply Zle_bool_imp_le. Qed. @@ -273,7 +195,7 @@ easy. rewrite Zpower_nat_S. apply Zmult_lt_0_compat with (2 := IHn). apply radix_gt_0. -apply Zle_lt_trans with (1 * Zpower_nat r n)%Z. +apply Z.le_lt_trans with (1 * Zpower_nat r n)%Z. rewrite Zmult_1_l. now apply (Zlt_le_succ 0). apply Zmult_lt_compat_r with (1 := H). @@ -287,7 +209,7 @@ Theorem Zpower_gt_0 : Proof. intros p Hp. rewrite Zpower_Zpower_nat with (1 := Hp). -induction (Zabs_nat p). +induction (Z.abs_nat p). easy. rewrite Zpower_nat_S. apply Zmult_lt_0_compat with (2 := IHn). @@ -336,7 +258,7 @@ rewrite <- (Zmult_1_r (r ^ e1)) at 1. apply Zmult_lt_compat2. split. now apply Zpower_gt_0. -apply Zle_refl. +apply Z.le_refl. split. easy. apply Zpower_gt_1. @@ -363,6 +285,36 @@ apply Zpower_le. clear -H ; omega. Qed. +Theorem Zpower_gt_id : + forall n, (n < Zpower r n)%Z. +Proof. +intros [|n|n] ; try easy. +simpl. +rewrite Zpower_pos_nat. +rewrite Zpos_eq_Z_of_nat_o_nat_of_P. +induction (nat_of_P n). +easy. +rewrite inj_S. +change (Zpower_nat r (S n0)) with (r * Zpower_nat r n0)%Z. +unfold Z.succ. +apply Z.lt_le_trans with (r * (Z_of_nat n0 + 1))%Z. +clear. +apply Zlt_0_minus_lt. +replace (r * (Z_of_nat n0 + 1) - (Z_of_nat n0 + 1))%Z with ((r - 1) * (Z_of_nat n0 + 1))%Z by ring. +apply Zmult_lt_0_compat. +cut (2 <= r)%Z. omega. +apply Zle_bool_imp_le. +apply r. +apply (Zle_lt_succ 0). +apply Zle_0_nat. +apply Zmult_le_compat_l. +now apply Zlt_le_succ. +apply Z.le_trans with 2%Z. +easy. +apply Zle_bool_imp_le. +apply r. +Qed. + End Zpower. Section Div_Mod. @@ -380,7 +332,7 @@ rewrite Zopp_mult_distr_l. apply Z_mod_plus. easy. apply Zmult_gt_0_compat. -now apply Zlt_gt. +now apply Z.lt_gt. easy. now elim Hb. Qed. @@ -411,7 +363,7 @@ Qed. Theorem Zdiv_mod_mult : forall n a b, (0 <= a)%Z -> (0 <= b)%Z -> - (Zdiv (Zmod n (a * b)) a) = Zmod (Zdiv n a) b. + (Z.div (Zmod n (a * b)) a) = Zmod (Z.div n a) b. Proof. intros n a b Ha Hb. destruct (Zle_lt_or_eq _ _ Ha) as [Ha'|Ha']. @@ -421,12 +373,12 @@ rewrite (Zmult_comm a b) at 2. rewrite Zmult_assoc. unfold Zminus. rewrite Zopp_mult_distr_l. -rewrite Z_div_plus by now apply Zlt_gt. +rewrite Z_div_plus by now apply Z.lt_gt. rewrite <- Zdiv_Zdiv by easy. apply sym_eq. apply Zmod_eq. -now apply Zlt_gt. -now apply Zmult_gt_0_compat ; apply Zlt_gt. +now apply Z.lt_gt. +now apply Zmult_gt_0_compat ; apply Z.lt_gt. rewrite <- Hb'. rewrite Zmult_0_r, 2!Zmod_0_r. apply Zdiv_0_l. @@ -439,7 +391,7 @@ Theorem ZOdiv_mod_mult : (Z.quot (Z.rem n (a * b)) a) = Z.rem (Z.quot n a) b. Proof. intros n a b. -destruct (Z_eq_dec a 0) as [Za|Za]. +destruct (Z.eq_dec a 0) as [Za|Za]. rewrite Za. now rewrite 2!Zquot_0_r, Zrem_0_l. assert (Z.rem n (a * b) = n + - (Z.quot (Z.quot n a) b * b) * a)%Z. @@ -456,34 +408,34 @@ Qed. Theorem ZOdiv_small_abs : forall a b, - (Zabs a < b)%Z -> Z.quot a b = Z0. + (Z.abs a < b)%Z -> Z.quot a b = Z0. Proof. intros a b Ha. destruct (Zle_or_lt 0 a) as [H|H]. -apply Zquot_small. +apply Z.quot_small. split. exact H. -now rewrite Zabs_eq in Ha. -apply Zopp_inj. -rewrite <- Zquot_opp_l, Zopp_0. -apply Zquot_small. +now rewrite Z.abs_eq in Ha. +apply Z.opp_inj. +rewrite <- Zquot_opp_l, Z.opp_0. +apply Z.quot_small. generalize (Zabs_non_eq a). omega. Qed. Theorem ZOmod_small_abs : forall a b, - (Zabs a < b)%Z -> Z.rem a b = a. + (Z.abs a < b)%Z -> Z.rem a b = a. Proof. intros a b Ha. destruct (Zle_or_lt 0 a) as [H|H]. -apply Zrem_small. +apply Z.rem_small. split. exact H. -now rewrite Zabs_eq in Ha. -apply Zopp_inj. +now rewrite Z.abs_eq in Ha. +apply Z.opp_inj. rewrite <- Zrem_opp_l. -apply Zrem_small. +apply Z.rem_small. generalize (Zabs_non_eq a). omega. Qed. @@ -493,7 +445,7 @@ Theorem ZOdiv_plus : (Z.quot (a + b) c = Z.quot a c + Z.quot b c + Z.quot (Z.rem a c + Z.rem b c) c)%Z. Proof. intros a b c Hab. -destruct (Z_eq_dec c 0) as [Zc|Zc]. +destruct (Z.eq_dec c 0) as [Zc|Zc]. now rewrite Zc, 4!Zquot_0_r. apply Zmult_reg_r with (1 := Zc). rewrite 2!Zmult_plus_distr_l. @@ -632,8 +584,8 @@ Proof. intros x y Hxy. generalize (Zle_cases x y). case Zle_bool ; intros H. -elim (Zlt_irrefl x). -now apply Zle_lt_trans with y. +elim (Z.lt_irrefl x). +now apply Z.le_lt_trans with y. apply refl_equal. Qed. @@ -672,8 +624,8 @@ Proof. intros x y Hxy. generalize (Zlt_cases x y). case Zlt_bool ; intros H. -elim (Zlt_irrefl x). -now apply Zlt_le_trans with y. +elim (Z.lt_irrefl x). +now apply Z.lt_le_trans with y. apply refl_equal. Qed. @@ -707,32 +659,32 @@ Inductive Zcompare_prop (x y : Z) : comparison -> Prop := | Zcompare_Gt_ : (y < x)%Z -> Zcompare_prop x y Gt. Theorem Zcompare_spec : - forall x y, Zcompare_prop x y (Zcompare x y). + forall x y, Zcompare_prop x y (Z.compare x y). Proof. intros x y. destruct (Z_dec x y) as [[H|H]|H]. generalize (Zlt_compare _ _ H). -case (Zcompare x y) ; try easy. +case (Z.compare x y) ; try easy. now constructor. generalize (Zgt_compare _ _ H). -case (Zcompare x y) ; try easy. +case (Z.compare x y) ; try easy. constructor. -now apply Zgt_lt. +now apply Z.gt_lt. generalize (proj2 (Zcompare_Eq_iff_eq _ _) H). -case (Zcompare x y) ; try easy. +case (Z.compare x y) ; try easy. now constructor. Qed. Theorem Zcompare_Lt : forall x y, - (x < y)%Z -> Zcompare x y = Lt. + (x < y)%Z -> Z.compare x y = Lt. Proof. easy. Qed. Theorem Zcompare_Eq : forall x y, - (x = y)%Z -> Zcompare x y = Eq. + (x = y)%Z -> Z.compare x y = Eq. Proof. intros x y. apply <- Zcompare_Eq_iff_eq. @@ -740,21 +692,29 @@ Qed. Theorem Zcompare_Gt : forall x y, - (y < x)%Z -> Zcompare x y = Gt. + (y < x)%Z -> Z.compare x y = Gt. Proof. intros x y. -apply Zlt_gt. +apply Z.lt_gt. Qed. End Zcompare. Section cond_Zopp. -Definition cond_Zopp (b : bool) m := if b then Zopp m else m. +Definition cond_Zopp (b : bool) m := if b then Z.opp m else m. + +Theorem cond_Zopp_negb : + forall x y, cond_Zopp (negb x) y = Z.opp (cond_Zopp x y). +Proof. +intros [|] y. +apply sym_eq, Z.opp_involutive. +easy. +Qed. Theorem abs_cond_Zopp : forall b m, - Zabs (cond_Zopp b m) = Zabs m. + Z.abs (cond_Zopp b m) = Z.abs m. Proof. intros [|] m. apply Zabs_Zopp. @@ -763,14 +723,14 @@ Qed. Theorem cond_Zopp_Zlt_bool : forall m, - cond_Zopp (Zlt_bool m 0) m = Zabs m. + cond_Zopp (Zlt_bool m 0) m = Z.abs m. Proof. intros m. apply sym_eq. case Zlt_bool_spec ; intros Hm. apply Zabs_non_eq. now apply Zlt_le_weak. -now apply Zabs_eq. +now apply Z.abs_eq. Qed. End cond_Zopp. @@ -808,11 +768,11 @@ Section faster_div. Lemma Zdiv_eucl_unique : forall a b, - Zdiv_eucl a b = (Zdiv a b, Zmod a b). + Z.div_eucl a b = (Z.div a b, Zmod a b). Proof. intros a b. -unfold Zdiv, Zmod. -now case Zdiv_eucl. +unfold Z.div, Zmod. +now case Z.div_eucl. Qed. Fixpoint Zpos_div_eucl_aux1 (a b : positive) {struct b} := @@ -835,7 +795,7 @@ intros a b. revert a. induction b ; intros a. - easy. -- change (Z.pos_div_eucl a (Zpos b~0)) with (Zdiv_eucl (Zpos a) (Zpos b~0)). +- change (Z.pos_div_eucl a (Zpos b~0)) with (Z.div_eucl (Zpos a) (Zpos b~0)). rewrite Zdiv_eucl_unique. change (Zpos b~0) with (2 * Zpos b)%Z. rewrite Z.rem_mul_r by easy. @@ -843,7 +803,7 @@ induction b ; intros a. destruct a as [a|a|]. + change (Zpos_div_eucl_aux1 a~1 b~0) with (let (q, r) := Zpos_div_eucl_aux1 a b in (q, 2 * r + 1)%Z). rewrite IHb. clear IHb. - change (Z.pos_div_eucl a (Zpos b)) with (Zdiv_eucl (Zpos a) (Zpos b)). + change (Z.pos_div_eucl a (Zpos b)) with (Z.div_eucl (Zpos a) (Zpos b)). rewrite Zdiv_eucl_unique. change (Zpos a~1) with (1 + 2 * Zpos a)%Z. rewrite (Zmult_comm 2 (Zpos a)). @@ -853,7 +813,7 @@ induction b ; intros a. apply Zplus_comm. + change (Zpos_div_eucl_aux1 a~0 b~0) with (let (q, r) := Zpos_div_eucl_aux1 a b in (q, 2 * r)%Z). rewrite IHb. clear IHb. - change (Z.pos_div_eucl a (Zpos b)) with (Zdiv_eucl (Zpos a) (Zpos b)). + change (Z.pos_div_eucl a (Zpos b)) with (Z.div_eucl (Zpos a) (Zpos b)). rewrite Zdiv_eucl_unique. change (Zpos a~0) with (2 * Zpos a)%Z. rewrite (Zmult_comm 2 (Zpos a)). @@ -861,7 +821,7 @@ induction b ; intros a. apply f_equal. now rewrite Z_mod_mult. + easy. -- change (Z.pos_div_eucl a 1) with (Zdiv_eucl (Zpos a) 1). +- change (Z.pos_div_eucl a 1) with (Z.div_eucl (Zpos a) 1). rewrite Zdiv_eucl_unique. now rewrite Zdiv_1_r, Zmod_1_r. Qed. @@ -879,13 +839,13 @@ Lemma Zpos_div_eucl_aux_correct : Proof. intros a b. unfold Zpos_div_eucl_aux. -change (Z.pos_div_eucl a (Zpos b)) with (Zdiv_eucl (Zpos a) (Zpos b)). +change (Z.pos_div_eucl a (Zpos b)) with (Z.div_eucl (Zpos a) (Zpos b)). rewrite Zdiv_eucl_unique. case Pos.compare_spec ; intros H. now rewrite H, Z_div_same, Z_mod_same. now rewrite Zdiv_small, Zmod_small by (split ; easy). rewrite Zpos_div_eucl_aux1_correct. -change (Z.pos_div_eucl a (Zpos b)) with (Zdiv_eucl (Zpos a) (Zpos b)). +change (Z.pos_div_eucl a (Zpos b)) with (Z.div_eucl (Zpos a) (Zpos b)). apply Zdiv_eucl_unique. Qed. @@ -920,7 +880,7 @@ Definition Zfast_div_eucl (a b : Z) := Theorem Zfast_div_eucl_correct : forall a b : Z, - Zfast_div_eucl a b = Zdiv_eucl a b. + Zfast_div_eucl a b = Z.div_eucl a b. Proof. unfold Zfast_div_eucl. intros [|a|a] [|b|b] ; try rewrite Zpos_div_eucl_aux_correct ; easy. diff --git a/flocq/IEEE754/Binary.v b/flocq/IEEE754/Binary.v new file mode 100644 index 00000000..0ec3a297 --- /dev/null +++ b/flocq/IEEE754/Binary.v @@ -0,0 +1,2814 @@ +(** +This file is part of the Flocq formalization of floating-point +arithmetic in Coq: http://flocq.gforge.inria.fr/ + +Copyright (C) 2010-2018 Sylvie Boldo +#<br /># +Copyright (C) 2010-2018 Guillaume Melquiond + +This library is free software; you can redistribute it and/or +modify it under the terms of the GNU Lesser General Public +License as published by the Free Software Foundation; either +version 3 of the License, or (at your option) any later version. + +This library is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +COPYING file for more details. +*) + +(** * IEEE-754 arithmetic *) +Require Import Core Digits Round Bracket Operations Div Sqrt Relative. +Require Import Psatz. + +Section AnyRadix. + +Inductive full_float := + | F754_zero (s : bool) + | F754_infinity (s : bool) + | F754_nan (s : bool) (m : positive) + | F754_finite (s : bool) (m : positive) (e : Z). + +Definition FF2R beta x := + match x with + | F754_finite s m e => F2R (Float beta (cond_Zopp s (Zpos m)) e) + | _ => 0%R + end. + +End AnyRadix. + +Section Binary. + +Arguments exist {A} {P}. + +(** [prec] is the number of bits of the mantissa including the implicit one; + [emax] is the exponent of the infinities. + For instance, binary32 is defined by [prec = 24] and [emax = 128]. *) +Variable prec emax : Z. +Context (prec_gt_0_ : Prec_gt_0 prec). +Hypothesis Hmax : (prec < emax)%Z. + +Let emin := (3 - emax - prec)%Z. +Let fexp := FLT_exp emin prec. +Instance fexp_correct : Valid_exp fexp := FLT_exp_valid emin prec. +Instance fexp_monotone : Monotone_exp fexp := FLT_exp_monotone emin prec. + +Definition canonical_mantissa m e := + Zeq_bool (fexp (Zpos (digits2_pos m) + e)) e. + +Definition bounded m e := + andb (canonical_mantissa m e) (Zle_bool e (emax - prec)). + +Definition nan_pl pl := + Zlt_bool (Zpos (digits2_pos pl)) prec. + +Definition valid_binary x := + match x with + | F754_finite _ m e => bounded m e + | F754_nan _ pl => nan_pl pl + | _ => true + end. + +(** Basic type used for representing binary FP numbers. + Note that there is exactly one such object per FP datum. *) + +Inductive binary_float := + | B754_zero (s : bool) + | B754_infinity (s : bool) + | B754_nan (s : bool) (pl : positive) : + nan_pl pl = true -> binary_float + | B754_finite (s : bool) (m : positive) (e : Z) : + bounded m e = true -> binary_float. + +Definition FF2B x := + match x as x return valid_binary x = true -> binary_float with + | F754_finite s m e => B754_finite s m e + | F754_infinity s => fun _ => B754_infinity s + | F754_zero s => fun _ => B754_zero s + | F754_nan b pl => fun H => B754_nan b pl H + end. + +Definition B2FF x := + match x with + | B754_finite s m e _ => F754_finite s m e + | B754_infinity s => F754_infinity s + | B754_zero s => F754_zero s + | B754_nan b pl _ => F754_nan b pl + end. + +Definition B2R f := + match f with + | B754_finite s m e _ => F2R (Float radix2 (cond_Zopp s (Zpos m)) e) + | _ => 0%R + end. + +Theorem FF2R_B2FF : + forall x, + FF2R radix2 (B2FF x) = B2R x. +Proof. +now intros [sx|sx|sx plx Hplx|sx mx ex Hx]. +Qed. + +Theorem B2FF_FF2B : + forall x Hx, + B2FF (FF2B x Hx) = x. +Proof. +now intros [sx|sx|sx plx|sx mx ex] Hx. +Qed. + +Theorem valid_binary_B2FF : + forall x, + valid_binary (B2FF x) = true. +Proof. +now intros [sx|sx|sx plx Hplx|sx mx ex Hx]. +Qed. + +Theorem FF2B_B2FF : + forall x H, + FF2B (B2FF x) H = x. +Proof. +intros [sx|sx|sx plx Hplx|sx mx ex Hx] H ; try easy. +apply f_equal, eqbool_irrelevance. +apply f_equal, eqbool_irrelevance. +Qed. + +Theorem FF2B_B2FF_valid : + forall x, + FF2B (B2FF x) (valid_binary_B2FF x) = x. +Proof. +intros x. +apply FF2B_B2FF. +Qed. + +Theorem B2R_FF2B : + forall x Hx, + B2R (FF2B x Hx) = FF2R radix2 x. +Proof. +now intros [sx|sx|sx plx|sx mx ex] Hx. +Qed. + +Theorem match_FF2B : + forall {T} fz fi fn ff x Hx, + match FF2B x Hx return T with + | B754_zero sx => fz sx + | B754_infinity sx => fi sx + | B754_nan b p _ => fn b p + | B754_finite sx mx ex _ => ff sx mx ex + end = + match x with + | F754_zero sx => fz sx + | F754_infinity sx => fi sx + | F754_nan b p => fn b p + | F754_finite sx mx ex => ff sx mx ex + end. +Proof. +now intros T fz fi fn ff [sx|sx|sx plx|sx mx ex] Hx. +Qed. + +Theorem canonical_canonical_mantissa : + forall (sx : bool) mx ex, + canonical_mantissa mx ex = true -> + canonical radix2 fexp (Float radix2 (cond_Zopp sx (Zpos mx)) ex). +Proof. +intros sx mx ex H. +assert (Hx := Zeq_bool_eq _ _ H). clear H. +apply sym_eq. +simpl. +pattern ex at 2 ; rewrite <- Hx. +apply (f_equal fexp). +rewrite mag_F2R_Zdigits. +rewrite <- Zdigits_abs. +rewrite Zpos_digits2_pos. +now case sx. +now case sx. +Qed. + +Theorem generic_format_B2R : + forall x, + generic_format radix2 fexp (B2R x). +Proof. +intros [sx|sx|sx plx Hx |sx mx ex Hx] ; try apply generic_format_0. +simpl. +apply generic_format_canonical. +apply canonical_canonical_mantissa. +now destruct (andb_prop _ _ Hx) as (H, _). +Qed. + +Theorem FLT_format_B2R : + forall x, + FLT_format radix2 emin prec (B2R x). +Proof with auto with typeclass_instances. +intros x. +apply FLT_format_generic... +apply generic_format_B2R. +Qed. + +Theorem B2FF_inj : + forall x y : binary_float, + B2FF x = B2FF y -> + x = y. +Proof. +intros [sx|sx|sx plx Hplx|sx mx ex Hx] [sy|sy|sy ply Hply|sy my ey Hy] ; try easy. +(* *) +intros H. +now inversion H. +(* *) +intros H. +now inversion H. +(* *) +intros H. +inversion H. +clear H. +revert Hplx. +rewrite H2. +intros Hx. +apply f_equal, eqbool_irrelevance. +(* *) +intros H. +inversion H. +clear H. +revert Hx. +rewrite H2, H3. +intros Hx. +apply f_equal, eqbool_irrelevance. +Qed. + +Definition is_finite_strict f := + match f with + | B754_finite _ _ _ _ => true + | _ => false + end. + +Theorem B2R_inj: + forall x y : binary_float, + is_finite_strict x = true -> + is_finite_strict y = true -> + B2R x = B2R y -> + x = y. +Proof. +intros [sx|sx| |sx mx ex Hx] [sy|sy| |sy my ey Hy] ; try easy. +simpl. +intros _ _ Heq. +assert (Hs: sx = sy). +(* *) +revert Heq. clear. +case sx ; case sy ; try easy ; + intros Heq ; apply False_ind ; revert Heq. +apply Rlt_not_eq. +apply Rlt_trans with R0. +now apply F2R_lt_0. +now apply F2R_gt_0. +apply Rgt_not_eq. +apply Rgt_trans with R0. +now apply F2R_gt_0. +now apply F2R_lt_0. +assert (mx = my /\ ex = ey). +(* *) +refine (_ (canonical_unique _ fexp _ _ _ _ Heq)). +rewrite Hs. +now case sy ; intro H ; injection H ; split. +apply canonical_canonical_mantissa. +exact (proj1 (andb_prop _ _ Hx)). +apply canonical_canonical_mantissa. +exact (proj1 (andb_prop _ _ Hy)). +(* *) +revert Hx. +rewrite Hs, (proj1 H), (proj2 H). +intros Hx. +apply f_equal. +apply eqbool_irrelevance. +Qed. + +Definition Bsign x := + match x with + | B754_nan s _ _ => s + | B754_zero s => s + | B754_infinity s => s + | B754_finite s _ _ _ => s + end. + +Definition sign_FF x := + match x with + | F754_nan s _ => s + | F754_zero s => s + | F754_infinity s => s + | F754_finite s _ _ => s + end. + +Theorem Bsign_FF2B : + forall x H, + Bsign (FF2B x H) = sign_FF x. +Proof. +now intros [sx|sx|sx plx|sx mx ex] H. +Qed. + +Definition is_finite f := + match f with + | B754_finite _ _ _ _ => true + | B754_zero _ => true + | _ => false + end. + +Definition is_finite_FF f := + match f with + | F754_finite _ _ _ => true + | F754_zero _ => true + | _ => false + end. + +Theorem is_finite_FF2B : + forall x Hx, + is_finite (FF2B x Hx) = is_finite_FF x. +Proof. +now intros [| | |]. +Qed. + +Theorem is_finite_FF_B2FF : + forall x, + is_finite_FF (B2FF x) = is_finite x. +Proof. +now intros [| |? []|]. +Qed. + +Theorem B2R_Bsign_inj: + forall x y : binary_float, + is_finite x = true -> + is_finite y = true -> + B2R x = B2R y -> + Bsign x = Bsign y -> + x = y. +Proof. +intros. destruct x, y; try (apply B2R_inj; now eauto). +- simpl in H2. congruence. +- symmetry in H1. apply Rmult_integral in H1. + destruct H1. apply (eq_IZR _ 0) in H1. destruct s0; discriminate H1. + simpl in H1. pose proof (bpow_gt_0 radix2 e). + rewrite H1 in H3. apply Rlt_irrefl in H3. destruct H3. +- apply Rmult_integral in H1. + destruct H1. apply (eq_IZR _ 0) in H1. destruct s; discriminate H1. + simpl in H1. pose proof (bpow_gt_0 radix2 e). + rewrite H1 in H3. apply Rlt_irrefl in H3. destruct H3. +Qed. + +Definition is_nan f := + match f with + | B754_nan _ _ _ => true + | _ => false + end. + +Definition is_nan_FF f := + match f with + | F754_nan _ _ => true + | _ => false + end. + +Theorem is_nan_FF2B : + forall x Hx, + is_nan (FF2B x Hx) = is_nan_FF x. +Proof. +now intros [| | |]. +Qed. + +Theorem is_nan_FF_B2FF : + forall x, + is_nan_FF (B2FF x) = is_nan x. +Proof. +now intros [| |? []|]. +Qed. + +Definition get_nan_pl (x : binary_float) : positive := + match x with B754_nan _ pl _ => pl | _ => xH end. + +Definition build_nan (x : { x | is_nan x = true }) : binary_float. +Proof. +apply (B754_nan (Bsign (proj1_sig x)) (get_nan_pl (proj1_sig x))). +destruct x as [x H]. +simpl. +revert H. +assert (H: false = true -> nan_pl 1 = true) by now destruct (nan_pl 1). +destruct x; try apply H. +intros _. +apply e. +Defined. + +Theorem build_nan_correct : + forall x : { x | is_nan x = true }, + build_nan x = proj1_sig x. +Proof. +intros [x H]. +now destruct x. +Qed. + +Theorem B2R_build_nan : + forall x, B2R (build_nan x) = 0%R. +Proof. +easy. +Qed. + +Theorem is_finite_build_nan : + forall x, is_finite (build_nan x) = false. +Proof. +easy. +Qed. + +Theorem is_nan_build_nan : + forall x, is_nan (build_nan x) = true. +Proof. +easy. +Qed. + +Definition erase (x : binary_float) : binary_float. +Proof. +destruct x as [s|s|s pl H|s m e H]. +- exact (B754_zero s). +- exact (B754_infinity s). +- apply (B754_nan s pl). + destruct nan_pl. + apply eq_refl. + exact H. +- apply (B754_finite s m e). + destruct bounded. + apply eq_refl. + exact H. +Defined. + +Theorem erase_correct : + forall x, erase x = x. +Proof. +destruct x as [s|s|s pl H|s m e H] ; try easy ; simpl. +- apply f_equal, eqbool_irrelevance. +- apply f_equal, eqbool_irrelevance. +Qed. + +(** Opposite *) + +Definition Bopp opp_nan x := + match x with + | B754_nan _ _ _ => build_nan (opp_nan x) + | B754_infinity sx => B754_infinity (negb sx) + | B754_finite sx mx ex Hx => B754_finite (negb sx) mx ex Hx + | B754_zero sx => B754_zero (negb sx) + end. + +Theorem Bopp_involutive : + forall opp_nan x, + is_nan x = false -> + Bopp opp_nan (Bopp opp_nan x) = x. +Proof. +now intros opp_nan [sx|sx|sx plx|sx mx ex Hx] ; simpl ; try rewrite Bool.negb_involutive. +Qed. + +Theorem B2R_Bopp : + forall opp_nan x, + B2R (Bopp opp_nan x) = (- B2R x)%R. +Proof. +intros opp_nan [sx|sx|sx plx Hplx|sx mx ex Hx]; apply sym_eq ; try apply Ropp_0. +simpl. +rewrite <- F2R_opp. +now case sx. +Qed. + +Theorem is_finite_Bopp : + forall opp_nan x, + is_finite (Bopp opp_nan x) = is_finite x. +Proof. +now intros opp_nan [| | |]. +Qed. + +Lemma Bsign_Bopp : + forall opp_nan x, is_nan x = false -> Bsign (Bopp opp_nan x) = negb (Bsign x). +Proof. now intros opp_nan [s|s|s pl H|s m e H]. Qed. + +(** Absolute value *) + +Definition Babs abs_nan (x : binary_float) : binary_float := + match x with + | B754_nan _ _ _ => build_nan (abs_nan x) + | B754_infinity sx => B754_infinity false + | B754_finite sx mx ex Hx => B754_finite false mx ex Hx + | B754_zero sx => B754_zero false + end. + +Theorem B2R_Babs : + forall abs_nan x, + B2R (Babs abs_nan x) = Rabs (B2R x). +Proof. + intros abs_nan [sx|sx|sx plx Hx|sx mx ex Hx]; apply sym_eq ; try apply Rabs_R0. + simpl. rewrite <- F2R_abs. now destruct sx. +Qed. + +Theorem is_finite_Babs : + forall abs_nan x, + is_finite (Babs abs_nan x) = is_finite x. +Proof. + now intros abs_nan [| | |]. +Qed. + +Theorem Bsign_Babs : + forall abs_nan x, + is_nan x = false -> + Bsign (Babs abs_nan x) = false. +Proof. + now intros abs_nan [| | |]. +Qed. + +Theorem Babs_idempotent : + forall abs_nan (x: binary_float), + is_nan x = false -> + Babs abs_nan (Babs abs_nan x) = Babs abs_nan x. +Proof. + now intros abs_nan [sx|sx|sx plx|sx mx ex Hx]. +Qed. + +Theorem Babs_Bopp : + forall abs_nan opp_nan x, + is_nan x = false -> + Babs abs_nan (Bopp opp_nan x) = Babs abs_nan x. +Proof. + now intros abs_nan opp_nan [| | |]. +Qed. + +(** Comparison + +[Some c] means ordered as per [c]; [None] means unordered. *) + +Definition Bcompare (f1 f2 : binary_float) : option comparison := + match f1, f2 with + | B754_nan _ _ _,_ | _,B754_nan _ _ _ => None + | B754_infinity s1, B754_infinity s2 => + Some match s1, s2 with + | true, true => Eq + | false, false => Eq + | true, false => Lt + | false, true => Gt + end + | B754_infinity s, _ => Some (if s then Lt else Gt) + | _, B754_infinity s => Some (if s then Gt else Lt) + | B754_finite s _ _ _, B754_zero _ => Some (if s then Lt else Gt) + | B754_zero _, B754_finite s _ _ _ => Some (if s then Gt else Lt) + | B754_zero _, B754_zero _ => Some Eq + | B754_finite s1 m1 e1 _, B754_finite s2 m2 e2 _ => + Some match s1, s2 with + | true, false => Lt + | false, true => Gt + | false, false => + match Z.compare e1 e2 with + | Lt => Lt + | Gt => Gt + | Eq => Pcompare m1 m2 Eq + end + | true, true => + match Z.compare e1 e2 with + | Lt => Gt + | Gt => Lt + | Eq => CompOpp (Pcompare m1 m2 Eq) + end + end + end. + +Theorem Bcompare_correct : + forall f1 f2, + is_finite f1 = true -> is_finite f2 = true -> + Bcompare f1 f2 = Some (Rcompare (B2R f1) (B2R f2)). +Proof. + Ltac apply_Rcompare := + match goal with + | [ |- Lt = Rcompare _ _ ] => symmetry; apply Rcompare_Lt + | [ |- Eq = Rcompare _ _ ] => symmetry; apply Rcompare_Eq + | [ |- Gt = Rcompare _ _ ] => symmetry; apply Rcompare_Gt + end. + unfold Bcompare; intros f1 f2 H1 H2. + destruct f1, f2; try easy; apply f_equal; clear H1 H2. + now rewrite Rcompare_Eq. + destruct s0 ; apply_Rcompare. + now apply F2R_lt_0. + now apply F2R_gt_0. + destruct s ; apply_Rcompare. + now apply F2R_lt_0. + now apply F2R_gt_0. + simpl. + apply andb_prop in e0; destruct e0; apply (canonical_canonical_mantissa false) in H. + apply andb_prop in e2; destruct e2; apply (canonical_canonical_mantissa false) in H1. + pose proof (Zcompare_spec e e1); unfold canonical, Fexp in H1, H. + assert (forall m1 m2 e1 e2, + let x := (IZR (Zpos m1) * bpow radix2 e1)%R in + let y := (IZR (Zpos m2) * bpow radix2 e2)%R in + (cexp radix2 fexp x < cexp radix2 fexp y)%Z -> (x < y)%R). + { + intros; apply Rnot_le_lt; intro; apply (mag_le radix2) in H5. + apply Zlt_not_le with (1 := H4). + now apply fexp_monotone. + now apply (F2R_gt_0 _ (Float radix2 (Zpos m2) e2)). + } + assert (forall m1 m2 e1 e2, (IZR (- Zpos m1) * bpow radix2 e1 < IZR (Zpos m2) * bpow radix2 e2)%R). + { + intros; apply (Rlt_trans _ 0%R). + now apply (F2R_lt_0 _ (Float radix2 (Zneg m1) e0)). + now apply (F2R_gt_0 _ (Float radix2 (Zpos m2) e2)). + } + unfold F2R, Fnum, Fexp. + destruct s, s0; try (now apply_Rcompare; apply H5); inversion H3; + try (apply_Rcompare; apply H4; rewrite H, H1 in H7; assumption); + try (apply_Rcompare; do 2 rewrite opp_IZR, Ropp_mult_distr_l_reverse; + apply Ropp_lt_contravar; apply H4; rewrite H, H1 in H7; assumption); + rewrite H7, Rcompare_mult_r, Rcompare_IZR by (apply bpow_gt_0); reflexivity. +Qed. + +Theorem Bcompare_swap : + forall x y, + Bcompare y x = match Bcompare x y with Some c => Some (CompOpp c) | None => None end. +Proof. + intros. + destruct x as [ ? | [] | ? ? | [] mx ex Bx ]; + destruct y as [ ? | [] | ? ? | [] my ey By ]; simpl; try easy. +- rewrite <- (Zcompare_antisym ex ey). destruct (ex ?= ey)%Z; try easy. + now rewrite (Pcompare_antisym mx my). +- rewrite <- (Zcompare_antisym ex ey). destruct (ex ?= ey)%Z; try easy. + now rewrite Pcompare_antisym. +Qed. + +Theorem bounded_lt_emax : + forall mx ex, + bounded mx ex = true -> + (F2R (Float radix2 (Zpos mx) ex) < bpow radix2 emax)%R. +Proof. +intros mx ex Hx. +destruct (andb_prop _ _ Hx) as (H1,H2). +generalize (Zeq_bool_eq _ _ H1). clear H1. intro H1. +generalize (Zle_bool_imp_le _ _ H2). clear H2. intro H2. +generalize (mag_F2R_Zdigits radix2 (Zpos mx) ex). +destruct (mag radix2 (F2R (Float radix2 (Zpos mx) ex))) as (e',Ex). +unfold mag_val. +intros H. +apply Rlt_le_trans with (bpow radix2 e'). +change (Zpos mx) with (Z.abs (Zpos mx)). +rewrite F2R_Zabs. +apply Ex. +apply Rgt_not_eq. +now apply F2R_gt_0. +apply bpow_le. +rewrite H. 2: discriminate. +revert H1. clear -H2. +rewrite Zpos_digits2_pos. +unfold fexp, FLT_exp. +intros ; zify ; omega. +Qed. + +Theorem bounded_ge_emin : + forall mx ex, + bounded mx ex = true -> + (bpow radix2 emin <= F2R (Float radix2 (Zpos mx) ex))%R. +Proof. +intros mx ex Hx. +destruct (andb_prop _ _ Hx) as [H1 _]. +apply Zeq_bool_eq in H1. +generalize (mag_F2R_Zdigits radix2 (Zpos mx) ex). +destruct (mag radix2 (F2R (Float radix2 (Zpos mx) ex))) as [e' Ex]. +unfold mag_val. +intros H. +assert (H0 : Zpos mx <> 0%Z) by easy. +rewrite Rabs_pos_eq in Ex by now apply F2R_ge_0. +refine (Rle_trans _ _ _ _ (proj1 (Ex _))). +2: now apply F2R_neq_0. +apply bpow_le. +rewrite H by easy. +revert H1. +rewrite Zpos_digits2_pos. +generalize (Zdigits radix2 (Zpos mx)) (Zdigits_gt_0 radix2 (Zpos mx) H0). +unfold fexp, FLT_exp. +clear -prec_gt_0_. +unfold Prec_gt_0 in prec_gt_0_. +clearbody emin. +intros ; zify ; omega. +Qed. + +Theorem abs_B2R_lt_emax : + forall x, + (Rabs (B2R x) < bpow radix2 emax)%R. +Proof. +intros [sx|sx|sx plx Hx|sx mx ex Hx] ; simpl ; try ( rewrite Rabs_R0 ; apply bpow_gt_0 ). +rewrite <- F2R_Zabs, abs_cond_Zopp. +now apply bounded_lt_emax. +Qed. + +Theorem abs_B2R_ge_emin : + forall x, + is_finite_strict x = true -> + (bpow radix2 emin <= Rabs (B2R x))%R. +Proof. +intros [sx|sx|sx plx Hx|sx mx ex Hx] ; simpl ; try discriminate. +intros; case sx; simpl. +- unfold F2R; simpl; rewrite Rabs_mult, <-abs_IZR; simpl. + rewrite Rabs_pos_eq; [|apply bpow_ge_0]. + now apply bounded_ge_emin. +- unfold F2R; simpl; rewrite Rabs_mult, <-abs_IZR; simpl. + rewrite Rabs_pos_eq; [|apply bpow_ge_0]. + now apply bounded_ge_emin. +Qed. + +Theorem bounded_canonical_lt_emax : + forall mx ex, + canonical radix2 fexp (Float radix2 (Zpos mx) ex) -> + (F2R (Float radix2 (Zpos mx) ex) < bpow radix2 emax)%R -> + bounded mx ex = true. +Proof. +intros mx ex Cx Bx. +apply andb_true_intro. +split. +unfold canonical_mantissa. +unfold canonical, Fexp in Cx. +rewrite Cx at 2. +rewrite Zpos_digits2_pos. +unfold cexp. +rewrite mag_F2R_Zdigits. 2: discriminate. +now apply -> Zeq_is_eq_bool. +apply Zle_bool_true. +unfold canonical, Fexp in Cx. +rewrite Cx. +unfold cexp, fexp, FLT_exp. +destruct (mag radix2 (F2R (Float radix2 (Zpos mx) ex))) as (e',Ex). simpl. +apply Z.max_lub. +cut (e' - 1 < emax)%Z. clear ; omega. +apply lt_bpow with radix2. +apply Rle_lt_trans with (2 := Bx). +change (Zpos mx) with (Z.abs (Zpos mx)). +rewrite F2R_Zabs. +apply Ex. +apply Rgt_not_eq. +now apply F2R_gt_0. +unfold emin. +generalize (prec_gt_0 prec). +clear -Hmax ; omega. +Qed. + +(** Truncation *) + +Record shr_record := { shr_m : Z ; shr_r : bool ; shr_s : bool }. + +Definition shr_1 mrs := + let '(Build_shr_record m r s) := mrs in + let s := orb r s in + match m with + | Z0 => Build_shr_record Z0 false s + | Zpos xH => Build_shr_record Z0 true s + | Zpos (xO p) => Build_shr_record (Zpos p) false s + | Zpos (xI p) => Build_shr_record (Zpos p) true s + | Zneg xH => Build_shr_record Z0 true s + | Zneg (xO p) => Build_shr_record (Zneg p) false s + | Zneg (xI p) => Build_shr_record (Zneg p) true s + end. + +Definition loc_of_shr_record mrs := + match mrs with + | Build_shr_record _ false false => loc_Exact + | Build_shr_record _ false true => loc_Inexact Lt + | Build_shr_record _ true false => loc_Inexact Eq + | Build_shr_record _ true true => loc_Inexact Gt + end. + +Definition shr_record_of_loc m l := + match l with + | loc_Exact => Build_shr_record m false false + | loc_Inexact Lt => Build_shr_record m false true + | loc_Inexact Eq => Build_shr_record m true false + | loc_Inexact Gt => Build_shr_record m true true + end. + +Theorem shr_m_shr_record_of_loc : + forall m l, + shr_m (shr_record_of_loc m l) = m. +Proof. +now intros m [|[| |]]. +Qed. + +Theorem loc_of_shr_record_of_loc : + forall m l, + loc_of_shr_record (shr_record_of_loc m l) = l. +Proof. +now intros m [|[| |]]. +Qed. + +Definition shr mrs e n := + match n with + | Zpos p => (iter_pos shr_1 p mrs, (e + n)%Z) + | _ => (mrs, e) + end. + +Lemma inbetween_shr_1 : + forall x mrs e, + (0 <= shr_m mrs)%Z -> + inbetween_float radix2 (shr_m mrs) e x (loc_of_shr_record mrs) -> + inbetween_float radix2 (shr_m (shr_1 mrs)) (e + 1) x (loc_of_shr_record (shr_1 mrs)). +Proof. +intros x mrs e Hm Hl. +refine (_ (new_location_even_correct (F2R (Float radix2 (shr_m (shr_1 mrs)) (e + 1))) (bpow radix2 e) 2 _ _ _ x (if shr_r (shr_1 mrs) then 1 else 0) (loc_of_shr_record mrs) _ _)) ; try easy. +2: apply bpow_gt_0. +2: now case (shr_r (shr_1 mrs)) ; split. +change 2%R with (bpow radix2 1). +rewrite <- bpow_plus. +rewrite (Zplus_comm 1), <- (F2R_bpow radix2 (e + 1)). +unfold inbetween_float, F2R. simpl. +rewrite plus_IZR, Rmult_plus_distr_r. +replace (new_location_even 2 (if shr_r (shr_1 mrs) then 1%Z else 0%Z) (loc_of_shr_record mrs)) with (loc_of_shr_record (shr_1 mrs)). +easy. +clear -Hm. +destruct mrs as (m, r, s). +now destruct m as [|[m|m|]|m] ; try (now elim Hm) ; destruct r as [|] ; destruct s as [|]. +rewrite (F2R_change_exp radix2 e). +2: apply Zle_succ. +unfold F2R. simpl. +rewrite <- 2!Rmult_plus_distr_r, <- 2!plus_IZR. +rewrite Zplus_assoc. +replace (shr_m (shr_1 mrs) * 2 ^ (e + 1 - e) + (if shr_r (shr_1 mrs) then 1%Z else 0%Z))%Z with (shr_m mrs). +exact Hl. +ring_simplify (e + 1 - e)%Z. +change (2^1)%Z with 2%Z. +rewrite Zmult_comm. +clear -Hm. +destruct mrs as (m, r, s). +now destruct m as [|[m|m|]|m] ; try (now elim Hm) ; destruct r as [|] ; destruct s as [|]. +Qed. + +Theorem inbetween_shr : + forall x m e l n, + (0 <= m)%Z -> + inbetween_float radix2 m e x l -> + let '(mrs, e') := shr (shr_record_of_loc m l) e n in + inbetween_float radix2 (shr_m mrs) e' x (loc_of_shr_record mrs). +Proof. +intros x m e l n Hm Hl. +destruct n as [|n|n]. +now destruct l as [|[| |]]. +2: now destruct l as [|[| |]]. +unfold shr. +rewrite iter_pos_nat. +rewrite Zpos_eq_Z_of_nat_o_nat_of_P. +induction (nat_of_P n). +simpl. +rewrite Zplus_0_r. +now destruct l as [|[| |]]. +rewrite iter_nat_S. +rewrite inj_S. +unfold Z.succ. +rewrite Zplus_assoc. +revert IHn0. +apply inbetween_shr_1. +clear -Hm. +induction n0. +now destruct l as [|[| |]]. +rewrite iter_nat_S. +revert IHn0. +generalize (iter_nat shr_1 n0 (shr_record_of_loc m l)). +clear. +intros (m, r, s) Hm. +now destruct m as [|[m|m|]|m] ; try (now elim Hm) ; destruct r as [|] ; destruct s as [|]. +Qed. + +Definition shr_fexp m e l := + shr (shr_record_of_loc m l) e (fexp (Zdigits2 m + e) - e). + +Theorem shr_truncate : + forall m e l, + (0 <= m)%Z -> + shr_fexp m e l = + let '(m', e', l') := truncate radix2 fexp (m, e, l) in (shr_record_of_loc m' l', e'). +Proof. +intros m e l Hm. +case_eq (truncate radix2 fexp (m, e, l)). +intros (m', e') l'. +unfold shr_fexp. +rewrite Zdigits2_Zdigits. +case_eq (fexp (Zdigits radix2 m + e) - e)%Z. +(* *) +intros He. +unfold truncate. +rewrite He. +simpl. +intros H. +now inversion H. +(* *) +intros p Hp. +assert (He: (e <= fexp (Zdigits radix2 m + e))%Z). +clear -Hp ; zify ; omega. +destruct (inbetween_float_ex radix2 m e l) as (x, Hx). +generalize (inbetween_shr x m e l (fexp (Zdigits radix2 m + e) - e) Hm Hx). +assert (Hx0 : (0 <= x)%R). +apply Rle_trans with (F2R (Float radix2 m e)). +now apply F2R_ge_0. +exact (proj1 (inbetween_float_bounds _ _ _ _ _ Hx)). +case_eq (shr (shr_record_of_loc m l) e (fexp (Zdigits radix2 m + e) - e)). +intros mrs e'' H3 H4 H1. +generalize (truncate_correct radix2 _ x m e l Hx0 Hx (or_introl _ He)). +rewrite H1. +intros (H2,_). +rewrite <- Hp, H3. +assert (e'' = e'). +change (snd (mrs, e'') = snd (fst (m',e',l'))). +rewrite <- H1, <- H3. +unfold truncate. +now rewrite Hp. +rewrite H in H4 |- *. +apply (f_equal (fun v => (v, _))). +destruct (inbetween_float_unique _ _ _ _ _ _ _ H2 H4) as (H5, H6). +rewrite H5, H6. +case mrs. +now intros m0 [|] [|]. +(* *) +intros p Hp. +unfold truncate. +rewrite Hp. +simpl. +intros H. +now inversion H. +Qed. + +(** Rounding modes *) + +Inductive mode := mode_NE | mode_ZR | mode_DN | mode_UP | mode_NA. + +Definition round_mode m := + match m with + | mode_NE => ZnearestE + | mode_ZR => Ztrunc + | mode_DN => Zfloor + | mode_UP => Zceil + | mode_NA => ZnearestA + end. + +Definition choice_mode m sx mx lx := + match m with + | mode_NE => cond_incr (round_N (negb (Z.even mx)) lx) mx + | mode_ZR => mx + | mode_DN => cond_incr (round_sign_DN sx lx) mx + | mode_UP => cond_incr (round_sign_UP sx lx) mx + | mode_NA => cond_incr (round_N true lx) mx + end. + +Global Instance valid_rnd_round_mode : forall m, Valid_rnd (round_mode m). +Proof. +destruct m ; unfold round_mode ; auto with typeclass_instances. +Qed. + +Definition overflow_to_inf m s := + match m with + | mode_NE => true + | mode_NA => true + | mode_ZR => false + | mode_UP => negb s + | mode_DN => s + end. + +Definition binary_overflow m s := + if overflow_to_inf m s then F754_infinity s + else F754_finite s (match (Zpower 2 prec - 1)%Z with Zpos p => p | _ => xH end) (emax - prec). + +Definition binary_round_aux mode sx mx ex lx := + let '(mrs', e') := shr_fexp mx ex lx in + let '(mrs'', e'') := shr_fexp (choice_mode mode sx (shr_m mrs') (loc_of_shr_record mrs')) e' loc_Exact in + match shr_m mrs'' with + | Z0 => F754_zero sx + | Zpos m => if Zle_bool e'' (emax - prec) then F754_finite sx m e'' else binary_overflow mode sx + | _ => F754_nan false xH (* dummy *) + end. + +Theorem binary_round_aux_correct' : + forall mode x mx ex lx, + (x <> 0)%R -> + inbetween_float radix2 mx ex (Rabs x) lx -> + (ex <= cexp radix2 fexp x)%Z -> + let z := binary_round_aux mode (Rlt_bool x 0) mx ex lx in + valid_binary z = true /\ + if Rlt_bool (Rabs (round radix2 fexp (round_mode mode) x)) (bpow radix2 emax) then + FF2R radix2 z = round radix2 fexp (round_mode mode) x /\ + is_finite_FF z = true /\ sign_FF z = Rlt_bool x 0 + else + z = binary_overflow mode (Rlt_bool x 0). +Proof with auto with typeclass_instances. +intros m x mx ex lx Px Bx Ex z. +unfold binary_round_aux in z. +revert z. +rewrite shr_truncate. +refine (_ (round_trunc_sign_any_correct' _ _ (round_mode m) (choice_mode m) _ x mx ex lx Bx (or_introl _ Ex))). +rewrite <- cexp_abs in Ex. +refine (_ (truncate_correct_partial' _ fexp _ _ _ _ _ Bx Ex)). +destruct (truncate radix2 fexp (mx, ex, lx)) as ((m1, e1), l1). +rewrite loc_of_shr_record_of_loc, shr_m_shr_record_of_loc. +set (m1' := choice_mode m (Rlt_bool x 0) m1 l1). +intros (H1a,H1b) H1c. +rewrite H1c. +assert (Hm: (m1 <= m1')%Z). +(* . *) +unfold m1', choice_mode, cond_incr. +case m ; + try apply Z.le_refl ; + match goal with |- (m1 <= if ?b then _ else _)%Z => + case b ; [ apply Zle_succ | apply Z.le_refl ] end. +assert (Hr: Rabs (round radix2 fexp (round_mode m) x) = F2R (Float radix2 m1' e1)). +(* . *) +rewrite <- (Z.abs_eq m1'). +replace (Z.abs m1') with (Z.abs (cond_Zopp (Rlt_bool x 0) m1')). +rewrite F2R_Zabs. +now apply f_equal. +apply abs_cond_Zopp. +apply Z.le_trans with (2 := Hm). +apply Zlt_succ_le. +apply gt_0_F2R with radix2 e1. +apply Rle_lt_trans with (1 := Rabs_pos x). +exact (proj2 (inbetween_float_bounds _ _ _ _ _ H1a)). +(* . *) +assert (Br: inbetween_float radix2 m1' e1 (Rabs (round radix2 fexp (round_mode m) x)) loc_Exact). +now apply inbetween_Exact. +destruct m1' as [|m1'|m1']. +(* . m1' = 0 *) +rewrite shr_truncate. 2: apply Z.le_refl. +generalize (truncate_0 radix2 fexp e1 loc_Exact). +destruct (truncate radix2 fexp (Z0, e1, loc_Exact)) as ((m2, e2), l2). +rewrite shr_m_shr_record_of_loc. +intros Hm2. +rewrite Hm2. +repeat split. +rewrite Rlt_bool_true. +repeat split. +apply sym_eq. +case Rlt_bool ; apply F2R_0. +rewrite <- F2R_Zabs, abs_cond_Zopp, F2R_0. +apply bpow_gt_0. +(* . 0 < m1' *) +assert (He: (e1 <= fexp (Zdigits radix2 (Zpos m1') + e1))%Z). +rewrite <- mag_F2R_Zdigits, <- Hr, mag_abs. +2: discriminate. +rewrite H1b. +rewrite cexp_abs. +fold (cexp radix2 fexp (round radix2 fexp (round_mode m) x)). +apply cexp_round_ge... +rewrite H1c. +case (Rlt_bool x 0). +apply Rlt_not_eq. +now apply F2R_lt_0. +apply Rgt_not_eq. +now apply F2R_gt_0. +refine (_ (truncate_correct_partial _ _ _ _ _ _ _ Br He)). +2: now rewrite Hr ; apply F2R_gt_0. +refine (_ (truncate_correct_format radix2 fexp (Zpos m1') e1 _ _ He)). +2: discriminate. +rewrite shr_truncate. 2: easy. +destruct (truncate radix2 fexp (Zpos m1', e1, loc_Exact)) as ((m2, e2), l2). +rewrite shr_m_shr_record_of_loc. +intros (H3,H4) (H2,_). +destruct m2 as [|m2|m2]. +elim Rgt_not_eq with (2 := H3). +rewrite F2R_0. +now apply F2R_gt_0. +rewrite F2R_cond_Zopp, H3, abs_cond_Ropp, <- F2R_abs. +simpl Z.abs. +case_eq (Zle_bool e2 (emax - prec)) ; intros He2. +assert (bounded m2 e2 = true). +apply andb_true_intro. +split. +unfold canonical_mantissa. +apply Zeq_bool_true. +rewrite Zpos_digits2_pos. +rewrite <- mag_F2R_Zdigits. +apply sym_eq. +now rewrite H3 in H4. +discriminate. +exact He2. +apply (conj H). +rewrite Rlt_bool_true. +repeat split. +apply F2R_cond_Zopp. +now apply bounded_lt_emax. +rewrite (Rlt_bool_false _ (bpow radix2 emax)). +refine (conj _ (refl_equal _)). +unfold binary_overflow. +case overflow_to_inf. +apply refl_equal. +unfold valid_binary, bounded. +rewrite Zle_bool_refl. +rewrite Bool.andb_true_r. +apply Zeq_bool_true. +rewrite Zpos_digits2_pos. +replace (Zdigits radix2 (Zpos (match (Zpower 2 prec - 1)%Z with Zpos p => p | _ => xH end))) with prec. +unfold fexp, FLT_exp, emin. +generalize (prec_gt_0 prec). +clear -Hmax ; zify ; omega. +change 2%Z with (radix_val radix2). +case_eq (Zpower radix2 prec - 1)%Z. +simpl Zdigits. +generalize (Zpower_gt_1 radix2 prec (prec_gt_0 prec)). +clear ; omega. +intros p Hp. +apply Zle_antisym. +cut (prec - 1 < Zdigits radix2 (Zpos p))%Z. clear ; omega. +apply Zdigits_gt_Zpower. +simpl Z.abs. rewrite <- Hp. +cut (Zpower radix2 (prec - 1) < Zpower radix2 prec)%Z. clear ; omega. +apply lt_IZR. +rewrite 2!IZR_Zpower. 2: now apply Zlt_le_weak. +apply bpow_lt. +apply Zlt_pred. +now apply Zlt_0_le_0_pred. +apply Zdigits_le_Zpower. +simpl Z.abs. rewrite <- Hp. +apply Zlt_pred. +intros p Hp. +generalize (Zpower_gt_1 radix2 _ (prec_gt_0 prec)). +clear -Hp ; zify ; omega. +apply Rnot_lt_le. +intros Hx. +generalize (refl_equal (bounded m2 e2)). +unfold bounded at 2. +rewrite He2. +rewrite Bool.andb_false_r. +rewrite bounded_canonical_lt_emax with (2 := Hx). +discriminate. +unfold canonical. +now rewrite <- H3. +elim Rgt_not_eq with (2 := H3). +apply Rlt_trans with R0. +now apply F2R_lt_0. +now apply F2R_gt_0. +rewrite <- Hr. +apply generic_format_abs... +apply generic_format_round... +(* . not m1' < 0 *) +elim Rgt_not_eq with (2 := Hr). +apply Rlt_le_trans with R0. +now apply F2R_lt_0. +apply Rabs_pos. +(* *) +now apply Rabs_pos_lt. +(* all the modes are valid *) +clear. case m. +exact inbetween_int_NE_sign. +exact inbetween_int_ZR_sign. +exact inbetween_int_DN_sign. +exact inbetween_int_UP_sign. +exact inbetween_int_NA_sign. +(* *) +apply inbetween_float_bounds in Bx. +apply Zlt_succ_le. +eapply gt_0_F2R. +apply Rle_lt_trans with (2 := proj2 Bx). +apply Rabs_pos. +Qed. + +Theorem binary_round_aux_correct : + forall mode x mx ex lx, + inbetween_float radix2 (Zpos mx) ex (Rabs x) lx -> + (ex <= fexp (Zdigits radix2 (Zpos mx) + ex))%Z -> + let z := binary_round_aux mode (Rlt_bool x 0) (Zpos mx) ex lx in + valid_binary z = true /\ + if Rlt_bool (Rabs (round radix2 fexp (round_mode mode) x)) (bpow radix2 emax) then + FF2R radix2 z = round radix2 fexp (round_mode mode) x /\ + is_finite_FF z = true /\ sign_FF z = Rlt_bool x 0 + else + z = binary_overflow mode (Rlt_bool x 0). +Proof with auto with typeclass_instances. +intros m x mx ex lx Bx Ex z. +unfold binary_round_aux in z. +revert z. +rewrite shr_truncate. 2: easy. +refine (_ (round_trunc_sign_any_correct _ _ (round_mode m) (choice_mode m) _ x (Zpos mx) ex lx Bx (or_introl _ Ex))). +refine (_ (truncate_correct_partial _ _ _ _ _ _ _ Bx Ex)). +destruct (truncate radix2 fexp (Zpos mx, ex, lx)) as ((m1, e1), l1). +rewrite loc_of_shr_record_of_loc, shr_m_shr_record_of_loc. +set (m1' := choice_mode m (Rlt_bool x 0) m1 l1). +intros (H1a,H1b) H1c. +rewrite H1c. +assert (Hm: (m1 <= m1')%Z). +(* . *) +unfold m1', choice_mode, cond_incr. +case m ; + try apply Z.le_refl ; + match goal with |- (m1 <= if ?b then _ else _)%Z => + case b ; [ apply Zle_succ | apply Z.le_refl ] end. +assert (Hr: Rabs (round radix2 fexp (round_mode m) x) = F2R (Float radix2 m1' e1)). +(* . *) +rewrite <- (Z.abs_eq m1'). +replace (Z.abs m1') with (Z.abs (cond_Zopp (Rlt_bool x 0) m1')). +rewrite F2R_Zabs. +now apply f_equal. +apply abs_cond_Zopp. +apply Z.le_trans with (2 := Hm). +apply Zlt_succ_le. +apply gt_0_F2R with radix2 e1. +apply Rle_lt_trans with (1 := Rabs_pos x). +exact (proj2 (inbetween_float_bounds _ _ _ _ _ H1a)). +(* . *) +assert (Br: inbetween_float radix2 m1' e1 (Rabs (round radix2 fexp (round_mode m) x)) loc_Exact). +now apply inbetween_Exact. +destruct m1' as [|m1'|m1']. +(* . m1' = 0 *) +rewrite shr_truncate. 2: apply Z.le_refl. +generalize (truncate_0 radix2 fexp e1 loc_Exact). +destruct (truncate radix2 fexp (Z0, e1, loc_Exact)) as ((m2, e2), l2). +rewrite shr_m_shr_record_of_loc. +intros Hm2. +rewrite Hm2. +repeat split. +rewrite Rlt_bool_true. +repeat split. +apply sym_eq. +case Rlt_bool ; apply F2R_0. +rewrite <- F2R_Zabs, abs_cond_Zopp, F2R_0. +apply bpow_gt_0. +(* . 0 < m1' *) +assert (He: (e1 <= fexp (Zdigits radix2 (Zpos m1') + e1))%Z). +rewrite <- mag_F2R_Zdigits, <- Hr, mag_abs. +2: discriminate. +rewrite H1b. +rewrite cexp_abs. +fold (cexp radix2 fexp (round radix2 fexp (round_mode m) x)). +apply cexp_round_ge... +rewrite H1c. +case (Rlt_bool x 0). +apply Rlt_not_eq. +now apply F2R_lt_0. +apply Rgt_not_eq. +now apply F2R_gt_0. +refine (_ (truncate_correct_partial _ _ _ _ _ _ _ Br He)). +2: now rewrite Hr ; apply F2R_gt_0. +refine (_ (truncate_correct_format radix2 fexp (Zpos m1') e1 _ _ He)). +2: discriminate. +rewrite shr_truncate. 2: easy. +destruct (truncate radix2 fexp (Zpos m1', e1, loc_Exact)) as ((m2, e2), l2). +rewrite shr_m_shr_record_of_loc. +intros (H3,H4) (H2,_). +destruct m2 as [|m2|m2]. +elim Rgt_not_eq with (2 := H3). +rewrite F2R_0. +now apply F2R_gt_0. +rewrite F2R_cond_Zopp, H3, abs_cond_Ropp, <- F2R_abs. +simpl Z.abs. +case_eq (Zle_bool e2 (emax - prec)) ; intros He2. +assert (bounded m2 e2 = true). +apply andb_true_intro. +split. +unfold canonical_mantissa. +apply Zeq_bool_true. +rewrite Zpos_digits2_pos. +rewrite <- mag_F2R_Zdigits. +apply sym_eq. +now rewrite H3 in H4. +discriminate. +exact He2. +apply (conj H). +rewrite Rlt_bool_true. +repeat split. +apply F2R_cond_Zopp. +now apply bounded_lt_emax. +rewrite (Rlt_bool_false _ (bpow radix2 emax)). +refine (conj _ (refl_equal _)). +unfold binary_overflow. +case overflow_to_inf. +apply refl_equal. +unfold valid_binary, bounded. +rewrite Zle_bool_refl. +rewrite Bool.andb_true_r. +apply Zeq_bool_true. +rewrite Zpos_digits2_pos. +replace (Zdigits radix2 (Zpos (match (Zpower 2 prec - 1)%Z with Zpos p => p | _ => xH end))) with prec. +unfold fexp, FLT_exp, emin. +generalize (prec_gt_0 prec). +clear -Hmax ; zify ; omega. +change 2%Z with (radix_val radix2). +case_eq (Zpower radix2 prec - 1)%Z. +simpl Zdigits. +generalize (Zpower_gt_1 radix2 prec (prec_gt_0 prec)). +clear ; omega. +intros p Hp. +apply Zle_antisym. +cut (prec - 1 < Zdigits radix2 (Zpos p))%Z. clear ; omega. +apply Zdigits_gt_Zpower. +simpl Z.abs. rewrite <- Hp. +cut (Zpower radix2 (prec - 1) < Zpower radix2 prec)%Z. clear ; omega. +apply lt_IZR. +rewrite 2!IZR_Zpower. 2: now apply Zlt_le_weak. +apply bpow_lt. +apply Zlt_pred. +now apply Zlt_0_le_0_pred. +apply Zdigits_le_Zpower. +simpl Z.abs. rewrite <- Hp. +apply Zlt_pred. +intros p Hp. +generalize (Zpower_gt_1 radix2 _ (prec_gt_0 prec)). +clear -Hp ; zify ; omega. +apply Rnot_lt_le. +intros Hx. +generalize (refl_equal (bounded m2 e2)). +unfold bounded at 2. +rewrite He2. +rewrite Bool.andb_false_r. +rewrite bounded_canonical_lt_emax with (2 := Hx). +discriminate. +unfold canonical. +now rewrite <- H3. +elim Rgt_not_eq with (2 := H3). +apply Rlt_trans with R0. +now apply F2R_lt_0. +now apply F2R_gt_0. +rewrite <- Hr. +apply generic_format_abs... +apply generic_format_round... +(* . not m1' < 0 *) +elim Rgt_not_eq with (2 := Hr). +apply Rlt_le_trans with R0. +now apply F2R_lt_0. +apply Rabs_pos. +(* *) +apply Rlt_le_trans with (2 := proj1 (inbetween_float_bounds _ _ _ _ _ Bx)). +now apply F2R_gt_0. +(* all the modes are valid *) +clear. case m. +exact inbetween_int_NE_sign. +exact inbetween_int_ZR_sign. +exact inbetween_int_DN_sign. +exact inbetween_int_UP_sign. +exact inbetween_int_NA_sign. +Qed. + +(** Multiplication *) + +Lemma Bmult_correct_aux : + forall m sx mx ex (Hx : bounded mx ex = true) sy my ey (Hy : bounded my ey = true), + let x := F2R (Float radix2 (cond_Zopp sx (Zpos mx)) ex) in + let y := F2R (Float radix2 (cond_Zopp sy (Zpos my)) ey) in + let z := binary_round_aux m (xorb sx sy) (Zpos (mx * my)) (ex + ey) loc_Exact in + valid_binary z = true /\ + if Rlt_bool (Rabs (round radix2 fexp (round_mode m) (x * y))) (bpow radix2 emax) then + FF2R radix2 z = round radix2 fexp (round_mode m) (x * y) /\ + is_finite_FF z = true /\ sign_FF z = xorb sx sy + else + z = binary_overflow m (xorb sx sy). +Proof. +intros m sx mx ex Hx sy my ey Hy x y. +unfold x, y. +rewrite <- F2R_mult. +simpl. +replace (xorb sx sy) with (Rlt_bool (F2R (Float radix2 (cond_Zopp sx (Zpos mx) * cond_Zopp sy (Zpos my)) (ex + ey))) 0). +apply binary_round_aux_correct. +constructor. +rewrite <- F2R_abs. +apply F2R_eq. +rewrite Zabs_Zmult. +now rewrite 2!abs_cond_Zopp. +(* *) +change (Zpos (mx * my)) with (Zpos mx * Zpos my)%Z. +assert (forall m e, bounded m e = true -> fexp (Zdigits radix2 (Zpos m) + e) = e)%Z. +clear. intros m e Hb. +destruct (andb_prop _ _ Hb) as (H,_). +apply Zeq_bool_eq. +now rewrite <- Zpos_digits2_pos. +generalize (H _ _ Hx) (H _ _ Hy). +clear x y sx sy Hx Hy H. +unfold fexp, FLT_exp. +refine (_ (Zdigits_mult_ge radix2 (Zpos mx) (Zpos my) _ _)) ; try discriminate. +refine (_ (Zdigits_gt_0 radix2 (Zpos mx) _) (Zdigits_gt_0 radix2 (Zpos my) _)) ; try discriminate. +generalize (Zdigits radix2 (Zpos mx)) (Zdigits radix2 (Zpos my)) (Zdigits radix2 (Zpos mx * Zpos my)). +clear -Hmax. +unfold emin. +intros dx dy dxy Hx Hy Hxy. +zify ; intros ; subst. +omega. +(* *) +case sx ; case sy. +apply Rlt_bool_false. +now apply F2R_ge_0. +apply Rlt_bool_true. +now apply F2R_lt_0. +apply Rlt_bool_true. +now apply F2R_lt_0. +apply Rlt_bool_false. +now apply F2R_ge_0. +Qed. + +Definition Bmult mult_nan m x y := + match x, y with + | B754_nan _ _ _, _ | _, B754_nan _ _ _ => build_nan (mult_nan x y) + | B754_infinity sx, B754_infinity sy => B754_infinity (xorb sx sy) + | B754_infinity sx, B754_finite sy _ _ _ => B754_infinity (xorb sx sy) + | B754_finite sx _ _ _, B754_infinity sy => B754_infinity (xorb sx sy) + | B754_infinity _, B754_zero _ => build_nan (mult_nan x y) + | B754_zero _, B754_infinity _ => build_nan (mult_nan x y) + | B754_finite sx _ _ _, B754_zero sy => B754_zero (xorb sx sy) + | B754_zero sx, B754_finite sy _ _ _ => B754_zero (xorb sx sy) + | B754_zero sx, B754_zero sy => B754_zero (xorb sx sy) + | B754_finite sx mx ex Hx, B754_finite sy my ey Hy => + FF2B _ (proj1 (Bmult_correct_aux m sx mx ex Hx sy my ey Hy)) + end. + +Theorem Bmult_correct : + forall mult_nan m x y, + if Rlt_bool (Rabs (round radix2 fexp (round_mode m) (B2R x * B2R y))) (bpow radix2 emax) then + B2R (Bmult mult_nan m x y) = round radix2 fexp (round_mode m) (B2R x * B2R y) /\ + is_finite (Bmult mult_nan m x y) = andb (is_finite x) (is_finite y) /\ + (is_nan (Bmult mult_nan m x y) = false -> + Bsign (Bmult mult_nan m x y) = xorb (Bsign x) (Bsign y)) + else + B2FF (Bmult mult_nan m x y) = binary_overflow m (xorb (Bsign x) (Bsign y)). +Proof. +intros mult_nan m [sx|sx|sx plx Hplx|sx mx ex Hx] [sy|sy|sy ply Hply|sy my ey Hy] ; + try ( rewrite ?Rmult_0_r, ?Rmult_0_l, round_0, Rabs_R0, Rlt_bool_true ; [ simpl ; try easy ; now rewrite B2R_build_nan, is_finite_build_nan, is_nan_build_nan | apply bpow_gt_0 | now auto with typeclass_instances ] ). +simpl. +case Bmult_correct_aux. +intros H1. +case Rlt_bool. +intros (H2, (H3, H4)). +split. +now rewrite B2R_FF2B. +split. +now rewrite is_finite_FF2B. +rewrite Bsign_FF2B. auto. +intros H2. +now rewrite B2FF_FF2B. +Qed. + +(** Normalization and rounding *) + +Definition shl_align mx ex ex' := + match (ex' - ex)%Z with + | Zneg d => (shift_pos d mx, ex') + | _ => (mx, ex) + end. + +Theorem shl_align_correct : + forall mx ex ex', + let (mx', ex'') := shl_align mx ex ex' in + F2R (Float radix2 (Zpos mx) ex) = F2R (Float radix2 (Zpos mx') ex'') /\ + (ex'' <= ex')%Z. +Proof. +intros mx ex ex'. +unfold shl_align. +case_eq (ex' - ex)%Z. +(* d = 0 *) +intros H. +repeat split. +rewrite Zminus_eq with (1 := H). +apply Z.le_refl. +(* d > 0 *) +intros d Hd. +repeat split. +replace ex' with (ex' - ex + ex)%Z by ring. +rewrite Hd. +pattern ex at 1 ; rewrite <- Zplus_0_l. +now apply Zplus_le_compat_r. +(* d < 0 *) +intros d Hd. +rewrite shift_pos_correct, Zmult_comm. +change (Zpower_pos 2 d) with (Zpower radix2 (Zpos d)). +change (Zpos d) with (Z.opp (Zneg d)). +rewrite <- Hd. +split. +replace (- (ex' - ex))%Z with (ex - ex')%Z by ring. +apply F2R_change_exp. +apply Zle_0_minus_le. +replace (ex - ex')%Z with (- (ex' - ex))%Z by ring. +now rewrite Hd. +apply Z.le_refl. +Qed. + +Theorem snd_shl_align : + forall mx ex ex', + (ex' <= ex)%Z -> + snd (shl_align mx ex ex') = ex'. +Proof. +intros mx ex ex' He. +unfold shl_align. +case_eq (ex' - ex)%Z ; simpl. +intros H. +now rewrite Zminus_eq with (1 := H). +intros p. +clear -He ; zify ; omega. +intros. +apply refl_equal. +Qed. + +Definition shl_align_fexp mx ex := + shl_align mx ex (fexp (Zpos (digits2_pos mx) + ex)). + +Theorem shl_align_fexp_correct : + forall mx ex, + let (mx', ex') := shl_align_fexp mx ex in + F2R (Float radix2 (Zpos mx) ex) = F2R (Float radix2 (Zpos mx') ex') /\ + (ex' <= fexp (Zdigits radix2 (Zpos mx') + ex'))%Z. +Proof. +intros mx ex. +unfold shl_align_fexp. +generalize (shl_align_correct mx ex (fexp (Zpos (digits2_pos mx) + ex))). +rewrite Zpos_digits2_pos. +case shl_align. +intros mx' ex' (H1, H2). +split. +exact H1. +rewrite <- mag_F2R_Zdigits. 2: easy. +rewrite <- H1. +now rewrite mag_F2R_Zdigits. +Qed. + +Definition binary_round m sx mx ex := + let '(mz, ez) := shl_align_fexp mx ex in binary_round_aux m sx (Zpos mz) ez loc_Exact. + +Theorem binary_round_correct : + forall m sx mx ex, + let z := binary_round m sx mx ex in + valid_binary z = true /\ + let x := F2R (Float radix2 (cond_Zopp sx (Zpos mx)) ex) in + if Rlt_bool (Rabs (round radix2 fexp (round_mode m) x)) (bpow radix2 emax) then + FF2R radix2 z = round radix2 fexp (round_mode m) x /\ + is_finite_FF z = true /\ + sign_FF z = sx + else + z = binary_overflow m sx. +Proof. +intros m sx mx ex. +unfold binary_round. +generalize (shl_align_fexp_correct mx ex). +destruct (shl_align_fexp mx ex) as (mz, ez). +intros (H1, H2). +set (x := F2R (Float radix2 (cond_Zopp sx (Zpos mx)) ex)). +replace sx with (Rlt_bool x 0). +apply binary_round_aux_correct. +constructor. +unfold x. +now rewrite <- F2R_Zabs, abs_cond_Zopp. +exact H2. +unfold x. +case sx. +apply Rlt_bool_true. +now apply F2R_lt_0. +apply Rlt_bool_false. +now apply F2R_ge_0. +Qed. + +Definition binary_normalize mode m e szero := + match m with + | Z0 => B754_zero szero + | Zpos m => FF2B _ (proj1 (binary_round_correct mode false m e)) + | Zneg m => FF2B _ (proj1 (binary_round_correct mode true m e)) + end. + +Theorem binary_normalize_correct : + forall m mx ex szero, + if Rlt_bool (Rabs (round radix2 fexp (round_mode m) (F2R (Float radix2 mx ex)))) (bpow radix2 emax) then + B2R (binary_normalize m mx ex szero) = round radix2 fexp (round_mode m) (F2R (Float radix2 mx ex)) /\ + is_finite (binary_normalize m mx ex szero) = true /\ + Bsign (binary_normalize m mx ex szero) = + match Rcompare (F2R (Float radix2 mx ex)) 0 with + | Eq => szero + | Lt => true + | Gt => false + end + else + B2FF (binary_normalize m mx ex szero) = binary_overflow m (Rlt_bool (F2R (Float radix2 mx ex)) 0). +Proof with auto with typeclass_instances. +intros m mx ez szero. +destruct mx as [|mz|mz] ; simpl. +rewrite F2R_0, round_0, Rabs_R0, Rlt_bool_true... +split... split... +rewrite Rcompare_Eq... +apply bpow_gt_0. +(* . mz > 0 *) +generalize (binary_round_correct m false mz ez). +simpl. +case Rlt_bool_spec. +intros _ (Vz, (Rz, (Rz', Rz''))). +split. +now rewrite B2R_FF2B. +split. +now rewrite is_finite_FF2B. +rewrite Bsign_FF2B, Rz''. +rewrite Rcompare_Gt... +apply F2R_gt_0. +simpl. zify; omega. +intros Hz' (Vz, Rz). +rewrite B2FF_FF2B, Rz. +apply f_equal. +apply sym_eq. +apply Rlt_bool_false. +now apply F2R_ge_0. +(* . mz < 0 *) +generalize (binary_round_correct m true mz ez). +simpl. +case Rlt_bool_spec. +intros _ (Vz, (Rz, (Rz', Rz''))). +split. +now rewrite B2R_FF2B. +split. +now rewrite is_finite_FF2B. +rewrite Bsign_FF2B, Rz''. +rewrite Rcompare_Lt... +apply F2R_lt_0. +simpl. zify; omega. +intros Hz' (Vz, Rz). +rewrite B2FF_FF2B, Rz. +apply f_equal. +apply sym_eq. +apply Rlt_bool_true. +now apply F2R_lt_0. +Qed. + +(** Addition *) + +Definition Bplus plus_nan m x y := + match x, y with + | B754_nan _ _ _, _ | _, B754_nan _ _ _ => build_nan (plus_nan x y) + | B754_infinity sx, B754_infinity sy => + if Bool.eqb sx sy then x else build_nan (plus_nan x y) + | B754_infinity _, _ => x + | _, B754_infinity _ => y + | B754_zero sx, B754_zero sy => + if Bool.eqb sx sy then x else + match m with mode_DN => B754_zero true | _ => B754_zero false end + | B754_zero _, _ => y + | _, B754_zero _ => x + | B754_finite sx mx ex Hx, B754_finite sy my ey Hy => + let ez := Z.min ex ey in + binary_normalize m (Zplus (cond_Zopp sx (Zpos (fst (shl_align mx ex ez)))) (cond_Zopp sy (Zpos (fst (shl_align my ey ez))))) + ez (match m with mode_DN => true | _ => false end) + end. + +Theorem Bplus_correct : + forall plus_nan m x y, + is_finite x = true -> + is_finite y = true -> + if Rlt_bool (Rabs (round radix2 fexp (round_mode m) (B2R x + B2R y))) (bpow radix2 emax) then + B2R (Bplus plus_nan m x y) = round radix2 fexp (round_mode m) (B2R x + B2R y) /\ + is_finite (Bplus plus_nan m x y) = true /\ + Bsign (Bplus plus_nan m x y) = + match Rcompare (B2R x + B2R y) 0 with + | Eq => match m with mode_DN => orb (Bsign x) (Bsign y) + | _ => andb (Bsign x) (Bsign y) end + | Lt => true + | Gt => false + end + else + (B2FF (Bplus plus_nan m x y) = binary_overflow m (Bsign x) /\ Bsign x = Bsign y). +Proof with auto with typeclass_instances. +intros plus_nan m [sx|sx| |sx mx ex Hx] [sy|sy| |sy my ey Hy] Fx Fy ; try easy. +(* *) +rewrite Rplus_0_r, round_0, Rabs_R0, Rlt_bool_true... +simpl. +rewrite Rcompare_Eq by auto. +destruct sx, sy; try easy; now case m. +apply bpow_gt_0. +(* *) +rewrite Rplus_0_l, round_generic, Rlt_bool_true... +split... split... +simpl. unfold F2R. +erewrite <- Rmult_0_l, Rcompare_mult_r. +rewrite Rcompare_IZR with (y:=0%Z). +destruct sy... +apply bpow_gt_0. +apply abs_B2R_lt_emax. +apply generic_format_B2R. +(* *) +rewrite Rplus_0_r, round_generic, Rlt_bool_true... +split... split... +simpl. unfold F2R. +erewrite <- Rmult_0_l, Rcompare_mult_r. +rewrite Rcompare_IZR with (y:=0%Z). +destruct sx... +apply bpow_gt_0. +apply abs_B2R_lt_emax. +apply generic_format_B2R. +(* *) +clear Fx Fy. +simpl. +set (szero := match m with mode_DN => true | _ => false end). +set (ez := Z.min ex ey). +set (mz := (cond_Zopp sx (Zpos (fst (shl_align mx ex ez))) + cond_Zopp sy (Zpos (fst (shl_align my ey ez))))%Z). +assert (Hp: (F2R (Float radix2 (cond_Zopp sx (Zpos mx)) ex) + + F2R (Float radix2 (cond_Zopp sy (Zpos my)) ey))%R = F2R (Float radix2 mz ez)). +rewrite 2!F2R_cond_Zopp. +generalize (shl_align_correct mx ex ez). +generalize (shl_align_correct my ey ez). +generalize (snd_shl_align mx ex ez (Z.le_min_l ex ey)). +generalize (snd_shl_align my ey ez (Z.le_min_r ex ey)). +destruct (shl_align mx ex ez) as (mx', ex'). +destruct (shl_align my ey ez) as (my', ey'). +simpl. +intros H1 H2. +rewrite H1, H2. +clear H1 H2. +intros (H1, _) (H2, _). +rewrite H1, H2. +clear H1 H2. +rewrite <- 2!F2R_cond_Zopp. +unfold F2R. simpl. +now rewrite <- Rmult_plus_distr_r, <- plus_IZR. +rewrite Hp. +assert (Sz: (bpow radix2 emax <= Rabs (round radix2 fexp (round_mode m) (F2R (Float radix2 mz ez))))%R -> sx = Rlt_bool (F2R (Float radix2 mz ez)) 0 /\ sx = sy). +(* . *) +rewrite <- Hp. +intros Bz. +destruct (Bool.bool_dec sx sy) as [Hs|Hs]. +(* .. *) +refine (conj _ Hs). +rewrite Hs. +apply sym_eq. +case sy. +apply Rlt_bool_true. +rewrite <- (Rplus_0_r 0). +apply Rplus_lt_compat. +now apply F2R_lt_0. +now apply F2R_lt_0. +apply Rlt_bool_false. +rewrite <- (Rplus_0_r 0). +apply Rplus_le_compat. +now apply F2R_ge_0. +now apply F2R_ge_0. +(* .. *) +elim Rle_not_lt with (1 := Bz). +generalize (bounded_lt_emax _ _ Hx) (bounded_lt_emax _ _ Hy) (andb_prop _ _ Hx) (andb_prop _ _ Hy). +intros Bx By (Hx',_) (Hy',_). +generalize (canonical_canonical_mantissa sx _ _ Hx') (canonical_canonical_mantissa sy _ _ Hy'). +clear -Bx By Hs prec_gt_0_. +intros Cx Cy. +destruct sx. +(* ... *) +destruct sy. +now elim Hs. +clear Hs. +apply Rabs_lt. +split. +apply Rlt_le_trans with (F2R (Float radix2 (cond_Zopp true (Zpos mx)) ex)). +rewrite F2R_Zopp. +now apply Ropp_lt_contravar. +apply round_ge_generic... +now apply generic_format_canonical. +pattern (F2R (Float radix2 (cond_Zopp true (Zpos mx)) ex)) at 1 ; rewrite <- Rplus_0_r. +apply Rplus_le_compat_l. +now apply F2R_ge_0. +apply Rle_lt_trans with (2 := By). +apply round_le_generic... +now apply generic_format_canonical. +rewrite <- (Rplus_0_l (F2R (Float radix2 (Zpos my) ey))). +apply Rplus_le_compat_r. +now apply F2R_le_0. +(* ... *) +destruct sy. +2: now elim Hs. +clear Hs. +apply Rabs_lt. +split. +apply Rlt_le_trans with (F2R (Float radix2 (cond_Zopp true (Zpos my)) ey)). +rewrite F2R_Zopp. +now apply Ropp_lt_contravar. +apply round_ge_generic... +now apply generic_format_canonical. +pattern (F2R (Float radix2 (cond_Zopp true (Zpos my)) ey)) at 1 ; rewrite <- Rplus_0_l. +apply Rplus_le_compat_r. +now apply F2R_ge_0. +apply Rle_lt_trans with (2 := Bx). +apply round_le_generic... +now apply generic_format_canonical. +rewrite <- (Rplus_0_r (F2R (Float radix2 (Zpos mx) ex))). +apply Rplus_le_compat_l. +now apply F2R_le_0. +(* . *) +generalize (binary_normalize_correct m mz ez szero). +case Rlt_bool_spec. +split; try easy. split; try easy. +destruct (Rcompare_spec (F2R (beta:=radix2) {| Fnum := mz; Fexp := ez |}) 0); try easy. +rewrite H1 in Hp. +apply Rplus_opp_r_uniq in Hp. +rewrite <- F2R_Zopp in Hp. +eapply canonical_unique in Hp. +inversion Hp. destruct sy, sx, m; try discriminate H3; easy. +apply canonical_canonical_mantissa. +apply Bool.andb_true_iff in Hy. easy. +replace (-cond_Zopp sx (Z.pos mx))%Z with (cond_Zopp (negb sx) (Z.pos mx)) + by (destruct sx; auto). +apply canonical_canonical_mantissa. +apply Bool.andb_true_iff in Hx. easy. +intros Hz' Vz. +specialize (Sz Hz'). +split. +rewrite Vz. +now apply f_equal. +apply Sz. +Qed. + +(** Subtraction *) + +Definition Bminus minus_nan m x y := + match x, y with + | B754_nan _ _ _, _ | _, B754_nan _ _ _ => build_nan (minus_nan x y) + | B754_infinity sx, B754_infinity sy => + if Bool.eqb sx (negb sy) then x else build_nan (minus_nan x y) + | B754_infinity _, _ => x + | _, B754_infinity sy => B754_infinity (negb sy) + | B754_zero sx, B754_zero sy => + if Bool.eqb sx (negb sy) then x else + match m with mode_DN => B754_zero true | _ => B754_zero false end + | B754_zero _, B754_finite sy my ey Hy => B754_finite (negb sy) my ey Hy + | _, B754_zero _ => x + | B754_finite sx mx ex Hx, B754_finite sy my ey Hy => + let ez := Z.min ex ey in + binary_normalize m (Zminus (cond_Zopp sx (Zpos (fst (shl_align mx ex ez)))) (cond_Zopp sy (Zpos (fst (shl_align my ey ez))))) + ez (match m with mode_DN => true | _ => false end) + end. + +Theorem Bminus_correct : + forall minus_nan m x y, + is_finite x = true -> + is_finite y = true -> + if Rlt_bool (Rabs (round radix2 fexp (round_mode m) (B2R x - B2R y))) (bpow radix2 emax) then + B2R (Bminus minus_nan m x y) = round radix2 fexp (round_mode m) (B2R x - B2R y) /\ + is_finite (Bminus minus_nan m x y) = true /\ + Bsign (Bminus minus_nan m x y) = + match Rcompare (B2R x - B2R y) 0 with + | Eq => match m with mode_DN => orb (Bsign x) (negb (Bsign y)) + | _ => andb (Bsign x) (negb (Bsign y)) end + | Lt => true + | Gt => false + end + else + (B2FF (Bminus minus_nan m x y) = binary_overflow m (Bsign x) /\ Bsign x = negb (Bsign y)). +Proof with auto with typeclass_instances. +intros minus_nan m x y Fx Fy. +generalize (Bplus_correct minus_nan m x (Bopp (fun n => minus_nan n (B754_zero false)) y) Fx). +rewrite is_finite_Bopp, B2R_Bopp. +intros H. +specialize (H Fy). +replace (negb (Bsign y)) with (Bsign (Bopp (fun n => minus_nan n (B754_zero false)) y)). +destruct x as [| | |sx mx ex Hx], y as [| | |sy my ey Hy] ; try easy. +unfold Bminus, Zminus. +now rewrite <- cond_Zopp_negb. +now destruct y as [ | | | ]. +Qed. + +(** Division *) + +Definition Fdiv_core_binary m1 e1 m2 e2 := + let d1 := Zdigits2 m1 in + let d2 := Zdigits2 m2 in + let e' := Z.min (fexp (d1 + e1 - (d2 + e2))) (e1 - e2) in + let s := (e1 - e2 - e')%Z in + let m' := + match s with + | Zpos _ => Z.shiftl m1 s + | Z0 => m1 + | Zneg _ => Z0 + end in + let '(q, r) := Zfast_div_eucl m' m2 in + (q, e', new_location m2 r loc_Exact). + +Lemma Bdiv_correct_aux : + forall m sx mx ex sy my ey, + let x := F2R (Float radix2 (cond_Zopp sx (Zpos mx)) ex) in + let y := F2R (Float radix2 (cond_Zopp sy (Zpos my)) ey) in + let z := + let '(mz, ez, lz) := Fdiv_core_binary (Zpos mx) ex (Zpos my) ey in + binary_round_aux m (xorb sx sy) mz ez lz in + valid_binary z = true /\ + if Rlt_bool (Rabs (round radix2 fexp (round_mode m) (x / y))) (bpow radix2 emax) then + FF2R radix2 z = round radix2 fexp (round_mode m) (x / y) /\ + is_finite_FF z = true /\ sign_FF z = xorb sx sy + else + z = binary_overflow m (xorb sx sy). +Proof. +intros m sx mx ex sy my ey. +unfold Fdiv_core_binary. +rewrite 2!Zdigits2_Zdigits. +set (e' := Z.min _ _). +generalize (Fdiv_core_correct radix2 (Zpos mx) ex (Zpos my) ey e' eq_refl eq_refl). +unfold Fdiv_core. +rewrite Zle_bool_true by apply Z.le_min_r. +match goal with |- context [Zfast_div_eucl ?m _] => set (mx' := m) end. +assert (mx' = Zpos mx * Zpower radix2 (ex - ey - e'))%Z as <-. +{ unfold mx'. + destruct (ex - ey - e')%Z as [|p|p]. + now rewrite Zmult_1_r. + now rewrite Z.shiftl_mul_pow2. + easy. } +clearbody mx'. +rewrite Zfast_div_eucl_correct. +destruct Z.div_eucl as [q r]. +intros Bz. +assert (xorb sx sy = Rlt_bool (F2R (Float radix2 (cond_Zopp sx (Zpos mx)) ex) * + / F2R (Float radix2 (cond_Zopp sy (Zpos my)) ey)) 0) as ->. +{ apply eq_sym. +case sy ; simpl. +change (Zneg my) with (Z.opp (Zpos my)). +rewrite F2R_Zopp. +rewrite <- Ropp_inv_permute. +rewrite Ropp_mult_distr_r_reverse. +case sx ; simpl. +apply Rlt_bool_false. +rewrite <- Ropp_mult_distr_l_reverse. +apply Rmult_le_pos. +rewrite <- F2R_opp. +now apply F2R_ge_0. +apply Rlt_le. +apply Rinv_0_lt_compat. +now apply F2R_gt_0. +apply Rlt_bool_true. +rewrite <- Ropp_0. +apply Ropp_lt_contravar. +apply Rmult_lt_0_compat. +now apply F2R_gt_0. +apply Rinv_0_lt_compat. +now apply F2R_gt_0. +apply Rgt_not_eq. +now apply F2R_gt_0. +case sx. +apply Rlt_bool_true. +rewrite F2R_Zopp. +rewrite Ropp_mult_distr_l_reverse. +rewrite <- Ropp_0. +apply Ropp_lt_contravar. +apply Rmult_lt_0_compat. +now apply F2R_gt_0. +apply Rinv_0_lt_compat. +now apply F2R_gt_0. +apply Rlt_bool_false. +apply Rmult_le_pos. +now apply F2R_ge_0. +apply Rlt_le. +apply Rinv_0_lt_compat. +now apply F2R_gt_0. } +unfold Rdiv. +apply binary_round_aux_correct'. +- apply Rmult_integral_contrapositive_currified. + now apply F2R_neq_0 ; case sx. + apply Rinv_neq_0_compat. + now apply F2R_neq_0 ; case sy. +- rewrite Rabs_mult, Rabs_Rinv. + now rewrite <- 2!F2R_Zabs, 2!abs_cond_Zopp. + now apply F2R_neq_0 ; case sy. +- rewrite <- cexp_abs, Rabs_mult, Rabs_Rinv. + rewrite 2!F2R_cond_Zopp, 2!abs_cond_Ropp, <- Rabs_Rinv. + rewrite <- Rabs_mult, cexp_abs. + apply Z.le_trans with (1 := Z.le_min_l _ _). + apply FLT_exp_monotone. + now apply mag_div_F2R. + now apply F2R_neq_0. + now apply F2R_neq_0 ; case sy. +Qed. + +Definition Bdiv div_nan m x y := + match x, y with + | B754_nan _ _ _, _ | _, B754_nan _ _ _ => build_nan (div_nan x y) + | B754_infinity sx, B754_infinity sy => build_nan (div_nan x y) + | B754_infinity sx, B754_finite sy _ _ _ => B754_infinity (xorb sx sy) + | B754_finite sx _ _ _, B754_infinity sy => B754_zero (xorb sx sy) + | B754_infinity sx, B754_zero sy => B754_infinity (xorb sx sy) + | B754_zero sx, B754_infinity sy => B754_zero (xorb sx sy) + | B754_finite sx _ _ _, B754_zero sy => B754_infinity (xorb sx sy) + | B754_zero sx, B754_finite sy _ _ _ => B754_zero (xorb sx sy) + | B754_zero sx, B754_zero sy => build_nan (div_nan x y) + | B754_finite sx mx ex _, B754_finite sy my ey _ => + FF2B _ (proj1 (Bdiv_correct_aux m sx mx ex sy my ey)) + end. + +Theorem Bdiv_correct : + forall div_nan m x y, + B2R y <> 0%R -> + if Rlt_bool (Rabs (round radix2 fexp (round_mode m) (B2R x / B2R y))) (bpow radix2 emax) then + B2R (Bdiv div_nan m x y) = round radix2 fexp (round_mode m) (B2R x / B2R y) /\ + is_finite (Bdiv div_nan m x y) = is_finite x /\ + (is_nan (Bdiv div_nan m x y) = false -> + Bsign (Bdiv div_nan m x y) = xorb (Bsign x) (Bsign y)) + else + B2FF (Bdiv div_nan m x y) = binary_overflow m (xorb (Bsign x) (Bsign y)). +Proof. +intros div_nan m x [sy|sy|sy ply|sy my ey Hy] Zy ; try now elim Zy. +revert x. +unfold Rdiv. +intros [sx|sx|sx plx Hx|sx mx ex Hx] ; + try ( rewrite Rmult_0_l, round_0, Rabs_R0, Rlt_bool_true ; [ simpl ; try easy ; now rewrite B2R_build_nan, is_finite_build_nan, is_nan_build_nan | apply bpow_gt_0 | auto with typeclass_instances ] ). +simpl. +case Bdiv_correct_aux. +intros H1. +unfold Rdiv. +case Rlt_bool. +intros (H2, (H3, H4)). +split. +now rewrite B2R_FF2B. +split. +now rewrite is_finite_FF2B. +rewrite Bsign_FF2B. congruence. +intros H2. +now rewrite B2FF_FF2B. +Qed. + +(** Square root *) + +Definition Fsqrt_core_binary m e := + let d := Zdigits2 m in + let e' := Z.min (fexp (Z.div2 (d + e + 1))) (Z.div2 e) in + let s := (e - 2 * e')%Z in + let m' := + match s with + | Zpos p => Z.shiftl m s + | Z0 => m + | Zneg _ => Z0 + end in + let (q, r) := Z.sqrtrem m' in + let l := + if Zeq_bool r 0 then loc_Exact + else loc_Inexact (if Zle_bool r q then Lt else Gt) in + (q, e', l). + +Lemma Bsqrt_correct_aux : + forall m mx ex (Hx : bounded mx ex = true), + let x := F2R (Float radix2 (Zpos mx) ex) in + let z := + let '(mz, ez, lz) := Fsqrt_core_binary (Zpos mx) ex in + binary_round_aux m false mz ez lz in + valid_binary z = true /\ + FF2R radix2 z = round radix2 fexp (round_mode m) (sqrt x) /\ + is_finite_FF z = true /\ sign_FF z = false. +Proof with auto with typeclass_instances. +intros m mx ex Hx. +unfold Fsqrt_core_binary. +rewrite Zdigits2_Zdigits. +set (e' := Z.min _ _). +assert (2 * e' <= ex)%Z as He. +{ assert (e' <= Z.div2 ex)%Z by apply Z.le_min_r. + rewrite (Zdiv2_odd_eqn ex). + destruct Z.odd ; omega. } +generalize (Fsqrt_core_correct radix2 (Zpos mx) ex e' eq_refl He). +unfold Fsqrt_core. +set (mx' := match (ex - 2 * e')%Z with Z0 => _ | _ => _ end). +assert (mx' = Zpos mx * Zpower radix2 (ex - 2 * e'))%Z as <-. +{ unfold mx'. + destruct (ex - 2 * e')%Z as [|p|p]. + now rewrite Zmult_1_r. + now rewrite Z.shiftl_mul_pow2. + easy. } +clearbody mx'. +destruct Z.sqrtrem as [mz r]. +set (lz := if Zeq_bool r 0 then _ else _). +clearbody lz. +intros Bz. +refine (_ (binary_round_aux_correct' m (sqrt (F2R (Float radix2 (Zpos mx) ex))) mz e' lz _ _ _)) ; cycle 1. + now apply Rgt_not_eq, sqrt_lt_R0, F2R_gt_0. + rewrite Rabs_pos_eq. + exact Bz. + apply sqrt_ge_0. + apply Z.le_trans with (1 := Z.le_min_l _ _). + apply FLT_exp_monotone. + rewrite mag_sqrt_F2R by easy. + apply Z.le_refl. +rewrite Rlt_bool_false by apply sqrt_ge_0. +rewrite Rlt_bool_true. +easy. +rewrite Rabs_pos_eq. +refine (_ (relative_error_FLT_ex radix2 emin prec (prec_gt_0 prec) (round_mode m) (sqrt (F2R (Float radix2 (Zpos mx) ex))) _)). +fold fexp. +intros (eps, (Heps, Hr)). +rewrite Hr. +assert (Heps': (Rabs eps < 1)%R). +apply Rlt_le_trans with (1 := Heps). +fold (bpow radix2 0). +apply bpow_le. +generalize (prec_gt_0 prec). +clear ; omega. +apply Rsqr_incrst_0. +3: apply bpow_ge_0. +rewrite Rsqr_mult. +rewrite Rsqr_sqrt. +2: now apply F2R_ge_0. +unfold Rsqr. +apply Rmult_ge_0_gt_0_lt_compat. +apply Rle_ge. +apply Rle_0_sqr. +apply bpow_gt_0. +now apply bounded_lt_emax. +apply Rlt_le_trans with 4%R. +apply (Rsqr_incrst_1 _ 2). +apply Rplus_lt_compat_l. +apply (Rabs_lt_inv _ _ Heps'). +rewrite <- (Rplus_opp_r 1). +apply Rplus_le_compat_l. +apply Rlt_le. +apply (Rabs_lt_inv _ _ Heps'). +now apply IZR_le. +change 4%R with (bpow radix2 2). +apply bpow_le. +generalize (prec_gt_0 prec). +clear -Hmax ; omega. +apply Rmult_le_pos. +apply sqrt_ge_0. +rewrite <- (Rplus_opp_r 1). +apply Rplus_le_compat_l. +apply Rlt_le. +apply (Rabs_lt_inv _ _ Heps'). +rewrite Rabs_pos_eq. +2: apply sqrt_ge_0. +apply Rsqr_incr_0. +2: apply bpow_ge_0. +2: apply sqrt_ge_0. +rewrite Rsqr_sqrt. +2: now apply F2R_ge_0. +apply Rle_trans with (bpow radix2 emin). +unfold Rsqr. +rewrite <- bpow_plus. +apply bpow_le. +unfold emin. +clear -Hmax ; omega. +apply generic_format_ge_bpow with fexp. +intros. +apply Z.le_max_r. +now apply F2R_gt_0. +apply generic_format_canonical. +apply (canonical_canonical_mantissa false). +apply (andb_prop _ _ Hx). +apply round_ge_generic... +apply generic_format_0. +apply sqrt_ge_0. +Qed. + +Definition Bsqrt sqrt_nan m x := + match x with + | B754_nan sx plx _ => build_nan (sqrt_nan x) + | B754_infinity false => x + | B754_infinity true => build_nan (sqrt_nan x) + | B754_finite true _ _ _ => build_nan (sqrt_nan x) + | B754_zero _ => x + | B754_finite sx mx ex Hx => + FF2B _ (proj1 (Bsqrt_correct_aux m mx ex Hx)) + end. + +Theorem Bsqrt_correct : + forall sqrt_nan m x, + B2R (Bsqrt sqrt_nan m x) = round radix2 fexp (round_mode m) (sqrt (B2R x)) /\ + is_finite (Bsqrt sqrt_nan m x) = match x with B754_zero _ => true | B754_finite false _ _ _ => true | _ => false end /\ + (is_nan (Bsqrt sqrt_nan m x) = false -> Bsign (Bsqrt sqrt_nan m x) = Bsign x). +Proof. +intros sqrt_nan m [sx|[|]|sx plx Hplx|sx mx ex Hx] ; + try ( simpl ; rewrite sqrt_0, round_0, ?B2R_build_nan, ?is_finite_build_nan, ?is_nan_build_nan ; intuition auto with typeclass_instances ; easy). +simpl. +case Bsqrt_correct_aux. +intros H1 (H2, (H3, H4)). +case sx. +rewrite B2R_build_nan, is_finite_build_nan, is_nan_build_nan. +refine (conj _ (conj (refl_equal false) _)). +apply sym_eq. +unfold sqrt. +case Rcase_abs. +intros _. +apply round_0. +auto with typeclass_instances. +intros H. +elim Rge_not_lt with (1 := H). +now apply F2R_lt_0. +easy. +split. +now rewrite B2R_FF2B. +split. +now rewrite is_finite_FF2B. +intros _. +now rewrite Bsign_FF2B. +Qed. + +(** A few values *) + +Definition Bone := FF2B _ (proj1 (binary_round_correct mode_NE false 1 0)). + +Theorem Bone_correct : B2R Bone = 1%R. +Proof. +unfold Bone; simpl. +set (Hr := binary_round_correct _ _ _ _). +unfold Hr; rewrite B2R_FF2B. +destruct Hr as (Vz, Hr). +revert Hr. +fold emin; simpl. +rewrite round_generic; [|now apply valid_rnd_N|]. +- unfold F2R; simpl; rewrite Rmult_1_r. + rewrite Rlt_bool_true. + + now intros (Hr, Hr'); rewrite Hr. + + rewrite Rabs_pos_eq; [|lra]. + change 1%R with (bpow radix2 0); apply bpow_lt. + unfold Prec_gt_0 in prec_gt_0_; lia. +- apply generic_format_F2R; intros _. + unfold cexp, fexp, FLT_exp, F2R; simpl; rewrite Rmult_1_r, mag_1. + unfold emin; unfold Prec_gt_0 in prec_gt_0_; lia. +Qed. + +Lemma is_finite_Bone : is_finite Bone = true. +Proof. +generalize Bone_correct; case Bone; simpl; + try (intros; reflexivity); intros; exfalso; lra. +Qed. + +Lemma Bsign_Bone : Bsign Bone = false. +Proof. +generalize Bone_correct; case Bone; simpl; + try (intros; exfalso; lra); intros s' m e _. +case s'; [|now intro]; unfold F2R; simpl. +intro H; exfalso; revert H; apply Rlt_not_eq, (Rle_lt_trans _ 0); [|lra]. +rewrite <-Ropp_0, <-(Ropp_involutive (_ * _)); apply Ropp_le_contravar. +rewrite Ropp_mult_distr_l; apply Rmult_le_pos; [|now apply bpow_ge_0]. +unfold IZR; rewrite <-INR_IPR; generalize (INR_pos m); lra. +Qed. + +Lemma Bmax_float_proof : + valid_binary + (F754_finite false (shift_pos (Z.to_pos prec) 1 - 1) (emax - prec)) + = true. +Proof. +unfold valid_binary, bounded; apply andb_true_intro; split. +- unfold canonical_mantissa; apply Zeq_bool_true. + set (p := Z.pos (digits2_pos _)). + assert (H : p = prec). + { unfold p; rewrite Zpos_digits2_pos, Pos2Z.inj_sub. + - rewrite shift_pos_correct, Z.mul_1_r. + assert (P2pm1 : (0 <= 2 ^ prec - 1)%Z). + { apply (Zplus_le_reg_r _ _ 1); ring_simplify. + change 1%Z with (2 ^ 0)%Z; change 2%Z with (radix2 : Z). + apply Zpower_le; unfold Prec_gt_0 in prec_gt_0_; lia. } + apply Zdigits_unique; + rewrite Z.pow_pos_fold, Z2Pos.id; [|exact prec_gt_0_]; simpl; split. + + rewrite (Z.abs_eq _ P2pm1). + replace prec with (prec - 1 + 1)%Z at 2 by ring. + rewrite Zpower_plus; [| unfold Prec_gt_0 in prec_gt_0_; lia|lia]. + simpl; unfold Z.pow_pos; simpl. + assert (1 <= 2 ^ (prec - 1))%Z; [|lia]. + change 1%Z with (2 ^ 0)%Z; change 2%Z with (radix2 : Z). + apply Zpower_le; simpl; unfold Prec_gt_0 in prec_gt_0_; lia. + + now rewrite Z.abs_eq; [lia|]. + - change (_ < _)%positive + with (Z.pos 1 < Z.pos (shift_pos (Z.to_pos prec) 1))%Z. + rewrite shift_pos_correct, Z.mul_1_r, Z.pow_pos_fold. + rewrite Z2Pos.id; [|exact prec_gt_0_]. + change 1%Z with (2 ^ 0)%Z; change 2%Z with (radix2 : Z). + apply Zpower_lt; unfold Prec_gt_0 in prec_gt_0_; lia. } + unfold fexp, FLT_exp; rewrite H, Z.max_l; [ring|]. + unfold Prec_gt_0 in prec_gt_0_; unfold emin; lia. +- apply Zle_bool_true; unfold emin; unfold Prec_gt_0 in prec_gt_0_; lia. +Qed. + +Definition Bmax_float := FF2B _ Bmax_float_proof. + +(** Extraction/modification of mantissa/exponent *) + +Definition Bnormfr_mantissa x := + match x with + | B754_finite _ mx ex _ => + if Z.eqb ex (-prec)%Z then Npos mx else 0%N + | _ => 0%N + end. + +Definition Bldexp mode f e := + match f with + | B754_finite sx mx ex _ => + FF2B _ (proj1 (binary_round_correct mode sx mx (ex+e))) + | _ => f + end. + +Theorem Bldexp_correct : + forall m (f : binary_float) e, + if Rlt_bool + (Rabs (round radix2 fexp (round_mode m) (B2R f * bpow radix2 e))) + (bpow radix2 emax) then + (B2R (Bldexp m f e) + = round radix2 fexp (round_mode m) (B2R f * bpow radix2 e))%R /\ + is_finite (Bldexp m f e) = is_finite f /\ + Bsign (Bldexp m f e) = Bsign f + else + B2FF (Bldexp m f e) = binary_overflow m (Bsign f). +Proof. +intros m f e. +case f. +- intro s; simpl; rewrite Rmult_0_l, round_0; [|apply valid_rnd_round_mode]. + now rewrite Rabs_R0, Rlt_bool_true; [|now apply bpow_gt_0]. +- intro s; simpl; rewrite Rmult_0_l, round_0; [|apply valid_rnd_round_mode]. + now rewrite Rabs_R0, Rlt_bool_true; [|now apply bpow_gt_0]. +- intro s; simpl; rewrite Rmult_0_l, round_0; [|apply valid_rnd_round_mode]. + now rewrite Rabs_R0, Rlt_bool_true; [|now apply bpow_gt_0]. +- intros s mf ef Hmef. + case (Rlt_bool_spec _ _); intro Hover. + + unfold Bldexp; rewrite B2R_FF2B, is_finite_FF2B, Bsign_FF2B. + simpl; unfold F2R; simpl; rewrite Rmult_assoc, <-bpow_plus. + destruct (binary_round_correct m s mf (ef + e)) as (Hf, Hr). + fold emin in Hr; simpl in Hr; rewrite Rlt_bool_true in Hr. + * now destruct Hr as (Hr, (Hfr, Hsr)); rewrite Hr, Hfr, Hsr. + * now revert Hover; unfold B2R, F2R; simpl; rewrite Rmult_assoc, bpow_plus. + + unfold Bldexp; rewrite B2FF_FF2B; simpl. + destruct (binary_round_correct m s mf (ef + e)) as (Hf, Hr). + fold emin in Hr; simpl in Hr; rewrite Rlt_bool_false in Hr; [exact Hr|]. + now revert Hover; unfold B2R, F2R; simpl; rewrite Rmult_assoc, bpow_plus. +Qed. + +(** This hypothesis is needed to implement Bfrexp + (otherwise, we have emin > - prec + and Bfrexp cannot fit the mantissa in interval [0.5, 1)) *) +Hypothesis Hemax : (3 <= emax)%Z. + +Definition Ffrexp_core_binary s m e := + if (Z.to_pos prec <=? digits2_pos m)%positive then + (F754_finite s m (-prec), (e + prec)%Z) + else + let d := (prec - Z.pos (digits2_pos m))%Z in + (F754_finite s (shift_pos (Z.to_pos d) m) (-prec), (e + prec - d)%Z). + +Lemma Bfrexp_correct_aux : + forall sx mx ex (Hx : bounded mx ex = true), + let x := F2R (Float radix2 (cond_Zopp sx (Z.pos mx)) ex) in + let z := fst (Ffrexp_core_binary sx mx ex) in + let e := snd (Ffrexp_core_binary sx mx ex) in + valid_binary z = true /\ + (/2 <= Rabs (FF2R radix2 z) < 1)%R /\ + (x = FF2R radix2 z * bpow radix2 e)%R. +Proof. +intros sx mx ex Bx. +set (x := F2R _). +set (z := fst _). +set (e := snd _); simpl. +assert (Dmx_le_prec : (Z.pos (digits2_pos mx) <= prec)%Z). +{ revert Bx; unfold bounded; rewrite Bool.andb_true_iff. + unfold canonical_mantissa; rewrite <-Zeq_is_eq_bool; unfold fexp, FLT_exp. + case (Z.max_spec (Z.pos (digits2_pos mx) + ex - prec) emin); lia. } +assert (Dmx_le_prec' : (digits2_pos mx <= Z.to_pos prec)%positive). +{ change (_ <= _)%positive + with (Z.pos (digits2_pos mx) <= Z.pos (Z.to_pos prec))%Z. + now rewrite Z2Pos.id; [|now apply prec_gt_0_]. } +unfold z, e, Ffrexp_core_binary. +case (Pos.leb_spec _ _); simpl; intro Dmx. +- unfold bounded, F2R; simpl. + assert (Dmx' : digits2_pos mx = Z.to_pos prec). + { now apply Pos.le_antisym. } + assert (Dmx'' : Z.pos (digits2_pos mx) = prec). + { now rewrite Dmx', Z2Pos.id; [|apply prec_gt_0_]. } + split; [|split]. + + apply andb_true_intro. + split; [|apply Zle_bool_true; lia]. + apply Zeq_bool_true; unfold fexp, FLT_exp. + rewrite Dmx', Z2Pos.id; [|now apply prec_gt_0_]. + rewrite Z.max_l; [ring|unfold emin; lia]. + + rewrite Rabs_mult, (Rabs_pos_eq (bpow _ _)); [|now apply bpow_ge_0]. + rewrite <-abs_IZR, abs_cond_Zopp; simpl; split. + * apply (Rmult_le_reg_r (bpow radix2 prec)); [now apply bpow_gt_0|]. + rewrite Rmult_assoc, <-bpow_plus, Z.add_opp_diag_l; simpl. + rewrite Rmult_1_r. + change (/ 2)%R with (bpow radix2 (- 1)); rewrite <-bpow_plus. + rewrite <-Dmx'', Z.add_comm, Zpos_digits2_pos, Zdigits_mag; [|lia]. + set (b := bpow _ _). + rewrite <-(Rabs_pos_eq (IZR _)); [|apply IZR_le; lia]. + apply bpow_mag_le; apply IZR_neq; lia. + * apply (Rmult_lt_reg_r (bpow radix2 prec)); [now apply bpow_gt_0|]. + rewrite Rmult_assoc, <-bpow_plus, Z.add_opp_diag_l; simpl. + rewrite Rmult_1_l, Rmult_1_r. + rewrite <-Dmx'', Zpos_digits2_pos, Zdigits_mag; [|lia]. + set (b := bpow _ _). + rewrite <-(Rabs_pos_eq (IZR _)); [|apply IZR_le; lia]. + apply bpow_mag_gt; apply IZR_neq; lia. + + unfold x, F2R; simpl; rewrite Rmult_assoc, <-bpow_plus. + now replace (_ + _)%Z with ex by ring. +- unfold bounded, F2R; simpl. + assert (Dmx' : (Z.pos (digits2_pos mx) < prec)%Z). + { now rewrite <-(Z2Pos.id prec); [|now apply prec_gt_0_]. } + split; [|split]. + + unfold bounded; apply andb_true_intro. + split; [|apply Zle_bool_true; lia]. + apply Zeq_bool_true; unfold fexp, FLT_exp. + rewrite Zpos_digits2_pos, shift_pos_correct, Z.pow_pos_fold. + rewrite Z2Pos.id; [|lia]. + rewrite Z.mul_comm; change 2%Z with (radix2 : Z). + rewrite Zdigits_mult_Zpower; [|lia|lia]. + rewrite Zpos_digits2_pos; replace (_ - _)%Z with (- prec)%Z by ring. + now rewrite Z.max_l; [|unfold emin; lia]. + + rewrite Rabs_mult, (Rabs_pos_eq (bpow _ _)); [|now apply bpow_ge_0]. + rewrite <-abs_IZR, abs_cond_Zopp; simpl. + rewrite shift_pos_correct, mult_IZR. + change (IZR (Z.pow_pos _ _)) + with (bpow radix2 (Z.pos (Z.to_pos ((prec - Z.pos (digits2_pos mx)))))). + rewrite Z2Pos.id; [|lia]. + rewrite Rmult_comm, <-Rmult_assoc, <-bpow_plus. + set (d := Z.pos (digits2_pos mx)). + replace (_ + _)%Z with (- d)%Z by ring; split. + * apply (Rmult_le_reg_l (bpow radix2 d)); [now apply bpow_gt_0|]. + rewrite <-Rmult_assoc, <-bpow_plus, Z.add_opp_diag_r. + rewrite Rmult_1_l. + change (/ 2)%R with (bpow radix2 (- 1)); rewrite <-bpow_plus. + rewrite <-(Rabs_pos_eq (IZR _)); [|apply IZR_le; lia]. + unfold d; rewrite Zpos_digits2_pos, Zdigits_mag; [|lia]. + apply bpow_mag_le; apply IZR_neq; lia. + * apply (Rmult_lt_reg_l (bpow radix2 d)); [now apply bpow_gt_0|]. + rewrite <-Rmult_assoc, <-bpow_plus, Z.add_opp_diag_r. + rewrite Rmult_1_l, Rmult_1_r. + rewrite <-(Rabs_pos_eq (IZR _)); [|apply IZR_le; lia]. + unfold d; rewrite Zpos_digits2_pos, Zdigits_mag; [|lia]. + apply bpow_mag_gt; apply IZR_neq; lia. + + rewrite Rmult_assoc, <-bpow_plus, shift_pos_correct. + rewrite IZR_cond_Zopp, mult_IZR, cond_Ropp_mult_r, <-IZR_cond_Zopp. + change (IZR (Z.pow_pos _ _)) + with (bpow radix2 (Z.pos (Z.to_pos (prec - Z.pos (digits2_pos mx))))). + rewrite Z2Pos.id; [|lia]. + rewrite Rmult_comm, <-Rmult_assoc, <-bpow_plus. + now replace (_ + _)%Z with ex by ring; rewrite Rmult_comm. +Qed. + +Definition Bfrexp f := + match f with + | B754_finite s m e H => + let e' := snd (Ffrexp_core_binary s m e) in + (FF2B _ (proj1 (Bfrexp_correct_aux s m e H)), e') + | _ => (f, (-2*emax-prec)%Z) + end. + +Theorem Bfrexp_correct : + forall f, + is_finite_strict f = true -> + let x := B2R f in + let z := fst (Bfrexp f) in + let e := snd (Bfrexp f) in + (/2 <= Rabs (B2R z) < 1)%R /\ + (x = B2R z * bpow radix2 e)%R /\ + e = mag radix2 x. +Proof. +intro f; case f; intro s; try discriminate; intros m e Hf _. +generalize (Bfrexp_correct_aux s m e Hf). +intros (_, (Hb, Heq)); simpl; rewrite B2R_FF2B. +split; [now simpl|]; split; [now simpl|]. +rewrite Heq, mag_mult_bpow. +- apply (Z.add_reg_l (- (snd (Ffrexp_core_binary s m e)))). + now ring_simplify; symmetry; apply mag_unique. +- intro H; destruct Hb as (Hb, _); revert Hb; rewrite H, Rabs_R0; lra. +Qed. + +(** Ulp *) + +Definition Bulp x := Bldexp mode_NE Bone (fexp (snd (Bfrexp x))). + +Theorem Bulp_correct : + forall x, + is_finite x = true -> + B2R (Bulp x) = ulp radix2 fexp (B2R x) /\ + is_finite (Bulp x) = true /\ + Bsign (Bulp x) = false. +Proof. +intro x; case x. +- intros s _; unfold Bulp. + replace (fexp _) with emin. + + generalize (Bldexp_correct mode_NE Bone emin). + rewrite Bone_correct, Rmult_1_l, round_generic; + [|now apply valid_rnd_N|apply generic_format_bpow; unfold fexp, FLT_exp; + rewrite Z.max_r; unfold Prec_gt_0 in prec_gt_0_; lia]. + rewrite Rlt_bool_true. + * intros (Hr, (Hf, Hs)); rewrite Hr, Hf, Hs. + split; [|now split; [apply is_finite_Bone|apply Bsign_Bone]]. + simpl; unfold ulp; rewrite Req_bool_true; [|reflexivity]. + destruct (negligible_exp_FLT emin prec) as (n, (Hn, Hn')). + change fexp with (FLT_exp emin prec); rewrite Hn. + now unfold FLT_exp; rewrite Z.max_r; + [|unfold Prec_gt_0 in prec_gt_0_; lia]. + * rewrite Rabs_pos_eq; [|now apply bpow_ge_0]; apply bpow_lt. + unfold emin; unfold Prec_gt_0 in prec_gt_0_; lia. + + simpl; change (fexp _) with (fexp (-2 * emax - prec)). + unfold fexp, FLT_exp; rewrite Z.max_r; [reflexivity|]. + unfold emin; unfold Prec_gt_0 in prec_gt_0_; lia. +- intro; discriminate. +- intros s pl Hpl; discriminate. +- intros s m e Hme _; unfold Bulp, ulp, cexp. + set (f := B754_finite _ _ _ _). + rewrite Req_bool_false. + + destruct (Bfrexp_correct f (eq_refl _)) as (Hfr1, (Hfr2, Hfr3)). + rewrite Hfr3. + set (e' := fexp _). + generalize (Bldexp_correct mode_NE Bone e'). + rewrite Bone_correct, Rmult_1_l, round_generic; [|now apply valid_rnd_N|]. + { rewrite Rlt_bool_true. + - intros (Hr, (Hf, Hs)); rewrite Hr, Hf, Hs. + now split; [|split; [apply is_finite_Bone|apply Bsign_Bone]]. + - rewrite Rabs_pos_eq; [|now apply bpow_ge_0]. + unfold e', fexp, FLT_exp. + case (Z.max_spec (mag radix2 (B2R f) - prec) emin) + as [(_, Hm)|(_, Hm)]; rewrite Hm; apply bpow_lt; + [now unfold emin; unfold Prec_gt_0 in prec_gt_0_; lia|]. + apply (Zplus_lt_reg_r _ _ prec); ring_simplify. + assert (mag radix2 (B2R f) <= emax)%Z; + [|now unfold Prec_gt_0 in prec_gt_0_; lia]. + apply mag_le_bpow; [|now apply abs_B2R_lt_emax]. + now unfold f, B2R; apply F2R_neq_0; case s. } + apply generic_format_bpow, Z.max_lub. + * unfold Prec_gt_0 in prec_gt_0_; lia. + * apply Z.le_max_r. + + now unfold f, B2R; apply F2R_neq_0; case s. +Qed. + +(** Successor (and predecessor) *) + +Definition Bpred_pos pred_pos_nan x := + match x with + | B754_finite _ mx _ _ => + let d := + if (mx~0 =? shift_pos (Z.to_pos prec) 1)%positive then + Bldexp mode_NE Bone (fexp (snd (Bfrexp x) - 1)) + else + Bulp x in + Bminus (fun _ => pred_pos_nan) mode_NE x d + | _ => x + end. + +Theorem Bpred_pos_correct : + forall pred_pos_nan x, + (0 < B2R x)%R -> + B2R (Bpred_pos pred_pos_nan x) = pred_pos radix2 fexp (B2R x) /\ + is_finite (Bpred_pos pred_pos_nan x) = true /\ + Bsign (Bpred_pos pred_pos_nan x) = false. +Proof. +intros pred_pos_nan x. +generalize (Bfrexp_correct x). +case x. +- simpl; intros s _ Bx; exfalso; apply (Rlt_irrefl _ Bx). +- simpl; intros s _ Bx; exfalso; apply (Rlt_irrefl _ Bx). +- simpl; intros s pl Hpl _ Bx; exfalso; apply (Rlt_irrefl _ Bx). +- intros sx mx ex Hmex Hfrexpx Px. + assert (Hsx : sx = false). + { revert Px; case sx; unfold B2R, F2R; simpl; [|now intro]. + intro Px; exfalso; revert Px; apply Rle_not_lt. + rewrite <-(Rmult_0_l (bpow radix2 ex)). + apply Rmult_le_compat_r; [apply bpow_ge_0|apply IZR_le; lia]. } + clear Px; rewrite Hsx in Hfrexpx |- *; clear Hsx sx. + specialize (Hfrexpx (eq_refl _)). + simpl in Hfrexpx; rewrite B2R_FF2B in Hfrexpx. + destruct Hfrexpx as (Hfrexpx_bounds, (Hfrexpx_eq, Hfrexpx_exp)). + unfold Bpred_pos, Bfrexp. + simpl (snd (_, snd _)). + rewrite Hfrexpx_exp. + set (x' := B754_finite _ _ _ _). + set (xr := F2R _). + assert (Nzxr : xr <> 0%R). + { unfold xr, F2R; simpl. + rewrite <-(Rmult_0_l (bpow radix2 ex)); intro H. + apply Rmult_eq_reg_r in H; [|apply Rgt_not_eq, bpow_gt_0]. + apply eq_IZR in H; lia. } + assert (Hulp := Bulp_correct x'). + specialize (Hulp (eq_refl _)). + assert (Hldexp := Bldexp_correct mode_NE Bone (fexp (mag radix2 xr - 1))). + rewrite Bone_correct, Rmult_1_l in Hldexp. + assert (Fbpowxr : generic_format radix2 fexp + (bpow radix2 (fexp (mag radix2 xr - 1)))). + { apply generic_format_bpow, Z.max_lub. + - unfold Prec_gt_0 in prec_gt_0_; lia. + - apply Z.le_max_r. } + assert (H : Rlt_bool (Rabs + (round radix2 fexp (round_mode mode_NE) + (bpow radix2 (fexp (mag radix2 xr - 1))))) + (bpow radix2 emax) = true); [|rewrite H in Hldexp; clear H]. + { apply Rlt_bool_true; rewrite round_generic; + [|apply valid_rnd_round_mode|apply Fbpowxr]. + rewrite Rabs_pos_eq; [|apply bpow_ge_0]; apply bpow_lt. + apply Z.max_lub_lt; [|unfold emin; unfold Prec_gt_0 in prec_gt_0_; lia]. + apply (Zplus_lt_reg_r _ _ (prec + 1)); ring_simplify. + rewrite Z.add_1_r; apply Zle_lt_succ, mag_le_bpow. + - exact Nzxr. + - apply (Rlt_le_trans _ (bpow radix2 emax)). + + change xr with (B2R x'); apply abs_B2R_lt_emax. + + apply bpow_le; unfold Prec_gt_0 in prec_gt_0_; lia. } + set (d := if (mx~0 =? _)%positive then _ else _). + set (minus_nan := fun _ => _). + assert (Hminus := Bminus_correct minus_nan mode_NE x' d (eq_refl _)). + assert (Fd : is_finite d = true). + { unfold d; case (_ =? _)%positive. + - now rewrite (proj1 (proj2 Hldexp)), is_finite_Bone. + - now rewrite (proj1 (proj2 Hulp)). } + specialize (Hminus Fd). + assert (Px : (0 <= B2R x')%R). + { unfold B2R, x', F2R; simpl. + now apply Rmult_le_pos; [apply IZR_le|apply bpow_ge_0]. } + assert (Pd : (0 <= B2R d)%R). + { unfold d; case (_ =? _)%positive. + - rewrite (proj1 Hldexp). + now rewrite round_generic; [apply bpow_ge_0|apply valid_rnd_N|]. + - rewrite (proj1 Hulp); apply ulp_ge_0. } + assert (Hdlex : (B2R d <= B2R x')%R). + { unfold d; case (_ =? _)%positive. + - rewrite (proj1 Hldexp). + rewrite round_generic; [|now apply valid_rnd_N|now simpl]. + apply (Rle_trans _ (bpow radix2 (mag radix2 xr - 1))). + + apply bpow_le, Z.max_lub. + * unfold Prec_gt_0 in prec_gt_0_; lia. + * apply (Zplus_le_reg_r _ _ 1); ring_simplify. + apply mag_ge_bpow. + replace (_ - 1)%Z with emin by ring. + now change xr with (B2R x'); apply abs_B2R_ge_emin. + + rewrite <-(Rabs_pos_eq _ Px). + now change xr with (B2R x'); apply bpow_mag_le. + - rewrite (proj1 Hulp); apply ulp_le_id. + + assert (B2R x' <> 0%R); [exact Nzxr|lra]. + + apply generic_format_B2R. } + assert (H : Rlt_bool + (Rabs + (round radix2 fexp + (round_mode mode_NE) (B2R x' - B2R d))) + (bpow radix2 emax) = true); [|rewrite H in Hminus; clear H]. + { apply Rlt_bool_true. + rewrite <-round_NE_abs; [|now apply FLT_exp_valid]. + rewrite Rabs_pos_eq; [|lra]. + apply (Rle_lt_trans _ (B2R x')). + - apply round_le_generic; + [now apply FLT_exp_valid|now apply valid_rnd_N| |lra]. + apply generic_format_B2R. + - apply (Rle_lt_trans _ _ _ (Rle_abs _)), abs_B2R_lt_emax. } + rewrite (proj1 Hminus). + rewrite (proj1 (proj2 Hminus)). + rewrite (proj2 (proj2 Hminus)). + split; [|split; [reflexivity|now case (Rcompare_spec _ _); [lra| |]]]. + unfold pred_pos, d. + case (Pos.eqb_spec _ _); intro Hd; case (Req_bool_spec _ _); intro Hpred. + + rewrite (proj1 Hldexp). + rewrite (round_generic _ _ _ _ Fbpowxr). + change xr with (B2R x'). + replace (_ - _)%R with (pred_pos radix2 fexp (B2R x')). + * rewrite round_generic; [reflexivity|now apply valid_rnd_N|]. + apply generic_format_pred_pos; + [now apply FLT_exp_valid|apply generic_format_B2R|]. + change xr with (B2R x') in Nzxr; lra. + * now unfold pred_pos; rewrite Req_bool_true. + + exfalso; apply Hpred. + assert (Hmx : IZR (Z.pos mx) = bpow radix2 (prec - 1)). + { apply (Rmult_eq_reg_l 2); [|lra]; rewrite <-mult_IZR. + change (2 * Z.pos mx)%Z with (Z.pos mx~0); rewrite Hd. + rewrite shift_pos_correct, Z.mul_1_r. + change (IZR (Z.pow_pos _ _)) with (bpow radix2 (Z.pos (Z.to_pos prec))). + rewrite Z2Pos.id; [|exact prec_gt_0_]. + change 2%R with (bpow radix2 1); rewrite <-bpow_plus. + f_equal; ring. } + unfold x' at 1; unfold B2R at 1; unfold F2R; simpl. + rewrite Hmx, <-bpow_plus; f_equal. + apply (Z.add_reg_l 1); ring_simplify; symmetry; apply mag_unique_pos. + unfold F2R; simpl; rewrite Hmx, <-bpow_plus; split. + * right; f_equal; ring. + * apply bpow_lt; lia. + + rewrite (proj1 Hulp). + assert (H : ulp radix2 fexp (B2R x') + = bpow radix2 (fexp (mag radix2 (B2R x') - 1))); + [|rewrite H; clear H]. + { unfold ulp; rewrite Req_bool_false; [|now simpl]. + unfold cexp; f_equal. + assert (H : (mag radix2 (B2R x') <= emin + prec)%Z). + { assert (Hcm : canonical_mantissa mx ex = true). + { now generalize Hmex; unfold bounded; rewrite Bool.andb_true_iff. } + apply (canonical_canonical_mantissa false) in Hcm. + revert Hcm; fold emin; unfold canonical, cexp; simpl. + change (F2R _) with (B2R x'); intro Hex. + apply Z.nlt_ge; intro H'; apply Hd. + apply Pos2Z.inj_pos; rewrite shift_pos_correct, Z.mul_1_r. + apply eq_IZR; change (IZR (Z.pow_pos _ _)) + with (bpow radix2 (Z.pos (Z.to_pos prec))). + rewrite Z2Pos.id; [|exact prec_gt_0_]. + change (Z.pos mx~0) with (2 * Z.pos mx)%Z. + rewrite Z.mul_comm, mult_IZR. + apply (Rmult_eq_reg_r (bpow radix2 (ex - 1))); + [|apply Rgt_not_eq, bpow_gt_0]. + change 2%R with (bpow radix2 1); rewrite Rmult_assoc, <-!bpow_plus. + replace (1 + _)%Z with ex by ring. + unfold B2R at 1, F2R in Hpred; simpl in Hpred; rewrite Hpred. + change (F2R _) with (B2R x'); rewrite Hex. + unfold fexp, FLT_exp; rewrite Z.max_l; [f_equal; ring|lia]. } + now unfold fexp, FLT_exp; do 2 (rewrite Z.max_r; [|lia]). } + replace (_ - _)%R with (pred_pos radix2 fexp (B2R x')). + * rewrite round_generic; [reflexivity|apply valid_rnd_N|]. + apply generic_format_pred_pos; + [now apply FLT_exp_valid| |change xr with (B2R x') in Nzxr; lra]. + apply generic_format_B2R. + * now unfold pred_pos; rewrite Req_bool_true. + + rewrite (proj1 Hulp). + replace (_ - _)%R with (pred_pos radix2 fexp (B2R x')). + * rewrite round_generic; [reflexivity|now apply valid_rnd_N|]. + apply generic_format_pred_pos; + [now apply FLT_exp_valid|apply generic_format_B2R|]. + change xr with (B2R x') in Nzxr; lra. + * now unfold pred_pos; rewrite Req_bool_false. +Qed. + +Definition Bsucc succ_nan x := + match x with + | B754_zero _ => Bldexp mode_NE Bone emin + | B754_infinity false => x + | B754_infinity true => Bopp succ_nan Bmax_float + | B754_nan _ _ _ => build_nan (succ_nan x) + | B754_finite false _ _ _ => + Bplus (fun _ => succ_nan) mode_NE x (Bulp x) + | B754_finite true _ _ _ => + Bopp succ_nan (Bpred_pos succ_nan (Bopp succ_nan x)) + end. + +Lemma Bsucc_correct : + forall succ_nan x, + is_finite x = true -> + if Rlt_bool (succ radix2 fexp (B2R x)) (bpow radix2 emax) then + B2R (Bsucc succ_nan x) = succ radix2 fexp (B2R x) /\ + is_finite (Bsucc succ_nan x) = true /\ + (Bsign (Bsucc succ_nan x) = Bsign x && is_finite_strict x)%bool + else + B2FF (Bsucc succ_nan x) = F754_infinity false. +Proof. +assert (Hsucc : succ radix2 fexp 0 = bpow radix2 emin). +{ unfold succ; rewrite Rle_bool_true; [|now right]; rewrite Rplus_0_l. + unfold ulp; rewrite Req_bool_true; [|now simpl]. + destruct (negligible_exp_FLT emin prec) as (n, (Hne, Hn)). + now unfold fexp; rewrite Hne; unfold FLT_exp; rewrite Z.max_r; + [|unfold Prec_gt_0 in prec_gt_0_; lia]. } +intros succ_nan [s|s|s pl Hpl|sx mx ex Hmex]; try discriminate; intros _. +- generalize (Bldexp_correct mode_NE Bone emin); unfold Bsucc; simpl. + assert (Hbemin : round radix2 fexp ZnearestE (bpow radix2 emin) + = bpow radix2 emin). + { rewrite round_generic; [reflexivity|apply valid_rnd_N|]. + apply generic_format_bpow. + unfold fexp, FLT_exp; rewrite Z.max_r; [now simpl|]. + unfold Prec_gt_0 in prec_gt_0_; lia. } + rewrite Hsucc, Rlt_bool_true. + + intros (Hr, (Hf, Hs)); rewrite Hr, Hf, Hs. + rewrite Bone_correct, Rmult_1_l, is_finite_Bone, Bsign_Bone. + case Rlt_bool_spec; intro Hover. + * now rewrite Bool.andb_false_r. + * exfalso; revert Hover; apply Rlt_not_le, bpow_lt. + unfold emin; unfold Prec_gt_0 in prec_gt_0_; lia. + + rewrite Bone_correct, Rmult_1_l, Hbemin, Rabs_pos_eq; [|apply bpow_ge_0]. + apply bpow_lt; unfold emin; unfold Prec_gt_0 in prec_gt_0_; lia. +- unfold Bsucc; case sx. + + case Rlt_bool_spec; intro Hover. + * rewrite B2R_Bopp; simpl (Bopp _ (B754_finite _ _ _ _)). + rewrite is_finite_Bopp. + set (ox := B754_finite false mx ex Hmex). + assert (Hpred := Bpred_pos_correct succ_nan ox). + assert (Hox : (0 < B2R ox)%R); [|specialize (Hpred Hox); clear Hox]. + { now apply Rmult_lt_0_compat; [apply IZR_lt|apply bpow_gt_0]. } + rewrite (proj1 Hpred), (proj1 (proj2 Hpred)). + unfold succ; rewrite Rle_bool_false; [split; [|split]|]. + { now unfold B2R, F2R, ox; simpl; rewrite Ropp_mult_distr_l, <-opp_IZR. } + { now simpl. } + { simpl (Bsign (B754_finite _ _ _ _)); simpl (true && _)%bool. + rewrite Bsign_Bopp, (proj2 (proj2 Hpred)); [now simpl|]. + now destruct Hpred as (_, (H, _)); revert H; case (Bpred_pos _ _). } + unfold B2R, F2R; simpl; change (Z.neg mx) with (- Z.pos mx)%Z. + rewrite opp_IZR, <-Ropp_mult_distr_l, <-Ropp_0; apply Ropp_lt_contravar. + now apply Rmult_lt_0_compat; [apply IZR_lt|apply bpow_gt_0]. + * exfalso; revert Hover; apply Rlt_not_le. + apply (Rle_lt_trans _ (succ radix2 fexp 0)). + { apply succ_le; [now apply FLT_exp_valid|apply generic_format_B2R| + apply generic_format_0|]. + unfold B2R, F2R; simpl; change (Z.neg mx) with (- Z.pos mx)%Z. + rewrite opp_IZR, <-Ropp_mult_distr_l, <-Ropp_0; apply Ropp_le_contravar. + now apply Rmult_le_pos; [apply IZR_le|apply bpow_ge_0]. } + rewrite Hsucc; apply bpow_lt. + unfold emin; unfold Prec_gt_0 in prec_gt_0_; lia. + + set (x := B754_finite _ _ _ _). + set (plus_nan := fun _ => succ_nan). + assert (Hulp := Bulp_correct x (eq_refl _)). + assert (Hplus := Bplus_correct plus_nan mode_NE x (Bulp x) (eq_refl _)). + rewrite (proj1 (proj2 Hulp)) in Hplus; specialize (Hplus (eq_refl _)). + assert (Px : (0 <= B2R x)%R). + { now apply Rmult_le_pos; [apply IZR_le|apply bpow_ge_0]. } + assert (Hsucc' : (succ radix2 fexp (B2R x) + = B2R x + ulp radix2 fexp (B2R x))%R). + { now unfold succ; rewrite (Rle_bool_true _ _ Px). } + rewrite (proj1 Hulp), <- Hsucc' in Hplus. + rewrite round_generic in Hplus; + [|apply valid_rnd_N| now apply generic_format_succ; + [apply FLT_exp_valid|apply generic_format_B2R]]. + rewrite Rabs_pos_eq in Hplus; [|apply (Rle_trans _ _ _ Px), succ_ge_id]. + revert Hplus; case Rlt_bool_spec; intros Hover Hplus. + * split; [now simpl|split; [now simpl|]]. + rewrite (proj2 (proj2 Hplus)); case Rcompare_spec. + { intro H; exfalso; revert H. + apply Rle_not_lt, (Rle_trans _ _ _ Px), succ_ge_id. } + { intro H; exfalso; revert H; apply Rgt_not_eq, Rlt_gt. + apply (Rlt_le_trans _ (B2R x)); [|apply succ_ge_id]. + now apply Rmult_lt_0_compat; [apply IZR_lt|apply bpow_gt_0]. } + now simpl. + * now rewrite (proj1 Hplus). +Qed. + +Definition Bpred pred_nan x := + Bopp pred_nan (Bsucc pred_nan (Bopp pred_nan x)). + +Lemma Bpred_correct : + forall pred_nan x, + is_finite x = true -> + if Rlt_bool (- bpow radix2 emax) (pred radix2 fexp (B2R x)) then + B2R (Bpred pred_nan x) = pred radix2 fexp (B2R x) /\ + is_finite (Bpred pred_nan x) = true /\ + (Bsign (Bpred pred_nan x) = Bsign x || negb (is_finite_strict x))%bool + else + B2FF (Bpred pred_nan x) = F754_infinity true. +Proof. +intros pred_nan x Fx. +assert (Fox : is_finite (Bopp pred_nan x) = true). +{ now rewrite is_finite_Bopp. } +rewrite <-(Ropp_involutive (B2R x)), <-(B2R_Bopp pred_nan). +rewrite pred_opp, Rlt_bool_opp. +generalize (Bsucc_correct pred_nan _ Fox). +case (Rlt_bool _ _). +- intros (HR, (HF, HS)); unfold Bpred. + rewrite B2R_Bopp, HR, is_finite_Bopp. + rewrite <-(Bool.negb_involutive (Bsign x)), <-Bool.negb_andb. + split; [reflexivity|split; [exact HF|]]. + replace (is_finite_strict x) with (is_finite_strict (Bopp pred_nan x)); + [|now case x; try easy; intros s pl Hpl; simpl; + rewrite is_finite_strict_build_nan]. + rewrite Bsign_Bopp, <-(Bsign_Bopp pred_nan x), HS. + + now simpl. + + now revert Fx; case x. + + now revert HF; case (Bsucc _ _). +- now unfold Bpred; case (Bsucc _ _); intro s; case s. +Qed. + +End Binary. diff --git a/flocq/Appli/Fappli_IEEE_bits.v b/flocq/IEEE754/Bits.v index e6a012cf..3a84edfe 100644 --- a/flocq/Appli/Fappli_IEEE_bits.v +++ b/flocq/IEEE754/Bits.v @@ -2,9 +2,9 @@ This file is part of the Flocq formalization of floating-point arithmetic in Coq: http://flocq.gforge.inria.fr/ -Copyright (C) 2011-2013 Sylvie Boldo +Copyright (C) 2011-2018 Sylvie Boldo #<br /># -Copyright (C) 2011-2013 Guillaume Melquiond +Copyright (C) 2011-2018 Guillaume Melquiond This library is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public @@ -18,46 +18,18 @@ COPYING file for more details. *) (** * IEEE-754 encoding of binary floating-point data *) -Require Import Fcore. -Require Import Fcore_digits. -Require Import Fcalc_digits. -Require Import Fappli_IEEE. +Require Import Core Digits Binary. Section Binary_Bits. -Arguments exist {A P} x _. -Arguments B754_zero {prec emax} _. -Arguments B754_infinity {prec emax} _. -Arguments B754_nan {prec emax} _ _. -Arguments B754_finite {prec emax} _ m e _. +Arguments exist {A} {P}. +Arguments B754_zero {prec} {emax}. +Arguments B754_infinity {prec} {emax}. +Arguments B754_nan {prec} {emax}. +Arguments B754_finite {prec} {emax}. (** Number of bits for the fraction and exponent *) Variable mw ew : Z. -Hypothesis Hmw : (0 < mw)%Z. -Hypothesis Hew : (0 < ew)%Z. - -Let emax := Zpower 2 (ew - 1). -Let prec := (mw + 1)%Z. -Let emin := (3 - emax - prec)%Z. -Let binary_float := binary_float prec emax. - -Let Hprec : (0 < prec)%Z. -unfold prec. -apply Zle_lt_succ. -now apply Zlt_le_weak. -Qed. - -Let Hm_gt_0 : (0 < 2^mw)%Z. -apply (Zpower_gt_0 radix2). -now apply Zlt_le_weak. -Qed. - -Let He_gt_0 : (0 < 2^ew)%Z. -apply (Zpower_gt_0 radix2). -now apply Zlt_le_weak. -Qed. - -Hypothesis Hmax : (prec < emax)%Z. Definition join_bits (s : bool) m e := (Z.shiftl ((if s then Zpower 2 ew else 0) + e) mw + m)%Z. @@ -69,8 +41,14 @@ Lemma join_bits_range : (0 <= join_bits s m e < 2 ^ (mw + ew + 1))%Z. Proof. intros s m e Hm He. +assert (0 <= mw)%Z as Hmw. + destruct mw as [|mw'|mw'] ; try easy. + clear -Hm ; simpl in Hm ; omega. +assert (0 <= ew)%Z as Hew. + destruct ew as [|ew'|ew'] ; try easy. + clear -He ; simpl in He ; omega. unfold join_bits. -rewrite Z.shiftl_mul_pow2 by now apply Zlt_le_weak. +rewrite Z.shiftl_mul_pow2 by easy. split. - apply (Zplus_le_compat 0 _ 0) with (2 := proj1 Hm). rewrite <- (Zmult_0_l (2^mw)). @@ -79,26 +57,24 @@ split. clear -He ; omega. now rewrite Zmult_0_l. clear -Hm ; omega. -- apply Zlt_le_trans with (((if s then 2 ^ ew else 0) + e + 1) * 2 ^ mw)%Z. +- apply Z.lt_le_trans with (((if s then 2 ^ ew else 0) + e + 1) * 2 ^ mw)%Z. rewrite (Zmult_plus_distr_l _ 1). apply Zplus_lt_compat_l. now rewrite Zmult_1_l. rewrite <- (Zplus_assoc mw), (Zplus_comm mw), Zpower_plus. apply Zmult_le_compat_r. - rewrite Zpower_plus. + rewrite Zpower_plus by easy. change (2^1)%Z with 2%Z. case s ; clear -He ; omega. - now apply Zlt_le_weak. - easy. clear -Hm ; omega. clear -Hew ; omega. - now apply Zlt_le_weak. + easy. Qed. Definition split_bits x := let mm := Zpower 2 mw in let em := Zpower 2 ew in - (Zle_bool (mm * em) x, Zmod x mm, Zmod (Zdiv x mm) em)%Z. + (Zle_bool (mm * em) x, Zmod x mm, Zmod (Z.div x mm) em)%Z. Theorem split_join_bits : forall s m e, @@ -107,45 +83,75 @@ Theorem split_join_bits : split_bits (join_bits s m e) = (s, m, e). Proof. intros s m e Hm He. +assert (0 <= mw)%Z as Hmw. + destruct mw as [|mw'|mw'] ; try easy. + clear -Hm ; simpl in Hm ; omega. +assert (0 <= ew)%Z as Hew. + destruct ew as [|ew'|ew'] ; try easy. + clear -He ; simpl in He ; omega. unfold split_bits, join_bits. -rewrite Z.shiftl_mul_pow2 by now apply Zlt_le_weak. -apply f_equal2. -apply f_equal2. -(* *) -case s. -apply Zle_bool_true. -apply Zle_0_minus_le. -ring_simplify. -apply Zplus_le_0_compat. -apply Zmult_le_0_compat. -apply He. +rewrite Z.shiftl_mul_pow2 by easy. +apply f_equal2 ; [apply f_equal2|]. +- case s. + + apply Zle_bool_true. + apply Zle_0_minus_le. + ring_simplify. + apply Zplus_le_0_compat. + apply Zmult_le_0_compat. + apply He. + clear -Hm ; omega. + apply Hm. + + apply Zle_bool_false. + apply Zplus_lt_reg_l with (2^mw * (-e))%Z. + replace (2 ^ mw * - e + ((0 + e) * 2 ^ mw + m))%Z with (m * 1)%Z by ring. + rewrite <- Zmult_plus_distr_r. + apply Z.lt_le_trans with (2^mw * 1)%Z. + now apply Zmult_lt_compat_r. + apply Zmult_le_compat_l. + clear -He ; omega. + clear -Hm ; omega. +- rewrite Zplus_comm. + rewrite Z_mod_plus_full. + now apply Zmod_small. +- rewrite Z_div_plus_full_l by (clear -Hm ; omega). + rewrite Zdiv_small with (1 := Hm). + rewrite Zplus_0_r. + case s. + + replace (2^ew + e)%Z with (e + 1 * 2^ew)%Z by ring. + rewrite Z_mod_plus_full. + now apply Zmod_small. + + now apply Zmod_small. +Qed. + +Hypothesis Hmw : (0 < mw)%Z. +Hypothesis Hew : (0 < ew)%Z. + +Let emax := Zpower 2 (ew - 1). +Let prec := (mw + 1)%Z. +Let emin := (3 - emax - prec)%Z. +Let binary_float := binary_float prec emax. + +Let Hprec : (0 < prec)%Z. +Proof. +unfold prec. +apply Zle_lt_succ. now apply Zlt_le_weak. -apply Hm. -apply Zle_bool_false. -apply Zplus_lt_reg_l with (2^mw * (-e))%Z. -replace (2 ^ mw * - e + ((0 + e) * 2 ^ mw + m))%Z with (m * 1)%Z by ring. -rewrite <- Zmult_plus_distr_r. -apply Zlt_le_trans with (2^mw * 1)%Z. -now apply Zmult_lt_compat_r. -apply Zmult_le_compat_l. -clear -He. omega. +Qed. + +Let Hm_gt_0 : (0 < 2^mw)%Z. +Proof. +apply (Zpower_gt_0 radix2). now apply Zlt_le_weak. -(* *) -rewrite Zplus_comm. -rewrite Z_mod_plus_full. -now apply Zmod_small. -(* *) -rewrite Z_div_plus_full_l. -rewrite Zdiv_small with (1 := Hm). -rewrite Zplus_0_r. -case s. -replace (2^ew + e)%Z with (e + 1 * 2^ew)%Z by ring. -rewrite Z_mod_plus_full. -now apply Zmod_small. -now apply Zmod_small. -now apply Zgt_not_eq. Qed. +Let He_gt_0 : (0 < 2^ew)%Z. +Proof. +apply (Zpower_gt_0 radix2). +now apply Zlt_le_weak. +Qed. + +Hypothesis Hmax : (prec < emax)%Z. + Theorem join_split_bits : forall x, (0 <= x < Zpower 2 (mw + ew + 1))%Z -> @@ -171,17 +177,15 @@ case Zle_bool_spec ; intros Hs. apply Zle_antisym. cut (x / (2^mw * 2^ew) < 2)%Z. clear ; omega. apply Zdiv_lt_upper_bound. -try apply Hx. (* 8.2/8.3 compatibility *) now apply Zmult_lt_0_compat. -rewrite <- Zpower_exp ; try ( apply Zle_ge ; apply Zlt_le_weak ; assumption ). +rewrite <- Zpower_exp ; try ( apply Z.le_ge ; apply Zlt_le_weak ; assumption ). change 2%Z at 1 with (Zpower 2 1). rewrite <- Zpower_exp. now rewrite Zplus_comm. discriminate. -apply Zle_ge. +apply Z.le_ge. now apply Zplus_le_0_compat ; apply Zlt_le_weak. apply Zdiv_le_lower_bound. -try apply Hx. (* 8.2/8.3 compatibility *) now apply Zmult_lt_0_compat. now rewrite Zmult_1_l. apply Zdiv_small. @@ -213,7 +217,7 @@ Definition bits_of_binary_float (x : binary_float) := match x with | B754_zero sx => join_bits sx 0 0 | B754_infinity sx => join_bits sx 0 (Zpower 2 ew - 1) - | B754_nan sx (exist plx _) => join_bits sx (Zpos plx) (Zpower 2 ew - 1) + | B754_nan sx plx _ => join_bits sx (Zpos plx) (Zpower 2 ew - 1) | B754_finite sx mx ex _ => let m := (Zpos mx - Zpower 2 mw)%Z in if Zle_bool 0 m then @@ -226,7 +230,7 @@ Definition split_bits_of_binary_float (x : binary_float) := match x with | B754_zero sx => (sx, 0, 0)%Z | B754_infinity sx => (sx, 0, Zpower 2 ew - 1)%Z - | B754_nan sx (exist plx _) => (sx, Zpos plx, Zpower 2 ew - 1)%Z + | B754_nan sx plx _ => (sx, Zpos plx, Zpower 2 ew - 1)%Z | B754_finite sx mx ex _ => let m := (Zpos mx - Zpower 2 mw)%Z in if Zle_bool 0 m then @@ -239,13 +243,14 @@ Theorem split_bits_of_binary_float_correct : forall x, split_bits (bits_of_binary_float x) = split_bits_of_binary_float x. Proof. -intros [sx|sx|sx [plx Hplx]|sx mx ex Hx] ; - try ( simpl ; apply split_join_bits ; split ; try apply Zle_refl ; try apply Zlt_pred ; trivial ; omega ). +intros [sx|sx|sx plx Hplx|sx mx ex Hx] ; + try ( simpl ; apply split_join_bits ; split ; try apply Z.le_refl ; try apply Zlt_pred ; trivial ; omega ). simpl. apply split_join_bits; split; try (zify; omega). destruct (digits2_Pnat_correct plx). +unfold nan_pl in Hplx. rewrite Zpos_digits2_pos, <- Z_of_nat_S_digits2_Pnat in Hplx. rewrite Zpower_nat_Z in H0. -eapply Zlt_le_trans. apply H0. +eapply Z.lt_le_trans. apply H0. change 2%Z with (radix_val radix2). apply Zpower_le. rewrite Z.ltb_lt in Hplx. unfold prec in *. zify; omega. @@ -253,7 +258,7 @@ unfold prec in *. zify; omega. unfold bits_of_binary_float, split_bits_of_binary_float. assert (Hf: (emin <= ex /\ Zdigits radix2 (Zpos mx) <= prec)%Z). destruct (andb_prop _ _ Hx) as (Hx', _). -unfold canonic_mantissa in Hx'. +unfold canonical_mantissa in Hx'. rewrite Zpos_digits2_pos in Hx'. generalize (Zeq_bool_eq _ _ Hx'). unfold FLT_exp. @@ -271,7 +276,7 @@ apply (Zpower_gt_Zdigits radix2 _ (Zpos mx)). apply Hf. unfold prec. rewrite Zplus_comm. -apply Zpower_exp ; apply Zle_ge. +apply Zpower_exp ; apply Z.le_ge. discriminate. now apply Zlt_le_weak. (* *) @@ -285,9 +290,9 @@ generalize (Zle_bool_imp_le _ _ Hx'). clear ; omega. apply sym_eq. rewrite (Zsucc_pred ew). -unfold Zsucc. +unfold Z.succ. rewrite Zplus_comm. -apply Zpower_exp ; apply Zle_ge. +apply Zpower_exp ; apply Z.le_ge. discriminate. now apply Zlt_0_le_0_pred. Qed. @@ -296,7 +301,7 @@ Theorem bits_of_binary_float_range: forall x, (0 <= bits_of_binary_float x < 2^(mw+ew+1))%Z. Proof. unfold bits_of_binary_float. -intros [sx|sx|sx [pl pl_range]|sx mx ex H]. +intros [sx|sx|sx pl pl_range|sx mx ex H]. - apply join_bits_range ; now split. - apply join_bits_range. now split. @@ -312,7 +317,7 @@ intros [sx|sx|sx [pl pl_range]|sx mx ex H]. - unfold bounded in H. apply Bool.andb_true_iff in H ; destruct H as [A B]. apply Z.leb_le in B. - unfold canonic_mantissa, FLT_exp in A. apply Zeq_bool_eq in A. + unfold canonical_mantissa, FLT_exp in A. apply Zeq_bool_eq in A. case Zle_bool_spec ; intros H. + apply join_bits_range. * split. @@ -362,6 +367,10 @@ Lemma binary_float_of_bits_aux_correct : Proof. intros x. unfold binary_float_of_bits_aux, split_bits. +assert (Hnan: nan_pl prec 1 = true). + apply Z.ltb_lt. + simpl. unfold prec. + clear -Hmw ; omega. case Zeq_bool_spec ; intros He1. case_eq (x mod 2^mw)%Z ; try easy. (* subnormal *) @@ -371,11 +380,11 @@ apply Zdigits_le_Zpower. simpl. rewrite <- Hm. eapply Z_mod_lt. -now apply Zlt_gt. -apply bounded_canonic_lt_emax ; try assumption. -unfold canonic, canonic_exp. +now apply Z.lt_gt. +apply bounded_canonical_lt_emax ; try assumption. +unfold canonical, cexp. fold emin. -rewrite ln_beta_F2R_Zdigits. 2: discriminate. +rewrite mag_F2R_Zdigits. 2: discriminate. unfold Fexp, FLT_exp. apply sym_eq. apply Zmax_right. @@ -383,16 +392,15 @@ clear -H Hprec. unfold prec ; omega. apply Rnot_le_lt. intros H0. -refine (_ (ln_beta_le radix2 _ _ _ H0)). -rewrite ln_beta_bpow. -rewrite ln_beta_F2R_Zdigits. 2: discriminate. +refine (_ (mag_le radix2 _ _ _ H0)). +rewrite mag_bpow. +rewrite mag_F2R_Zdigits. 2: discriminate. unfold emin, prec. apply Zlt_not_le. cut (0 < emax)%Z. clear -H Hew ; omega. apply (Zpower_gt_0 radix2). clear -Hew ; omega. apply bpow_gt_0. -simpl. intros. rewrite Z.ltb_lt. unfold prec. zify; omega. case Zeq_bool_spec ; intros He2. case_eq (x mod 2 ^ mw)%Z; try easy. (* nan *) @@ -403,39 +411,37 @@ apply Zdigits_le_Zpower. simpl. rewrite <- Eqplx. edestruct Z_mod_lt; eauto. change 2%Z with (radix_val radix2). apply Z.lt_gt, Zpower_gt_0. omega. -simpl. intros. rewrite Z.ltb_lt. unfold prec. zify; omega. case_eq (x mod 2^mw + 2^mw)%Z ; try easy. -simpl. intros. rewrite Z.ltb_lt. unfold prec. zify; omega. (* normal *) intros px Hm. assert (prec = Zdigits radix2 (Zpos px)). (* . *) -rewrite Zdigits_ln_beta. 2: discriminate. +rewrite Zdigits_mag. 2: discriminate. apply sym_eq. -apply ln_beta_unique. -rewrite <- Z2R_abs. -unfold Zabs. +apply mag_unique. +rewrite <- abs_IZR. +unfold Z.abs. replace (prec - 1)%Z with mw by ( unfold prec ; ring ). -rewrite <- Z2R_Zpower with (1 := Zlt_le_weak _ _ Hmw). -rewrite <- Z2R_Zpower. 2: now apply Zlt_le_weak. +rewrite <- IZR_Zpower with (1 := Zlt_le_weak _ _ Hmw). +rewrite <- IZR_Zpower. 2: now apply Zlt_le_weak. rewrite <- Hm. split. -apply Z2R_le. +apply IZR_le. change (radix2^mw)%Z with (0 + 2^mw)%Z. apply Zplus_le_compat_r. eapply Z_mod_lt. -now apply Zlt_gt. -apply Z2R_lt. +now apply Z.lt_gt. +apply IZR_lt. unfold prec. -rewrite Zpower_exp. 2: now apply Zle_ge ; apply Zlt_le_weak. 2: discriminate. +rewrite Zpower_exp. 2: now apply Z.le_ge ; apply Zlt_le_weak. 2: discriminate. rewrite <- Zplus_diag_eq_mult_2. apply Zplus_lt_compat_r. eapply Z_mod_lt. -now apply Zlt_gt. +now apply Z.lt_gt. (* . *) -apply bounded_canonic_lt_emax ; try assumption. -unfold canonic, canonic_exp. -rewrite ln_beta_F2R_Zdigits. 2: discriminate. +apply bounded_canonical_lt_emax ; try assumption. +unfold canonical, cexp. +rewrite mag_F2R_Zdigits. 2: discriminate. unfold Fexp, FLT_exp. rewrite <- H. set (ex := ((x / 2^mw) mod 2^ew)%Z). @@ -448,14 +454,14 @@ cut (0 <= ex)%Z. unfold emin. clear ; intros H1 H2 ; omega. eapply Z_mod_lt. -apply Zlt_gt. +apply Z.lt_gt. apply (Zpower_gt_0 radix2). now apply Zlt_le_weak. apply Rnot_le_lt. intros H0. -refine (_ (ln_beta_le radix2 _ _ _ H0)). -rewrite ln_beta_bpow. -rewrite ln_beta_F2R_Zdigits. 2: discriminate. +refine (_ (mag_le radix2 _ _ _ H0)). +rewrite mag_bpow. +rewrite mag_F2R_Zdigits. 2: discriminate. rewrite <- H. apply Zlt_not_le. unfold emin. @@ -472,11 +478,10 @@ apply refl_equal. discriminate. clear -Hew ; omega. eapply Z_mod_lt. -apply Zlt_gt. +apply Z.lt_gt. apply (Zpower_gt_0 radix2). now apply Zlt_le_weak. apply bpow_gt_0. -simpl. intros. rewrite Z.ltb_lt. unfold prec. zify; omega. Qed. Definition binary_float_of_bits x := @@ -492,7 +497,7 @@ unfold binary_float_of_bits. rewrite B2FF_FF2B. unfold binary_float_of_bits_aux. rewrite split_bits_of_binary_float_correct. -destruct x as [sx|sx|sx [plx Hplx]|sx mx ex Bx]. +destruct x as [sx|sx|sx plx Hplx|sx mx ex Bx]. apply refl_equal. (* *) simpl. @@ -563,7 +568,7 @@ intros (sx, mx) ex Sx. assert (Bm: (0 <= mx < 2^mw)%Z). inversion_clear Sx. apply Z_mod_lt. -now apply Zlt_gt. +now apply Z.lt_gt. case Zeq_bool_spec ; intros He1. (* subnormal *) case_eq mx. @@ -604,41 +609,47 @@ End Binary_Bits. (** Specialization for IEEE single precision operations *) Section B32_Bits. -Arguments B754_nan {prec emax} _ _. +Arguments B754_nan {prec} {emax}. Definition binary32 := binary_float 24 128. Let Hprec : (0 < 24)%Z. +Proof. apply refl_equal. Qed. Let Hprec_emax : (24 < 128)%Z. +Proof. apply refl_equal. Qed. -Definition default_nan_pl32 : bool * nan_pl 24 := - (false, exist _ (iter_nat xO 22 xH) (refl_equal true)). +Definition default_nan_pl32 : { nan : binary32 | is_nan 24 128 nan = true } := + exist _ (@B754_nan 24 128 false (iter_nat xO 22 xH) (refl_equal true)) (refl_equal true). -Definition unop_nan_pl32 (f : binary32) : bool * nan_pl 24 := - match f with - | B754_nan s pl => (s, pl) +Definition unop_nan_pl32 (f : binary32) : { nan : binary32 | is_nan 24 128 nan = true } := + match f as f with + | B754_nan s pl Hpl => exist _ (B754_nan s pl Hpl) (refl_equal true) | _ => default_nan_pl32 end. -Definition binop_nan_pl32 (f1 f2 : binary32) : bool * nan_pl 24 := +Definition binop_nan_pl32 (f1 f2 : binary32) : { nan : binary32 | is_nan 24 128 nan = true } := match f1, f2 with - | B754_nan s1 pl1, _ => (s1, pl1) - | _, B754_nan s2 pl2 => (s2, pl2) + | B754_nan s1 pl1 Hpl1, _ => exist _ (B754_nan s1 pl1 Hpl1) (refl_equal true) + | _, B754_nan s2 pl2 Hpl2 => exist _ (B754_nan s2 pl2 Hpl2) (refl_equal true) | _, _ => default_nan_pl32 end. -Definition b32_opp := Bopp 24 128 pair. -Definition b32_plus := Bplus _ _ Hprec Hprec_emax binop_nan_pl32. -Definition b32_minus := Bminus _ _ Hprec Hprec_emax binop_nan_pl32. -Definition b32_mult := Bmult _ _ Hprec Hprec_emax binop_nan_pl32. -Definition b32_div := Bdiv _ _ Hprec Hprec_emax binop_nan_pl32. -Definition b32_sqrt := Bsqrt _ _ Hprec Hprec_emax unop_nan_pl32. +Definition b32_erase : binary32 -> binary32 := erase 24 128. +Definition b32_opp : binary32 -> binary32 := Bopp 24 128 unop_nan_pl32. +Definition b32_abs : binary32 -> binary32 := Babs 24 128 unop_nan_pl32. +Definition b32_sqrt : mode -> binary32 -> binary32 := Bsqrt _ _ Hprec Hprec_emax unop_nan_pl32. + +Definition b32_plus : mode -> binary32 -> binary32 -> binary32 := Bplus _ _ Hprec Hprec_emax binop_nan_pl32. +Definition b32_minus : mode -> binary32 -> binary32 -> binary32 := Bminus _ _ Hprec Hprec_emax binop_nan_pl32. +Definition b32_mult : mode -> binary32 -> binary32 -> binary32 := Bmult _ _ Hprec Hprec_emax binop_nan_pl32. +Definition b32_div : mode -> binary32 -> binary32 -> binary32 := Bdiv _ _ Hprec Hprec_emax binop_nan_pl32. +Definition b32_compare : binary32 -> binary32 -> option comparison := Bcompare 24 128. Definition b32_of_bits : Z -> binary32 := binary_float_of_bits 23 8 (refl_equal _) (refl_equal _) (refl_equal _). Definition bits_of_b32 : binary32 -> Z := bits_of_binary_float 23 8. @@ -647,41 +658,47 @@ End B32_Bits. (** Specialization for IEEE double precision operations *) Section B64_Bits. -Arguments B754_nan {prec emax} _ _. +Arguments B754_nan {prec} {emax}. Definition binary64 := binary_float 53 1024. Let Hprec : (0 < 53)%Z. +Proof. apply refl_equal. Qed. Let Hprec_emax : (53 < 1024)%Z. +Proof. apply refl_equal. Qed. -Definition default_nan_pl64 : bool * nan_pl 53 := - (false, exist _ (iter_nat xO 51 xH) (refl_equal true)). +Definition default_nan_pl64 : { nan : binary64 | is_nan 53 1024 nan = true } := + exist _ (@B754_nan 53 1024 false (iter_nat xO 51 xH) (refl_equal true)) (refl_equal true). -Definition unop_nan_pl64 (f : binary64) : bool * nan_pl 53 := - match f with - | B754_nan s pl => (s, pl) +Definition unop_nan_pl64 (f : binary64) : { nan : binary64 | is_nan 53 1024 nan = true } := + match f as f with + | B754_nan s pl Hpl => exist _ (B754_nan s pl Hpl) (refl_equal true) | _ => default_nan_pl64 end. -Definition binop_nan_pl64 (pl1 pl2 : binary64) : bool * nan_pl 53 := - match pl1, pl2 with - | B754_nan s1 pl1, _ => (s1, pl1) - | _, B754_nan s2 pl2 => (s2, pl2) +Definition binop_nan_pl64 (f1 f2 : binary64) : { nan : binary64 | is_nan 53 1024 nan = true } := + match f1, f2 with + | B754_nan s1 pl1 Hpl1, _ => exist _ (B754_nan s1 pl1 Hpl1) (refl_equal true) + | _, B754_nan s2 pl2 Hpl2 => exist _ (B754_nan s2 pl2 Hpl2) (refl_equal true) | _, _ => default_nan_pl64 end. -Definition b64_opp := Bopp 53 1024 pair. -Definition b64_plus := Bplus _ _ Hprec Hprec_emax binop_nan_pl64. -Definition b64_minus := Bminus _ _ Hprec Hprec_emax binop_nan_pl64. -Definition b64_mult := Bmult _ _ Hprec Hprec_emax binop_nan_pl64. -Definition b64_div := Bdiv _ _ Hprec Hprec_emax binop_nan_pl64. -Definition b64_sqrt := Bsqrt _ _ Hprec Hprec_emax unop_nan_pl64. +Definition b64_erase : binary64 -> binary64 := erase 53 1024. +Definition b64_opp : binary64 -> binary64 := Bopp 53 1024 unop_nan_pl64. +Definition b64_abs : binary64 -> binary64 := Babs 53 1024 unop_nan_pl64. +Definition b64_sqrt : mode -> binary64 -> binary64 := Bsqrt _ _ Hprec Hprec_emax unop_nan_pl64. + +Definition b64_plus : mode -> binary64 -> binary64 -> binary64 := Bplus _ _ Hprec Hprec_emax binop_nan_pl64. +Definition b64_minus : mode -> binary64 -> binary64 -> binary64 := Bminus _ _ Hprec Hprec_emax binop_nan_pl64. +Definition b64_mult : mode -> binary64 -> binary64 -> binary64 := Bmult _ _ Hprec Hprec_emax binop_nan_pl64. +Definition b64_div : mode -> binary64 -> binary64 -> binary64 := Bdiv _ _ Hprec Hprec_emax binop_nan_pl64. +Definition b64_compare : binary64 -> binary64 -> option comparison := Bcompare 53 1024. Definition b64_of_bits : Z -> binary64 := binary_float_of_bits 52 11 (refl_equal _) (refl_equal _) (refl_equal _). Definition bits_of_b64 : binary64 -> Z := bits_of_binary_float 52 11. diff --git a/flocq/Prop/Div_sqrt_error.v b/flocq/Prop/Div_sqrt_error.v new file mode 100644 index 00000000..79220438 --- /dev/null +++ b/flocq/Prop/Div_sqrt_error.v @@ -0,0 +1,872 @@ +(** +This file is part of the Flocq formalization of floating-point +arithmetic in Coq: http://flocq.gforge.inria.fr/ + +Copyright (C) 2010-2018 Sylvie Boldo +#<br /># +Copyright (C) 2010-2018 Guillaume Melquiond + +This library is free software; you can redistribute it and/or +modify it under the terms of the GNU Lesser General Public +License as published by the Free Software Foundation; either +version 3 of the License, or (at your option) any later version. + +This library is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +COPYING file for more details. +*) + +(** * Remainder of the division and square root are in the FLX format *) + +Require Import Psatz. +Require Import Core Operations Relative Sterbenz Mult_error. + +Section Fprop_divsqrt_error. + +Variable beta : radix. +Notation bpow e := (bpow beta e). + +Variable prec : Z. + +Lemma generic_format_plus_prec : + forall fexp, (forall e, (fexp e <= e - prec)%Z) -> + forall x y (fx fy: float beta), + (x = F2R fx)%R -> (y = F2R fy)%R -> (Rabs (x+y) < bpow (prec+Fexp fx))%R -> + (Rabs (x+y) < bpow (prec+Fexp fy))%R -> + generic_format beta fexp (x+y)%R. +Proof. +intros fexp Hfexp x y fx fy Hx Hy H1 H2. +case (Req_dec (x+y) 0); intros H. +rewrite H; apply generic_format_0. +rewrite Hx, Hy, <- F2R_plus. +apply generic_format_F2R. +intros _. +case_eq (Fplus fx fy). +intros mz ez Hz. +rewrite <- Hz. +apply Z.le_trans with (Z.min (Fexp fx) (Fexp fy)). +rewrite F2R_plus, <- Hx, <- Hy. +unfold cexp. +apply Z.le_trans with (1:=Hfexp _). +apply Zplus_le_reg_l with prec; ring_simplify. +apply mag_le_bpow with (1 := H). +now apply Z.min_case. +rewrite <- Fexp_Fplus, Hz. +apply Z.le_refl. +Qed. + +Context { prec_gt_0_ : Prec_gt_0 prec }. + +Notation format := (generic_format beta (FLX_exp prec)). +Notation cexp := (cexp beta (FLX_exp prec)). + +Variable choice : Z -> bool. + + +(** Remainder of the division in FLX *) +Theorem div_error_FLX : + forall rnd { Zrnd : Valid_rnd rnd } x y, + format x -> format y -> + format (x - round beta (FLX_exp prec) rnd (x/y) * y)%R. +Proof with auto with typeclass_instances. +intros rnd Zrnd x y Hx Hy. +destruct (Req_dec y 0) as [Zy|Zy]. +now rewrite Zy, Rmult_0_r, Rminus_0_r. +destruct (Req_dec (round beta (FLX_exp prec) rnd (x/y)) 0) as [Hr|Hr]. +rewrite Hr; ring_simplify (x-0*y)%R; assumption. +assert (Zx: x <> R0). +contradict Hr. +rewrite Hr. +unfold Rdiv. +now rewrite Rmult_0_l, round_0. +destruct (canonical_generic_format _ _ x Hx) as (fx,(Hx1,Hx2)). +destruct (canonical_generic_format _ _ y Hy) as (fy,(Hy1,Hy2)). +destruct (canonical_generic_format beta (FLX_exp prec) (round beta (FLX_exp prec) rnd (x / y))) as (fr,(Hr1,Hr2)). +apply generic_format_round... +unfold Rminus; apply generic_format_plus_prec with fx (Fopp (Fmult fr fy)); trivial. +intros e; apply Z.le_refl. +now rewrite F2R_opp, F2R_mult, <- Hr1, <- Hy1. +(* *) +destruct (relative_error_FLX_ex beta prec (prec_gt_0 prec) rnd (x / y)%R) as (eps,(Heps1,Heps2)). +rewrite Heps2. +rewrite <- Rabs_Ropp. +replace (-(x + - (x / y * (1 + eps) * y)))%R with (x * eps)%R by now field. +rewrite Rabs_mult. +apply Rlt_le_trans with (Rabs x * 1)%R. +apply Rmult_lt_compat_l. +now apply Rabs_pos_lt. +apply Rlt_le_trans with (1 := Heps1). +change 1%R with (bpow 0). +apply bpow_le. +generalize (prec_gt_0 prec). +clear ; omega. +rewrite Rmult_1_r. +rewrite Hx2, <- Hx1. +unfold cexp. +destruct (mag beta x) as (ex, Hex). +simpl. +specialize (Hex Zx). +apply Rlt_le. +apply Rlt_le_trans with (1 := proj2 Hex). +apply bpow_le. +unfold FLX_exp. +ring_simplify. +apply Z.le_refl. +(* *) +replace (Fexp (Fopp (Fmult fr fy))) with (Fexp fr + Fexp fy)%Z. +2: unfold Fopp, Fmult; destruct fr; destruct fy; now simpl. +replace (x + - (round beta (FLX_exp prec) rnd (x / y) * y))%R with + (y * (-(round beta (FLX_exp prec) rnd (x / y) - x/y)))%R. +2: field; assumption. +rewrite Rabs_mult. +apply Rlt_le_trans with (Rabs y * bpow (Fexp fr))%R. +apply Rmult_lt_compat_l. +now apply Rabs_pos_lt. +rewrite Rabs_Ropp. +replace (bpow (Fexp fr)) with (ulp beta (FLX_exp prec) (F2R fr)). +rewrite <- Hr1. +apply error_lt_ulp_round... +apply Rmult_integral_contrapositive_currified; try apply Rinv_neq_0_compat; assumption. +rewrite ulp_neq_0. +2: now rewrite <- Hr1. +apply f_equal. +now rewrite Hr2, <- Hr1. +replace (prec+(Fexp fr+Fexp fy))%Z with ((prec+Fexp fy)+Fexp fr)%Z by ring. +rewrite bpow_plus. +apply Rmult_le_compat_r. +apply bpow_ge_0. +rewrite Hy2, <- Hy1 ; unfold cexp, FLX_exp. +ring_simplify (prec + (mag beta y - prec))%Z. +destruct (mag beta y); simpl. +left; now apply a. +Qed. + +(** Remainder of the square in FLX (with p>1) and rounding to nearest *) +Variable Hp1 : Z.lt 1 prec. + +Theorem sqrt_error_FLX_N : + forall x, format x -> + format (x - Rsqr (round beta (FLX_exp prec) (Znearest choice) (sqrt x)))%R. +Proof with auto with typeclass_instances. +intros x Hx. +destruct (total_order_T x 0) as [[Hxz|Hxz]|Hxz]. +unfold sqrt. +destruct (Rcase_abs x). +rewrite round_0... +unfold Rsqr. +now rewrite Rmult_0_l, Rminus_0_r. +elim (Rlt_irrefl 0). +now apply Rgt_ge_trans with x. +rewrite Hxz, sqrt_0, round_0... +unfold Rsqr. +rewrite Rmult_0_l, Rminus_0_r. +apply generic_format_0. +case (Req_dec (round beta (FLX_exp prec) (Znearest choice) (sqrt x)) 0); intros Hr. +rewrite Hr; unfold Rsqr; ring_simplify (x-0*0)%R; assumption. +destruct (canonical_generic_format _ _ x Hx) as (fx,(Hx1,Hx2)). +destruct (canonical_generic_format beta (FLX_exp prec) (round beta (FLX_exp prec) (Znearest choice) (sqrt x))) as (fr,(Hr1,Hr2)). +apply generic_format_round... +unfold Rminus; apply generic_format_plus_prec with fx (Fopp (Fmult fr fr)); trivial. +intros e; apply Z.le_refl. +unfold Rsqr; now rewrite F2R_opp,F2R_mult, <- Hr1. +(* *) +apply Rle_lt_trans with x. +apply Rabs_minus_le. +apply Rle_0_sqr. +destruct (relative_error_N_FLX_ex beta prec (prec_gt_0 prec) choice (sqrt x)) as (eps,(Heps1,Heps2)). +rewrite Heps2. +rewrite Rsqr_mult, Rsqr_sqrt, Rmult_comm. 2: now apply Rlt_le. +apply Rmult_le_compat_r. +now apply Rlt_le. +apply Rle_trans with (5²/4²)%R. +rewrite <- Rsqr_div. +apply Rsqr_le_abs_1. +apply Rle_trans with (1 := Rabs_triang _ _). +rewrite Rabs_R1. +apply Rplus_le_reg_l with (-1)%R. +replace (-1 + (1 + Rabs eps))%R with (Rabs eps) by ring. +apply Rle_trans with (1 := Heps1). +rewrite Rabs_pos_eq. +apply Rmult_le_reg_l with 2%R. +now apply IZR_lt. +rewrite <- Rmult_assoc, Rinv_r, Rmult_1_l. +apply Rle_trans with (bpow (-1)). +apply bpow_le. +omega. +replace (2 * (-1 + 5 / 4))%R with (/2)%R by field. +apply Rinv_le. +now apply IZR_lt. +apply IZR_le. +unfold Zpower_pos. simpl. +rewrite Zmult_1_r. +apply Zle_bool_imp_le. +apply beta. +now apply IZR_neq. +unfold Rdiv. +apply Rmult_le_pos. +now apply IZR_le. +apply Rlt_le. +apply Rinv_0_lt_compat. +now apply IZR_lt. +now apply IZR_neq. +unfold Rsqr. +replace (5 * 5 / (4 * 4))%R with (25 * /16)%R by field. +apply Rmult_le_reg_r with 16%R. +now apply IZR_lt. +rewrite Rmult_assoc, Rinv_l, Rmult_1_r. +now apply (IZR_le _ 32). +now apply IZR_neq. +rewrite Hx2, <- Hx1; unfold cexp, FLX_exp. +ring_simplify (prec + (mag beta x - prec))%Z. +destruct (mag beta x); simpl. +rewrite <- (Rabs_right x). +apply a. +now apply Rgt_not_eq. +now apply Rgt_ge. +(* *) +replace (Fexp (Fopp (Fmult fr fr))) with (Fexp fr + Fexp fr)%Z. +2: unfold Fopp, Fmult; destruct fr; now simpl. +rewrite Hr1. +replace (x + - Rsqr (F2R fr))%R with (-((F2R fr - sqrt x)*(F2R fr + sqrt x)))%R. +2: rewrite <- (sqrt_sqrt x) at 3; auto. +2: unfold Rsqr; ring. +rewrite Rabs_Ropp, Rabs_mult. +apply Rle_lt_trans with ((/2*bpow (Fexp fr))* Rabs (F2R fr + sqrt x))%R. +apply Rmult_le_compat_r. +apply Rabs_pos. +apply Rle_trans with (/2*ulp beta (FLX_exp prec) (F2R fr))%R. +rewrite <- Hr1. +apply error_le_half_ulp_round... +right; rewrite ulp_neq_0. +2: now rewrite <- Hr1. +apply f_equal. +rewrite Hr2, <- Hr1; trivial. +rewrite Rmult_assoc, Rmult_comm. +replace (prec+(Fexp fr+Fexp fr))%Z with (Fexp fr + (prec+Fexp fr))%Z by ring. +rewrite bpow_plus, Rmult_assoc. +apply Rmult_lt_compat_l. +apply bpow_gt_0. +apply Rmult_lt_reg_l with (1 := Rlt_0_2). +apply Rle_lt_trans with (Rabs (F2R fr + sqrt x)). +right; field. +apply Rle_lt_trans with (1:=Rabs_triang _ _). +(* . *) +assert (Rabs (F2R fr) < bpow (prec + Fexp fr))%R. +rewrite Hr2. +unfold cexp, FLX_exp. +ring_simplify (prec + (mag beta (F2R fr) - prec))%Z. +destruct (mag beta (F2R fr)); simpl. +apply a. +rewrite <- Hr1; auto. +(* . *) +apply Rlt_le_trans with (bpow (prec + Fexp fr)+ Rabs (sqrt x))%R. +now apply Rplus_lt_compat_r. +(* . *) +replace (2 * bpow (prec + Fexp fr))%R with (bpow (prec + Fexp fr) + bpow (prec + Fexp fr))%R by ring. +apply Rplus_le_compat_l. +assert (sqrt x <> 0)%R. +apply Rgt_not_eq. +now apply sqrt_lt_R0. +destruct (mag beta (sqrt x)) as (es,Es). +specialize (Es H0). +apply Rle_trans with (bpow es). +now apply Rlt_le. +apply bpow_le. +case (Zle_or_lt es (prec + Fexp fr)) ; trivial. +intros H1. +absurd (Rabs (F2R fr) < bpow (es - 1))%R. +apply Rle_not_lt. +rewrite <- Hr1. +apply abs_round_ge_generic... +apply generic_format_bpow. +unfold FLX_exp; omega. +apply Es. +apply Rlt_le_trans with (1:=H). +apply bpow_le. +omega. +now apply Rlt_le. +Qed. + +Lemma sqrt_error_N_FLX_aux1 x (Fx : format x) (Px : (0 < x)%R) : + exists (mu : R) (e : Z), (format mu /\ x = mu * bpow (2 * e) :> R + /\ 1 <= mu < bpow 2)%R. +Proof. +set (e := ((mag beta x - 1) / 2)%Z). +set (mu := (x * bpow (-2 * e)%Z)%R). +assert (Hbe : (bpow (-2 * e) * bpow (2 * e) = 1)%R). +{ now rewrite <- bpow_plus; case e; simpl; [reflexivity| |]; intro p; + rewrite Z.pos_sub_diag. } +assert (Fmu : format mu); [now apply mult_bpow_exact_FLX|]. +exists mu, e; split; [exact Fmu|split; [|split]]. +{ set (e2 := (2 * e)%Z); simpl; unfold mu; rewrite Rmult_assoc. + now unfold e2; rewrite Hbe, Rmult_1_r. } +{ apply (Rmult_le_reg_r (bpow (2 * e))). + { apply bpow_gt_0. } + rewrite Rmult_1_l; set (e2 := (2 * e)%Z); simpl; unfold mu. + unfold e2; rewrite Rmult_assoc, Hbe, Rmult_1_r. + apply (Rle_trans _ (bpow (mag beta x - 1))). + { now apply bpow_le; unfold e; apply Z_mult_div_ge. } + set (l := mag _ _); rewrite <- (Rabs_pos_eq _ (Rlt_le _ _ Px)). + unfold l; apply bpow_mag_le. + intro Hx; revert Px; rewrite Hx; apply Rlt_irrefl. } +simpl; unfold mu; change (IZR _) with (bpow 2). +apply (Rmult_lt_reg_r (bpow (2 * e))); [now apply bpow_gt_0|]. +rewrite Rmult_assoc, Hbe, Rmult_1_r. +apply (Rlt_le_trans _ (bpow (mag beta x))). +{ rewrite <- (Rabs_pos_eq _ (Rlt_le _ _ Px)) at 1; apply bpow_mag_gt. } +rewrite <- bpow_plus; apply bpow_le; unfold e; set (mxm1 := (_ - 1)%Z). +replace (_ * _)%Z with (2 * (mxm1 / 2) + mxm1 mod 2 - mxm1 mod 2)%Z by ring. +rewrite <- Z.div_mod; [|now simpl]. +apply (Zplus_le_reg_r _ _ (mxm1 mod 2 - mag beta x)%Z). +unfold mxm1; destruct (Z.mod_bound_or (mag beta x - 1) 2); omega. +Qed. + +Notation u_ro := (u_ro beta prec). + +Lemma sqrt_error_N_FLX_aux2 x (Fx : format x) : + (1 <= x)%R -> + (x = 1 :> R \/ x = 1 + 2 * u_ro :> R \/ 1 + 4 * u_ro <= x)%R. +Proof. +intro HxGe1. +assert (Pu_ro : (0 <= u_ro)%R); [apply Rmult_le_pos; [lra|apply bpow_ge_0]|]. +destruct (Rle_or_lt x 1) as [HxLe1|HxGt1]; [now left; apply Rle_antisym|right]. +assert (F1 : format 1); [now apply generic_format_FLX_1|]. +assert (H2eps : (2 * u_ro = bpow (-prec + 1))%R). +{ unfold u_ro; rewrite bpow_plus; field. } +assert (HmuGe1p2eps : (1 + 2 * u_ro <= x)%R). +{ rewrite H2eps, <- succ_FLX_1. + now apply succ_le_lt; [now apply FLX_exp_valid| | |]. } +destruct (Rle_or_lt x (1 + 2 * u_ro)) as [HxLe1p2eps|HxGt1p2eps]; + [now left; apply Rle_antisym|right]. +assert (Hulp1p2eps : (ulp beta (FLX_exp prec) (1 + 2 * u_ro) = 2 * u_ro)%R). +{ destruct (ulp_succ_pos _ _ _ F1 Rlt_0_1) as [Hsucc|Hsucc]. + { now rewrite H2eps, <- succ_FLX_1, <- ulp_FLX_1. } + exfalso; revert Hsucc; apply Rlt_not_eq. + rewrite succ_FLX_1, mag_1, bpow_1, <- H2eps; simpl. + apply (Rlt_le_trans _ 2); [apply Rplus_lt_compat_l|]. + { unfold u_ro; rewrite <-Rmult_assoc, Rinv_r, Rmult_1_l; [|lra]. + change R1 with (bpow 0); apply bpow_lt; omega. } + apply IZR_le, Zle_bool_imp_le, radix_prop. } +assert (Hsucc1p2eps : + (succ beta (FLX_exp prec) (1 + 2 * u_ro) = 1 + 4 * u_ro)%R). +{ unfold succ; rewrite Rle_bool_true; [rewrite Hulp1p2eps; ring|]. + apply Rplus_le_le_0_compat; lra. } +rewrite <- Hsucc1p2eps. +apply succ_le_lt; [now apply FLX_exp_valid| |exact Fx|now simpl]. +rewrite H2eps, <- succ_FLX_1. +now apply generic_format_succ; [apply FLX_exp_valid|]. +Qed. + +Lemma sqrt_error_N_FLX_aux3 : + (u_ro / sqrt (1 + 4 * u_ro) <= 1 - 1 / sqrt (1 + 2 * u_ro))%R. +Proof. +assert (Pu_ro : (0 <= u_ro)%R); [apply Rmult_le_pos; [lra|apply bpow_ge_0]|]. +unfold Rdiv; apply (Rplus_le_reg_r (/ sqrt (1 + 2 * u_ro))); ring_simplify. +apply (Rmult_le_reg_r (sqrt (1 + 4 * u_ro) * sqrt (1 + 2 * u_ro))). +{ apply Rmult_lt_0_compat; apply sqrt_lt_R0; lra. } +field_simplify; [|split; apply Rgt_not_eq, Rlt_gt, sqrt_lt_R0; lra]. +try unfold Rdiv; rewrite ?Rinv_1, ?Rmult_1_r. +apply Rsqr_incr_0_var; [|now apply Rmult_le_pos; apply sqrt_pos]. +rewrite <-sqrt_mult; [|lra|lra]. +rewrite Rsqr_sqrt; [|apply Rmult_le_pos; lra]. +unfold Rsqr; ring_simplify; unfold pow; rewrite !Rmult_1_r. +rewrite !sqrt_def; [|lra|lra]. +apply (Rplus_le_reg_r (-u_ro * u_ro - 1 -4 * u_ro - 2 * u_ro ^ 3)). +ring_simplify; apply Rsqr_incr_0_var. +{ unfold Rsqr; ring_simplify. + unfold pow; rewrite !Rmult_1_r, !sqrt_def; [|lra|lra]. + apply (Rplus_le_reg_r (-32 * u_ro ^ 4 - 24 * u_ro ^ 3 - 4 * u_ro ^ 2)). + ring_simplify. + replace (_ + _)%R + with (((4 * u_ro ^ 2 - 28 * u_ro + 9) * u_ro + 4) * u_ro ^ 3)%R by ring. + apply Rmult_le_pos; [|now apply pow_le]. + assert (Heps_le_half : (u_ro <= 1 / 2)%R). + { unfold u_ro, Rdiv; rewrite Rmult_comm; apply Rmult_le_compat_r; [lra|]. + change 1%R with (bpow 0); apply bpow_le; omega. } + apply (Rle_trans _ (-8 * u_ro + 4)); [lra|]. + apply Rplus_le_compat_r, Rmult_le_compat_r; [apply Pu_ro|]. + now assert (H : (0 <= u_ro ^ 2)%R); [apply pow2_ge_0|lra]. } +assert (H : (u_ro ^ 3 <= u_ro ^ 2)%R). +{ unfold pow; rewrite <-!Rmult_assoc, Rmult_1_r. + apply Rmult_le_compat_l; [now apply Rmult_le_pos; apply Pu_ro|]. + now apply Rlt_le, u_ro_lt_1. } +now assert (H' : (0 <= u_ro ^ 2)%R); [apply pow2_ge_0|lra]. +Qed. + +Lemma om1ds1p2u_ro_pos : (0 <= 1 - 1 / sqrt (1 + 2 * u_ro))%R. +Proof. +unfold Rdiv; rewrite Rmult_1_l, <-Rinv_1 at 1. +apply Rle_0_minus, Rinv_le; [lra|]. +rewrite <- sqrt_1 at 1; apply sqrt_le_1_alt. +assert (H := u_ro_pos beta prec); lra. +Qed. + +Lemma om1ds1p2u_ro_le_u_rod1pu_ro : + (1 - 1 / sqrt (1 + 2 * u_ro) <= u_ro / (1 + u_ro))%R. +Proof. +assert (Pu_ro := u_ro_pos beta prec). +apply (Rmult_le_reg_r (sqrt (1 + 2 * u_ro) * (1 + u_ro))). +{ apply Rmult_lt_0_compat; [apply sqrt_lt_R0|]; lra. } +field_simplify; [|lra|intro H; apply sqrt_eq_0 in H; lra]. +try unfold Rdiv; unfold Rminus; rewrite ?Rinv_1, ?Rmult_1_r, !Rplus_assoc. +rewrite <-(Rplus_0_r (sqrt _ * _)) at 2; apply Rplus_le_compat_l. +apply (Rplus_le_reg_r (1 + u_ro)); ring_simplify. +rewrite <-(sqrt_square (_ + 1)); [|lra]; apply sqrt_le_1_alt. +assert (H : (0 <= u_ro * u_ro)%R); [apply Rmult_le_pos|]; lra. +Qed. + +Lemma s1p2u_rom1_pos : (0 <= sqrt (1 + 2 * u_ro) - 1)%R. +apply (Rplus_le_reg_r 1); ring_simplify. +rewrite <-sqrt_1 at 1; apply sqrt_le_1_alt. +assert (H := u_ro_pos beta prec); lra. +Qed. + +Theorem sqrt_error_N_FLX x (Fx : format x) : + (Rabs (round beta (FLX_exp prec) (Znearest choice) (sqrt x) - sqrt x) + <= (1 - 1 / sqrt (1 + 2 * u_ro)) * Rabs (sqrt x))%R. +Proof. +assert (Peps := u_ro_pos beta prec). +assert (Peps' : (0 < u_ro)%R). +{ unfold u_ro; apply Rmult_lt_0_compat; [lra|apply bpow_gt_0]. } +assert (Pb := om1ds1p2u_ro_pos). +assert (Pb' := s1p2u_rom1_pos). +destruct (Rle_or_lt x 0) as [Nx|Px]. +{ rewrite (sqrt_neg _ Nx), round_0, Rabs_R0, Rmult_0_r; [|apply valid_rnd_N]. + now unfold Rminus; rewrite Rplus_0_l, Rabs_Ropp, Rabs_R0; right. } +destruct (sqrt_error_N_FLX_aux1 _ Fx Px) + as (mu, (e, (Fmu, (Hmu, (HmuGe1, HmuLtsqradix))))). +pose (t := sqrt x). +set (rt := round _ _ _ _). +assert (Ht : (t = sqrt mu * bpow e)%R). +{ unfold t; rewrite Hmu, sqrt_mult_alt; [|now apply (Rle_trans _ _ _ Rle_0_1)]. + now rewrite sqrt_bpow. } +destruct (sqrt_error_N_FLX_aux2 _ Fmu HmuGe1) as [Hmu'|[Hmu'|Hmu']]. +{ unfold rt; fold t; rewrite Ht, Hmu', sqrt_1, Rmult_1_l. + rewrite round_generic; [|now apply valid_rnd_N|]. + { rewrite Rminus_diag_eq, Rabs_R0; [|now simpl]. + now apply Rmult_le_pos; [|apply Rabs_pos]. } + apply generic_format_bpow'; [now apply FLX_exp_valid|]. + unfold FLX_exp; omega. } +{ assert (Hsqrtmu : (1 <= sqrt mu < 1 + u_ro)%R); [rewrite Hmu'; split|]. + { rewrite <- sqrt_1 at 1; apply sqrt_le_1_alt; lra. } + { rewrite <- sqrt_square; [|lra]; apply sqrt_lt_1_alt; split; [lra|]. + ring_simplify; assert (0 < u_ro ^ 2)%R; [apply pow_lt|]; lra. } + assert (Fbpowe : generic_format beta (FLX_exp prec) (bpow e)). + { apply generic_format_bpow; unfold FLX_exp; omega. } + assert (Hrt : rt = bpow e :> R). + { unfold rt; fold t; rewrite Ht; simpl; apply Rle_antisym. + { apply round_N_le_midp; [now apply FLX_exp_valid|exact Fbpowe|]. + apply (Rlt_le_trans _ ((1 + u_ro) * bpow e)). + { now apply Rmult_lt_compat_r; [apply bpow_gt_0|]. } + unfold succ; rewrite Rle_bool_true; [|now apply bpow_ge_0]. + rewrite ulp_bpow; unfold FLX_exp. + unfold Z.sub, u_ro; rewrite !bpow_plus; right; field. } + apply round_ge_generic; + [now apply FLX_exp_valid|now apply valid_rnd_N|exact Fbpowe|]. + rewrite <- (Rmult_1_l (bpow _)) at 1. + now apply Rmult_le_compat_r; [apply bpow_ge_0|]. } + fold t; rewrite Hrt, Ht, Hmu', <-(Rabs_pos_eq _ Pb), <-Rabs_mult. + rewrite Rabs_minus_sym; right; f_equal; field; lra. } +assert (Hsqrtmu : (1 + u_ro < sqrt mu)%R). +{ apply (Rlt_le_trans _ (sqrt (1 + 4 * u_ro))); [|now apply sqrt_le_1_alt]. + assert (P1peps : (0 <= 1 + u_ro)%R) + by now apply Rplus_le_le_0_compat; [lra|apply Peps]. + rewrite <- (sqrt_square (1 + u_ro)); [|lra]. + apply sqrt_lt_1_alt; split; [now apply Rmult_le_pos|]. + apply (Rplus_lt_reg_r (-1 - 2 * u_ro)); ring_simplify; simpl. + rewrite Rmult_1_r; apply Rmult_lt_compat_r; [apply Peps'|]. + now apply (Rlt_le_trans _ 1); [apply u_ro_lt_1|lra]. } +assert (Hulpt : (ulp beta (FLX_exp prec) t = 2 * u_ro * bpow e)%R). +{ unfold ulp; rewrite Req_bool_false; [|apply Rgt_not_eq, Rlt_gt]. + { unfold u_ro; rewrite <-Rmult_assoc, Rinv_r, Rmult_1_l, <-bpow_plus; [|lra]. + f_equal; unfold cexp, FLX_exp. + assert (Hmagt : (mag beta t = 1 + e :> Z)%Z). + { apply mag_unique. + unfold t; rewrite (Rabs_pos_eq _ (Rlt_le _ _ (sqrt_lt_R0 _ Px))). + fold t; split. + { rewrite Ht; replace (_ - _)%Z with e by ring. + rewrite <- (Rmult_1_l (bpow _)) at 1; apply Rmult_le_compat_r. + { apply bpow_ge_0. } + now rewrite <- sqrt_1; apply sqrt_le_1_alt. } + rewrite bpow_plus, bpow_1, Ht; simpl. + apply Rmult_lt_compat_r; [now apply bpow_gt_0|]. + rewrite <- sqrt_square. + { apply sqrt_lt_1_alt; split; [lra|]. + apply (Rlt_le_trans _ _ _ HmuLtsqradix); right. + now unfold bpow, Z.pow_pos; simpl; rewrite Zmult_1_r, mult_IZR. } + apply IZR_le, (Z.le_trans _ 2), Zle_bool_imp_le, radix_prop; omega. } + rewrite Hmagt; ring. } + rewrite Ht; apply Rmult_lt_0_compat; [|now apply bpow_gt_0]. + now apply (Rlt_le_trans _ 1); [lra|rewrite <- sqrt_1; apply sqrt_le_1_alt]. } +assert (Pt : (0 < t)%R). +{ rewrite Ht; apply Rmult_lt_0_compat; [lra|apply bpow_gt_0]. } +assert (H : (Rabs ((rt - sqrt x) / sqrt x) + <= 1 - 1 / sqrt (1 + 2 * u_ro))%R). +{ unfold Rdiv; rewrite Rabs_mult, (Rabs_pos_eq (/ _)); + [|now left; apply Rinv_0_lt_compat]. + apply (Rle_trans _ ((u_ro * bpow e) / t)). + { unfold Rdiv; apply Rmult_le_compat_r; [now left; apply Rinv_0_lt_compat|]. + apply (Rle_trans _ _ _ (error_le_half_ulp _ _ _ _)). + fold t; rewrite Hulpt; right; field. } + apply (Rle_trans _ (u_ro / sqrt (1 + 4 * u_ro))). + { apply (Rle_trans _ (u_ro * bpow e / (sqrt (1 + 4 * u_ro) * bpow e))). + { unfold Rdiv; apply Rmult_le_compat_l; + [now apply Rmult_le_pos; [apply Peps|apply bpow_ge_0]|]. + apply Rinv_le. + { apply Rmult_lt_0_compat; [apply sqrt_lt_R0; lra|apply bpow_gt_0]. } + now rewrite Ht; apply Rmult_le_compat_r; + [apply bpow_ge_0|apply sqrt_le_1_alt]. } + right; field; split; apply Rgt_not_eq, Rlt_gt; + [apply sqrt_lt_R0; lra|apply bpow_gt_0]. } + apply sqrt_error_N_FLX_aux3. } +revert H; unfold Rdiv; rewrite Rabs_mult, Rabs_Rinv; [|fold t; lra]; intro H. +apply (Rmult_le_reg_r (/ Rabs (sqrt x))); + [apply Rinv_0_lt_compat, Rabs_pos_lt; fold t; lra|]. +apply (Rle_trans _ _ _ H); right; field; split; [apply Rabs_no_R0;fold t|]; lra. +Qed. + +Theorem sqrt_error_N_FLX_ex x (Fx : format x) : + exists eps, + (Rabs eps <= 1 - 1 / sqrt (1 + 2 * u_ro))%R /\ + round beta (FLX_exp prec) (Znearest choice) (sqrt x) + = (sqrt x * (1 + eps))%R. +Proof. +now apply relative_error_le_conversion; + [apply valid_rnd_N|apply om1ds1p2u_ro_pos|apply sqrt_error_N_FLX]. +Qed. + +Lemma sqrt_error_N_round_ex_derive : + forall x rx, + (exists eps, + (Rabs eps <= 1 - 1 / sqrt (1 + 2 * u_ro))%R /\ rx = (x * (1 + eps))%R) -> + exists eps, + (Rabs eps <= sqrt (1 + 2 * u_ro) - 1)%R /\ x = (rx * (1 + eps))%R. +Proof. +intros x rx (d, (Bd, Hd)). +assert (H := Rabs_le_inv _ _ Bd). +assert (H' := om1ds1p2u_ro_le_u_rod1pu_ro). +assert (H'' := u_rod1pu_ro_le_u_ro beta prec). +assert (H''' := u_ro_lt_1 beta prec prec_gt_0_). +assert (Hpos := s1p2u_rom1_pos). +destruct (Req_dec rx 0) as [Zfx|Nzfx]. +{ exists 0%R; split; [now rewrite Rabs_R0|]. + rewrite Rplus_0_r, Rmult_1_r, Zfx; rewrite Zfx in Hd. + destruct (Rmult_integral _ _ (sym_eq Hd)); lra. } +destruct (Req_dec x 0) as [Zx|Nzx]. +{ now exfalso; revert Hd; rewrite Zx; rewrite Rmult_0_l. } +set (d' := ((x - rx) / rx)%R). +assert (Hd' : (Rabs d' <= sqrt (1 + 2 * u_ro) - 1)%R). +{ unfold d'; rewrite Hd. + replace (_ / _)%R with (- d / (1 + d))%R; [|now field; split; lra]. + unfold Rdiv; rewrite Rabs_mult, Rabs_Ropp. + rewrite (Rabs_pos_eq (/ _)); [|apply Rlt_le, Rinv_0_lt_compat; lra]. + apply (Rmult_le_reg_r (1 + d)); [lra|]. + rewrite Rmult_assoc, Rinv_l, Rmult_1_r; [|lra]. + apply (Rle_trans _ _ _ Bd). + apply (Rle_trans _ ((sqrt (1 + 2 * u_ro) - 1) * (1/sqrt (1 + 2 * u_ro)))); + [right; field|apply Rmult_le_compat_l]; lra. } +now exists d'; split; [exact Hd'|]; unfold d'; field. +Qed. + +(** sqrt(1 + 2 u_ro) - 1 <= u_ro *) +Theorem sqrt_error_N_FLX_round_ex : + forall x, + format x -> + exists eps, + (Rabs eps <= sqrt (1 + 2 * u_ro) - 1)%R /\ + sqrt x = (round beta (FLX_exp prec) (Znearest choice) (sqrt x) * (1 + eps))%R. +Proof. +now intros x Fx; apply sqrt_error_N_round_ex_derive, sqrt_error_N_FLX_ex. +Qed. + +Variable emin : Z. +Hypothesis Hemin : (emin <= 2 * (1 - prec))%Z. + +Theorem sqrt_error_N_FLT_ex : + forall x, + generic_format beta (FLT_exp emin prec) x -> + exists eps, + (Rabs eps <= 1 - 1 / sqrt (1 + 2 * u_ro))%R /\ + round beta (FLT_exp emin prec) (Znearest choice) (sqrt x) + = (sqrt x * (1 + eps))%R. +Proof. +intros x Fx. +assert (Heps := u_ro_pos). +assert (Pb := om1ds1p2u_ro_pos). +destruct (Rle_or_lt x 0) as [Nx|Px]. +{ exists 0%R; split; [now rewrite Rabs_R0|]. + now rewrite (sqrt_neg x Nx), round_0, Rmult_0_l; [|apply valid_rnd_N]. } +assert (Fx' := generic_format_FLX_FLT _ _ _ _ Fx). +destruct (sqrt_error_N_FLX_ex _ Fx') as (d, (Bd, Hd)). +exists d; split; [exact Bd|]; rewrite <-Hd; apply round_FLT_FLX. +apply (Rle_trans _ (bpow (emin / 2)%Z)). +{ apply bpow_le, Z.div_le_lower_bound; lia. } +apply (Rle_trans _ _ _ (sqrt_bpow_ge _ _)). +rewrite Rabs_pos_eq; [|now apply sqrt_pos]; apply sqrt_le_1_alt. +revert Fx; apply generic_format_ge_bpow; [|exact Px]. +intro e; unfold FLT_exp; apply Z.le_max_r. +Qed. + +(** sqrt(1 + 2 u_ro) - 1 <= u_ro *) +Theorem sqrt_error_N_FLT_round_ex : + forall x, + generic_format beta (FLT_exp emin prec) x -> + exists eps, + (Rabs eps <= sqrt (1 + 2 * u_ro) - 1)%R /\ + sqrt x + = (round beta (FLT_exp emin prec) (Znearest choice) (sqrt x) * (1 + eps))%R. +Proof. +now intros x Fx; apply sqrt_error_N_round_ex_derive, sqrt_error_N_FLT_ex. +Qed. + +End Fprop_divsqrt_error. + +Section format_REM_aux. + +Variable beta : radix. +Notation bpow e := (bpow beta e). + +Variable fexp : Z -> Z. +Context { valid_exp : Valid_exp fexp }. +Context { monotone_exp : Monotone_exp fexp }. + +Variable rnd : R -> Z. +Context { valid_rnd : Valid_rnd rnd }. + +Notation format := (generic_format beta fexp). + +Lemma format_REM_aux: + forall x y : R, + format x -> format y -> (0 <= x)%R -> (0 < y)%R -> + ((0 < x/y < /2)%R -> rnd (x/y) = 0%Z) -> + format (x - IZR (rnd (x/y))*y). +Proof with auto with typeclass_instances. +intros x y Fx Fy Hx Hy rnd_small. +pose (n:=rnd (x / y)). +assert (Hn:(IZR n = round beta (FIX_exp 0) rnd (x/y))%R). +unfold round, FIX_exp, cexp, scaled_mantissa, F2R; simpl. +now rewrite 2!Rmult_1_r. +assert (H:(0 <= n)%Z). +apply le_IZR; rewrite Hn; simpl. +apply Rle_trans with (round beta (FIX_exp 0) rnd 0). +right; apply sym_eq, round_0... +apply round_le... +apply Fourier_util.Rle_mult_inv_pos; assumption. +case (Zle_lt_or_eq 0 n); try exact H. +clear H; intros H. +case (Zle_lt_or_eq 1 n). +omega. +clear H; intros H. +set (ex := cexp beta fexp x). +set (ey := cexp beta fexp y). +set (mx := Ztrunc (scaled_mantissa beta fexp x)). +set (my := Ztrunc (scaled_mantissa beta fexp y)). +case (Zle_or_lt ey ex); intros Hexy. +(* ey <= ex *) +assert (H0:(x-IZR n *y = F2R (Float beta (mx*beta^(ex-ey) - n*my) ey))%R). +unfold Rminus; rewrite Rplus_comm. +replace (IZR n) with (F2R (Float beta n 0)). +rewrite Fx, Fy. +fold mx my ex ey. +rewrite <- F2R_mult. +rewrite <- F2R_opp. +rewrite <- F2R_plus. +unfold Fplus. simpl. +rewrite Zle_imp_le_bool with (1 := Hexy). +f_equal; f_equal; ring. +unfold F2R; simpl; ring. +fold n; rewrite H0. +apply generic_format_F2R. +rewrite <- H0; intros H3. +apply monotone_exp. +apply mag_le_abs. +rewrite H0; apply F2R_neq_0; easy. +apply Rmult_le_reg_l with (/Rabs y)%R. +apply Rinv_0_lt_compat. +apply Rabs_pos_lt. +now apply Rgt_not_eq. +rewrite Rinv_l. +2: apply Rgt_not_eq, Rabs_pos_lt. +2: now apply Rgt_not_eq. +rewrite <- Rabs_Rinv. +2: now apply Rgt_not_eq. +rewrite <- Rabs_mult. +replace (/y * (x - IZR n *y))%R with (-(IZR n - x/y))%R. +rewrite Rabs_Ropp. +rewrite Hn. +apply Rle_trans with (1:= error_le_ulp beta (FIX_exp 0) _ _). +rewrite ulp_FIX. +simpl; apply Rle_refl. +field. +now apply Rgt_not_eq. +(* ex < ey: impossible as 1 < n *) +absurd (1 < n)%Z; try easy. +apply Zle_not_lt. +apply le_IZR; simpl; rewrite Hn. +apply round_le_generic... +apply generic_format_FIX. +exists (Float beta 1 0); try easy. +unfold F2R; simpl; ring. +apply Rmult_le_reg_r with y; try easy. +unfold Rdiv; rewrite Rmult_assoc. +rewrite Rinv_l, Rmult_1_r, Rmult_1_l. +2: now apply Rgt_not_eq. +assert (mag beta x < mag beta y)%Z. +case (Zle_or_lt (mag beta y) (mag beta x)); try easy. +intros J; apply monotone_exp in J; clear -J Hexy. +unfold ex, ey, cexp in Hexy; omega. +left; apply lt_mag with beta; easy. +(* n = 1 -> Sterbenz + rnd_small *) +intros Hn'; fold n; rewrite <- Hn'. +rewrite Rmult_1_l. +case Hx; intros Hx'. +assert (J:(0 < x/y)%R). +apply Fourier_util.Rlt_mult_inv_pos; assumption. +apply sterbenz... +assert (H0:(Rabs (1 - x/y) < 1)%R). +rewrite Hn', Hn. +apply Rlt_le_trans with (ulp beta (FIX_exp 0) (round beta (FIX_exp 0) rnd (x / y)))%R. +apply error_lt_ulp_round... +now apply Rgt_not_eq. +rewrite ulp_FIX. +rewrite <- Hn, <- Hn'. +apply Rle_refl. +apply Rabs_lt_inv in H0. +split; apply Rmult_le_reg_l with (/y)%R; try now apply Rinv_0_lt_compat. +unfold Rdiv; rewrite <- Rmult_assoc. +rewrite Rinv_l. +2: now apply Rgt_not_eq. +rewrite Rmult_1_l, Rmult_comm; fold (x/y)%R. +case (Rle_or_lt (/2) (x/y)); try easy. +intros K. +elim Zlt_not_le with (1 := H). +apply Zeq_le. +apply rnd_small. +now split. +apply Ropp_le_cancel; apply Rplus_le_reg_l with 1%R. +apply Rle_trans with (1-x/y)%R. +2: right; unfold Rdiv; ring. +left; apply Rle_lt_trans with (2:=proj1 H0). +right; field. +now apply Rgt_not_eq. +rewrite <- Hx', Rminus_0_l. +now apply generic_format_opp. +(* n = 0 *) +clear H; intros H; fold n; rewrite <- H. +now rewrite Rmult_0_l, Rminus_0_r. +Qed. + +End format_REM_aux. + +Section format_REM. + +Variable beta : radix. +Notation bpow e := (bpow beta e). + +Variable fexp : Z -> Z. +Context { valid_exp : Valid_exp fexp }. +Context { monotone_exp : Monotone_exp fexp }. + +Notation format := (generic_format beta fexp). + +Theorem format_REM : + forall rnd : R -> Z, Valid_rnd rnd -> + forall x y : R, + ((Rabs (x/y) < /2)%R -> rnd (x/y)%R = 0%Z) -> + format x -> format y -> + format (x - IZR (rnd (x/y)%R) * y). +Proof with auto with typeclass_instances. +(* assume 0 < y *) +assert (H: forall rnd : R -> Z, Valid_rnd rnd -> + forall x y : R, + ((Rabs (x/y) < /2)%R -> rnd (x/y)%R = 0%Z) -> + format x -> format y -> (0 < y)%R -> + format (x - IZR (rnd (x/y)%R) * y)). +intros rnd valid_rnd x y Hrnd Fx Fy Hy. +case (Rle_or_lt 0 x); intros Hx. +apply format_REM_aux; try easy. +intros K. +apply Hrnd. +rewrite Rabs_pos_eq. +apply K. +apply Rlt_le, K. +replace (x - IZR (rnd (x/y)) * y)%R with + (- (-x - IZR (Zrnd_opp rnd (-x/y)) * y))%R. +apply generic_format_opp. +apply format_REM_aux; try easy... +now apply generic_format_opp. +apply Ropp_le_cancel; rewrite Ropp_0, Ropp_involutive; now left. +replace (- x / y)%R with (- (x/y))%R by (unfold Rdiv; ring). +intros K. +unfold Zrnd_opp. +rewrite Ropp_involutive, Hrnd. +easy. +rewrite Rabs_left. +apply K. +apply Ropp_lt_cancel. +now rewrite Ropp_0. +unfold Zrnd_opp. +replace (- (- x / y))%R with (x / y)%R by (unfold Rdiv; ring). +rewrite opp_IZR. +ring. +(* *) +intros rnd valid_rnd x y Hrnd Fx Fy. +case (Rle_or_lt 0 y); intros Hy. +destruct Hy as [Hy|Hy]. +now apply H. +now rewrite <- Hy, Rmult_0_r, Rminus_0_r. +replace (IZR (rnd (x/y)) * y)%R with + (IZR ((Zrnd_opp rnd) ((x / -y))) * -y)%R. +apply H; try easy... +replace (x / - y)%R with (- (x/y))%R. +intros K. +unfold Zrnd_opp. +rewrite Ropp_involutive, Hrnd. +easy. +now rewrite <- Rabs_Ropp. +field; now apply Rlt_not_eq. +now apply generic_format_opp. +apply Ropp_lt_cancel; now rewrite Ropp_0, Ropp_involutive. +unfold Zrnd_opp. +replace (- (x / - y))%R with (x/y)%R. +rewrite opp_IZR. +ring. +field; now apply Rlt_not_eq. +Qed. + +Theorem format_REM_ZR: + forall x y : R, + format x -> format y -> + format (x - IZR (Ztrunc (x/y)) * y). +Proof with auto with typeclass_instances. +intros x y Fx Fy. +apply format_REM; try easy... +intros K. +apply Z.abs_0_iff. +rewrite <- Ztrunc_abs. +rewrite Ztrunc_floor by apply Rabs_pos. +apply Zle_antisym. +replace 0%Z with (Zfloor (/2)). +apply Zfloor_le. +now apply Rlt_le. +apply Zfloor_imp. +simpl ; lra. +apply Zfloor_lub. +apply Rabs_pos. +Qed. + +Theorem format_REM_N : + forall choice, + forall x y : R, + format x -> format y -> + format (x - IZR (Znearest choice (x/y)) * y). +Proof with auto with typeclass_instances. +intros choice x y Fx Fy. +apply format_REM; try easy... +intros K. +apply Znearest_imp. +now rewrite Rminus_0_r. +Qed. + +End format_REM. diff --git a/flocq/Appli/Fappli_double_round.v b/flocq/Prop/Double_rounding.v index 82f61da3..055409bb 100644 --- a/flocq/Appli/Fappli_double_round.v +++ b/flocq/Prop/Double_rounding.v @@ -1,13 +1,28 @@ -(** * Conditions for innocuous double rounding. *) +(** +This file is part of the Flocq formalization of floating-point +arithmetic in Coq: http://flocq.gforge.inria.fr/ + +Copyright (C) 2014-2018 Sylvie Boldo +#<br /># +Copyright (C) 2014-2018 Guillaume Melquiond +#<br /># +Copyright (C) 2014-2018 Pierre Roux + +This library is free software; you can redistribute it and/or +modify it under the terms of the GNU Lesser General Public +License as published by the Free Software Foundation; either +version 3 of the License, or (at your option) any later version. + +This library is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +COPYING file for more details. +*) -Require Import Fcore_Raux. -Require Import Fcore_defs. -Require Import Fcore_generic_fmt. -Require Import Fcalc_ops. -Require Import Fcore_ulp. -Require Fcore_FLX Fcore_FLT Fcore_FTZ. +(** * Conditions for innocuous double rounding. *) Require Import Psatz. +Require Import Raux Defs Generic_fmt Operations Ulp FLX FLT FTZ. Open Scope R_scope. @@ -15,9 +30,9 @@ Section Double_round. Variable beta : radix. Notation bpow e := (bpow beta e). -Notation ln_beta x := (ln_beta beta x). +Notation mag x := (mag beta x). -Definition double_round_eq fexp1 fexp2 choice1 choice2 x := +Definition round_round_eq fexp1 fexp2 choice1 choice2 x := round beta fexp1 (Znearest choice1) (round beta fexp2 (Znearest choice2) x) = round beta fexp1 (Znearest choice1) x. @@ -26,22 +41,22 @@ Ltac bpow_simplify := (* bpow ex * bpow ey ~~> bpow (ex + ey) *) repeat match goal with - | |- context [(Fcore_Raux.bpow _ _ * Fcore_Raux.bpow _ _)] => + | |- context [(Raux.bpow _ _ * Raux.bpow _ _)] => rewrite <- bpow_plus - | |- context [(?X1 * Fcore_Raux.bpow _ _ * Fcore_Raux.bpow _ _)] => + | |- context [(?X1 * Raux.bpow _ _ * Raux.bpow _ _)] => rewrite (Rmult_assoc X1); rewrite <- bpow_plus - | |- context [(?X1 * (?X2 * Fcore_Raux.bpow _ _) * Fcore_Raux.bpow _ _)] => + | |- context [(?X1 * (?X2 * Raux.bpow _ _) * Raux.bpow _ _)] => rewrite <- (Rmult_assoc X1 X2); rewrite (Rmult_assoc (X1 * X2)); rewrite <- bpow_plus end; (* ring_simplify arguments of bpow *) repeat match goal with - | |- context [(Fcore_Raux.bpow _ ?X)] => + | |- context [(Raux.bpow _ ?X)] => progress ring_simplify X end; (* bpow 0 ~~> 1 *) - change (Fcore_Raux.bpow _ 0) with 1; + change (Raux.bpow _ 0) with 1; repeat match goal with | |- context [(_ * 1)] => @@ -54,26 +69,26 @@ Definition midp (fexp : Z -> Z) (x : R) := Definition midp' (fexp : Z -> Z) (x : R) := round beta fexp Zceil x - / 2 * ulp beta fexp x. -Lemma double_round_lt_mid_further_place' : +Lemma round_round_lt_mid_further_place' : forall (fexp1 fexp2 : Z -> Z), Valid_exp fexp1 -> Valid_exp fexp2 -> forall (choice1 choice2 : Z -> bool), forall x, 0 < x -> - (fexp2 (ln_beta x) <= fexp1 (ln_beta x) - 1)%Z -> - x < bpow (ln_beta x) - / 2 * ulp beta fexp2 x -> + (fexp2 (mag x) <= fexp1 (mag x) - 1)%Z -> + x < bpow (mag x) - / 2 * ulp beta fexp2 x -> x < midp fexp1 x - / 2 * ulp beta fexp2 x -> - double_round_eq fexp1 fexp2 choice1 choice2 x. + round_round_eq fexp1 fexp2 choice1 choice2 x. Proof. intros fexp1 fexp2 Vfexp1 Vfexp2 choice1 choice2 x Px Hf2f1 Hx1. -unfold double_round_eq. +unfold round_round_eq. set (x' := round beta fexp1 Zfloor x). intro Hx2'. assert (Hx2 : x - round beta fexp1 Zfloor x < / 2 * (ulp beta fexp1 x - ulp beta fexp2 x)). { now apply (Rplus_lt_reg_r (round beta fexp1 Zfloor x)); ring_simplify. } set (x'' := round beta fexp2 (Znearest choice2) x). -assert (Hr1 : Rabs (x'' - x) <= / 2 * bpow (fexp2 (ln_beta x))). +assert (Hr1 : Rabs (x'' - x) <= / 2 * bpow (fexp2 (mag x))). apply Rle_trans with (/ 2 * ulp beta fexp2 x). now unfold x''; apply error_le_half_ulp... rewrite ulp_neq_0;[now right|now apply Rgt_not_eq]. @@ -82,12 +97,12 @@ assert (Pxx' : 0 <= x - x'). apply round_DN_pt. exact Vfexp1. } rewrite 2!ulp_neq_0 in Hx2; try (apply Rgt_not_eq; assumption). -assert (Hr2 : Rabs (x'' - x') < / 2 * bpow (fexp1 (ln_beta x))). +assert (Hr2 : Rabs (x'' - x') < / 2 * bpow (fexp1 (mag x))). { replace (x'' - x') with (x'' - x + (x - x')) by ring. apply (Rle_lt_trans _ _ _ (Rabs_triang _ _)). - replace (/ 2 * _) with (/ 2 * bpow (fexp2 (ln_beta x)) - + (/ 2 * (bpow (fexp1 (ln_beta x)) - - bpow (fexp2 (ln_beta x))))) by ring. + replace (/ 2 * _) with (/ 2 * bpow (fexp2 (mag x)) + + (/ 2 * (bpow (fexp1 (mag x)) + - bpow (fexp2 (mag x))))) by ring. apply Rplus_le_lt_compat. - exact Hr1. - now rewrite Rabs_right; [|now apply Rle_ge]; apply Hx2. } @@ -95,9 +110,9 @@ destruct (Req_dec x'' 0) as [Zx''|Nzx'']. - (* x'' = 0 *) rewrite Zx'' in Hr1 |- *. rewrite round_0; [|now apply valid_rnd_N]. - unfold round, F2R, scaled_mantissa, canonic_exp; simpl. + unfold round, F2R, scaled_mantissa, cexp; simpl. rewrite (Znearest_imp _ _ 0); [now simpl; rewrite Rmult_0_l|]. - apply (Rmult_lt_reg_r (bpow (fexp1 (ln_beta x)))); [now apply bpow_gt_0|]. + apply (Rmult_lt_reg_r (bpow (fexp1 (mag x)))); [now apply bpow_gt_0|]. rewrite <- (Rabs_right (bpow (fexp1 _))) at 1; [|now apply Rle_ge; apply bpow_ge_0]. rewrite <- Rabs_mult; rewrite Rmult_minus_distr_r. @@ -109,25 +124,25 @@ destruct (Req_dec x'' 0) as [Zx''|Nzx'']. apply bpow_lt. omega. - (* x'' <> 0 *) - assert (Lx'' : ln_beta x'' = ln_beta x :> Z). + assert (Lx'' : mag x'' = mag x :> Z). { apply Zle_antisym. - - apply ln_beta_le_bpow; [exact Nzx''|]. + - apply mag_le_bpow; [exact Nzx''|]. replace x'' with (x'' - x + x) by ring. apply (Rle_lt_trans _ _ _ (Rabs_triang _ _)). - replace (bpow _) with (/ 2 * bpow (fexp2 (ln_beta x)) - + (bpow (ln_beta x) - - / 2 * bpow (fexp2 (ln_beta x)))) by ring. + replace (bpow _) with (/ 2 * bpow (fexp2 (mag x)) + + (bpow (mag x) + - / 2 * bpow (fexp2 (mag x)))) by ring. apply Rplus_le_lt_compat; [exact Hr1|]. rewrite ulp_neq_0 in Hx1;[idtac| now apply Rgt_not_eq]. now rewrite Rabs_right; [|apply Rle_ge; apply Rlt_le]. - unfold x'' in Nzx'' |- *. - now apply ln_beta_round_ge; [|apply valid_rnd_N|]. } - unfold round, F2R, scaled_mantissa, canonic_exp; simpl. + now apply mag_round_ge; [|apply valid_rnd_N|]. } + unfold round, F2R, scaled_mantissa, cexp; simpl. rewrite Lx''. rewrite (Znearest_imp _ _ (Zfloor (scaled_mantissa beta fexp1 x))). + rewrite (Znearest_imp _ _ (Zfloor (scaled_mantissa beta fexp1 x))); [reflexivity|]. - apply (Rmult_lt_reg_r (bpow (fexp1 (ln_beta x)))); [now apply bpow_gt_0|]. + apply (Rmult_lt_reg_r (bpow (fexp1 (mag x)))); [now apply bpow_gt_0|]. rewrite <- (Rabs_right (bpow (fexp1 _))) at 1; [|now apply Rle_ge; apply bpow_ge_0]. rewrite <- Rabs_mult. @@ -137,9 +152,9 @@ destruct (Req_dec x'' 0) as [Zx''|Nzx'']. rewrite Rabs_right; [|now apply Rle_ge]. apply (Rlt_le_trans _ _ _ Hx2). apply Rmult_le_compat_l; [lra|]. - generalize (bpow_ge_0 beta (fexp2 (ln_beta x))). - unfold ulp, canonic_exp; lra. - + apply (Rmult_lt_reg_r (bpow (fexp1 (ln_beta x)))); [now apply bpow_gt_0|]. + generalize (bpow_ge_0 beta (fexp2 (mag x))). + unfold ulp, cexp; lra. + + apply (Rmult_lt_reg_r (bpow (fexp1 (mag x)))); [now apply bpow_gt_0|]. rewrite <- (Rabs_right (bpow (fexp1 _))) at 1; [|now apply Rle_ge; apply bpow_ge_0]. rewrite <- Rabs_mult. @@ -148,16 +163,16 @@ destruct (Req_dec x'' 0) as [Zx''|Nzx'']. now bpow_simplify. Qed. -Lemma double_round_lt_mid_further_place : +Lemma round_round_lt_mid_further_place : forall (fexp1 fexp2 : Z -> Z), Valid_exp fexp1 -> Valid_exp fexp2 -> forall (choice1 choice2 : Z -> bool), forall x, 0 < x -> - (fexp2 (ln_beta x) <= fexp1 (ln_beta x) - 1)%Z -> - (fexp1 (ln_beta x) <= ln_beta x)%Z -> + (fexp2 (mag x) <= fexp1 (mag x) - 1)%Z -> + (fexp1 (mag x) <= mag x)%Z -> x < midp fexp1 x - / 2 * ulp beta fexp2 x -> - double_round_eq fexp1 fexp2 choice1 choice2 x. + round_round_eq fexp1 fexp2 choice1 choice2 x. Proof. intros fexp1 fexp2 Vfexp1 Vfexp2 choice1 choice2 x Px Hf2f1 Hf1. intro Hx2'. @@ -165,15 +180,15 @@ assert (Hx2 : x - round beta fexp1 Zfloor x < / 2 * (ulp beta fexp1 x - ulp beta fexp2 x)). { now apply (Rplus_lt_reg_r (round beta fexp1 Zfloor x)); ring_simplify. } revert Hx2. -unfold double_round_eq. +unfold round_round_eq. set (x' := round beta fexp1 Zfloor x). intro Hx2. assert (Pxx' : 0 <= x - x'). { apply Rle_0_minus. apply round_DN_pt. exact Vfexp1. } -assert (x < bpow (ln_beta x) - / 2 * bpow (fexp2 (ln_beta x))); - [|apply double_round_lt_mid_further_place'; try assumption]... +assert (x < bpow (mag x) - / 2 * bpow (fexp2 (mag x))); + [|apply round_round_lt_mid_further_place'; try assumption]... 2: rewrite ulp_neq_0;[assumption|now apply Rgt_not_eq]. destruct (Req_dec x' 0) as [Zx'|Nzx']. - (* x' = 0 *) @@ -182,10 +197,10 @@ destruct (Req_dec x' 0) as [Zx'|Nzx']. rewrite Rmult_minus_distr_l. rewrite 2!ulp_neq_0;[idtac|now apply Rgt_not_eq|now apply Rgt_not_eq]. apply Rplus_le_compat_r. - apply (Rmult_le_reg_r (bpow (- ln_beta x))); [now apply bpow_gt_0|]. - unfold ulp, canonic_exp; bpow_simplify. + apply (Rmult_le_reg_r (bpow (- mag x))); [now apply bpow_gt_0|]. + unfold ulp, cexp; bpow_simplify. apply Rmult_le_reg_l with (1 := Rlt_0_2). - replace (2 * (/ 2 * _)) with (bpow (fexp1 (ln_beta x) - ln_beta x)) by field. + replace (2 * (/ 2 * _)) with (bpow (fexp1 (mag x) - mag x)) by field. apply Rle_trans with 1; [|lra]. change 1 with (bpow 0); apply bpow_le. omega. @@ -193,16 +208,16 @@ destruct (Req_dec x' 0) as [Zx'|Nzx']. assert (Px' : 0 < x'). { assert (0 <= x'); [|lra]. unfold x'. - apply (Rmult_le_reg_r (bpow (- fexp1 (ln_beta x)))); + apply (Rmult_le_reg_r (bpow (- fexp1 (mag x)))); [now apply bpow_gt_0|]. rewrite Rmult_0_l. - unfold round, F2R, canonic_exp; simpl; bpow_simplify. - change 0 with (Z2R 0); apply Z2R_le. + unfold round, F2R, cexp; simpl; bpow_simplify. + apply IZR_le. apply Zfloor_lub. rewrite <- (Rabs_right x); [|now apply Rle_ge; apply Rlt_le]. rewrite scaled_mantissa_abs. apply Rabs_pos. } - assert (Hx' : x' <= bpow (ln_beta x) - ulp beta fexp1 x). + assert (Hx' : x' <= bpow (mag x) - ulp beta fexp1 x). { apply (Rplus_le_reg_r (ulp beta fexp1 x)); ring_simplify. rewrite <- ulp_DN. - change (round _ _ _ _) with x'. @@ -213,10 +228,10 @@ destruct (Req_dec x' 0) as [Zx'|Nzx']. + apply Rle_lt_trans with x. * now apply round_DN_pt. * rewrite <- (Rabs_right x) at 1; [|now apply Rle_ge; apply Rlt_le]. - apply bpow_ln_beta_gt. + apply bpow_mag_gt. - exact Vfexp1. - - exact Px'. } - fold (canonic_exp beta fexp2 x); fold (ulp beta fexp2 x). + - now apply Rlt_le. } + fold (cexp beta fexp2 x); fold (ulp beta fexp2 x). assert (/ 2 * ulp beta fexp1 x <= ulp beta fexp1 x). rewrite <- (Rmult_1_l (ulp _ _ _)) at 2. apply Rmult_le_compat_r; [|lra]. @@ -227,39 +242,39 @@ destruct (Req_dec x' 0) as [Zx'|Nzx']. lra. Qed. -Lemma double_round_lt_mid_same_place : +Lemma round_round_lt_mid_same_place : forall (fexp1 fexp2 : Z -> Z), Valid_exp fexp1 -> forall (choice1 choice2 : Z -> bool), forall x, 0 < x -> - (fexp2 (ln_beta x) = fexp1 (ln_beta x))%Z -> + (fexp2 (mag x) = fexp1 (mag x))%Z -> x < midp fexp1 x -> - double_round_eq fexp1 fexp2 choice1 choice2 x. + round_round_eq fexp1 fexp2 choice1 choice2 x. Proof. intros fexp1 fexp2 Vfexp1 choice1 choice2 x Px Hf2f1. intro Hx'. assert (Hx : x - round beta fexp1 Zfloor x < / 2 * ulp beta fexp1 x). { now apply (Rplus_lt_reg_r (round beta fexp1 Zfloor x)); ring_simplify. } revert Hx. -unfold double_round_eq. +unfold round_round_eq. set (x' := round beta fexp1 Zfloor x). intro Hx. assert (Pxx' : 0 <= x - x'). { apply Rle_0_minus. apply round_DN_pt. exact Vfexp1. } -assert (H : Rabs (x * bpow (- fexp1 (ln_beta x)) - - Z2R (Zfloor (x * bpow (- fexp1 (ln_beta x))))) < / 2). -{ apply (Rmult_lt_reg_r (bpow (fexp1 (ln_beta x)))); [now apply bpow_gt_0|]. - unfold scaled_mantissa, canonic_exp in Hx. +assert (H : Rabs (x * bpow (- fexp1 (mag x)) - + IZR (Zfloor (x * bpow (- fexp1 (mag x))))) < / 2). +{ apply (Rmult_lt_reg_r (bpow (fexp1 (mag x)))); [now apply bpow_gt_0|]. + unfold scaled_mantissa, cexp in Hx. rewrite <- (Rabs_right (bpow (fexp1 _))) at 1; [|now apply Rle_ge; apply bpow_ge_0]. rewrite <- Rabs_mult. rewrite Rmult_minus_distr_r. bpow_simplify. apply Rabs_lt. - change (Z2R _ * _) with x'. + change (IZR _ * _) with x'. split. - apply Rlt_le_trans with 0; [|exact Pxx']. rewrite <- Ropp_0. @@ -269,55 +284,54 @@ assert (H : Rabs (x * bpow (- fexp1 (ln_beta x)) - apply bpow_gt_0. - rewrite ulp_neq_0 in Hx;try apply Rgt_not_eq; assumption. } unfold round at 2. -unfold F2R, scaled_mantissa, canonic_exp; simpl. +unfold F2R, scaled_mantissa, cexp; simpl. rewrite Hf2f1. -rewrite (Znearest_imp _ _ (Zfloor (scaled_mantissa beta fexp1 x))). -- rewrite round_generic. - + unfold round, F2R, scaled_mantissa, canonic_exp; simpl. - now rewrite (Znearest_imp _ _ (Zfloor (x * bpow (- fexp1 (ln_beta x))))). +rewrite (Znearest_imp _ _ (Zfloor (scaled_mantissa beta fexp1 x)) H). +rewrite round_generic. + + unfold round, F2R, scaled_mantissa, cexp; simpl. + now rewrite (Znearest_imp _ _ (Zfloor (x * bpow (- fexp1 (mag x))))). + now apply valid_rnd_N. - + fold (canonic_exp beta fexp1 x). - change (Z2R _ * bpow _) with (round beta fexp1 Zfloor x). + + fold (cexp beta fexp1 x). + change (IZR _ * bpow _) with (round beta fexp1 Zfloor x). apply generic_format_round. exact Vfexp1. now apply valid_rnd_DN. -- now unfold scaled_mantissa, canonic_exp. Qed. -Lemma double_round_lt_mid : +Lemma round_round_lt_mid : forall (fexp1 fexp2 : Z -> Z), Valid_exp fexp1 -> Valid_exp fexp2 -> forall (choice1 choice2 : Z -> bool), forall x, 0 < x -> - (fexp2 (ln_beta x) <= fexp1 (ln_beta x))%Z -> - (fexp1 (ln_beta x) <= ln_beta x)%Z -> + (fexp2 (mag x) <= fexp1 (mag x))%Z -> + (fexp1 (mag x) <= mag x)%Z -> x < midp fexp1 x -> - ((fexp2 (ln_beta x) <= fexp1 (ln_beta x) - 1)%Z -> + ((fexp2 (mag x) <= fexp1 (mag x) - 1)%Z -> x < midp fexp1 x - / 2 * ulp beta fexp2 x) -> - double_round_eq fexp1 fexp2 choice1 choice2 x. + round_round_eq fexp1 fexp2 choice1 choice2 x. Proof. intros fexp1 fexp2 Vfexp1 Vfexp2 choice1 choice2 x Px Hf2f1 Hf1 Hx Hx'. -destruct (Zle_or_lt (fexp1 (ln_beta x)) (fexp2 (ln_beta x))) as [Hf2'|Hf2']. -- (* fexp1 (ln_beta x) <= fexp2 (ln_beta x) *) - assert (Hf2'' : (fexp2 (ln_beta x) = fexp1 (ln_beta x) :> Z)%Z); [omega|]. - now apply double_round_lt_mid_same_place. -- (* fexp2 (ln_beta x) < fexp1 (ln_beta x) *) - assert (Hf2'' : (fexp2 (ln_beta x) <= fexp1 (ln_beta x) - 1)%Z); [omega|]. +destruct (Zle_or_lt (fexp1 (mag x)) (fexp2 (mag x))) as [Hf2'|Hf2']. +- (* fexp1 (mag x) <= fexp2 (mag x) *) + assert (Hf2'' : (fexp2 (mag x) = fexp1 (mag x) :> Z)%Z); [omega|]. + now apply round_round_lt_mid_same_place. +- (* fexp2 (mag x) < fexp1 (mag x) *) + assert (Hf2'' : (fexp2 (mag x) <= fexp1 (mag x) - 1)%Z); [omega|]. generalize (Hx' Hf2''); intro Hx''. - now apply double_round_lt_mid_further_place. + now apply round_round_lt_mid_further_place. Qed. -Lemma double_round_gt_mid_further_place' : +Lemma round_round_gt_mid_further_place' : forall (fexp1 fexp2 : Z -> Z), Valid_exp fexp1 -> Valid_exp fexp2 -> forall (choice1 choice2 : Z -> bool), forall x, 0 < x -> - (fexp2 (ln_beta x) <= fexp1 (ln_beta x) - 1)%Z -> - round beta fexp2 (Znearest choice2) x < bpow (ln_beta x) -> + (fexp2 (mag x) <= fexp1 (mag x) - 1)%Z -> + round beta fexp2 (Znearest choice2) x < bpow (mag x) -> midp' fexp1 x + / 2 * ulp beta fexp2 x < x -> - double_round_eq fexp1 fexp2 choice1 choice2 x. + round_round_eq fexp1 fexp2 choice1 choice2 x. Proof. intros fexp1 fexp2 Vfexp1 Vfexp2 choice1 choice2 x Px Hf2f1. intros Hx1 Hx2'. @@ -327,11 +341,11 @@ assert (Hx2 : round beta fexp1 Zceil x - x + / 2 * ulp beta fexp2 x)); ring_simplify. now unfold midp' in Hx2'. } revert Hx1 Hx2. -unfold double_round_eq. +unfold round_round_eq. set (x' := round beta fexp1 Zceil x). set (x'' := round beta fexp2 (Znearest choice2) x). intros Hx1 Hx2. -assert (Hr1 : Rabs (x'' - x) <= / 2 * bpow (fexp2 (ln_beta x))). +assert (Hr1 : Rabs (x'' - x) <= / 2 * bpow (fexp2 (mag x))). apply Rle_trans with (/2* ulp beta fexp2 x). now unfold x''; apply error_le_half_ulp... rewrite ulp_neq_0;[now right|now apply Rgt_not_eq]. @@ -339,12 +353,12 @@ assert (Px'x : 0 <= x' - x). { apply Rle_0_minus. apply round_UP_pt. exact Vfexp1. } -assert (Hr2 : Rabs (x'' - x') < / 2 * bpow (fexp1 (ln_beta x))). +assert (Hr2 : Rabs (x'' - x') < / 2 * bpow (fexp1 (mag x))). { replace (x'' - x') with (x'' - x + (x - x')) by ring. apply (Rle_lt_trans _ _ _ (Rabs_triang _ _)). - replace (/ 2 * _) with (/ 2 * bpow (fexp2 (ln_beta x)) - + (/ 2 * (bpow (fexp1 (ln_beta x)) - - bpow (fexp2 (ln_beta x))))) by ring. + replace (/ 2 * _) with (/ 2 * bpow (fexp2 (mag x)) + + (/ 2 * (bpow (fexp1 (mag x)) + - bpow (fexp2 (mag x))))) by ring. apply Rplus_le_lt_compat. - exact Hr1. - rewrite Rabs_minus_sym. @@ -354,9 +368,9 @@ destruct (Req_dec x'' 0) as [Zx''|Nzx'']. - (* x'' = 0 *) rewrite Zx'' in Hr1 |- *. rewrite round_0; [|now apply valid_rnd_N]. - unfold round, F2R, scaled_mantissa, canonic_exp; simpl. + unfold round, F2R, scaled_mantissa, cexp; simpl. rewrite (Znearest_imp _ _ 0); [now simpl; rewrite Rmult_0_l|]. - apply (Rmult_lt_reg_r (bpow (fexp1 (ln_beta x)))); [now apply bpow_gt_0|]. + apply (Rmult_lt_reg_r (bpow (fexp1 (mag x)))); [now apply bpow_gt_0|]. rewrite <- (Rabs_right (bpow (fexp1 _))) at 1; [|now apply Rle_ge; apply bpow_ge_0]. rewrite <- Rabs_mult; rewrite Rmult_minus_distr_r. @@ -368,9 +382,9 @@ destruct (Req_dec x'' 0) as [Zx''|Nzx'']. apply bpow_lt. omega. - (* x'' <> 0 *) - assert (Lx'' : ln_beta x'' = ln_beta x :> Z). + assert (Lx'' : mag x'' = mag x :> Z). { apply Zle_antisym. - - apply ln_beta_le_bpow; [exact Nzx''|]. + - apply mag_le_bpow; [exact Nzx''|]. rewrite Rabs_right; [exact Hx1|apply Rle_ge]. apply round_ge_generic. + exact Vfexp2. @@ -378,13 +392,13 @@ destruct (Req_dec x'' 0) as [Zx''|Nzx'']. + apply generic_format_0. + now apply Rlt_le. - unfold x'' in Nzx'' |- *. - now apply ln_beta_round_ge; [|apply valid_rnd_N|]. } - unfold round, F2R, scaled_mantissa, canonic_exp; simpl. + now apply mag_round_ge; [|apply valid_rnd_N|]. } + unfold round, F2R, scaled_mantissa, cexp; simpl. rewrite Lx''. rewrite (Znearest_imp _ _ (Zceil (scaled_mantissa beta fexp1 x))). + rewrite (Znearest_imp _ _ (Zceil (scaled_mantissa beta fexp1 x))); [reflexivity|]. - apply (Rmult_lt_reg_r (bpow (fexp1 (ln_beta x)))); [now apply bpow_gt_0|]. + apply (Rmult_lt_reg_r (bpow (fexp1 (mag x)))); [now apply bpow_gt_0|]. rewrite <- (Rabs_right (bpow (fexp1 _))) at 1; [|now apply Rle_ge; apply bpow_ge_0]. rewrite <- Rabs_mult. @@ -395,10 +409,10 @@ destruct (Req_dec x'' 0) as [Zx''|Nzx'']. rewrite Rabs_right; [|now apply Rle_ge]. apply (Rlt_le_trans _ _ _ Hx2). apply Rmult_le_compat_l; [lra|]. - generalize (bpow_ge_0 beta (fexp2 (ln_beta x))). + generalize (bpow_ge_0 beta (fexp2 (mag x))). rewrite 2!ulp_neq_0; try (apply Rgt_not_eq; assumption). - unfold canonic_exp; lra. - + apply (Rmult_lt_reg_r (bpow (fexp1 (ln_beta x)))); [now apply bpow_gt_0|]. + unfold cexp; lra. + + apply (Rmult_lt_reg_r (bpow (fexp1 (mag x)))); [now apply bpow_gt_0|]. rewrite <- (Rabs_right (bpow (fexp1 _))) at 1; [|now apply Rle_ge; apply bpow_ge_0]. rewrite <- Rabs_mult. @@ -407,16 +421,16 @@ destruct (Req_dec x'' 0) as [Zx''|Nzx'']. now bpow_simplify. Qed. -Lemma double_round_gt_mid_further_place : +Lemma round_round_gt_mid_further_place : forall (fexp1 fexp2 : Z -> Z), Valid_exp fexp1 -> Valid_exp fexp2 -> forall (choice1 choice2 : Z -> bool), forall x, 0 < x -> - (fexp2 (ln_beta x) <= fexp1 (ln_beta x) - 1)%Z -> - (fexp1 (ln_beta x) <= ln_beta x)%Z -> + (fexp2 (mag x) <= fexp1 (mag x) - 1)%Z -> + (fexp1 (mag x) <= mag x)%Z -> midp' fexp1 x + / 2 * ulp beta fexp2 x < x -> - double_round_eq fexp1 fexp2 choice1 choice2 x. + round_round_eq fexp1 fexp2 choice1 choice2 x. Proof. intros fexp1 fexp2 Vfexp1 Vfexp2 choice1 choice2 x Px Hf2f1 Hf1 Hx2'. assert (Hx2 : round beta fexp1 Zceil x - x @@ -425,15 +439,15 @@ assert (Hx2 : round beta fexp1 Zceil x - x + / 2 * ulp beta fexp2 x)); ring_simplify. now unfold midp' in Hx2'. } revert Hx2. -unfold double_round_eq. +unfold round_round_eq. set (x' := round beta fexp1 Zfloor x). intro Hx2. set (x'' := round beta fexp2 (Znearest choice2) x). -destruct (Rlt_or_le x'' (bpow (ln_beta x))) as [Hx''|Hx'']; - [now apply double_round_gt_mid_further_place'|]. -(* bpow (ln_beta x) <= x'' *) -assert (Hx''pow : x'' = bpow (ln_beta x)). -{ assert (H'x'' : x'' < bpow (ln_beta x) + / 2 * ulp beta fexp2 x). +destruct (Rlt_or_le x'' (bpow (mag x))) as [Hx''|Hx'']; + [now apply round_round_gt_mid_further_place'|]. +(* bpow (mag x) <= x'' *) +assert (Hx''pow : x'' = bpow (mag x)). +{ assert (H'x'' : x'' < bpow (mag x) + / 2 * ulp beta fexp2 x). { apply Rle_lt_trans with (x + / 2 * ulp beta fexp2 x). - apply (Rplus_le_reg_r (- x)); ring_simplify. apply Rabs_le_inv. @@ -441,22 +455,22 @@ assert (Hx''pow : x'' = bpow (ln_beta x)). exact Vfexp2. - apply Rplus_lt_compat_r. rewrite <- Rabs_right at 1; [|now apply Rle_ge; apply Rlt_le]. - apply bpow_ln_beta_gt. } + apply bpow_mag_gt. } apply Rle_antisym; [|exact Hx'']. - unfold x'', round, F2R, scaled_mantissa, canonic_exp; simpl. - apply (Rmult_le_reg_r (bpow (- fexp2 (ln_beta x)))); [now apply bpow_gt_0|]. + unfold x'', round, F2R, scaled_mantissa, cexp; simpl. + apply (Rmult_le_reg_r (bpow (- fexp2 (mag x)))); [now apply bpow_gt_0|]. bpow_simplify. - rewrite <- (Z2R_Zpower _ (_ - _)); [|omega]. - apply Z2R_le. + rewrite <- (IZR_Zpower _ (_ - _)); [|omega]. + apply IZR_le. apply Zlt_succ_le; unfold Z.succ. - apply lt_Z2R. - rewrite Z2R_plus; rewrite Z2R_Zpower; [|omega]. - apply (Rmult_lt_reg_r (bpow (fexp2 (ln_beta x)))); [now apply bpow_gt_0|]. + apply lt_IZR. + rewrite plus_IZR; rewrite IZR_Zpower; [|omega]. + apply (Rmult_lt_reg_r (bpow (fexp2 (mag x)))); [now apply bpow_gt_0|]. rewrite Rmult_plus_distr_r; rewrite Rmult_1_l. bpow_simplify. apply (Rlt_le_trans _ _ _ H'x''). apply Rplus_le_compat_l. - rewrite <- (Rmult_1_l (Fcore_Raux.bpow _ _)). + rewrite <- (Rmult_1_l (Raux.bpow _ _)). rewrite ulp_neq_0;[idtac|now apply Rgt_not_eq]. apply Rmult_le_compat_r; [now apply bpow_ge_0|]. lra. } @@ -467,26 +481,26 @@ assert (Hr : Rabs (x - x'') < / 2 * ulp beta fexp1 x). exact Vfexp2. - apply Rmult_lt_compat_l; [lra|]. rewrite 2!ulp_neq_0; try now apply Rgt_not_eq. - unfold canonic_exp; apply bpow_lt. + unfold cexp; apply bpow_lt. omega. } -unfold round, F2R, scaled_mantissa, canonic_exp; simpl. -assert (Hf : (0 <= ln_beta x - fexp1 (ln_beta x''))%Z). +unfold round, F2R, scaled_mantissa, cexp; simpl. +assert (Hf : (0 <= mag x - fexp1 (mag x''))%Z). { rewrite Hx''pow. - rewrite ln_beta_bpow. - assert (fexp1 (ln_beta x + 1) <= ln_beta x)%Z; [|omega]. - destruct (Zle_or_lt (ln_beta x) (fexp1 (ln_beta x))) as [Hle|Hlt]; + rewrite mag_bpow. + assert (fexp1 (mag x + 1) <= mag x)%Z; [|omega]. + destruct (Zle_or_lt (mag x) (fexp1 (mag x))) as [Hle|Hlt]; [|now apply Vfexp1]. - assert (H : (ln_beta x = fexp1 (ln_beta x) :> Z)%Z); + assert (H : (mag x = fexp1 (mag x) :> Z)%Z); [now apply Zle_antisym|]. rewrite H. now apply Vfexp1. } -rewrite (Znearest_imp _ _ (beta ^ (ln_beta x - fexp1 (ln_beta x'')))%Z). -- rewrite (Znearest_imp _ _ (beta ^ (ln_beta x - fexp1 (ln_beta x)))%Z). - + rewrite Z2R_Zpower; [|exact Hf]. - rewrite Z2R_Zpower; [|omega]. +rewrite (Znearest_imp _ _ (beta ^ (mag x - fexp1 (mag x'')))%Z). +- rewrite (Znearest_imp _ _ (beta ^ (mag x - fexp1 (mag x)))%Z). + + rewrite IZR_Zpower; [|exact Hf]. + rewrite IZR_Zpower; [|omega]. now bpow_simplify. - + rewrite Z2R_Zpower; [|omega]. - apply (Rmult_lt_reg_r (bpow (fexp1 (ln_beta x)))); [now apply bpow_gt_0|]. + + rewrite IZR_Zpower; [|omega]. + apply (Rmult_lt_reg_r (bpow (fexp1 (mag x)))); [now apply bpow_gt_0|]. rewrite <- (Rabs_right (bpow (fexp1 _))) at 1; [|now apply Rle_ge; apply bpow_ge_0]. rewrite <- Rabs_mult. @@ -494,8 +508,8 @@ rewrite (Znearest_imp _ _ (beta ^ (ln_beta x - fexp1 (ln_beta x'')))%Z). bpow_simplify. rewrite ulp_neq_0 in Hr;[idtac|now apply Rgt_not_eq]. rewrite <- Hx''pow; exact Hr. -- rewrite Z2R_Zpower; [|exact Hf]. - apply (Rmult_lt_reg_r (bpow (fexp1 (ln_beta x'')))); [now apply bpow_gt_0|]. +- rewrite IZR_Zpower; [|exact Hf]. + apply (Rmult_lt_reg_r (bpow (fexp1 (mag x'')))); [now apply bpow_gt_0|]. rewrite <- (Rabs_right (bpow (fexp1 _))) at 1; [|now apply Rle_ge; apply bpow_ge_0]. rewrite <- Rabs_mult. @@ -507,24 +521,24 @@ rewrite (Znearest_imp _ _ (beta ^ (ln_beta x - fexp1 (ln_beta x'')))%Z). apply Rmult_lt_compat_l; [lra|apply bpow_gt_0]. Qed. -Lemma double_round_gt_mid_same_place : +Lemma round_round_gt_mid_same_place : forall (fexp1 fexp2 : Z -> Z), Valid_exp fexp1 -> forall (choice1 choice2 : Z -> bool), forall x, 0 < x -> - (fexp2 (ln_beta x) = fexp1 (ln_beta x))%Z -> + (fexp2 (mag x) = fexp1 (mag x))%Z -> midp' fexp1 x < x -> - double_round_eq fexp1 fexp2 choice1 choice2 x. + round_round_eq fexp1 fexp2 choice1 choice2 x. Proof. intros fexp1 fexp2 Vfexp1 choice1 choice2 x Px Hf2f1 Hx'. assert (Hx : round beta fexp1 Zceil x - x < / 2 * ulp beta fexp1 x). { apply (Rplus_lt_reg_r (- / 2 * ulp beta fexp1 x + x)); ring_simplify. now unfold midp' in Hx'. } -assert (H : Rabs (Z2R (Zceil (x * bpow (- fexp1 (ln_beta x)))) - - x * bpow (- fexp1 (ln_beta x))) < / 2). -{ apply (Rmult_lt_reg_r (bpow (fexp1 (ln_beta x)))); [now apply bpow_gt_0|]. - unfold scaled_mantissa, canonic_exp in Hx. +assert (H : Rabs (IZR (Zceil (x * bpow (- fexp1 (mag x)))) + - x * bpow (- fexp1 (mag x))) < / 2). +{ apply (Rmult_lt_reg_r (bpow (fexp1 (mag x)))); [now apply bpow_gt_0|]. + unfold scaled_mantissa, cexp in Hx. rewrite <- (Rabs_right (bpow (fexp1 _))) at 1; [|now apply Rle_ge; apply bpow_ge_0]. rewrite <- Rabs_mult. @@ -541,67 +555,67 @@ assert (H : Rabs (Z2R (Zceil (x * bpow (- fexp1 (ln_beta x)))) apply round_UP_pt. exact Vfexp1. - rewrite ulp_neq_0 in Hx;[exact Hx|now apply Rgt_not_eq]. } -unfold double_round_eq, round at 2. -unfold F2R, scaled_mantissa, canonic_exp; simpl. +unfold round_round_eq, round at 2. +unfold F2R, scaled_mantissa, cexp; simpl. rewrite Hf2f1. rewrite (Znearest_imp _ _ (Zceil (scaled_mantissa beta fexp1 x))). - rewrite round_generic. - + unfold round, F2R, scaled_mantissa, canonic_exp; simpl. - now rewrite (Znearest_imp _ _ (Zceil (x * bpow (- fexp1 (ln_beta x))))); + + unfold round, F2R, scaled_mantissa, cexp; simpl. + now rewrite (Znearest_imp _ _ (Zceil (x * bpow (- fexp1 (mag x))))); [|rewrite Rabs_minus_sym]. + now apply valid_rnd_N. - + fold (canonic_exp beta fexp1 x). - change (Z2R _ * bpow _) with (round beta fexp1 Zceil x). + + fold (cexp beta fexp1 x). + change (IZR _ * bpow _) with (round beta fexp1 Zceil x). apply generic_format_round. exact Vfexp1. now apply valid_rnd_UP. - now rewrite Rabs_minus_sym. Qed. -Lemma double_round_gt_mid : +Lemma round_round_gt_mid : forall (fexp1 fexp2 : Z -> Z), Valid_exp fexp1 -> Valid_exp fexp2 -> forall (choice1 choice2 : Z -> bool), forall x, 0 < x -> - (fexp2 (ln_beta x) <= fexp1 (ln_beta x))%Z -> - (fexp1 (ln_beta x) <= ln_beta x)%Z -> + (fexp2 (mag x) <= fexp1 (mag x))%Z -> + (fexp1 (mag x) <= mag x)%Z -> midp' fexp1 x < x -> - ((fexp2 (ln_beta x) <= fexp1 (ln_beta x) - 1)%Z -> + ((fexp2 (mag x) <= fexp1 (mag x) - 1)%Z -> midp' fexp1 x + / 2 * ulp beta fexp2 x < x) -> - double_round_eq fexp1 fexp2 choice1 choice2 x. + round_round_eq fexp1 fexp2 choice1 choice2 x. Proof. intros fexp1 fexp2 Vfexp1 Vfexp2 choice1 choice2 x Px Hf2f1 Hf1 Hx Hx'. -destruct (Zle_or_lt (fexp1 (ln_beta x)) (fexp2 (ln_beta x))) as [Hf2'|Hf2']. -- (* fexp1 (ln_beta x) <= fexp2 (ln_beta x) *) - assert (Hf2'' : (fexp2 (ln_beta x) = fexp1 (ln_beta x) :> Z)%Z); [omega|]. - now apply double_round_gt_mid_same_place. -- (* fexp2 (ln_beta x) < fexp1 (ln_beta x) *) - assert (Hf2'' : (fexp2 (ln_beta x) <= fexp1 (ln_beta x) - 1)%Z); [omega|]. +destruct (Zle_or_lt (fexp1 (mag x)) (fexp2 (mag x))) as [Hf2'|Hf2']. +- (* fexp1 (mag x) <= fexp2 (mag x) *) + assert (Hf2'' : (fexp2 (mag x) = fexp1 (mag x) :> Z)%Z); [omega|]. + now apply round_round_gt_mid_same_place. +- (* fexp2 (mag x) < fexp1 (mag x) *) + assert (Hf2'' : (fexp2 (mag x) <= fexp1 (mag x) - 1)%Z); [omega|]. generalize (Hx' Hf2''); intro Hx''. - now apply double_round_gt_mid_further_place. + now apply round_round_gt_mid_further_place. Qed. Section Double_round_mult. -Lemma ln_beta_mult_disj : +Lemma mag_mult_disj : forall x y, x <> 0 -> y <> 0 -> - ((ln_beta (x * y) = (ln_beta x + ln_beta y - 1)%Z :> Z) - \/ (ln_beta (x * y) = (ln_beta x + ln_beta y)%Z :> Z)). + ((mag (x * y) = (mag x + mag y - 1)%Z :> Z) + \/ (mag (x * y) = (mag x + mag y)%Z :> Z)). Proof. intros x y Zx Zy. -destruct (ln_beta_mult beta x y Zx Zy). +destruct (mag_mult beta x y Zx Zy). omega. Qed. -Definition double_round_mult_hyp fexp1 fexp2 := +Definition round_round_mult_hyp fexp1 fexp2 := (forall ex ey, (fexp2 (ex + ey) <= fexp1 ex + fexp1 ey)%Z) /\ (forall ex ey, (fexp2 (ex + ey - 1) <= fexp1 ex + fexp1 ey)%Z). -Lemma double_round_mult_aux : +Lemma round_round_mult_aux : forall (fexp1 fexp2 : Z -> Z), - double_round_mult_hyp fexp1 fexp2 -> + round_round_mult_hyp fexp1 fexp2 -> forall x y, generic_format beta fexp1 x -> generic_format beta fexp1 y -> generic_format beta fexp2 (x * y). @@ -621,31 +635,31 @@ destruct (Req_dec x 0) as [Zx|Zx]. + (* y <> 0 *) revert Fx Fy. unfold generic_format. - unfold canonic_exp. + unfold cexp. set (mx := Ztrunc (scaled_mantissa beta fexp1 x)). set (my := Ztrunc (scaled_mantissa beta fexp1 y)). unfold F2R; simpl. intros Fx Fy. - set (fxy := Float beta (mx * my) (fexp1 (ln_beta x) + fexp1 (ln_beta y))). + set (fxy := Float beta (mx * my) (fexp1 (mag x) + fexp1 (mag y))). assert (Hxy : x * y = F2R fxy). { unfold fxy, F2R; simpl. rewrite bpow_plus. - rewrite Z2R_mult. + rewrite mult_IZR. rewrite Fx, Fy at 1. ring. } apply generic_format_F2R' with (f := fxy); [now rewrite Hxy|]. intros _. - unfold canonic_exp, fxy; simpl. + unfold cexp, fxy; simpl. destruct Hfexp as (Hfexp1, Hfexp2). - now destruct (ln_beta_mult_disj x y Zx Zy) as [Lxy|Lxy]; rewrite Lxy. + now destruct (mag_mult_disj x y Zx Zy) as [Lxy|Lxy]; rewrite Lxy. Qed. Variable rnd : R -> Z. Context { valid_rnd : Valid_rnd rnd }. -Theorem double_round_mult : +Theorem round_round_mult : forall (fexp1 fexp2 : Z -> Z), - double_round_mult_hyp fexp1 fexp2 -> + round_round_mult_hyp fexp1 fexp2 -> forall x y, generic_format beta fexp1 x -> generic_format beta fexp1 y -> round beta fexp1 rnd (round beta fexp2 rnd (x * y)) @@ -654,21 +668,19 @@ Proof. intros fexp1 fexp2 Hfexp x y Fx Fy. assert (Hxy : round beta fexp2 rnd (x * y) = x * y). { apply round_generic; [assumption|]. - now apply (double_round_mult_aux fexp1 fexp2). } + now apply (round_round_mult_aux fexp1 fexp2). } now rewrite Hxy at 1. Qed. Section Double_round_mult_FLX. -Import Fcore_FLX. - Variable prec : Z. Variable prec' : Z. Context { prec_gt_0_ : Prec_gt_0 prec }. Context { prec_gt_0_' : Prec_gt_0 prec' }. -Theorem double_round_mult_FLX : +Theorem round_round_mult_FLX : (2 * prec <= prec')%Z -> forall x y, FLX_format beta prec x -> FLX_format beta prec y -> @@ -676,9 +688,9 @@ Theorem double_round_mult_FLX : = round beta (FLX_exp prec) rnd (x * y). Proof. intros Hprec x y Fx Fy. -apply double_round_mult; +apply round_round_mult; [|now apply generic_format_FLX|now apply generic_format_FLX]. -unfold double_round_mult_hyp; split; intros ex ey; unfold FLX_exp; +unfold round_round_mult_hyp; split; intros ex ey; unfold FLX_exp; omega. Qed. @@ -686,16 +698,13 @@ End Double_round_mult_FLX. Section Double_round_mult_FLT. -Import Fcore_FLX. -Import Fcore_FLT. - Variable emin prec : Z. Variable emin' prec' : Z. Context { prec_gt_0_ : Prec_gt_0 prec }. Context { prec_gt_0_' : Prec_gt_0 prec' }. -Theorem double_round_mult_FLT : +Theorem round_round_mult_FLT : (emin' <= 2 * emin)%Z -> (2 * prec <= prec')%Z -> forall x y, FLT_format beta emin prec x -> FLT_format beta emin prec y -> @@ -704,9 +713,9 @@ Theorem double_round_mult_FLT : = round beta (FLT_exp emin prec) rnd (x * y). Proof. intros Hemin Hprec x y Fx Fy. -apply double_round_mult; +apply round_round_mult; [|now apply generic_format_FLT|now apply generic_format_FLT]. -unfold double_round_mult_hyp; split; intros ex ey; +unfold round_round_mult_hyp; split; intros ex ey; unfold FLT_exp; generalize (Zmax_spec (ex + ey - prec') emin'); generalize (Zmax_spec (ex + ey - 1 - prec') emin'); @@ -719,16 +728,13 @@ End Double_round_mult_FLT. Section Double_round_mult_FTZ. -Import Fcore_FLX. -Import Fcore_FTZ. - Variable emin prec : Z. Variable emin' prec' : Z. Context { prec_gt_0_ : Prec_gt_0 prec }. Context { prec_gt_0_' : Prec_gt_0 prec' }. -Theorem double_round_mult_FTZ : +Theorem round_round_mult_FTZ : (emin' + prec' <= 2 * emin + prec)%Z -> (2 * prec <= prec')%Z -> forall x y, @@ -738,9 +744,9 @@ Theorem double_round_mult_FTZ : = round beta (FTZ_exp emin prec) rnd (x * y). Proof. intros Hemin Hprec x y Fx Fy. -apply double_round_mult; +apply round_round_mult; [|now apply generic_format_FTZ|now apply generic_format_FTZ]. -unfold double_round_mult_hyp; split; intros ex ey; +unfold round_round_mult_hyp; split; intros ex ey; unfold FTZ_exp; unfold Prec_gt_0 in *; destruct (Z.ltb_spec (ex + ey - prec') emin'); @@ -756,83 +762,77 @@ End Double_round_mult. Section Double_round_plus. -Lemma ln_beta_plus_disj : +Lemma mag_plus_disj : forall x y, 0 < y -> y <= x -> - ((ln_beta (x + y) = ln_beta x :> Z) - \/ (ln_beta (x + y) = (ln_beta x + 1)%Z :> Z)). + ((mag (x + y) = mag x :> Z) + \/ (mag (x + y) = (mag x + 1)%Z :> Z)). Proof. intros x y Py Hxy. -destruct (ln_beta_plus beta x y Py Hxy). +destruct (mag_plus beta x y Py Hxy). omega. Qed. -Lemma ln_beta_plus_separated : +Lemma mag_plus_separated : forall fexp : Z -> Z, forall x y, 0 < x -> 0 <= y -> generic_format beta fexp x -> - (ln_beta y <= fexp (ln_beta x))%Z -> - (ln_beta (x + y) = ln_beta x :> Z). + (mag y <= fexp (mag x))%Z -> + (mag (x + y) = mag x :> Z). Proof. intros fexp x y Px Nny Fx Hsep. -destruct (Req_dec y 0) as [Zy|Nzy]. -- (* y = 0 *) - now rewrite Zy; rewrite Rplus_0_r. -- (* y <> 0 *) - apply (ln_beta_plus_eps beta fexp); [assumption|assumption|]. - split; [assumption|]. - rewrite ulp_neq_0;[idtac|now apply Rgt_not_eq]. - unfold canonic_exp. - destruct (ln_beta y) as (ey, Hey); simpl in *. - apply Rlt_le_trans with (bpow ey). - + now rewrite <- (Rabs_right y); [apply Hey|apply Rle_ge]. - + now apply bpow_le. +apply mag_plus_eps with (1 := Px) (2 := Fx). +apply (conj Nny). +rewrite <- Rabs_pos_eq with (1 := Nny). +apply Rlt_le_trans with (1 := bpow_mag_gt beta _). +rewrite ulp_neq_0 by now apply Rgt_not_eq. +now apply bpow_le. Qed. -Lemma ln_beta_minus_disj : +Lemma mag_minus_disj : forall x y, 0 < x -> 0 < y -> - (ln_beta y <= ln_beta x - 2)%Z -> - ((ln_beta (x - y) = ln_beta x :> Z) - \/ (ln_beta (x - y) = (ln_beta x - 1)%Z :> Z)). + (mag y <= mag x - 2)%Z -> + ((mag (x - y) = mag x :> Z) + \/ (mag (x - y) = (mag x - 1)%Z :> Z)). Proof. intros x y Px Py Hln. -assert (Hxy : y < x); [now apply (ln_beta_lt_pos beta); [ |omega]|]. -generalize (ln_beta_minus beta x y Py Hxy); intro Hln2. -generalize (ln_beta_minus_lb beta x y Px Py Hln); intro Hln3. +assert (Hxy : y < x); [now apply (lt_mag beta); [ |omega]|]. +generalize (mag_minus beta x y Py Hxy); intro Hln2. +generalize (mag_minus_lb beta x y Px Py Hln); intro Hln3. omega. Qed. -Lemma ln_beta_minus_separated : +Lemma mag_minus_separated : forall fexp : Z -> Z, Valid_exp fexp -> forall x y, 0 < x -> 0 < y -> y < x -> - bpow (ln_beta x - 1) < x -> - generic_format beta fexp x -> (ln_beta y <= fexp (ln_beta x))%Z -> - (ln_beta (x - y) = ln_beta x :> Z). + bpow (mag x - 1) < x -> + generic_format beta fexp x -> (mag y <= fexp (mag x))%Z -> + (mag (x - y) = mag x :> Z). Proof. intros fexp Vfexp x y Px Py Yltx Xgtpow Fx Ly. -apply ln_beta_unique. +apply mag_unique. split. - apply Rabs_ge; right. - assert (Hy : y < ulp beta fexp (bpow (ln_beta x - 1))). + assert (Hy : y < ulp beta fexp (bpow (mag x - 1))). { rewrite ulp_bpow. - replace (_ + _)%Z with (ln_beta x : Z) by ring. + replace (_ + _)%Z with (mag x : Z) by ring. rewrite <- (Rabs_right y); [|now apply Rle_ge; apply Rlt_le]. - apply Rlt_le_trans with (bpow (ln_beta y)). - - apply bpow_ln_beta_gt. + apply Rlt_le_trans with (bpow (mag y)). + - apply bpow_mag_gt. - now apply bpow_le. } apply (Rplus_le_reg_r y); ring_simplify. - apply Rle_trans with (bpow (ln_beta x - 1) - + ulp beta fexp (bpow (ln_beta x - 1))). + apply Rle_trans with (bpow (mag x - 1) + + ulp beta fexp (bpow (mag x - 1))). + now apply Rplus_le_compat_l; apply Rlt_le. + rewrite <- succ_eq_pos;[idtac|apply bpow_ge_0]. apply succ_le_lt; [apply Vfexp|idtac|exact Fx|assumption]. - apply (generic_format_bpow beta fexp (ln_beta x - 1)). - replace (_ + _)%Z with (ln_beta x : Z) by ring. - assert (fexp (ln_beta x) < ln_beta x)%Z; [|omega]. - now apply ln_beta_generic_gt; [|now apply Rgt_not_eq|]. + apply (generic_format_bpow beta fexp (mag x - 1)). + replace (_ + _)%Z with (mag x : Z) by ring. + assert (fexp (mag x) < mag x)%Z; [|omega]. + now apply mag_generic_gt; [|now apply Rgt_not_eq|]. - rewrite Rabs_right. + apply Rlt_trans with x. * rewrite <- (Rplus_0_r x) at 2. @@ -840,22 +840,22 @@ split. rewrite <- Ropp_0. now apply Ropp_lt_contravar. * apply Rabs_lt_inv. - apply bpow_ln_beta_gt. + apply bpow_mag_gt. + lra. Qed. -Definition double_round_plus_hyp fexp1 fexp2 := +Definition round_round_plus_hyp fexp1 fexp2 := (forall ex ey, (fexp1 (ex + 1) - 1 <= ey)%Z -> (fexp2 ex <= fexp1 ey)%Z) /\ (forall ex ey, (fexp1 (ex - 1) + 1 <= ey)%Z -> (fexp2 ex <= fexp1 ey)%Z) /\ (forall ex ey, (fexp1 ex - 1 <= ey)%Z -> (fexp2 ex <= fexp1 ey)%Z) /\ (forall ex ey, (ex - 1 <= ey)%Z -> (fexp2 ex <= fexp1 ey)%Z). -Lemma double_round_plus_aux0_aux_aux : +Lemma round_round_plus_aux0_aux_aux : forall (fexp1 fexp2 : Z -> Z), forall x y, - (fexp1 (ln_beta x) <= fexp1 (ln_beta y))%Z -> - (fexp2 (ln_beta (x + y))%Z <= fexp1 (ln_beta x))%Z -> - (fexp2 (ln_beta (x + y))%Z <= fexp1 (ln_beta y))%Z -> + (fexp1 (mag x) <= fexp1 (mag y))%Z -> + (fexp2 (mag (x + y))%Z <= fexp1 (mag x))%Z -> + (fexp2 (mag (x + y))%Z <= fexp1 (mag y))%Z -> generic_format beta fexp1 x -> generic_format beta fexp1 y -> generic_format beta fexp2 (x + y). Proof. @@ -863,224 +863,224 @@ intros fexp1 fexp2 x y Oxy Hlnx Hlny Fx Fy. destruct (Req_dec x 0) as [Zx|Nzx]. - (* x = 0 *) rewrite Zx, Rplus_0_l in Hlny |- *. - now apply (generic_inclusion_ln_beta beta fexp1). + now apply (generic_inclusion_mag beta fexp1). - (* x <> 0 *) destruct (Req_dec y 0) as [Zy|Nzy]. + (* y = 0 *) rewrite Zy, Rplus_0_r in Hlnx |- *. - now apply (generic_inclusion_ln_beta beta fexp1). + now apply (generic_inclusion_mag beta fexp1). + (* y <> 0 *) revert Fx Fy. - unfold generic_format at -3, canonic_exp, F2R; simpl. + unfold generic_format at -3, cexp, F2R; simpl. set (mx := Ztrunc (scaled_mantissa beta fexp1 x)). set (my := Ztrunc (scaled_mantissa beta fexp1 y)). intros Fx Fy. - set (fxy := Float beta (mx + my * (beta ^ (fexp1 (ln_beta y) - - fexp1 (ln_beta x)))) - (fexp1 (ln_beta x))). + set (fxy := Float beta (mx + my * (beta ^ (fexp1 (mag y) + - fexp1 (mag x)))) + (fexp1 (mag x))). assert (Hxy : x + y = F2R fxy). { unfold fxy, F2R; simpl. - rewrite Z2R_plus. + rewrite plus_IZR. rewrite Rmult_plus_distr_r. rewrite <- Fx. - rewrite Z2R_mult. - rewrite Z2R_Zpower; [|omega]. + rewrite mult_IZR. + rewrite IZR_Zpower; [|omega]. bpow_simplify. now rewrite <- Fy. } apply generic_format_F2R' with (f := fxy); [now rewrite Hxy|]. intros _. - now unfold canonic_exp, fxy; simpl. + now unfold cexp, fxy; simpl. Qed. -Lemma double_round_plus_aux0_aux : +Lemma round_round_plus_aux0_aux : forall (fexp1 fexp2 : Z -> Z), forall x y, - (fexp2 (ln_beta (x + y))%Z <= fexp1 (ln_beta x))%Z -> - (fexp2 (ln_beta (x + y))%Z <= fexp1 (ln_beta y))%Z -> + (fexp2 (mag (x + y))%Z <= fexp1 (mag x))%Z -> + (fexp2 (mag (x + y))%Z <= fexp1 (mag y))%Z -> generic_format beta fexp1 x -> generic_format beta fexp1 y -> generic_format beta fexp2 (x + y). Proof. intros fexp1 fexp2 x y Hlnx Hlny Fx Fy. -destruct (Z.le_gt_cases (fexp1 (ln_beta x)) (fexp1 (ln_beta y))) as [Hle|Hgt]. -- now apply (double_round_plus_aux0_aux_aux fexp1). +destruct (Z.le_gt_cases (fexp1 (mag x)) (fexp1 (mag y))) as [Hle|Hgt]. +- now apply (round_round_plus_aux0_aux_aux fexp1). - rewrite Rplus_comm in Hlnx, Hlny |- *. - now apply (double_round_plus_aux0_aux_aux fexp1); [omega| | | |]. + now apply (round_round_plus_aux0_aux_aux fexp1); [omega| | | |]. Qed. -(* fexp1 (ln_beta x) - 1 <= ln_beta y : +(* fexp1 (mag x) - 1 <= mag y : * addition is exact in the largest precision (fexp2). *) -Lemma double_round_plus_aux0 : +Lemma round_round_plus_aux0 : forall (fexp1 fexp2 : Z -> Z), Valid_exp fexp1 -> - double_round_plus_hyp fexp1 fexp2 -> + round_round_plus_hyp fexp1 fexp2 -> forall x y, (0 < x)%R -> (0 < y)%R -> (y <= x)%R -> - (fexp1 (ln_beta x) - 1 <= ln_beta y)%Z -> + (fexp1 (mag x) - 1 <= mag y)%Z -> generic_format beta fexp1 x -> generic_format beta fexp1 y -> generic_format beta fexp2 (x + y). Proof. intros fexp1 fexp2 Vfexp1 Hexp x y Px Py Hyx Hln Fx Fy. assert (Nny : (0 <= y)%R); [now apply Rlt_le|]. destruct Hexp as (_,(Hexp2,(Hexp3,Hexp4))). -destruct (Z.le_gt_cases (ln_beta y) (fexp1 (ln_beta x))) as [Hle|Hgt]. -- (* ln_beta y <= fexp1 (ln_beta x) *) - assert (Lxy : ln_beta (x + y) = ln_beta x :> Z); - [now apply (ln_beta_plus_separated fexp1)|]. - apply (double_round_plus_aux0_aux fexp1); +destruct (Z.le_gt_cases (mag y) (fexp1 (mag x))) as [Hle|Hgt]. +- (* mag y <= fexp1 (mag x) *) + assert (Lxy : mag (x + y) = mag x :> Z); + [now apply (mag_plus_separated fexp1)|]. + apply (round_round_plus_aux0_aux fexp1); [| |assumption|assumption]; rewrite Lxy. + now apply Hexp4; omega. + now apply Hexp3; omega. -- (* fexp1 (ln_beta x) < ln_beta y *) - apply (double_round_plus_aux0_aux fexp1); [| |assumption|assumption]. - destruct (ln_beta_plus_disj x y Py Hyx) as [Lxy|Lxy]; rewrite Lxy. +- (* fexp1 (mag x) < mag y *) + apply (round_round_plus_aux0_aux fexp1); [| |assumption|assumption]. + destruct (mag_plus_disj x y Py Hyx) as [Lxy|Lxy]; rewrite Lxy. + now apply Hexp4; omega. - + apply Hexp2; apply (ln_beta_le beta y x Py) in Hyx. - replace (_ - _)%Z with (ln_beta x : Z) by ring. + + apply Hexp2; apply (mag_le beta y x Py) in Hyx. + replace (_ - _)%Z with (mag x : Z) by ring. omega. - + destruct (ln_beta_plus_disj x y Py Hyx) as [Lxy|Lxy]; rewrite Lxy. + + destruct (mag_plus_disj x y Py Hyx) as [Lxy|Lxy]; rewrite Lxy. * now apply Hexp3; omega. * apply Hexp2. - replace (_ - _)%Z with (ln_beta x : Z) by ring. + replace (_ - _)%Z with (mag x : Z) by ring. omega. Qed. -Lemma double_round_plus_aux1_aux : +Lemma round_round_plus_aux1_aux : forall k, (0 < k)%Z -> forall (fexp : Z -> Z), forall x y, 0 < x -> 0 < y -> - (ln_beta y <= fexp (ln_beta x) - k)%Z -> - (ln_beta (x + y) = ln_beta x :> Z) -> + (mag y <= fexp (mag x) - k)%Z -> + (mag (x + y) = mag x :> Z) -> generic_format beta fexp x -> - 0 < (x + y) - round beta fexp Zfloor (x + y) < bpow (fexp (ln_beta x) - k). + 0 < (x + y) - round beta fexp Zfloor (x + y) < bpow (fexp (mag x) - k). Proof. assert (Hbeta : (2 <= beta)%Z). { destruct beta as (beta_val,beta_prop). now apply Zle_bool_imp_le. } intros k Hk fexp x y Px Py Hln Hlxy Fx. revert Fx. -unfold round, generic_format, F2R, scaled_mantissa, canonic_exp; simpl. +unfold round, generic_format, F2R, scaled_mantissa, cexp; simpl. rewrite Hlxy. -set (mx := Ztrunc (x * bpow (- fexp (ln_beta x)))). +set (mx := Ztrunc (x * bpow (- fexp (mag x)))). intros Fx. -assert (R : (x + y) * bpow (- fexp (ln_beta x)) - = Z2R mx + y * bpow (- fexp (ln_beta x))). +assert (R : (x + y) * bpow (- fexp (mag x)) + = IZR mx + y * bpow (- fexp (mag x))). { rewrite Fx at 1. rewrite Rmult_plus_distr_r. now bpow_simplify. } rewrite R. -assert (LB : 0 < y * bpow (- fexp (ln_beta x))). +assert (LB : 0 < y * bpow (- fexp (mag x))). { rewrite <- (Rmult_0_r y). now apply Rmult_lt_compat_l; [|apply bpow_gt_0]. } -assert (UB : y * bpow (- fexp (ln_beta x)) < / Z2R (beta ^ k)). -{ apply Rlt_le_trans with (bpow (ln_beta y) * bpow (- fexp (ln_beta x))). +assert (UB : y * bpow (- fexp (mag x)) < / IZR (beta ^ k)). +{ apply Rlt_le_trans with (bpow (mag y) * bpow (- fexp (mag x))). - apply Rmult_lt_compat_r; [now apply bpow_gt_0|]. rewrite <- (Rabs_right y) at 1; [|now apply Rle_ge; apply Rlt_le]. - apply bpow_ln_beta_gt. - - apply Rle_trans with (bpow (fexp (ln_beta x) - k) - * bpow (- fexp (ln_beta x)))%R. + apply bpow_mag_gt. + - apply Rle_trans with (bpow (fexp (mag x) - k) + * bpow (- fexp (mag x)))%R. + apply Rmult_le_compat_r; [now apply bpow_ge_0|]. now apply bpow_le. + bpow_simplify. rewrite bpow_opp. destruct k. * omega. - * simpl; unfold Fcore_Raux.bpow, Z.pow_pos. + * simpl; unfold Raux.bpow, Z.pow_pos. now apply Rle_refl. - * casetype False; apply (Zlt_irrefl 0). - apply (Zlt_trans _ _ _ Hk). + * casetype False; apply (Z.lt_irrefl 0). + apply (Z.lt_trans _ _ _ Hk). apply Zlt_neg_0. } rewrite (Zfloor_imp mx). { split; ring_simplify. - - apply (Rmult_lt_reg_r (bpow (- fexp (ln_beta x)))); [now apply bpow_gt_0|]. + - apply (Rmult_lt_reg_r (bpow (- fexp (mag x)))); [now apply bpow_gt_0|]. rewrite Rmult_minus_distr_r, Rmult_0_l. bpow_simplify. rewrite R; ring_simplify. now apply Rmult_lt_0_compat; [|apply bpow_gt_0]. - - apply (Rmult_lt_reg_r (bpow (- fexp (ln_beta x)))); [now apply bpow_gt_0|]. + - apply (Rmult_lt_reg_r (bpow (- fexp (mag x)))); [now apply bpow_gt_0|]. rewrite Rmult_minus_distr_r. bpow_simplify. rewrite R; ring_simplify. apply (Rlt_le_trans _ _ _ UB). rewrite bpow_opp. apply Rinv_le; [now apply bpow_gt_0|]. - now rewrite Z2R_Zpower; [right|omega]. } + now rewrite IZR_Zpower; [right|omega]. } split. - rewrite <- Rplus_0_r at 1; apply Rplus_le_compat_l. now apply Rlt_le. -- rewrite Z2R_plus; apply Rplus_lt_compat_l. - apply (Rmult_lt_reg_r (bpow (fexp (ln_beta x)))); [now apply bpow_gt_0|]. +- rewrite plus_IZR; apply Rplus_lt_compat_l. + apply (Rmult_lt_reg_r (bpow (fexp (mag x)))); [now apply bpow_gt_0|]. rewrite Rmult_1_l. bpow_simplify. - apply Rlt_trans with (bpow (ln_beta y)). + apply Rlt_trans with (bpow (mag y)). + rewrite <- Rabs_right at 1; [|now apply Rle_ge; apply Rlt_le]. - apply bpow_ln_beta_gt. + apply bpow_mag_gt. + apply bpow_lt; omega. Qed. -(* ln_beta y <= fexp1 (ln_beta x) - 2 : double_round_lt_mid applies. *) -Lemma double_round_plus_aux1 : +(* mag y <= fexp1 (mag x) - 2 : round_round_lt_mid applies. *) +Lemma round_round_plus_aux1 : forall (fexp1 fexp2 : Z -> Z), Valid_exp fexp1 -> Valid_exp fexp2 -> forall (choice1 choice2 : Z -> bool), - double_round_plus_hyp fexp1 fexp2 -> + round_round_plus_hyp fexp1 fexp2 -> forall x y, 0 < x -> 0 < y -> - (ln_beta y <= fexp1 (ln_beta x) - 2)%Z -> + (mag y <= fexp1 (mag x) - 2)%Z -> generic_format beta fexp1 x -> - double_round_eq fexp1 fexp2 choice1 choice2 (x + y). + round_round_eq fexp1 fexp2 choice1 choice2 (x + y). Proof. assert (Hbeta : (2 <= beta)%Z). { destruct beta as (beta_val,beta_prop). now apply Zle_bool_imp_le. } intros fexp1 fexp2 Vfexp1 Vfexp2 choice1 choice2 Hexp x y Px Py Hly Fx. -assert (Lxy : ln_beta (x + y) = ln_beta x :> Z); - [now apply (ln_beta_plus_separated fexp1); [|apply Rlt_le| |omega]|]. +assert (Lxy : mag (x + y) = mag x :> Z); + [now apply (mag_plus_separated fexp1); [|apply Rlt_le| |omega]|]. destruct Hexp as (_,(_,(_,Hexp4))). -assert (Hf2 : (fexp2 (ln_beta x) <= fexp1 (ln_beta x))%Z); +assert (Hf2 : (fexp2 (mag x) <= fexp1 (mag x))%Z); [now apply Hexp4; omega|]. assert (Bpow2 : bpow (- 2) <= / 2 * / 2). { replace (/2 * /2) with (/4) by field. rewrite (bpow_opp _ 2). apply Rinv_le; [lra|]. - apply (Z2R_le (2 * 2) (beta * (beta * 1))). + apply (IZR_le (2 * 2) (beta * (beta * 1))). rewrite Zmult_1_r. now apply Zmult_le_compat; omega. } assert (P2 : (0 < 2)%Z) by omega. -unfold double_round_eq. -apply double_round_lt_mid. +unfold round_round_eq. +apply round_round_lt_mid. - exact Vfexp1. - exact Vfexp2. - lra. - now rewrite Lxy. - rewrite Lxy. - assert (fexp1 (ln_beta x) < ln_beta x)%Z; [|omega]. - now apply ln_beta_generic_gt; [|apply Rgt_not_eq|]. + assert (fexp1 (mag x) < mag x)%Z; [|omega]. + now apply mag_generic_gt; [|apply Rgt_not_eq|]. - unfold midp. apply (Rplus_lt_reg_r (- round beta fexp1 Zfloor (x + y))). - apply (Rlt_le_trans _ _ _ (proj2 (double_round_plus_aux1_aux 2 P2 fexp1 x y Px + apply (Rlt_le_trans _ _ _ (proj2 (round_round_plus_aux1_aux 2 P2 fexp1 x y Px Py Hly Lxy Fx))). ring_simplify. rewrite ulp_neq_0;[idtac|now apply Rgt_not_eq, Rplus_lt_0_compat]. - unfold canonic_exp; rewrite Lxy. - apply (Rmult_le_reg_r (bpow (- fexp1 (ln_beta x)))); [now apply bpow_gt_0|]. + unfold cexp; rewrite Lxy. + apply (Rmult_le_reg_r (bpow (- fexp1 (mag x)))); [now apply bpow_gt_0|]. bpow_simplify. apply (Rle_trans _ _ _ Bpow2). rewrite <- (Rmult_1_r (/ 2)) at 3. apply Rmult_le_compat_l; lra. - rewrite ulp_neq_0;[idtac|now apply Rgt_not_eq, Rplus_lt_0_compat]. - unfold round, F2R, scaled_mantissa, canonic_exp; simpl; rewrite Lxy. + unfold round, F2R, scaled_mantissa, cexp; simpl; rewrite Lxy. intro Hf2'. - apply (Rmult_lt_reg_r (bpow (- fexp1 (ln_beta x)))); + apply (Rmult_lt_reg_r (bpow (- fexp1 (mag x)))); [now apply bpow_gt_0|]. - apply (Rmult_lt_reg_r (bpow (fexp1 (ln_beta x)))); [now apply bpow_gt_0|]. + apply (Rmult_lt_reg_r (bpow (fexp1 (mag x)))); [now apply bpow_gt_0|]. bpow_simplify. apply (Rplus_lt_reg_r (- round beta fexp1 Zfloor (x + y))). unfold midp; ring_simplify. - apply (Rlt_le_trans _ _ _ (proj2 (double_round_plus_aux1_aux 2 P2 fexp1 x y Px + apply (Rlt_le_trans _ _ _ (proj2 (round_round_plus_aux1_aux 2 P2 fexp1 x y Px Py Hly Lxy Fx))). - apply (Rmult_le_reg_r (bpow (- fexp1 (ln_beta x)))); [now apply bpow_gt_0|]. + apply (Rmult_le_reg_r (bpow (- fexp1 (mag x)))); [now apply bpow_gt_0|]. rewrite ulp_neq_0;[idtac|now apply Rgt_not_eq, Rplus_lt_0_compat]. - unfold canonic_exp; rewrite Lxy, Rmult_minus_distr_r; bpow_simplify. + unfold cexp; rewrite Lxy, Rmult_minus_distr_r; bpow_simplify. apply (Rle_trans _ _ _ Bpow2). rewrite <- (Rmult_1_r (/ 2)) at 3; rewrite <- Rmult_minus_distr_l. apply Rmult_le_compat_l; [lra|]. @@ -1089,49 +1089,49 @@ apply double_round_lt_mid. apply Ropp_le_contravar. { apply Rle_trans with (bpow (- 1)). - apply bpow_le; omega. - - unfold Fcore_Raux.bpow, Z.pow_pos; simpl. + - unfold Raux.bpow, Z.pow_pos; simpl. apply Rinv_le; [lra|]. - change 2 with (Z2R 2); apply Z2R_le; omega. } + apply IZR_le; omega. } Qed. -(* double_round_plus_aux{0,1} together *) -Lemma double_round_plus_aux2 : +(* round_round_plus_aux{0,1} together *) +Lemma round_round_plus_aux2 : forall (fexp1 fexp2 : Z -> Z), Valid_exp fexp1 -> Valid_exp fexp2 -> forall (choice1 choice2 : Z -> bool), - double_round_plus_hyp fexp1 fexp2 -> + round_round_plus_hyp fexp1 fexp2 -> forall x y, 0 < x -> 0 < y -> y <= x -> generic_format beta fexp1 x -> generic_format beta fexp1 y -> - double_round_eq fexp1 fexp2 choice1 choice2 (x + y). + round_round_eq fexp1 fexp2 choice1 choice2 (x + y). Proof. intros fexp1 fexp2 Vfexp1 Vfexp2 choice1 choice2 Hexp x y Px Py Hyx Fx Fy. -unfold double_round_eq. -destruct (Zle_or_lt (ln_beta y) (fexp1 (ln_beta x) - 2)) as [Hly|Hly]. -- (* ln_beta y <= fexp1 (ln_beta x) - 2 *) - now apply double_round_plus_aux1. -- (* fexp1 (ln_beta x) - 2 < ln_beta y *) +unfold round_round_eq. +destruct (Zle_or_lt (mag y) (fexp1 (mag x) - 2)) as [Hly|Hly]. +- (* mag y <= fexp1 (mag x) - 2 *) + now apply round_round_plus_aux1. +- (* fexp1 (mag x) - 2 < mag y *) rewrite (round_generic beta fexp2). + reflexivity. + now apply valid_rnd_N. - + assert (Hf1 : (fexp1 (ln_beta x) - 1 <= ln_beta y)%Z); [omega|]. - now apply (double_round_plus_aux0 fexp1). + + assert (Hf1 : (fexp1 (mag x) - 1 <= mag y)%Z); [omega|]. + now apply (round_round_plus_aux0 fexp1). Qed. -Lemma double_round_plus_aux : +Lemma round_round_plus_aux : forall (fexp1 fexp2 : Z -> Z), Valid_exp fexp1 -> Valid_exp fexp2 -> forall (choice1 choice2 : Z -> bool), - double_round_plus_hyp fexp1 fexp2 -> + round_round_plus_hyp fexp1 fexp2 -> forall x y, 0 <= x -> 0 <= y -> generic_format beta fexp1 x -> generic_format beta fexp1 y -> - double_round_eq fexp1 fexp2 choice1 choice2 (x + y). + round_round_eq fexp1 fexp2 choice1 choice2 (x + y). Proof. intros fexp1 fexp2 Vfexp1 Vfexp2 choice1 choice2 Hexp x y Nnx Nny Fx Fy. -unfold double_round_eq. +unfold round_round_eq. destruct (Req_dec x 0) as [Zx|Nzx]. - (* x = 0 *) destruct Hexp as (_,(_,(_,Hexp4))). @@ -1139,7 +1139,7 @@ destruct (Req_dec x 0) as [Zx|Nzx]. rewrite (round_generic beta fexp2). + reflexivity. + now apply valid_rnd_N. - + apply (generic_inclusion_ln_beta beta fexp1). + + apply (generic_inclusion_mag beta fexp1). now intros _; apply Hexp4; omega. exact Fy. - (* x <> 0 *) @@ -1150,7 +1150,7 @@ destruct (Req_dec x 0) as [Zx|Nzx]. rewrite (round_generic beta fexp2). * reflexivity. * now apply valid_rnd_N. - * apply (generic_inclusion_ln_beta beta fexp1). + * apply (generic_inclusion_mag beta fexp1). now intros _; apply Hexp4; omega. exact Fx. + (* y <> 0 *) @@ -1160,118 +1160,118 @@ destruct (Req_dec x 0) as [Zx|Nzx]. * (* x < y *) apply Rlt_le in H. rewrite Rplus_comm. - now apply double_round_plus_aux2. - * now apply double_round_plus_aux2. + now apply round_round_plus_aux2. + * now apply round_round_plus_aux2. Qed. -Lemma double_round_minus_aux0_aux : +Lemma round_round_minus_aux0_aux : forall (fexp1 fexp2 : Z -> Z), forall x y, - (fexp2 (ln_beta (x - y))%Z <= fexp1 (ln_beta x))%Z -> - (fexp2 (ln_beta (x - y))%Z <= fexp1 (ln_beta y))%Z -> + (fexp2 (mag (x - y))%Z <= fexp1 (mag x))%Z -> + (fexp2 (mag (x - y))%Z <= fexp1 (mag y))%Z -> generic_format beta fexp1 x -> generic_format beta fexp1 y -> generic_format beta fexp2 (x - y). Proof. intros fexp1 fexp2 x y. replace (x - y)%R with (x + (- y))%R; [|ring]. intros Hlnx Hlny Fx Fy. -rewrite <- (ln_beta_opp beta y) in Hlny. +rewrite <- (mag_opp beta y) in Hlny. apply generic_format_opp in Fy. -now apply (double_round_plus_aux0_aux fexp1). +now apply (round_round_plus_aux0_aux fexp1). Qed. -(* fexp1 (ln_beta x) - 1 <= ln_beta y : +(* fexp1 (mag x) - 1 <= mag y : * substraction is exact in the largest precision (fexp2). *) -Lemma double_round_minus_aux0 : +Lemma round_round_minus_aux0 : forall (fexp1 fexp2 : Z -> Z), - double_round_plus_hyp fexp1 fexp2 -> + round_round_plus_hyp fexp1 fexp2 -> forall x y, 0 < y -> y < x -> - (fexp1 (ln_beta x) - 1 <= ln_beta y)%Z -> + (fexp1 (mag x) - 1 <= mag y)%Z -> generic_format beta fexp1 x -> generic_format beta fexp1 y -> generic_format beta fexp2 (x - y). Proof. intros fexp1 fexp2 Hexp x y Py Hyx Hln Fx Fy. assert (Px := Rlt_trans 0 y x Py Hyx). destruct Hexp as (Hexp1,(_,(Hexp3,Hexp4))). -assert (Lyx : (ln_beta y <= ln_beta x)%Z); - [now apply ln_beta_le; [|apply Rlt_le]|]. -destruct (Z.lt_ge_cases (ln_beta x - 2) (ln_beta y)) as [Hlt|Hge]. -- (* ln_beta x - 2 < ln_beta y *) - assert (Hor : (ln_beta y = ln_beta x :> Z) - \/ (ln_beta y = ln_beta x - 1 :> Z)%Z); [omega|]. +assert (Lyx : (mag y <= mag x)%Z); + [now apply mag_le; [|apply Rlt_le]|]. +destruct (Z.lt_ge_cases (mag x - 2) (mag y)) as [Hlt|Hge]. +- (* mag x - 2 < mag y *) + assert (Hor : (mag y = mag x :> Z) + \/ (mag y = mag x - 1 :> Z)%Z); [omega|]. destruct Hor as [Heq|Heqm1]. - + (* ln_beta y = ln_beta x *) - apply (double_round_minus_aux0_aux fexp1); [| |exact Fx|exact Fy]. + + (* mag y = mag x *) + apply (round_round_minus_aux0_aux fexp1); [| |exact Fx|exact Fy]. * apply Hexp4. - apply Zle_trans with (ln_beta (x - y)); [omega|]. - now apply ln_beta_minus. + apply Z.le_trans with (mag (x - y)); [omega|]. + now apply mag_minus. * rewrite Heq. apply Hexp4. - apply Zle_trans with (ln_beta (x - y)); [omega|]. - now apply ln_beta_minus. - + (* ln_beta y = ln_beta x - 1 *) - apply (double_round_minus_aux0_aux fexp1); [| |exact Fx|exact Fy]. + apply Z.le_trans with (mag (x - y)); [omega|]. + now apply mag_minus. + + (* mag y = mag x - 1 *) + apply (round_round_minus_aux0_aux fexp1); [| |exact Fx|exact Fy]. * apply Hexp4. - apply Zle_trans with (ln_beta (x - y)); [omega|]. - now apply ln_beta_minus. + apply Z.le_trans with (mag (x - y)); [omega|]. + now apply mag_minus. * rewrite Heqm1. apply Hexp4. apply Zplus_le_compat_r. - now apply ln_beta_minus. -- (* ln_beta y <= ln_beta x - 2 *) - destruct (ln_beta_minus_disj x y Px Py Hge) as [Lxmy|Lxmy]. - + (* ln_beta (x - y) = ln_beta x *) - apply (double_round_minus_aux0_aux fexp1); [| |exact Fx|exact Fy]. + now apply mag_minus. +- (* mag y <= mag x - 2 *) + destruct (mag_minus_disj x y Px Py Hge) as [Lxmy|Lxmy]. + + (* mag (x - y) = mag x *) + apply (round_round_minus_aux0_aux fexp1); [| |exact Fx|exact Fy]. * apply Hexp4. omega. * now rewrite Lxmy; apply Hexp3. - + (* ln_beta (x - y) = ln_beta x - 1 *) - apply (double_round_minus_aux0_aux fexp1); [| |exact Fx|exact Fy]; + + (* mag (x - y) = mag x - 1 *) + apply (round_round_minus_aux0_aux fexp1); [| |exact Fx|exact Fy]; rewrite Lxmy. * apply Hexp1. - replace (_ + _)%Z with (ln_beta x : Z); [|ring]. - now apply Zle_trans with (ln_beta y). + replace (_ + _)%Z with (mag x : Z); [|ring]. + now apply Z.le_trans with (mag y). * apply Hexp1. - now replace (_ + _)%Z with (ln_beta x : Z); [|ring]. + now replace (_ + _)%Z with (mag x : Z); [|ring]. Qed. -(* ln_beta y <= fexp1 (ln_beta x) - 2, - * fexp1 (ln_beta (x - y)) - 1 <= ln_beta y : +(* mag y <= fexp1 (mag x) - 2, + * fexp1 (mag (x - y)) - 1 <= mag y : * substraction is exact in the largest precision (fexp2). *) -Lemma double_round_minus_aux1 : +Lemma round_round_minus_aux1 : forall (fexp1 fexp2 : Z -> Z), Valid_exp fexp1 -> Valid_exp fexp2 -> - double_round_plus_hyp fexp1 fexp2 -> + round_round_plus_hyp fexp1 fexp2 -> forall x y, 0 < y -> y < x -> - (ln_beta y <= fexp1 (ln_beta x) - 2)%Z -> - (fexp1 (ln_beta (x - y)) - 1 <= ln_beta y)%Z -> + (mag y <= fexp1 (mag x) - 2)%Z -> + (fexp1 (mag (x - y)) - 1 <= mag y)%Z -> generic_format beta fexp1 x -> generic_format beta fexp1 y -> generic_format beta fexp2 (x - y). Proof. intros fexp1 fexp2 Vfexp1 Vfexp2 Hexp x y Py Hyx Hln Hln' Fx Fy. assert (Px := Rlt_trans 0 y x Py Hyx). destruct Hexp as (Hexp1,(Hexp2,(Hexp3,Hexp4))). -assert (Lyx : (ln_beta y <= ln_beta x)%Z); - [now apply ln_beta_le; [|apply Rlt_le]|]. -assert (Hfx : (fexp1 (ln_beta x) < ln_beta x)%Z); - [now apply ln_beta_generic_gt; [|apply Rgt_not_eq|]|]. -assert (Hfy : (fexp1 (ln_beta y) < ln_beta y)%Z); - [now apply ln_beta_generic_gt; [|apply Rgt_not_eq|]|]. -apply (double_round_minus_aux0_aux fexp1); [| |exact Fx|exact Fy]. -- apply Zle_trans with (fexp1 (ln_beta (x - y))). +assert (Lyx : (mag y <= mag x)%Z); + [now apply mag_le; [|apply Rlt_le]|]. +assert (Hfx : (fexp1 (mag x) < mag x)%Z); + [now apply mag_generic_gt; [|apply Rgt_not_eq|]|]. +assert (Hfy : (fexp1 (mag y) < mag y)%Z); + [now apply mag_generic_gt; [|apply Rgt_not_eq|]|]. +apply (round_round_minus_aux0_aux fexp1); [| |exact Fx|exact Fy]. +- apply Z.le_trans with (fexp1 (mag (x - y))). + apply Hexp4; omega. + omega. - now apply Hexp3. Qed. -Lemma double_round_minus_aux2_aux : +Lemma round_round_minus_aux2_aux : forall (fexp : Z -> Z), Valid_exp fexp -> forall x y, 0 < y -> y < x -> - (ln_beta y <= fexp (ln_beta x) - 1)%Z -> + (mag y <= fexp (mag x) - 1)%Z -> generic_format beta fexp x -> generic_format beta fexp y -> round beta fexp Zceil (x - y) - (x - y) <= y. @@ -1279,19 +1279,19 @@ Proof. intros fexp Vfexp x y Py Hxy Hly Fx Fy. assert (Px := Rlt_trans 0 y x Py Hxy). revert Fx. -unfold generic_format, F2R, scaled_mantissa, canonic_exp; simpl. -set (mx := Ztrunc (x * bpow (- fexp (ln_beta x)))). +unfold generic_format, F2R, scaled_mantissa, cexp; simpl. +set (mx := Ztrunc (x * bpow (- fexp (mag x)))). intro Fx. -assert (Hfx : (fexp (ln_beta x) < ln_beta x)%Z); - [now apply ln_beta_generic_gt; [|apply Rgt_not_eq|]|]. -assert (Hfy : (fexp (ln_beta y) < ln_beta y)%Z); - [now apply ln_beta_generic_gt; [|apply Rgt_not_eq|]|]. -destruct (Rlt_or_le (bpow (ln_beta x - 1)) x) as [Hx|Hx]. -- (* bpow (ln_beta x - 1) < x *) - assert (Lxy : ln_beta (x - y) = ln_beta x :> Z); - [now apply (ln_beta_minus_separated fexp); [| | | | | |omega]|]. +assert (Hfx : (fexp (mag x) < mag x)%Z); + [now apply mag_generic_gt; [|apply Rgt_not_eq|]|]. +assert (Hfy : (fexp (mag y) < mag y)%Z); + [now apply mag_generic_gt; [|apply Rgt_not_eq|]|]. +destruct (Rlt_or_le (bpow (mag x - 1)) x) as [Hx|Hx]. +- (* bpow (mag x - 1) < x *) + assert (Lxy : mag (x - y) = mag x :> Z); + [now apply (mag_minus_separated fexp); [| | | | | |omega]|]. assert (Rxy : round beta fexp Zceil (x - y) = x). - { unfold round, F2R, scaled_mantissa, canonic_exp; simpl. + { unfold round, F2R, scaled_mantissa, cexp; simpl. rewrite Lxy. apply eq_sym; rewrite Fx at 1; apply eq_sym. apply Rmult_eq_compat_r. @@ -1301,18 +1301,18 @@ destruct (Rlt_or_le (bpow (ln_beta x - 1)) x) as [Hx|Hx]. bpow_simplify. apply Zceil_imp. split. - - unfold Zminus; rewrite Z2R_plus. + - unfold Zminus; rewrite plus_IZR. apply Rplus_lt_compat_l. apply Ropp_lt_contravar; simpl. - apply (Rmult_lt_reg_r (bpow (fexp (ln_beta x)))); + apply (Rmult_lt_reg_r (bpow (fexp (mag x)))); [now apply bpow_gt_0|]. rewrite Rmult_1_l; bpow_simplify. - apply Rlt_le_trans with (bpow (ln_beta y)). + apply Rlt_le_trans with (bpow (mag y)). + rewrite <- Rabs_right at 1; [|now apply Rle_ge; apply Rlt_le]. - apply bpow_ln_beta_gt. + apply bpow_mag_gt. + apply bpow_le. omega. - - rewrite <- (Rplus_0_r (Z2R _)) at 2. + - rewrite <- (Rplus_0_r (IZR _)) at 2. apply Rplus_le_compat_l. rewrite <- Ropp_0; apply Ropp_le_contravar. rewrite <- (Rmult_0_r y). @@ -1320,34 +1320,34 @@ destruct (Rlt_or_le (bpow (ln_beta x - 1)) x) as [Hx|Hx]. now apply bpow_ge_0. } rewrite Rxy; ring_simplify. apply Rle_refl. -- (* x <= bpow (ln_beta x - 1) *) - assert (Xpow : x = bpow (ln_beta x - 1)). +- (* x <= bpow (mag x - 1) *) + assert (Xpow : x = bpow (mag x - 1)). { apply Rle_antisym; [exact Hx|]. - destruct (ln_beta x) as (ex, Hex); simpl. + destruct (mag x) as (ex, Hex); simpl. rewrite <- (Rabs_right x); [|now apply Rle_ge; apply Rlt_le]. apply Hex. now apply Rgt_not_eq. } - assert (Lxy : (ln_beta (x - y) = ln_beta x - 1 :> Z)%Z). + assert (Lxy : (mag (x - y) = mag x - 1 :> Z)%Z). { apply Zle_antisym. - - apply ln_beta_le_bpow. + - apply mag_le_bpow. + apply Rminus_eq_contra. now intro Hx'; rewrite Hx' in Hxy; apply (Rlt_irrefl y). + rewrite Rabs_right; lra. - - apply (ln_beta_minus_lb beta x y Px Py). + - apply (mag_minus_lb beta x y Px Py). omega. } - assert (Hfx1 : (fexp (ln_beta x - 1) < ln_beta x - 1)%Z); - [now apply (valid_exp_large fexp (ln_beta y)); [|omega]|]. + assert (Hfx1 : (fexp (mag x - 1) < mag x - 1)%Z); + [now apply (valid_exp_large fexp (mag y)); [|omega]|]. assert (Rxy : round beta fexp Zceil (x - y) <= x). { rewrite Xpow at 2. - unfold round, F2R, scaled_mantissa, canonic_exp; simpl. + unfold round, F2R, scaled_mantissa, cexp; simpl. rewrite Lxy. - apply (Rmult_le_reg_r (bpow (- fexp (ln_beta x - 1)%Z))); + apply (Rmult_le_reg_r (bpow (- fexp (mag x - 1)%Z))); [now apply bpow_gt_0|]. bpow_simplify. - rewrite <- (Z2R_Zpower beta (_ - _ - _)); [|omega]. - apply Z2R_le. + rewrite <- (IZR_Zpower beta (_ - _ - _)); [|omega]. + apply IZR_le. apply Zceil_glb. - rewrite Z2R_Zpower; [|omega]. + rewrite IZR_Zpower; [|omega]. rewrite Xpow at 1. rewrite Rmult_minus_distr_r. bpow_simplify. @@ -1360,21 +1360,21 @@ destruct (Rlt_or_le (bpow (ln_beta x - 1)) x) as [Hx|Hx]. lra. Qed. -(* ln_beta y <= fexp1 (ln_beta x) - 2 : - * ln_beta y <= fexp1 (ln_beta (x - y)) - 2 : - * double_round_gt_mid applies. *) -Lemma double_round_minus_aux2 : +(* mag y <= fexp1 (mag x) - 2 : + * mag y <= fexp1 (mag (x - y)) - 2 : + * round_round_gt_mid applies. *) +Lemma round_round_minus_aux2 : forall (fexp1 fexp2 : Z -> Z), Valid_exp fexp1 -> Valid_exp fexp2 -> forall (choice1 choice2 : Z -> bool), - double_round_plus_hyp fexp1 fexp2 -> + round_round_plus_hyp fexp1 fexp2 -> forall x y, 0 < y -> y < x -> - (ln_beta y <= fexp1 (ln_beta x) - 2)%Z -> - (ln_beta y <= fexp1 (ln_beta (x - y)) - 2)%Z -> + (mag y <= fexp1 (mag x) - 2)%Z -> + (mag y <= fexp1 (mag (x - y)) - 2)%Z -> generic_format beta fexp1 x -> generic_format beta fexp1 y -> - double_round_eq fexp1 fexp2 choice1 choice2 (x - y). + round_round_eq fexp1 fexp2 choice1 choice2 (x - y). Proof. assert (Hbeta : (2 <= beta)%Z). { destruct beta as (beta_val,beta_prop). @@ -1382,52 +1382,52 @@ assert (Hbeta : (2 <= beta)%Z). intros fexp1 fexp2 Vfexp1 Vfexp2 choice1 choice2 Hexp x y Py Hxy Hly Hly' Fx Fy. assert (Px := Rlt_trans 0 y x Py Hxy). destruct Hexp as (_,(_,(_,Hexp4))). -assert (Hf2 : (fexp2 (ln_beta x) <= fexp1 (ln_beta x))%Z); +assert (Hf2 : (fexp2 (mag x) <= fexp1 (mag x))%Z); [now apply Hexp4; omega|]. -assert (Hfx : (fexp1 (ln_beta x) < ln_beta x)%Z); - [now apply ln_beta_generic_gt; [|apply Rgt_not_eq|]|]. +assert (Hfx : (fexp1 (mag x) < mag x)%Z); + [now apply mag_generic_gt; [|apply Rgt_not_eq|]|]. assert (Bpow2 : bpow (- 2) <= / 2 * / 2). { replace (/2 * /2) with (/4) by field. rewrite (bpow_opp _ 2). apply Rinv_le; [lra|]. - apply (Z2R_le (2 * 2) (beta * (beta * 1))). + apply (IZR_le (2 * 2) (beta * (beta * 1))). rewrite Zmult_1_r. now apply Zmult_le_compat; omega. } -assert (Ly : y < bpow (ln_beta y)). +assert (Ly : y < bpow (mag y)). { apply Rabs_lt_inv. - apply bpow_ln_beta_gt. } -unfold double_round_eq. -apply double_round_gt_mid. + apply bpow_mag_gt. } +unfold round_round_eq. +apply round_round_gt_mid. - exact Vfexp1. - exact Vfexp2. - lra. - apply Hexp4; omega. -- assert (fexp1 (ln_beta (x - y)) < ln_beta (x - y))%Z; [|omega]. - apply (valid_exp_large fexp1 (ln_beta x - 1)). - + apply (valid_exp_large fexp1 (ln_beta y)); [|omega]. - now apply ln_beta_generic_gt; [|apply Rgt_not_eq|]. - + now apply ln_beta_minus_lb; [| |omega]. +- assert (fexp1 (mag (x - y)) < mag (x - y))%Z; [|omega]. + apply (valid_exp_large fexp1 (mag x - 1)). + + apply (valid_exp_large fexp1 (mag y)); [|omega]. + now apply mag_generic_gt; [|apply Rgt_not_eq|]. + + now apply mag_minus_lb; [| |omega]. - unfold midp'. apply (Rplus_lt_reg_r (/ 2 * ulp beta fexp1 (x - y) - (x - y))). ring_simplify. replace (_ + _) with (round beta fexp1 Zceil (x - y) - (x - y)) by ring. - apply Rlt_le_trans with (bpow (fexp1 (ln_beta (x - y)) - 2)). + apply Rlt_le_trans with (bpow (fexp1 (mag (x - y)) - 2)). + apply Rle_lt_trans with y; - [now apply double_round_minus_aux2_aux; try assumption; omega|]. + [now apply round_round_minus_aux2_aux; try assumption; omega|]. apply (Rlt_le_trans _ _ _ Ly). now apply bpow_le. + rewrite ulp_neq_0;[idtac|now apply sym_not_eq, Rlt_not_eq, Rgt_minus]. - unfold canonic_exp. - replace (_ - 2)%Z with (fexp1 (ln_beta (x - y)) - 1 - 1)%Z by ring. + unfold cexp. + replace (_ - 2)%Z with (fexp1 (mag (x - y)) - 1 - 1)%Z by ring. unfold Zminus at 1; rewrite bpow_plus. rewrite Rmult_comm. apply Rmult_le_compat. * now apply bpow_ge_0. * now apply bpow_ge_0. - * unfold Fcore_Raux.bpow, Z.pow_pos; simpl. + * unfold Raux.bpow, Z.pow_pos; simpl. rewrite Zmult_1_r; apply Rinv_le. lra. - now change 2 with (Z2R 2); apply Z2R_le. + now apply IZR_le. * apply bpow_le; omega. - intro Hf2'. unfold midp'. @@ -1436,53 +1436,53 @@ apply double_round_gt_mid. ring_simplify. replace (_ + _) with (round beta fexp1 Zceil (x - y) - (x - y)) by ring. apply Rle_lt_trans with y; - [now apply double_round_minus_aux2_aux; try assumption; omega|]. + [now apply round_round_minus_aux2_aux; try assumption; omega|]. apply (Rlt_le_trans _ _ _ Ly). - apply Rle_trans with (bpow (fexp1 (ln_beta (x - y)) - 2)); + apply Rle_trans with (bpow (fexp1 (mag (x - y)) - 2)); [now apply bpow_le|]. - replace (_ - 2)%Z with (fexp1 (ln_beta (x - y)) - 1 - 1)%Z by ring. + replace (_ - 2)%Z with (fexp1 (mag (x - y)) - 1 - 1)%Z by ring. unfold Zminus at 1; rewrite bpow_plus. rewrite <- Rmult_minus_distr_l. rewrite Rmult_comm; apply Rmult_le_compat. + apply bpow_ge_0. + apply bpow_ge_0. - + unfold Fcore_Raux.bpow, Z.pow_pos; simpl. + + unfold Raux.bpow, Z.pow_pos; simpl. rewrite Zmult_1_r; apply Rinv_le; [lra|]. - now change 2 with (Z2R 2); apply Z2R_le. + now apply IZR_le. + rewrite 2!ulp_neq_0; try now apply Rgt_not_eq, Rgt_minus. - unfold canonic_exp. - apply (Rplus_le_reg_r (bpow (fexp2 (ln_beta (x - y))))); ring_simplify. - apply Rle_trans with (2 * bpow (fexp1 (ln_beta (x - y)) - 1)). - * replace (2 * bpow (fexp1 (ln_beta (x - y)) - 1)) with (bpow (fexp1 (ln_beta (x - y)) - 1) + bpow (fexp1 (ln_beta (x - y)) - 1)) by ring. + unfold cexp. + apply (Rplus_le_reg_r (bpow (fexp2 (mag (x - y))))); ring_simplify. + apply Rle_trans with (2 * bpow (fexp1 (mag (x - y)) - 1)). + * rewrite double. apply Rplus_le_compat_l. now apply bpow_le. * unfold Zminus; rewrite bpow_plus. rewrite Rmult_comm; rewrite Rmult_assoc. rewrite <- Rmult_1_r. apply Rmult_le_compat_l; [now apply bpow_ge_0|]. - unfold Fcore_Raux.bpow, Z.pow_pos; simpl. + unfold Raux.bpow, Z.pow_pos; simpl. rewrite Zmult_1_r. - apply Z2R_le, Rinv_le in Hbeta. + apply IZR_le, Rinv_le in Hbeta. simpl in Hbeta. lra. apply Rlt_0_2. Qed. -(* double_round_minus_aux{0,1,2} together *) -Lemma double_round_minus_aux3 : +(* round_round_minus_aux{0,1,2} together *) +Lemma round_round_minus_aux3 : forall (fexp1 fexp2 : Z -> Z), Valid_exp fexp1 -> Valid_exp fexp2 -> forall (choice1 choice2 : Z -> bool), - double_round_plus_hyp fexp1 fexp2 -> + round_round_plus_hyp fexp1 fexp2 -> forall x y, 0 < y -> y <= x -> generic_format beta fexp1 x -> generic_format beta fexp1 y -> - double_round_eq fexp1 fexp2 choice1 choice2 (x - y). + round_round_eq fexp1 fexp2 choice1 choice2 (x - y). Proof. intros fexp1 fexp2 Vfexp1 Vfexp2 choice1 choice2 Hexp x y Py Hyx Fx Fy. assert (Px := Rlt_le_trans 0 y x Py Hyx). -unfold double_round_eq. +unfold round_round_eq. destruct (Req_dec y x) as [Hy|Hy]. - (* y = x *) rewrite Hy; replace (x - x) with 0 by ring. @@ -1491,38 +1491,38 @@ destruct (Req_dec y x) as [Hy|Hy]. + now apply valid_rnd_N. - (* y < x *) assert (Hyx' : y < x); [lra|]. - destruct (Zle_or_lt (ln_beta y) (fexp1 (ln_beta x) - 2)) as [Hly|Hly]. - + (* ln_beta y <= fexp1 (ln_beta x) - 2 *) - destruct (Zle_or_lt (ln_beta y) (fexp1 (ln_beta (x - y)) - 2)) + destruct (Zle_or_lt (mag y) (fexp1 (mag x) - 2)) as [Hly|Hly]. + + (* mag y <= fexp1 (mag x) - 2 *) + destruct (Zle_or_lt (mag y) (fexp1 (mag (x - y)) - 2)) as [Hly'|Hly']. - * (* ln_beta y <= fexp1 (ln_beta (x - y)) - 2 *) - now apply double_round_minus_aux2. - * (* fexp1 (ln_beta (x - y)) - 2 < ln_beta y *) + * (* mag y <= fexp1 (mag (x - y)) - 2 *) + now apply round_round_minus_aux2. + * (* fexp1 (mag (x - y)) - 2 < mag y *) { rewrite (round_generic beta fexp2). - reflexivity. - now apply valid_rnd_N. - - assert (Hf1 : (fexp1 (ln_beta (x - y)) - 1 <= ln_beta y)%Z); [omega|]. - now apply (double_round_minus_aux1 fexp1). } + - assert (Hf1 : (fexp1 (mag (x - y)) - 1 <= mag y)%Z); [omega|]. + now apply (round_round_minus_aux1 fexp1). } + rewrite (round_generic beta fexp2). * reflexivity. * now apply valid_rnd_N. - * assert (Hf1 : (fexp1 (ln_beta x) - 1 <= ln_beta y)%Z); [omega|]. - now apply (double_round_minus_aux0 fexp1). + * assert (Hf1 : (fexp1 (mag x) - 1 <= mag y)%Z); [omega|]. + now apply (round_round_minus_aux0 fexp1). Qed. -Lemma double_round_minus_aux : +Lemma round_round_minus_aux : forall (fexp1 fexp2 : Z -> Z), Valid_exp fexp1 -> Valid_exp fexp2 -> forall (choice1 choice2 : Z -> bool), - double_round_plus_hyp fexp1 fexp2 -> + round_round_plus_hyp fexp1 fexp2 -> forall x y, 0 <= x -> 0 <= y -> generic_format beta fexp1 x -> generic_format beta fexp1 y -> - double_round_eq fexp1 fexp2 choice1 choice2 (x - y). + round_round_eq fexp1 fexp2 choice1 choice2 (x - y). Proof. intros fexp1 fexp2 Vfexp1 Vfexp2 choice1 choice2 Hexp x y Nnx Nny Fx Fy. -unfold double_round_eq. +unfold round_round_eq. destruct (Req_dec x 0) as [Zx|Nzx]. - (* x = 0 *) rewrite Zx; unfold Rminus; rewrite Rplus_0_l. @@ -1530,7 +1530,7 @@ destruct (Req_dec x 0) as [Zx|Nzx]. rewrite (round_generic beta fexp2). * reflexivity. * now apply valid_rnd_N. - * apply (generic_inclusion_ln_beta beta fexp1). + * apply (generic_inclusion_mag beta fexp1). destruct Hexp as (_,(_,(_,Hexp4))). now intros _; apply Hexp4; omega. exact Fy. @@ -1541,7 +1541,7 @@ destruct (Req_dec x 0) as [Zx|Nzx]. rewrite (round_generic beta fexp2). * reflexivity. * now apply valid_rnd_N. - * apply (generic_inclusion_ln_beta beta fexp1). + * apply (generic_inclusion_mag beta fexp1). destruct Hexp as (_,(_,(_,Hexp4))). now intros _; apply Hexp4; omega. exact Fx. @@ -1554,23 +1554,23 @@ destruct (Req_dec x 0) as [Zx|Nzx]. replace (x - y) with (- (y - x)) by ring. do 3 rewrite round_N_opp. apply Ropp_eq_compat. - now apply double_round_minus_aux3. + now apply round_round_minus_aux3. * (* y <= x *) - now apply double_round_minus_aux3. + now apply round_round_minus_aux3. Qed. -Lemma double_round_plus : +Lemma round_round_plus : forall (fexp1 fexp2 : Z -> Z), Valid_exp fexp1 -> Valid_exp fexp2 -> forall (choice1 choice2 : Z -> bool), - double_round_plus_hyp fexp1 fexp2 -> + round_round_plus_hyp fexp1 fexp2 -> forall x y, generic_format beta fexp1 x -> generic_format beta fexp1 y -> - double_round_eq fexp1 fexp2 choice1 choice2 (x + y). + round_round_eq fexp1 fexp2 choice1 choice2 (x + y). Proof. intros fexp1 fexp2 Vfexp1 Vfexp2 choice1 choice2 Hexp x y Fx Fy. -unfold double_round_eq. +unfold round_round_eq. destruct (Rlt_or_le x 0) as [Sx|Sx]; destruct (Rlt_or_le y 0) as [Sy|Sy]. - (* x < 0, y < 0 *) replace (x + y) with (- (- x - y)); [|ring]. @@ -1580,87 +1580,85 @@ destruct (Rlt_or_le x 0) as [Sx|Sx]; destruct (Rlt_or_le y 0) as [Sy|Sy]. assert (Py : 0 <= - y); [lra|]. apply generic_format_opp in Fx. apply generic_format_opp in Fy. - now apply double_round_plus_aux. + now apply round_round_plus_aux. - (* x < 0, 0 <= y *) replace (x + y) with (y - (- x)); [|ring]. assert (Px : 0 <= - x); [lra|]. apply generic_format_opp in Fx. - now apply double_round_minus_aux. + now apply round_round_minus_aux. - (* 0 <= x, y < 0 *) replace (x + y) with (x - (- y)); [|ring]. assert (Py : 0 <= - y); [lra|]. apply generic_format_opp in Fy. - now apply double_round_minus_aux. + now apply round_round_minus_aux. - (* 0 <= x, 0 <= y *) - now apply double_round_plus_aux. + now apply round_round_plus_aux. Qed. -Lemma double_round_minus : +Lemma round_round_minus : forall (fexp1 fexp2 : Z -> Z), Valid_exp fexp1 -> Valid_exp fexp2 -> forall (choice1 choice2 : Z -> bool), - double_round_plus_hyp fexp1 fexp2 -> + round_round_plus_hyp fexp1 fexp2 -> forall x y, generic_format beta fexp1 x -> generic_format beta fexp1 y -> - double_round_eq fexp1 fexp2 choice1 choice2 (x - y). + round_round_eq fexp1 fexp2 choice1 choice2 (x - y). Proof. intros fexp1 fexp2 Vfexp1 Vfexp2 choice1 choice2 Hexp x y Fx Fy. unfold Rminus. apply generic_format_opp in Fy. -now apply double_round_plus. +now apply round_round_plus. Qed. Section Double_round_plus_FLX. -Import Fcore_FLX. - Variable prec : Z. Variable prec' : Z. Context { prec_gt_0_ : Prec_gt_0 prec }. Context { prec_gt_0_' : Prec_gt_0 prec' }. -Lemma FLX_double_round_plus_hyp : +Lemma FLX_round_round_plus_hyp : (2 * prec + 1 <= prec')%Z -> - double_round_plus_hyp (FLX_exp prec) (FLX_exp prec'). + round_round_plus_hyp (FLX_exp prec) (FLX_exp prec'). Proof. intros Hprec. unfold FLX_exp. -unfold double_round_plus_hyp; split; [|split; [|split]]; +unfold round_round_plus_hyp; split; [|split; [|split]]; intros ex ey; try omega. unfold Prec_gt_0 in prec_gt_0_. omega. Qed. -Theorem double_round_plus_FLX : +Theorem round_round_plus_FLX : forall choice1 choice2, (2 * prec + 1 <= prec')%Z -> forall x y, FLX_format beta prec x -> FLX_format beta prec y -> - double_round_eq (FLX_exp prec) (FLX_exp prec') choice1 choice2 (x + y). + round_round_eq (FLX_exp prec) (FLX_exp prec') choice1 choice2 (x + y). Proof. intros choice1 choice2 Hprec x y Fx Fy. -apply double_round_plus. +apply round_round_plus. - now apply FLX_exp_valid. - now apply FLX_exp_valid. -- now apply FLX_double_round_plus_hyp. +- now apply FLX_round_round_plus_hyp. - now apply generic_format_FLX. - now apply generic_format_FLX. Qed. -Theorem double_round_minus_FLX : +Theorem round_round_minus_FLX : forall choice1 choice2, (2 * prec + 1 <= prec')%Z -> forall x y, FLX_format beta prec x -> FLX_format beta prec y -> - double_round_eq (FLX_exp prec) (FLX_exp prec') choice1 choice2 (x - y). + round_round_eq (FLX_exp prec) (FLX_exp prec') choice1 choice2 (x - y). Proof. intros choice1 choice2 Hprec x y Fx Fy. -apply double_round_minus. +apply round_round_minus. - now apply FLX_exp_valid. - now apply FLX_exp_valid. -- now apply FLX_double_round_plus_hyp. +- now apply FLX_round_round_plus_hyp. - now apply generic_format_FLX. - now apply generic_format_FLX. Qed. @@ -1669,22 +1667,19 @@ End Double_round_plus_FLX. Section Double_round_plus_FLT. -Import Fcore_FLX. -Import Fcore_FLT. - Variable emin prec : Z. Variable emin' prec' : Z. Context { prec_gt_0_ : Prec_gt_0 prec }. Context { prec_gt_0_' : Prec_gt_0 prec' }. -Lemma FLT_double_round_plus_hyp : +Lemma FLT_round_round_plus_hyp : (emin' <= emin)%Z -> (2 * prec + 1 <= prec')%Z -> - double_round_plus_hyp (FLT_exp emin prec) (FLT_exp emin' prec'). + round_round_plus_hyp (FLT_exp emin prec) (FLT_exp emin' prec'). Proof. intros Hemin Hprec. unfold FLT_exp. -unfold double_round_plus_hyp; split; [|split; [|split]]; intros ex ey. +unfold round_round_plus_hyp; split; [|split; [|split]]; intros ex ey. - generalize (Zmax_spec (ex + 1 - prec) emin). generalize (Zmax_spec (ex - prec') emin'). generalize (Zmax_spec (ey - prec) emin). @@ -1703,36 +1698,36 @@ unfold double_round_plus_hyp; split; [|split; [|split]]; intros ex ey. omega. Qed. -Theorem double_round_plus_FLT : +Theorem round_round_plus_FLT : forall choice1 choice2, (emin' <= emin)%Z -> (2 * prec + 1 <= prec')%Z -> forall x y, FLT_format beta emin prec x -> FLT_format beta emin prec y -> - double_round_eq (FLT_exp emin prec) (FLT_exp emin' prec') + round_round_eq (FLT_exp emin prec) (FLT_exp emin' prec') choice1 choice2 (x + y). Proof. intros choice1 choice2 Hemin Hprec x y Fx Fy. -apply double_round_plus. +apply round_round_plus. - now apply FLT_exp_valid. - now apply FLT_exp_valid. -- now apply FLT_double_round_plus_hyp. +- now apply FLT_round_round_plus_hyp. - now apply generic_format_FLT. - now apply generic_format_FLT. Qed. -Theorem double_round_minus_FLT : +Theorem round_round_minus_FLT : forall choice1 choice2, (emin' <= emin)%Z -> (2 * prec + 1 <= prec')%Z -> forall x y, FLT_format beta emin prec x -> FLT_format beta emin prec y -> - double_round_eq (FLT_exp emin prec) (FLT_exp emin' prec') + round_round_eq (FLT_exp emin prec) (FLT_exp emin' prec') choice1 choice2 (x - y). Proof. intros choice1 choice2 Hemin Hprec x y Fx Fy. -apply double_round_minus. +apply round_round_minus. - now apply FLT_exp_valid. - now apply FLT_exp_valid. -- now apply FLT_double_round_plus_hyp. +- now apply FLT_round_round_plus_hyp. - now apply generic_format_FLT. - now apply generic_format_FLT. Qed. @@ -1741,23 +1736,20 @@ End Double_round_plus_FLT. Section Double_round_plus_FTZ. -Import Fcore_FLX. -Import Fcore_FTZ. - Variable emin prec : Z. Variable emin' prec' : Z. Context { prec_gt_0_ : Prec_gt_0 prec }. Context { prec_gt_0_' : Prec_gt_0 prec' }. -Lemma FTZ_double_round_plus_hyp : +Lemma FTZ_round_round_plus_hyp : (emin' + prec' <= emin + 1)%Z -> (2 * prec + 1 <= prec')%Z -> - double_round_plus_hyp (FTZ_exp emin prec) (FTZ_exp emin' prec'). + round_round_plus_hyp (FTZ_exp emin prec) (FTZ_exp emin' prec'). Proof. intros Hemin Hprec. unfold FTZ_exp. unfold Prec_gt_0 in *. -unfold double_round_plus_hyp; split; [|split; [|split]]; intros ex ey. +unfold round_round_plus_hyp; split; [|split; [|split]]; intros ex ey. - destruct (Z.ltb_spec (ex + 1 - prec) emin); destruct (Z.ltb_spec (ex - prec') emin'); destruct (Z.ltb_spec (ey - prec) emin); @@ -1775,58 +1767,58 @@ unfold double_round_plus_hyp; split; [|split; [|split]]; intros ex ey. omega. Qed. -Theorem double_round_plus_FTZ : +Theorem round_round_plus_FTZ : forall choice1 choice2, (emin' + prec' <= emin + 1)%Z -> (2 * prec + 1 <= prec')%Z -> forall x y, FTZ_format beta emin prec x -> FTZ_format beta emin prec y -> - double_round_eq (FTZ_exp emin prec) (FTZ_exp emin' prec') + round_round_eq (FTZ_exp emin prec) (FTZ_exp emin' prec') choice1 choice2 (x + y). Proof. intros choice1 choice2 Hemin Hprec x y Fx Fy. -apply double_round_plus. +apply round_round_plus. - now apply FTZ_exp_valid. - now apply FTZ_exp_valid. -- now apply FTZ_double_round_plus_hyp. +- now apply FTZ_round_round_plus_hyp. - now apply generic_format_FTZ. - now apply generic_format_FTZ. Qed. -Theorem double_round_minus_FTZ : +Theorem round_round_minus_FTZ : forall choice1 choice2, (emin' + prec' <= emin + 1)%Z -> (2 * prec + 1 <= prec')%Z -> forall x y, FTZ_format beta emin prec x -> FTZ_format beta emin prec y -> - double_round_eq (FTZ_exp emin prec) (FTZ_exp emin' prec') + round_round_eq (FTZ_exp emin prec) (FTZ_exp emin' prec') choice1 choice2 (x - y). Proof. intros choice1 choice2 Hemin Hprec x y Fx Fy. -apply double_round_minus. +apply round_round_minus. - now apply FTZ_exp_valid. - now apply FTZ_exp_valid. -- now apply FTZ_double_round_plus_hyp. +- now apply FTZ_round_round_plus_hyp. - now apply generic_format_FTZ. - now apply generic_format_FTZ. Qed. End Double_round_plus_FTZ. -Section Double_round_plus_beta_ge_3. +Section Double_round_plus_radix_ge_3. -Definition double_round_plus_beta_ge_3_hyp fexp1 fexp2 := +Definition round_round_plus_radix_ge_3_hyp fexp1 fexp2 := (forall ex ey, (fexp1 (ex + 1) <= ey)%Z -> (fexp2 ex <= fexp1 ey)%Z) /\ (forall ex ey, (fexp1 (ex - 1) + 1 <= ey)%Z -> (fexp2 ex <= fexp1 ey)%Z) /\ (forall ex ey, (fexp1 ex <= ey)%Z -> (fexp2 ex <= fexp1 ey)%Z) /\ (forall ex ey, (ex - 1 <= ey)%Z -> (fexp2 ex <= fexp1 ey)%Z). -(* fexp1 (ln_beta x) <= ln_beta y : +(* fexp1 (mag x) <= mag y : * addition is exact in the largest precision (fexp2). *) -Lemma double_round_plus_beta_ge_3_aux0 : +Lemma round_round_plus_radix_ge_3_aux0 : forall (fexp1 fexp2 : Z -> Z), Valid_exp fexp1 -> - double_round_plus_beta_ge_3_hyp fexp1 fexp2 -> + round_round_plus_radix_ge_3_hyp fexp1 fexp2 -> forall x y, (0 < y)%R -> (y <= x)%R -> - (fexp1 (ln_beta x) <= ln_beta y)%Z -> + (fexp1 (mag x) <= mag y)%Z -> generic_format beta fexp1 x -> generic_format beta fexp1 y -> generic_format beta fexp2 (x + y). Proof. @@ -1834,84 +1826,84 @@ intros fexp1 fexp2 Vfexp1 Hexp x y Py Hyx Hln Fx Fy. assert (Px := Rlt_le_trans 0 y x Py Hyx). assert (Nny : (0 <= y)%R); [now apply Rlt_le|]. destruct Hexp as (_,(Hexp2,(Hexp3,Hexp4))). -destruct (Z.le_gt_cases (ln_beta y) (fexp1 (ln_beta x))) as [Hle|Hgt]. -- (* ln_beta y <= fexp1 (ln_beta x) *) - assert (Lxy : ln_beta (x + y) = ln_beta x :> Z); - [now apply (ln_beta_plus_separated fexp1)|]. - apply (double_round_plus_aux0_aux fexp1); +destruct (Z.le_gt_cases (mag y) (fexp1 (mag x))) as [Hle|Hgt]. +- (* mag y <= fexp1 (mag x) *) + assert (Lxy : mag (x + y) = mag x :> Z); + [now apply (mag_plus_separated fexp1)|]. + apply (round_round_plus_aux0_aux fexp1); [| |assumption|assumption]; rewrite Lxy. + now apply Hexp4; omega. + now apply Hexp3; omega. -- (* fexp1 (ln_beta x) < ln_beta y *) - apply (double_round_plus_aux0_aux fexp1); [| |assumption|assumption]. - destruct (ln_beta_plus_disj x y Py Hyx) as [Lxy|Lxy]; rewrite Lxy. +- (* fexp1 (mag x) < mag y *) + apply (round_round_plus_aux0_aux fexp1); [| |assumption|assumption]. + destruct (mag_plus_disj x y Py Hyx) as [Lxy|Lxy]; rewrite Lxy. + now apply Hexp4; omega. - + apply Hexp2; apply (ln_beta_le beta y x Py) in Hyx. - replace (_ - _)%Z with (ln_beta x : Z) by ring. + + apply Hexp2; apply (mag_le beta y x Py) in Hyx. + replace (_ - _)%Z with (mag x : Z) by ring. omega. - + destruct (ln_beta_plus_disj x y Py Hyx) as [Lxy|Lxy]; rewrite Lxy. + + destruct (mag_plus_disj x y Py Hyx) as [Lxy|Lxy]; rewrite Lxy. * now apply Hexp3; omega. * apply Hexp2. - replace (_ - _)%Z with (ln_beta x : Z) by ring. + replace (_ - _)%Z with (mag x : Z) by ring. omega. Qed. -(* ln_beta y <= fexp1 (ln_beta x) - 1 : double_round_lt_mid applies. *) -Lemma double_round_plus_beta_ge_3_aux1 : +(* mag y <= fexp1 (mag x) - 1 : round_round_lt_mid applies. *) +Lemma round_round_plus_radix_ge_3_aux1 : (3 <= beta)%Z -> forall (fexp1 fexp2 : Z -> Z), Valid_exp fexp1 -> Valid_exp fexp2 -> forall (choice1 choice2 : Z -> bool), - double_round_plus_beta_ge_3_hyp fexp1 fexp2 -> + round_round_plus_radix_ge_3_hyp fexp1 fexp2 -> forall x y, 0 < x -> 0 < y -> - (ln_beta y <= fexp1 (ln_beta x) - 1)%Z -> + (mag y <= fexp1 (mag x) - 1)%Z -> generic_format beta fexp1 x -> - double_round_eq fexp1 fexp2 choice1 choice2 (x + y). + round_round_eq fexp1 fexp2 choice1 choice2 (x + y). Proof. intros Hbeta fexp1 fexp2 Vfexp1 Vfexp2 choice1 choice2 Hexp x y Px Py Hly Fx. -assert (Lxy : ln_beta (x + y) = ln_beta x :> Z); - [now apply (ln_beta_plus_separated fexp1); [|apply Rlt_le| |omega]|]. +assert (Lxy : mag (x + y) = mag x :> Z); + [now apply (mag_plus_separated fexp1); [|apply Rlt_le| |omega]|]. destruct Hexp as (_,(_,(_,Hexp4))). -assert (Hf2 : (fexp2 (ln_beta x) <= fexp1 (ln_beta x))%Z); +assert (Hf2 : (fexp2 (mag x) <= fexp1 (mag x))%Z); [now apply Hexp4; omega|]. assert (Bpow3 : bpow (- 1) <= / 3). -{ unfold Fcore_Raux.bpow, Z.pow_pos; simpl. +{ unfold Raux.bpow, Z.pow_pos; simpl. rewrite Zmult_1_r. apply Rinv_le; [lra|]. - now change 3 with (Z2R 3); apply Z2R_le. } + now apply IZR_le. } assert (P1 : (0 < 1)%Z) by omega. -unfold double_round_eq. -apply double_round_lt_mid. +unfold round_round_eq. +apply round_round_lt_mid. - exact Vfexp1. - exact Vfexp2. - lra. - now rewrite Lxy. - rewrite Lxy. - assert (fexp1 (ln_beta x) < ln_beta x)%Z; [|omega]. - now apply ln_beta_generic_gt; [|apply Rgt_not_eq|]. + assert (fexp1 (mag x) < mag x)%Z; [|omega]. + now apply mag_generic_gt; [|apply Rgt_not_eq|]. - unfold midp. apply (Rplus_lt_reg_r (- round beta fexp1 Zfloor (x + y))). - apply (Rlt_le_trans _ _ _ (proj2 (double_round_plus_aux1_aux 1 P1 fexp1 x y Px + apply (Rlt_le_trans _ _ _ (proj2 (round_round_plus_aux1_aux 1 P1 fexp1 x y Px Py Hly Lxy Fx))). ring_simplify. rewrite ulp_neq_0;[idtac|now apply Rgt_not_eq, Rplus_lt_0_compat]. - unfold canonic_exp; rewrite Lxy. - apply (Rmult_le_reg_r (bpow (- fexp1 (ln_beta x)))); + unfold cexp; rewrite Lxy. + apply (Rmult_le_reg_r (bpow (- fexp1 (mag x)))); [now apply bpow_gt_0|]. bpow_simplify. apply (Rle_trans _ _ _ Bpow3); lra. - rewrite ulp_neq_0;[idtac|now apply Rgt_not_eq, Rplus_lt_0_compat]. - unfold round, F2R, scaled_mantissa, canonic_exp; simpl; rewrite Lxy. + unfold round, F2R, scaled_mantissa, cexp; simpl; rewrite Lxy. intro Hf2'. unfold midp. apply (Rplus_lt_reg_r (- round beta fexp1 Zfloor (x + y))); ring_simplify. rewrite <- Rmult_minus_distr_l. - apply (Rlt_le_trans _ _ _ (proj2 (double_round_plus_aux1_aux 1 P1 fexp1 x y Px + apply (Rlt_le_trans _ _ _ (proj2 (round_round_plus_aux1_aux 1 P1 fexp1 x y Px Py Hly Lxy Fx))). rewrite ulp_neq_0;[idtac|now apply Rgt_not_eq, Rplus_lt_0_compat]. - unfold canonic_exp; rewrite Lxy. - apply (Rmult_le_reg_r (bpow (- fexp1 (ln_beta x)))); + unfold cexp; rewrite Lxy. + apply (Rmult_le_reg_r (bpow (- fexp1 (mag x)))); [now apply bpow_gt_0|]. rewrite (Rmult_assoc (/ 2)). rewrite Rmult_minus_distr_r. @@ -1925,47 +1917,47 @@ apply double_round_lt_mid. now apply Rle_trans with (bpow (- 1)); [apply bpow_le; omega|]. Qed. -(* double_round_plus_beta_ge_3_aux{0,1} together *) -Lemma double_round_plus_beta_ge_3_aux2 : +(* round_round_plus_radix_ge_3_aux{0,1} together *) +Lemma round_round_plus_radix_ge_3_aux2 : (3 <= beta)%Z -> forall (fexp1 fexp2 : Z -> Z), Valid_exp fexp1 -> Valid_exp fexp2 -> forall (choice1 choice2 : Z -> bool), - double_round_plus_beta_ge_3_hyp fexp1 fexp2 -> + round_round_plus_radix_ge_3_hyp fexp1 fexp2 -> forall x y, 0 < y -> y <= x -> generic_format beta fexp1 x -> generic_format beta fexp1 y -> - double_round_eq fexp1 fexp2 choice1 choice2 (x + y). + round_round_eq fexp1 fexp2 choice1 choice2 (x + y). Proof. intros Hbeta fexp1 fexp2 Vfexp1 Vfexp2 choice1 choice2 Hexp x y Py Hyx Fx Fy. assert (Px := Rlt_le_trans 0 y x Py Hyx). -unfold double_round_eq. -destruct (Zle_or_lt (ln_beta y) (fexp1 (ln_beta x) - 1)) as [Hly|Hly]. -- (* ln_beta y <= fexp1 (ln_beta x) - 1 *) - now apply double_round_plus_beta_ge_3_aux1. -- (* fexp1 (ln_beta x) - 1 < ln_beta y *) +unfold round_round_eq. +destruct (Zle_or_lt (mag y) (fexp1 (mag x) - 1)) as [Hly|Hly]. +- (* mag y <= fexp1 (mag x) - 1 *) + now apply round_round_plus_radix_ge_3_aux1. +- (* fexp1 (mag x) - 1 < mag y *) rewrite (round_generic beta fexp2). + reflexivity. + now apply valid_rnd_N. - + assert (Hf1 : (fexp1 (ln_beta x) <= ln_beta y)%Z); [omega|]. - now apply (double_round_plus_beta_ge_3_aux0 fexp1). + + assert (Hf1 : (fexp1 (mag x) <= mag y)%Z); [omega|]. + now apply (round_round_plus_radix_ge_3_aux0 fexp1). Qed. -Lemma double_round_plus_beta_ge_3_aux : +Lemma round_round_plus_radix_ge_3_aux : (3 <= beta)%Z -> forall (fexp1 fexp2 : Z -> Z), Valid_exp fexp1 -> Valid_exp fexp2 -> forall (choice1 choice2 : Z -> bool), - double_round_plus_beta_ge_3_hyp fexp1 fexp2 -> + round_round_plus_radix_ge_3_hyp fexp1 fexp2 -> forall x y, 0 <= x -> 0 <= y -> generic_format beta fexp1 x -> generic_format beta fexp1 y -> - double_round_eq fexp1 fexp2 choice1 choice2 (x + y). + round_round_eq fexp1 fexp2 choice1 choice2 (x + y). Proof. intros Hbeta fexp1 fexp2 Vfexp1 Vfexp2 choice1 choice2 Hexp x y Nnx Nny Fx Fy. -unfold double_round_eq. +unfold round_round_eq. destruct (Req_dec x 0) as [Zx|Nzx]. - (* x = 0 *) destruct Hexp as (_,(_,(_,Hexp4))). @@ -1973,7 +1965,7 @@ destruct (Req_dec x 0) as [Zx|Nzx]. rewrite (round_generic beta fexp2). + reflexivity. + now apply valid_rnd_N. - + apply (generic_inclusion_ln_beta beta fexp1). + + apply (generic_inclusion_mag beta fexp1). now intros _; apply Hexp4; omega. exact Fy. - (* x <> 0 *) @@ -1984,7 +1976,7 @@ destruct (Req_dec x 0) as [Zx|Nzx]. rewrite (round_generic beta fexp2). * reflexivity. * now apply valid_rnd_N. - * apply (generic_inclusion_ln_beta beta fexp1). + * apply (generic_inclusion_mag beta fexp1). now intros _; apply Hexp4; omega. exact Fx. + (* y <> 0 *) @@ -1994,156 +1986,156 @@ destruct (Req_dec x 0) as [Zx|Nzx]. * (* x < y *) apply Rlt_le in H. rewrite Rplus_comm. - now apply double_round_plus_beta_ge_3_aux2. - * now apply double_round_plus_beta_ge_3_aux2. + now apply round_round_plus_radix_ge_3_aux2. + * now apply round_round_plus_radix_ge_3_aux2. Qed. -(* fexp1 (ln_beta x) <= ln_beta y : +(* fexp1 (mag x) <= mag y : * substraction is exact in the largest precision (fexp2). *) -Lemma double_round_minus_beta_ge_3_aux0 : +Lemma round_round_minus_radix_ge_3_aux0 : forall (fexp1 fexp2 : Z -> Z), - double_round_plus_beta_ge_3_hyp fexp1 fexp2 -> + round_round_plus_radix_ge_3_hyp fexp1 fexp2 -> forall x y, 0 < y -> y < x -> - (fexp1 (ln_beta x) <= ln_beta y)%Z -> + (fexp1 (mag x) <= mag y)%Z -> generic_format beta fexp1 x -> generic_format beta fexp1 y -> generic_format beta fexp2 (x - y). Proof. intros fexp1 fexp2 Hexp x y Py Hyx Hln Fx Fy. assert (Px := Rlt_trans 0 y x Py Hyx). destruct Hexp as (Hexp1,(_,(Hexp3,Hexp4))). -assert (Lyx : (ln_beta y <= ln_beta x)%Z); - [now apply ln_beta_le; [|apply Rlt_le]|]. -destruct (Z.lt_ge_cases (ln_beta x - 2) (ln_beta y)) as [Hlt|Hge]. -- (* ln_beta x - 2 < ln_beta y *) - assert (Hor : (ln_beta y = ln_beta x :> Z) - \/ (ln_beta y = ln_beta x - 1 :> Z)%Z); [omega|]. +assert (Lyx : (mag y <= mag x)%Z); + [now apply mag_le; [|apply Rlt_le]|]. +destruct (Z.lt_ge_cases (mag x - 2) (mag y)) as [Hlt|Hge]. +- (* mag x - 2 < mag y *) + assert (Hor : (mag y = mag x :> Z) + \/ (mag y = mag x - 1 :> Z)%Z); [omega|]. destruct Hor as [Heq|Heqm1]. - + (* ln_beta y = ln_beta x *) - apply (double_round_minus_aux0_aux fexp1); [| |exact Fx|exact Fy]. + + (* mag y = mag x *) + apply (round_round_minus_aux0_aux fexp1); [| |exact Fx|exact Fy]. * apply Hexp4. - apply Zle_trans with (ln_beta (x - y)); [omega|]. - now apply ln_beta_minus. + apply Z.le_trans with (mag (x - y)); [omega|]. + now apply mag_minus. * rewrite Heq. apply Hexp4. - apply Zle_trans with (ln_beta (x - y)); [omega|]. - now apply ln_beta_minus. - + (* ln_beta y = ln_beta x - 1 *) - apply (double_round_minus_aux0_aux fexp1); [| |exact Fx|exact Fy]. + apply Z.le_trans with (mag (x - y)); [omega|]. + now apply mag_minus. + + (* mag y = mag x - 1 *) + apply (round_round_minus_aux0_aux fexp1); [| |exact Fx|exact Fy]. * apply Hexp4. - apply Zle_trans with (ln_beta (x - y)); [omega|]. - now apply ln_beta_minus. + apply Z.le_trans with (mag (x - y)); [omega|]. + now apply mag_minus. * rewrite Heqm1. apply Hexp4. apply Zplus_le_compat_r. - now apply ln_beta_minus. -- (* ln_beta y <= ln_beta x - 2 *) - destruct (ln_beta_minus_disj x y Px Py Hge) as [Lxmy|Lxmy]. - + (* ln_beta (x - y) = ln_beta x *) - apply (double_round_minus_aux0_aux fexp1); [| |exact Fx|exact Fy]. + now apply mag_minus. +- (* mag y <= mag x - 2 *) + destruct (mag_minus_disj x y Px Py Hge) as [Lxmy|Lxmy]. + + (* mag (x - y) = mag x *) + apply (round_round_minus_aux0_aux fexp1); [| |exact Fx|exact Fy]. * apply Hexp4. omega. * now rewrite Lxmy; apply Hexp3. - + (* ln_beta (x - y) = ln_beta x - 1 *) - apply (double_round_minus_aux0_aux fexp1); [| |exact Fx|exact Fy]; + + (* mag (x - y) = mag x - 1 *) + apply (round_round_minus_aux0_aux fexp1); [| |exact Fx|exact Fy]; rewrite Lxmy. * apply Hexp1. - replace (_ + _)%Z with (ln_beta x : Z); [|ring]. - now apply Zle_trans with (ln_beta y). + replace (_ + _)%Z with (mag x : Z); [|ring]. + now apply Z.le_trans with (mag y). * apply Hexp1. - now replace (_ + _)%Z with (ln_beta x : Z); [|ring]. + now replace (_ + _)%Z with (mag x : Z); [|ring]. Qed. -(* ln_beta y <= fexp1 (ln_beta x) - 1, - * fexp1 (ln_beta (x - y)) <= ln_beta y : +(* mag y <= fexp1 (mag x) - 1, + * fexp1 (mag (x - y)) <= mag y : * substraction is exact in the largest precision (fexp2). *) -Lemma double_round_minus_beta_ge_3_aux1 : +Lemma round_round_minus_radix_ge_3_aux1 : forall (fexp1 fexp2 : Z -> Z), Valid_exp fexp1 -> Valid_exp fexp2 -> - double_round_plus_beta_ge_3_hyp fexp1 fexp2 -> + round_round_plus_radix_ge_3_hyp fexp1 fexp2 -> forall x y, 0 < y -> y < x -> - (ln_beta y <= fexp1 (ln_beta x) - 1)%Z -> - (fexp1 (ln_beta (x - y)) <= ln_beta y)%Z -> + (mag y <= fexp1 (mag x) - 1)%Z -> + (fexp1 (mag (x - y)) <= mag y)%Z -> generic_format beta fexp1 x -> generic_format beta fexp1 y -> generic_format beta fexp2 (x - y). Proof. intros fexp1 fexp2 Vfexp1 Vfexp2 Hexp x y Py Hyx Hln Hln' Fx Fy. assert (Px := Rlt_trans 0 y x Py Hyx). destruct Hexp as (Hexp1,(Hexp2,(Hexp3,Hexp4))). -assert (Lyx : (ln_beta y <= ln_beta x)%Z); - [now apply ln_beta_le; [|apply Rlt_le]|]. -assert (Hfx : (fexp1 (ln_beta x) < ln_beta x)%Z); - [now apply ln_beta_generic_gt; [|apply Rgt_not_eq|]|]. -assert (Hfy : (fexp1 (ln_beta y) < ln_beta y)%Z); - [now apply ln_beta_generic_gt; [|apply Rgt_not_eq|]|]. -apply (double_round_minus_aux0_aux fexp1); [| |exact Fx|exact Fy]. -- apply Zle_trans with (fexp1 (ln_beta (x - y))). +assert (Lyx : (mag y <= mag x)%Z); + [now apply mag_le; [|apply Rlt_le]|]. +assert (Hfx : (fexp1 (mag x) < mag x)%Z); + [now apply mag_generic_gt; [|apply Rgt_not_eq|]|]. +assert (Hfy : (fexp1 (mag y) < mag y)%Z); + [now apply mag_generic_gt; [|apply Rgt_not_eq|]|]. +apply (round_round_minus_aux0_aux fexp1); [| |exact Fx|exact Fy]. +- apply Z.le_trans with (fexp1 (mag (x - y))). + apply Hexp4; omega. + omega. - now apply Hexp3. Qed. -(* ln_beta y <= fexp1 (ln_beta x) - 1 : - * ln_beta y <= fexp1 (ln_beta (x - y)) - 1 : - * double_round_gt_mid applies. *) -Lemma double_round_minus_beta_ge_3_aux2 : +(* mag y <= fexp1 (mag x) - 1 : + * mag y <= fexp1 (mag (x - y)) - 1 : + * round_round_gt_mid applies. *) +Lemma round_round_minus_radix_ge_3_aux2 : (3 <= beta)%Z -> forall (fexp1 fexp2 : Z -> Z), Valid_exp fexp1 -> Valid_exp fexp2 -> forall (choice1 choice2 : Z -> bool), - double_round_plus_beta_ge_3_hyp fexp1 fexp2 -> + round_round_plus_radix_ge_3_hyp fexp1 fexp2 -> forall x y, 0 < y -> y < x -> - (ln_beta y <= fexp1 (ln_beta x) - 1)%Z -> - (ln_beta y <= fexp1 (ln_beta (x - y)) - 1)%Z -> + (mag y <= fexp1 (mag x) - 1)%Z -> + (mag y <= fexp1 (mag (x - y)) - 1)%Z -> generic_format beta fexp1 x -> generic_format beta fexp1 y -> - double_round_eq fexp1 fexp2 choice1 choice2 (x - y). + round_round_eq fexp1 fexp2 choice1 choice2 (x - y). Proof. intros Hbeta fexp1 fexp2 Vfexp1 Vfexp2 choice1 choice2 Hexp x y Py Hxy Hly Hly' Fx Fy. assert (Px := Rlt_trans 0 y x Py Hxy). destruct Hexp as (_,(_,(_,Hexp4))). -assert (Hf2 : (fexp2 (ln_beta x) <= fexp1 (ln_beta x))%Z); +assert (Hf2 : (fexp2 (mag x) <= fexp1 (mag x))%Z); [now apply Hexp4; omega|]. -assert (Hfx : (fexp1 (ln_beta x) < ln_beta x)%Z); - [now apply ln_beta_generic_gt; [|apply Rgt_not_eq|]|]. +assert (Hfx : (fexp1 (mag x) < mag x)%Z); + [now apply mag_generic_gt; [|apply Rgt_not_eq|]|]. assert (Bpow3 : bpow (- 1) <= / 3). -{ unfold Fcore_Raux.bpow, Z.pow_pos; simpl. +{ unfold Raux.bpow, Z.pow_pos; simpl. rewrite Zmult_1_r. apply Rinv_le; [lra|]. - now change 3 with (Z2R 3); apply Z2R_le. } -assert (Ly : y < bpow (ln_beta y)). + now apply IZR_le. } +assert (Ly : y < bpow (mag y)). { apply Rabs_lt_inv. - apply bpow_ln_beta_gt. } -unfold double_round_eq. -apply double_round_gt_mid. + apply bpow_mag_gt. } +unfold round_round_eq. +apply round_round_gt_mid. - exact Vfexp1. - exact Vfexp2. - lra. - apply Hexp4; omega. -- assert (fexp1 (ln_beta (x - y)) < ln_beta (x - y))%Z; [|omega]. - apply (valid_exp_large fexp1 (ln_beta x - 1)). - + apply (valid_exp_large fexp1 (ln_beta y)); [|omega]. - now apply ln_beta_generic_gt; [|apply Rgt_not_eq|]. - + now apply ln_beta_minus_lb; [| |omega]. +- assert (fexp1 (mag (x - y)) < mag (x - y))%Z; [|omega]. + apply (valid_exp_large fexp1 (mag x - 1)). + + apply (valid_exp_large fexp1 (mag y)); [|omega]. + now apply mag_generic_gt; [|apply Rgt_not_eq|]. + + now apply mag_minus_lb; [| |omega]. - unfold midp'. apply (Rplus_lt_reg_r (/ 2 * ulp beta fexp1 (x - y) - (x - y))). ring_simplify. replace (_ + _) with (round beta fexp1 Zceil (x - y) - (x - y)) by ring. - apply Rlt_le_trans with (bpow (fexp1 (ln_beta (x - y)) - 1)). + apply Rlt_le_trans with (bpow (fexp1 (mag (x - y)) - 1)). + apply Rle_lt_trans with y; - [now apply double_round_minus_aux2_aux|]. + [now apply round_round_minus_aux2_aux|]. apply (Rlt_le_trans _ _ _ Ly). now apply bpow_le. + rewrite ulp_neq_0;[idtac|now apply Rgt_not_eq, Rgt_minus]. - unfold canonic_exp. + unfold cexp. unfold Zminus at 1; rewrite bpow_plus. rewrite Rmult_comm. apply Rmult_le_compat_r; [now apply bpow_ge_0|]. - unfold Fcore_Raux.bpow, Z.pow_pos; simpl. + unfold Raux.bpow, Z.pow_pos; simpl. rewrite Zmult_1_r; apply Rinv_le; [lra|]. - now change 2 with (Z2R 2); apply Z2R_le; omega. + now apply IZR_le; omega. - intro Hf2'. unfold midp'. apply (Rplus_lt_reg_r (/ 2 * (ulp beta fexp1 (x - y) @@ -2151,21 +2143,21 @@ apply double_round_gt_mid. ring_simplify; rewrite <- Rmult_minus_distr_l. replace (_ + _) with (round beta fexp1 Zceil (x - y) - (x - y)) by ring. apply Rle_lt_trans with y; - [now apply double_round_minus_aux2_aux|]. + [now apply round_round_minus_aux2_aux|]. apply (Rlt_le_trans _ _ _ Ly). - apply Rle_trans with (bpow (fexp1 (ln_beta (x - y)) - 1)); + apply Rle_trans with (bpow (fexp1 (mag (x - y)) - 1)); [now apply bpow_le|]. rewrite 2!ulp_neq_0; try now apply Rgt_not_eq, Rgt_minus. - unfold canonic_exp. - apply (Rmult_le_reg_r (bpow (- fexp1 (ln_beta (x - y))))); + unfold cexp. + apply (Rmult_le_reg_r (bpow (- fexp1 (mag (x - y))))); [now apply bpow_gt_0|]. rewrite Rmult_assoc. rewrite Rmult_minus_distr_r. bpow_simplify. apply Rle_trans with (/ 3). - + unfold Fcore_Raux.bpow, Z.pow_pos; simpl. + + unfold Raux.bpow, Z.pow_pos; simpl. rewrite Zmult_1_r; apply Rinv_le; [lra|]. - now change 3 with (Z2R 3); apply Z2R_le. + now apply IZR_le. + replace (/ 3) with (/ 2 * (2 / 3)) by field. apply Rmult_le_compat_l; [lra|]. apply (Rplus_le_reg_r (- 1)); ring_simplify. @@ -2173,27 +2165,27 @@ apply double_round_gt_mid. apply Ropp_le_contravar. apply Rle_trans with (bpow (- 1)). * apply bpow_le; omega. - * unfold Fcore_Raux.bpow, Z.pow_pos; simpl. + * unfold Raux.bpow, Z.pow_pos; simpl. rewrite Zmult_1_r; apply Rinv_le; [lra|]. - now change 3 with (Z2R 3); apply Z2R_le. + now apply IZR_le. Qed. -(* double_round_minus_aux{0,1,2} together *) -Lemma double_round_minus_beta_ge_3_aux3 : +(* round_round_minus_aux{0,1,2} together *) +Lemma round_round_minus_radix_ge_3_aux3 : (3 <= beta)%Z -> forall (fexp1 fexp2 : Z -> Z), Valid_exp fexp1 -> Valid_exp fexp2 -> forall (choice1 choice2 : Z -> bool), - double_round_plus_beta_ge_3_hyp fexp1 fexp2 -> + round_round_plus_radix_ge_3_hyp fexp1 fexp2 -> forall x y, 0 < y -> y <= x -> generic_format beta fexp1 x -> generic_format beta fexp1 y -> - double_round_eq fexp1 fexp2 choice1 choice2 (x - y). + round_round_eq fexp1 fexp2 choice1 choice2 (x - y). Proof. intros Hbeta fexp1 fexp2 Vfexp1 Vfexp2 choice1 choice2 Hexp x y Py Hyx Fx Fy. assert (Px := Rlt_le_trans 0 y x Py Hyx). -unfold double_round_eq. +unfold round_round_eq. destruct (Req_dec y x) as [Hy|Hy]. - (* y = x *) rewrite Hy; replace (x - x) with 0 by ring. @@ -2202,39 +2194,39 @@ destruct (Req_dec y x) as [Hy|Hy]. + now apply valid_rnd_N. - (* y < x *) assert (Hyx' : y < x); [lra|]. - destruct (Zle_or_lt (ln_beta y) (fexp1 (ln_beta x) - 1)) as [Hly|Hly]. - + (* ln_beta y <= fexp1 (ln_beta x) - 1 *) - destruct (Zle_or_lt (ln_beta y) (fexp1 (ln_beta (x - y)) - 1)) + destruct (Zle_or_lt (mag y) (fexp1 (mag x) - 1)) as [Hly|Hly]. + + (* mag y <= fexp1 (mag x) - 1 *) + destruct (Zle_or_lt (mag y) (fexp1 (mag (x - y)) - 1)) as [Hly'|Hly']. - * (* ln_beta y <= fexp1 (ln_beta (x - y)) - 1 *) - now apply double_round_minus_beta_ge_3_aux2. - * (* fexp1 (ln_beta (x - y)) - 1 < ln_beta y *) + * (* mag y <= fexp1 (mag (x - y)) - 1 *) + now apply round_round_minus_radix_ge_3_aux2. + * (* fexp1 (mag (x - y)) - 1 < mag y *) { rewrite (round_generic beta fexp2). - reflexivity. - now apply valid_rnd_N. - - assert (Hf1 : (fexp1 (ln_beta (x - y)) <= ln_beta y)%Z); [omega|]. - now apply (double_round_minus_beta_ge_3_aux1 fexp1). } + - assert (Hf1 : (fexp1 (mag (x - y)) <= mag y)%Z); [omega|]. + now apply (round_round_minus_radix_ge_3_aux1 fexp1). } + rewrite (round_generic beta fexp2). * reflexivity. * now apply valid_rnd_N. - * assert (Hf1 : (fexp1 (ln_beta x) <= ln_beta y)%Z); [omega|]. - now apply (double_round_minus_beta_ge_3_aux0 fexp1). + * assert (Hf1 : (fexp1 (mag x) <= mag y)%Z); [omega|]. + now apply (round_round_minus_radix_ge_3_aux0 fexp1). Qed. -Lemma double_round_minus_beta_ge_3_aux : +Lemma round_round_minus_radix_ge_3_aux : (3 <= beta)%Z -> forall (fexp1 fexp2 : Z -> Z), Valid_exp fexp1 -> Valid_exp fexp2 -> forall (choice1 choice2 : Z -> bool), - double_round_plus_beta_ge_3_hyp fexp1 fexp2 -> + round_round_plus_radix_ge_3_hyp fexp1 fexp2 -> forall x y, 0 <= x -> 0 <= y -> generic_format beta fexp1 x -> generic_format beta fexp1 y -> - double_round_eq fexp1 fexp2 choice1 choice2 (x - y). + round_round_eq fexp1 fexp2 choice1 choice2 (x - y). Proof. intros Hbeta fexp1 fexp2 Vfexp1 Vfexp2 choice1 choice2 Hexp x y Nnx Nny Fx Fy. -unfold double_round_eq. +unfold round_round_eq. destruct (Req_dec x 0) as [Zx|Nzx]. - (* x = 0 *) rewrite Zx; unfold Rminus; rewrite Rplus_0_l. @@ -2242,7 +2234,7 @@ destruct (Req_dec x 0) as [Zx|Nzx]. rewrite (round_generic beta fexp2). * reflexivity. * now apply valid_rnd_N. - * apply (generic_inclusion_ln_beta beta fexp1). + * apply (generic_inclusion_mag beta fexp1). destruct Hexp as (_,(_,(_,Hexp4))). now intros _; apply Hexp4; omega. exact Fy. @@ -2253,7 +2245,7 @@ destruct (Req_dec x 0) as [Zx|Nzx]. rewrite (round_generic beta fexp2). * reflexivity. * now apply valid_rnd_N. - * apply (generic_inclusion_ln_beta beta fexp1). + * apply (generic_inclusion_mag beta fexp1). destruct Hexp as (_,(_,(_,Hexp4))). now intros _; apply Hexp4; omega. exact Fx. @@ -2266,24 +2258,24 @@ destruct (Req_dec x 0) as [Zx|Nzx]. replace (x - y) with (- (y - x)) by ring. do 3 rewrite round_N_opp. apply Ropp_eq_compat. - now apply double_round_minus_beta_ge_3_aux3. + now apply round_round_minus_radix_ge_3_aux3. * (* y <= x *) - now apply double_round_minus_beta_ge_3_aux3. + now apply round_round_minus_radix_ge_3_aux3. Qed. -Lemma double_round_plus_beta_ge_3 : +Lemma round_round_plus_radix_ge_3 : (3 <= beta)%Z -> forall (fexp1 fexp2 : Z -> Z), Valid_exp fexp1 -> Valid_exp fexp2 -> forall (choice1 choice2 : Z -> bool), - double_round_plus_beta_ge_3_hyp fexp1 fexp2 -> + round_round_plus_radix_ge_3_hyp fexp1 fexp2 -> forall x y, generic_format beta fexp1 x -> generic_format beta fexp1 y -> - double_round_eq fexp1 fexp2 choice1 choice2 (x + y). + round_round_eq fexp1 fexp2 choice1 choice2 (x + y). Proof. intros Hbeta fexp1 fexp2 Vfexp1 Vfexp2 choice1 choice2 Hexp x y Fx Fy. -unfold double_round_eq. +unfold round_round_eq. destruct (Rlt_or_le x 0) as [Sx|Sx]; destruct (Rlt_or_le y 0) as [Sy|Sy]. - (* x < 0, y < 0 *) replace (x + y) with (- (- x - y)); [|ring]. @@ -2293,41 +2285,39 @@ destruct (Rlt_or_le x 0) as [Sx|Sx]; destruct (Rlt_or_le y 0) as [Sy|Sy]. assert (Py : 0 <= - y); [lra|]. apply generic_format_opp in Fx. apply generic_format_opp in Fy. - now apply double_round_plus_beta_ge_3_aux. + now apply round_round_plus_radix_ge_3_aux. - (* x < 0, 0 <= y *) replace (x + y) with (y - (- x)); [|ring]. assert (Px : 0 <= - x); [lra|]. apply generic_format_opp in Fx. - now apply double_round_minus_beta_ge_3_aux. + now apply round_round_minus_radix_ge_3_aux. - (* 0 <= x, y < 0 *) replace (x + y) with (x - (- y)); [|ring]. assert (Py : 0 <= - y); [lra|]. apply generic_format_opp in Fy. - now apply double_round_minus_beta_ge_3_aux. + now apply round_round_minus_radix_ge_3_aux. - (* 0 <= x, 0 <= y *) - now apply double_round_plus_beta_ge_3_aux. + now apply round_round_plus_radix_ge_3_aux. Qed. -Lemma double_round_minus_beta_ge_3 : +Lemma round_round_minus_radix_ge_3 : (3 <= beta)%Z -> forall (fexp1 fexp2 : Z -> Z), Valid_exp fexp1 -> Valid_exp fexp2 -> forall (choice1 choice2 : Z -> bool), - double_round_plus_beta_ge_3_hyp fexp1 fexp2 -> + round_round_plus_radix_ge_3_hyp fexp1 fexp2 -> forall x y, generic_format beta fexp1 x -> generic_format beta fexp1 y -> - double_round_eq fexp1 fexp2 choice1 choice2 (x - y). + round_round_eq fexp1 fexp2 choice1 choice2 (x - y). Proof. intros Hbeta fexp1 fexp2 Vfexp1 Vfexp2 choice1 choice2 Hexp x y Fx Fy. unfold Rminus. apply generic_format_opp in Fy. -now apply double_round_plus_beta_ge_3. +now apply round_round_plus_radix_ge_3. Qed. -Section Double_round_plus_beta_ge_3_FLX. - -Import Fcore_FLX. +Section Double_round_plus_radix_ge_3_FLX. Variable prec : Z. Variable prec' : Z. @@ -2335,60 +2325,57 @@ Variable prec' : Z. Context { prec_gt_0_ : Prec_gt_0 prec }. Context { prec_gt_0_' : Prec_gt_0 prec' }. -Lemma FLX_double_round_plus_beta_ge_3_hyp : +Lemma FLX_round_round_plus_radix_ge_3_hyp : (2 * prec <= prec')%Z -> - double_round_plus_beta_ge_3_hyp (FLX_exp prec) (FLX_exp prec'). + round_round_plus_radix_ge_3_hyp (FLX_exp prec) (FLX_exp prec'). Proof. intros Hprec. unfold FLX_exp. -unfold double_round_plus_beta_ge_3_hyp; split; [|split; [|split]]; +unfold round_round_plus_radix_ge_3_hyp; split; [|split; [|split]]; intros ex ey; try omega. unfold Prec_gt_0 in prec_gt_0_. omega. Qed. -Theorem double_round_plus_beta_ge_3_FLX : +Theorem round_round_plus_radix_ge_3_FLX : (3 <= beta)%Z -> forall choice1 choice2, (2 * prec <= prec')%Z -> forall x y, FLX_format beta prec x -> FLX_format beta prec y -> - double_round_eq (FLX_exp prec) (FLX_exp prec') choice1 choice2 (x + y). + round_round_eq (FLX_exp prec) (FLX_exp prec') choice1 choice2 (x + y). Proof. intros Hbeta choice1 choice2 Hprec x y Fx Fy. -apply double_round_plus_beta_ge_3. +apply round_round_plus_radix_ge_3. - exact Hbeta. - now apply FLX_exp_valid. - now apply FLX_exp_valid. -- now apply FLX_double_round_plus_beta_ge_3_hyp. +- now apply FLX_round_round_plus_radix_ge_3_hyp. - now apply generic_format_FLX. - now apply generic_format_FLX. Qed. -Theorem double_round_minus_beta_ge_3_FLX : +Theorem round_round_minus_radix_ge_3_FLX : (3 <= beta)%Z -> forall choice1 choice2, (2 * prec <= prec')%Z -> forall x y, FLX_format beta prec x -> FLX_format beta prec y -> - double_round_eq (FLX_exp prec) (FLX_exp prec') choice1 choice2 (x - y). + round_round_eq (FLX_exp prec) (FLX_exp prec') choice1 choice2 (x - y). Proof. intros Hbeta choice1 choice2 Hprec x y Fx Fy. -apply double_round_minus_beta_ge_3. +apply round_round_minus_radix_ge_3. - exact Hbeta. - now apply FLX_exp_valid. - now apply FLX_exp_valid. -- now apply FLX_double_round_plus_beta_ge_3_hyp. +- now apply FLX_round_round_plus_radix_ge_3_hyp. - now apply generic_format_FLX. - now apply generic_format_FLX. Qed. -End Double_round_plus_beta_ge_3_FLX. - -Section Double_round_plus_beta_ge_3_FLT. +End Double_round_plus_radix_ge_3_FLX. -Import Fcore_FLX. -Import Fcore_FLT. +Section Double_round_plus_radix_ge_3_FLT. Variable emin prec : Z. Variable emin' prec' : Z. @@ -2396,13 +2383,13 @@ Variable emin' prec' : Z. Context { prec_gt_0_ : Prec_gt_0 prec }. Context { prec_gt_0_' : Prec_gt_0 prec' }. -Lemma FLT_double_round_plus_beta_ge_3_hyp : +Lemma FLT_round_round_plus_radix_ge_3_hyp : (emin' <= emin)%Z -> (2 * prec <= prec')%Z -> - double_round_plus_beta_ge_3_hyp (FLT_exp emin prec) (FLT_exp emin' prec'). + round_round_plus_radix_ge_3_hyp (FLT_exp emin prec) (FLT_exp emin' prec'). Proof. intros Hemin Hprec. unfold FLT_exp. -unfold double_round_plus_beta_ge_3_hyp; split; [|split; [|split]]; intros ex ey. +unfold round_round_plus_radix_ge_3_hyp; split; [|split; [|split]]; intros ex ey. - generalize (Zmax_spec (ex + 1 - prec) emin). generalize (Zmax_spec (ex - prec') emin'). generalize (Zmax_spec (ey - prec) emin). @@ -2421,50 +2408,47 @@ unfold double_round_plus_beta_ge_3_hyp; split; [|split; [|split]]; intros ex ey. omega. Qed. -Theorem double_round_plus_beta_ge_3_FLT : +Theorem round_round_plus_radix_ge_3_FLT : (3 <= beta)%Z -> forall choice1 choice2, (emin' <= emin)%Z -> (2 * prec <= prec')%Z -> forall x y, FLT_format beta emin prec x -> FLT_format beta emin prec y -> - double_round_eq (FLT_exp emin prec) (FLT_exp emin' prec') + round_round_eq (FLT_exp emin prec) (FLT_exp emin' prec') choice1 choice2 (x + y). Proof. intros Hbeta choice1 choice2 Hemin Hprec x y Fx Fy. -apply double_round_plus_beta_ge_3. +apply round_round_plus_radix_ge_3. - exact Hbeta. - now apply FLT_exp_valid. - now apply FLT_exp_valid. -- now apply FLT_double_round_plus_beta_ge_3_hyp. +- now apply FLT_round_round_plus_radix_ge_3_hyp. - now apply generic_format_FLT. - now apply generic_format_FLT. Qed. -Theorem double_round_minus_beta_ge_3_FLT : +Theorem round_round_minus_radix_ge_3_FLT : (3 <= beta)%Z -> forall choice1 choice2, (emin' <= emin)%Z -> (2 * prec <= prec')%Z -> forall x y, FLT_format beta emin prec x -> FLT_format beta emin prec y -> - double_round_eq (FLT_exp emin prec) (FLT_exp emin' prec') + round_round_eq (FLT_exp emin prec) (FLT_exp emin' prec') choice1 choice2 (x - y). Proof. intros Hbeta choice1 choice2 Hemin Hprec x y Fx Fy. -apply double_round_minus_beta_ge_3. +apply round_round_minus_radix_ge_3. - exact Hbeta. - now apply FLT_exp_valid. - now apply FLT_exp_valid. -- now apply FLT_double_round_plus_beta_ge_3_hyp. +- now apply FLT_round_round_plus_radix_ge_3_hyp. - now apply generic_format_FLT. - now apply generic_format_FLT. Qed. -End Double_round_plus_beta_ge_3_FLT. +End Double_round_plus_radix_ge_3_FLT. -Section Double_round_plus_beta_ge_3_FTZ. - -Import Fcore_FLX. -Import Fcore_FTZ. +Section Double_round_plus_radix_ge_3_FTZ. Variable emin prec : Z. Variable emin' prec' : Z. @@ -2472,14 +2456,14 @@ Variable emin' prec' : Z. Context { prec_gt_0_ : Prec_gt_0 prec }. Context { prec_gt_0_' : Prec_gt_0 prec' }. -Lemma FTZ_double_round_plus_beta_ge_3_hyp : +Lemma FTZ_round_round_plus_radix_ge_3_hyp : (emin' + prec' <= emin + 1)%Z -> (2 * prec <= prec')%Z -> - double_round_plus_beta_ge_3_hyp (FTZ_exp emin prec) (FTZ_exp emin' prec'). + round_round_plus_radix_ge_3_hyp (FTZ_exp emin prec) (FTZ_exp emin' prec'). Proof. intros Hemin Hprec. unfold FTZ_exp. unfold Prec_gt_0 in *. -unfold double_round_plus_beta_ge_3_hyp; split; [|split; [|split]]; intros ex ey. +unfold round_round_plus_radix_ge_3_hyp; split; [|split; [|split]]; intros ex ey. - destruct (Z.ltb_spec (ex + 1 - prec) emin); destruct (Z.ltb_spec (ex - prec') emin'); destruct (Z.ltb_spec (ey - prec) emin); @@ -2497,64 +2481,64 @@ unfold double_round_plus_beta_ge_3_hyp; split; [|split; [|split]]; intros ex ey. omega. Qed. -Theorem double_round_plus_beta_ge_3_FTZ : +Theorem round_round_plus_radix_ge_3_FTZ : (3 <= beta)%Z -> forall choice1 choice2, (emin' + prec' <= emin + 1)%Z -> (2 * prec <= prec')%Z -> forall x y, FTZ_format beta emin prec x -> FTZ_format beta emin prec y -> - double_round_eq (FTZ_exp emin prec) (FTZ_exp emin' prec') + round_round_eq (FTZ_exp emin prec) (FTZ_exp emin' prec') choice1 choice2 (x + y). Proof. intros Hbeta choice1 choice2 Hemin Hprec x y Fx Fy. -apply double_round_plus_beta_ge_3. +apply round_round_plus_radix_ge_3. - exact Hbeta. - now apply FTZ_exp_valid. - now apply FTZ_exp_valid. -- now apply FTZ_double_round_plus_beta_ge_3_hyp. +- now apply FTZ_round_round_plus_radix_ge_3_hyp. - now apply generic_format_FTZ. - now apply generic_format_FTZ. Qed. -Theorem double_round_minus_beta_ge_3_FTZ : +Theorem round_round_minus_radix_ge_3_FTZ : (3 <= beta)%Z -> forall choice1 choice2, (emin' + prec' <= emin + 1)%Z -> (2 * prec <= prec')%Z -> forall x y, FTZ_format beta emin prec x -> FTZ_format beta emin prec y -> - double_round_eq (FTZ_exp emin prec) (FTZ_exp emin' prec') + round_round_eq (FTZ_exp emin prec) (FTZ_exp emin' prec') choice1 choice2 (x - y). Proof. intros Hbeta choice1 choice2 Hemin Hprec x y Fx Fy. -apply double_round_minus_beta_ge_3. +apply round_round_minus_radix_ge_3. - exact Hbeta. - now apply FTZ_exp_valid. - now apply FTZ_exp_valid. -- now apply FTZ_double_round_plus_beta_ge_3_hyp. +- now apply FTZ_round_round_plus_radix_ge_3_hyp. - now apply generic_format_FTZ. - now apply generic_format_FTZ. Qed. -End Double_round_plus_beta_ge_3_FTZ. +End Double_round_plus_radix_ge_3_FTZ. -End Double_round_plus_beta_ge_3. +End Double_round_plus_radix_ge_3. End Double_round_plus. -Lemma double_round_mid_cases : +Lemma round_round_mid_cases : forall (fexp1 fexp2 : Z -> Z), Valid_exp fexp1 -> Valid_exp fexp2 -> forall (choice1 choice2 : Z -> bool), forall x, 0 < x -> - (fexp2 (ln_beta x) <= fexp1 (ln_beta x) - 1)%Z -> - (fexp1 (ln_beta x) <= ln_beta x)%Z -> + (fexp2 (mag x) <= fexp1 (mag x) - 1)%Z -> + (fexp1 (mag x) <= mag x)%Z -> (Rabs (x - midp fexp1 x) <= / 2 * (ulp beta fexp2 x) -> - double_round_eq fexp1 fexp2 choice1 choice2 x) -> - double_round_eq fexp1 fexp2 choice1 choice2 x. + round_round_eq fexp1 fexp2 choice1 choice2 x) -> + round_round_eq fexp1 fexp2 choice1 choice2 x. Proof. intros fexp1 fexp2 Vfexp1 Vfexp2 choice1 choice2 x Px Hf2f1 Hf1. -unfold double_round_eq, midp. +unfold round_round_eq, midp. set (rd := round beta fexp1 Zfloor x). set (u1 := ulp beta fexp1 x). set (u2 := ulp beta fexp2 x). @@ -2562,14 +2546,14 @@ intros Cmid. destruct (generic_format_EM beta fexp1 x) as [Fx|Nfx]. - (* generic_format beta fexp1 x *) rewrite (round_generic beta fexp2); [reflexivity|now apply valid_rnd_N|]. - now apply (generic_inclusion_ln_beta beta fexp1); [omega|]. + now apply (generic_inclusion_mag beta fexp1); [omega|]. - (* ~ generic_format beta fexp1 x *) assert (Hceil : round beta fexp1 Zceil x = rd + u1); [now apply round_UP_DN_ulp|]. - assert (Hf2' : (fexp2 (ln_beta x) <= fexp1 (ln_beta x) - 1)%Z); [omega|]. + assert (Hf2' : (fexp2 (mag x) <= fexp1 (mag x) - 1)%Z); [omega|]. destruct (Rlt_or_le (x - rd) (/ 2 * (u1 - u2))). + (* x - rd < / 2 * (u1 - u2) *) - apply double_round_lt_mid_further_place; try assumption. + apply round_round_lt_mid_further_place; try assumption. unfold midp. fold rd; fold u1; fold u2. apply (Rplus_lt_reg_r (- rd)); ring_simplify. now rewrite <- Rmult_minus_distr_l. @@ -2580,7 +2564,7 @@ destruct (generic_format_EM beta fexp1 x) as [Fx|Nfx]. < / 2 * (ulp beta fexp1 x - ulp beta fexp2 x)). { rewrite Hceil; fold u1; fold u2. lra. } - apply double_round_gt_mid_further_place; try assumption. + apply round_round_gt_mid_further_place; try assumption. unfold midp'; lra. - (* x - rd <= / 2 * (u1 + u2) *) apply Cmid, Rabs_le; split; lra. } @@ -2588,31 +2572,31 @@ Qed. Section Double_round_sqrt. -Definition double_round_sqrt_hyp fexp1 fexp2 := +Definition round_round_sqrt_hyp fexp1 fexp2 := (forall ex, (2 * fexp1 ex <= fexp1 (2 * ex))%Z) /\ (forall ex, (2 * fexp1 ex <= fexp1 (2 * ex - 1))%Z) /\ (forall ex, (fexp1 (2 * ex) < 2 * ex)%Z -> (fexp2 ex + ex <= 2 * fexp1 ex - 2)%Z). -Lemma ln_beta_sqrt_disj : +Lemma mag_sqrt_disj : forall x, 0 < x -> - (ln_beta x = 2 * ln_beta (sqrt x) - 1 :> Z)%Z - \/ (ln_beta x = 2 * ln_beta (sqrt x) :> Z)%Z. + (mag x = 2 * mag (sqrt x) - 1 :> Z)%Z + \/ (mag x = 2 * mag (sqrt x) :> Z)%Z. Proof. intros x Px. -generalize (ln_beta_sqrt beta x Px). -intro H. -omega. +rewrite (mag_sqrt beta x Px). +generalize (Zdiv2_odd_eqn (mag x + 1)). +destruct Z.odd ; intros ; omega. Qed. -Lemma double_round_sqrt_aux : +Lemma round_round_sqrt_aux : forall fexp1 fexp2 : Z -> Z, Valid_exp fexp1 -> Valid_exp fexp2 -> - double_round_sqrt_hyp fexp1 fexp2 -> + round_round_sqrt_hyp fexp1 fexp2 -> forall x, 0 < x -> - (fexp2 (ln_beta (sqrt x)) <= fexp1 (ln_beta (sqrt x)) - 1)%Z -> + (fexp2 (mag (sqrt x)) <= fexp1 (mag (sqrt x)) - 1)%Z -> generic_format beta fexp1 x -> / 2 * ulp beta fexp2 (sqrt x) < Rabs (sqrt x - midp fexp1 (sqrt x)). Proof. @@ -2621,8 +2605,8 @@ assert (Hbeta : (2 <= beta)%Z). { destruct beta as (beta_val,beta_prop). now apply Zle_bool_imp_le. } set (a := round beta fexp1 Zfloor (sqrt x)). -set (u1 := bpow (fexp1 (ln_beta (sqrt x)))). -set (u2 := bpow (fexp2 (ln_beta (sqrt x)))). +set (u1 := bpow (fexp1 (mag (sqrt x)))). +set (u2 := bpow (fexp2 (mag (sqrt x)))). set (b := / 2 * (u1 - u2)). set (b' := / 2 * (u1 + u2)). unfold midp; rewrite 2!ulp_neq_0; try now apply Rgt_not_eq, sqrt_lt_R0. @@ -2633,9 +2617,9 @@ assert (Fa : generic_format beta fexp1 a). - exact Vfexp1. - now apply valid_rnd_DN. } revert Fa; revert Fx. -unfold generic_format, F2R, scaled_mantissa, canonic_exp; simpl. -set (mx := Ztrunc (x * bpow (- fexp1 (ln_beta x)))). -set (ma := Ztrunc (a * bpow (- fexp1 (ln_beta a)))). +unfold generic_format, F2R, scaled_mantissa, cexp; simpl. +set (mx := Ztrunc (x * bpow (- fexp1 (mag x)))). +set (ma := Ztrunc (a * bpow (- fexp1 (mag a)))). intros Fx Fa. assert (Nna : 0 <= a). { rewrite <- (round_0 beta fexp1 Zfloor). @@ -2666,14 +2650,14 @@ assert (Hl : a + b <= sqrt x). replace (_ + sqrt _) with (sqrt x - (a + / 2 * u1)) by ring. rewrite Ropp_mult_distr_l_reverse. now apply Rabs_le_inv in H; destruct H. } -assert (Hf1 : (2 * fexp1 (ln_beta (sqrt x)) <= fexp1 (ln_beta (x)))%Z); - [destruct (ln_beta_sqrt_disj x Px) as [H'|H']; rewrite H'; apply Hexp|]. -assert (Hlx : (fexp1 (2 * ln_beta (sqrt x)) < 2 * ln_beta (sqrt x))%Z). -{ destruct (ln_beta_sqrt_disj x Px) as [Hlx|Hlx]. - - apply (valid_exp_large fexp1 (ln_beta x)); [|omega]. - now apply ln_beta_generic_gt; [|apply Rgt_not_eq|]. +assert (Hf1 : (2 * fexp1 (mag (sqrt x)) <= fexp1 (mag (x)))%Z); + [destruct (mag_sqrt_disj x Px) as [H'|H']; rewrite H'; apply Hexp|]. +assert (Hlx : (fexp1 (2 * mag (sqrt x)) < 2 * mag (sqrt x))%Z). +{ destruct (mag_sqrt_disj x Px) as [Hlx|Hlx]. + - apply (valid_exp_large fexp1 (mag x)); [|omega]. + now apply mag_generic_gt; [|apply Rgt_not_eq|]. - rewrite <- Hlx. - now apply ln_beta_generic_gt; [|apply Rgt_not_eq|]. } + now apply mag_generic_gt; [|apply Rgt_not_eq|]. } assert (Hsl : a * a + u1 * a - u2 * a + b * b <= x). { replace (_ + _) with ((a + b) * (a + b)); [|now unfold b; field]. rewrite <- sqrt_def; [|now apply Rlt_le]. @@ -2692,34 +2676,33 @@ destruct (Req_dec a 0) as [Za|Nza]. + revert Hsl; unfold Rminus; rewrite Za; do 3 rewrite Rmult_0_r. now rewrite Ropp_0; do 3 rewrite Rplus_0_l. + rewrite Fx. - apply (Rmult_le_reg_r (bpow (- fexp1 (ln_beta x)))); + apply (Rmult_le_reg_r (bpow (- fexp1 (mag x)))); [now apply bpow_gt_0|]. rewrite Rmult_0_l; bpow_simplify. unfold mx. rewrite Ztrunc_floor; [|now apply Rmult_le_pos; [apply Rlt_le|apply bpow_ge_0]]. - apply Req_le. - change 0 with (Z2R 0); apply f_equal. + apply Req_le, IZR_eq. apply Zfloor_imp. split; [now apply Rmult_le_pos; [apply Rlt_le|apply bpow_ge_0]|simpl]. - apply (Rmult_lt_reg_r (bpow (fexp1 (ln_beta x)))); [now apply bpow_gt_0|]. + apply (Rmult_lt_reg_r (bpow (fexp1 (mag x)))); [now apply bpow_gt_0|]. rewrite Rmult_1_l; bpow_simplify. - apply Rlt_le_trans with (bpow (2 * fexp1 (ln_beta (sqrt x)))); + apply Rlt_le_trans with (bpow (2 * fexp1 (mag (sqrt x)))); [|now apply bpow_le]. change 2%Z with (1 + 1)%Z; rewrite Zmult_plus_distr_l; rewrite Zmult_1_l. rewrite bpow_plus. rewrite <- (sqrt_def x) at 1; [|now apply Rlt_le]. - assert (sqrt x < bpow (fexp1 (ln_beta (sqrt x)))); + assert (sqrt x < bpow (fexp1 (mag (sqrt x)))); [|now apply Rmult_lt_compat; [apply sqrt_pos|apply sqrt_pos| |]]. apply (Rle_lt_trans _ _ _ Hr); rewrite Za; rewrite Rplus_0_l. unfold b'; change (bpow _) with u1. apply Rlt_le_trans with (/ 2 * (u1 + u1)); [|lra]. apply Rmult_lt_compat_l; [lra|]; apply Rplus_lt_compat_l. - unfold u2, u1, ulp, canonic_exp; apply bpow_lt; omega. + unfold u2, u1, ulp, cexp; apply bpow_lt; omega. - (* a <> 0 *) assert (Pa : 0 < a); [lra|]. - assert (Hla : (ln_beta a = ln_beta (sqrt x) :> Z)). - { unfold a; apply ln_beta_DN. + assert (Hla : (mag a = mag (sqrt x) :> Z)). + { unfold a; apply mag_DN. - exact Vfexp1. - now fold a. } assert (Hl' : 0 < - (u2 * a) + b * b). @@ -2728,60 +2711,60 @@ destruct (Req_dec a 0) as [Za|Nza]. apply (Rplus_lt_reg_r (/ 2 * u2 * u1)); field_simplify. replace (_ / 2) with (u2 * (a + / 2 * u1)) by field. replace (_ / 8) with (/ 4 * (u2 ^ 2 + u1 ^ 2)) by field. - apply Rlt_le_trans with (u2 * bpow (ln_beta (sqrt x))). + apply Rlt_le_trans with (u2 * bpow (mag (sqrt x))). - apply Rmult_lt_compat_l; [now unfold u2, ulp; apply bpow_gt_0|]. unfold u1; rewrite <- Hla. - apply Rlt_le_trans with (a + bpow (fexp1 (ln_beta a))). + apply Rlt_le_trans with (a + bpow (fexp1 (mag a))). + apply Rplus_lt_compat_l. rewrite <- (Rmult_1_l (bpow _)) at 2. apply Rmult_lt_compat_r; [apply bpow_gt_0|lra]. + apply Rle_trans with (a+ ulp beta fexp1 a). right; now rewrite ulp_neq_0. apply (id_p_ulp_le_bpow _ _ _ _ Pa Fa). - apply Rabs_lt_inv, bpow_ln_beta_gt. + apply Rabs_lt_inv, bpow_mag_gt. - apply Rle_trans with (bpow (- 2) * u1 ^ 2). + unfold pow; rewrite Rmult_1_r. - unfold u1, u2, ulp, canonic_exp; bpow_simplify; apply bpow_le. + unfold u1, u2, ulp, cexp; bpow_simplify; apply bpow_le. now apply Hexp. + apply Rmult_le_compat. * apply bpow_ge_0. * apply pow2_ge_0. - * unfold Fcore_Raux.bpow, Z.pow_pos; simpl; rewrite Zmult_1_r. + * unfold Raux.bpow, Z.pow_pos; simpl; rewrite Zmult_1_r. apply Rinv_le; [lra|]. - change 4 with (Z2R (2 * 2)%Z); apply Z2R_le, Zmult_le_compat; omega. + change 4%Z with (2 * 2)%Z; apply IZR_le, Zmult_le_compat; omega. * rewrite <- (Rplus_0_l (u1 ^ 2)) at 1; apply Rplus_le_compat_r. apply pow2_ge_0. } assert (Hr' : x <= a * a + u1 * a). { rewrite Hla in Fa. rewrite <- Rmult_plus_distr_r. - unfold u1, ulp, canonic_exp. + unfold u1, ulp, cexp. rewrite <- (Rmult_1_l (bpow _)); rewrite Fa; rewrite <- Rmult_plus_distr_r. - rewrite <- Rmult_assoc; rewrite (Rmult_comm _ (Z2R ma)). - rewrite <- (Rmult_assoc (Z2R ma)); bpow_simplify. - apply (Rmult_le_reg_r (bpow (- 2 * fexp1 (ln_beta (sqrt x))))); + rewrite <- Rmult_assoc; rewrite (Rmult_comm _ (IZR ma)). + rewrite <- (Rmult_assoc (IZR ma)); bpow_simplify. + apply (Rmult_le_reg_r (bpow (- 2 * fexp1 (mag (sqrt x))))); [now apply bpow_gt_0|bpow_simplify]. rewrite Fx at 1; bpow_simplify. - rewrite <- Z2R_Zpower; [|omega]. - change 1 with (Z2R 1); rewrite <- Z2R_plus; do 2 rewrite <- Z2R_mult. - apply Z2R_le, Zlt_succ_le, lt_Z2R. - unfold Z.succ; rewrite Z2R_plus; do 2 rewrite Z2R_mult; rewrite Z2R_plus. - rewrite Z2R_Zpower; [|omega]. - apply (Rmult_lt_reg_r (bpow (2 * fexp1 (ln_beta (sqrt x))))); + rewrite <- IZR_Zpower; [|omega]. + rewrite <- plus_IZR, <- 2!mult_IZR. + apply IZR_le, Zlt_succ_le, lt_IZR. + unfold Z.succ; rewrite plus_IZR; do 2 rewrite mult_IZR; rewrite plus_IZR. + rewrite IZR_Zpower; [|omega]. + apply (Rmult_lt_reg_r (bpow (2 * fexp1 (mag (sqrt x))))); [now apply bpow_gt_0|bpow_simplify]. rewrite <- Fx. change 2%Z with (1 + 1)%Z; rewrite Zmult_plus_distr_l; rewrite Zmult_1_l. rewrite bpow_plus; simpl. replace (_ * _) with (a * a + u1 * a + u1 * u1); - [|unfold u1, ulp, canonic_exp; rewrite Fa; ring]. + [|unfold u1, ulp, cexp; rewrite Fa; ring]. apply (Rle_lt_trans _ _ _ Hsr). rewrite Rplus_assoc; apply Rplus_lt_compat_l. apply (Rplus_lt_reg_r (- b' * b' + / 2 * u1 * u2)); ring_simplify. replace (_ + _) with ((a + / 2 * u1) * u2) by ring. - apply Rlt_le_trans with (bpow (ln_beta (sqrt x)) * u2). + apply Rlt_le_trans with (bpow (mag (sqrt x)) * u2). - apply Rmult_lt_compat_r; [now unfold u2, ulp; apply bpow_gt_0|]. apply Rlt_le_trans with (a + u1); [lra|]. - unfold u1; fold (canonic_exp beta fexp1 (sqrt x)). - rewrite <- canonic_exp_DN; [|exact Vfexp1|exact Pa]; fold a. + unfold u1; fold (cexp beta fexp1 (sqrt x)). + rewrite <- cexp_DN; [|exact Vfexp1|exact Pa]; fold a. rewrite <- ulp_neq_0; trivial. apply id_p_ulp_le_bpow. + exact Pa. @@ -2789,27 +2772,27 @@ destruct (Req_dec a 0) as [Za|Nza]. + apply Rle_lt_trans with (sqrt x). * now apply round_DN_pt. * apply Rabs_lt_inv. - apply bpow_ln_beta_gt. + apply bpow_mag_gt. - apply Rle_trans with (/ 2 * u1 ^ 2). + apply Rle_trans with (bpow (- 2) * u1 ^ 2). * unfold pow; rewrite Rmult_1_r. - unfold u2, u1, ulp, canonic_exp. + unfold u2, u1, ulp, cexp. bpow_simplify. apply bpow_le. rewrite Zplus_comm. now apply Hexp. * apply Rmult_le_compat_r; [now apply pow2_ge_0|]. - unfold Fcore_Raux.bpow; simpl; unfold Z.pow_pos; simpl. + unfold Raux.bpow; simpl; unfold Z.pow_pos; simpl. rewrite Zmult_1_r. apply Rinv_le; [lra|]. - change 2 with (Z2R 2); apply Z2R_le. + apply IZR_le. rewrite <- (Zmult_1_l 2). apply Zmult_le_compat; omega. + assert (u2 ^ 2 < u1 ^ 2); [|unfold b'; lra]. unfold pow; do 2 rewrite Rmult_1_r. assert (H' : 0 <= u2); [unfold u2, ulp; apply bpow_ge_0|]. assert (u2 < u1); [|now apply Rmult_lt_compat]. - unfold u1, u2, ulp, canonic_exp; apply bpow_lt; omega. } + unfold u1, u2, ulp, cexp; apply bpow_lt; omega. } apply (Rlt_irrefl (a * a + u1 * a)). apply Rlt_le_trans with (a * a + u1 * a - u2 * a + b * b). + rewrite <- (Rplus_0_r (a * a + _)) at 1. @@ -2819,29 +2802,29 @@ destruct (Req_dec a 0) as [Za|Nza]. Qed. -Lemma double_round_sqrt : +Lemma round_round_sqrt : forall fexp1 fexp2 : Z -> Z, Valid_exp fexp1 -> Valid_exp fexp2 -> forall (choice1 choice2 : Z -> bool), - double_round_sqrt_hyp fexp1 fexp2 -> + round_round_sqrt_hyp fexp1 fexp2 -> forall x, generic_format beta fexp1 x -> - double_round_eq fexp1 fexp2 choice1 choice2 (sqrt x). + round_round_eq fexp1 fexp2 choice1 choice2 (sqrt x). Proof. intros fexp1 fexp2 Vfexp1 Vfexp2 choice1 choice2 Hexp x Fx. -unfold double_round_eq. +unfold round_round_eq. destruct (Rle_or_lt x 0) as [Npx|Px]. - (* x <= 0 *) rewrite (sqrt_neg _ Npx). now rewrite round_0; [|apply valid_rnd_N]. - (* 0 < x *) - assert (Hfx : (fexp1 (ln_beta x) < ln_beta x)%Z); - [now apply ln_beta_generic_gt; try assumption; lra|]. - assert (Hfsx : (fexp1 (ln_beta (sqrt x)) < ln_beta (sqrt x))%Z). + assert (Hfx : (fexp1 (mag x) < mag x)%Z); + [now apply mag_generic_gt; try assumption; lra|]. + assert (Hfsx : (fexp1 (mag (sqrt x)) < mag (sqrt x))%Z). { destruct (Rle_or_lt x 1) as [Hx|Hx]. - (* x <= 1 *) - apply (valid_exp_large fexp1 (ln_beta x)); [exact Hfx|]. - apply ln_beta_le; [exact Px|]. + apply (valid_exp_large fexp1 (mag x)); [exact Hfx|]. + apply mag_le; [exact Px|]. rewrite <- (sqrt_def x) at 1; [|lra]. rewrite <- Rmult_1_r. apply Rmult_le_compat_l. @@ -2854,64 +2837,62 @@ destruct (Rle_or_lt x 0) as [Npx|Px]. intro Hexp10. assert (Hf0 : (fexp1 1 < 1)%Z); [omega|clear Hexp10]. apply (valid_exp_large fexp1 1); [exact Hf0|]. - apply ln_beta_ge_bpow. + apply mag_ge_bpow. rewrite Zeq_minus; [|reflexivity]. - unfold Fcore_Raux.bpow; simpl. + unfold Raux.bpow; simpl. apply Rabs_ge; right. rewrite <- sqrt_1. apply sqrt_le_1_alt. now apply Rlt_le. } - assert (Hf2 : (fexp2 (ln_beta (sqrt x)) <= fexp1 (ln_beta (sqrt x)) - 1)%Z). - { assert (H : (fexp1 (2 * ln_beta (sqrt x)) < 2 * ln_beta (sqrt x))%Z). - { destruct (ln_beta_sqrt_disj x Px) as [Hlx|Hlx]. - - apply (valid_exp_large fexp1 (ln_beta x)); [|omega]. - now apply ln_beta_generic_gt; [|apply Rgt_not_eq|]. + assert (Hf2 : (fexp2 (mag (sqrt x)) <= fexp1 (mag (sqrt x)) - 1)%Z). + { assert (H : (fexp1 (2 * mag (sqrt x)) < 2 * mag (sqrt x))%Z). + { destruct (mag_sqrt_disj x Px) as [Hlx|Hlx]. + - apply (valid_exp_large fexp1 (mag x)); [|omega]. + now apply mag_generic_gt; [|apply Rgt_not_eq|]. - rewrite <- Hlx. - now apply ln_beta_generic_gt; [|apply Rgt_not_eq|]. } - generalize ((proj2 (proj2 Hexp)) (ln_beta (sqrt x)) H). + now apply mag_generic_gt; [|apply Rgt_not_eq|]. } + generalize ((proj2 (proj2 Hexp)) (mag (sqrt x)) H). omega. } - apply double_round_mid_cases. + apply round_round_mid_cases. + exact Vfexp1. + exact Vfexp2. + now apply sqrt_lt_R0. + omega. + omega. + intros Hmid; casetype False; apply (Rle_not_lt _ _ Hmid). - apply (double_round_sqrt_aux fexp1 fexp2 Vfexp1 Vfexp2 Hexp x Px Hf2 Fx). + apply (round_round_sqrt_aux fexp1 fexp2 Vfexp1 Vfexp2 Hexp x Px Hf2 Fx). Qed. Section Double_round_sqrt_FLX. -Import Fcore_FLX. - Variable prec : Z. Variable prec' : Z. Context { prec_gt_0_ : Prec_gt_0 prec }. Context { prec_gt_0_' : Prec_gt_0 prec' }. -Lemma FLX_double_round_sqrt_hyp : +Lemma FLX_round_round_sqrt_hyp : (2 * prec + 2 <= prec')%Z -> - double_round_sqrt_hyp (FLX_exp prec) (FLX_exp prec'). + round_round_sqrt_hyp (FLX_exp prec) (FLX_exp prec'). Proof. intros Hprec. unfold FLX_exp. unfold Prec_gt_0 in prec_gt_0_. -unfold double_round_sqrt_hyp; split; [|split]; intro ex; omega. +unfold round_round_sqrt_hyp; split; [|split]; intro ex; omega. Qed. -Theorem double_round_sqrt_FLX : +Theorem round_round_sqrt_FLX : forall choice1 choice2, (2 * prec + 2 <= prec')%Z -> forall x, FLX_format beta prec x -> - double_round_eq (FLX_exp prec) (FLX_exp prec') choice1 choice2 (sqrt x). + round_round_eq (FLX_exp prec) (FLX_exp prec') choice1 choice2 (sqrt x). Proof. intros choice1 choice2 Hprec x Fx. -apply double_round_sqrt. +apply round_round_sqrt. - now apply FLX_exp_valid. - now apply FLX_exp_valid. -- now apply FLX_double_round_sqrt_hyp. +- now apply FLX_round_round_sqrt_hyp. - now apply generic_format_FLX. Qed. @@ -2919,26 +2900,23 @@ End Double_round_sqrt_FLX. Section Double_round_sqrt_FLT. -Import Fcore_FLX. -Import Fcore_FLT. - Variable emin prec : Z. Variable emin' prec' : Z. Context { prec_gt_0_ : Prec_gt_0 prec }. Context { prec_gt_0_' : Prec_gt_0 prec' }. -Lemma FLT_double_round_sqrt_hyp : +Lemma FLT_round_round_sqrt_hyp : (emin <= 0)%Z -> ((emin' <= emin - prec - 2)%Z \/ (2 * emin' <= emin - 4 * prec - 2)%Z) -> (2 * prec + 2 <= prec')%Z -> - double_round_sqrt_hyp (FLT_exp emin prec) (FLT_exp emin' prec'). + round_round_sqrt_hyp (FLT_exp emin prec) (FLT_exp emin' prec'). Proof. intros Hemin Heminprec Hprec. unfold FLT_exp. unfold Prec_gt_0 in prec_gt_0_. -unfold double_round_sqrt_hyp; split; [|split]; intros ex. +unfold round_round_sqrt_hyp; split; [|split]; intros ex. - generalize (Zmax_spec (ex - prec) emin). generalize (Zmax_spec (2 * ex - prec) emin). omega. @@ -2951,7 +2929,7 @@ unfold double_round_sqrt_hyp; split; [|split]; intros ex. omega. Qed. -Theorem double_round_sqrt_FLT : +Theorem round_round_sqrt_FLT : forall choice1 choice2, (emin <= 0)%Z -> ((emin' <= emin - prec - 2)%Z @@ -2959,14 +2937,14 @@ Theorem double_round_sqrt_FLT : (2 * prec + 2 <= prec')%Z -> forall x, FLT_format beta emin prec x -> - double_round_eq (FLT_exp emin prec) (FLT_exp emin' prec') + round_round_eq (FLT_exp emin prec) (FLT_exp emin' prec') choice1 choice2 (sqrt x). Proof. intros choice1 choice2 Hemin Heminprec Hprec x Fx. -apply double_round_sqrt. +apply round_round_sqrt. - now apply FLT_exp_valid. - now apply FLT_exp_valid. -- now apply FLT_double_round_sqrt_hyp. +- now apply FLT_round_round_sqrt_hyp. - now apply generic_format_FLT. Qed. @@ -2974,24 +2952,21 @@ End Double_round_sqrt_FLT. Section Double_round_sqrt_FTZ. -Import Fcore_FLX. -Import Fcore_FTZ. - Variable emin prec : Z. Variable emin' prec' : Z. Context { prec_gt_0_ : Prec_gt_0 prec }. Context { prec_gt_0_' : Prec_gt_0 prec' }. -Lemma FTZ_double_round_sqrt_hyp : +Lemma FTZ_round_round_sqrt_hyp : (2 * (emin' + prec') <= emin + prec <= 1)%Z -> (2 * prec + 2 <= prec')%Z -> - double_round_sqrt_hyp (FTZ_exp emin prec) (FTZ_exp emin' prec'). + round_round_sqrt_hyp (FTZ_exp emin prec) (FTZ_exp emin' prec'). Proof. intros Hemin Hprec. unfold FTZ_exp. unfold Prec_gt_0 in *. -unfold double_round_sqrt_hyp; split; [|split]; intros ex. +unfold round_round_sqrt_hyp; split; [|split]; intros ex. - destruct (Z.ltb_spec (ex - prec) emin); destruct (Z.ltb_spec (2 * ex - prec) emin); omega. @@ -3008,49 +2983,49 @@ unfold double_round_sqrt_hyp; split; [|split]; intros ex. omega. Qed. -Theorem double_round_sqrt_FTZ : +Theorem round_round_sqrt_FTZ : (4 <= beta)%Z -> forall choice1 choice2, (2 * (emin' + prec') <= emin + prec <= 1)%Z -> (2 * prec + 2 <= prec')%Z -> forall x, FTZ_format beta emin prec x -> - double_round_eq (FTZ_exp emin prec) (FTZ_exp emin' prec') + round_round_eq (FTZ_exp emin prec) (FTZ_exp emin' prec') choice1 choice2 (sqrt x). Proof. intros Hbeta choice1 choice2 Hemin Hprec x Fx. -apply double_round_sqrt. +apply round_round_sqrt. - now apply FTZ_exp_valid. - now apply FTZ_exp_valid. -- now apply FTZ_double_round_sqrt_hyp. +- now apply FTZ_round_round_sqrt_hyp. - now apply generic_format_FTZ. Qed. End Double_round_sqrt_FTZ. -Section Double_round_sqrt_beta_ge_4. +Section Double_round_sqrt_radix_ge_4. -Definition double_round_sqrt_beta_ge_4_hyp fexp1 fexp2 := +Definition round_round_sqrt_radix_ge_4_hyp fexp1 fexp2 := (forall ex, (2 * fexp1 ex <= fexp1 (2 * ex))%Z) /\ (forall ex, (2 * fexp1 ex <= fexp1 (2 * ex - 1))%Z) /\ (forall ex, (fexp1 (2 * ex) < 2 * ex)%Z -> (fexp2 ex + ex <= 2 * fexp1 ex - 1)%Z). -Lemma double_round_sqrt_beta_ge_4_aux : +Lemma round_round_sqrt_radix_ge_4_aux : (4 <= beta)%Z -> forall fexp1 fexp2 : Z -> Z, Valid_exp fexp1 -> Valid_exp fexp2 -> - double_round_sqrt_beta_ge_4_hyp fexp1 fexp2 -> + round_round_sqrt_radix_ge_4_hyp fexp1 fexp2 -> forall x, 0 < x -> - (fexp2 (ln_beta (sqrt x)) <= fexp1 (ln_beta (sqrt x)) - 1)%Z -> + (fexp2 (mag (sqrt x)) <= fexp1 (mag (sqrt x)) - 1)%Z -> generic_format beta fexp1 x -> / 2 * ulp beta fexp2 (sqrt x) < Rabs (sqrt x - midp fexp1 (sqrt x)). Proof. intros Hbeta fexp1 fexp2 Vfexp1 Vfexp2 Hexp x Px Hf2 Fx. set (a := round beta fexp1 Zfloor (sqrt x)). -set (u1 := bpow (fexp1 (ln_beta (sqrt x)))). -set (u2 := bpow (fexp2 (ln_beta (sqrt x)))). +set (u1 := bpow (fexp1 (mag (sqrt x)))). +set (u2 := bpow (fexp2 (mag (sqrt x)))). set (b := / 2 * (u1 - u2)). set (b' := / 2 * (u1 + u2)). unfold midp; rewrite 2!ulp_neq_0; try now apply Rgt_not_eq, sqrt_lt_R0. @@ -3061,9 +3036,9 @@ assert (Fa : generic_format beta fexp1 a). - exact Vfexp1. - now apply valid_rnd_DN. } revert Fa; revert Fx. -unfold generic_format, F2R, scaled_mantissa, canonic_exp; simpl. -set (mx := Ztrunc (x * bpow (- fexp1 (ln_beta x)))). -set (ma := Ztrunc (a * bpow (- fexp1 (ln_beta a)))). +unfold generic_format, F2R, scaled_mantissa, cexp; simpl. +set (mx := Ztrunc (x * bpow (- fexp1 (mag x)))). +set (ma := Ztrunc (a * bpow (- fexp1 (mag a)))). intros Fx Fa. assert (Nna : 0 <= a). { rewrite <- (round_0 beta fexp1 Zfloor). @@ -3080,7 +3055,7 @@ assert (Pb : 0 < b). rewrite <- (Rmult_0_r (/ 2)). apply Rmult_lt_compat_l; [lra|]. apply Rlt_Rminus. - unfold u2, u1, ulp, canonic_exp. + unfold u2, u1, ulp, cexp. apply bpow_lt. omega. } assert (Pb' : 0 < b'). @@ -3094,14 +3069,14 @@ assert (Hl : a + b <= sqrt x). replace (_ + sqrt _) with (sqrt x - (a + / 2 * u1)) by ring. rewrite Ropp_mult_distr_l_reverse. now apply Rabs_le_inv in H; destruct H. } -assert (Hf1 : (2 * fexp1 (ln_beta (sqrt x)) <= fexp1 (ln_beta (x)))%Z); - [destruct (ln_beta_sqrt_disj x Px) as [H'|H']; rewrite H'; apply Hexp|]. -assert (Hlx : (fexp1 (2 * ln_beta (sqrt x)) < 2 * ln_beta (sqrt x))%Z). -{ destruct (ln_beta_sqrt_disj x Px) as [Hlx|Hlx]. - - apply (valid_exp_large fexp1 (ln_beta x)); [|omega]. - now apply ln_beta_generic_gt; [|apply Rgt_not_eq|]. +assert (Hf1 : (2 * fexp1 (mag (sqrt x)) <= fexp1 (mag (x)))%Z); + [destruct (mag_sqrt_disj x Px) as [H'|H']; rewrite H'; apply Hexp|]. +assert (Hlx : (fexp1 (2 * mag (sqrt x)) < 2 * mag (sqrt x))%Z). +{ destruct (mag_sqrt_disj x Px) as [Hlx|Hlx]. + - apply (valid_exp_large fexp1 (mag x)); [|omega]. + now apply mag_generic_gt; [|apply Rgt_not_eq|]. - rewrite <- Hlx. - now apply ln_beta_generic_gt; [|apply Rgt_not_eq|]. } + now apply mag_generic_gt; [|apply Rgt_not_eq|]. } assert (Hsl : a * a + u1 * a - u2 * a + b * b <= x). { replace (_ + _) with ((a + b) * (a + b)); [|now unfold b; field]. rewrite <- sqrt_def; [|now apply Rlt_le]. @@ -3120,34 +3095,33 @@ destruct (Req_dec a 0) as [Za|Nza]. + revert Hsl; unfold Rminus; rewrite Za; do 3 rewrite Rmult_0_r. now rewrite Ropp_0; do 3 rewrite Rplus_0_l. + rewrite Fx. - apply (Rmult_le_reg_r (bpow (- fexp1 (ln_beta x)))); + apply (Rmult_le_reg_r (bpow (- fexp1 (mag x)))); [now apply bpow_gt_0|]. rewrite Rmult_0_l; bpow_simplify. unfold mx. rewrite Ztrunc_floor; [|now apply Rmult_le_pos; [apply Rlt_le|apply bpow_ge_0]]. - apply Req_le. - change 0 with (Z2R 0); apply f_equal. + apply Req_le, IZR_eq. apply Zfloor_imp. split; [now apply Rmult_le_pos; [apply Rlt_le|apply bpow_ge_0]|simpl]. - apply (Rmult_lt_reg_r (bpow (fexp1 (ln_beta x)))); [now apply bpow_gt_0|]. + apply (Rmult_lt_reg_r (bpow (fexp1 (mag x)))); [now apply bpow_gt_0|]. rewrite Rmult_1_l; bpow_simplify. - apply Rlt_le_trans with (bpow (2 * fexp1 (ln_beta (sqrt x)))); + apply Rlt_le_trans with (bpow (2 * fexp1 (mag (sqrt x)))); [|now apply bpow_le]. change 2%Z with (1 + 1)%Z; rewrite Zmult_plus_distr_l; rewrite Zmult_1_l. rewrite bpow_plus. rewrite <- (sqrt_def x) at 1; [|now apply Rlt_le]. - assert (sqrt x < bpow (fexp1 (ln_beta (sqrt x)))); + assert (sqrt x < bpow (fexp1 (mag (sqrt x)))); [|now apply Rmult_lt_compat; [apply sqrt_pos|apply sqrt_pos| |]]. apply (Rle_lt_trans _ _ _ Hr); rewrite Za; rewrite Rplus_0_l. unfold b'; change (bpow _) with u1. apply Rlt_le_trans with (/ 2 * (u1 + u1)); [|lra]. apply Rmult_lt_compat_l; [lra|]; apply Rplus_lt_compat_l. - unfold u2, u1, ulp, canonic_exp; apply bpow_lt; omega. + unfold u2, u1, ulp, cexp; apply bpow_lt; omega. - (* a <> 0 *) assert (Pa : 0 < a); [lra|]. - assert (Hla : (ln_beta a = ln_beta (sqrt x) :> Z)). - { unfold a; apply ln_beta_DN. + assert (Hla : (mag a = mag (sqrt x) :> Z)). + { unfold a; apply mag_DN. - exact Vfexp1. - now fold a. } assert (Hl' : 0 < - (u2 * a) + b * b). @@ -3156,7 +3130,7 @@ destruct (Req_dec a 0) as [Za|Nza]. apply (Rplus_lt_reg_r (/ 2 * u2 * u1)); field_simplify. replace (_ / 2) with (u2 * (a + / 2 * u1)) by field. replace (_ / 8) with (/ 4 * (u2 ^ 2 + u1 ^ 2)) by field. - apply Rlt_le_trans with (u2 * bpow (ln_beta (sqrt x))). + apply Rlt_le_trans with (u2 * bpow (mag (sqrt x))). - apply Rmult_lt_compat_l; [now unfold u2, ulp; apply bpow_gt_0|]. unfold u1; rewrite <- Hla. apply Rlt_le_trans with (a + ulp beta fexp1 a). @@ -3165,50 +3139,50 @@ destruct (Req_dec a 0) as [Za|Nza]. rewrite ulp_neq_0; trivial. apply Rmult_lt_compat_r; [apply bpow_gt_0|lra]. + apply (id_p_ulp_le_bpow _ _ _ _ Pa Fa). - apply Rabs_lt_inv, bpow_ln_beta_gt. + apply Rabs_lt_inv, bpow_mag_gt. - apply Rle_trans with (bpow (- 1) * u1 ^ 2). + unfold pow; rewrite Rmult_1_r. - unfold u1, u2, ulp, canonic_exp; bpow_simplify; apply bpow_le. + unfold u1, u2, ulp, cexp; bpow_simplify; apply bpow_le. now apply Hexp. + apply Rmult_le_compat. * apply bpow_ge_0. * apply pow2_ge_0. - * unfold Fcore_Raux.bpow, Z.pow_pos; simpl; rewrite Zmult_1_r. + * unfold Raux.bpow, Z.pow_pos; simpl; rewrite Zmult_1_r. apply Rinv_le; [lra|]. - now change 4 with (Z2R 4); apply Z2R_le. + now apply IZR_le. * rewrite <- (Rplus_0_l (u1 ^ 2)) at 1; apply Rplus_le_compat_r. apply pow2_ge_0. } assert (Hr' : x <= a * a + u1 * a). { rewrite Hla in Fa. rewrite <- Rmult_plus_distr_r. - unfold u1, ulp, canonic_exp. + unfold u1, ulp, cexp. rewrite <- (Rmult_1_l (bpow _)); rewrite Fa; rewrite <- Rmult_plus_distr_r. - rewrite <- Rmult_assoc; rewrite (Rmult_comm _ (Z2R ma)). - rewrite <- (Rmult_assoc (Z2R ma)); bpow_simplify. - apply (Rmult_le_reg_r (bpow (- 2 * fexp1 (ln_beta (sqrt x))))); + rewrite <- Rmult_assoc; rewrite (Rmult_comm _ (IZR ma)). + rewrite <- (Rmult_assoc (IZR ma)); bpow_simplify. + apply (Rmult_le_reg_r (bpow (- 2 * fexp1 (mag (sqrt x))))); [now apply bpow_gt_0|bpow_simplify]. rewrite Fx at 1; bpow_simplify. - rewrite <- Z2R_Zpower; [|omega]. - change 1 with (Z2R 1); rewrite <- Z2R_plus; do 2 rewrite <- Z2R_mult. - apply Z2R_le, Zlt_succ_le, lt_Z2R. - unfold Z.succ; rewrite Z2R_plus; do 2 rewrite Z2R_mult; rewrite Z2R_plus. - rewrite Z2R_Zpower; [|omega]. - apply (Rmult_lt_reg_r (bpow (2 * fexp1 (ln_beta (sqrt x))))); + rewrite <- IZR_Zpower; [|omega]. + rewrite <- plus_IZR, <- 2!mult_IZR. + apply IZR_le, Zlt_succ_le, lt_IZR. + unfold Z.succ; rewrite plus_IZR; do 2 rewrite mult_IZR; rewrite plus_IZR. + rewrite IZR_Zpower; [|omega]. + apply (Rmult_lt_reg_r (bpow (2 * fexp1 (mag (sqrt x))))); [now apply bpow_gt_0|bpow_simplify]. rewrite <- Fx. change 2%Z with (1 + 1)%Z; rewrite Zmult_plus_distr_l; rewrite Zmult_1_l. rewrite bpow_plus; simpl. replace (_ * _) with (a * a + u1 * a + u1 * u1); - [|unfold u1, ulp, canonic_exp; rewrite Fa; ring]. + [|unfold u1, ulp, cexp; rewrite Fa; ring]. apply (Rle_lt_trans _ _ _ Hsr). rewrite Rplus_assoc; apply Rplus_lt_compat_l. apply (Rplus_lt_reg_r (- b' * b' + / 2 * u1 * u2)); ring_simplify. replace (_ + _) with ((a + / 2 * u1) * u2) by ring. - apply Rlt_le_trans with (bpow (ln_beta (sqrt x)) * u2). + apply Rlt_le_trans with (bpow (mag (sqrt x)) * u2). - apply Rmult_lt_compat_r; [now unfold u2, ulp; apply bpow_gt_0|]. apply Rlt_le_trans with (a + u1); [lra|]. - unfold u1; fold (canonic_exp beta fexp1 (sqrt x)). - rewrite <- canonic_exp_DN; [|exact Vfexp1|exact Pa]; fold a. + unfold u1; fold (cexp beta fexp1 (sqrt x)). + rewrite <- cexp_DN; [|exact Vfexp1|exact Pa]; fold a. rewrite <- ulp_neq_0; trivial. apply id_p_ulp_le_bpow. + exact Pa. @@ -3216,25 +3190,25 @@ destruct (Req_dec a 0) as [Za|Nza]. + apply Rle_lt_trans with (sqrt x). * now apply round_DN_pt. * apply Rabs_lt_inv. - apply bpow_ln_beta_gt. + apply bpow_mag_gt. - apply Rle_trans with (/ 2 * u1 ^ 2). + apply Rle_trans with (bpow (- 1) * u1 ^ 2). * unfold pow; rewrite Rmult_1_r. - unfold u2, u1, ulp, canonic_exp. + unfold u2, u1, ulp, cexp. bpow_simplify. apply bpow_le. rewrite Zplus_comm. now apply Hexp. * apply Rmult_le_compat_r; [now apply pow2_ge_0|]. - unfold Fcore_Raux.bpow; simpl; unfold Z.pow_pos; simpl. + unfold Raux.bpow; simpl; unfold Z.pow_pos; simpl. rewrite Zmult_1_r. apply Rinv_le; [lra|]. - change 2 with (Z2R 2); apply Z2R_le; omega. + apply IZR_le; omega. + assert (u2 ^ 2 < u1 ^ 2); [|unfold b'; lra]. unfold pow; do 2 rewrite Rmult_1_r. assert (H' : 0 <= u2); [unfold u2, ulp; apply bpow_ge_0|]. assert (u2 < u1); [|now apply Rmult_lt_compat]. - unfold u1, u2, ulp, canonic_exp; apply bpow_lt; omega. } + unfold u1, u2, ulp, cexp; apply bpow_lt; omega. } apply (Rlt_irrefl (a * a + u1 * a)). apply Rlt_le_trans with (a * a + u1 * a - u2 * a + b * b). + rewrite <- (Rplus_0_r (a * a + _)) at 1. @@ -3243,18 +3217,18 @@ destruct (Req_dec a 0) as [Za|Nza]. + now apply Rle_trans with x. Qed. -Lemma double_round_sqrt_beta_ge_4 : +Lemma round_round_sqrt_radix_ge_4 : (4 <= beta)%Z -> forall fexp1 fexp2 : Z -> Z, Valid_exp fexp1 -> Valid_exp fexp2 -> forall (choice1 choice2 : Z -> bool), - double_round_sqrt_beta_ge_4_hyp fexp1 fexp2 -> + round_round_sqrt_radix_ge_4_hyp fexp1 fexp2 -> forall x, generic_format beta fexp1 x -> - double_round_eq fexp1 fexp2 choice1 choice2 (sqrt x). + round_round_eq fexp1 fexp2 choice1 choice2 (sqrt x). Proof. intros Hbeta fexp1 fexp2 Vfexp1 Vfexp2 choice1 choice2 Hexp x Fx. -unfold double_round_eq. +unfold round_round_eq. destruct (Rle_or_lt x 0) as [Npx|Px]. - (* x <= 0 *) assert (Hs : sqrt x = 0). @@ -3272,13 +3246,13 @@ destruct (Rle_or_lt x 0) as [Npx|Px]. + reflexivity. + now apply valid_rnd_N. - (* 0 < x *) - assert (Hfx : (fexp1 (ln_beta x) < ln_beta x)%Z); - [now apply ln_beta_generic_gt; try assumption; lra|]. - assert (Hfsx : (fexp1 (ln_beta (sqrt x)) < ln_beta (sqrt x))%Z). + assert (Hfx : (fexp1 (mag x) < mag x)%Z); + [now apply mag_generic_gt; try assumption; lra|]. + assert (Hfsx : (fexp1 (mag (sqrt x)) < mag (sqrt x))%Z). { destruct (Rle_or_lt x 1) as [Hx|Hx]. - (* x <= 1 *) - apply (valid_exp_large fexp1 (ln_beta x)); [exact Hfx|]. - apply ln_beta_le; [exact Px|]. + apply (valid_exp_large fexp1 (mag x)); [exact Hfx|]. + apply mag_le; [exact Px|]. rewrite <- (sqrt_def x) at 1; [|lra]. rewrite <- Rmult_1_r. apply Rmult_le_compat_l. @@ -3291,36 +3265,34 @@ destruct (Rle_or_lt x 0) as [Npx|Px]. intro Hexp10. assert (Hf0 : (fexp1 1 < 1)%Z); [omega|clear Hexp10]. apply (valid_exp_large fexp1 1); [exact Hf0|]. - apply ln_beta_ge_bpow. + apply mag_ge_bpow. rewrite Zeq_minus; [|reflexivity]. - unfold Fcore_Raux.bpow; simpl. + unfold Raux.bpow; simpl. apply Rabs_ge; right. rewrite <- sqrt_1. apply sqrt_le_1_alt. now apply Rlt_le. } - assert (Hf2 : (fexp2 (ln_beta (sqrt x)) <= fexp1 (ln_beta (sqrt x)) - 1)%Z). - { assert (H : (fexp1 (2 * ln_beta (sqrt x)) < 2 * ln_beta (sqrt x))%Z). - { destruct (ln_beta_sqrt_disj x Px) as [Hlx|Hlx]. - - apply (valid_exp_large fexp1 (ln_beta x)); [|omega]. - now apply ln_beta_generic_gt; [|apply Rgt_not_eq|]. + assert (Hf2 : (fexp2 (mag (sqrt x)) <= fexp1 (mag (sqrt x)) - 1)%Z). + { assert (H : (fexp1 (2 * mag (sqrt x)) < 2 * mag (sqrt x))%Z). + { destruct (mag_sqrt_disj x Px) as [Hlx|Hlx]. + - apply (valid_exp_large fexp1 (mag x)); [|omega]. + now apply mag_generic_gt; [|apply Rgt_not_eq|]. - rewrite <- Hlx. - now apply ln_beta_generic_gt; [|apply Rgt_not_eq|]. } - generalize ((proj2 (proj2 Hexp)) (ln_beta (sqrt x)) H). + now apply mag_generic_gt; [|apply Rgt_not_eq|]. } + generalize ((proj2 (proj2 Hexp)) (mag (sqrt x)) H). omega. } - apply double_round_mid_cases. + apply round_round_mid_cases. + exact Vfexp1. + exact Vfexp2. + now apply sqrt_lt_R0. + omega. + omega. + intros Hmid; casetype False; apply (Rle_not_lt _ _ Hmid). - apply (double_round_sqrt_beta_ge_4_aux Hbeta fexp1 fexp2 Vfexp1 Vfexp2 + apply (round_round_sqrt_radix_ge_4_aux Hbeta fexp1 fexp2 Vfexp1 Vfexp2 Hexp x Px Hf2 Fx). Qed. -Section Double_round_sqrt_beta_ge_4_FLX. - -Import Fcore_FLX. +Section Double_round_sqrt_radix_ge_4_FLX. Variable prec : Z. Variable prec' : Z. @@ -3328,39 +3300,36 @@ Variable prec' : Z. Context { prec_gt_0_ : Prec_gt_0 prec }. Context { prec_gt_0_' : Prec_gt_0 prec' }. -Lemma FLX_double_round_sqrt_beta_ge_4_hyp : +Lemma FLX_round_round_sqrt_radix_ge_4_hyp : (2 * prec + 1 <= prec')%Z -> - double_round_sqrt_beta_ge_4_hyp (FLX_exp prec) (FLX_exp prec'). + round_round_sqrt_radix_ge_4_hyp (FLX_exp prec) (FLX_exp prec'). Proof. intros Hprec. unfold FLX_exp. unfold Prec_gt_0 in prec_gt_0_. -unfold double_round_sqrt_beta_ge_4_hyp; split; [|split]; intro ex; omega. +unfold round_round_sqrt_radix_ge_4_hyp; split; [|split]; intro ex; omega. Qed. -Theorem double_round_sqrt_beta_ge_4_FLX : +Theorem round_round_sqrt_radix_ge_4_FLX : (4 <= beta)%Z -> forall choice1 choice2, (2 * prec + 1 <= prec')%Z -> forall x, FLX_format beta prec x -> - double_round_eq (FLX_exp prec) (FLX_exp prec') choice1 choice2 (sqrt x). + round_round_eq (FLX_exp prec) (FLX_exp prec') choice1 choice2 (sqrt x). Proof. intros Hbeta choice1 choice2 Hprec x Fx. -apply double_round_sqrt_beta_ge_4. +apply round_round_sqrt_radix_ge_4. - exact Hbeta. - now apply FLX_exp_valid. - now apply FLX_exp_valid. -- now apply FLX_double_round_sqrt_beta_ge_4_hyp. +- now apply FLX_round_round_sqrt_radix_ge_4_hyp. - now apply generic_format_FLX. Qed. -End Double_round_sqrt_beta_ge_4_FLX. +End Double_round_sqrt_radix_ge_4_FLX. -Section Double_round_sqrt_beta_ge_4_FLT. - -Import Fcore_FLX. -Import Fcore_FLT. +Section Double_round_sqrt_radix_ge_4_FLT. Variable emin prec : Z. Variable emin' prec' : Z. @@ -3368,17 +3337,17 @@ Variable emin' prec' : Z. Context { prec_gt_0_ : Prec_gt_0 prec }. Context { prec_gt_0_' : Prec_gt_0 prec' }. -Lemma FLT_double_round_sqrt_beta_ge_4_hyp : +Lemma FLT_round_round_sqrt_radix_ge_4_hyp : (emin <= 0)%Z -> ((emin' <= emin - prec - 1)%Z \/ (2 * emin' <= emin - 4 * prec)%Z) -> (2 * prec + 1 <= prec')%Z -> - double_round_sqrt_beta_ge_4_hyp (FLT_exp emin prec) (FLT_exp emin' prec'). + round_round_sqrt_radix_ge_4_hyp (FLT_exp emin prec) (FLT_exp emin' prec'). Proof. intros Hemin Heminprec Hprec. unfold FLT_exp. unfold Prec_gt_0 in prec_gt_0_. -unfold double_round_sqrt_beta_ge_4_hyp; split; [|split]; intros ex. +unfold round_round_sqrt_radix_ge_4_hyp; split; [|split]; intros ex. - generalize (Zmax_spec (ex - prec) emin). generalize (Zmax_spec (2 * ex - prec) emin). omega. @@ -3391,7 +3360,7 @@ unfold double_round_sqrt_beta_ge_4_hyp; split; [|split]; intros ex. omega. Qed. -Theorem double_round_sqrt_beta_ge_4_FLT : +Theorem round_round_sqrt_radix_ge_4_FLT : (4 <= beta)%Z -> forall choice1 choice2, (emin <= 0)%Z -> @@ -3400,24 +3369,21 @@ Theorem double_round_sqrt_beta_ge_4_FLT : (2 * prec + 1 <= prec')%Z -> forall x, FLT_format beta emin prec x -> - double_round_eq (FLT_exp emin prec) (FLT_exp emin' prec') + round_round_eq (FLT_exp emin prec) (FLT_exp emin' prec') choice1 choice2 (sqrt x). Proof. intros Hbeta choice1 choice2 Hemin Heminprec Hprec x Fx. -apply double_round_sqrt_beta_ge_4. +apply round_round_sqrt_radix_ge_4. - exact Hbeta. - now apply FLT_exp_valid. - now apply FLT_exp_valid. -- now apply FLT_double_round_sqrt_beta_ge_4_hyp. +- now apply FLT_round_round_sqrt_radix_ge_4_hyp. - now apply generic_format_FLT. Qed. -End Double_round_sqrt_beta_ge_4_FLT. - -Section Double_round_sqrt_beta_ge_4_FTZ. +End Double_round_sqrt_radix_ge_4_FLT. -Import Fcore_FLX. -Import Fcore_FTZ. +Section Double_round_sqrt_radix_ge_4_FTZ. Variable emin prec : Z. Variable emin' prec' : Z. @@ -3425,15 +3391,15 @@ Variable emin' prec' : Z. Context { prec_gt_0_ : Prec_gt_0 prec }. Context { prec_gt_0_' : Prec_gt_0 prec' }. -Lemma FTZ_double_round_sqrt_beta_ge_4_hyp : +Lemma FTZ_round_round_sqrt_radix_ge_4_hyp : (2 * (emin' + prec') <= emin + prec <= 1)%Z -> (2 * prec + 1 <= prec')%Z -> - double_round_sqrt_beta_ge_4_hyp (FTZ_exp emin prec) (FTZ_exp emin' prec'). + round_round_sqrt_radix_ge_4_hyp (FTZ_exp emin prec) (FTZ_exp emin' prec'). Proof. intros Hemin Hprec. unfold FTZ_exp. unfold Prec_gt_0 in *. -unfold double_round_sqrt_beta_ge_4_hyp; split; [|split]; intros ex. +unfold round_round_sqrt_radix_ge_4_hyp; split; [|split]; intros ex. - destruct (Z.ltb_spec (ex - prec) emin); destruct (Z.ltb_spec (2 * ex - prec) emin); omega. @@ -3450,47 +3416,47 @@ unfold double_round_sqrt_beta_ge_4_hyp; split; [|split]; intros ex. omega. Qed. -Theorem double_round_sqrt_beta_ge_4_FTZ : +Theorem round_round_sqrt_radix_ge_4_FTZ : (4 <= beta)%Z -> forall choice1 choice2, (2 * (emin' + prec') <= emin + prec <= 1)%Z -> (2 * prec + 1 <= prec')%Z -> forall x, FTZ_format beta emin prec x -> - double_round_eq (FTZ_exp emin prec) (FTZ_exp emin' prec') + round_round_eq (FTZ_exp emin prec) (FTZ_exp emin' prec') choice1 choice2 (sqrt x). Proof. intros Hbeta choice1 choice2 Hemin Hprec x Fx. -apply double_round_sqrt_beta_ge_4. +apply round_round_sqrt_radix_ge_4. - exact Hbeta. - now apply FTZ_exp_valid. - now apply FTZ_exp_valid. -- now apply FTZ_double_round_sqrt_beta_ge_4_hyp. +- now apply FTZ_round_round_sqrt_radix_ge_4_hyp. - now apply generic_format_FTZ. Qed. -End Double_round_sqrt_beta_ge_4_FTZ. +End Double_round_sqrt_radix_ge_4_FTZ. -End Double_round_sqrt_beta_ge_4. +End Double_round_sqrt_radix_ge_4. End Double_round_sqrt. Section Double_round_div. -Lemma double_round_eq_mid_beta_even : +Lemma round_round_eq_mid_beta_even : forall (fexp1 fexp2 : Z -> Z), Valid_exp fexp1 -> Valid_exp fexp2 -> forall (choice1 choice2 : Z -> bool), (exists n, (beta = 2 * n :> Z)%Z) -> forall x, 0 < x -> - (fexp2 (ln_beta x) <= fexp1 (ln_beta x) - 1)%Z -> - (fexp1 (ln_beta x) <= ln_beta x)%Z -> + (fexp2 (mag x) <= fexp1 (mag x) - 1)%Z -> + (fexp1 (mag x) <= mag x)%Z -> x = midp fexp1 x -> - double_round_eq fexp1 fexp2 choice1 choice2 x. + round_round_eq fexp1 fexp2 choice1 choice2 x. Proof. intros fexp1 fexp2 Vfexp1 Vfexp2 choice1 choice2 Ebeta x Px Hf2 Hf1. -unfold double_round_eq. +unfold round_round_eq. unfold midp. set (rd := round beta fexp1 Zfloor x). set (u := ulp beta fexp1 x). @@ -3505,30 +3471,30 @@ assert (Hbeta : (2 <= beta)%Z). apply (Rplus_eq_compat_l rd) in Xmid; ring_simplify in Xmid. rewrite (round_generic beta fexp2); [reflexivity|now apply valid_rnd_N|]. set (f := Float beta (Zfloor (scaled_mantissa beta fexp2 rd) - + n * beta ^ (fexp1 (ln_beta x) - 1 - - fexp2 (ln_beta x))) - (canonic_exp beta fexp2 x)). + + n * beta ^ (fexp1 (mag x) - 1 + - fexp2 (mag x))) + (cexp beta fexp2 x)). assert (Hf : F2R f = x). { unfold f, F2R; simpl. - rewrite Z2R_plus. + rewrite plus_IZR. rewrite Rmult_plus_distr_r. - rewrite Z2R_mult. - rewrite Z2R_Zpower; [|omega]. - unfold canonic_exp at 2; bpow_simplify. + rewrite mult_IZR. + rewrite IZR_Zpower; [|omega]. + unfold cexp at 2; bpow_simplify. unfold Zminus; rewrite bpow_plus. rewrite (Rmult_comm _ (bpow (- 1))). - rewrite <- (Rmult_assoc (Z2R n)). - change (bpow (- 1)) with (/ Z2R (beta * 1)). + rewrite <- (Rmult_assoc (IZR n)). + change (bpow (- 1)) with (/ IZR (beta * 1)). rewrite Zmult_1_r. rewrite Ebeta. - rewrite (Z2R_mult 2). + rewrite (mult_IZR 2). rewrite Rinv_mult_distr; - [|simpl; lra|change 0 with (Z2R 0); apply Z2R_neq; omega]. - rewrite <- Rmult_assoc; rewrite (Rmult_comm (Z2R n)); - rewrite (Rmult_assoc _ (Z2R n)). + [|simpl; lra | apply IZR_neq; omega]. + rewrite <- Rmult_assoc; rewrite (Rmult_comm (IZR n)); + rewrite (Rmult_assoc _ (IZR n)). rewrite Rinv_r; - [rewrite Rmult_1_r|change 0 with (Z2R 0); apply Z2R_neq; omega]. - simpl; fold (canonic_exp beta fexp1 x). + [rewrite Rmult_1_r | apply IZR_neq; omega]. + simpl; fold (cexp beta fexp1 x). rewrite <- 2!ulp_neq_0; try now apply Rgt_not_eq. fold u; rewrite Xmid at 2. apply f_equal2; [|reflexivity]. @@ -3537,7 +3503,7 @@ assert (Hf : F2R f = x). - (* rd = 0 *) rewrite Zrd. rewrite scaled_mantissa_0. - change 0 with (Z2R 0) at 1; rewrite Zfloor_Z2R. + rewrite Zfloor_IZR. now rewrite Rmult_0_l. - (* rd <> 0 *) assert (Nnrd : 0 <= rd). @@ -3546,187 +3512,187 @@ assert (Hf : F2R f = x). - apply generic_format_0. - now apply Rlt_le. } assert (Prd : 0 < rd); [lra|]. - assert (Lrd : (ln_beta rd = ln_beta x :> Z)). + assert (Lrd : (mag rd = mag x :> Z)). { apply Zle_antisym. - - apply ln_beta_le; [exact Prd|]. + - apply mag_le; [exact Prd|]. now apply round_DN_pt. - - apply ln_beta_round_ge. + - apply mag_round_ge. + exact Vfexp1. + now apply valid_rnd_DN. + exact Nzrd. } unfold scaled_mantissa. unfold rd at 1. - unfold round, F2R, scaled_mantissa, canonic_exp; simpl. + unfold round, F2R, scaled_mantissa, cexp; simpl. bpow_simplify. rewrite Lrd. - rewrite <- (Z2R_Zpower _ (_ - _)); [|omega]. - rewrite <- Z2R_mult. - rewrite (Zfloor_imp (Zfloor (x * bpow (- fexp1 (ln_beta x))) * - beta ^ (fexp1 (ln_beta x) - fexp2 (ln_beta x)))). - + rewrite Z2R_mult. - rewrite Z2R_Zpower; [|omega]. + rewrite <- (IZR_Zpower _ (_ - _)); [|omega]. + rewrite <- mult_IZR. + rewrite (Zfloor_imp (Zfloor (x * bpow (- fexp1 (mag x))) * + beta ^ (fexp1 (mag x) - fexp2 (mag x)))). + + rewrite mult_IZR. + rewrite IZR_Zpower; [|omega]. bpow_simplify. now unfold rd. + split; [now apply Rle_refl|]. - rewrite Z2R_plus. + rewrite plus_IZR. simpl; lra. } apply (generic_format_F2R' _ _ x f Hf). intros _. -apply Zle_refl. +apply Z.le_refl. Qed. -Lemma double_round_really_zero : +Lemma round_round_really_zero : forall (fexp1 fexp2 : Z -> Z), Valid_exp fexp1 -> Valid_exp fexp2 -> forall (choice1 choice2 : Z -> bool), forall x, 0 < x -> - (ln_beta x <= fexp1 (ln_beta x) - 2)%Z -> - double_round_eq fexp1 fexp2 choice1 choice2 x. + (mag x <= fexp1 (mag x) - 2)%Z -> + round_round_eq fexp1 fexp2 choice1 choice2 x. Proof. intros fexp1 fexp2 Vfexp1 Vfexp2 choice1 choice2 x Px Hf1. -assert (Hlx : bpow (ln_beta x - 1) <= x < bpow (ln_beta x)). -{ destruct (ln_beta x) as (ex,Hex); simpl. +assert (Hlx : bpow (mag x - 1) <= x < bpow (mag x)). +{ destruct (mag x) as (ex,Hex); simpl. rewrite <- (Rabs_right x); [|now apply Rle_ge; apply Rlt_le]. apply Hex. now apply Rgt_not_eq. } -unfold double_round_eq. -rewrite (round_N_really_small_pos beta fexp1 _ x (ln_beta x)); [|exact Hlx|omega]. +unfold round_round_eq. +rewrite (round_N_small_pos beta fexp1 _ x (mag x)); [|exact Hlx|omega]. set (x'' := round beta fexp2 (Znearest choice2) x). destruct (Req_dec x'' 0) as [Zx''|Nzx'']; [now rewrite Zx''; rewrite round_0; [|apply valid_rnd_N]|]. -destruct (Zle_or_lt (fexp2 (ln_beta x)) (ln_beta x)). -- (* fexp2 (ln_beta x) <= ln_beta x *) - destruct (Rlt_or_le x'' (bpow (ln_beta x))). - + (* x'' < bpow (ln_beta x) *) - rewrite (round_N_really_small_pos beta fexp1 _ _ (ln_beta x)); +destruct (Zle_or_lt (fexp2 (mag x)) (mag x)). +- (* fexp2 (mag x) <= mag x *) + destruct (Rlt_or_le x'' (bpow (mag x))). + + (* x'' < bpow (mag x) *) + rewrite (round_N_small_pos beta fexp1 _ _ (mag x)); [reflexivity|split; [|exact H0]|omega]. - apply round_large_pos_ge_pow; [now apply valid_rnd_N| |now apply Hlx]. + apply round_large_pos_ge_bpow; [now apply valid_rnd_N| |now apply Hlx]. fold x''; assert (0 <= x''); [|lra]; unfold x''. rewrite <- (round_0 beta fexp2 (Znearest choice2)). now apply round_le; [|apply valid_rnd_N|apply Rlt_le]. - + (* bpow (ln_beta x) <= x'' *) - assert (Hx'' : x'' = bpow (ln_beta x)). + + (* bpow (mag x) <= x'' *) + assert (Hx'' : x'' = bpow (mag x)). { apply Rle_antisym; [|exact H0]. rewrite <- (round_generic beta fexp2 (Znearest choice2) (bpow _)). - now apply round_le; [|apply valid_rnd_N|apply Rlt_le]. - now apply generic_format_bpow'. } rewrite Hx''. - unfold round, F2R, scaled_mantissa, canonic_exp; simpl. - rewrite ln_beta_bpow. - assert (Hf11 : (fexp1 (ln_beta x + 1) = fexp1 (ln_beta x) :> Z)%Z); + unfold round, F2R, scaled_mantissa, cexp; simpl. + rewrite mag_bpow. + assert (Hf11 : (fexp1 (mag x + 1) = fexp1 (mag x) :> Z)%Z); [apply Vfexp1; omega|]. rewrite Hf11. - apply (Rmult_eq_reg_r (bpow (- fexp1 (ln_beta x)))); + apply (Rmult_eq_reg_r (bpow (- fexp1 (mag x)))); [|now apply Rgt_not_eq; apply bpow_gt_0]. rewrite Rmult_0_l; bpow_simplify. - change 0 with (Z2R 0); apply f_equal. + apply IZR_eq. apply Znearest_imp. simpl; unfold Rminus; rewrite Ropp_0; rewrite Rplus_0_r. rewrite Rabs_right; [|now apply Rle_ge; apply bpow_ge_0]. apply Rle_lt_trans with (bpow (- 2)); [now apply bpow_le; omega|]. - unfold Fcore_Raux.bpow, Z.pow_pos; simpl; rewrite Zmult_1_r. + unfold Raux.bpow, Z.pow_pos; simpl; rewrite Zmult_1_r. assert (Hbeta : (2 <= beta)%Z). { destruct beta as (beta_val,beta_prop); simpl. now apply Zle_bool_imp_le. } apply Rinv_lt_contravar. * apply Rmult_lt_0_compat; [lra|]. - rewrite Z2R_mult; apply Rmult_lt_0_compat; change 0 with (Z2R 0); - apply Z2R_lt; omega. - * change 2 with (Z2R 2); apply Z2R_lt. - apply (Zle_lt_trans _ _ _ Hbeta). + rewrite mult_IZR; apply Rmult_lt_0_compat; + apply IZR_lt; omega. + * apply IZR_lt. + apply (Z.le_lt_trans _ _ _ Hbeta). rewrite <- (Zmult_1_r beta) at 1. apply Zmult_lt_compat_l; omega. -- (* ln_beta x < fexp2 (ln_beta x) *) +- (* mag x < fexp2 (mag x) *) casetype False; apply Nzx''. - now apply (round_N_really_small_pos beta _ _ _ (ln_beta x)). + now apply (round_N_small_pos beta _ _ _ (mag x)). Qed. -Lemma double_round_zero : +Lemma round_round_zero : forall fexp1 fexp2 : Z -> Z, Valid_exp fexp1 -> Valid_exp fexp2 -> forall (choice1 choice2 : Z -> bool), forall x, 0 < x -> - (fexp1 (ln_beta x) = ln_beta x + 1 :> Z)%Z -> - x < bpow (ln_beta x) - / 2 * ulp beta fexp2 x -> - double_round_eq fexp1 fexp2 choice1 choice2 x. + (fexp1 (mag x) = mag x + 1 :> Z)%Z -> + x < bpow (mag x) - / 2 * ulp beta fexp2 x -> + round_round_eq fexp1 fexp2 choice1 choice2 x. Proof. intros fexp1 fexp2 Vfexp1 Vfexp2 choice1 choice2 x Px Hf1. -unfold double_round_eq. +unfold round_round_eq. set (x'' := round beta fexp2 (Znearest choice2) x). set (u1 := ulp beta fexp1 x). set (u2 := ulp beta fexp2 x). intro Hx. -assert (Hlx : bpow (ln_beta x - 1) <= x < bpow (ln_beta x)). -{ destruct (ln_beta x) as (ex,Hex); simpl. +assert (Hlx : bpow (mag x - 1) <= x < bpow (mag x)). +{ destruct (mag x) as (ex,Hex); simpl. rewrite <- (Rabs_right x); [|now apply Rle_ge; apply Rlt_le]. apply Hex. now apply Rgt_not_eq. } -rewrite (round_N_really_small_pos beta fexp1 choice1 x (ln_beta x)); +rewrite (round_N_small_pos beta fexp1 choice1 x (mag x)); [|exact Hlx|omega]. destruct (Req_dec x'' 0) as [Zx''|Nzx'']; [now rewrite Zx''; rewrite round_0; [reflexivity|apply valid_rnd_N]|]. -rewrite (round_N_really_small_pos beta _ _ x'' (ln_beta x)); +rewrite (round_N_small_pos beta _ _ x'' (mag x)); [reflexivity| |omega]. split. -- apply round_large_pos_ge_pow. +- apply round_large_pos_ge_bpow. + now apply valid_rnd_N. + assert (0 <= x''); [|now fold x''; lra]. rewrite <- (round_0 beta fexp2 (Znearest choice2)). now apply round_le; [|apply valid_rnd_N|apply Rlt_le]. + apply Rle_trans with (Rabs x); [|now rewrite Rabs_right; [apply Rle_refl|apply Rle_ge; apply Rlt_le]]. - destruct (ln_beta x) as (ex,Hex); simpl; apply Hex. + destruct (mag x) as (ex,Hex); simpl; apply Hex. now apply Rgt_not_eq. - replace x'' with (x + (x'' - x)) by ring. - replace (bpow _) with (bpow (ln_beta x) - / 2 * u2 + / 2 * u2) by ring. + replace (bpow _) with (bpow (mag x) - / 2 * u2 + / 2 * u2) by ring. apply Rplus_lt_le_compat; [exact Hx|]. apply Rabs_le_inv. now apply error_le_half_ulp. Qed. -Lemma double_round_all_mid_cases : +Lemma round_round_all_mid_cases : forall fexp1 fexp2 : Z -> Z, Valid_exp fexp1 -> Valid_exp fexp2 -> forall (choice1 choice2 : Z -> bool), forall x, 0 < x -> - (fexp2 (ln_beta x) <= fexp1 (ln_beta x) - 1)%Z -> - ((fexp1 (ln_beta x) = ln_beta x + 1 :> Z)%Z -> - bpow (ln_beta x) - / 2 * ulp beta fexp2 x <= x -> - double_round_eq fexp1 fexp2 choice1 choice2 x) -> - ((fexp1 (ln_beta x) <= ln_beta x)%Z -> + (fexp2 (mag x) <= fexp1 (mag x) - 1)%Z -> + ((fexp1 (mag x) = mag x + 1 :> Z)%Z -> + bpow (mag x) - / 2 * ulp beta fexp2 x <= x -> + round_round_eq fexp1 fexp2 choice1 choice2 x) -> + ((fexp1 (mag x) <= mag x)%Z -> midp fexp1 x - / 2 * ulp beta fexp2 x <= x < midp fexp1 x -> - double_round_eq fexp1 fexp2 choice1 choice2 x) -> - ((fexp1 (ln_beta x) <= ln_beta x)%Z -> + round_round_eq fexp1 fexp2 choice1 choice2 x) -> + ((fexp1 (mag x) <= mag x)%Z -> x = midp fexp1 x -> - double_round_eq fexp1 fexp2 choice1 choice2 x) -> - ((fexp1 (ln_beta x) <= ln_beta x)%Z -> + round_round_eq fexp1 fexp2 choice1 choice2 x) -> + ((fexp1 (mag x) <= mag x)%Z -> midp fexp1 x < x <= midp fexp1 x + / 2 * ulp beta fexp2 x -> - double_round_eq fexp1 fexp2 choice1 choice2 x) -> - double_round_eq fexp1 fexp2 choice1 choice2 x. + round_round_eq fexp1 fexp2 choice1 choice2 x) -> + round_round_eq fexp1 fexp2 choice1 choice2 x. Proof. intros fexp1 fexp2 Vfexp1 Vfexp2 choice1 choice2 x Px Hf2. set (x' := round beta fexp1 Zfloor x). set (u1 := ulp beta fexp1 x). set (u2 := ulp beta fexp2 x). intros Cz Clt Ceq Cgt. -destruct (Ztrichotomy (ln_beta x) (fexp1 (ln_beta x) - 1)) as [Hlt|[Heq|Hgt]]. -- (* ln_beta x < fexp1 (ln_beta x) - 1 *) - assert (H : (ln_beta x <= fexp1 (ln_beta x) - 2)%Z) by omega. - now apply double_round_really_zero. -- (* ln_beta x = fexp1 (ln_beta x) - 1 *) - assert (H : (fexp1 (ln_beta x) = (ln_beta x + 1))%Z) by omega. - destruct (Rlt_or_le x (bpow (ln_beta x) - / 2 * u2)) as [Hlt'|Hge']. - + now apply double_round_zero. +destruct (Ztrichotomy (mag x) (fexp1 (mag x) - 1)) as [Hlt|[Heq|Hgt]]. +- (* mag x < fexp1 (mag x) - 1 *) + assert (H : (mag x <= fexp1 (mag x) - 2)%Z) by omega. + now apply round_round_really_zero. +- (* mag x = fexp1 (mag x) - 1 *) + assert (H : (fexp1 (mag x) = (mag x + 1))%Z) by omega. + destruct (Rlt_or_le x (bpow (mag x) - / 2 * u2)) as [Hlt'|Hge']. + + now apply round_round_zero. + now apply Cz. -- (* ln_beta x > fexp1 (ln_beta x) - 1 *) - assert (H : (fexp1 (ln_beta x) <= ln_beta x)%Z) by omega. +- (* mag x > fexp1 (mag x) - 1 *) + assert (H : (fexp1 (mag x) <= mag x)%Z) by omega. destruct (Rtotal_order x (midp fexp1 x)) as [Hlt'|[Heq'|Hgt']]. + (* x < midp fexp1 x *) destruct (Rlt_or_le x (midp fexp1 x - / 2 * u2)) as [Hlt''|Hle'']. - * now apply double_round_lt_mid_further_place; [| | |omega| |]. + * now apply round_round_lt_mid_further_place; [| | |omega| |]. * now apply Clt; [|split]. + (* x = midp fexp1 x *) now apply Ceq. @@ -3735,33 +3701,33 @@ destruct (Ztrichotomy (ln_beta x) (fexp1 (ln_beta x) - 1)) as [Hlt|[Heq|Hgt]]. * now apply Cgt; [|split]. * { destruct (generic_format_EM beta fexp1 x) as [Fx|Nfx]. - (* generic_format beta fexp1 x *) - unfold double_round_eq; rewrite (round_generic beta fexp2); + unfold round_round_eq; rewrite (round_generic beta fexp2); [reflexivity|now apply valid_rnd_N|]. - now apply (generic_inclusion_ln_beta beta fexp1); [omega|]. + now apply (generic_inclusion_mag beta fexp1); [omega|]. - (* ~ generic_format beta fexp1 x *) assert (Hceil : round beta fexp1 Zceil x = x' + u1); [now apply round_UP_DN_ulp|]. - assert (Hf2' : (fexp2 (ln_beta x) <= fexp1 (ln_beta x) - 1)%Z); + assert (Hf2' : (fexp2 (mag x) <= fexp1 (mag x) - 1)%Z); [omega|]. assert (midp' fexp1 x + / 2 * ulp beta fexp2 x < x); - [|now apply double_round_gt_mid_further_place]. + [|now apply round_round_gt_mid_further_place]. revert Hle''; unfold midp, midp'; fold x'. rewrite Hceil; fold u1; fold u2. lra. } Qed. -Lemma ln_beta_div_disj : +Lemma mag_div_disj : forall x y : R, 0 < x -> 0 < y -> - ((ln_beta (x / y) = ln_beta x - ln_beta y :> Z)%Z - \/ (ln_beta (x / y) = ln_beta x - ln_beta y + 1 :> Z)%Z). + ((mag (x / y) = mag x - mag y :> Z)%Z + \/ (mag (x / y) = mag x - mag y + 1 :> Z)%Z). Proof. intros x y Px Py. -generalize (ln_beta_div beta x y Px Py). +generalize (mag_div beta x y (Rgt_not_eq _ _ Px) (Rgt_not_eq _ _ Py)). omega. Qed. -Definition double_round_div_hyp fexp1 fexp2 := +Definition round_round_div_hyp fexp1 fexp2 := (forall ex, (fexp2 ex <= fexp1 ex - 1)%Z) /\ (forall ex ey, (fexp1 ex < ex)%Z -> (fexp1 ey < ey)%Z -> (fexp1 (ex - ey) <= ex - ey + 1)%Z -> @@ -3777,63 +3743,63 @@ Definition double_round_div_hyp fexp1 fexp2 := (fexp1 (ex - ey) = ex - ey + 1)%Z -> (fexp2 (ex - ey) <= ex - ey - ey + fexp1 ey)%Z). -Lemma double_round_div_aux0 : +Lemma round_round_div_aux0 : forall fexp1 fexp2 : Z -> Z, Valid_exp fexp1 -> Valid_exp fexp2 -> forall (choice1 choice2 : Z -> bool), - double_round_div_hyp fexp1 fexp2 -> + round_round_div_hyp fexp1 fexp2 -> forall x y, 0 < x -> 0 < y -> generic_format beta fexp1 x -> generic_format beta fexp1 y -> - fexp1 (ln_beta (x / y)) = (ln_beta (x / y) + 1)%Z -> - ~ (bpow (ln_beta (x / y)) - / 2 * ulp beta fexp2 (x / y) <= x / y). + fexp1 (mag (x / y)) = (mag (x / y) + 1)%Z -> + ~ (bpow (mag (x / y)) - / 2 * ulp beta fexp2 (x / y) <= x / y). Proof. intros fexp1 fexp2 Vfexp1 Vfexp2 choice1 choice2 Hexp x y Px Py Fx Fy Hf1. -assert (Hfx : (fexp1 (ln_beta x) < ln_beta x)%Z); - [now apply ln_beta_generic_gt; [|apply Rgt_not_eq|]|]. -assert (Hfy : (fexp1 (ln_beta y) < ln_beta y)%Z); - [now apply ln_beta_generic_gt; [|apply Rgt_not_eq|]|]. -set (p := bpow (ln_beta (x / y))). -set (u2 := bpow (fexp2 (ln_beta (x / y)))). +assert (Hfx : (fexp1 (mag x) < mag x)%Z); + [now apply mag_generic_gt; [|apply Rgt_not_eq|]|]. +assert (Hfy : (fexp1 (mag y) < mag y)%Z); + [now apply mag_generic_gt; [|apply Rgt_not_eq|]|]. +set (p := bpow (mag (x / y))). +set (u2 := bpow (fexp2 (mag (x / y)))). revert Fx Fy. -unfold generic_format, F2R, scaled_mantissa, canonic_exp; simpl. -set (mx := Ztrunc (x * bpow (- fexp1 (ln_beta x)))). -set (my := Ztrunc (y * bpow (- fexp1 (ln_beta y)))). +unfold generic_format, F2R, scaled_mantissa, cexp; simpl. +set (mx := Ztrunc (x * bpow (- fexp1 (mag x)))). +set (my := Ztrunc (y * bpow (- fexp1 (mag y)))). intros Fx Fy. rewrite ulp_neq_0. 2: apply Rmult_integral_contrapositive_currified; [now apply Rgt_not_eq|idtac]. 2: now apply Rinv_neq_0_compat, Rgt_not_eq. intro Hl. assert (Hr : x / y < p); - [now apply Rabs_lt_inv; apply bpow_ln_beta_gt|]. + [now apply Rabs_lt_inv; apply bpow_mag_gt|]. apply (Rlt_irrefl (p - / 2 * u2)). apply (Rle_lt_trans _ _ _ Hl). apply (Rmult_lt_reg_r y _ _ Py). unfold Rdiv; rewrite Rmult_assoc. rewrite Rinv_l; [|now apply Rgt_not_eq]; rewrite Rmult_1_r. -destruct (Zle_or_lt Z0 (fexp1 (ln_beta x) - ln_beta (x / y) - - fexp1 (ln_beta y))%Z) as [He|He]. -- (* ln_beta (x / y) + fexp1 (ln_beta y) <= fexp1 (ln_beta x) *) - apply Rle_lt_trans with (p * y - p * bpow (fexp1 (ln_beta y))). +destruct (Zle_or_lt Z0 (fexp1 (mag x) - mag (x / y) + - fexp1 (mag y))%Z) as [He|He]. +- (* mag (x / y) + fexp1 (mag y) <= fexp1 (mag x) *) + apply Rle_lt_trans with (p * y - p * bpow (fexp1 (mag y))). + rewrite Fx; rewrite Fy at 1. rewrite <- Rmult_assoc. rewrite (Rmult_comm p). unfold p; bpow_simplify. - apply (Rmult_le_reg_r (bpow (- ln_beta (x / y) - fexp1 (ln_beta y)))); + apply (Rmult_le_reg_r (bpow (- mag (x / y) - fexp1 (mag y)))); [now apply bpow_gt_0|]. rewrite Rmult_minus_distr_r. bpow_simplify. - rewrite <- Z2R_Zpower; [|exact He]. - rewrite <- Z2R_mult. - change 1 with (Z2R 1); rewrite <- Z2R_minus. - apply Z2R_le. + rewrite <- IZR_Zpower; [|exact He]. + rewrite <- mult_IZR. + rewrite <- minus_IZR. + apply IZR_le. apply (Zplus_le_reg_r _ _ 1); ring_simplify. apply Zlt_le_succ. - apply lt_Z2R. - rewrite Z2R_mult. - rewrite Z2R_Zpower; [|exact He]. - apply (Rmult_lt_reg_r (bpow (fexp1 (ln_beta y) + ln_beta (x / y)))); + apply lt_IZR. + rewrite mult_IZR. + rewrite IZR_Zpower; [|exact He]. + apply (Rmult_lt_reg_r (bpow (fexp1 (mag y) + mag (x / y)))); [now apply bpow_gt_0|]. bpow_simplify. rewrite <- Fx. @@ -3845,7 +3811,7 @@ destruct (Zle_or_lt Z0 (fexp1 (ln_beta x) - ln_beta (x / y) + rewrite Rmult_minus_distr_r. unfold Rminus; apply Rplus_lt_compat_l. apply Ropp_lt_contravar. - apply Rlt_le_trans with (u2 * bpow (ln_beta y)). + apply Rlt_le_trans with (u2 * bpow (mag y)). * rewrite <- (Rmult_1_l (u2 * _)). rewrite Rmult_assoc. { apply Rmult_lt_compat. @@ -3854,38 +3820,38 @@ destruct (Zle_or_lt Z0 (fexp1 (ln_beta x) - ln_beta (x / y) - lra. - apply Rmult_lt_compat_l; [now apply bpow_gt_0|]. apply Rabs_lt_inv. - apply bpow_ln_beta_gt. } - * unfold u2, p, ulp, canonic_exp; bpow_simplify; apply bpow_le. - apply (Zplus_le_reg_r _ _ (- ln_beta y)); ring_simplify. - rewrite (Zplus_comm (- _)); fold (Zminus (ln_beta (x / y)) (ln_beta y)). - destruct (ln_beta_div_disj x y Px Py) as [Hxy|Hxy]; rewrite Hxy; + apply bpow_mag_gt. } + * unfold u2, p, ulp, cexp; bpow_simplify; apply bpow_le. + apply (Zplus_le_reg_r _ _ (- mag y)); ring_simplify. + rewrite (Zplus_comm (- _)); fold (Zminus (mag (x / y)) (mag y)). + destruct (mag_div_disj x y Px Py) as [Hxy|Hxy]; rewrite Hxy; [now apply Hexp; [| |rewrite <- Hxy]|]. - replace (_ - _ + 1)%Z with ((ln_beta x + 1) - ln_beta y)%Z by ring. + replace (_ - _ + 1)%Z with ((mag x + 1) - mag y)%Z by ring. apply Hexp. - { now assert (fexp1 (ln_beta x + 1) <= ln_beta x)%Z; + { now assert (fexp1 (mag x + 1) <= mag x)%Z; [apply valid_exp|omega]. } { assumption. } - replace (_ + 1 - _)%Z with (ln_beta x - ln_beta y + 1)%Z by ring. + replace (_ + 1 - _)%Z with (mag x - mag y + 1)%Z by ring. now rewrite <- Hxy. -- (* fexp1 (ln_beta x) < ln_beta (x / y) + fexp1 (ln_beta y) *) - apply Rle_lt_trans with (p * y - bpow (fexp1 (ln_beta x))). +- (* fexp1 (mag x) < mag (x / y) + fexp1 (mag y) *) + apply Rle_lt_trans with (p * y - bpow (fexp1 (mag x))). + rewrite Fx at 1; rewrite Fy at 1. - apply (Rmult_le_reg_r (bpow (- fexp1 (ln_beta x)))); + apply (Rmult_le_reg_r (bpow (- fexp1 (mag x)))); [now apply bpow_gt_0|]. rewrite Rmult_minus_distr_r. bpow_simplify. rewrite (Rmult_comm p). unfold p; bpow_simplify. - rewrite <- Z2R_Zpower; [|omega]. - rewrite <- Z2R_mult. - change 1 with (Z2R 1); rewrite <- Z2R_minus. - apply Z2R_le. + rewrite <- IZR_Zpower; [|omega]. + rewrite <- mult_IZR. + rewrite <- minus_IZR. + apply IZR_le. apply (Zplus_le_reg_r _ _ 1); ring_simplify. apply Zlt_le_succ. - apply lt_Z2R. - rewrite Z2R_mult. - rewrite Z2R_Zpower; [|omega]. - apply (Rmult_lt_reg_r (bpow (fexp1 (ln_beta x)))); + apply lt_IZR. + rewrite mult_IZR. + rewrite IZR_Zpower; [|omega]. + apply (Rmult_lt_reg_r (bpow (fexp1 (mag x)))); [now apply bpow_gt_0|bpow_simplify]. rewrite <- Fx. rewrite Zplus_comm; rewrite bpow_plus. @@ -3896,7 +3862,7 @@ destruct (Zle_or_lt Z0 (fexp1 (ln_beta x) - ln_beta (x / y) + rewrite Rmult_minus_distr_r. unfold Rminus; apply Rplus_lt_compat_l. apply Ropp_lt_contravar. - apply Rlt_le_trans with (u2 * bpow (ln_beta y)). + apply Rlt_le_trans with (u2 * bpow (mag y)). * rewrite <- (Rmult_1_l (u2 * _)). rewrite Rmult_assoc. { apply Rmult_lt_compat. @@ -3905,33 +3871,33 @@ destruct (Zle_or_lt Z0 (fexp1 (ln_beta x) - ln_beta (x / y) - lra. - apply Rmult_lt_compat_l; [now apply bpow_gt_0|]. apply Rabs_lt_inv. - apply bpow_ln_beta_gt. } - * unfold u2, p, ulp, canonic_exp; bpow_simplify; apply bpow_le. - apply (Zplus_le_reg_r _ _ (- ln_beta y)); ring_simplify. - rewrite (Zplus_comm (- _)); fold (Zminus (ln_beta (x / y)) (ln_beta y)). - destruct (ln_beta_div_disj x y Px Py) as [Hxy|Hxy]; rewrite Hxy; - apply Hexp; try assumption; rewrite <- Hxy; rewrite Hf1; apply Zle_refl. + apply bpow_mag_gt. } + * unfold u2, p, ulp, cexp; bpow_simplify; apply bpow_le. + apply (Zplus_le_reg_r _ _ (- mag y)); ring_simplify. + rewrite (Zplus_comm (- _)); fold (Zminus (mag (x / y)) (mag y)). + destruct (mag_div_disj x y Px Py) as [Hxy|Hxy]; rewrite Hxy; + apply Hexp; try assumption; rewrite <- Hxy; rewrite Hf1; apply Z.le_refl. Qed. -Lemma double_round_div_aux1 : +Lemma round_round_div_aux1 : forall fexp1 fexp2 : Z -> Z, Valid_exp fexp1 -> Valid_exp fexp2 -> forall (choice1 choice2 : Z -> bool), - double_round_div_hyp fexp1 fexp2 -> + round_round_div_hyp fexp1 fexp2 -> forall x y, 0 < x -> 0 < y -> generic_format beta fexp1 x -> generic_format beta fexp1 y -> - (fexp1 (ln_beta (x / y)) <= ln_beta (x / y))%Z -> + (fexp1 (mag (x / y)) <= mag (x / y))%Z -> ~ (midp fexp1 (x / y) - / 2 * ulp beta fexp2 (x / y) <= x / y < midp fexp1 (x / y)). Proof. intros fexp1 fexp2 Vfexp1 Vfexp2 choice1 choice2 Hexp x y Px Py Fx Fy Hf1. -assert (Hfx : (fexp1 (ln_beta x) < ln_beta x)%Z); - [now apply ln_beta_generic_gt; [|apply Rgt_not_eq|]|]. -assert (Hfy : (fexp1 (ln_beta y) < ln_beta y)%Z); - [now apply ln_beta_generic_gt; [|apply Rgt_not_eq|]|]. +assert (Hfx : (fexp1 (mag x) < mag x)%Z); + [now apply mag_generic_gt; [|apply Rgt_not_eq|]|]. +assert (Hfy : (fexp1 (mag y) < mag y)%Z); + [now apply mag_generic_gt; [|apply Rgt_not_eq|]|]. assert (S : (x / y <> 0)%R). apply Rmult_integral_contrapositive_currified; [now apply Rgt_not_eq|idtac]. now apply Rinv_neq_0_compat, Rgt_not_eq. @@ -3945,14 +3911,14 @@ cut (~ (/ 2 * (ulp beta fexp1 (x / y) - ulp beta fexp2 (x / y)) - apply (Rplus_lt_reg_l (round beta fexp1 Zfloor (x / y))). ring_simplify. apply H'. } -set (u1 := bpow (fexp1 (ln_beta (x / y)))). -set (u2 := bpow (fexp2 (ln_beta (x / y)))). +set (u1 := bpow (fexp1 (mag (x / y)))). +set (u2 := bpow (fexp2 (mag (x / y)))). set (x' := round beta fexp1 Zfloor (x / y)). rewrite 2!ulp_neq_0; trivial. revert Fx Fy. -unfold generic_format, F2R, scaled_mantissa, canonic_exp; simpl. -set (mx := Ztrunc (x * bpow (- fexp1 (ln_beta x)))). -set (my := Ztrunc (y * bpow (- fexp1 (ln_beta y)))). +unfold generic_format, F2R, scaled_mantissa, cexp; simpl. +set (mx := Ztrunc (x * bpow (- fexp1 (mag x)))). +set (my := Ztrunc (y * bpow (- fexp1 (mag y)))). intros Fx Fy. intro Hlr. apply (Rlt_irrefl (/ 2 * (u1 - u2))). @@ -3966,48 +3932,47 @@ apply (Rmult_lt_reg_l 2); [lra|]. rewrite Rmult_minus_distr_l; rewrite Rmult_plus_distr_l. do 5 rewrite <- Rmult_assoc. rewrite Rinv_r; [|lra]; do 2 rewrite Rmult_1_l. -destruct (Zle_or_lt Z0 (fexp1 (ln_beta x) - fexp1 (ln_beta (x / y)) - - fexp1 (ln_beta y))%Z) as [He|He]. -- (* fexp1 (ln_beta (x / y)) + fexp1 (ln_beta y)) <= fexp1 (ln_beta x) *) +destruct (Zle_or_lt Z0 (fexp1 (mag x) - fexp1 (mag (x / y)) + - fexp1 (mag y))%Z) as [He|He]. +- (* fexp1 (mag (x / y)) + fexp1 (mag y)) <= fexp1 (mag x) *) apply Rle_lt_trans with (2 * x' * y + u1 * y - - bpow (fexp1 (ln_beta (x / y)) - + fexp1 (ln_beta y))). + - bpow (fexp1 (mag (x / y)) + + fexp1 (mag y))). + rewrite Fx at 1; rewrite Fy at 1 2. - apply (Rmult_le_reg_r (bpow (- fexp1 (ln_beta (x / y)) - - fexp1 (ln_beta y)))); + apply (Rmult_le_reg_r (bpow (- fexp1 (mag (x / y)) + - fexp1 (mag y)))); [now apply bpow_gt_0|]. rewrite Rmult_minus_distr_r; rewrite (Rmult_plus_distr_r (_ * _ * _)). bpow_simplify. replace (2 * x' * _ * _) - with (2 * Z2R my * x' * bpow (- fexp1 (ln_beta (x / y)))) by ring. + with (2 * IZR my * x' * bpow (- fexp1 (mag (x / y)))) by ring. rewrite (Rmult_comm u1). - unfold x', u1, round, F2R, ulp, scaled_mantissa, canonic_exp; simpl. + unfold x', u1, round, F2R, ulp, scaled_mantissa, cexp; simpl. bpow_simplify. - rewrite <- Z2R_Zpower; [|exact He]. - change 2 with (Z2R 2). - do 4 rewrite <- Z2R_mult. - rewrite <- Z2R_plus. - change 1 with (Z2R 1); rewrite <- Z2R_minus. - apply Z2R_le. + rewrite <- IZR_Zpower; [|exact He]. + do 4 rewrite <- mult_IZR. + rewrite <- plus_IZR. + rewrite <- minus_IZR. + apply IZR_le. apply (Zplus_le_reg_r _ _ 1); ring_simplify. apply Zlt_le_succ. - apply lt_Z2R. - rewrite Z2R_plus. - do 4 rewrite Z2R_mult; simpl. - rewrite Z2R_Zpower; [|exact He]. - apply (Rmult_lt_reg_r (bpow (fexp1 (ln_beta (x / y)) - + fexp1 (ln_beta y)))); + apply lt_IZR. + rewrite plus_IZR. + do 4 rewrite mult_IZR; simpl. + rewrite IZR_Zpower; [|exact He]. + apply (Rmult_lt_reg_r (bpow (fexp1 (mag (x / y)) + + fexp1 (mag y)))); [now apply bpow_gt_0|bpow_simplify]. rewrite Rmult_assoc. rewrite <- Fx. - rewrite (Rmult_plus_distr_r _ _ (Fcore_Raux.bpow _ _)). + rewrite (Rmult_plus_distr_r _ _ (Raux.bpow _ _)). rewrite Rmult_assoc. rewrite bpow_plus. - rewrite <- (Rmult_assoc (Z2R (Zfloor _))). - change (Z2R (Zfloor _) * _) with x'. - do 2 rewrite (Rmult_comm _ (bpow (fexp1 (ln_beta y)))). + rewrite <- (Rmult_assoc (IZR (Zfloor _))). + change (IZR (Zfloor _) * _) with x'. + do 2 rewrite (Rmult_comm _ (bpow (fexp1 (mag y)))). rewrite Rmult_assoc. - do 2 rewrite <- (Rmult_assoc (Z2R my)). + do 2 rewrite <- (Rmult_assoc (IZR my)). rewrite <- Fy. change (bpow _) with u1. apply (Rmult_lt_reg_l (/ 2)); [lra|]. @@ -4022,60 +3987,59 @@ destruct (Zle_or_lt Z0 (fexp1 (ln_beta x) - fexp1 (ln_beta (x / y)) now rewrite Rmult_comm. + apply Rplus_lt_compat_l. apply Ropp_lt_contravar. - apply Rlt_le_trans with (u2 * bpow (ln_beta y)). + apply Rlt_le_trans with (u2 * bpow (mag y)). * { apply Rmult_lt_compat_l. - apply bpow_gt_0. - apply Rabs_lt_inv. - apply bpow_ln_beta_gt. } - * unfold u2, ulp, canonic_exp; bpow_simplify; apply bpow_le. - apply (Zplus_le_reg_r _ _ (- ln_beta y)); ring_simplify. + apply bpow_mag_gt. } + * unfold u2, ulp, cexp; bpow_simplify; apply bpow_le. + apply (Zplus_le_reg_r _ _ (- mag y)); ring_simplify. rewrite <- Zplus_assoc; rewrite (Zplus_comm (- _)). - destruct (ln_beta_div_disj x y Px Py) as [Hxy|Hxy]; rewrite Hxy; + destruct (mag_div_disj x y Px Py) as [Hxy|Hxy]; rewrite Hxy; [now apply Hexp; [| |rewrite <- Hxy]|]. - replace (_ - _ + 1)%Z with ((ln_beta x + 1) - ln_beta y)%Z by ring. + replace (_ - _ + 1)%Z with ((mag x + 1) - mag y)%Z by ring. apply Hexp. - { now assert (fexp1 (ln_beta x + 1) <= ln_beta x)%Z; + { now assert (fexp1 (mag x + 1) <= mag x)%Z; [apply valid_exp|omega]. } { assumption. } - replace (_ + 1 - _)%Z with (ln_beta x - ln_beta y + 1)%Z by ring. + replace (_ + 1 - _)%Z with (mag x - mag y + 1)%Z by ring. now rewrite <- Hxy. -- (* fexp1 (ln_beta x) < fexp1 (ln_beta (x / y)) + fexp1 (ln_beta y) *) - apply Rle_lt_trans with (2 * x' * y + u1 * y - bpow (fexp1 (ln_beta x))). +- (* fexp1 (mag x) < fexp1 (mag (x / y)) + fexp1 (mag y) *) + apply Rle_lt_trans with (2 * x' * y + u1 * y - bpow (fexp1 (mag x))). + rewrite Fx at 1; rewrite Fy at 1 2. - apply (Rmult_le_reg_r (bpow (- fexp1 (ln_beta x)))); + apply (Rmult_le_reg_r (bpow (- fexp1 (mag x)))); [now apply bpow_gt_0|]. rewrite Rmult_minus_distr_r; rewrite (Rmult_plus_distr_r (_ * _ * _)). bpow_simplify. replace (2 * x' * _ * _) - with (2 * Z2R my * x' * bpow (fexp1 (ln_beta y) - fexp1 (ln_beta x))) by ring. + with (2 * IZR my * x' * bpow (fexp1 (mag y) - fexp1 (mag x))) by ring. rewrite (Rmult_comm u1). - unfold x', u1, round, F2R, ulp, scaled_mantissa, canonic_exp; simpl. + unfold x', u1, round, F2R, ulp, scaled_mantissa, cexp; simpl. bpow_simplify. - rewrite <- (Z2R_Zpower _ (_ - _)%Z); [|omega]. - change 2 with (Z2R 2). - do 5 rewrite <- Z2R_mult. - rewrite <- Z2R_plus. - change 1 with (Z2R 1); rewrite <- Z2R_minus. - apply Z2R_le. + rewrite <- (IZR_Zpower _ (_ - _)%Z); [|omega]. + do 5 rewrite <- mult_IZR. + rewrite <- plus_IZR. + rewrite <- minus_IZR. + apply IZR_le. apply (Zplus_le_reg_r _ _ 1); ring_simplify. apply Zlt_le_succ. - apply lt_Z2R. - rewrite Z2R_plus. - do 5 rewrite Z2R_mult; simpl. - rewrite Z2R_Zpower; [|omega]. - apply (Rmult_lt_reg_r (bpow (fexp1 (ln_beta x)))); + apply lt_IZR. + rewrite plus_IZR. + do 5 rewrite mult_IZR; simpl. + rewrite IZR_Zpower; [|omega]. + apply (Rmult_lt_reg_r (bpow (fexp1 (mag x)))); [now apply bpow_gt_0|]. rewrite Rmult_assoc. rewrite <- Fx. - rewrite (Rmult_plus_distr_r _ _ (Fcore_Raux.bpow _ _)). + rewrite (Rmult_plus_distr_r _ _ (Raux.bpow _ _)). bpow_simplify. rewrite Rmult_assoc. rewrite bpow_plus. - rewrite <- (Rmult_assoc (Z2R (Zfloor _))). - change (Z2R (Zfloor _) * _) with x'. - do 2 rewrite (Rmult_comm _ (bpow (fexp1 (ln_beta y)))). + rewrite <- (Rmult_assoc (IZR (Zfloor _))). + change (IZR (Zfloor _) * _) with x'. + do 2 rewrite (Rmult_comm _ (bpow (fexp1 (mag y)))). rewrite Rmult_assoc. - do 2 rewrite <- (Rmult_assoc (Z2R my)). + do 2 rewrite <- (Rmult_assoc (IZR my)). rewrite <- Fy. change (bpow _) with u1. apply (Rmult_lt_reg_l (/ 2)); [lra|]. @@ -4090,37 +4054,37 @@ destruct (Zle_or_lt Z0 (fexp1 (ln_beta x) - fexp1 (ln_beta (x / y)) now rewrite Rmult_comm. + apply Rplus_lt_compat_l. apply Ropp_lt_contravar. - apply Rlt_le_trans with (u2 * bpow (ln_beta y)). + apply Rlt_le_trans with (u2 * bpow (mag y)). * { apply Rmult_lt_compat_l. - apply bpow_gt_0. - apply Rabs_lt_inv. - apply bpow_ln_beta_gt. } - * unfold u2, ulp, canonic_exp; bpow_simplify; apply bpow_le. - apply (Zplus_le_reg_r _ _ (- ln_beta y)); ring_simplify. + apply bpow_mag_gt. } + * unfold u2, ulp, cexp; bpow_simplify; apply bpow_le. + apply (Zplus_le_reg_r _ _ (- mag y)); ring_simplify. rewrite (Zplus_comm (- _)). - destruct (ln_beta_div_disj x y Px Py) as [Hxy|Hxy]; rewrite Hxy; + destruct (mag_div_disj x y Px Py) as [Hxy|Hxy]; rewrite Hxy; apply Hexp; try assumption; rewrite <- Hxy; omega. Qed. -Lemma double_round_div_aux2 : +Lemma round_round_div_aux2 : forall fexp1 fexp2 : Z -> Z, Valid_exp fexp1 -> Valid_exp fexp2 -> forall (choice1 choice2 : Z -> bool), - double_round_div_hyp fexp1 fexp2 -> + round_round_div_hyp fexp1 fexp2 -> forall x y, 0 < x -> 0 < y -> generic_format beta fexp1 x -> generic_format beta fexp1 y -> - (fexp1 (ln_beta (x / y)) <= ln_beta (x / y))%Z -> + (fexp1 (mag (x / y)) <= mag (x / y))%Z -> ~ (midp fexp1 (x / y) < x / y <= midp fexp1 (x / y) + / 2 * ulp beta fexp2 (x / y)). Proof. intros fexp1 fexp2 Vfexp1 Vfexp2 choice1 choice2 Hexp x y Px Py Fx Fy Hf1. -assert (Hfx : (fexp1 (ln_beta x) < ln_beta x)%Z); - [now apply ln_beta_generic_gt; [|apply Rgt_not_eq|]|]. -assert (Hfy : (fexp1 (ln_beta y) < ln_beta y)%Z); - [now apply ln_beta_generic_gt; [|apply Rgt_not_eq|]|]. +assert (Hfx : (fexp1 (mag x) < mag x)%Z); + [now apply mag_generic_gt; [|apply Rgt_not_eq|]|]. +assert (Hfy : (fexp1 (mag y) < mag y)%Z); + [now apply mag_generic_gt; [|apply Rgt_not_eq|]|]. cut (~ (/ 2 * ulp beta fexp1 (x / y) < x / y - round beta fexp1 Zfloor (x / y) <= / 2 * (ulp beta fexp1 (x / y) + ulp beta fexp2 (x / y)))). @@ -4131,17 +4095,17 @@ cut (~ (/ 2 * ulp beta fexp1 (x / y) - apply (Rplus_le_reg_l (round beta fexp1 Zfloor (x / y))). ring_simplify. apply H'. } -set (u1 := bpow (fexp1 (ln_beta (x / y)))). -set (u2 := bpow (fexp2 (ln_beta (x / y)))). +set (u1 := bpow (fexp1 (mag (x / y)))). +set (u2 := bpow (fexp2 (mag (x / y)))). set (x' := round beta fexp1 Zfloor (x / y)). assert (S : (x / y <> 0)%R). apply Rmult_integral_contrapositive_currified; [now apply Rgt_not_eq|idtac]. now apply Rinv_neq_0_compat, Rgt_not_eq. rewrite 2!ulp_neq_0; trivial. revert Fx Fy. -unfold generic_format, F2R, scaled_mantissa, canonic_exp; simpl. -set (mx := Ztrunc (x * bpow (- fexp1 (ln_beta x)))). -set (my := Ztrunc (y * bpow (- fexp1 (ln_beta y)))). +unfold generic_format, F2R, scaled_mantissa, cexp; simpl. +set (mx := Ztrunc (x * bpow (- fexp1 (mag x)))). +set (my := Ztrunc (y * bpow (- fexp1 (mag y)))). intros Fx Fy. intro Hlr. apply (Rlt_irrefl (/ 2 * (u1 + u2))). @@ -4155,76 +4119,75 @@ apply (Rmult_lt_reg_l 2); [lra|]. do 2 rewrite Rmult_plus_distr_l. do 5 rewrite <- Rmult_assoc. rewrite Rinv_r; [|lra]; do 2 rewrite Rmult_1_l. -destruct (Zle_or_lt Z0 (fexp1 (ln_beta x) - fexp1 (ln_beta (x / y)) - - fexp1 (ln_beta y))%Z) as [He|He]. -- (* fexp1 (ln_beta (x / y)) + fexp1 (ln_beta y) <= fexp1 (ln_beta x) *) - apply Rlt_le_trans with (u1 * y + bpow (fexp1 (ln_beta (x / y)) - + fexp1 (ln_beta y)) +destruct (Zle_or_lt Z0 (fexp1 (mag x) - fexp1 (mag (x / y)) + - fexp1 (mag y))%Z) as [He|He]. +- (* fexp1 (mag (x / y)) + fexp1 (mag y) <= fexp1 (mag x) *) + apply Rlt_le_trans with (u1 * y + bpow (fexp1 (mag (x / y)) + + fexp1 (mag y)) + 2 * x' * y). + apply Rplus_lt_compat_r, Rplus_lt_compat_l. - apply Rlt_le_trans with (u2 * bpow (ln_beta y)). + apply Rlt_le_trans with (u2 * bpow (mag y)). * { apply Rmult_lt_compat_l. - apply bpow_gt_0. - apply Rabs_lt_inv. - apply bpow_ln_beta_gt. } - * unfold u2, ulp, canonic_exp; bpow_simplify; apply bpow_le. - apply (Zplus_le_reg_r _ _ (- ln_beta y)); ring_simplify. + apply bpow_mag_gt. } + * unfold u2, ulp, cexp; bpow_simplify; apply bpow_le. + apply (Zplus_le_reg_r _ _ (- mag y)); ring_simplify. rewrite <- Zplus_assoc; rewrite (Zplus_comm (- _)). - destruct (ln_beta_div_disj x y Px Py) as [Hxy|Hxy]; rewrite Hxy; + destruct (mag_div_disj x y Px Py) as [Hxy|Hxy]; rewrite Hxy; [now apply Hexp; [| |rewrite <- Hxy]|]. - replace (_ - _ + 1)%Z with ((ln_beta x + 1) - ln_beta y)%Z by ring. + replace (_ - _ + 1)%Z with ((mag x + 1) - mag y)%Z by ring. apply Hexp. - { now assert (fexp1 (ln_beta x + 1) <= ln_beta x)%Z; + { now assert (fexp1 (mag x + 1) <= mag x)%Z; [apply valid_exp|omega]. } { assumption. } - replace (_ + 1 - _)%Z with (ln_beta x - ln_beta y + 1)%Z by ring. + replace (_ + 1 - _)%Z with (mag x - mag y + 1)%Z by ring. now rewrite <- Hxy. + apply Rge_le; rewrite Fx at 1; apply Rle_ge. - replace (u1 * y) with (u1 * (Z2R my * bpow (fexp1 (ln_beta y)))); + replace (u1 * y) with (u1 * (IZR my * bpow (fexp1 (mag y)))); [|now apply eq_sym; rewrite Fy at 1]. - replace (2 * x' * y) with (2 * x' * (Z2R my * bpow (fexp1 (ln_beta y)))); + replace (2 * x' * y) with (2 * x' * (IZR my * bpow (fexp1 (mag y)))); [|now apply eq_sym; rewrite Fy at 1]. - apply (Rmult_le_reg_r (bpow (- fexp1 (ln_beta (x / y)) - - fexp1 (ln_beta y)))); + apply (Rmult_le_reg_r (bpow (- fexp1 (mag (x / y)) + - fexp1 (mag y)))); [now apply bpow_gt_0|]. do 2 rewrite Rmult_plus_distr_r. bpow_simplify. rewrite (Rmult_comm u1). - unfold u1, ulp, canonic_exp; bpow_simplify. + unfold u1, ulp, cexp; bpow_simplify. rewrite (Rmult_assoc 2). rewrite (Rmult_comm x'). rewrite (Rmult_assoc 2). - unfold x', round, F2R, scaled_mantissa, canonic_exp; simpl. + unfold x', round, F2R, scaled_mantissa, cexp; simpl. bpow_simplify. - rewrite <- (Z2R_Zpower _ (_ - _)%Z); [|exact He]. - change 2 with (Z2R 2). - do 4 rewrite <- Z2R_mult. - change 1 with (Z2R 1); do 2 rewrite <- Z2R_plus. - apply Z2R_le. + rewrite <- (IZR_Zpower _ (_ - _)%Z); [|exact He]. + do 4 rewrite <- mult_IZR. + do 2 rewrite <- plus_IZR. + apply IZR_le. rewrite Zplus_comm, Zplus_assoc. apply Zlt_le_succ. - apply lt_Z2R. - rewrite Z2R_plus. - do 4 rewrite Z2R_mult; simpl. - rewrite Z2R_Zpower; [|exact He]. - apply (Rmult_lt_reg_r (bpow (fexp1 (ln_beta y)))); + apply lt_IZR. + rewrite plus_IZR. + do 4 rewrite mult_IZR; simpl. + rewrite IZR_Zpower; [|exact He]. + apply (Rmult_lt_reg_r (bpow (fexp1 (mag y)))); [now apply bpow_gt_0|]. rewrite Rmult_plus_distr_r. - rewrite (Rmult_comm _ (Z2R _)). + rewrite (Rmult_comm _ (IZR _)). do 2 rewrite Rmult_assoc. rewrite <- Fy. bpow_simplify. unfold Zminus; rewrite bpow_plus. - rewrite (Rmult_assoc _ (Z2R mx)). - rewrite <- (Rmult_assoc (Z2R mx)). + rewrite (Rmult_assoc _ (IZR mx)). + rewrite <- (Rmult_assoc (IZR mx)). rewrite <- Fx. - apply (Rmult_lt_reg_r (bpow (fexp1 (ln_beta (x / y))))); + apply (Rmult_lt_reg_r (bpow (fexp1 (mag (x / y))))); [now apply bpow_gt_0|]. rewrite Rmult_plus_distr_r. bpow_simplify. rewrite (Rmult_comm _ y). do 2 rewrite Rmult_assoc. - change (Z2R (Zfloor _) * _) with x'. + change (IZR (Zfloor _) * _) with x'. change (bpow _) with u1. apply (Rmult_lt_reg_l (/ 2)); [lra|]. rewrite Rmult_plus_distr_l. @@ -4239,52 +4202,51 @@ destruct (Zle_or_lt Z0 (fexp1 (ln_beta x) - fexp1 (ln_beta (x / y)) rewrite Rinv_l; [|now apply Rgt_not_eq]; do 2 rewrite Rmult_1_l. rewrite (Rmult_comm (/ y)). now rewrite (Rplus_comm (- x')). -- (* fexp1 (ln_beta x) < fexp1 (ln_beta (x / y)) + fexp1 (ln_beta y) *) - apply Rlt_le_trans with (2 * x' * y + u1 * y + bpow (fexp1 (ln_beta x))). +- (* fexp1 (mag x) < fexp1 (mag (x / y)) + fexp1 (mag y) *) + apply Rlt_le_trans with (2 * x' * y + u1 * y + bpow (fexp1 (mag x))). + rewrite Rplus_comm, Rplus_assoc; do 2 apply Rplus_lt_compat_l. - apply Rlt_le_trans with (u2 * bpow (ln_beta y)). + apply Rlt_le_trans with (u2 * bpow (mag y)). * apply Rmult_lt_compat_l. now apply bpow_gt_0. - now apply Rabs_lt_inv; apply bpow_ln_beta_gt. - * unfold u2, ulp, canonic_exp; bpow_simplify; apply bpow_le. - apply (Zplus_le_reg_r _ _ (- ln_beta y)); ring_simplify. + now apply Rabs_lt_inv; apply bpow_mag_gt. + * unfold u2, ulp, cexp; bpow_simplify; apply bpow_le. + apply (Zplus_le_reg_r _ _ (- mag y)); ring_simplify. rewrite (Zplus_comm (- _)). - destruct (ln_beta_div_disj x y Px Py) as [Hxy|Hxy]; rewrite Hxy; + destruct (mag_div_disj x y Px Py) as [Hxy|Hxy]; rewrite Hxy; apply Hexp; try assumption; rewrite <- Hxy; omega. + apply Rge_le; rewrite Fx at 1; apply Rle_ge. rewrite Fy at 1 2. - apply (Rmult_le_reg_r (bpow (- fexp1 (ln_beta x)))); + apply (Rmult_le_reg_r (bpow (- fexp1 (mag x)))); [now apply bpow_gt_0|]. do 2 rewrite Rmult_plus_distr_r. bpow_simplify. replace (2 * x' * _ * _) - with (2 * Z2R my * x' * bpow (fexp1 (ln_beta y) - fexp1 (ln_beta x))) by ring. + with (2 * IZR my * x' * bpow (fexp1 (mag y) - fexp1 (mag x))) by ring. rewrite (Rmult_comm u1). - unfold x', u1, round, F2R, ulp, scaled_mantissa, canonic_exp; simpl. + unfold x', u1, round, F2R, ulp, scaled_mantissa, cexp; simpl. bpow_simplify. - rewrite <- (Z2R_Zpower _ (_ - _)%Z); [|omega]. - change 2 with (Z2R 2). - do 5 rewrite <- Z2R_mult. - change 1 with (Z2R 1); do 2 rewrite <- Z2R_plus. - apply Z2R_le. + rewrite <- (IZR_Zpower _ (_ - _)%Z); [|omega]. + do 5 rewrite <- mult_IZR. + do 2 rewrite <- plus_IZR. + apply IZR_le. apply Zlt_le_succ. - apply lt_Z2R. - rewrite Z2R_plus. - do 5 rewrite Z2R_mult; simpl. - rewrite Z2R_Zpower; [|omega]. - apply (Rmult_lt_reg_r (bpow (fexp1 (ln_beta x)))); + apply lt_IZR. + rewrite plus_IZR. + do 5 rewrite mult_IZR; simpl. + rewrite IZR_Zpower; [|omega]. + apply (Rmult_lt_reg_r (bpow (fexp1 (mag x)))); [now apply bpow_gt_0|]. - rewrite (Rmult_assoc _ (Z2R mx)). + rewrite (Rmult_assoc _ (IZR mx)). rewrite <- Fx. rewrite Rmult_plus_distr_r. bpow_simplify. rewrite bpow_plus. rewrite Rmult_assoc. - rewrite <- (Rmult_assoc (Z2R _)). - change (Z2R _ * bpow _) with x'. - do 2 rewrite (Rmult_comm _ (bpow (fexp1 (ln_beta y)))). + rewrite <- (Rmult_assoc (IZR _)). + change (IZR _ * bpow _) with x'. + do 2 rewrite (Rmult_comm _ (bpow (fexp1 (mag y)))). rewrite Rmult_assoc. - do 2 rewrite <- (Rmult_assoc (Z2R my)). + do 2 rewrite <- (Rmult_assoc (IZR my)). rewrite <- Fy. change (bpow _) with u1. apply (Rmult_lt_reg_l (/ 2)); [lra|]. @@ -4302,55 +4264,55 @@ destruct (Zle_or_lt Z0 (fexp1 (ln_beta x) - fexp1 (ln_beta (x / y)) now rewrite (Rplus_comm (- x')). Qed. -Lemma double_round_div_aux : +Lemma round_round_div_aux : forall fexp1 fexp2 : Z -> Z, Valid_exp fexp1 -> Valid_exp fexp2 -> forall (choice1 choice2 : Z -> bool), (exists n, (beta = 2 * n :> Z)%Z) -> - double_round_div_hyp fexp1 fexp2 -> + round_round_div_hyp fexp1 fexp2 -> forall x y, 0 < x -> 0 < y -> generic_format beta fexp1 x -> generic_format beta fexp1 y -> - double_round_eq fexp1 fexp2 choice1 choice2 (x / y). + round_round_eq fexp1 fexp2 choice1 choice2 (x / y). Proof. intros fexp1 fexp2 Vfexp1 Vfexp2 choice1 choice2 Ebeta Hexp x y Px Py Fx Fy. assert (Pxy : 0 < x / y). { apply Rmult_lt_0_compat; [exact Px|]. now apply Rinv_0_lt_compat. } -apply double_round_all_mid_cases. +apply round_round_all_mid_cases. - exact Vfexp1. - exact Vfexp2. - exact Pxy. - apply Hexp. - intros Hf1 Hlxy. casetype False. - now apply (double_round_div_aux0 fexp1 fexp2 _ _ choice1 choice2 Hexp x y). + now apply (round_round_div_aux0 fexp1 fexp2 _ _ choice1 choice2 Hexp x y). - intros Hf1 Hlxy. casetype False. - now apply (double_round_div_aux1 fexp1 fexp2 _ _ choice1 choice2 Hexp x y). + now apply (round_round_div_aux1 fexp1 fexp2 _ _ choice1 choice2 Hexp x y). - intro H. - apply double_round_eq_mid_beta_even; try assumption. + apply round_round_eq_mid_beta_even; try assumption. apply Hexp. - intros Hf1 Hlxy. casetype False. - now apply (double_round_div_aux2 fexp1 fexp2 _ _ choice1 choice2 Hexp x y). + now apply (round_round_div_aux2 fexp1 fexp2 _ _ choice1 choice2 Hexp x y). Qed. -Lemma double_round_div : +Lemma round_round_div : forall fexp1 fexp2 : Z -> Z, Valid_exp fexp1 -> Valid_exp fexp2 -> forall (choice1 choice2 : Z -> bool), (exists n, (beta = 2 * n :> Z)%Z) -> - double_round_div_hyp fexp1 fexp2 -> + round_round_div_hyp fexp1 fexp2 -> forall x y, y <> 0 -> generic_format beta fexp1 x -> generic_format beta fexp1 y -> - double_round_eq fexp1 fexp2 choice1 choice2 (x / y). + round_round_eq fexp1 fexp2 choice1 choice2 (x / y). Proof. intros fexp1 fexp2 Vfexp1 Vfexp2 choice1 choice2 Ebeta Hexp x y Nzy Fx Fy. -unfold double_round_eq. +unfold round_round_eq. destruct (Rtotal_order x 0) as [Nx|[Zx|Px]]. - (* x < 0 *) destruct (Rtotal_order y 0) as [Ny|[Zy|Py]]. @@ -4367,7 +4329,7 @@ destruct (Rtotal_order x 0) as [Nx|[Zx|Px]]. rewrite Ropp_0 in Nx, Ny. apply generic_format_opp in Fx. apply generic_format_opp in Fy. - now apply double_round_div_aux. + now apply round_round_div_aux. + (* y = 0 *) now casetype False; apply Nzy. + (* y > 0 *) @@ -4378,7 +4340,7 @@ destruct (Rtotal_order x 0) as [Nx|[Zx|Px]]. apply Ropp_lt_contravar in Nx. rewrite Ropp_0 in Nx. apply generic_format_opp in Fx. - now apply double_round_div_aux. + now apply round_round_div_aux. - (* x = 0 *) rewrite Zx. unfold Rdiv; rewrite Rmult_0_l. @@ -4394,50 +4356,48 @@ destruct (Rtotal_order x 0) as [Nx|[Zx|Px]]. apply Ropp_lt_contravar in Ny. rewrite Ropp_0 in Ny. apply generic_format_opp in Fy. - now apply double_round_div_aux. + now apply round_round_div_aux. + (* y = 0 *) now casetype False; apply Nzy. + (* y > 0 *) - now apply double_round_div_aux. + now apply round_round_div_aux. Qed. Section Double_round_div_FLX. -Import Fcore_FLX. - Variable prec : Z. Variable prec' : Z. Context { prec_gt_0_ : Prec_gt_0 prec }. Context { prec_gt_0_' : Prec_gt_0 prec' }. -Lemma FLX_double_round_div_hyp : +Lemma FLX_round_round_div_hyp : (2 * prec <= prec')%Z -> - double_round_div_hyp (FLX_exp prec) (FLX_exp prec'). + round_round_div_hyp (FLX_exp prec) (FLX_exp prec'). Proof. intros Hprec. unfold Prec_gt_0 in prec_gt_0_. unfold FLX_exp. -unfold double_round_div_hyp. +unfold round_round_div_hyp. split; [now intro ex; omega|]. split; [|split; [|split]]; intros ex ey; omega. Qed. -Theorem double_round_div_FLX : +Theorem round_round_div_FLX : forall choice1 choice2, (exists n, (beta = 2 * n :> Z)%Z) -> (2 * prec <= prec')%Z -> forall x y, y <> 0 -> FLX_format beta prec x -> FLX_format beta prec y -> - double_round_eq (FLX_exp prec) (FLX_exp prec') choice1 choice2 (x / y). + round_round_eq (FLX_exp prec) (FLX_exp prec') choice1 choice2 (x / y). Proof. intros choice1 choice2 Ebeta Hprec x y Nzy Fx Fy. -apply double_round_div. +apply round_round_div. - now apply FLX_exp_valid. - now apply FLX_exp_valid. - exact Ebeta. -- now apply FLX_double_round_div_hyp. +- now apply FLX_round_round_div_hyp. - exact Nzy. - now apply generic_format_FLX. - now apply generic_format_FLX. @@ -4447,24 +4407,21 @@ End Double_round_div_FLX. Section Double_round_div_FLT. -Import Fcore_FLX. -Import Fcore_FLT. - Variable emin prec : Z. Variable emin' prec' : Z. Context { prec_gt_0_ : Prec_gt_0 prec }. Context { prec_gt_0_' : Prec_gt_0 prec' }. -Lemma FLT_double_round_div_hyp : +Lemma FLT_round_round_div_hyp : (emin' <= emin - prec - 2)%Z -> (2 * prec <= prec')%Z -> - double_round_div_hyp (FLT_exp emin prec) (FLT_exp emin' prec'). + round_round_div_hyp (FLT_exp emin prec) (FLT_exp emin' prec'). Proof. intros Hemin Hprec. unfold FLT_exp. unfold Prec_gt_0 in prec_gt_0_. -unfold double_round_div_hyp. +unfold round_round_div_hyp. split; [intro ex|split; [|split; [|split]]; intros ex ey]. - generalize (Zmax_spec (ex - prec') emin'). generalize (Zmax_spec (ex - prec) emin). @@ -4491,7 +4448,7 @@ split; [intro ex|split; [|split; [|split]]; intros ex ey]. omega. Qed. -Theorem double_round_div_FLT : +Theorem round_round_div_FLT : forall choice1 choice2, (exists n, (beta = 2 * n :> Z)%Z) -> (emin' <= emin - prec - 2)%Z -> @@ -4499,15 +4456,15 @@ Theorem double_round_div_FLT : forall x y, y <> 0 -> FLT_format beta emin prec x -> FLT_format beta emin prec y -> - double_round_eq (FLT_exp emin prec) (FLT_exp emin' prec') + round_round_eq (FLT_exp emin prec) (FLT_exp emin' prec') choice1 choice2 (x / y). Proof. intros choice1 choice2 Ebeta Hemin Hprec x y Nzy Fx Fy. -apply double_round_div. +apply round_round_div. - now apply FLT_exp_valid. - now apply FLT_exp_valid. - exact Ebeta. -- now apply FLT_double_round_div_hyp. +- now apply FLT_round_round_div_hyp. - exact Nzy. - now apply generic_format_FLT. - now apply generic_format_FLT. @@ -4517,25 +4474,22 @@ End Double_round_div_FLT. Section Double_round_div_FTZ. -Import Fcore_FLX. -Import Fcore_FTZ. - Variable emin prec : Z. Variable emin' prec' : Z. Context { prec_gt_0_ : Prec_gt_0 prec }. Context { prec_gt_0_' : Prec_gt_0 prec' }. -Lemma FTZ_double_round_div_hyp : +Lemma FTZ_round_round_div_hyp : (emin' + prec' <= emin - 1)%Z -> (2 * prec <= prec')%Z -> - double_round_div_hyp (FTZ_exp emin prec) (FTZ_exp emin' prec'). + round_round_div_hyp (FTZ_exp emin prec) (FTZ_exp emin' prec'). Proof. intros Hemin Hprec. unfold FTZ_exp. unfold Prec_gt_0 in prec_gt_0_. unfold Prec_gt_0 in prec_gt_0_. -unfold double_round_div_hyp. +unfold round_round_div_hyp. split; [intro ex|split; [|split; [|split]]; intros ex ey]. - destruct (Z.ltb_spec (ex - prec') emin'); destruct (Z.ltb_spec (ex - prec) emin); @@ -4562,7 +4516,7 @@ split; [intro ex|split; [|split; [|split]]; intros ex ey]. omega. Qed. -Theorem double_round_div_FTZ : +Theorem round_round_div_FTZ : forall choice1 choice2, (exists n, (beta = 2 * n :> Z)%Z) -> (emin' + prec' <= emin - 1)%Z -> @@ -4570,15 +4524,15 @@ Theorem double_round_div_FTZ : forall x y, y <> 0 -> FTZ_format beta emin prec x -> FTZ_format beta emin prec y -> - double_round_eq (FTZ_exp emin prec) (FTZ_exp emin' prec') + round_round_eq (FTZ_exp emin prec) (FTZ_exp emin' prec') choice1 choice2 (x / y). Proof. intros choice1 choice2 Ebeta Hemin Hprec x y Nzy Fx Fy. -apply double_round_div. +apply round_round_div. - now apply FTZ_exp_valid. - now apply FTZ_exp_valid. - exact Ebeta. -- now apply FTZ_double_round_div_hyp. +- now apply FTZ_round_round_div_hyp. - exact Nzy. - now apply generic_format_FTZ. - now apply generic_format_FTZ. diff --git a/flocq/Prop/Fprop_div_sqrt_error.v b/flocq/Prop/Fprop_div_sqrt_error.v deleted file mode 100644 index 422b6b64..00000000 --- a/flocq/Prop/Fprop_div_sqrt_error.v +++ /dev/null @@ -1,300 +0,0 @@ -(** -This file is part of the Flocq formalization of floating-point -arithmetic in Coq: http://flocq.gforge.inria.fr/ - -Copyright (C) 2010-2013 Sylvie Boldo -#<br /># -Copyright (C) 2010-2013 Guillaume Melquiond - -This library is free software; you can redistribute it and/or -modify it under the terms of the GNU Lesser General Public -License as published by the Free Software Foundation; either -version 3 of the License, or (at your option) any later version. - -This library is distributed in the hope that it will be useful, -but WITHOUT ANY WARRANTY; without even the implied warranty of -MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -COPYING file for more details. -*) - -(** * Remainder of the division and square root are in the FLX format *) -Require Import Fcore. -Require Import Fcalc_ops. -Require Import Fprop_relative. - -Section Fprop_divsqrt_error. - -Variable beta : radix. -Notation bpow e := (bpow beta e). - -Variable prec : Z. - -Theorem generic_format_plus_prec: - forall fexp, (forall e, (fexp e <= e - prec)%Z) -> - forall x y (fx fy: float beta), - (x = F2R fx)%R -> (y = F2R fy)%R -> (Rabs (x+y) < bpow (prec+Fexp fx))%R -> (Rabs (x+y) < bpow (prec+Fexp fy))%R - -> generic_format beta fexp (x+y)%R. -intros fexp Hfexp x y fx fy Hx Hy H1 H2. -case (Req_dec (x+y) 0); intros H. -rewrite H; apply generic_format_0. -rewrite Hx, Hy, <- F2R_plus. -apply generic_format_F2R. -intros _. -case_eq (Fplus beta fx fy). -intros mz ez Hz. -rewrite <- Hz. -apply Zle_trans with (Zmin (Fexp fx) (Fexp fy)). -rewrite F2R_plus, <- Hx, <- Hy. -unfold canonic_exp. -apply Zle_trans with (1:=Hfexp _). -apply Zplus_le_reg_l with prec; ring_simplify. -apply ln_beta_le_bpow with (1 := H). -now apply Zmin_case. -rewrite <- Fexp_Fplus, Hz. -apply Zle_refl. -Qed. - -Theorem ex_Fexp_canonic: forall fexp, forall x, generic_format beta fexp x - -> exists fx:float beta, (x=F2R fx)%R /\ Fexp fx = canonic_exp beta fexp x. -intros fexp x; unfold generic_format. -exists (Float beta (Ztrunc (scaled_mantissa beta fexp x)) (canonic_exp beta fexp x)). -split; auto. -Qed. - - -Context { prec_gt_0_ : Prec_gt_0 prec }. - -Notation format := (generic_format beta (FLX_exp prec)). -Notation cexp := (canonic_exp beta (FLX_exp prec)). - -Variable choice : Z -> bool. - - -(** Remainder of the division in FLX *) -Theorem div_error_FLX : - forall rnd { Zrnd : Valid_rnd rnd } x y, - format x -> format y -> - format (x - round beta (FLX_exp prec) rnd (x/y) * y)%R. -Proof with auto with typeclass_instances. -intros rnd Zrnd x y Hx Hy. -destruct (Req_dec y 0) as [Zy|Zy]. -now rewrite Zy, Rmult_0_r, Rminus_0_r. -destruct (Req_dec (round beta (FLX_exp prec) rnd (x/y)) 0) as [Hr|Hr]. -rewrite Hr; ring_simplify (x-0*y)%R; assumption. -assert (Zx: x <> R0). -contradict Hr. -rewrite Hr. -unfold Rdiv. -now rewrite Rmult_0_l, round_0. -destruct (ex_Fexp_canonic _ x Hx) as (fx,(Hx1,Hx2)). -destruct (ex_Fexp_canonic _ y Hy) as (fy,(Hy1,Hy2)). -destruct (ex_Fexp_canonic (FLX_exp prec) (round beta (FLX_exp prec) rnd (x / y))) as (fr,(Hr1,Hr2)). -apply generic_format_round... -unfold Rminus; apply generic_format_plus_prec with fx (Fopp beta (Fmult beta fr fy)); trivial. -intros e; apply Zle_refl. -now rewrite F2R_opp, F2R_mult, <- Hr1, <- Hy1. -(* *) -destruct (relative_error_FLX_ex beta prec (prec_gt_0 prec) rnd (x / y)%R) as (eps,(Heps1,Heps2)). -rewrite Heps2. -rewrite <- Rabs_Ropp. -replace (-(x + - (x / y * (1 + eps) * y)))%R with (x * eps)%R by now field. -rewrite Rabs_mult. -apply Rlt_le_trans with (Rabs x * 1)%R. -apply Rmult_lt_compat_l. -now apply Rabs_pos_lt. -apply Rlt_le_trans with (1 := Heps1). -change 1%R with (bpow 0). -apply bpow_le. -generalize (prec_gt_0 prec). -clear ; omega. -rewrite Rmult_1_r. -rewrite Hx2. -unfold canonic_exp. -destruct (ln_beta beta x) as (ex, Hex). -simpl. -specialize (Hex Zx). -apply Rlt_le. -apply Rlt_le_trans with (1 := proj2 Hex). -apply bpow_le. -unfold FLX_exp. -ring_simplify. -apply Zle_refl. -(* *) -replace (Fexp (Fopp beta (Fmult beta fr fy))) with (Fexp fr + Fexp fy)%Z. -2: unfold Fopp, Fmult; destruct fr; destruct fy; now simpl. -replace (x + - (round beta (FLX_exp prec) rnd (x / y) * y))%R with - (y * (-(round beta (FLX_exp prec) rnd (x / y) - x/y)))%R. -2: field; assumption. -rewrite Rabs_mult. -apply Rlt_le_trans with (Rabs y * bpow (Fexp fr))%R. -apply Rmult_lt_compat_l. -now apply Rabs_pos_lt. -rewrite Rabs_Ropp. -replace (bpow (Fexp fr)) with (ulp beta (FLX_exp prec) (F2R fr)). -rewrite <- Hr1. -apply error_lt_ulp_round... -apply Rmult_integral_contrapositive_currified; try apply Rinv_neq_0_compat; assumption. -rewrite ulp_neq_0. -2: now rewrite <- Hr1. -apply f_equal. -now rewrite Hr2, <- Hr1. -replace (prec+(Fexp fr+Fexp fy))%Z with ((prec+Fexp fy)+Fexp fr)%Z by ring. -rewrite bpow_plus. -apply Rmult_le_compat_r. -apply bpow_ge_0. -rewrite Hy2; unfold canonic_exp, FLX_exp. -ring_simplify (prec + (ln_beta beta y - prec))%Z. -destruct (ln_beta beta y); simpl. -left; now apply a. -Qed. - -(** Remainder of the square in FLX (with p>1) and rounding to nearest *) -Variable Hp1 : Zlt 1 prec. - -Theorem sqrt_error_FLX_N : - forall x, format x -> - format (x - Rsqr (round beta (FLX_exp prec) (Znearest choice) (sqrt x)))%R. -Proof with auto with typeclass_instances. -intros x Hx. -destruct (total_order_T x 0) as [[Hxz|Hxz]|Hxz]. -unfold sqrt. -destruct (Rcase_abs x). -rewrite round_0... -unfold Rsqr. -now rewrite Rmult_0_l, Rminus_0_r. -elim (Rlt_irrefl 0). -now apply Rgt_ge_trans with x. -rewrite Hxz, sqrt_0, round_0... -unfold Rsqr. -rewrite Rmult_0_l, Rminus_0_r. -apply generic_format_0. -case (Req_dec (round beta (FLX_exp prec) (Znearest choice) (sqrt x)) 0); intros Hr. -rewrite Hr; unfold Rsqr; ring_simplify (x-0*0)%R; assumption. -destruct (ex_Fexp_canonic _ x Hx) as (fx,(Hx1,Hx2)). -destruct (ex_Fexp_canonic (FLX_exp prec) (round beta (FLX_exp prec) (Znearest choice) (sqrt x))) as (fr,(Hr1,Hr2)). -apply generic_format_round... -unfold Rminus; apply generic_format_plus_prec with fx (Fopp beta (Fmult beta fr fr)); trivial. -intros e; apply Zle_refl. -unfold Rsqr; now rewrite F2R_opp,F2R_mult, <- Hr1. -(* *) -apply Rle_lt_trans with x. -apply Rabs_minus_le. -apply Rle_0_sqr. -destruct (relative_error_N_FLX_ex beta prec (prec_gt_0 prec) choice (sqrt x)) as (eps,(Heps1,Heps2)). -rewrite Heps2. -rewrite Rsqr_mult, Rsqr_sqrt, Rmult_comm. 2: now apply Rlt_le. -apply Rmult_le_compat_r. -now apply Rlt_le. -apply Rle_trans with (5²/4²)%R. -rewrite <- Rsqr_div. -apply Rsqr_le_abs_1. -apply Rle_trans with (1 := Rabs_triang _ _). -rewrite Rabs_R1. -apply Rplus_le_reg_l with (-1)%R. -replace (-1 + (1 + Rabs eps))%R with (Rabs eps) by ring. -apply Rle_trans with (1 := Heps1). -rewrite Rabs_pos_eq. -apply Rmult_le_reg_l with 2%R. -now apply (Z2R_lt 0 2). -rewrite <- Rmult_assoc, Rinv_r, Rmult_1_l. -apply Rle_trans with (bpow (-1)). -apply bpow_le. -omega. -replace (2 * (-1 + 5 / 4))%R with (/2)%R by field. -apply Rinv_le. -now apply (Z2R_lt 0 2). -apply (Z2R_le 2). -unfold Zpower_pos. simpl. -rewrite Zmult_1_r. -apply Zle_bool_imp_le. -apply beta. -apply Rgt_not_eq. -now apply (Z2R_lt 0 2). -unfold Rdiv. -apply Rmult_le_pos. -now apply (Z2R_le 0 5). -apply Rlt_le. -apply Rinv_0_lt_compat. -now apply (Z2R_lt 0 4). -apply Rgt_not_eq. -now apply (Z2R_lt 0 4). -unfold Rsqr. -replace (5 * 5 / (4 * 4))%R with (25 * /16)%R by field. -apply Rmult_le_reg_r with 16%R. -now apply (Z2R_lt 0 16). -rewrite Rmult_assoc, Rinv_l, Rmult_1_r. -now apply (Z2R_le 25 32). -apply Rgt_not_eq. -now apply (Z2R_lt 0 16). -rewrite Hx2; unfold canonic_exp, FLX_exp. -ring_simplify (prec + (ln_beta beta x - prec))%Z. -destruct (ln_beta beta x); simpl. -rewrite <- (Rabs_right x). -apply a. -now apply Rgt_not_eq. -now apply Rgt_ge. -(* *) -replace (Fexp (Fopp beta (Fmult beta fr fr))) with (Fexp fr + Fexp fr)%Z. -2: unfold Fopp, Fmult; destruct fr; now simpl. -rewrite Hr1. -replace (x + - Rsqr (F2R fr))%R with (-((F2R fr - sqrt x)*(F2R fr + sqrt x)))%R. -2: rewrite <- (sqrt_sqrt x) at 3; auto. -2: unfold Rsqr; ring. -rewrite Rabs_Ropp, Rabs_mult. -apply Rle_lt_trans with ((/2*bpow (Fexp fr))* Rabs (F2R fr + sqrt x))%R. -apply Rmult_le_compat_r. -apply Rabs_pos. -apply Rle_trans with (/2*ulp beta (FLX_exp prec) (F2R fr))%R. -rewrite <- Hr1. -apply error_le_half_ulp_round... -right; rewrite ulp_neq_0. -2: now rewrite <- Hr1. -apply f_equal. -rewrite Hr2, <- Hr1; trivial. -rewrite Rmult_assoc, Rmult_comm. -replace (prec+(Fexp fr+Fexp fr))%Z with (Fexp fr + (prec+Fexp fr))%Z by ring. -rewrite bpow_plus, Rmult_assoc. -apply Rmult_lt_compat_l. -apply bpow_gt_0. -apply Rmult_lt_reg_l with (1 := Rlt_0_2). -apply Rle_lt_trans with (Rabs (F2R fr + sqrt x)). -right; field. -apply Rle_lt_trans with (1:=Rabs_triang _ _). -(* . *) -assert (Rabs (F2R fr) < bpow (prec + Fexp fr))%R. -rewrite Hr2; unfold canonic_exp; rewrite Hr1. -unfold FLX_exp. -ring_simplify (prec + (ln_beta beta (F2R fr) - prec))%Z. -destruct (ln_beta beta (F2R fr)); simpl. -apply a. -rewrite <- Hr1; auto. -(* . *) -apply Rlt_le_trans with (bpow (prec + Fexp fr)+ Rabs (sqrt x))%R. -now apply Rplus_lt_compat_r. -(* . *) -replace (2 * bpow (prec + Fexp fr))%R with (bpow (prec + Fexp fr) + bpow (prec + Fexp fr))%R by ring. -apply Rplus_le_compat_l. -assert (sqrt x <> 0)%R. -apply Rgt_not_eq. -now apply sqrt_lt_R0. -destruct (ln_beta beta (sqrt x)) as (es,Es). -specialize (Es H0). -apply Rle_trans with (bpow es). -now apply Rlt_le. -apply bpow_le. -case (Zle_or_lt es (prec + Fexp fr)) ; trivial. -intros H1. -absurd (Rabs (F2R fr) < bpow (es - 1))%R. -apply Rle_not_lt. -rewrite <- Hr1. -apply abs_round_ge_generic... -apply generic_format_bpow. -unfold FLX_exp; omega. -apply Es. -apply Rlt_le_trans with (1:=H). -apply bpow_le. -omega. -now apply Rlt_le. -Qed. - -End Fprop_divsqrt_error. diff --git a/flocq/Prop/Fprop_mult_error.v b/flocq/Prop/Mult_error.v index 44448cd6..57a3856f 100644 --- a/flocq/Prop/Fprop_mult_error.v +++ b/flocq/Prop/Mult_error.v @@ -2,9 +2,9 @@ This file is part of the Flocq formalization of floating-point arithmetic in Coq: http://flocq.gforge.inria.fr/ -Copyright (C) 2010-2013 Sylvie Boldo +Copyright (C) 2010-2018 Sylvie Boldo #<br /># -Copyright (C) 2010-2013 Guillaume Melquiond +Copyright (C) 2010-2018 Guillaume Melquiond This library is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public @@ -18,8 +18,7 @@ COPYING file for more details. *) (** * Error of the multiplication is in the FLX/FLT format *) -Require Import Fcore. -Require Import Fcalc_ops. +Require Import Core Operations Plus_error. Section Fprop_mult_error. @@ -30,7 +29,7 @@ Variable prec : Z. Context { prec_gt_0_ : Prec_gt_0 prec }. Notation format := (generic_format beta (FLX_exp prec)). -Notation cexp := (canonic_exp beta (FLX_exp prec)). +Notation cexp := (cexp beta (FLX_exp prec)). Variable rnd : R -> Z. Context { valid_rnd : Valid_rnd rnd }. @@ -41,9 +40,9 @@ Lemma mult_error_FLX_aux: format x -> format y -> (round beta (FLX_exp prec) rnd (x * y) - (x * y) <> 0)%R -> exists f:float beta, - (F2R f = round beta (FLX_exp prec) rnd (x * y) - (x * y))%R - /\ (canonic_exp beta (FLX_exp prec) (F2R f) <= Fexp f)%Z - /\ (Fexp f = cexp x + cexp y)%Z. + (F2R f = round beta (FLX_exp prec) rnd (x * y) - (x * y))%R + /\ (cexp (F2R f) <= Fexp f)%Z + /\ (Fexp f = cexp x + cexp y)%Z. Proof with auto with typeclass_instances. intros x y Hx Hy Hz. set (f := (round beta (FLX_exp prec) rnd (x * y))). @@ -52,26 +51,26 @@ contradict Hz. rewrite Hxy0. rewrite round_0... ring. -destruct (ln_beta beta (x * y)) as (exy, Hexy). +destruct (mag beta (x * y)) as (exy, Hexy). specialize (Hexy Hxy0). -destruct (ln_beta beta (f - x * y)) as (er, Her). +destruct (mag beta (f - x * y)) as (er, Her). specialize (Her Hz). -destruct (ln_beta beta x) as (ex, Hex). +destruct (mag beta x) as (ex, Hex). assert (Hx0: (x <> 0)%R). contradict Hxy0. now rewrite Hxy0, Rmult_0_l. specialize (Hex Hx0). -destruct (ln_beta beta y) as (ey, Hey). +destruct (mag beta y) as (ey, Hey). assert (Hy0: (y <> 0)%R). contradict Hxy0. now rewrite Hxy0, Rmult_0_r. specialize (Hey Hy0). (* *) assert (Hc1: (cexp (x * y)%R - prec <= cexp x + cexp y)%Z). -unfold canonic_exp, FLX_exp. -rewrite ln_beta_unique with (1 := Hex). -rewrite ln_beta_unique with (1 := Hey). -rewrite ln_beta_unique with (1 := Hexy). +unfold cexp, FLX_exp. +rewrite mag_unique with (1 := Hex). +rewrite mag_unique with (1 := Hey). +rewrite mag_unique with (1 := Hexy). cut (exy - 1 < ex + ey)%Z. omega. apply (lt_bpow beta). apply Rle_lt_trans with (1 := proj1 Hexy). @@ -84,10 +83,10 @@ apply Hex. apply Hey. (* *) assert (Hc2: (cexp x + cexp y <= cexp (x * y)%R)%Z). -unfold canonic_exp, FLX_exp. -rewrite ln_beta_unique with (1 := Hex). -rewrite ln_beta_unique with (1 := Hey). -rewrite ln_beta_unique with (1 := Hexy). +unfold cexp, FLX_exp. +rewrite mag_unique with (1 := Hex). +rewrite mag_unique with (1 := Hey). +rewrite mag_unique with (1 := Hexy). cut ((ex - 1) + (ey - 1) < exy)%Z. generalize (prec_gt_0 prec). clear ; omega. @@ -120,16 +119,16 @@ split;[assumption|split]. rewrite Hr. simpl. clear Hr. -apply Zle_trans with (cexp (x * y)%R - prec)%Z. -unfold canonic_exp, FLX_exp. +apply Z.le_trans with (cexp (x * y)%R - prec)%Z. +unfold cexp, FLX_exp. apply Zplus_le_compat_r. -rewrite ln_beta_unique with (1 := Hexy). -apply ln_beta_le_bpow with (1 := Hz). +rewrite mag_unique with (1 := Hexy). +apply mag_le_bpow with (1 := Hz). replace (bpow (exy - prec)) with (ulp beta (FLX_exp prec) (x * y)). apply error_lt_ulp... rewrite ulp_neq_0; trivial. -unfold canonic_exp. -now rewrite ln_beta_unique with (1 := Hexy). +unfold cexp. +now rewrite mag_unique with (1 := Hexy). apply Hc1. reflexivity. Qed. @@ -149,6 +148,24 @@ rewrite <- H1. now apply generic_format_F2R. Qed. +Lemma mult_bpow_exact_FLX : + forall x e, + format x -> + format (x * bpow e)%R. +Proof. +intros x e Fx. +destruct (Req_dec x 0) as [Zx|Nzx]. +{ rewrite Zx, Rmult_0_l; apply generic_format_0. } +rewrite Fx. +set (mx := Ztrunc _); set (ex := cexp _). +pose (f := {| Fnum := mx; Fexp := ex + e |} : float beta). +apply (generic_format_F2R' _ _ _ f). +{ now unfold F2R; simpl; rewrite bpow_plus, Rmult_assoc. } +intro Nzmx; unfold mx, ex; rewrite <- Fx. +unfold f, ex; simpl; unfold cexp; rewrite (mag_mult_bpow _ _ _ Nzx). +unfold FLX_exp; omega. +Qed. + End Fprop_mult_error. Section Fprop_mult_error_FLT. @@ -160,7 +177,7 @@ Variable emin prec : Z. Context { prec_gt_0_ : Prec_gt_0 prec }. Notation format := (generic_format beta (FLT_exp emin prec)). -Notation cexp := (canonic_exp beta (FLT_exp emin prec)). +Notation cexp := (cexp beta (FLT_exp emin prec)). Variable rnd : R -> Z. Context { valid_rnd : Valid_rnd rnd }. @@ -169,7 +186,7 @@ Context { valid_rnd : Valid_rnd rnd }. Theorem mult_error_FLT : forall x y, format x -> format y -> - (x*y = 0)%R \/ (bpow (emin + 2*prec - 1) <= Rabs (x * y))%R -> + (x * y <> 0 -> bpow (emin + 2*prec - 1) <= Rabs (x * y))%R -> format (round beta (FLT_exp emin prec) rnd (x * y) - (x * y))%R. Proof with auto with typeclass_instances. intros x y Hx Hy Hxy. @@ -177,12 +194,13 @@ set (f := (round beta (FLT_exp emin prec) rnd (x * y))). destruct (Req_dec (f - x * y) 0) as [Hr0|Hr0]. rewrite Hr0. apply generic_format_0. -destruct Hxy as [Hxy|Hxy]. +destruct (Req_dec (x * y) 0) as [Hxy'|Hxy']. unfold f. -rewrite Hxy. +rewrite Hxy'. rewrite round_0... ring_simplify (0 - 0)%R. apply generic_format_0. +specialize (Hxy Hxy'). destruct (mult_error_FLX_aux beta prec rnd x y) as ((m,e),(H1,(H2,H3))). now apply generic_format_FLX_FLT with emin. now apply generic_format_FLX_FLT with emin. @@ -199,14 +217,14 @@ unfold f; rewrite <- H1. apply generic_format_F2R. intros _. simpl in H2, H3. -unfold canonic_exp, FLT_exp. -case (Zmax_spec (ln_beta beta (F2R (Float beta m e)) - prec) emin); +unfold cexp, FLT_exp. +case (Zmax_spec (mag beta (F2R (Float beta m e)) - prec) emin); intros (M1,M2); rewrite M2. -apply Zle_trans with (2:=H2). -unfold canonic_exp, FLX_exp. -apply Zle_refl. +apply Z.le_trans with (2:=H2). +unfold cexp, FLX_exp. +apply Z.le_refl. rewrite H3. -unfold canonic_exp, FLX_exp. +unfold cexp, FLX_exp. assert (Hxy0:(x*y <> 0)%R). contradict Hr0. unfold f. @@ -219,9 +237,9 @@ now rewrite Hxy0, Rmult_0_l. assert (Hy0: (y <> 0)%R). contradict Hxy0. now rewrite Hxy0, Rmult_0_r. -destruct (ln_beta beta x) as (ex,Ex) ; simpl. +destruct (mag beta x) as (ex,Ex) ; simpl. specialize (Ex Hx0). -destruct (ln_beta beta y) as (ey,Ey) ; simpl. +destruct (mag beta y) as (ey,Ey) ; simpl. specialize (Ey Hy0). assert (emin + 2 * prec -1 < ex + ey)%Z. 2: omega. @@ -233,4 +251,85 @@ apply Ex. apply Ey. Qed. +Lemma F2R_ge: forall (y:float beta), + (F2R y <> 0)%R -> (bpow (Fexp y) <= Rabs (F2R y))%R. +Proof. +intros (ny,ey). +rewrite <- F2R_Zabs; unfold F2R; simpl. +case (Zle_lt_or_eq 0 (Z.abs ny)). +apply Z.abs_nonneg. +intros Hy _. +rewrite <- (Rmult_1_l (bpow _)) at 1. +apply Rmult_le_compat_r. +apply bpow_ge_0. +apply IZR_le; omega. +intros H1 H2; contradict H2. +replace ny with 0%Z. +simpl; ring. +now apply sym_eq, Z.abs_0_iff, sym_eq. +Qed. + +Theorem mult_error_FLT_ge_bpow : + forall x y e, + format x -> format y -> + (bpow (e+2*prec-1) <= Rabs (x * y))%R -> + (round beta (FLT_exp emin prec) rnd (x * y) - (x * y) <> 0)%R -> + (bpow e <= Rabs (round beta (FLT_exp emin prec) rnd (x * y) - (x * y)))%R. +Proof with auto with typeclass_instances. +intros x y e. +set (f := (round beta (FLT_exp emin prec) rnd (x * y))). +intros Fx Fy H1. +unfold f; rewrite Fx, Fy, <- F2R_mult. +simpl Fmult. +destruct (round_repr_same_exp beta (FLT_exp emin prec) + rnd (Ztrunc (scaled_mantissa beta (FLT_exp emin prec) x) * + Ztrunc (scaled_mantissa beta (FLT_exp emin prec) y)) + (cexp x + cexp y)) as (n,Hn). +rewrite Hn; clear Hn. +rewrite <- F2R_minus, Fminus_same_exp. +intros K. +eapply Rle_trans with (2:=F2R_ge _ K). +simpl (Fexp _). +apply bpow_le. +unfold cexp, FLT_exp. +destruct (mag beta x) as (ex,Hx). +destruct (mag beta y) as (ey,Hy). +simpl; apply Z.le_trans with ((ex-prec)+(ey-prec))%Z. +2: apply Zplus_le_compat; apply Z.le_max_l. +assert (e + 2*prec -1< ex+ey)%Z;[idtac|omega]. +apply lt_bpow with beta. +apply Rle_lt_trans with (1:=H1). +rewrite Rabs_mult, bpow_plus. +apply Rmult_lt_compat. +apply Rabs_pos. +apply Rabs_pos. +apply Hx. +intros K'; contradict H1; apply Rlt_not_le. +rewrite K', Rmult_0_l, Rabs_R0; apply bpow_gt_0. +apply Hy. +intros K'; contradict H1; apply Rlt_not_le. +rewrite K', Rmult_0_r, Rabs_R0; apply bpow_gt_0. +Qed. + +Lemma mult_bpow_exact_FLT : + forall x e, + format x -> + (emin + prec - mag beta x <= e)%Z -> + format (x * bpow e)%R. +Proof. +intros x e Fx He. +destruct (Req_dec x 0) as [Zx|Nzx]. +{ rewrite Zx, Rmult_0_l; apply generic_format_0. } +rewrite Fx. +set (mx := Ztrunc _); set (ex := cexp _). +pose (f := {| Fnum := mx; Fexp := ex + e |} : float beta). +apply (generic_format_F2R' _ _ _ f). +{ now unfold F2R; simpl; rewrite bpow_plus, Rmult_assoc. } +intro Nzmx; unfold mx, ex; rewrite <- Fx. +unfold f, ex; simpl; unfold cexp; rewrite (mag_mult_bpow _ _ _ Nzx). +unfold FLT_exp; rewrite Z.max_l; [|omega]; rewrite <- Z.add_max_distr_r. +set (n := (_ - _ + _)%Z); apply (Z.le_trans _ n); [unfold n; omega|]. +apply Z.le_max_l. +Qed. + End Fprop_mult_error_FLT. diff --git a/flocq/Prop/Fprop_plus_error.v b/flocq/Prop/Plus_error.v index 9bb5aee8..42f80093 100644 --- a/flocq/Prop/Fprop_plus_error.v +++ b/flocq/Prop/Plus_error.v @@ -2,9 +2,9 @@ This file is part of the Flocq formalization of floating-point arithmetic in Coq: http://flocq.gforge.inria.fr/ -Copyright (C) 2010-2013 Sylvie Boldo +Copyright (C) 2010-2018 Sylvie Boldo #<br /># -Copyright (C) 2010-2013 Guillaume Melquiond +Copyright (C) 2010-2018 Guillaume Melquiond This library is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public @@ -20,15 +20,9 @@ COPYING file for more details. (** * Error of the rounded-to-nearest addition is representable. *) Require Import Psatz. -Require Import Fcore_Raux. -Require Import Fcore_defs. -Require Import Fcore_float_prop. -Require Import Fcore_generic_fmt. -Require Import Fcore_FIX. -Require Import Fcore_FLX. -Require Import Fcore_FLT. -Require Import Fcore_ulp. -Require Import Fcalc_ops. +Require Import Raux Defs Float_prop Generic_fmt. +Require Import FIX FLX FLT Ulp Operations. +Require Import Relative. Section Fprop_plus_error. @@ -44,31 +38,31 @@ Section round_repr_same_exp. Variable rnd : R -> Z. Context { valid_rnd : Valid_rnd rnd }. -Theorem round_repr_same_exp : +Lemma round_repr_same_exp : forall m e, exists m', round beta fexp rnd (F2R (Float beta m e)) = F2R (Float beta m' e). Proof with auto with typeclass_instances. intros m e. -set (e' := canonic_exp beta fexp (F2R (Float beta m e))). +set (e' := cexp beta fexp (F2R (Float beta m e))). unfold round, scaled_mantissa. fold e'. destruct (Zle_or_lt e' e) as [He|He]. exists m. unfold F2R at 2. simpl. rewrite Rmult_assoc, <- bpow_plus. -rewrite <- Z2R_Zpower. 2: omega. -rewrite <- Z2R_mult, Zrnd_Z2R... +rewrite <- IZR_Zpower. 2: omega. +rewrite <- mult_IZR, Zrnd_IZR... unfold F2R. simpl. -rewrite Z2R_mult. +rewrite mult_IZR. rewrite Rmult_assoc. -rewrite Z2R_Zpower. 2: omega. +rewrite IZR_Zpower. 2: omega. rewrite <- bpow_plus. -apply (f_equal (fun v => Z2R m * bpow v)%R). +apply (f_equal (fun v => IZR m * bpow v)%R). ring. -exists ((rnd (Z2R m * bpow (e - e'))) * Zpower beta (e' - e))%Z. +exists ((rnd (IZR m * bpow (e - e'))) * Zpower beta (e' - e))%Z. unfold F2R. simpl. -rewrite Z2R_mult. -rewrite Z2R_Zpower. 2: omega. +rewrite mult_IZR. +rewrite IZR_Zpower. 2: omega. rewrite 2!Rmult_assoc. rewrite <- 2!bpow_plus. apply (f_equal (fun v => _ * bpow v)%R). @@ -84,13 +78,13 @@ Variable choice : Z -> bool. Lemma plus_error_aux : forall x y, - (canonic_exp beta fexp x <= canonic_exp beta fexp y)%Z -> + (cexp beta fexp x <= cexp beta fexp y)%Z -> format x -> format y -> format (round beta fexp (Znearest choice) (x + y) - (x + y))%R. Proof. intros x y. -set (ex := canonic_exp beta fexp x). -set (ey := canonic_exp beta fexp y). +set (ex := cexp beta fexp x). +set (ey := cexp beta fexp y). intros He Hx Hy. destruct (Req_dec (round beta fexp (Znearest choice) (x + y) - (x + y)) R0) as [H0|H0]. rewrite H0. @@ -116,7 +110,7 @@ apply generic_format_F2R. intros _. apply monotone_exp. rewrite <- H, <- Hxy', <- Hxy. -apply ln_beta_le_abs. +apply mag_le_abs. exact H0. pattern x at 3 ; replace x with (-(y - (x + y)))%R by ring. rewrite Rabs_Ropp. @@ -130,7 +124,7 @@ Theorem plus_error : format (round beta fexp (Znearest choice) (x + y) - (x + y))%R. Proof. intros x y Hx Hy. -destruct (Zle_or_lt (canonic_exp beta fexp x) (canonic_exp beta fexp y)). +destruct (Zle_or_lt (cexp beta fexp x) (cexp beta fexp y)). now apply plus_error_aux. rewrite Rplus_comm. apply plus_error_aux ; try easy. @@ -154,20 +148,17 @@ Section round_plus_eq_zero_aux. Variable rnd : R -> Z. Context { valid_rnd : Valid_rnd rnd }. -Lemma round_plus_eq_zero_aux : +Lemma round_plus_neq_0_aux : forall x y, - (canonic_exp beta fexp x <= canonic_exp beta fexp y)%Z -> + (cexp beta fexp x <= cexp beta fexp y)%Z -> format x -> format y -> - (0 <= x + y)%R -> - round beta fexp rnd (x + y) = 0%R -> - (x + y = 0)%R. + (0 < x + y)%R -> + round beta fexp rnd (x + y) <> 0%R. Proof with auto with typeclass_instances. -intros x y He Hx Hy Hp Hxy. -destruct (Req_dec (x + y) 0) as [H0|H0]. -exact H0. -destruct (ln_beta beta (x + y)) as (exy, Hexy). +intros x y He Hx Hy Hxy. +destruct (mag beta (x + y)) as (exy, Hexy). simpl. -specialize (Hexy H0). +specialize (Hexy (Rgt_not_eq _ _ Hxy)). destruct (Zle_or_lt exy (fexp exy)) as [He'|He']. (* . *) assert (H: (x + y)%R = F2R (Float beta (Ztrunc (x * bpow (- fexp exy)) + @@ -175,19 +166,21 @@ assert (H: (x + y)%R = F2R (Float beta (Ztrunc (x * bpow (- fexp exy)) + rewrite (subnormal_exponent beta fexp exy x He' Hx) at 1. rewrite (subnormal_exponent beta fexp exy y He' Hy) at 1. now rewrite <- F2R_plus, Fplus_same_exp. -rewrite H in Hxy. -rewrite round_generic in Hxy... -now rewrite <- H in Hxy. +rewrite H. +rewrite round_generic... +rewrite <- H. +now apply Rgt_not_eq. apply generic_format_F2R. intros _. rewrite <- H. -unfold canonic_exp. -rewrite ln_beta_unique with (1 := Hexy). -apply Zle_refl. +unfold cexp. +rewrite mag_unique with (1 := Hexy). +apply Z.le_refl. (* . *) +intros H. elim Rle_not_lt with (1 := round_le beta _ rnd _ _ (proj1 Hexy)). -rewrite (Rabs_pos_eq _ Hp). -rewrite Hxy. +rewrite (Rabs_pos_eq _ (Rlt_le _ _ Hxy)). +rewrite H. rewrite round_generic... apply bpow_gt_0. apply generic_format_bpow. @@ -201,40 +194,46 @@ Variable rnd : R -> Z. Context { valid_rnd : Valid_rnd rnd }. (** rnd(x+y)=0 -> x+y = 0 provided this is not a FTZ format *) -Theorem round_plus_eq_zero : +Theorem round_plus_neq_0 : forall x y, format x -> format y -> - round beta fexp rnd (x + y) = 0%R -> - (x + y = 0)%R. + (x + y <> 0)%R -> + round beta fexp rnd (x + y) <> 0%R. Proof with auto with typeclass_instances. -intros x y Hx Hy. +intros x y Hx Hy Hxy. destruct (Rle_or_lt 0 (x + y)) as [H1|H1]. (* . *) -revert H1. -destruct (Zle_or_lt (canonic_exp beta fexp x) (canonic_exp beta fexp y)) as [H2|H2]. -now apply round_plus_eq_zero_aux. +destruct (Zle_or_lt (cexp beta fexp x) (cexp beta fexp y)) as [H2|H2]. +apply round_plus_neq_0_aux... +lra. rewrite Rplus_comm. -apply round_plus_eq_zero_aux ; try easy. +apply round_plus_neq_0_aux ; try easy. now apply Zlt_le_weak. +lra. (* . *) -revert H1. -rewrite <- (Ropp_involutive (x + y)), Ropp_plus_distr, <- Ropp_0. -intros H1. +rewrite <- (Ropp_involutive (x + y)), Ropp_plus_distr. rewrite round_opp. -intros Hxy. -apply f_equal. -cut (round beta fexp (Zrnd_opp rnd) (- x + - y) = 0)%R. -cut (0 <= -x + -y)%R. -destruct (Zle_or_lt (canonic_exp beta fexp (-x)) (canonic_exp beta fexp (-y))) as [H2|H2]. -apply round_plus_eq_zero_aux ; try apply generic_format_opp... +apply Ropp_neq_0_compat. +destruct (Zle_or_lt (cexp beta fexp (-x)) (cexp beta fexp (-y))) as [H2|H2]. +apply round_plus_neq_0_aux; try apply generic_format_opp... +lra. rewrite Rplus_comm. -apply round_plus_eq_zero_aux ; try apply generic_format_opp... +apply round_plus_neq_0_aux; try apply generic_format_opp... now apply Zlt_le_weak. -apply Rlt_le. -now apply Ropp_lt_cancel. -rewrite <- (Ropp_involutive (round _ _ _ _)). -rewrite Hxy. -apply Ropp_involutive. +lra. +Qed. + +Theorem round_plus_eq_0 : + forall x y, + format x -> format y -> + round beta fexp rnd (x + y) = 0%R -> + (x + y = 0)%R. +Proof with auto with typeclass_instances. +intros x y Fx Fy H. +destruct (Req_dec (x + y) 0) as [H'|H']. +exact H'. +contradict H. +now apply round_plus_neq_0. Qed. End Fprop_plus_zero. @@ -258,14 +257,48 @@ apply generic_format_FLT_FIX... rewrite Zplus_comm; assumption. apply generic_format_FIX_FLT, FIX_format_generic in Fx. apply generic_format_FIX_FLT, FIX_format_generic in Fy. -destruct Fx as (nx,(H1x,H2x)). -destruct Fy as (ny,(H1y,H2y)). +destruct Fx as [nx H1x H2x]. +destruct Fy as [ny H1y H2y]. apply generic_format_FIX. exists (Float beta (Fnum nx+Fnum ny)%Z emin). -split;[idtac|reflexivity]. rewrite H1x,H1y; unfold F2R; simpl. rewrite H2x, H2y. -rewrite Z2R_plus; ring. +rewrite plus_IZR; ring. +easy. +Qed. + +Variable choice : Z -> bool. + +Lemma FLT_plus_error_N_ex : forall x y, + generic_format beta (FLT_exp emin prec) x -> + generic_format beta (FLT_exp emin prec) y -> + exists eps, + (Rabs eps <= u_ro beta prec / (1 + u_ro beta prec))%R /\ + round beta (FLT_exp emin prec) (Znearest choice) (x + y) + = ((x + y) * (1 + eps))%R. +Proof. +intros x y Fx Fy. +assert (Pb := u_rod1pu_ro_pos beta prec). +destruct (Rle_or_lt (bpow (emin + prec - 1)) (Rabs (x + y))) as [M|M]. +{ destruct (relative_error_N_FLX'_ex beta prec prec_gt_0_ choice (x + y)) + as (d, (Bd, Hd)). + now exists d; split; [exact Bd|]; rewrite <- Hd; apply round_FLT_FLX. } +exists 0%R; rewrite Rabs_R0; split; [exact Pb|]; rewrite Rplus_0_r, Rmult_1_r. +apply round_generic; [apply valid_rnd_N|]. +apply FLT_format_plus_small; [exact Fx|exact Fy|]. +apply Rlt_le, (Rlt_le_trans _ _ _ M), bpow_le; lia. +Qed. + +Lemma FLT_plus_error_N_round_ex : forall x y, + generic_format beta (FLT_exp emin prec) x -> + generic_format beta (FLT_exp emin prec) y -> + exists eps, + (Rabs eps <= u_ro beta prec)%R /\ + (x + y + = round beta (FLT_exp emin prec) (Znearest choice) (x + y) * (1 + eps))%R. +Proof. +intros x y Fx Fy. +now apply relative_error_N_round_ex_derive, FLT_plus_error_N_ex. Qed. End Fprop_plus_FLT. @@ -282,62 +315,58 @@ Variable rnd : R -> Z. Context { valid_rnd : Valid_rnd rnd }. Notation format := (generic_format beta fexp). -Notation cexp := (canonic_exp beta fexp). +Notation cexp := (cexp beta fexp). Lemma ex_shift : forall x e, format x -> (e <= cexp x)%Z -> - exists m, (x = Z2R m * bpow e)%R. + exists m, (x = IZR m * bpow e)%R. Proof with auto with typeclass_instances. intros x e Fx He. exists (Ztrunc (scaled_mantissa beta fexp x)*Zpower beta (cexp x -e))%Z. rewrite Fx at 1; unfold F2R; simpl. -rewrite Z2R_mult, Rmult_assoc. +rewrite mult_IZR, Rmult_assoc. f_equal. -rewrite Z2R_Zpower. +rewrite IZR_Zpower. 2: omega. rewrite <- bpow_plus; f_equal; ring. Qed. -Lemma ln_beta_minus1 : +Lemma mag_minus1 : forall z, z <> 0%R -> - (ln_beta beta z - 1)%Z = ln_beta beta (z / Z2R beta). + (mag beta z - 1)%Z = mag beta (z / IZR beta). Proof. intros z Hz. unfold Zminus. -rewrite <- ln_beta_mult_bpow with (1 := Hz). +rewrite <- mag_mult_bpow by easy. now rewrite bpow_opp, bpow_1. Qed. -Theorem round_plus_mult_ulp : +Theorem round_plus_F2R : forall x y, format x -> format y -> (x <> 0)%R -> - exists m, (round beta fexp rnd (x+y) = Z2R m * ulp beta fexp (x/Z2R beta))%R. + exists m, + round beta fexp rnd (x+y) = F2R (Float beta m (cexp (x / IZR beta))). Proof with auto with typeclass_instances. intros x y Fx Fy Zx. -case (Zle_or_lt (ln_beta beta (x/Z2R beta)) (ln_beta beta y)); intros H1. -pose (e:=cexp (x / Z2R beta)). +case (Zle_or_lt (mag beta (x/IZR beta)) (mag beta y)); intros H1. +pose (e:=cexp (x / IZR beta)). destruct (ex_shift x e) as (nx, Hnx); try exact Fx. apply monotone_exp. -rewrite <- (ln_beta_minus1 x Zx); omega. +rewrite <- (mag_minus1 x Zx); omega. destruct (ex_shift y e) as (ny, Hny); try assumption. apply monotone_exp... destruct (round_repr_same_exp beta fexp rnd (nx+ny) e) as (n,Hn). exists n. -apply trans_eq with (F2R (Float beta n e)). +fold e. rewrite <- Hn; f_equal. -rewrite Hnx, Hny; unfold F2R; simpl; rewrite Z2R_plus; ring. +rewrite Hnx, Hny; unfold F2R; simpl; rewrite plus_IZR; ring. unfold F2R; simpl. -rewrite ulp_neq_0; try easy. -apply Rmult_integral_contrapositive_currified; try assumption. -apply Rinv_neq_0_compat. -apply Rgt_not_eq. -apply radix_pos. (* *) -destruct (ex_shift (round beta fexp rnd (x + y)) (cexp (x/Z2R beta))) as (n,Hn). +destruct (ex_shift (round beta fexp rnd (x + y)) (cexp (x/IZR beta))) as (n,Hn). apply generic_format_round... -apply Zle_trans with (cexp (x+y)). +apply Z.le_trans with (cexp (x+y)). apply monotone_exp. -rewrite <- ln_beta_minus1 by easy. -rewrite <- (ln_beta_abs beta (x+y)). +rewrite <- mag_minus1 by easy. +rewrite <- (mag_abs beta (x+y)). (* . *) assert (U: (Rabs (x+y) = Rabs x + Rabs y)%R \/ (y <> 0 /\ Rabs (x+y) = Rabs x - Rabs y)%R). assert (V: forall x y, (Rabs y <= Rabs x)%R -> @@ -374,94 +403,89 @@ rewrite Rabs_left1. ring. lra. apply V; left. -apply ln_beta_lt_pos with beta. +apply lt_mag with beta. now apply Rabs_pos_lt. -rewrite <- ln_beta_minus1 in H1; try assumption. -rewrite 2!ln_beta_abs; omega. +rewrite <- mag_minus1 in H1; try assumption. +rewrite 2!mag_abs; omega. (* . *) destruct U as [U|U]. -rewrite U; apply Zle_trans with (ln_beta beta x). +rewrite U; apply Z.le_trans with (mag beta x). omega. -rewrite <- ln_beta_abs. -apply ln_beta_le. +rewrite <- mag_abs. +apply mag_le. now apply Rabs_pos_lt. apply Rplus_le_reg_l with (-Rabs x)%R; ring_simplify. apply Rabs_pos. destruct U as (U',U); rewrite U. -rewrite <- ln_beta_abs. -apply ln_beta_minus_lb. +rewrite <- mag_abs. +apply mag_minus_lb. now apply Rabs_pos_lt. now apply Rabs_pos_lt. -rewrite 2!ln_beta_abs. -assert (ln_beta beta y < ln_beta beta x - 1)%Z. -now rewrite (ln_beta_minus1 x Zx). +rewrite 2!mag_abs. +assert (mag beta y < mag beta x - 1)%Z. +now rewrite (mag_minus1 x Zx). omega. -apply canonic_exp_round_ge... -intros K. -apply round_plus_eq_zero in K... +apply cexp_round_ge... +apply round_plus_neq_0... contradict H1; apply Zle_not_lt. -rewrite <- (ln_beta_minus1 x Zx). +rewrite <- (mag_minus1 x Zx). replace y with (-x)%R. -rewrite ln_beta_opp; omega. +rewrite mag_opp; omega. lra. -exists n. -rewrite ulp_neq_0. -assumption. -apply Rmult_integral_contrapositive_currified; try assumption. -apply Rinv_neq_0_compat. -apply Rgt_not_eq. -apply radix_pos. +now exists n. Qed. Context {exp_not_FTZ : Exp_not_FTZ fexp}. Theorem round_plus_ge_ulp : forall x y, format x -> format y -> - round beta fexp rnd (x+y) = 0%R \/ - (ulp beta fexp (x/Z2R beta) <= Rabs (round beta fexp rnd (x+y)))%R. + round beta fexp rnd (x+y) <> 0%R -> + (ulp beta fexp (x/IZR beta) <= Rabs (round beta fexp rnd (x+y)))%R. Proof with auto with typeclass_instances. -intros x y Fx Fy. +intros x y Fx Fy KK. case (Req_dec x 0); intros Zx. (* *) rewrite Zx, Rplus_0_l. rewrite round_generic... unfold Rdiv; rewrite Rmult_0_l. -rewrite Fy at 2. +rewrite Fy. unfold F2R; simpl; rewrite Rabs_mult. rewrite (Rabs_pos_eq (bpow _)) by apply bpow_ge_0. case (Z.eq_dec (Ztrunc (scaled_mantissa beta fexp y)) 0); intros Hm. -left. -rewrite Fy, Hm; unfold F2R; simpl; ring. -right. +contradict KK. +rewrite Zx, Fy, Hm; unfold F2R; simpl. +rewrite Rplus_0_l, Rmult_0_l. +apply round_0... apply Rle_trans with (1*bpow (cexp y))%R. rewrite Rmult_1_l. rewrite <- ulp_neq_0. apply ulp_ge_ulp_0... intros K; apply Hm. rewrite K, scaled_mantissa_0. -apply (Ztrunc_Z2R 0). +apply Ztrunc_IZR. apply Rmult_le_compat_r. apply bpow_ge_0. -rewrite <- Z2R_abs. -apply (Z2R_le 1). +rewrite <- abs_IZR. +apply IZR_le. apply (Zlt_le_succ 0). now apply Z.abs_pos. (* *) -destruct (round_plus_mult_ulp x y Fx Fy Zx) as (m,Hm). +destruct (round_plus_F2R x y Fx Fy Zx) as (m,Hm). case (Z.eq_dec m 0); intros Zm. -left. -rewrite Hm, Zm; simpl; ring. -right. -rewrite Hm, Rabs_mult. -rewrite (Rabs_pos_eq (ulp _ _ _)) by apply ulp_ge_0. -apply Rle_trans with (1*ulp beta fexp (x/Z2R beta))%R. -right; ring. +contradict KK. +rewrite Hm, Zm. +apply F2R_0. +rewrite Hm, <- F2R_Zabs. +rewrite ulp_neq_0. +rewrite <- (Rmult_1_l (bpow _)). apply Rmult_le_compat_r. -apply ulp_ge_0. -rewrite <- Z2R_abs. -apply (Z2R_le 1). +apply bpow_ge_0. +apply IZR_le. apply (Zlt_le_succ 0). now apply Z.abs_pos. +apply Rmult_integral_contrapositive_currified with (1 := Zx). +apply Rinv_neq_0_compat. +apply Rgt_not_eq, radix_pos. Qed. End Fprop_plus_mult_ulp. @@ -476,27 +500,27 @@ Context { valid_rnd : Valid_rnd rnd }. Variable emin prec : Z. Context { prec_gt_0_ : Prec_gt_0 prec }. -Theorem round_plus_ge_ulp_FLT : forall x y e, +Theorem round_FLT_plus_ge : + forall x y e, generic_format beta (FLT_exp emin prec) x -> generic_format beta (FLT_exp emin prec) y -> - (bpow e <= Rabs x)%R -> - round beta (FLT_exp emin prec) rnd (x+y) = 0%R \/ - (bpow (e - prec) <= Rabs (round beta (FLT_exp emin prec) rnd (x+y)))%R. + (bpow (e + prec) <= Rabs x)%R -> + round beta (FLT_exp emin prec) rnd (x + y) <> 0%R -> + (bpow e <= Rabs (round beta (FLT_exp emin prec) rnd (x + y)))%R. Proof with auto with typeclass_instances. -intros x y e Fx Fy He. +intros x y e Fx Fy He KK. assert (Zx: x <> 0%R). contradict He. apply Rlt_not_le; rewrite He, Rabs_R0. apply bpow_gt_0. -case round_plus_ge_ulp with beta (FLT_exp emin prec) rnd x y... -intros H; right. -apply Rle_trans with (2:=H). +apply Rle_trans with (ulp beta (FLT_exp emin prec) (x/IZR beta)). +2: apply round_plus_ge_ulp... rewrite ulp_neq_0. -unfold canonic_exp. -rewrite <- ln_beta_minus1 by easy. +unfold cexp. +rewrite <- mag_minus1; try assumption. unfold FLT_exp; apply bpow_le. -apply Zle_trans with (2:=Z.le_max_l _ _). -destruct (ln_beta beta x) as (n,Hn); simpl. -assert (e < n)%Z; try omega. +apply Z.le_trans with (2:=Z.le_max_l _ _). +destruct (mag beta x) as (n,Hn); simpl. +assert (e + prec < n)%Z; try omega. apply lt_bpow with beta. apply Rle_lt_trans with (1:=He). now apply Hn. @@ -506,26 +530,45 @@ apply Rgt_not_eq. apply radix_pos. Qed. -Theorem round_plus_ge_ulp_FLX : forall x y e, +Lemma round_FLT_plus_ge' : + forall x y e, + generic_format beta (FLT_exp emin prec) x -> generic_format beta (FLT_exp emin prec) y -> + (x <> 0%R -> (bpow (e+prec) <= Rabs x)%R) -> + (x = 0%R -> y <> 0%R -> (bpow e <= Rabs y)%R) -> + round beta (FLT_exp emin prec) rnd (x+y) <> 0%R -> + (bpow e <= Rabs (round beta (FLT_exp emin prec) rnd (x+y)))%R. +Proof with auto with typeclass_instances. +intros x y e Fx Fy H1 H2 H3. +case (Req_dec x 0); intros H4. +case (Req_dec y 0); intros H5. +contradict H3. +rewrite H4, H5, Rplus_0_l; apply round_0... +rewrite H4, Rplus_0_l. +rewrite round_generic... +apply round_FLT_plus_ge; try easy. +now apply H1. +Qed. + +Theorem round_FLX_plus_ge : + forall x y e, generic_format beta (FLX_exp prec) x -> generic_format beta (FLX_exp prec) y -> - (bpow e <= Rabs x)%R -> - round beta (FLX_exp prec) rnd (x+y) = 0%R \/ - (bpow (e - prec) <= Rabs (round beta (FLX_exp prec) rnd (x+y)))%R. + (bpow (e+prec) <= Rabs x)%R -> + (round beta (FLX_exp prec) rnd (x+y) <> 0)%R -> + (bpow e <= Rabs (round beta (FLX_exp prec) rnd (x+y)))%R. Proof with auto with typeclass_instances. -intros x y e Fx Fy He. +intros x y e Fx Fy He KK. assert (Zx: x <> 0%R). contradict He. apply Rlt_not_le; rewrite He, Rabs_R0. apply bpow_gt_0. -case round_plus_ge_ulp with beta (FLX_exp prec) rnd x y... -intros H; right. -apply Rle_trans with (2:=H). +apply Rle_trans with (ulp beta (FLX_exp prec) (x/IZR beta)). +2: apply round_plus_ge_ulp... rewrite ulp_neq_0. -unfold canonic_exp. -rewrite <- ln_beta_minus1 by easy. +unfold cexp. +rewrite <- mag_minus1 by easy. unfold FLX_exp; apply bpow_le. -destruct (ln_beta beta x) as (n,Hn); simpl. -assert (e < n)%Z; try omega. +destruct (mag beta x) as (n,Hn); simpl. +assert (e + prec < n)%Z; try omega. apply lt_bpow with beta. apply Rle_lt_trans with (1:=He). now apply Hn. @@ -536,3 +579,28 @@ apply radix_pos. Qed. End Fprop_plus_ge_ulp. + +Section Fprop_plus_le_ops. + +Variable beta : radix. +Variable fexp : Z -> Z. +Context { valid_exp : Valid_exp fexp }. +Variable choice : Z -> bool. + +Lemma plus_error_le_l : + forall x y, + generic_format beta fexp x -> generic_format beta fexp y -> + (Rabs (round beta fexp (Znearest choice) (x + y) - (x + y)) <= Rabs x)%R. +Proof. +intros x y Fx Fy. +apply (Rle_trans _ (Rabs (y - (x + y)))); [now apply round_N_pt|]. +rewrite Rabs_minus_sym; right; f_equal; ring. +Qed. + +Lemma plus_error_le_r : + forall x y, + generic_format beta fexp x -> generic_format beta fexp y -> + (Rabs (round beta fexp (Znearest choice) (x + y) - (x + y)) <= Rabs y)%R. +Proof. now intros x y Fx Fy; rewrite Rplus_comm; apply plus_error_le_l. Qed. + +End Fprop_plus_le_ops. diff --git a/flocq/Prop/Fprop_relative.v b/flocq/Prop/Relative.v index 276ccd3b..5f87bd84 100644 --- a/flocq/Prop/Fprop_relative.v +++ b/flocq/Prop/Relative.v @@ -2,9 +2,9 @@ This file is part of the Flocq formalization of floating-point arithmetic in Coq: http://flocq.gforge.inria.fr/ -Copyright (C) 2010-2013 Sylvie Boldo +Copyright (C) 2010-2018 Sylvie Boldo #<br /># -Copyright (C) 2010-2013 Guillaume Melquiond +Copyright (C) 2010-2018 Guillaume Melquiond This library is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public @@ -18,7 +18,8 @@ COPYING file for more details. *) (** * Relative error of the roundings *) -Require Import Fcore. +Require Import Core. +Require Import Psatz. (* for lra *) Section Fprop_relative. @@ -88,6 +89,32 @@ rewrite Rinv_l with (1 := Hx0). now rewrite Rabs_R1, Rmult_1_r. Qed. +Lemma relative_error_le_conversion_inv : + forall x b, + (exists eps, + (Rabs eps <= b)%R /\ round beta fexp rnd x = (x * (1 + eps))%R) -> + (Rabs (round beta fexp rnd x - x) <= b * Rabs x)%R. +Proof with auto with typeclass_instances. +intros x b (eps, (Beps, Heps)). +assert (Pb : (0 <= b)%R); [now revert Beps; apply Rle_trans, Rabs_pos|]. +rewrite Heps; replace (_ - _)%R with (eps * x)%R; [|ring]. +now rewrite Rabs_mult; apply Rmult_le_compat_r; [apply Rabs_pos|]. +Qed. + +Lemma relative_error_le_conversion_round_inv : + forall x b, + (exists eps, + (Rabs eps <= b)%R /\ x = (round beta fexp rnd x * (1 + eps))%R) -> + (Rabs (round beta fexp rnd x - x) <= b * Rabs (round beta fexp rnd x))%R. +Proof with auto with typeclass_instances. +intros x b. +set (rx := round _ _ _ _). +intros (eps, (Beps, Heps)). +assert (Pb : (0 <= b)%R); [now revert Beps; apply Rle_trans, Rabs_pos|]. +rewrite Heps; replace (_ - _)%R with (- (eps * rx))%R; [|ring]. +now rewrite Rabs_Ropp, Rabs_mult; apply Rmult_le_compat_r; [apply Rabs_pos|]. +Qed. + End relative_error_conversion. Variable emin p : Z. @@ -108,8 +135,8 @@ apply Rlt_not_le, bpow_gt_0. apply Rlt_le_trans with (ulp beta fexp x)%R. now apply error_lt_ulp... rewrite ulp_neq_0; trivial. -unfold canonic_exp. -destruct (ln_beta beta x) as (ex, He). +unfold cexp. +destruct (mag beta x) as (ex, He). simpl. specialize (He Hx'). apply Rle_trans with (bpow (-p + 1) * bpow (ex - 1))%R. @@ -150,7 +177,7 @@ apply relative_error. unfold x. rewrite <- F2R_Zabs. apply bpow_le_F2R. -apply F2R_lt_reg with beta emin. +apply lt_F2R with beta emin. rewrite F2R_0, F2R_Zabs. now apply Rabs_pos_lt. Qed. @@ -179,8 +206,8 @@ apply Rlt_not_le, bpow_gt_0. apply Rlt_le_trans with (ulp beta fexp x)%R. now apply error_lt_ulp. rewrite ulp_neq_0; trivial. -unfold canonic_exp. -destruct (ln_beta beta x) as (ex, He). +unfold cexp. +destruct (mag beta x) as (ex, He). simpl. specialize (He Hx'). assert (He': (emin < ex)%Z). @@ -218,7 +245,7 @@ exact Hp. unfold x. rewrite <- F2R_Zabs. apply bpow_le_F2R. -apply F2R_lt_reg with beta emin. +apply lt_F2R with beta emin. rewrite F2R_0, F2R_Zabs. now apply Rabs_pos_lt. Qed. @@ -237,15 +264,15 @@ rewrite Rmult_assoc. apply Rmult_le_compat_l. apply Rlt_le. apply Rinv_0_lt_compat. -now apply (Z2R_lt 0 2). +now apply IZR_lt. assert (Hx': (x <> 0)%R). intros H. apply Rlt_not_le with (2 := Hx). rewrite H, Rabs_R0. apply bpow_gt_0. rewrite ulp_neq_0; trivial. -unfold canonic_exp. -destruct (ln_beta beta x) as (ex, He). +unfold cexp. +destruct (mag beta x) as (ex, He). simpl. specialize (He Hx'). apply Rle_trans with (bpow (-p + 1) * bpow (ex - 1))%R. @@ -274,7 +301,7 @@ apply relative_error_le_conversion... apply Rlt_le. apply Rmult_lt_0_compat. apply Rinv_0_lt_compat. -now apply (Z2R_lt 0 2). +now apply IZR_lt. apply bpow_gt_0. now apply relative_error_N. Qed. @@ -296,7 +323,7 @@ apply relative_error_N. unfold x. rewrite <- F2R_Zabs. apply bpow_le_F2R. -apply F2R_lt_reg with beta emin. +apply lt_F2R with beta emin. rewrite F2R_0, F2R_Zabs. now apply Rabs_pos_lt. Qed. @@ -311,7 +338,7 @@ apply relative_error_le_conversion... apply Rlt_le. apply Rmult_lt_0_compat. apply Rinv_0_lt_compat. -now apply (Z2R_lt 0 2). +now apply IZR_lt. apply bpow_gt_0. now apply relative_error_N_F2R_emin. Qed. @@ -329,15 +356,15 @@ rewrite Rmult_assoc. apply Rmult_le_compat_l. apply Rlt_le. apply Rinv_0_lt_compat. -now apply (Z2R_lt 0 2). +now apply IZR_lt. assert (Hx': (x <> 0)%R). intros H. apply Rlt_not_le with (2 := Hx). rewrite H, Rabs_R0. apply bpow_gt_0. rewrite ulp_neq_0; trivial. -unfold canonic_exp. -destruct (ln_beta beta x) as (ex, He). +unfold cexp. +destruct (mag beta x) as (ex, He). simpl. specialize (He Hx'). assert (He': (emin < ex)%Z). @@ -381,17 +408,250 @@ apply relative_error_N_round with (1 := Hp). unfold x. rewrite <- F2R_Zabs. apply bpow_le_F2R. -apply F2R_lt_reg with beta emin. +apply lt_F2R with beta emin. rewrite F2R_0, F2R_Zabs. now apply Rabs_pos_lt. Qed. End Fprop_relative_generic. +Section Fprop_relative_FLX. + +Variable prec : Z. +Variable Hp : Z.lt 0 prec. + +Lemma relative_error_FLX_aux : + forall k, (prec <= k - FLX_exp prec k)%Z. +Proof. +intros k. +unfold FLX_exp. +omega. +Qed. + +Variable rnd : R -> Z. +Context { valid_rnd : Valid_rnd rnd }. + +Theorem relative_error_FLX : + forall x, + (x <> 0)%R -> + (Rabs (round beta (FLX_exp prec) rnd x - x) < bpow (-prec + 1) * Rabs x)%R. +Proof with auto with typeclass_instances. +intros x Hx. +destruct (mag beta x) as (ex, He). +specialize (He Hx). +apply relative_error with (ex - 1)%Z... +intros k _. +apply relative_error_FLX_aux. +apply He. +Qed. + +(** 1+#ε# property in any rounding in FLX *) +Theorem relative_error_FLX_ex : + forall x, + exists eps, + (Rabs eps < bpow (-prec + 1))%R /\ round beta (FLX_exp prec) rnd x = (x * (1 + eps))%R. +Proof with auto with typeclass_instances. +intros x. +apply relative_error_lt_conversion... +apply bpow_gt_0. +now apply relative_error_FLX. +Qed. + +Theorem relative_error_FLX_round : + forall x, + (x <> 0)%R -> + (Rabs (round beta (FLX_exp prec) rnd x - x) < bpow (-prec + 1) * Rabs (round beta (FLX_exp prec) rnd x))%R. +Proof with auto with typeclass_instances. +intros x Hx. +destruct (mag beta x) as (ex, He). +specialize (He Hx). +apply relative_error_round with (ex - 1)%Z... +intros k _. +apply relative_error_FLX_aux. +apply He. +Qed. + +Variable choice : Z -> bool. + +Theorem relative_error_N_FLX : + forall x, + (Rabs (round beta (FLX_exp prec) (Znearest choice) x - x) <= /2 * bpow (-prec + 1) * Rabs x)%R. +Proof with auto with typeclass_instances. +intros x. +destruct (Req_dec x 0) as [Hx|Hx]. +(* . *) +rewrite Hx, round_0... +unfold Rminus. +rewrite Rplus_0_l, Rabs_Ropp, Rabs_R0. +rewrite Rmult_0_r. +apply Rle_refl. +(* . *) +destruct (mag beta x) as (ex, He). +specialize (He Hx). +apply relative_error_N with (ex - 1)%Z... +intros k _. +apply relative_error_FLX_aux. +apply He. +Qed. + +(** unit roundoff *) +Definition u_ro := (/2 * bpow (-prec + 1))%R. + +Lemma u_ro_pos : (0 <= u_ro)%R. +Proof. apply Rmult_le_pos; [lra|apply bpow_ge_0]. Qed. + +Lemma u_ro_lt_1 : (u_ro < 1)%R. +Proof. +unfold u_ro; apply (Rmult_lt_reg_l 2); [lra|]. +rewrite <-Rmult_assoc, Rinv_r, Rmult_1_l, Rmult_1_r; [|lra]. +apply (Rle_lt_trans _ (bpow 0)); + [apply bpow_le; omega|simpl; lra]. +Qed. + +Lemma u_rod1pu_ro_pos : (0 <= u_ro / (1 + u_ro))%R. +Proof. +apply Rmult_le_pos; [|apply Rlt_le, Rinv_0_lt_compat]; +assert (H := u_ro_pos); lra. +Qed. + +Lemma u_rod1pu_ro_le_u_ro : (u_ro / (1 + u_ro) <= u_ro)%R. +Proof. +assert (Pu_ro := u_ro_pos). +apply (Rmult_le_reg_r (1 + u_ro)); [lra|]. +unfold Rdiv; rewrite Rmult_assoc, Rinv_l; [|lra]. +assert (0 <= u_ro * u_ro)%R; [apply Rmult_le_pos|]; lra. +Qed. + +Theorem relative_error_N_FLX' : + forall x, + (Rabs (round beta (FLX_exp prec) (Znearest choice) x - x) + <= u_ro / (1 + u_ro) * Rabs x)%R. +Proof with auto with typeclass_instances. +intro x. +assert (Pu_ro : (0 <= u_ro)%R). +{ apply Rmult_le_pos; [lra|apply bpow_ge_0]. } +destruct (Req_dec x 0) as [Zx|Nzx]. +{ rewrite Zx, Rabs_R0, Rmult_0_r, round_0... + now unfold Rminus; rewrite Rplus_0_l, Rabs_Ropp, Rabs_R0; right. } +set (ufpx := bpow (mag beta x - 1)%Z). +set (rx := round _ _ _ _). +assert (Pufpx : (0 <= ufpx)%R); [now apply bpow_ge_0|]. +assert (H_2_1 : (Rabs (rx - x) <= u_ro * ufpx)%R). +{ refine (Rle_trans _ _ _ (error_le_half_ulp _ _ _ _) _); + [now apply FLX_exp_valid|right]. + unfold ulp, cexp, FLX_exp, u_ro, ufpx; rewrite (Req_bool_false _ _ Nzx). + rewrite Rmult_assoc, <-bpow_plus; do 2 f_equal; ring. } +assert (H_2_3 : (ufpx + Rabs (rx - x) <= Rabs x)%R). +{ apply (Rplus_le_reg_r (- ufpx)); ring_simplify. + destruct (Rle_or_lt 0 x) as [Sx|Sx]. + { apply (Rle_trans _ (Rabs (ufpx - x))). + { apply round_N_pt; [now apply FLX_exp_valid|]. + apply generic_format_bpow; unfold FLX_exp; lia. } + rewrite Rabs_minus_sym, Rabs_pos_eq. + { now rewrite Rabs_pos_eq; [right; ring|]. } + apply (Rplus_le_reg_r ufpx); ring_simplify. + now rewrite <-(Rabs_pos_eq _ Sx); apply bpow_mag_le. } + apply (Rle_trans _ (Rabs (- ufpx - x))). + { apply round_N_pt; [now apply FLX_exp_valid|]. + apply generic_format_opp, generic_format_bpow; unfold FLX_exp; lia. } + rewrite Rabs_pos_eq; [now rewrite Rabs_left; [right|]|]. + apply (Rplus_le_reg_r x); ring_simplify. + rewrite <-(Ropp_involutive x); apply Ropp_le_contravar; unfold ufpx. + rewrite <-mag_opp, <-Rabs_pos_eq; [apply bpow_mag_le|]; lra. } +assert (H : (Rabs ((rx - x) / x) <= u_ro / (1 + u_ro))%R). +{ assert (H : (0 < ufpx + Rabs (rx - x))%R). + { apply Rplus_lt_le_0_compat; [apply bpow_gt_0|apply Rabs_pos]. } + apply (Rle_trans _ (Rabs (rx - x) / (ufpx + Rabs (rx - x)))). + { unfold Rdiv; rewrite Rabs_mult; apply Rmult_le_compat_l; [apply Rabs_pos|]. + now rewrite (Rabs_Rinv _ Nzx); apply Rinv_le. } + apply (Rmult_le_reg_r ((ufpx + Rabs (rx - x)) * (1 + u_ro))). + { apply Rmult_lt_0_compat; lra. } + field_simplify; [try unfold Rdiv; rewrite ?Rinv_1, ?Rmult_1_r| |]; lra. } +revert H; unfold Rdiv; rewrite Rabs_mult, (Rabs_Rinv _ Nzx); intro H. +apply (Rmult_le_reg_r (/ Rabs x)); [now apply Rinv_0_lt_compat, Rabs_pos_lt|]. +now apply (Rle_trans _ _ _ H); right; field; split; [apply Rabs_no_R0|lra]. +Qed. + +(** 1+#ε# property in rounding to nearest in FLX *) +Theorem relative_error_N_FLX_ex : + forall x, + exists eps, + (Rabs eps <= /2 * bpow (-prec + 1))%R /\ round beta (FLX_exp prec) (Znearest choice) x = (x * (1 + eps))%R. +Proof with auto with typeclass_instances. +intros x. +apply relative_error_le_conversion... +apply Rlt_le. +apply Rmult_lt_0_compat. +apply Rinv_0_lt_compat. +now apply IZR_lt. +apply bpow_gt_0. +now apply relative_error_N_FLX. +Qed. + +Theorem relative_error_N_FLX'_ex : + forall x, + exists eps, + (Rabs eps <= u_ro / (1 + u_ro))%R /\ + round beta (FLX_exp prec) (Znearest choice) x = (x * (1 + eps))%R. +Proof with auto with typeclass_instances. +intros x. +apply relative_error_le_conversion... +{ apply u_rod1pu_ro_pos. } +now apply relative_error_N_FLX'. +Qed. + +Lemma relative_error_N_round_ex_derive : + forall x rx, + (exists eps, (Rabs eps <= u_ro / (1 + u_ro))%R /\ rx = (x * (1 + eps))%R) -> + exists eps, (Rabs eps <= u_ro)%R /\ x = (rx * (1 + eps))%R. +Proof. +intros x rx (d, (Bd, Hd)). +assert (Pu_ro := u_ro_pos). +assert (H := Rabs_le_inv _ _ Bd). +assert (H' := u_rod1pu_ro_le_u_ro); assert (H'' := u_ro_lt_1). +destruct (Req_dec rx 0) as [Zfx|Nzfx]. +{ exists 0%R; split; [now rewrite Rabs_R0|]. + rewrite Rplus_0_r, Rmult_1_r, Zfx. + now rewrite Zfx in Hd; destruct (Rmult_integral _ _ (sym_eq Hd)); [|lra]. } +destruct (Req_dec x 0) as [Zx|Nzx]. +{ now exfalso; revert Hd; rewrite Zx, Rmult_0_l. } +set (d' := ((x - rx) / rx)%R). +assert (Hd' : (Rabs d' <= u_ro)%R). +{ unfold d'; rewrite Hd. + replace (_ / _)%R with (- d / (1 + d))%R; [|now field; split; lra]. + unfold Rdiv; rewrite Rabs_mult, Rabs_Ropp. + rewrite (Rabs_pos_eq (/ _)); [|apply Rlt_le, Rinv_0_lt_compat; lra]. + apply (Rmult_le_reg_r (1 + d)); [lra|]. + rewrite Rmult_assoc, Rinv_l, Rmult_1_r; [|lra]. + apply (Rle_trans _ _ _ Bd). + unfold Rdiv; apply Rmult_le_compat_l; [now apply u_ro_pos|]. + apply (Rle_trans _ (1 - u_ro / (1 + u_ro))); [right; field|]; lra. } +now exists d'; split; [|unfold d'; field]. +Qed. + +Theorem relative_error_N_FLX_round_ex : + forall x, + exists eps, + (Rabs eps <= u_ro)%R /\ + x = (round beta (FLX_exp prec) (Znearest choice) x * (1 + eps))%R. +Proof. +intro x; apply relative_error_N_round_ex_derive, relative_error_N_FLX'_ex. +Qed. + +Theorem relative_error_N_FLX_round : + forall x, + (Rabs (round beta (FLX_exp prec) (Znearest choice) x - x) <= /2 * bpow (-prec + 1) * Rabs(round beta (FLX_exp prec) (Znearest choice) x))%R. +Proof. +intro x. +apply relative_error_le_conversion_round_inv, relative_error_N_FLX_round_ex. +Qed. + +End Fprop_relative_FLX. + Section Fprop_relative_FLT. Variable emin prec : Z. -Variable Hp : Zlt 0 prec. +Variable Hp : Z.lt 0 prec. Lemma relative_error_FLT_aux : forall k, (emin + prec - 1 < k)%Z -> (prec <= k - FLT_exp emin prec k)%Z. @@ -486,7 +746,7 @@ apply relative_error_le_conversion... apply Rlt_le. apply Rmult_lt_0_compat. apply Rinv_0_lt_compat. -now apply (Z2R_lt 0 2). +now apply IZR_lt. apply bpow_gt_0. now apply relative_error_N_FLT. Qed. @@ -607,23 +867,84 @@ apply Rlt_le, pos_half_prf. rewrite ulp_neq_0. 2: now apply Rgt_not_eq. apply bpow_le. -unfold FLT_exp, canonic_exp. +unfold FLT_exp, cexp. rewrite Zmax_right. omega. -destruct (ln_beta beta x) as (e,He); simpl. +destruct (mag beta x) as (e,He); simpl. assert (e-1 < emin+prec)%Z. apply (lt_bpow beta). apply Rle_lt_trans with (2:=Hx). -rewrite <- (Rabs_right x). -apply He; auto with real. -apply Rle_ge; now left. +rewrite <- (Rabs_pos_eq x) by now apply Rlt_le. +now apply He, Rgt_not_eq. omega. -split;ring. +split ; ring. +Qed. + +Theorem relative_error_N_FLT'_ex : + forall x, + exists eps eta : R, + (Rabs eps <= u_ro prec / (1 + u_ro prec))%R /\ + (Rabs eta <= /2 * bpow emin)%R /\ + (eps * eta = 0)%R /\ + round beta (FLT_exp emin prec) (Znearest choice) x + = (x * (1 + eps) + eta)%R. +Proof. +intro x. +set (rx := round _ _ _ x). +assert (Pb := u_rod1pu_ro_pos prec). +destruct (Rle_or_lt (bpow (emin + prec - 1)) (Rabs x)) as [MX|Mx]. +{ destruct (relative_error_N_FLX'_ex prec Hp choice x) as (d, (Bd, Hd)). + exists d, 0%R; split; [exact Bd|]; split. + { rewrite Rabs_R0; apply Rmult_le_pos; [lra|apply bpow_ge_0]. } + rewrite Rplus_0_r, Rmult_0_r; split; [reflexivity|]. + now rewrite <- Hd; apply round_FLT_FLX. } +assert (H : (Rabs (rx - x) <= /2 * bpow emin)%R). +{ refine (Rle_trans _ _ _ (error_le_half_ulp _ _ _ _) _); + [now apply FLT_exp_valid|]. + rewrite ulp_FLT_small; [now right|now simpl|]. + apply (Rlt_le_trans _ _ _ Mx), bpow_le; lia. } +exists 0%R, (rx - x)%R; split; [now rewrite Rabs_R0|]; split; [exact H|]. +now rewrite Rmult_0_l, Rplus_0_r, Rmult_1_r; split; [|ring]. +Qed. + +Theorem relative_error_N_FLT'_ex_separate : + forall x, + exists x' : R, + round beta (FLT_exp emin prec) (Znearest choice) x' + = round beta (FLT_exp emin prec) (Znearest choice) x /\ + (exists eta, Rabs eta <= /2 * bpow emin /\ x' = x + eta)%R /\ + (exists eps, Rabs eps <= u_ro prec / (1 + u_ro prec) /\ + round beta (FLT_exp emin prec) (Znearest choice) x' + = x' * (1 + eps))%R. +Proof. +intro x. +set (rx := round _ _ _ x). +destruct (relative_error_N_FLT'_ex x) as (d, (e, (Bd, (Be, (Hde0, Hde))))). +destruct (Rlt_or_le (Rabs (d * x)) (Rabs e)) as [HdxLte|HeLedx]. +{ exists rx; split; [|split]. + { apply round_generic; [now apply valid_rnd_N|]. + now apply generic_format_round; [apply FLT_exp_valid|apply valid_rnd_N]. } + { exists e; split; [exact Be|]. + unfold rx; rewrite Hde; destruct (Rmult_integral _ _ Hde0) as [Zd|Ze]. + { now rewrite Zd, Rplus_0_r, Rmult_1_r. } + exfalso; revert HdxLte; rewrite Ze, Rabs_R0; apply Rle_not_lt, Rabs_pos. } + exists 0%R; split; [now rewrite Rabs_R0; apply u_rod1pu_ro_pos|]. + rewrite Rplus_0_r, Rmult_1_r; apply round_generic; [now apply valid_rnd_N|]. + now apply generic_format_round; [apply FLT_exp_valid|apply valid_rnd_N]. } +exists x; split; [now simpl|split]. +{ exists 0%R; split; + [rewrite Rabs_R0; apply Rmult_le_pos; [lra|apply bpow_ge_0]|ring]. } +exists d; rewrite Hde; destruct (Rmult_integral _ _ Hde0) as [Zd|Ze]. +{ split; [exact Bd|]. + assert (Ze : e = 0%R); [|now rewrite Ze, Rplus_0_r]. + apply Rabs_eq_R0, Rle_antisym; [|now apply Rabs_pos]. + now revert HeLedx; rewrite Zd, Rmult_0_l, Rabs_R0. } +now rewrite Ze, Rplus_0_r. Qed. End Fprop_relative_FLT. -Lemma error_N_FLT : +Theorem error_N_FLT : forall (emin prec : Z), (0 < prec)%Z -> forall (choice : Z -> bool), forall (x : R), @@ -638,9 +959,9 @@ intros emin prec Pprec choice x. destruct (Rtotal_order x 0) as [Nx|[Zx|Px]]. { assert (Pmx : (0 < - x)%R). { now rewrite <- Ropp_0; apply Ropp_lt_contravar. } - destruct (error_N_FLT_aux emin prec Pprec - (fun t : Z => negb (choice (- (t + 1))%Z)) - (- x)%R Pmx) + destruct (@error_N_FLT_aux emin prec Pprec + (fun t : Z => negb (choice (- (t + 1))%Z)) + (- x)%R Pmx) as (d,(e,(Hd,(He,(Hde,Hr))))). exists d; exists (- e)%R; split; [exact Hd|split; [|split]]. { now rewrite Rabs_Ropp. } @@ -659,124 +980,4 @@ destruct (Rtotal_order x 0) as [Nx|[Zx|Px]]. now apply error_N_FLT_aux. Qed. -Section Fprop_relative_FLX. - -Variable prec : Z. -Variable Hp : Zlt 0 prec. - -Lemma relative_error_FLX_aux : - forall k, (prec <= k - FLX_exp prec k)%Z. -Proof. -intros k. -unfold FLX_exp. -omega. -Qed. - -Variable rnd : R -> Z. -Context { valid_rnd : Valid_rnd rnd }. - -Theorem relative_error_FLX : - forall x, - (x <> 0)%R -> - (Rabs (round beta (FLX_exp prec) rnd x - x) < bpow (-prec + 1) * Rabs x)%R. -Proof with auto with typeclass_instances. -intros x Hx. -destruct (ln_beta beta x) as (ex, He). -specialize (He Hx). -apply relative_error with (ex - 1)%Z... -intros k _. -apply relative_error_FLX_aux. -apply He. -Qed. - -(** 1+#ε# property in any rounding in FLX *) -Theorem relative_error_FLX_ex : - forall x, - exists eps, - (Rabs eps < bpow (-prec + 1))%R /\ round beta (FLX_exp prec) rnd x = (x * (1 + eps))%R. -Proof with auto with typeclass_instances. -intros x. -apply relative_error_lt_conversion... -apply bpow_gt_0. -now apply relative_error_FLX. -Qed. - -Theorem relative_error_FLX_round : - forall x, - (x <> 0)%R -> - (Rabs (round beta (FLX_exp prec) rnd x - x) < bpow (-prec + 1) * Rabs (round beta (FLX_exp prec) rnd x))%R. -Proof with auto with typeclass_instances. -intros x Hx. -destruct (ln_beta beta x) as (ex, He). -specialize (He Hx). -apply relative_error_round with (ex - 1)%Z... -intros k _. -apply relative_error_FLX_aux. -apply He. -Qed. - -Variable choice : Z -> bool. - -Theorem relative_error_N_FLX : - forall x, - (Rabs (round beta (FLX_exp prec) (Znearest choice) x - x) <= /2 * bpow (-prec + 1) * Rabs x)%R. -Proof with auto with typeclass_instances. -intros x. -destruct (Req_dec x 0) as [Hx|Hx]. -(* . *) -rewrite Hx, round_0... -unfold Rminus. -rewrite Rplus_0_l, Rabs_Ropp, Rabs_R0. -rewrite Rmult_0_r. -apply Rle_refl. -(* . *) -destruct (ln_beta beta x) as (ex, He). -specialize (He Hx). -apply relative_error_N with (ex - 1)%Z... -intros k _. -apply relative_error_FLX_aux. -apply He. -Qed. - -(** 1+#ε# property in rounding to nearest in FLX *) -Theorem relative_error_N_FLX_ex : - forall x, - exists eps, - (Rabs eps <= /2 * bpow (-prec + 1))%R /\ round beta (FLX_exp prec) (Znearest choice) x = (x * (1 + eps))%R. -Proof with auto with typeclass_instances. -intros x. -apply relative_error_le_conversion... -apply Rlt_le. -apply Rmult_lt_0_compat. -apply Rinv_0_lt_compat. -now apply (Z2R_lt 0 2). -apply bpow_gt_0. -now apply relative_error_N_FLX. -Qed. - -Theorem relative_error_N_FLX_round : - forall x, - (Rabs (round beta (FLX_exp prec) (Znearest choice) x - x) <= /2 * bpow (-prec + 1) * Rabs (round beta (FLX_exp prec) (Znearest choice) x))%R. -Proof with auto with typeclass_instances. -intros x. -destruct (Req_dec x 0) as [Hx|Hx]. -(* . *) -rewrite Hx, round_0... -unfold Rminus. -rewrite Rplus_0_l, Rabs_Ropp, Rabs_R0. -rewrite Rmult_0_r. -apply Rle_refl. -(* . *) -destruct (ln_beta beta x) as (ex, He). -specialize (He Hx). -apply relative_error_N_round with (ex - 1)%Z. -now apply FLX_exp_valid. -intros k _. -apply relative_error_FLX_aux. -exact Hp. -apply He. -Qed. - -End Fprop_relative_FLX. - -End Fprop_relative.
\ No newline at end of file +End Fprop_relative. diff --git a/flocq/Appli/Fappli_rnd_odd.v b/flocq/Prop/Round_odd.v index 273c1000..df2952cc 100644 --- a/flocq/Appli/Fappli_rnd_odd.v +++ b/flocq/Prop/Round_odd.v @@ -2,9 +2,9 @@ This file is part of the Flocq formalization of floating-point arithmetic in Coq: http://flocq.gforge.inria.fr/ -Copyright (C) 2010-2013 Sylvie Boldo +Copyright (C) 2013-2018 Sylvie Boldo #<br /># -Copyright (C) 2010-2013 Guillaume Melquiond +Copyright (C) 2013-2018 Guillaume Melquiond This library is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public @@ -21,12 +21,11 @@ COPYING file for more details. between rnd_NE and double rounding with rnd_odd and then rnd_NE *) Require Import Reals Psatz. -Require Import Fcore. -Require Import Fcalc_ops. +Require Import Core Operations. -Definition Zrnd_odd x := match Req_EM_T x (Z2R (Zfloor x)) with +Definition Zrnd_odd x := match Req_EM_T x (IZR (Zfloor x)) with | left _ => Zfloor x - | right _ => match (Zeven (Zfloor x)) with + | right _ => match (Z.even (Zfloor x)) with | true => Zceil x | false => Zfloor x end @@ -41,64 +40,120 @@ split. intros x y Hxy. assert (Zfloor x <= Zrnd_odd y)%Z. (* .. *) -apply Zle_trans with (Zfloor y). +apply Z.le_trans with (Zfloor y). now apply Zfloor_le. -unfold Zrnd_odd; destruct (Req_EM_T y (Z2R (Zfloor y))). -now apply Zle_refl. -case (Zeven (Zfloor y)). -apply le_Z2R. +unfold Zrnd_odd; destruct (Req_EM_T y (IZR (Zfloor y))). +now apply Z.le_refl. +case (Z.even (Zfloor y)). +apply le_IZR. apply Rle_trans with y. apply Zfloor_lb. apply Zceil_ub. -now apply Zle_refl. +now apply Z.le_refl. unfold Zrnd_odd at 1. (* . *) -destruct (Req_EM_T x (Z2R (Zfloor x))) as [Hx|Hx]. +destruct (Req_EM_T x (IZR (Zfloor x))) as [Hx|Hx]. (* .. *) apply H. (* .. *) -case_eq (Zeven (Zfloor x)); intros Hx2. +case_eq (Z.even (Zfloor x)); intros Hx2. 2: apply H. -unfold Zrnd_odd; destruct (Req_EM_T y (Z2R (Zfloor y))) as [Hy|Hy]. +unfold Zrnd_odd; destruct (Req_EM_T y (IZR (Zfloor y))) as [Hy|Hy]. apply Zceil_glb. now rewrite <- Hy. -case_eq (Zeven (Zfloor y)); intros Hy2. +case_eq (Z.even (Zfloor y)); intros Hy2. now apply Zceil_le. apply Zceil_glb. assert (H0:(Zfloor x <= Zfloor y)%Z) by now apply Zfloor_le. case (Zle_lt_or_eq _ _ H0); intros H1. apply Rle_trans with (1:=Zceil_ub _). rewrite Zceil_floor_neq. -apply Z2R_le; omega. +apply IZR_le; omega. now apply sym_not_eq. contradict Hy2. rewrite <- H1, Hx2; discriminate. (* . *) intros n; unfold Zrnd_odd. -rewrite Zfloor_Z2R, Zceil_Z2R. -destruct (Req_EM_T (Z2R n) (Z2R n)); trivial. -case (Zeven n); trivial. +rewrite Zfloor_IZR, Zceil_IZR. +destruct (Req_EM_T (IZR n) (IZR n)); trivial. +case (Z.even n); trivial. Qed. -Lemma Zrnd_odd_Zodd: forall x, x <> (Z2R (Zfloor x)) -> - (Zeven (Zrnd_odd x)) = false. +Lemma Zrnd_odd_Zodd: forall x, x <> (IZR (Zfloor x)) -> + (Z.even (Zrnd_odd x)) = false. Proof. intros x Hx; unfold Zrnd_odd. -destruct (Req_EM_T x (Z2R (Zfloor x))) as [H|H]. +destruct (Req_EM_T x (IZR (Zfloor x))) as [H|H]. now contradict H. -case_eq (Zeven (Zfloor x)). +case_eq (Z.even (Zfloor x)). (* difficult case *) intros H'. rewrite Zceil_floor_neq. -rewrite Zeven_plus, H'. +rewrite Z.even_add, H'. reflexivity. now apply sym_not_eq. trivial. Qed. +Lemma Zfloor_plus: forall (n:Z) y, + (Zfloor (IZR n+y) = n + Zfloor y)%Z. +Proof. +intros n y; unfold Zfloor. +unfold Zminus; rewrite Zplus_assoc; f_equal. +apply sym_eq, tech_up. +rewrite plus_IZR. +apply Rplus_lt_compat_l. +apply archimed. +rewrite plus_IZR, Rplus_assoc. +apply Rplus_le_compat_l. +apply Rplus_le_reg_r with (-y)%R. +ring_simplify (y+1+-y)%R. +apply archimed. +Qed. + +Lemma Zceil_plus: forall (n:Z) y, + (Zceil (IZR n+y) = n + Zceil y)%Z. +Proof. +intros n y; unfold Zceil. +rewrite Ropp_plus_distr, <- Ropp_Ropp_IZR. +rewrite Zfloor_plus. +ring. +Qed. + + +Lemma Zeven_abs: forall z, Z.even (Z.abs z) = Z.even z. +Proof. +intros z; case (Zle_or_lt z 0); intros H1. +rewrite Z.abs_neq; try assumption. +apply Z.even_opp. +rewrite Z.abs_eq; auto with zarith. +Qed. + + + + +Lemma Zrnd_odd_plus: forall x y, (x = IZR (Zfloor x)) -> + Z.even (Zfloor x) = true -> + (IZR (Zrnd_odd (x+y)) = x+IZR (Zrnd_odd y))%R. +Proof. +intros x y Hx H. +unfold Zrnd_odd; rewrite Hx, Zfloor_plus. +case (Req_EM_T y (IZR (Zfloor y))); intros Hy. +rewrite Hy; repeat rewrite <- plus_IZR. +repeat rewrite Zfloor_IZR. +case (Req_EM_T _ _); intros K; easy. +case (Req_EM_T _ _); intros K. +contradict Hy. +apply Rplus_eq_reg_l with (IZR (Zfloor x)). +now rewrite K, plus_IZR. +rewrite Z.even_add, H; simpl. +case (Z.even (Zfloor y)). +now rewrite Zceil_plus, plus_IZR. +now rewrite plus_IZR. +Qed. Section Fcore_rnd_odd. @@ -113,20 +168,19 @@ Context { valid_exp : Valid_exp fexp }. Context { exists_NE_ : Exists_NE beta fexp }. Notation format := (generic_format beta fexp). -Notation canonic := (canonic beta fexp). -Notation cexp := (canonic_exp beta fexp). +Notation canonical := (canonical beta fexp). +Notation cexp := (cexp beta fexp). Definition Rnd_odd_pt (x f : R) := format f /\ ((f = x)%R \/ ((Rnd_DN_pt format x f \/ Rnd_UP_pt format x f) /\ - exists g : float beta, f = F2R g /\ canonic g /\ Zeven (Fnum g) = false)). + exists g : float beta, f = F2R g /\ canonical g /\ Z.even (Fnum g) = false)). Definition Rnd_odd (rnd : R -> R) := forall x : R, Rnd_odd_pt x (rnd x). - -Theorem Rnd_odd_pt_sym : forall x f : R, +Theorem Rnd_odd_pt_opp_inv : forall x f : R, Rnd_odd_pt (-x) (-f) -> Rnd_odd_pt x f. Proof with auto with typeclass_instances. intros x f (H1,H2). @@ -144,12 +198,12 @@ destruct H2. right. replace f with (-(-f))%R by ring. replace x with (-(-x))%R by ring. -apply Rnd_DN_UP_pt_sym... +apply Rnd_UP_pt_opp... apply generic_format_opp. left. replace f with (-(-f))%R by ring. replace x with (-(-x))%R by ring. -apply Rnd_UP_DN_pt_sym... +apply Rnd_DN_pt_opp... apply generic_format_opp. exists (Float beta (-Fnum g) (Fexp g)). split. @@ -157,15 +211,15 @@ rewrite F2R_Zopp. replace f with (-(-f))%R by ring. rewrite Hg1; reflexivity. split. -now apply canonic_opp. +now apply canonical_opp. simpl. -now rewrite Zeven_opp. +now rewrite Z.even_opp. Qed. Theorem round_odd_opp : forall x, - (round beta fexp Zrnd_odd (-x) = (- round beta fexp Zrnd_odd x))%R. + round beta fexp Zrnd_odd (-x) = (- round beta fexp Zrnd_odd x)%R. Proof. intros x; unfold round. rewrite <- F2R_Zopp. @@ -174,36 +228,36 @@ apply f_equal2; apply f_equal. rewrite scaled_mantissa_opp. generalize (scaled_mantissa beta fexp x); intros r. unfold Zrnd_odd. -case (Req_EM_T (- r) (Z2R (Zfloor (- r)))). -case (Req_EM_T r (Z2R (Zfloor r))). +case (Req_EM_T (- r) (IZR (Zfloor (- r)))). +case (Req_EM_T r (IZR (Zfloor r))). intros Y1 Y2. -apply eq_Z2R. -now rewrite Z2R_opp, <- Y1, <-Y2. +apply eq_IZR. +now rewrite opp_IZR, <- Y1, <-Y2. intros Y1 Y2. -absurd (r=Z2R (Zfloor r)); trivial. +absurd (r=IZR (Zfloor r)); trivial. pattern r at 2; replace r with (-(-r))%R by ring. -rewrite Y2, <- Z2R_opp. -rewrite Zfloor_Z2R. -rewrite Z2R_opp, <- Y2. +rewrite Y2, <- opp_IZR. +rewrite Zfloor_IZR. +rewrite opp_IZR, <- Y2. ring. -case (Req_EM_T r (Z2R (Zfloor r))). +case (Req_EM_T r (IZR (Zfloor r))). intros Y1 Y2. -absurd (-r=Z2R (Zfloor (-r)))%R; trivial. +absurd (-r=IZR (Zfloor (-r)))%R; trivial. pattern r at 2; rewrite Y1. -rewrite <- Z2R_opp, Zfloor_Z2R. -now rewrite Z2R_opp, <- Y1. +rewrite <- opp_IZR, Zfloor_IZR. +now rewrite opp_IZR, <- Y1. intros Y1 Y2. unfold Zceil; rewrite Ropp_involutive. -replace (Zeven (Zfloor (- r))) with (negb (Zeven (Zfloor r))). -case (Zeven (Zfloor r)); simpl; ring. -apply trans_eq with (Zeven (Zceil r)). +replace (Z.even (Zfloor (- r))) with (negb (Z.even (Zfloor r))). +case (Z.even (Zfloor r)); simpl; ring. +apply trans_eq with (Z.even (Zceil r)). rewrite Zceil_floor_neq. -rewrite Zeven_plus. -destruct (Zeven (Zfloor r)); reflexivity. +rewrite Z.even_add. +destruct (Z.even (Zfloor r)); reflexivity. now apply sym_not_eq. -rewrite <- (Zeven_opp (Zfloor (- r))). +rewrite <- (Z.even_opp (Zfloor (- r))). reflexivity. -apply canonic_exp_opp. +apply cexp_opp. Qed. @@ -221,7 +275,7 @@ rewrite round_0... split. apply generic_format_0. now left. -intros Hx; apply Rnd_odd_pt_sym. +intros Hx; apply Rnd_odd_pt_opp_inv. rewrite <- round_odd_opp. apply H. auto with real. @@ -248,7 +302,7 @@ right; apply round_UP_pt... (* *) unfold o, Zrnd_odd, round. case (Req_EM_T (scaled_mantissa beta fexp x) - (Z2R (Zfloor (scaled_mantissa beta fexp x)))). + (IZR (Zfloor (scaled_mantissa beta fexp x)))). intros T. absurd (o=x); trivial. apply round_generic... @@ -260,20 +314,20 @@ apply Rmult_le_pos. now left. apply bpow_ge_0. intros L. -case_eq (Zeven (Zfloor (scaled_mantissa beta fexp x))). +case_eq (Z.even (Zfloor (scaled_mantissa beta fexp x))). (* . *) generalize (generic_format_round beta fexp Zceil x). unfold generic_format. set (f:=round beta fexp Zceil x). -set (ef := canonic_exp beta fexp f). +set (ef := cexp f). set (mf := Ztrunc (scaled_mantissa beta fexp f)). exists (Float beta mf ef). -unfold Fcore_generic_fmt.canonic. +unfold canonical. rewrite <- H0. repeat split; try assumption. -apply trans_eq with (negb (Zeven (Zfloor (scaled_mantissa beta fexp x)))). +apply trans_eq with (negb (Z.even (Zfloor (scaled_mantissa beta fexp x)))). 2: rewrite H1; reflexivity. -apply trans_eq with (negb (Zeven (Fnum +apply trans_eq with (negb (Z.even (Fnum (Float beta (Zfloor (scaled_mantissa beta fexp x)) (cexp x))))). 2: reflexivity. case (Rle_lt_or_eq_dec 0 (round beta fexp Zfloor x)). @@ -294,10 +348,10 @@ assumption. apply Rmult_le_pos. now left. apply bpow_ge_0. -unfold Fcore_generic_fmt.canonic. +unfold canonical. simpl. -apply sym_eq, canonic_exp_DN... -unfold Fcore_generic_fmt.canonic. +apply sym_eq, cexp_DN... +unfold canonical. rewrite <- H0; reflexivity. reflexivity. apply trans_eq with (round beta fexp Ztrunc (round beta fexp Zceil x)). @@ -305,7 +359,7 @@ reflexivity. apply round_generic... intros Y. replace (Fnum {| Fnum := Zfloor (scaled_mantissa beta fexp x); Fexp := cexp x |}) - with (Fnum (Float beta 0 (fexp (ln_beta beta 0)))). + with (Fnum (Float beta 0 (fexp (mag beta 0)))). generalize (DN_UP_parity_generic beta fexp)... unfold DN_UP_parity_prop. intros T; apply T with x; clear T. @@ -319,15 +373,15 @@ assumption. apply Rmult_le_pos. now left. apply bpow_ge_0. -apply canonic_0. -unfold Fcore_generic_fmt.canonic. +apply canonical_0. +unfold canonical. rewrite <- H0; reflexivity. rewrite <- Y; unfold F2R; simpl; ring. apply trans_eq with (round beta fexp Ztrunc (round beta fexp Zceil x)). reflexivity. apply round_generic... simpl. -apply eq_Z2R, Rmult_eq_reg_r with (bpow (cexp x)). +apply eq_IZR, Rmult_eq_reg_r with (bpow (cexp x)). unfold round, F2R in Y; simpl in Y; rewrite <- Y. simpl; ring. apply Rgt_not_eq, bpow_gt_0. @@ -338,27 +392,25 @@ rewrite <- round_0 with beta fexp Zfloor... apply round_le... now left. intros Hrx. -set (ef := canonic_exp beta fexp x). +set (ef := cexp x). set (mf := Zfloor (scaled_mantissa beta fexp x)). exists (Float beta mf ef). -unfold Fcore_generic_fmt.canonic. +unfold canonical. repeat split; try assumption. simpl. apply trans_eq with (cexp (round beta fexp Zfloor x )). -apply sym_eq, canonic_exp_DN... +apply sym_eq, cexp_DN... reflexivity. intros Hrx; contradict Y. replace (Zfloor (scaled_mantissa beta fexp x)) with 0%Z. simpl; discriminate. -apply eq_Z2R, Rmult_eq_reg_r with (bpow (cexp x)). +apply eq_IZR, Rmult_eq_reg_r with (bpow (cexp x)). unfold round, F2R in Hrx; simpl in Hrx; rewrite <- Hrx. simpl; ring. apply Rgt_not_eq, bpow_gt_0. Qed. - - -Theorem Rnd_odd_pt_unicity : +Theorem Rnd_odd_pt_unique : forall x f1 f2 : R, Rnd_odd_pt x f1 -> Rnd_odd_pt x f2 -> f1 = f2. @@ -381,61 +433,56 @@ contradict L; now rewrite <- H1. destruct H2 as [H2|(H2,H2')]. contradict L; now rewrite <- H2. destruct H1 as [H1|H1]; destruct H2 as [H2|H2]. -apply Rnd_DN_pt_unicity with format x; assumption. +apply Rnd_DN_pt_unique with format x; assumption. destruct H1' as (ff,(K1,(K2,K3))). destruct H2' as (gg,(L1,(L2,L3))). absurd (true = false); try discriminate. rewrite <- L3. -apply trans_eq with (negb (Zeven (Fnum ff))). +apply trans_eq with (negb (Z.even (Fnum ff))). rewrite K3; easy. apply sym_eq. generalize (DN_UP_parity_generic beta fexp). unfold DN_UP_parity_prop; intros T; apply (T x); clear T; try assumption... -rewrite <- K1; apply Rnd_DN_pt_unicity with (generic_format beta fexp) x; try easy... +rewrite <- K1; apply Rnd_DN_pt_unique with (generic_format beta fexp) x; try easy... now apply round_DN_pt... -rewrite <- L1; apply Rnd_UP_pt_unicity with (generic_format beta fexp) x; try easy... +rewrite <- L1; apply Rnd_UP_pt_unique with (generic_format beta fexp) x; try easy... now apply round_UP_pt... (* *) destruct H1' as (ff,(K1,(K2,K3))). destruct H2' as (gg,(L1,(L2,L3))). absurd (true = false); try discriminate. rewrite <- K3. -apply trans_eq with (negb (Zeven (Fnum gg))). +apply trans_eq with (negb (Z.even (Fnum gg))). rewrite L3; easy. apply sym_eq. generalize (DN_UP_parity_generic beta fexp). unfold DN_UP_parity_prop; intros T; apply (T x); clear T; try assumption... -rewrite <- L1; apply Rnd_DN_pt_unicity with (generic_format beta fexp) x; try easy... +rewrite <- L1; apply Rnd_DN_pt_unique with (generic_format beta fexp) x; try easy... now apply round_DN_pt... -rewrite <- K1; apply Rnd_UP_pt_unicity with (generic_format beta fexp) x; try easy... +rewrite <- K1; apply Rnd_UP_pt_unique with (generic_format beta fexp) x; try easy... now apply round_UP_pt... -apply Rnd_UP_pt_unicity with format x; assumption. +apply Rnd_UP_pt_unique with format x; assumption. Qed. - - Theorem Rnd_odd_pt_monotone : round_pred_monotone (Rnd_odd_pt). Proof with auto with typeclass_instances. intros x y f g H1 H2 Hxy. apply Rle_trans with (round beta fexp Zrnd_odd x). -right; apply Rnd_odd_pt_unicity with x; try assumption. +right; apply Rnd_odd_pt_unique with x; try assumption. apply round_odd_pt. apply Rle_trans with (round beta fexp Zrnd_odd y). apply round_le... -right; apply Rnd_odd_pt_unicity with y; try assumption. +right; apply Rnd_odd_pt_unique with y; try assumption. apply round_odd_pt. Qed. - - - End Fcore_rnd_odd. Section Odd_prop_aux. Variable beta : radix. -Hypothesis Even_beta: Zeven (radix_val beta)=true. +Hypothesis Even_beta: Z.even (radix_val beta)=true. Notation bpow e := (bpow beta e). @@ -454,26 +501,26 @@ Lemma generic_format_fexpe_fexp: forall x, generic_format beta fexp x -> generic_format beta fexpe x. Proof. intros x Hx. -apply generic_inclusion_ln_beta with fexp; trivial; intros Hx2. -generalize (fexpe_fexp (ln_beta beta x)). +apply generic_inclusion_mag with fexp; trivial; intros Hx2. +generalize (fexpe_fexp (mag beta x)). omega. Qed. Lemma exists_even_fexp_lt: forall (c:Z->Z), forall (x:R), - (exists f:float beta, F2R f = x /\ (c (ln_beta beta x) < Fexp f)%Z) -> - exists f:float beta, F2R f =x /\ canonic beta c f /\ Zeven (Fnum f) = true. + (exists f:float beta, F2R f = x /\ (c (mag beta x) < Fexp f)%Z) -> + exists f:float beta, F2R f =x /\ canonical beta c f /\ Z.even (Fnum f) = true. Proof with auto with typeclass_instances. intros c x (g,(Hg1,Hg2)). exists (Float beta - (Fnum g*Z.pow (radix_val beta) (Fexp g - c (ln_beta beta x))) - (c (ln_beta beta x))). + (Fnum g*Z.pow (radix_val beta) (Fexp g - c (mag beta x))) + (c (mag beta x))). assert (F2R (Float beta - (Fnum g*Z.pow (radix_val beta) (Fexp g - c (ln_beta beta x))) - (c (ln_beta beta x))) = x). + (Fnum g*Z.pow (radix_val beta) (Fexp g - c (mag beta x))) + (c (mag beta x))) = x). unfold F2R; simpl. -rewrite Z2R_mult, Z2R_Zpower. +rewrite mult_IZR, IZR_Zpower. rewrite Rmult_assoc, <- bpow_plus. rewrite <- Hg1; unfold F2R. apply f_equal, f_equal. @@ -481,11 +528,11 @@ ring. omega. split; trivial. split. -unfold canonic, canonic_exp. +unfold canonical, cexp. now rewrite H. simpl. -rewrite Zeven_mult. -rewrite Zeven_Zpower. +rewrite Z.even_mul. +rewrite Z.even_pow. rewrite Even_beta. apply Bool.orb_true_intro. now right. @@ -499,9 +546,9 @@ Variable x:R. Variable d u: float beta. Hypothesis Hd: Rnd_DN_pt (generic_format beta fexp) x (F2R d). -Hypothesis Cd: canonic beta fexp d. +Hypothesis Cd: canonical beta fexp d. Hypothesis Hu: Rnd_UP_pt (generic_format beta fexp) x (F2R u). -Hypothesis Cu: canonic beta fexp u. +Hypothesis Cu: canonical beta fexp u. Hypothesis xPos: (0 < x)%R. @@ -511,14 +558,14 @@ Let m:= ((F2R d+F2R u)/2)%R. Lemma d_eq: F2R d= round beta fexp Zfloor x. Proof with auto with typeclass_instances. -apply Rnd_DN_pt_unicity with (generic_format beta fexp) x... +apply Rnd_DN_pt_unique with (generic_format beta fexp) x... apply round_DN_pt... Qed. Lemma u_eq: F2R u= round beta fexp Zceil x. Proof with auto with typeclass_instances. -apply Rnd_UP_pt_unicity with (generic_format beta fexp) x... +apply Rnd_UP_pt_unique with (generic_format beta fexp) x... apply round_UP_pt... Qed. @@ -532,47 +579,47 @@ Qed. -Lemma ln_beta_d: (0< F2R d)%R -> - (ln_beta beta (F2R d) = ln_beta beta x :>Z). +Lemma mag_d: (0< F2R d)%R -> + (mag beta (F2R d) = mag beta x :>Z). Proof with auto with typeclass_instances. intros Y. -rewrite d_eq; apply ln_beta_DN... +rewrite d_eq; apply mag_DN... now rewrite <- d_eq. Qed. -Lemma Fexp_d: (0 < F2R d)%R -> Fexp d =fexp (ln_beta beta x). +Lemma Fexp_d: (0 < F2R d)%R -> Fexp d =fexp (mag beta x). Proof with auto with typeclass_instances. intros Y. -now rewrite Cd, <- ln_beta_d. +now rewrite Cd, <- mag_d. Qed. Lemma format_bpow_x: (0 < F2R d)%R - -> generic_format beta fexp (bpow (ln_beta beta x)). + -> generic_format beta fexp (bpow (mag beta x)). Proof with auto with typeclass_instances. intros Y. apply generic_format_bpow. apply valid_exp. rewrite <- Fexp_d; trivial. -apply Zlt_le_trans with (ln_beta beta (F2R d))%Z. -rewrite Cd; apply ln_beta_generic_gt... +apply Z.lt_le_trans with (mag beta (F2R d))%Z. +rewrite Cd; apply mag_generic_gt... now apply Rgt_not_eq. apply Hd. -apply ln_beta_le; trivial. +apply mag_le; trivial. apply Hd. Qed. Lemma format_bpow_d: (0 < F2R d)%R -> - generic_format beta fexp (bpow (ln_beta beta (F2R d))). + generic_format beta fexp (bpow (mag beta (F2R d))). Proof with auto with typeclass_instances. intros Y; apply generic_format_bpow. apply valid_exp. -apply ln_beta_generic_gt... +apply mag_generic_gt... now apply Rgt_not_eq. -now apply generic_format_canonic. +now apply generic_format_canonical. Qed. @@ -596,12 +643,12 @@ unfold m. lra. Qed. -Lemma ln_beta_m: (0 < F2R d)%R -> (ln_beta beta m =ln_beta beta (F2R d) :>Z). +Lemma mag_m: (0 < F2R d)%R -> (mag beta m =mag beta (F2R d) :>Z). Proof with auto with typeclass_instances. -intros dPos; apply ln_beta_unique_pos. +intros dPos; apply mag_unique_pos. split. apply Rle_trans with (F2R d). -destruct (ln_beta beta (F2R d)) as (e,He). +destruct (mag beta (F2R d)) as (e,He). simpl. rewrite Rabs_right in He. apply He. @@ -614,13 +661,13 @@ rewrite u_eq. apply round_le_generic... apply generic_format_bpow. apply valid_exp. -apply ln_beta_generic_gt... +apply mag_generic_gt... now apply Rgt_not_eq. -now apply generic_format_canonic. -case (Rle_or_lt x (bpow (ln_beta beta (F2R d)))); trivial; intros Z. -absurd ((bpow (ln_beta beta (F2R d)) <= (F2R d)))%R. +now apply generic_format_canonical. +case (Rle_or_lt x (bpow (mag beta (F2R d)))); trivial; intros Z. +absurd ((bpow (mag beta (F2R d)) <= (F2R d)))%R. apply Rlt_not_le. -destruct (ln_beta beta (F2R d)) as (e,He). +destruct (mag beta (F2R d)) as (e,He). simpl in *; rewrite Rabs_right in He. apply He. now apply Rgt_not_eq. @@ -630,12 +677,12 @@ apply Rle_trans with (round beta fexp Zfloor x). apply round_ge_generic... apply generic_format_bpow. apply valid_exp. -apply ln_beta_generic_gt... +apply mag_generic_gt... now apply Rgt_not_eq. -now apply generic_format_canonic. +now apply generic_format_canonical. now left. replace m with (F2R d). -destruct (ln_beta beta (F2R d)) as (e,He). +destruct (mag beta (F2R d)) as (e,He). simpl in *; rewrite Rabs_right in He. apply He. now apply Rgt_not_eq. @@ -645,17 +692,17 @@ lra. Qed. -Lemma ln_beta_m_0: (0 = F2R d)%R - -> (ln_beta beta m =ln_beta beta (F2R u)-1:>Z)%Z. +Lemma mag_m_0: (0 = F2R d)%R + -> (mag beta m =mag beta (F2R u)-1:>Z)%Z. Proof with auto with typeclass_instances. intros Y. -apply ln_beta_unique_pos. +apply mag_unique_pos. unfold m; rewrite <- Y, Rplus_0_l. rewrite u_eq. -destruct (ln_beta beta x) as (e,He). +destruct (mag beta x) as (e,He). rewrite Rabs_pos_eq in He by now apply Rlt_le. rewrite round_UP_small_pos with (ex:=e). -rewrite ln_beta_bpow. +rewrite mag_bpow. ring_simplify (fexp e + 1 - 1)%Z. split. unfold Zminus; rewrite bpow_plus. @@ -664,7 +711,7 @@ apply bpow_ge_0. simpl; unfold Z.pow_pos; simpl. rewrite Zmult_1_r; apply Rinv_le. exact Rlt_0_2. -apply (Z2R_le 2). +apply IZR_le. specialize (radix_gt_1 beta). omega. apply Rlt_le_trans with (bpow (fexp e)*1)%R. @@ -691,29 +738,29 @@ simpl; now rewrite Fexp_d. Qed. - - -Lemma m_eq: (0 < F2R d)%R -> exists f:float beta, - F2R f = m /\ (Fexp f = fexp (ln_beta beta x) -1)%Z. +Lemma m_eq : + (0 < F2R d)%R -> + exists f:float beta, + F2R f = m /\ (Fexp f = fexp (mag beta x) - 1)%Z. Proof with auto with typeclass_instances. intros Y. specialize (Zeven_ex (radix_val beta)); rewrite Even_beta. intros (b, Hb); rewrite Zplus_0_r in Hb. destruct u'_eq as (u', (Hu'1,Hu'2)); trivial. -exists (Fmult beta (Float beta b (-1)) (Fplus beta d u'))%R. +exists (Fmult (Float beta b (-1)) (Fplus d u'))%R. split. rewrite F2R_mult, F2R_plus, Hu'1. unfold m; rewrite Rmult_comm. unfold Rdiv; apply f_equal. unfold F2R; simpl; unfold Z.pow_pos; simpl. -rewrite Zmult_1_r, Hb, Z2R_mult. +rewrite Zmult_1_r, Hb, mult_IZR. simpl; field. apply Rgt_not_eq, Rmult_lt_reg_l with (1 := Rlt_0_2). -rewrite Rmult_0_r, <- (Z2R_mult 2), <-Hb. +rewrite Rmult_0_r, <- (mult_IZR 2), <-Hb. apply radix_pos. -apply trans_eq with (-1+Fexp (Fplus beta d u'))%Z. +apply trans_eq with (-1+Fexp (Fplus d u'))%Z. unfold Fmult. -destruct (Fplus beta d u'); reflexivity. +destruct (Fplus d u'); reflexivity. rewrite Zplus_comm; unfold Zminus; apply f_equal2. 2: reflexivity. rewrite Fexp_Fplus. @@ -723,21 +770,21 @@ rewrite Hu'2; omega. Qed. Lemma m_eq_0: (0 = F2R d)%R -> exists f:float beta, - F2R f = m /\ (Fexp f = fexp (ln_beta beta (F2R u)) -1)%Z. + F2R f = m /\ (Fexp f = fexp (mag beta (F2R u)) -1)%Z. Proof with auto with typeclass_instances. intros Y. specialize (Zeven_ex (radix_val beta)); rewrite Even_beta. intros (b, Hb); rewrite Zplus_0_r in Hb. -exists (Fmult beta (Float beta b (-1)) u)%R. +exists (Fmult (Float beta b (-1)) u)%R. split. rewrite F2R_mult; unfold m; rewrite <- Y, Rplus_0_l. rewrite Rmult_comm. unfold Rdiv; apply f_equal. unfold F2R; simpl; unfold Z.pow_pos; simpl. -rewrite Zmult_1_r, Hb, Z2R_mult. +rewrite Zmult_1_r, Hb, mult_IZR. simpl; field. apply Rgt_not_eq, Rmult_lt_reg_l with (1 := Rlt_0_2). -rewrite Rmult_0_r, <- (Z2R_mult 2), <-Hb. +rewrite Rmult_0_r, <- (mult_IZR 2), <-Hb. apply radix_pos. apply trans_eq with (-1+Fexp u)%Z. unfold Fmult. @@ -746,12 +793,12 @@ rewrite Zplus_comm, Cu; unfold Zminus; now apply f_equal2. Qed. Lemma fexp_m_eq_0: (0 = F2R d)%R -> - (fexp (ln_beta beta (F2R u)-1) < fexp (ln_beta beta (F2R u))+1)%Z. + (fexp (mag beta (F2R u)-1) < fexp (mag beta (F2R u))+1)%Z. Proof with auto with typeclass_instances. intros Y. -assert ((fexp (ln_beta beta (F2R u) - 1) <= fexp (ln_beta beta (F2R u))))%Z. +assert ((fexp (mag beta (F2R u) - 1) <= fexp (mag beta (F2R u))))%Z. 2: omega. -destruct (ln_beta beta x) as (e,He). +destruct (mag beta x) as (e,He). rewrite Rabs_right in He. 2: now left. assert (e <= fexp e)%Z. @@ -760,7 +807,7 @@ now apply He, Rgt_not_eq. now rewrite <- d_eq, Y. rewrite u_eq, round_UP_small_pos with (ex:=e); trivial. 2: now apply He, Rgt_not_eq. -rewrite ln_beta_bpow. +rewrite mag_bpow. ring_simplify (fexp e + 1 - 1)%Z. replace (fexp (fexp e)) with (fexp e). case exists_NE_; intros V. @@ -770,33 +817,34 @@ apply sym_eq, valid_exp; omega. Qed. Lemma Fm: generic_format beta fexpe m. +Proof. case (d_ge_0); intros Y. (* *) destruct m_eq as (g,(Hg1,Hg2)); trivial. apply generic_format_F2R' with g. now apply sym_eq. -intros H; unfold canonic_exp; rewrite Hg2. -rewrite ln_beta_m; trivial. +intros H; unfold cexp; rewrite Hg2. +rewrite mag_m; trivial. rewrite <- Fexp_d; trivial. rewrite Cd. -unfold canonic_exp. -generalize (fexpe_fexp (ln_beta beta (F2R d))). +unfold cexp. +generalize (fexpe_fexp (mag beta (F2R d))). omega. (* *) destruct m_eq_0 as (g,(Hg1,Hg2)); trivial. apply generic_format_F2R' with g. assumption. -intros H; unfold canonic_exp; rewrite Hg2. -rewrite ln_beta_m_0; try assumption. -apply Zle_trans with (1:=fexpe_fexp _). -assert (fexp (ln_beta beta (F2R u)-1) < fexp (ln_beta beta (F2R u))+1)%Z;[idtac|omega]. -now apply fexp_m_eq_0. +intros H; unfold cexp; rewrite Hg2. +rewrite mag_m_0; try assumption. +apply Z.le_trans with (1:=fexpe_fexp _). +generalize (fexp_m_eq_0 Y). +omega. Qed. Lemma Zm: - exists g : float beta, F2R g = m /\ canonic beta fexpe g /\ Zeven (Fnum g) = true. + exists g : float beta, F2R g = m /\ canonical beta fexpe g /\ Z.even (Fnum g) = true. Proof with auto with typeclass_instances. case (d_ge_0); intros Y. (* *) @@ -804,26 +852,27 @@ destruct m_eq as (g,(Hg1,Hg2)); trivial. apply exists_even_fexp_lt. exists g; split; trivial. rewrite Hg2. -rewrite ln_beta_m; trivial. +rewrite mag_m; trivial. rewrite <- Fexp_d; trivial. rewrite Cd. -unfold canonic_exp. -generalize (fexpe_fexp (ln_beta beta (F2R d))). +unfold cexp. +generalize (fexpe_fexp (mag beta (F2R d))). omega. (* *) destruct m_eq_0 as (g,(Hg1,Hg2)); trivial. apply exists_even_fexp_lt. exists g; split; trivial. rewrite Hg2. -rewrite ln_beta_m_0; trivial. -apply Zle_lt_trans with (1:=fexpe_fexp _). -assert (fexp (ln_beta beta (F2R u)-1) < fexp (ln_beta beta (F2R u))+1)%Z;[idtac|omega]. -now apply fexp_m_eq_0. +rewrite mag_m_0; trivial. +apply Z.le_lt_trans with (1:=fexpe_fexp _). +generalize (fexp_m_eq_0 Y). +omega. Qed. -Lemma DN_odd_d_aux: forall z, (F2R d<= z< F2R u)%R -> - Rnd_DN_pt (generic_format beta fexp) z (F2R d). +Lemma DN_odd_d_aux : + forall z, (F2R d <= z < F2R u)%R -> + Rnd_DN_pt (generic_format beta fexp) z (F2R d). Proof with auto with typeclass_instances. intros z Hz1. replace (F2R d) with (round beta fexp Zfloor z). @@ -834,22 +883,21 @@ intros Y; apply Rle_antisym; trivial. apply round_DN_pt... apply Hd. apply Hz1. -intros Y; absurd (z < z)%R. -auto with real. +intros Y ; elim (Rlt_irrefl z). apply Rlt_le_trans with (1:=proj2 Hz1), Rle_trans with (1:=Y). apply round_DN_pt... Qed. -Lemma UP_odd_d_aux: forall z, (F2R d< z <= F2R u)%R -> - Rnd_UP_pt (generic_format beta fexp) z (F2R u). +Lemma UP_odd_d_aux : + forall z, (F2R d < z <= F2R u)%R -> + Rnd_UP_pt (generic_format beta fexp) z (F2R u). Proof with auto with typeclass_instances. intros z Hz1. replace (F2R u) with (round beta fexp Zceil z). apply round_UP_pt... case (Rnd_DN_UP_pt_split _ _ _ _ Hd Hu (round beta fexp Zceil z)). apply generic_format_round... -intros Y; absurd (z < z)%R. -auto with real. +intros Y ; elim (Rlt_irrefl z). apply Rle_lt_trans with (2:=proj1 Hz1), Rle_trans with (2:=Y). apply round_UP_pt... intros Y; apply Rle_antisym; trivial. @@ -859,7 +907,7 @@ apply Hz1. Qed. -Theorem round_odd_prop_pos: +Lemma round_N_odd_pos : round beta fexp (Znearest choice) (round beta fexpe Zrnd_odd x) = round beta fexp (Znearest choice) x. Proof with auto with typeclass_instances. @@ -889,7 +937,7 @@ absurd (true=false). discriminate. rewrite <- Hk3, <- Hk'3. apply f_equal, f_equal. -apply canonic_unicity with fexpe... +apply canonical_unique with fexpe... now rewrite Hk'1, <- Y2. assert (generic_format beta fexp o -> (forall P:Prop, P)). intros Y. @@ -902,14 +950,14 @@ destruct H as (_,(k,(Hk1,(Hk2,Hk3)))). destruct (exists_even_fexp_lt fexpe o) as (k',(Hk'1,(Hk'2,Hk'3))). eexists; split. apply sym_eq, Y. -simpl; unfold canonic_exp. -apply Zle_lt_trans with (1:=fexpe_fexp _). +simpl; unfold cexp. +apply Z.le_lt_trans with (1:=fexpe_fexp _). omega. absurd (true=false). discriminate. rewrite <- Hk3, <- Hk'3. apply f_equal, f_equal. -apply canonic_unicity with fexpe... +apply canonical_unique with fexpe... now rewrite Hk'1, <- Hk1. case K1; clear K1; intros K1. 2: apply H; rewrite <- K1; apply Hd. @@ -957,7 +1005,7 @@ End Odd_prop_aux. Section Odd_prop. Variable beta : radix. -Hypothesis Even_beta: Zeven (radix_val beta)=true. +Hypothesis Even_beta: Z.even (radix_val beta)=true. Variable fexp : Z -> Z. Variable fexpe : Z -> Z. @@ -970,25 +1018,8 @@ Context { exists_NE_e : Exists_NE beta fexpe }. (* for defining rounding to odd Hypothesis fexpe_fexp: forall e, (fexpe e <= fexp e -2)%Z. - -Theorem canonizer: forall f, generic_format beta fexp f - -> exists g : float beta, f = F2R g /\ canonic beta fexp g. -Proof with auto with typeclass_instances. -intros f Hf. -exists (Float beta (Ztrunc (scaled_mantissa beta fexp f)) (canonic_exp beta fexp f)). -assert (L:(f = F2R (Float beta (Ztrunc (scaled_mantissa beta fexp f)) (canonic_exp beta fexp f)))). -apply trans_eq with (round beta fexp Ztrunc f). -apply sym_eq, round_generic... -reflexivity. -split; trivial. -unfold canonic; rewrite <- L. -reflexivity. -Qed. - - - - -Theorem round_odd_prop: forall x, +Theorem round_N_odd : + forall x, round beta fexp (Znearest choice) (round beta fexpe Zrnd_odd x) = round beta fexp (Znearest choice) x. Proof with auto with typeclass_instances. @@ -998,25 +1029,192 @@ rewrite <- (Ropp_involutive x). rewrite round_odd_opp. rewrite 2!round_N_opp. apply f_equal. -destruct (canonizer (round beta fexp Zfloor (-x))) as (d,(Hd1,Hd2)). +destruct (canonical_generic_format beta fexp (round beta fexp Zfloor (-x))) as (d,(Hd1,Hd2)). apply generic_format_round... -destruct (canonizer (round beta fexp Zceil (-x))) as (u,(Hu1,Hu2)). +destruct (canonical_generic_format beta fexp (round beta fexp Zceil (-x))) as (u,(Hu1,Hu2)). apply generic_format_round... -apply round_odd_prop_pos with d u... +apply round_N_odd_pos with d u... rewrite <- Hd1; apply round_DN_pt... rewrite <- Hu1; apply round_UP_pt... auto with real. (* . *) rewrite H; repeat rewrite round_0... (* . *) -destruct (canonizer (round beta fexp Zfloor x)) as (d,(Hd1,Hd2)). +destruct (canonical_generic_format beta fexp (round beta fexp Zfloor x)) as (d,(Hd1,Hd2)). apply generic_format_round... -destruct (canonizer (round beta fexp Zceil x)) as (u,(Hu1,Hu2)). +destruct (canonical_generic_format beta fexp (round beta fexp Zceil x)) as (u,(Hu1,Hu2)). apply generic_format_round... -apply round_odd_prop_pos with d u... +apply round_N_odd_pos with d u... rewrite <- Hd1; apply round_DN_pt... rewrite <- Hu1; apply round_UP_pt... Qed. - End Odd_prop. + + +Section Odd_propbis. + +Variable beta : radix. +Hypothesis Even_beta: Z.even (radix_val beta)=true. + +Variable emin prec:Z. +Variable choice:Z->bool. + +Hypothesis prec_gt_1: (1 < prec)%Z. + + +Notation format := (generic_format beta (FLT_exp emin prec)). +Notation round_flt :=(round beta (FLT_exp emin prec) (Znearest choice)). +Notation cexp_flt := (cexp beta (FLT_exp emin prec)). +Notation fexpe k := (FLT_exp (emin-k) (prec+k)). + + + +Lemma Zrnd_odd_plus': forall x y, + (exists n:Z, exists e:Z, (x = IZR n*bpow beta e)%R /\ (1 <= e)%Z) -> + (IZR (Zrnd_odd (x+y)) = x+IZR (Zrnd_odd y))%R. +Proof. +intros x y (n,(e,(H1,H2))). +apply Zrnd_odd_plus. +rewrite H1. +rewrite <- IZR_Zpower. +2: auto with zarith. +now rewrite <- mult_IZR, Zfloor_IZR. +rewrite H1, <- IZR_Zpower. +2: auto with zarith. +rewrite <- mult_IZR, Zfloor_IZR. +rewrite Z.even_mul. +rewrite Z.even_pow. +2: auto with zarith. +rewrite Even_beta. +apply Bool.orb_true_iff; now right. +Qed. + + + +Theorem mag_round_odd: forall (x:R), + (emin < mag beta x)%Z -> + (mag_val beta _ (mag beta (round beta (FLT_exp emin prec) Zrnd_odd x)) + = mag_val beta x (mag beta x))%Z. +Proof with auto with typeclass_instances. +intros x. +assert (T:Prec_gt_0 prec). +unfold Prec_gt_0; auto with zarith. +case (Req_dec x 0); intros Zx. +intros _; rewrite Zx, round_0... +destruct (mag beta x) as (e,He); simpl; intros H. +apply mag_unique; split. +apply abs_round_ge_generic... +apply FLT_format_bpow... +auto with zarith. +now apply He. +assert (V: + (Rabs (round beta (FLT_exp emin prec) Zrnd_odd x) <= bpow beta e)%R). +apply abs_round_le_generic... +apply FLT_format_bpow... +auto with zarith. +left; now apply He. +case V; try easy; intros K. +assert (H0:Rnd_odd_pt beta (FLT_exp emin prec) x (round beta (FLT_exp emin prec) Zrnd_odd x)). +apply round_odd_pt... +destruct H0 as (_,HH); destruct HH as [H0|(H0,(g,(Hg1,(Hg2,Hg3))))]. +absurd (Rabs x < bpow beta e)%R. +apply Rle_not_lt; right. +now rewrite <- H0,K. +now apply He. +pose (gg:=Float beta (Zpower beta (e-FLT_exp emin prec (e+1))) (FLT_exp emin prec (e+1))). +assert (Y1: F2R gg = bpow beta e). +unfold F2R; simpl. +rewrite IZR_Zpower. +rewrite <- bpow_plus. +f_equal; ring. +assert (FLT_exp emin prec (e+1) <= e)%Z; [idtac|auto with zarith]. +unfold FLT_exp. +apply Z.max_case_strong; auto with zarith. +assert (Y2: canonical beta (FLT_exp emin prec) gg). +unfold canonical; rewrite Y1; unfold gg; simpl. +unfold cexp; now rewrite mag_bpow. +assert (Y3: Fnum gg = Z.abs (Fnum g)). +apply trans_eq with (Fnum (Fabs g)). +2: destruct g; unfold Fabs; now simpl. +f_equal. +apply canonical_unique with (FLT_exp emin prec); try assumption. +destruct g; unfold Fabs; apply canonical_abs; easy. +now rewrite Y1, F2R_abs, <- Hg1,K. +assert (Y4: Z.even (Fnum gg) = true). +unfold gg; simpl. +rewrite Z.even_pow; try assumption. +assert (FLT_exp emin prec (e+1) < e)%Z; [idtac|auto with zarith]. +unfold FLT_exp. +apply Z.max_case_strong; auto with zarith. +absurd (true = false). +discriminate. +rewrite <- Hg3. +rewrite <- Zeven_abs. +now rewrite <- Y3. +Qed. + +Theorem fexp_round_odd: forall (x:R), + (cexp_flt (round beta (FLT_exp emin prec) Zrnd_odd x) + = cexp_flt x)%Z. +Proof with auto with typeclass_instances. +intros x. +assert (G0:Valid_exp (FLT_exp emin prec)). +apply FLT_exp_valid; unfold Prec_gt_0; auto with zarith. +case (Req_dec x 0); intros Zx. +rewrite Zx, round_0... +case (Zle_or_lt (mag beta x) emin). +unfold cexp; destruct (mag beta x) as (e,He); simpl. +intros H; unfold FLT_exp at 4. +rewrite Z.max_r. +2: auto with zarith. +apply Z.max_r. +assert (G: Rabs (round beta (FLT_exp emin prec) Zrnd_odd x) = bpow beta emin). +assert (G1: (Rabs (round beta (FLT_exp emin prec) Zrnd_odd x) <= bpow beta emin)%R). +apply abs_round_le_generic... +apply generic_format_bpow'... +unfold FLT_exp; rewrite Z.max_r; auto with zarith. +left; apply Rlt_le_trans with (bpow beta e). +now apply He. +now apply bpow_le. +assert (G2: (0 <= Rabs (round beta (FLT_exp emin prec) Zrnd_odd x))%R). +apply Rabs_pos. +assert (G3: (Rabs (round beta (FLT_exp emin prec) Zrnd_odd x) <> 0)%R). +assert (H0:Rnd_odd_pt beta (FLT_exp emin prec) x + (round beta (FLT_exp emin prec) Zrnd_odd x)). +apply round_odd_pt... +destruct H0 as (_,H0); destruct H0 as [H0|(_,(g,(Hg1,(Hg2,Hg3))))]. +apply Rgt_not_eq; rewrite H0. +apply Rlt_le_trans with (bpow beta (e-1)). +apply bpow_gt_0. +now apply He. +rewrite Hg1; intros K. +contradict Hg3. +replace (Fnum g) with 0%Z. +easy. +case (Z.eq_dec (Fnum g) Z0); intros W; try easy. +contradict K. +apply Rabs_no_R0. +now apply F2R_neq_0. +apply Rle_antisym; try assumption. +apply Rle_trans with (succ beta (FLT_exp emin prec) 0). +right; rewrite succ_0. +rewrite ulp_FLT_small; try easy. +unfold Prec_gt_0; auto with zarith. +rewrite Rabs_R0; apply bpow_gt_0. +apply succ_le_lt... +apply generic_format_0. +apply generic_format_abs; apply generic_format_round... +case G2; [easy|intros; now contradict G3]. +rewrite <- mag_abs. +rewrite G, mag_bpow; auto with zarith. +intros H; unfold cexp. +now rewrite mag_round_odd. +Qed. + + + + +End Odd_propbis. + + diff --git a/flocq/Prop/Fprop_Sterbenz.v b/flocq/Prop/Sterbenz.v index 4e74f889..746b7026 100644 --- a/flocq/Prop/Fprop_Sterbenz.v +++ b/flocq/Prop/Sterbenz.v @@ -2,9 +2,9 @@ This file is part of the Flocq formalization of floating-point arithmetic in Coq: http://flocq.gforge.inria.fr/ -Copyright (C) 2010-2013 Sylvie Boldo +Copyright (C) 2010-2018 Sylvie Boldo #<br /># -Copyright (C) 2010-2013 Guillaume Melquiond +Copyright (C) 2010-2018 Guillaume Melquiond This library is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public @@ -19,10 +19,7 @@ COPYING file for more details. (** * Sterbenz conditions for exact subtraction *) -Require Import Fcore_Raux. -Require Import Fcore_defs. -Require Import Fcore_generic_fmt. -Require Import Fcalc_ops. +Require Import Raux Defs Generic_fmt Operations. Section Fprop_Sterbenz. @@ -37,7 +34,7 @@ Notation format := (generic_format beta fexp). Theorem generic_format_plus : forall x y, format x -> format y -> - (Rabs (x + y) < bpow (Zmin (ln_beta beta x) (ln_beta beta y)))%R -> + (Rabs (x + y) <= bpow (Z.min (mag beta x) (mag beta y)))%R -> format (x + y)%R. Proof. intros x y Fx Fy Hxy. @@ -48,44 +45,51 @@ destruct (Req_dec x R0) as [Zx|Zx]. now rewrite Zx, Rplus_0_l. destruct (Req_dec y R0) as [Zy|Zy]. now rewrite Zy, Rplus_0_r. +destruct Hxy as [Hxy|Hxy]. revert Hxy. -destruct (ln_beta beta x) as (ex, Ex). simpl. +destruct (mag beta x) as (ex, Ex). simpl. specialize (Ex Zx). -destruct (ln_beta beta y) as (ey, Ey). simpl. +destruct (mag beta y) as (ey, Ey). simpl. specialize (Ey Zy). intros Hxy. set (fx := Float beta (Ztrunc (scaled_mantissa beta fexp x)) (fexp ex)). assert (Hx: x = F2R fx). rewrite Fx at 1. -unfold canonic_exp. -now rewrite ln_beta_unique with (1 := Ex). +unfold cexp. +now rewrite mag_unique with (1 := Ex). set (fy := Float beta (Ztrunc (scaled_mantissa beta fexp y)) (fexp ey)). assert (Hy: y = F2R fy). rewrite Fy at 1. -unfold canonic_exp. -now rewrite ln_beta_unique with (1 := Ey). +unfold cexp. +now rewrite mag_unique with (1 := Ey). rewrite Hx, Hy. rewrite <- F2R_plus. apply generic_format_F2R. intros _. -case_eq (Fplus beta fx fy). +case_eq (Fplus fx fy). intros mxy exy Pxy. rewrite <- Pxy, F2R_plus, <- Hx, <- Hy. -unfold canonic_exp. -replace exy with (fexp (Zmin ex ey)). +unfold cexp. +replace exy with (fexp (Z.min ex ey)). apply monotone_exp. -now apply ln_beta_le_bpow. -replace exy with (Fexp (Fplus beta fx fy)) by exact (f_equal Fexp Pxy). +now apply mag_le_bpow. +replace exy with (Fexp (Fplus fx fy)) by exact (f_equal Fexp Pxy). rewrite Fexp_Fplus. simpl. clear -monotone_exp. apply sym_eq. destruct (Zmin_spec ex ey) as [(H1,H2)|(H1,H2)] ; rewrite H2. -apply Zmin_l. +apply Z.min_l. now apply monotone_exp. -apply Zmin_r. +apply Z.min_r. apply monotone_exp. apply Zlt_le_weak. -now apply Zgt_lt. +now apply Z.gt_lt. +apply generic_format_abs_inv. +rewrite Hxy. +apply generic_format_bpow. +apply valid_exp. +case (Zmin_spec (mag beta x) (mag beta y)); intros (H1,H2); + rewrite H2; now apply mag_generic_gt. Qed. Theorem generic_format_plus_weak : @@ -100,17 +104,17 @@ now rewrite Zx, Rplus_0_l. destruct (Req_dec y R0) as [Zy|Zy]. now rewrite Zy, Rplus_0_r. apply generic_format_plus ; try assumption. -apply Rle_lt_trans with (1 := Hxy). +apply Rle_trans with (1 := Hxy). unfold Rmin. destruct (Rle_dec (Rabs x) (Rabs y)) as [Hxy'|Hxy']. -rewrite Zmin_l. -destruct (ln_beta beta x) as (ex, Hx). -now apply Hx. -now apply ln_beta_le_abs. -rewrite Zmin_r. -destruct (ln_beta beta y) as (ex, Hy). -now apply Hy. -apply ln_beta_le_abs. +rewrite Z.min_l. +destruct (mag beta x) as (ex, Hx). +apply Rlt_le; now apply Hx. +now apply mag_le_abs. +rewrite Z.min_r. +destruct (mag beta y) as (ex, Hy). +apply Rlt_le; now apply Hy. +apply mag_le_abs. exact Zy. apply Rlt_le. now apply Rnot_le_lt. diff --git a/flocq/Flocq_version.v b/flocq/Version.v index 72d4fe20..d0e36a57 100644 --- a/flocq/Flocq_version.v +++ b/flocq/Version.v @@ -2,9 +2,9 @@ This file is part of the Flocq formalization of floating-point arithmetic in Coq: http://flocq.gforge.inria.fr/ -Copyright (C) 2011-2013 Sylvie Boldo +Copyright (C) 2011-2018 Sylvie Boldo #<br /># -Copyright (C) 2011-2013 Guillaume Melquiond +Copyright (C) 2011-2018 Guillaume Melquiond This library is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public @@ -29,4 +29,4 @@ Definition Flocq_version := Eval vm_compute in parse t major (minor * 10 + N_of_ascii h - N_of_ascii "0"%char)%N | Empty_string => (major * 100 + minor)%N end in - parse "2.6.1"%string N0 N0. + parse "3.1.0"%string N0 N0. diff --git a/lib/Coqlib.v b/lib/Coqlib.v index 3b8e5b3b..02c5d07f 100644 --- a/lib/Coqlib.v +++ b/lib/Coqlib.v @@ -411,42 +411,12 @@ Qed. (** Properties of Euclidean division and modulus. *) -Lemma Zdiv_small: - forall x y, 0 <= x < y -> x / y = 0. -Proof. - intros. assert (y > 0). omega. - assert (forall a b, - 0 <= a < y -> - 0 <= y * b + a < y -> - b = 0). - intros. - assert (b = 0 \/ b > 0 \/ (-b) > 0). omega. - elim H3; intro. - auto. - elim H4; intro. - assert (y * b >= y * 1). apply Zmult_ge_compat_l. omega. omega. - omegaContradiction. - assert (y * (-b) >= y * 1). apply Zmult_ge_compat_l. omega. omega. - rewrite <- Zopp_mult_distr_r in H6. omegaContradiction. - apply H1 with (x mod y). - apply Z_mod_lt. auto. - rewrite <- Z_div_mod_eq. auto. auto. -Qed. - -Lemma Zmod_small: - forall x y, 0 <= x < y -> x mod y = x. -Proof. - intros. assert (y > 0). omega. - generalize (Z_div_mod_eq x y H0). - rewrite (Zdiv_small x y H). omega. -Qed. - Lemma Zmod_unique: forall x y a b, x = a * y + b -> 0 <= b < y -> x mod y = b. Proof. intros. subst x. rewrite Z.add_comm. - rewrite Z_mod_plus. apply Zmod_small. auto. omega. + rewrite Z_mod_plus. apply Z.mod_small. auto. omega. Qed. Lemma Zdiv_unique: @@ -461,30 +431,7 @@ Lemma Zdiv_Zdiv: forall a b c, b > 0 -> c > 0 -> (a / b) / c = a / (b * c). Proof. - intros. - generalize (Z_div_mod_eq a b H). generalize (Z_mod_lt a b H). intros. - generalize (Z_div_mod_eq (a/b) c H0). generalize (Z_mod_lt (a/b) c H0). intros. - set (q1 := a / b) in *. set (r1 := a mod b) in *. - set (q2 := q1 / c) in *. set (r2 := q1 mod c) in *. - symmetry. apply Zdiv_unique with (r2 * b + r1). - rewrite H2. rewrite H4. ring. - split. - assert (0 <= r2 * b). apply Z.mul_nonneg_nonneg. omega. omega. omega. - assert ((r2 + 1) * b <= c * b). - apply Zmult_le_compat_r. omega. omega. - replace ((r2 + 1) * b) with (r2 * b + b) in H5 by ring. - replace (c * b) with (b * c) in H5 by ring. - omega. -Qed. - -Lemma Zmult_le_compat_l_neg : - forall n m p:Z, n >= m -> p <= 0 -> p * n <= p * m. -Proof. - intros. - assert ((-p) * n >= (-p) * m). apply Zmult_ge_compat_l. auto. omega. - replace (p * n) with (- ((-p) * n)) by ring. - replace (p * m) with (- ((-p) * m)) by ring. - omega. + intros. apply Z.div_div; omega. Qed. Lemma Zdiv_interval_1: @@ -516,9 +463,9 @@ Proof. intros. assert (lo <= a / b < hi+1). apply Zdiv_interval_1. omega. omega. auto. - assert (lo * b <= lo * 1). apply Zmult_le_compat_l_neg. omega. omega. + assert (lo * b <= lo * 1) by (apply Z.mul_le_mono_nonpos_l; omega). replace (lo * 1) with lo in H3 by ring. - assert ((hi + 1) * 1 <= (hi + 1) * b). apply Zmult_le_compat_l. omega. omega. + assert ((hi + 1) * 1 <= (hi + 1) * b) by (apply Z.mul_le_mono_nonneg_l; omega). replace ((hi + 1) * 1) with (hi + 1) in H4 by ring. omega. omega. @@ -529,42 +476,11 @@ Lemma Zmod_recombine: a > 0 -> b > 0 -> x mod (a * b) = ((x/b) mod a) * b + (x mod b). Proof. - intros. - set (xb := x/b). - apply Zmod_unique with (xb/a). - generalize (Z_div_mod_eq x b H0); fold xb; intro EQ1. - generalize (Z_div_mod_eq xb a H); intro EQ2. - rewrite EQ2 in EQ1. - eapply eq_trans. eexact EQ1. ring. - generalize (Z_mod_lt x b H0). intro. - generalize (Z_mod_lt xb a H). intro. - assert (0 <= xb mod a * b <= a * b - b). - split. apply Z.mul_nonneg_nonneg; omega. - replace (a * b - b) with ((a - 1) * b) by ring. - apply Zmult_le_compat; omega. - omega. + intros. rewrite (Z.mul_comm a b). rewrite Z.rem_mul_r by omega. ring. Qed. (** Properties of divisibility. *) -Lemma Zdivides_trans: - forall x y z, (x | y) -> (y | z) -> (x | z). -Proof. - intros x y z [a A] [b B]; subst. exists (a*b); ring. -Qed. - -Definition Zdivide_dec: - forall (p q: Z), p > 0 -> { (p|q) } + { ~(p|q) }. -Proof. - intros. destruct (zeq (Z.modulo q p) 0). - left. exists (q / p). - transitivity (p * (q / p) + (q mod p)). apply Z_div_mod_eq; auto. - transitivity (p * (q / p)). omega. ring. - right; red; intros. elim n. apply Z_div_exact_1; auto. - inv H0. rewrite Z_div_mult; auto. ring. -Defined. -Global Opaque Zdivide_dec. - Lemma Zdivide_interval: forall a b c, 0 < c -> 0 <= a < b -> (c | a) -> (c | b) -> 0 <= a <= b - c. @@ -577,43 +493,20 @@ Qed. (** Conversion from [Z] to [nat]. *) -Definition nat_of_Z: Z -> nat := Z.to_nat. - -Lemma nat_of_Z_of_nat: - forall n, nat_of_Z (Z.of_nat n) = n. -Proof. - exact Nat2Z.id. -Qed. - -Lemma nat_of_Z_max: - forall z, Z.of_nat (nat_of_Z z) = Z.max z 0. -Proof. - intros. unfold Z.max. destruct z; simpl; auto. - change (Z.of_nat (Z.to_nat (Zpos p)) = Zpos p). - apply Z2Nat.id. compute; intuition congruence. -Qed. - -Lemma nat_of_Z_eq: - forall z, z >= 0 -> Z.of_nat (nat_of_Z z) = z. -Proof. - unfold nat_of_Z; intros. apply Z2Nat.id. omega. -Qed. - -Lemma nat_of_Z_neg: - forall n, n <= 0 -> nat_of_Z n = O. +Lemma Z_to_nat_neg: + forall n, n <= 0 -> Z.to_nat n = O. Proof. destruct n; unfold Z.le; simpl; auto. congruence. Qed. -Lemma nat_of_Z_plus: - forall p q, - p >= 0 -> q >= 0 -> - nat_of_Z (p + q) = (nat_of_Z p + nat_of_Z q)%nat. +Lemma Z_to_nat_max: + forall z, Z.of_nat (Z.to_nat z) = Z.max z 0. Proof. - unfold nat_of_Z; intros. apply Z2Nat.inj_add; omega. + intros. destruct (zle 0 z). +- rewrite Z2Nat.id by auto. xomega. +- rewrite Z_to_nat_neg by omega. xomega. Qed. - (** Alignment: [align n amount] returns the smallest multiple of [amount] greater than or equal to [n]. *) diff --git a/lib/Floats.v b/lib/Floats.v index ba225be1..9540303b 100644 --- a/lib/Floats.v +++ b/lib/Floats.v @@ -16,12 +16,10 @@ (** Formalization of floating-point numbers, using the Flocq library. *) -Require Import Coqlib. -Require Import Integers. -Require Import Fappli_IEEE. -Require Import Fappli_IEEE_bits. -Require Import Fappli_IEEE_extra. -Require Import Fcore. +Require Import Coqlib Zbits Integers. +(*From Flocq*) +Require Import Binary Bits Core. +Require Import IEEE754_extra. Require Import Program. Require Archi. @@ -95,6 +93,17 @@ Proof. destruct x as [[]|]; simpl; intros; discriminate. Qed. +(** Relation between number of bits and base-2 logarithm *) + +Lemma digits2_log2: + forall p, Z.pos (Digits.digits2_pos p) = Z.succ (Z.log2 (Z.pos p)). +Proof. + assert (E: forall p, Digits.digits2_pos p = Pos.size p). + { induction p; simpl; rewrite ?IHp; auto. } + intros p. rewrite E. + destruct p; simpl; rewrite ?Pos.add_1_r; reflexivity. +Qed. + Local Notation __ := (eq_refl Datatypes.Lt). Local Hint Extern 1 (Prec_gt_0 _) => exact (eq_refl Datatypes.Lt). @@ -111,77 +120,81 @@ Module Float. (** Transform a Nan payload to a quiet Nan payload. *) -Program Definition transform_quiet_pl (pl:nan_pl 53) : nan_pl 53 := - Pos.lor pl (iter_nat xO 51 xH). -Next Obligation. - destruct pl. - simpl. rewrite Z.ltb_lt in *. - assert (forall x, Fcore_digits.digits2_pos x = Pos.size x). - { induction x0; simpl; auto; rewrite IHx0; zify; omega. } - rewrite H, Psize_log_inf, <- Zlog2_log_inf in *. clear H. - change (Z.pos (Pos.lor x 2251799813685248)) with (Z.lor (Z.pos x) 2251799813685248%Z). - rewrite Z.log2_lor by (zify; omega). - apply Z.max_case. auto. simpl. omega. -Qed. - -Lemma nan_payload_fequal: - forall prec (p1 p2: nan_pl prec), - proj1_sig p1 = proj1_sig p2 -> p1 = p2. +Lemma transform_quiet_nan_proof (p : positive) : + nan_pl 53 p = true -> + nan_pl 53 (Pos.lor p (iter_nat xO 51 1%positive)) = true. Proof. - intros. destruct p1, p2; simpl in H; subst. f_equal. apply Fcore_Zaux.eqbool_irrelevance. + unfold nan_pl. intros K. + simpl. rewrite Z.ltb_lt, digits2_log2 in *. + change (Z.pos (Pos.lor p 2251799813685248)) with (Z.lor (Z.pos p) 2251799813685248%Z). + rewrite Z.log2_lor by xomega. + now apply Z.max_case. Qed. -Lemma lor_idempotent: - forall x y, Pos.lor (Pos.lor x y) y = Pos.lor x y. +Definition transform_quiet_nan s p H : {x :float | is_nan _ _ x = true} := + exist _ (B754_nan 53 1024 s _ (transform_quiet_nan_proof p H)) (eq_refl true). + +(** Nan payload operations for single <-> double conversions. *) + +Lemma expand_nan_proof (p : positive) : + nan_pl 24 p = true -> + nan_pl 53 (Pos.shiftl_nat p 29) = true. Proof. - induction x; destruct y; simpl; f_equal; auto; - induction y; simpl; f_equal; auto. + unfold nan_pl. intros K. + rewrite Z.ltb_lt in *. + unfold Pos.shiftl_nat, nat_rect, Digits.digits2_pos. + fold (Digits.digits2_pos p). + zify; omega. Qed. -Lemma transform_quiet_pl_idempotent: - forall pl, transform_quiet_pl (transform_quiet_pl pl) = transform_quiet_pl pl. +Definition expand_nan s p H : {x | is_nan 53 1024 x = true} := + exist _ (B754_nan 53 1024 s _ (expand_nan_proof p H)) (eq_refl true). + +Definition of_single_nan (f : float32) : { x : float | is_nan _ _ x = true } := + match f with + | B754_nan s p H => + if Archi.float_of_single_preserves_sNaN + then expand_nan s p H + else transform_quiet_nan s _ (expand_nan_proof p H) + | _ => Archi.default_nan_64 + end. + +Lemma reduce_nan_proof (p : positive) : + nan_pl 53 p = true -> + nan_pl 24 (Pos.shiftr_nat p 29) = true. Proof. - intros. apply nan_payload_fequal; simpl. apply lor_idempotent. + unfold nan_pl. intros K. + rewrite Z.ltb_lt in *. + unfold Pos.shiftr_nat, nat_rect. + assert (H : forall x, Digits.digits2_pos (Pos.div2 x) = (Digits.digits2_pos x - 1)%positive) + by (destruct x; simpl; auto; rewrite Pplus_one_succ_r, Pos.add_sub; auto). + rewrite !H, !Pos2Z.inj_sub_max. + repeat (apply Z.max_lub_lt; [reflexivity |apply Z.lt_sub_lt_add_l]). + exact K. Qed. -(** Nan payload operations for single <-> double conversions. *) +Definition reduce_nan s p H : {x : float32 | is_nan _ _ x = true} := + exist _ (B754_nan 24 128 s _ (reduce_nan_proof p H)) (eq_refl true). -Definition expand_pl (pl: nan_pl 24) : nan_pl 53. -Proof. - refine (exist _ (Pos.shiftl_nat (proj1_sig pl) 29) _). - abstract ( - destruct pl; unfold proj1_sig, Pos.shiftl_nat, nat_rect, Fcore_digits.digits2_pos; - fold (Fcore_digits.digits2_pos x); - rewrite Z.ltb_lt in *; - zify; omega). -Defined. - -Definition of_single_pl (s:bool) (pl:nan_pl 24) : (bool * nan_pl 53) := - (s, - if Archi.float_of_single_preserves_sNaN - then expand_pl pl - else transform_quiet_pl (expand_pl pl)). - -Definition reduce_pl (pl: nan_pl 53) : nan_pl 24. -Proof. - refine (exist _ (Pos.shiftr_nat (proj1_sig pl) 29) _). - abstract ( - destruct pl; unfold proj1_sig, Pos.shiftr_nat, nat_rect; - rewrite Z.ltb_lt in *; - assert (forall x, Fcore_digits.digits2_pos (Pos.div2 x) = - (Fcore_digits.digits2_pos x - 1)%positive) - by (destruct x0; simpl; auto; rewrite Pplus_one_succ_r, Pos.add_sub; auto); - rewrite !H, !Pos2Z.inj_sub_max; - repeat (apply Z.max_lub_lt; [reflexivity |apply Z.lt_sub_lt_add_l]); auto). -Defined. - -Definition to_single_pl (s:bool) (pl:nan_pl 53) : (bool * nan_pl 24) := - (s, reduce_pl (transform_quiet_pl pl)). +Definition to_single_nan (f : float) : { x : float32 | is_nan _ _ x = true } := + match f with + | B754_nan s p H => reduce_nan s _ (transform_quiet_nan_proof p H) + | _ => Archi.default_nan_32 + end. (** NaN payload operations for opposite and absolute value. *) -Definition neg_pl (s:bool) (pl:nan_pl 53) := (negb s, pl). -Definition abs_pl (s:bool) (pl:nan_pl 53) := (false, pl). +Definition neg_nan (f : float) : { x : float | is_nan _ _ x = true } := + match f with + | B754_nan s p H => exist _ (B754_nan 53 1024 (negb s) p H) (eq_refl true) + | _ => Archi.default_nan_64 + end. + +Definition abs_nan (f : float) : { x : float | is_nan _ _ x = true } := + match f with + | B754_nan s p H => exist _ (B754_nan 53 1024 false p H) (eq_refl true) + | _ => Archi.default_nan_64 + end. (** The NaN payload operations for two-argument arithmetic operations are not part of the IEEE754 standard, but all architectures of @@ -191,15 +204,16 @@ Definition abs_pl (s:bool) (pl:nan_pl 53) := (false, pl). - a choice function determining which of the payload arguments to choose, when an operation is given two NaN arguments. *) -Definition binop_pl (x y: binary64) : bool*nan_pl 53 := +Definition binop_nan (x y : float) : {x : float | is_nan 53 1024 x = true} := + if Archi.fpu_returns_default_qNaN then Archi.default_nan_64 else match x, y with - | B754_nan s1 pl1, B754_nan s2 pl2 => - if Archi.choose_binop_pl_64 s1 pl1 s2 pl2 - then (s2, transform_quiet_pl pl2) - else (s1, transform_quiet_pl pl1) - | B754_nan s1 pl1, _ => (s1, transform_quiet_pl pl1) - | _, B754_nan s2 pl2 => (s2, transform_quiet_pl pl2) - | _, _ => Archi.default_pl_64 + | B754_nan s1 pl1 H1, B754_nan s2 pl2 H2 => + if Archi.choose_binop_pl_64 pl1 pl2 + then transform_quiet_nan s2 pl2 H2 + else transform_quiet_nan s1 pl1 H1 + | B754_nan s1 pl1 H1, _ => transform_quiet_nan s1 pl1 H1 + | _, B754_nan s2 pl2 H2 => transform_quiet_nan s2 pl2 H2 + | _, _ => Archi.default_nan_64 end. (** ** Operations over double-precision floats *) @@ -210,16 +224,16 @@ Definition eq_dec: forall (f1 f2: float), {f1 = f2} + {f1 <> f2} := Beq_dec _ _. (** Arithmetic operations *) -Definition neg: float -> float := Bopp _ _ neg_pl. (**r opposite (change sign) *) -Definition abs: float -> float := Babs _ _ abs_pl. (**r absolute value (set sign to [+]) *) +Definition neg: float -> float := Bopp _ _ neg_nan. (**r opposite (change sign) *) +Definition abs: float -> float := Babs _ _ abs_nan. (**r absolute value (set sign to [+]) *) Definition add: float -> float -> float := - Bplus 53 1024 __ __ binop_pl mode_NE. (**r addition *) + Bplus 53 1024 __ __ binop_nan mode_NE. (**r addition *) Definition sub: float -> float -> float := - Bminus 53 1024 __ __ binop_pl mode_NE. (**r subtraction *) + Bminus 53 1024 __ __ binop_nan mode_NE. (**r subtraction *) Definition mul: float -> float -> float := - Bmult 53 1024 __ __ binop_pl mode_NE. (**r multiplication *) + Bmult 53 1024 __ __ binop_nan mode_NE. (**r multiplication *) Definition div: float -> float -> float := - Bdiv 53 1024 __ __ binop_pl mode_NE. (**r division *) + Bdiv 53 1024 __ __ binop_nan mode_NE. (**r division *) Definition compare (f1 f2: float) : option Datatypes.comparison := (**r general comparison *) Bcompare 53 1024 f1 f2. Definition cmp (c:comparison) (f1 f2: float) : bool := (**r Boolean comparison *) @@ -229,8 +243,8 @@ Definition ordered (f1 f2: float) : bool := (** Conversions *) -Definition of_single: float32 -> float := Bconv _ _ 53 1024 __ __ of_single_pl mode_NE. -Definition to_single: float -> float32 := Bconv _ _ 24 128 __ __ to_single_pl mode_NE. +Definition of_single: float32 -> float := Bconv _ _ 53 1024 __ __ of_single_nan mode_NE. +Definition to_single: float -> float32 := Bconv _ _ 24 128 __ __ to_single_nan mode_NE. Definition to_int (f:float): option int := (**r conversion to signed 32-bit int *) option_map Int.repr (ZofB_range _ _ f Int.min_signed Int.max_signed). @@ -287,15 +301,19 @@ Ltac smart_omega := Theorem add_commut: forall x y, is_nan _ _ x = false \/ is_nan _ _ y = false -> add x y = add y x. Proof. - intros. apply Bplus_commut. - destruct x, y; try reflexivity. simpl in H. intuition congruence. + intros. apply Bplus_commut. unfold binop_nan. + destruct Archi.fpu_returns_default_qNaN. easy. + destruct x, y; try reflexivity. + now destruct H. Qed. Theorem mul_commut: forall x y, is_nan _ _ x = false \/ is_nan _ _ y = false -> mul x y = mul y x. Proof. - intros. apply Bmult_commut. - destruct x, y; try reflexivity. simpl in H. intuition congruence. + intros. apply Bmult_commut. unfold binop_nan. + destruct Archi.fpu_returns_default_qNaN. easy. + destruct x, y; try reflexivity. + now destruct H. Qed. (** Multiplication by 2 is diagonal addition. *) @@ -304,10 +322,10 @@ Theorem mul2_add: forall f, add f f = mul f (of_int (Int.repr 2%Z)). Proof. intros. apply Bmult2_Bplus. - intros. destruct x; try discriminate. simpl. - transitivity (b, transform_quiet_pl n). - destruct Archi.choose_binop_pl_64; auto. - destruct y; auto || discriminate. + intros x y Hx Hy. unfold binop_nan. + destruct Archi.fpu_returns_default_qNaN. easy. + destruct x as [| |sx px Nx|]; try discriminate. + now destruct y, Archi.choose_binop_pl_64. Qed. (** Divisions that can be turned into multiplication by an inverse. *) @@ -317,11 +335,11 @@ Definition exact_inverse : float -> option float := Bexact_inverse 53 1024 __ __ Theorem div_mul_inverse: forall x y z, exact_inverse y = Some z -> div x y = mul x z. Proof. - intros. apply Bdiv_mult_inverse; auto. - intros. destruct x0; try discriminate. simpl. - transitivity (b, transform_quiet_pl n). - destruct y0; reflexivity || discriminate. - destruct z0; reflexivity || discriminate. + intros. apply Bdiv_mult_inverse. 2: easy. + intros x0 y0 z0 Hx Hy Hz. unfold binop_nan. + destruct Archi.fpu_returns_default_qNaN. easy. + destruct x0 as [| |sx px Nx|]; try discriminate. + now destruct y0, z0. Qed. (** Properties of comparisons. *) @@ -451,7 +469,7 @@ Proof. rewrite Bcompare_correct in CMP by auto. inv CMP. apply Rcompare_Lt_inv in H1. rewrite EQy in H1. assert (p < Int.unsigned ox8000_0000). - { apply lt_Z2R. eapply Rle_lt_trans; eauto. } + { apply lt_IZR. apply Rle_lt_trans with (1 := P) (2 := H1). } change Int.max_signed with (Int.unsigned ox8000_0000 - 1). omega. Qed. @@ -471,7 +489,7 @@ Proof. intros (EQy & FINy & SIGNy). assert (FINx: is_finite _ _ x = true). { rewrite ZofB_correct in C. destruct (is_finite _ _ x) eqn:FINx; congruence. } - assert (GE: (B2R _ _ x >= Z2R (Int.unsigned ox8000_0000))%R). + assert (GE: (B2R _ _ x >= IZR (Int.unsigned ox8000_0000))%R). { rewrite <- EQy. unfold cmp, cmp_of_comparison, compare in H. rewrite Bcompare_correct in H by auto. destruct (Rcompare (B2R 53 1024 x) (B2R 53 1024 y)) eqn:CMP. @@ -502,7 +520,6 @@ Proof. transitivity (split_bits 52 11 (join_bits 52 11 false (Int.unsigned x) 1075)). - f_equal. rewrite Int64.ofwords_add'. reflexivity. - apply split_join_bits. - compute; auto. generalize (Int.unsigned_range x). compute_this Int.modulus; compute_this (2^52); omega. compute_this (2^11); omega. @@ -510,7 +527,7 @@ Qed. Lemma from_words_value: forall x, - B2R _ _ (from_words ox4330_0000 x) = (bpow radix2 52 + Z2R (Int.unsigned x))%R + B2R _ _ (from_words ox4330_0000 x) = (bpow radix2 52 + IZR (Int.unsigned x))%R /\ is_finite _ _ (from_words ox4330_0000 x) = true /\ Bsign _ _ (from_words ox4330_0000 x) = false. Proof. @@ -520,7 +537,7 @@ Proof. destruct (Int.unsigned x + Z.pow_pos 2 52) eqn:?. exfalso; now smart_omega. simpl; rewrite <- Heqz; unfold F2R; simpl. split; auto. - rewrite <- (Z2R_plus 4503599627370496), Rmult_1_r. f_equal. rewrite Z.add_comm. auto. + rewrite Rmult_1_r, plus_IZR. apply Rplus_comm. exfalso; now smart_omega. Qed. @@ -533,7 +550,7 @@ Proof. destruct (BofZ_exact 53 1024 __ __ (2^52 + Int.unsigned x)) as (D & E & F). smart_omega. apply B2R_Bsign_inj; auto. - rewrite A, D. rewrite Z2R_plus. auto. + rewrite A, D. rewrite plus_IZR. auto. rewrite C, F. symmetry. apply Zlt_bool_false. smart_omega. Qed. @@ -585,7 +602,6 @@ Proof. transitivity (split_bits 52 11 (join_bits 52 11 false (Int.unsigned x) 1107)). - f_equal. rewrite Int64.ofwords_add'. reflexivity. - apply split_join_bits. - compute; auto. generalize (Int.unsigned_range x). compute_this Int.modulus; compute_this (2^52); omega. compute_this (2^11); omega. @@ -593,7 +609,7 @@ Qed. Lemma from_words_value': forall x, - B2R _ _ (from_words ox4530_0000 x) = (bpow radix2 84 + Z2R (Int.unsigned x * two_p 32))%R + B2R _ _ (from_words ox4530_0000 x) = (bpow radix2 84 + IZR (Int.unsigned x * two_p 32))%R /\ is_finite _ _ (from_words ox4530_0000 x) = true /\ Bsign _ _ (from_words ox4530_0000 x) = false. Proof. @@ -603,8 +619,8 @@ Proof. destruct (Int.unsigned x + Z.pow_pos 2 52) eqn:?. exfalso; now smart_omega. simpl; rewrite <- Heqz; unfold F2R; simpl. split; auto. - rewrite <- (Z2R_plus 19342813113834066795298816), <- (Z2R_mult _ 4294967296). - f_equal; compute_this (Z.pow_pos 2 52); compute_this (two_power_pos 32); ring. + rewrite plus_IZR, Rmult_plus_distr_r, <- 2!mult_IZR, Rplus_comm. + easy. assert (Zneg p < 0) by reflexivity. exfalso; now smart_omega. Qed. @@ -620,7 +636,7 @@ Proof. with ((2^52 + Int.unsigned x) * 2^32) by ring. apply integer_representable_n2p; auto. smart_omega. omega. omega. apply B2R_Bsign_inj; auto. - rewrite A, D. rewrite <- Z2R_Zpower by omega. rewrite <- Z2R_plus. auto. + rewrite A, D. rewrite <- IZR_Zpower by omega. rewrite <- plus_IZR. auto. rewrite C, F. symmetry. apply Zlt_bool_false. compute_this (2^84); compute_this (2^32); omega. Qed. @@ -904,38 +920,42 @@ Module Float32. (** ** NaN payload manipulations *) -Program Definition transform_quiet_pl (pl:nan_pl 24) : nan_pl 24 := - Pos.lor pl (iter_nat xO 22 xH). -Next Obligation. - destruct pl. - simpl. rewrite Z.ltb_lt in *. - assert (forall x, Fcore_digits.digits2_pos x = Pos.size x). - { induction x0; simpl; auto; rewrite IHx0; zify; omega. } - rewrite H, Psize_log_inf, <- Zlog2_log_inf in *. clear H. - change (Z.pos (Pos.lor x 4194304)) with (Z.lor (Z.pos x) 4194304%Z). - rewrite Z.log2_lor by (zify; omega). - apply Z.max_case. auto. simpl. omega. -Qed. - -Lemma transform_quiet_pl_idempotent: - forall pl, transform_quiet_pl (transform_quiet_pl pl) = transform_quiet_pl pl. +Lemma transform_quiet_nan_proof (p : positive) : + nan_pl 24 p = true -> + nan_pl 24 (Pos.lor p (iter_nat xO 22 1%positive)) = true. Proof. - intros []; simpl; intros. apply Float.nan_payload_fequal. - simpl. apply Float.lor_idempotent. + unfold nan_pl. intros K. + simpl. rewrite Z.ltb_lt, digits2_log2 in *. + change (Z.pos (Pos.lor p 4194304)) with (Z.lor (Z.pos p) 4194304%Z). + rewrite Z.log2_lor by xomega. + now apply Z.max_case. Qed. -Definition neg_pl (s:bool) (pl:nan_pl 24) := (negb s, pl). -Definition abs_pl (s:bool) (pl:nan_pl 24) := (false, pl). +Definition transform_quiet_nan s p H : {x : float32 | is_nan _ _ x = true} := + exist _ (B754_nan 24 128 s _ (transform_quiet_nan_proof p H)) (eq_refl true). + +Definition neg_nan (f : float32) : { x : float32 | is_nan _ _ x = true } := + match f with + | B754_nan s p H => exist _ (B754_nan 24 128 (negb s) p H) (eq_refl true) + | _ => Archi.default_nan_32 + end. + +Definition abs_nan (f : float32) : { x : float32 | is_nan _ _ x = true } := + match f with + | B754_nan s p H => exist _ (B754_nan 24 128 false p H) (eq_refl true) + | _ => Archi.default_nan_32 + end. -Definition binop_pl (x y: binary32) : bool*nan_pl 24 := +Definition binop_nan (x y : float32) : {x : float32 | is_nan _ _ x = true} := + if Archi.fpu_returns_default_qNaN then Archi.default_nan_32 else match x, y with - | B754_nan s1 pl1, B754_nan s2 pl2 => - if Archi.choose_binop_pl_32 s1 pl1 s2 pl2 - then (s2, transform_quiet_pl pl2) - else (s1, transform_quiet_pl pl1) - | B754_nan s1 pl1, _ => (s1, transform_quiet_pl pl1) - | _, B754_nan s2 pl2 => (s2, transform_quiet_pl pl2) - | _, _ => Archi.default_pl_32 + | B754_nan s1 pl1 H1, B754_nan s2 pl2 H2 => + if Archi.choose_binop_pl_32 pl1 pl2 + then transform_quiet_nan s2 pl2 H2 + else transform_quiet_nan s1 pl1 H1 + | B754_nan s1 pl1 H1, _ => transform_quiet_nan s1 pl1 H1 + | _, B754_nan s2 pl2 H2 => transform_quiet_nan s2 pl2 H2 + | _, _ => Archi.default_nan_32 end. (** ** Operations over single-precision floats *) @@ -946,16 +966,16 @@ Definition eq_dec: forall (f1 f2: float32), {f1 = f2} + {f1 <> f2} := Beq_dec _ (** Arithmetic operations *) -Definition neg: float32 -> float32 := Bopp _ _ neg_pl. (**r opposite (change sign) *) -Definition abs: float32 -> float32 := Babs _ _ abs_pl. (**r absolute value (set sign to [+]) *) +Definition neg: float32 -> float32 := Bopp _ _ neg_nan. (**r opposite (change sign) *) +Definition abs: float32 -> float32 := Babs _ _ abs_nan. (**r absolute value (set sign to [+]) *) Definition add: float32 -> float32 -> float32 := - Bplus 24 128 __ __ binop_pl mode_NE. (**r addition *) + Bplus 24 128 __ __ binop_nan mode_NE. (**r addition *) Definition sub: float32 -> float32 -> float32 := - Bminus 24 128 __ __ binop_pl mode_NE. (**r subtraction *) + Bminus 24 128 __ __ binop_nan mode_NE. (**r subtraction *) Definition mul: float32 -> float32 -> float32 := - Bmult 24 128 __ __ binop_pl mode_NE. (**r multiplication *) + Bmult 24 128 __ __ binop_nan mode_NE. (**r multiplication *) Definition div: float32 -> float32 -> float32 := - Bdiv 24 128 __ __ binop_pl mode_NE. (**r division *) + Bdiv 24 128 __ __ binop_nan mode_NE. (**r division *) Definition compare (f1 f2: float32) : option Datatypes.comparison := (**r general comparison *) Bcompare 24 128 f1 f2. Definition cmp (c:comparison) (f1 f2: float32) : bool := (**r comparison *) @@ -1003,15 +1023,19 @@ Definition of_bits (b: int): float32 := b32_of_bits (Int.unsigned b). Theorem add_commut: forall x y, is_nan _ _ x = false \/ is_nan _ _ y = false -> add x y = add y x. Proof. - intros. apply Bplus_commut. - destruct x, y; try reflexivity. simpl in H. intuition congruence. + intros. apply Bplus_commut. unfold binop_nan. + destruct Archi.fpu_returns_default_qNaN. easy. + destruct x, y; try reflexivity. + now destruct H. Qed. Theorem mul_commut: forall x y, is_nan _ _ x = false \/ is_nan _ _ y = false -> mul x y = mul y x. Proof. - intros. apply Bmult_commut. - destruct x, y; try reflexivity. simpl in H. intuition congruence. + intros. apply Bmult_commut. unfold binop_nan. + destruct Archi.fpu_returns_default_qNaN. easy. + destruct x, y; try reflexivity. + now destruct H. Qed. (** Multiplication by 2 is diagonal addition. *) @@ -1020,10 +1044,10 @@ Theorem mul2_add: forall f, add f f = mul f (of_int (Int.repr 2%Z)). Proof. intros. apply Bmult2_Bplus. - intros. destruct x; try discriminate. simpl. - transitivity (b, transform_quiet_pl n). - destruct Archi.choose_binop_pl_32; auto. - destruct y; auto || discriminate. + intros x y Hx Hy. unfold binop_nan. + destruct Archi.fpu_returns_default_qNaN. easy. + destruct x as [| |sx px Nx|]; try discriminate. + now destruct y, Archi.choose_binop_pl_32. Qed. (** Divisions that can be turned into multiplication by an inverse. *) @@ -1033,11 +1057,11 @@ Definition exact_inverse : float32 -> option float32 := Bexact_inverse 24 128 __ Theorem div_mul_inverse: forall x y z, exact_inverse y = Some z -> div x y = mul x z. Proof. - intros. apply Bdiv_mult_inverse; auto. - intros. destruct x0; try discriminate. simpl. - transitivity (b, transform_quiet_pl n). - destruct y0; reflexivity || discriminate. - destruct z0; reflexivity || discriminate. + intros. apply Bdiv_mult_inverse. 2: easy. + intros x0 y0 z0 Hx Hy Hz. unfold binop_nan. + destruct Archi.fpu_returns_default_qNaN. easy. + destruct x0 as [| |sx px Nx|]; try discriminate. + now destruct y0, z0. Qed. (** Properties of comparisons. *) @@ -1193,7 +1217,7 @@ Proof. set (m := n mod 2^p + (2^p-1)) in *. assert (C: m / 2^p = if zeq (n mod 2^p) 0 then 0 else 1). { unfold m. destruct (zeq (n mod 2^p) 0). - rewrite e. apply Zdiv_small. omega. + rewrite e. apply Z.div_small. omega. eapply Zdiv_unique with (n mod 2^p - 1). ring. omega. } assert (D: Z.testbit m p = if zeq (n mod 2^p) 0 then false else true). { destruct (zeq (n mod 2^p) 0). @@ -1201,7 +1225,7 @@ Proof. apply Z.testbit_true; auto. rewrite C; auto. } assert (E: forall i, p < i -> Z.testbit m i = false). { intros. apply Z.testbit_false. omega. - replace (m / 2^i) with 0. auto. symmetry. apply Zdiv_small. + replace (m / 2^i) with 0. auto. symmetry. apply Z.div_small. unfold m. split. omega. apply Z.lt_le_trans with (2 * 2^p). omega. change 2 with (2^1) at 1. rewrite <- (Zpower_plus radix2) by omega. apply Zpower_le. omega. } @@ -1264,7 +1288,7 @@ Proof. intros. pose proof (Int64.unsigned_range n). unfold of_longu. erewrite of_long_round_odd. - unfold of_double, Float.to_single. instantiate (1 := Float.to_single_pl). + unfold of_double, Float.to_single. instantiate (1 := Float.to_single_nan). f_equal. unfold Float.of_longu. f_equal. set (n' := Z.land (Z.lor (Int64.unsigned n) (Z.land (Int64.unsigned n) 2047 + 2047)) (-2048)). assert (int_round_odd (Int64.unsigned n) 11 = n') by (apply int_round_odd_plus; omega). @@ -1310,7 +1334,7 @@ Proof. intros. pose proof (Int64.signed_range n). unfold of_long. erewrite of_long_round_odd. - unfold of_double, Float.to_single. instantiate (1 := Float.to_single_pl). + unfold of_double, Float.to_single. instantiate (1 := Float.to_single_nan). f_equal. unfold Float.of_long. f_equal. set (n' := Z.land (Z.lor (Int64.signed n) (Z.land (Int64.signed n) 2047 + 2047)) (-2048)). assert (int_round_odd (Int64.signed n) 11 = n') by (apply int_round_odd_plus; omega). @@ -1331,9 +1355,9 @@ Proof. rewrite Int64.testbit_repr by auto. f_equal. f_equal. unfold Int64.and. change (Int64.unsigned (Int64.repr 2047)) with 2047. change 2047 with (Z.ones 11). rewrite ! Z.land_ones by omega. - rewrite Int64.unsigned_repr. apply Int64.eqmod_mod_eq. + rewrite Int64.unsigned_repr. apply eqmod_mod_eq. apply Z.lt_gt. apply (Zpower_gt_0 radix2); omega. - apply Int64.eqmod_divides with (2^64). apply Int64.eqm_signed_unsigned. + apply eqmod_divides with (2^64). apply Int64.eqm_signed_unsigned. exists (2^(64-11)); auto. exploit (Z_mod_lt (Int64.unsigned n) (2^11)). compute; auto. assert (2^11 < Int64.max_unsigned) by (compute; auto). omega. diff --git a/lib/Heaps.v b/lib/Heaps.v index 2a21f88c..9fa07a1d 100644 --- a/lib/Heaps.v +++ b/lib/Heaps.v @@ -432,7 +432,7 @@ Lemma lt_heap_In: Proof. induction h; simpl; intros. contradiction. - intuition. apply le_lt_trans with x0; auto. red. left. apply E.eq_sym; auto. + intuition. apply le_lt_trans with x0; auto. red. left. assumption. Qed. Lemma findMax_max: diff --git a/lib/Fappli_IEEE_extra.v b/lib/IEEE754_extra.v index 85fadc16..c23149be 100644 --- a/lib/Fappli_IEEE_extra.v +++ b/lib/IEEE754_extra.v @@ -20,15 +20,8 @@ Require Import Psatz. Require Import Bool. Require Import Eqdep_dec. -Require Import Fcore. -Require Import Fcore_digits. -Require Import Fcalc_digits. -Require Import Fcalc_ops. -Require Import Fcalc_round. -Require Import Fcalc_bracket. -Require Import Fprop_Sterbenz. -Require Import Fappli_IEEE. -Require Import Fappli_rnd_odd. +(*From Flocq *) +Require Import Core Digits Operations Round Bracket Sterbenz Binary Round_odd. Local Open Scope Z_scope. @@ -65,7 +58,7 @@ Definition is_finite_pos0 (f: binary_float) : bool := match f with | B754_zero _ _ s => negb s | B754_infinity _ _ _ => false - | B754_nan _ _ _ _ => false + | B754_nan _ _ _ _ _ => false | B754_finite _ _ _ _ _ _ => true end. @@ -74,10 +67,10 @@ Lemma Bsign_pos0: Proof. intros. destruct x as [ [] | | | [] ex mx Bx ]; try discriminate; simpl. - rewrite Rlt_bool_false; auto. lra. -- rewrite Rlt_bool_true; auto. apply F2R_lt_0_compat. compute; auto. +- rewrite Rlt_bool_true; auto. apply F2R_lt_0. compute; auto. - rewrite Rlt_bool_false; auto. assert ((F2R (Float radix2 (Z.pos ex) mx) > 0)%R) by - ( apply F2R_gt_0_compat; compute; auto ). + ( apply F2R_gt_0; compute; auto ). lra. Qed. @@ -101,18 +94,18 @@ Proof. assert (UIP_bool: forall (b1 b2: bool) (e e': b1 = b2), e = e'). { intros. apply UIP_dec. decide equality. } Ltac try_not_eq := try solve [right; congruence]. - destruct f1 as [| |? []|], f2 as [| |? []|]; - try destruct b; try destruct b0; + destruct f1 as [s1|s1|s1 p1 H1|s1 m1 e1 H1], f2 as [s2|s2|s2 p2 H2|s2 m2 e2 H2]; + try destruct s1; try destruct s2; try solve [left; auto]; try_not_eq. - destruct (Pos.eq_dec x x0); try_not_eq; + destruct (Pos.eq_dec p1 p2); try_not_eq; subst; left; f_equal; f_equal; apply UIP_bool. - destruct (Pos.eq_dec x x0); try_not_eq; + destruct (Pos.eq_dec p1 p2); try_not_eq; subst; left; f_equal; f_equal; apply UIP_bool. - destruct (Pos.eq_dec m m0); try_not_eq; - destruct (Z.eq_dec e e1); try solve [right; intro H; inversion H; congruence]; + destruct (Pos.eq_dec m1 m2); try_not_eq; + destruct (Z.eq_dec e1 e2); try solve [right; intro H; inversion H; congruence]; subst; left; f_equal; apply UIP_bool. - destruct (Pos.eq_dec m m0); try_not_eq; - destruct (Z.eq_dec e e1); try solve [right; intro H; inversion H; congruence]; + destruct (Pos.eq_dec m1 m2); try_not_eq; + destruct (Z.eq_dec e1 e2); try solve [right; intro H; inversion H; congruence]; subst; left; f_equal; apply UIP_bool. Defined. @@ -121,7 +114,7 @@ Defined. (** Integers that can be represented exactly as FP numbers. *) Definition integer_representable (n: Z): Prop := - Z.abs n <= 2^emax - 2^(emax - prec) /\ generic_format radix2 fexp (Z2R n). + Z.abs n <= 2^emax - 2^(emax - prec) /\ generic_format radix2 fexp (IZR n). Let int_upper_bound_eq: 2^emax - 2^(emax - prec) = (2^prec - 1) * 2^(emax - prec). Proof. @@ -142,9 +135,9 @@ Proof. rewrite Z.abs_mul. f_equal. rewrite Z.abs_eq. auto. apply (Zpower_ge_0 radix2). - apply generic_format_FLT. exists (Float radix2 n p). unfold F2R; simpl. - split. rewrite <- Z2R_Zpower by auto. apply Z2R_mult. - split. zify; omega. - unfold emin; red in prec_gt_0_; omega. + rewrite <- IZR_Zpower by auto. apply mult_IZR. + simpl; zify; omega. + unfold emin, Fexp; red in prec_gt_0_; omega. Qed. Lemma integer_representable_2p: @@ -166,16 +159,16 @@ Proof. - red in prec_gt_0_. apply generic_format_FLT. exists (Float radix2 1 p). unfold F2R; simpl. - split. rewrite Rmult_1_l. rewrite <- Z2R_Zpower. auto. omega. - split. change 1 with (2^0). apply (Zpower_lt radix2). omega. auto. - unfold emin; omega. + rewrite Rmult_1_l. rewrite <- IZR_Zpower. auto. omega. + simpl Z.abs. change 1 with (2^0). apply (Zpower_lt radix2). omega. auto. + unfold emin, Fexp; omega. Qed. Lemma integer_representable_opp: forall n, integer_representable n -> integer_representable (-n). Proof. intros n (A & B); split. rewrite Z.abs_opp. auto. - rewrite Z2R_opp. apply generic_format_opp; auto. + rewrite opp_IZR. apply generic_format_opp; auto. Qed. Lemma integer_representable_n2p_wide: @@ -204,19 +197,20 @@ Qed. Lemma round_int_no_overflow: forall n, Z.abs n <= 2^emax - 2^(emax-prec) -> - (Rabs (round radix2 fexp (round_mode mode_NE) (Z2R n)) < bpow radix2 emax)%R. + (Rabs (round radix2 fexp (round_mode mode_NE) (IZR n)) < bpow radix2 emax)%R. Proof. intros. red in prec_gt_0_. rewrite <- round_NE_abs. - apply Rle_lt_trans with (Z2R (2^emax - 2^(emax-prec))). + apply Rle_lt_trans with (IZR (2^emax - 2^(emax-prec))). apply round_le_generic. apply fexp_correct; auto. apply valid_rnd_N. apply generic_format_FLT. exists (Float radix2 (2^prec-1) (emax-prec)). rewrite int_upper_bound_eq. unfold F2R; simpl. - split. rewrite <- Z2R_Zpower by omega. rewrite <- Z2R_mult. auto. - split. assert (0 < 2^prec) by (apply (Zpower_gt_0 radix2); omega). zify; omega. - unfold emin; omega. - rewrite <- Z2R_abs. apply Z2R_le. auto. - rewrite <- Z2R_Zpower by omega. apply Z2R_lt. simpl. + rewrite <- IZR_Zpower by omega. rewrite <- mult_IZR. auto. + assert (0 < 2^prec) by (apply (Zpower_gt_0 radix2); omega). + unfold Fnum; simpl; zify; omega. + unfold emin, Fexp; omega. + rewrite <- abs_IZR. apply IZR_le. auto. + rewrite <- IZR_Zpower by omega. apply IZR_lt. simpl. assert (0 < 2^(emax-prec)) by (apply (Zpower_gt_0 radix2); omega). omega. apply fexp_correct. auto. @@ -229,9 +223,9 @@ Definition BofZ (n: Z) : binary_float := Theorem BofZ_correct: forall n, - if Rlt_bool (Rabs (round radix2 fexp (round_mode mode_NE) (Z2R n))) (bpow radix2 emax) + if Rlt_bool (Rabs (round radix2 fexp (round_mode mode_NE) (IZR n))) (bpow radix2 emax) then - B2R prec emax (BofZ n) = round radix2 fexp (round_mode mode_NE) (Z2R n) /\ + B2R prec emax (BofZ n) = round radix2 fexp (round_mode mode_NE) (IZR n) /\ is_finite _ _ (BofZ n) = true /\ Bsign prec emax (BofZ n) = Z.ltb n 0 else @@ -240,24 +234,24 @@ Proof. intros. generalize (binary_normalize_correct prec emax prec_gt_0_ Hmax mode_NE n 0 false). fold emin; fold fexp; fold (BofZ n). - replace (F2R {| Fnum := n; Fexp := 0 |}) with (Z2R n). + replace (F2R {| Fnum := n; Fexp := 0 |}) with (IZR n). destruct Rlt_bool. - intros (A & B & C). split; [|split]. + auto. + auto. - + rewrite C. change 0%R with (Z2R 0). rewrite Rcompare_Z2R. + + rewrite C. rewrite Rcompare_IZR. unfold Z.ltb. auto. -- intros A; rewrite A. f_equal. change 0%R with (Z2R 0). +- intros A; rewrite A. f_equal. generalize (Z.ltb_spec n 0); intros SPEC; inversion SPEC. - apply Rlt_bool_true; apply Z2R_lt; auto. - apply Rlt_bool_false; apply Z2R_le; auto. + apply Rlt_bool_true; apply IZR_lt; auto. + apply Rlt_bool_false; apply IZR_le; auto. - unfold F2R; simpl. ring. Qed. Theorem BofZ_finite: forall n, Z.abs n <= 2^emax - 2^(emax-prec) -> - B2R _ _ (BofZ n) = round radix2 fexp (round_mode mode_NE) (Z2R n) + B2R _ _ (BofZ n) = round radix2 fexp (round_mode mode_NE) (IZR n) /\ is_finite _ _ (BofZ n) = true /\ Bsign _ _ (BofZ n) = Z.ltb n 0%Z. Proof. @@ -269,7 +263,7 @@ Qed. Theorem BofZ_representable: forall n, integer_representable n -> - B2R _ _ (BofZ n) = Z2R n + B2R _ _ (BofZ n) = IZR n /\ is_finite _ _ (BofZ n) = true /\ Bsign _ _ (BofZ n) = (n <? 0). Proof. @@ -280,7 +274,7 @@ Qed. Theorem BofZ_exact: forall n, -2^prec <= n <= 2^prec -> - B2R _ _ (BofZ n) = Z2R n + B2R _ _ (BofZ n) = IZR n /\ is_finite _ _ (BofZ n) = true /\ Bsign _ _ (BofZ n) = Z.ltb n 0%Z. Proof. @@ -294,20 +288,19 @@ Proof. intros. generalize (binary_normalize_correct prec emax prec_gt_0_ Hmax mode_NE n 0 false). fold emin; fold fexp; fold (BofZ n). - replace (F2R {| Fnum := n; Fexp := 0 |}) with (Z2R n) by + replace (F2R {| Fnum := n; Fexp := 0 |}) with (IZR n) by (unfold F2R; simpl; ring). rewrite Rlt_bool_true by (apply round_int_no_overflow; auto). intros (A & B & C). destruct (BofZ n); auto; try discriminate. - simpl in *. rewrite C. change 0%R with (Z2R 0). rewrite Rcompare_Z2R. + simpl in *. rewrite C. rewrite Rcompare_IZR. generalize (Zcompare_spec n 0); intros SPEC; inversion SPEC; auto. - assert ((round radix2 fexp ZnearestE (Z2R n) <= -1)%R). - { change (-1)%R with (Z2R (-1)). - apply round_le_generic. apply fexp_correct. auto. apply valid_rnd_N. + assert ((round radix2 fexp ZnearestE (IZR n) <= -1)%R). + { apply round_le_generic. apply fexp_correct. auto. apply valid_rnd_N. apply (integer_representable_opp 1). apply (integer_representable_2p 0). red in prec_gt_0_; omega. - apply Z2R_le; omega. + apply IZR_le; omega. } lra. Qed. @@ -334,13 +327,13 @@ Proof. destruct (BofZ_representable q) as (D & E & F); auto. generalize (Bplus_correct _ _ _ Hmax nan mode_NE (BofZ p) (BofZ q) B E). fold emin; fold fexp. - rewrite A, D. rewrite <- Z2R_plus. + rewrite A, D. rewrite <- plus_IZR. generalize (BofZ_correct (p + q)). destruct Rlt_bool. - intros (P & Q & R) (U & V & W). apply B2R_Bsign_inj; auto. rewrite P, U; auto. rewrite R, W, C, F. - change 0%R with (Z2R 0). rewrite Rcompare_Z2R. unfold Z.ltb at 3. + rewrite Rcompare_IZR. unfold Z.ltb at 3. generalize (Zcompare_spec (p + q) 0); intros SPEC; inversion SPEC; auto. assert (EITHER: 0 <= p \/ 0 <= q) by omega. destruct EITHER; [apply andb_false_intro1 | apply andb_false_intro2]; @@ -364,13 +357,13 @@ Proof. destruct (BofZ_representable q) as (D & E & F); auto. generalize (Bminus_correct _ _ _ Hmax nan mode_NE (BofZ p) (BofZ q) B E). fold emin; fold fexp. - rewrite A, D. rewrite <- Z2R_minus. + rewrite A, D. rewrite <- minus_IZR. generalize (BofZ_correct (p - q)). destruct Rlt_bool. - intros (P & Q & R) (U & V & W). apply B2R_Bsign_inj; auto. rewrite P, U; auto. rewrite R, W, C, F. - change 0%R with (Z2R 0). rewrite Rcompare_Z2R. unfold Z.ltb at 3. + rewrite Rcompare_IZR. unfold Z.ltb at 3. generalize (Zcompare_spec (p - q) 0); intros SPEC; inversion SPEC; auto. assert (EITHER: 0 <= p \/ q < 0) by omega. destruct EITHER; [apply andb_false_intro1 | apply andb_false_intro2]. @@ -405,7 +398,7 @@ Proof. destruct (BofZ_representable q) as (D & E & F); auto. generalize (Bmult_correct _ _ _ Hmax nan mode_NE (BofZ p) (BofZ q)). fold emin; fold fexp. - rewrite A, B, C, D, E, F. rewrite <- Z2R_mult. + rewrite A, B, C, D, E, F. rewrite <- mult_IZR. generalize (BofZ_correct (p * q)). destruct Rlt_bool. - intros (P & Q & R) (U & V & W). apply B2R_Bsign_inj; auto. @@ -431,36 +424,36 @@ Proof. apply integer_representable_2p. auto. apply (Zpower_gt_0 radix2). omega. -- assert (Z2R x <> 0%R) by (apply (Z2R_neq _ _ n)). +- assert (IZR x <> 0%R) by (apply (IZR_neq _ _ n)). destruct (BofZ_finite x H) as (A & B & C). destruct (BofZ_representable (2^p)) as (D & E & F). apply integer_representable_2p. auto. - assert (canonic_exp radix2 fexp (Z2R (x * 2^p)) = - canonic_exp radix2 fexp (Z2R x) + p). + assert (cexp radix2 fexp (IZR (x * 2^p)) = + cexp radix2 fexp (IZR x) + p). { - unfold canonic_exp, fexp. rewrite Z2R_mult. - change (2^p) with (radix2^p). rewrite Z2R_Zpower by omega. - rewrite ln_beta_mult_bpow by auto. - assert (prec + 1 <= ln_beta radix2 (Z2R x)). - { rewrite <- (ln_beta_abs radix2 (Z2R x)). - rewrite <- (ln_beta_bpow radix2 prec). - apply ln_beta_le. - apply bpow_gt_0. rewrite <- Z2R_Zpower by (red in prec_gt_0_;omega). - rewrite <- Z2R_abs. apply Z2R_le; auto. } + unfold cexp, fexp. rewrite mult_IZR. + change (2^p) with (radix2^p). rewrite IZR_Zpower by omega. + rewrite mag_mult_bpow by auto. + assert (prec + 1 <= mag radix2 (IZR x)). + { rewrite <- (mag_abs radix2 (IZR x)). + rewrite <- (mag_bpow radix2 prec). + apply mag_le. + apply bpow_gt_0. rewrite <- IZR_Zpower by (red in prec_gt_0_;omega). + rewrite <- abs_IZR. apply IZR_le; auto. } unfold FLT_exp. unfold emin; red in prec_gt_0_; zify; omega. } - assert (forall m, round radix2 fexp m (Z2R x) * Z2R (2^p) = - round radix2 fexp m (Z2R (x * 2^p)))%R. + assert (forall m, round radix2 fexp m (IZR x) * IZR (2^p) = + round radix2 fexp m (IZR (x * 2^p)))%R. { intros. unfold round, scaled_mantissa. rewrite H3. - rewrite Z2R_mult. rewrite Z.opp_add_distr. rewrite bpow_plus. - set (a := Z2R x); set (b := bpow radix2 (- canonic_exp radix2 fexp a)). - replace (a * Z2R (2^p) * (b * bpow radix2 (-p)))%R with (a * b)%R. + rewrite mult_IZR. rewrite Z.opp_add_distr. rewrite bpow_plus. + set (a := IZR x); set (b := bpow radix2 (- cexp radix2 fexp a)). + replace (a * IZR (2^p) * (b * bpow radix2 (-p)))%R with (a * b)%R. unfold F2R; simpl. rewrite Rmult_assoc. f_equal. - rewrite bpow_plus. f_equal. apply (Z2R_Zpower radix2). omega. - transitivity ((a * b) * (Z2R (2^p) * bpow radix2 (-p)))%R. - rewrite (Z2R_Zpower radix2). rewrite <- bpow_plus. + rewrite bpow_plus. f_equal. apply (IZR_Zpower radix2). omega. + transitivity ((a * b) * (IZR (2^p) * bpow radix2 (-p)))%R. + rewrite (IZR_Zpower radix2). rewrite <- bpow_plus. replace (p + -p) with 0 by omega. change (bpow radix2 0) with 1%R. ring. omega. ring. @@ -502,7 +495,7 @@ Lemma round_odd_flt: round radix2 fexp (Znearest choice) (round radix2 (FLT_exp emin' prec') Zrnd_odd x) = round radix2 fexp (Znearest choice) x. Proof. - intros. apply round_odd_prop. auto. apply fexp_correct; auto. + intros. apply round_N_odd. auto. apply fexp_correct; auto. apply exists_NE_FLT. right; omega. apply FLT_exp_valid. red; omega. apply exists_NE_FLT. right; omega. @@ -519,17 +512,17 @@ Corollary round_odd_fix: Proof. intros. destruct (Req_EM_T x 0%R). - subst x. rewrite round_0. auto. apply valid_rnd_odd. -- set (prec' := ln_beta radix2 x - p). +- set (prec' := mag radix2 x - p). set (emin' := emin - 2). - assert (PREC: ln_beta radix2 (bpow radix2 (prec + p + 1)) <= ln_beta radix2 x). - { rewrite <- (ln_beta_abs radix2 x). - apply ln_beta_le; auto. apply bpow_gt_0. } - rewrite ln_beta_bpow in PREC. - assert (CANON: canonic_exp radix2 (FLT_exp emin' prec') x = - canonic_exp radix2 (FIX_exp p) x). + assert (PREC: mag radix2 (bpow radix2 (prec + p + 1)) <= mag radix2 x). + { rewrite <- (mag_abs radix2 x). + apply mag_le; auto. apply bpow_gt_0. } + rewrite mag_bpow in PREC. + assert (CANON: cexp radix2 (FLT_exp emin' prec') x = + cexp radix2 (FIX_exp p) x). { - unfold canonic_exp, FLT_exp, FIX_exp. - replace (ln_beta radix2 x - prec') with p by (unfold prec'; omega). + unfold cexp, FLT_exp, FIX_exp. + replace (mag radix2 x - prec') with p by (unfold prec'; omega). apply Z.max_l. unfold emin', emin. red in prec_gt_0_; omega. } assert (RND: round radix2 (FIX_exp p) Zrnd_odd x = @@ -549,7 +542,7 @@ Definition int_round_odd (x: Z) (p: Z) := Lemma Zrnd_odd_int: forall n p, 0 <= p -> - Zrnd_odd (Z2R n * bpow radix2 (-p)) * 2^p = + Zrnd_odd (IZR n * bpow radix2 (-p)) * 2^p = int_round_odd n p. Proof. intros. @@ -561,29 +554,29 @@ Proof. pose proof (bpow_gt_0 radix2 (-p)). assert (bpow radix2 p * bpow radix2 (-p) = 1)%R. { rewrite <- bpow_plus. replace (p + -p) with 0 by omega. auto. } - assert (Z2R n * bpow radix2 (-p) = Z2R q + Z2R r * bpow radix2 (-p))%R. - { rewrite H1. rewrite Z2R_plus, Z2R_mult. - change (Z2R (2^p)) with (Z2R (radix2^p)). - rewrite Z2R_Zpower by omega. ring_simplify. + assert (IZR n * bpow radix2 (-p) = IZR q + IZR r * bpow radix2 (-p))%R. + { rewrite H1. rewrite plus_IZR, mult_IZR. + change (IZR (2^p)) with (IZR (radix2^p)). + rewrite IZR_Zpower by omega. ring_simplify. rewrite Rmult_assoc. rewrite H4. ring. } - assert (0 <= Z2R r < bpow radix2 p)%R. - { split. change 0%R with (Z2R 0). apply Z2R_le; omega. - rewrite <- Z2R_Zpower by omega. apply Z2R_lt; tauto. } - assert (0 <= Z2R r * bpow radix2 (-p) < 1)%R. + assert (0 <= IZR r < bpow radix2 p)%R. + { split. apply IZR_le; omega. + rewrite <- IZR_Zpower by omega. apply IZR_lt; tauto. } + assert (0 <= IZR r * bpow radix2 (-p) < 1)%R. { generalize (bpow_gt_0 radix2 (-p)). intros. split. apply Rmult_le_pos; lra. rewrite <- H4. apply Rmult_lt_compat_r. auto. tauto. } - assert (Zfloor (Z2R n * bpow radix2 (-p)) = q). - { apply Zfloor_imp. rewrite H5. rewrite Z2R_plus. change (Z2R 1) with 1%R. lra. } + assert (Zfloor (IZR n * bpow radix2 (-p)) = q). + { apply Zfloor_imp. rewrite H5. rewrite plus_IZR. lra. } unfold Zrnd_odd. destruct Req_EM_T. -- assert (Z2R r * bpow radix2 (-p) = 0)%R. +- assert (IZR r * bpow radix2 (-p) = 0)%R. { rewrite H8 in e. rewrite e in H5. lra. } apply Rmult_integral in H9. destruct H9; [ | lra ]. - apply (eq_Z2R r 0) in H9. apply <- Z.eqb_eq in H9. rewrite H9. assumption. -- assert (Z2R r * bpow radix2 (-p) <> 0)%R. + apply (eq_IZR r 0) in H9. apply <- Z.eqb_eq in H9. rewrite H9. assumption. +- assert (IZR r * bpow radix2 (-p) <> 0)%R. { rewrite H8 in n0. lra. } destruct (Z.eqb r 0) eqn:RZ. - apply Z.eqb_eq in RZ. rewrite RZ in H9. change (Z2R 0) with 0%R in H9. + apply Z.eqb_eq in RZ. rewrite RZ in H9. rewrite Rmult_0_l in H9. congruence. rewrite Zceil_floor_neq by lra. rewrite H8. change Zeven with Z.even. rewrite Zodd_even_bool. destruct (Z.even q); auto. @@ -594,9 +587,9 @@ Lemma int_round_odd_le: x <= y -> int_round_odd x p <= int_round_odd y p. Proof. intros. - assert (Zrnd_odd (Z2R x * bpow radix2 (-p)) <= Zrnd_odd (Z2R y * bpow radix2 (-p))). + assert (Zrnd_odd (IZR x * bpow radix2 (-p)) <= Zrnd_odd (IZR y * bpow radix2 (-p))). { apply Zrnd_le. apply valid_rnd_odd. apply Rmult_le_compat_r. apply bpow_ge_0. - apply Z2R_le; auto. } + apply IZR_le; auto. } rewrite <- ! Zrnd_odd_int by auto. apply Zmult_le_compat_r. auto. apply (Zpower_ge_0 radix2). Qed. @@ -635,14 +628,14 @@ Proof. destruct (BofZ_finite (int_round_odd x p) YRANGE) as (Y1 & Y2 & Y3). apply BofZ_finite_equal; auto. rewrite X1, Y1. - assert (Z2R (int_round_odd x p) = round radix2 (FIX_exp p) Zrnd_odd (Z2R x)). + assert (IZR (int_round_odd x p) = round radix2 (FIX_exp p) Zrnd_odd (IZR x)). { - unfold round, scaled_mantissa, canonic_exp, FIX_exp. + unfold round, scaled_mantissa, cexp, FIX_exp. rewrite <- Zrnd_odd_int by omega. - unfold F2R; simpl. rewrite Z2R_mult. f_equal. apply (Z2R_Zpower radix2). omega. + unfold F2R; simpl. rewrite mult_IZR. f_equal. apply (IZR_Zpower radix2). omega. } rewrite H. symmetry. apply round_odd_fix. auto. omega. - rewrite <- Z2R_Zpower. rewrite <- Z2R_abs. apply Z2R_le; auto. + rewrite <- IZR_Zpower. rewrite <- abs_IZR. apply IZR_le; auto. red in prec_gt_0_; omega. Qed. @@ -704,37 +697,37 @@ Theorem ZofB_correct: forall f, ZofB f = if is_finite _ _ f then Some (Ztrunc (B2R _ _ f)) else None. Proof. - destruct f; simpl; auto. -- f_equal. symmetry. apply (Ztrunc_Z2R 0). + destruct f as [s|s|s p H|s m e H]; simpl; auto. +- f_equal. symmetry. apply (Ztrunc_IZR 0). - destruct e; f_equal. - + unfold F2R; simpl. rewrite Rmult_1_r. rewrite Ztrunc_Z2R. auto. - + unfold F2R; simpl. rewrite <- Z2R_mult. rewrite Ztrunc_Z2R. auto. - + unfold F2R; simpl. rewrite Z2R_cond_Zopp. rewrite <- cond_Ropp_mult_l. - assert (EQ: forall x, Ztrunc (cond_Ropp b x) = cond_Zopp b (Ztrunc x)). + + unfold F2R; simpl. rewrite Rmult_1_r. rewrite Ztrunc_IZR. auto. + + unfold F2R; simpl. rewrite <- mult_IZR. rewrite Ztrunc_IZR. auto. + + unfold F2R; simpl. rewrite IZR_cond_Zopp. rewrite <- cond_Ropp_mult_l. + assert (EQ: forall x, Ztrunc (cond_Ropp s x) = cond_Zopp s (Ztrunc x)). { - intros. destruct b; simpl; auto. apply Ztrunc_opp. + intros. destruct s; simpl; auto. apply Ztrunc_opp. } rewrite EQ. f_equal. generalize (Zpower_pos_gt_0 2 p (eq_refl _)); intros. rewrite Ztrunc_floor. symmetry. apply Zfloor_div. omega. - apply Rmult_le_pos. apply (Z2R_le 0). compute; congruence. - apply Rlt_le. apply Rinv_0_lt_compat. apply (Z2R_lt 0). auto. + apply Rmult_le_pos. apply IZR_le. compute; congruence. + apply Rlt_le. apply Rinv_0_lt_compat. apply IZR_lt. auto. Qed. (** Interval properties. *) Remark Ztrunc_range_pos: - forall x, 0 < Ztrunc x -> (Z2R (Ztrunc x) <= x < Z2R (Ztrunc x + 1)%Z)%R. + forall x, 0 < Ztrunc x -> (IZR (Ztrunc x) <= x < IZR (Ztrunc x + 1)%Z)%R. Proof. intros. - rewrite Ztrunc_floor. split. apply Zfloor_lb. rewrite Z2R_plus. apply Zfloor_ub. + rewrite Ztrunc_floor. split. apply Zfloor_lb. rewrite plus_IZR. apply Zfloor_ub. generalize (Rle_bool_spec 0%R x). intros RLE; inversion RLE; subst; clear RLE. auto. rewrite Ztrunc_ceil in H by lra. unfold Zceil in H. assert (-x < 0)%R. - { apply Rlt_le_trans with (Z2R (Zfloor (-x)) + 1)%R. apply Zfloor_ub. - change 0%R with (Z2R 0). change 1%R with (Z2R 1). rewrite <- Z2R_plus. - apply Z2R_le. omega. } + { apply Rlt_le_trans with (IZR (Zfloor (-x)) + 1)%R. apply Zfloor_ub. + rewrite <- plus_IZR. + apply IZR_le. omega. } lra. Qed. @@ -744,32 +737,32 @@ Proof. intros; generalize (Rle_bool_spec 0%R x). intros RLE; inversion RLE; subst; clear RLE. - rewrite Ztrunc_floor in H by auto. split. + apply Rlt_le_trans with 0%R; auto. rewrite <- Ropp_0. apply Ropp_lt_contravar. apply Rlt_0_1. - + replace 1%R with (Z2R (Zfloor x) + 1)%R. apply Zfloor_ub. rewrite H. simpl. apply Rplus_0_l. + + replace 1%R with (IZR (Zfloor x) + 1)%R. apply Zfloor_ub. rewrite H. simpl. apply Rplus_0_l. - rewrite Ztrunc_ceil in H by (apply Rlt_le; auto). split. + apply (Ropp_lt_cancel (-(1))). rewrite Ropp_involutive. - replace 1%R with (Z2R (Zfloor (-x)) + 1)%R. apply Zfloor_ub. + replace 1%R with (IZR (Zfloor (-x)) + 1)%R. apply Zfloor_ub. unfold Zceil in H. replace (Zfloor (-x)) with 0 by omega. simpl. apply Rplus_0_l. + apply Rlt_le_trans with 0%R; auto. apply Rle_0_1. Qed. Theorem ZofB_range_pos: - forall f n, ZofB f = Some n -> 0 < n -> (Z2R n <= B2R _ _ f < Z2R (n + 1)%Z)%R. + forall f n, ZofB f = Some n -> 0 < n -> (IZR n <= B2R _ _ f < IZR (n + 1)%Z)%R. Proof. intros. rewrite ZofB_correct in H. destruct (is_finite prec emax f) eqn:FIN; inversion H. apply Ztrunc_range_pos. congruence. Qed. Theorem ZofB_range_neg: - forall f n, ZofB f = Some n -> n < 0 -> (Z2R (n - 1)%Z < B2R _ _ f <= Z2R n)%R. + forall f n, ZofB f = Some n -> n < 0 -> (IZR (n - 1)%Z < B2R _ _ f <= IZR n)%R. Proof. intros. rewrite ZofB_correct in H. destruct (is_finite prec emax f) eqn:FIN; inversion H. set (x := B2R prec emax f) in *. set (y := (-x)%R). - assert (A: (Z2R (Ztrunc y) <= y < Z2R (Ztrunc y + 1)%Z)%R). + assert (A: (IZR (Ztrunc y) <= y < IZR (Ztrunc y + 1)%Z)%R). { apply Ztrunc_range_pos. unfold y. rewrite Ztrunc_opp. omega. } destruct A as [B C]. unfold y in B, C. rewrite Ztrunc_opp in B, C. replace (- Ztrunc x + 1) with (- (Ztrunc x - 1)) in C by omega. - rewrite Z2R_opp in B, C. lra. + rewrite opp_IZR in B, C. lra. Qed. Theorem ZofB_range_zero: @@ -780,13 +773,13 @@ Proof. Qed. Theorem ZofB_range_nonneg: - forall f n, ZofB f = Some n -> 0 <= n -> (-1 < B2R _ _ f < Z2R (n + 1)%Z)%R. + forall f n, ZofB f = Some n -> 0 <= n -> (-1 < B2R _ _ f < IZR (n + 1)%Z)%R. Proof. intros. destruct (Z.eq_dec n 0). - subst n. apply ZofB_range_zero. auto. - destruct (ZofB_range_pos f n) as (A & B). auto. omega. - split; auto. apply Rlt_le_trans with (Z2R 0). simpl; lra. - apply Rle_trans with (Z2R n); auto. apply Z2R_le; auto. + split; auto. apply Rlt_le_trans with 0%R. simpl; lra. + apply Rle_trans with (IZR n); auto. apply IZR_le; auto. Qed. (** For representable integers, [ZofB] is left inverse of [BofZ]. *) @@ -795,35 +788,35 @@ Theorem ZofBofZ_exact: forall n, integer_representable n -> ZofB (BofZ n) = Some n. Proof. intros. destruct (BofZ_representable n H) as (A & B & C). - rewrite ZofB_correct. rewrite A, B. f_equal. apply Ztrunc_Z2R. + rewrite ZofB_correct. rewrite A, B. f_equal. apply Ztrunc_IZR. Qed. (** Compatibility with subtraction *) Remark Zfloor_minus: - forall x n, Zfloor (x - Z2R n) = Zfloor x - n. + forall x n, Zfloor (x - IZR n) = Zfloor x - n. Proof. intros. apply Zfloor_imp. replace (Zfloor x - n + 1) with ((Zfloor x + 1) - n) by omega. - rewrite ! Z2R_minus. unfold Rminus. split. + rewrite ! minus_IZR. unfold Rminus. split. apply Rplus_le_compat_r. apply Zfloor_lb. - apply Rplus_lt_compat_r. rewrite Z2R_plus. apply Zfloor_ub. + apply Rplus_lt_compat_r. rewrite plus_IZR. apply Zfloor_ub. Qed. Theorem ZofB_minus: forall minus_nan m f p q, - ZofB f = Some p -> 0 <= p < 2*q -> q <= 2^prec -> (Z2R q <= B2R _ _ f)%R -> + ZofB f = Some p -> 0 <= p < 2*q -> q <= 2^prec -> (IZR q <= B2R _ _ f)%R -> ZofB (Bminus _ _ _ Hmax minus_nan m f (BofZ q)) = Some (p - q). Proof. intros. assert (Q: -2^prec <= q <= 2^prec). { split; auto. generalize (Zpower_ge_0 radix2 prec); simpl; omega. } - assert (RANGE: (-1 < B2R _ _ f < Z2R (p + 1)%Z)%R) by (apply ZofB_range_nonneg; auto; omega). + assert (RANGE: (-1 < B2R _ _ f < IZR (p + 1)%Z)%R) by (apply ZofB_range_nonneg; auto; omega). rewrite ZofB_correct in H. destruct (is_finite prec emax f) eqn:FIN; try discriminate. - assert (PQ2: (Z2R (p + 1) <= Z2R q * 2)%R). - { change 2%R with (Z2R 2). rewrite <- Z2R_mult. apply Z2R_le. omega. } - assert (EXACT: round radix2 fexp (round_mode m) (B2R _ _ f - Z2R q)%R = (B2R _ _ f - Z2R q)%R). + assert (PQ2: (IZR (p + 1) <= IZR q * 2)%R). + { rewrite <- mult_IZR. apply IZR_le. omega. } + assert (EXACT: round radix2 fexp (round_mode m) (B2R _ _ f - IZR q)%R = (B2R _ _ f - IZR q)%R). { apply round_generic. apply valid_rnd_round_mode. - apply sterbenz_aux. apply FLT_exp_monotone. apply generic_format_B2R. + apply sterbenz_aux. now apply FLT_exp_valid. apply FLT_exp_monotone. apply generic_format_B2R. apply integer_representable_n. auto. lra. } destruct (BofZ_exact q Q) as (A & B & C). generalize (Bminus_correct _ _ _ Hmax minus_nan m f (BofZ q) FIN B). @@ -834,8 +827,8 @@ Proof. lra. lra. - rewrite A. fold emin; fold fexp. rewrite EXACT. apply Rle_lt_trans with (bpow radix2 prec). - apply Rle_trans with (Z2R q). apply Rabs_le. lra. - rewrite <- Z2R_Zpower. apply Z2R_le; auto. red in prec_gt_0_; omega. + apply Rle_trans with (IZR q). apply Rabs_le. lra. + rewrite <- IZR_Zpower. apply IZR_le; auto. red in prec_gt_0_; omega. apply bpow_lt. auto. Qed. @@ -875,7 +868,7 @@ Qed. Theorem ZofB_range_minus: forall minus_nan m f p q, - ZofB_range f 0 (2 * q - 1) = Some p -> q <= 2^prec -> (Z2R q <= B2R _ _ f)%R -> + ZofB_range f 0 (2 * q - 1) = Some p -> q <= 2^prec -> (IZR q <= B2R _ _ f)%R -> ZofB_range (Bminus _ _ _ Hmax minus_nan m f (BofZ q)) (-q) (q - 1) = Some (p - q). Proof. intros. destruct (ZofB_range_inversion _ _ _ _ H) as (A & B & C). @@ -897,11 +890,11 @@ Proof. intros until y; intros NAN. pose proof (Bplus_correct _ _ _ Hmax plus_nan mode x y). pose proof (Bplus_correct _ _ _ Hmax plus_nan mode y x). - unfold Bplus in *; destruct x; destruct y; auto. -- rewrite (eqb_sym b0 b). destruct (eqb b b0) eqn:EQB; auto. + unfold Bplus in *; destruct x as [sx|sx|sx px Hx|sx mx ex Hx]; destruct y as [sy|sy|sy py Hy|sy my ey Hy]; auto. +- rewrite (eqb_sym sy sx). destruct (eqb sx sy) eqn:EQB; auto. f_equal; apply eqb_prop; auto. - rewrite NAN; auto. -- rewrite (eqb_sym b0 b). destruct (eqb b b0) eqn:EQB. +- rewrite (eqb_sym sy sx). destruct (eqb sx sy) eqn:EQB. f_equal; apply eqb_prop; auto. rewrite NAN; auto. - rewrite NAN; auto. @@ -913,8 +906,8 @@ Proof. - generalize (H (eq_refl _) (eq_refl _)); clear H. generalize (H0 (eq_refl _) (eq_refl _)); clear H0. fold emin. fold fexp. - set (x := B754_finite prec emax b0 m0 e1 e2). set (rx := B2R _ _ x). - set (y := B754_finite prec emax b m e e0). set (ry := B2R _ _ y). + set (x := B754_finite prec emax sx mx ex Hx). set (rx := B2R _ _ x). + set (y := B754_finite prec emax sy my ey Hy). set (ry := B2R _ _ y). rewrite (Rplus_comm ry rx). destruct Rlt_bool. + intros (A1 & A2 & A3) (B1 & B2 & B3). apply B2R_Bsign_inj; auto. rewrite <- B1 in A1. auto. @@ -930,31 +923,31 @@ Proof. intros until y; intros NAN. pose proof (Bmult_correct _ _ _ Hmax mult_nan mode x y). pose proof (Bmult_correct _ _ _ Hmax mult_nan mode y x). - unfold Bmult in *; destruct x; destruct y; auto. -- rewrite (xorb_comm b0 b); auto. + unfold Bmult in *; destruct x as [sx|sx|sx px Hx|sx mx ex Hx]; destruct y as [sy|sy|sy py Hy|sy my ey Hy]; auto. +- rewrite (xorb_comm sx sy); auto. - rewrite NAN; auto. - rewrite NAN; auto. -- rewrite (xorb_comm b0 b); auto. +- rewrite (xorb_comm sx sy); auto. - rewrite NAN; auto. -- rewrite (xorb_comm b0 b); auto. +- rewrite (xorb_comm sx sy); auto. - rewrite NAN; auto. -- rewrite (xorb_comm b0 b); auto. +- rewrite (xorb_comm sx sy); auto. - rewrite NAN; auto. - rewrite NAN; auto. - rewrite NAN; auto. - rewrite NAN; auto. -- rewrite (xorb_comm b0 b); auto. -- rewrite (xorb_comm b0 b); auto. +- rewrite (xorb_comm sx sy); auto. +- rewrite (xorb_comm sx sy); auto. - rewrite NAN; auto. - revert H H0. fold emin. fold fexp. - set (x := B754_finite prec emax b0 m0 e1 e2). set (rx := B2R _ _ x). - set (y := B754_finite prec emax b m e e0). set (ry := B2R _ _ y). + set (x := B754_finite prec emax sx mx ex Hx). set (rx := B2R _ _ x). + set (y := B754_finite prec emax sy my ey Hy). set (ry := B2R _ _ y). rewrite (Rmult_comm ry rx). destruct (Rlt_bool (Rabs (round radix2 fexp (round_mode mode) (rx * ry))) (bpow radix2 emax)). + intros (A1 & A2 & A3) (B1 & B2 & B3). apply B2R_Bsign_inj; auto. rewrite <- B1 in A1. auto. - rewrite ! Bsign_FF2B. f_equal. f_equal. apply xorb_comm. apply Pos.mul_comm. apply Z.add_comm. + rewrite ! Bsign_FF2B. f_equal. f_equal. apply xorb_comm. now rewrite Pos.mul_comm. apply Z.add_comm. + intros A B. apply B2FF_inj. etransitivity. eapply A. rewrite xorb_comm. auto. Qed. @@ -973,26 +966,26 @@ Proof. rewrite A, B, C in H. rewrite xorb_false_r in H. destruct (is_finite _ _ f) eqn:FIN. - pose proof (Bplus_correct _ _ _ Hmax plus_nan mode f f FIN FIN). fold emin in H0. - assert (EQ: (B2R prec emax f * Z2R 2%Z = B2R prec emax f + B2R prec emax f)%R). - { change (Z2R 2%Z) with 2%R. ring. } + assert (EQ: (B2R prec emax f * IZR 2%Z = B2R prec emax f + B2R prec emax f)%R). + { ring. } rewrite <- EQ in H0. destruct Rlt_bool. + destruct H0 as (P & Q & R). destruct H as (S & T & U). apply B2R_Bsign_inj; auto. rewrite P, S. auto. rewrite R, U. - replace 0%R with (0 * Z2R 2%Z)%R by ring. rewrite Rcompare_mult_r. - rewrite andb_diag, orb_diag. destruct f; try discriminate; simpl. + replace 0%R with (0 * 2)%R by ring. rewrite Rcompare_mult_r. + rewrite andb_diag, orb_diag. destruct f as [s|s|s p H|s m e H]; try discriminate; simpl. rewrite Rcompare_Eq by auto. destruct mode; auto. replace 0%R with (@F2R radix2 {| Fnum := 0%Z; Fexp := e |}). - rewrite Rcompare_F2R. destruct b; auto. + rewrite Rcompare_F2R. destruct s; auto. unfold F2R. simpl. ring. - change 0%R with (Z2R 0%Z). apply Z2R_lt. omega. + apply IZR_lt. omega. destruct (Bmult prec emax prec_gt_0_ Hmax mult_nan mode f (BofZ 2)); reflexivity || discriminate. + destruct H0 as (P & Q). apply B2FF_inj. rewrite P, H. auto. -- destruct f; try discriminate. - + simpl Bplus. rewrite eqb_true. destruct (BofZ 2) eqn:B2; try discriminate; simpl in *. - assert ((0 = 2)%Z) by (apply eq_Z2R; auto). discriminate. - subst b0. rewrite xorb_false_r. auto. +- destruct f as [sf|sf|sf pf Hf|sf mf ef Hf]; try discriminate. + + simpl Bplus. rewrite eqb_true. destruct (BofZ 2) as [| | |s2 m2 e2 H2] eqn:B2; try discriminate; simpl in *. + assert ((0 = 2)%Z) by (apply eq_IZR; auto). discriminate. + subst s2. rewrite xorb_false_r. auto. auto. + unfold Bplus, Bmult. rewrite <- NAN by auto. auto. Qed. @@ -1031,7 +1024,7 @@ Remark bounded_Bexact_inverse: forall e, emin <= e <= emax - prec <-> bounded prec emax Bexact_inverse_mantissa e = true. Proof. - intros. unfold bounded, canonic_mantissa. rewrite andb_true_iff. + intros. unfold bounded, canonical_mantissa. rewrite andb_true_iff. rewrite <- Zeq_is_eq_bool. rewrite <- Zle_is_le_bool. rewrite Bexact_inverse_mantissa_digits2_pos. split. @@ -1063,23 +1056,23 @@ Lemma Bexact_inverse_correct: /\ B2R _ _ f <> 0%R /\ Bsign _ _ f' = Bsign _ _ f. Proof with (try discriminate). - intros f f' EI. unfold Bexact_inverse in EI. destruct f... + intros f f' EI. unfold Bexact_inverse in EI. destruct f as [s|s|s p H|s m e H]... destruct (Pos.eq_dec m Bexact_inverse_mantissa)... set (e' := -e - (prec - 1) * 2) in *. destruct (Z_le_dec emin e')... destruct (Z_le_dec e' emax)... inversion EI; clear EI; subst f' m. split. auto. split. auto. split. unfold B2R. rewrite Bexact_inverse_mantissa_value. - unfold F2R; simpl. rewrite Z2R_cond_Zopp. + unfold F2R; simpl. rewrite IZR_cond_Zopp. rewrite <- ! cond_Ropp_mult_l. red in prec_gt_0_. - replace (Z2R (2 ^ (prec - 1))) with (bpow radix2 (prec - 1)) - by (symmetry; apply (Z2R_Zpower radix2); omega). + replace (IZR (2 ^ (prec - 1))) with (bpow radix2 (prec - 1)) + by (symmetry; apply (IZR_Zpower radix2); omega). rewrite <- ! bpow_plus. replace (prec - 1 + e') with (- (prec - 1 + e)) by (unfold e'; omega). - rewrite bpow_opp. unfold cond_Ropp; destruct b; auto. + rewrite bpow_opp. unfold cond_Ropp; destruct s; auto. rewrite Ropp_inv_permute. auto. apply Rgt_not_eq. apply bpow_gt_0. - split. simpl. red; intros. apply F2R_eq_0_reg in H. destruct b; simpl in H; discriminate. + split. simpl. apply F2R_neq_0. destruct s; simpl in H; discriminate. auto. Qed. @@ -1180,7 +1173,7 @@ Lemma bpow_log_pos: 0 < n -> (bpow radix2 (n * Z.log2 base)%Z <= bpow base n)%R. Proof. - intros. rewrite <- ! Z2R_Zpower. apply Z2R_le; apply Zpower_log; auto. + intros. rewrite <- ! IZR_Zpower. apply IZR_le; apply Zpower_log; auto. omega. rewrite Z.mul_comm; apply Zmult_gt_0_le_0_compat. omega. apply Z.log2_nonneg. Qed. @@ -1202,7 +1195,7 @@ Lemma round_integer_overflow: forall (base: radix) e m, 0 < e -> emax <= e * Z.log2 base -> - (bpow radix2 emax <= round radix2 fexp (round_mode mode_NE) (Z2R (Zpos m) * bpow base e))%R. + (bpow radix2 emax <= round radix2 fexp (round_mode mode_NE) (IZR (Zpos m) * bpow base e))%R. Proof. intros. rewrite <- (round_generic radix2 fexp (round_mode mode_NE) (bpow radix2 emax)); auto. @@ -1210,11 +1203,11 @@ Proof. rewrite <- (Rmult_1_l (bpow radix2 emax)). apply Rmult_le_compat. apply Rle_0_1. apply bpow_ge_0. - apply (Z2R_le 1). zify; omega. + apply IZR_le. zify; omega. eapply Rle_trans. eapply bpow_le. eassumption. apply bpow_log_pos; auto. apply generic_format_FLT. exists (Float radix2 1 emax). - split. unfold F2R; simpl. ring. - split. simpl. apply (Zpower_gt_1 radix2); auto. + unfold F2R; simpl. ring. + simpl. apply (Zpower_gt_1 radix2); auto. simpl. unfold emin; red in prec_gt_0_; omega. Qed. @@ -1227,15 +1220,15 @@ Proof. set (eps := bpow radix2 (emin - 1)) in *. assert (A: round radix2 fexp (round_mode mode_NE) eps = 0%R). { unfold round. simpl. - assert (E: canonic_exp radix2 fexp eps = emin). - { unfold canonic_exp, eps. rewrite ln_beta_bpow. unfold fexp, FLT_exp. zify; red in prec_gt_0_; omega. } + assert (E: cexp radix2 fexp eps = emin). + { unfold cexp, eps. rewrite mag_bpow. unfold fexp, FLT_exp. zify; red in prec_gt_0_; omega. } unfold scaled_mantissa; rewrite E. assert (P: (eps * bpow radix2 (-emin) = / 2)%R). { unfold eps. rewrite <- bpow_plus. replace (emin - 1 + -emin) with (-1) by omega. auto. } rewrite P. unfold Znearest. assert (F: Zfloor (/ 2)%R = 0). { apply Zfloor_imp. simpl. lra. } - rewrite F. change (Z2R 0) with 0%R. rewrite Rminus_0_r. rewrite Rcompare_Eq by auto. + rewrite F. rewrite Rminus_0_r. rewrite Rcompare_Eq by auto. simpl. unfold F2R; simpl. apply Rmult_0_l. } apply Rle_antisym. @@ -1248,15 +1241,15 @@ Lemma round_integer_underflow: forall (base: radix) e m, e < 0 -> e * Z.log2 base + Z.log2_up (Zpos m) < emin -> - round radix2 fexp (round_mode mode_NE) (Z2R (Zpos m) * bpow base e) = 0%R. + round radix2 fexp (round_mode mode_NE) (IZR (Zpos m) * bpow base e) = 0%R. Proof. intros. apply round_NE_underflows. split. -- apply Rmult_le_pos. apply (Z2R_le 0). zify; omega. apply bpow_ge_0. +- apply Rmult_le_pos. apply IZR_le. zify; omega. apply bpow_ge_0. - apply Rle_trans with (bpow radix2 (Z.log2_up (Z.pos m) + e * Z.log2 base)). + rewrite bpow_plus. apply Rmult_le_compat. - apply (Z2R_le 0); zify; omega. + apply IZR_le; zify; omega. apply bpow_ge_0. - rewrite <- Z2R_Zpower. apply Z2R_le. + rewrite <- IZR_Zpower. apply IZR_le. destruct (Z.eq_dec (Z.pos m) 1). rewrite e0. simpl. omega. apply Z.log2_up_spec. zify; omega. @@ -1270,7 +1263,7 @@ Qed. Theorem Bparse_correct: forall b m e (BASE: 2 <= Zpos b), let base := {| radix_val := Zpos b; radix_prop := Zle_imp_le_bool _ _ BASE |} in - let r := round radix2 fexp (round_mode mode_NE) (Z2R (Zpos m) * bpow base e) in + let r := round radix2 fexp (round_mode mode_NE) (IZR (Zpos m) * bpow base e) in if Rlt_bool (Rabs r) (bpow radix2 emax) then B2R _ _ (Bparse b m e) = r /\ is_finite _ _ (Bparse b m e) = true @@ -1279,7 +1272,7 @@ Theorem Bparse_correct: B2FF _ _ (Bparse b m e) = F754_infinity false. Proof. intros. - assert (A: forall x, @F2R radix2 {| Fnum := x; Fexp := 0 |} = Z2R x). + assert (A: forall x, @F2R radix2 {| Fnum := x; Fexp := 0 |} = IZR x). { intros. unfold F2R, Fnum; simpl. ring. } unfold Bparse, r. destruct e as [ | e | e]. - (* e = Z0 *) @@ -1288,7 +1281,7 @@ Proof. - (* e = Zpos e *) destruct (Z.ltb_spec (Z.pos e * Z.log2 (Z.pos b)) emax). + (* no overflow *) - rewrite pos_pow_spec. rewrite <- Z2R_Zpower by (zify; omega). rewrite <- Z2R_mult. + rewrite pos_pow_spec. rewrite <- IZR_Zpower by (zify; omega). rewrite <- mult_IZR. replace false with (Z.pos m * Z.pos b ^ Z.pos e <? 0). exact (BofZ_correct (Z.pos m * Z.pos b ^ Z.pos e)). rewrite Z.ltb_ge. rewrite Z.mul_comm. apply Zmult_gt_0_le_0_compat. zify; omega. apply (Zpower_ge_0 base). @@ -1300,25 +1293,21 @@ Proof. + (* undeflow *) rewrite round_integer_underflow; auto. rewrite Rlt_bool_true. auto. - replace (Rabs 0)%R with 0%R. apply bpow_gt_0. apply (Z2R_abs 0). + replace (Rabs 0)%R with 0%R. apply bpow_gt_0. apply (abs_IZR 0). zify; omega. + (* no underflow *) generalize (Bdiv_correct_aux prec emax prec_gt_0_ Hmax mode_NE false m 0 false (pos_pow b e) 0). - set (f := match Fdiv_core_binary prec (Z.pos m) 0 (Z.pos (pos_pow b e)) 0 with - | (0, _, _) => F754_nan false 1 - | (Z.pos mz0, ez, lz) => - binary_round_aux prec emax mode_NE (xorb false false) mz0 ez lz - | (Z.neg _, _, _) => F754_nan false 1 - end). + set (f := let '(mz, ez, lz) := Fdiv_core_binary prec emax (Z.pos m) 0 (Z.pos (pos_pow b e)) 0 + in binary_round_aux prec emax mode_NE (xorb false false) mz ez lz). fold emin; fold fexp. rewrite ! A. unfold cond_Zopp. rewrite pos_pow_spec. - assert (B: (Z2R (Z.pos m) / Z2R (Z.pos b ^ Z.pos e) = - Z2R (Z.pos m) * bpow base (Z.neg e))%R). + assert (B: (IZR (Z.pos m) / IZR (Z.pos b ^ Z.pos e) = + IZR (Z.pos m) * bpow base (Z.neg e))%R). { change (Z.neg e) with (- (Z.pos e)). rewrite bpow_opp. auto. } rewrite B. intros [P Q]. destruct (Rlt_bool (Rabs (round radix2 fexp (round_mode mode_NE) - (Z2R (Z.pos m) * bpow base (Z.neg e)))) + (IZR (Z.pos m) * bpow base (Z.neg e)))) (bpow radix2 emax)). * destruct Q as (Q1 & Q2 & Q3). split. rewrite B2R_FF2B, Q1. auto. @@ -1344,9 +1333,9 @@ Hypothesis Hmax2 : (prec2 < emax2)%Z. Let binary_float1 := binary_float prec1 emax1. Let binary_float2 := binary_float prec2 emax2. -Definition Bconv (conv_nan: bool -> nan_pl prec1 -> bool * nan_pl prec2) (md: mode) (f: binary_float1) : binary_float2 := +Definition Bconv (conv_nan: binary_float1 -> {x | is_nan prec2 emax2 x = true}) (md: mode) (f: binary_float1) : binary_float2 := match f with - | B754_nan _ _ s pl => let '(s, pl) := conv_nan s pl in B754_nan _ _ s pl + | B754_nan _ _ _ _ _ => build_nan prec2 emax2 (conv_nan f) | B754_infinity _ _ s => B754_infinity _ _ s | B754_zero _ _ s => B754_zero _ _ s | B754_finite _ _ s m e _ => binary_normalize _ _ _ Hmax2 md (cond_Zopp s (Zpos m)) e s @@ -1363,18 +1352,18 @@ Theorem Bconv_correct: else B2FF _ _ (Bconv conv_nan m f) = binary_overflow prec2 emax2 m (Bsign _ _ f). Proof. - intros. destruct f; try discriminate. + intros. destruct f as [sf|sf|sf pf Hf|sf mf ef Hf]; try discriminate. - simpl. rewrite round_0. rewrite Rabs_R0. rewrite Rlt_bool_true. auto. apply bpow_gt_0. apply valid_rnd_round_mode. -- generalize (binary_normalize_correct _ _ _ Hmax2 m (cond_Zopp b (Zpos m0)) e b). +- generalize (binary_normalize_correct _ _ _ Hmax2 m (cond_Zopp sf (Zpos mf)) ef sf). fold emin2; fold fexp2. simpl. destruct Rlt_bool. + intros (A & B & C). split. auto. split. auto. rewrite C. - destruct b; simpl. - rewrite Rcompare_Lt. auto. apply F2R_lt_0_compat. simpl. compute; auto. - rewrite Rcompare_Gt. auto. apply F2R_gt_0_compat. simpl. compute; auto. - + intros A. rewrite A. f_equal. destruct b. - apply Rlt_bool_true. apply F2R_lt_0_compat. simpl. compute; auto. - apply Rlt_bool_false. apply Rlt_le. apply Rgt_lt. apply F2R_gt_0_compat. simpl. compute; auto. + destruct sf; simpl. + rewrite Rcompare_Lt. auto. apply F2R_lt_0. simpl. compute; auto. + rewrite Rcompare_Gt. auto. apply F2R_gt_0. simpl. compute; auto. + + intros A. rewrite A. f_equal. destruct sf. + apply Rlt_bool_true. apply F2R_lt_0. simpl. compute; auto. + apply Rlt_bool_false. apply Rlt_le. apply Rgt_lt. apply F2R_gt_0. simpl. compute; auto. Qed. (** Converting a finite FP number to higher or equal precision preserves its value. *) @@ -1421,15 +1410,15 @@ Proof. unfold BofZ. generalize (binary_normalize_correct _ _ _ Hmax2 mode_NE n 0 false). fold emin2; fold fexp2. rewrite A. - replace (F2R {| Fnum := n; Fexp := 0 |}) with (Z2R n). + replace (F2R {| Fnum := n; Fexp := 0 |}) with (IZR n). destruct Rlt_bool. - intros (P & Q & R) (D & E & F). apply B2R_Bsign_inj; auto. - congruence. rewrite F, C, R. change 0%R with (Z2R 0). rewrite Rcompare_Z2R. + congruence. rewrite F, C, R. rewrite Rcompare_IZR. unfold Z.ltb. auto. -- intros P Q. apply B2FF_inj. rewrite P, Q. rewrite C. f_equal. change 0%R with (Z2R 0). +- intros P Q. apply B2FF_inj. rewrite P, Q. rewrite C. f_equal. generalize (Zlt_bool_spec n 0); intros LT; inversion LT. - rewrite Rlt_bool_true; auto. apply Z2R_lt; auto. - rewrite Rlt_bool_false; auto. apply Z2R_le; auto. + rewrite Rlt_bool_true; auto. apply IZR_lt; auto. + rewrite Rlt_bool_false; auto. apply IZR_le; auto. - unfold F2R; simpl. rewrite Rmult_1_r. auto. Qed. @@ -1472,19 +1461,15 @@ Proof. rewrite ! Bcompare_correct by auto. rewrite A, D. auto. - generalize (Bconv_widen_exact H H0 conv_nan m x) (Bconv_widen_exact H H0 conv_nan m y); intros P Q. - destruct x, y; try discriminate; simpl in P, Q; simpl; + destruct x as [sx|sx|sx px Hx|sx mx ex Hx], y as [sy|sy|sy py Hy|sy my ey Hy]; try discriminate; simpl in P, Q; simpl; repeat (match goal with |- context [conv_nan ?b ?pl] => destruct (conv_nan b pl) end); auto. destruct Q as (D & E & F); auto. - destruct (binary_normalize prec2 emax2 prec2_gt_0_ Hmax2 m (cond_Zopp b0 (Z.pos m0)) e b0); - discriminate || reflexivity. + now destruct binary_normalize. destruct P as (A & B & C); auto. - destruct (binary_normalize prec2 emax2 prec2_gt_0_ Hmax2 m (cond_Zopp b (Z.pos m0)) e b); - try discriminate; simpl. destruct b; auto. destruct b, b1; auto. + now destruct binary_normalize. destruct P as (A & B & C); auto. - destruct (binary_normalize prec2 emax2 prec2_gt_0_ Hmax2 m (cond_Zopp b (Z.pos m0)) e b); - try discriminate; simpl. destruct b; auto. - destruct b, b2; auto. + now destruct binary_normalize. Qed. End Conversions. diff --git a/lib/Integers.v b/lib/Integers.v index 0e506208..f4213332 100644 --- a/lib/Integers.v +++ b/lib/Integers.v @@ -16,7 +16,7 @@ (** Formalizations of machine integers modulo $2^N$ #2<sup>N</sup>#. *) Require Import Eqdep_dec Zquot Zwf. -Require Import Coqlib. +Require Import Coqlib Zbits. Require Archi. (** * Comparisons *) @@ -80,11 +80,19 @@ Proof. unfold modulus. apply two_power_nat_two_p. Qed. +Remark modulus_gt_one: modulus > 1. +Proof. + rewrite modulus_power. apply Z.lt_gt. apply (two_p_monotone_strict 0). + generalize wordsize_pos; omega. +Qed. + Remark modulus_pos: modulus > 0. Proof. - rewrite modulus_power. apply two_p_gt_ZERO. generalize wordsize_pos; omega. + generalize modulus_gt_one; omega. Qed. +Hint Resolve modulus_pos: ints. + (** * Representation of machine integers *) (** A machine integer (type [int]) is represented as a Coq arbitrary-precision @@ -95,17 +103,6 @@ Record int: Type := mkint { intval: Z; intrange: -1 < intval < modulus }. (** Fast normalization modulo [2^wordsize] *) -Fixpoint P_mod_two_p (p: positive) (n: nat) {struct n} : Z := - match n with - | O => 0 - | S m => - match p with - | xH => 1 - | xO q => Z.double (P_mod_two_p q m) - | xI q => Z.succ_double (P_mod_two_p q m) - end - end. - Definition Z_mod_modulus (x: Z) : Z := match x with | Z0 => 0 @@ -113,51 +110,9 @@ Definition Z_mod_modulus (x: Z) : Z := | Zneg p => let r := P_mod_two_p p wordsize in if zeq r 0 then 0 else modulus - r end. -Lemma P_mod_two_p_range: - forall n p, 0 <= P_mod_two_p p n < two_power_nat n. -Proof. - induction n; simpl; intros. - - rewrite two_power_nat_O. omega. - - rewrite two_power_nat_S. destruct p. - + generalize (IHn p). rewrite Z.succ_double_spec. omega. - + generalize (IHn p). rewrite Z.double_spec. omega. - + generalize (two_power_nat_pos n). omega. -Qed. - -Lemma P_mod_two_p_eq: - forall n p, P_mod_two_p p n = (Zpos p) mod (two_power_nat n). -Proof. - assert (forall n p, exists y, Zpos p = y * two_power_nat n + P_mod_two_p p n). - { - induction n; simpl; intros. - - rewrite two_power_nat_O. exists (Zpos p). ring. - - rewrite two_power_nat_S. destruct p. - + destruct (IHn p) as [y EQ]. exists y. - change (Zpos p~1) with (2 * Zpos p + 1). rewrite EQ. - rewrite Z.succ_double_spec. ring. - + destruct (IHn p) as [y EQ]. exists y. - change (Zpos p~0) with (2 * Zpos p). rewrite EQ. - rewrite (Z.double_spec (P_mod_two_p p n)). ring. - + exists 0; omega. - } - intros. - destruct (H n p) as [y EQ]. - symmetry. apply Zmod_unique with y. auto. apply P_mod_two_p_range. -Qed. - Lemma Z_mod_modulus_range: forall x, 0 <= Z_mod_modulus x < modulus. -Proof. - intros; unfold Z_mod_modulus. - destruct x. - - generalize modulus_pos; intuition. - - apply P_mod_two_p_range. - - set (r := P_mod_two_p p wordsize). - assert (0 <= r < modulus) by apply P_mod_two_p_range. - destruct (zeq r 0). - + generalize modulus_pos; intuition. - + Psatz.lia. -Qed. +Proof (Z_mod_two_p_range wordsize). Lemma Z_mod_modulus_range': forall x, -1 < Z_mod_modulus x < modulus. @@ -167,22 +122,7 @@ Qed. Lemma Z_mod_modulus_eq: forall x, Z_mod_modulus x = x mod modulus. -Proof. - intros. unfold Z_mod_modulus. destruct x. - - rewrite Zmod_0_l. auto. - - apply P_mod_two_p_eq. - - generalize (P_mod_two_p_range wordsize p) (P_mod_two_p_eq wordsize p). - fold modulus. intros A B. - exploit (Z_div_mod_eq (Zpos p) modulus). apply modulus_pos. intros C. - set (q := Zpos p / modulus) in *. - set (r := P_mod_two_p p wordsize) in *. - rewrite <- B in C. - change (Z.neg p) with (- (Z.pos p)). destruct (zeq r 0). - + symmetry. apply Zmod_unique with (-q). rewrite C; rewrite e. Psatz.lia. - intuition. - + symmetry. apply Zmod_unique with (-q - 1). rewrite C. Psatz.lia. - intuition. -Qed. +Proof (Z_mod_two_p_eq wordsize). (** The [unsigned] and [signed] functions return the Coq integer corresponding to the given machine integer, interpreted as unsigned or signed @@ -317,63 +257,20 @@ Definition shr_carry (x y: int) : int := (** Zero and sign extensions *) -Definition Zshiftin (b: bool) (x: Z) : Z := - if b then Z.succ_double x else Z.double x. - -(** In pseudo-code: -<< - Fixpoint Zzero_ext (n: Z) (x: Z) : Z := - if zle n 0 then - 0 - else - Zshiftin (Z.odd x) (Zzero_ext (Z.pred n) (Z.div2 x)). - Fixpoint Zsign_ext (n: Z) (x: Z) : Z := - if zle n 1 then - if Z.odd x then -1 else 0 - else - Zshiftin (Z.odd x) (Zzero_ext (Z.pred n) (Z.div2 x)). ->> - We encode this [nat]-like recursion using the [Z.iter] iteration - function, in order to make the [Zzero_ext] and [Zsign_ext] - functions efficiently executable within Coq. -*) - -Definition Zzero_ext (n: Z) (x: Z) : Z := - Z.iter n - (fun rec x => Zshiftin (Z.odd x) (rec (Z.div2 x))) - (fun x => 0) - x. - -Definition Zsign_ext (n: Z) (x: Z) : Z := - Z.iter (Z.pred n) - (fun rec x => Zshiftin (Z.odd x) (rec (Z.div2 x))) - (fun x => if Z.odd x then -1 else 0) - x. - Definition zero_ext (n: Z) (x: int) : int := repr (Zzero_ext n (unsigned x)). - Definition sign_ext (n: Z) (x: int) : int := repr (Zsign_ext n (unsigned x)). (** Decomposition of a number as a sum of powers of two. *) -Fixpoint Z_one_bits (n: nat) (x: Z) (i: Z) {struct n}: list Z := - match n with - | O => nil - | S m => - if Z.odd x - then i :: Z_one_bits m (Z.div2 x) (i+1) - else Z_one_bits m (Z.div2 x) (i+1) - end. - Definition one_bits (x: int) : list int := List.map repr (Z_one_bits wordsize (unsigned x) 0). (** Recognition of powers of two. *) Definition is_power2 (x: int) : option int := - match Z_one_bits wordsize (unsigned x) 0 with - | i :: nil => Some (repr i) - | _ => None + match Z_is_power2 (unsigned x) with + | Some i => Some (repr i) + | None => None end. (** Comparisons. *) @@ -497,101 +394,7 @@ Qed. (** ** Modulo arithmetic *) -(** We define and state properties of equality and arithmetic modulo a - positive integer. *) - -Section EQ_MODULO. - -Variable modul: Z. -Hypothesis modul_pos: modul > 0. - -Definition eqmod (x y: Z) : Prop := exists k, x = k * modul + y. - -Lemma eqmod_refl: forall x, eqmod x x. -Proof. - intros; red. exists 0. omega. -Qed. - -Lemma eqmod_refl2: forall x y, x = y -> eqmod x y. -Proof. - intros. subst y. apply eqmod_refl. -Qed. - -Lemma eqmod_sym: forall x y, eqmod x y -> eqmod y x. -Proof. - intros x y [k EQ]; red. exists (-k). subst x. ring. -Qed. - -Lemma eqmod_trans: forall x y z, eqmod x y -> eqmod y z -> eqmod x z. -Proof. - intros x y z [k1 EQ1] [k2 EQ2]; red. - exists (k1 + k2). subst x; subst y. ring. -Qed. - -Lemma eqmod_small_eq: - forall x y, eqmod x y -> 0 <= x < modul -> 0 <= y < modul -> x = y. -Proof. - intros x y [k EQ] I1 I2. - generalize (Zdiv_unique _ _ _ _ EQ I2). intro. - rewrite (Zdiv_small x modul I1) in H. subst k. omega. -Qed. - -Lemma eqmod_mod_eq: - forall x y, eqmod x y -> x mod modul = y mod modul. -Proof. - intros x y [k EQ]. subst x. - rewrite Z.add_comm. apply Z_mod_plus. auto. -Qed. - -Lemma eqmod_mod: - forall x, eqmod x (x mod modul). -Proof. - intros; red. exists (x / modul). - rewrite Z.mul_comm. apply Z_div_mod_eq. auto. -Qed. - -Lemma eqmod_add: - forall a b c d, eqmod a b -> eqmod c d -> eqmod (a + c) (b + d). -Proof. - intros a b c d [k1 EQ1] [k2 EQ2]; red. - subst a; subst c. exists (k1 + k2). ring. -Qed. - -Lemma eqmod_neg: - forall x y, eqmod x y -> eqmod (-x) (-y). -Proof. - intros x y [k EQ]; red. exists (-k). rewrite EQ. ring. -Qed. - -Lemma eqmod_sub: - forall a b c d, eqmod a b -> eqmod c d -> eqmod (a - c) (b - d). -Proof. - intros a b c d [k1 EQ1] [k2 EQ2]; red. - subst a; subst c. exists (k1 - k2). ring. -Qed. - -Lemma eqmod_mult: - forall a b c d, eqmod a c -> eqmod b d -> eqmod (a * b) (c * d). -Proof. - intros a b c d [k1 EQ1] [k2 EQ2]; red. - subst a; subst b. - exists (k1 * k2 * modul + c * k2 + k1 * d). - ring. -Qed. - -End EQ_MODULO. - -Lemma eqmod_divides: - forall n m x y, eqmod n x y -> Z.divide m n -> eqmod m x y. -Proof. - intros. destruct H as [k1 EQ1]. destruct H0 as [k2 EQ2]. - exists (k1*k2). rewrite <- Z.mul_assoc. rewrite <- EQ2. auto. -Qed. - -(** We then specialize these definitions to equality modulo - $2^{wordsize}$ #2<sup>wordsize</sup>#. *) - -Hint Resolve modulus_pos: ints. +(** [eqm] is equality modulo $2^{wordsize}$ #2<sup>wordsize</sup>#. *) Definition eqm := eqmod modulus. @@ -637,6 +440,19 @@ Lemma eqm_mult: Proof (eqmod_mult modulus). Hint Resolve eqm_mult: ints. +Lemma eqm_same_bits: + forall x y, + (forall i, 0 <= i < zwordsize -> Z.testbit x i = Z.testbit y i) -> + eqm x y. +Proof (eqmod_same_bits wordsize). + +Lemma same_bits_eqm: + forall x y i, + eqm x y -> + 0 <= i < zwordsize -> + Z.testbit x i = Z.testbit y i. +Proof (same_bits_eqmod wordsize). + (** ** Properties of the coercions between [Z] and [int] *) Lemma eqm_samerepr: forall x y, eqm x y -> repr x = repr y. @@ -706,7 +522,7 @@ Theorem repr_unsigned: forall i, repr (unsigned i) = i. Proof. destruct i; simpl. unfold repr. apply mkint_eq. - rewrite Z_mod_modulus_eq. apply Zmod_small; omega. + rewrite Z_mod_modulus_eq. apply Z.mod_small; omega. Qed. Hint Resolve repr_unsigned: ints. @@ -729,7 +545,7 @@ Theorem unsigned_repr: forall z, 0 <= z <= max_unsigned -> unsigned (repr z) = z. Proof. intros. rewrite unsigned_repr_eq. - apply Zmod_small. unfold max_unsigned in H. omega. + apply Z.mod_small. unfold max_unsigned in H. omega. Qed. Hint Resolve unsigned_repr: ints. @@ -776,7 +592,7 @@ Qed. Theorem unsigned_one: unsigned one = 1. Proof. - unfold one; rewrite unsigned_repr_eq. apply Zmod_small. split. omega. + unfold one; rewrite unsigned_repr_eq. apply Z.mod_small. split. omega. unfold modulus. replace wordsize with (S(Init.Nat.pred wordsize)). rewrite two_power_nat_S. generalize (two_power_nat_pos (Init.Nat.pred wordsize)). omega. @@ -787,7 +603,7 @@ Theorem unsigned_mone: unsigned mone = modulus - 1. Proof. unfold mone; rewrite unsigned_repr_eq. replace (-1) with ((modulus - 1) + (-1) * modulus). - rewrite Z_mod_plus_full. apply Zmod_small. + rewrite Z_mod_plus_full. apply Z.mod_small. generalize modulus_pos. omega. omega. Qed. @@ -819,7 +635,7 @@ Qed. Theorem unsigned_repr_wordsize: unsigned iwordsize = zwordsize. Proof. - unfold iwordsize; rewrite unsigned_repr_eq. apply Zmod_small. + unfold iwordsize; rewrite unsigned_repr_eq. apply Z.mod_small. generalize wordsize_pos wordsize_max_unsigned; unfold max_unsigned; omega. Qed. @@ -1298,298 +1114,6 @@ Qed. (** ** Bit-level properties *) -(** ** Properties of bit-level operations over [Z] *) - -Remark Ztestbit_0: forall n, Z.testbit 0 n = false. -Proof Z.testbit_0_l. - -Remark Ztestbit_1: forall n, Z.testbit 1 n = zeq n 0. -Proof. - intros. destruct n; simpl; auto. -Qed. - -Remark Ztestbit_m1: forall n, 0 <= n -> Z.testbit (-1) n = true. -Proof. - intros. destruct n; simpl; auto. -Qed. - -Remark Zshiftin_spec: - forall b x, Zshiftin b x = 2 * x + (if b then 1 else 0). -Proof. - unfold Zshiftin; intros. destruct b. - - rewrite Z.succ_double_spec. omega. - - rewrite Z.double_spec. omega. -Qed. - -Remark Zshiftin_inj: - forall b1 x1 b2 x2, - Zshiftin b1 x1 = Zshiftin b2 x2 -> b1 = b2 /\ x1 = x2. -Proof. - intros. rewrite !Zshiftin_spec in H. - destruct b1; destruct b2. - split; [auto|omega]. - omegaContradiction. - omegaContradiction. - split; [auto|omega]. -Qed. - -Remark Zdecomp: - forall x, x = Zshiftin (Z.odd x) (Z.div2 x). -Proof. - intros. destruct x; simpl. - - auto. - - destruct p; auto. - - destruct p; auto. simpl. rewrite Pos.pred_double_succ. auto. -Qed. - -Remark Ztestbit_shiftin: - forall b x n, - 0 <= n -> - Z.testbit (Zshiftin b x) n = if zeq n 0 then b else Z.testbit x (Z.pred n). -Proof. - intros. rewrite Zshiftin_spec. destruct (zeq n 0). - - subst n. destruct b. - + apply Z.testbit_odd_0. - + rewrite Z.add_0_r. apply Z.testbit_even_0. - - assert (0 <= Z.pred n) by omega. - set (n' := Z.pred n) in *. - replace n with (Z.succ n') by (unfold n'; omega). - destruct b. - + apply Z.testbit_odd_succ; auto. - + rewrite Z.add_0_r. apply Z.testbit_even_succ; auto. -Qed. - -Remark Ztestbit_shiftin_base: - forall b x, Z.testbit (Zshiftin b x) 0 = b. -Proof. - intros. rewrite Ztestbit_shiftin. apply zeq_true. omega. -Qed. - -Remark Ztestbit_shiftin_succ: - forall b x n, 0 <= n -> Z.testbit (Zshiftin b x) (Z.succ n) = Z.testbit x n. -Proof. - intros. rewrite Ztestbit_shiftin. rewrite zeq_false. rewrite Z.pred_succ. auto. - omega. omega. -Qed. - -Remark Ztestbit_eq: - forall n x, 0 <= n -> - Z.testbit x n = if zeq n 0 then Z.odd x else Z.testbit (Z.div2 x) (Z.pred n). -Proof. - intros. rewrite (Zdecomp x) at 1. apply Ztestbit_shiftin; auto. -Qed. - -Remark Ztestbit_base: - forall x, Z.testbit x 0 = Z.odd x. -Proof. - intros. rewrite Ztestbit_eq. apply zeq_true. omega. -Qed. - -Remark Ztestbit_succ: - forall n x, 0 <= n -> Z.testbit x (Z.succ n) = Z.testbit (Z.div2 x) n. -Proof. - intros. rewrite Ztestbit_eq. rewrite zeq_false. rewrite Z.pred_succ. auto. - omega. omega. -Qed. - -Lemma eqmod_same_bits: - forall n x y, - (forall i, 0 <= i < Z.of_nat n -> Z.testbit x i = Z.testbit y i) -> - eqmod (two_power_nat n) x y. -Proof. - induction n; intros. - - change (two_power_nat 0) with 1. exists (x-y); ring. - - rewrite two_power_nat_S. - assert (eqmod (two_power_nat n) (Z.div2 x) (Z.div2 y)). - apply IHn. intros. rewrite <- !Ztestbit_succ. apply H. rewrite Nat2Z.inj_succ; omega. - omega. omega. - destruct H0 as [k EQ]. - exists k. rewrite (Zdecomp x). rewrite (Zdecomp y). - replace (Z.odd y) with (Z.odd x). - rewrite EQ. rewrite !Zshiftin_spec. ring. - exploit (H 0). rewrite Nat2Z.inj_succ; omega. - rewrite !Ztestbit_base. auto. -Qed. - -Lemma eqm_same_bits: - forall x y, - (forall i, 0 <= i < zwordsize -> Z.testbit x i = Z.testbit y i) -> - eqm x y. -Proof (eqmod_same_bits wordsize). - -Lemma same_bits_eqmod: - forall n x y i, - eqmod (two_power_nat n) x y -> 0 <= i < Z.of_nat n -> - Z.testbit x i = Z.testbit y i. -Proof. - induction n; intros. - - simpl in H0. omegaContradiction. - - rewrite Nat2Z.inj_succ in H0. rewrite two_power_nat_S in H. - rewrite !(Ztestbit_eq i); intuition. - destruct H as [k EQ]. - assert (EQ': Zshiftin (Z.odd x) (Z.div2 x) = - Zshiftin (Z.odd y) (k * two_power_nat n + Z.div2 y)). - { - rewrite (Zdecomp x) in EQ. rewrite (Zdecomp y) in EQ. - rewrite EQ. rewrite !Zshiftin_spec. ring. - } - exploit Zshiftin_inj; eauto. intros [A B]. - destruct (zeq i 0). - + auto. - + apply IHn. exists k; auto. omega. -Qed. - -Lemma same_bits_eqm: - forall x y i, - eqm x y -> - 0 <= i < zwordsize -> - Z.testbit x i = Z.testbit y i. -Proof (same_bits_eqmod wordsize). - -Remark two_power_nat_infinity: - forall x, 0 <= x -> exists n, x < two_power_nat n. -Proof. - intros x0 POS0; pattern x0; apply natlike_ind; auto. - exists O. compute; auto. - intros. destruct H0 as [n LT]. exists (S n). rewrite two_power_nat_S. - generalize (two_power_nat_pos n). omega. -Qed. - -Lemma equal_same_bits: - forall x y, - (forall i, 0 <= i -> Z.testbit x i = Z.testbit y i) -> - x = y. -Proof. - intros. - set (z := if zlt x y then y - x else x - y). - assert (0 <= z). - unfold z; destruct (zlt x y); omega. - exploit (two_power_nat_infinity z); auto. intros [n LT]. - assert (eqmod (two_power_nat n) x y). - apply eqmod_same_bits. intros. apply H. tauto. - assert (eqmod (two_power_nat n) z 0). - unfold z. destruct (zlt x y). - replace 0 with (y - y) by omega. apply eqmod_sub. apply eqmod_refl. auto. - replace 0 with (x - x) by omega. apply eqmod_sub. apply eqmod_refl. apply eqmod_sym; auto. - assert (z = 0). - apply eqmod_small_eq with (two_power_nat n). auto. omega. generalize (two_power_nat_pos n); omega. - unfold z in H3. destruct (zlt x y); omega. -Qed. - -Lemma Z_one_complement: - forall i, 0 <= i -> - forall x, Z.testbit (-x-1) i = negb (Z.testbit x i). -Proof. - intros i0 POS0. pattern i0. apply Zlt_0_ind; auto. - intros i IND POS x. - rewrite (Zdecomp x). set (y := Z.div2 x). - replace (- Zshiftin (Z.odd x) y - 1) - with (Zshiftin (negb (Z.odd x)) (- y - 1)). - rewrite !Ztestbit_shiftin; auto. - destruct (zeq i 0). auto. apply IND. omega. - rewrite !Zshiftin_spec. destruct (Z.odd x); simpl negb; ring. -Qed. - -Lemma Ztestbit_above: - forall n x i, - 0 <= x < two_power_nat n -> - i >= Z.of_nat n -> - Z.testbit x i = false. -Proof. - induction n; intros. - - change (two_power_nat 0) with 1 in H. - replace x with 0 by omega. - apply Z.testbit_0_l. - - rewrite Nat2Z.inj_succ in H0. rewrite Ztestbit_eq. rewrite zeq_false. - apply IHn. rewrite two_power_nat_S in H. rewrite (Zdecomp x) in H. - rewrite Zshiftin_spec in H. destruct (Z.odd x); omega. - omega. omega. omega. -Qed. - -Lemma Ztestbit_above_neg: - forall n x i, - -two_power_nat n <= x < 0 -> - i >= Z.of_nat n -> - Z.testbit x i = true. -Proof. - intros. set (y := -x-1). - assert (Z.testbit y i = false). - apply Ztestbit_above with n. - unfold y; omega. auto. - unfold y in H1. rewrite Z_one_complement in H1. - change true with (negb false). rewrite <- H1. rewrite negb_involutive; auto. - omega. -Qed. - -Lemma Zsign_bit: - forall n x, - 0 <= x < two_power_nat (S n) -> - Z.testbit x (Z.of_nat n) = if zlt x (two_power_nat n) then false else true. -Proof. - induction n; intros. - - change (two_power_nat 1) with 2 in H. - assert (x = 0 \/ x = 1) by omega. - destruct H0; subst x; reflexivity. - - rewrite Nat2Z.inj_succ. rewrite Ztestbit_eq. rewrite zeq_false. rewrite Z.pred_succ. - rewrite IHn. rewrite two_power_nat_S. - destruct (zlt (Z.div2 x) (two_power_nat n)); rewrite (Zdecomp x); rewrite Zshiftin_spec. - rewrite zlt_true. auto. destruct (Z.odd x); omega. - rewrite zlt_false. auto. destruct (Z.odd x); omega. - rewrite (Zdecomp x) in H; rewrite Zshiftin_spec in H. - rewrite two_power_nat_S in H. destruct (Z.odd x); omega. - omega. omega. -Qed. - -Lemma Zshiftin_ind: - forall (P: Z -> Prop), - P 0 -> - (forall b x, 0 <= x -> P x -> P (Zshiftin b x)) -> - forall x, 0 <= x -> P x. -Proof. - intros. destruct x. - - auto. - - induction p. - + change (P (Zshiftin true (Z.pos p))). auto. - + change (P (Zshiftin false (Z.pos p))). auto. - + change (P (Zshiftin true 0)). apply H0. omega. auto. - - compute in H1. intuition congruence. -Qed. - -Lemma Zshiftin_pos_ind: - forall (P: Z -> Prop), - P 1 -> - (forall b x, 0 < x -> P x -> P (Zshiftin b x)) -> - forall x, 0 < x -> P x. -Proof. - intros. destruct x; simpl in H1; try discriminate. - induction p. - + change (P (Zshiftin true (Z.pos p))). auto. - + change (P (Zshiftin false (Z.pos p))). auto. - + auto. -Qed. - -Lemma Ztestbit_le: - forall x y, - 0 <= y -> - (forall i, 0 <= i -> Z.testbit x i = true -> Z.testbit y i = true) -> - x <= y. -Proof. - intros x y0 POS0; revert x; pattern y0; apply Zshiftin_ind; auto; intros. - - replace x with 0. omega. apply equal_same_bits; intros. - rewrite Ztestbit_0. destruct (Z.testbit x i) as [] eqn:E; auto. - exploit H; eauto. rewrite Ztestbit_0. auto. - - assert (Z.div2 x0 <= x). - { apply H0. intros. exploit (H1 (Z.succ i)). - omega. rewrite Ztestbit_succ; auto. rewrite Ztestbit_shiftin_succ; auto. - } - rewrite (Zdecomp x0). rewrite !Zshiftin_spec. - destruct (Z.odd x0) as [] eqn:E1; destruct b as [] eqn:E2; try omega. - exploit (H1 0). omega. rewrite Ztestbit_base; auto. - rewrite Ztestbit_shiftin_base. congruence. -Qed. - -(** ** Bit-level reasoning over type [int] *) - Definition testbit (x: int) (i: Z) : bool := Z.testbit (unsigned x) i. Lemma testbit_repr: @@ -1888,7 +1412,7 @@ Proof. rewrite bits_or; auto. rewrite H0; auto. Qed. -(** Properties of bitwise complement.*) +(** ** Properties of bitwise complement.*) Theorem not_involutive: forall (x: int), not (not x) = x. @@ -2007,7 +1531,7 @@ Proof. rewrite xor_idem. rewrite unsigned_one, unsigned_zero; auto. Qed. -(** Connections between [add] and bitwise logical operations. *) +(** ** Connections between [add] and bitwise logical operations. *) Lemma Z_add_is_or: forall i, 0 <= i -> @@ -2458,7 +1982,7 @@ Proof. - rewrite andb_false_r; auto. - generalize (unsigned_range n); intros. rewrite bits_mone. rewrite andb_true_r. f_equal. - symmetry. apply Zmod_small. omega. + symmetry. apply Z.mod_small. omega. omega. Qed. @@ -2485,7 +2009,7 @@ Theorem rol_zero: rol x zero = x. Proof. bit_solve. f_equal. rewrite unsigned_zero. rewrite Z.sub_0_r. - apply Zmod_small; auto. + apply Z.mod_small; auto. Qed. Lemma bitwise_binop_rol: @@ -2610,65 +2134,31 @@ Proof. rewrite !testbit_repr; auto. rewrite !Z.lor_spec. rewrite orb_comm. f_equal; apply same_bits_eqm; auto. - apply eqm_unsigned_repr_r. apply eqm_refl2. f_equal. - rewrite Zmod_small; auto. + rewrite Z.mod_small; auto. assert (unsigned (add y z) = zwordsize). rewrite H1. apply unsigned_repr_wordsize. unfold add in H5. rewrite unsigned_repr in H5. omega. generalize two_wordsize_max_unsigned; omega. - apply eqm_unsigned_repr_r. apply eqm_refl2. f_equal. - apply Zmod_small; auto. + apply Z.mod_small; auto. Qed. -(** ** Properties of [Z_one_bits] and [is_power2]. *) - -Fixpoint powerserie (l: list Z): Z := - match l with - | nil => 0 - | x :: xs => two_p x + powerserie xs - end. +(** ** Properties of [is_power2]. *) -Lemma Z_one_bits_powerserie: - forall x, 0 <= x < modulus -> x = powerserie (Z_one_bits wordsize x 0). -Proof. - assert (forall n x i, - 0 <= i -> - 0 <= x < two_power_nat n -> - x * two_p i = powerserie (Z_one_bits n x i)). - { - induction n; intros. - simpl. rewrite two_power_nat_O in H0. - assert (x = 0) by omega. subst x. omega. - rewrite two_power_nat_S in H0. simpl Z_one_bits. - rewrite (Zdecomp x) in H0. rewrite Zshiftin_spec in H0. - assert (EQ: Z.div2 x * two_p (i + 1) = powerserie (Z_one_bits n (Z.div2 x) (i + 1))). - apply IHn. omega. - destruct (Z.odd x); omega. - rewrite two_p_is_exp in EQ. change (two_p 1) with 2 in EQ. - rewrite (Zdecomp x) at 1. rewrite Zshiftin_spec. - destruct (Z.odd x); simpl powerserie; rewrite <- EQ; ring. - omega. omega. - } - intros. rewrite <- H. change (two_p 0) with 1. omega. - omega. exact H0. -Qed. - -Lemma Z_one_bits_range: - forall x i, In i (Z_one_bits wordsize x 0) -> 0 <= i < zwordsize. +Remark is_power2_inv: + forall n logn, + is_power2 n = Some logn -> + Z_is_power2 (unsigned n) = Some (unsigned logn) /\ 0 <= unsigned logn < zwordsize. Proof. - assert (forall n x i j, - In j (Z_one_bits n x i) -> i <= j < i + Z.of_nat n). - { - induction n; simpl In. - tauto. - intros x i j. rewrite Nat2Z.inj_succ. - assert (In j (Z_one_bits n (Z.div2 x) (i + 1)) -> i <= j < i + Z.succ (Z.of_nat n)). - intros. exploit IHn; eauto. omega. - destruct (Z.odd x); simpl. - intros [A|B]. subst j. omega. auto. - auto. - } - intros. generalize (H wordsize x 0 i H0). fold zwordsize; omega. + unfold is_power2; intros. + destruct (Z_is_power2 (unsigned n)) as [i|] eqn:E; inv H. + assert (0 <= i < zwordsize). + { apply Z_is_power2_range with (unsigned n). + generalize wordsize_pos; omega. + rewrite <- modulus_power. apply unsigned_range. + auto. } + rewrite unsigned_repr; auto. generalize wordsize_max_unsigned; omega. Qed. Lemma is_power2_rng: @@ -2676,16 +2166,7 @@ Lemma is_power2_rng: is_power2 n = Some logn -> 0 <= unsigned logn < zwordsize. Proof. - intros n logn. unfold is_power2. - generalize (Z_one_bits_range (unsigned n)). - destruct (Z_one_bits wordsize (unsigned n) 0). - intros; discriminate. - destruct l. - intros. injection H0; intro; subst logn; clear H0. - assert (0 <= z < zwordsize). - apply H. auto with coqlib. - rewrite unsigned_repr. auto. generalize wordsize_max_unsigned; omega. - intros; discriminate. + intros. apply (is_power2_inv n logn); auto. Qed. Theorem is_power2_range: @@ -2701,18 +2182,8 @@ Lemma is_power2_correct: is_power2 n = Some logn -> unsigned n = two_p (unsigned logn). Proof. - intros n logn. unfold is_power2. - generalize (Z_one_bits_powerserie (unsigned n) (unsigned_range n)). - generalize (Z_one_bits_range (unsigned n)). - destruct (Z_one_bits wordsize (unsigned n) 0). - intros; discriminate. - destruct l. - intros. simpl in H0. injection H1; intros; subst logn; clear H1. - rewrite unsigned_repr. replace (two_p z) with (two_p z + 0). - auto. omega. elim (H z); intros. - generalize wordsize_max_unsigned; omega. - auto with coqlib. - intros; discriminate. + intros. apply is_power2_inv in H. destruct H as [P Q]. + apply Z_is_power2_sound in P. tauto. Qed. Remark two_p_range: @@ -2727,34 +2198,12 @@ Proof. unfold max_unsigned, modulus. omega. Qed. -Remark Z_one_bits_zero: - forall n i, Z_one_bits n 0 i = nil. -Proof. - induction n; intros; simpl; auto. -Qed. - -Remark Z_one_bits_two_p: - forall n x i, - 0 <= x < Z.of_nat n -> - Z_one_bits n (two_p x) i = (i + x) :: nil. -Proof. - induction n; intros; simpl. simpl in H. omegaContradiction. - rewrite Nat2Z.inj_succ in H. - assert (x = 0 \/ 0 < x) by omega. destruct H0. - subst x; simpl. decEq. omega. apply Z_one_bits_zero. - assert (Z.odd (two_p x) = false /\ Z.div2 (two_p x) = two_p (x-1)). - apply Zshiftin_inj. rewrite <- Zdecomp. rewrite !Zshiftin_spec. - rewrite <- two_p_S. rewrite Z.add_0_r. f_equal; omega. omega. - destruct H1 as [A B]; rewrite A; rewrite B. - rewrite IHn. f_equal; omega. omega. -Qed. - Lemma is_power2_two_p: forall n, 0 <= n < zwordsize -> is_power2 (repr (two_p n)) = Some (repr n). Proof. intros. unfold is_power2. rewrite unsigned_repr. - rewrite Z_one_bits_two_p. auto. auto. + rewrite Z_is_power2_complete by omega; auto. apply two_p_range. auto. Qed. @@ -2762,19 +2211,6 @@ Qed. (** Left shifts and multiplications by powers of 2. *) -Lemma Zshiftl_mul_two_p: - forall x n, 0 <= n -> Z.shiftl x n = x * two_p n. -Proof. - intros. destruct n; simpl. - - omega. - - pattern p. apply Pos.peano_ind. - + change (two_power_pos 1) with 2. simpl. ring. - + intros. rewrite Pos.iter_succ. rewrite H0. - rewrite Pplus_one_succ_l. rewrite two_power_pos_is_exp. - change (two_power_pos 1) with 2. ring. - - compute in H. congruence. -Qed. - Lemma shl_mul_two_p: forall x y, shl x y = mul x (repr (two_p (unsigned y))). @@ -2834,21 +2270,6 @@ Qed. (** Unsigned right shifts and unsigned divisions by powers of 2. *) -Lemma Zshiftr_div_two_p: - forall x n, 0 <= n -> Z.shiftr x n = x / two_p n. -Proof. - intros. destruct n; unfold Z.shiftr; simpl. - - rewrite Zdiv_1_r. auto. - - pattern p. apply Pos.peano_ind. - + change (two_power_pos 1) with 2. simpl. apply Zdiv2_div. - + intros. rewrite Pos.iter_succ. rewrite H0. - rewrite Pplus_one_succ_l. rewrite two_power_pos_is_exp. - change (two_power_pos 1) with 2. - rewrite Zdiv2_div. rewrite Z.mul_comm. apply Zdiv_Zdiv. - rewrite two_power_pos_nat. apply two_power_nat_pos. omega. - - compute in H. congruence. -Qed. - Lemma shru_div_two_p: forall x y, shru x y = repr (unsigned x / two_p (unsigned y)). @@ -2891,43 +2312,6 @@ Qed. (** Unsigned modulus over [2^n] is masking with [2^n-1]. *) -Lemma Ztestbit_mod_two_p: - forall n x i, - 0 <= n -> 0 <= i -> - Z.testbit (x mod (two_p n)) i = if zlt i n then Z.testbit x i else false. -Proof. - intros n0 x i N0POS. revert x i; pattern n0; apply natlike_ind; auto. - - intros. change (two_p 0) with 1. rewrite Zmod_1_r. rewrite Z.testbit_0_l. - rewrite zlt_false; auto. omega. - - intros. rewrite two_p_S; auto. - replace (x0 mod (2 * two_p x)) - with (Zshiftin (Z.odd x0) (Z.div2 x0 mod two_p x)). - rewrite Ztestbit_shiftin; auto. rewrite (Ztestbit_eq i x0); auto. destruct (zeq i 0). - + rewrite zlt_true; auto. omega. - + rewrite H0. destruct (zlt (Z.pred i) x). - * rewrite zlt_true; auto. omega. - * rewrite zlt_false; auto. omega. - * omega. - + rewrite (Zdecomp x0) at 3. set (x1 := Z.div2 x0). symmetry. - apply Zmod_unique with (x1 / two_p x). - rewrite !Zshiftin_spec. rewrite Z.add_assoc. f_equal. - transitivity (2 * (two_p x * (x1 / two_p x) + x1 mod two_p x)). - f_equal. apply Z_div_mod_eq. apply two_p_gt_ZERO; auto. - ring. - rewrite Zshiftin_spec. exploit (Z_mod_lt x1 (two_p x)). apply two_p_gt_ZERO; auto. - destruct (Z.odd x0); omega. -Qed. - -Corollary Ztestbit_two_p_m1: - forall n i, 0 <= n -> 0 <= i -> - Z.testbit (two_p n - 1) i = if zlt i n then true else false. -Proof. - intros. replace (two_p n - 1) with ((-1) mod (two_p n)). - rewrite Ztestbit_mod_two_p; auto. destruct (zlt i n); auto. apply Ztestbit_m1; auto. - apply Zmod_unique with (-1). ring. - exploit (two_p_gt_ZERO n). auto. omega. -Qed. - Theorem modu_and: forall x n logn, is_power2 n = Some logn -> @@ -2949,21 +2333,6 @@ Qed. (** ** Properties of [shrx] (signed division by a power of 2) *) -Lemma Zquot_Zdiv: - forall x y, - y > 0 -> - Z.quot x y = if zlt x 0 then (x + y - 1) / y else x / y. -Proof. - intros. destruct (zlt x 0). - - symmetry. apply Zquot_unique_full with ((x + y - 1) mod y - (y - 1)). - + red. right; split. omega. - exploit (Z_mod_lt (x + y - 1) y); auto. - rewrite Z.abs_eq. omega. omega. - + transitivity ((y * ((x + y - 1) / y) + (x + y - 1) mod y) - (y-1)). - rewrite <- Z_div_mod_eq. ring. auto. ring. - - apply Zquot_Zdiv_pos; omega. -Qed. - Theorem shrx_zero: forall x, zwordsize > 1 -> shrx x zero = x. Proof. @@ -3042,17 +2411,6 @@ Proof. bit_solve. destruct (zlt (i + unsigned (sub iwordsize y)) zwordsize); auto. Qed. -Lemma Zdiv_shift: - forall x y, y > 0 -> - (x + (y - 1)) / y = x / y + if zeq (Z.modulo x y) 0 then 0 else 1. -Proof. - intros. generalize (Z_div_mod_eq x y H). generalize (Z_mod_lt x y H). - set (q := x / y). set (r := x mod y). intros. - destruct (zeq r 0). - apply Zdiv_unique with (y - 1). rewrite H1. rewrite e. ring. omega. - apply Zdiv_unique with (r - 1). rewrite H1. ring. omega. -Qed. - Theorem shrx_carry: forall x y, ltu y (repr (zwordsize - 1)) = true -> @@ -3143,51 +2501,6 @@ Qed. (** ** Properties of integer zero extension and sign extension. *) -Lemma Ziter_base: - forall (A: Type) n (f: A -> A) x, n <= 0 -> Z.iter n f x = x. -Proof. - intros. unfold Z.iter. destruct n; auto. compute in H. elim H; auto. -Qed. - -Lemma Ziter_succ: - forall (A: Type) n (f: A -> A) x, - 0 <= n -> Z.iter (Z.succ n) f x = f (Z.iter n f x). -Proof. - intros. destruct n; simpl. - - auto. - - rewrite Pos.add_1_r. apply Pos.iter_succ. - - compute in H. elim H; auto. -Qed. - -Lemma Znatlike_ind: - forall (P: Z -> Prop), - (forall n, n <= 0 -> P n) -> - (forall n, 0 <= n -> P n -> P (Z.succ n)) -> - forall n, P n. -Proof. - intros. destruct (zle 0 n). - apply natlike_ind; auto. apply H; omega. - apply H. omega. -Qed. - -Lemma Zzero_ext_spec: - forall n x i, 0 <= i -> - Z.testbit (Zzero_ext n x) i = if zlt i n then Z.testbit x i else false. -Proof. - unfold Zzero_ext. induction n using Znatlike_ind. - - intros. rewrite Ziter_base; auto. - rewrite zlt_false. rewrite Ztestbit_0; auto. omega. - - intros. rewrite Ziter_succ; auto. - rewrite Ztestbit_shiftin; auto. - rewrite (Ztestbit_eq i x); auto. - destruct (zeq i 0). - + subst i. rewrite zlt_true; auto. omega. - + rewrite IHn. destruct (zlt (Z.pred i) n). - rewrite zlt_true; auto. omega. - rewrite zlt_false; auto. omega. - omega. -Qed. - Lemma bits_zero_ext: forall n x i, 0 <= i -> testbit (zero_ext n x) i = if zlt i n then testbit x i else false. @@ -3197,35 +2510,6 @@ Proof. rewrite !bits_above; auto. destruct (zlt i n); auto. Qed. -Lemma Zsign_ext_spec: - forall n x i, 0 <= i -> 0 < n -> - Z.testbit (Zsign_ext n x) i = Z.testbit x (if zlt i n then i else n - 1). -Proof. - intros n0 x i I0 N0. - revert x i I0. pattern n0. apply Zlt_lower_bound_ind with (z := 1). - - unfold Zsign_ext. intros. - destruct (zeq x 1). - + subst x; simpl. - replace (if zlt i 1 then i else 0) with 0. - rewrite Ztestbit_base. - destruct (Z.odd x0). - apply Ztestbit_m1; auto. - apply Ztestbit_0. - destruct (zlt i 1); omega. - + set (x1 := Z.pred x). replace x1 with (Z.succ (Z.pred x1)). - rewrite Ziter_succ. rewrite Ztestbit_shiftin. - destruct (zeq i 0). - * subst i. rewrite zlt_true. rewrite Ztestbit_base; auto. omega. - * rewrite H. unfold x1. destruct (zlt (Z.pred i) (Z.pred x)). - rewrite zlt_true. rewrite (Ztestbit_eq i x0); auto. rewrite zeq_false; auto. omega. - rewrite zlt_false. rewrite (Ztestbit_eq (x - 1) x0). rewrite zeq_false; auto. - omega. omega. omega. unfold x1; omega. omega. - * omega. - * unfold x1; omega. - * omega. - - omega. -Qed. - Lemma bits_sign_ext: forall n x i, 0 <= i < zwordsize -> 0 < n -> testbit (sign_ext n x) i = testbit x (if zlt i n then i else n - 1). @@ -3527,7 +2811,7 @@ Proof. auto with ints. decEq. apply Z_one_bits_powerserie. auto with ints. unfold one_bits. - generalize (Z_one_bits_range (unsigned x)). + generalize (Z_one_bits_range wordsize (unsigned x)). generalize (Z_one_bits wordsize (unsigned x) 0). induction l. intros; reflexivity. @@ -3535,7 +2819,8 @@ Proof. apply eqm_add. rewrite shl_mul_two_p. rewrite mul_commut. rewrite mul_one. apply eqm_unsigned_repr_r. rewrite unsigned_repr. auto with ints. - generalize (H a (in_eq _ _)). generalize wordsize_max_unsigned. omega. + generalize (H a (in_eq _ _)). change (Z.of_nat wordsize) with zwordsize. + generalize wordsize_max_unsigned. omega. auto with ints. intros; apply H; auto with coqlib. Qed. @@ -3735,8 +3020,7 @@ Proof. intros. rewrite <- negb_orb. rewrite <- not_ltu. rewrite negb_involutive. auto. Qed. - -(** Non-overlapping test *) +(** ** Non-overlapping test *) Definition no_overlap (ofs1: int) (sz1: Z) (ofs2: int) (sz2: Z) : bool := let x1 := unsigned ofs1 in let x2 := unsigned ofs2 in @@ -3762,94 +3046,10 @@ Proof. intros [C|C] [D|D]; omega. Qed. -(** Size of integers, in bits. *) - -Definition Zsize (x: Z) : Z := - match x with - | Zpos p => Zpos (Pos.size p) - | _ => 0 - end. +(** ** Size of integers, in bits. *) Definition size (x: int) : Z := Zsize (unsigned x). -Remark Zsize_pos: forall x, 0 <= Zsize x. -Proof. - destruct x; simpl. omega. compute; intuition congruence. omega. -Qed. - -Remark Zsize_pos': forall x, 0 < x -> 0 < Zsize x. -Proof. - destruct x; simpl; intros; try discriminate. compute; auto. -Qed. - -Lemma Zsize_shiftin: - forall b x, 0 < x -> Zsize (Zshiftin b x) = Z.succ (Zsize x). -Proof. - intros. destruct x; compute in H; try discriminate. - destruct b. - change (Zshiftin true (Zpos p)) with (Zpos (p~1)). - simpl. f_equal. rewrite Pos.add_1_r; auto. - change (Zshiftin false (Zpos p)) with (Zpos (p~0)). - simpl. f_equal. rewrite Pos.add_1_r; auto. -Qed. - -Lemma Ztestbit_size_1: - forall x, 0 < x -> Z.testbit x (Z.pred (Zsize x)) = true. -Proof. - intros x0 POS0; pattern x0; apply Zshiftin_pos_ind; auto. - intros. rewrite Zsize_shiftin; auto. - replace (Z.pred (Z.succ (Zsize x))) with (Z.succ (Z.pred (Zsize x))) by omega. - rewrite Ztestbit_shiftin_succ. auto. generalize (Zsize_pos' x H); omega. -Qed. - -Lemma Ztestbit_size_2: - forall x, 0 <= x -> forall i, i >= Zsize x -> Z.testbit x i = false. -Proof. - intros x0 POS0. destruct (zeq x0 0). - - subst x0; intros. apply Ztestbit_0. - - pattern x0; apply Zshiftin_pos_ind. - + simpl. intros. change 1 with (Zshiftin true 0). rewrite Ztestbit_shiftin. - rewrite zeq_false. apply Ztestbit_0. omega. omega. - + intros. rewrite Zsize_shiftin in H1; auto. - generalize (Zsize_pos' _ H); intros. - rewrite Ztestbit_shiftin. rewrite zeq_false. apply H0. omega. - omega. omega. - + omega. -Qed. - -Lemma Zsize_interval_1: - forall x, 0 <= x -> 0 <= x < two_p (Zsize x). -Proof. - intros. - assert (x = x mod (two_p (Zsize x))). - apply equal_same_bits; intros. - rewrite Ztestbit_mod_two_p; auto. - destruct (zlt i (Zsize x)). auto. apply Ztestbit_size_2; auto. - apply Zsize_pos; auto. - rewrite H0 at 1. rewrite H0 at 3. apply Z_mod_lt. apply two_p_gt_ZERO. apply Zsize_pos; auto. -Qed. - -Lemma Zsize_interval_2: - forall x n, 0 <= n -> 0 <= x < two_p n -> n >= Zsize x. -Proof. - intros. set (N := Z.to_nat n). - assert (Z.of_nat N = n) by (apply Z2Nat.id; auto). - rewrite <- H1 in H0. rewrite <- two_power_nat_two_p in H0. - destruct (zeq x 0). - subst x; simpl; omega. - destruct (zlt n (Zsize x)); auto. - exploit (Ztestbit_above N x (Z.pred (Zsize x))). auto. omega. - rewrite Ztestbit_size_1. congruence. omega. -Qed. - -Lemma Zsize_monotone: - forall x y, 0 <= x <= y -> Zsize x <= Zsize y. -Proof. - intros. apply Z.ge_le. apply Zsize_interval_2. apply Zsize_pos. - exploit (Zsize_interval_1 y). omega. - omega. -Qed. - Theorem size_zero: size zero = 0. Proof. unfold size; rewrite unsigned_zero; auto. @@ -4315,7 +3515,7 @@ Theorem one_bits'_range: Proof. intros. destruct (list_in_map_inv _ _ _ H) as [i0 [EQ IN]]. - exploit Z_one_bits_range; eauto. intros R. + exploit Z_one_bits_range; eauto. fold zwordsize. intros R. unfold Int.ltu. rewrite EQ. rewrite Int.unsigned_repr. change (Int.unsigned iwordsize') with zwordsize. apply zlt_true. omega. assert (zwordsize < Int.max_unsigned) by reflexivity. omega. @@ -4374,7 +3574,7 @@ Lemma is_power2'_correct: Proof. unfold is_power2'; intros. destruct (Z_one_bits wordsize (unsigned n) 0) as [ | i [ | ? ?]] eqn:B; inv H. - rewrite (Z_one_bits_powerserie (unsigned n)) by (apply unsigned_range). + rewrite (Z_one_bits_powerserie wordsize (unsigned n)) by (apply unsigned_range). rewrite Int.unsigned_repr. rewrite B; simpl. omega. assert (0 <= i < zwordsize). { apply Z_one_bits_range with (unsigned n). rewrite B; auto with coqlib. } diff --git a/lib/Zbits.v b/lib/Zbits.v new file mode 100644 index 00000000..dca2a5a2 --- /dev/null +++ b/lib/Zbits.v @@ -0,0 +1,1028 @@ +(* *********************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Xavier Leroy, Collège de France and Inria Paris *) +(* *) +(* Copyright Institut National de Recherche en Informatique et en *) +(* Automatique. All rights reserved. This file is distributed *) +(* under the terms of the GNU General Public License as published by *) +(* the Free Software Foundation, either version 2 of the License, or *) +(* (at your option) any later version. This file is also distributed *) +(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* *) +(* *********************************************************************) + +(** Additional operations and proofs about binary integers, + on top of the ZArith standard library. *) + +Require Import Psatz Zquot. +Require Import Coqlib. + +(** ** Modulo arithmetic *) + +(** We define and state properties of equality and arithmetic modulo a + positive integer. *) + +Section EQ_MODULO. + +Variable modul: Z. +Hypothesis modul_pos: modul > 0. + +Definition eqmod (x y: Z) : Prop := exists k, x = k * modul + y. + +Lemma eqmod_refl: forall x, eqmod x x. +Proof. + intros; red. exists 0. omega. +Qed. + +Lemma eqmod_refl2: forall x y, x = y -> eqmod x y. +Proof. + intros. subst y. apply eqmod_refl. +Qed. + +Lemma eqmod_sym: forall x y, eqmod x y -> eqmod y x. +Proof. + intros x y [k EQ]; red. exists (-k). subst x. ring. +Qed. + +Lemma eqmod_trans: forall x y z, eqmod x y -> eqmod y z -> eqmod x z. +Proof. + intros x y z [k1 EQ1] [k2 EQ2]; red. + exists (k1 + k2). subst x; subst y. ring. +Qed. + +Lemma eqmod_small_eq: + forall x y, eqmod x y -> 0 <= x < modul -> 0 <= y < modul -> x = y. +Proof. + intros x y [k EQ] I1 I2. + generalize (Zdiv_unique _ _ _ _ EQ I2). intro. + rewrite (Z.div_small x modul I1) in H. subst k. omega. +Qed. + +Lemma eqmod_mod_eq: + forall x y, eqmod x y -> x mod modul = y mod modul. +Proof. + intros x y [k EQ]. subst x. + rewrite Z.add_comm. apply Z_mod_plus. auto. +Qed. + +Lemma eqmod_mod: + forall x, eqmod x (x mod modul). +Proof. + intros; red. exists (x / modul). + rewrite Z.mul_comm. apply Z_div_mod_eq. auto. +Qed. + +Lemma eqmod_add: + forall a b c d, eqmod a b -> eqmod c d -> eqmod (a + c) (b + d). +Proof. + intros a b c d [k1 EQ1] [k2 EQ2]; red. + subst a; subst c. exists (k1 + k2). ring. +Qed. + +Lemma eqmod_neg: + forall x y, eqmod x y -> eqmod (-x) (-y). +Proof. + intros x y [k EQ]; red. exists (-k). rewrite EQ. ring. +Qed. + +Lemma eqmod_sub: + forall a b c d, eqmod a b -> eqmod c d -> eqmod (a - c) (b - d). +Proof. + intros a b c d [k1 EQ1] [k2 EQ2]; red. + subst a; subst c. exists (k1 - k2). ring. +Qed. + +Lemma eqmod_mult: + forall a b c d, eqmod a c -> eqmod b d -> eqmod (a * b) (c * d). +Proof. + intros a b c d [k1 EQ1] [k2 EQ2]; red. + subst a; subst b. + exists (k1 * k2 * modul + c * k2 + k1 * d). + ring. +Qed. + +End EQ_MODULO. + +Lemma eqmod_divides: + forall n m x y, eqmod n x y -> Z.divide m n -> eqmod m x y. +Proof. + intros. destruct H as [k1 EQ1]. destruct H0 as [k2 EQ2]. + exists (k1*k2). rewrite <- Z.mul_assoc. rewrite <- EQ2. auto. +Qed. + +(** ** Fast normalization modulo [2^n] *) + +Fixpoint P_mod_two_p (p: positive) (n: nat) {struct n} : Z := + match n with + | O => 0 + | S m => + match p with + | xH => 1 + | xO q => Z.double (P_mod_two_p q m) + | xI q => Z.succ_double (P_mod_two_p q m) + end + end. + +Definition Z_mod_two_p (x: Z) (n: nat) : Z := + match x with + | Z0 => 0 + | Zpos p => P_mod_two_p p n + | Zneg p => let r := P_mod_two_p p n in if zeq r 0 then 0 else two_power_nat n - r + end. + +Lemma P_mod_two_p_range: + forall n p, 0 <= P_mod_two_p p n < two_power_nat n. +Proof. + induction n; simpl; intros. + - rewrite two_power_nat_O. omega. + - rewrite two_power_nat_S. destruct p. + + generalize (IHn p). rewrite Z.succ_double_spec. omega. + + generalize (IHn p). rewrite Z.double_spec. omega. + + generalize (two_power_nat_pos n). omega. +Qed. + +Lemma P_mod_two_p_eq: + forall n p, P_mod_two_p p n = (Zpos p) mod (two_power_nat n). +Proof. + assert (forall n p, exists y, Zpos p = y * two_power_nat n + P_mod_two_p p n). + { + induction n; simpl; intros. + - rewrite two_power_nat_O. exists (Zpos p). ring. + - rewrite two_power_nat_S. destruct p. + + destruct (IHn p) as [y EQ]. exists y. + change (Zpos p~1) with (2 * Zpos p + 1). rewrite EQ. + rewrite Z.succ_double_spec. ring. + + destruct (IHn p) as [y EQ]. exists y. + change (Zpos p~0) with (2 * Zpos p). rewrite EQ. + rewrite (Z.double_spec (P_mod_two_p p n)). ring. + + exists 0; omega. + } + intros. + destruct (H n p) as [y EQ]. + symmetry. apply Zmod_unique with y. auto. apply P_mod_two_p_range. +Qed. + +Lemma Z_mod_two_p_range: + forall n x, 0 <= Z_mod_two_p x n < two_power_nat n. +Proof. + intros; unfold Z_mod_two_p. generalize (two_power_nat_pos n); intros. + destruct x. + - intuition. + - apply P_mod_two_p_range. + - set (r := P_mod_two_p p n). + assert (0 <= r < two_power_nat n) by apply P_mod_two_p_range. + destruct (zeq r 0). + + intuition. + + Psatz.lia. +Qed. + +Lemma Z_mod_two_p_eq: + forall n x, Z_mod_two_p x n = x mod (two_power_nat n). +Proof. + intros. unfold Z_mod_two_p. generalize (two_power_nat_pos n); intros. + destruct x. + - rewrite Zmod_0_l. auto. + - apply P_mod_two_p_eq. + - generalize (P_mod_two_p_range n p) (P_mod_two_p_eq n p). intros A B. + exploit (Z_div_mod_eq (Zpos p) (two_power_nat n)); auto. intros C. + set (q := Zpos p / two_power_nat n) in *. + set (r := P_mod_two_p p n) in *. + rewrite <- B in C. + change (Z.neg p) with (- (Z.pos p)). destruct (zeq r 0). + + symmetry. apply Zmod_unique with (-q). rewrite C; rewrite e. Psatz.lia. + intuition. + + symmetry. apply Zmod_unique with (-q - 1). rewrite C. Psatz.lia. + intuition. +Qed. + +(** ** Bit-level operations and properties *) + +(** Shift [x] left by one and insert [b] as the low bit of the result. *) + +Definition Zshiftin (b: bool) (x: Z) : Z := + if b then Z.succ_double x else Z.double x. + +Remark Ztestbit_0: forall n, Z.testbit 0 n = false. +Proof Z.testbit_0_l. + +Remark Ztestbit_1: forall n, Z.testbit 1 n = zeq n 0. +Proof. + intros. destruct n; simpl; auto. +Qed. + +Remark Ztestbit_m1: forall n, 0 <= n -> Z.testbit (-1) n = true. +Proof. + intros. destruct n; simpl; auto. +Qed. + +Remark Zshiftin_spec: + forall b x, Zshiftin b x = 2 * x + (if b then 1 else 0). +Proof. + unfold Zshiftin; intros. destruct b. + - rewrite Z.succ_double_spec. omega. + - rewrite Z.double_spec. omega. +Qed. + +Remark Zshiftin_inj: + forall b1 x1 b2 x2, + Zshiftin b1 x1 = Zshiftin b2 x2 -> b1 = b2 /\ x1 = x2. +Proof. + intros. rewrite !Zshiftin_spec in H. + destruct b1; destruct b2. + split; [auto|omega]. + omegaContradiction. + omegaContradiction. + split; [auto|omega]. +Qed. + +Remark Zdecomp: + forall x, x = Zshiftin (Z.odd x) (Z.div2 x). +Proof. + intros. destruct x; simpl. + - auto. + - destruct p; auto. + - destruct p; auto. simpl. rewrite Pos.pred_double_succ. auto. +Qed. + +Remark Ztestbit_shiftin: + forall b x n, + 0 <= n -> + Z.testbit (Zshiftin b x) n = if zeq n 0 then b else Z.testbit x (Z.pred n). +Proof. + intros. rewrite Zshiftin_spec. destruct (zeq n 0). + - subst n. destruct b. + + apply Z.testbit_odd_0. + + rewrite Z.add_0_r. apply Z.testbit_even_0. + - assert (0 <= Z.pred n) by omega. + set (n' := Z.pred n) in *. + replace n with (Z.succ n') by (unfold n'; omega). + destruct b. + + apply Z.testbit_odd_succ; auto. + + rewrite Z.add_0_r. apply Z.testbit_even_succ; auto. +Qed. + +Remark Ztestbit_shiftin_base: + forall b x, Z.testbit (Zshiftin b x) 0 = b. +Proof. + intros. rewrite Ztestbit_shiftin. apply zeq_true. omega. +Qed. + +Remark Ztestbit_shiftin_succ: + forall b x n, 0 <= n -> Z.testbit (Zshiftin b x) (Z.succ n) = Z.testbit x n. +Proof. + intros. rewrite Ztestbit_shiftin. rewrite zeq_false. rewrite Z.pred_succ. auto. + omega. omega. +Qed. + +Lemma Zshiftin_ind: + forall (P: Z -> Prop), + P 0 -> + (forall b x, 0 <= x -> P x -> P (Zshiftin b x)) -> + forall x, 0 <= x -> P x. +Proof. + intros. destruct x. + - auto. + - induction p. + + change (P (Zshiftin true (Z.pos p))). auto. + + change (P (Zshiftin false (Z.pos p))). auto. + + change (P (Zshiftin true 0)). apply H0. omega. auto. + - compute in H1. intuition congruence. +Qed. + +Lemma Zshiftin_pos_ind: + forall (P: Z -> Prop), + P 1 -> + (forall b x, 0 < x -> P x -> P (Zshiftin b x)) -> + forall x, 0 < x -> P x. +Proof. + intros. destruct x; simpl in H1; try discriminate. + induction p. + + change (P (Zshiftin true (Z.pos p))). auto. + + change (P (Zshiftin false (Z.pos p))). auto. + + auto. +Qed. + +(** ** Bit-wise decomposition ([Z.testbit]) *) + +Remark Ztestbit_eq: + forall n x, 0 <= n -> + Z.testbit x n = if zeq n 0 then Z.odd x else Z.testbit (Z.div2 x) (Z.pred n). +Proof. + intros. rewrite (Zdecomp x) at 1. apply Ztestbit_shiftin; auto. +Qed. + +Remark Ztestbit_base: + forall x, Z.testbit x 0 = Z.odd x. +Proof. + intros. rewrite Ztestbit_eq. apply zeq_true. omega. +Qed. + +Remark Ztestbit_succ: + forall n x, 0 <= n -> Z.testbit x (Z.succ n) = Z.testbit (Z.div2 x) n. +Proof. + intros. rewrite Ztestbit_eq. rewrite zeq_false. rewrite Z.pred_succ. auto. + omega. omega. +Qed. + +Lemma eqmod_same_bits: + forall n x y, + (forall i, 0 <= i < Z.of_nat n -> Z.testbit x i = Z.testbit y i) -> + eqmod (two_power_nat n) x y. +Proof. + induction n; intros. + - change (two_power_nat 0) with 1. exists (x-y); ring. + - rewrite two_power_nat_S. + assert (eqmod (two_power_nat n) (Z.div2 x) (Z.div2 y)). + apply IHn. intros. rewrite <- !Ztestbit_succ. apply H. rewrite Nat2Z.inj_succ; omega. + omega. omega. + destruct H0 as [k EQ]. + exists k. rewrite (Zdecomp x). rewrite (Zdecomp y). + replace (Z.odd y) with (Z.odd x). + rewrite EQ. rewrite !Zshiftin_spec. ring. + exploit (H 0). rewrite Nat2Z.inj_succ; omega. + rewrite !Ztestbit_base. auto. +Qed. + +Lemma same_bits_eqmod: + forall n x y i, + eqmod (two_power_nat n) x y -> 0 <= i < Z.of_nat n -> + Z.testbit x i = Z.testbit y i. +Proof. + induction n; intros. + - simpl in H0. omegaContradiction. + - rewrite Nat2Z.inj_succ in H0. rewrite two_power_nat_S in H. + rewrite !(Ztestbit_eq i); intuition. + destruct H as [k EQ]. + assert (EQ': Zshiftin (Z.odd x) (Z.div2 x) = + Zshiftin (Z.odd y) (k * two_power_nat n + Z.div2 y)). + { + rewrite (Zdecomp x) in EQ. rewrite (Zdecomp y) in EQ. + rewrite EQ. rewrite !Zshiftin_spec. ring. + } + exploit Zshiftin_inj; eauto. intros [A B]. + destruct (zeq i 0). + + auto. + + apply IHn. exists k; auto. omega. +Qed. + +Lemma equal_same_bits: + forall x y, + (forall i, 0 <= i -> Z.testbit x i = Z.testbit y i) -> + x = y. +Proof Z.bits_inj'. + +Lemma Z_one_complement: + forall i, 0 <= i -> + forall x, Z.testbit (-x-1) i = negb (Z.testbit x i). +Proof. + intros i0 POS0. pattern i0. apply Zlt_0_ind; auto. + intros i IND POS x. + rewrite (Zdecomp x). set (y := Z.div2 x). + replace (- Zshiftin (Z.odd x) y - 1) + with (Zshiftin (negb (Z.odd x)) (- y - 1)). + rewrite !Ztestbit_shiftin; auto. + destruct (zeq i 0). auto. apply IND. omega. + rewrite !Zshiftin_spec. destruct (Z.odd x); simpl negb; ring. +Qed. + +Lemma Ztestbit_above: + forall n x i, + 0 <= x < two_power_nat n -> + i >= Z.of_nat n -> + Z.testbit x i = false. +Proof. + induction n; intros. + - change (two_power_nat 0) with 1 in H. + replace x with 0 by omega. + apply Z.testbit_0_l. + - rewrite Nat2Z.inj_succ in H0. rewrite Ztestbit_eq. rewrite zeq_false. + apply IHn. rewrite two_power_nat_S in H. rewrite (Zdecomp x) in H. + rewrite Zshiftin_spec in H. destruct (Z.odd x); omega. + omega. omega. omega. +Qed. + +Lemma Ztestbit_above_neg: + forall n x i, + -two_power_nat n <= x < 0 -> + i >= Z.of_nat n -> + Z.testbit x i = true. +Proof. + intros. set (y := -x-1). + assert (Z.testbit y i = false). + apply Ztestbit_above with n. + unfold y; omega. auto. + unfold y in H1. rewrite Z_one_complement in H1. + change true with (negb false). rewrite <- H1. rewrite negb_involutive; auto. + omega. +Qed. + +Lemma Zsign_bit: + forall n x, + 0 <= x < two_power_nat (S n) -> + Z.testbit x (Z.of_nat n) = if zlt x (two_power_nat n) then false else true. +Proof. + induction n; intros. + - change (two_power_nat 1) with 2 in H. + assert (x = 0 \/ x = 1) by omega. + destruct H0; subst x; reflexivity. + - rewrite Nat2Z.inj_succ. rewrite Ztestbit_eq. rewrite zeq_false. rewrite Z.pred_succ. + rewrite IHn. rewrite two_power_nat_S. + destruct (zlt (Z.div2 x) (two_power_nat n)); rewrite (Zdecomp x); rewrite Zshiftin_spec. + rewrite zlt_true. auto. destruct (Z.odd x); omega. + rewrite zlt_false. auto. destruct (Z.odd x); omega. + rewrite (Zdecomp x) in H; rewrite Zshiftin_spec in H. + rewrite two_power_nat_S in H. destruct (Z.odd x); omega. + omega. omega. +Qed. + +Lemma Ztestbit_le: + forall x y, + 0 <= y -> + (forall i, 0 <= i -> Z.testbit x i = true -> Z.testbit y i = true) -> + x <= y. +Proof. + intros x y0 POS0; revert x; pattern y0; apply Zshiftin_ind; auto; intros. + - replace x with 0. omega. apply equal_same_bits; intros. + rewrite Ztestbit_0. destruct (Z.testbit x i) as [] eqn:E; auto. + exploit H; eauto. rewrite Ztestbit_0. auto. + - assert (Z.div2 x0 <= x). + { apply H0. intros. exploit (H1 (Z.succ i)). + omega. rewrite Ztestbit_succ; auto. rewrite Ztestbit_shiftin_succ; auto. + } + rewrite (Zdecomp x0). rewrite !Zshiftin_spec. + destruct (Z.odd x0) as [] eqn:E1; destruct b as [] eqn:E2; try omega. + exploit (H1 0). omega. rewrite Ztestbit_base; auto. + rewrite Ztestbit_shiftin_base. congruence. +Qed. + +Lemma Ztestbit_mod_two_p: + forall n x i, + 0 <= n -> 0 <= i -> + Z.testbit (x mod (two_p n)) i = if zlt i n then Z.testbit x i else false. +Proof. + intros n0 x i N0POS. revert x i; pattern n0; apply natlike_ind; auto. + - intros. change (two_p 0) with 1. rewrite Zmod_1_r. rewrite Z.testbit_0_l. + rewrite zlt_false; auto. omega. + - intros. rewrite two_p_S; auto. + replace (x0 mod (2 * two_p x)) + with (Zshiftin (Z.odd x0) (Z.div2 x0 mod two_p x)). + rewrite Ztestbit_shiftin; auto. rewrite (Ztestbit_eq i x0); auto. destruct (zeq i 0). + + rewrite zlt_true; auto. omega. + + rewrite H0. destruct (zlt (Z.pred i) x). + * rewrite zlt_true; auto. omega. + * rewrite zlt_false; auto. omega. + * omega. + + rewrite (Zdecomp x0) at 3. set (x1 := Z.div2 x0). symmetry. + apply Zmod_unique with (x1 / two_p x). + rewrite !Zshiftin_spec. rewrite Z.add_assoc. f_equal. + transitivity (2 * (two_p x * (x1 / two_p x) + x1 mod two_p x)). + f_equal. apply Z_div_mod_eq. apply two_p_gt_ZERO; auto. + ring. + rewrite Zshiftin_spec. exploit (Z_mod_lt x1 (two_p x)). apply two_p_gt_ZERO; auto. + destruct (Z.odd x0); omega. +Qed. + +Corollary Ztestbit_two_p_m1: + forall n i, 0 <= n -> 0 <= i -> + Z.testbit (two_p n - 1) i = if zlt i n then true else false. +Proof. + intros. replace (two_p n - 1) with ((-1) mod (two_p n)). + rewrite Ztestbit_mod_two_p; auto. destruct (zlt i n); auto. apply Ztestbit_m1; auto. + apply Zmod_unique with (-1). ring. + exploit (two_p_gt_ZERO n). auto. omega. +Qed. + +Corollary Ztestbit_neg_two_p: + forall n i, 0 <= n -> 0 <= i -> + Z.testbit (- (two_p n)) i = if zlt i n then false else true. +Proof. + intros. + replace (- two_p n) with (- (two_p n - 1) - 1) by omega. + rewrite Z_one_complement by auto. + rewrite Ztestbit_two_p_m1 by auto. + destruct (zlt i n); auto. +Qed. + +Lemma Z_add_is_or: + forall i, 0 <= i -> + forall x y, + (forall j, 0 <= j <= i -> Z.testbit x j && Z.testbit y j = false) -> + Z.testbit (x + y) i = Z.testbit x i || Z.testbit y i. +Proof. + intros i0 POS0. pattern i0. apply Zlt_0_ind; auto. + intros i IND POS x y EXCL. + rewrite (Zdecomp x) in *. rewrite (Zdecomp y) in *. + transitivity (Z.testbit (Zshiftin (Z.odd x || Z.odd y) (Z.div2 x + Z.div2 y)) i). + - f_equal. rewrite !Zshiftin_spec. + exploit (EXCL 0). omega. rewrite !Ztestbit_shiftin_base. intros. +Opaque Z.mul. + destruct (Z.odd x); destruct (Z.odd y); simpl in *; discriminate || ring. + - rewrite !Ztestbit_shiftin; auto. + destruct (zeq i 0). + + auto. + + apply IND. omega. intros. + exploit (EXCL (Z.succ j)). omega. + rewrite !Ztestbit_shiftin_succ. auto. + omega. omega. +Qed. + +(** ** Zero and sign extensions *) + +(** In pseudo-code: +<< + Fixpoint Zzero_ext (n: Z) (x: Z) : Z := + if zle n 0 then + 0 + else + Zshiftin (Z.odd x) (Zzero_ext (Z.pred n) (Z.div2 x)). + Fixpoint Zsign_ext (n: Z) (x: Z) : Z := + if zle n 1 then + if Z.odd x then -1 else 0 + else + Zshiftin (Z.odd x) (Zzero_ext (Z.pred n) (Z.div2 x)). +>> + We encode this [nat]-like recursion using the [Z.iter] iteration + function, in order to make the [Zzero_ext] and [Zsign_ext] + functions efficiently executable within Coq. +*) + +Definition Zzero_ext (n: Z) (x: Z) : Z := + Z.iter n + (fun rec x => Zshiftin (Z.odd x) (rec (Z.div2 x))) + (fun x => 0) + x. + +Definition Zsign_ext (n: Z) (x: Z) : Z := + Z.iter (Z.pred n) + (fun rec x => Zshiftin (Z.odd x) (rec (Z.div2 x))) + (fun x => if Z.odd x then -1 else 0) + x. + +Lemma Ziter_base: + forall (A: Type) n (f: A -> A) x, n <= 0 -> Z.iter n f x = x. +Proof. + intros. unfold Z.iter. destruct n; auto. compute in H. elim H; auto. +Qed. + +Lemma Ziter_succ: + forall (A: Type) n (f: A -> A) x, + 0 <= n -> Z.iter (Z.succ n) f x = f (Z.iter n f x). +Proof. + intros. destruct n; simpl. + - auto. + - rewrite Pos.add_1_r. apply Pos.iter_succ. + - compute in H. elim H; auto. +Qed. + +Lemma Znatlike_ind: + forall (P: Z -> Prop), + (forall n, n <= 0 -> P n) -> + (forall n, 0 <= n -> P n -> P (Z.succ n)) -> + forall n, P n. +Proof. + intros. destruct (zle 0 n). + apply natlike_ind; auto. apply H; omega. + apply H. omega. +Qed. + +Lemma Zzero_ext_spec: + forall n x i, 0 <= i -> + Z.testbit (Zzero_ext n x) i = if zlt i n then Z.testbit x i else false. +Proof. + unfold Zzero_ext. induction n using Znatlike_ind. + - intros. rewrite Ziter_base; auto. + rewrite zlt_false. rewrite Ztestbit_0; auto. omega. + - intros. rewrite Ziter_succ; auto. + rewrite Ztestbit_shiftin; auto. + rewrite (Ztestbit_eq i x); auto. + destruct (zeq i 0). + + subst i. rewrite zlt_true; auto. omega. + + rewrite IHn. destruct (zlt (Z.pred i) n). + rewrite zlt_true; auto. omega. + rewrite zlt_false; auto. omega. + omega. +Qed. + +Lemma Zsign_ext_spec: + forall n x i, 0 <= i -> 0 < n -> + Z.testbit (Zsign_ext n x) i = Z.testbit x (if zlt i n then i else n - 1). +Proof. + intros n0 x i I0 N0. + revert x i I0. pattern n0. apply Zlt_lower_bound_ind with (z := 1). + - unfold Zsign_ext. intros. + destruct (zeq x 1). + + subst x; simpl. + replace (if zlt i 1 then i else 0) with 0. + rewrite Ztestbit_base. + destruct (Z.odd x0). + apply Ztestbit_m1; auto. + apply Ztestbit_0. + destruct (zlt i 1); omega. + + set (x1 := Z.pred x). replace x1 with (Z.succ (Z.pred x1)). + rewrite Ziter_succ. rewrite Ztestbit_shiftin. + destruct (zeq i 0). + * subst i. rewrite zlt_true. rewrite Ztestbit_base; auto. omega. + * rewrite H. unfold x1. destruct (zlt (Z.pred i) (Z.pred x)). + rewrite zlt_true. rewrite (Ztestbit_eq i x0); auto. rewrite zeq_false; auto. omega. + rewrite zlt_false. rewrite (Ztestbit_eq (x - 1) x0). rewrite zeq_false; auto. + omega. omega. omega. unfold x1; omega. omega. + * omega. + * unfold x1; omega. + * omega. + - omega. +Qed. + +(** [Zzero_ext n x] is [x modulo 2^n] *) + +Lemma Zzero_ext_mod: + forall n x, 0 <= n -> Zzero_ext n x = x mod (two_p n). +Proof. + intros. apply equal_same_bits; intros. + rewrite Zzero_ext_spec, Ztestbit_mod_two_p by auto. auto. +Qed. + +(** [Zzero_ext n x] is the unique integer congruent to [x] modulo [2^n] in the range [0...2^n-1]. *) + +Lemma Zzero_ext_range: + forall n x, 0 <= n -> 0 <= Zzero_ext n x < two_p n. +Proof. + intros. rewrite Zzero_ext_mod; auto. apply Z_mod_lt. apply two_p_gt_ZERO. omega. +Qed. + +Lemma eqmod_Zzero_ext: + forall n x, 0 <= n -> eqmod (two_p n) (Zzero_ext n x) x. +Proof. + intros. rewrite Zzero_ext_mod; auto. apply eqmod_sym. apply eqmod_mod. + apply two_p_gt_ZERO. omega. +Qed. + +(** Relation between [Zsign_ext n x] and (Zzero_ext n x] *) + +Lemma Zsign_ext_zero_ext: + forall n, 0 < n -> forall x, + Zsign_ext n x = Zzero_ext n x - (if Z.testbit x (n - 1) then two_p n else 0). +Proof. + intros. apply equal_same_bits; intros. + rewrite Zsign_ext_spec by auto. + destruct (Z.testbit x (n - 1)) eqn:SIGNBIT. +- set (n' := - two_p n). + replace (Zzero_ext n x - two_p n) with (Zzero_ext n x + n') by (unfold n'; omega). + rewrite Z_add_is_or; auto. + rewrite Zzero_ext_spec by auto. unfold n'; rewrite Ztestbit_neg_two_p by omega. + destruct (zlt i n). rewrite orb_false_r; auto. auto. + intros. rewrite Zzero_ext_spec by omega. unfold n'; rewrite Ztestbit_neg_two_p by omega. + destruct (zlt j n); auto using andb_false_r. +- replace (Zzero_ext n x - 0) with (Zzero_ext n x) by omega. + rewrite Zzero_ext_spec by auto. + destruct (zlt i n); auto. +Qed. + +(** [Zsign_ext n x] is the unique integer congruent to [x] modulo [2^n] + in the range [-2^(n-1)...2^(n-1) - 1]. *) + +Lemma Zsign_ext_range: + forall n x, 0 < n -> -two_p (n-1) <= Zsign_ext n x < two_p (n-1). +Proof. + intros. + assert (A: 0 <= Zzero_ext n x < two_p n) by (apply Zzero_ext_range; omega). + assert (B: Z.testbit (Zzero_ext n x) (n - 1) = + if zlt (Zzero_ext n x) (two_p (n - 1)) then false else true). + { set (N := Z.to_nat (n - 1)). + generalize (Zsign_bit N (Zzero_ext n x)). + rewrite ! two_power_nat_two_p. + rewrite inj_S. unfold N; rewrite Z2Nat.id by omega. + intros X; apply X. replace (Z.succ (n - 1)) with n by omega. exact A. + } + assert (C: two_p n = 2 * two_p (n - 1)). + { rewrite <- two_p_S by omega. f_equal; omega. } + rewrite Zzero_ext_spec, zlt_true in B by omega. + rewrite Zsign_ext_zero_ext by auto. rewrite B. + destruct (zlt (Zzero_ext n x) (two_p (n - 1))); omega. +Qed. + +Lemma eqmod_Zsign_ext: + forall n x, 0 < n -> + eqmod (two_p n) (Zsign_ext n x) x. +Proof. + intros. rewrite Zsign_ext_zero_ext by auto. + apply eqmod_trans with (x - 0). + apply eqmod_sub. + apply eqmod_Zzero_ext; omega. + exists (if Z.testbit x (n - 1) then 1 else 0). destruct (Z.testbit x (n - 1)); ring. + apply eqmod_refl2; omega. +Qed. + +(** ** Decomposition of a number as a sum of powers of two. *) + +Fixpoint Z_one_bits (n: nat) (x: Z) (i: Z) {struct n}: list Z := + match n with + | O => nil + | S m => + if Z.odd x + then i :: Z_one_bits m (Z.div2 x) (i+1) + else Z_one_bits m (Z.div2 x) (i+1) + end. + +Fixpoint powerserie (l: list Z): Z := + match l with + | nil => 0 + | x :: xs => two_p x + powerserie xs + end. + +Lemma Z_one_bits_powerserie: + forall n x, 0 <= x < two_power_nat n -> x = powerserie (Z_one_bits n x 0). +Proof. + assert (forall n x i, + 0 <= i -> + 0 <= x < two_power_nat n -> + x * two_p i = powerserie (Z_one_bits n x i)). + { + induction n; intros. + simpl. rewrite two_power_nat_O in H0. + assert (x = 0) by omega. subst x. omega. + rewrite two_power_nat_S in H0. simpl Z_one_bits. + rewrite (Zdecomp x) in H0. rewrite Zshiftin_spec in H0. + assert (EQ: Z.div2 x * two_p (i + 1) = powerserie (Z_one_bits n (Z.div2 x) (i + 1))). + apply IHn. omega. + destruct (Z.odd x); omega. + rewrite two_p_is_exp in EQ. change (two_p 1) with 2 in EQ. + rewrite (Zdecomp x) at 1. rewrite Zshiftin_spec. + destruct (Z.odd x); simpl powerserie; rewrite <- EQ; ring. + omega. omega. + } + intros. rewrite <- H. change (two_p 0) with 1. omega. + omega. exact H0. +Qed. + +Lemma Z_one_bits_range: + forall n x i, In i (Z_one_bits n x 0) -> 0 <= i < Z.of_nat n. +Proof. + assert (forall n x i j, + In j (Z_one_bits n x i) -> i <= j < i + Z.of_nat n). + { + induction n; simpl In. + tauto. + intros x i j. rewrite Nat2Z.inj_succ. + assert (In j (Z_one_bits n (Z.div2 x) (i + 1)) -> i <= j < i + Z.succ (Z.of_nat n)). + intros. exploit IHn; eauto. omega. + destruct (Z.odd x); simpl. + intros [A|B]. subst j. omega. auto. + auto. + } + intros. generalize (H n x 0 i H0). omega. +Qed. + +Remark Z_one_bits_zero: + forall n i, Z_one_bits n 0 i = nil. +Proof. + induction n; intros; simpl; auto. +Qed. + +Remark Z_one_bits_two_p: + forall n x i, + 0 <= x < Z.of_nat n -> + Z_one_bits n (two_p x) i = (i + x) :: nil. +Proof. + induction n; intros; simpl. simpl in H. omegaContradiction. + rewrite Nat2Z.inj_succ in H. + assert (x = 0 \/ 0 < x) by omega. destruct H0. + subst x; simpl. decEq. omega. apply Z_one_bits_zero. + assert (Z.odd (two_p x) = false /\ Z.div2 (two_p x) = two_p (x-1)). + apply Zshiftin_inj. rewrite <- Zdecomp. rewrite !Zshiftin_spec. + rewrite <- two_p_S. rewrite Z.add_0_r. f_equal; omega. omega. + destruct H1 as [A B]; rewrite A; rewrite B. + rewrite IHn. f_equal; omega. omega. +Qed. + +(** ** Recognition of powers of two *) + +Fixpoint P_is_power2 (p: positive) : bool := + match p with + | xH => true + | xO q => P_is_power2 q + | xI q => false + end. + +Definition Z_is_power2 (x: Z) : option Z := + match x with + | Z0 => None + | Zpos p => if P_is_power2 p then Some (Z.log2 x) else None + | Zneg _ => None + end. + +Remark P_is_power2_sound: + forall p, P_is_power2 p = true -> Z.pos p = two_p (Z.log2 (Z.pos p)). +Proof. + induction p; simpl P_is_power2; intros. +- discriminate. +- change (Z.pos p~0) with (2 * Z.pos p). apply IHp in H. + rewrite Z.log2_double by xomega. rewrite two_p_S. congruence. + apply Z.log2_nonneg. +- reflexivity. +Qed. + +Lemma Z_is_power2_sound: + forall x i, Z_is_power2 x = Some i -> x = two_p i /\ i = Z.log2 x. +Proof. + unfold Z_is_power2; intros. destruct x; try discriminate. + destruct (P_is_power2 p) eqn:P; try discriminate. + apply P_is_power2_sound in P. rewrite P; split; congruence. +Qed. + +Corollary Z_is_power2_range: + forall n x i, + 0 <= n -> 0 <= x < two_p n -> Z_is_power2 x = Some i -> 0 <= i < n. +Proof. + intros. + assert (x <> 0) by (red; intros; subst x; discriminate). + apply Z_is_power2_sound in H1. destruct H1 as [P Q]. subst i. + split. apply Z.log2_nonneg. apply Z.log2_lt_pow2. omega. rewrite <- two_p_equiv; tauto. +Qed. + +Lemma Z_is_power2_complete: + forall i, 0 <= i -> Z_is_power2 (two_p i) = Some i. +Proof. +Opaque Z.log2. + assert (A: forall x i, Z_is_power2 x = Some i -> Z_is_power2 (2 * x) = Some (Z.succ i)). + { destruct x; simpl; intros; try discriminate. + change (2 * Z.pos p) with (Z.pos (xO p)); simpl. + destruct (P_is_power2 p); inv H. rewrite <- Z.log2_double by xomega. auto. + } + induction i using Znatlike_ind; intros. +- replace i with 0 by omega. reflexivity. +- rewrite two_p_S by omega. apply A. apply IHi; omega. +Qed. + +Definition Z_is_power2m1 (x: Z) : option Z := Z_is_power2 (Z.succ x). + +Lemma Z_is_power2m1_sound: + forall x i, Z_is_power2m1 x = Some i -> x = two_p i - 1. +Proof. + unfold Z_is_power2m1; intros. apply Z_is_power2_sound in H. omega. +Qed. + +Lemma Z_is_power2m1_complete: + forall i, 0 <= i -> Z_is_power2m1 (two_p i - 1) = Some i. +Proof. + intros. unfold Z_is_power2m1. replace (Z.succ (two_p i - 1)) with (two_p i) by omega. + apply Z_is_power2_complete; auto. +Qed. + +Lemma Z_is_power2m1_range: + forall n x i, + 0 <= n -> 0 <= x < two_p n -> Z_is_power2m1 x = Some i -> 0 <= i <= n. +Proof. + intros. destruct (zeq x (two_p n - 1)). +- subst x. rewrite Z_is_power2m1_complete in H1 by auto. inv H1; omega. +- unfold Z_is_power2m1 in H1. apply (Z_is_power2_range n (Z.succ x) i) in H1; omega. +Qed. + +(** ** Relation between bitwise operations and multiplications / divisions by powers of 2 *) + +(** Left shifts and multiplications by powers of 2. *) + +Lemma Zshiftl_mul_two_p: + forall x n, 0 <= n -> Z.shiftl x n = x * two_p n. +Proof. + intros. destruct n; simpl. + - omega. + - pattern p. apply Pos.peano_ind. + + change (two_power_pos 1) with 2. simpl. ring. + + intros. rewrite Pos.iter_succ. rewrite H0. + rewrite Pplus_one_succ_l. rewrite two_power_pos_is_exp. + change (two_power_pos 1) with 2. ring. + - compute in H. congruence. +Qed. + +(** Right shifts and divisions by powers of 2. *) + +Lemma Zshiftr_div_two_p: + forall x n, 0 <= n -> Z.shiftr x n = x / two_p n. +Proof. + intros. destruct n; unfold Z.shiftr; simpl. + - rewrite Zdiv_1_r. auto. + - pattern p. apply Pos.peano_ind. + + change (two_power_pos 1) with 2. simpl. apply Zdiv2_div. + + intros. rewrite Pos.iter_succ. rewrite H0. + rewrite Pplus_one_succ_l. rewrite two_power_pos_is_exp. + change (two_power_pos 1) with 2. + rewrite Zdiv2_div. rewrite Z.mul_comm. apply Zdiv_Zdiv. + rewrite two_power_pos_nat. apply two_power_nat_pos. omega. + - compute in H. congruence. +Qed. + +(** ** Properties of [shrx] (signed division by a power of 2) *) + +Lemma Zquot_Zdiv: + forall x y, + y > 0 -> + Z.quot x y = if zlt x 0 then (x + y - 1) / y else x / y. +Proof. + intros. destruct (zlt x 0). + - symmetry. apply Zquot_unique_full with ((x + y - 1) mod y - (y - 1)). + + red. right; split. omega. + exploit (Z_mod_lt (x + y - 1) y); auto. + rewrite Z.abs_eq. omega. omega. + + transitivity ((y * ((x + y - 1) / y) + (x + y - 1) mod y) - (y-1)). + rewrite <- Z_div_mod_eq. ring. auto. ring. + - apply Zquot_Zdiv_pos; omega. +Qed. + +Lemma Zdiv_shift: + forall x y, y > 0 -> + (x + (y - 1)) / y = x / y + if zeq (Z.modulo x y) 0 then 0 else 1. +Proof. + intros. generalize (Z_div_mod_eq x y H). generalize (Z_mod_lt x y H). + set (q := x / y). set (r := x mod y). intros. + destruct (zeq r 0). + apply Zdiv_unique with (y - 1). rewrite H1. rewrite e. ring. omega. + apply Zdiv_unique with (r - 1). rewrite H1. ring. omega. +Qed. + +(** ** Size of integers, in bits. *) + +Definition Zsize (x: Z) : Z := + match x with + | Zpos p => Zpos (Pos.size p) + | _ => 0 + end. + +Remark Zsize_pos: forall x, 0 <= Zsize x. +Proof. + destruct x; simpl. omega. compute; intuition congruence. omega. +Qed. + +Remark Zsize_pos': forall x, 0 < x -> 0 < Zsize x. +Proof. + destruct x; simpl; intros; try discriminate. compute; auto. +Qed. + +Lemma Zsize_shiftin: + forall b x, 0 < x -> Zsize (Zshiftin b x) = Z.succ (Zsize x). +Proof. + intros. destruct x; compute in H; try discriminate. + destruct b. + change (Zshiftin true (Zpos p)) with (Zpos (p~1)). + simpl. f_equal. rewrite Pos.add_1_r; auto. + change (Zshiftin false (Zpos p)) with (Zpos (p~0)). + simpl. f_equal. rewrite Pos.add_1_r; auto. +Qed. + +Lemma Ztestbit_size_1: + forall x, 0 < x -> Z.testbit x (Z.pred (Zsize x)) = true. +Proof. + intros x0 POS0; pattern x0; apply Zshiftin_pos_ind; auto. + intros. rewrite Zsize_shiftin; auto. + replace (Z.pred (Z.succ (Zsize x))) with (Z.succ (Z.pred (Zsize x))) by omega. + rewrite Ztestbit_shiftin_succ. auto. generalize (Zsize_pos' x H); omega. +Qed. + +Lemma Ztestbit_size_2: + forall x, 0 <= x -> forall i, i >= Zsize x -> Z.testbit x i = false. +Proof. + intros x0 POS0. destruct (zeq x0 0). + - subst x0; intros. apply Ztestbit_0. + - pattern x0; apply Zshiftin_pos_ind. + + simpl. intros. change 1 with (Zshiftin true 0). rewrite Ztestbit_shiftin. + rewrite zeq_false. apply Ztestbit_0. omega. omega. + + intros. rewrite Zsize_shiftin in H1; auto. + generalize (Zsize_pos' _ H); intros. + rewrite Ztestbit_shiftin. rewrite zeq_false. apply H0. omega. + omega. omega. + + omega. +Qed. + +Lemma Zsize_interval_1: + forall x, 0 <= x -> 0 <= x < two_p (Zsize x). +Proof. + intros. + assert (x = x mod (two_p (Zsize x))). + apply equal_same_bits; intros. + rewrite Ztestbit_mod_two_p; auto. + destruct (zlt i (Zsize x)). auto. apply Ztestbit_size_2; auto. + apply Zsize_pos; auto. + rewrite H0 at 1. rewrite H0 at 3. apply Z_mod_lt. apply two_p_gt_ZERO. apply Zsize_pos; auto. +Qed. + +Lemma Zsize_interval_2: + forall x n, 0 <= n -> 0 <= x < two_p n -> n >= Zsize x. +Proof. + intros. set (N := Z.to_nat n). + assert (Z.of_nat N = n) by (apply Z2Nat.id; auto). + rewrite <- H1 in H0. rewrite <- two_power_nat_two_p in H0. + destruct (zeq x 0). + subst x; simpl; omega. + destruct (zlt n (Zsize x)); auto. + exploit (Ztestbit_above N x (Z.pred (Zsize x))). auto. omega. + rewrite Ztestbit_size_1. congruence. omega. +Qed. + +Lemma Zsize_monotone: + forall x y, 0 <= x <= y -> Zsize x <= Zsize y. +Proof. + intros. apply Z.ge_le. apply Zsize_interval_2. apply Zsize_pos. + exploit (Zsize_interval_1 y). omega. + omega. +Qed. diff --git a/powerpc/Archi.v b/powerpc/Archi.v index 5d11aad1..d792e4fe 100644 --- a/powerpc/Archi.v +++ b/powerpc/Archi.v @@ -17,8 +17,8 @@ (** Architecture-dependent parameters for PowerPC *) Require Import ZArith. -Require Import Fappli_IEEE. -Require Import Fappli_IEEE_bits. +(*From Flocq*) +Require Import Binary Bits. Definition ptr64 := false. @@ -37,21 +37,24 @@ Proof. reflexivity. Qed. -Program Definition default_pl_64 : bool * nan_pl 53 := - (false, iter_nat 51 _ xO xH). +Definition default_nan_64 : { x : binary64 | is_nan _ _ x = true } := + exist _ (B754_nan 53 1024 false (iter_nat 51 _ xO xH) (eq_refl true)) (eq_refl true). -Definition choose_binop_pl_64 (s1: bool) (pl1: nan_pl 53) (s2: bool) (pl2: nan_pl 53) := +Definition choose_binop_pl_64 (pl1 pl2 : positive) := false. (**r always choose first NaN *) -Program Definition default_pl_32 : bool * nan_pl 24 := - (false, iter_nat 22 _ xO xH). +Definition default_nan_32 : { x : binary32 | is_nan _ _ x = true } := + exist _ (B754_nan 24 128 false (iter_nat 22 _ xO xH) (eq_refl true)) (eq_refl true). -Definition choose_binop_pl_32 (s1: bool) (pl1: nan_pl 24) (s2: bool) (pl2: nan_pl 24) := +Definition choose_binop_pl_32 (pl1 pl2 : positive) := false. (**r always choose first NaN *) +Definition fpu_returns_default_qNaN := false. + Definition float_of_single_preserves_sNaN := true. Global Opaque ptr64 big_endian splitlong - default_pl_64 choose_binop_pl_64 - default_pl_32 choose_binop_pl_32 - float_of_single_preserves_sNaN.
\ No newline at end of file + default_nan_64 choose_binop_pl_64 + default_nan_32 choose_binop_pl_32 + fpu_returns_default_qNaN + float_of_single_preserves_sNaN. diff --git a/powerpc/Asm.v b/powerpc/Asm.v index ad24f563..b9300fd7 100644 --- a/powerpc/Asm.v +++ b/powerpc/Asm.v @@ -231,6 +231,7 @@ Inductive instruction : Type := | Pfres: freg -> freg -> instruction (**r approximate inverse *) | Pfsel: freg -> freg -> freg -> freg -> instruction (**r FP conditional move *) | Pisel: ireg -> ireg -> ireg -> crbit -> instruction (**r integer select *) + | Pfsel_gen: freg -> freg -> freg -> crbit -> instruction (**r floating point select *) | Pisync: instruction (**r ISYNC barrier *) | Picbi: ireg -> ireg -> instruction (**r instruction cache invalidate *) | Picbtls: int -> ireg -> ireg -> instruction (**r instruction cache block touch and lock set *) @@ -860,6 +861,20 @@ Definition exec_instr (f: function) (i: instruction) (rs: regset) (m: mem) : out Next (nextinstr (rs#rd <- (Val.subf rs#r1 rs#r2))) m | Pfsubs rd r1 r2 => Next (nextinstr (rs#rd <- (Val.subfs rs#r1 rs#r2))) m + | Pisel rd r1 r2 bit => + let v := + match rs#(reg_of_crbit bit) with + | Vint n => if Int.eq n Int.zero then rs#r2 else rs#r1 + | _ => Vundef + end in + Next (nextinstr (rs #rd <- v #GPR0 <- Vundef)) m + | Pfsel_gen rd r1 r2 bit => + let v := + match rs#(reg_of_crbit bit) with + | Vint n => if Int.eq n Int.zero then rs#r2 else rs#r1 + | _ => Vundef + end in + Next (nextinstr (rs #rd <- v #GPR0 <- Vundef)) m | Plbz rd cst r1 => load1 Mint8unsigned rd cst r1 rs m | Plbzx rd r1 r2 => @@ -1073,7 +1088,6 @@ Definition exec_instr (f: function) (i: instruction) (rs: regset) (m: mem) : out | Pfrsqrte _ _ | Pfres _ _ | Pfsel _ _ _ _ - | Pisel _ _ _ _ | Plwarx _ _ _ | Plwbrx _ _ _ | Picbi _ _ diff --git a/powerpc/AsmToJSON.ml b/powerpc/AsmToJSON.ml index ee3eaca8..99c51e43 100644 --- a/powerpc/AsmToJSON.ml +++ b/powerpc/AsmToJSON.ml @@ -228,6 +228,7 @@ let pp_instructions pp ic = | Pfres (fr1,fr2) -> instruction pp "Pfres" [Freg fr1; Freg fr2] | Pfsel (fr1,fr2,fr3,fr4) -> instruction pp "Pfsel" [Freg fr1; Freg fr2; Freg fr3; Freg fr4] | Pisel (ir1,ir2,ir3,cr) -> instruction pp "Pisel" [Ireg ir1; Ireg ir2; Ireg ir3; Crbit cr] + | Pfsel_gen _ -> assert false (* Should not occur *) | Picbi (ir1,ir2) -> instruction pp "Picbi" [Ireg ir1; Ireg ir2] | Picbtls (n,ir1,ir2) -> instruction pp "Picbtls" [Constant (Cint n);Ireg ir1; Ireg ir2] | Pisync -> instruction pp "Pisync" [] diff --git a/powerpc/Asmexpand.ml b/powerpc/Asmexpand.ml index 49a0d237..415b6651 100644 --- a/powerpc/Asmexpand.ml +++ b/powerpc/Asmexpand.ml @@ -36,12 +36,14 @@ let _2 = coqint_of_camlint 2l let _4 = coqint_of_camlint 4l let _6 = coqint_of_camlint 6l let _8 = coqint_of_camlint 8l +let _16 = coqint_of_camlint 16l let _31 = coqint_of_camlint 31l let _32 = coqint_of_camlint 32l let _64 = coqint_of_camlint 64l let _m1 = coqint_of_camlint (-1l) let _m4 = coqint_of_camlint (-4l) let _m8 = coqint_of_camlint (-8l) +let _m16 = coqint_of_camlint (-16l) let _0L = Integers.Int64.zero let _32L = coqint_of_camlint64 32L @@ -56,6 +58,15 @@ let emit_loadimm r n = let emit_addimm rd rs n = List.iter emit (Asmgen.addimm rd rs n []) +(* Numbering of bits in the CR register *) + +let num_crbit = function + | CRbit_0 -> 0 + | CRbit_1 -> 1 + | CRbit_2 -> 2 + | CRbit_3 -> 3 + | CRbit_6 -> 6 + (* Handling of annotations *) let expand_annot_val kind txt targ args res = @@ -77,8 +88,6 @@ let expand_annot_val kind txt targ args res = So, use 64-bit accesses only if alignment >= 4. Note that lfd and stfd cannot trap on ill-formed floats. *) - - let offset_in_range ofs = Int.eq (Asmgen.high_s ofs) _0 @@ -410,10 +419,21 @@ let expand_builtin_va_start r = let expand_int64_arith conflict rl fn = if conflict then (fn GPR0; emit (Pmr(rl, GPR0))) else fn rl -(* Expansion of integer conditional moves (__builtin_*sel) *) +(* Expansion of integer conditional moves (__builtin_*sel and Pisel) *) (* The generated code works equally well with 32-bit integer registers and with 64-bit integer registers. *) +let expand_integer_cond_move_1 a2 a3 res = + (* GPR0 is -1 (all ones) if condition is true, 0 if it is false *) + if res <> a3 then begin + emit (Pand_ (res, a2, GPR0)); + emit (Pandc (GPR0, a3, GPR0)) + end else begin + emit (Pandc (res, a3, GPR0)); + emit (Pand_ (GPR0, a2, GPR0)) + end; + emit (Por (res, res, GPR0)) + let expand_integer_cond_move a1 a2 a3 res = if a2 = a3 then emit (Pmr (res, a2)) @@ -423,15 +443,37 @@ let expand_integer_cond_move a1 a2 a3 res = end else begin (* a1 has type _Bool, hence it is 0 or 1 *) emit (Psubfic (GPR0, a1, Cint _0)); - (* r0 = -1 (all ones) if a1 is true, r0 = 0 if a1 is false *) - if res <> a3 then begin - emit (Pand_ (res, a2, GPR0)); - emit (Pandc (GPR0, a3, GPR0)) - end else begin - emit (Pandc (res, a3, GPR0)); - emit (Pand_ (GPR0, a2, GPR0)) - end; - emit (Por (res, res, GPR0)) + expand_integer_cond_move_1 a2 a3 res + end + + +(* Expansion of floating point conditional moves (Pfcmove) *) + +let expand_float_cond_move bit a2 a3 res = + emit (Pmfcr GPR0); + emit (Prlwinm(GPR0, GPR0, Z.of_uint (4 + num_crbit bit), _8)); + emit (Pstfdu (a3, Cint (_m16), GPR1)); + emit (Pcfi_adjust _16); + emit (Pstfd (a2, Cint (_8), GPR1)); + emit (Plfdx (res, GPR1, GPR0)); + emit (Paddi (GPR1, GPR1, (Cint _16))); + emit (Pcfi_adjust _m16) + + + +(* Symmetrically, we emulate the "isel" instruction on PPC processors + that do not have it. *) + +let expand_isel bit a2 a3 res = + if a2 = a3 then + emit (Pmr (res, a2)) + else if eref then + emit (Pisel (res, a2, a3, bit)) + else begin + emit (Pmfcr GPR0); + emit (Prlwinm(GPR0, GPR0, Z.of_uint (1 + num_crbit bit), _1)); + emit (Psubfic (GPR0, GPR0, Cint _0)); + expand_integer_cond_move_1 a2 a3 res end (* Convert integer constant into GPR with corresponding number *) @@ -772,13 +814,6 @@ let set_cr6 sg = (* Expand instructions *) -let num_crbit = function - | CRbit_0 -> 0 - | CRbit_1 -> 1 - | CRbit_2 -> 2 - | CRbit_3 -> 3 - | CRbit_6 -> 6 - let expand_instruction instr = match instr with | Pallocframe(sz, ofs,retofs) -> @@ -874,6 +909,10 @@ let expand_instruction instr = emit (Pcfi_adjust _m8); | Pfxdp(r1, r2) -> if r1 <> r2 then emit(Pfmr(r1, r2)) + | Pisel(rd, r1, r2, bit) -> + expand_isel bit r1 r2 rd + | Pfsel_gen (rd, r1, r2, bit) -> + expand_float_cond_move bit r1 r2 rd | Plmake(r1, rhi, rlo) -> if r1 = rlo then emit (Prldimi(r1, rhi, _32L, upper32)) diff --git a/powerpc/Asmgen.v b/powerpc/Asmgen.v index 8c296f0a..a686414a 100644 --- a/powerpc/Asmgen.v +++ b/powerpc/Asmgen.v @@ -125,17 +125,35 @@ Definition rolm (r1 r2: ireg) (amount mask: int) (k: code) := Definition low64_u (n: int64) := Int64.zero_ext 16 n. Definition low64_s (n: int64) := Int64.sign_ext 16 n. -Definition loadimm64 (r: ireg) (n: int64) (k: code) := +Definition loadimm64_32s (r: ireg) (n: int64) (k: code) := let lo_u := low64_u n in let lo_s := low64_s n in - let hi_s := Int64.sign_ext 16 (Int64.shr n (Int64.repr 16)) in + let hi_s := low64_s (Int64.shr n (Int64.repr 16)) in if Int64.eq n lo_s then Paddi64 r GPR0 n :: k - else if Int64.eq n (Int64.or (Int64.shl hi_s (Int64.repr 16)) lo_u) then - Paddis64 r GPR0 hi_s :: Pori64 r r lo_u :: k + else + Paddis64 r GPR0 hi_s :: Pori64 r r lo_u :: k. + +Definition loadimm64 (r: ireg) (n: int64) (k: code) := + if Int64.eq n (Int64.sign_ext 32 n) then + loadimm64_32s r n k else Pldi r n :: k. +(** [loadimm64_notemp] is a variant of [loadimm64] that uses no temporary + register. The code it produces is larger and slower than the code + produced by [loadimm64], but it is sometimes useful to preserve all registers + except the destination. *) + +Definition loadimm64_notemp (r: ireg) (n: int64) (k: code) := + if Int64.eq n (Int64.sign_ext 32 n) then + loadimm64_32s r n k + else + loadimm64_32s r (Int64.shru n (Int64.repr 32)) + (Prldinm r r (Int.repr 32) (Int64.shl Int64.mone (Int64.repr 32)) :: + Poris64 r r (low64_u (Int64.shru n (Int64.repr 16))) :: + Pori64 r r (low64_u n) :: k). + Definition opimm64 (insn2: ireg -> ireg -> ireg -> instruction) (insn1: ireg -> ireg -> int64 -> instruction) (r1 r2: ireg) (n: int64) (ok: bool) (k: code) := @@ -261,18 +279,14 @@ Definition transl_cond do r1 <- ireg_of a1; if Int64.eq n (low64_s n) then OK (Pcmpdi r1 n :: k) - else if ireg_eq r1 GPR12 then - OK (Pmr GPR0 GPR12 :: loadimm64 GPR12 n (Pcmpd GPR0 GPR12 :: k)) else - OK (loadimm64 GPR0 n (Pcmpd r1 GPR0 :: k)) + OK (loadimm64_notemp GPR0 n (Pcmpd r1 GPR0 :: k)) | Ccompluimm c n, a1 :: nil => do r1 <- ireg_of a1; if Int64.eq n (low64_u n) then OK (Pcmpldi r1 n :: k) - else if ireg_eq r1 GPR12 then - OK (Pmr GPR0 GPR12 :: loadimm64 GPR12 n (Pcmpld GPR0 GPR12 :: k)) else - OK (loadimm64 GPR0 n (Pcmpld r1 GPR0 :: k)) + OK (loadimm64_notemp GPR0 n (Pcmpld r1 GPR0 :: k)) | _, _ => Error(msg "Asmgen.transl_cond") end. @@ -390,6 +404,28 @@ Definition transl_cond_op else Pxori r' r' (Cint Int.one) :: k) end. +(** Translation of a select operation *) + +Definition transl_select_op + (cond: condition) (args: list mreg) (r1 r2 rd: ireg) (k: code) := + if ireg_eq r1 r2 then + OK (Pmr rd r1 :: k) + else + (let p := crbit_for_cond cond in + let r1' := if snd p then r1 else r2 in + let r2' := if snd p then r2 else r1 in + transl_cond cond args (Pisel rd r1' r2' (fst p) :: k)). + +Definition transl_fselect_op + (cond: condition) (args: list mreg) (r1 r2 rd: freg) (k: code) := + if freg_eq r1 r2 then + OK (Pfmr rd r1 :: k) + else + (let p := crbit_for_cond cond in + let r1' := if snd p then r1 else r2 in + let r2' := if snd p then r2 else r1 in + transl_cond cond args (Pfsel_gen rd r1' r2' (fst p) :: k)). + (** Translation of the arithmetic operation [r <- op(args)]. The corresponding instructions are prepended to [k]. *) @@ -596,6 +632,17 @@ Definition transl_op do r1 <- ireg_of a1; do r <- ireg_of res; OK (Plhi r r1 :: k) | Ocmp cmp, _ => transl_cond_op cmp args res k + | Osel cmp ty, a1 :: a2 :: args => + match preg_of res with + | IR r1 => + do r1 <- ireg_of a1; do r2 <- ireg_of a2; do r <- ireg_of res; + transl_select_op cmp args r1 r2 r k + | FR r => + do r1 <- freg_of a1; do r2 <- freg_of a2; do r <- freg_of res; + transl_fselect_op cmp args r1 r2 r k + | _ => + Error (msg "Asmgen.Osel") + end (*c PPC64 operations *) | Olongconst n, nil => do r <- ireg_of res; OK (loadimm64 r n k) diff --git a/powerpc/Asmgenproof.v b/powerpc/Asmgenproof.v index 8ad28aea..d653633c 100644 --- a/powerpc/Asmgenproof.v +++ b/powerpc/Asmgenproof.v @@ -179,14 +179,28 @@ Proof. Qed. Hint Resolve rolm_label: labels. +Remark loadimm64_32s_label: + forall r n k, tail_nolabel k (loadimm64_32s r n k). +Proof. + unfold loadimm64_32s; intros. destruct Int64.eq; TailNoLabel. +Qed. +Hint Resolve loadimm64_32s_label: labels. + Remark loadimm64_label: forall r n k, tail_nolabel k (loadimm64 r n k). Proof. - unfold loadimm64; intros. - destruct Int64.eq. TailNoLabel. destruct Int64.eq; TailNoLabel. + unfold loadimm64; intros. destruct Int64.eq; TailNoLabel. Qed. Hint Resolve loadimm64_label: labels. +Remark loadimm64_notemp_label: + forall r n k, tail_nolabel k (loadimm64_notemp r n k). +Proof. + unfold loadimm64_notemp; intros. destruct Int64.eq; TailNoLabel. + eapply tail_nolabel_trans; TailNoLabel. +Qed. +Hint Resolve loadimm64_notemp_label: labels. + Remark loadind_label: forall base ofs ty dst k c, loadind base ofs ty dst k = OK c -> tail_nolabel k c. @@ -234,6 +248,24 @@ Proof. destruct (snd (crbit_for_cond c0)); TailNoLabel. Qed. +Remark transl_select_op_label: + forall cond args r1 r2 rd k c, + transl_select_op cond args r1 r2 rd k = OK c -> tail_nolabel k c. +Proof. + unfold transl_select_op; intros. destruct (ireg_eq r1 r2). + TailNoLabel. + eapply tail_nolabel_trans. eapply transl_cond_label; eauto. TailNoLabel. +Qed. + +Remark transl_fselect_op_label: + forall cond args r1 r2 rd k c, + transl_fselect_op cond args r1 r2 rd k = OK c -> tail_nolabel k c. +Proof. + unfold transl_fselect_op; intros. destruct (freg_eq r1 r2). + TailNoLabel. + eapply tail_nolabel_trans. eapply transl_cond_label; eauto. TailNoLabel. +Qed. + Remark transl_op_label: forall op args r k c, transl_op op args r k = OK c -> tail_nolabel k c. @@ -261,6 +293,7 @@ Opaque Int.eq. destruct Int64.eq. TailNoLabel. destruct ireg_eq; [apply tail_nolabel_cons; unfold nolabel;auto|]; eapply tail_nolabel_trans; TailNoLabel. - eapply transl_cond_op_label; eauto. +- destruct (preg_of r); monadInv H. eapply transl_select_op_label; eauto. eapply transl_fselect_op_label; eauto. Qed. Remark transl_memory_access_label: diff --git a/powerpc/Asmgenproof1.v b/powerpc/Asmgenproof1.v index c18757b2..884d5366 100644 --- a/powerpc/Asmgenproof1.v +++ b/powerpc/Asmgenproof1.v @@ -16,6 +16,7 @@ Require Import Coqlib. Require Import Errors. Require Import Maps. Require Import AST. +Require Import Zbits. Require Import Integers. Require Import Floats. Require Import Values. @@ -80,13 +81,13 @@ Proof. unfold Int.modu, Int.zero. decEq. change 0 with (0 mod 65536). change (Int.unsigned (Int.repr 65536)) with 65536. - apply Int.eqmod_mod_eq. omega. - unfold x, low_s. eapply Int.eqmod_trans. - apply Int.eqmod_divides with Int.modulus. + apply eqmod_mod_eq. omega. + unfold x, low_s. eapply eqmod_trans. + apply eqmod_divides with Int.modulus. unfold Int.sub. apply Int.eqm_unsigned_repr_l. apply Int.eqm_refl. exists 65536. compute; auto. replace 0 with (Int.unsigned n - Int.unsigned n) by omega. - apply Int.eqmod_sub. apply Int.eqmod_refl. apply Int.eqmod_sign_ext'. + apply eqmod_sub. apply eqmod_refl. apply Int.eqmod_sign_ext'. compute; auto. rewrite H0 in H. rewrite Int.add_zero in H. rewrite <- H. unfold x. rewrite Int.sub_add_opp. rewrite Int.add_assoc. @@ -531,6 +532,40 @@ Qed. (** Load int64 constant. *) +Lemma loadimm64_32s_correct: + forall r n k rs m, + exists rs', + exec_straight ge fn (loadimm64_32s r n k) rs m k rs' m + /\ rs'#r = Vlong (Int64.sign_ext 32 n) + /\ forall r': preg, r' <> r -> r' <> PC -> rs'#r' = rs#r'. +Proof. + unfold loadimm64_32s; intros. predSpec Int64.eq Int64.eq_spec n (low64_s n). + - econstructor; split; [|split]. + + apply exec_straight_one. simpl; eauto. auto. + + Simpl. rewrite Int64.add_zero_l. rewrite H. unfold low64_s. + rewrite Int64.sign_ext_widen by omega. auto. + + intros; Simpl. + - econstructor; split; [|split]. + + eapply exec_straight_two. simpl; eauto. simpl; eauto. auto. auto. + + Simpl. simpl. f_equal. rewrite Int64.add_zero_l. + apply Int64.same_bits_eq; intros. assert (Int64.zwordsize = 64) by auto. + rewrite Int64.bits_or, Int64.bits_shl by auto. + unfold low64_s, low64_u. + rewrite Int64.bits_zero_ext by omega. + change (Int64.unsigned (Int64.repr 16)) with 16. + destruct (zlt i 16). + * rewrite Int64.bits_sign_ext by omega. rewrite zlt_true by omega. auto. + * rewrite ! Int64.bits_sign_ext by omega. rewrite orb_false_r. + destruct (zlt i 32). + ** rewrite zlt_true by omega. rewrite Int64.bits_shr by omega. + change (Int64.unsigned (Int64.repr 16)) with 16. + rewrite zlt_true by omega. f_equal; omega. + ** rewrite zlt_false by omega. rewrite Int64.bits_shr by omega. + change (Int64.unsigned (Int64.repr 16)) with 16. + reflexivity. + + intros; Simpl. +Qed. + Lemma loadimm64_correct: forall r n k rs m, exists rs', @@ -539,20 +574,78 @@ Lemma loadimm64_correct: /\ forall r': preg, r' <> r -> r' <> GPR12 -> r' <> PC -> rs'#r' = rs#r'. Proof. intros. unfold loadimm64. - set (hi_s := Int64.sign_ext 16 (Int64.shr n (Int64.repr 16))). - set (hi' := Int64.shl hi_s (Int64.repr 16)). - destruct (Int64.eq n (low64_s n)). - (* addi *) - econstructor; split. apply exec_straight_one. simpl; eauto. auto. - rewrite Int64.add_zero_l. intuition Simpl. - (* addis + ori *) - predSpec Int64.eq Int64.eq_spec n (Int64.or hi' (low64_u n)). - econstructor; split. eapply exec_straight_two. simpl; eauto. simpl; eauto. auto. auto. - split. Simpl. rewrite Int64.add_zero_l. simpl; f_equal; auto. - intros. Simpl. - (* ldi *) - econstructor; split. apply exec_straight_one. simpl; eauto. auto. - intuition Simpl. + predSpec Int64.eq Int64.eq_spec n (Int64.sign_ext 32 n). + - destruct (loadimm64_32s_correct r n k rs m) as (rs' & A & B & C). + exists rs'; intuition auto. congruence. + - econstructor; split. apply exec_straight_one. simpl; eauto. auto. + intuition Simpl. +Qed. + +(** Alternate load int64 immediate *) + +Lemma loadimm64_notemp_correct: + forall r n k rs m, + exists rs', + exec_straight ge fn (loadimm64_notemp r n k) rs m k rs' m + /\ rs'#r = Vlong n + /\ forall r': preg, r' <> r -> r' <> PC -> rs'#r' = rs#r'. +Proof. + intros. unfold loadimm64_notemp. + predSpec Int64.eq Int64.eq_spec n (Int64.sign_ext 32 n). +- destruct (loadimm64_32s_correct r n k rs m) as (rs' & A & B & C). + exists rs'; intuition auto. congruence. +- set (n2 := Int64.shru n (Int64.repr 32)). + set (n1 := Int64.zero_ext 16 (Int64.shru n (Int64.repr 16))). + set (n0 := Int64.zero_ext 16 n). + set (mi := Int64.shl n1 (Int64.repr 16)). + set (hi := Int64.shl (Int64.sign_ext 32 n2) (Int64.repr 32)). + assert (HI: forall i, 0 <= i < Int64.zwordsize -> + Int64.testbit hi i = if zlt i 32 then false else Int64.testbit n i). + { intros. unfold hi. assert (Int64.zwordsize = 64) by auto. + rewrite Int64.bits_shl by auto. + change (Int64.unsigned (Int64.repr 32)) with 32. + destruct (zlt i 32); auto. + rewrite Int64.bits_sign_ext by omega. + rewrite zlt_true by omega. + unfold n2. rewrite Int64.bits_shru by omega. + change (Int64.unsigned (Int64.repr 32)) with 32. + rewrite zlt_true by omega. f_equal; omega. + } + assert (MI: forall i, 0 <= i < Int64.zwordsize -> + Int64.testbit mi i = + if zlt i 16 then false + else if zlt i 32 then Int64.testbit n i else false). + { intros. unfold mi. assert (Int64.zwordsize = 64) by auto. + rewrite Int64.bits_shl by auto. + change (Int64.unsigned (Int64.repr 16)) with 16. + destruct (zlt i 16); auto. + unfold n1. rewrite Int64.bits_zero_ext by omega. + rewrite Int64.bits_shru by omega. + destruct (zlt i 32). + rewrite zlt_true by omega. + change (Int64.unsigned (Int64.repr 16)) with 16. + rewrite zlt_true by omega. f_equal; omega. + rewrite zlt_false by omega. auto. + } + assert (EQ: Int64.or (Int64.or hi mi) n0 = n). + { apply Int64.same_bits_eq; intros. + rewrite ! Int64.bits_or by auto. + unfold n0; rewrite Int64.bits_zero_ext by omega. + rewrite HI, MI by auto. + destruct (zlt i 16). + rewrite zlt_true by omega. auto. + destruct (zlt i 32); rewrite ! orb_false_r; auto. + } + edestruct (loadimm64_32s_correct r n2) as (rs' & A & B & C). + econstructor; split; [|split]. + + eapply exec_straight_trans. eexact A. + eapply exec_straight_three. + simpl. rewrite B. simpl; auto. + simpl; auto. + simpl; auto. + reflexivity. reflexivity. reflexivity. + + Simpl. simpl. f_equal. rewrite <- Int64.shl_rolm by auto. exact EQ. + + intros; Simpl. Qed. (** Add int64 immediate. *) @@ -889,7 +982,7 @@ Lemma transl_cond_correct_1: (if snd (crbit_for_cond cond) then Val.of_optbool (eval_condition cond (map rs (map preg_of args)) m) else Val.notbool (Val.of_optbool (eval_condition cond (map rs (map preg_of args)) m))) - /\ forall r, important_preg r = true -> preg_notin r (destroyed_by_cond cond) -> rs'#r = rs#r. + /\ forall r, important_preg r = true -> rs'#r = rs#r. Proof. intros. Opaque Int.eq. @@ -991,20 +1084,12 @@ Opaque Int.eq. auto with asmgen. - (* Ccomplimm *) rewrite <- Val.notbool_negb_3. rewrite <- Val.negate_cmpl_bool. - destruct (Int64.eq i (low64_s i)); [|destruct (ireg_eq x GPR12)]; inv EQ0. + destruct (Int64.eq i (low64_s i)); inv EQ0. + destruct (compare_slong_spec rs (rs x) (Vlong i)) as [A [B [C D]]]. econstructor; split. apply exec_straight_one. simpl; reflexivity. reflexivity. split. case c0; simpl; auto. auto with asmgen. -+ destruct (loadimm64_correct GPR12 i (Pcmpd GPR0 GPR12 :: k) (nextinstr (rs#GPR0 <- (rs#GPR12))) m) as [rs1 [EX1 [RES1 OTH1]]]. - destruct (compare_slong_spec rs1 (rs GPR12) (Vlong i)) as [A [B [C D]]]. - assert (SAME: rs1 GPR0 = rs GPR12) by (apply OTH1; eauto with asmgen). - econstructor; split. - eapply exec_straight_step. simpl;reflexivity. reflexivity. - eapply exec_straight_trans. eexact EX1. eapply exec_straight_one. simpl;reflexivity. reflexivity. - split. rewrite RES1, SAME. destruct c0; simpl; auto. - simpl; intros. rewrite RES1, SAME. rewrite D by eauto with asmgen. rewrite OTH1 by eauto with asmgen. Simpl. -+ destruct (loadimm64_correct GPR0 i (Pcmpd x GPR0 :: k) rs m) as [rs1 [EX1 [RES1 OTH1]]]. ++ destruct (loadimm64_notemp_correct GPR0 i (Pcmpd x GPR0 :: k) rs m) as [rs1 [EX1 [RES1 OTH1]]]. destruct (compare_slong_spec rs1 (rs x) (Vlong i)) as [A [B [C D]]]. assert (SAME: rs1 x = rs x) by (apply OTH1; eauto with asmgen). econstructor; split. @@ -1013,20 +1098,12 @@ Opaque Int.eq. simpl; intros. rewrite RES1, SAME. rewrite D; eauto with asmgen. - (* Ccompluimm *) rewrite <- Val.notbool_negb_3. rewrite <- Val.negate_cmplu_bool. - destruct (Int64.eq i (low64_u i)); [|destruct (ireg_eq x GPR12)]; inv EQ0. + destruct (Int64.eq i (low64_u i)); inv EQ0. + destruct (compare_ulong_spec rs m (rs x) (Vlong i)) as [A [B [C D]]]. econstructor; split. apply exec_straight_one. simpl; reflexivity. reflexivity. split. case c0; simpl; auto. auto with asmgen. -+ destruct (loadimm64_correct GPR12 i (Pcmpld GPR0 GPR12 :: k) (nextinstr (rs#GPR0 <- (rs#GPR12))) m) as [rs1 [EX1 [RES1 OTH1]]]. - destruct (compare_ulong_spec rs1 m (rs GPR12) (Vlong i)) as [A [B [C D]]]. - assert (SAME: rs1 GPR0 = rs GPR12) by (apply OTH1; eauto with asmgen). - econstructor; split. - eapply exec_straight_step. simpl;reflexivity. reflexivity. - eapply exec_straight_trans. eexact EX1. eapply exec_straight_one. simpl;reflexivity. reflexivity. - split. rewrite RES1, SAME. destruct c0; simpl; auto. - simpl; intros. rewrite RES1, SAME. rewrite D by eauto with asmgen. rewrite OTH1 by eauto with asmgen. Simpl. -+ destruct (loadimm64_correct GPR0 i (Pcmpld x GPR0 :: k) rs m) as [rs1 [EX1 [RES1 OTH1]]]. ++ destruct (loadimm64_notemp_correct GPR0 i (Pcmpld x GPR0 :: k) rs m) as [rs1 [EX1 [RES1 OTH1]]]. destruct (compare_ulong_spec rs1 m (rs x) (Vlong i)) as [A [B [C D]]]. assert (SAME: rs1 x = rs x) by (apply OTH1; eauto with asmgen). econstructor; split. @@ -1045,7 +1122,7 @@ Lemma transl_cond_correct_2: (if snd (crbit_for_cond cond) then Val.of_bool b else Val.notbool (Val.of_bool b)) - /\ forall r, important_preg r = true -> preg_notin r (destroyed_by_cond cond) -> rs'#r = rs#r. + /\ forall r, important_preg r = true -> rs'#r = rs#r. Proof. intros. replace (Val.of_bool b) @@ -1072,7 +1149,8 @@ Proof. exploit transl_cond_correct_2. eauto. eapply eval_condition_lessdef. eapply preg_vals; eauto. eauto. eauto. intros [rs' [A [B C]]]. - exists rs'; split. eauto. split. auto. apply agree_undef_regs with rs; auto. intros r D. + exists rs'; split. eauto. split. auto. + apply agree_undef_regs with rs; auto. intros r D E. apply C. apply important_data_preg_1; auto. Qed. @@ -1180,6 +1258,64 @@ Proof. intuition Simpl. rewrite RES1. destruct (eval_condition c rs ## (preg_of ## rl) m). destruct b; auto. auto. Qed. + +Lemma transl_select_op_correct: + forall cond args ty r1 r2 rd k rs m c, + transl_select_op cond args r1 r2 rd k = OK c -> + important_preg rd = true -> important_preg r1 = true -> important_preg r2 = true -> + exists rs', + exec_straight ge fn c rs m k rs' m + /\ Val.lessdef (Val.select (eval_condition cond (map rs (map preg_of args)) m) rs#r1 rs#r2 ty) rs'#rd + /\ forall r, important_preg r = true -> r <> rd -> rs'#r = rs#r. +Proof. + intros until c. intros TR IMP1 IMP2 IMP3. + unfold transl_select_op in TR. + destruct (ireg_eq r1 r2). + - inv TR. econstructor; split; [|split]. + + apply exec_straight_one. simpl; eauto. auto. + + Simpl. destruct (eval_condition cond rs ## (preg_of ## args) m) as [[]|]; simpl; auto using Val.lessdef_normalize. + + intros; Simpl. + - destruct (transl_cond_correct_1 cond args _ rs m _ TR) as (rs1 & A & B & C). + set (bit := fst (crbit_for_cond cond)) in *. + set (dir := snd (crbit_for_cond cond)) in *. + set (ob := eval_condition cond rs##(preg_of##args) m) in *. + econstructor; split; [|split]. + + eapply exec_straight_trans. eexact A. apply exec_straight_one. simpl; eauto. + reflexivity. + + Simpl. + rewrite <- (C r1), <- (C r2) by auto. + rewrite B. destruct dir; destruct ob as [[]|]; simpl; auto using Val.lessdef_normalize. + + intros. Simpl. +Qed. + +Lemma transl_fselect_op_correct: + forall cond args ty r1 r2 rd k rs m c, + transl_fselect_op cond args r1 r2 rd k = OK c -> + important_preg rd = true -> important_preg r1 = true -> important_preg r2 = true -> + exists rs', + exec_straight ge fn c rs m k rs' m + /\ Val.lessdef (Val.select (eval_condition cond (map rs (map preg_of args)) m) rs#r1 rs#r2 ty) rs'#rd + /\ forall r, important_preg r = true -> r <> rd -> rs'#r = rs#r. +Proof. + intros until c. intros TR IMP1 IMP2 IMP3. + unfold transl_fselect_op in TR. + destruct (freg_eq r1 r2). + - inv TR. econstructor; split; [|split]. + + apply exec_straight_one. simpl; eauto. auto. + + Simpl. destruct (eval_condition cond rs ## (preg_of ## args) m) as [[]|]; simpl; auto using Val.lessdef_normalize. + + intros; Simpl. + - destruct (transl_cond_correct_1 cond args _ rs m _ TR) as (rs1 & A & B & C). + set (bit := fst (crbit_for_cond cond)) in *. + set (dir := snd (crbit_for_cond cond)) in *. + set (ob := eval_condition cond rs##(preg_of##args) m) in *. + econstructor; split; [|split]. + + eapply exec_straight_trans. eexact A. apply exec_straight_one. simpl; eauto. + reflexivity. + + Simpl. + rewrite <- (C r1), <- (C r2) by auto. + rewrite B. destruct dir; destruct ob as [[]|]; simpl; auto using Val.lessdef_normalize. + + intros. Simpl. +Qed. (** Translation of arithmetic operations. *) @@ -1377,6 +1513,18 @@ Opaque Val.add. (* Ocmp *) - destruct (transl_cond_op_correct c0 args res k rs m c) as [rs' [A [B C]]]; auto. exists rs'; auto with asmgen. + (* Osel *) +- assert (X: forall mr r, ireg_of mr = OK r -> important_preg r = true). + { intros. apply ireg_of_eq in H0. apply important_data_preg_1. rewrite <- H0. + auto with asmgen. } + assert (Y: forall mr r, freg_of mr = OK r -> important_preg r = true). + { intros. apply freg_of_eq in H0. apply important_data_preg_1. rewrite <- H0. + auto with asmgen. } + destruct (preg_of res) eqn:RES; monadInv H; rewrite <- RES. + + rewrite (ireg_of_eq _ _ EQ), (ireg_of_eq _ _ EQ0), (ireg_of_eq _ _ EQ1) in *. + destruct (transl_select_op_correct _ _ t _ _ _ _ rs m _ EQ3) as (rs' & A & B & C); eauto. + + rewrite (freg_of_eq _ _ EQ), (freg_of_eq _ _ EQ0), (freg_of_eq _ _ EQ1) in *. + destruct (transl_fselect_op_correct _ _ t _ _ _ _ rs m _ EQ3) as (rs' & A & B & C); eauto. Qed. Lemma transl_op_correct: diff --git a/powerpc/Machregs.v b/powerpc/Machregs.v index 53d99e2f..e7c8758b 100644 --- a/powerpc/Machregs.v +++ b/powerpc/Machregs.v @@ -159,11 +159,7 @@ Definition register_by_name (s: string) : option mreg := (** ** Destroyed registers, preferred registers *) -Definition destroyed_by_cond (cond: condition): list mreg := - match cond with - | Ccomplimm _ _ | Ccompluimm _ _ => R12 :: nil - | _ => nil - end. +Definition destroyed_by_cond (cond: condition): list mreg := nil. Definition destroyed_by_op (op: operation): list mreg := match op with diff --git a/powerpc/NeedOp.v b/powerpc/NeedOp.v index 9a579cc5..5ea09bd8 100644 --- a/powerpc/NeedOp.v +++ b/powerpc/NeedOp.v @@ -65,6 +65,7 @@ Definition needs_of_operation (op: operation) (nv: nval): list nval := | Ofloatofwords | Omakelong => op2 (default nv) | Olowlong | Ohighlong => op1 (default nv) | Ocmp c => needs_of_condition c + | Osel c ty => nv :: nv :: needs_of_condition c end. Definition operation_is_redundant (op: operation) (nv: nval): bool := @@ -147,6 +148,10 @@ Proof. erewrite needs_of_condition_sound by eauto. subst v; simpl. auto with na. subst v; auto with na. +- destruct (eval_condition c args m) as [b|] eqn:EC. + erewrite needs_of_condition_sound by eauto. + apply select_sound; auto. + simpl; auto with na. Qed. Lemma operation_is_redundant_sound: diff --git a/powerpc/Op.v b/powerpc/Op.v index e6f942c1..0f082c1f 100644 --- a/powerpc/Op.v +++ b/powerpc/Op.v @@ -150,8 +150,9 @@ Inductive operation : Type := | Olowlong: operation (**r [rd = low-word(r1)] *) | Ohighlong: operation (**r [rd = high-word(r1)] *) (*c Boolean tests: *) - | Ocmp: condition -> operation. (**r [rd = 1] if condition holds, [rd = 0] otherwise. *) - + | Ocmp: condition -> operation (**r [rd = 1] if condition holds, [rd = 0] otherwise. *) + | Osel: condition -> typ -> operation. + (**r [rd = rs1] if condition holds, [rd = rs2] otherwise. *) (** Addressing modes. [r1], [r2], etc, are the arguments to the addressing. *) @@ -173,7 +174,7 @@ Proof. Defined. Definition beq_operation: forall (x y: operation), bool. - generalize Int.eq_dec Int64.eq_dec Ptrofs.eq_dec ident_eq Float.eq_dec Float32.eq_dec eq_condition; boolean_equality. + generalize Int.eq_dec Int64.eq_dec Ptrofs.eq_dec ident_eq Float.eq_dec Float32.eq_dec typ_eq eq_condition; boolean_equality. Defined. Definition eq_operation (x y: operation): {x=y} + {x<>y}. @@ -306,6 +307,7 @@ Definition eval_operation | Olowlong, v1::nil => Some(Val.loword v1) | Ohighlong, v1::nil => Some(Val.hiword v1) | Ocmp c, _ => Some(Val.of_optbool (eval_condition c vl m)) + | Osel c ty, v1::v2::vl => Some(Val.select (eval_condition c vl m) v1 v2 ty) | _, _ => None end. @@ -455,6 +457,7 @@ Definition type_of_operation (op: operation) : list typ * typ := | Olowlong => (Tlong :: nil, Tint) | Ohighlong => (Tlong :: nil, Tint) | Ocmp c => (type_of_condition c, Tint) + | Osel c ty => (ty :: ty :: type_of_condition c, ty) end. Definition type_of_addressing (addr: addressing) : list typ := @@ -575,6 +578,7 @@ Proof with (try exact I; try reflexivity). destruct v0... destruct v0... destruct (eval_condition c vl m); simpl... destruct b... + unfold Val.select. destruct (eval_condition c vl m). apply Val.normalize_type. exact I. Qed. End SOUNDNESS. @@ -727,22 +731,40 @@ Definition is_trivial_op (op: operation) : bool := (** Operations that depend on the memory state. *) +Definition condition_depends_on_memory (c: condition) : bool := + match c with + | Ccompu _ => true + | Ccompuimm _ _ => true + | Ccomplu _ => Archi.ppc64 + | Ccompluimm _ _ => Archi.ppc64 + | _ => false + end. + Definition op_depends_on_memory (op: operation) : bool := match op with - | Ocmp (Ccompu _) => true - | Ocmp (Ccompuimm _ _) => true - | Ocmp (Ccomplu _) => Archi.ppc64 - | Ocmp (Ccompluimm _ _) => Archi.ppc64 + | Ocmp c => condition_depends_on_memory c + | Osel c ty => condition_depends_on_memory c | _ => false end. +Lemma condition_depends_on_memory_correct: + forall c args m1 m2, + condition_depends_on_memory c = false -> + eval_condition c args m1 = eval_condition c args m2. +Proof. + intros. destruct c; simpl; auto; discriminate. +Qed. + Lemma op_depends_on_memory_correct: forall (F V: Type) (ge: Genv.t F V) sp op args m1 m2, op_depends_on_memory op = false -> eval_operation ge sp op args m1 = eval_operation ge sp op args m2. Proof. - intros until m2. destruct op; simpl; try congruence. unfold eval_condition. - destruct c; simpl; auto; try discriminate. + intros until m2. destruct op; simpl; try congruence; intros C. +- f_equal; f_equal; apply condition_depends_on_memory_correct; auto. +- destruct args; auto. destruct args; auto. + rewrite (condition_depends_on_memory_correct c args m1 m2 C). + auto. Qed. (** Global variables mentioned in an operation or addressing mode *) @@ -989,6 +1011,9 @@ Proof. exploit eval_condition_inj; eauto. intros EQ; rewrite EQ. destruct b; simpl; constructor. simpl; constructor. + apply Val.select_inject; auto. + destruct (eval_condition c vl1 m1) eqn:?; auto. + right; symmetry; eapply eval_condition_inj; eauto. Qed. Lemma eval_addressing_inj: diff --git a/powerpc/PrintOp.ml b/powerpc/PrintOp.ml index cffaafdb..8d7f17ab 100644 --- a/powerpc/PrintOp.ml +++ b/powerpc/PrintOp.ml @@ -110,6 +110,10 @@ let print_operation reg pp = function | Olowlong, [r1] -> fprintf pp "lowlong(%a)" reg r1 | Ohighlong, [r1] -> fprintf pp "highlong(%a)" reg r1 | Ocmp c, args -> print_condition reg pp (c, args) + | Osel (c, ty), r1::r2::args -> + fprintf pp "%a ?%s %a : %a" + (print_condition reg) (c, args) + (PrintAST.name_of_type ty) reg r1 reg r2 | Olongconst n, [] -> fprintf pp "%LdL" (camlint64_of_coqint n) | Ocast32signed, [r1] -> fprintf pp "int32signed(%a)" reg r1 | Ocast32unsigned, [r1] -> fprintf pp "int32unsigned(%a)" reg r1 diff --git a/powerpc/SelectLongproof.v b/powerpc/SelectLongproof.v index b4e48596..eba071eb 100644 --- a/powerpc/SelectLongproof.v +++ b/powerpc/SelectLongproof.v @@ -12,7 +12,7 @@ (** Correctness of instruction selection for 64-bit integer operations *) -Require Import String Coqlib Maps Integers Floats Errors. +Require Import String Coqlib Maps Zbits Integers Floats Errors. Require Archi. Require Import AST Values Memory Globalenvs Events. Require Import Cminor Op CminorSel. @@ -222,11 +222,11 @@ Proof. change (Int64.unsigned Int64.iwordsize) with 64. f_equal. rewrite Int.unsigned_repr. - apply Int.eqmod_mod_eq. omega. - apply Int.eqmod_trans with a. - apply Int.eqmod_divides with Int.modulus. apply Int.eqm_sym. apply Int.eqm_unsigned_repr. + apply eqmod_mod_eq. omega. + apply eqmod_trans with a. + apply eqmod_divides with Int.modulus. apply Int.eqm_sym. apply Int.eqm_unsigned_repr. exists (two_p (32-6)); auto. - apply Int.eqmod_divides with Int64.modulus. apply Int64.eqm_unsigned_repr. + apply eqmod_divides with Int64.modulus. apply Int64.eqm_unsigned_repr. exists (two_p (64-6)); auto. assert (0 <= Int.unsigned (Int.repr a) mod 64 < 64) by (apply Z_mod_lt; omega). assert (64 < Int.max_unsigned) by (compute; auto). diff --git a/powerpc/SelectOp.vp b/powerpc/SelectOp.vp index 478ce251..b1cac124 100644 --- a/powerpc/SelectOp.vp +++ b/powerpc/SelectOp.vp @@ -44,6 +44,7 @@ Require Import Floats. Require Import Op. Require Import CminorSel. Require Import OpHelpers. +Require Archi. Local Open Scope cminorsel_scope. @@ -517,6 +518,19 @@ Definition singleofintu (e: expr) := Definition singleoffloat (e: expr) := Eop Osingleoffloat (e ::: Enil). Definition floatofsingle (e: expr) := Eop Ofloatofsingle (e ::: Enil). +(** ** Selection *) + +Definition select (ty: typ) (cond: condition) (args: exprlist) (e1 e2: expr) := + if match ty with + | Tint => true + | Tfloat => true + | Tsingle => true + | Tlong => Archi.ppc64 + | _ => false + end + then Some (Eop (Osel cond ty) (e1 ::: e2 ::: args)) + else None. + (** ** Recognition of addressing modes for load and store operations *) Definition can_use_Aindexed2 (chunk: memory_chunk): bool := diff --git a/powerpc/SelectOpproof.v b/powerpc/SelectOpproof.v index 00b91e70..92852d36 100644 --- a/powerpc/SelectOpproof.v +++ b/powerpc/SelectOpproof.v @@ -1004,6 +1004,27 @@ Proof. exists (Val.singleoffloat v); split. EvalOp. inv D; auto. Qed. +Theorem eval_select: + forall le ty cond al vl a1 v1 a2 v2 a b, + select ty cond al a1 a2 = Some a -> + eval_exprlist ge sp e m le al vl -> + eval_expr ge sp e m le a1 v1 -> + eval_expr ge sp e m le a2 v2 -> + eval_condition cond vl m = Some b -> + + exists v, + eval_expr ge sp e m le a v + /\ Val.lessdef (Val.select (Some b) v1 v2 ty) v. +Proof. + unfold select; intros. + destruct (match ty with Tint => true | Tfloat => true | Tsingle => true | Tlong => Archi.ppc64 | _ => false end); inv H. + exists (Val.select (Some b) v1 v2 ty); split. + apply eval_Eop with (v1 :: v2 :: vl). + constructor; auto. constructor; auto. + simpl. rewrite H3; auto. + auto. +Qed. + Theorem eval_addressing: forall le chunk a v b ofs, eval_expr ge sp e m le a v -> diff --git a/powerpc/TargetPrinter.ml b/powerpc/TargetPrinter.ml index c1aaa55d..a1338561 100644 --- a/powerpc/TargetPrinter.ml +++ b/powerpc/TargetPrinter.ml @@ -118,13 +118,22 @@ module Linux_System : SYSTEM = let name_of_section = function | Section_text -> ".text" | Section_data i -> - if i then ".data" else "COMM" + if i then + ".data" + else + common_section ~sec:".section .bss" () | Section_small_data i -> - if i then ".section .sdata,\"aw\",@progbits" else "COMM" + if i then + ".section .sdata,\"aw\",@progbits" + else + common_section ~sec:".section .sbss,\"aw\",@nobits" () | Section_const i -> - if i then ".rodata" else "COMM" + if i || (not !Clflags.option_fcommon) then ".rodata" else "COMM" | Section_small_const i -> - if i then ".section .sdata2,\"a\",@progbits" else "COMM" + if i || (not !Clflags.option_fcommon) then + ".section .sdata2,\"a\",@progbits" + else + "COMM" | Section_string -> ".rodata" | Section_literal -> ".section .rodata.cst8,\"aM\",@progbits,8" | Section_jumptable -> ".text" @@ -209,7 +218,7 @@ module Diab_System : SYSTEM = let name_of_section = function | Section_text -> ".text" - | Section_data i -> if i then ".data" else "COMM" + | Section_data i -> if i then ".data" else common_section () | Section_small_data i -> if i then ".sdata" else ".sbss" | Section_const _ -> ".text" | Section_small_const _ -> ".sdata2" @@ -604,6 +613,7 @@ module Target (System : SYSTEM):TARGET = fprintf oc " fsel %a, %a, %a, %a\n" freg r1 freg r2 freg r3 freg r4 | Pisel (r1,r2,r3,cr) -> fprintf oc " isel %a, %a, %a, %a\n" ireg r1 ireg r2 ireg r3 crbit cr + | Pfsel_gen _ -> assert false | Picbi (r1,r2) -> fprintf oc " icbi %a, %a\n" ireg r1 ireg r2 | Picbtls (n,r1,r2) -> diff --git a/powerpc/ValueAOp.v b/powerpc/ValueAOp.v index f7f65e9e..a270d857 100644 --- a/powerpc/ValueAOp.v +++ b/powerpc/ValueAOp.v @@ -141,6 +141,7 @@ Definition eval_static_operation (op: operation) (vl: list aval): aval := | Olowlong, v1::nil => loword v1 | Ohighlong, v1::nil => hiword v1 | Ocmp c, _ => of_optbool (eval_static_condition c vl) + | Osel c ty, v1::v2::vl => select (eval_static_condition c vl) v1 v2 | _, _ => Vbot end. @@ -211,6 +212,7 @@ Proof. apply rolml_sound; auto. apply floatofwords_sound; auto. apply of_optbool_sound. eapply eval_static_condition_sound; eauto. + apply select_sound; auto. eapply eval_static_condition_sound; eauto. Qed. End SOUNDNESS. diff --git a/riscV/Archi.v b/riscV/Archi.v index a1664262..3758d686 100644 --- a/riscV/Archi.v +++ b/riscV/Archi.v @@ -17,8 +17,8 @@ (** Architecture-dependent parameters for RISC-V *) Require Import ZArith. -Require Import Fappli_IEEE. -Require Import Fappli_IEEE_bits. +(*From Flocq*) +Require Import Binary Bits. Parameter ptr64 : bool. @@ -38,26 +38,28 @@ Qed. floating-point operation is NaN, it is the canonical NaN. The canonical NaN has a positive sign and all significand bits clear except the MSB, a.k.a. the quiet bit." - We need to extend the [choose_binop_pl] functions to account for - this case. *) + Exceptions are operations manipulating signs. *) -Program Definition default_pl_64 : bool * nan_pl 53 := - (false, iter_nat 51 _ xO xH). +Definition default_nan_64 : { x : binary64 | is_nan _ _ x = true } := + exist _ (B754_nan 53 1024 false (iter_nat 51 _ xO xH) (eq_refl true)) (eq_refl true). -Definition choose_binop_pl_64 (s1: bool) (pl1: nan_pl 53) (s2: bool) (pl2: nan_pl 53) := - false. (**r always choose first NaN *) +Definition choose_binop_pl_64 (pl1 pl2 : positive) := + false. (**r irrelevant *) -Program Definition default_pl_32 : bool * nan_pl 24 := - (false, iter_nat 22 _ xO xH). +Definition default_nan_32 : { x : binary32 | is_nan _ _ x = true } := + exist _ (B754_nan 24 128 false (iter_nat 22 _ xO xH) (eq_refl true)) (eq_refl true). -Definition choose_binop_pl_32 (s1: bool) (pl1: nan_pl 24) (s2: bool) (pl2: nan_pl 24) := - false. (**r always choose first NaN *) +Definition choose_binop_pl_32 (pl1 pl2 : positive) := + false. (**r irrelevant *) + +Definition fpu_returns_default_qNaN := true. Definition float_of_single_preserves_sNaN := false. Global Opaque ptr64 big_endian splitlong - default_pl_64 choose_binop_pl_64 - default_pl_32 choose_binop_pl_32 + default_nan_64 choose_binop_pl_64 + default_nan_32 choose_binop_pl_32 + fpu_returns_default_qNaN float_of_single_preserves_sNaN. (** Whether to generate position-independent code or not *) diff --git a/riscV/Asm.v b/riscV/Asm.v index 1d8fda11..dc410a3b 100644 --- a/riscV/Asm.v +++ b/riscV/Asm.v @@ -369,7 +369,7 @@ lbl: - [Ploadfi rd fval]: similar to [Ploadli] but loads a double FP constant fval into a float register rd. -- [Ploadsi rd fval]: similar to [Ploadli] but loads a singe FP constant fval +- [Ploadsi rd fval]: similar to [Ploadli] but loads a single FP constant fval into a float register rd. - [Pallocframe sz pos]: in the formal semantics, this diff --git a/riscV/Asmgenproof1.v b/riscV/Asmgenproof1.v index 7f070c12..98d5bd33 100644 --- a/riscV/Asmgenproof1.v +++ b/riscV/Asmgenproof1.v @@ -16,7 +16,7 @@ (* *********************************************************************) Require Import Coqlib Errors Maps. -Require Import AST Integers Floats Values Memory Globalenvs. +Require Import AST Zbits Integers Floats Values Memory Globalenvs. Require Import Op Locations Mach Conventions. Require Import Asm Asmgen Asmgenproof0. @@ -33,16 +33,16 @@ Proof. predSpec Int.eq Int.eq_spec n lo. - auto. - set (m := Int.sub n lo). - assert (A: Int.eqmod (two_p 12) (Int.unsigned lo) (Int.unsigned n)) by (apply Int.eqmod_sign_ext'; compute; auto). - assert (B: Int.eqmod (two_p 12) (Int.unsigned n - Int.unsigned lo) 0). + assert (A: eqmod (two_p 12) (Int.unsigned lo) (Int.unsigned n)) by (apply Int.eqmod_sign_ext'; compute; auto). + assert (B: eqmod (two_p 12) (Int.unsigned n - Int.unsigned lo) 0). { replace 0 with (Int.unsigned n - Int.unsigned n) by omega. - auto using Int.eqmod_sub, Int.eqmod_refl. } - assert (C: Int.eqmod (two_p 12) (Int.unsigned m) 0). - { apply Int.eqmod_trans with (Int.unsigned n - Int.unsigned lo); auto. - apply Int.eqmod_divides with Int.modulus. apply Int.eqm_sym; apply Int.eqm_unsigned_repr. + auto using eqmod_sub, eqmod_refl. } + assert (C: eqmod (two_p 12) (Int.unsigned m) 0). + { apply eqmod_trans with (Int.unsigned n - Int.unsigned lo); auto. + apply eqmod_divides with Int.modulus. apply Int.eqm_sym; apply Int.eqm_unsigned_repr. exists (two_p (32-12)); auto. } assert (D: Int.modu m (Int.repr 4096) = Int.zero). - { apply Int.eqmod_mod_eq in C. unfold Int.modu. + { apply eqmod_mod_eq in C. unfold Int.modu. change (Int.unsigned (Int.repr 4096)) with (two_p 12). rewrite C. reflexivity. apply two_p_gt_ZERO; omega. } diff --git a/riscV/SelectOp.vp b/riscV/SelectOp.vp index 181b9d05..ba7c5664 100644 --- a/riscV/SelectOp.vp +++ b/riscV/SelectOp.vp @@ -420,6 +420,12 @@ Definition singleofintu (e: expr) := Eop Osingleofintu (e ::: Enil). Definition singleoffloat (e: expr) := Eop Osingleoffloat (e ::: Enil). Definition floatofsingle (e: expr) := Eop Ofloatofsingle (e ::: Enil). +(** ** Selection *) + +Definition select (ty: typ) (cond: condition) (args: exprlist) (e1 e2: expr) + : option expr + := None. + (** ** Recognition of addressing modes for load and store operations *) Nondetfunction addressing (chunk: memory_chunk) (e: expr) := diff --git a/riscV/SelectOpproof.v b/riscV/SelectOpproof.v index 9966305c..46cc1bbc 100644 --- a/riscV/SelectOpproof.v +++ b/riscV/SelectOpproof.v @@ -20,6 +20,7 @@ Require Import Coqlib. Require Import Maps. Require Import AST. +Require Import Zbits. Require Import Integers. Require Import Floats. Require Import Values. @@ -376,7 +377,7 @@ Proof. change (Int.ltu (Int.repr 32) Int64.iwordsize') with true; simpl. apply Val.lessdef_same. f_equal. transitivity (Int.repr (Z.shiftr (Int.signed i * Int.signed i0) 32)). - unfold Int.mulhs; f_equal. rewrite Int.Zshiftr_div_two_p by omega. reflexivity. + unfold Int.mulhs; f_equal. rewrite Zshiftr_div_two_p by omega. reflexivity. apply Int.same_bits_eq; intros n N. change Int.zwordsize with 32 in *. assert (N1: 0 <= n < 64) by omega. @@ -404,7 +405,7 @@ Proof. change (Int.ltu (Int.repr 32) Int64.iwordsize') with true; simpl. apply Val.lessdef_same. f_equal. transitivity (Int.repr (Z.shiftr (Int.unsigned i * Int.unsigned i0) 32)). - unfold Int.mulhu; f_equal. rewrite Int.Zshiftr_div_two_p by omega. reflexivity. + unfold Int.mulhu; f_equal. rewrite Zshiftr_div_two_p by omega. reflexivity. apply Int.same_bits_eq; intros n N. change Int.zwordsize with 32 in *. assert (N1: 0 <= n < 64) by omega. @@ -876,6 +877,20 @@ Proof. red; intros. unfold floatofsingle. TrivialExists. Qed. +Theorem eval_select: + forall le ty cond al vl a1 v1 a2 v2 a b, + select ty cond al a1 a2 = Some a -> + eval_exprlist ge sp e m le al vl -> + eval_expr ge sp e m le a1 v1 -> + eval_expr ge sp e m le a2 v2 -> + eval_condition cond vl m = Some b -> + exists v, + eval_expr ge sp e m le a v + /\ Val.lessdef (Val.select (Some b) v1 v2 ty) v. +Proof. + unfold select; intros; discriminate. +Qed. + Theorem eval_addressing: forall le chunk a v b ofs, eval_expr ge sp e m le a v -> diff --git a/riscV/TargetPrinter.ml b/riscV/TargetPrinter.ml index 19704bad..92df7a76 100644 --- a/riscV/TargetPrinter.ml +++ b/riscV/TargetPrinter.ml @@ -108,9 +108,9 @@ module Target : TARGET = let name_of_section = function | Section_text -> ".text" | Section_data i | Section_small_data i -> - if i then ".data" else "COMM" + if i then ".data" else common_section () | Section_const i | Section_small_const i -> - if i then ".section .rodata" else "COMM" + if i || (not !Clflags.option_fcommon) then ".section .rodata" else "COMM" | Section_string -> ".section .rodata" | Section_literal -> ".section .rodata" | Section_jumptable -> ".section .rodata" diff --git a/runtime/Makefile b/runtime/Makefile index 1258d941..0a18e0f8 100644 --- a/runtime/Makefile +++ b/runtime/Makefile @@ -79,16 +79,16 @@ clean:: ifeq ($(strip $(HAS_RUNTIME_LIB)),true) install:: - install -d $(LIBDIR) - install -m 0644 $(LIB) $(LIBDIR) + install -d $(DESTDIR)$(LIBDIR) + install -m 0644 $(LIB) $(DESTDIR)$(LIBDIR) else install:: endif ifeq ($(strip $(HAS_STANDARD_HEADERS)),true) install:: - install -d $(LIBDIR)/include - install -m 0644 $(INCLUDES) $(LIBDIR)/include + install -d $(DESTDIR)$(LIBDIR)/include + install -m 0644 $(INCLUDES) $(DESTDIR)$(LIBDIR)/include else install:: endif diff --git a/test/c/chomp.c b/test/c/chomp.c index c88cef5c..728e7a01 100644 --- a/test/c/chomp.c +++ b/test/c/chomp.c @@ -106,7 +106,7 @@ void dump_play(struct _play *play) /* and for the entire game tree */ int get_value(int *data) /* get the value (0 or 1) for a specific _data */ { struct _play *search; - search = game_tree; /* start at the begginig */ + search = game_tree; /* start at the beginning */ while (! equal_data(search -> state,data)) /* until you find a match */ search = search -> next; /* take next element */ return search -> value; /* return its value */ @@ -138,7 +138,7 @@ void show_list(struct _list *list) /* show the entire list of moves */ } } -void show_play(struct _play *play) /* to diplay the whole tree */ +void show_play(struct _play *play) /* to display the whole tree */ { while (play != NULL) { @@ -154,7 +154,7 @@ void show_play(struct _play *play) /* to diplay the whole tree */ int in_wanted(int *data) /* checks if the current _data is in the wanted list */ { struct _list *current; - current = wanted; /* start at the begginig */ + current = wanted; /* start at the beginning */ while (current != NULL) /* unitl the last one */ { if (equal_data(current -> data,data)) break; /* break if found */ diff --git a/test/regression/Makefile b/test/regression/Makefile index 0bcbcc1f..ab27c85a 100644 --- a/test/regression/Makefile +++ b/test/regression/Makefile @@ -16,7 +16,7 @@ TESTS=int32 int64 floats floats-basics \ funct3 expr5 struct7 struct8 struct11 struct12 casts1 casts2 char1 \ sizeof1 sizeof2 binops bool for1 for2 switch switch2 compound \ decl1 interop1 bitfields9 ptrs3 \ - parsing krfun + parsing krfun ifconv # Can run, but only in compiled mode, and have reference output in Results diff --git a/test/regression/Results/ifconv b/test/regression/Results/ifconv new file mode 100644 index 00000000..38019fe6 --- /dev/null +++ b/test/regression/Results/ifconv @@ -0,0 +1,26 @@ +test1(0,1,12,34) = 12 +test1(1,0,45,67) = 67 +test2(0,1,12,34) = 12 +test2(1,0,45,67) = 67 +test3(0,1,12,34) = 12 +test3(1,0,45,67) = 67 +test4(0,1,12,34) = 12 +test4(1,0,45,67) = 67 +test5(0,1,12) = 13 +test5(1,0,45) = 44 +test6(NULL) = 0 +test6(&i) = 1244 +test7(1,0) = -1 +test7(-100,4) = -25 +test8(0) = 0 +test8(1) = -72 +ltest1(-1, 0, 123LL, 456LL) = 124 +ltest1(1, 0, 123LL, 456LL) = 114 +dmax(0.0, 3.14) = 3.140000 +dmax(1.0, -2.718) = 1.000000 +dabs(1.0) = 1.000000 +dabs(-2.718) = 2.718000 +smin(0.0, 3.14) = 0.000000 +smin(1.0, -2.718) = -2.718000 +sdoz(1.0, 0.5) = 0.500000 +sdoz(0.0, 3.14) = 0.000000 diff --git a/test/regression/ifconv.c b/test/regression/ifconv.c new file mode 100644 index 00000000..dcbf43e5 --- /dev/null +++ b/test/regression/ifconv.c @@ -0,0 +1,129 @@ +#include <stdio.h> + +/* Several equivalent forms that should be turned into cmov */ + +int test1(int x, int y, int a, int b) +{ + return x < y ? a : b; +} + +int test2(int x, int y, int a, int b) +{ + int r; + if (x < y) { r = a; } else { r = b; } + return r; +} + +int test3(int x, int y, int a, int b) +{ + int r = b; + if (x < y) { r = a; } + return r; +} + +int test4(int x, int y, int a, int b) +{ + int r = a; + if (x < y) { /*skip*/; } else { r = b; } + return r; +} + +/* A more advanced example */ + +int test5(int x, int y, int a) +{ + return x < y ? a + 1 : a - 1; +} + +/* Unsafe operations should not be turned into cmov */ + +int test6(int * p) +{ + return p == NULL ? 0 : *p + 10; +} + +int test7(int a, int b) +{ + return b == 0 ? -1 : a / b; +} + +/* Very large operations should not be turned into cmov */ + +int test8(int a) +{ + return a == 0 ? 0 : a*a*a*a - 2*a*a*a + 10*a*a + 42*a - 123; +} + +/* Some examples with 64-bit integers */ + +long long ltest1(int x, int y, long long a, long long b) +{ + return x < y ? a + 1 : b >> 2; +} + +/* Some examples with floating-point */ + +double dmax(double x, double y) +{ + return x >= y ? x : y; +} + +double dabs(double x) +{ + return x < 0.0 ? -x : x; +} + +float smin(float x, float y) +{ + return x <= y ? x : y; +} + +float sdoz(float x, float y) +{ + return x >= y ? x - y : 0.0f; +} + +/* Test harness */ + +#define TESTI(call) printf(#call " = %d\n", call) +#define TESTL(call) printf(#call " = %lld\n", call) +#define TESTF(call) printf(#call " = %f\n", call) + + +int main() +{ + int i = 1234; + TESTI(test1(0,1,12,34)); + TESTI(test1(1,0,45,67)); + TESTI(test2(0,1,12,34)); + TESTI(test2(1,0,45,67)); + TESTI(test3(0,1,12,34)); + TESTI(test3(1,0,45,67)); + TESTI(test4(0,1,12,34)); + TESTI(test4(1,0,45,67)); + TESTI(test5(0,1,12)); + TESTI(test5(1,0,45)); + TESTI(test6(NULL)); + TESTI(test6(&i)); + TESTI(test7(1,0)); + TESTI(test7(-100,4)); + TESTI(test8(0)); + TESTI(test8(1)); + + TESTL(ltest1(-1, 0, 123LL, 456LL)); + TESTL(ltest1(1, 0, 123LL, 456LL)); + + TESTF(dmax(0.0, 3.14)); + TESTF(dmax(1.0, -2.718)); + + TESTF(dabs(1.0)); + TESTF(dabs(-2.718)); + + TESTF(smin(0.0, 3.14)); + TESTF(smin(1.0, -2.718)); + + TESTF(sdoz(1.0, 0.5)); + TESTF(sdoz(0.0, 3.14)); + + return 0; +} @@ -851,11 +851,12 @@ Definition exec_instr (f: function) (i: instruction) (rs: regset) (m: mem) : out | Ptestq_ri r1 n => Next (nextinstr (compare_longs (Val.andl (rs r1) (Vlong n)) (Vlong Int64.zero) rs m)) m | Pcmov c rd r1 => - match eval_testcond c rs with - | Some true => Next (nextinstr (rs#rd <- (rs#r1))) m - | Some false => Next (nextinstr rs) m - | None => Next (nextinstr (rs#rd <- Vundef)) m - end + let v := + match eval_testcond c rs with + | Some b => if b then rs#r1 else rs#rd + | None => Vundef + end in + Next (nextinstr (rs#rd <- v)) m | Psetcc c rd => Next (nextinstr (rs#rd <- (Val.of_optbool (eval_testcond c rs)))) m (** Arithmetic operations over double-precision floats *) diff --git a/x86/Asmgen.v b/x86/Asmgen.v index dedbfbe6..73e3263e 100644 --- a/x86/Asmgen.v +++ b/x86/Asmgen.v @@ -305,6 +305,35 @@ Definition mk_jcc (cond: extcond) (lbl: label) (k: code) := | Cond_or c1 c2 => Pjcc c1 lbl :: Pjcc c2 lbl :: k end. +Definition negate_testcond (c: testcond) : testcond := + match c with + | Cond_e => Cond_ne | Cond_ne => Cond_e + | Cond_b => Cond_ae | Cond_be => Cond_a + | Cond_ae => Cond_b | Cond_a => Cond_be + | Cond_l => Cond_ge | Cond_le => Cond_g + | Cond_ge => Cond_l | Cond_g => Cond_le + | Cond_p => Cond_np | Cond_np => Cond_p + end. + +Definition mk_sel (cond: extcond) (rd r2: ireg) (k: code) := + match cond with + | Cond_base c => + OK (Pcmov (negate_testcond c) rd r2 :: k) + | Cond_and c1 c2 => + OK (Pcmov (negate_testcond c1) rd r2 :: + Pcmov (negate_testcond c2) rd r2 :: k) + | Cond_or c1 c2 => + Error (msg "Asmgen.mk_sel") (**r should never happen, see [SelectOp.select] *) + end. + +Definition transl_sel + (cond: condition) (args: list mreg) (rd r2: ireg) (k: code) : res code := + if ireg_eq rd r2 then + OK (Pmov_rr rd r2 :: k) (* must generate one instruction... *) + else + do k1 <- mk_sel (testcond_for_condition cond) rd r2 k; + transl_cond cond args k1. + (** Translation of the arithmetic operation [r <- op(args)]. The corresponding instructions are prepended to [k]. *) @@ -597,6 +626,10 @@ Definition transl_op | Ocmp c, args => do r <- ireg_of res; transl_cond c args (mk_setcc (testcond_for_condition c) r k) + | Osel c ty, a1 :: a2 :: args => + assertion (mreg_eq a1 res); + do r <- ireg_of res; do r2 <- ireg_of a2; + transl_sel c args r r2 k | _, _ => Error(msg "Asmgen.transl_op") end. diff --git a/x86/Asmgenproof.v b/x86/Asmgenproof.v index 3aa87a4c..f1fd41e3 100644 --- a/x86/Asmgenproof.v +++ b/x86/Asmgenproof.v @@ -194,6 +194,14 @@ Proof. intros. destruct xc; simpl; TailNoLabel. Qed. +Remark mk_sel_label: + forall xc rd r2 k c, + mk_sel xc rd r2 k = OK c -> + tail_nolabel k c. +Proof. + unfold mk_sel; intros; destruct xc; inv H; TailNoLabel. +Qed. + Remark transl_cond_label: forall cond args k c, transl_cond cond args k = OK c -> @@ -221,6 +229,9 @@ Proof. destruct (Float32.eq_dec n Float32.zero); TailNoLabel. destruct (normalize_addrmode_64 x) as [am' [delta|]]; TailNoLabel. eapply tail_nolabel_trans. eapply transl_cond_label; eauto. eapply mk_setcc_label. + unfold transl_sel in EQ2. destruct (ireg_eq x x0); monadInv EQ2. + TailNoLabel. + eapply tail_nolabel_trans. eapply transl_cond_label; eauto. eapply mk_sel_label; eauto. Qed. Remark transl_load_label: @@ -706,7 +717,7 @@ Opaque loadind. intros. simpl in TR. destruct (transl_cond_correct tge tf cond args _ _ rs0 m' TR) as [rs' [A [B C]]]. - rewrite EC in B. + rewrite EC in B. destruct B as [B _]. destruct (testcond_for_condition cond); simpl in *. (* simple jcc *) exists (Pjcc c1 lbl); exists k; exists rs'. @@ -744,7 +755,7 @@ Opaque loadind. left; eapply exec_straight_steps; eauto. intros. simpl in TR. destruct (transl_cond_correct tge tf cond args _ _ rs0 m' TR) as [rs' [A [B C]]]. - rewrite EC in B. + rewrite EC in B. destruct B as [B _]. destruct (testcond_for_condition cond); simpl in *. (* simple jcc *) econstructor; split. diff --git a/x86/Asmgenproof1.v b/x86/Asmgenproof1.v index 904debdc..fd88954e 100644 --- a/x86/Asmgenproof1.v +++ b/x86/Asmgenproof1.v @@ -208,7 +208,8 @@ Proof. set (x' := Int.add x tnm1). set (rs2 := nextinstr (compare_ints (Vint x) (Vint Int.zero) rs1 m)). set (rs3 := nextinstr (rs2#RCX <- (Vint x'))). - set (rs4 := nextinstr (if Int.lt x Int.zero then rs3#RAX <- (Vint x') else rs3)). + set (v' := if Int.lt x Int.zero then Vint x' else Vint x). + set (rs4 := nextinstr (rs3#RAX <- v')). set (rs5 := nextinstr_nf (rs4#RAX <- (Val.shr rs4#RAX (Vint n)))). assert (rs3#RAX = Vint x). unfold rs3. Simplifs. assert (rs3#RCX = Vint x'). unfold rs3. Simplifs. @@ -218,13 +219,12 @@ Proof. change (rs2 RAX) with (rs1 RAX). rewrite A. simpl. rewrite Int.repr_unsigned. rewrite Int.add_zero_l. auto. auto. apply exec_straight_step with rs4 m. simpl. - rewrite Int.lt_sub_overflow. unfold rs4. destruct (Int.lt x Int.zero); simpl; auto. - unfold rs4. destruct (Int.lt x Int.zero); simpl; auto. + rewrite Int.lt_sub_overflow. unfold rs4, v'. rewrite H, H0. destruct (Int.lt x Int.zero); simpl; auto. + auto. apply exec_straight_one. auto. auto. split. unfold rs5. Simplifs. unfold rs4. rewrite nextinstr_inv; auto with asmgen. - destruct (Int.lt x Int.zero). rewrite Pregmap.gss. rewrite A; auto. rewrite A; rewrite H; auto. + rewrite Pregmap.gss. unfold v'. rewrite A. reflexivity. intros. unfold rs5. Simplifs. unfold rs4. Simplifs. - transitivity (rs3#r). destruct (Int.lt x Int.zero). Simplifs. auto. unfold rs3. Simplifs. unfold rs2. Simplifs. unfold compare_ints. Simplifs. Qed. @@ -913,6 +913,7 @@ Lemma transl_cond_correct: /\ match eval_condition cond (map rs (map preg_of args)) m with | None => True | Some b => eval_extcond (testcond_for_condition cond) rs' = Some b + /\ eval_extcond (testcond_for_condition (negate_condition cond)) rs' = Some (negb b) end /\ forall r, data_preg r = true -> rs'#r = rs r. Proof. @@ -921,58 +922,78 @@ Proof. - (* comp *) simpl. rewrite (ireg_of_eq _ _ EQ). rewrite (ireg_of_eq _ _ EQ1). econstructor. split. apply exec_straight_one. simpl. eauto. auto. - split. destruct (Val.cmp_bool c0 (rs x) (rs x0)) eqn:?; auto. + split. destruct (Val.cmp_bool c0 (rs x) (rs x0)) eqn:?; auto. split. + eapply testcond_for_signed_comparison_32_correct; eauto. eapply testcond_for_signed_comparison_32_correct; eauto. + rewrite Val.negate_cmp_bool, Heqo; auto. intros. unfold compare_ints. Simplifs. - (* compu *) simpl. rewrite (ireg_of_eq _ _ EQ). rewrite (ireg_of_eq _ _ EQ1). econstructor. split. apply exec_straight_one. simpl. eauto. auto. - split. destruct (Val.cmpu_bool (Mem.valid_pointer m) c0 (rs x) (rs x0)) eqn:?; auto. + split. destruct (Val.cmpu_bool (Mem.valid_pointer m) c0 (rs x) (rs x0)) eqn:?; auto. split. eapply testcond_for_unsigned_comparison_32_correct; eauto. + eapply testcond_for_unsigned_comparison_32_correct; eauto. + rewrite Val.negate_cmpu_bool, Heqo; auto. intros. unfold compare_ints. Simplifs. - (* compimm *) simpl. rewrite (ireg_of_eq _ _ EQ). destruct (Int.eq_dec n Int.zero). econstructor; split. apply exec_straight_one. simpl; eauto. auto. - split. destruct (rs x); simpl; auto. subst. rewrite Int.and_idem. + split. destruct (rs x); simpl; auto. subst. rewrite Int.and_idem. split. + eapply testcond_for_signed_comparison_32_correct; eauto. eapply testcond_for_signed_comparison_32_correct; eauto. + rewrite Val.negate_cmp_bool; auto. intros. unfold compare_ints. Simplifs. econstructor; split. apply exec_straight_one. simpl; eauto. auto. - split. destruct (Val.cmp_bool c0 (rs x) (Vint n)) eqn:?; auto. + split. destruct (Val.cmp_bool c0 (rs x) (Vint n)) eqn:?; auto. split. eapply testcond_for_signed_comparison_32_correct; eauto. + eapply testcond_for_signed_comparison_32_correct; eauto. + rewrite Val.negate_cmp_bool, Heqo; auto. intros. unfold compare_ints. Simplifs. - (* compuimm *) simpl. rewrite (ireg_of_eq _ _ EQ). econstructor. split. apply exec_straight_one. simpl. eauto. auto. - split. destruct (Val.cmpu_bool (Mem.valid_pointer m) c0 (rs x) (Vint n)) eqn:?; auto. + split. destruct (Val.cmpu_bool (Mem.valid_pointer m) c0 (rs x) (Vint n)) eqn:?; auto; split. + eapply testcond_for_unsigned_comparison_32_correct; eauto. eapply testcond_for_unsigned_comparison_32_correct; eauto. + rewrite Val.negate_cmpu_bool, Heqo; auto. intros. unfold compare_ints. Simplifs. - (* compl *) simpl. rewrite (ireg_of_eq _ _ EQ). rewrite (ireg_of_eq _ _ EQ1). econstructor. split. apply exec_straight_one. simpl. eauto. auto. - split. destruct (Val.cmpl_bool c0 (rs x) (rs x0)) eqn:?; auto. + split. destruct (Val.cmpl_bool c0 (rs x) (rs x0)) eqn:?; auto. split. eapply testcond_for_signed_comparison_64_correct; eauto. + eapply testcond_for_signed_comparison_64_correct; eauto. + rewrite Val.negate_cmpl_bool, Heqo; auto. intros. unfold compare_longs. Simplifs. - (* complu *) simpl. rewrite (ireg_of_eq _ _ EQ). rewrite (ireg_of_eq _ _ EQ1). econstructor. split. apply exec_straight_one. simpl. eauto. auto. - split. destruct (Val.cmplu_bool (Mem.valid_pointer m) c0 (rs x) (rs x0)) eqn:?; auto. + split. destruct (Val.cmplu_bool (Mem.valid_pointer m) c0 (rs x) (rs x0)) eqn:?; auto. split. + eapply testcond_for_unsigned_comparison_64_correct; eauto. eapply testcond_for_unsigned_comparison_64_correct; eauto. + rewrite Val.negate_cmplu_bool, Heqo; auto. intros. unfold compare_longs. Simplifs. - (* compimm *) simpl. rewrite (ireg_of_eq _ _ EQ). destruct (Int64.eq_dec n Int64.zero). econstructor; split. apply exec_straight_one. simpl; eauto. auto. - split. destruct (rs x); simpl; auto. subst. rewrite Int64.and_idem. + split. destruct (rs x); simpl; auto. subst. rewrite Int64.and_idem. split. eapply testcond_for_signed_comparison_64_correct; eauto. + eapply testcond_for_signed_comparison_64_correct; eauto. + rewrite Val.negate_cmpl_bool; auto. intros. unfold compare_longs. Simplifs. econstructor; split. apply exec_straight_one. simpl; eauto. auto. - split. destruct (Val.cmpl_bool c0 (rs x) (Vlong n)) eqn:?; auto. + split. destruct (Val.cmpl_bool c0 (rs x) (Vlong n)) eqn:?; auto. split. + eapply testcond_for_signed_comparison_64_correct; eauto. eapply testcond_for_signed_comparison_64_correct; eauto. + rewrite Val.negate_cmpl_bool, Heqo; auto. intros. unfold compare_longs. Simplifs. - (* compuimm *) simpl. rewrite (ireg_of_eq _ _ EQ). econstructor. split. apply exec_straight_one. simpl. eauto. auto. - split. destruct (Val.cmplu_bool (Mem.valid_pointer m) c0 (rs x) (Vlong n)) eqn:?; auto. + split. destruct (Val.cmplu_bool (Mem.valid_pointer m) c0 (rs x) (Vlong n)) eqn:?; auto. split. eapply testcond_for_unsigned_comparison_64_correct; eauto. + eapply testcond_for_unsigned_comparison_64_correct; eauto. + rewrite Val.negate_cmplu_bool, Heqo; auto. intros. unfold compare_longs. Simplifs. - (* compf *) simpl. rewrite (freg_of_eq _ _ EQ). rewrite (freg_of_eq _ _ EQ1). @@ -981,7 +1002,9 @@ Proof. destruct c0; simpl; auto. unfold nextinstr. rewrite Pregmap.gss. rewrite compare_floats_inv; auto with asmgen. split. destruct (rs x); destruct (rs x0); simpl; auto. - repeat rewrite swap_floats_commut. apply testcond_for_float_comparison_correct. + repeat rewrite swap_floats_commut. split. + apply testcond_for_float_comparison_correct. + apply testcond_for_neg_float_comparison_correct. intros. Simplifs. apply compare_floats_inv; auto with asmgen. - (* notcompf *) simpl. rewrite (freg_of_eq _ _ EQ). rewrite (freg_of_eq _ _ EQ1). @@ -990,7 +1013,9 @@ Proof. destruct c0; simpl; auto. unfold nextinstr. rewrite Pregmap.gss. rewrite compare_floats_inv; auto with asmgen. split. destruct (rs x); destruct (rs x0); simpl; auto. - repeat rewrite swap_floats_commut. apply testcond_for_neg_float_comparison_correct. + repeat rewrite swap_floats_commut. split. + apply testcond_for_neg_float_comparison_correct. + rewrite negb_involutive. apply testcond_for_float_comparison_correct. intros. Simplifs. apply compare_floats_inv; auto with asmgen. - (* compfs *) simpl. rewrite (freg_of_eq _ _ EQ). rewrite (freg_of_eq _ _ EQ1). @@ -999,7 +1024,9 @@ Proof. destruct c0; simpl; auto. unfold nextinstr. rewrite Pregmap.gss. rewrite compare_floats32_inv; auto with asmgen. split. destruct (rs x); destruct (rs x0); simpl; auto. - repeat rewrite swap_floats_commut. apply testcond_for_float32_comparison_correct. + repeat rewrite swap_floats_commut. split. + apply testcond_for_float32_comparison_correct. + apply testcond_for_neg_float32_comparison_correct. intros. Simplifs. apply compare_floats32_inv; auto with asmgen. - (* notcompfs *) simpl. rewrite (freg_of_eq _ _ EQ). rewrite (freg_of_eq _ _ EQ1). @@ -1008,7 +1035,9 @@ Proof. destruct c0; simpl; auto. unfold nextinstr. rewrite Pregmap.gss. rewrite compare_floats32_inv; auto with asmgen. split. destruct (rs x); destruct (rs x0); simpl; auto. - repeat rewrite swap_floats_commut. apply testcond_for_neg_float32_comparison_correct. + repeat rewrite swap_floats_commut. split. + apply testcond_for_neg_float32_comparison_correct. + rewrite negb_involutive. apply testcond_for_float32_comparison_correct. intros. Simplifs. apply compare_floats32_inv; auto with asmgen. - (* maskzero *) simpl. rewrite (ireg_of_eq _ _ EQ). @@ -1133,6 +1162,94 @@ Proof. intuition Simplifs. Qed. +Definition negate_extcond (xc: extcond) : extcond := + match xc with + | Cond_base c => Cond_base (negate_testcond c) + | Cond_and c1 c2 => Cond_or (negate_testcond c1) (negate_testcond c2) + | Cond_or c1 c2 => Cond_and (negate_testcond c1) (negate_testcond c2) + end. + +Remark negate_testcond_for_condition: + forall cond, + negate_extcond (testcond_for_condition cond) = testcond_for_condition (negate_condition cond). +Proof. + intros. destruct cond; try destruct c; reflexivity. +Qed. + +Lemma mk_sel_correct: + forall xc ty rd r2 k c ob rs m, + mk_sel xc rd r2 k = OK c -> + rd <> r2 -> + match ob with + | Some b => eval_extcond xc rs = Some b /\ eval_extcond (negate_extcond xc) rs = Some (negb b) + | None => True + end -> + exists rs', + exec_straight ge fn c rs m k rs' m + /\ Val.lessdef (Val.select ob rs#rd rs#r2 ty) rs'#rd + /\ forall r, data_preg r = true -> r <> rd -> rs'#r = rs r. +Proof. + intros. destruct xc; monadInv H; simpl in H1. +- econstructor; split. + eapply exec_straight_one. reflexivity. reflexivity. + set (v := match eval_testcond (negate_testcond c0) rs with + | Some true => rs r2 + | Some false => rs rd + | None => Vundef + end). + split. rewrite nextinstr_inv, Pregmap.gss by eauto with asmgen. + destruct ob; simpl; auto. destruct H1 as [_ B]; unfold v; rewrite B. + destruct b; apply Val.lessdef_normalize. + intros; Simplifs. +- econstructor; split. + eapply exec_straight_two. + reflexivity. reflexivity. reflexivity. reflexivity. + set (v1 := match eval_testcond (negate_testcond c1) rs with + | Some true => rs r2 + | Some false => rs rd + | None => Vundef + end). + rewrite eval_testcond_nextinstr, eval_testcond_set_ireg. + set (v2 := match eval_testcond (negate_testcond c2) rs with + | Some true => nextinstr rs # rd <- v1 r2 + | Some false => nextinstr rs # rd <- v1 rd + | None => Vundef + end). + split. rewrite nextinstr_inv, Pregmap.gss by eauto with asmgen. + destruct ob; simpl; auto. + destruct H1 as [_ B]. + destruct (eval_testcond (negate_testcond c1) rs) as [b1|]; try discriminate. + destruct (eval_testcond (negate_testcond c2) rs) as [b2|]; try discriminate. + inv B. apply negb_sym in H1. subst b. + replace v2 with (if b2 then rs#r2 else v1). + unfold v1. destruct b1, b2; apply Val.lessdef_normalize. + unfold v2. destruct b2; symmetry; Simplifs. + intros; Simplifs. +Qed. + +Lemma transl_sel_correct: + forall ty cond args rd r2 k c rs m, + transl_sel cond args rd r2 k = OK c -> + exists rs', + exec_straight ge fn c rs m k rs' m + /\ Val.lessdef (Val.select (eval_condition cond (map rs (map preg_of args)) m) rs#rd rs#r2 ty) rs'#rd + /\ forall r, data_preg r = true -> r <> rd -> rs'#r = rs r. +Proof. + unfold transl_sel; intros. destruct (ireg_eq rd r2); monadInv H. +- econstructor; split. + apply exec_straight_one; reflexivity. + split. rewrite nextinstr_inv, Pregmap.gss by auto with asmgen. + destruct eval_condition as [[]|]; simpl; auto using Val.lessdef_normalize. + intros; Simplifs. +- destruct (transl_cond_correct _ _ _ _ rs m EQ0) as (rs1 & A & B & C). + rewrite <- negate_testcond_for_condition in B. + destruct (mk_sel_correct _ ty _ _ _ _ _ rs1 m EQ n B) as (rs2 & D & E & F). + exists rs2; split. + eapply exec_straight_trans; eauto. + split. rewrite ! C in E by auto with asmgen. exact E. + intros. rewrite F; auto. +Qed. + (** Translation of arithmetic operations. *) Ltac ArgsInv := @@ -1142,7 +1259,9 @@ Ltac ArgsInv := | [ H: bind _ _ = OK _ |- _ ] => monadInv H; ArgsInv | [ H: match _ with left _ => _ | right _ => assertion_failed end = OK _ |- _ ] => monadInv H; ArgsInv | [ H: match _ with true => _ | false => assertion_failed end = OK _ |- _ ] => monadInv H; ArgsInv - | [ H: ireg_of _ = OK _ |- _ ] => simpl in *; rewrite (ireg_of_eq _ _ H) in *; clear H; ArgsInv + | [ H: ireg_of _ = OK _ |- _ ] => simpl in *; rewrite (ireg_of_eq _ _ H) in *; + let X := fresh "EQ" in generalize (ireg_of_eq _ _ H); intros X; + clear H; ArgsInv | [ H: freg_of _ = OK _ |- _ ] => simpl in *; rewrite (freg_of_eq _ _ H) in *; clear H; ArgsInv | _ => idtac end. @@ -1334,9 +1453,12 @@ Transparent destroyed_by_op. exists rs3. split. eapply exec_straight_trans. eexact P. eexact S. split. rewrite T. destruct (eval_condition cond rs ## (preg_of ## args) m). - rewrite Q. auto. + destruct Q as [Q _]. rewrite Q. auto. simpl; auto. intros. transitivity (rs2 r); auto. +(* selection *) + rewrite EQ1. exploit transl_sel_correct; eauto. intros (rs' & A & B & C). + exists rs'; split. eexact A. eauto. Qed. (** Translation of memory loads. *) diff --git a/x86/Machregs.v b/x86/Machregs.v index bdf492ed..6f3064b8 100644 --- a/x86/Machregs.v +++ b/x86/Machregs.v @@ -351,6 +351,7 @@ Definition two_address_op (op: operation) : bool := | Olongofsingle => false | Osingleoflong => false | Ocmp c => false + | Osel c op => true end. (* Constraints on constant propagation for builtins *) diff --git a/x86/NeedOp.v b/x86/NeedOp.v index 68ecc745..d9a58fbb 100644 --- a/x86/NeedOp.v +++ b/x86/NeedOp.v @@ -120,6 +120,7 @@ Definition needs_of_operation (op: operation) (nv: nval): list nval := | Ointoffloat | Ofloatofint | Ointofsingle | Osingleofint => op1 (default nv) | Olongoffloat | Ofloatoflong | Olongofsingle | Osingleoflong => op1 (default nv) | Ocmp c => needs_of_condition c + | Osel c ty => nv :: nv :: needs_of_condition c end. Definition operation_is_redundant (op: operation) (nv: nval): bool := @@ -231,6 +232,10 @@ Proof. erewrite needs_of_condition_sound by eauto. subst v; simpl. auto with na. subst v; auto with na. +- destruct (eval_condition c args m) as [b|] eqn:EC. + erewrite needs_of_condition_sound by eauto. + apply select_sound; auto. + simpl; auto with na. Qed. Lemma operation_is_redundant_sound: @@ -167,7 +167,9 @@ Inductive operation : Type := | Olongofsingle (**r [rd = signed_long_of_float32(r1)] *) | Osingleoflong (**r [rd = float32_of_signed_long(r1)] *) (*c Boolean tests: *) - | Ocmp (cond: condition). (**r [rd = 1] if condition holds, [rd = 0] otherwise. *) + | Ocmp (cond: condition) (**r [rd = 1] if condition holds, [rd = 0] otherwise. *) + | Osel: condition -> typ -> operation. + (**r [rd = rs1] if condition holds, [rd = rs2] otherwise. *) (** Comparison functions (used in modules [CSE] and [Allocation]). *) @@ -186,7 +188,7 @@ Defined. Definition beq_operation: forall (x y: operation), bool. Proof. - generalize Int.eq_dec Int64.eq_dec Float.eq_dec Float32.eq_dec ident_eq eq_addressing eq_condition; boolean_equality. + generalize Int.eq_dec Int64.eq_dec Float.eq_dec Float32.eq_dec ident_eq typ_eq eq_addressing eq_condition; boolean_equality. Defined. Definition eq_operation: forall (x y: operation), {x=y} + {x<>y}. @@ -407,6 +409,7 @@ Definition eval_operation | Olongofsingle, v1::nil => Val.longofsingle v1 | Osingleoflong, v1::nil => Val.singleoflong v1 | Ocmp c, _ => Some(Val.of_optbool (eval_condition c vl m)) + | Osel c ty, v1::v2::vl => Some(Val.select (eval_condition c vl m) v1 v2 ty) | _, _ => None end. @@ -578,6 +581,7 @@ Definition type_of_operation (op: operation) : list typ * typ := | Olongofsingle => (Tsingle :: nil, Tlong) | Osingleoflong => (Tlong :: nil, Tsingle) | Ocmp c => (type_of_condition c, Tint) + | Osel c ty => (ty :: ty :: type_of_condition c, ty) end. (** Weak type soundness results for [eval_operation]: @@ -735,6 +739,7 @@ Proof with (try exact I; try reflexivity). destruct v0; simpl in H0; inv H0. destruct (Float32.to_long f); inv H2... destruct v0; simpl in H0; inv H0... destruct (eval_condition cond vl m); simpl... destruct b... + unfold Val.select. destruct (eval_condition c vl m). apply Val.normalize_type. exact I. Qed. End SOUNDNESS. @@ -958,23 +963,42 @@ Definition is_trivial_op (op: operation) : bool := (** Operations that depend on the memory state. *) +Definition condition_depends_on_memory (c: condition) : bool := + match c with + | Ccompu _ => negb Archi.ptr64 + | Ccompuimm _ _ => negb Archi.ptr64 + | Ccomplu _ => Archi.ptr64 + | Ccompluimm _ _ => Archi.ptr64 + | _ => false + end. + Definition op_depends_on_memory (op: operation) : bool := match op with - | Ocmp (Ccompu _) => negb Archi.ptr64 - | Ocmp (Ccompuimm _ _) => negb Archi.ptr64 - | Ocmp (Ccomplu _) => Archi.ptr64 - | Ocmp (Ccompluimm _ _) => Archi.ptr64 + | Ocmp c => condition_depends_on_memory c + | Osel c ty => condition_depends_on_memory c | _ => false end. +Lemma condition_depends_on_memory_correct: + forall c args m1 m2, + condition_depends_on_memory c = false -> + eval_condition c args m1 = eval_condition c args m2. +Proof. + intros until m2. + destruct c; simpl; intros SF; auto; rewrite ? negb_false_iff in SF; + unfold Val.cmpu_bool, Val.cmplu_bool; rewrite SF; reflexivity. +Qed. + Lemma op_depends_on_memory_correct: forall (F V: Type) (ge: Genv.t F V) sp op args m1 m2, op_depends_on_memory op = false -> eval_operation ge sp op args m1 = eval_operation ge sp op args m2. Proof. - intros until m2. destruct op; simpl; try congruence. - destruct cond; simpl; intros SF; auto; rewrite ? negb_false_iff in SF; - unfold Val.cmpu_bool, Val.cmplu_bool; rewrite SF; reflexivity. + intros until m2. destruct op; simpl; try congruence; intros C. +- f_equal; f_equal; apply condition_depends_on_memory_correct; auto. +- destruct args; auto. destruct args; auto. + rewrite (condition_depends_on_memory_correct c args m1 m2 C). + auto. Qed. (** Global variables mentioned in an operation or addressing mode *) @@ -1290,6 +1314,9 @@ Proof. exploit eval_condition_inj; eauto. intros EQ; rewrite EQ. destruct b; simpl; constructor. simpl; constructor. + apply Val.select_inject; auto. + destruct (eval_condition c vl1 m1) eqn:?; auto. + right; symmetry; eapply eval_condition_inj; eauto. Qed. End EVAL_COMPAT. diff --git a/x86/PrintOp.ml b/x86/PrintOp.ml index faa5bb5f..6aa4d450 100644 --- a/x86/PrintOp.ml +++ b/x86/PrintOp.ml @@ -164,6 +164,10 @@ let print_operation reg pp = function | Olongofsingle, [r1] -> fprintf pp "longofsingle(%a)" reg r1 | Osingleoflong, [r1] -> fprintf pp "singleoflong(%a)" reg r1 | Ocmp c, args -> print_condition reg pp (c, args) + | Osel (c, ty), r1::r2::args -> + fprintf pp "%a ?%s %a : %a" + (print_condition reg) (c, args) + (PrintAST.name_of_type ty) reg r1 reg r2 | _ -> fprintf pp "<bad operator>" diff --git a/x86/SelectOp.vp b/x86/SelectOp.vp index eadda093..c0434a67 100644 --- a/x86/SelectOp.vp +++ b/x86/SelectOp.vp @@ -457,7 +457,35 @@ Nondetfunction cast16signed (e: expr) := Eop Ocast16signed (e ::: Enil) end. -(** Floating-point conversions *) +(** ** Selection *) + +Definition select_supported (ty: typ) : bool := + match ty with + | Tint => true + | Tlong => Archi.ptr64 + | _ => false + end. + +(** [Asmgen.mk_sel] cannot always handle the conditions that are + implemented as a "and" of two processor flags. However it can + handle the negation of those conditions, which are implemented + as an "or". So, for the risky conditions we just take their + negation and swap the two arguments of the [select]. *) + +Definition select_swap (cond: condition) := + match cond with + | Ccompf Cne | Ccompfs Cne | Cnotcompf Ceq | Cnotcompfs Ceq => true + | _ => false + end. + +Definition select (ty: typ) (cond: condition) (args: exprlist) (e1 e2: expr) := + if select_supported ty then + if select_swap cond + then Some (Eop (Osel (negate_condition cond) ty) (e2 ::: e1 ::: args)) + else Some (Eop (Osel cond ty) (e1 ::: e2 ::: args)) + else None. + +(** ** Floating-point conversions *) Definition singleoffloat (e: expr) := Eop Osingleoffloat (e ::: Enil). Definition floatofsingle (e: expr) := Eop Ofloatofsingle (e ::: Enil). diff --git a/x86/SelectOpproof.v b/x86/SelectOpproof.v index 1eeb5906..5e0f84e3 100644 --- a/x86/SelectOpproof.v +++ b/x86/SelectOpproof.v @@ -773,6 +773,32 @@ Proof. TrivialExists. Qed. +Theorem eval_select: + forall le ty cond al vl a1 v1 a2 v2 a b, + select ty cond al a1 a2 = Some a -> + eval_exprlist ge sp e m le al vl -> + eval_expr ge sp e m le a1 v1 -> + eval_expr ge sp e m le a2 v2 -> + eval_condition cond vl m = Some b -> + exists v, + eval_expr ge sp e m le a v + /\ Val.lessdef (Val.select (Some b) v1 v2 ty) v. +Proof. + unfold select; intros. + destruct (select_supported ty); try discriminate. + destruct (select_swap cond); inv H. +- exists (Val.select (Some (negb b)) v2 v1 ty); split. + apply eval_Eop with (v2 :: v1 :: vl). + constructor; auto. constructor; auto. + simpl. rewrite eval_negate_condition, H3; auto. + destruct b; auto. +- exists (Val.select (Some b) v1 v2 ty); split. + apply eval_Eop with (v1 :: v2 :: vl). + constructor; auto. constructor; auto. + simpl. rewrite H3; auto. + auto. +Qed. + Theorem eval_singleoffloat: unary_constructor_sound singleoffloat Val.singleoffloat. Proof. red; intros. unfold singleoffloat. TrivialExists. diff --git a/x86/TargetPrinter.ml b/x86/TargetPrinter.ml index 3ac2f36e..3025d2e7 100644 --- a/x86/TargetPrinter.ml +++ b/x86/TargetPrinter.ml @@ -103,7 +103,7 @@ let rec log2 n = assert (n > 0); if n = 1 then 0 else 1 + log2 (n lsr 1) -(* System dependend printer functions *) +(* System dependent printer functions *) module type SYSTEM = sig val raw_symbol: out_channel -> string -> unit @@ -134,9 +134,9 @@ module ELF_System : SYSTEM = let name_of_section = function | Section_text -> ".text" | Section_data i | Section_small_data i -> - if i then ".data" else "COMM" + if i then ".data" else common_section () | Section_const i | Section_small_const i -> - if i then ".section .rodata" else "COMM" + if i || (not !Clflags.option_fcommon) then ".section .rodata" else "COMM" | Section_string -> ".section .rodata" | Section_literal -> ".section .rodata.cst8,\"aM\",@progbits,8" | Section_jumptable -> ".text" @@ -192,9 +192,9 @@ module MacOS_System : SYSTEM = let name_of_section = function | Section_text -> ".text" | Section_data i | Section_small_data i -> - if i then ".data" else "COMM" + if i || (not !Clflags.option_fcommon) then ".data" else "COMM" | Section_const i | Section_small_const i -> - if i then ".const" else "COMM" + if i || (not !Clflags.option_fcommon) then ".const" else "COMM" | Section_string -> ".const" | Section_literal -> ".literal8" | Section_jumptable -> ".text" (* needed in 64 bits, not a problem in 32 bits *) @@ -269,9 +269,9 @@ module Cygwin_System : SYSTEM = let name_of_section = function | Section_text -> ".text" | Section_data i | Section_small_data i -> - if i then ".data" else "COMM" + if i then ".data" else common_section () | Section_const i | Section_small_const i -> - if i then ".section .rdata,\"dr\"" else "COMM" + if i || (not !Clflags.option_fcommon) then ".section .rdata,\"dr\"" else "COMM" | Section_string -> ".section .rdata,\"dr\"" | Section_literal -> ".section .rdata,\"dr\"" | Section_jumptable -> ".text" diff --git a/x86/ValueAOp.v b/x86/ValueAOp.v index 1021a9c8..d0b8427a 100644 --- a/x86/ValueAOp.v +++ b/x86/ValueAOp.v @@ -160,6 +160,7 @@ Definition eval_static_operation (op: operation) (vl: list aval): aval := | Olongofsingle, v1::nil => longofsingle v1 | Osingleoflong, v1::nil => singleoflong v1 | Ocmp c, _ => of_optbool (eval_static_condition c vl) + | Osel c ty, v1::v2::vl => select (eval_static_condition c vl) v1 v2 | _, _ => Vbot end. @@ -258,6 +259,7 @@ Proof. eapply eval_static_addressing_32_sound; eauto. eapply eval_static_addressing_64_sound; eauto. apply of_optbool_sound. eapply eval_static_condition_sound; eauto. + apply select_sound; auto. eapply eval_static_condition_sound; eauto. Qed. End SOUNDNESS. diff --git a/x86_32/Archi.v b/x86_32/Archi.v index 8e96b4f1..f10570e2 100644 --- a/x86_32/Archi.v +++ b/x86_32/Archi.v @@ -17,8 +17,8 @@ (** Architecture-dependent parameters for x86 in 32-bit mode *) Require Import ZArith. -Require Import Fappli_IEEE. -Require Import Fappli_IEEE_bits. +(*From Flocq*) +Require Import Binary Bits. Definition ptr64 := false. @@ -34,21 +34,24 @@ Proof. unfold splitlong. destruct ptr64; simpl; congruence. Qed. -Program Definition default_pl_64 : bool * nan_pl 53 := - (true, iter_nat 51 _ xO xH). +Definition default_nan_64 : { x : binary64 | is_nan _ _ x = true } := + exist _ (B754_nan 53 1024 true (iter_nat 51 _ xO xH) (eq_refl true)) (eq_refl true). -Definition choose_binop_pl_64 (s1: bool) (pl1: nan_pl 53) (s2: bool) (pl2: nan_pl 53) := +Definition choose_binop_pl_64 (pl1 pl2 : positive) := false. (**r always choose first NaN *) -Program Definition default_pl_32 : bool * nan_pl 24 := - (true, iter_nat 22 _ xO xH). +Definition default_nan_32 : { x : binary32 | is_nan _ _ x = true } := + exist _ (B754_nan 24 128 true (iter_nat 22 _ xO xH) (eq_refl true)) (eq_refl true). -Definition choose_binop_pl_32 (s1: bool) (pl1: nan_pl 24) (s2: bool) (pl2: nan_pl 24) := +Definition choose_binop_pl_32 (pl1 pl2 : positive) := false. (**r always choose first NaN *) +Definition fpu_returns_default_qNaN := false. + Definition float_of_single_preserves_sNaN := false. Global Opaque ptr64 big_endian splitlong - default_pl_64 choose_binop_pl_64 - default_pl_32 choose_binop_pl_32 + default_nan_64 choose_binop_pl_64 + default_nan_32 choose_binop_pl_32 + fpu_returns_default_qNaN float_of_single_preserves_sNaN. diff --git a/x86_64/Archi.v b/x86_64/Archi.v index 7b5301df..01eb36dd 100644 --- a/x86_64/Archi.v +++ b/x86_64/Archi.v @@ -17,8 +17,8 @@ (** Architecture-dependent parameters for x86 in 64-bit mode *) Require Import ZArith. -Require Import Fappli_IEEE. -Require Import Fappli_IEEE_bits. +(*From Flocq*) +Require Import Binary Bits. Definition ptr64 := true. @@ -34,21 +34,24 @@ Proof. unfold splitlong. destruct ptr64; simpl; congruence. Qed. -Program Definition default_pl_64 : bool * nan_pl 53 := - (true, iter_nat 51 _ xO xH). +Definition default_nan_64 : { x : binary64 | is_nan _ _ x = true } := + exist _ (B754_nan 53 1024 true (iter_nat 51 _ xO xH) (eq_refl true)) (eq_refl true). -Definition choose_binop_pl_64 (s1: bool) (pl1: nan_pl 53) (s2: bool) (pl2: nan_pl 53) := +Definition choose_binop_pl_64 (pl1 pl2 : positive) := false. (**r always choose first NaN *) -Program Definition default_pl_32 : bool * nan_pl 24 := - (true, iter_nat 22 _ xO xH). +Definition default_nan_32 : { x : binary32 | is_nan _ _ x = true } := + exist _ (B754_nan 24 128 true (iter_nat 22 _ xO xH) (eq_refl true)) (eq_refl true). -Definition choose_binop_pl_32 (s1: bool) (pl1: nan_pl 24) (s2: bool) (pl2: nan_pl 24) := +Definition choose_binop_pl_32 (pl1 pl2 : positive) := false. (**r always choose first NaN *) +Definition fpu_returns_default_qNaN := false. + Definition float_of_single_preserves_sNaN := false. Global Opaque ptr64 big_endian splitlong - default_pl_64 choose_binop_pl_64 - default_pl_32 choose_binop_pl_32 + default_nan_64 choose_binop_pl_64 + default_nan_32 choose_binop_pl_32 + fpu_returns_default_qNaN float_of_single_preserves_sNaN. |