diff options
49 files changed, 5923 insertions, 1945 deletions
@@ -5,18 +5,20 @@ lib/Maps.vo lib/Maps.glob: lib/Maps.v lib/Coqlib.vo lib/Heaps.vo lib/Heaps.glob: lib/Heaps.v lib/Coqlib.vo lib/Ordered.vo lib/Lattice.vo lib/Lattice.glob: lib/Lattice.v lib/Coqlib.vo lib/Maps.vo lib/Ordered.vo lib/Ordered.glob: lib/Ordered.v lib/Coqlib.vo lib/Maps.vo lib/Integers.vo -lib/Iteration.vo lib/Iteration.glob: lib/Iteration.v lib/Axioms.vo lib/Coqlib.vo +lib/Iteration.vo lib/Iteration.glob: lib/Iteration.v lib/Axioms.vo lib/Coqlib.vo lib/Wfsimpl.vo lib/Integers.vo lib/Integers.glob: lib/Integers.v lib/Axioms.vo lib/Coqlib.vo lib/Floats.vo lib/Floats.glob: lib/Floats.v lib/Coqlib.vo lib/Integers.vo lib/Parmov.vo lib/Parmov.glob: lib/Parmov.v lib/Axioms.vo lib/Coqlib.vo lib/UnionFind.vo lib/UnionFind.glob: lib/UnionFind.v lib/Coqlib.vo +lib/Wfsimpl.vo lib/Wfsimpl.glob: lib/Wfsimpl.v lib/Axioms.vo +lib/Postorder.vo lib/Postorder.glob: lib/Postorder.v lib/Coqlib.vo lib/Maps.vo lib/Iteration.vo common/Errors.vo common/Errors.glob: common/Errors.v lib/Coqlib.vo common/AST.vo common/AST.glob: common/AST.v lib/Coqlib.vo common/Errors.vo lib/Integers.vo lib/Floats.vo common/Events.vo common/Events.glob: common/Events.v lib/Coqlib.vo lib/Intv.vo common/AST.vo lib/Integers.vo lib/Floats.vo common/Values.vo common/Memory.vo common/Globalenvs.vo common/Errors.vo common/Globalenvs.vo common/Globalenvs.glob: common/Globalenvs.v lib/Axioms.vo lib/Coqlib.vo common/Errors.vo lib/Maps.vo common/AST.vo lib/Integers.vo lib/Floats.vo common/Values.vo common/Memory.vo common/Memdata.vo common/Memdata.glob: common/Memdata.v lib/Coqlib.vo common/AST.vo lib/Integers.vo lib/Floats.vo common/Values.vo common/Memtype.vo common/Memtype.glob: common/Memtype.v lib/Coqlib.vo common/AST.vo lib/Integers.vo lib/Floats.vo common/Values.vo common/Memdata.vo -common/Memory.vo common/Memory.glob: common/Memory.v lib/Axioms.vo lib/Coqlib.vo common/AST.vo lib/Integers.vo lib/Floats.vo common/Values.vo common/Memdata.vo common/Memtype.vo +common/Memory.vo common/Memory.glob: common/Memory.v lib/Axioms.vo lib/Coqlib.vo lib/Maps.vo common/AST.vo lib/Integers.vo lib/Floats.vo common/Values.vo common/Memdata.vo common/Memtype.vo lib/Intv.vo common/Values.vo common/Values.glob: common/Values.v lib/Coqlib.vo common/AST.vo lib/Integers.vo lib/Floats.vo common/Smallstep.vo common/Smallstep.glob: common/Smallstep.v lib/Coqlib.vo common/AST.vo common/Events.vo common/Globalenvs.vo lib/Integers.vo common/Behaviors.vo common/Behaviors.glob: common/Behaviors.v lib/Coqlib.vo common/AST.vo common/Events.vo common/Globalenvs.vo lib/Integers.vo common/Smallstep.vo @@ -36,6 +38,11 @@ backend/RTLgenspec.vo backend/RTLgenspec.glob: backend/RTLgenspec.v lib/Coqlib.v backend/RTLgenproof.vo backend/RTLgenproof.glob: backend/RTLgenproof.v lib/Coqlib.vo lib/Maps.vo common/AST.vo lib/Integers.vo common/Values.vo common/Memory.vo common/Events.vo common/Smallstep.vo common/Globalenvs.vo common/Switch.vo backend/Registers.vo backend/Cminor.vo $(ARCH)/Op.vo backend/CminorSel.vo backend/RTL.vo backend/RTLgen.vo backend/RTLgenspec.vo common/Errors.vo backend/Tailcall.vo backend/Tailcall.glob: backend/Tailcall.v lib/Coqlib.vo lib/Maps.vo common/AST.vo common/Globalenvs.vo backend/Registers.vo $(ARCH)/Op.vo backend/RTL.vo backend/Conventions.vo backend/Tailcallproof.vo backend/Tailcallproof.glob: backend/Tailcallproof.v lib/Coqlib.vo lib/Maps.vo common/AST.vo lib/Integers.vo common/Values.vo common/Memory.vo $(ARCH)/Op.vo common/Events.vo common/Globalenvs.vo common/Smallstep.vo backend/Registers.vo backend/RTL.vo backend/Conventions.vo backend/Tailcall.vo +backend/Inlining.vo backend/Inlining.glob: backend/Inlining.v lib/Coqlib.vo lib/Wfsimpl.vo common/Errors.vo lib/Maps.vo common/AST.vo lib/Integers.vo common/Values.vo $(ARCH)/Op.vo backend/Registers.vo backend/RTL.vo +backend/Inliningspec.vo backend/Inliningspec.glob: backend/Inliningspec.v lib/Coqlib.vo lib/Wfsimpl.vo common/Errors.vo lib/Maps.vo common/AST.vo lib/Integers.vo common/Values.vo common/Globalenvs.vo $(ARCH)/Op.vo backend/Registers.vo backend/RTL.vo backend/Inlining.vo +backend/Inliningproof.vo backend/Inliningproof.glob: backend/Inliningproof.v lib/Coqlib.vo common/Errors.vo lib/Maps.vo common/AST.vo lib/Integers.vo common/Values.vo common/Memory.vo common/Globalenvs.vo common/Events.vo common/Smallstep.vo $(ARCH)/Op.vo backend/Registers.vo backend/Inlining.vo backend/Inliningspec.vo backend/RTL.vo +backend/Renumber.vo backend/Renumber.glob: backend/Renumber.v lib/Coqlib.vo lib/Maps.vo lib/Postorder.vo common/AST.vo backend/RTL.vo +backend/Renumberproof.vo backend/Renumberproof.glob: backend/Renumberproof.v lib/Coqlib.vo lib/Maps.vo lib/Postorder.vo common/AST.vo common/Values.vo common/Events.vo common/Memory.vo common/Globalenvs.vo common/Smallstep.vo $(ARCH)/Op.vo backend/Registers.vo backend/RTL.vo backend/Renumber.vo backend/RTLtyping.vo backend/RTLtyping.glob: backend/RTLtyping.v lib/Coqlib.vo common/Errors.vo lib/Maps.vo common/AST.vo $(ARCH)/Op.vo backend/Registers.vo common/Globalenvs.vo common/Values.vo common/Memory.vo lib/Integers.vo common/Events.vo common/Smallstep.vo backend/RTL.vo backend/Conventions.vo backend/Kildall.vo backend/Kildall.glob: backend/Kildall.v lib/Coqlib.vo lib/Iteration.vo lib/Maps.vo lib/Lattice.vo lib/Heaps.vo $(ARCH)/ConstpropOp.vo $(ARCH)/ConstpropOp.glob: $(ARCH)/ConstpropOp.v lib/Coqlib.vo common/AST.vo lib/Integers.vo lib/Floats.vo common/Values.vo $(ARCH)/Op.vo backend/Registers.vo @@ -104,5 +111,5 @@ cfrontend/Cshmgenproof.vo cfrontend/Cshmgenproof.glob: cfrontend/Cshmgenproof.v cfrontend/Csharpminor.vo cfrontend/Csharpminor.glob: cfrontend/Csharpminor.v lib/Coqlib.vo lib/Maps.vo common/AST.vo lib/Integers.vo lib/Floats.vo common/Values.vo common/Memory.vo common/Events.vo common/Globalenvs.vo backend/Cminor.vo common/Smallstep.vo cfrontend/Cminorgen.vo cfrontend/Cminorgen.glob: cfrontend/Cminorgen.v lib/Coqlib.vo common/Errors.vo lib/Maps.vo lib/Ordered.vo common/AST.vo lib/Integers.vo lib/Floats.vo common/Memdata.vo cfrontend/Csharpminor.vo backend/Cminor.vo cfrontend/Cminorgenproof.vo cfrontend/Cminorgenproof.glob: cfrontend/Cminorgenproof.v lib/Coqlib.vo lib/Intv.vo common/Errors.vo lib/Maps.vo common/AST.vo lib/Integers.vo lib/Floats.vo common/Values.vo common/Memdata.vo common/Memory.vo common/Events.vo common/Globalenvs.vo common/Smallstep.vo common/Switch.vo cfrontend/Csharpminor.vo backend/Cminor.vo cfrontend/Cminorgen.vo -driver/Compiler.vo driver/Compiler.glob: driver/Compiler.v lib/Axioms.vo lib/Coqlib.vo lib/Maps.vo common/Errors.vo common/AST.vo common/Values.vo common/Smallstep.vo cfrontend/Csyntax.vo cfrontend/Csem.vo cfrontend/Cstrategy.vo cfrontend/Cexec.vo cfrontend/Clight.vo cfrontend/Csharpminor.vo backend/Cminor.vo backend/CminorSel.vo backend/RTL.vo backend/LTL.vo backend/LTLin.vo backend/Linear.vo backend/Mach.vo backend/Machsem.vo $(ARCH)/Asm.vo cfrontend/Initializers.vo cfrontend/SimplExpr.vo cfrontend/Cshmgen.vo cfrontend/Cminorgen.vo backend/Selection.vo backend/RTLgen.vo backend/Tailcall.vo backend/Constprop.vo backend/CSE.vo backend/Allocation.vo backend/Tunneling.vo backend/Linearize.vo backend/CleanupLabels.vo backend/Reload.vo backend/RRE.vo backend/Stacking.vo $(ARCH)/Asmgen.vo backend/RTLtyping.vo backend/LTLtyping.vo backend/LTLintyping.vo backend/Lineartyping.vo backend/Machtyping.vo cfrontend/SimplExprproof.vo cfrontend/Cshmgenproof.vo cfrontend/Cminorgenproof.vo backend/Selectionproof.vo backend/RTLgenproof.vo backend/Tailcallproof.vo backend/Constpropproof.vo backend/CSEproof.vo backend/Allocproof.vo backend/Alloctyping.vo backend/Tunnelingproof.vo backend/Tunnelingtyping.vo backend/Linearizeproof.vo backend/Linearizetyping.vo backend/CleanupLabelsproof.vo backend/CleanupLabelstyping.vo backend/Reloadproof.vo backend/Reloadtyping.vo backend/RREproof.vo backend/RREtyping.vo backend/Stackingproof.vo backend/Stackingtyping.vo $(ARCH)/Asmgenproof.vo +driver/Compiler.vo driver/Compiler.glob: driver/Compiler.v lib/Axioms.vo lib/Coqlib.vo lib/Maps.vo common/Errors.vo common/AST.vo common/Values.vo common/Smallstep.vo cfrontend/Csyntax.vo cfrontend/Csem.vo cfrontend/Cstrategy.vo cfrontend/Cexec.vo cfrontend/Clight.vo cfrontend/Csharpminor.vo backend/Cminor.vo backend/CminorSel.vo backend/RTL.vo backend/LTL.vo backend/LTLin.vo backend/Linear.vo backend/Mach.vo backend/Machsem.vo $(ARCH)/Asm.vo cfrontend/Initializers.vo cfrontend/SimplExpr.vo cfrontend/Cshmgen.vo cfrontend/Cminorgen.vo backend/Selection.vo backend/RTLgen.vo backend/Tailcall.vo backend/Inlining.vo backend/Renumber.vo backend/Constprop.vo backend/CSE.vo backend/Allocation.vo backend/Tunneling.vo backend/Linearize.vo backend/CleanupLabels.vo backend/Reload.vo backend/RRE.vo backend/Stacking.vo $(ARCH)/Asmgen.vo backend/RTLtyping.vo backend/LTLtyping.vo backend/LTLintyping.vo backend/Lineartyping.vo backend/Machtyping.vo cfrontend/SimplExprproof.vo cfrontend/Cshmgenproof.vo cfrontend/Cminorgenproof.vo backend/Selectionproof.vo backend/RTLgenproof.vo backend/Tailcallproof.vo backend/Inliningproof.vo backend/Renumberproof.vo backend/Constpropproof.vo backend/CSEproof.vo backend/Allocproof.vo backend/Alloctyping.vo backend/Tunnelingproof.vo backend/Tunnelingtyping.vo backend/Linearizeproof.vo backend/Linearizetyping.vo backend/CleanupLabelsproof.vo backend/CleanupLabelstyping.vo backend/Reloadproof.vo backend/Reloadtyping.vo backend/RREproof.vo backend/RREtyping.vo backend/Stackingproof.vo backend/Stackingtyping.vo $(ARCH)/Asmgenproof.vo driver/Complements.vo driver/Complements.glob: driver/Complements.v lib/Coqlib.vo common/AST.vo lib/Integers.vo common/Values.vo common/Events.vo common/Globalenvs.vo common/Smallstep.vo common/Behaviors.vo cfrontend/Csyntax.vo cfrontend/Csem.vo cfrontend/Cstrategy.vo cfrontend/Clight.vo backend/Cminor.vo backend/RTL.vo $(ARCH)/Asm.vo driver/Compiler.vo common/Errors.vo @@ -39,12 +39,13 @@ GPATH=$(DIRS) # General-purpose libraries (in lib/) LIB=Axioms.v Coqlib.v Intv.v Maps.v Heaps.v Lattice.v Ordered.v \ - Iteration.v Integers.v Floats.v Parmov.v UnionFind.v + Iteration.v Integers.v Floats.v Parmov.v UnionFind.v Wfsimpl.v \ + Postorder.v # Parts common to the front-ends and the back-end (in common/) -COMMON=Errors.v AST.v Events.v Globalenvs.v Memdata.v Memtype.v Memory.v Values.v \ - Smallstep.v Behaviors.v Switch.v Determinism.v +COMMON=Errors.v AST.v Events.v Globalenvs.v Memdata.v Memtype.v Memory.v \ + Values.v Smallstep.v Behaviors.v Switch.v Determinism.v # Back-end modules (in backend/, $(ARCH)/, $(ARCH)/$(VARIANT)) @@ -54,6 +55,8 @@ BACKEND=\ Registers.v RTL.v \ RTLgen.v RTLgenspec.v RTLgenproof.v \ Tailcall.v Tailcallproof.v \ + Inlining.v Inliningspec.v Inliningproof.v \ + Renumber.v Renumberproof.v \ RTLtyping.v \ Kildall.v \ ConstpropOp.v Constprop.v ConstpropOpproof.v Constpropproof.v \ diff --git a/arm/ConstpropOp.vp b/arm/ConstpropOp.vp index 0c77305..c0a04f0 100644 --- a/arm/ConstpropOp.vp +++ b/arm/ConstpropOp.vp @@ -84,11 +84,13 @@ Definition eval_static_intoffloat (f: float) := Definition eval_static_intuoffloat (f: float) := match Float.intuoffloat f with Some x => I x | None => Unknown end. +Parameter propagate_float_constants: unit -> bool. + Nondetfunction eval_static_operation (op: operation) (vl: list approx) := match op, vl with | Omove, v1::nil => v1 | Ointconst n, nil => I n - | Ofloatconst n, nil => F n + | Ofloatconst n, nil => if propagate_float_constants tt then F n else Unknown | Oaddrsymbol s n, nil => G s n | Oaddrstack n, nil => S n | Oadd, I n1 :: I n2 :: nil => I(Int.add n1 n2) @@ -138,12 +140,30 @@ Nondetfunction eval_static_operation (op: operation) (vl: list approx) := | Osingleoffloat, F n1 :: nil => F(Float.singleoffloat n1) | Ointoffloat, F n1 :: nil => eval_static_intoffloat n1 | Ointuoffloat, F n1 :: nil => eval_static_intuoffloat n1 - | Ofloatofint, I n1 :: nil => F(Float.floatofint n1) - | Ofloatofintu, I n1 :: nil => F(Float.floatofintu n1) + | Ofloatofint, I n1 :: nil => if propagate_float_constants tt then F(Float.floatofint n1) else Unknown + | Ofloatofintu, I n1 :: nil => if propagate_float_constants tt then F(Float.floatofintu n1) else Unknown | Ocmp c, vl => eval_static_condition_val c vl | _, _ => Unknown end. +Nondetfunction eval_static_addressing (addr: addressing) (vl: list approx) := + match addr, vl with + | Aindexed n, I n1::nil => I (Int.add n1 n) + | Aindexed n, G id ofs::nil => G id (Int.add ofs n) + | Aindexed n, S ofs::nil => S (Int.add ofs n) + | Aindexed2, I n1::I n2::nil => I (Int.add n1 n2) + | Aindexed2, G id ofs::I n2::nil => G id (Int.add ofs n2) + | Aindexed2, I n1::G id ofs::nil => G id (Int.add ofs n1) + | Aindexed2, S ofs::I n2::nil => S (Int.add ofs n2) + | Aindexed2, I n1::S ofs::nil => S (Int.add ofs n1) + | Aindexed2shift s, I n1::I n2::nil => I (Int.add n1 (eval_static_shift s n2)) + | Aindexed2shift s, G id ofs::I n2::nil => G id (Int.add ofs (eval_static_shift s n2)) + | Aindexed2shift s, S ofs::I n2::nil => S (Int.add ofs (eval_static_shift s n2)) + | Ainstack ofs, nil => S ofs + | _, _ => Unknown + end. + + (** * Operator strength reduction *) (** We now define auxiliary functions for strength reduction of diff --git a/arm/ConstpropOpproof.v b/arm/ConstpropOpproof.v index bf3b216..242f29b 100644 --- a/arm/ConstpropOpproof.v +++ b/arm/ConstpropOpproof.v @@ -124,7 +124,7 @@ Proof. unfold eval_static_operation. case (eval_static_operation_match op al); intros; InvVLMA; simpl in *; FuncInv; try (subst v); try (rewrite eval_static_shift_correct); auto. - + destruct (propagate_float_constants tt); simpl; auto. rewrite shift_symbol_address; auto. rewrite shift_symbol_address; auto. rewrite Val.add_assoc; auto. @@ -145,7 +145,8 @@ Proof. destruct (Int.ltu n2 Int.iwordsize); simpl; auto. unfold eval_static_intoffloat. destruct (Float.intoffloat n1); simpl in H0; inv H0; simpl; auto. unfold eval_static_intuoffloat. destruct (Float.intuoffloat n1); simpl in H0; inv H0; simpl; auto. - + destruct (propagate_float_constants tt); simpl; auto. + destruct (propagate_float_constants tt); simpl; auto. unfold eval_static_condition_val, Val.of_optbool. destruct (eval_static_condition c vl0) as []_eqn. rewrite (eval_static_condition_correct _ _ _ m _ H Heqo). @@ -153,6 +154,27 @@ Proof. simpl; auto. Qed. +Lemma eval_static_addressing_correct: + forall addr al vl v, + val_list_match_approx al vl -> + eval_addressing ge sp addr vl = Some v -> + val_match_approx (eval_static_addressing addr al) v. +Proof. + intros until v. unfold eval_static_addressing. + case (eval_static_addressing_match addr al); intros; + InvVLMA; simpl in *; FuncInv; try (subst v); try (rewrite eval_static_shift_correct); auto. + rewrite shift_symbol_address; auto. + rewrite Val.add_assoc. auto. + repeat rewrite shift_symbol_address. auto. + fold (Val.add (Vint n1) (symbol_address ge id ofs)). + repeat rewrite shift_symbol_address. apply Val.add_commut. + repeat rewrite Val.add_assoc. auto. + fold (Val.add (Vint n1) (Val.add sp (Vint ofs))). + rewrite Val.add_permut. decEq. rewrite Val.add_commut. auto. + rewrite shift_symbol_address. auto. + rewrite Val.add_assoc. auto. +Qed. + (** * Correctness of strength reduction *) (** We now show that strength reduction over operators and addressing diff --git a/arm/Unusedglob1.ml b/arm/Unusedglob1.ml new file mode 100644 index 0000000..04ef89a --- /dev/null +++ b/arm/Unusedglob1.ml @@ -0,0 +1,32 @@ +(* *********************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Xavier Leroy, INRIA Paris-Rocquencourt *) +(* *) +(* 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. *) +(* *) +(* *********************************************************************) + +(* Identifiers referenced from an ARM Asm instruction *) + +open Datatypes +open AST +open Asm + +let referenced_builtin ef = + match ef with + | EF_vload_global(chunk, id, ofs) -> [id] + | EF_vstore_global(chunk, id, ofs) -> [id] + | _ -> [] + +let referenced_instr = function + | Pbsymb(s, _) -> [s] + | Pblsymb(s, _) -> [s] + | Ploadsymbol(_, s, _) -> [s] + | Pbuiltin ef -> referenced_builtin ef + | _ -> [] + +let code_of_function f = f.fn_code diff --git a/backend/CminorSel.v b/backend/CminorSel.v index 84b47f3..a8e49e8 100644 --- a/backend/CminorSel.v +++ b/backend/CminorSel.v @@ -68,8 +68,8 @@ Inductive stmt : Type := | Sskip: stmt | Sassign : ident -> expr -> stmt | Sstore : memory_chunk -> addressing -> exprlist -> expr -> stmt - | Scall : option ident -> signature -> expr -> exprlist -> stmt - | Stailcall: signature -> expr -> exprlist -> stmt + | Scall : option ident -> signature -> expr + ident -> exprlist -> stmt + | Stailcall: signature -> expr + ident -> exprlist -> stmt | Sbuiltin : option ident -> external_function -> exprlist -> stmt | Sseq: stmt -> stmt -> stmt | Sifthenelse: condexpr -> stmt -> stmt -> stmt @@ -208,6 +208,14 @@ Scheme eval_expr_ind3 := Minimality for eval_expr Sort Prop with eval_condexpr_ind3 := Minimality for eval_condexpr Sort Prop with eval_exprlist_ind3 := Minimality for eval_exprlist Sort Prop. +Inductive eval_expr_or_symbol: letenv -> expr + ident -> val -> Prop := + | eval_eos_e: forall le e v, + eval_expr le e v -> + eval_expr_or_symbol le (inl _ e) v + | eval_eos_s: forall le id b, + Genv.find_symbol ge id = Some b -> + eval_expr_or_symbol le (inr _ id) (Vptr b Int.zero). + End EVAL_EXPR. (** Pop continuation until a call or stop *) @@ -282,7 +290,7 @@ Inductive step: state -> trace -> state -> Prop := E0 (State f Sskip k sp e m') | step_call: forall f optid sig a bl k sp e m vf vargs fd, - eval_expr sp e m nil a vf -> + eval_expr_or_symbol sp e m nil a vf -> eval_exprlist sp e m nil bl vargs -> Genv.find_funct ge vf = Some fd -> funsig fd = sig -> @@ -290,7 +298,7 @@ Inductive step: state -> trace -> state -> Prop := E0 (Callstate fd vargs (Kcall optid f sp e k) m) | step_tailcall: forall f sig a bl k sp e m vf vargs fd m', - eval_expr (Vptr sp Int.zero) e m nil a vf -> + eval_expr_or_symbol (Vptr sp Int.zero) e m nil a vf -> eval_exprlist (Vptr sp Int.zero) e m nil bl vargs -> Genv.find_funct ge vf = Some fd -> funsig fd = sig -> diff --git a/backend/Constprop.v b/backend/Constprop.v index c3b9863..19e5d1a 100644 --- a/backend/Constprop.v +++ b/backend/Constprop.v @@ -107,11 +107,84 @@ End Approx. Module D := LPMap Approx. -(** The transfer function for the dataflow analysis is straightforward: - for [Iop] instructions, we set the approximation of the destination - register to the result of executing abstractly the operation; - for [Iload] and [Icall], we set the approximation of the destination - to [Unknown]. *) +(** We keep track of read-only global variables (i.e. "const" global + variables in C) as a map from their names to their initialization + data. *) + +Definition global_approx : Type := PTree.t (list init_data). + +(** Given some initialization data and a byte offset, compute a static + approximation of the result of a memory load from a memory block + initialized with this data. *) + +Fixpoint eval_load_init (chunk: memory_chunk) (pos: Z) (il: list init_data): approx := + match il with + | nil => Unknown + | Init_int8 n :: il' => + if zeq pos 0 then + match chunk with + | Mint8unsigned => I (Int.zero_ext 8 n) + | Mint8signed => I (Int.sign_ext 8 n) + | _ => Unknown + end + else eval_load_init chunk (pos - 1) il' + | Init_int16 n :: il' => + if zeq pos 0 then + match chunk with + | Mint16unsigned => I (Int.zero_ext 16 n) + | Mint16signed => I (Int.sign_ext 16 n) + | _ => Unknown + end + else eval_load_init chunk (pos - 2) il' + | Init_int32 n :: il' => + if zeq pos 0 + then match chunk with Mint32 => I n | _ => Unknown end + else eval_load_init chunk (pos - 4) il' + | Init_float32 n :: il' => + if zeq pos 0 + then match chunk with + | Mfloat32 => if propagate_float_constants tt then F (Float.singleoffloat n) else Unknown + | _ => Unknown + end + else eval_load_init chunk (pos - 4) il' + | Init_float64 n :: il' => + if zeq pos 0 + then match chunk with + | Mfloat64 => if propagate_float_constants tt then F n else Unknown + | _ => Unknown + end + else eval_load_init chunk (pos - 8) il' + | Init_addrof symb ofs :: il' => + if zeq pos 0 + then match chunk with Mint32 => G symb ofs | _ => Unknown end + else eval_load_init chunk (pos - 4) il' + | Init_space n :: il' => + eval_load_init chunk (pos - Zmax n 0) il' + end. + +(** Compute a static approximation for the result of a load at an address whose + approximation is known. If the approximation points to a global variable, + and this global variable is read-only, we use its initialization data + to determine a static approximation. Otherwise, [Unknown] is returned. *) + +Definition eval_static_load (gapp: global_approx) (chunk: memory_chunk) (addr: approx) : approx := + match addr with + | G symb ofs => + match gapp!symb with + | None => Unknown + | Some il => eval_load_init chunk (Int.unsigned ofs) il + end + | _ => Unknown + end. + +(** The transfer function for the dataflow analysis is straightforward. + For [Iop] instructions, we set the approximation of the destination + register to the result of executing abstractly the operation. + For [Iload] instructions, we set the approximation of the destination + register to the result of [eval_static_load]. + For [Icall] and [Ibuiltin], the destination register becomes [Unknown]. + Other instructions keep the approximations unchanged, as they preserve + the values of all registers. *) Definition approx_reg (app: D.t) (r: reg) := D.get r app. @@ -119,7 +192,7 @@ Definition approx_reg (app: D.t) (r: reg) := Definition approx_regs (app: D.t) (rl: list reg):= List.map (approx_reg app) rl. -Definition transfer (f: function) (pc: node) (before: D.t) := +Definition transfer (gapp: global_approx) (f: function) (pc: node) (before: D.t) := match f.(fn_code)!pc with | None => before | Some i => @@ -128,7 +201,9 @@ Definition transfer (f: function) (pc: node) (before: D.t) := let a := eval_static_operation op (approx_regs before args) in D.set res a before | Iload chunk addr args dst s => - D.set dst Unknown before + let a := eval_static_load gapp chunk + (eval_static_addressing addr (approx_regs before args)) in + D.set dst a before | Icall sig ros args res s => D.set res Unknown before | Ibuiltin ef args res s => @@ -142,12 +217,13 @@ Definition transfer (f: function) (pc: node) (before: D.t) := generic solver for forward dataflow inequations. [analyze f] returns a mapping from program points to mappings of pseudo-registers to approximations. It can fail to reach a fixpoint in a reasonable - number of iterations, in which case [None] is returned. *) + number of iterations, in which case we use the trivial mapping + (program point -> [D.top]) instead. *) Module DS := Dataflow_Solver(D)(NodeSetForward). -Definition analyze (f: RTL.function): PMap.t D.t := - match DS.fixpoint (successors f) (transfer f) +Definition analyze (gapp: global_approx) (f: RTL.function): PMap.t D.t := + match DS.fixpoint (successors f) (transfer gapp f) ((f.(fn_entrypoint), D.top) :: nil) with | None => PMap.init D.top | Some res => res @@ -158,10 +234,12 @@ Definition analyze (f: RTL.function): PMap.t D.t := (** The code transformation proceeds instruction by instruction. Operators whose arguments are all statically known are turned into ``load integer constant'', ``load float constant'' or - ``load symbol address'' operations. Operators for which some + ``load symbol address'' operations. Likewise for loads whose + result can be statically predicted. Operators for which some but not all arguments are known are subject to strength reduction, and similarly for the addressing modes of load and store instructions. - Other instructions are unchanged. *) + Conditional branches and multi-way branches are statically resolved + into [Inop] instructions if possible. Other instructions are unchanged. *) Definition transf_ros (app: D.t) (ros: reg + ident) : reg + ident := match ros with @@ -173,25 +251,38 @@ Definition transf_ros (app: D.t) (ros: reg + ident) : reg + ident := | inr s => ros end. -Definition transf_instr (app: D.t) (instr: instruction) := +Parameter generate_float_constants : unit -> bool. + +Definition const_for_result (a: approx) : option operation := + match a with + | I n => Some(Ointconst n) + | F n => if generate_float_constants tt then Some(Ofloatconst n) else None + | G symb ofs => Some(Oaddrsymbol symb ofs) + | S ofs => Some(Oaddrstack ofs) + | _ => None + end. + +Definition transf_instr (gapp: global_approx) (app: D.t) (instr: instruction) := match instr with | Iop op args res s => - match eval_static_operation op (approx_regs app args) with - | I n => - Iop (Ointconst n) nil res s - | F n => - Iop (Ofloatconst n) nil res s - | G symb ofs => - Iop (Oaddrsymbol symb ofs) nil res s - | S ofs => - Iop (Oaddrstack ofs) nil res s - | _ => + let a := eval_static_operation op (approx_regs app args) in + match const_for_result a with + | Some cop => + Iop cop nil res s + | None => let (op', args') := op_strength_reduction op args (approx_regs app args) in Iop op' args' res s end | Iload chunk addr args dst s => - let (addr', args') := addr_strength_reduction addr args (approx_regs app args) in - Iload chunk addr' args' dst s + let a := eval_static_load gapp chunk + (eval_static_addressing addr (approx_regs app args)) in + match const_for_result a with + | Some cop => + Iop cop nil dst s + | None => + let (addr', args') := addr_strength_reduction addr args (approx_regs app args) in + Iload chunk addr' args' dst s + end | Istore chunk addr args src s => let (addr', args') := addr_strength_reduction addr args (approx_regs app args) in Istore chunk addr' args' src s @@ -223,20 +314,32 @@ Definition transf_instr (app: D.t) (instr: instruction) := instr end. -Definition transf_code (approxs: PMap.t D.t) (instrs: code) : code := - PTree.map (fun pc instr => transf_instr approxs!!pc instr) instrs. +Definition transf_code (gapp: global_approx) (app: PMap.t D.t) (instrs: code) : code := + PTree.map (fun pc instr => transf_instr gapp app!!pc instr) instrs. -Definition transf_function (f: function) : function := - let approxs := analyze f in +Definition transf_function (gapp: global_approx) (f: function) : function := + let approxs := analyze gapp f in mkfunction f.(fn_sig) f.(fn_params) f.(fn_stacksize) - (transf_code approxs f.(fn_code)) + (transf_code gapp approxs f.(fn_code)) f.(fn_entrypoint). -Definition transf_fundef (fd: fundef) : fundef := - AST.transf_fundef transf_function fd. +Definition transf_fundef (gapp: global_approx) (fd: fundef) : fundef := + AST.transf_fundef (transf_function gapp) fd. + +Fixpoint make_global_approx (gapp: global_approx) (vars: list (ident * globvar unit)) : global_approx := + match vars with + | nil => gapp + | (id, gv) :: vars' => + let gapp1 := + if gv.(gvar_readonly) && negb gv.(gvar_volatile) + then PTree.set id gv.(gvar_init) gapp + else PTree.remove id gapp in + make_global_approx gapp1 vars' + end. Definition transf_program (p: program) : program := - transform_program transf_fundef p. + let gapp := make_global_approx (PTree.empty _) p.(prog_vars) in + transform_program (transf_fundef gapp) p. diff --git a/backend/Constpropproof.v b/backend/Constpropproof.v index 9affea8..406e613 100644 --- a/backend/Constpropproof.v +++ b/backend/Constpropproof.v @@ -31,11 +31,18 @@ Require Import ConstpropOp. Require Import Constprop. Require Import ConstpropOpproof. +Section PRESERVATION. + +Variable prog: program. +Let tprog := transf_program prog. +Let ge := Genv.globalenv prog. +Let tge := Genv.globalenv tprog. +Let gapp := make_global_approx (PTree.empty _) prog.(prog_vars). + (** * Correctness of the static analysis *) Section ANALYSIS. -Variable ge: genv. Variable sp: val. Definition regs_match_approx (a: D.t) (rs: regset) : Prop := @@ -97,14 +104,14 @@ Lemma analyze_correct_1: forall f pc rs pc' i, f.(fn_code)!pc = Some i -> In pc' (successors_instr i) -> - regs_match_approx (transfer f pc (analyze f)!!pc) rs -> - regs_match_approx (analyze f)!!pc' rs. + regs_match_approx (transfer gapp f pc (analyze gapp f)!!pc) rs -> + regs_match_approx (analyze gapp f)!!pc' rs. Proof. intros until i. unfold analyze. - caseEq (DS.fixpoint (successors f) (transfer f) + caseEq (DS.fixpoint (successors f) (transfer gapp f) ((fn_entrypoint f, D.top) :: nil)). intros approxs; intros. - apply regs_match_approx_increasing with (transfer f pc approxs!!pc). + apply regs_match_approx_increasing with (transfer gapp f pc approxs!!pc). eapply DS.fixpoint_solution; eauto. unfold successors_list, successors. rewrite PTree.gmap1. rewrite H0. auto. auto. @@ -113,10 +120,10 @@ Qed. Lemma analyze_correct_3: forall f rs, - regs_match_approx (analyze f)!!(f.(fn_entrypoint)) rs. + regs_match_approx (analyze gapp f)!!(f.(fn_entrypoint)) rs. Proof. intros. unfold analyze. - caseEq (DS.fixpoint (successors f) (transfer f) + caseEq (DS.fixpoint (successors f) (transfer gapp f) ((fn_entrypoint f, D.top) :: nil)). intros approxs; intros. apply regs_match_approx_increasing with D.top. @@ -125,6 +132,301 @@ Proof. intros. rewrite PMap.gi. apply regs_match_approx_top. Qed. +(** eval_static_load *) + +Definition mem_match_approx (m: mem) : Prop := + forall id il b, + gapp!id = Some il -> Genv.find_symbol ge id = Some b -> + Genv.load_store_init_data ge m b 0 il /\ + Mem.valid_block m b /\ + (forall ofs, ~Mem.perm m b ofs Max Writable). + +Lemma eval_load_init_sound: + forall chunk m b il base ofs pos v, + Genv.load_store_init_data ge m b base il -> + Mem.load chunk m b ofs = Some v -> + ofs = base + pos -> + val_match_approx ge sp (eval_load_init chunk pos il) v. +Proof. + induction il; simpl; intros. +(* base case il = nil *) + auto. +(* inductive case *) + destruct a. + (* Init_int8 *) + destruct H. destruct (zeq pos 0). subst. rewrite Zplus_0_r in H0. + destruct chunk; simpl; auto. + rewrite Mem.load_int8_signed_unsigned in H0. rewrite H in H0. simpl in H0. + inv H0. decEq. apply Int.sign_ext_zero_ext. compute; auto. + congruence. + eapply IHil; eauto. omega. + (* Init_int16 *) + destruct H. destruct (zeq pos 0). subst. rewrite Zplus_0_r in H0. + destruct chunk; simpl; auto. + rewrite Mem.load_int16_signed_unsigned in H0. rewrite H in H0. simpl in H0. + inv H0. decEq. apply Int.sign_ext_zero_ext. compute; auto. + congruence. + eapply IHil; eauto. omega. + (* Init_int32 *) + destruct H. destruct (zeq pos 0). subst. rewrite Zplus_0_r in H0. + destruct chunk; simpl; auto. + congruence. + eapply IHil; eauto. omega. + (* Init_float32 *) + destruct H. destruct (zeq pos 0). subst. rewrite Zplus_0_r in H0. + destruct chunk; simpl; auto. destruct (propagate_float_constants tt); simpl; auto. + congruence. + eapply IHil; eauto. omega. + (* Init_float64 *) + destruct H. destruct (zeq pos 0). subst. rewrite Zplus_0_r in H0. + destruct chunk; simpl; auto. destruct (propagate_float_constants tt); simpl; auto. + congruence. + eapply IHil; eauto. omega. + (* Init_space *) + eapply IHil; eauto. omega. + (* Init_symbol *) + destruct H as [[b' [A B]] C]. + destruct (zeq pos 0). subst. rewrite Zplus_0_r in H0. + destruct chunk; simpl; auto. + unfold symbol_address. rewrite A. congruence. + eapply IHil; eauto. omega. +Qed. + +Lemma eval_static_load_sound: + forall chunk m addr vaddr v, + Mem.loadv chunk m vaddr = Some v -> + mem_match_approx m -> + val_match_approx ge sp addr vaddr -> + val_match_approx ge sp (eval_static_load gapp chunk addr) v. +Proof. + intros. unfold eval_static_load. destruct addr; simpl; auto. + destruct (gapp!i) as [il|]_eqn; auto. + red in H1. subst vaddr. unfold symbol_address in H. + destruct (Genv.find_symbol ge i) as [b'|]_eqn; simpl in H; try discriminate. + exploit H0; eauto. intros [A [B C]]. + eapply eval_load_init_sound; eauto. + red; auto. +Qed. + +Lemma mem_match_approx_store: + forall chunk m addr v m', + mem_match_approx m -> + Mem.storev chunk m addr v = Some m' -> + mem_match_approx m'. +Proof. + intros; red; intros. exploit H; eauto. intros [A [B C]]. + destruct addr; simpl in H0; try discriminate. + exploit Mem.store_valid_access_3; eauto. intros [P Q]. + split. apply Genv.load_store_init_data_invariant with m; auto. + intros. eapply Mem.load_store_other; eauto. left; red; intro; subst b0. + eapply C. apply Mem.perm_cur_max. eapply P. instantiate (1 := Int.unsigned i). + generalize (size_chunk_pos chunk). omega. + split. eauto with mem. + intros; red; intros. eapply C. eapply Mem.perm_store_2; eauto. +Qed. + +Lemma mem_match_approx_alloc: + forall m lo hi b m', + mem_match_approx m -> + Mem.alloc m lo hi = (m', b) -> + mem_match_approx m'. +Proof. + intros; red; intros. exploit H; eauto. intros [A [B C]]. + split. apply Genv.load_store_init_data_invariant with m; auto. + intros. eapply Mem.load_alloc_unchanged; eauto. + split. eauto with mem. + intros; red; intros. exploit Mem.perm_alloc_inv; eauto. + rewrite zeq_false. apply C. eapply Mem.valid_not_valid_diff; eauto with mem. +Qed. + +Lemma mem_match_approx_free: + forall m lo hi b m', + mem_match_approx m -> + Mem.free m b lo hi = Some m' -> + mem_match_approx m'. +Proof. + intros; red; intros. exploit H; eauto. intros [A [B C]]. + split. apply Genv.load_store_init_data_invariant with m; auto. + intros. eapply Mem.load_free; eauto. + destruct (zeq b0 b); auto. subst b0. + right. destruct (zlt lo hi); auto. + elim (C lo). apply Mem.perm_cur_max. + exploit Mem.free_range_perm; eauto. instantiate (1 := lo); omega. + intros; eapply Mem.perm_implies; eauto with mem. + split. eauto with mem. + intros; red; intros. eapply C. eauto with mem. +Qed. + +Lemma mem_match_approx_extcall: + forall ef vargs m t vres m', + mem_match_approx m -> + external_call ef ge vargs m t vres m' -> + mem_match_approx m'. +Proof. + intros; red; intros. exploit H; eauto. intros [A [B C]]. + split. apply Genv.load_store_init_data_invariant with m; auto. + intros. eapply external_call_readonly; eauto. + split. eapply external_call_valid_block; eauto. + intros; red; intros. elim (C ofs). eapply external_call_max_perm; eauto. +Qed. + +(* Show that mem_match_approx holds initially *) + +Definition global_approx_charact (g: genv) (ga: global_approx) : Prop := + forall id il b, + ga!id = Some il -> + Genv.find_symbol g id = Some b -> + Genv.find_var_info g b = Some (mkglobvar tt il true false). + +Lemma make_global_approx_correct: + forall vl g ga, + global_approx_charact g ga -> + global_approx_charact (Genv.add_variables g vl) (make_global_approx ga vl). +Proof. + induction vl; simpl; intros. + auto. + destruct a as [id gv]. apply IHvl. + red; intros. + assert (EITHER: id0 = id /\ gv = mkglobvar tt il true false + \/ id0 <> id /\ ga!id0 = Some il). + destruct (gvar_readonly gv && negb (gvar_volatile gv)) as []_eqn. + rewrite PTree.gsspec in H0. destruct (peq id0 id). + inv H0. left. split; auto. + destruct gv; simpl in *. + destruct gvar_readonly; try discriminate. + destruct gvar_volatile; try discriminate. + destruct gvar_info. auto. + right; auto. + rewrite PTree.grspec in H0. destruct (PTree.elt_eq id0 id); try discriminate. + right; auto. + unfold Genv.add_variable, Genv.find_symbol, Genv.find_var_info in *; + simpl in *. + destruct EITHER as [[A B] | [A B]]. + subst id0. rewrite PTree.gss in H1. inv H1. rewrite ZMap.gss. auto. + rewrite PTree.gso in H1; auto. rewrite ZMap.gso. eapply H. eauto. auto. + exploit Genv.genv_symb_range; eauto. unfold ZIndexed.t. omega. +Qed. + +Theorem mem_match_approx_init: + forall m, Genv.init_mem prog = Some m -> mem_match_approx m. +Proof. + intros. + assert (global_approx_charact ge gapp). + unfold ge, gapp. unfold Genv.globalenv. + apply make_global_approx_correct. + red; intros. rewrite PTree.gempty in H0; discriminate. + red; intros. + exploit Genv.init_mem_characterization. + unfold ge in H0. eapply H0; eauto. eauto. + unfold Genv.perm_globvar; simpl. + intros [A [B C]]. + split. auto. split. eapply Genv.find_symbol_not_fresh; eauto. + intros; red; intros. exploit B; eauto. intros [P Q]. inv Q. +Qed. + +(********************** +Definition mem_match_approx_gen (g: genv) (ga: global_approx) (m: mem) : Prop := + forall id il b, + ga!id = Some il -> Genv.find_symbol g id = Some b -> + Genv.load_store_init_data ge m b 0 il /\ + Mem.valid_block m b /\ + (forall ofs, ~Mem.perm m b ofs Max Writable). + +Lemma mem_match_approx_alloc_variables: + forall vl g ga m m', + mem_match_approx_gen g ga m -> + Genv.genv_nextvar g = Mem.nextblock m -> + Genv.alloc_variables ge m vl = Some m' -> + mem_match_approx_gen (Genv.add_variables g vl) (make_global_approx ga vl) m'. +Proof. + induction vl; simpl; intros. +(* base case *) + inv H1. auto. +(* inductive case *) + destruct a as [id gv]. + set (ga1 := if gv.(gvar_readonly) && negb gv.(gvar_volatile) + then PTree.set id gv.(gvar_init) ga + else PTree.remove id ga). + revert H1. unfold Genv.alloc_variable. simpl. + set (il := gvar_init gv) in *. + set (sz := Genv.init_data_list_size il) in *. + destruct (Mem.alloc m 0 sz) as [m1 b]_eqn. + destruct (Genv.store_zeros m1 b sz) as [m2|]_eqn; try congruence. + destruct (Genv.store_init_data_list ge m2 b 0 il) as [m3|]_eqn; try congruence. + destruct (Mem.drop_perm m3 b 0 sz (Genv.perm_globvar gv)) as [m4|]_eqn; try congruence. + intros. + exploit Mem.alloc_result; eauto. intro NB. + assert (NB': Mem.nextblock m4 = Mem.nextblock m1). + rewrite (Mem.nextblock_drop _ _ _ _ _ _ Heqo1). + rewrite (Genv.store_init_data_list_nextblock _ _ _ _ _ Heqo0). + rewrite (Genv.store_zeros_nextblock _ _ _ Heqo). + auto. + apply IHvl with m4. + (* mem_match_approx for intermediate state *) + red; intros. + unfold Genv.find_symbol in H3. simpl in H3. + rewrite H0 in H3. rewrite <- NB in H3. + assert (EITHER: id0 <> id /\ ga!id0 = Some il0 + \/ id0 = id /\ il0 = il /\ gvar_readonly gv = true /\ gvar_volatile gv = false). + unfold ga1 in H2. destruct (gvar_readonly gv && negb (gvar_volatile gv)) as []_eqn. + rewrite PTree.gsspec in H2. destruct (peq id0 id). + inv H2. right. split; auto. split; auto. + destruct (gvar_readonly gv); simpl in Heqb1; try discriminate. + destruct (gvar_volatile gv); simpl in Heqb1; try discriminate. + auto. auto. + rewrite PTree.grspec in H2. destruct (PTree.elt_eq id0 id); try discriminate. + auto. + destruct EITHER as [[A B] | [A [B [C D]]]]. + (* older blocks *) + rewrite PTree.gso in H3; auto. exploit H; eauto. intros [P [Q R]]. + assert (b0 <> b). eapply Mem.valid_not_valid_diff; eauto with mem. + split. apply Genv.load_store_init_data_invariant with m; auto. + intros. transitivity (Mem.load chunk m3 b0 ofs). eapply Mem.load_drop; eauto. + transitivity (Mem.load chunk m2 b0 ofs). eapply Genv.store_init_data_list_outside; eauto. + transitivity (Mem.load chunk m1 b0 ofs). eapply Genv.store_zeros_outside; eauto. + eapply Mem.load_alloc_unchanged; eauto. + split. red. rewrite NB'. change (Mem.valid_block m1 b0). eauto with mem. + intros; red; intros. elim (R ofs). + eapply Mem.perm_alloc_4; eauto. + rewrite Genv.store_zeros_perm; [idtac|eauto]. + rewrite Genv.store_init_data_list_perm; [idtac|eauto]. + eapply Mem.perm_drop_4; eauto. + (* same block *) + subst id0 il0. rewrite PTree.gss in H3. injection H3; intro EQ; subst b0. + unfold Genv.perm_globvar in Heqo1. + rewrite D in Heqo1. rewrite C in Heqo1. + split. apply Genv.load_store_init_data_invariant with m3. + intros. eapply Mem.load_drop; eauto. do 3 right. auto with mem. + eapply Genv.store_init_data_list_charact; eauto. + split. red. rewrite NB'. change (Mem.valid_block m1 b). eauto with mem. + intros; red; intros. + assert (0 <= ofs < sz). + eapply Mem.perm_alloc_3; eauto. + rewrite Genv.store_zeros_perm; [idtac|eauto]. + rewrite Genv.store_init_data_list_perm; [idtac|eauto]. + eapply Mem.perm_drop_4; eauto. + assert (PO: perm_order Readable Writable). + eapply Mem.perm_drop_2; eauto. + inv PO. + (* nextvar hyp *) + simpl. rewrite NB'. rewrite (Mem.nextblock_alloc _ _ _ _ _ Heqp). + unfold block in *; omega. + (* alloc vars hyp *) + auto. +Qed. + +Theorem mem_match_approx_init: + forall m, Genv.init_mem prog = Some m -> mem_match_approx m. +Proof. + intros. unfold Genv.init_mem in H. + eapply mem_match_approx_alloc_variables; eauto. +(* mem_match_approx on empty list *) + red; intros. rewrite PTree.gempty in H0. discriminate. +(* nextvar *) + rewrite Genv.add_functions_nextvar. auto. +Qed. +********************************) + End ANALYSIS. (** * Correctness of the code transformation *) @@ -132,13 +434,6 @@ End ANALYSIS. (** We now show that the transformed code after constant propagation has the same semantics as the original code. *) -Section PRESERVATION. - -Variable prog: program. -Let tprog := transf_program prog. -Let ge := Genv.globalenv prog. -Let tge := Genv.globalenv tprog. - Lemma symbols_preserved: forall (s: ident), Genv.find_symbol tge s = Genv.find_symbol ge s. Proof. @@ -156,24 +451,24 @@ Qed. Lemma functions_translated: forall (v: val) (f: fundef), Genv.find_funct ge v = Some f -> - Genv.find_funct tge v = Some (transf_fundef f). + Genv.find_funct tge v = Some (transf_fundef gapp f). Proof. intros. - exact (Genv.find_funct_transf transf_fundef _ _ H). + exact (Genv.find_funct_transf (transf_fundef gapp) _ _ H). Qed. Lemma function_ptr_translated: forall (b: block) (f: fundef), Genv.find_funct_ptr ge b = Some f -> - Genv.find_funct_ptr tge b = Some (transf_fundef f). + Genv.find_funct_ptr tge b = Some (transf_fundef gapp f). Proof. intros. - exact (Genv.find_funct_ptr_transf transf_fundef _ _ H). + exact (Genv.find_funct_ptr_transf (transf_fundef gapp) _ _ H). Qed. Lemma sig_function_translated: forall f, - funsig (transf_fundef f) = funsig f. + funsig (transf_fundef gapp f) = funsig f. Proof. intros. destruct f; reflexivity. Qed. @@ -209,17 +504,17 @@ Qed. Lemma transf_ros_correct: forall sp ros rs rs' f approx, - regs_match_approx ge sp approx rs -> + regs_match_approx sp approx rs -> find_function ge ros rs = Some f -> regs_lessdef rs rs' -> - find_function tge (transf_ros approx ros) rs' = Some (transf_fundef f). + find_function tge (transf_ros approx ros) rs' = Some (transf_fundef gapp f). Proof. intros. destruct ros; simpl in *. generalize (H r); intro MATCH. generalize (H1 r); intro LD. destruct (rs#r); simpl in H0; try discriminate. destruct (Int.eq_dec i Int.zero); try discriminate. inv LD. - assert (find_function tge (inl _ r) rs' = Some (transf_fundef f)). + assert (find_function tge (inl _ r) rs' = Some (transf_fundef gapp f)). simpl. rewrite <- H4. simpl. rewrite dec_eq_true. apply function_ptr_translated. auto. destruct (D.get r approx); auto. predSpec Int.eq Int.eq_spec i0 Int.zero; intros; auto. @@ -230,6 +525,20 @@ Proof. apply function_ptr_translated; auto. Qed. +Lemma const_for_result_correct: + forall a op sp v m, + const_for_result a = Some op -> + val_match_approx ge sp a v -> + eval_operation tge sp op nil m = Some v. +Proof. + unfold const_for_result; intros. + destruct a; inv H; simpl in H0. + simpl. congruence. + destruct (generate_float_constants tt); inv H2. simpl. congruence. + simpl. subst v. unfold symbol_address. rewrite symbols_preserved. auto. + simpl. congruence. +Qed. + (** The proof of semantic preservation is a simulation argument based on diagrams of the following form: << @@ -259,29 +568,32 @@ Inductive match_stackframes: stackframe -> stackframe -> Prop := match_stackframe_intro: forall res sp pc rs f rs', regs_lessdef rs rs' -> - (forall v, regs_match_approx ge sp (analyze f)!!pc (rs#res <- v)) -> + (forall v, regs_match_approx sp (analyze gapp f)!!pc (rs#res <- v)) -> match_stackframes (Stackframe res f sp pc rs) - (Stackframe res (transf_function f) sp pc rs'). + (Stackframe res (transf_function gapp f) sp pc rs'). Inductive match_states: state -> state -> Prop := | match_states_intro: forall s sp pc rs m f s' rs' m' - (MATCH: regs_match_approx ge sp (analyze f)!!pc rs) + (MATCH: regs_match_approx sp (analyze gapp f)!!pc rs) + (GMATCH: mem_match_approx m) (STACKS: list_forall2 match_stackframes s s') (REGS: regs_lessdef rs rs') (MEM: Mem.extends m m'), match_states (State s f sp pc rs m) - (State s' (transf_function f) sp pc rs' m') + (State s' (transf_function gapp f) sp pc rs' m') | match_states_call: forall s f args m s' args' m' + (GMATCH: mem_match_approx m) (STACKS: list_forall2 match_stackframes s s') (ARGS: Val.lessdef_list args args') (MEM: Mem.extends m m'), match_states (Callstate s f args m) - (Callstate s' (transf_fundef f) args' m') + (Callstate s' (transf_fundef gapp f) args' m') | match_states_return: forall s v m s' v' m' + (GMATCH: mem_match_approx m) (STACKS: list_forall2 match_stackframes s s') (RES: Val.lessdef v v') (MEM: Mem.extends m m'), @@ -292,7 +604,7 @@ Inductive match_states: state -> state -> Prop := Ltac TransfInstr := match goal with | H1: (PTree.get ?pc ?c = Some ?instr), f: function |- _ => - cut ((transf_function f).(fn_code)!pc = Some(transf_instr (analyze f)!!pc instr)); + cut ((transf_function gapp f).(fn_code)!pc = Some(transf_instr gapp (analyze gapp f)!!pc instr)); [ simpl transf_instr | unfold transf_function, transf_code; simpl; rewrite PTree.gmap; unfold option_map; rewrite H1; reflexivity ] @@ -310,7 +622,7 @@ Proof. induction 1; intros; inv MS. (* Inop *) - exists (State s' (transf_function f) sp pc' rs' m'); split. + exists (State s' (transf_function gapp f) sp pc' rs' m'); split. TransfInstr; intro. eapply exec_Inop; eauto. econstructor; eauto. eapply analyze_correct_1 with (pc := pc); eauto. @@ -318,70 +630,73 @@ Proof. unfold transfer; rewrite H. auto. (* Iop *) - assert (MATCH': regs_match_approx ge sp (analyze f) # pc' rs # res <- v). + TransfInstr. + set (a := eval_static_operation op (approx_regs (analyze gapp f)#pc args)). + assert (VMATCH: val_match_approx ge sp a v). + eapply eval_static_operation_correct; eauto. + apply approx_regs_val_list; auto. + assert (MATCH': regs_match_approx sp (analyze gapp f) # pc' rs # res <- v). eapply analyze_correct_1 with (pc := pc); eauto. simpl; auto. unfold transfer; rewrite H. apply regs_match_approx_update; auto. - eapply eval_static_operation_correct; eauto. - apply approx_regs_val_list; auto. - TransfInstr. - exploit eval_static_operation_correct; eauto. eapply approx_regs_val_list; eauto. intros VM. - destruct (eval_static_operation op (approx_regs (analyze f) # pc args)); intros; simpl in VM. - (* Novalue *) - contradiction. - (* Unknown *) + destruct (const_for_result a) as [cop|]_eqn; intros. + (* constant is propagated *) + exists (State s' (transf_function gapp f) sp pc' (rs'#res <- v) m'); split. + eapply exec_Iop; eauto. + eapply const_for_result_correct; eauto. + econstructor; eauto. + apply set_reg_lessdef; auto. + (* operator is strength-reduced *) exploit op_strength_reduction_correct. eexact MATCH. reflexivity. eauto. - destruct (op_strength_reduction op args (approx_regs (analyze f) # pc args)) as [op' args']. + destruct (op_strength_reduction op args (approx_regs (analyze gapp f) # pc args)) as [op' args']. intros [v' [EV' LD']]. assert (EV'': exists v'', eval_operation ge sp op' rs'##args' m' = Some v'' /\ Val.lessdef v' v''). - eapply eval_operation_lessdef; eauto. eapply regs_lessdef_regs; eauto. + eapply eval_operation_lessdef; eauto. eapply regs_lessdef_regs; eauto. destruct EV'' as [v'' [EV'' LD'']]. - exists (State s' (transf_function f) sp pc' (rs'#res <- v'') m'); split. + exists (State s' (transf_function gapp f) sp pc' (rs'#res <- v'') m'); split. econstructor. eauto. rewrite <- EV''. apply eval_operation_preserved. exact symbols_preserved. econstructor; eauto. apply set_reg_lessdef; auto. eapply Val.lessdef_trans; eauto. - (* I i *) - subst v. exists (State s' (transf_function f) sp pc' (rs'#res <- (Vint i)) m'); split. - econstructor; eauto. - econstructor; eauto. apply set_reg_lessdef; auto. - (* F *) - subst v. exists (State s' (transf_function f) sp pc' (rs'#res <- (Vfloat f0)) m'); split. - econstructor; eauto. - econstructor; eauto. apply set_reg_lessdef; auto. - (* G *) - subst v. exists (State s' (transf_function f) sp pc' (rs'#res <- (symbol_address tge i i0)) m'); split. - econstructor; eauto. - econstructor; eauto. apply set_reg_lessdef; auto. - unfold symbol_address. rewrite symbols_preserved; auto. - (* S *) - subst v. exists (State s' (transf_function f) sp pc' (rs'#res <- (Val.add sp (Vint i))) m'); split. - econstructor; eauto. - econstructor; eauto. apply set_reg_lessdef; auto. (* Iload *) TransfInstr. - generalize (addr_strength_reduction_correct ge sp (analyze f)!!pc rs - MATCH addr args (approx_regs (analyze f) # pc args) (refl_equal _)). - destruct (addr_strength_reduction addr args (approx_regs (analyze f) # pc args)) as [addr' args']. - intros P Q. rewrite H0 in P. + set (ap1 := eval_static_addressing addr + (approx_regs (analyze gapp f) # pc args)). + set (ap2 := eval_static_load gapp chunk ap1). + assert (VM1: val_match_approx ge sp ap1 a). + eapply eval_static_addressing_correct; eauto. + eapply approx_regs_val_list; eauto. + assert (VM2: val_match_approx ge sp ap2 v). + eapply eval_static_load_sound; eauto. + assert (MATCH': regs_match_approx sp (analyze gapp f) # pc' rs # dst <- v). + eapply analyze_correct_1 with (pc := pc); eauto. simpl; auto. + unfold transfer; rewrite H. + apply regs_match_approx_update; auto. + destruct (const_for_result ap2) as [cop|]_eqn; intros. + (* constant-propagated *) + exists (State s' (transf_function gapp f) sp pc' (rs'#dst <- v) m'); split. + eapply exec_Iop; eauto. eapply const_for_result_correct; eauto. + econstructor; eauto. apply set_reg_lessdef; auto. + (* strength-reduced *) + generalize (addr_strength_reduction_correct ge sp (analyze gapp f)!!pc rs + MATCH addr args (approx_regs (analyze gapp f) # pc args) (refl_equal _)). + destruct (addr_strength_reduction addr args (approx_regs (analyze gapp f) # pc args)) as [addr' args']. + rewrite H0. intros P. assert (ADDR': exists a', eval_addressing ge sp addr' rs'##args' = Some a' /\ Val.lessdef a a'). eapply eval_addressing_lessdef; eauto. eapply regs_lessdef_regs; eauto. destruct ADDR' as [a' [A B]]. assert (C: eval_addressing tge sp addr' rs'##args' = Some a'). rewrite <- A. apply eval_addressing_preserved. exact symbols_preserved. exploit Mem.loadv_extends; eauto. intros [v' [D E]]. - exists (State s' (transf_function f) sp pc' (rs'#dst <- v') m'); split. + exists (State s' (transf_function gapp f) sp pc' (rs'#dst <- v') m'); split. eapply exec_Iload; eauto. econstructor; eauto. - eapply analyze_correct_1; eauto. simpl; auto. - unfold transfer; rewrite H. - apply regs_match_approx_update; auto. simpl; auto. apply set_reg_lessdef; auto. (* Istore *) TransfInstr. - generalize (addr_strength_reduction_correct ge sp (analyze f)!!pc rs - MATCH addr args (approx_regs (analyze f) # pc args) (refl_equal _)). - destruct (addr_strength_reduction addr args (approx_regs (analyze f) # pc args)) as [addr' args']. + generalize (addr_strength_reduction_correct ge sp (analyze gapp f)!!pc rs + MATCH addr args (approx_regs (analyze gapp f) # pc args) (refl_equal _)). + destruct (addr_strength_reduction addr args (approx_regs (analyze gapp f) # pc args)) as [addr' args']. intros P Q. rewrite H0 in P. assert (ADDR': exists a', eval_addressing ge sp addr' rs'##args' = Some a' /\ Val.lessdef a a'). eapply eval_addressing_lessdef; eauto. eapply regs_lessdef_regs; eauto. @@ -389,11 +704,12 @@ Proof. assert (C: eval_addressing tge sp addr' rs'##args' = Some a'). rewrite <- A. apply eval_addressing_preserved. exact symbols_preserved. exploit Mem.storev_extends; eauto. intros [m2' [D E]]. - exists (State s' (transf_function f) sp pc' rs' m2'); split. + exists (State s' (transf_function gapp f) sp pc' rs' m2'); split. eapply exec_Istore; eauto. econstructor; eauto. eapply analyze_correct_1; eauto. simpl; auto. unfold transfer; rewrite H. auto. + eapply mem_match_approx_store; eauto. (* Icall *) exploit transf_ros_correct; eauto. intro FIND'. @@ -413,18 +729,20 @@ Proof. TransfInstr; intro. econstructor; split. eapply exec_Itailcall; eauto. apply sig_function_translated; auto. - constructor; auto. apply regs_lessdef_regs; auto. + constructor; auto. + eapply mem_match_approx_free; eauto. + apply regs_lessdef_regs; auto. (* Ibuiltin *) Opaque builtin_strength_reduction. - destruct (builtin_strength_reduction ef args (approx_regs (analyze f)#pc args)) as [ef' args']_eqn. - generalize (builtin_strength_reduction_correct ge sp (analyze f)!!pc rs - MATCH ef args (approx_regs (analyze f) # pc args) _ _ _ _ (refl_equal _) H0). + destruct (builtin_strength_reduction ef args (approx_regs (analyze gapp f)#pc args)) as [ef' args']_eqn. + generalize (builtin_strength_reduction_correct ge sp (analyze gapp f)!!pc rs + MATCH ef args (approx_regs (analyze gapp f) # pc args) _ _ _ _ (refl_equal _) H0). rewrite Heqp. intros P. exploit external_call_mem_extends; eauto. instantiate (1 := rs'##args'). apply regs_lessdef_regs; auto. intros [v' [m2' [A [B [C D]]]]]. - exists (State s' (transf_function f) sp pc' (rs'#res <- v') m2'); split. + exists (State s' (transf_function gapp f) sp pc' (rs'#res <- v') m2'); split. eapply exec_Ibuiltin. TransfInstr. rewrite Heqp. eauto. eapply external_call_symbols_preserved; eauto. exact symbols_preserved. exact varinfo_preserved. @@ -432,16 +750,17 @@ Opaque builtin_strength_reduction. eapply analyze_correct_1; eauto. simpl; auto. unfold transfer; rewrite H. apply regs_match_approx_update; auto. simpl; auto. + eapply mem_match_approx_extcall; eauto. apply set_reg_lessdef; auto. (* Icond *) TransfInstr. - generalize (cond_strength_reduction_correct ge sp (analyze f)#pc rs m - MATCH cond args (approx_regs (analyze f) # pc args) (refl_equal _)). - destruct (cond_strength_reduction cond args (approx_regs (analyze f) # pc args)) as [cond' args']. + generalize (cond_strength_reduction_correct ge sp (analyze gapp f)#pc rs m + MATCH cond args (approx_regs (analyze gapp f) # pc args) (refl_equal _)). + destruct (cond_strength_reduction cond args (approx_regs (analyze gapp f) # pc args)) as [cond' args']. intros EV1. - exists (State s' (transf_function f) sp (if b then ifso else ifnot) rs' m'); split. - destruct (eval_static_condition cond (approx_regs (analyze f) # pc args)) as []_eqn. + exists (State s' (transf_function gapp f) sp (if b then ifso else ifnot) rs' m'); split. + destruct (eval_static_condition cond (approx_regs (analyze gapp f) # pc args)) as []_eqn. assert (eval_condition cond rs ## args m = Some b0). eapply eval_static_condition_correct; eauto. eapply approx_regs_val_list; eauto. assert (b = b0) by congruence. subst b0. @@ -453,14 +772,14 @@ Opaque builtin_strength_reduction. unfold transfer; rewrite H. auto. (* Ijumptable *) - assert (A: (fn_code (transf_function f))!pc = Some(Ijumptable arg tbl) - \/ (fn_code (transf_function f))!pc = Some(Inop pc')). - TransfInstr. destruct (approx_reg (analyze f) # pc arg) as []_eqn; auto. + assert (A: (fn_code (transf_function gapp f))!pc = Some(Ijumptable arg tbl) + \/ (fn_code (transf_function gapp f))!pc = Some(Inop pc')). + TransfInstr. destruct (approx_reg (analyze gapp f) # pc arg) as []_eqn; auto. generalize (MATCH arg). unfold approx_reg in Heqt. rewrite Heqt. rewrite H0. simpl. intro EQ; inv EQ. rewrite H1. auto. assert (B: rs'#arg = Vint n). generalize (REGS arg); intro LD; inv LD; congruence. - exists (State s' (transf_function f) sp pc' rs' m'); split. + exists (State s' (transf_function gapp f) sp pc' rs' m'); split. destruct A. eapply exec_Ijumptable; eauto. eapply exec_Inop; eauto. econstructor; eauto. eapply analyze_correct_1; eauto. @@ -472,6 +791,7 @@ Opaque builtin_strength_reduction. exists (Returnstate s' (regmap_optget or Vundef rs') m2'); split. eapply exec_Ireturn; eauto. TransfInstr; auto. constructor; auto. + eapply mem_match_approx_free; eauto. destruct or; simpl; auto. (* internal function *) @@ -482,6 +802,7 @@ Opaque builtin_strength_reduction. eapply exec_function_internal; simpl; eauto. simpl. econstructor; eauto. apply analyze_correct_3; auto. + eapply mem_match_approx_alloc; eauto. apply init_regs_lessdef; auto. (* external function *) @@ -492,6 +813,7 @@ Opaque builtin_strength_reduction. eapply external_call_symbols_preserved; eauto. exact symbols_preserved. exact varinfo_preserved. constructor; auto. + eapply mem_match_approx_extcall; eauto. (* return *) inv H3. inv H1. @@ -506,14 +828,16 @@ Lemma transf_initial_states: Proof. intros. inversion H. exploit function_ptr_translated; eauto. intro FIND. - exists (Callstate nil (transf_fundef f) nil m0); split. + exists (Callstate nil (transf_fundef gapp f) nil m0); split. econstructor; eauto. apply Genv.init_mem_transf; auto. replace (prog_main tprog) with (prog_main prog). rewrite symbols_preserved. eauto. reflexivity. rewrite <- H3. apply sig_function_translated. - constructor. constructor. constructor. apply Mem.extends_refl. + constructor. + eapply mem_match_approx_init; eauto. + constructor. constructor. apply Mem.extends_refl. Qed. Lemma transf_final_states: diff --git a/backend/Inlining.v b/backend/Inlining.v new file mode 100644 index 0000000..406447b --- /dev/null +++ b/backend/Inlining.v @@ -0,0 +1,477 @@ +(* *********************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Xavier Leroy, INRIA Paris-Rocquencourt *) +(* *) +(* 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. *) +(* *) +(* *********************************************************************) + +(** RTL function inlining *) + +Require Import Coqlib. +Require Import Wfsimpl. +Require Import Errors. +Require Import Maps. +Require Import AST. +Require Import Integers. +Require Import Values. +Require Import Op. +Require Import Registers. +Require Import RTL. + +Ltac xomega := unfold Plt, Ple in *; zify; omega. + +(** ** Environment of inlinable functions *) + +(** We maintain a mapping from function names to their definitions. + In this mapping, we only include functions that are eligible for + inlining, as determined by the external heuristic + [should_inline]. *) + +Definition funenv : Type := PTree.t function. + +Definition size_fenv (fenv: funenv) := PTree_Properties.cardinal fenv. + +Parameter should_inline: ident -> function -> bool. + +Definition add_fundef (fenv: funenv) (idf: ident * fundef) : funenv := + match idf with + | (id, External ef) => + PTree.remove id fenv + | (id, Internal f) => + if should_inline id f + then PTree.set id f fenv + else PTree.remove id fenv + end. + +Definition remove_vardef (fenv: funenv) (idv: ident * globvar unit) : funenv := + PTree.remove (fst idv) fenv. + +Definition funenv_program (p: program) : funenv := + List.fold_left remove_vardef p.(prog_vars) + (List.fold_left add_fundef p.(prog_funct) (PTree.empty function)). + +(** Resources used by a function. *) + +(** Maximum PC (node number) in the CFG of a function. All nodes of + the CFG of [f] are between 1 and [max_pc_function f] (inclusive). *) + +Definition max_pc_function (f: function) := + PTree.fold (fun m pc i => Pmax m pc) f.(fn_code) 1%positive. + +(** Maximum pseudo-register defined in a function. All results of + an instruction of [f], as well as all parameters of [f], are between + 1 and [max_def_function] (inclusive). *) + +Definition max_def_instr (i: instruction) := + match i with + | Iop op args res s => res + | Iload chunk addr args dst s => dst + | Icall sg ros args res s => res + | Ibuiltin ef args res s => res + | _ => 1%positive + end. + +Definition max_def_function (f: function) := + Pmax + (PTree.fold (fun m pc i => Pmax m (max_def_instr i)) f.(fn_code) 1%positive) + (List.fold_left (fun m r => Pmax m r) f.(fn_params) 1%positive). + +(** State monad *) + +(** To construct incrementally the CFG of a function after inlining, + we use a state monad similar to that used in module [RTLgen]. + It records the current state of the CFG, plus counters to generate + fresh pseudo-registers and fresh CFG nodes. It also records the + stack size needed for the inlined function. *) + +Record state : Type := mkstate { + st_nextreg: positive; (**r last used pseudo-register *) + st_nextnode: positive; (**r last used CFG node *) + st_code: code; (**r current CFG *) + st_stksize: Z (**r current stack size *) +}. + +(** Monotone evolution of the state. *) + +Inductive sincr (s1 s2: state) : Prop := + Sincr (NEXTREG: Ple s1.(st_nextreg) s2.(st_nextreg)) + (NEXTNODE: Ple s1.(st_nextnode) s2.(st_nextnode)) + (STKSIZE: s1.(st_stksize) <= s2.(st_stksize)). + +Remark sincr_refl: forall s, sincr s s. +Proof. + intros; constructor; xomega. +Qed. + +Lemma sincr_trans: forall s1 s2 s3, sincr s1 s2 -> sincr s2 s3 -> sincr s1 s3. +Proof. + intros. inv H; inv H0. constructor; xomega. +Qed. + +(** Dependently-typed state monad, ensuring that the final state is + greater or equal (in the sense of predicate [sincr] above) than + the initial state. *) + +Inductive res {A: Type} {s: state}: Type := R (x: A) (s': state) (I: sincr s s'). + +Definition mon (A: Type) : Type := forall (s: state), @res A s. + +(** Operations on this monad. *) + +Definition ret {A: Type} (x: A): mon A := + fun s => R x s (sincr_refl s). + +Definition bind {A B: Type} (x: mon A) (f: A -> mon B): mon B := + fun s1 => match x s1 with R vx s2 I1 => + match f vx s2 with R vy s3 I2 => + R vy s3 (sincr_trans s1 s2 s3 I1 I2) + end + end. + +Notation "'do' X <- A ; B" := (bind A (fun X => B)) + (at level 200, X ident, A at level 100, B at level 200). + +Definition initstate := + mkstate 1%positive 1%positive (PTree.empty instruction) 0. + +Program Definition set_instr (pc: node) (i: instruction): mon unit := + fun s => + R tt + (mkstate s.(st_nextreg) s.(st_nextnode) (PTree.set pc i s.(st_code)) s.(st_stksize)) + _. +Next Obligation. + intros; constructor; simpl; xomega. +Qed. + +Program Definition add_instr (i: instruction): mon node := + fun s => + let pc := Psucc s.(st_nextnode) in + R pc + (mkstate s.(st_nextreg) pc (PTree.set pc i s.(st_code)) s.(st_stksize)) + _. +Next Obligation. + intros; constructor; simpl; xomega. +Qed. + +Program Definition reserve_nodes (numnodes: positive): mon positive := + fun s => + R s.(st_nextnode) + (mkstate s.(st_nextreg) (Pplus s.(st_nextnode) numnodes) s.(st_code) s.(st_stksize)) + _. +Next Obligation. + intros; constructor; simpl; xomega. +Qed. + +Program Definition reserve_regs (numregs: positive): mon positive := + fun s => + R s.(st_nextreg) + (mkstate (Pplus s.(st_nextreg) numregs) s.(st_nextnode) s.(st_code) s.(st_stksize)) + _. +Next Obligation. + intros; constructor; simpl; xomega. +Qed. + +Program Definition request_stack (sz: Z): mon unit := + fun s => + R tt + (mkstate s.(st_nextreg) s.(st_nextnode) s.(st_code) (Zmax s.(st_stksize) sz)) + _. +Next Obligation. + intros; constructor; simpl; xomega. +Qed. + +Fixpoint mlist_iter2 {A B: Type} (f: A -> B -> mon unit) (l: list (A*B)): mon unit := + match l with + | nil => ret tt + | (x,y) :: l' => do z <- f x y; mlist_iter2 f l' + end. + +(** ** Inlining contexts *) + +(** A context describes how to insert the CFG for a source function into + the CFG for the function after inlining: +- a source instruction at PC [n] is relocated to PC [n + ctx.(dpc)]; +- all pseudo-registers of this instruction are shifted by [ctx.(dreg)]; +- all stack references are shifted by [ctx.(dstk)]; +- "return" instructions are transformed into "return" or "move" instructions + as governed by [ctx.(retinfo)]. +*) + +Record context: Type := mkcontext { + dpc: positive; (**r offset for PCs *) + dreg: positive; (**r offset for pseudo-regs *) + dstk: Z; (**r offset for stack references *) + mreg: positive; (**r max pseudo-reg number *) + mstk: Z; (**r original stack block size *) + retinfo: option(node * reg) (**r where to branch on return *) + (**r and deposit return value *) +}. + +(** The following functions "shift" (relocate) PCs, registers, operations, etc. *) + +Definition spc (ctx: context) (pc: node) := Pplus pc ctx.(dpc). + +Definition sreg (ctx: context) (r: reg) := Pplus r ctx.(dreg). + +Definition sregs (ctx: context) (rl: list reg) := List.map (sreg ctx) rl. + +Definition sros (ctx: context) (ros: reg + ident) := sum_left_map (sreg ctx) ros. + +Definition sop (ctx: context) (op: operation) := + shift_stack_operation (Int.repr ctx.(dstk)) op. + +Definition saddr (ctx: context) (addr: addressing) := + shift_stack_addressing (Int.repr ctx.(dstk)) addr. + +(** The initial context, used to copy the CFG of a toplevel function. *) + +Definition initcontext (dpc dreg nreg: positive) (sz: Z) := + {| dpc := dpc; + dreg := dreg; + dstk := 0; + mreg := nreg; + mstk := Zmax sz 0; + retinfo := None |}. + +(** The context used to inline a call to another function. *) + +Definition min_alignment (sz: Z) := + if zle sz 1 then 1 + else if zle sz 2 then 2 + else if zle sz 4 then 4 else 8. + +Definition callcontext (ctx: context) + (dpc dreg nreg: positive) (sz: Z) + (retpc: node) (retreg: reg) := + {| dpc := dpc; + dreg := dreg; + dstk := align (ctx.(dstk) + ctx.(mstk)) (min_alignment sz); + mreg := nreg; + mstk := Zmax sz 0; + retinfo := Some (spc ctx retpc, sreg ctx retreg) |}. + +(** The context used to inline a tail call to another function. *) + +Definition tailcontext (ctx: context) (dpc dreg nreg: positive) (sz: Z) := + {| dpc := dpc; + dreg := dreg; + dstk := align ctx.(dstk) (min_alignment sz); + mreg := nreg; + mstk := Zmax sz 0; + retinfo := ctx.(retinfo) |}. + +(** ** Recursive expansion and copying of a CFG *) + +(** Insert "move" instructions to copy the arguments of an inlined + function into its parameters. *) + +Fixpoint add_moves (srcs dsts: list reg) (succ: node): mon node := + match srcs, dsts with + | s1 :: sl, d1 :: dl => + do n <- add_instr (Iop Omove (s1 :: nil) d1 succ); + add_moves sl dl n + | _, _ => + ret succ + end. + +(** To prevent infinite inlining of a recursive function, when we + inline the body of a function [f], this function is removed from the + environment of inlinable functions and therefore becomes ineligible + for inlining. This decreases the size (number of entries) of the + environment and guarantees termination. Inlining is, therefore, + presented as a well-founded recursion over the size of the environment. *) + +Section EXPAND_CFG. + +Variable fenv: funenv. + +(** The [rec] parameter is the recursor: [rec fenv' P ctx f] copies + the body of function [f], with inline expansion within, as governed + by context [ctx]. It can only be called for function environments + [fenv'] strictly smaller than the current environment [fenv]. *) + +Variable rec: forall fenv', (size_fenv fenv' < size_fenv fenv)%nat -> context -> function -> mon unit. + +(** Given a register-or-symbol [ros], can we inline the corresponding call? *) + +Inductive inline_decision (ros: reg + ident) : Type := + | Cannot_inline + | Can_inline (id: ident) (f: function) (P: ros = inr reg id) (Q: fenv!id = Some f). + +Program Definition can_inline (ros: reg + ident): inline_decision ros := + match ros with + | inl r => Cannot_inline _ + | inr id => match fenv!id with Some f => Can_inline _ id f _ _ | None => Cannot_inline _ end + end. + +(** Inlining of a call to function [f]. An appropriate context is + created, then the CFG of [f] is recursively copied, then moves + are inserted to copy the arguments of the call to the parameters of [f]. *) + +Definition inline_function (ctx: context) (id: ident) (f: function) + (P: PTree.get id fenv = Some f) + (args: list reg) + (retpc: node) (retreg: reg) : mon node := + let npc := max_pc_function f in + let nreg := max_def_function f in + do dpc <- reserve_nodes npc; + do dreg <- reserve_regs nreg; + let ctx' := callcontext ctx dpc dreg nreg f.(fn_stacksize) retpc retreg in + do x <- rec (PTree.remove id fenv) (PTree_Properties.cardinal_remove P) ctx' f; + add_moves (sregs ctx args) (sregs ctx' f.(fn_params)) (spc ctx' f.(fn_entrypoint)). + +(** Inlining of a tail call to function [f]. Similar to [inline_function], + but the new context is different. *) + +Definition inline_tail_function (ctx: context) (id: ident) (f: function) + (P: PTree.get id fenv = Some f) + (args: list reg): mon node := + let npc := max_pc_function f in + let nreg := max_def_function f in + do dpc <- reserve_nodes npc; + do dreg <- reserve_regs nreg; + let ctx' := tailcontext ctx dpc dreg nreg f.(fn_stacksize) in + do x <- rec (PTree.remove id fenv) (PTree_Properties.cardinal_remove P) ctx' f; + add_moves (sregs ctx args) (sregs ctx' f.(fn_params)) (spc ctx' f.(fn_entrypoint)). + +(** The instruction generated for a [Ireturn] instruction found in an + inlined function body. *) + +Definition inline_return (ctx: context) (or: option reg) (retinfo: node * reg) := + match retinfo, or with + | (retpc, retreg), Some r => Iop Omove (sreg ctx r :: nil) retreg retpc + | (retpc, retreg), None => Inop retpc + end. + +(** Expansion and copying of an instruction. For most instructions, + its registers and successor PC are shifted as per the context [ctx], + then the instruction is inserted in the final CFG at its final position + [spc ctx pc]. + + [Icall] instructions are either replaced by a "goto" to the expansion + of the called function, or shifted as described above. + + [Itailcall] instructions are similar, with one additional case. If + the [Itailcall] occurs in the body of an inlined function, and + cannot be inlined itself, it must be turned into an [Icall] + instruction that branches to the return point of the inlined + function. + + Finally, [Ireturn] instructions within an inlined function are + turned into a "move" or "goto" that stores the result, if any, + into the destination register, then branches back to the successor + of the inlined call. *) + +Definition expand_instr (ctx: context) (pc: node) (i: instruction): mon unit := + match i with + | Inop s => + set_instr (spc ctx pc) (Inop (spc ctx s)) + | Iop op args res s => + set_instr (spc ctx pc) + (Iop (sop ctx op) (sregs ctx args) (sreg ctx res) (spc ctx s)) + | Iload chunk addr args dst s => + set_instr (spc ctx pc) + (Iload chunk (saddr ctx addr) (sregs ctx args) (sreg ctx dst) (spc ctx s)) + | Istore chunk addr args src s => + set_instr (spc ctx pc) + (Istore chunk (saddr ctx addr) (sregs ctx args) (sreg ctx src) (spc ctx s)) + | Icall sg ros args res s => + match can_inline ros with + | Cannot_inline => + set_instr (spc ctx pc) + (Icall sg (sros ctx ros) (sregs ctx args) (sreg ctx res) (spc ctx s)) + | Can_inline id f P Q => + do n <- inline_function ctx id f Q args s res; + set_instr (spc ctx pc) (Inop n) + end + | Itailcall sg ros args => + match can_inline ros with + | Cannot_inline => + match ctx.(retinfo) with + | None => + set_instr (spc ctx pc) + (Itailcall sg (sros ctx ros) (sregs ctx args)) + | Some(rpc, rreg) => + set_instr (spc ctx pc) + (Icall sg (sros ctx ros) (sregs ctx args) rreg rpc) + end + | Can_inline id f P Q => + do n <- inline_tail_function ctx id f Q args; + set_instr (spc ctx pc) (Inop n) + end + | Ibuiltin ef args res s => + set_instr (spc ctx pc) + (Ibuiltin ef (sregs ctx args) (sreg ctx res) (spc ctx s)) + | Icond cond args s1 s2 => + set_instr (spc ctx pc) + (Icond cond (sregs ctx args) (spc ctx s1) (spc ctx s2)) + | Ijumptable r tbl => + set_instr (spc ctx pc) + (Ijumptable (sreg ctx r) (List.map (spc ctx) tbl)) + | Ireturn or => + match ctx.(retinfo) with + | None => + set_instr (spc ctx pc) (Ireturn (option_map (sreg ctx) or)) + | Some rinfo => + set_instr (spc ctx pc) (inline_return ctx or rinfo) + end + end. + +(** The expansion of a function [f] iteratively expands all its + instructions, after recording how much stack it needs. *) + +Definition expand_cfg_rec (ctx: context) (f: function): mon unit := + do x <- request_stack (ctx.(dstk) + ctx.(mstk)); + mlist_iter2 (expand_instr ctx) (PTree.elements f.(fn_code)). + +End EXPAND_CFG. + +(** Here we "tie the knot" of the recursion, taking the fixpoint + of [expand_cfg_rec]. *) + +Definition expand_cfg := Fixm size_fenv expand_cfg_rec. + +(** Start of the recursion: copy and inline function [f] in the + initial context. *) + +Definition expand_function (fenv: funenv) (f: function): mon context := + let npc := max_pc_function f in + let nreg := max_def_function f in + do dpc <- reserve_nodes npc; + do dreg <- reserve_regs nreg; + let ctx := initcontext dpc dreg nreg f.(fn_stacksize) in + do x <- expand_cfg fenv ctx f; + ret ctx. + +(** ** Inlining in functions and whole programs. *) + +Local Open Scope string_scope. + +(** Inlining can increase the size of the function's stack block. We must + make sure that the new size does not exceed [Int.max_unsigned], otherwise + address computations within the stack would overflow and produce incorrect + results. *) + +Definition transf_function (fenv: funenv) (f: function) : Errors.res function := + let '(R ctx s _) := expand_function fenv f initstate in + if zle s.(st_stksize) Int.max_unsigned then + OK (mkfunction f.(fn_sig) + (sregs ctx f.(fn_params)) + s.(st_stksize) + s.(st_code) + (spc ctx f.(fn_entrypoint))) + else + Error(msg "Inlining: stack too big"). + +Definition transf_fundef (fenv: funenv) (fd: fundef) : Errors.res fundef := + AST.transf_partial_fundef (transf_function fenv) fd. + +Definition transf_program (p: program): Errors.res program := + let fenv := funenv_program p in + AST.transform_partial_program (transf_fundef fenv) p. + diff --git a/backend/Inliningaux.ml b/backend/Inliningaux.ml new file mode 100644 index 0000000..4212916 --- /dev/null +++ b/backend/Inliningaux.ml @@ -0,0 +1,18 @@ +(* *********************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Xavier Leroy, INRIA Paris-Rocquencourt *) +(* *) +(* 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 Camlcoq + +(* To be considered: heuristics based on size of function? *) + +let should_inline (id: AST.ident) (f: RTL.coq_function) = + C2C.atom_is_inline id diff --git a/backend/Inliningproof.v b/backend/Inliningproof.v new file mode 100644 index 0000000..c62e173 --- /dev/null +++ b/backend/Inliningproof.v @@ -0,0 +1,1240 @@ +(* *********************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Xavier Leroy, INRIA Paris-Rocquencourt *) +(* *) +(* 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. *) +(* *) +(* *********************************************************************) + +(** RTL function inlining: semantic preservation *) + +Require Import Coqlib. +Require Import Errors. +Require Import Maps. +Require Import AST. +Require Import Integers. +Require Import Values. +Require Import Memory. +Require Import Globalenvs. +Require Import Events. +Require Import Smallstep. +Require Import Op. +Require Import Registers. +Require Import Inlining. +Require Import Inliningspec. +Require Import RTL. + +Section INLINING. + +Variable prog: program. +Variable tprog: program. +Hypothesis TRANSF: transf_program prog = OK tprog. +Let ge := Genv.globalenv prog. +Let tge := Genv.globalenv tprog. +Let fenv := funenv_program prog. + +Lemma symbols_preserved: + forall (s: ident), Genv.find_symbol tge s = Genv.find_symbol ge s. +Proof. + intros. apply Genv.find_symbol_transf_partial with (transf_fundef fenv); auto. +Qed. + +Lemma varinfo_preserved: + forall b, Genv.find_var_info tge b = Genv.find_var_info ge b. +Proof. + intros. apply Genv.find_var_info_transf_partial with (transf_fundef fenv); auto. +Qed. + +Lemma functions_translated: + forall (v: val) (f: fundef), + Genv.find_funct ge v = Some f -> + exists f', Genv.find_funct tge v = Some f' /\ transf_fundef fenv f = OK f'. +Proof (Genv.find_funct_transf_partial (transf_fundef fenv) _ TRANSF). + +Lemma function_ptr_translated: + forall (b: block) (f: fundef), + Genv.find_funct_ptr ge b = Some f -> + exists f', Genv.find_funct_ptr tge b = Some f' /\ transf_fundef fenv f = OK f'. +Proof (Genv.find_funct_ptr_transf_partial (transf_fundef fenv) _ TRANSF). + +Lemma sig_function_translated: + forall f f', transf_fundef fenv f = OK f' -> funsig f' = funsig f. +Proof. + intros. destruct f; Errors.monadInv H. + exploit transf_function_spec; eauto. intros SP; inv SP. auto. + auto. +Qed. + +(** ** Properties of contexts and relocations *) + +Remark sreg_below_diff: + forall ctx r r', Ple r' ctx.(dreg) -> sreg ctx r <> r'. +Proof. + intros. unfold sreg. xomega. +Qed. + +Remark context_below_diff: + forall ctx1 ctx2 r1 r2, + context_below ctx1 ctx2 -> Ple r1 ctx1.(mreg) -> sreg ctx1 r1 <> sreg ctx2 r2. +Proof. + intros. red in H. unfold sreg. xomega. +Qed. + +Remark context_below_le: + forall ctx1 ctx2 r, context_below ctx1 ctx2 -> Ple r ctx1.(mreg) -> Ple (sreg ctx1 r) ctx2.(dreg). +Proof. + intros. red in H. unfold sreg. xomega. +Qed. + +(** ** Agreement between register sets before and after inlining. *) + +Definition agree_regs (F: meminj) (ctx: context) (rs rs': regset) := + (forall r, Ple r ctx.(mreg) -> val_inject F rs#r rs'#(sreg ctx r)) +/\(forall r, Plt ctx.(mreg) r -> rs#r = Vundef). + +Definition val_reg_charact (F: meminj) (ctx: context) (rs': regset) (v: val) (r: reg) := + (Plt ctx.(mreg) r /\ v = Vundef) \/ (Ple r ctx.(mreg) /\ val_inject F v rs'#(sreg ctx r)). + +Remark Plt_Ple_dec: + forall p q, {Plt p q} + {Ple q p}. +Proof. + intros. destruct (plt p q). left; auto. right; xomega. +Qed. + +Lemma agree_val_reg_gen: + forall F ctx rs rs' r, agree_regs F ctx rs rs' -> val_reg_charact F ctx rs' rs#r r. +Proof. + intros. destruct H as [A B]. + destruct (Plt_Ple_dec (mreg ctx) r). + left. rewrite B; auto. + right. auto. +Qed. + +Lemma agree_val_regs_gen: + forall F ctx rs rs' rl, + agree_regs F ctx rs rs' -> list_forall2 (val_reg_charact F ctx rs') rs##rl rl. +Proof. + induction rl; intros; constructor; auto. apply agree_val_reg_gen; auto. +Qed. + +Lemma agree_val_reg: + forall F ctx rs rs' r, agree_regs F ctx rs rs' -> val_inject F rs#r rs'#(sreg ctx r). +Proof. + intros. exploit agree_val_reg_gen; eauto. instantiate (1 := r). intros [[A B] | [A B]]. + rewrite B; auto. + auto. +Qed. + +Lemma agree_val_regs: + forall F ctx rs rs' rl, agree_regs F ctx rs rs' -> val_list_inject F rs##rl rs'##(sregs ctx rl). +Proof. + induction rl; intros; simpl. constructor. constructor; auto. apply agree_val_reg; auto. +Qed. + +Lemma agree_set_reg: + forall F ctx rs rs' r v v', + agree_regs F ctx rs rs' -> + val_inject F v v' -> + Ple r ctx.(mreg) -> + agree_regs F ctx (rs#r <- v) (rs'#(sreg ctx r) <- v'). +Proof. + unfold agree_regs; intros. destruct H. split; intros. + repeat rewrite Regmap.gsspec. + destruct (peq r0 r). subst r0. rewrite peq_true. auto. + rewrite peq_false. auto. unfold sreg; xomega. + rewrite Regmap.gso. auto. xomega. +Qed. + +Lemma agree_set_reg_undef: + forall F ctx rs rs' r v', + agree_regs F ctx rs rs' -> + agree_regs F ctx (rs#r <- Vundef) (rs'#(sreg ctx r) <- v'). +Proof. + unfold agree_regs; intros. destruct H. split; intros. + repeat rewrite Regmap.gsspec. + destruct (peq r0 r). subst r0. rewrite peq_true. auto. + rewrite peq_false. auto. unfold sreg; xomega. + rewrite Regmap.gsspec. destruct (peq r0 r); auto. +Qed. + +Lemma agree_set_reg_undef': + forall F ctx rs rs' r, + agree_regs F ctx rs rs' -> + agree_regs F ctx (rs#r <- Vundef) rs'. +Proof. + unfold agree_regs; intros. destruct H. split; intros. + rewrite Regmap.gsspec. + destruct (peq r0 r). subst r0. auto. auto. + rewrite Regmap.gsspec. destruct (peq r0 r); auto. +Qed. + +Lemma agree_regs_invariant: + forall F ctx rs rs1 rs2, + agree_regs F ctx rs rs1 -> + (forall r, Plt ctx.(dreg) r -> Ple r (ctx.(dreg) + ctx.(mreg)) -> rs2#r = rs1#r) -> + agree_regs F ctx rs rs2. +Proof. + unfold agree_regs; intros. destruct H. split; intros. + rewrite H0. auto. unfold sreg; xomega. unfold sreg; xomega. + apply H1; auto. +Qed. + +Lemma agree_regs_incr: + forall F ctx rs1 rs2 F', + agree_regs F ctx rs1 rs2 -> + inject_incr F F' -> + agree_regs F' ctx rs1 rs2. +Proof. + intros. destruct H. split; intros. eauto. auto. +Qed. + +Remark agree_regs_init: + forall F ctx rs, agree_regs F ctx (Regmap.init Vundef) rs. +Proof. + intros; split; intros. rewrite Regmap.gi; auto. rewrite Regmap.gi; auto. +Qed. + +Lemma agree_regs_init_regs: + forall F ctx rl vl vl', + val_list_inject F vl vl' -> + (forall r, In r rl -> Ple r ctx.(mreg)) -> + agree_regs F ctx (init_regs vl rl) (init_regs vl' (sregs ctx rl)). +Proof. + induction rl; simpl; intros. + apply agree_regs_init. + inv H. apply agree_regs_init. + apply agree_set_reg; auto. +Qed. + +(** ** Executing sequences of moves *) + +Lemma tr_moves_init_regs: + forall F stk f sp m ctx1 ctx2, context_below ctx1 ctx2 -> + forall rdsts rsrcs vl pc1 pc2 rs1, + tr_moves f.(fn_code) pc1 (sregs ctx1 rsrcs) (sregs ctx2 rdsts) pc2 -> + (forall r, In r rdsts -> Ple r ctx2.(mreg)) -> + list_forall2 (val_reg_charact F ctx1 rs1) vl rsrcs -> + exists rs2, + star step tge (State stk f sp pc1 rs1 m) + E0 (State stk f sp pc2 rs2 m) + /\ agree_regs F ctx2 (init_regs vl rdsts) rs2 + /\ forall r, Ple r ctx2.(dreg) -> rs2#r = rs1#r. +Proof. + induction rdsts; simpl; intros. +(* rdsts = nil *) + inv H0. exists rs1; split. apply star_refl. split. apply agree_regs_init. auto. +(* rdsts = a :: rdsts *) + inv H2. inv H0. + exists rs1; split. apply star_refl. split. apply agree_regs_init. auto. + simpl in H0. inv H0. + exploit IHrdsts; eauto. intros [rs2 [A [B C]]]. + exists (rs2#(sreg ctx2 a) <- (rs2#(sreg ctx1 b1))). + split. eapply star_right. eauto. eapply exec_Iop; eauto. traceEq. + split. destruct H3 as [[P Q] | [P Q]]. + subst a1. eapply agree_set_reg_undef; eauto. + eapply agree_set_reg; eauto. rewrite C; auto. apply context_below_le; auto. + intros. rewrite Regmap.gso. auto. apply sym_not_equal. eapply sreg_below_diff; eauto. + destruct H2; discriminate. +Qed. + +(** ** Memory invariants *) + +(** A stack location is private if it is not the image of a valid + location and we have full rights on it. *) + +Definition loc_private (F: meminj) (m m': mem) (sp: block) (ofs: Z) : Prop := + Mem.perm m' sp ofs Cur Freeable /\ + (forall b delta, F b = Some(sp, delta) -> ~Mem.perm m b (ofs - delta) Max Nonempty). + +(** Likewise, for a range of locations. *) + +Definition range_private (F: meminj) (m m': mem) (sp: block) (lo hi: Z) : Prop := + forall ofs, lo <= ofs < hi -> loc_private F m m' sp ofs. + +Lemma range_private_invariant: + forall F m m' sp lo hi F1 m1 m1', + range_private F m m' sp lo hi -> + (forall b delta ofs, + F1 b = Some(sp, delta) -> + Mem.perm m1 b ofs Max Nonempty -> + lo <= ofs + delta < hi -> + F b = Some(sp, delta) /\ Mem.perm m b ofs Max Nonempty) -> + (forall ofs, Mem.perm m' sp ofs Cur Freeable -> Mem.perm m1' sp ofs Cur Freeable) -> + range_private F1 m1 m1' sp lo hi. +Proof. + intros; red; intros. exploit H; eauto. intros [A B]. split; auto. + intros; red; intros. exploit H0; eauto. omega. intros [P Q]. + eelim B; eauto. +Qed. + +Lemma range_private_perms: + forall F m m' sp lo hi, + range_private F m m' sp lo hi -> + Mem.range_perm m' sp lo hi Cur Freeable. +Proof. + intros; red; intros. eapply H; eauto. +Qed. + +Lemma range_private_alloc_left: + forall F m m' sp' base hi sz m1 sp F1, + range_private F m m' sp' base hi -> + Mem.alloc m 0 sz = (m1, sp) -> + F1 sp = Some(sp', base) -> + (forall b, b <> sp -> F1 b = F b) -> + range_private F1 m1 m' sp' (base + Zmax sz 0) hi. +Proof. + intros; red; intros. + exploit (H ofs). generalize (Zmax2 sz 0). omega. intros [A B]. + split; auto. intros; red; intros. + exploit Mem.perm_alloc_inv; eauto. + destruct (zeq b sp); intros. + subst b. rewrite H1 in H4; inv H4. + rewrite Zmax_spec in H3. destruct (zlt 0 sz); omega. + rewrite H2 in H4; auto. eelim B; eauto. +Qed. + +Lemma range_private_free_left: + forall F m m' sp base sz hi b m1, + range_private F m m' sp (base + Zmax sz 0) hi -> + Mem.free m b 0 sz = Some m1 -> + F b = Some(sp, base) -> + Mem.inject F m m' -> + range_private F m1 m' sp base hi. +Proof. + intros; red; intros. + destruct (zlt ofs (base + Zmax sz 0)). + red; split. + replace ofs with ((ofs - base) + base) by omega. + eapply Mem.perm_inject; eauto. + eapply Mem.free_range_perm; eauto. + rewrite Zmax_spec in z. destruct (zlt 0 sz); omega. + intros; red; intros. destruct (eq_block b b0). + subst b0. rewrite H1 in H4; inv H4. + eelim Mem.perm_free_2; eauto. rewrite Zmax_spec in z. destruct (zlt 0 sz); omega. + exploit Mem.mi_no_overlap; eauto. + apply Mem.perm_cur_max. apply Mem.perm_implies with Freeable; auto with mem. + eapply Mem.free_range_perm. eauto. + instantiate (1 := ofs - base). rewrite Zmax_spec in z. destruct (zlt 0 sz); omega. + eapply Mem.perm_free_3; eauto. + intros [A | A]. congruence. omega. + + exploit (H ofs). omega. intros [A B]. split. auto. + intros; red; intros. eelim B; eauto. eapply Mem.perm_free_3; eauto. +Qed. + +Lemma range_private_extcall: + forall F F' m1 m2 m1' m2' sp base hi, + range_private F m1 m1' sp base hi -> + (forall b ofs p, + Mem.valid_block m1 b -> Mem.perm m2 b ofs Max p -> Mem.perm m1 b ofs Max p) -> + mem_unchanged_on (loc_out_of_reach F m1) m1' m2' -> + Mem.inject F m1 m1' -> + inject_incr F F' -> + inject_separated F F' m1 m1' -> + Mem.valid_block m1' sp -> + range_private F' m2 m2' sp base hi. +Proof. + intros until hi; intros RP PERM UNCH INJ INCR SEP VB. + red; intros. exploit RP; eauto. intros [A B]. + destruct UNCH as [U1 U2]. + split. auto. + intros. red in SEP. destruct (F b) as [[sp1 delta1] |]_eqn. + exploit INCR; eauto. intros EQ; rewrite H0 in EQ; inv EQ. + red; intros; eelim B; eauto. eapply PERM; eauto. + red. destruct (zlt b (Mem.nextblock m1)); auto. + exploit Mem.mi_freeblocks; eauto. congruence. + exploit SEP; eauto. tauto. +Qed. + +(** ** Relating global environments *) + +Inductive match_globalenvs (F: meminj) (bound: Z): Prop := + | mk_match_globalenvs + (POS: bound > 0) + (DOMAIN: forall b, b < bound -> F b = Some(b, 0)) + (IMAGE: forall b1 b2 delta, F b1 = Some(b2, delta) -> b2 < bound -> b1 = b2) + (SYMBOLS: forall id b, Genv.find_symbol ge id = Some b -> b < bound) + (INFOS: forall b gv, Genv.find_var_info ge b = Some gv -> b < bound). + +Lemma find_function_agree: + forall ros rs fd F ctx rs' bound, + find_function ge ros rs = Some fd -> + agree_regs F ctx rs rs' -> + match_globalenvs F bound -> + exists fd', + find_function tge (sros ctx ros) rs' = Some fd' /\ transf_fundef fenv fd = OK fd'. +Proof. + intros. destruct ros as [r | id]; simpl in *. + (* register *) + assert (rs'#(sreg ctx r) = rs#r). + exploit Genv.find_funct_inv; eauto. intros [b EQ]. + assert (A: val_inject F rs#r rs'#(sreg ctx r)). eapply agree_val_reg; eauto. + rewrite EQ in A; inv A. + inv H1. rewrite DOMAIN in H5. inv H5. auto. + rewrite EQ in H; rewrite Genv.find_funct_find_funct_ptr in H. + exploit Genv.find_funct_ptr_negative. unfold ge in H; eexact H. omega. + rewrite H2. eapply functions_translated; eauto. + (* symbol *) + rewrite symbols_preserved. destruct (Genv.find_symbol ge id); try discriminate. + eapply function_ptr_translated; eauto. +Qed. + +(** ** Relating stacks *) + +Inductive match_stacks (F: meminj) (m m': mem): + list stackframe -> list stackframe -> block -> Prop := + | match_stacks_nil: forall bound1 bound + (MG: match_globalenvs F bound1) + (BELOW: bound1 <= bound), + match_stacks F m m' nil nil bound + | match_stacks_cons: forall res f sp pc rs stk f' sp' rs' stk' bound ctx + (MS: match_stacks_inside F m m' stk stk' f' ctx sp' rs') + (FB: tr_funbody fenv f'.(fn_stacksize) ctx f f'.(fn_code)) + (AG: agree_regs F ctx rs rs') + (SP: F sp = Some(sp', ctx.(dstk))) + (PRIV: range_private F m m' sp' (ctx.(dstk) + ctx.(mstk)) f'.(fn_stacksize)) + (SSZ1: 0 <= f'.(fn_stacksize) <= Int.max_unsigned) + (SSZ2: forall ofs, Mem.perm m' sp' ofs Max Nonempty -> 0 <= ofs <= f'.(fn_stacksize)) + (RES: Ple res ctx.(mreg)) + (BELOW: sp' < bound), + match_stacks F m m' + (Stackframe res f (Vptr sp Int.zero) pc rs :: stk) + (Stackframe (sreg ctx res) f' (Vptr sp' Int.zero) (spc ctx pc) rs' :: stk') + bound + | match_stacks_untailcall: forall stk res f' sp' rpc rs' stk' bound ctx + (MS: match_stacks_inside F m m' stk stk' f' ctx sp' rs') + (PRIV: range_private F m m' sp' ctx.(dstk) f'.(fn_stacksize)) + (SSZ1: 0 <= f'.(fn_stacksize) <= Int.max_unsigned) + (SSZ2: forall ofs, Mem.perm m' sp' ofs Max Nonempty -> 0 <= ofs <= f'.(fn_stacksize)) + (RET: ctx.(retinfo) = Some (rpc, res)) + (BELOW: sp' < bound), + match_stacks F m m' + stk + (Stackframe res f' (Vptr sp' Int.zero) rpc rs' :: stk') + bound + +with match_stacks_inside (F: meminj) (m m': mem): + list stackframe -> list stackframe -> function -> context -> block -> regset -> Prop := + | match_stacks_inside_base: forall stk stk' f' ctx sp' rs' + (MS: match_stacks F m m' stk stk' sp') + (RET: ctx.(retinfo) = None) + (DSTK: ctx.(dstk) = 0), + match_stacks_inside F m m' stk stk' f' ctx sp' rs' + | match_stacks_inside_inlined: forall res f sp pc rs stk stk' f' ctx sp' rs' ctx' + (MS: match_stacks_inside F m m' stk stk' f' ctx' sp' rs') + (FB: tr_funbody fenv f'.(fn_stacksize) ctx' f f'.(fn_code)) + (AG: agree_regs F ctx' rs rs') + (SP: F sp = Some(sp', ctx'.(dstk))) + (PAD: range_private F m m' sp' (ctx'.(dstk) + ctx'.(mstk)) ctx.(dstk)) + (RES: Ple res ctx'.(mreg)) + (RET: ctx.(retinfo) = Some (spc ctx' pc, sreg ctx' res)) + (BELOW: context_below ctx' ctx) + (SBELOW: context_stack_call ctx' ctx), + match_stacks_inside F m m' (Stackframe res f (Vptr sp Int.zero) pc rs :: stk) + stk' f' ctx sp' rs'. + +(** Properties of match_stacks *) + +Section MATCH_STACKS. + +Variable F: meminj. +Variables m m': mem. + +Lemma match_stacks_globalenvs: + forall stk stk' bound, + match_stacks F m m' stk stk' bound -> exists b, match_globalenvs F b +with match_stacks_inside_globalenvs: + forall stk stk' f ctx sp rs', + match_stacks_inside F m m' stk stk' f ctx sp rs' -> exists b, match_globalenvs F b. +Proof. + induction 1; eauto. + induction 1; eauto. +Qed. + +Lemma match_globalenvs_preserves_globals: + forall b, match_globalenvs F b -> meminj_preserves_globals ge F. +Proof. + intros. inv H. red. split. eauto. split. eauto. + intros. symmetry. eapply IMAGE; eauto. +Qed. + +Lemma match_stacks_inside_globals: + forall stk stk' f ctx sp rs', + match_stacks_inside F m m' stk stk' f ctx sp rs' -> meminj_preserves_globals ge F. +Proof. + intros. exploit match_stacks_inside_globalenvs; eauto. intros [b A]. + eapply match_globalenvs_preserves_globals; eauto. +Qed. + +Lemma match_stacks_bound: + forall stk stk' bound bound1, + match_stacks F m m' stk stk' bound -> + bound <= bound1 -> + match_stacks F m m' stk stk' bound1. +Proof. + intros. inv H. + apply match_stacks_nil with bound0. auto. omega. + eapply match_stacks_cons; eauto. omega. + eapply match_stacks_untailcall; eauto. omega. +Qed. + +Variable F1: meminj. +Variables m1 m1': mem. +Hypothesis INCR: inject_incr F F1. + +Lemma match_stacks_invariant: + forall stk stk' bound, match_stacks F m m' stk stk' bound -> + forall (INJ: forall b1 b2 delta, + F1 b1 = Some(b2, delta) -> b2 < bound -> F b1 = Some(b2, delta)) + (PERM1: forall b1 b2 delta ofs, + F1 b1 = Some(b2, delta) -> b2 < bound -> + Mem.perm m1 b1 ofs Max Nonempty -> Mem.perm m b1 ofs Max Nonempty) + (PERM2: forall b ofs, b < bound -> + Mem.perm m' b ofs Cur Freeable -> Mem.perm m1' b ofs Cur Freeable) + (PERM3: forall b ofs k p, b < bound -> + Mem.perm m1' b ofs k p -> Mem.perm m' b ofs k p), + match_stacks F1 m1 m1' stk stk' bound + +with match_stacks_inside_invariant: + forall stk stk' f' ctx sp' rs1, + match_stacks_inside F m m' stk stk' f' ctx sp' rs1 -> + forall rs2 + (RS: forall r, Ple r ctx.(dreg) -> rs2#r = rs1#r) + (INJ: forall b1 b2 delta, + F1 b1 = Some(b2, delta) -> b2 <= sp' -> F b1 = Some(b2, delta)) + (PERM1: forall b1 b2 delta ofs, + F1 b1 = Some(b2, delta) -> b2 <= sp' -> + Mem.perm m1 b1 ofs Max Nonempty -> Mem.perm m b1 ofs Max Nonempty) + (PERM2: forall b ofs, b <= sp' -> + Mem.perm m' b ofs Cur Freeable -> Mem.perm m1' b ofs Cur Freeable) + (PERM3: forall b ofs k p, b <= sp' -> + Mem.perm m1' b ofs k p -> Mem.perm m' b ofs k p), + match_stacks_inside F1 m1 m1' stk stk' f' ctx sp' rs2. + +Proof. + induction 1; intros. + (* nil *) + apply match_stacks_nil with (bound1 := bound1). + inv MG. constructor; auto. + intros. apply IMAGE with delta. eapply INJ; eauto. omega. auto. + omega. + (* cons *) + apply match_stacks_cons with (ctx := ctx); auto. + eapply match_stacks_inside_invariant; eauto. + intros; eapply INJ; eauto; omega. + intros; eapply PERM1; eauto; omega. + intros; eapply PERM2; eauto; omega. + intros; eapply PERM3; eauto; omega. + eapply agree_regs_incr; eauto. + eapply range_private_invariant; eauto. + (* untailcall *) + apply match_stacks_untailcall with (ctx := ctx); auto. + eapply match_stacks_inside_invariant; eauto. + intros; eapply INJ; eauto; omega. + intros; eapply PERM1; eauto; omega. + intros; eapply PERM2; eauto; omega. + intros; eapply PERM3; eauto; omega. + eapply range_private_invariant; eauto. + + induction 1; intros. + (* base *) + eapply match_stacks_inside_base; eauto. + eapply match_stacks_invariant; eauto. + intros; eapply INJ; eauto; omega. + intros; eapply PERM1; eauto; omega. + intros; eapply PERM2; eauto; omega. + intros; eapply PERM3; eauto; omega. + (* inlined *) + apply match_stacks_inside_inlined with (ctx' := ctx'); auto. + apply IHmatch_stacks_inside; auto. + intros. apply RS. red in BELOW. xomega. + apply agree_regs_incr with F; auto. + apply agree_regs_invariant with rs'; auto. + intros. apply RS. red in BELOW. xomega. + eapply range_private_invariant; eauto. + intros. split. eapply INJ; eauto. omega. eapply PERM1; eauto. omega. + intros. eapply PERM2; eauto. omega. +Qed. + +Lemma match_stacks_empty: + forall stk stk' bound, + match_stacks F m m' stk stk' bound -> stk = nil -> stk' = nil +with match_stacks_inside_empty: + forall stk stk' f ctx sp rs, + match_stacks_inside F m m' stk stk' f ctx sp rs -> stk = nil -> stk' = nil /\ ctx.(retinfo) = None. +Proof. + induction 1; intros. + auto. + discriminate. + exploit match_stacks_inside_empty; eauto. intros [A B]. congruence. + induction 1; intros. + split. eapply match_stacks_empty; eauto. auto. + discriminate. +Qed. + +End MATCH_STACKS. + +(** Preservation by assignment to a register *) + +Lemma match_stacks_inside_set_reg: + forall F m m' stk stk' f' ctx sp' rs' r v, + match_stacks_inside F m m' stk stk' f' ctx sp' rs' -> + match_stacks_inside F m m' stk stk' f' ctx sp' (rs'#(sreg ctx r) <- v). +Proof. + intros. eapply match_stacks_inside_invariant; eauto. + intros. apply Regmap.gso. unfold sreg. xomega. +Qed. + +(** Preservation by a memory store *) + +Lemma match_stacks_inside_store: + forall F m m' stk stk' f' ctx sp' rs' chunk b ofs v m1 chunk' b' ofs' v' m1', + match_stacks_inside F m m' stk stk' f' ctx sp' rs' -> + Mem.store chunk m b ofs v = Some m1 -> + Mem.store chunk' m' b' ofs' v' = Some m1' -> + match_stacks_inside F m1 m1' stk stk' f' ctx sp' rs'. +Proof. + intros. + eapply match_stacks_inside_invariant; eauto with mem. +Qed. + +(** Preservation by an allocation *) + +Lemma match_stacks_inside_alloc_left: + forall F m m' stk stk' f' ctx sp' rs', + match_stacks_inside F m m' stk stk' f' ctx sp' rs' -> + forall sz m1 b F1 delta, + Mem.alloc m 0 sz = (m1, b) -> + inject_incr F F1 -> + F1 b = Some(sp', delta) -> + (forall b1, b1 <> b -> F1 b1 = F b1) -> + delta >= ctx.(dstk) -> + match_stacks_inside F1 m1 m' stk stk' f' ctx sp' rs'. +Proof. + induction 1; intros. + (* base *) + eapply match_stacks_inside_base; eauto. + eapply match_stacks_invariant; eauto. + intros. destruct (eq_block b1 b). + subst b1. rewrite H1 in H4; inv H4. omegaContradiction. + rewrite H2 in H4; auto. + intros. exploit Mem.perm_alloc_inv; eauto. destruct (zeq b1 b); intros; auto. + subst b1. rewrite H1 in H4. inv H4. omegaContradiction. + (* inlined *) + eapply match_stacks_inside_inlined; eauto. + eapply IHmatch_stacks_inside; eauto. destruct SBELOW. omega. + eapply agree_regs_incr; eauto. + eapply range_private_invariant; eauto. + intros. exploit Mem.perm_alloc_inv; eauto. destruct (zeq b0 b); intros. + subst b0. rewrite H2 in H5; inv H5. omegaContradiction. + rewrite H3 in H5; auto. +Qed. + +(** Preservation by freeing *) + +Lemma match_stacks_free_left: + forall F m m' stk stk' sp b lo hi m1, + match_stacks F m m' stk stk' sp -> + Mem.free m b lo hi = Some m1 -> + match_stacks F m1 m' stk stk' sp. +Proof. + intros. eapply match_stacks_invariant; eauto. + intros. eapply Mem.perm_free_3; eauto. +Qed. + +Lemma match_stacks_free_right: + forall F m m' stk stk' sp lo hi m1', + match_stacks F m m' stk stk' sp -> + Mem.free m' sp lo hi = Some m1' -> + match_stacks F m m1' stk stk' sp. +Proof. + intros. eapply match_stacks_invariant; eauto. + intros. eapply Mem.perm_free_1; eauto. left. unfold block; omega. + intros. eapply Mem.perm_free_3; eauto. +Qed. + +Lemma min_alignment_sound: + forall sz n, (min_alignment sz | n) -> Mem.inj_offset_aligned n sz. +Proof. + intros; red; intros. unfold min_alignment in H. + 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. + 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. + destruct chunk; simpl in *; auto. + apply Zone_divide. + apply Zone_divide. + apply H2; omega. +Qed. + +(** Preservation by external calls *) + +Section EXTCALL. + +Variables F1 F2: meminj. +Variables m1 m2 m1' m2': mem. +Hypothesis MAXPERM: forall b ofs p, Mem.valid_block m1 b -> Mem.perm m2 b ofs Max p -> Mem.perm m1 b ofs Max p. +Hypothesis MAXPERM': forall b ofs p, Mem.valid_block m1' b -> Mem.perm m2' b ofs Max p -> Mem.perm m1' b ofs Max p. +Hypothesis UNCHANGED: mem_unchanged_on (loc_out_of_reach F1 m1) m1' m2'. +Hypothesis INJ: Mem.inject F1 m1 m1'. +Hypothesis INCR: inject_incr F1 F2. +Hypothesis SEP: inject_separated F1 F2 m1 m1'. + +Lemma match_stacks_extcall: + forall stk stk' bound, + match_stacks F1 m1 m1' stk stk' bound -> + bound <= Mem.nextblock m1' -> + match_stacks F2 m2 m2' stk stk' bound +with match_stacks_inside_extcall: + forall stk stk' f' ctx sp' rs', + match_stacks_inside F1 m1 m1' stk stk' f' ctx sp' rs' -> + sp' < Mem.nextblock m1' -> + match_stacks_inside F2 m2 m2' stk stk' f' ctx sp' rs'. +Proof. + induction 1; intros. + apply match_stacks_nil with bound1; auto. + inv MG. constructor; intros; eauto. + destruct (F1 b1) as [[b2' delta']|]_eqn. + exploit INCR; eauto. intros EQ; rewrite H0 in EQ; inv EQ. eapply IMAGE; eauto. + exploit SEP; eauto. intros [A B]. elim B. red. omega. + eapply match_stacks_cons; eauto. + eapply match_stacks_inside_extcall; eauto. omega. + eapply agree_regs_incr; eauto. + eapply range_private_extcall; eauto. red; omega. + intros. apply SSZ2; auto. apply MAXPERM'; auto. red; omega. + eapply match_stacks_untailcall; eauto. + eapply match_stacks_inside_extcall; eauto. omega. + eapply range_private_extcall; eauto. red; omega. + intros. apply SSZ2; auto. apply MAXPERM'; auto. red; omega. + induction 1; intros. + eapply match_stacks_inside_base; eauto. + eapply match_stacks_extcall; eauto. omega. + eapply match_stacks_inside_inlined; eauto. + eapply agree_regs_incr; eauto. + eapply range_private_extcall; eauto. +Qed. + +End EXTCALL. + +(** Change of context corresponding to an inlined tailcall *) + +Lemma align_unchanged: + forall n amount, amount > 0 -> (amount | n) -> align n amount = n. +Proof. + intros. destruct H0 as [p EQ]. subst n. unfold align. decEq. + apply Zdiv_unique with (b := amount - 1). omega. omega. +Qed. + +Lemma match_stacks_inside_inlined_tailcall: + forall F m m' stk stk' f' ctx sp' rs' ctx' f, + match_stacks_inside F m m' stk stk' f' ctx sp' rs' -> + context_below ctx ctx' -> + context_stack_tailcall ctx f ctx' -> + ctx'.(retinfo) = ctx.(retinfo) -> + range_private F m m' sp' ctx.(dstk) f'.(fn_stacksize) -> + tr_funbody fenv f'.(fn_stacksize) ctx' f f'.(fn_code) -> + match_stacks_inside F m m' stk stk' f' ctx' sp' rs'. +Proof. + intros. inv H. + (* base *) + eapply match_stacks_inside_base; eauto. congruence. + rewrite H1. rewrite DSTK. apply align_unchanged. apply min_alignment_pos. apply Zdivide_0. + (* inlined *) + assert (dstk ctx <= dstk ctx'). rewrite H1. apply align_le. apply min_alignment_pos. + eapply match_stacks_inside_inlined; eauto. + red; intros. destruct (zlt ofs (dstk ctx)). apply PAD; omega. apply H3. inv H4. xomega. + congruence. + unfold context_below in *. xomega. + unfold context_stack_call in *. omega. +Qed. + +(** ** Relating states *) + +Inductive match_states: state -> state -> Prop := + | match_regular_states: forall stk f sp pc rs m stk' f' sp' rs' m' F ctx + (MS: match_stacks_inside F m m' stk stk' f' ctx sp' rs') + (FB: tr_funbody fenv f'.(fn_stacksize) ctx f f'.(fn_code)) + (AG: agree_regs F ctx rs rs') + (SP: F sp = Some(sp', ctx.(dstk))) + (MINJ: Mem.inject F m m') + (VB: Mem.valid_block m' sp') + (PRIV: range_private F m m' sp' (ctx.(dstk) + ctx.(mstk)) f'.(fn_stacksize)) + (SSZ1: 0 <= f'.(fn_stacksize) <= Int.max_unsigned) + (SSZ2: forall ofs, Mem.perm m' sp' ofs Max Nonempty -> 0 <= ofs <= f'.(fn_stacksize)), + match_states (State stk f (Vptr sp Int.zero) pc rs m) + (State stk' f' (Vptr sp' Int.zero) (spc ctx pc) rs' m') + | match_call_states: forall stk fd args m stk' fd' args' m' F + (MS: match_stacks F m m' stk stk' (Mem.nextblock m')) + (FD: transf_fundef fenv fd = OK fd') + (VINJ: val_list_inject F args args') + (MINJ: Mem.inject F m m'), + match_states (Callstate stk fd args m) + (Callstate stk' fd' args' m') + | match_call_regular_states: forall stk f vargs m stk' f' sp' rs' m' F ctx ctx' pc' pc1' rargs + (MS: match_stacks_inside F m m' stk stk' f' ctx sp' rs') + (FB: tr_funbody fenv f'.(fn_stacksize) ctx f f'.(fn_code)) + (BELOW: context_below ctx' ctx) + (NOP: f'.(fn_code)!pc' = Some(Inop pc1')) + (MOVES: tr_moves f'.(fn_code) pc1' (sregs ctx' rargs) (sregs ctx f.(fn_params)) (spc ctx f.(fn_entrypoint))) + (VINJ: list_forall2 (val_reg_charact F ctx' rs') vargs rargs) + (MINJ: Mem.inject F m m') + (VB: Mem.valid_block m' sp') + (PRIV: range_private F m m' sp' ctx.(dstk) f'.(fn_stacksize)) + (SSZ1: 0 <= f'.(fn_stacksize) <= Int.max_unsigned) + (SSZ2: forall ofs, Mem.perm m' sp' ofs Max Nonempty -> 0 <= ofs <= f'.(fn_stacksize)), + match_states (Callstate stk (Internal f) vargs m) + (State stk' f' (Vptr sp' Int.zero) pc' rs' m') + | match_return_states: forall stk v m stk' v' m' F + (MS: match_stacks F m m' stk stk' (Mem.nextblock m')) + (VINJ: val_inject F v v') + (MINJ: Mem.inject F m m'), + match_states (Returnstate stk v m) + (Returnstate stk' v' m') + | match_return_regular_states: forall stk v m stk' f' sp' rs' m' F ctx pc' or rinfo + (MS: match_stacks_inside F m m' stk stk' f' ctx sp' rs') + (RET: ctx.(retinfo) = Some rinfo) + (AT: f'.(fn_code)!pc' = Some(inline_return ctx or rinfo)) + (VINJ: match or with None => v = Vundef | Some r => val_inject F v rs'#(sreg ctx r) end) + (MINJ: Mem.inject F m m') + (VB: Mem.valid_block m' sp') + (PRIV: range_private F m m' sp' ctx.(dstk) f'.(fn_stacksize)) + (SSZ1: 0 <= f'.(fn_stacksize) <= Int.max_unsigned) + (SSZ2: forall ofs, Mem.perm m' sp' ofs Max Nonempty -> 0 <= ofs <= f'.(fn_stacksize)), + match_states (Returnstate stk v m) + (State stk' f' (Vptr sp' Int.zero) pc' rs' m'). + +(** ** Forward simulation *) + +Definition measure (S: state) : nat := + match S with + | State _ _ _ _ _ _ => 1%nat + | Callstate _ _ _ _ => 0%nat + | Returnstate _ _ _ => 0%nat + end. + +Lemma tr_funbody_inv: + forall sz cts f c pc i, + tr_funbody fenv sz cts f c -> f.(fn_code)!pc = Some i -> tr_instr fenv sz cts pc i c. +Proof. + intros. inv H. eauto. +Qed. + +Theorem step_simulation: + forall S1 t S2, + step ge S1 t S2 -> + forall S1' (MS: match_states S1 S1'), + (exists S2', plus step tge S1' t S2' /\ match_states S2 S2') + \/ (measure S2 < measure S1 /\ t = E0 /\ match_states S2 S1')%nat. +Proof. + induction 1; intros; inv MS. + +(* nop *) + exploit tr_funbody_inv; eauto. intros TR; inv TR. + left; econstructor; split. + eapply plus_one. eapply exec_Inop; eauto. + econstructor; eauto. + +(* op *) + exploit tr_funbody_inv; eauto. intros TR; inv TR. + exploit eval_operation_inject. + eapply match_stacks_inside_globals; eauto. + eexact SP. + instantiate (2 := rs##args). instantiate (1 := rs'##(sregs ctx args)). eapply agree_val_regs; eauto. + eexact MINJ. eauto. + fold (sop ctx op). intros [v' [A B]]. + left; econstructor; split. + eapply plus_one. eapply exec_Iop; eauto. erewrite eval_operation_preserved; eauto. + exact symbols_preserved. + econstructor; eauto. + apply match_stacks_inside_set_reg; auto. + apply agree_set_reg; auto. + +(* load *) + exploit tr_funbody_inv; eauto. intros TR; inv TR. + exploit eval_addressing_inject. + eapply match_stacks_inside_globals; eauto. + eexact SP. + instantiate (2 := rs##args). instantiate (1 := rs'##(sregs ctx args)). eapply agree_val_regs; eauto. + eauto. + fold (saddr ctx addr). intros [a' [P Q]]. + exploit Mem.loadv_inject; eauto. intros [v' [U V]]. + left; econstructor; split. + eapply plus_one. eapply exec_Iload; eauto. erewrite eval_addressing_preserved; eauto. + exact symbols_preserved. + econstructor; eauto. + apply match_stacks_inside_set_reg; auto. + apply agree_set_reg; auto. + +(* store *) + exploit tr_funbody_inv; eauto. intros TR; inv TR. + exploit eval_addressing_inject. + eapply match_stacks_inside_globals; eauto. + eexact SP. + instantiate (2 := rs##args). instantiate (1 := rs'##(sregs ctx args)). eapply agree_val_regs; eauto. + eauto. + fold saddr. intros [a' [P Q]]. + exploit Mem.storev_mapped_inject; eauto. eapply agree_val_reg; eauto. + intros [m1' [U V]]. + left; econstructor; split. + eapply plus_one. eapply exec_Istore; eauto. erewrite eval_addressing_preserved; eauto. + exact symbols_preserved. + destruct a; simpl in H1; try discriminate. + destruct a'; simpl in U; try discriminate. + econstructor; eauto. + eapply match_stacks_inside_store; eauto. + eapply Mem.store_valid_block_1; eauto. + eapply range_private_invariant; eauto. + intros; split; auto. eapply Mem.perm_store_2; eauto. + intros; eapply Mem.perm_store_1; eauto. + intros. eapply SSZ2. eapply Mem.perm_store_2; eauto. + +(* call *) + exploit match_stacks_inside_globalenvs; eauto. intros [bound G]. + exploit find_function_agree; eauto. intros [fd' [A B]]. + exploit tr_funbody_inv; eauto. intros TR; inv TR. +(* not inlined *) + left; econstructor; split. + eapply plus_one. eapply exec_Icall; eauto. + eapply sig_function_translated; eauto. + econstructor; eauto. + eapply match_stacks_cons; eauto. + eapply agree_val_regs; eauto. +(* inlined *) + assert (fd = Internal f0). + simpl in H0. destruct (Genv.find_symbol ge id) as [b|]_eqn; try discriminate. + exploit (funenv_program_compat prog); eauto. intros. + unfold ge in H0. congruence. + subst fd. + right; split. simpl; omega. split. auto. + econstructor; eauto. + eapply match_stacks_inside_inlined; eauto. + red; intros. apply PRIV. inv H13. destruct H16. xomega. + apply agree_val_regs_gen; auto. + red; intros; apply PRIV. destruct H16. omega. + +(* tailcall *) + exploit match_stacks_inside_globalenvs; eauto. intros [bound G]. + exploit find_function_agree; eauto. intros [fd' [A B]]. + assert (PRIV': range_private F m' m'0 sp' (dstk ctx) f'.(fn_stacksize)). + eapply range_private_free_left; eauto. inv FB. rewrite <- H4. auto. + exploit tr_funbody_inv; eauto. intros TR; inv TR. +(* within the original function *) + inv MS0; try congruence. + assert (X: { m1' | Mem.free m'0 sp' 0 (fn_stacksize f') = Some m1'}). + apply Mem.range_perm_free. red; intros. + destruct (zlt ofs f.(fn_stacksize)). + replace ofs with (ofs + dstk ctx) by omega. eapply Mem.perm_inject; eauto. + eapply Mem.free_range_perm; eauto. omega. + inv FB. eapply range_private_perms; eauto. xomega. + destruct X as [m1' FREE]. + left; econstructor; split. + eapply plus_one. eapply exec_Itailcall; eauto. + eapply sig_function_translated; eauto. + econstructor; eauto. + eapply match_stacks_bound with (bound := sp'). + eapply match_stacks_invariant; eauto. + intros. eapply Mem.perm_free_3; eauto. + intros. eapply Mem.perm_free_1; eauto. left; unfold block; omega. + intros. eapply Mem.perm_free_3; eauto. + erewrite Mem.nextblock_free; eauto. red in VB; omega. + eapply agree_val_regs; eauto. + eapply Mem.free_right_inject; eauto. eapply Mem.free_left_inject; eauto. + (* show that no valid location points into the stack block being freed *) + intros. rewrite DSTK in PRIV'. exploit (PRIV' (ofs + delta)). omega. intros [P Q]. + eelim Q; eauto. replace (ofs + delta - delta) with ofs by omega. + apply Mem.perm_max with k. apply Mem.perm_implies with p; auto with mem. +(* turned into a call *) + left; econstructor; split. + eapply plus_one. eapply exec_Icall; eauto. + eapply sig_function_translated; eauto. + econstructor; eauto. + eapply match_stacks_untailcall; eauto. + eapply match_stacks_inside_invariant; eauto. + intros. eapply Mem.perm_free_3; eauto. + eapply agree_val_regs; eauto. + eapply Mem.free_left_inject; eauto. +(* inlined *) + assert (fd = Internal f0). + simpl in H0. destruct (Genv.find_symbol ge id) as [b|]_eqn; try discriminate. + exploit (funenv_program_compat prog); eauto. intros. + unfold ge in H0. congruence. + subst fd. + right; split. simpl; omega. split. auto. + econstructor; eauto. + eapply match_stacks_inside_inlined_tailcall; eauto. + eapply match_stacks_inside_invariant; eauto. + intros. eapply Mem.perm_free_3; eauto. + apply agree_val_regs_gen; auto. + eapply Mem.free_left_inject; eauto. + red; intros; apply PRIV'. + assert (dstk ctx <= dstk ctx'). red in H14; rewrite H14. apply align_le. apply min_alignment_pos. + omega. + +(* builtin *) + exploit tr_funbody_inv; eauto. intros TR; inv TR. + exploit external_call_mem_inject; eauto. + eapply match_stacks_inside_globals; eauto. + instantiate (1 := rs'##(sregs ctx args)). eapply agree_val_regs; eauto. + intros [F1 [v1 [m1' [A [B [C [D [E [J K]]]]]]]]]. + left; econstructor; split. + eapply plus_one. eapply exec_Ibuiltin; eauto. + eapply external_call_symbols_preserved; eauto. + exact symbols_preserved. exact varinfo_preserved. + econstructor. + eapply match_stacks_inside_set_reg. + eapply match_stacks_inside_extcall with (F1 := F) (F2 := F1) (m1 := m) (m1' := m'0); eauto. + intros; eapply external_call_max_perm; eauto. + intros; eapply external_call_max_perm; eauto. + auto. + eapply agree_set_reg. eapply agree_regs_incr; eauto. auto. auto. + apply J; auto. + auto. + eapply external_call_valid_block; eauto. + eapply range_private_extcall; eauto. + intros; eapply external_call_max_perm; eauto. + auto. + intros. apply SSZ2. eapply external_call_max_perm; eauto. + +(* cond *) + exploit tr_funbody_inv; eauto. intros TR; inv TR. + assert (eval_condition cond rs'##(sregs ctx args) m' = Some b). + eapply eval_condition_inject; eauto. eapply agree_val_regs; eauto. + left; econstructor; split. + eapply plus_one. eapply exec_Icond; eauto. + destruct b; econstructor; eauto. + +(* jumptable *) + exploit tr_funbody_inv; eauto. intros TR; inv TR. + assert (val_inject F rs#arg rs'#(sreg ctx arg)). eapply agree_val_reg; eauto. + rewrite H0 in H2; inv H2. + left; econstructor; split. + eapply plus_one. eapply exec_Ijumptable; eauto. + rewrite list_nth_z_map. rewrite H1. simpl; reflexivity. + econstructor; eauto. + +(* return *) + exploit tr_funbody_inv; eauto. intros TR; inv TR. + (* not inlined *) + inv MS0; try congruence. + assert (X: { m1' | Mem.free m'0 sp' 0 (fn_stacksize f') = Some m1'}). + apply Mem.range_perm_free. red; intros. + destruct (zlt ofs f.(fn_stacksize)). + replace ofs with (ofs + dstk ctx) by omega. eapply Mem.perm_inject; eauto. + eapply Mem.free_range_perm; eauto. omega. + inv FB. eapply range_private_perms; eauto. + generalize (Zmax_spec (fn_stacksize f) 0). destruct (zlt 0 (fn_stacksize f)); omega. + destruct X as [m1' FREE]. + left; econstructor; split. + eapply plus_one. eapply exec_Ireturn; eauto. + econstructor; eauto. + eapply match_stacks_bound with (bound := sp'). + eapply match_stacks_invariant; eauto. + intros. eapply Mem.perm_free_3; eauto. + intros. eapply Mem.perm_free_1; eauto. left; unfold block; omega. + intros. eapply Mem.perm_free_3; eauto. + erewrite Mem.nextblock_free; eauto. red in VB; omega. + destruct or; simpl. apply agree_val_reg; auto. auto. + eapply Mem.free_right_inject; eauto. eapply Mem.free_left_inject; eauto. + (* show that no valid location points into the stack block being freed *) + intros. inversion FB; subst. + assert (PRIV': range_private F m' m'0 sp' (dstk ctx) f'.(fn_stacksize)). + rewrite H8 in PRIV. eapply range_private_free_left; eauto. + rewrite DSTK in PRIV'. exploit (PRIV' (ofs + delta)). omega. intros [A B]. + eelim B; eauto. replace (ofs + delta - delta) with ofs by omega. + apply Mem.perm_max with k. apply Mem.perm_implies with p; auto with mem. + + (* inlined *) + right. split. simpl. omega. split. auto. + econstructor; eauto. + eapply match_stacks_inside_invariant; eauto. + intros. eapply Mem.perm_free_3; eauto. + destruct or; simpl. apply agree_val_reg; auto. auto. + eapply Mem.free_left_inject; eauto. + inv FB. rewrite H4 in PRIV. eapply range_private_free_left; eauto. + +(* internal function, not inlined *) + assert (A: exists f', tr_function fenv f f' /\ fd' = Internal f'). + Errors.monadInv FD. exists x. split; auto. eapply transf_function_spec; eauto. + destruct A as [f' [TR EQ]]. inversion TR; subst. + exploit Mem.alloc_parallel_inject. eauto. eauto. apply Zle_refl. + instantiate (1 := fn_stacksize f'). inv H0. xomega. + intros [F' [m1' [sp' [A [B [C [D E]]]]]]]. + left; econstructor; split. + eapply plus_one. eapply exec_function_internal; eauto. + rewrite H5. econstructor. + instantiate (1 := F'). apply match_stacks_inside_base. + assert (SP: sp' = Mem.nextblock m'0) by (eapply Mem.alloc_result; eauto). + rewrite <- SP in MS0. + eapply match_stacks_invariant; eauto. + intros. destruct (eq_block b1 stk). + subst b1. rewrite D in H7; inv H7. unfold block in *; omegaContradiction. + rewrite E in H7; auto. + intros. exploit Mem.perm_alloc_inv. eexact H. eauto. + destruct (zeq b1 stk); intros; auto. + subst b1. rewrite D in H7; inv H7. unfold block in *; omegaContradiction. + intros. eapply Mem.perm_alloc_1; eauto. + intros. exploit Mem.perm_alloc_inv. eexact A. eauto. + rewrite zeq_false; auto. unfold block; omega. + auto. auto. auto. + rewrite H4. apply agree_regs_init_regs. eauto. auto. inv H0; auto. congruence. auto. + eapply Mem.valid_new_block; eauto. + red; intros. split. + eapply Mem.perm_alloc_2; eauto. inv H0; xomega. + intros; red; intros. exploit Mem.perm_alloc_inv. eexact H. eauto. + destruct (zeq b stk); intros. + subst. rewrite D in H8; inv H8. inv H0; xomega. + rewrite E in H8; auto. eelim Mem.fresh_block_alloc. eexact A. eapply Mem.mi_mappedblocks; eauto. + auto. + intros. exploit Mem.perm_alloc_inv; eauto. rewrite zeq_true. omega. + +(* internal function, inlined *) + inversion FB; subst. + exploit Mem.alloc_left_mapped_inject. + eauto. + eauto. + (* sp' is valid *) + instantiate (1 := sp'). auto. + (* offset is representable *) + instantiate (1 := dstk ctx). generalize (Zmax2 (fn_stacksize f) 0). omega. + (* size of target block is representable *) + intros. right. exploit SSZ2; eauto with mem. inv FB; omega. + (* we have full permissions on sp' at and above dstk ctx *) + intros. apply Mem.perm_cur. apply Mem.perm_implies with Freeable; auto with mem. + eapply range_private_perms; eauto. xomega. + (* offset is aligned *) + replace (fn_stacksize f - 0) with (fn_stacksize f) by omega. + inv FB. apply min_alignment_sound; auto. + (* nobody maps to (sp, dstk ctx...) *) + intros. exploit (PRIV (ofs + delta')); eauto. xomega. + intros [A B]. eelim B; eauto. + replace (ofs + delta' - delta') with ofs by omega. + apply Mem.perm_max with k. apply Mem.perm_implies with p; auto with mem. + intros [F' [A [B [C D]]]]. + exploit tr_moves_init_regs; eauto. intros [rs'' [P [Q R]]]. + left; econstructor; split. + eapply plus_left. eapply exec_Inop; eauto. eexact P. traceEq. + econstructor. + eapply match_stacks_inside_alloc_left; eauto. + eapply match_stacks_inside_invariant; eauto. + omega. + auto. + apply agree_regs_incr with F; auto. + auto. auto. auto. + rewrite H2. eapply range_private_alloc_left; eauto. + auto. auto. + +(* external function *) + exploit match_stacks_globalenvs; eauto. intros [bound MG]. + exploit external_call_mem_inject; eauto. + eapply match_globalenvs_preserves_globals; eauto. + intros [F1 [v1 [m1' [A [B [C [D [E [J K]]]]]]]]]. + simpl in FD. inv FD. + left; econstructor; split. + eapply plus_one. eapply exec_function_external; eauto. + eapply external_call_symbols_preserved; eauto. + exact symbols_preserved. exact varinfo_preserved. + econstructor. + eapply match_stacks_bound with (Mem.nextblock m'0). + eapply match_stacks_extcall with (F1 := F) (F2 := F1) (m1 := m) (m1' := m'0); eauto. + intros; eapply external_call_max_perm; eauto. + intros; eapply external_call_max_perm; eauto. + omega. + eapply external_call_nextblock; eauto. + auto. auto. + +(* return fron noninlined function *) + inv MS0. + (* normal case *) + left; econstructor; split. + eapply plus_one. eapply exec_return. + econstructor; eauto. + apply match_stacks_inside_set_reg; auto. + apply agree_set_reg; auto. + (* untailcall case *) + inv MS; try congruence. + rewrite RET in RET0; inv RET0. +(* + assert (rpc = pc). unfold spc in H0; unfold node in *; xomega. + assert (res0 = res). unfold sreg in H1; unfold reg in *; xomega. + subst rpc res0. +*) + left; econstructor; split. + eapply plus_one. eapply exec_return. + eapply match_regular_states. + eapply match_stacks_inside_set_reg; eauto. + auto. + apply agree_set_reg; auto. + auto. auto. auto. + red; intros. destruct (zlt ofs (dstk ctx)). apply PAD; omega. apply PRIV; omega. + auto. auto. + +(* return from inlined function *) + inv MS0; try congruence. rewrite RET0 in RET; inv RET. + unfold inline_return in AT. + assert (PRIV': range_private F m m' sp' (dstk ctx' + mstk ctx') f'.(fn_stacksize)). + red; intros. destruct (zlt ofs (dstk ctx)). apply PAD. omega. apply PRIV. omega. + destruct or. + (* with a result *) + left; econstructor; split. + eapply plus_one. eapply exec_Iop; eauto. simpl. reflexivity. + econstructor; eauto. apply match_stacks_inside_set_reg; auto. apply agree_set_reg; auto. + (* without a result *) + left; econstructor; split. + eapply plus_one. eapply exec_Inop; eauto. + econstructor; eauto. subst vres. apply agree_set_reg_undef'; auto. +Qed. + +Lemma transf_initial_states: + forall st1, initial_state prog st1 -> exists st2, initial_state tprog st2 /\ match_states st1 st2. +Proof. + intros. inv H. + exploit function_ptr_translated; eauto. intros [tf [FIND TR]]. + exists (Callstate nil tf nil m0); split. + econstructor; eauto. + unfold transf_program in TRANSF. eapply Genv.init_mem_transf_partial; eauto. + rewrite symbols_preserved. + rewrite (transform_partial_program_main _ _ TRANSF). auto. + rewrite <- H3. apply sig_function_translated; auto. + econstructor; eauto. + instantiate (1 := Mem.flat_inj (Mem.nextblock m0)). + apply match_stacks_nil with (Mem.nextblock m0). + constructor; intros. + apply Mem.nextblock_pos. + unfold Mem.flat_inj. apply zlt_true; auto. + unfold Mem.flat_inj in H. destruct (zlt b1 (Mem.nextblock m0)); congruence. + eapply Genv.find_symbol_not_fresh; eauto. + eapply Genv.find_var_info_not_fresh; eauto. + omega. + eapply Genv.initmem_inject; eauto. +Qed. + +Lemma transf_final_states: + forall st1 st2 r, + match_states st1 st2 -> final_state st1 r -> final_state st2 r. +Proof. + intros. inv H0. inv H. + exploit match_stacks_empty; eauto. intros EQ; subst. inv VINJ. constructor. + exploit match_stacks_inside_empty; eauto. intros [A B]. congruence. +Qed. + +Theorem transf_program_correct: + forward_simulation (semantics prog) (semantics tprog). +Proof. + eapply forward_simulation_star. + eexact symbols_preserved. + eexact transf_initial_states. + eexact transf_final_states. + eexact step_simulation. +Qed. + +End INLINING. diff --git a/backend/Inliningspec.v b/backend/Inliningspec.v new file mode 100644 index 0000000..ec72290 --- /dev/null +++ b/backend/Inliningspec.v @@ -0,0 +1,712 @@ +(* *********************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Xavier Leroy, INRIA Paris-Rocquencourt *) +(* *) +(* 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. *) +(* *) +(* *********************************************************************) + +(** RTL function inlining: relational specification *) + +Require Import Coqlib. +Require Import Wfsimpl. +Require Import Errors. +Require Import Maps. +Require Import AST. +Require Import Integers. +Require Import Values. +Require Import Globalenvs. +Require Import Op. +Require Import Registers. +Require Import RTL. +Require Import Inlining. + +(** ** Soundness of function environments. *) + +(** A (compile-time) function environment is compatible with a + (run-time) global environment if the following condition holds. *) + +Definition fenv_compat (ge: genv) (fenv: funenv) : Prop := + forall id b f, + fenv!id = Some f -> Genv.find_symbol ge id = Some b -> + Genv.find_funct_ptr ge b = Some (Internal f). + +Remark add_fundef_compat: + forall ge fenv idf, + fenv_compat ge fenv -> + fenv_compat (Genv.add_function ge idf) (Inlining.add_fundef fenv idf). +Proof. + intros. destruct idf as [id fd]. red; simpl; intros. + unfold Genv.find_symbol in H1; simpl in H1. + unfold Genv.find_funct_ptr; simpl. + rewrite PTree.gsspec in H1. destruct (peq id0 id). + (* same *) + subst id0. inv H1. rewrite ZMap.gss. + destruct fd. destruct (should_inline id f0). + rewrite PTree.gss in H0. inv H0; auto. + rewrite PTree.grs in H0; discriminate. + rewrite PTree.grs in H0; discriminate. + (* different *) + rewrite ZMap.gso. eapply H; eauto. + destruct fd. destruct (should_inline id f0). + rewrite PTree.gso in H0; auto. + rewrite PTree.gro in H0; auto. + rewrite PTree.gro in H0; auto. + exploit Genv.genv_symb_range; eauto. intros [A B]. unfold ZIndexed.t; omega. +Qed. + +Remark remove_vardef_compat: + forall ge fenv idv, + fenv_compat ge fenv -> + fenv_compat (Genv.add_variable ge idv) (Inlining.remove_vardef fenv idv). +Proof. + intros. destruct idv as [id vi]. red; simpl; intros. + unfold Genv.find_symbol in H1; simpl in H1. + unfold Genv.find_funct_ptr; simpl. + unfold remove_vardef in H0; simpl in H0. + rewrite PTree.gsspec in H1. rewrite PTree.grspec in H0. + unfold PTree.elt_eq in H0. destruct (peq id0 id). + discriminate. + eapply H; eauto. +Qed. + +Lemma funenv_program_compat: + forall p, fenv_compat (Genv.globalenv p) (funenv_program p). +Proof. + intros. + unfold Genv.globalenv, funenv_program. + assert (forall funs ge fenv, + fenv_compat ge fenv -> + fenv_compat (Genv.add_functions ge funs) (fold_left add_fundef funs fenv)). + unfold Genv.add_functions. induction funs; simpl; intros. + auto. apply IHfuns. apply add_fundef_compat; auto. + assert (forall vars ge fenv, + fenv_compat ge fenv -> + fenv_compat (Genv.add_variables ge vars) (fold_left remove_vardef vars fenv)). + unfold Genv.add_variables. induction vars; simpl; intros. + auto. apply IHvars. apply remove_vardef_compat; auto. + apply H0. apply H. red; intros. rewrite PTree.gempty in H1; discriminate. +Qed. + +(** ** Soundness of the computed bounds over function resources *) + +Remark Pmax_l: forall x y, Ple x (Pmax x y). +Proof. intros; xomega. Qed. + +Remark Pmax_r: forall x y, Ple y (Pmax x y). +Proof. intros; xomega. Qed. + +Lemma max_pc_function_sound: + forall f pc i, f.(fn_code)!pc = Some i -> Ple pc (max_pc_function f). +Proof. + intros until i. unfold max_pc_function. + apply PTree_Properties.fold_rec with (P := fun c m => c!pc = Some i -> Ple pc m). + (* extensionality *) + intros. apply H0. rewrite H; auto. + (* base case *) + rewrite PTree.gempty. congruence. + (* inductive case *) + intros. rewrite PTree.gsspec in H2. destruct (peq pc k). + inv H2. apply Pmax_r. + apply Ple_trans with a. auto. apply Pmax_l. +Qed. + +Lemma max_def_function_instr: + forall f pc i, f.(fn_code)!pc = Some i -> Ple (max_def_instr i) (max_def_function f). +Proof. + intros. unfold max_def_function. eapply Ple_trans. 2: eapply Pmax_l. + revert H. + apply PTree_Properties.fold_rec with (P := fun c m => c!pc = Some i -> Ple (max_def_instr i) m). + (* extensionality *) + intros. apply H0. rewrite H; auto. + (* base case *) + rewrite PTree.gempty. congruence. + (* inductive case *) + intros. rewrite PTree.gsspec in H2. destruct (peq pc k). + inv H2. apply Pmax_r. + apply Ple_trans with a. auto. apply Pmax_l. +Qed. + +Lemma max_def_function_params: + forall f r, In r f.(fn_params) -> Ple r (max_def_function f). +Proof. + assert (A: forall l m, Ple m (fold_left (fun m r => Pmax m r) l m)). + induction l; simpl; intros. + apply Ple_refl. + eapply Ple_trans. 2: eauto. apply Pmax_l. + assert (B: forall l m r, In r l -> Ple r (fold_left (fun m r => Pmax m r) l m)). + induction l; simpl; intros. + contradiction. + destruct H. subst a. eapply Ple_trans. 2: eapply A. apply Pmax_r. + eauto. + unfold max_def_function; intros. + eapply Ple_trans. 2: eapply Pmax_r. eauto. +Qed. + +(** ** Working with the state monad *) + +Remark bind_inversion: + forall (A B: Type) (f: mon A) (g: A -> mon B) + (y: B) (s1 s3: state) (i: sincr s1 s3), + bind f g s1 = R y s3 i -> + exists x, exists s2, exists i1, exists i2, + f s1 = R x s2 i1 /\ g x s2 = R y s3 i2. +Proof. + unfold bind; intros. destruct (f s1). exists x; exists s'; exists I. + destruct (g x s'). inv H. exists I0; auto. +Qed. + +Ltac monadInv1 H := + match type of H with + | (R _ _ _ = R _ _ _) => + inversion H; clear H; try subst + | (ret _ _ = R _ _ _) => + inversion H; clear H; try subst + | (bind ?F ?G ?S = R ?X ?S' ?I) => + let x := fresh "x" in ( + let s := fresh "s" in ( + let i1 := fresh "INCR" in ( + let i2 := fresh "INCR" in ( + let EQ1 := fresh "EQ" in ( + let EQ2 := fresh "EQ" in ( + destruct (bind_inversion _ _ F G X S S' I H) as [x [s [i1 [i2 [EQ1 EQ2]]]]]; + clear H; + try (monadInv1 EQ2))))))) + end. + +Ltac monadInv H := + match type of H with + | (ret _ _ = R _ _ _) => monadInv1 H + | (bind ?F ?G ?S = R ?X ?S' ?I) => monadInv1 H + | (?F _ _ _ _ _ _ _ _ = R _ _ _) => + ((progress simpl in H) || unfold F in H); monadInv1 H + | (?F _ _ _ _ _ _ _ = R _ _ _) => + ((progress simpl in H) || unfold F in H); monadInv1 H + | (?F _ _ _ _ _ _ = R _ _ _) => + ((progress simpl in H) || unfold F in H); monadInv1 H + | (?F _ _ _ _ _ = R _ _ _) => + ((progress simpl in H) || unfold F in H); monadInv1 H + | (?F _ _ _ _ = R _ _ _) => + ((progress simpl in H) || unfold F in H); monadInv1 H + | (?F _ _ _ = R _ _ _) => + ((progress simpl in H) || unfold F in H); monadInv1 H + | (?F _ _ = R _ _ _) => + ((progress simpl in H) || unfold F in H); monadInv1 H + | (?F _ = R _ _ _) => + ((progress simpl in H) || unfold F in H); monadInv1 H + end. + +(** ** Relational specification of the translation of moves *) + +Inductive tr_moves (c: code) : node -> list reg -> list reg -> node -> Prop := + | tr_moves_cons: forall pc1 src srcs dst dsts pc2 pc3, + tr_moves c pc1 srcs dsts pc2 -> + c!pc2 = Some(Iop Omove (src :: nil) dst pc3) -> + tr_moves c pc1 (src :: srcs) (dst :: dsts) pc3 + | tr_moves_nil: forall srcs dsts pc, + srcs = nil \/ dsts = nil -> + tr_moves c pc srcs dsts pc. + +Lemma add_moves_unchanged: + forall srcs dsts pc2 s pc1 s' i pc, + add_moves srcs dsts pc2 s = R pc1 s' i -> + Ple pc s.(st_nextnode) \/ Plt s'.(st_nextnode) pc -> + s'.(st_code)!pc = s.(st_code)!pc. +Proof. + induction srcs; simpl; intros. + monadInv H. auto. + destruct dsts; monadInv H. auto. + transitivity (st_code s0)!pc. eapply IHsrcs; eauto. monadInv EQ; simpl. xomega. + monadInv EQ; simpl. apply PTree.gso. + inversion INCR0; simpl in *. xomega. +Qed. + +Lemma add_moves_spec: + forall srcs dsts pc2 s pc1 s' i c, + add_moves srcs dsts pc2 s = R pc1 s' i -> + (forall pc, Plt s.(st_nextnode) pc -> Ple pc s'.(st_nextnode) -> c!pc = s'.(st_code)!pc) -> + tr_moves c pc1 srcs dsts pc2. +Proof. + induction srcs; simpl; intros. + monadInv H. apply tr_moves_nil; auto. + destruct dsts; monadInv H. apply tr_moves_nil; auto. + apply tr_moves_cons with x. eapply IHsrcs; eauto. + intros. inversion INCR. apply H0; xomega. + monadInv EQ. + rewrite H0. erewrite add_moves_unchanged; eauto. + simpl. apply PTree.gss. + simpl. xomega. + xomega. + inversion INCR; inversion INCR0; simpl in *; xomega. +Qed. + +(** ** Relational specification of CFG expansion *) + +Section INLINING_SPEC. + +Variable fenv: funenv. + +Definition context_below (ctx1 ctx2: context): Prop := + Ple (Pplus ctx1.(dreg) ctx1.(mreg)) ctx2.(dreg). + +Definition context_stack_call (ctx1 ctx2: context): Prop := + ctx1.(mstk) >= 0 /\ ctx1.(dstk) + ctx1.(mstk) <= ctx2.(dstk). + +Definition context_stack_tailcall (ctx1: context) (f: function) (ctx2: context) : Prop := + ctx2.(dstk) = align ctx1.(dstk) (min_alignment f.(fn_stacksize)). + +Section INLINING_BODY_SPEC. + +Variable stacksize: Z. + +Inductive tr_instr: context -> node -> instruction -> code -> Prop := + | tr_nop: forall ctx pc c s, + c!(spc ctx pc) = Some (Inop (spc ctx s)) -> + tr_instr ctx pc (Inop s) c + | tr_op: forall ctx pc c op args res s, + Ple res ctx.(mreg) -> + c!(spc ctx pc) = Some (Iop (sop ctx op) (sregs ctx args) (sreg ctx res) (spc ctx s)) -> + tr_instr ctx pc (Iop op args res s) c + | tr_load: forall ctx pc c chunk addr args res s, + Ple res ctx.(mreg) -> + c!(spc ctx pc) = Some (Iload chunk (saddr ctx addr) (sregs ctx args) (sreg ctx res) (spc ctx s)) -> + tr_instr ctx pc (Iload chunk addr args res s) c + | tr_store: forall ctx pc c chunk addr args src s, + c!(spc ctx pc) = Some (Istore chunk (saddr ctx addr) (sregs ctx args) (sreg ctx src) (spc ctx s)) -> + tr_instr ctx pc (Istore chunk addr args src s) c + | tr_call: forall ctx pc c sg ros args res s, + Ple res ctx.(mreg) -> + c!(spc ctx pc) = Some (Icall sg (sros ctx ros) (sregs ctx args) (sreg ctx res) (spc ctx s)) -> + tr_instr ctx pc (Icall sg ros args res s) c + | tr_call_inlined:forall ctx pc sg id args res s c f pc1 ctx', + Ple res ctx.(mreg) -> + fenv!id = Some f -> + c!(spc ctx pc) = Some(Inop pc1) -> + tr_moves c pc1 (sregs ctx args) (sregs ctx' f.(fn_params)) (spc ctx' f.(fn_entrypoint)) -> + tr_funbody ctx' f c -> + ctx'.(retinfo) = Some(spc ctx s, sreg ctx res) -> + context_below ctx ctx' -> + context_stack_call ctx ctx' -> + tr_instr ctx pc (Icall sg (inr _ id) args res s) c + | tr_tailcall: forall ctx pc c sg ros args, + c!(spc ctx pc) = Some (Itailcall sg (sros ctx ros) (sregs ctx args)) -> + ctx.(retinfo) = None -> + tr_instr ctx pc (Itailcall sg ros args) c + | tr_tailcall_call: forall ctx pc c sg ros args res s, + c!(spc ctx pc) = Some (Icall sg (sros ctx ros) (sregs ctx args) res s) -> + ctx.(retinfo) = Some(s, res) -> + tr_instr ctx pc (Itailcall sg ros args) c + | tr_tailcall_inlined: forall ctx pc sg id args c f pc1 ctx', + fenv!id = Some f -> + c!(spc ctx pc) = Some(Inop pc1) -> + tr_moves c pc1 (sregs ctx args) (sregs ctx' f.(fn_params)) (spc ctx' f.(fn_entrypoint)) -> + tr_funbody ctx' f c -> + ctx'.(retinfo) = ctx.(retinfo) -> + context_below ctx ctx' -> + context_stack_tailcall ctx f ctx' -> + tr_instr ctx pc (Itailcall sg (inr _ id) args) c + | tr_builtin: forall ctx pc c ef args res s, + Ple res ctx.(mreg) -> + c!(spc ctx pc) = Some (Ibuiltin ef (sregs ctx args) (sreg ctx res) (spc ctx s)) -> + tr_instr ctx pc (Ibuiltin ef args res s) c + | tr_cond: forall ctx pc cond args s1 s2 c, + c!(spc ctx pc) = Some (Icond cond (sregs ctx args) (spc ctx s1) (spc ctx s2)) -> + tr_instr ctx pc (Icond cond args s1 s2) c + | tr_jumptable: forall ctx pc r tbl c, + c!(spc ctx pc) = Some (Ijumptable (sreg ctx r) (List.map (spc ctx) tbl)) -> + tr_instr ctx pc (Ijumptable r tbl) c + | tr_return: forall ctx pc or c, + c!(spc ctx pc) = Some (Ireturn (option_map (sreg ctx) or)) -> + ctx.(retinfo) = None -> + tr_instr ctx pc (Ireturn or) c + | tr_return_inlined: forall ctx pc or c rinfo, + c!(spc ctx pc) = Some (inline_return ctx or rinfo) -> + ctx.(retinfo) = Some rinfo -> + tr_instr ctx pc (Ireturn or) c + +with tr_funbody: context -> function -> code -> Prop := + | tr_funbody_intro: forall ctx f c, + (forall r, In r f.(fn_params) -> Ple r ctx.(mreg)) -> + (forall pc i, f.(fn_code)!pc = Some i -> tr_instr ctx pc i c) -> + ctx.(mstk) = Zmax f.(fn_stacksize) 0 -> + (min_alignment f.(fn_stacksize) | ctx.(dstk)) -> + ctx.(dstk) >= 0 -> ctx.(dstk) + ctx.(mstk) <= stacksize -> + tr_funbody ctx f c. + +Definition fenv_agree (fe: funenv) : Prop := + forall id f, fe!id = Some f -> fenv!id = Some f. + +Section EXPAND_INSTR. + +Variable fe: funenv. +Hypothesis FE: fenv_agree fe. + +Variable rec: forall fe', (size_fenv fe' < size_fenv fe)%nat -> context -> function -> mon unit. + +Hypothesis rec_unchanged: + forall fe' (L: (size_fenv fe' < size_fenv fe)%nat) ctx f s x s' i pc, + rec fe' L ctx f s = R x s' i -> + Ple ctx.(dpc) s.(st_nextnode) -> + Ple pc ctx.(dpc) -> + s'.(st_code)!pc = s.(st_code)!pc. + +Remark set_instr_other: + forall pc instr s x s' i pc', + set_instr pc instr s = R x s' i -> + pc' <> pc -> + s'.(st_code)!pc' = s.(st_code)!pc'. +Proof. + intros. monadInv H; simpl. apply PTree.gso; auto. +Qed. + +Remark set_instr_same: + forall pc instr s x s' i c, + set_instr pc instr s = R x s' i -> + c!(pc) = s'.(st_code)!pc -> + c!(pc) = Some instr. +Proof. + intros. rewrite H0. monadInv H; simpl. apply PTree.gss. +Qed. + +Lemma expand_instr_unchanged: + forall ctx pc instr s x s' i pc', + expand_instr fe rec ctx pc instr s = R x s' i -> + Ple ctx.(dpc) s.(st_nextnode) -> + Ple pc' s.(st_nextnode) -> + pc' <> spc ctx pc -> + s'.(st_code)!pc' = s.(st_code)!pc'. +Proof. + generalize set_instr_other; intros A. + intros. unfold expand_instr in H; destruct instr; eauto. +(* call *) + destruct (can_inline fe s1). eauto. + monadInv H. unfold inline_function in EQ. monadInv EQ. + transitivity (s2.(st_code)!pc'). eauto. + transitivity (s5.(st_code)!pc'). eapply add_moves_unchanged; eauto. + left. inversion INCR5. inversion INCR3. monadInv EQ1; simpl in *. xomega. + transitivity (s4.(st_code)!pc'). eapply rec_unchanged; eauto. + simpl. monadInv EQ; simpl. monadInv EQ1; simpl. xomega. + simpl. monadInv EQ1; simpl. auto. + monadInv EQ; simpl. monadInv EQ1; simpl. auto. +(* tailcall *) + destruct (can_inline fe s1). + destruct (retinfo ctx) as [[rpc rreg]|]; eauto. + monadInv H. unfold inline_tail_function in EQ. monadInv EQ. + transitivity (s2.(st_code)!pc'). eauto. + transitivity (s5.(st_code)!pc'). eapply add_moves_unchanged; eauto. + left. inversion INCR5. inversion INCR3. monadInv EQ1; simpl in *. xomega. + transitivity (s4.(st_code)!pc'). eapply rec_unchanged; eauto. + simpl. monadInv EQ; simpl. monadInv EQ1; simpl. xomega. + simpl. monadInv EQ1; simpl. auto. + monadInv EQ; simpl. monadInv EQ1; simpl. auto. +(* return *) + destruct (retinfo ctx) as [[rpc rreg]|]; eauto. +Qed. + +Lemma iter_expand_instr_unchanged: + forall ctx pc l s x s' i, + mlist_iter2 (expand_instr fe rec ctx) l s = R x s' i -> + Ple ctx.(dpc) s.(st_nextnode) -> + Ple pc s.(st_nextnode) -> + ~In pc (List.map (spc ctx) (List.map (@fst _ _) l)) -> + list_norepet (List.map (@fst _ _) l) -> + s'.(st_code)!pc = s.(st_code)!pc. +Proof. + induction l; simpl; intros. + (* base case *) + monadInv H. auto. + (* inductive case *) + destruct a as [pc1 instr1]; simpl in *. + monadInv H. inv H3. + transitivity ((st_code s0)!pc). + eapply IHl; eauto. destruct INCR; xomega. destruct INCR; xomega. + eapply expand_instr_unchanged; eauto. +Qed. + +Lemma expand_cfg_rec_unchanged: + forall ctx f s x s' i pc, + expand_cfg_rec fe rec ctx f s = R x s' i -> + Ple ctx.(dpc) s.(st_nextnode) -> + Ple pc ctx.(dpc) -> + s'.(st_code)!pc = s.(st_code)!pc. +Proof. + intros. unfold expand_cfg_rec in H. monadInv H. inversion EQ. + transitivity ((st_code s0)!pc). + eapply iter_expand_instr_unchanged; eauto. + subst s0; auto. + subst s0; simpl. xomega. + red; intros. exploit list_in_map_inv; eauto. intros [pc1 [A B]]. + subst pc. unfold spc in H1. xomega. + apply PTree.elements_keys_norepet. + subst s0; auto. +Qed. + +Hypothesis rec_spec: + forall fe' (L: (size_fenv fe' < size_fenv fe)%nat) ctx f s x s' i c, + rec fe' L ctx f s = R x s' i -> + fenv_agree fe' -> + Ple (ctx.(dpc) + max_pc_function f) s.(st_nextnode) -> + ctx.(mreg) = max_def_function f -> + Ple (ctx.(dreg) + ctx.(mreg)) s.(st_nextreg) -> + ctx.(mstk) >= 0 -> + ctx.(mstk) = Zmax (fn_stacksize f) 0 -> + (min_alignment (fn_stacksize f) | ctx.(dstk)) -> + ctx.(dstk) >= 0 -> + s'.(st_stksize) <= stacksize -> + (forall pc, Plt ctx.(dpc) pc -> Ple pc s'.(st_nextnode) -> c!pc = s'.(st_code)!pc) -> + tr_funbody ctx f c. + +Remark min_alignment_pos: + forall sz, min_alignment sz > 0. +Proof. + intros; unfold min_alignment. + destruct (zle sz 1). omega. destruct (zle sz 2). omega. destruct (zle sz 4); omega. +Qed. + +Ltac inv_incr := + match goal with + | [ H: sincr _ _ |- _ ] => destruct H; inv_incr + | _ => idtac + end. + +Lemma expand_instr_spec: + forall ctx pc instr s x s' i c, + expand_instr fe rec ctx pc instr s = R x s' i -> + Ple (max_def_instr instr) ctx.(mreg) -> + Ple (spc ctx pc) s.(st_nextnode) -> + Ple (ctx.(dreg) + ctx.(mreg)) s.(st_nextreg) -> + ctx.(mstk) >= 0 -> ctx.(dstk) >= 0 -> + s'.(st_stksize) <= stacksize -> + (forall pc', Plt s.(st_nextnode) pc' -> Ple pc' s'.(st_nextnode) -> c!pc' = s'.(st_code)!pc') -> + c!(spc ctx pc) = s'.(st_code)!(spc ctx pc) -> + tr_instr ctx pc instr c. +Proof. + intros until c; intros EXP DEFS OPC OREG STK1 STK2 STK3 S1 S2. + generalize set_instr_same; intros BASE. + unfold expand_instr in EXP; destruct instr; simpl in DEFS; + try (econstructor; eauto; fail). +(* call *) + destruct (can_inline fe s1) as [|id f P Q]. + (* not inlined *) + eapply tr_call; eauto. + (* inlined *) + subst s1. + monadInv EXP. unfold inline_function in EQ; monadInv EQ. + set (ctx' := callcontext ctx x1 x2 (max_def_function f) (fn_stacksize f) n r). + inversion EQ0; inversion EQ1; inversion EQ. inv_incr. + apply tr_call_inlined with (pc1 := x0) (ctx' := ctx') (f := f); auto. + eapply BASE; eauto. + eapply add_moves_spec; eauto. + intros. rewrite S1. eapply set_instr_other; eauto. unfold node; xomega. xomega. xomega. + eapply rec_spec; eauto. + red; intros. rewrite PTree.grspec in H. destruct (PTree.elt_eq id0 id); try discriminate. auto. + simpl. subst s2; simpl in *; xomega. + simpl. subst s3; simpl in *; xomega. + simpl. xomega. + simpl. apply align_divides. apply min_alignment_pos. + assert (dstk ctx + mstk ctx <= dstk ctx'). simpl. apply align_le. apply min_alignment_pos. omega. + omega. + intros. simpl in H. rewrite S1. + transitivity s1.(st_code)!pc0. eapply set_instr_other; eauto. unfold node in *; xomega. + eapply add_moves_unchanged; eauto. unfold node in *; xomega. xomega. + red; simpl. subst s2; simpl in *; xomega. + red; simpl. split. auto. apply align_le. apply min_alignment_pos. +(* tailcall *) + destruct (can_inline fe s1) as [|id f P Q]. + (* not inlined *) + destruct (retinfo ctx) as [[rpc rreg] | ]_eqn. + (* turned into a call *) + eapply tr_tailcall_call; eauto. + (* preserved *) + eapply tr_tailcall; eauto. + (* inlined *) + subst s1. + monadInv EXP. unfold inline_function in EQ; monadInv EQ. + set (ctx' := tailcontext ctx x1 x2 (max_def_function f) (fn_stacksize f)) in *. + inversion EQ0; inversion EQ1; inversion EQ. inv_incr. + apply tr_tailcall_inlined with (pc1 := x0) (ctx' := ctx') (f := f); auto. + eapply BASE; eauto. + eapply add_moves_spec; eauto. + intros. rewrite S1. eapply set_instr_other; eauto. unfold node; xomega. xomega. xomega. + eapply rec_spec; eauto. + red; intros. rewrite PTree.grspec in H. destruct (PTree.elt_eq id0 id); try discriminate. auto. + simpl. subst s2; simpl in *; xomega. + simpl. subst s3; simpl in *; xomega. + simpl. xomega. + simpl. apply align_divides. apply min_alignment_pos. + assert (dstk ctx <= dstk ctx'). simpl. apply align_le. apply min_alignment_pos. omega. + omega. + intros. simpl in H. rewrite S1. + transitivity s1.(st_code)!pc0. eapply set_instr_other; eauto. unfold node in *; xomega. + eapply add_moves_unchanged; eauto. unfold node in *; xomega. xomega. + red; simpl. subst s2; simpl in *; xomega. + red; auto. +(* return *) + destruct (retinfo ctx) as [[rpc rreg] | ]_eqn. + (* inlined *) + eapply tr_return_inlined; eauto. + (* unchanged *) + eapply tr_return; eauto. +Qed. + +Lemma iter_expand_instr_spec: + forall ctx l s x s' i c, + mlist_iter2 (expand_instr fe rec ctx) l s = R x s' i -> + list_norepet (List.map (@fst _ _) l) -> + (forall pc instr, In (pc, instr) l -> Ple (max_def_instr instr) ctx.(mreg)) -> + (forall pc instr, In (pc, instr) l -> Ple (spc ctx pc) s.(st_nextnode)) -> + Ple (ctx.(dreg) + ctx.(mreg)) s.(st_nextreg) -> + ctx.(mstk) >= 0 -> ctx.(dstk) >= 0 -> + s'.(st_stksize) <= stacksize -> + (forall pc', Plt s.(st_nextnode) pc' -> Ple pc' s'.(st_nextnode) -> c!pc' = s'.(st_code)!pc') -> + (forall pc instr, In (pc, instr) l -> c!(spc ctx pc) = s'.(st_code)!(spc ctx pc)) -> + forall pc instr, In (pc, instr) l -> tr_instr ctx pc instr c. +Proof. + induction l; simpl; intros. + (* base case *) + contradiction. + (* inductive case *) + destruct a as [pc1 instr1]; simpl in *. inv H0. monadInv H. inv_incr. + assert (A: Ple ctx.(dpc) s0.(st_nextnode)). + assert (B: Ple (spc ctx pc) (st_nextnode s)) by eauto. unfold spc in B; xomega. + destruct H9. inv H. + (* same pc *) + eapply expand_instr_spec; eauto. + omega. + intros. + transitivity ((st_code s')!pc'). + apply H7. auto. xomega. + eapply iter_expand_instr_unchanged; eauto. + red; intros. rewrite list_map_compose in H9. exploit list_in_map_inv; eauto. + intros [[pc0 instr0] [P Q]]. simpl in P. + assert (Ple (spc ctx pc0) (st_nextnode s)) by eauto. xomega. + transitivity ((st_code s')!(spc ctx pc)). + eapply H8; eauto. + eapply iter_expand_instr_unchanged; eauto. + assert (Ple (spc ctx pc) (st_nextnode s)) by eauto. xomega. + red; intros. rewrite list_map_compose in H. exploit list_in_map_inv; eauto. + intros [[pc0 instr0] [P Q]]. simpl in P. unfold spc in P. + assert (pc = pc0) by (unfold node; xomega). subst pc0. + elim H12. change pc with (fst (pc, instr0)). apply List.in_map; auto. + (* older pc *) + inv_incr. eapply IHl; eauto. + intros. eapply Ple_trans; eauto. + intros; eapply Ple_trans; eauto. + intros. apply H7; auto. xomega. +Qed. + +Lemma expand_cfg_rec_spec: + forall ctx f s x s' i c, + expand_cfg_rec fe rec ctx f s = R x s' i -> + Ple (ctx.(dpc) + max_pc_function f) s.(st_nextnode) -> + ctx.(mreg) = max_def_function f -> + Ple (ctx.(dreg) + ctx.(mreg)) s.(st_nextreg) -> + ctx.(mstk) >= 0 -> + ctx.(mstk) = Zmax (fn_stacksize f) 0 -> + (min_alignment (fn_stacksize f) | ctx.(dstk)) -> + ctx.(dstk) >= 0 -> + s'.(st_stksize) <= stacksize -> + (forall pc', Plt ctx.(dpc) pc' -> Ple pc' s'.(st_nextnode) -> c!pc' = s'.(st_code)!pc') -> + tr_funbody ctx f c. +Proof. + intros. unfold expand_cfg_rec in H. monadInv H. inversion EQ. + constructor. + intros. rewrite H1. eapply max_def_function_params; eauto. + intros. eapply iter_expand_instr_spec; eauto. + apply PTree.elements_keys_norepet. + intros. rewrite H1. eapply max_def_function_instr; eauto. + eapply PTree.elements_complete; eauto. + intros. + assert (Ple pc0 (max_pc_function f)). + eapply max_pc_function_sound. eapply PTree.elements_complete; eauto. + unfold spc. subst s0; simpl; xomega. + subst s0; simpl; auto. + intros. apply H8; auto. subst s0; simpl in H11; xomega. + intros. apply H8. unfold spc; xomega. + assert (Ple pc0 (max_pc_function f)). + eapply max_pc_function_sound. eapply PTree.elements_complete; eauto. + unfold spc. inversion i; xomega. + apply PTree.elements_correct; auto. + auto. auto. auto. + inversion INCR0. subst s0; simpl in STKSIZE; xomega. +Qed. + +End EXPAND_INSTR. + +Lemma expand_cfg_unchanged: + forall fe ctx f s x s' i pc, + expand_cfg fe ctx f s = R x s' i -> + Ple ctx.(dpc) s.(st_nextnode) -> + Ple pc ctx.(dpc) -> + s'.(st_code)!pc = s.(st_code)!pc. +Proof. + intros fe0; pattern fe0. apply well_founded_ind with (R := ltof _ size_fenv). + apply well_founded_ltof. + intros. unfold expand_cfg in H0. rewrite unroll_Fixm in H0. + eapply expand_cfg_rec_unchanged; eauto. assumption. +Qed. + +Lemma expand_cfg_spec: + forall fe ctx f s x s' i c, + expand_cfg fe ctx f s = R x s' i -> + fenv_agree fe -> + Ple (ctx.(dpc) + max_pc_function f) s.(st_nextnode) -> + ctx.(mreg) = max_def_function f -> + Ple (ctx.(dreg) + ctx.(mreg)) s.(st_nextreg) -> + ctx.(mstk) >= 0 -> + ctx.(mstk) = Zmax (fn_stacksize f) 0 -> + (min_alignment (fn_stacksize f) | ctx.(dstk)) -> + ctx.(dstk) >= 0 -> + s'.(st_stksize) <= stacksize -> + (forall pc', Plt ctx.(dpc) pc' -> Ple pc' s'.(st_nextnode) -> c!pc' = s'.(st_code)!pc') -> + tr_funbody ctx f c. +Proof. + intros fe0; pattern fe0. apply well_founded_ind with (R := ltof _ size_fenv). + apply well_founded_ltof. + intros. unfold expand_cfg in H0. rewrite unroll_Fixm in H0. + eapply expand_cfg_rec_spec; eauto. + simpl. intros. eapply expand_cfg_unchanged; eauto. assumption. +Qed. + +End INLINING_BODY_SPEC. + +(** ** Relational specification of the translation of a function *) + +Inductive tr_function: function -> function -> Prop := + | tr_function_intro: forall f f' ctx, + tr_funbody f'.(fn_stacksize) ctx f f'.(fn_code) -> + ctx.(dstk) = 0 -> + ctx.(retinfo) = None -> + f'.(fn_sig) = f.(fn_sig) -> + f'.(fn_params) = sregs ctx f.(fn_params) -> + f'.(fn_entrypoint) = spc ctx f.(fn_entrypoint) -> + 0 <= fn_stacksize f' <= Int.max_unsigned -> + tr_function f f'. + +Lemma transf_function_spec: + forall f f', transf_function fenv f = OK f' -> tr_function f f'. +Proof. + intros. unfold transf_function in H. + destruct (expand_function fenv f initstate) as [ctx s i]_eqn. + destruct (zle (st_stksize s) Int.max_unsigned); inv H. + monadInv Heqr. set (ctx := initcontext x x0 (max_def_function f) (fn_stacksize f)) in *. +Opaque initstate. + destruct INCR3. inversion EQ1. inversion EQ. + apply tr_function_intro with ctx; auto. + eapply expand_cfg_spec with (fe := fenv); eauto. + red; auto. + unfold ctx; rewrite <- H1; rewrite <- H2; rewrite <- H3; simpl. xomega. + unfold ctx; rewrite <- H0; rewrite <- H1; simpl. xomega. + simpl. xomega. + simpl. apply Zdivide_0. + simpl. omega. + simpl. omega. + simpl. split; auto. destruct INCR2. destruct INCR1. destruct INCR0. destruct INCR. + simpl. change 0 with (st_stksize initstate). omega. +Qed. + +End INLINING_SPEC. diff --git a/backend/PrintLTLin.ml b/backend/PrintLTLin.ml index adff483..bb360eb 100644 --- a/backend/PrintLTLin.ml +++ b/backend/PrintLTLin.ml @@ -90,29 +90,26 @@ let print_instruction pp i = | Lreturn (Some arg) -> fprintf pp "return %a@ " reg arg -let print_function pp f = - fprintf pp "@[<v 2>f(%a) {@ " regs f.fn_params; +let print_function pp id f = + fprintf pp "@[<v 2>%s(%a) {@ " (extern_atom id) regs f.fn_params; List.iter (print_instruction pp) f.fn_code; fprintf pp "@;<0 -2>}@]@." -let print_fundef pp fd = +let print_fundef pp (id, fd) = match fd with - | Internal f -> print_function pp f + | Internal f -> print_function pp id f | External _ -> () +let print_program pp prog = + List.iter (print_fundef pp) prog.prog_funct + let destination : string option ref = ref None -let currpp : formatter option ref = ref None -let print_if fd = +let print_if prog = match !destination with | None -> () | Some f -> - let pp = - match !currpp with - | Some pp -> pp - | None -> - let oc = open_out f in - let pp = formatter_of_out_channel oc in - currpp := Some pp; - pp - in print_fundef pp fd + let oc = open_out f in + let pp = formatter_of_out_channel oc in + print_program pp prog; + close_out oc diff --git a/backend/PrintMach.ml b/backend/PrintMach.ml index a6a1cc5..03977a6 100644 --- a/backend/PrintMach.ml +++ b/backend/PrintMach.ml @@ -97,29 +97,26 @@ let print_instruction pp i = | Mreturn -> fprintf pp "return@ " -let print_function pp f = - fprintf pp "@[<v 2>f() {@ "; +let print_function pp id f = + fprintf pp "@[<v 2>%s() {@ " (extern_atom id); List.iter (print_instruction pp) f.fn_code; fprintf pp "@;<0 -2>}@]@." -let print_fundef pp fd = +let print_fundef pp (id, fd) = match fd with - | Internal f -> print_function pp f + | Internal f -> print_function pp id f | External _ -> () +let print_program pp prog = + List.iter (print_fundef pp) prog.prog_funct + let destination : string option ref = ref None -let currpp : formatter option ref = ref None -let print_if fd = +let print_if prog = match !destination with | None -> () | Some f -> - let pp = - match !currpp with - | Some pp -> pp - | None -> - let oc = open_out f in - let pp = formatter_of_out_channel oc in - currpp := Some pp; - pp - in print_fundef pp fd + let oc = open_out f in + let pp = formatter_of_out_channel oc in + print_program pp prog; + close_out oc diff --git a/backend/PrintRTL.ml b/backend/PrintRTL.ml index 985bd63..4fc8f56 100644 --- a/backend/PrintRTL.ml +++ b/backend/PrintRTL.ml @@ -90,8 +90,8 @@ let print_instruction pp (pc, i) = | Ireturn (Some arg) -> fprintf pp "return %a@ " reg arg -let print_function pp f = - fprintf pp "@[<v 2>f(%a) {@ " regs f.fn_params; +let print_function pp id f = + fprintf pp "@[<v 2>%s(%a) {@ " (extern_atom id) regs f.fn_params; let instrs = List.sort (fun (pc1, _) (pc2, _) -> Pervasives.compare pc2 pc1) @@ -103,42 +103,35 @@ let print_function pp f = List.iter (print_instruction pp) instrs; fprintf pp "@;<0 -2>}@]@." -let print_fundef pp fd = +let print_fundef pp (id, fd) = match fd with - | Internal f -> print_function pp f + | Internal f -> print_function pp id f | External _ -> () -let print_if optdest currpp fd = +let print_program pp (prog: RTL.program) = + List.iter (print_fundef pp) prog.prog_funct + +let print_if optdest prog = match !optdest with | None -> () | Some f -> - let pp = - match !currpp with - | Some pp -> pp - | None -> - let oc = open_out f in - let pp = formatter_of_out_channel oc in - currpp := Some pp; - pp - in print_fundef pp fd + let oc = open_out f in + let pp = formatter_of_out_channel oc in + print_program pp prog; + close_out oc let destination_rtl : string option ref = ref None -let pp_rtl : formatter option ref = ref None -let print_rtl = print_if destination_rtl pp_rtl +let print_rtl = print_if destination_rtl let destination_tailcall : string option ref = ref None -let pp_tailcall : formatter option ref = ref None -let print_tailcall = print_if destination_tailcall pp_tailcall +let print_tailcall = print_if destination_tailcall -let destination_castopt : string option ref = ref None -let pp_castopt : formatter option ref = ref None -let print_castopt = print_if destination_castopt pp_castopt +let destination_inlining : string option ref = ref None +let print_inlining = print_if destination_inlining let destination_constprop : string option ref = ref None -let pp_constprop : formatter option ref = ref None -let print_constprop = print_if destination_constprop pp_constprop +let print_constprop = print_if destination_constprop let destination_cse : string option ref = ref None -let pp_cse : formatter option ref = ref None -let print_cse = print_if destination_cse pp_cse +let print_cse = print_if destination_cse diff --git a/backend/RTLgen.v b/backend/RTLgen.v index 28d2b06..86c1177 100644 --- a/backend/RTLgen.v +++ b/backend/RTLgen.v @@ -557,19 +557,28 @@ Fixpoint transl_stmt (map: mapping) (s: stmt) (nd: node) do no <- add_instr (Istore chunk addr rl r nd); do ns <- transl_expr map b r no; transl_exprlist map al rl ns - | Scall optid sig b cl => + | Scall optid sig (inl b) cl => do rf <- alloc_reg map b; do rargs <- alloc_regs map cl; do r <- alloc_optreg map optid; do n1 <- add_instr (Icall sig (inl _ rf) rargs r nd); do n2 <- transl_exprlist map cl rargs n1; transl_expr map b rf n2 - | Stailcall sig b cl => + | Scall optid sig (inr id) cl => + do rargs <- alloc_regs map cl; + do r <- alloc_optreg map optid; + do n1 <- add_instr (Icall sig (inr _ id) rargs r nd); + transl_exprlist map cl rargs n1 + | Stailcall sig (inl b) cl => do rf <- alloc_reg map b; do rargs <- alloc_regs map cl; do n1 <- add_instr (Itailcall sig (inl _ rf) rargs); do n2 <- transl_exprlist map cl rargs n1; transl_expr map b rf n2 + | Stailcall sig (inr id) cl => + do rargs <- alloc_regs map cl; + do n1 <- add_instr (Itailcall sig (inr _ id) rargs); + transl_exprlist map cl rargs n1 | Sbuiltin optid ef al => do rargs <- alloc_regs map al; do r <- alloc_optreg map optid; diff --git a/backend/RTLgenproof.v b/backend/RTLgenproof.v index c5182db..e06224a 100644 --- a/backend/RTLgenproof.v +++ b/backend/RTLgenproof.v @@ -1142,7 +1142,8 @@ Proof. econstructor; eauto. constructor. (* call *) - inv TS. + inv TS; inv H. + (* indirect *) exploit transl_expr_correct; eauto. intros [rs' [A [B [C D]]]]. exploit transl_exprlist_correct; eauto. @@ -1154,9 +1155,21 @@ Proof. apply sig_transl_function; auto. traceEq. rewrite G. constructor. auto. econstructor; eauto. + (* direct *) + exploit transl_exprlist_correct; eauto. + intros [rs'' [E [F [G J]]]]. + exploit functions_translated; eauto. intros [tf' [P Q]]. + econstructor; split. + left; eapply plus_right. eexact E. + eapply exec_Icall; eauto. simpl. rewrite symbols_preserved. rewrite H4. + rewrite Genv.find_funct_find_funct_ptr in P. eauto. + apply sig_transl_function; auto. + traceEq. + rewrite G. constructor. auto. econstructor; eauto. (* tailcall *) - inv TS. + inv TS; inv H. + (* indirect *) exploit transl_expr_correct; eauto. intros [rs' [A [B [C D]]]]. exploit transl_exprlist_correct; eauto. @@ -1168,7 +1181,21 @@ Proof. left; eapply plus_right. eapply star_trans. eexact A. eexact E. reflexivity. eapply exec_Itailcall; eauto. simpl. rewrite J. rewrite C. eauto. simpl; auto. apply sig_transl_function; auto. - rewrite H2; eauto. + rewrite H; eauto. + traceEq. + rewrite G. constructor; auto. + (* direct *) + exploit transl_exprlist_correct; eauto. + intros [rs'' [E [F [G J]]]]. + exploit functions_translated; eauto. intros [tf' [P Q]]. + exploit match_stacks_call_cont; eauto. intros [U V]. + assert (fn_stacksize tf = fn_stackspace f). inv TF; auto. + econstructor; split. + left; eapply plus_right. eexact E. + eapply exec_Itailcall; eauto. simpl. rewrite symbols_preserved. rewrite H5. + rewrite Genv.find_funct_find_funct_ptr in P. eauto. + apply sig_transl_function; auto. + rewrite H; eauto. traceEq. rewrite G. constructor; auto. diff --git a/backend/RTLgenspec.v b/backend/RTLgenspec.v index 9b2e63e..f6c59fc 100644 --- a/backend/RTLgenspec.v +++ b/backend/RTLgenspec.v @@ -865,12 +865,21 @@ Inductive tr_stmt (c: code) (map: mapping): tr_exprlist c map (rf :: nil) cl n1 n2 rargs -> c!n2 = Some (Icall sig (inl _ rf) rargs rd nd) -> reg_map_ok map rd optid -> - tr_stmt c map (Scall optid sig b cl) ns nd nexits ngoto nret rret + tr_stmt c map (Scall optid sig (inl _ b) cl) ns nd nexits ngoto nret rret + | tr_Scall_imm: forall optid sig id cl ns nd nexits ngoto nret rret rd n2 rargs, + tr_exprlist c map nil cl ns n2 rargs -> + c!n2 = Some (Icall sig (inr _ id) rargs rd nd) -> + reg_map_ok map rd optid -> + tr_stmt c map (Scall optid sig (inr _ id) cl) ns nd nexits ngoto nret rret | tr_Stailcall: forall sig b cl ns nd nexits ngoto nret rret n1 rf n2 rargs, tr_expr c map nil b ns n1 rf None -> tr_exprlist c map (rf :: nil) cl n1 n2 rargs -> c!n2 = Some (Itailcall sig (inl _ rf) rargs) -> - tr_stmt c map (Stailcall sig b cl) ns nd nexits ngoto nret rret + tr_stmt c map (Stailcall sig (inl _ b) cl) ns nd nexits ngoto nret rret + | tr_Stailcall_imm: forall sig id cl ns nd nexits ngoto nret rret n2 rargs, + tr_exprlist c map nil cl ns n2 rargs -> + c!n2 = Some (Itailcall sig (inr _ id) rargs) -> + tr_stmt c map (Stailcall sig (inr _ id) cl) ns nd nexits ngoto nret rret | tr_Sbuiltin: forall optid ef al ns nd nexits ngoto nret rret rd n1 rargs, tr_exprlist c map nil al ns n1 rargs -> c!n1 = Some (Ibuiltin ef rargs rd nd) -> @@ -1251,23 +1260,34 @@ Proof. apply tr_expr_incr with s3; auto. eapply transl_expr_charact; eauto 4 with rtlg. (* Scall *) + destruct s0 as [b | id]; monadInv TR; saturateTrans. + (* indirect *) econstructor; eauto 4 with rtlg. eapply transl_expr_charact; eauto 3 with rtlg. apply tr_exprlist_incr with s5. auto. eapply transl_exprlist_charact; eauto 3 with rtlg. - eapply alloc_regs_target_ok with (s1 := s1); eauto 3 with rtlg. + eapply alloc_regs_target_ok with (s1 := s0); eauto 3 with rtlg. apply regs_valid_cons; eauto 3 with rtlg. - apply regs_valid_incr with s1; eauto 3 with rtlg. + apply regs_valid_incr with s0; eauto 3 with rtlg. apply regs_valid_cons; eauto 3 with rtlg. apply regs_valid_incr with s2; eauto 3 with rtlg. eapply alloc_optreg_map_ok with (s1 := s2); eauto 3 with rtlg. + (* direct *) + econstructor; eauto 4 with rtlg. + eapply transl_exprlist_charact; eauto 3 with rtlg. + eapply alloc_optreg_map_ok with (s1 := s0); eauto 3 with rtlg. (* Stailcall *) - assert (RV: regs_valid (x :: nil) s1). + destruct s0 as [b | id]; monadInv TR; saturateTrans. + (* indirect *) + assert (RV: regs_valid (x :: nil) s0). apply regs_valid_cons; eauto 3 with rtlg. econstructor; eauto 3 with rtlg. eapply transl_expr_charact; eauto 3 with rtlg. apply tr_exprlist_incr with s4; auto. eapply transl_exprlist_charact; eauto 4 with rtlg. + (* direct *) + econstructor; eauto 3 with rtlg. + eapply transl_exprlist_charact; eauto 4 with rtlg. (* Sbuiltin *) econstructor; eauto 4 with rtlg. eapply transl_exprlist_charact; eauto 3 with rtlg. diff --git a/backend/Renumber.v b/backend/Renumber.v new file mode 100644 index 0000000..b933bba --- /dev/null +++ b/backend/Renumber.v @@ -0,0 +1,81 @@ +(* *********************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Xavier Leroy, INRIA Paris-Rocquencourt *) +(* *) +(* 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. *) +(* *) +(* *********************************************************************) + +(** Postorder renumbering of RTL control-flow graphs. *) + +Require Import Coqlib. +Require Import Maps. +Require Import Postorder. +Require Import AST. +Require Import RTL. + +(** CompCert's dataflow analyses (module [Kildall]) are more precise + and run faster when the sequence [1, 2, 3, ...] is a postorder + enumeration of the nodes of the control-flow graph. This property + can be guaranteed when generating the CFG (module [RTLgen]), but + is, however, invalidated by further RTL optimization passes such as + [Inlining]. + + In this module, we renumber the nodes of RTL control-flow graphs + to restore the postorder property given above. In passing, + we also eliminate CFG nodes that are not reachable from the entry point: + these nodes are dead code. *) + +Section RENUMBER. + +Variable pnum: PTree.t positive. (**r a postorder numbering *) + +Definition renum_pc (pc: node) : node := + match pnum!pc with + | Some pc' => pc' + | None => 1%positive (**r impossible case, never exercised *) + end. + +Definition renum_instr (i: instruction) : instruction := + match i with + | Inop s => Inop (renum_pc s) + | Iop op args res s => Iop op args res (renum_pc s) + | Iload chunk addr args res s => Iload chunk addr args res (renum_pc s) + | Istore chunk addr args src s => Istore chunk addr args src (renum_pc s) + | Icall sg ros args res s => Icall sg ros args res (renum_pc s) + | Itailcall sg ros args => i + | Ibuiltin ef args res s => Ibuiltin ef args res (renum_pc s) + | Icond cond args s1 s2 => Icond cond args (renum_pc s1) (renum_pc s2) + | Ijumptable arg tbl => Ijumptable arg (List.map renum_pc tbl) + | Ireturn or => i + end. + +Definition renum_node (c': code) (pc: node) (i: instruction) : code := + match pnum!pc with + | None => c' + | Some pc' => PTree.set pc' (renum_instr i) c' + end. + +Definition renum_cfg (c: code) : code := + PTree.fold renum_node c (PTree.empty instruction). + +End RENUMBER. + +Definition transf_function (f: function) : function := + let pnum := postorder (successors f) f.(fn_entrypoint) in + mkfunction + f.(fn_sig) + f.(fn_params) + f.(fn_stacksize) + (renum_cfg pnum f.(fn_code)) + (renum_pc pnum f.(fn_entrypoint)). + +Definition transf_fundef (fd: fundef) : fundef := + AST.transf_fundef transf_function fd. + +Definition transf_program (p: program) : program := + AST.transform_program transf_fundef p. diff --git a/backend/Renumberproof.v b/backend/Renumberproof.v new file mode 100644 index 0000000..a1b32b8 --- /dev/null +++ b/backend/Renumberproof.v @@ -0,0 +1,268 @@ +(* *********************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Xavier Leroy, INRIA Paris-Rocquencourt *) +(* *) +(* 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. *) +(* *) +(* *********************************************************************) + +(** Postorder renumbering of RTL control-flow graphs. *) + +Require Import Coqlib. +Require Import Maps. +Require Import Postorder. +Require Import AST. +Require Import Values. +Require Import Events. +Require Import Memory. +Require Import Globalenvs. +Require Import Smallstep. +Require Import Op. +Require Import Registers. +Require Import RTL. +Require Import Renumber. + +Section PRESERVATION. + +Variable prog: program. +Let tprog := transf_program prog. +Let ge := Genv.globalenv prog. +Let tge := Genv.globalenv tprog. + +Lemma functions_translated: + forall v f, + Genv.find_funct ge v = Some f -> + Genv.find_funct tge v = Some (transf_fundef f). +Proof (@Genv.find_funct_transf _ _ _ transf_fundef prog). + +Lemma function_ptr_translated: + forall v f, + Genv.find_funct_ptr ge v = Some f -> + Genv.find_funct_ptr tge v = Some (transf_fundef f). +Proof (@Genv.find_funct_ptr_transf _ _ _ transf_fundef prog). + +Lemma symbols_preserved: + forall id, + Genv.find_symbol tge id = Genv.find_symbol ge id. +Proof (@Genv.find_symbol_transf _ _ _ transf_fundef prog). + +Lemma varinfo_preserved: + forall b, Genv.find_var_info tge b = Genv.find_var_info ge b. +Proof (@Genv.find_var_info_transf _ _ _ transf_fundef prog). + +Lemma sig_preserved: + forall f, funsig (transf_fundef f) = funsig f. +Proof. + destruct f; reflexivity. +Qed. + +Lemma find_function_translated: + forall ros rs fd, + find_function ge ros rs = Some fd -> + find_function tge ros rs = Some (transf_fundef fd). +Proof. + unfold find_function; intros. destruct ros as [r|id]. + eapply functions_translated; eauto. + rewrite symbols_preserved. destruct (Genv.find_symbol ge id); try congruence. + eapply function_ptr_translated; eauto. +Qed. + +(** Effect of an injective renaming of nodes on a CFG. *) + +Section RENUMBER. + +Variable f: PTree.t positive. + +Hypothesis f_inj: forall x1 x2 y, f!x1 = Some y -> f!x2 = Some y -> x1 = x2. + +Lemma renum_cfg_nodes: + forall c x y i, + c!x = Some i -> f!x = Some y -> (renum_cfg f c)!y = Some(renum_instr f i). +Proof. + set (P := fun (c c': code) => + forall x y i, c!x = Some i -> f!x = Some y -> c'!y = Some(renum_instr f i)). + intros c0. change (P c0 (renum_cfg f c0)). unfold renum_cfg. + apply PTree_Properties.fold_rec; unfold P; intros. + (* extensionality *) + eapply H0; eauto. rewrite H; auto. + (* base *) + rewrite PTree.gempty in H; congruence. + (* induction *) + rewrite PTree.gsspec in H2. unfold renum_node. destruct (peq x k). + inv H2. rewrite H3. apply PTree.gss. + destruct f!k as [y'|]_eqn. + rewrite PTree.gso. eauto. red; intros; subst y'. elim n. eapply f_inj; eauto. + eauto. +Qed. + +End RENUMBER. + +Definition pnum (f: function) := postorder (successors f) f.(fn_entrypoint). + +Definition reach (f: function) (pc: node) := reachable (successors f) f.(fn_entrypoint) pc. + +Lemma transf_function_at: + forall f pc i, + f.(fn_code)!pc = Some i -> + reach f pc -> + (transf_function f).(fn_code)!(renum_pc (pnum f) pc) = Some(renum_instr (pnum f) i). +Proof. + intros. + destruct (postorder_correct (successors f) f.(fn_entrypoint)) as [A B]. + fold (pnum f) in *. + unfold renum_pc. destruct (pnum f)! pc as [pc'|]_eqn. + simpl. eapply renum_cfg_nodes; eauto. + elim (B pc); auto. unfold successors. rewrite PTree.gmap1. rewrite H. simpl. congruence. +Qed. + +Ltac TR_AT := + match goal with + | [ A: (fn_code _)!_ = Some _ , B: reach _ _ |- _ ] => + generalize (transf_function_at _ _ _ A B); simpl renum_instr; intros + end. + +Lemma reach_succ: + forall f pc i s, + f.(fn_code)!pc = Some i -> In s (successors_instr i) -> + reach f pc -> reach f s. +Proof. + unfold reach; intros. econstructor; eauto. + unfold successors. rewrite PTree.gmap1. rewrite H. auto. +Qed. + +Inductive match_frames: RTL.stackframe -> RTL.stackframe -> Prop := + | match_frames_intro: forall res f sp pc rs + (REACH: reach f pc), + match_frames (Stackframe res f sp pc rs) + (Stackframe res (transf_function f) sp (renum_pc (pnum f) pc) rs). + +Inductive match_states: RTL.state -> RTL.state -> Prop := + | match_regular_states: forall stk f sp pc rs m stk' + (STACKS: list_forall2 match_frames stk stk') + (REACH: reach f pc), + match_states (State stk f sp pc rs m) + (State stk' (transf_function f) sp (renum_pc (pnum f) pc) rs m) + | match_callstates: forall stk f args m stk' + (STACKS: list_forall2 match_frames stk stk'), + match_states (Callstate stk f args m) + (Callstate stk' (transf_fundef f) args m) + | match_returnstates: forall stk v m stk' + (STACKS: list_forall2 match_frames stk stk'), + match_states (Returnstate stk v m) + (Returnstate stk' v m). + +Lemma step_simulation: + forall S1 t S2, RTL.step ge S1 t S2 -> + forall S1', match_states S1 S1' -> + exists S2', RTL.step tge S1' t S2' /\ match_states S2 S2'. +Proof. + induction 1; intros S1' MS; inv MS; try TR_AT. +(* nop *) + econstructor; split. eapply exec_Inop; eauto. + constructor; auto. eapply reach_succ; eauto. simpl; auto. +(* op *) + econstructor; split. + eapply exec_Iop; eauto. + instantiate (1 := v). rewrite <- H0. apply eval_operation_preserved. exact symbols_preserved. + constructor; auto. eapply reach_succ; eauto. simpl; auto. +(* load *) + econstructor; split. + eapply exec_Iload; eauto. + rewrite <- H0. apply eval_addressing_preserved. exact symbols_preserved. + constructor; auto. eapply reach_succ; eauto. simpl; auto. +(* store *) + econstructor; split. + eapply exec_Istore; eauto. + rewrite <- H0. apply eval_addressing_preserved. exact symbols_preserved. + constructor; auto. eapply reach_succ; eauto. simpl; auto. +(* call *) + econstructor; split. + eapply exec_Icall with (fd := transf_fundef fd); eauto. + eapply find_function_translated; eauto. + apply sig_preserved. + constructor. constructor; auto. constructor. eapply reach_succ; eauto. simpl; auto. +(* tailcall *) + econstructor; split. + eapply exec_Itailcall with (fd := transf_fundef fd); eauto. + eapply find_function_translated; eauto. + apply sig_preserved. + constructor. auto. +(* builtin *) + econstructor; split. + eapply exec_Ibuiltin; eauto. + eapply external_call_symbols_preserved; eauto. + exact symbols_preserved. exact varinfo_preserved. + constructor; auto. eapply reach_succ; eauto. simpl; auto. +(* cond *) + econstructor; split. + eapply exec_Icond; eauto. + replace (if b then renum_pc (pnum f) ifso else renum_pc (pnum f) ifnot) + with (renum_pc (pnum f) (if b then ifso else ifnot)). + constructor; auto. eapply reach_succ; eauto. simpl. destruct b; auto. + destruct b; auto. +(* jumptbl *) + econstructor; split. + eapply exec_Ijumptable; eauto. rewrite list_nth_z_map. rewrite H1. simpl; eauto. + constructor; auto. eapply reach_succ; eauto. simpl. eapply list_nth_z_in; eauto. +(* return *) + econstructor; split. + eapply exec_Ireturn; eauto. + constructor; auto. +(* internal function *) + simpl. econstructor; split. + eapply exec_function_internal; eauto. + constructor; auto. unfold reach. constructor. +(* external function *) + econstructor; split. + eapply exec_function_external; eauto. + eapply external_call_symbols_preserved; eauto. + exact symbols_preserved. exact varinfo_preserved. + constructor; auto. +(* return *) + inv STACKS. inv H1. + econstructor; split. + eapply exec_return; eauto. + constructor; auto. +Qed. + +Lemma transf_initial_states: + forall S1, RTL.initial_state prog S1 -> + exists S2, RTL.initial_state tprog S2 /\ match_states S1 S2. +Proof. + intros. inv H. econstructor; split. + econstructor. + eapply Genv.init_mem_transf; eauto. + simpl. rewrite symbols_preserved. eauto. + eapply function_ptr_translated; eauto. + rewrite <- H3; apply sig_preserved. + constructor. constructor. +Qed. + +Lemma transf_final_states: + forall S1 S2 r, match_states S1 S2 -> RTL.final_state S1 r -> RTL.final_state S2 r. +Proof. + intros. inv H0. inv H. inv STACKS. constructor. +Qed. + +Theorem transf_program_correct: + forward_simulation (RTL.semantics prog) (RTL.semantics tprog). +Proof. + eapply forward_simulation_step. + eexact symbols_preserved. + eexact transf_initial_states. + eexact transf_final_states. + exact step_simulation. +Qed. + +End PRESERVATION. + + + + + + + diff --git a/backend/Selection.v b/backend/Selection.v index ef627d7..11654f1 100644 --- a/backend/Selection.v +++ b/backend/Selection.v @@ -171,7 +171,13 @@ Fixpoint sel_exprlist (al: list Cminor.expr) : exprlist := | a :: bl => Econs (sel_expr a) (sel_exprlist bl) end. -(** Recognition of calls to built-in functions that should be inlined *) +(** Recognition of immediate calls and calls to built-in functions + that should be inlined *) + +Inductive call_kind : Type := + | Call_default + | Call_imm (id: ident) + | Call_builtin (ef: external_function). Definition expr_is_addrof_ident (e: Cminor.expr) : option ident := match e with @@ -180,16 +186,16 @@ Definition expr_is_addrof_ident (e: Cminor.expr) : option ident := | _ => None end. -Definition expr_is_addrof_builtin (ge: Cminor.genv) (e: Cminor.expr) : option external_function := +Definition classify_call (ge: Cminor.genv) (e: Cminor.expr) : call_kind := match expr_is_addrof_ident e with - | None => None + | None => Call_default | Some id => match Genv.find_symbol ge id with - | None => None + | None => Call_imm id | Some b => match Genv.find_funct_ptr ge b with - | Some(External ef) => if ef_inline ef then Some ef else None - | _ => None + | Some(External ef) => if ef_inline ef then Call_builtin ef else Call_imm id + | _ => Call_imm id end end end. @@ -202,14 +208,18 @@ Fixpoint sel_stmt (ge: Cminor.genv) (s: Cminor.stmt) : stmt := | Cminor.Sassign id e => Sassign id (sel_expr e) | Cminor.Sstore chunk addr rhs => store chunk (sel_expr addr) (sel_expr rhs) | Cminor.Scall optid sg fn args => - match expr_is_addrof_builtin ge fn with - | None => Scall optid sg (sel_expr fn) (sel_exprlist args) - | Some ef => Sbuiltin optid ef (sel_exprlist args) + match classify_call ge fn with + | Call_default => Scall optid sg (inl _ (sel_expr fn)) (sel_exprlist args) + | Call_imm id => Scall optid sg (inr _ id) (sel_exprlist args) + | Call_builtin ef => Sbuiltin optid ef (sel_exprlist args) end | Cminor.Sbuiltin optid ef args => Sbuiltin optid ef (sel_exprlist args) | Cminor.Stailcall sg fn args => - Stailcall sg (sel_expr fn) (sel_exprlist args) + match classify_call ge fn with + | Call_imm id => Stailcall sg (inr _ id) (sel_exprlist args) + | _ => Stailcall sg (inl _ (sel_expr fn)) (sel_exprlist args) + end | Cminor.Sseq s1 s2 => Sseq (sel_stmt ge s1) (sel_stmt ge s2) | Cminor.Sifthenelse e ifso ifnot => Sifthenelse (condexpr_of_expr (sel_expr e)) diff --git a/backend/Selectionproof.v b/backend/Selectionproof.v index 2a0efd5..4e67181 100644 --- a/backend/Selectionproof.v +++ b/backend/Selectionproof.v @@ -270,21 +270,27 @@ Proof. predSpec Int.eq Int.eq_spec i0 Int.zero; congruence. Qed. -Lemma expr_is_addrof_builtin_correct: - forall ge sp e m a v ef fd, - expr_is_addrof_builtin ge a = Some ef -> +Lemma classify_call_correct: + forall ge sp e m a v fd, Cminor.eval_expr ge sp e m a v -> Genv.find_funct ge v = Some fd -> - fd = External ef. + match classify_call ge a with + | Call_default => True + | Call_imm id => exists b, Genv.find_symbol ge id = Some b /\ v = Vptr b Int.zero + | Call_builtin ef => fd = External ef + end. Proof. - intros until fd; unfold expr_is_addrof_builtin. - case_eq (expr_is_addrof_ident a); intros; try congruence. - exploit expr_is_addrof_ident_correct; eauto. intro EQ; subst a. - inv H1. inv H4. - destruct (Genv.find_symbol ge i); try congruence. - rewrite Genv.find_funct_find_funct_ptr in H2. rewrite H2 in H0. - destruct fd; try congruence. - destruct (ef_inline e0); congruence. + unfold classify_call; intros. + destruct (expr_is_addrof_ident a) as [id|]_eqn. + exploit expr_is_addrof_ident_correct; eauto. intros EQ; subst a. + inv H. inv H2. + destruct (Genv.find_symbol ge id) as [b|]_eqn. + rewrite Genv.find_funct_find_funct_ptr in H0. + rewrite H0. + destruct fd. exists b; auto. + destruct (ef_inline e0). auto. exists b; auto. + simpl in H0. discriminate. + auto. Qed. (** Compatibility of evaluation functions with the "less defined than" relation. *) @@ -539,7 +545,9 @@ Proof. (* store *) unfold store. destruct (addressing m (sel_expr e)); simpl; auto. (* call *) - destruct (expr_is_addrof_builtin ge e); simpl; auto. + destruct (classify_call ge e); simpl; auto. +(* tailcall *) + destruct (classify_call ge e); simpl; auto. (* seq *) exploit (IHs1 (Cminor.Kseq s2 k)). constructor; eauto. destruct (Cminor.find_label lbl s1 (Cminor.Kseq s2 k)) as [[sx kx] | ]; @@ -598,27 +606,38 @@ Proof. eapply eval_store; eauto. constructor; auto. (* Scall *) - exploit sel_expr_correct; eauto. intros [vf' [A B]]. exploit sel_exprlist_correct; eauto. intros [vargs' [C D]]. - destruct (expr_is_addrof_builtin ge a) as [ef|]_eqn. - (* Scall turned into Sbuiltin *) - exploit expr_is_addrof_builtin_correct; eauto. intro EQ1. subst fd. - right; split. omega. split. auto. - econstructor; eauto. - (* Scall preserved *) + exploit classify_call_correct; eauto. + destruct (classify_call ge a) as [ | id | ef]. + (* indirect *) + exploit sel_expr_correct; eauto. intros [vf' [A B]]. left; econstructor; split. - econstructor; eauto. + econstructor; eauto. econstructor; eauto. eapply functions_translated; eauto. apply sig_function_translated. constructor; auto. constructor; auto. + (* direct *) + intros [b [U V]]. + left; econstructor; split. + econstructor; eauto. econstructor; eauto. rewrite symbols_preserved; eauto. + eapply functions_translated; eauto. subst vf; auto. + apply sig_function_translated. + constructor; auto. constructor; auto. + (* turned into Sbuiltin *) + intros EQ. subst fd. + right; split. omega. split. auto. + econstructor; eauto. (* Stailcall *) exploit Mem.free_parallel_extends; eauto. intros [m2' [P Q]]. exploit sel_expr_correct; eauto. intros [vf' [A B]]. exploit sel_exprlist_correct; eauto. intros [vargs' [C D]]. left; econstructor; split. - econstructor; eauto. - eapply functions_translated; eauto. - apply sig_function_translated. + exploit classify_call_correct; eauto. + destruct (classify_call ge a) as [ | id | ef]; intros. + econstructor; eauto. econstructor; eauto. eapply functions_translated; eauto. apply sig_function_translated. + destruct H2 as [b [U V]]. + econstructor; eauto. econstructor; eauto. rewrite symbols_preserved; eauto. eapply functions_translated; eauto. subst vf; auto. apply sig_function_translated. + econstructor; eauto. econstructor; eauto. eapply functions_translated; eauto. apply sig_function_translated. constructor; auto. apply call_cont_commut; auto. (* Sbuiltin *) exploit sel_exprlist_correct; eauto. intros [vargs' [P Q]]. diff --git a/backend/Stackingproof.v b/backend/Stackingproof.v index 2ec14aa..be5e4b9 100644 --- a/backend/Stackingproof.v +++ b/backend/Stackingproof.v @@ -423,13 +423,13 @@ Definition frame_perm_freeable (m: mem) (sp: block): Prop := forall ofs, 0 <= ofs < fe.(fe_size) -> ofs < fe.(fe_stack_data) \/ fe.(fe_stack_data) + f.(Linear.fn_stacksize) <= ofs -> - Mem.perm m sp ofs Freeable. + Mem.perm m sp ofs Cur Freeable. Lemma offset_of_index_perm: forall m sp idx, index_valid idx -> frame_perm_freeable m sp -> - Mem.range_perm m sp (offset_of_index fe idx) (offset_of_index fe idx + AST.typesize (type_of_index idx)) Freeable. + Mem.range_perm m sp (offset_of_index fe idx) (offset_of_index fe idx + AST.typesize (type_of_index idx)) Cur Freeable. Proof. intros. exploit offset_of_index_valid; eauto. intros [A B]. @@ -612,7 +612,7 @@ Record agree_frame (j: meminj) (ls ls0: locset) (** Bounds of the Linear stack data block *) agree_bounds: - Mem.bounds m sp = (0, f.(Linear.fn_stacksize)); + forall ofs p, Mem.perm m sp ofs Max p -> 0 <= ofs < f.(Linear.fn_stacksize); (** Permissions on the frame part of the Mach stack block *) agree_perm: @@ -928,16 +928,16 @@ Lemma agree_frame_invariant: forall j ls ls0 m sp m' sp' parent retaddr m1 m1', agree_frame j ls ls0 m sp m' sp' parent retaddr -> (Mem.valid_block m sp -> Mem.valid_block m1 sp) -> - (Mem.bounds m1 sp = Mem.bounds m sp) -> + (forall ofs p, Mem.perm m1 sp ofs Max p -> Mem.perm m sp ofs Max p) -> (Mem.valid_block m' sp' -> Mem.valid_block m1' sp') -> (forall chunk ofs v, ofs + size_chunk chunk <= fe.(fe_stack_data) \/ fe.(fe_stack_data) + f.(Linear.fn_stacksize) <= ofs -> Mem.load chunk m' sp' ofs = Some v -> Mem.load chunk m1' sp' ofs = Some v) -> - (forall ofs p, + (forall ofs k p, ofs < fe.(fe_stack_data) \/ fe.(fe_stack_data) + f.(Linear.fn_stacksize) <= ofs -> - Mem.perm m' sp' ofs p -> Mem.perm m1' sp' ofs p) -> + Mem.perm m' sp' ofs k p -> Mem.perm m1' sp' ofs k p) -> agree_frame j ls ls0 m1 sp m1' sp' parent retaddr. Proof. intros. @@ -950,7 +950,7 @@ Proof. index_contains_inj j m' sp' idx v -> index_contains_inj j m1' sp' idx v). intros. destruct H5 as [v' [A B]]. exists v'; split; auto. inv H; constructor; auto; intros. - rewrite H1; auto. + eauto. red; intros. apply H4; auto. Qed. @@ -960,7 +960,7 @@ Lemma agree_frame_extcall_invariant: forall j ls ls0 m sp m' sp' parent retaddr m1 m1', agree_frame j ls ls0 m sp m' sp' parent retaddr -> (Mem.valid_block m sp -> Mem.valid_block m1 sp) -> - (Mem.bounds m1 sp = Mem.bounds m sp) -> + (forall ofs p, Mem.perm m1 sp ofs Max p -> Mem.perm m sp ofs Max p) -> (Mem.valid_block m' sp' -> Mem.valid_block m1' sp') -> mem_unchanged_on (loc_out_of_reach j m) m' m1' -> agree_frame j ls ls0 m1 sp m1' sp' parent retaddr. @@ -970,7 +970,7 @@ Proof. ofs < fe.(fe_stack_data) \/ fe.(fe_stack_data) + f.(Linear.fn_stacksize) <= ofs -> loc_out_of_reach j m sp' ofs). intros; red; intros. exploit agree_inj_unique; eauto. intros [EQ1 EQ2]; subst. - rewrite (agree_bounds _ _ _ _ _ _ _ _ _ H). unfold fst, snd. omega. + red; intros. exploit agree_bounds; eauto. omega. eapply agree_frame_invariant; eauto. intros. apply H3. intros. apply REACH. omega. auto. intros. apply H3; auto. @@ -992,17 +992,23 @@ Opaque Int.add. inv VINJ; simpl in *; try discriminate. eapply agree_frame_invariant; eauto. eauto with mem. - eapply Mem.bounds_store; eauto. + eauto with mem. eauto with mem. intros. rewrite <- H1. eapply Mem.load_store_other; eauto. destruct (zeq sp' b2); auto. subst b2. right. exploit agree_inj_unique; eauto. intros [P Q]. subst b1 delta. exploit Mem.store_valid_access_3. eexact STORE1. intros [A B]. - exploit Mem.range_perm_in_bounds. eexact A. generalize (size_chunk_pos chunk); omega. - rewrite (agree_bounds _ _ _ _ _ _ _ _ _ AG). unfold fst,snd. intros [C D]. - rewrite shifted_stack_offset_no_overflow. omega. - generalize (size_chunk_pos chunk); omega. + rewrite shifted_stack_offset_no_overflow. + exploit agree_bounds. eauto. apply Mem.perm_cur_max. apply A. + instantiate (1 := Int.unsigned ofs1). generalize (size_chunk_pos chunk). omega. + intros C. + exploit agree_bounds. eauto. apply Mem.perm_cur_max. apply A. + instantiate (1 := Int.unsigned ofs1 + size_chunk chunk - 1). generalize (size_chunk_pos chunk). omega. + intros D. + omega. + eapply agree_bounds. eauto. apply Mem.perm_cur_max. apply A. + generalize (size_chunk_pos chunk). omega. intros; eauto with mem. Qed. @@ -1325,7 +1331,7 @@ Qed. Lemma stores_in_frame_inject: forall j sp sp' m, (forall b delta, j b = Some(sp', delta) -> b = sp /\ delta = fe.(fe_stack_data)) -> - Mem.bounds m sp = (0, f.(Linear.fn_stacksize)) -> + (forall ofs k p, Mem.perm m sp ofs k p -> 0 <= ofs < f.(Linear.fn_stacksize)) -> forall m1 m2, stores_in_frame sp' m1 m2 -> Mem.inject j m m1 -> Mem.inject j m m2. Proof. induction 3; intros. @@ -1333,7 +1339,7 @@ Proof. apply IHstores_in_frame. intros. eapply Mem.store_outside_inject; eauto. intros. exploit H; eauto. intros [A B]; subst. - rewrite H0; unfold fst, snd. omega. + exploit H0; eauto. omega. Qed. Lemma stores_in_frame_valid: @@ -1343,7 +1349,7 @@ Proof. Qed. Lemma stores_in_frame_perm: - forall b ofs p sp m m', stores_in_frame sp m m' -> Mem.perm m b ofs p -> Mem.perm m' b ofs p. + forall b ofs k p sp m m', stores_in_frame sp m m' -> Mem.perm m b ofs k p -> Mem.perm m' b ofs k p. Proof. induction 1; intros. auto. apply IHstores_in_frame. eauto with mem. Qed. @@ -1396,8 +1402,9 @@ Proof. instantiate (1 := sp'). eauto with mem. instantiate (1 := fe_stack_data fe). generalize stack_data_offset_valid (bound_stack_data_pos b) size_no_overflow; omega. - right. rewrite (Mem.bounds_alloc_same _ _ _ _ _ ALLOC'). unfold fst, snd. - split. omega. apply size_no_overflow. + intros; right. + exploit Mem.perm_alloc_inv. eexact ALLOC'. eauto. rewrite zeq_true. + generalize size_no_overflow. omega. intros. apply Mem.perm_implies with Freeable; auto with mem. eapply Mem.perm_alloc_2; eauto. generalize stack_data_offset_valid bound_stack_data_stacksize; omega. @@ -1495,7 +1502,7 @@ Proof. (* valid sp' *) eapply stores_in_frame_valid with (m := m2'); eauto with mem. (* bounds *) - eapply Mem.bounds_alloc_same; eauto. + exploit Mem.perm_alloc_inv. eexact ALLOC. eauto. rewrite zeq_true. auto. (* perms *) auto. (* wt *) @@ -1506,7 +1513,7 @@ Proof. split. eapply inject_alloc_separated; eauto with mem. (* inject *) split. eapply stores_in_frame_inject; eauto. - eapply Mem.bounds_alloc_same; eauto. + intros. exploit Mem.perm_alloc_inv. eexact ALLOC. eauto. rewrite zeq_true. auto. (* stores in frame *) auto. Qed. @@ -1690,8 +1697,7 @@ Proof. simpl. rewrite H2. auto. intros. exploit agree_inj_unique; eauto. intros [P Q]; subst b1 delta. exists 0; exists (Linear.fn_stacksize f); split. auto with coqlib. - exploit Mem.perm_in_bounds; eauto. - rewrite (agree_bounds _ _ _ _ _ _ _ _ _ H0). auto. + eapply agree_bounds. eauto. eapply Mem.perm_max. eauto. (* can execute epilogue *) exploit restore_callee_save_correct; eauto. instantiate (1 := rs). red; intros. @@ -1775,7 +1781,7 @@ Lemma match_stacks_change_linear_mem: forall j m1 m2 m' cs cs' sg bound bound', match_stacks j m1 m' cs cs' sg bound bound' -> (forall b, b < bound -> Mem.valid_block m1 b -> Mem.valid_block m2 b) -> - (forall b, b < bound -> Mem.bounds m2 b = Mem.bounds m1 b) -> + (forall b ofs p, b < bound -> Mem.perm m2 b ofs Max p -> Mem.perm m1 b ofs Max p) -> match_stacks j m2 m' cs cs' sg bound bound'. Proof. induction 1; intros. @@ -1784,7 +1790,7 @@ Proof. eapply agree_frame_invariant; eauto. apply IHmatch_stacks. intros. apply H0; auto. omega. - intros. apply H1. omega. + intros. apply H1. omega. auto. Qed. (** Invariance with respect to change of [m']. *) @@ -1793,7 +1799,7 @@ Lemma match_stacks_change_mach_mem: forall j m m1' m2' cs cs' sg bound bound', match_stacks j m m1' cs cs' sg bound bound' -> (forall b, b < bound' -> Mem.valid_block m1' b -> Mem.valid_block m2' b) -> - (forall b ofs p, b < bound' -> Mem.perm m1' b ofs p -> Mem.perm m2' b ofs p) -> + (forall b ofs k p, b < bound' -> Mem.perm m1' b ofs k p -> Mem.perm m2' b ofs k p) -> (forall chunk b ofs v, b < bound' -> Mem.load chunk m1' b ofs = Some v -> Mem.load chunk m2' b ofs = Some v) -> match_stacks j m m2' cs cs' sg bound bound'. Proof. @@ -1813,7 +1819,7 @@ Lemma match_stacks_change_mem_extcall: forall j m1 m2 m1' m2' cs cs' sg bound bound', match_stacks j m1 m1' cs cs' sg bound bound' -> (forall b, b < bound -> Mem.valid_block m1 b -> Mem.valid_block m2 b) -> - (forall b, b < bound -> Mem.bounds m2 b = Mem.bounds m1 b) -> + (forall b ofs p, b < bound -> Mem.perm m2 b ofs Max p -> Mem.perm m1 b ofs Max p) -> (forall b, b < bound' -> Mem.valid_block m1' b -> Mem.valid_block m2' b) -> mem_unchanged_on (loc_out_of_reach j m1) m1' m2' -> match_stacks j m2 m2' cs cs' sg bound bound'. @@ -1824,7 +1830,7 @@ Proof. eapply agree_frame_extcall_invariant; eauto. apply IHmatch_stacks. intros; apply H0; auto; omega. - intros; apply H1; omega. + intros; apply H1. omega. auto. intros; apply H2; auto; omega. auto. Qed. @@ -1888,7 +1894,7 @@ Proof. eapply match_stacks_change_meminj; eauto. eapply match_stacks_change_mem_extcall; eauto. intros; eapply external_call_valid_block; eauto. - intros; eapply external_call_bounds; eauto. red; omega. + intros; eapply external_call_max_perm; eauto. red; omega. intros; eapply external_call_valid_block; eauto. Qed. @@ -2435,9 +2441,9 @@ Proof. econstructor; eauto with coqlib. eapply Mem.store_outside_inject; eauto. intros. exploit agree_inj_unique; eauto. intros [EQ1 EQ2]; subst b' delta. - rewrite (agree_bounds _ _ _ _ _ _ _ _ _ _ AGFRAME). unfold fst, snd. rewrite Zplus_0_l. - rewrite size_type_chunk. + rewrite size_type_chunk in H5. exploit offset_of_index_disj_stack_data_2; eauto. + exploit agree_bounds. eauto. apply Mem.perm_cur_max. eauto. omega. apply match_stacks_change_mach_mem with m'; auto. eauto with mem. eauto with mem. intros. rewrite <- H4; eapply Mem.load_store_other; eauto. left; unfold block; omega. @@ -2546,7 +2552,7 @@ Proof. auto. eauto with mem. intros. eapply Mem.perm_free_1; eauto. left; unfold block; omega. intros. rewrite <- H2. eapply Mem.load_free; eauto. left; unfold block; omega. - eauto with mem. intros. eapply Mem.bounds_free; eauto. + eauto with mem. intros. eapply Mem.perm_free_3; eauto. apply Zlt_le_weak. change (Mem.valid_block m' stk). eapply Mem.valid_block_free_1; eauto. eapply agree_valid_linear; eauto. apply Zlt_le_weak. change (Mem.valid_block m1' sp'). eapply Mem.valid_block_free_1; eauto. eapply agree_valid_mach; eauto. eapply find_function_well_typed; eauto. @@ -2570,7 +2576,7 @@ Proof. eapply agree_frame_inject_incr; eauto. apply agree_frame_extcall_invariant with m m'0; auto. eapply external_call_valid_block; eauto. - eapply external_call_bounds; eauto. eapply agree_valid_linear; eauto. + intros. eapply external_call_max_perm; eauto. eapply agree_valid_linear; eauto. eapply external_call_valid_block; eauto. eapply agree_valid_mach; eauto. inv WTI. simpl; rewrite H4. eapply external_call_well_typed; eauto. @@ -2594,7 +2600,7 @@ Proof. eapply agree_frame_inject_incr; eauto. apply agree_frame_extcall_invariant with m m'0; auto. eapply external_call_valid_block; eauto. - eapply external_call_bounds; eauto. eapply agree_valid_linear; eauto. + intros. eapply external_call_max_perm; eauto. eapply agree_valid_linear; eauto. eapply external_call_valid_block; eauto. eapply agree_valid_mach; eauto. @@ -2652,7 +2658,7 @@ Proof. eauto. eauto with mem. intros. eapply Mem.perm_free_1; eauto. left; unfold block; omega. intros. rewrite <- H1. eapply Mem.load_free; eauto. left; unfold block; omega. - eauto with mem. intros. eapply Mem.bounds_free; eauto. + eauto with mem. intros. eapply Mem.perm_free_3; eauto. apply Zlt_le_weak. change (Mem.valid_block m' stk). eapply Mem.valid_block_free_1; eauto. eapply agree_valid_linear; eauto. apply Zlt_le_weak. change (Mem.valid_block m1' sp'). eapply Mem.valid_block_free_1; eauto. eapply agree_valid_mach; eauto. apply wt_return_regs; auto. eapply match_stacks_wt_locset; eauto. eapply agree_wt_ls; eauto. @@ -2677,7 +2683,8 @@ Proof. apply match_stacks_change_linear_mem with m. rewrite SP_EQ; rewrite SP'_EQ. eapply match_stacks_change_meminj; eauto. omega. - eauto with mem. intros. eapply Mem.bounds_alloc_other; eauto. unfold block; omega. + eauto with mem. intros. exploit Mem.perm_alloc_inv. eexact H. eauto. + rewrite zeq_false. auto. omega. intros. eapply stores_in_frame_valid; eauto with mem. intros. eapply stores_in_frame_perm; eauto with mem. intros. rewrite <- H1. transitivity (Mem.load chunk m2' b ofs). eapply stores_in_frame_contents; eauto. diff --git a/backend/Unusedglob.ml b/backend/Unusedglob.ml new file mode 100644 index 0000000..4139678 --- /dev/null +++ b/backend/Unusedglob.ml @@ -0,0 +1,91 @@ +(* *********************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Xavier Leroy, INRIA Paris-Rocquencourt *) +(* *) +(* 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. *) +(* *) +(* *********************************************************************) + +(* Removing unused definitions of static functions and global variables *) + +open Camlcoq +open Maps +open AST +open Asm +open Unusedglob1 + +module IdentSet = Set.Make(struct type t = ident let compare = compare end) + +(* The set of globals referenced from a function definition *) + +let add_referenced_instr rf i = + List.fold_right IdentSet.add (referenced_instr i) rf + +let referenced_function f = + List.fold_left add_referenced_instr IdentSet.empty (code_of_function f) + +let referenced_fundef = function + | Internal f -> referenced_function f + | External ef -> IdentSet.empty + +(* The set of globals referenced from a variable definition (initialization) *) + +let add_referenced_init_data rf = function + | Init_addrof(id, ofs) -> IdentSet.add id rf + | _ -> rf + +let referenced_globvar gv = + List.fold_left add_referenced_init_data IdentSet.empty gv.gvar_init + +(* The map global |-> set of globals it references *) + +let use_map p = + List.fold_left (fun m (id, gv) -> PTree.set id (referenced_globvar gv) m) + (List.fold_left (fun m (id, fd) -> PTree.set id (referenced_fundef fd) m) + PTree.empty p.prog_funct) p.prog_vars + +(* Worklist algorithm computing the set of used globals *) + +let rec used_idents usemap used wrk = + match wrk with + | [] -> used + | id :: wrk -> + if IdentSet.mem id used then used_idents usemap used wrk else + match PTree.get id usemap with + | None -> used_idents usemap used wrk + | Some s -> used_idents usemap (IdentSet.add id used) + (IdentSet.fold (fun id l -> id::l) s wrk) + +(* The worklist is initially populated with all nonstatic globals *) + +let add_nonstatic wrk id = + if C2C.atom_is_static id then wrk else id :: wrk + +let initial_worklist p = + List.fold_left (fun wrk (id, gv) -> add_nonstatic wrk id) + (List.fold_left (fun wrk (id, fd) -> add_nonstatic wrk id) + [] p.prog_funct) p.prog_vars + +(* Eliminate unused definitions *) + +let rec filter used = function + | [] -> [] + | (id, def) :: rem -> + if IdentSet.mem id used + then (id, def) :: filter used rem + else filter used rem + +let filter_prog used p = + { prog_funct = filter used p.prog_funct; + prog_main = p.prog_main; + prog_vars = filter used p.prog_vars } + +(* Entry point *) + +let transf_program p = + filter_prog (used_idents (use_map p) IdentSet.empty (initial_worklist p)) p + diff --git a/cfrontend/C2C.ml b/cfrontend/C2C.ml index 508c414..0d29a23 100644 --- a/cfrontend/C2C.ml +++ b/cfrontend/C2C.ml @@ -956,3 +956,9 @@ let atom_is_small_data a ofs = (Hashtbl.find decl_atom a).a_small_data with Not_found -> false + +let atom_is_inline a = + try + (Hashtbl.find decl_atom a).a_inline + with Not_found -> + false diff --git a/cfrontend/Cminorgenproof.v b/cfrontend/Cminorgenproof.v index 1a66ec9..f94e081 100644 --- a/cfrontend/Cminorgenproof.v +++ b/cfrontend/Cminorgenproof.v @@ -150,10 +150,10 @@ Proof. Qed. Lemma perm_freelist: - forall fbl m m' b ofs p, + forall fbl m m' b ofs k p, Mem.free_list m fbl = Some m' -> - Mem.perm m' b ofs p -> - Mem.perm m b ofs p. + Mem.perm m' b ofs k p -> + Mem.perm m b ofs k p. Proof. induction fbl; simpl; intros until p. congruence. @@ -177,7 +177,7 @@ Lemma free_list_freeable: forall l m m', Mem.free_list m l = Some m' -> forall b lo hi, - In (b, lo, hi) l -> Mem.range_perm m b lo hi Freeable. + In (b, lo, hi) l -> Mem.range_perm m b lo hi Cur Freeable. Proof. induction l; simpl; intros. contradiction. @@ -189,18 +189,6 @@ Proof. red; intros. eapply Mem.perm_free_3; eauto. exploit IHl; eauto. Qed. -Lemma bounds_freelist: - forall b l m m', - Mem.free_list m l = Some m' -> Mem.bounds m' b = Mem.bounds m b. -Proof. - induction l; simpl; intros. - inv H; auto. - revert H. destruct a as [[b' lo'] hi']. - caseEq (Mem.free m b' lo' hi'); try congruence. - intros m1 FREE1 FREE2. - transitivity (Mem.bounds m1 b). eauto. eapply Mem.bounds_free; eauto. -Qed. - Lemma nextblock_storev: forall chunk m addr v m', Mem.storev chunk m addr v = Some m' -> Mem.nextblock m' = Mem.nextblock m. @@ -324,8 +312,8 @@ Record match_env (f: meminj) (cenv: compilenv) (** The sizes of blocks appearing in [e] agree with their types *) me_bounds: - forall id b lv, - PTree.get id e = Some(b, lv) -> Mem.bounds m b = (0, sizeof lv) + forall id b lv ofs p, + PTree.get id e = Some(b, lv) -> Mem.perm m b ofs Max p -> 0 <= ofs < sizeof lv }. Hint Resolve me_low_high. @@ -351,7 +339,7 @@ Proof. rewrite <- H4. eapply Mem.load_store_other; eauto. left. congruence. (* bounds *) - intros. rewrite (Mem.bounds_store _ _ _ _ _ _ H0). eauto. + intros. eauto with mem. Qed. (** Preservation by assignment to a Csharpminor variable that is @@ -403,7 +391,7 @@ Proof. (* temps *) intros. rewrite PTree.gso. auto. unfold for_temp, for_var; congruence. (* bounds *) - intros. rewrite (Mem.bounds_store _ _ _ _ _ _ H2). eauto. + intros. eauto with mem. Qed. (** Preservation by assignment to a Csharpminor temporary and the @@ -442,16 +430,14 @@ Lemma match_env_invariant: (forall b ofs chunk v, lo <= b < hi -> Mem.load chunk m1 b ofs = Some v -> Mem.load chunk m2 b ofs = Some v) -> - (forall b, - lo <= b < hi -> Mem.bounds m2 b = Mem.bounds m1 b) -> + (forall b ofs p, + lo <= b < hi -> Mem.perm m2 b ofs Max p -> Mem.perm m1 b ofs Max p) -> match_env f cenv e le m1 te sp lo hi -> match_env f cenv e le m2 te sp lo hi. Proof. intros. inv H1. constructor; eauto. (* vars *) intros. geninv (me_vars0 id); econstructor; eauto. - (* bounds *) - intros. rewrite H0. eauto. eauto. Qed. (** [match_env] is insensitive to the Cminor values of stack-allocated data. *) @@ -551,10 +537,10 @@ Proof. exploit Mem.alloc_result; eauto. unfold block; omega. (* bounds *) intros. rewrite PTree.gsspec in H. - rewrite (Mem.bounds_alloc _ _ _ _ _ ALLOC). + exploit Mem.perm_alloc_inv. eexact ALLOC. eauto. destruct (peq id0 id). - inv H. apply dec_eq_true. - rewrite dec_eq_false. eauto. + inv H. rewrite zeq_true. auto. + rewrite zeq_false. eauto. apply Mem.valid_not_valid_diff with m1. exploit me_bounded0; eauto. intros [A B]. auto. eauto with mem. @@ -599,7 +585,8 @@ Proof. intros. eapply me_incr0; eauto. rewrite <- OTHER; eauto. exploit Mem.alloc_result; eauto. unfold block in *; omega. (* bounds *) - intros. rewrite (Mem.bounds_alloc_other _ _ _ _ _ ALLOC). eauto. + intros. exploit Mem.perm_alloc_inv. eexact ALLOC. eauto. + rewrite zeq_false. eauto. exploit me_bounded0; eauto. Qed. @@ -634,7 +621,7 @@ Lemma match_env_external_call: mem_unchanged_on (loc_unmapped f1) m1 m2 -> inject_incr f1 f2 -> inject_separated f1 f2 m1 m1' -> - (forall b, Mem.valid_block m1 b -> Mem.bounds m2 b = Mem.bounds m1 b) -> + (forall b ofs p, Mem.valid_block m1 b -> Mem.perm m2 b ofs Max p -> Mem.perm m1 b ofs Max p) -> hi <= Mem.nextblock m1 -> sp < Mem.nextblock m1' -> match_env f2 cenv e le m2 te sp lo hi. Proof. @@ -661,7 +648,7 @@ Proof. instantiate (1 := b). red; omega. intros. apply me_incr0 with b delta. congruence. auto. (* bounds *) - intros. rewrite BOUNDS; eauto. + intros. eapply me_bounds0; eauto. eapply BOUNDS; eauto. red. exploit me_bounded0; eauto. omega. Qed. @@ -704,13 +691,12 @@ Inductive match_globalenvs (f: meminj) (bound: Z): Prop := that are not images of C#minor local variable blocks. *) -Definition padding_freeable (f: meminj) (m: mem) (tm: mem) (sp: block) (sz: Z) : Prop := +Definition padding_freeable (f: meminj) (e: Csharpminor.env) (tm: mem) (sp: block) (sz: Z) : Prop := forall ofs, 0 <= ofs < sz -> - Mem.perm tm sp ofs Freeable - \/ exists b, exists delta, - f b = Some(sp, delta) - /\ Mem.low_bound m b + delta <= ofs < Mem.high_bound m b + delta. + Mem.perm tm sp ofs Cur Freeable + \/ exists id, exists b, exists lv, exists delta, + e!id = Some(b, lv) /\ f b = Some(sp, delta) /\ delta <= ofs < delta + sizeof lv. Inductive match_callstack (f: meminj) (m: mem) (tm: mem): callstack -> Z -> Z -> Prop := @@ -724,7 +710,7 @@ Inductive match_callstack (f: meminj) (m: mem) (tm: mem): (BOUND: hi <= bound) (TBOUND: sp < tbound) (MENV: match_env f cenv e le m te sp lo hi) - (PERM: padding_freeable f m tm sp tf.(fn_stackspace)) + (PERM: padding_freeable f e tm sp tf.(fn_stackspace)) (MCS: match_callstack f m tm cs lo sp), match_callstack f m tm (Frame cenv tf e le te sp lo hi :: cs) bound tbound. @@ -742,22 +728,20 @@ Qed. generalize those for [match_env]. *) Lemma padding_freeable_invariant: - forall f1 m1 tm1 sp sz cenv e le te lo hi f2 m2 tm2, - padding_freeable f1 m1 tm1 sp sz -> + forall f1 m1 tm1 sp sz cenv e le te lo hi f2 tm2, + padding_freeable f1 e tm1 sp sz -> match_env f1 cenv e le m1 te sp lo hi -> - (forall ofs, Mem.perm tm1 sp ofs Freeable -> Mem.perm tm2 sp ofs Freeable) -> - (forall b, b < hi -> Mem.bounds m2 b = Mem.bounds m1 b) -> + (forall ofs, Mem.perm tm1 sp ofs Cur Freeable -> Mem.perm tm2 sp ofs Cur Freeable) -> (forall b, b < hi -> f2 b = f1 b) -> - padding_freeable f2 m2 tm2 sp sz. + padding_freeable f2 e tm2 sp sz. Proof. intros; red; intros. - exploit H; eauto. intros [A | [b [delta [A B]]]]. + exploit H; eauto. intros [A | [id [b [lv [delta [A [B C]]]]]]]. left; auto. - exploit me_inv; eauto. intros [id [lv C]]. - exploit me_bounded; eauto. intros [D E]. - right; exists b; exists delta. split. - rewrite H3; auto. - rewrite H2; auto. + exploit me_bounded; eauto. intros [D E]. + right; exists id; exists b; exists lv; exists delta; split. + auto. + rewrite H2; auto. Qed. Lemma match_callstack_store_mapped: @@ -775,7 +759,6 @@ Proof. eapply match_env_store_mapped; eauto. congruence. eapply padding_freeable_invariant; eauto. intros; eauto with mem. - intros. eapply Mem.bounds_store; eauto. Qed. Lemma match_callstack_storev_mapped: @@ -800,21 +783,17 @@ Lemma match_callstack_invariant: hi <= bound -> match_env f cenv e le m te sp lo hi -> match_env f cenv e le m' te sp lo hi) -> - (forall b, - b < bound -> Mem.bounds m' b = Mem.bounds m b) -> - (forall b ofs p, - b < tbound -> Mem.perm tm b ofs p -> Mem.perm tm' b ofs p) -> + (forall b ofs k p, + b < tbound -> Mem.perm tm b ofs k p -> Mem.perm tm' b ofs k p) -> match_callstack f m' tm' cs bound tbound. Proof. induction 1; intros. econstructor; eauto. constructor; auto. - eapply padding_freeable_invariant; eauto. - intros. apply H1. omega. + eapply padding_freeable_invariant; eauto. eapply IHmatch_callstack; eauto. intros. eapply H0; eauto. inv MENV; omega. intros. apply H1; auto. inv MENV; omega. - intros. apply H2; auto. omega. Qed. Lemma match_callstack_store_local: @@ -828,14 +807,11 @@ Lemma match_callstack_store_local: Proof. intros. inv H3. constructor; auto. eapply match_env_store_local; eauto. - eapply padding_freeable_invariant; eauto. - intros. eapply Mem.bounds_store; eauto. eapply match_callstack_invariant; eauto. intros. apply match_env_invariant with m1; auto. intros. rewrite <- H6. eapply Mem.load_store_other; eauto. - left. inv MENV. exploit me_bounded0; eauto. unfold block in *; omega. - intros. eapply Mem.bounds_store; eauto. - intros. eapply Mem.bounds_store; eauto. + left. inv MENV. exploit me_bounded0; eauto. unfold block in *; omega. + intros. eauto with mem. Qed. (** A variant of [match_callstack_store_local] where the Cminor environment @@ -923,11 +899,9 @@ Proof. assert ({tm' | Mem.free tm sp 0 (fn_stackspace tf) = Some tm'}). apply Mem.range_perm_free. red; intros. - exploit PERM; eauto. intros [A | [b [delta [A B]]]]. + exploit PERM; eauto. intros [A | [id [b [lv [delta [A [B C]]]]]]]. auto. - exploit me_inv0; eauto. intros [id [lv C]]. - exploit me_bounds0; eauto. intro D. rewrite D in B; simpl in B. - assert (Mem.range_perm m b 0 (sizeof lv) Freeable). + assert (Mem.range_perm m b 0 (sizeof lv) Cur Freeable). eapply free_list_freeable; eauto. eapply in_blocks_of_env; eauto. replace ofs with ((ofs - delta) + delta) by omega. eapply Mem.perm_inject; eauto. apply H0. omega. @@ -943,15 +917,13 @@ Proof. intros. exploit in_blocks_of_env_inv; eauto. intros [id [lv [A [B C]]]]. exploit me_bounded0; eauto. unfold block; omega. - intros. eapply bounds_freelist; eauto. - intros. eapply bounds_freelist; eauto. + intros. eapply perm_freelist; eauto. intros. eapply Mem.perm_free_1; eauto. left; unfold block; omega. eapply Mem.free_inject; eauto. intros. exploit me_inv0; eauto. intros [id [lv A]]. exists 0; exists (sizeof lv); split. eapply in_blocks_of_env; eauto. - exploit me_bounds0; eauto. intro B. - exploit Mem.perm_in_bounds; eauto. rewrite B; simpl. auto. + eapply me_bounds0; eauto. eapply Mem.perm_max. eauto. Qed. (** Preservation of [match_callstack] by allocations. *) @@ -975,7 +947,6 @@ Proof. constructor; auto. eapply match_env_alloc_other; eauto. omega. destruct (f2 b); auto. destruct p; omega. eapply padding_freeable_invariant; eauto. - intros. eapply Mem.bounds_alloc_other; eauto. unfold block; omega. intros. apply H1. unfold block; omega. apply IHmatch_callstack. inv MENV; omega. @@ -1004,9 +975,12 @@ Proof. constructor. omega. auto. eapply match_env_alloc_same; eauto. - eapply padding_freeable_invariant; eauto. - intros. eapply Mem.bounds_alloc_other; eauto. unfold block in *; omega. - intros. apply OTHER. unfold block in *; omega. + red; intros. exploit PERM; eauto. intros [A | [id' [b' [lv' [delta' [A [B C]]]]]]]. + left; auto. + right; exists id'; exists b'; exists lv'; exists delta'. + split. rewrite PTree.gso; auto. congruence. + split. apply INCR; auto. + auto. eapply match_callstack_alloc_below; eauto. inv MENV. unfold block in *; omega. inv ACOND. auto. omega. omega. @@ -1059,43 +1033,42 @@ Qed. (** Decidability of the predicate "this is not a padding location" *) -Definition is_reachable (f: meminj) (m: mem) (sp: block) (ofs: Z) : Prop := - exists b, exists delta, - f b = Some(sp, delta) - /\ Mem.low_bound m b + delta <= ofs < Mem.high_bound m b + delta. +Definition is_reachable (f: meminj) (e: Csharpminor.env) (sp: block) (ofs: Z) : Prop := + exists id, exists b, exists lv, exists delta, + e!id = Some(b, lv) /\ f b = Some(sp, delta) /\ delta <= ofs < delta + sizeof lv. Lemma is_reachable_dec: - forall f cenv e le m te sp lo hi ofs, - match_env f cenv e le m te sp lo hi -> - {is_reachable f m sp ofs} + {~is_reachable f m sp ofs}. + forall f e sp ofs, is_reachable f e sp ofs \/ ~is_reachable f e sp ofs. Proof. - intros. - set (P := fun (b: block) => - match f b with - | None => False - | Some(b', delta) => - b' = sp /\ Mem.low_bound m b + delta <= ofs < Mem.high_bound m b + delta - end). - assert ({forall b, Intv.In b (lo, hi) -> ~P b} + {exists b, Intv.In b (lo, hi) /\ P b}). - apply Intv.forall_dec. intro b. unfold P. - destruct (f b) as [[b' delta] | ]. - destruct (eq_block b' sp). - destruct (zle (Mem.low_bound m b + delta) ofs). - destruct (zlt ofs (Mem.high_bound m b + delta)). - right; auto. - left; intuition. - left; intuition. - left; intuition. - left; intuition. - inv H. destruct H0. - right; red; intros [b [delta [A [B C]]]]. - elim (n b). - exploit me_inv0; eauto. intros [id [lv D]]. exploit me_bounded0; eauto. - red. rewrite A. auto. - left. destruct e0 as [b [A B]]. red in B; revert B. - case_eq (f b). intros [b' delta] EQ [C [D E]]. subst b'. - exists b; exists delta. auto. - tauto. + intros. + set (pred := fun id_b_lv : ident * (block * var_kind) => + match id_b_lv with + | (id, (b, lv)) => + match f b with + | None => false + | Some(sp', delta) => + if eq_block sp sp' + then zle delta ofs && zlt ofs (delta + sizeof lv) + else false + end + end). + destruct (List.existsb pred (PTree.elements e)) as []_eqn. + rewrite List.existsb_exists in Heqb. + destruct Heqb as [[id [b lv]] [A B]]. + simpl in B. destruct (f b) as [[sp' delta] |]_eqn; try discriminate. + destruct (eq_block sp sp'); try discriminate. + destruct (andb_prop _ _ B). + left; red. exists id; exists b; exists lv; exists delta. + split. apply PTree.elements_complete; auto. + split. congruence. + split; eapply proj_sumbool_true; eauto. + right; red. intros [id [b [lv [delta [A [B C]]]]]]. + assert (existsb pred (PTree.elements e) = true). + rewrite List.existsb_exists. exists (id, (b, lv)); split. + apply PTree.elements_correct; auto. + simpl. rewrite B. rewrite dec_eq_true. + unfold proj_sumbool. destruct C. rewrite zle_true; auto. rewrite zlt_true; auto. + congruence. Qed. (** Preservation of [match_callstack] by external calls. *) @@ -1106,14 +1079,14 @@ Lemma match_callstack_external_call: mem_unchanged_on (loc_out_of_reach f1 m1) m1' m2' -> inject_incr f1 f2 -> inject_separated f1 f2 m1 m1' -> - (forall b, Mem.valid_block m1 b -> Mem.bounds m2 b = Mem.bounds m1 b) -> + (forall b ofs p, Mem.valid_block m1 b -> Mem.perm m2 b ofs Max p -> Mem.perm m1 b ofs Max p) -> forall cs bound tbound, match_callstack f1 m1 m1' cs bound tbound -> bound <= Mem.nextblock m1 -> tbound <= Mem.nextblock m1' -> match_callstack f2 m2 m2' cs bound tbound. Proof. intros until m2'. - intros UNMAPPED OUTOFREACH INCR SEPARATED BOUNDS. + intros UNMAPPED OUTOFREACH INCR SEPARATED MAXPERMS. destruct OUTOFREACH as [OUTOFREACH1 OUTOFREACH2]. induction 1; intros. (* base case *) @@ -1127,18 +1100,16 @@ Proof. eapply match_env_external_call; eauto. omega. omega. (* padding-freeable *) red; intros. - destruct (is_reachable_dec _ _ _ _ _ _ _ _ _ ofs MENV). - destruct i as [b [delta [A B]]]. - right; exists b; exists delta; split. - apply INCR; auto. rewrite BOUNDS. auto. - exploit me_inv; eauto. intros [id [lv C]]. - exploit me_bounded; eauto. intros. red; omega. + destruct (is_reachable_dec f1 e sp ofs). + destruct H3 as [id [b [lv [delta [A [B C]]]]]]. + right; exists id; exists b; exists lv; exists delta. + split. auto. split. apply INCR; auto. auto. exploit PERM; eauto. intros [A|A]; try contradiction. left. - apply OUTOFREACH1; auto. red; intros. - assert ((ofs < Mem.low_bound m1 b0 + delta \/ ofs >= Mem.high_bound m1 b0 + delta) - \/ Mem.low_bound m1 b0 + delta <= ofs < Mem.high_bound m1 b0 + delta) - by omega. destruct H4; auto. - elim n. exists b0; exists delta; auto. + apply OUTOFREACH1; auto. red; intros. + red; intros; elim H3. + exploit me_inv; eauto. intros [id [lv B]]. + exploit me_bounds; eauto. intros C. + red. exists id; exists b0; exists lv; exists delta. intuition omega. (* induction *) eapply IHmatch_callstack; eauto. inv MENV; omega. omega. Qed. @@ -2091,7 +2062,7 @@ Proof. split. auto. split. apply match_callstack_incr_bound with (Mem.nextblock m) (Mem.nextblock tm). eapply match_callstack_external_call; eauto. - intros. eapply external_call_bounds; eauto. + intros. eapply external_call_max_perm; eauto. omega. omega. eapply external_call_nextblock_incr; eauto. eapply external_call_nextblock_incr; eauto. @@ -2189,8 +2160,9 @@ Lemma match_callstack_alloc_variable: forall atk id lv cenv sz cenv' sz' tm sp e tf m m' b te le lo cs f tv, assign_variable atk (id, lv) (cenv, sz) = (cenv', sz') -> Mem.valid_block tm sp -> - Mem.bounds tm sp = (0, tf.(fn_stackspace)) -> - Mem.range_perm tm sp 0 tf.(fn_stackspace) Freeable -> + (forall ofs k p, + Mem.perm tm sp ofs k p -> 0 <= ofs < tf.(fn_stackspace)) -> + Mem.range_perm tm sp 0 tf.(fn_stackspace) Cur Freeable -> tf.(fn_stackspace) <= Int.max_unsigned -> Mem.alloc m 0 (sizeof lv) = (m', b) -> match_callstack f m tm @@ -2198,7 +2170,8 @@ Lemma match_callstack_alloc_variable: (Mem.nextblock m) (Mem.nextblock tm) -> Mem.inject f m tm -> 0 <= sz -> sz' <= tf.(fn_stackspace) -> - (forall b delta, f b = Some(sp, delta) -> Mem.high_bound m b + delta <= sz) -> + (forall b delta ofs k p, + f b = Some(sp, delta) -> Mem.perm m b ofs k p -> ofs + delta < sz) -> e!id = None -> te!(for_var id) = Some tv -> exists f', @@ -2207,8 +2180,8 @@ Lemma match_callstack_alloc_variable: /\ match_callstack f' m' tm (Frame cenv' tf (PTree.set id (b, lv) e) le te sp lo (Mem.nextblock m') :: cs) (Mem.nextblock m') (Mem.nextblock tm) - /\ (forall b delta, - f' b = Some(sp, delta) -> Mem.high_bound m' b + delta <= sz'). + /\ (forall b delta ofs k p, + f' b = Some(sp, delta) -> Mem.perm m' b ofs k p -> ofs + delta < sz'). Proof. intros until tv. intros ASV VALID BOUNDS PERMS NOOV ALLOC MCS INJ LO HI RANGE E TE. generalize ASV. unfold assign_variable. @@ -2222,23 +2195,22 @@ Proof. generalize (align_le sz (size_chunk chunk) SIZEPOS). fold ofs. intro SZOFS. exploit Mem.alloc_left_mapped_inject. eauto. eauto. eauto. - instantiate (1 := ofs). omega. - right; rewrite BOUNDS; simpl. omega. - intros. apply Mem.perm_implies with Freeable; auto with mem. + instantiate (1 := ofs). omega. + intros. exploit BOUNDS; eauto. omega. + intros. apply Mem.perm_implies with Freeable; auto with mem. apply Mem.perm_cur. apply PERMS. rewrite LV in H1. simpl in H1. omega. rewrite LV; simpl. rewrite Zminus_0_r. unfold ofs. apply inj_offset_aligned_var. - intros. generalize (RANGE _ _ H1). omega. + intros. generalize (RANGE _ _ _ _ _ H1 H2). omega. intros [f1 [MINJ1 [INCR1 [SAME OTHER]]]]. exists f1; split. auto. split. auto. split. eapply match_callstack_alloc_left; eauto. rewrite <- LV; auto. rewrite SAME; constructor. - intros. rewrite (Mem.bounds_alloc _ _ _ _ _ ALLOC). - destruct (eq_block b0 b); simpl. + intros. exploit Mem.perm_alloc_inv; eauto. destruct (zeq b0 b). subst b0. assert (delta = ofs) by congruence. subst delta. rewrite LV. simpl. omega. - rewrite OTHER in H1; eauto. generalize (RANGE _ _ H1). omega. + intro. rewrite OTHER in H1; eauto. generalize (RANGE _ _ _ _ _ H1 H3). omega. (* 1.2 info = Var_local chunk *) intro EQ; injection EQ; intros; clear EQ. subst sz'. rewrite <- H0. exploit Mem.alloc_left_unmapped_inject; eauto. @@ -2247,8 +2219,7 @@ Proof. eapply match_callstack_alloc_left; eauto. rewrite <- LV; auto. rewrite SAME; constructor. - intros. rewrite (Mem.bounds_alloc _ _ _ _ _ ALLOC). - destruct (eq_block b0 b); simpl. + intros. exploit Mem.perm_alloc_inv; eauto. destruct (zeq b0 b). subst b0. congruence. rewrite OTHER in H; eauto. (* 2 info = Var_stack_array ofs *) @@ -2259,29 +2230,29 @@ Proof. exploit Mem.alloc_left_mapped_inject. eauto. eauto. eauto. instantiate (1 := ofs). generalize Int.min_signed_neg. omega. - right; rewrite BOUNDS; simpl. generalize Int.min_signed_neg. omega. - intros. apply Mem.perm_implies with Freeable; auto with mem. + intros. exploit BOUNDS; eauto. generalize Int.min_signed_neg. omega. + intros. apply Mem.perm_implies with Freeable; auto with mem. apply Mem.perm_cur. apply PERMS. rewrite LV in H3. simpl in H3. omega. rewrite LV; simpl. rewrite Zminus_0_r. unfold ofs. apply inj_offset_aligned_array'. - intros. generalize (RANGE _ _ H3). omega. + intros. generalize (RANGE _ _ _ _ _ H3 H4). omega. intros [f1 [MINJ1 [INCR1 [SAME OTHER]]]]. exists f1; split. auto. split. auto. split. subst cenv'. eapply match_callstack_alloc_left; eauto. rewrite <- LV; auto. rewrite SAME; constructor. - intros. rewrite (Mem.bounds_alloc _ _ _ _ _ ALLOC). - destruct (eq_block b0 b); simpl. + intros. exploit Mem.perm_alloc_inv; eauto. destruct (zeq b0 b). subst b0. assert (delta = ofs) by congruence. subst delta. rewrite LV. simpl. omega. - rewrite OTHER in H3; eauto. generalize (RANGE _ _ H3). omega. + intro. rewrite OTHER in H3; eauto. generalize (RANGE _ _ _ _ _ H3 H5). omega. Qed. Lemma match_callstack_alloc_variables_rec: forall tm sp cenv' tf le te lo cs atk, Mem.valid_block tm sp -> - Mem.bounds tm sp = (0, tf.(fn_stackspace)) -> - Mem.range_perm tm sp 0 tf.(fn_stackspace) Freeable -> + (forall ofs k p, + Mem.perm tm sp ofs k p -> 0 <= ofs < tf.(fn_stackspace)) -> + Mem.range_perm tm sp 0 tf.(fn_stackspace) Cur Freeable -> tf.(fn_stackspace) <= Int.max_unsigned -> forall e m vars e' m', alloc_variables e m vars e' m' -> @@ -2292,8 +2263,8 @@ Lemma match_callstack_alloc_variables_rec: (Mem.nextblock m) (Mem.nextblock tm) -> Mem.inject f m tm -> 0 <= sz -> - (forall b delta, - f b = Some(sp, delta) -> Mem.high_bound m b + delta <= sz) -> + (forall b delta ofs k p, + f b = Some(sp, delta) -> Mem.perm m b ofs k p -> ofs + delta < sz) -> (forall id lv, In (id, lv) vars -> te!(for_var id) <> None) -> list_norepet (List.map (@fst ident var_kind) vars) -> (forall id lv, In (id, lv) vars -> e!id = None) -> @@ -2395,8 +2366,7 @@ Proof. intros. unfold build_compilenv in H. eapply match_callstack_alloc_variables_rec; eauto with mem. - eapply Mem.bounds_alloc_same; eauto. - red; intros; eauto with mem. + red; intros. eapply Mem.perm_alloc_2; eauto. eapply match_callstack_alloc_right; eauto. eapply Mem.alloc_right_inject; eauto. omega. intros. elim (Mem.valid_not_valid_diff tm sp sp); eauto with mem. @@ -3257,7 +3227,7 @@ Proof. (Mem.nextblock m') (Mem.nextblock tm')). apply match_callstack_incr_bound with (Mem.nextblock m) (Mem.nextblock tm). eapply match_callstack_external_call; eauto. - intros. eapply external_call_bounds; eauto. + intros. eapply external_call_max_perm; eauto. omega. omega. eapply external_call_nextblock_incr; eauto. eapply external_call_nextblock_incr; eauto. @@ -3414,7 +3384,7 @@ Opaque PTree.set. econstructor; eauto. apply match_callstack_incr_bound with (Mem.nextblock m) (Mem.nextblock tm). eapply match_callstack_external_call; eauto. - intros. eapply external_call_bounds; eauto. + intros. eapply external_call_max_perm; eauto. omega. omega. eapply external_call_nextblock_incr; eauto. eapply external_call_nextblock_incr; eauto. diff --git a/cfrontend/Initializersproof.v b/cfrontend/Initializersproof.v index 627db89..37f15cf 100644 --- a/cfrontend/Initializersproof.v +++ b/cfrontend/Initializersproof.v @@ -327,8 +327,8 @@ Qed. Lemma mem_empty_not_valid_pointer: forall b ofs, Mem.valid_pointer Mem.empty b ofs = false. Proof. - intros. unfold Mem.valid_pointer. destruct (Mem.perm_dec Mem.empty b ofs Nonempty); auto. - red in p. simpl in p. contradiction. + intros. unfold Mem.valid_pointer. destruct (Mem.perm_dec Mem.empty b ofs Cur Nonempty); auto. + eelim Mem.perm_empty; eauto. Qed. Lemma sem_cmp_match: diff --git a/common/Events.v b/common/Events.v index 3d082a7..93e1827 100644 --- a/common/Events.v +++ b/common/Events.v @@ -560,23 +560,22 @@ Definition extcall_sem : Type := (** We now specify the expected properties of this predicate. *) Definition mem_unchanged_on (P: block -> Z -> Prop) (m_before m_after: mem): Prop := - (forall b ofs p, - P b ofs -> Mem.perm m_before b ofs p -> Mem.perm m_after b ofs p) + (forall b ofs k p, + P b ofs -> Mem.perm m_before b ofs k p -> Mem.perm m_after b ofs k p) /\(forall chunk b ofs v, (forall i, ofs <= i < ofs + size_chunk chunk -> P b i) -> Mem.load chunk m_before b ofs = Some v -> Mem.load chunk m_after b ofs = Some v). Definition loc_out_of_bounds (m: mem) (b: block) (ofs: Z) : Prop := - ofs < Mem.low_bound m b \/ ofs > Mem.high_bound m b. + ~Mem.perm m b ofs Max Nonempty. Definition loc_unmapped (f: meminj) (b: block) (ofs: Z): Prop := f b = None. Definition loc_out_of_reach (f: meminj) (m: mem) (b: block) (ofs: Z): Prop := forall b0 delta, - f b0 = Some(b, delta) -> - ofs < Mem.low_bound m b0 + delta \/ ofs >= Mem.high_bound m b0 + delta. + f b0 = Some(b, delta) -> ~Mem.perm m b0 (ofs - delta) Max Nonempty. Definition inject_separated (f f': meminj) (m1 m2: mem): Prop := forall b1 b2 delta, @@ -613,11 +612,22 @@ Record extcall_properties (sem: extcall_sem) sem F V ge vargs m1 t vres m2 -> Mem.valid_block m1 b -> Mem.valid_block m2 b; -(** External calls preserve the bounds of valid blocks. *) - ec_bounds: - forall F V (ge: Genv.t F V) vargs m1 t vres m2 b, +(** External calls cannot increase the max permissions of a valid block. + They can decrease the max permissions, e.g. by freeing. *) + ec_max_perm: + forall F V (ge: Genv.t F V) vargs m1 t vres m2 b ofs p, + sem F V ge vargs m1 t vres m2 -> + Mem.valid_block m1 b -> Mem.perm m2 b ofs Max p -> Mem.perm m1 b ofs Max p; + +(** External call cannot modify memory unless they have [Max, Writable] + permissions. *) + ec_readonly: + forall F V (ge: Genv.t F V) vargs m1 t vres m2 chunk b ofs, sem F V ge vargs m1 t vres m2 -> - Mem.valid_block m1 b -> Mem.bounds m2 b = Mem.bounds m1 b; + Mem.valid_block m1 b -> + (forall ofs', ofs <= ofs' < ofs + size_chunk chunk -> + ~(Mem.perm m1 b ofs' Max Writable)) -> + Mem.load chunk m2 b ofs = Mem.load chunk m1 b ofs; (** External calls must commute with memory extensions, in the following sense. *) @@ -759,7 +769,9 @@ Proof. inv H1. constructor. eapply volatile_load_preserved; eauto. (* valid blocks *) inv H; auto. -(* bounds *) +(* max perms *) + inv H; auto. +(* readonly *) inv H; auto. (* mem extends *) inv H. inv H1. inv H6. inv H4. @@ -821,7 +833,9 @@ Proof. inv H1. econstructor. rewrite H; eauto. eapply volatile_load_preserved; eauto. (* valid blocks *) inv H; auto. -(* bounds *) +(* max perm *) + inv H; auto. +(* readonly *) inv H; auto. (* extends *) inv H. inv H1. exploit volatile_load_extends; eauto. intros [v' [A B]]. @@ -867,6 +881,28 @@ Proof. rewrite H0; auto. Qed. +Lemma volatile_store_readonly: + forall F V (ge: Genv.t F V) chunk1 m1 b1 ofs1 v t m2 chunk ofs b, + volatile_store ge chunk1 m1 b1 ofs1 v t m2 -> + Mem.valid_block m1 b -> + (forall ofs', ofs <= ofs' < ofs + size_chunk chunk -> + ~(Mem.perm m1 b ofs' Max Writable)) -> + Mem.load chunk m2 b ofs = Mem.load chunk m1 b ofs. +Proof. + intros. inv H. + auto. + eapply Mem.load_store_other; eauto. + destruct (eq_block b b1); auto. subst b1. right. + apply (Intv.range_disjoint' (ofs, ofs + size_chunk chunk) + (Int.unsigned ofs1, Int.unsigned ofs1 + size_chunk chunk1)). + red; intros; red; intros. + elim (H1 x); auto. + exploit Mem.store_valid_access_3; eauto. intros [A B]. + apply Mem.perm_cur_max. apply A. auto. + simpl. generalize (size_chunk_pos chunk); omega. + simpl. generalize (size_chunk_pos chunk1); omega. +Qed. + Lemma volatile_store_extends: forall F V (ge: Genv.t F V) chunk m1 b ofs v t m2 m1' v', volatile_store ge chunk m1 b ofs v t m2 -> @@ -886,15 +922,14 @@ Proof. eapply Mem.perm_store_1; eauto. rewrite <- H4. eapply Mem.load_store_other; eauto. destruct (eq_block b0 b); auto. subst b0; right. - exploit Mem.valid_access_in_bounds. - eapply Mem.store_valid_access_3. eexact H3. - intros [C D]. - generalize (size_chunk_pos chunk0). intro E. - generalize (size_chunk_pos chunk). intro G. apply (Intv.range_disjoint' (ofs0, ofs0 + size_chunk chunk0) (Int.unsigned ofs, Int.unsigned ofs + size_chunk chunk)). - red; intros. generalize (H x H5). unfold loc_out_of_bounds, Intv.In; simpl. omega. - simpl; omega. simpl; omega. + red; intros; red; intros. + exploit (H x H5). exploit Mem.store_valid_access_3. eexact H3. intros [E G]. + apply Mem.perm_cur_max. apply Mem.perm_implies with Writable; auto with mem. + auto. + simpl. generalize (size_chunk_pos chunk0). omega. + simpl. generalize (size_chunk_pos chunk). omega. Qed. Lemma volatile_store_inject: @@ -929,15 +964,15 @@ Proof. assert (EQ: Int.unsigned (Int.add ofs (Int.repr delta)) = Int.unsigned ofs + delta). eapply Mem.address_inject; eauto with mem. unfold Mem.storev in A. rewrite EQ in A. rewrite EQ. - exploit Mem.valid_access_in_bounds. - eapply Mem.store_valid_access_3. eexact H0. - intros [C D]. - generalize (size_chunk_pos chunk0). intro E. - generalize (size_chunk_pos chunk). intro G. apply (Intv.range_disjoint' (ofs0, ofs0 + size_chunk chunk0) (Int.unsigned ofs + delta, Int.unsigned ofs + delta + size_chunk chunk)). - red; intros. exploit (H1 x H7). eauto. unfold Intv.In; simpl. omega. - simpl; omega. simpl; omega. + red; intros; red; intros. exploit (H1 x H7). eauto. + exploit Mem.store_valid_access_3. eexact H0. intros [C D]. + apply Mem.perm_cur_max. apply Mem.perm_implies with Writable; auto with mem. + apply C. red in H8; simpl in H8. omega. + auto. + simpl. generalize (size_chunk_pos chunk0). omega. + simpl. generalize (size_chunk_pos chunk). omega. Qed. Lemma volatile_store_receptive: @@ -961,8 +996,10 @@ Proof. inv H1. constructor. eapply volatile_store_preserved; eauto. (* valid block *) inv H. inv H1. auto. eauto with mem. -(* bounds *) - inv H. inv H1. auto. eapply Mem.bounds_store; eauto. +(* perms *) + inv H. inv H2. auto. eauto with mem. +(* readonly *) + inv H. eapply volatile_store_readonly; eauto. (* mem extends*) inv H. inv H1. inv H6. inv H7. inv H4. exploit volatile_store_extends; eauto. intros [m2' [A [B C]]]. @@ -1016,8 +1053,10 @@ Proof. inv H1. econstructor. rewrite H; eauto. eapply volatile_store_preserved; eauto. (* valid block *) inv H. inv H2. auto. eauto with mem. -(* bounds *) - inv H. inv H2. auto. eapply Mem.bounds_store; eauto. +(* perms *) + inv H. inv H3. auto. eauto with mem. +(* readonly *) + inv H. eapply volatile_store_readonly; eauto. (* mem extends*) rewrite volatile_store_global_charact in H. destruct H as [b [P Q]]. exploit ec_mem_extends. eapply volatile_store_ok. eexact Q. eauto. eauto. @@ -1076,11 +1115,15 @@ Proof. inv H1; econstructor; eauto. (* valid block *) inv H. eauto with mem. -(* bounds *) - inv H. transitivity (Mem.bounds m' b). - eapply Mem.bounds_store; eauto. - eapply Mem.bounds_alloc_other; eauto. +(* perms *) + inv H. exploit Mem.perm_alloc_inv. eauto. eapply Mem.perm_store_2; eauto. + rewrite zeq_false. auto. apply Mem.valid_not_valid_diff with m1; eauto with mem. +(* readonly *) + inv H. transitivity (Mem.load chunk m' b ofs). + eapply Mem.load_store_other; eauto. + left. apply Mem.valid_not_valid_diff with m1; eauto with mem. + eapply Mem.load_alloc_unchanged; eauto. (* mem extends *) inv H. inv H1. inv H5. inv H7. exploit Mem.alloc_extends; eauto. apply Zle_refl. apply Zle_refl. @@ -1153,8 +1196,21 @@ Proof. inv H1; econstructor; eauto. (* valid block *) inv H. eauto with mem. -(* bounds *) - inv H. eapply Mem.bounds_free; eauto. +(* perms *) + inv H. eapply Mem.perm_free_3; eauto. +(* readonly *) + inv H. eapply Mem.load_free; eauto. + destruct (eq_block b b0); auto. + subst b0. right; right. + apply (Intv.range_disjoint' + (ofs, ofs + size_chunk chunk) + (Int.unsigned lo - 4, Int.unsigned lo + Int.unsigned sz)). + red; intros; red; intros. + elim (H1 x). auto. apply Mem.perm_cur_max. + apply Mem.perm_implies with Freeable; auto with mem. + exploit Mem.free_range_perm; eauto. + simpl. generalize (size_chunk_pos chunk); omega. + simpl. omega. (* mem extends *) inv H. inv H1. inv H8. inv H6. exploit Mem.load_extends; eauto. intros [vsz [A B]]. inv B. @@ -1163,19 +1219,20 @@ Proof. econstructor; eauto. eapply UNCHANGED; eauto. omega. intros. destruct (eq_block b' b); auto. subst b; right. - red in H. - exploit Mem.range_perm_in_bounds. - eapply Mem.free_range_perm. eexact H4. omega. omega. + assert (~(Int.unsigned lo - 4 <= ofs < Int.unsigned lo + Int.unsigned sz)). + red; intros; elim H. apply Mem.perm_cur_max. apply Mem.perm_implies with Freeable; auto with mem. + eapply Mem.free_range_perm. eexact H4. auto. + omega. (* mem inject *) inv H0. inv H2. inv H7. inv H9. exploit Mem.load_inject; eauto. intros [vsz [A B]]. inv B. - assert (Mem.range_perm m1 b (Int.unsigned lo - 4) (Int.unsigned lo + Int.unsigned sz) Freeable). + assert (Mem.range_perm m1 b (Int.unsigned lo - 4) (Int.unsigned lo + Int.unsigned sz) Cur Freeable). eapply Mem.free_range_perm; eauto. exploit Mem.address_inject; eauto. - apply Mem.perm_implies with Freeable; auto with mem. + apply Mem.perm_implies with Freeable; auto with mem. apply Mem.perm_cur_max. apply H0. instantiate (1 := lo). omega. intro EQ. - assert (Mem.range_perm m1' b2 (Int.unsigned lo + delta - 4) (Int.unsigned lo + delta + Int.unsigned sz) Freeable). + assert (Mem.range_perm m1' b2 (Int.unsigned lo + delta - 4) (Int.unsigned lo + delta + Int.unsigned sz) Cur Freeable). red; intros. replace ofs with ((ofs - delta) + delta) by omega. eapply Mem.perm_inject; eauto. apply H0. omega. @@ -1194,20 +1251,23 @@ Proof. subst b. assert (delta0 = delta) by congruence. subst delta0. exists (Int.unsigned lo - 4); exists (Int.unsigned lo + Int.unsigned sz); split. simpl; auto. omega. - elimtype False. - exploit Mem.inject_no_overlap. eauto. eauto. eauto. eauto. - instantiate (1 := ofs + delta0 - delta). - apply Mem.perm_implies with Freeable; auto with mem. - apply H0. omega. eauto with mem. + elimtype False. exploit Mem.inject_no_overlap. eauto. eauto. eauto. eauto. + instantiate (1 := ofs + delta0 - delta). + apply Mem.perm_cur_max. apply Mem.perm_implies with Freeable; auto with mem. + apply H0. omega. + eapply Mem.perm_max. eauto with mem. unfold block; omega. eapply UNCHANGED; eauto. omega. intros. red in H7. left. congruence. eapply UNCHANGED; eauto. omega. intros. - destruct (eq_block b' b2); auto. subst b'. right. - red in H7. generalize (H7 _ _ H6). intros. - exploit Mem.range_perm_in_bounds. eexact H0. omega. intros. omega. + destruct (eq_block b' b2); auto. subst b'. right. + assert (~(Int.unsigned lo + delta - 4 <= ofs < Int.unsigned lo + delta + Int.unsigned sz)). + red; intros. elim (H7 _ _ H6). + apply Mem.perm_cur_max. apply Mem.perm_implies with Freeable; auto with mem. + apply H0. omega. + omega. red; intros. congruence. (* trace length *) @@ -1245,8 +1305,20 @@ Proof. intros. inv H1. econstructor; eauto. (* valid blocks *) intros. inv H. eauto with mem. -(* bounds *) - intros. inv H. eapply Mem.bounds_storebytes; eauto. +(* perms *) + intros. inv H. eapply Mem.perm_storebytes_2; eauto. +(* readonly *) + intros. inv H. eapply Mem.load_storebytes_other; eauto. + destruct (eq_block b bdst); auto. subst b. right. + apply (Intv.range_disjoint' + (ofs, ofs + size_chunk chunk) + (Int.unsigned odst, Int.unsigned odst + Z_of_nat (length bytes))). + red; intros; red; intros. elim (H1 x); auto. + apply Mem.perm_cur_max. + eapply Mem.storebytes_range_perm; eauto. + simpl. generalize (size_chunk_pos chunk); omega. + simpl. rewrite (Mem.loadbytes_length _ _ _ _ _ H8). rewrite nat_of_Z_eq. + omega. omega. (* extensions *) intros. inv H. inv H1. inv H13. inv H14. inv H10. inv H11. @@ -1262,30 +1334,31 @@ Proof. exploit Mem.loadbytes_length. eexact H8. intros. rewrite <- H1. eapply Mem.load_storebytes_other; eauto. destruct (eq_block b bdst); auto. subst b; right. - exploit Mem.range_perm_in_bounds. eapply Mem.storebytes_range_perm. eexact H9. - rewrite H10. rewrite nat_of_Z_eq. omega. omega. - intros [P Q]. - exploit list_forall2_length; eauto. intros R. rewrite R in Q. + exploit list_forall2_length; eauto. intros R. apply (Intv.range_disjoint' (ofs, ofs + size_chunk chunk) (Int.unsigned odst, Int.unsigned odst + Z_of_nat (length bytes2))); simpl. - red; intros. generalize (H x H11). unfold loc_out_of_bounds, Intv.In; simpl. omega. - generalize (size_chunk_pos chunk); omega. - rewrite <- R; rewrite H10. rewrite nat_of_Z_eq. omega. omega. + red; unfold Intv.In; simpl; intros; red; intros. + eapply (H x H11). + apply Mem.perm_cur_max. apply Mem.perm_implies with Writable; auto with mem. + eapply Mem.storebytes_range_perm. eexact H9. + rewrite R. auto. + generalize (size_chunk_pos chunk). omega. + rewrite <- R. rewrite H10. rewrite nat_of_Z_eq. omega. omega. (* injections *) intros. inv H0. inv H2. inv H14. inv H15. inv H11. inv H12. exploit Mem.loadbytes_length; eauto. intros LEN. - assert (RPSRC: Mem.range_perm m1 bsrc (Int.unsigned osrc) (Int.unsigned osrc + sz) Nonempty). + assert (RPSRC: Mem.range_perm m1 bsrc (Int.unsigned osrc) (Int.unsigned osrc + sz) Cur Nonempty). eapply Mem.range_perm_implies. eapply Mem.loadbytes_range_perm; eauto. auto with mem. - assert (RPDST: Mem.range_perm m1 bdst (Int.unsigned odst) (Int.unsigned odst + sz) Nonempty). + assert (RPDST: Mem.range_perm m1 bdst (Int.unsigned odst) (Int.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. - assert (PSRC: Mem.perm m1 bsrc (Int.unsigned osrc) Nonempty). + assert (PSRC: Mem.perm m1 bsrc (Int.unsigned osrc) Cur Nonempty). apply RPSRC. omega. - assert (PDST: Mem.perm m1 bdst (Int.unsigned odst) Nonempty). + assert (PDST: Mem.perm m1 bdst (Int.unsigned odst) Cur Nonempty). apply RPDST. omega. - exploit Mem.address_inject. eauto. eexact PSRC. eauto. intros EQ1. - exploit Mem.address_inject. eauto. eexact PDST. eauto. intros EQ2. + exploit Mem.address_inject. eauto. apply Mem.perm_cur_max. eexact PSRC. eauto. intros EQ1. + exploit Mem.address_inject. eauto. apply Mem.perm_cur_max. eexact PDST. eauto. intros EQ2. exploit Mem.loadbytes_inject; eauto. intros [bytes2 [A B]]. exploit Mem.storebytes_mapped_inject; eauto. intros [m2' [C D]]. exists f; exists Vundef; exists m2'. @@ -1293,6 +1366,8 @@ Proof. eapply Mem.aligned_area_inject with (m := m1); eauto. eapply Mem.aligned_area_inject with (m := m1); eauto. eapply Mem.disjoint_or_equal_inject with (m := m1); eauto. + apply Mem.range_perm_max with Cur; auto. + apply Mem.range_perm_max with Cur; auto. split. constructor. split. auto. split. red; split; intros. eauto with mem. @@ -1306,10 +1381,8 @@ Proof. rewrite <- (list_forall2_length B). rewrite LEN. rewrite nat_of_Z_eq; try omega. apply (Intv.range_disjoint' (ofs, ofs + size_chunk chunk) (Int.unsigned odst + delta0, Int.unsigned odst + delta0 + sz)); simpl. - red; intros. generalize (H0 x H12). unfold loc_out_of_reach, Intv.In; simpl. - intros. exploit H14; eauto. - exploit Mem.range_perm_in_bounds. eexact RPDST. omega. - omega. + red; unfold Intv.In; simpl; intros; red; intros. + eapply (H0 x H12). eauto. apply Mem.perm_cur_max. apply RPDST. omega. generalize (size_chunk_pos chunk); omega. omega. split. apply inject_incr_refl. @@ -1348,7 +1421,9 @@ Proof. eapply eventval_match_preserved; eauto. (* valid block *) inv H; auto. -(* bounds *) +(* perms *) + inv H; auto. +(* readonly *) inv H; auto. (* mem extends *) inv H. @@ -1403,7 +1478,9 @@ Proof. eapply eventval_list_match_preserved; eauto. (* valid blocks *) inv H; auto. -(* bounds *) +(* perms *) + inv H; auto. +(* readonly *) inv H; auto. (* mem extends *) inv H. @@ -1453,6 +1530,8 @@ Proof. inv H; auto. + inv H; auto. + inv H. inv H1. inv H6. exists v2; exists m1'; intuition. econstructor; eauto. @@ -1527,7 +1606,8 @@ Definition external_call_well_typed ef := ec_well_typed (external_call_spec ef). Definition external_call_arity ef := ec_arity (external_call_spec ef). Definition external_call_symbols_preserved_gen ef := ec_symbols_preserved (external_call_spec ef). Definition external_call_valid_block ef := ec_valid_block (external_call_spec ef). -Definition external_call_bounds ef := ec_bounds (external_call_spec ef). +Definition external_call_max_perm ef := ec_max_perm (external_call_spec ef). +Definition external_call_readonly ef := ec_readonly (external_call_spec ef). Definition external_call_mem_extends ef := ec_mem_extends (external_call_spec ef). Definition external_call_mem_inject ef := ec_mem_inject (external_call_spec ef). Definition external_call_trace_length ef := ec_trace_length (external_call_spec ef). diff --git a/common/Globalenvs.v b/common/Globalenvs.v index 539bb77..d7449f9 100644 --- a/common/Globalenvs.v +++ b/common/Globalenvs.v @@ -276,6 +276,40 @@ Proof. intros. unfold globalenv; eauto. Qed. +Theorem find_var_exists: + forall p id gv, + list_norepet (prog_var_names p) -> + In (id, gv) (prog_vars p) -> + exists b, + find_symbol (globalenv p) id = Some b + /\ find_var_info (globalenv p) b = Some gv. +Proof. + intros until gv. + assert (forall vl ge, + ~In id (var_names vl) -> + (exists b, find_symbol ge id = Some b /\ find_var_info ge b = Some gv) -> + (exists b, find_symbol (add_variables ge vl) id = Some b + /\ find_var_info (add_variables ge vl) b = Some gv)). + induction vl; simpl; intros. + auto. + apply IHvl. tauto. destruct a as [id1 gv1]. destruct H0 as [b [P Q]]. + unfold add_variable, find_symbol, find_var_info; simpl. + exists b; split. rewrite PTree.gso. auto. intuition. + rewrite ZMap.gso. auto. exploit genv_vars_range; eauto. + unfold ZIndexed.t; omega. + + unfold globalenv, prog_var_names. + generalize (prog_vars p) (add_functions empty_genv (prog_funct p)). + induction l; simpl; intros. + contradiction. + destruct a as [id1 gv1]; simpl in *. inv H0. + destruct H1. inv H0. + apply H; auto. + exists (genv_nextvar t0); split. + unfold find_symbol, add_variable; simpl. apply PTree.gss. + unfold find_var_info, add_variable; simpl. apply ZMap.gss. + apply IHl; auto. +Qed. Remark add_variables_inversion : forall vs e x b, find_symbol (add_variables e vs) x = Some b -> @@ -740,50 +774,63 @@ Qed. Remark store_zeros_perm: - forall prm b' q m b n m', + forall k prm b' q m b n m', store_zeros m b n = Some m' -> - Mem.perm m b' q prm -> Mem.perm m' b' q prm. + (Mem.perm m b' q k prm <-> Mem.perm m' b' q k prm). Proof. intros until n. functional induction (store_zeros m b n); intros. - inv H; auto. - eauto with mem. + inv H; tauto. + destruct (IHo _ H); intros. split; eauto with mem. congruence. Qed. Remark store_init_data_list_perm: - forall prm b' q idl b m p m', + forall k prm b' q idl b m p m', store_init_data_list m b p idl = Some m' -> - Mem.perm m b' q prm -> Mem.perm m' b' q prm. + (Mem.perm m b' q k prm <-> Mem.perm m' b' q k prm). Proof. induction idl; simpl; intros until m'. - intros. congruence. - caseEq (store_init_data m b p a); try congruence. intros. - eapply IHidl; eauto. - destruct a; simpl in H; eauto with mem. - congruence. + intros. inv H. tauto. + caseEq (store_init_data m b p a); try congruence. intros. + rewrite <- (IHidl _ _ _ _ H0). + destruct a; simpl in H; split; eauto with mem. + inv H; auto. inv H; auto. + destruct (find_symbol ge i); try congruence. eauto with mem. destruct (find_symbol ge i); try congruence. eauto with mem. Qed. Remark alloc_variables_perm: - forall prm b' q vl m m', + forall k prm b' q vl m m', alloc_variables m vl = Some m' -> - Mem.perm m b' q prm -> Mem.perm m' b' q prm. + Mem.valid_block m b' -> + (Mem.perm m b' q k prm <-> Mem.perm m' b' q k prm). Proof. induction vl. - simpl; intros. congruence. + simpl; intros. inv H. tauto. intros until m'. simpl. unfold alloc_variable. set (init := gvar_init a#2). set (sz := init_data_list_size init). caseEq (Mem.alloc m 0 sz). intros m1 b ALLOC. caseEq (store_zeros m1 b sz); try congruence. intros m2 STZ. caseEq (store_init_data_list m2 b 0 init); try congruence. intros m3 STORE. - caseEq (Mem.drop_perm m3 b 0 sz (perm_globvar a#2)); try congruence. intros m4 DROP REC PERM. + caseEq (Mem.drop_perm m3 b 0 sz (perm_globvar a#2)); try congruence. intros m4 DROP REC VALID. assert (b' <> b). apply Mem.valid_not_valid_diff with m; eauto with mem. - eapply IHvl; eauto. - eapply Mem.perm_drop_3; eauto. - eapply store_init_data_list_perm; eauto. - eapply store_zeros_perm; eauto. + assert (VALID': Mem.valid_block m4 b'). + unfold Mem.valid_block. rewrite (Mem.nextblock_drop _ _ _ _ _ _ DROP). + rewrite (store_init_data_list_nextblock _ _ _ _ STORE). + rewrite (store_zeros_nextblock _ _ _ STZ). + change (Mem.valid_block m1 b'). eauto with mem. + rewrite <- (IHvl _ _ REC VALID'). + split; intros. + eapply Mem.perm_drop_3; eauto. + rewrite <- store_init_data_list_perm; [idtac|eauto]. + rewrite <- store_zeros_perm; [idtac|eauto]. eauto with mem. + assert (Mem.perm m1 b' q k prm). + rewrite store_zeros_perm; [idtac|eauto]. + rewrite store_init_data_list_perm; [idtac|eauto]. + eapply Mem.perm_drop_4; eauto. + exploit Mem.perm_alloc_inv; eauto. rewrite zeq_false; auto. Qed. Remark store_zeros_outside: @@ -913,56 +960,93 @@ Proof. repeat rewrite H. destruct a; intuition. Qed. -Lemma alloc_variables_charact: - forall id gv vl g m m', +Definition variables_initialized (g: t) (m: mem) := + forall b gv, + find_var_info g b = Some gv -> + Mem.range_perm m b 0 (init_data_list_size gv.(gvar_init)) Cur (perm_globvar gv) + /\ (forall ofs k p, Mem.perm m b ofs k p -> + 0 <= ofs < init_data_list_size gv.(gvar_init) /\ perm_order (perm_globvar gv) p) + /\ (gv.(gvar_volatile) = false -> load_store_init_data m b 0 gv.(gvar_init)). + +Lemma alloc_variable_initialized: + forall g m id v m', genv_nextvar g = Mem.nextblock m -> - alloc_variables m vl = Some m' -> - list_norepet (map (@fst ident (globvar V)) vl) -> - In (id, gv) vl -> - exists b, find_symbol (add_variables g vl) id = Some b - /\ find_var_info (add_variables g vl) b = Some gv - /\ Mem.range_perm m' b 0 (init_data_list_size gv.(gvar_init)) (perm_globvar gv) - /\ (gv.(gvar_volatile) = false -> load_store_init_data m' b 0 gv.(gvar_init)). -Proof. - induction vl; simpl. - contradiction. - intros until m'; intro NEXT. - unfold alloc_variable. destruct a as [id' gv']. simpl. - set (init := gvar_init gv'). - set (sz := init_data_list_size init). - caseEq (Mem.alloc m 0 sz); try congruence. intros m1 b ALLOC. - caseEq (store_zeros m1 b sz); try congruence. intros m2 STZ. - caseEq (store_init_data_list m2 b 0 init); try congruence. intros m3 STORE. - caseEq (Mem.drop_perm m3 b 0 sz (perm_globvar gv')); try congruence. - intros m4 DROP REC NOREPET IN. inv NOREPET. - exploit Mem.alloc_result; eauto. intro BEQ. - destruct IN. inversion H; subst id gv. - exists (Mem.nextblock m); split. - rewrite add_variables_same_symb; auto. unfold find_symbol; simpl. - rewrite PTree.gss. congruence. - split. rewrite add_variables_same_address. unfold find_var_info; simpl. - rewrite NEXT. apply ZMap.gss. - simpl. rewrite <- NEXT; omega. - split. red; intros. - rewrite <- BEQ. eapply alloc_variables_perm; eauto. eapply Mem.perm_drop_1; eauto. - intros NOVOL. + alloc_variable m (id, v) = Some m' -> + variables_initialized g m -> + variables_initialized (add_variable g (id, v)) m' + /\ genv_nextvar (add_variable g (id,v)) = Mem.nextblock m'. +Proof. + intros. revert H0. unfold alloc_variable. simpl. + set (il := gvar_init v). + set (sz := init_data_list_size il). + caseEq (Mem.alloc m 0 sz). intros m1 b1 ALLOC. + caseEq (store_zeros m1 b1 sz); try congruence. intros m2 ZEROS. + caseEq (store_init_data_list m2 b1 0 il); try congruence. intros m3 INIT DROP. + exploit Mem.nextblock_alloc; eauto. intros NB1. + assert (Mem.nextblock m' = Mem.nextblock m1). + rewrite (Mem.nextblock_drop _ _ _ _ _ _ DROP). + rewrite (store_init_data_list_nextblock _ _ _ _ INIT). + eapply store_zeros_nextblock; eauto. + exploit Mem.alloc_result; eauto. intro RES. + split. + (* var-init *) + red; intros. revert H2. + unfold add_variable, find_var_info; simpl. + rewrite H; rewrite <- RES. + rewrite ZMap.gsspec. destruct (ZIndexed.eq b b1); intros VI. + (* new var *) + injection VI; intro EQ. subst b gv. clear VI. + fold il. fold sz. + split. red; intros. eapply Mem.perm_drop_1; eauto. + split. intros. + assert (0 <= ofs < sz). + eapply Mem.perm_alloc_3; eauto. + rewrite store_zeros_perm; [idtac|eauto]. + rewrite store_init_data_list_perm; [idtac|eauto]. + eapply Mem.perm_drop_4; eauto. + split; auto. eapply Mem.perm_drop_2; eauto. + intros. apply load_store_init_data_invariant with m3. - intros. transitivity (Mem.load chunk m4 (Mem.nextblock m) ofs). - eapply load_alloc_variables; eauto. - red. rewrite (Mem.nextblock_drop _ _ _ _ _ _ DROP). - rewrite (store_init_data_list_nextblock _ _ _ _ STORE). - rewrite (store_zeros_nextblock _ _ _ STZ). - change (Mem.valid_block m1 (Mem.nextblock m)). rewrite <- BEQ. eauto with mem. - eapply Mem.load_drop; eauto. repeat right. - unfold perm_globvar. rewrite NOVOL. destruct (gvar_readonly gv'); auto with mem. - rewrite <- BEQ. eapply store_init_data_list_charact; eauto. + intros. eapply Mem.load_drop; eauto. right; right; right. + unfold perm_globvar. destruct (gvar_volatile v); try discriminate. + destruct (gvar_readonly v); auto with mem. + eapply store_init_data_list_charact; eauto. + (* older vars *) + exploit H1; eauto. intros [A [B C]]. + split. red; intros. eapply Mem.perm_drop_3; eauto. + rewrite <- store_init_data_list_perm; [idtac|eauto]. + rewrite <- store_zeros_perm; [idtac|eauto]. + eapply Mem.perm_alloc_1; eauto. + split. intros. eapply B. + eapply Mem.perm_alloc_4; eauto. + rewrite store_zeros_perm; [idtac|eauto]. + rewrite store_init_data_list_perm; [idtac|eauto]. + eapply Mem.perm_drop_4; eauto. + intros. apply load_store_init_data_invariant with m; auto. + intros. transitivity (Mem.load chunk m3 b ofs). + eapply Mem.load_drop; eauto. + transitivity (Mem.load chunk m2 b ofs). + eapply store_init_data_list_outside; eauto. + transitivity (Mem.load chunk m1 b ofs). + eapply store_zeros_outside; eauto. + eapply Mem.load_alloc_unchanged; eauto. + red. exploit genv_vars_range; eauto. rewrite <- H. omega. + rewrite H0; rewrite NB1; rewrite H; auto. +Qed. - apply IHvl with m4; auto. - simpl. - rewrite (Mem.nextblock_drop _ _ _ _ _ _ DROP). - rewrite (store_init_data_list_nextblock _ _ _ _ STORE). - rewrite (store_zeros_nextblock _ _ _ STZ). - rewrite (Mem.nextblock_alloc _ _ _ _ _ ALLOC). unfold block in *; omega. +Lemma alloc_variables_initialized: + forall vl g m m', + genv_nextvar g = Mem.nextblock m -> + alloc_variables m vl = Some m' -> + variables_initialized g m -> + variables_initialized (add_variables g vl) m'. +Proof. + induction vl; simpl; intros. + inv H0; auto. + destruct (alloc_variable m a) as [m1|]_eqn; try discriminate. + destruct a as [id gv]. + exploit alloc_variable_initialized; eauto. intros [P Q]. + eapply IHvl; eauto. Qed. End INITMEM. @@ -1007,19 +1091,19 @@ Proof. red. rewrite H1. rewrite <- H3. intuition. Qed. -Theorem find_var_exists: - forall p id gv m, - list_norepet (prog_var_names p) -> - In (id, gv) (prog_vars p) -> +Theorem init_mem_characterization: + forall p b gv m, + find_var_info (globalenv p) b = Some gv -> init_mem p = Some m -> - exists b, find_symbol (globalenv p) id = Some b - /\ find_var_info (globalenv p) b = Some gv - /\ Mem.range_perm m b 0 (init_data_list_size gv.(gvar_init)) (perm_globvar gv) - /\ (gv.(gvar_volatile) = false -> load_store_init_data (globalenv p) m b 0 gv.(gvar_init)). + Mem.range_perm m b 0 (init_data_list_size gv.(gvar_init)) Cur (perm_globvar gv) + /\ (forall ofs k p, Mem.perm m b ofs k p -> + 0 <= ofs < init_data_list_size gv.(gvar_init) /\ perm_order (perm_globvar gv) p) + /\ (gv.(gvar_volatile) = false -> load_store_init_data (globalenv p) m b 0 gv.(gvar_init)). Proof. - intros. exploit alloc_variables_charact; eauto. - instantiate (1 := Mem.empty). rewrite add_functions_nextvar. rewrite Mem.nextblock_empty; auto. - assumption. + intros. eapply alloc_variables_initialized; eauto. + rewrite add_functions_nextvar; auto. + red; intros. exploit genv_vars_range; eauto. rewrite add_functions_nextvar. + simpl. intros. omegaContradiction. Qed. (** ** Compatibility with memory injections *) @@ -1142,8 +1226,8 @@ Proof. Mem.store chunk m2 b ofs v = Some m2' -> Mem.inject (Mem.flat_inj thr) m1 m2'). intros. eapply Mem.store_outside_inject; eauto. - intros b' ? INJ'. unfold Mem.flat_inj in INJ'. - destruct (zlt b' thr); inversion INJ'; subst. omega. + intros. unfold Mem.flat_inj in H0. + destruct (zlt b' thr); inversion H0; subst. omega. destruct id; simpl in ST; try (eapply P; eauto; fail). inv ST; auto. revert ST. caseEq (find_symbol ge i); try congruence. intros; eapply P; eauto. @@ -1687,31 +1771,40 @@ Proof. rewrite H0; simpl. auto. Qed. - -(* This may not yet be in the ideal form for easy use .*) -Theorem find_new_var_exists: - list_norepet (prog_var_names p ++ var_names new_vars) -> - forall id gv m, In (id, gv) new_vars -> - init_mem p' = Some m -> - exists b, find_symbol (globalenv p') id = Some b - /\ find_var_info (globalenv p') b = Some gv - /\ Mem.range_perm m b 0 (init_data_list_size gv.(gvar_init)) (perm_globvar gv) - /\ (gv.(gvar_volatile) = false -> load_store_init_data (globalenv p') m b 0 gv.(gvar_init)). +Theorem find_new_var_exists: + forall id gv, + list_norepet (var_names new_vars) -> + In (id, gv) new_vars -> + exists b, find_symbol (globalenv p') id = Some b /\ find_var_info (globalenv p') b = Some gv. Proof. intros. - destruct p. + assert (P: forall b vars (ge: t B W), + ~In id (var_names vars) -> + find_symbol ge id = Some b + /\ find_var_info ge b = Some gv -> + find_symbol (add_variables ge vars) id = Some b + /\ find_var_info (add_variables ge vars) b = Some gv). + induction vars; simpl; intros. auto. apply IHvars. tauto. + destruct a as [id1 gv1]; unfold add_variable, find_symbol, find_var_info; simpl in *. + destruct H2; split. rewrite PTree.gso. auto. intuition. + rewrite ZMap.gso. auto. exploit genv_vars_range; eauto. unfold ZIndexed.t; omega. + + assert (Q: forall vars (ge: t B W), + list_norepet (var_names vars) -> + In (id, gv) vars -> + exists b, find_symbol (add_variables ge vars) id = Some b + /\ find_var_info (add_variables ge vars) b = Some gv). + induction vars; simpl; intros. + contradiction. + destruct a as [id1 gv1]; simpl in *. inv H1. destruct H2. inv H1. + exists (genv_nextvar ge). apply P; auto. + unfold add_variable, find_symbol, find_var_info; simpl in *. + split. apply PTree.gss. apply ZMap.gss. + apply IHvars; auto. + unfold transform_partial_augment_program in transf_OK. monadInv transf_OK. rename x into prog_funct'. rename x0 into prog_vars'. simpl in *. - assert (var_names prog_vars = var_names prog_vars'). - clear - EQ1. generalize dependent prog_vars'. induction prog_vars; intros. - simpl in EQ1. inversion EQ1; subst; auto. - simpl in EQ1. destruct a. destruct (transf_globvar transf_var g); try discriminate. monadInv EQ1. - simpl; f_equal; auto. - apply find_var_exists. - unfold prog_var_names in *; simpl in *. - rewrite var_names_app. rewrite <- H2. auto. - simpl. intuition. - auto. + unfold globalenv; simpl. repeat rewrite add_variables_app. apply Q; auto. Qed. Theorem find_var_info_rev_transf_augment: diff --git a/common/Memory.v b/common/Memory.v index 059a27e..0fc663f 100644 --- a/common/Memory.v +++ b/common/Memory.v @@ -25,9 +25,10 @@ - [alloc]: allocate a fresh memory block; - [free]: invalidate a memory block. *) - + Require Import Axioms. Require Import Coqlib. +Require Import Maps. Require Import AST. Require Import Integers. Require Import Floats. @@ -35,24 +36,7 @@ Require Import Values. Require Export Memdata. Require Export Memtype. -Definition update (A: Type) (x: Z) (v: A) (f: Z -> A) : Z -> A := - fun y => if zeq y x then v else f y. - -Implicit Arguments update [A]. - -Lemma update_s: - forall (A: Type) (x: Z) (v: A) (f: Z -> A), - update x v f x = v. -Proof. - intros; unfold update. apply zeq_true. -Qed. - -Lemma update_o: - forall (A: Type) (x: Z) (v: A) (f: Z -> A) (y: Z), - x <> y -> update x v f y = f y. -Proof. - intros; unfold update. apply zeq_false; auto. -Qed. +Local Notation "a # b" := (ZMap.get b a) (at level 1). Module Mem <: MEM. @@ -62,25 +46,31 @@ Definition perm_order' (po: option permission) (p: permission) := | None => False end. +Definition perm_order'' (po1 po2: option permission) := + match po1, po2 with + | Some p1, Some p2 => perm_order p1 p2 + | _, None => True + | None, Some _ => False + end. + Record mem' : Type := mkmem { - mem_contents: block -> Z -> memval; - mem_access: block -> Z -> option permission; - bounds: block -> Z * Z; + mem_contents: ZMap.t (ZMap.t memval); (**r [block -> offset -> memval] *) + mem_access: ZMap.t (Z -> perm_kind -> option permission); + (**r [block -> offset -> kind -> option permission] *) nextblock: block; nextblock_pos: nextblock > 0; - nextblock_noaccess: forall b, 0 < b < nextblock \/ bounds b = (0,0) ; - bounds_noaccess: forall b ofs, ofs < fst(bounds b) \/ ofs >= snd(bounds b) -> mem_access b ofs = None; - noread_undef: forall b ofs, perm_order' (mem_access b ofs) Readable \/ mem_contents b ofs = Undef + access_max: + forall b ofs, perm_order'' (mem_access#b ofs Max) (mem_access#b ofs Cur); + nextblock_noaccess: + forall b ofs k, b <= 0 \/ b >= nextblock -> mem_access#b ofs k = None }. Definition mem := mem'. Lemma mkmem_ext: - forall cont1 cont2 acc1 acc2 bound1 bound2 next1 next2 - a1 a2 b1 b2 c1 c2 d1 d2, - cont1=cont2 -> acc1=acc2 -> bound1=bound2 -> next1=next2 -> - mkmem cont1 acc1 bound1 next1 a1 b1 c1 d1 = - mkmem cont2 acc2 bound2 next2 a2 b2 c2 d2. + forall cont1 cont2 acc1 acc2 next1 next2 a1 a2 b1 b2 c1 c2, + cont1=cont2 -> acc1=acc2 -> next1=next2 -> + mkmem cont1 acc1 next1 a1 b1 c1 = mkmem cont2 acc2 next2 a2 b2 c2. Proof. intros. subst. f_equal; apply proof_irr. Qed. @@ -103,29 +93,54 @@ Hint Local Resolve valid_not_valid_diff: mem. (** Permissions *) -Definition perm (m: mem) (b: block) (ofs: Z) (p: permission) : Prop := - perm_order' (mem_access m b ofs) p. +Definition perm (m: mem) (b: block) (ofs: Z) (k: perm_kind) (p: permission) : Prop := + perm_order' (m.(mem_access)#b ofs k) p. Theorem perm_implies: - forall m b ofs p1 p2, perm m b ofs p1 -> perm_order p1 p2 -> perm m b ofs p2. + forall m b ofs k p1 p2, perm m b ofs k p1 -> perm_order p1 p2 -> perm m b ofs k p2. Proof. unfold perm, perm_order'; intros. - destruct (mem_access m b ofs); auto. + destruct (m.(mem_access)#b ofs k); auto. eapply perm_order_trans; eauto. Qed. Hint Local Resolve perm_implies: mem. +Theorem perm_cur_max: + forall m b ofs p, perm m b ofs Cur p -> perm m b ofs Max p. +Proof. + assert (forall po1 po2 p, + perm_order' po2 p -> perm_order'' po1 po2 -> perm_order' po1 p). + unfold perm_order', perm_order''. intros. + destruct po2; try contradiction. + destruct po1; try contradiction. + eapply perm_order_trans; eauto. + unfold perm; intros. + generalize (access_max m b ofs). eauto. +Qed. + +Theorem perm_cur: + forall m b ofs k p, perm m b ofs Cur p -> perm m b ofs k p. +Proof. + intros. destruct k; auto. apply perm_cur_max. auto. +Qed. + +Theorem perm_max: + forall m b ofs k p, perm m b ofs k p -> perm m b ofs Max p. +Proof. + intros. destruct k; auto. apply perm_cur_max. auto. +Qed. + +Hint Local Resolve perm_cur perm_max: mem. + Theorem perm_valid_block: - forall m b ofs p, perm m b ofs p -> valid_block m b. + forall m b ofs k p, perm m b ofs k p -> valid_block m b. Proof. unfold perm; intros. destruct (zlt b m.(nextblock)). auto. - assert (mem_access m b ofs = None). - destruct (nextblock_noaccess m b). - elimtype False; omega. - apply bounds_noaccess. rewrite H0; simpl; omega. + assert (m.(mem_access)#b ofs k = None). + eapply nextblock_noaccess; eauto. rewrite H0 in H. contradiction. Qed. @@ -147,34 +162,48 @@ Proof. Qed. Theorem perm_dec: - forall m b ofs p, {perm m b ofs p} + {~ perm m b ofs p}. + forall m b ofs k p, {perm m b ofs k p} + {~ perm m b ofs k p}. Proof. unfold perm; intros. apply perm_order'_dec. Qed. - -Definition range_perm (m: mem) (b: block) (lo hi: Z) (p: permission) : Prop := - forall ofs, lo <= ofs < hi -> perm m b ofs p. + +Definition range_perm (m: mem) (b: block) (lo hi: Z) (k: perm_kind) (p: permission) : Prop := + forall ofs, lo <= ofs < hi -> perm m b ofs k p. Theorem range_perm_implies: - forall m b lo hi p1 p2, - range_perm m b lo hi p1 -> perm_order p1 p2 -> range_perm m b lo hi p2. + forall m b lo hi k p1 p2, + range_perm m b lo hi k p1 -> perm_order p1 p2 -> range_perm m b lo hi k p2. Proof. unfold range_perm; intros; eauto with mem. Qed. -Hint Local Resolve range_perm_implies: mem. +Theorem range_perm_cur: + forall m b lo hi k p, + range_perm m b lo hi Cur p -> range_perm m b lo hi k p. +Proof. + unfold range_perm; intros; eauto with mem. +Qed. + +Theorem range_perm_max: + forall m b lo hi k p, + range_perm m b lo hi k p -> range_perm m b lo hi Max p. +Proof. + unfold range_perm; intros; eauto with mem. +Qed. + +Hint Local Resolve range_perm_implies range_perm_cur range_perm_max: mem. Lemma range_perm_dec: - forall m b lo hi p, {range_perm m b lo hi p} + {~ range_perm m b lo hi p}. + forall m b lo hi k p, {range_perm m b lo hi k p} + {~ range_perm m b lo hi k p}. Proof. intros. assert (forall n, 0 <= n -> - {range_perm m b lo (lo + n) p} + {~ range_perm m b lo (lo + n) p}). + {range_perm m b lo (lo + n) k p} + {~ range_perm m b lo (lo + n) k p}). apply natlike_rec2. left. red; intros. omegaContradiction. intros. destruct H0. - destruct (perm_dec m b (lo + z) p). + destruct (perm_dec m b (lo + z) k p). left. red; intros. destruct (zeq ofs (lo + z)). congruence. apply r. omega. right; red; intro. elim n. apply H0. omega. right; red; intro. elim n. red; intros. apply H0. omega. @@ -185,14 +214,14 @@ Qed. (** [valid_access m chunk b ofs p] holds if a memory access of the given chunk is possible in [m] at address [b, ofs] - with permissions [p]. + with current permissions [p]. This means: -- The range of bytes accessed all have permission [p]. +- The range of bytes accessed all have current permission [p]. - The offset [ofs] is aligned. *) Definition valid_access (m: mem) (chunk: memory_chunk) (b: block) (ofs: Z) (p: permission): Prop := - range_perm m b ofs (ofs + size_chunk chunk) p + range_perm m b ofs (ofs + size_chunk chunk) Cur p /\ (align_chunk chunk | ofs). Theorem valid_access_implies: @@ -220,7 +249,7 @@ Theorem valid_access_valid_block: valid_block m b. Proof. intros. destruct H. - assert (perm m b ofs Nonempty). + assert (perm m b ofs Cur Nonempty). apply H. generalize (size_chunk_pos chunk). omega. eauto with mem. Qed. @@ -228,11 +257,11 @@ Qed. Hint Local Resolve valid_access_valid_block: mem. Lemma valid_access_perm: - forall m chunk b ofs p, + forall m chunk b ofs k p, valid_access m chunk b ofs p -> - perm m b ofs p. + perm m b ofs k p. Proof. - intros. destruct H. apply H. generalize (size_chunk_pos chunk). omega. + intros. destruct H. apply perm_cur. apply H. generalize (size_chunk_pos chunk). omega. Qed. Lemma valid_access_compat: @@ -250,7 +279,7 @@ Lemma valid_access_dec: {valid_access m chunk b ofs p} + {~ valid_access m chunk b ofs p}. Proof. intros. - destruct (range_perm_dec m b ofs (ofs + size_chunk chunk) p). + destruct (range_perm_dec m b ofs (ofs + size_chunk chunk) Cur p). destruct (Zdivide_dec (align_chunk chunk) ofs (align_chunk_pos chunk)). left; constructor; auto. right; red; intro V; inv V; contradiction. @@ -261,14 +290,14 @@ Qed. the byte at the given location is nonempty. *) Definition valid_pointer (m: mem) (b: block) (ofs: Z): bool := - perm_dec m b ofs Nonempty. + perm_dec m b ofs Cur Nonempty. Theorem valid_pointer_nonempty_perm: forall m b ofs, - valid_pointer m b ofs = true <-> perm m b ofs Nonempty. + valid_pointer m b ofs = true <-> perm m b ofs Cur Nonempty. Proof. intros. unfold valid_pointer. - destruct (perm_dec m b ofs Nonempty); simpl; + destruct (perm_dec m b ofs Cur Nonempty); simpl; intuition congruence. Qed. @@ -283,62 +312,23 @@ Proof. destruct H. apply H. simpl. omega. Qed. -(** Bounds *) - -(** Each block has a low bound and a high bound, determined at allocation time - and invariant afterward. The crucial properties of bounds is - that any offset below the low bound or above the high bound is - empty. *) - -Notation low_bound m b := (fst(bounds m b)). -Notation high_bound m b := (snd(bounds m b)). - -Theorem perm_in_bounds: - forall m b ofs p, perm m b ofs p -> low_bound m b <= ofs < high_bound m b. -Proof. - unfold perm. intros. - destruct (zlt ofs (fst (bounds m b))). - exploit bounds_noaccess. left; eauto. - intros. - rewrite H0 in H. contradiction. - destruct (zlt ofs (snd (bounds m b))). - omega. - exploit bounds_noaccess. right; eauto. - intro; rewrite H0 in H. contradiction. -Qed. - -Theorem range_perm_in_bounds: - forall m b lo hi p, - range_perm m b lo hi p -> lo < hi -> low_bound m b <= lo /\ hi <= high_bound m b. -Proof. - intros. split. - exploit (perm_in_bounds m b lo p). apply H. omega. omega. - exploit (perm_in_bounds m b (hi-1) p). apply H. omega. omega. -Qed. - -Theorem valid_access_in_bounds: - forall m chunk b ofs p, - valid_access m chunk b ofs p -> - low_bound m b <= ofs /\ ofs + size_chunk chunk <= high_bound m b. -Proof. - intros. inv H. apply range_perm_in_bounds with p; auto. - generalize (size_chunk_pos chunk). omega. -Qed. - -Hint Local Resolve perm_in_bounds range_perm_in_bounds valid_access_in_bounds. - -(** * Store operations *) +(** * Operations over memory stores *) (** The initial store *) Program Definition empty: mem := - mkmem (fun b ofs => Undef) - (fun b ofs => None) - (fun b => (0,0)) - 1 _ _ _ _. + mkmem (ZMap.init (ZMap.init Undef)) + (ZMap.init (fun ofs k => None)) + 1 _ _ _. Next Obligation. omega. Qed. +Next Obligation. + repeat rewrite ZMap.gi. red; auto. +Qed. +Next Obligation. + rewrite ZMap.gi. auto. +Qed. Definition nullptr: block := 0. @@ -348,108 +338,56 @@ Definition nullptr: block := 0. infinite memory. *) Program Definition alloc (m: mem) (lo hi: Z) := - (mkmem (update m.(nextblock) - (fun ofs => Undef) - m.(mem_contents)) - (update m.(nextblock) - (fun ofs => if zle lo ofs && zlt ofs hi then Some Freeable else None) - m.(mem_access)) - (update m.(nextblock) (lo, hi) m.(bounds)) + (mkmem (ZMap.set m.(nextblock) + (ZMap.init Undef) + m.(mem_contents)) + (ZMap.set m.(nextblock) + (fun ofs k => if zle lo ofs && zlt ofs hi then Some Freeable else None) + m.(mem_access)) (Zsucc m.(nextblock)) - _ _ _ _, + _ _ _, m.(nextblock)). Next Obligation. generalize (nextblock_pos m). omega. Qed. Next Obligation. - assert (0 < b < Zsucc (nextblock m) \/ b <= 0 \/ b > nextblock m) by omega. - destruct H as [?|[?|?]]. left; omega. - right. - rewrite update_o. - destruct (nextblock_noaccess m b); auto. elimtype False; omega. - generalize (nextblock_pos m); omega. -(* generalize (bounds_noaccess m b 0).*) - destruct (nextblock_noaccess m b); auto. left; omega. - rewrite update_o. right; auto. omega. -Qed. -Next Obligation. - unfold update in *. destruct (zeq b (nextblock m)). - simpl in H. destruct H. - unfold proj_sumbool. rewrite zle_false. auto. omega. - unfold proj_sumbool. rewrite zlt_false; auto. rewrite andb_false_r. auto. - apply bounds_noaccess. auto. + repeat rewrite ZMap.gsspec. destruct (ZIndexed.eq b (nextblock m)). + subst b. destruct (zle lo ofs && zlt ofs hi); red; auto with mem. + apply access_max. Qed. Next Obligation. -unfold update. -destruct (zeq b (nextblock m)); auto. -apply noread_undef. + rewrite ZMap.gsspec. destruct (ZIndexed.eq b (nextblock m)). + subst b. generalize (nextblock_pos m). intros. omegaContradiction. + apply nextblock_noaccess. omega. Qed. - (** Freeing a block between the given bounds. Return the updated memory state where the given range of the given block has been invalidated: future reads and writes to this - range will fail. Requires write permission on the given range. *) - -Definition clearN (m: block -> Z -> memval) (b: block) (lo hi: Z) : - block -> Z -> memval := - fun b' ofs => if zeq b' b - then if zle lo ofs && zlt ofs hi then Undef else m b' ofs - else m b' ofs. - -Lemma clearN_in: - forall m b lo hi ofs, lo <= ofs < hi -> clearN m b lo hi b ofs = Undef. -Proof. -intros. unfold clearN. rewrite zeq_true. -destruct H; unfold andb, proj_sumbool. -rewrite zle_true; auto. rewrite zlt_true; auto. -Qed. - -Lemma clearN_out: - forall m b lo hi b' ofs, (b<>b' \/ ofs < lo \/ hi <= ofs) -> clearN m b lo hi b' ofs = m b' ofs. -Proof. -intros. unfold clearN. destruct (zeq b' b); auto. -subst b'. -destruct H. contradiction H; auto. -destruct (zle lo ofs); auto. -destruct (zlt ofs hi); auto. -elimtype False; omega. -Qed. - + range will fail. Requires freeable permission on the given range. *) Program Definition unchecked_free (m: mem) (b: block) (lo hi: Z): mem := - mkmem (clearN m.(mem_contents) b lo hi) - (update b - (fun ofs => if zle lo ofs && zlt ofs hi then None else m.(mem_access) b ofs) + mkmem m.(mem_contents) + (ZMap.set b + (fun ofs k => if zle lo ofs && zlt ofs hi then None else m.(mem_access)#b ofs k) m.(mem_access)) - m.(bounds) - m.(nextblock) _ _ _ _. + m.(nextblock) _ _ _. Next Obligation. apply nextblock_pos. Qed. Next Obligation. -apply (nextblock_noaccess m b0). + repeat rewrite ZMap.gsspec. destruct (ZIndexed.eq b0 b). + destruct (zle lo ofs && zlt ofs hi). red; auto. apply access_max. + apply access_max. Qed. Next Obligation. - unfold update. destruct (zeq b0 b). subst b0. - destruct (zle lo ofs); simpl; auto. - destruct (zlt ofs hi); simpl; auto. - apply bounds_noaccess; auto. - apply bounds_noaccess; auto. - apply bounds_noaccess; auto. -Qed. -Next Obligation. - unfold clearN, update. - destruct (zeq b0 b). subst b0. - destruct (zle lo ofs); simpl; auto. - destruct (zlt ofs hi); simpl; auto. - apply noread_undef. - apply noread_undef. - apply noread_undef. + repeat rewrite ZMap.gsspec. destruct (ZIndexed.eq b0 b). subst. + destruct (zle lo ofs && zlt ofs hi). auto. apply nextblock_noaccess; auto. + apply nextblock_noaccess; auto. Qed. Definition free (m: mem) (b: block) (lo hi: Z): option mem := - if range_perm_dec m b lo hi Freeable + if range_perm_dec m b lo hi Cur Freeable then Some(unchecked_free m b lo hi) else None. @@ -467,10 +405,10 @@ Fixpoint free_list (m: mem) (l: list (block * Z * Z)) {struct l}: option mem := (** Reading N adjacent bytes in a block content. *) -Fixpoint getN (n: nat) (p: Z) (c: Z -> memval) {struct n}: list memval := +Fixpoint getN (n: nat) (p: Z) (c: ZMap.t memval) {struct n}: list memval := match n with | O => nil - | S n' => c p :: getN n' (p + 1) c + | S n' => c#p :: getN n' (p + 1) c end. (** [load chunk m b ofs] perform a read in memory state [m], at address @@ -480,7 +418,7 @@ Fixpoint getN (n: nat) (p: Z) (c: Z -> memval) {struct n}: list memval := Definition load (chunk: memory_chunk) (m: mem) (b: block) (ofs: Z): option val := if valid_access_dec m chunk b ofs Readable - then Some(decode_val chunk (getN (size_chunk_nat chunk) ofs (m.(mem_contents) b))) + then Some(decode_val chunk (getN (size_chunk_nat chunk) ofs (m.(mem_contents)#b))) else None. (** [loadv chunk m addr] is similar, but the address and offset are given @@ -497,38 +435,37 @@ Definition loadv (chunk: memory_chunk) (m: mem) (addr: val) : option val := not readable. *) Definition loadbytes (m: mem) (b: block) (ofs n: Z): option (list memval) := - if range_perm_dec m b ofs (ofs + n) Readable - then Some (getN (nat_of_Z n) ofs (m.(mem_contents) b)) + if range_perm_dec m b ofs (ofs + n) Cur Readable + then Some (getN (nat_of_Z n) ofs (m.(mem_contents)#b)) else None. (** Memory stores. *) (** Writing N adjacent bytes in a block content. *) -Fixpoint setN (vl: list memval) (p: Z) (c: Z -> memval) {struct vl}: Z -> memval := +Fixpoint setN (vl: list memval) (p: Z) (c: ZMap.t memval) {struct vl}: ZMap.t memval := match vl with | nil => c - | v :: vl' => setN vl' (p + 1) (update p v c) + | v :: vl' => setN vl' (p + 1) (ZMap.set p v c) end. - Remark setN_other: forall vl c p q, (forall r, p <= r < p + Z_of_nat (length vl) -> r <> q) -> - setN vl p c q = c q. + (setN vl p c)#q = c#q. Proof. induction vl; intros; simpl. auto. simpl length in H. rewrite inj_S in H. - transitivity (update p a c q). - apply IHvl. intros. apply H. omega. - apply update_o. apply H. omega. + transitivity ((ZMap.set p a c)#q). + apply IHvl. intros. apply H. omega. + apply ZMap.gso. apply not_eq_sym. apply H. omega. Qed. Remark setN_outside: forall vl c p q, q < p \/ q >= p + Z_of_nat (length vl) -> - setN vl p c q = c q. + (setN vl p c)#q = c#q. Proof. intros. apply setN_other. intros. omega. @@ -541,13 +478,13 @@ Proof. induction vl; intros; simpl. auto. decEq. - rewrite setN_outside. apply update_s. omega. + rewrite setN_outside. apply ZMap.gss. omega. apply IHvl. Qed. Remark getN_exten: forall c1 c2 n p, - (forall i, p <= i < p + Z_of_nat n -> c1 i = c2 i) -> + (forall i, p <= i < p + Z_of_nat n -> c1#i = c2#i) -> getN n p c1 = getN n p c2. Proof. induction n; intros. auto. rewrite inj_S in H. simpl. decEq. @@ -562,50 +499,23 @@ Proof. intros. apply getN_exten. intros. apply setN_outside. omega. Qed. -Lemma setN_noread_undef: - forall m b ofs bytes (RP: range_perm m b ofs (ofs + Z_of_nat (length bytes)) Writable), - forall b' ofs', - perm m b' ofs' Readable \/ - update b (setN bytes ofs (mem_contents m b)) (mem_contents m) b' ofs' = Undef. -Proof. - intros. unfold update. destruct (zeq b' b). subst b'. - assert (ofs <= ofs' < ofs + Z_of_nat (length bytes) - \/ ofs' < ofs - \/ ofs' >= ofs + Z_of_nat (length bytes)) by omega. - destruct H. left. apply perm_implies with Writable; auto with mem. - rewrite setN_outside; auto. apply noread_undef; auto. - apply noread_undef; auto. -Qed. - -Lemma store_noread_undef: - forall m ch b ofs (VA: valid_access m ch b ofs Writable) v, - forall b' ofs', - perm m b' ofs' Readable \/ - update b (setN (encode_val ch v) ofs (mem_contents m b)) (mem_contents m) b' ofs' = Undef. -Proof. - intros. destruct VA. apply setN_noread_undef. - rewrite encode_val_length. rewrite <- size_chunk_conv. auto. -Qed. - (** [store chunk m b ofs v] perform a write in memory state [m]. Value [v] is stored at address [b] and offset [ofs]. Return the updated memory store, or [None] if the accessed bytes are not writable. *) Definition store (chunk: memory_chunk) (m: mem) (b: block) (ofs: Z) (v: val): option mem := - match valid_access_dec m chunk b ofs Writable with - | left VA => Some (mkmem (update b - (setN (encode_val chunk v) ofs (m.(mem_contents) b)) - m.(mem_contents)) - m.(mem_access) - m.(bounds) - m.(nextblock) - m.(nextblock_pos) - m.(nextblock_noaccess) - m.(bounds_noaccess) - (store_noread_undef m chunk b ofs VA v)) - | right _ => None - end. + if valid_access_dec m chunk b ofs Writable then + Some (mkmem (ZMap.set b + (setN (encode_val chunk v) ofs (m.(mem_contents)#b)) + m.(mem_contents)) + m.(mem_access) + m.(nextblock) + m.(nextblock_pos) + m.(access_max) + m.(nextblock_noaccess)) + else + None. (** [storev chunk m addr v] is similar, but the address and offset are given as a single value [addr], which must be a pointer value. *) @@ -621,57 +531,45 @@ Definition storev (chunk: memory_chunk) (m: mem) (addr v: val) : option mem := or [None] if the accessed locations are not writable. *) Definition storebytes (m: mem) (b: block) (ofs: Z) (bytes: list memval) : option mem := - match range_perm_dec m b ofs (ofs + Z_of_nat (length bytes)) Writable with - | left RP => - Some (mkmem - (update b (setN bytes ofs (m.(mem_contents) b)) m.(mem_contents)) + if range_perm_dec m b ofs (ofs + Z_of_nat (length bytes)) Cur Writable then + Some (mkmem + (ZMap.set b (setN bytes ofs (m.(mem_contents)#b)) m.(mem_contents)) m.(mem_access) - m.(bounds) m.(nextblock) m.(nextblock_pos) - m.(nextblock_noaccess) - m.(bounds_noaccess) - (setN_noread_undef m b ofs bytes RP)) - | right _ => - None - end. - -(** [drop_perm m b lo hi p] sets the permissions of the byte range - [(b, lo) ... (b, hi - 1)] to [p]. These bytes must have permissions - at least [p] in the initial memory state [m]. + m.(access_max) + m.(nextblock_noaccess)) + else + None. + +(** [drop_perm m b lo hi p] sets the max permissions of the byte range + [(b, lo) ... (b, hi - 1)] to [p]. These bytes must have current permissions + [Freeable] in the initial memory state [m]. Returns updated memory state, or [None] if insufficient permissions. *) Program Definition drop_perm (m: mem) (b: block) (lo hi: Z) (p: permission): option mem := - if range_perm_dec m b lo hi p then - Some (mkmem (update b - (fun ofs => if zle lo ofs && zlt ofs hi && negb (perm_order_dec p Readable) - then Undef else m.(mem_contents) b ofs) - m.(mem_contents)) - (update b - (fun ofs => if zle lo ofs && zlt ofs hi then Some p else m.(mem_access) b ofs) + if range_perm_dec m b lo hi Cur Freeable then + Some (mkmem m.(mem_contents) + (ZMap.set b + (fun ofs k => if zle lo ofs && zlt ofs hi then Some p else m.(mem_access)#b ofs k) m.(mem_access)) - m.(bounds) m.(nextblock) _ _ _ _) + m.(nextblock) _ _ _) else None. Next Obligation. - destruct m; auto. + apply nextblock_pos. Qed. Next Obligation. - destruct m; auto. + repeat rewrite ZMap.gsspec. destruct (ZIndexed.eq b0 b). subst b0. + destruct (zle lo ofs && zlt ofs hi). red; auto with mem. apply access_max. + apply access_max. Qed. Next Obligation. - unfold update. destruct (zeq b0 b). subst b0. + specialize (nextblock_noaccess m b0 ofs k H0). intros. + rewrite ZMap.gsspec. destruct (ZIndexed.eq b0 b). subst b0. destruct (zle lo ofs). destruct (zlt ofs hi). - exploit range_perm_in_bounds; eauto. omega. intros. omegaContradiction. - simpl. eapply bounds_noaccess; eauto. - simpl. eapply bounds_noaccess; eauto. - eapply bounds_noaccess; eauto. -Qed. -Next Obligation. - unfold update. destruct (zeq b0 b). subst b0. - destruct (zle lo ofs && zlt ofs hi). - destruct (perm_order_dec p Readable); simpl; auto. - eapply noread_undef; eauto. - eapply noread_undef; eauto. + assert (perm m b ofs k Freeable). apply perm_cur. apply H; auto. + unfold perm in H2. rewrite H1 in H2. contradiction. + auto. auto. auto. Qed. (** * Properties of the memory operations *) @@ -681,14 +579,14 @@ Qed. Theorem nextblock_empty: nextblock empty = 1. Proof. reflexivity. Qed. -Theorem perm_empty: forall b ofs p, ~perm empty b ofs p. +Theorem perm_empty: forall b ofs k p, ~perm empty b ofs k p. Proof. - intros. unfold perm, empty; simpl. congruence. + intros. unfold perm, empty; simpl. rewrite ZMap.gi. simpl. tauto. Qed. Theorem valid_access_empty: forall chunk b ofs p, ~valid_access empty chunk b ofs p. Proof. - intros. red; intros. elim (perm_empty b ofs p). apply H. + intros. red; intros. elim (perm_empty b ofs Cur p). apply H. generalize (size_chunk_pos chunk); omega. Qed. @@ -716,7 +614,7 @@ Qed. Lemma load_result: forall chunk m b ofs v, load chunk m b ofs = Some v -> - v = decode_val chunk (getN (size_chunk_nat chunk) ofs (m.(mem_contents) b)). + v = decode_val chunk (getN (size_chunk_nat chunk) ofs (m.(mem_contents)#b)). Proof. intros until v. unfold load. destruct (valid_access_dec m chunk b ofs Readable); intros. @@ -748,7 +646,7 @@ Theorem load_cast: end. Proof. intros. exploit load_result; eauto. - set (l := getN (size_chunk_nat chunk) ofs (mem_contents m b)). + set (l := getN (size_chunk_nat chunk) ofs m.(mem_contents)#b). intros. subst v. apply decode_val_cast. Qed. @@ -758,7 +656,7 @@ Theorem load_int8_signed_unsigned: Proof. intros. unfold load. change (size_chunk_nat Mint8signed) with (size_chunk_nat Mint8unsigned). - set (cl := getN (size_chunk_nat Mint8unsigned) ofs (mem_contents m b)). + set (cl := getN (size_chunk_nat Mint8unsigned) ofs m.(mem_contents)#b). destruct (valid_access_dec m Mint8signed b ofs Readable). rewrite pred_dec_true; auto. unfold decode_val. destruct (proj_bytes cl); auto. rewrite decode_int8_signed_unsigned. auto. @@ -771,7 +669,7 @@ Theorem load_int16_signed_unsigned: Proof. intros. unfold load. change (size_chunk_nat Mint16signed) with (size_chunk_nat Mint16unsigned). - set (cl := getN (size_chunk_nat Mint16unsigned) ofs (mem_contents m b)). + set (cl := getN (size_chunk_nat Mint16unsigned) ofs m.(mem_contents)#b). destruct (valid_access_dec m Mint16signed b ofs Readable). rewrite pred_dec_true; auto. unfold decode_val. destruct (proj_bytes cl); auto. rewrite decode_int16_signed_unsigned. auto. @@ -782,7 +680,7 @@ Qed. Theorem range_perm_loadbytes: forall m b ofs len, - range_perm m b ofs (ofs + len) Readable -> + range_perm m b ofs (ofs + len) Cur Readable -> exists bytes, loadbytes m b ofs len = Some bytes. Proof. intros. econstructor. unfold loadbytes. rewrite pred_dec_true; eauto. @@ -791,10 +689,10 @@ Qed. Theorem loadbytes_range_perm: forall m b ofs len bytes, loadbytes m b ofs len = Some bytes -> - range_perm m b ofs (ofs + len) Readable. + range_perm m b ofs (ofs + len) Cur Readable. Proof. intros until bytes. unfold loadbytes. - destruct (range_perm_dec m b ofs (ofs + len) Readable). auto. congruence. + destruct (range_perm_dec m b ofs (ofs + len) Cur Readable). auto. congruence. Qed. Theorem loadbytes_load: @@ -804,7 +702,7 @@ Theorem loadbytes_load: load chunk m b ofs = Some(decode_val chunk bytes). Proof. unfold loadbytes, load; intros. - destruct (range_perm_dec m b ofs (ofs + size_chunk chunk) Readable); + destruct (range_perm_dec m b ofs (ofs + size_chunk chunk) Cur Readable); try congruence. inv H. rewrite pred_dec_true. auto. split; auto. @@ -818,7 +716,7 @@ Theorem load_loadbytes: Proof. intros. exploit load_valid_access; eauto. intros [A B]. exploit load_result; eauto. intros. - exists (getN (size_chunk_nat chunk) ofs (mem_contents m b)); split. + exists (getN (size_chunk_nat chunk) ofs m.(mem_contents)#b); split. unfold loadbytes. rewrite pred_dec_true; auto. auto. Qed. @@ -835,7 +733,7 @@ Theorem loadbytes_length: length bytes = nat_of_Z n. Proof. unfold loadbytes; intros. - destruct (range_perm_dec m b ofs (ofs + n) Readable); try congruence. + destruct (range_perm_dec m b ofs (ofs + n) Cur Readable); try congruence. inv H. apply getN_length. Qed. @@ -866,8 +764,8 @@ Theorem loadbytes_concat: loadbytes m b ofs (n1 + n2) = Some(bytes1 ++ bytes2). Proof. unfold loadbytes; intros. - destruct (range_perm_dec m b ofs (ofs + n1) Readable); try congruence. - destruct (range_perm_dec m b (ofs + n1) (ofs + n1 + n2) Readable); try congruence. + 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. congruence. @@ -886,7 +784,7 @@ Theorem loadbytes_split: /\ bytes = bytes1 ++ bytes2. Proof. unfold loadbytes; intros. - destruct (range_perm_dec m b ofs (ofs + (n1 + n2)) Readable); + 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. @@ -899,28 +797,28 @@ Qed. Theorem load_rep: forall ch m1 m2 b ofs v1 v2, - (forall z, 0 <= z < size_chunk ch -> mem_contents m1 b (ofs+z) = mem_contents m2 b (ofs+z)) -> + (forall z, 0 <= z < size_chunk ch -> m1.(mem_contents)#b#(ofs+z) = m2.(mem_contents)#b#(ofs+z)) -> load ch m1 b ofs = Some v1 -> load ch m2 b ofs = Some v2 -> v1 = v2. Proof. -intros. -apply load_result in H0. -apply load_result in H1. -subst. -f_equal. -rewrite size_chunk_conv in H. -remember (size_chunk_nat ch) as n; clear Heqn. -revert ofs H; induction n; intros; simpl; auto. -f_equal. -rewrite inj_S in H. -replace ofs with (ofs+0) by omega. -apply H; omega. -apply IHn. -intros. -rewrite <- Zplus_assoc. -apply H. -rewrite inj_S. omega. + intros. + apply load_result in H0. + apply load_result in H1. + subst. + f_equal. + rewrite size_chunk_conv in H. + remember (size_chunk_nat ch) as n; clear Heqn. + revert ofs H; induction n; intros; simpl; auto. + f_equal. + rewrite inj_S in H. + replace ofs with (ofs+0) by omega. + apply H; omega. + apply IHn. + intros. + rewrite <- Zplus_assoc. + apply H. + rewrite inj_S. omega. Qed. (** ** Properties related to [store] *) @@ -954,27 +852,27 @@ Proof. auto. Qed. -Lemma store_mem_contents: mem_contents m2 = - update b (setN (encode_val chunk v) ofs (m1.(mem_contents) b)) m1.(mem_contents). +Lemma store_mem_contents: + mem_contents m2 = ZMap.set b (setN (encode_val chunk v) ofs m1.(mem_contents)#b) m1.(mem_contents). Proof. unfold store in STORE. destruct ( valid_access_dec m1 chunk b ofs Writable); inv STORE. auto. Qed. Theorem perm_store_1: - forall b' ofs' p, perm m1 b' ofs' p -> perm m2 b' ofs' p. + forall b' ofs' k p, perm m1 b' ofs' k p -> perm m2 b' ofs' k p. Proof. intros. unfold perm in *. rewrite store_access; auto. Qed. Theorem perm_store_2: - forall b' ofs' p, perm m2 b' ofs' p -> perm m1 b' ofs' p. + forall b' ofs' k p, perm m2 b' ofs' k p -> perm m1 b' ofs' k p. Proof. intros. unfold perm in *. rewrite store_access in H; auto. Qed. -Hint Local Resolve perm_store_1 perm_store_2: mem. +Local Hint Resolve perm_store_1 perm_store_2: mem. Theorem nextblock_store: nextblock m2 = nextblock m1. @@ -996,7 +894,7 @@ Proof. unfold valid_block; intros. rewrite nextblock_store in H; auto. Qed. -Hint Local Resolve store_valid_block_1 store_valid_block_2: mem. +Local Hint Resolve store_valid_block_1 store_valid_block_2: mem. Theorem store_valid_access_1: forall chunk' b' ofs' p, @@ -1020,16 +918,7 @@ Proof. congruence. Qed. -Hint Local Resolve store_valid_access_1 store_valid_access_2 - store_valid_access_3: mem. - -Theorem bounds_store: - forall b', bounds m2 b' = bounds m1 b'. -Proof. - intros. - unfold store in STORE. - destruct ( valid_access_dec m1 chunk b ofs Writable); inv STORE. simpl. auto. -Qed. +Local Hint Resolve store_valid_access_1 store_valid_access_2 store_valid_access_3: mem. Theorem load_store_similar: forall chunk', @@ -1043,7 +932,7 @@ Proof. exists v'; split; auto. exploit load_result; eauto. intros B. rewrite B. rewrite store_mem_contents; simpl. - rewrite update_s. + rewrite ZMap.gss. replace (size_chunk_nat chunk') with (length (encode_val chunk v)). rewrite getN_setN_same. apply decode_encode_val_general. rewrite encode_val_length. repeat rewrite size_chunk_conv in H. @@ -1070,7 +959,7 @@ Proof. destruct (valid_access_dec m1 chunk' b' ofs' Readable). rewrite pred_dec_true. decEq. decEq. rewrite store_mem_contents; simpl. - unfold update. destruct (zeq b' b). subst b'. + rewrite ZMap.gsspec. destruct (ZIndexed.eq b' b). subst b'. apply getN_setN_outside. rewrite encode_val_length. repeat rewrite <- size_chunk_conv. intuition. auto. @@ -1085,9 +974,8 @@ Proof. intros. assert (valid_access m2 chunk b ofs Readable) by eauto with mem. unfold loadbytes. rewrite pred_dec_true. rewrite store_mem_contents; simpl. - rewrite update_s. - replace (nat_of_Z (size_chunk chunk)) - with (length (encode_val chunk v)). + rewrite ZMap.gss. + replace (nat_of_Z (size_chunk chunk)) with (length (encode_val chunk v)). rewrite getN_setN_same. auto. rewrite encode_val_length. auto. apply H. @@ -1102,10 +990,10 @@ Theorem loadbytes_store_other: loadbytes m2 b' ofs' n = loadbytes m1 b' ofs' n. Proof. intros. unfold loadbytes. - destruct (range_perm_dec m1 b' ofs' (ofs' + n) Readable). + destruct (range_perm_dec m1 b' ofs' (ofs' + n) Cur Readable). rewrite pred_dec_true. decEq. rewrite store_mem_contents; simpl. - unfold update. destruct (zeq b' b). subst b'. + rewrite ZMap.gsspec. destruct (ZIndexed.eq b' b). subst b'. destruct H. congruence. destruct (zle n 0). rewrite (nat_of_Z_neg _ z). auto. @@ -1122,12 +1010,12 @@ Lemma setN_property: forall (P: memval -> Prop) vl p q c, (forall v, In v vl -> P v) -> p <= q < p + Z_of_nat (length vl) -> - P(setN vl p c q). + P((setN vl p c)#q). Proof. induction vl; intros. simpl in H0. omegaContradiction. simpl length in H0. rewrite inj_S in H0. simpl. - destruct (zeq p q). subst q. rewrite setN_outside. rewrite update_s. + destruct (zeq p q). subst q. rewrite setN_outside. rewrite ZMap.gss. auto with coqlib. omega. apply IHvl. auto with coqlib. omega. Qed. @@ -1135,7 +1023,7 @@ Qed. Lemma getN_in: forall c q n p, p <= q < p + Z_of_nat n -> - In (c q) (getN n p c). + In (c#q) (getN n p c). Proof. induction n; intros. simpl in H; omegaContradiction. @@ -1151,14 +1039,14 @@ Theorem load_pointer_store: \/ (b' <> b \/ ofs' + size_chunk chunk' <= ofs \/ ofs + size_chunk chunk <= ofs'). Proof. intros. exploit load_result; eauto. rewrite store_mem_contents; simpl. - unfold update. destruct (zeq b' b); auto. subst b'. intro DEC. + rewrite ZMap.gsspec. destruct (ZIndexed.eq b' b); auto. subst b'. intro DEC. destruct (zle (ofs' + size_chunk chunk') ofs); auto. destruct (zle (ofs + size_chunk chunk) ofs'); auto. destruct (size_chunk_nat_pos chunk) as [sz SZ]. destruct (size_chunk_nat_pos chunk') as [sz' SZ']. exploit decode_pointer_shape; eauto. intros [CHUNK' PSHAPE]. clear CHUNK'. generalize (encode_val_shape chunk v). intro VSHAPE. - set (c := mem_contents m1 b) in *. + set (c := m1.(mem_contents)#b) in *. set (c' := setN (encode_val chunk v) ofs c) in *. destruct (zeq ofs ofs'). @@ -1167,7 +1055,7 @@ Proof. exploit decode_val_pointer_inv; eauto. intros [A B]. subst chunk'. simpl in B. inv B. generalize H4. unfold c'. rewrite <- H0. simpl. - rewrite setN_outside; try omega. rewrite update_s. intros. + rewrite setN_outside; try omega. rewrite ZMap.gss. intros. exploit (encode_val_pointer_inv chunk v v_b v_o). rewrite <- H0. subst mv1. eauto. intros [C [D E]]. left; auto. @@ -1184,9 +1072,9 @@ Proof. For the read to return a pointer, it must satisfy ~memval_valid_cont. *) elimtype False. - assert (~memval_valid_cont (c' ofs')). + assert (~memval_valid_cont (c'#ofs')). rewrite SZ' in PSHAPE. simpl in PSHAPE. inv PSHAPE. auto. - assert (memval_valid_cont (c' ofs')). + assert (memval_valid_cont (c'#ofs')). inv VSHAPE. unfold c'. rewrite <- H1. simpl. apply setN_property. auto. assert (length mvl = sz). @@ -1205,10 +1093,10 @@ Proof. For the read to return a pointer, it must satisfy ~memval_valid_first. *) elimtype False. - assert (memval_valid_first (c' ofs)). + assert (memval_valid_first (c'#ofs)). inv VSHAPE. unfold c'. rewrite <- H0. simpl. - rewrite setN_outside. rewrite update_s. auto. omega. - assert (~memval_valid_first (c' ofs)). + rewrite setN_outside. rewrite ZMap.gss. auto. omega. + assert (~memval_valid_first (c'#ofs)). rewrite SZ' in PSHAPE. simpl in PSHAPE. inv PSHAPE. apply H4. apply getN_in. rewrite size_chunk_conv in z. rewrite SZ' in z. rewrite inj_S in z. omega. @@ -1217,9 +1105,9 @@ Qed. End STORE. -Hint Local Resolve perm_store_1 perm_store_2: mem. -Hint Local Resolve store_valid_block_1 store_valid_block_2: mem. -Hint Local Resolve store_valid_access_1 store_valid_access_2 +Local Hint Resolve perm_store_1 perm_store_2: mem. +Local Hint Resolve store_valid_block_1 store_valid_block_2: mem. +Local Hint Resolve store_valid_access_1 store_valid_access_2 store_valid_access_3: mem. Theorem load_store_pointer_overlap: @@ -1237,8 +1125,8 @@ Proof. rewrite LD; clear LD. Opaque encode_val. rewrite ST; simpl. - rewrite update_s. - set (c := mem_contents m1 b). + rewrite ZMap.gss. + set (c := m1.(mem_contents)#b). set (c' := setN (encode_val chunk (Vptr v_b v_o)) ofs c). destruct (decode_val_shape chunk' (getN (size_chunk_nat chunk') ofs' c')) as [OK | VSHAPE]. @@ -1265,9 +1153,9 @@ Opaque encode_val. The byte at ofs' is Undef or not memval_valid_first (because write of pointer). The byte at ofs' must be memval_valid_first and not Undef (otherwise load returns Vundef). *) - assert (memval_valid_first (c' ofs') /\ c' ofs' <> Undef). + assert (memval_valid_first (c'#ofs') /\ c'#ofs' <> Undef). rewrite SZ' in VSHAPE. simpl in VSHAPE. inv VSHAPE. auto. - assert (~memval_valid_first (c' ofs') \/ c' ofs' = Undef). + assert (~memval_valid_first (c'#ofs') \/ c'#ofs' = Undef). unfold c'. destruct ENC. right. apply setN_property. rewrite H5. intros. eapply in_list_repeat; eauto. rewrite encode_val_length. rewrite <- size_chunk_conv. omega. @@ -1285,11 +1173,11 @@ Opaque encode_val. The byte at ofs is Undef or not memval_valid_cont (because write of pointer). The byte at ofs must be memval_valid_cont and not Undef (otherwise load returns Vundef). *) - assert (memval_valid_cont (c' ofs) /\ c' ofs <> Undef). + assert (memval_valid_cont (c'#ofs) /\ c'#ofs <> Undef). rewrite SZ' in VSHAPE. simpl in VSHAPE. inv VSHAPE. apply H8. apply getN_in. rewrite size_chunk_conv in H2. rewrite SZ' in H2. rewrite inj_S in H2. omega. - assert (~memval_valid_cont (c' ofs) \/ c' ofs = Undef). + assert (~memval_valid_cont (c'#ofs) \/ c'#ofs = Undef). elim ENC. rewrite <- GET. rewrite SZ. simpl. intros. right; congruence. rewrite <- GET. rewrite SZ. simpl. intros. inv H5. auto. @@ -1309,8 +1197,8 @@ Proof. rewrite LD; clear LD. Opaque encode_val. rewrite ST; simpl. - rewrite update_s. - set (c1 := mem_contents m1 b). + rewrite ZMap.gss. + set (c1 := m1.(mem_contents)#b). set (e := encode_val chunk (Vptr v_b v_o)). destruct (size_chunk_nat_pos chunk) as [sz SZ]. destruct (size_chunk_nat_pos chunk') as [sz' SZ']. @@ -1322,7 +1210,7 @@ Opaque encode_val. Transparent encode_val. unfold e, encode_val. rewrite SZ. destruct chunk; simpl; auto. destruct e as [ | e1 el]. contradiction. - rewrite SZ'. simpl. rewrite setN_outside. rewrite update_s. + rewrite SZ'. simpl. rewrite setN_outside. rewrite ZMap.gss. destruct e1; try contradiction. destruct chunk'; auto. destruct chunk'; auto. intuition. @@ -1350,7 +1238,6 @@ Proof. destruct chunk1; destruct chunk2; inv H0; unfold valid_access, align_chunk in *; try contradiction. Qed. - Theorem store_signed_unsigned_8: forall m b ofs v, store Mint8signed m b ofs v = store Mint8unsigned m b ofs v. @@ -1395,22 +1282,12 @@ Proof. intros. apply store_similar_chunks. simpl. decEq. apply encode_float32_ca Theorem range_perm_storebytes: forall m1 b ofs bytes, - range_perm m1 b ofs (ofs + Z_of_nat (length bytes)) Writable -> + range_perm m1 b ofs (ofs + Z_of_nat (length bytes)) Cur Writable -> { m2 : mem | storebytes m1 b ofs bytes = Some m2 }. Proof. - intros. - exists (mkmem - (update b (setN bytes ofs (m1.(mem_contents) b)) m1.(mem_contents)) - m1.(mem_access) - m1.(bounds) - m1.(nextblock) - m1.(nextblock_pos) - m1.(nextblock_noaccess) - m1.(bounds_noaccess) - (setN_noread_undef m1 b ofs bytes H)). - unfold storebytes. - destruct (range_perm_dec m1 b ofs (ofs + Z_of_nat (length bytes)) Writable). - decEq. decEq. apply proof_irr. + intros. econstructor. unfold storebytes. + destruct (range_perm_dec m1 b ofs (ofs + Z_of_nat (length bytes)) Cur Writable). + reflexivity. contradiction. Qed. @@ -1421,9 +1298,9 @@ Theorem storebytes_store: store chunk m1 b ofs v = Some m2. Proof. unfold storebytes, store. intros. - destruct (range_perm_dec m1 b ofs (ofs + Z_of_nat (length (encode_val chunk v))) Writable); inv H. + destruct (range_perm_dec m1 b ofs (ofs + Z_of_nat (length (encode_val chunk v))) Cur Writable); inv H. destruct (valid_access_dec m1 chunk b ofs Writable). - decEq. decEq. apply proof_irr. + auto. elim n. constructor; auto. rewrite encode_val_length in r. rewrite size_chunk_conv. auto. Qed. @@ -1435,21 +1312,11 @@ Theorem store_storebytes: Proof. unfold storebytes, store. intros. destruct (valid_access_dec m1 chunk b ofs Writable); inv H. - destruct (range_perm_dec m1 b ofs (ofs + Z_of_nat (length (encode_val chunk v))) Writable). - decEq. decEq. apply proof_irr. + destruct (range_perm_dec m1 b ofs (ofs + Z_of_nat (length (encode_val chunk v))) Cur Writable). + auto. destruct v0. elim n. rewrite encode_val_length. rewrite <- size_chunk_conv. auto. Qed. - -Theorem storebytes_empty: - forall m b ofs, storebytes m b ofs nil = Some m. -Proof. - intros. unfold storebytes. simpl. - destruct (range_perm_dec m b ofs (ofs + 0) Writable). - decEq. destruct m; simpl; apply mkmem_ext; auto. - apply extensionality. unfold update; intros. destruct (zeq x b); congruence. - elim n. red; intros; omegaContradiction. -Qed. Section STOREBYTES. Variable m1: mem. @@ -1462,33 +1329,33 @@ Hypothesis STORE: storebytes m1 b ofs bytes = Some m2. Lemma storebytes_access: mem_access m2 = mem_access m1. Proof. unfold storebytes in STORE. - destruct (range_perm_dec m1 b ofs (ofs + Z_of_nat (length bytes)) Writable); + destruct (range_perm_dec m1 b ofs (ofs + Z_of_nat (length bytes)) Cur Writable); inv STORE. auto. Qed. Lemma storebytes_mem_contents: - mem_contents m2 = update b (setN bytes ofs (m1.(mem_contents) b)) m1.(mem_contents). + mem_contents m2 = ZMap.set b (setN bytes ofs m1.(mem_contents)#b) m1.(mem_contents). Proof. unfold storebytes in STORE. - destruct (range_perm_dec m1 b ofs (ofs + Z_of_nat (length bytes)) Writable); + destruct (range_perm_dec m1 b ofs (ofs + Z_of_nat (length bytes)) Cur Writable); inv STORE. auto. Qed. Theorem perm_storebytes_1: - forall b' ofs' p, perm m1 b' ofs' p -> perm m2 b' ofs' p. + forall b' ofs' k p, perm m1 b' ofs' k p -> perm m2 b' ofs' k p. Proof. intros. unfold perm in *. rewrite storebytes_access; auto. Qed. Theorem perm_storebytes_2: - forall b' ofs' p, perm m2 b' ofs' p -> perm m1 b' ofs' p. + forall b' ofs' k p, perm m2 b' ofs' k p -> perm m1 b' ofs' k p. Proof. intros. unfold perm in *. rewrite storebytes_access in H; auto. Qed. -Hint Local Resolve perm_storebytes_1 perm_storebytes_2: mem. +Local Hint Resolve perm_storebytes_1 perm_storebytes_2: mem. Theorem storebytes_valid_access_1: forall chunk' b' ofs' p, @@ -1504,14 +1371,14 @@ Proof. intros. inv H. constructor; try red; auto with mem. Qed. -Hint Local Resolve storebytes_valid_access_1 storebytes_valid_access_2: mem. +Local Hint Resolve storebytes_valid_access_1 storebytes_valid_access_2: mem. Theorem nextblock_storebytes: nextblock m2 = nextblock m1. Proof. intros. unfold storebytes in STORE. - destruct (range_perm_dec m1 b ofs (ofs + Z_of_nat (length bytes)) Writable); + destruct (range_perm_dec m1 b ofs (ofs + Z_of_nat (length bytes)) Cur Writable); inv STORE. auto. Qed. @@ -1528,24 +1395,14 @@ Proof. unfold valid_block; intros. rewrite nextblock_storebytes in H; auto. Qed. -Hint Local Resolve storebytes_valid_block_1 storebytes_valid_block_2: mem. +Local Hint Resolve storebytes_valid_block_1 storebytes_valid_block_2: mem. Theorem storebytes_range_perm: - range_perm m1 b ofs (ofs + Z_of_nat (length bytes)) Writable. + range_perm m1 b ofs (ofs + Z_of_nat (length bytes)) Cur Writable. Proof. intros. unfold storebytes in STORE. - destruct (range_perm_dec m1 b ofs (ofs + Z_of_nat (length bytes)) Writable); - inv STORE. - auto. -Qed. - -Theorem bounds_storebytes: - forall b', bounds m2 b' = bounds m1 b'. -Proof. - intros. - unfold storebytes in STORE. - destruct (range_perm_dec m1 b ofs (ofs + Z_of_nat (length bytes)) Writable); + destruct (range_perm_dec m1 b ofs (ofs + Z_of_nat (length bytes)) Cur Writable); inv STORE. auto. Qed. @@ -1554,10 +1411,10 @@ Theorem loadbytes_storebytes_same: loadbytes m2 b ofs (Z_of_nat (length bytes)) = Some bytes. Proof. intros. unfold storebytes in STORE. unfold loadbytes. - destruct (range_perm_dec m1 b ofs (ofs + Z_of_nat (length bytes)) Writable); + destruct (range_perm_dec m1 b ofs (ofs + Z_of_nat (length bytes)) Cur Writable); try discriminate. rewrite pred_dec_true. - decEq. inv STORE; simpl. rewrite update_s. rewrite nat_of_Z_of_nat. + decEq. inv STORE; simpl. rewrite ZMap.gss. rewrite nat_of_Z_of_nat. apply getN_setN_same. red; eauto with mem. Qed. @@ -1571,10 +1428,10 @@ Theorem loadbytes_storebytes_other: loadbytes m2 b' ofs' len = loadbytes m1 b' ofs' len. Proof. intros. unfold loadbytes. - destruct (range_perm_dec m1 b' ofs' (ofs' + len) Readable). + destruct (range_perm_dec m1 b' ofs' (ofs' + len) Cur Readable). rewrite pred_dec_true. rewrite storebytes_mem_contents. decEq. - unfold update. destruct (zeq b' b). subst b'. + rewrite ZMap.gsspec. destruct (ZIndexed.eq b' b). subst b'. apply getN_setN_outside. rewrite nat_of_Z_eq; auto. intuition congruence. auto. red; auto with mem. @@ -1592,8 +1449,8 @@ Proof. intros. unfold load. destruct (valid_access_dec m1 chunk b' ofs' Readable). rewrite pred_dec_true. - rewrite storebytes_mem_contents. decEq. - unfold update. destruct (zeq b' b). subst b'. + rewrite storebytes_mem_contents. decEq. + rewrite ZMap.gsspec. destruct (ZIndexed.eq b' b). subst b'. rewrite getN_setN_outside. auto. rewrite <- size_chunk_conv. intuition congruence. auto. destruct v; split; auto. red; auto with mem. @@ -1620,12 +1477,11 @@ Theorem storebytes_concat: Proof. intros. generalize H; intro ST1. generalize H0; intro ST2. unfold storebytes; unfold storebytes in ST1; unfold storebytes in ST2. - destruct (range_perm_dec m b ofs (ofs + Z_of_nat(length bytes1)) Writable); try congruence. - destruct (range_perm_dec m1 b (ofs + Z_of_nat(length bytes1)) (ofs + Z_of_nat(length bytes1) + Z_of_nat(length bytes2)) Writable); try congruence. - destruct (range_perm_dec m b ofs (ofs + Z_of_nat (length (bytes1 ++ bytes2))) Writable). + destruct (range_perm_dec m b ofs (ofs + Z_of_nat(length bytes1)) Cur Writable); try congruence. + destruct (range_perm_dec m1 b (ofs + Z_of_nat(length bytes1)) (ofs + Z_of_nat(length bytes1) + Z_of_nat(length bytes2)) Cur Writable); try congruence. + destruct (range_perm_dec m b ofs (ofs + Z_of_nat (length (bytes1 ++ bytes2))) Cur Writable). inv ST1; inv ST2; simpl. decEq. apply mkmem_ext; auto. - apply extensionality; intros. unfold update. destruct (zeq x b); auto. - subst x. rewrite zeq_true. apply setN_concat. + rewrite ZMap.gss. rewrite setN_concat. symmetry. apply ZMap.set2. elim n. rewrite app_length. rewrite inj_plus. red; intros. destruct (zlt ofs0 (ofs + Z_of_nat(length bytes1))). @@ -1694,7 +1550,7 @@ Proof. unfold valid_block. rewrite alloc_result. rewrite nextblock_alloc. omega. Qed. -Hint Local Resolve valid_block_alloc fresh_block_alloc valid_new_block: mem. +Local Hint Resolve valid_block_alloc fresh_block_alloc valid_new_block: mem. Theorem valid_block_alloc_inv: forall b', valid_block m2 b' -> b' = b \/ valid_block m1 b'. @@ -1705,49 +1561,47 @@ Proof. Qed. Theorem perm_alloc_1: - forall b' ofs p, perm m1 b' ofs p -> perm m2 b' ofs p. + forall b' ofs k p, perm m1 b' ofs k p -> perm m2 b' ofs k p. Proof. unfold perm; intros. injection ALLOC; intros. rewrite <- H1; simpl. - subst b. unfold update. destruct (zeq b' (nextblock m1)); auto. - elimtype False. - destruct (nextblock_noaccess m1 b'). - omega. - rewrite bounds_noaccess in H. contradiction. rewrite H0. simpl; omega. + subst b. rewrite ZMap.gsspec. destruct (ZIndexed.eq b' (nextblock m1)); auto. + rewrite nextblock_noaccess in H. contradiction. omega. Qed. Theorem perm_alloc_2: - forall ofs, lo <= ofs < hi -> perm m2 b ofs Freeable. + forall ofs k, lo <= ofs < hi -> perm m2 b ofs k Freeable. Proof. unfold perm; intros. injection ALLOC; intros. rewrite <- H1; simpl. - subst b. rewrite update_s. unfold proj_sumbool. rewrite zle_true. + subst b. rewrite ZMap.gss. unfold proj_sumbool. rewrite zle_true. rewrite zlt_true. simpl. auto with mem. omega. omega. Qed. -Theorem perm_alloc_3: - forall ofs p, ofs < lo \/ hi <= ofs -> ~perm m2 b ofs p. -Proof. - unfold perm; intros. injection ALLOC; intros. rewrite <- H1; simpl. - subst b. rewrite update_s. unfold proj_sumbool. - destruct H. rewrite zle_false. simpl. congruence. omega. - rewrite zlt_false. rewrite andb_false_r. - intro; contradiction. - omega. -Qed. - -Hint Local Resolve perm_alloc_1 perm_alloc_2 perm_alloc_3: mem. - Theorem perm_alloc_inv: - forall b' ofs p, - perm m2 b' ofs p -> - if zeq b' b then lo <= ofs < hi else perm m1 b' ofs p. + forall b' ofs k p, + perm m2 b' ofs k p -> + if zeq b' b then lo <= ofs < hi else perm m1 b' ofs k p. Proof. intros until p; unfold perm. inv ALLOC. simpl. - unfold update. destruct (zeq b' (nextblock m1)); intros. + rewrite ZMap.gsspec. unfold ZIndexed.eq. destruct (zeq b' (nextblock m1)); intros. destruct (zle lo ofs); try contradiction. destruct (zlt ofs hi); try contradiction. split; auto. auto. Qed. +Theorem perm_alloc_3: + forall ofs k p, perm m2 b ofs k p -> lo <= ofs < hi. +Proof. + intros. exploit perm_alloc_inv; eauto. rewrite zeq_true; auto. +Qed. + +Theorem perm_alloc_4: + forall b' ofs k p, perm m2 b' ofs k p -> b' <> b -> perm m1 b' ofs k p. +Proof. + intros. exploit perm_alloc_inv; eauto. rewrite zeq_false; auto. +Qed. + +Local Hint Resolve perm_alloc_1 perm_alloc_2 perm_alloc_3 perm_alloc_4: mem. + Theorem valid_access_alloc_other: forall chunk b' ofs p, valid_access m1 chunk b' ofs p -> @@ -1766,7 +1620,7 @@ Proof. red; intros. apply perm_alloc_2. omega. Qed. -Hint Local Resolve valid_access_alloc_other valid_access_alloc_same: mem. +Local Hint Resolve valid_access_alloc_other valid_access_alloc_same: mem. Theorem valid_access_alloc_inv: forall chunk b' ofs p, @@ -1778,8 +1632,8 @@ Proof. intros. inv H. generalize (size_chunk_pos chunk); intro. unfold eq_block. destruct (zeq b' b). subst b'. - assert (perm m2 b ofs p). apply H0. omega. - assert (perm m2 b (ofs + size_chunk chunk - 1) p). apply H0. omega. + assert (perm m2 b ofs Cur p). apply H0. omega. + assert (perm m2 b (ofs + size_chunk chunk - 1) Cur p). apply H0. omega. exploit perm_alloc_inv. eexact H2. rewrite zeq_true. intro. exploit perm_alloc_inv. eexact H3. rewrite zeq_true. intro. intuition omega. @@ -1787,25 +1641,6 @@ Proof. exploit perm_alloc_inv. apply H0. eauto. rewrite zeq_false; auto. Qed. -Theorem bounds_alloc: - forall b', bounds m2 b' = if eq_block b' b then (lo, hi) else bounds m1 b'. -Proof. - injection ALLOC; intros. rewrite <- H; rewrite <- H0; simpl. - unfold update. auto. -Qed. - -Theorem bounds_alloc_same: - bounds m2 b = (lo, hi). -Proof. - rewrite bounds_alloc. apply dec_eq_true. -Qed. - -Theorem bounds_alloc_other: - forall b', b' <> b -> bounds m2 b' = bounds m1 b'. -Proof. - intros. rewrite bounds_alloc. apply dec_eq_false. auto. -Qed. - Theorem load_alloc_unchanged: forall chunk b' ofs, valid_block m1 b' -> @@ -1817,7 +1652,7 @@ Proof. subst b'. elimtype False. eauto with mem. rewrite pred_dec_true; auto. injection ALLOC; intros. rewrite <- H2; simpl. - rewrite update_o. auto. rewrite H1. apply sym_not_equal; eauto with mem. + rewrite ZMap.gso. auto. rewrite H1. apply sym_not_equal; eauto with mem. rewrite pred_dec_false. auto. eauto with mem. Qed. @@ -1837,7 +1672,7 @@ Theorem load_alloc_same: Proof. intros. exploit load_result; eauto. intro. rewrite H0. injection ALLOC; intros. rewrite <- H2; simpl. rewrite <- H1. - rewrite update_s. destruct chunk; reflexivity. + rewrite ZMap.gss. destruct chunk; simpl; repeat rewrite ZMap.gi; reflexivity. Qed. Theorem load_alloc_same': @@ -1854,14 +1689,14 @@ Qed. End ALLOC. -Hint Local Resolve valid_block_alloc fresh_block_alloc valid_new_block: mem. -Hint Local Resolve valid_access_alloc_other valid_access_alloc_same: mem. +Local Hint Resolve valid_block_alloc fresh_block_alloc valid_new_block: mem. +Local Hint Resolve valid_access_alloc_other valid_access_alloc_same: mem. (** ** Properties related to [free]. *) Theorem range_perm_free: forall m1 b lo hi, - range_perm m1 b lo hi Freeable -> + range_perm m1 b lo hi Cur Freeable -> { m2: mem | free m1 b lo hi = Some m2 }. Proof. intros; unfold free. rewrite pred_dec_true; auto. econstructor; eauto. @@ -1876,16 +1711,16 @@ Variable m2: mem. Hypothesis FREE: free m1 bf lo hi = Some m2. Theorem free_range_perm: - range_perm m1 bf lo hi Freeable. + range_perm m1 bf lo hi Cur Freeable. Proof. - unfold free in FREE. destruct (range_perm_dec m1 bf lo hi Freeable); auto. + unfold free in FREE. destruct (range_perm_dec m1 bf lo hi Cur Freeable); auto. congruence. Qed. Lemma free_result: m2 = unchecked_free m1 bf lo hi. Proof. - unfold free in FREE. destruct (range_perm_dec m1 bf lo hi Freeable). + unfold free in FREE. destruct (range_perm_dec m1 bf lo hi Cur Freeable). congruence. congruence. Qed. @@ -1907,16 +1742,16 @@ Proof. intros. rewrite free_result in H. assumption. Qed. -Hint Local Resolve valid_block_free_1 valid_block_free_2: mem. +Local Hint Resolve valid_block_free_1 valid_block_free_2: mem. Theorem perm_free_1: - forall b ofs p, + forall b ofs k p, b <> bf \/ ofs < lo \/ hi <= ofs -> - perm m1 b ofs p -> - perm m2 b ofs p. + perm m1 b ofs k p -> + perm m2 b ofs k p. Proof. intros. rewrite free_result. unfold perm, unchecked_free; simpl. - unfold update. destruct (zeq b bf). subst b. + rewrite ZMap.gsspec. destruct (ZIndexed.eq b bf). subst b. destruct (zle lo ofs); simpl. destruct (zlt ofs hi); simpl. elimtype False; intuition. @@ -1925,22 +1760,33 @@ Proof. Qed. Theorem perm_free_2: - forall ofs p, lo <= ofs < hi -> ~ perm m2 bf ofs p. + forall ofs k p, lo <= ofs < hi -> ~ perm m2 bf ofs k p. Proof. intros. rewrite free_result. unfold perm, unchecked_free; simpl. - rewrite update_s. unfold proj_sumbool. rewrite zle_true. rewrite zlt_true. - simpl. congruence. omega. omega. + rewrite ZMap.gss. unfold proj_sumbool. rewrite zle_true. rewrite zlt_true. + simpl. tauto. omega. omega. Qed. Theorem perm_free_3: - forall b ofs p, - perm m2 b ofs p -> perm m1 b ofs p. + forall b ofs k p, + perm m2 b ofs k p -> perm m1 b ofs k p. Proof. intros until p. rewrite free_result. unfold perm, unchecked_free; simpl. - unfold update. destruct (zeq b bf). subst b. + rewrite ZMap.gsspec. destruct (ZIndexed.eq b bf). subst b. destruct (zle lo ofs); simpl. - destruct (zlt ofs hi); simpl. intro; contradiction. - congruence. auto. auto. + destruct (zlt ofs hi); simpl. tauto. + auto. auto. auto. +Qed. + +Theorem perm_free_inv: + forall b ofs k p, + perm m1 b ofs k p -> + (b = bf /\ lo <= ofs < hi) \/ perm m2 b ofs k p. +Proof. + intros. rewrite free_result. unfold perm, unchecked_free; simpl. + rewrite ZMap.gsspec. destruct (ZIndexed.eq b bf); auto. subst b. + destruct (zle lo ofs); simpl; auto. + destruct (zlt ofs hi); simpl; auto. Qed. Theorem valid_access_free_1: @@ -1962,9 +1808,9 @@ Proof. intros; red; intros. inv H2. generalize (size_chunk_pos chunk); intros. destruct (zlt ofs lo). - elim (perm_free_2 lo p). + elim (perm_free_2 lo Cur p). omega. apply H3. omega. - elim (perm_free_2 ofs p). + elim (perm_free_2 ofs Cur p). omega. apply H3. omega. Qed. @@ -1976,10 +1822,10 @@ Proof. intros. destruct H. split; auto. red; intros. generalize (H ofs0 H1). rewrite free_result. unfold perm, unchecked_free; simpl. - unfold update. destruct (zeq b bf). subst b. + rewrite ZMap.gsspec. destruct (ZIndexed.eq b bf). subst b. destruct (zle lo ofs0); simpl. - destruct (zlt ofs0 hi); simpl. - intro; contradiction. congruence. auto. auto. + destruct (zlt ofs0 hi); simpl. + tauto. auto. auto. auto. Qed. Theorem valid_access_free_inv_2: @@ -1994,12 +1840,6 @@ Proof. elim (valid_access_free_2 chunk ofs p); auto. omega. Qed. -Theorem bounds_free: - forall b, bounds m2 b = bounds m1 b. -Proof. - intros. rewrite free_result; simpl. auto. -Qed. - Theorem load_free: forall chunk b ofs, b <> bf \/ lo >= hi \/ ofs + size_chunk chunk <= lo \/ hi <= ofs -> @@ -2009,51 +1849,32 @@ Proof. destruct (valid_access_dec m2 chunk b ofs Readable). rewrite pred_dec_true. rewrite free_result; auto. - simpl. f_equal. f_equal. - unfold clearN. - rewrite size_chunk_conv in H. - remember (size_chunk_nat chunk) as n; clear Heqn. - clear v FREE. - revert lo hi ofs H; induction n; intros; simpl; auto. - f_equal. - destruct (zeq b bf); auto. subst bf. - destruct (zle lo ofs); auto. destruct (zlt ofs hi); auto. - elimtype False. - destruct H as [? | [? | [? | ?]]]; try omega. - contradict H; auto. - rewrite inj_S in H; omega. - apply IHn. - rewrite inj_S in H. - destruct H as [? | [? | [? | ?]]]; auto. - unfold block in *; omega. - unfold block in *; omega. - - apply valid_access_free_inv_1; auto. + eapply valid_access_free_inv_1; eauto. rewrite pred_dec_false; auto. red; intro; elim n. eapply valid_access_free_1; eauto. Qed. End FREE. -Hint Local Resolve valid_block_free_1 valid_block_free_2 +Local Hint Resolve valid_block_free_1 valid_block_free_2 perm_free_1 perm_free_2 perm_free_3 valid_access_free_1 valid_access_free_inv_1: mem. (** ** Properties related to [drop_perm] *) Theorem range_perm_drop_1: - forall m b lo hi p m', drop_perm m b lo hi p = Some m' -> range_perm m b lo hi p. + forall m b lo hi p m', drop_perm m b lo hi p = Some m' -> range_perm m b lo hi Cur Freeable. Proof. unfold drop_perm; intros. - destruct (range_perm_dec m b lo hi p). auto. discriminate. + destruct (range_perm_dec m b lo hi Cur Freeable). auto. discriminate. Qed. Theorem range_perm_drop_2: forall m b lo hi p, - range_perm m b lo hi p -> {m' | drop_perm m b lo hi p = Some m' }. + range_perm m b lo hi Cur Freeable -> {m' | drop_perm m b lo hi p = Some m' }. Proof. unfold drop_perm; intros. - destruct (range_perm_dec m b lo hi p). econstructor. eauto. contradiction. + destruct (range_perm_dec m b lo hi Cur Freeable). econstructor. eauto. contradiction. Qed. Section DROP. @@ -2068,59 +1889,64 @@ Hypothesis DROP: drop_perm m b lo hi p = Some m'. Theorem nextblock_drop: nextblock m' = nextblock m. Proof. - unfold drop_perm in DROP. destruct (range_perm_dec m b lo hi p); inv DROP; auto. + unfold drop_perm in DROP. destruct (range_perm_dec m b lo hi Cur Freeable); inv DROP; auto. +Qed. + +Theorem drop_perm_valid_block_1: + forall b', valid_block m b' -> valid_block m' b'. +Proof. + unfold valid_block; rewrite nextblock_drop; auto. +Qed. + +Theorem drop_perm_valid_block_2: + forall b', valid_block m' b' -> valid_block m b'. +Proof. + unfold valid_block; rewrite nextblock_drop; auto. Qed. Theorem perm_drop_1: - forall ofs, lo <= ofs < hi -> perm m' b ofs p. + forall ofs k, lo <= ofs < hi -> perm m' b ofs k p. Proof. intros. - unfold drop_perm in DROP. destruct (range_perm_dec m b lo hi p); inv DROP. - unfold perm. simpl. rewrite update_s. unfold proj_sumbool. + unfold drop_perm in DROP. destruct (range_perm_dec m b lo hi Cur Freeable); inv DROP. + unfold perm. simpl. rewrite ZMap.gss. unfold proj_sumbool. rewrite zle_true. rewrite zlt_true. simpl. constructor. omega. omega. Qed. Theorem perm_drop_2: - forall ofs p', lo <= ofs < hi -> perm m' b ofs p' -> perm_order p p'. + forall ofs k p', lo <= ofs < hi -> perm m' b ofs k p' -> perm_order p p'. Proof. intros. - unfold drop_perm in DROP. destruct (range_perm_dec m b lo hi p); inv DROP. - revert H0. unfold perm; simpl. rewrite update_s. unfold proj_sumbool. + unfold drop_perm in DROP. destruct (range_perm_dec m b lo hi Cur Freeable); inv DROP. + revert H0. unfold perm; simpl. rewrite ZMap.gss. unfold proj_sumbool. rewrite zle_true. rewrite zlt_true. simpl. auto. omega. omega. Qed. Theorem perm_drop_3: - forall b' ofs p', b' <> b \/ ofs < lo \/ hi <= ofs -> perm m b' ofs p' -> perm m' b' ofs p'. + forall b' ofs k p', b' <> b \/ ofs < lo \/ hi <= ofs -> perm m b' ofs k p' -> perm m' b' ofs k p'. Proof. intros. - unfold drop_perm in DROP. destruct (range_perm_dec m b lo hi p); inv DROP. - unfold perm; simpl. unfold update. destruct (zeq b' b). subst b'. + unfold drop_perm in DROP. destruct (range_perm_dec m b lo hi Cur Freeable); inv DROP. + unfold perm; simpl. rewrite ZMap.gsspec. destruct (ZIndexed.eq b' b). subst b'. unfold proj_sumbool. destruct (zle lo ofs). destruct (zlt ofs hi). byContradiction. intuition omega. auto. auto. auto. Qed. Theorem perm_drop_4: - forall b' ofs p', perm m' b' ofs p' -> perm m b' ofs p'. + forall b' ofs k p', perm m' b' ofs k p' -> perm m b' ofs k p'. Proof. intros. - unfold drop_perm in DROP. destruct (range_perm_dec m b lo hi p); inv DROP. - revert H. unfold perm; simpl. unfold update. destruct (zeq b' b). + unfold drop_perm in DROP. destruct (range_perm_dec m b lo hi Cur Freeable); inv DROP. + revert H. unfold perm; simpl. rewrite ZMap.gsspec. destruct (ZIndexed.eq b' b). subst b'. unfold proj_sumbool. destruct (zle lo ofs). destruct (zlt ofs hi). - simpl. intros. apply perm_implies with p. apply r. tauto. auto. + simpl. intros. apply perm_implies with p. apply perm_implies with Freeable. apply perm_cur. + apply r. tauto. auto with mem. auto. auto. auto. auto. Qed. -Theorem bounds_drop: - forall b', bounds m' b' = bounds m b'. -Proof. - intros. - unfold drop_perm in DROP. destruct (range_perm_dec m b lo hi p); inv DROP. - unfold bounds; simpl. auto. -Qed. - Lemma valid_access_drop_1: forall chunk b' ofs p', b' <> b \/ ofs + size_chunk chunk <= lo \/ hi <= ofs \/ perm_order p p' -> @@ -2167,13 +1993,7 @@ Proof. unfold load. destruct (valid_access_dec m chunk b' ofs Readable). rewrite pred_dec_true. - unfold drop_perm in DROP. destruct (range_perm_dec m b lo hi p); inv DROP. simpl. - unfold update. destruct (zeq b' b). subst b'. decEq. decEq. - apply getN_exten. rewrite <- size_chunk_conv. intros. - unfold proj_sumbool. destruct (zle lo i). destruct (zlt i hi). destruct (perm_order_dec p Readable). - auto. - elimtype False. intuition. - auto. auto. auto. + unfold drop_perm in DROP. destruct (range_perm_dec m b lo hi Cur Freeable); inv DROP. simpl. auto. eapply valid_access_drop_1; eauto. rewrite pred_dec_false. auto. red; intros; elim n. eapply valid_access_drop_2; eauto. @@ -2181,85 +2001,6 @@ Qed. End DROP. -(** * Extensionality properties *) - -Lemma mem_access_ext: - forall m1 m2, perm m1 = perm m2 -> mem_access m1 = mem_access m2. -Proof. - intros. - apply extensionality; intro b. - apply extensionality; intro ofs. - case_eq (mem_access m1 b ofs); case_eq (mem_access m2 b ofs); intros; auto. - assert (perm m1 b ofs p <-> perm m2 b ofs p) by (rewrite H; intuition). - assert (perm m1 b ofs p0 <-> perm m2 b ofs p0) by (rewrite H; intuition). - unfold perm, perm_order' in H2,H3. - rewrite H0 in H2,H3; rewrite H1 in H2,H3. - f_equal. - assert (perm_order p p0 -> perm_order p0 p -> p0=p) by - (clear; intros; inv H; inv H0; auto). - intuition. - assert (perm m1 b ofs p <-> perm m2 b ofs p) by (rewrite H; intuition). - unfold perm, perm_order' in H2; rewrite H0 in H2; rewrite H1 in H2. - assert (perm_order p p) by auto with mem. - intuition. - assert (perm m1 b ofs p <-> perm m2 b ofs p) by (rewrite H; intuition). - unfold perm, perm_order' in H2; rewrite H0 in H2; rewrite H1 in H2. - assert (perm_order p p) by auto with mem. - intuition. -Qed. - -Lemma mem_ext': - forall m1 m2, - mem_access m1 = mem_access m2 -> - nextblock m1 = nextblock m2 -> - (forall b, 0 < b < nextblock m1 -> bounds m1 b = bounds m2 b) -> - (forall b ofs, perm_order' (mem_access m1 b ofs) Readable -> - mem_contents m1 b ofs = mem_contents m2 b ofs) -> - m1 = m2. -Proof. - intros. - destruct m1; destruct m2; simpl in *. - destruct H; subst. - apply mkmem_ext; auto. - apply extensionality; intro b. - apply extensionality; intro ofs. - destruct (perm_order'_dec (mem_access0 b ofs) Readable). - auto. - destruct (noread_undef0 b ofs); try contradiction. - destruct (noread_undef1 b ofs); try contradiction. - congruence. - apply extensionality; intro b. - destruct (nextblock_noaccess0 b); auto. - destruct (nextblock_noaccess1 b); auto. - congruence. -Qed. - -Theorem mem_ext: - forall m1 m2, - perm m1 = perm m2 -> - nextblock m1 = nextblock m2 -> - (forall b, 0 < b < nextblock m1 -> bounds m1 b = bounds m2 b) -> - (forall b ofs, loadbytes m1 b ofs 1 = loadbytes m2 b ofs 1) -> - m1 = m2. -Proof. - intros. - generalize (mem_access_ext _ _ H); clear H; intro. - apply mem_ext'; auto. - intros. - specialize (H2 b ofs). - unfold loadbytes in H2; simpl in H2. - destruct (range_perm_dec m1 b ofs (ofs+1)). - destruct (range_perm_dec m2 b ofs (ofs+1)). - inv H2; auto. - contradict n. - intros ofs' ?; assert (ofs'=ofs) by omega; subst ofs'. - unfold perm, perm_order'. - rewrite <- H; destruct (mem_access m1 b ofs); try destruct p; intuition. - contradict n. - intros ofs' ?; assert (ofs'=ofs) by omega; subst ofs'. - unfold perm. destruct (mem_access m1 b ofs); try destruct p; intuition. -Qed. - (** * Generic injections *) (** A memory state [m1] generically injects into another memory state [m2] via the @@ -2272,6 +2013,11 @@ Qed. Record mem_inj (f: meminj) (m1 m2: mem) : Prop := mk_mem_inj { + mi_perm: + forall b1 b2 delta ofs k p, + f b1 = Some(b2, delta) -> + perm m1 b1 ofs k p -> + perm m2 b2 (ofs + delta) k p; mi_access: forall b1 b2 delta chunk ofs p, f b1 = Some(b2, delta) -> @@ -2280,33 +2026,28 @@ Record mem_inj (f: meminj) (m1 m2: mem) : Prop := mi_memval: forall b1 ofs b2 delta, f b1 = Some(b2, delta) -> - perm m1 b1 ofs Nonempty -> - memval_inject f (m1.(mem_contents) b1 ofs) (m2.(mem_contents) b2 (ofs + delta)) + perm m1 b1 ofs Cur Readable -> + memval_inject f (m1.(mem_contents)#b1#ofs) (m2.(mem_contents)#b2#(ofs + delta)) }. (** Preservation of permissions *) Lemma perm_inj: - forall f m1 m2 b1 ofs p b2 delta, + forall f m1 m2 b1 ofs k p b2 delta, mem_inj f m1 m2 -> - perm m1 b1 ofs p -> + perm m1 b1 ofs k p -> f b1 = Some(b2, delta) -> - perm m2 b2 (ofs + delta) p. + perm m2 b2 (ofs + delta) k p. Proof. - intros. - assert (valid_access m1 Mint8unsigned b1 ofs p). - split. red; intros. simpl in H2. replace ofs0 with ofs by omega. auto. - simpl. apply Zone_divide. - exploit mi_access; eauto. intros [A B]. - apply A. simpl; omega. + intros. eapply mi_perm; eauto. Qed. Lemma range_perm_inj: - forall f m1 m2 b1 lo hi p b2 delta, + forall f m1 m2 b1 lo hi k p b2 delta, mem_inj f m1 m2 -> - range_perm m1 b1 lo hi p -> + range_perm m1 b1 lo hi k p -> f b1 = Some(b2, delta) -> - range_perm m2 b2 (lo + delta) (hi + delta) p. + range_perm m2 b2 (lo + delta) (hi + delta) k p. Proof. intros; red; intros. replace ofs with ((ofs - delta) + delta) by omega. @@ -2320,18 +2061,17 @@ Lemma getN_inj: mem_inj f m1 m2 -> f b1 = Some(b2, delta) -> forall n ofs, - range_perm m1 b1 ofs (ofs + Z_of_nat n) Readable -> + range_perm m1 b1 ofs (ofs + Z_of_nat n) Cur Readable -> list_forall2 (memval_inject f) - (getN n ofs (m1.(mem_contents) b1)) - (getN n (ofs + delta) (m2.(mem_contents) b2)). + (getN n ofs (m1.(mem_contents)#b1)) + (getN n (ofs + delta) (m2.(mem_contents)#b2)). Proof. induction n; intros; simpl. constructor. rewrite inj_S in H1. constructor. eapply mi_memval; eauto. - apply perm_implies with Readable. - apply H1. omega. constructor. + apply H1. omega. replace (ofs + delta + 1) with ((ofs + 1) + delta) by omega. apply IHn. red; intros; apply H1; omega. Qed. @@ -2344,7 +2084,7 @@ Lemma load_inj: exists v2, load chunk m2 b2 (ofs + delta) = Some v2 /\ val_inject f v1 v2. Proof. intros. - exists (decode_val chunk (getN (size_chunk_nat chunk) (ofs + delta) (m2.(mem_contents) b2))). + exists (decode_val chunk (getN (size_chunk_nat chunk) (ofs + delta) (m2.(mem_contents)#b2))). split. unfold load. apply pred_dec_true. eapply mi_access; eauto with mem. exploit load_result; eauto. intro. rewrite H2. @@ -2361,8 +2101,8 @@ Lemma loadbytes_inj: /\ list_forall2 (memval_inject f) bytes1 bytes2. Proof. intros. unfold loadbytes in *. - destruct (range_perm_dec m1 b1 ofs (ofs + len) Readable); inv H0. - exists (getN (nat_of_Z len) (ofs + delta) (m2.(mem_contents) b2)). + 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)). split. apply pred_dec_true. replace (ofs + delta + len) with ((ofs + len) + delta) by omega. eapply range_perm_inj; eauto with mem. @@ -2377,46 +2117,27 @@ Lemma setN_inj: forall (access: Z -> Prop) delta f vl1 vl2, list_forall2 (memval_inject f) vl1 vl2 -> forall p c1 c2, - (forall q, access q -> memval_inject f (c1 q) (c2 (q + delta))) -> - (forall q, access q -> memval_inject f ((setN vl1 p c1) q) - ((setN vl2 (p + delta) c2) (q + delta))). + (forall q, access q -> memval_inject f (c1#q) (c2#(q + delta))) -> + (forall q, access q -> memval_inject f ((setN vl1 p c1)#q) + ((setN vl2 (p + delta) c2)#(q + delta))). Proof. induction 1; intros; simpl. auto. replace (p + delta + 1) with ((p + 1) + delta) by omega. apply IHlist_forall2; auto. - intros. unfold update at 1. destruct (zeq q0 p). subst q0. - rewrite update_s. auto. - rewrite update_o. auto. omega. + intros. rewrite ZMap.gsspec at 1. destruct (ZIndexed.eq q0 p). subst q0. + rewrite ZMap.gss. auto. + rewrite ZMap.gso. auto. unfold ZIndexed.t in *. omega. Qed. Definition meminj_no_overlap (f: meminj) (m: mem) : Prop := - forall b1 b1' delta1 b2 b2' delta2, - b1 <> b2 -> - f b1 = Some (b1', delta1) -> - f b2 = Some (b2', delta2) -> - b1' <> b2' -(* - \/ low_bound m b1 >= high_bound m b1 - \/ low_bound m b2 >= high_bound m b2 *) - \/ high_bound m b1 + delta1 <= low_bound m b2 + delta2 - \/ high_bound m b2 + delta2 <= low_bound m b1 + delta1. - -Lemma meminj_no_overlap_perm: - forall f m b1 b1' delta1 b2 b2' delta2 ofs1 ofs2, - meminj_no_overlap f m -> + forall b1 b1' delta1 b2 b2' delta2 ofs1 ofs2, b1 <> b2 -> f b1 = Some (b1', delta1) -> f b2 = Some (b2', delta2) -> - perm m b1 ofs1 Nonempty -> - perm m b2 ofs2 Nonempty -> + perm m b1 ofs1 Max Nonempty -> + perm m b2 ofs2 Max Nonempty -> b1' <> b2' \/ ofs1 + delta1 <> ofs2 + delta2. -Proof. - intros. exploit H; eauto. intro. - exploit perm_in_bounds. eexact H3. intro. - exploit perm_in_bounds. eexact H4. intro. - destruct H5. auto. right. omega. -Qed. Lemma store_mapped_inj: forall f chunk m1 b1 ofs v1 n1 m2 b2 delta v2, @@ -2429,41 +2150,43 @@ Lemma store_mapped_inj: store chunk m2 b2 (ofs + delta) v2 = Some n2 /\ mem_inj f n1 n2. Proof. - intros. inversion H. + intros. assert (valid_access m2 chunk b2 (ofs + delta) Writable). - eapply mi_access0; eauto with mem. + eapply mi_access; eauto with mem. destruct (valid_access_store _ _ _ _ v2 H4) as [n2 STORE]. - exists n2; split. eauto. + exists n2; split. auto. constructor. +(* perm *) + intros. eapply perm_store_1; [eexact STORE|]. + eapply mi_perm; eauto. + eapply perm_store_2; eauto. (* access *) - intros. - eapply store_valid_access_1; [apply STORE |]. - eapply mi_access0; eauto. - eapply store_valid_access_2; [apply H0 |]. auto. + intros. eapply store_valid_access_1; [apply STORE |]. + eapply mi_access; eauto. + eapply store_valid_access_2; eauto. (* mem_contents *) intros. - assert (perm m1 b0 ofs0 Nonempty). eapply perm_store_2; eauto. rewrite (store_mem_contents _ _ _ _ _ _ H0). rewrite (store_mem_contents _ _ _ _ _ _ STORE). - unfold update. - destruct (zeq b0 b1). subst b0. + repeat rewrite ZMap.gsspec. + destruct (ZIndexed.eq b0 b1). subst b0. (* block = b1, block = b2 *) assert (b3 = b2) by congruence. subst b3. assert (delta0 = delta) by congruence. subst delta0. rewrite zeq_true. - apply setN_inj with (access := fun ofs => perm m1 b1 ofs Nonempty). - apply encode_val_inject; auto. auto. auto. - destruct (zeq b3 b2). subst b3. + apply setN_inj with (access := fun ofs => perm m1 b1 ofs Cur Readable). + apply encode_val_inject; auto. intros. eapply mi_memval; eauto. eauto with mem. + destruct (ZIndexed.eq b3 b2). subst b3. (* block <> b1, block = b2 *) - rewrite setN_other. auto. + rewrite setN_other. eapply mi_memval; eauto. eauto with mem. rewrite encode_val_length. rewrite <- size_chunk_conv. intros. assert (b2 <> b2 \/ ofs0 + delta0 <> (r - delta) + delta). - eapply meminj_no_overlap_perm; eauto. + eapply H1; eauto. eauto 6 with mem. exploit store_valid_access_3. eexact H0. intros [A B]. - eapply perm_implies. apply A. omega. auto with mem. - destruct H9. congruence. omega. + eapply perm_implies. apply perm_cur_max. apply A. omega. auto with mem. + destruct H8. congruence. omega. (* block <> b1, block <> b2 *) - eauto. + eapply mi_memval; eauto. eauto with mem. Qed. Lemma store_unmapped_inj: @@ -2473,14 +2196,15 @@ Lemma store_unmapped_inj: f b1 = None -> mem_inj f n1 m2. Proof. - intros. inversion H. - constructor. + intros. constructor. +(* perm *) + intros. eapply mi_perm; eauto with mem. (* access *) - eauto with mem. + intros. eapply mi_access; eauto with mem. (* mem_contents *) intros. rewrite (store_mem_contents _ _ _ _ _ _ H0). - rewrite update_o. eauto with mem. + rewrite ZMap.gso. eapply mi_memval; eauto with mem. congruence. Qed. @@ -2489,21 +2213,25 @@ Lemma store_outside_inj: mem_inj f m1 m2 -> (forall b' delta ofs', f b' = Some(b, delta) -> - perm m1 b' ofs' Nonempty -> - ofs' + delta < ofs \/ ofs' + delta >= ofs + size_chunk chunk) -> + perm m1 b' ofs' Cur Readable -> + ofs <= ofs' + delta < ofs + size_chunk chunk -> False) -> store chunk m2 b ofs v = Some m2' -> mem_inj f m1 m2'. Proof. - intros. inversion H. constructor. + intros. inv H. constructor. +(* perm *) + eauto with mem. (* access *) eauto with mem. (* mem_contents *) intros. rewrite (store_mem_contents _ _ _ _ _ _ H1). - unfold update. destruct (zeq b2 b). subst b2. + rewrite ZMap.gsspec. destruct (ZIndexed.eq b2 b). subst b2. rewrite setN_outside. auto. rewrite encode_val_length. rewrite <- size_chunk_conv. - eapply H0; eauto. + destruct (zlt (ofs0 + delta) ofs); auto. + destruct (zle (ofs + size_chunk chunk) (ofs0 + delta)). omega. + byContradiction. eapply H0; eauto. omega. eauto with mem. Qed. @@ -2519,7 +2247,7 @@ Lemma storebytes_mapped_inj: /\ mem_inj f n1 n2. Proof. intros. inversion H. - assert (range_perm m2 b2 (ofs + delta) (ofs + delta + Z_of_nat (length bytes2)) Writable). + assert (range_perm m2 b2 (ofs + delta) (ofs + delta + Z_of_nat (length bytes2)) Cur Writable). replace (ofs + delta + Z_of_nat (length bytes2)) with ((ofs + Z_of_nat (length bytes1)) + delta). eapply range_perm_inj; eauto with mem. @@ -2528,33 +2256,37 @@ Proof. destruct (range_perm_storebytes _ _ _ _ H4) as [n2 STORE]. exists n2; split. eauto. constructor. +(* perm *) + intros. + eapply perm_storebytes_1; [apply STORE |]. + eapply mi_perm0; eauto. + eapply perm_storebytes_2; eauto. (* access *) intros. eapply storebytes_valid_access_1; [apply STORE |]. eapply mi_access0; eauto. - eapply storebytes_valid_access_2; [apply H0 |]. auto. + eapply storebytes_valid_access_2; eauto. (* mem_contents *) intros. - assert (perm m1 b0 ofs0 Nonempty). eapply perm_storebytes_2; eauto. + assert (perm m1 b0 ofs0 Cur Readable). eapply perm_storebytes_2; eauto. rewrite (storebytes_mem_contents _ _ _ _ _ H0). rewrite (storebytes_mem_contents _ _ _ _ _ STORE). - unfold update. - destruct (zeq b0 b1). subst b0. + repeat rewrite ZMap.gsspec. destruct (ZIndexed.eq b0 b1). subst b0. (* block = b1, block = b2 *) assert (b3 = b2) by congruence. subst b3. assert (delta0 = delta) by congruence. subst delta0. rewrite zeq_true. - apply setN_inj with (access := fun ofs => perm m1 b1 ofs Nonempty); auto. - destruct (zeq b3 b2). subst b3. + apply setN_inj with (access := fun ofs => perm m1 b1 ofs Cur Readable); auto. + destruct (ZIndexed.eq b3 b2). subst b3. (* block <> b1, block = b2 *) rewrite setN_other. auto. intros. assert (b2 <> b2 \/ ofs0 + delta0 <> (r - delta) + delta). - eapply meminj_no_overlap_perm; eauto. + eapply H1; eauto 6 with mem. exploit storebytes_range_perm. eexact H0. instantiate (1 := r - delta). rewrite (list_forall2_length H3). omega. - eauto with mem. + eauto 6 with mem. destruct H9. congruence. omega. (* block <> b1, block <> b2 *) eauto. @@ -2569,12 +2301,14 @@ Lemma storebytes_unmapped_inj: Proof. intros. inversion H. constructor. +(* perm *) + intros. eapply mi_perm0; eauto. eapply perm_storebytes_2; eauto. (* access *) intros. eapply mi_access0; eauto. eapply storebytes_valid_access_2; eauto. (* mem_contents *) intros. rewrite (storebytes_mem_contents _ _ _ _ _ H0). - rewrite update_o. eapply mi_memval0; eauto. eapply perm_storebytes_2; eauto. + rewrite ZMap.gso. eapply mi_memval0; eauto. eapply perm_storebytes_2; eauto. congruence. Qed. @@ -2583,20 +2317,24 @@ Lemma storebytes_outside_inj: mem_inj f m1 m2 -> (forall b' delta ofs', f b' = Some(b, delta) -> - perm m1 b' ofs' Nonempty -> - ofs' + delta < ofs \/ ofs' + delta >= ofs + Z_of_nat (length bytes2)) -> + perm m1 b' ofs' Cur Readable -> + ofs <= ofs' + delta < ofs + Z_of_nat (length bytes2) -> False) -> storebytes m2 b ofs bytes2 = Some m2' -> mem_inj f m1 m2'. Proof. intros. inversion H. constructor. +(* perm *) + intros. eapply perm_storebytes_1; eauto with mem. (* access *) intros. eapply storebytes_valid_access_1; eauto with mem. (* mem_contents *) intros. rewrite (storebytes_mem_contents _ _ _ _ _ H1). - unfold update. destruct (zeq b2 b). subst b2. + rewrite ZMap.gsspec. destruct (ZIndexed.eq b2 b). subst b2. rewrite setN_outside. auto. - eapply H0; eauto. + destruct (zlt (ofs0 + delta) ofs); auto. + destruct (zle (ofs + Z_of_nat (length bytes2)) (ofs0 + delta)). omega. + byContradiction. eapply H0; eauto. omega. eauto with mem. Qed. @@ -2610,17 +2348,17 @@ Lemma alloc_right_inj: Proof. intros. injection H0. intros NEXT MEM. inversion H. constructor. +(* perm *) + intros. eapply perm_alloc_1; eauto. (* access *) - intros. eauto with mem. + intros. eapply valid_access_alloc_other; eauto. (* mem_contents *) intros. - assert (valid_access m2 Mint8unsigned b0 (ofs + delta) Nonempty). - eapply mi_access0; eauto. - split. simpl. red; intros. assert (ofs0 = ofs) by omega. congruence. - simpl. apply Zone_divide. + assert (perm m2 b0 (ofs + delta) Cur Readable). + eapply mi_perm0; eauto. assert (valid_block m2 b0) by eauto with mem. - rewrite <- MEM; simpl. rewrite update_o. eauto with mem. - rewrite NEXT. apply sym_not_equal. eauto with mem. + rewrite <- MEM; simpl. rewrite ZMap.gso. eauto with mem. + rewrite NEXT. eauto with mem. Qed. Lemma alloc_left_unmapped_inj: @@ -2631,15 +2369,18 @@ Lemma alloc_left_unmapped_inj: mem_inj f m1' m2. Proof. intros. inversion H. constructor. +(* perm *) + intros. exploit perm_alloc_inv; eauto. intros. + destruct (zeq b0 b1). congruence. eauto. (* access *) - unfold update; intros. - exploit valid_access_alloc_inv; eauto. unfold eq_block. intros. + intros. exploit valid_access_alloc_inv; eauto. unfold eq_block. intros. destruct (zeq b0 b1). congruence. eauto. (* mem_contents *) injection H0; intros NEXT MEM. intros. - rewrite <- MEM; simpl. rewrite NEXT. unfold update. - exploit perm_alloc_inv; eauto. intros. - destruct (zeq b0 b1). constructor. eauto. + rewrite <- MEM; simpl. rewrite NEXT. + exploit perm_alloc_inv; eauto. intros. + rewrite ZMap.gsspec. unfold ZIndexed.eq. destruct (zeq b0 b1). + rewrite ZMap.gi. constructor. eauto. Qed. Definition inj_offset_aligned (delta: Z) (size: Z) : Prop := @@ -2651,25 +2392,30 @@ Lemma alloc_left_mapped_inj: alloc m1 lo hi = (m1', b1) -> valid_block m2 b2 -> inj_offset_aligned delta (hi-lo) -> - (forall ofs p, lo <= ofs < hi -> perm m2 b2 (ofs + delta) p) -> + (forall ofs k p, lo <= ofs < hi -> perm m2 b2 (ofs + delta) k p) -> f b1 = Some(b2, delta) -> mem_inj f m1' m2. Proof. intros. inversion H. constructor. +(* perm *) + intros. + exploit perm_alloc_inv; eauto. intros. destruct (zeq b0 b1). subst b0. + rewrite H4 in H5; inv H5. eauto. eauto. (* access *) intros. exploit valid_access_alloc_inv; eauto. unfold eq_block. intros. - destruct (zeq b0 b1). subst b0. rewrite H4 in H5. inversion H5; clear H5; subst b3 delta0. + destruct (zeq b0 b1). subst b0. rewrite H4 in H5. inv H5. split. red; intros. - replace ofs0 with ((ofs0 - delta) + delta) by omega. + replace ofs0 with ((ofs0 - delta0) + delta0) by omega. apply H3. omega. destruct H6. apply Zdivide_plus_r. auto. apply H2. omega. eauto. (* mem_contents *) injection H0; intros NEXT MEM. - intros. rewrite <- MEM; simpl. rewrite NEXT. unfold update. - exploit perm_alloc_inv; eauto. intros. - destruct (zeq b0 b1). constructor. eauto. + intros. rewrite <- MEM; simpl. rewrite NEXT. + exploit perm_alloc_inv; eauto. intros. + rewrite ZMap.gsspec. unfold ZIndexed.eq. + destruct (zeq b0 b1). rewrite ZMap.gi. constructor. eauto. Qed. Lemma free_left_inj: @@ -2679,45 +2425,42 @@ Lemma free_left_inj: mem_inj f m1' m2. Proof. intros. exploit free_result; eauto. intro FREE. inversion H. constructor. +(* perm *) + intros. eauto with mem. (* access *) intros. eauto with mem. (* mem_contents *) - intros. rewrite FREE; simpl. - assert (b=b1 /\ lo <= ofs < hi \/ (b<>b1 \/ ofs<lo \/ hi <= ofs)) by (unfold block; omega). - destruct H3. - destruct H3. subst b1. - rewrite (clearN_in _ _ _ _ _ H4); auto. - constructor. - rewrite (clearN_out _ _ _ _ _ _ H3). - apply mi_memval0; auto. - eapply perm_free_3; eauto. + intros. rewrite FREE; simpl. eauto with mem. Qed. - Lemma free_right_inj: forall f m1 m2 b lo hi m2', mem_inj f m1 m2 -> free m2 b lo hi = Some m2' -> - (forall b1 delta ofs p, - f b1 = Some(b, delta) -> perm m1 b1 ofs p -> - lo <= ofs + delta < hi -> False) -> + (forall b' delta ofs k p, + f b' = Some(b, delta) -> + perm m1 b' ofs k p -> lo <= ofs + delta < hi -> False) -> mem_inj f m1 m2'. Proof. - intros. exploit free_result; eauto. intro FREE. inversion H. constructor. + intros. exploit free_result; eauto. intro FREE. inversion H. + assert (PERM: + forall b1 b2 delta ofs k p, + f b1 = Some (b2, delta) -> + perm m1 b1 ofs k p -> perm m2' b2 (ofs + delta) k p). + intros. + intros. eapply perm_free_1; eauto. + destruct (zeq b2 b); auto. subst b. right. + assert (~ (lo <= ofs + delta < hi)). red; intros; eapply H1; eauto. + omega. + constructor. +(* perm *) + auto. (* access *) intros. exploit mi_access0; eauto. intros [RG AL]. split; auto. - red; intros. eapply perm_free_1; eauto. - destruct (zeq b2 b); auto. subst b. right. - destruct (zlt ofs0 lo); auto. destruct (zle hi ofs0); auto. - elimtype False. eapply H1 with (ofs := ofs0 - delta). eauto. - apply H3. omega. omega. + red; intros. replace ofs0 with ((ofs0 - delta) + delta) by omega. + eapply PERM. eauto. apply H3. omega. (* mem_contents *) - intros. rewrite FREE; simpl. - specialize (mi_memval0 _ _ _ _ H2 H3). - assert (b=b2 /\ lo <= ofs+delta < hi \/ (b<>b2 \/ ofs+delta<lo \/ hi <= ofs+delta)) by (unfold block; omega). - destruct H4. destruct H4. subst b2. - specialize (H1 _ _ _ _ H2 H3). elimtype False; auto. - rewrite (clearN_out _ _ _ _ _ _ H4); auto. + intros. rewrite FREE; simpl. eauto. Qed. (** Preservation of [drop_perm] operations. *) @@ -2730,13 +2473,16 @@ Lemma drop_unmapped_inj: mem_inj f m1' m2. Proof. intros. inv H. constructor. +(* perm *) + intros. eapply mi_perm0; eauto. eapply perm_drop_4; eauto. +(* access *) intros. eapply mi_access0. eauto. - eapply valid_access_drop_2; eauto. - intros. replace (mem_contents m1' b1 ofs) with (mem_contents m1 b1 ofs). - apply mi_memval0; auto. - eapply perm_drop_4; eauto. - unfold drop_perm in H0. destruct (range_perm_dec m1 b lo hi p); inv H0. - simpl. rewrite update_o; auto. congruence. + eapply valid_access_drop_2; eauto. +(* contents *) + intros. + replace (m1'.(mem_contents)#b1#ofs) with (m1.(mem_contents)#b1#ofs). + apply mi_memval0; auto. eapply perm_drop_4; eauto. + unfold drop_perm in H0; destruct (range_perm_dec m1 b lo hi Cur Freeable); inv H0; auto. Qed. Lemma drop_mapped_inj: @@ -2755,103 +2501,84 @@ Proof. replace ofs with ((ofs - delta) + delta) by omega. eapply perm_inj; eauto. eapply range_perm_drop_1; eauto. omega. destruct X as [m2' DROP]. exists m2'; split; auto. - inv H. constructor; intros. + inv H. + assert (PERM: forall b0 b3 delta0 ofs k p0, + f b0 = Some (b3, delta0) -> + perm m1' b0 ofs k p0 -> perm m2' b3 (ofs + delta0) k p0). + intros. + assert (perm m2 b3 (ofs + delta0) k p0). + eapply mi_perm0; eauto. eapply perm_drop_4; eauto. + destruct (zeq b1 b0). + (* b1 = b0 *) + subst b0. rewrite H2 in H; inv H. + destruct (zlt (ofs + delta0) (lo + delta0)). eapply perm_drop_3; eauto. + destruct (zle (hi + delta0) (ofs + delta0)). eapply perm_drop_3; eauto. + assert (perm_order p p0). + eapply perm_drop_2. eexact H0. instantiate (1 := ofs). omega. eauto. + apply perm_implies with p; auto. + eapply perm_drop_1. eauto. omega. + (* b1 <> b0 *) + eapply perm_drop_3; eauto. + destruct (zeq b3 b2); auto. + destruct (zlt (ofs + delta0) (lo + delta)); auto. + destruct (zle (hi + delta) (ofs + delta0)); auto. + exploit H1; eauto. + instantiate (1 := ofs + delta0 - delta). + apply perm_cur_max. apply perm_implies with Freeable. + eapply range_perm_drop_1; eauto. omega. auto with mem. + eapply perm_drop_4; eauto. eapply perm_max. apply perm_implies with p0. eauto. + eauto with mem. + unfold block. omega. + constructor. +(* perm *) + auto. (* access *) - exploit mi_access0; eauto. eapply valid_access_drop_2; eauto. + intros. exploit mi_access0; eauto. eapply valid_access_drop_2; eauto. intros [A B]. split; auto. red; intros. - destruct (eq_block b1 b0). subst b0. rewrite H2 in H; inv H. - (* b1 = b0 *) - destruct (zlt ofs0 (lo + delta0)). eapply perm_drop_3; eauto. - destruct (zle (hi + delta0) ofs0). eapply perm_drop_3; eauto. - destruct H3 as [C D]. - assert (perm_order p p0). - eapply perm_drop_2. eexact H0. instantiate (1 := ofs0 - delta0). omega. - apply C. omega. - apply perm_implies with p; auto. - eapply perm_drop_1. eauto. omega. - (* b1 <> b0 *) - eapply perm_drop_3; eauto. - exploit H1; eauto. intros [P | P]. auto. right. - destruct (zlt lo hi). - exploit range_perm_in_bounds. eapply range_perm_drop_1. eexact H0. auto. - intros [U V]. - exploit valid_access_drop_2. eexact H0. eauto. - intros [C D]. - exploit range_perm_in_bounds. eexact C. generalize (size_chunk_pos chunk); omega. - intros [X Y]. - generalize (size_chunk_pos chunk). omega. - omega. + replace ofs0 with ((ofs0 - delta0) + delta0) by omega. + eapply PERM; eauto. apply H3. omega. (* memval *) - assert (A: perm m1 b0 ofs Nonempty). eapply perm_drop_4; eauto. - exploit mi_memval0; eauto. intros B. - unfold drop_perm in *. - destruct (range_perm_dec m1 b1 lo hi p); inversion H0; clear H0. clear H5. - destruct (range_perm_dec m2 b2 (lo + delta) (hi + delta) p); inversion DROP; clear DROP. clear H4. - simpl. unfold update. destruct (zeq b0 b1). - (* b1 = b0 *) - subst b0. rewrite H2 in H; inv H. rewrite zeq_true. unfold proj_sumbool. - destruct (zle lo ofs). - rewrite zle_true. - destruct (zlt ofs hi). - rewrite zlt_true. - destruct (perm_order_dec p Readable). - simpl. auto. - simpl. constructor. - omega. - rewrite zlt_false. simpl. auto. omega. - omega. - rewrite zle_false. simpl. auto. omega. - (* b1 <> b0 *) - destruct (zeq b3 b2). - (* b2 = b3 *) - subst b3. exploit H1. eauto. eauto. eauto. intros [P | P]. congruence. - exploit perm_in_bounds; eauto. intros X. - destruct (zle (lo + delta) (ofs + delta0)). - destruct (zlt (ofs + delta0) (hi + delta)). - destruct (zlt lo hi). - exploit range_perm_in_bounds. eexact r. auto. intros [Y Z]. - omegaContradiction. - omegaContradiction. - simpl. auto. - simpl. auto. - auto. + intros. + replace (m1'.(mem_contents)#b0) with (m1.(mem_contents)#b0). + replace (m2'.(mem_contents)#b3) with (m2.(mem_contents)#b3). + apply mi_memval0; auto. eapply perm_drop_4; eauto. + unfold drop_perm in DROP; destruct (range_perm_dec m2 b2 (lo + delta) (hi + delta) Cur Freeable); inv DROP; auto. + unfold drop_perm in H0; destruct (range_perm_dec m1 b1 lo hi Cur Freeable); inv H0; auto. Qed. Lemma drop_outside_inj: forall f m1 m2 b lo hi p m2', mem_inj f m1 m2 -> drop_perm m2 b lo hi p = Some m2' -> - (forall b' delta, + (forall b' delta ofs' k p, f b' = Some(b, delta) -> - high_bound m1 b' + delta <= lo - \/ hi <= low_bound m1 b' + delta) -> + perm m1 b' ofs' k p -> + lo <= ofs' + delta < hi -> False) -> mem_inj f m1 m2'. -Proof. - intros. destruct H. constructor; intros. - +Proof. + intros. inv H. + assert (PERM: forall b0 b3 delta0 ofs k p0, + f b0 = Some (b3, delta0) -> + perm m1 b0 ofs k p0 -> perm m2' b3 (ofs + delta0) k p0). + intros. eapply perm_drop_3; eauto. + destruct (zeq b3 b); auto. subst b3. right. + destruct (zlt (ofs + delta0) lo); auto. + destruct (zle hi (ofs + delta0)); auto. + byContradiction. exploit H1; eauto. omega. + constructor. + (* perm *) + auto. (* access *) - inversion H2. - destruct (range_perm_in_bounds _ _ _ _ _ H3). - pose proof (size_chunk_pos chunk). omega. - pose proof (mi_access0 b1 b2 delta chunk ofs p0 H H2). clear mi_access0 H2 H3. - unfold valid_access in *. intuition. clear H3. - unfold range_perm in *. intros. - eapply perm_drop_3; eauto. - destruct (eq_block b2 b); subst; try (intuition; fail). - destruct (H1 b1 delta H); intuition omega. - - (* memval *) - pose proof (mi_memval0 _ _ _ _ H H2). clear mi_memval0. - unfold Mem.drop_perm in H0. - destruct (Mem.range_perm_dec m2 b lo hi p); inversion H0; subst; clear H0. - simpl. unfold update. destruct (zeq b2 b); subst; auto. - pose proof (perm_in_bounds _ _ _ _ H2). - destruct (H1 b1 delta H). - destruct (zle lo (ofs + delta)); simpl; auto. exfalso; omega. - destruct (zle lo (ofs + delta)); destruct (zlt (ofs + delta) hi); simpl; auto. - exfalso; omega. + intros. exploit mi_access0; eauto. intros [A B]. split; auto. + red; intros. + replace ofs0 with ((ofs0 - delta) + delta) by omega. + eapply PERM; eauto. apply H2. omega. + (* contents *) + intros. + replace (m2'.(mem_contents)#b2) with (m2.(mem_contents)#b2). + apply mi_memval0; auto. + unfold drop_perm in H0; destruct (range_perm_dec m2 b lo hi Cur Freeable); inv H0; auto. Qed. - (** * Memory extensions *) (** A store [m2] extends a store [m1] if [m2] can be obtained from [m1] @@ -2864,9 +2591,6 @@ Record extends' (m1 m2: mem) : Prop := mk_extends { mext_next: nextblock m1 = nextblock m2; mext_inj: mem_inj inject_id m1 m2 -(* - mext_bounds: forall b, low_bound m2 b <= low_bound m1 b /\ high_bound m1 b <= high_bound m2 b -*) }. Definition extends := extends'. @@ -2876,6 +2600,7 @@ Theorem extends_refl: Proof. intros. constructor. auto. constructor. intros. unfold inject_id in H; inv H. replace (ofs + 0) with ofs by omega. auto. + intros. unfold inject_id in H; inv H. replace (ofs + 0) with ofs by omega. auto. intros. unfold inject_id in H; inv H. replace (ofs + 0) with ofs by omega. apply memval_lessdef_refl. Qed. @@ -2936,30 +2661,19 @@ Proof. rewrite (nextblock_store _ _ _ _ _ _ H0). rewrite (nextblock_store _ _ _ _ _ _ A). auto. -(* - intros. - rewrite (bounds_store _ _ _ _ _ _ H0). - rewrite (bounds_store _ _ _ _ _ _ A). - auto. -*) Qed. Theorem store_outside_extends: forall chunk m1 m2 b ofs v m2', extends m1 m2 -> store chunk m2 b ofs v = Some m2' -> - ofs + size_chunk chunk <= low_bound m1 b \/ high_bound m1 b <= ofs -> + (forall ofs', perm m1 b ofs' Cur Readable -> ofs <= ofs' < ofs + size_chunk chunk -> False) -> extends m1 m2'. Proof. intros. inversion H. constructor. rewrite (nextblock_store _ _ _ _ _ _ H0). auto. eapply store_outside_inj; eauto. - unfold inject_id; intros. inv H2. - exploit perm_in_bounds; eauto. omega. -(* - intros. - rewrite (bounds_store _ _ _ _ _ _ H0). auto. -*) + unfold inject_id; intros. inv H2. eapply H1; eauto. omega. Qed. Theorem storev_extends: @@ -2997,30 +2711,19 @@ Proof. rewrite (nextblock_storebytes _ _ _ _ _ H0). rewrite (nextblock_storebytes _ _ _ _ _ A). auto. -(* - intros. - rewrite (bounds_store _ _ _ _ _ _ H0). - rewrite (bounds_store _ _ _ _ _ _ A). - auto. -*) Qed. Theorem storebytes_outside_extends: forall m1 m2 b ofs bytes2 m2', extends m1 m2 -> storebytes m2 b ofs bytes2 = Some m2' -> - ofs + Z_of_nat (length bytes2) <= low_bound m1 b \/ high_bound m1 b <= ofs -> + (forall ofs', perm m1 b ofs' Cur Readable -> ofs <= ofs' < ofs + Z_of_nat (length bytes2) -> False) -> extends m1 m2'. Proof. intros. inversion H. constructor. rewrite (nextblock_storebytes _ _ _ _ _ H0). auto. eapply storebytes_outside_inj; eauto. - unfold inject_id; intros. inv H2. - exploit perm_in_bounds; eauto. omega. -(* - intros. - rewrite (bounds_store _ _ _ _ _ _ H0). auto. -*) + unfold inject_id; intros. inv H2. eapply H1; eauto. omega. Qed. Theorem alloc_extends: @@ -3063,26 +2766,19 @@ Proof. intros. inv H. constructor. rewrite (nextblock_free _ _ _ _ _ H0). auto. eapply free_left_inj; eauto. -(* - intros. rewrite (bounds_free _ _ _ _ _ H0). auto. -*) Qed. Theorem free_right_extends: forall m1 m2 b lo hi m2', extends m1 m2 -> free m2 b lo hi = Some m2' -> - (forall ofs p, lo <= ofs < hi -> ~perm m1 b ofs p) -> + (forall ofs k p, perm m1 b ofs k p -> lo <= ofs < hi -> False) -> extends m1 m2'. Proof. intros. inv H. constructor. rewrite (nextblock_free _ _ _ _ _ H0). auto. eapply free_right_inj; eauto. - unfold inject_id; intros. inv H. - elim (H1 ofs p); auto. omega. -(* - intros. rewrite (bounds_free _ _ _ _ _ H0). auto. -*) + unfold inject_id; intros. inv H. eapply H1; eauto. omega. Qed. Theorem free_parallel_extends: @@ -3105,15 +2801,8 @@ Proof. rewrite (nextblock_free _ _ _ _ _ FREE). auto. eapply free_right_inj with (m1 := m1'); eauto. eapply free_left_inj; eauto. - unfold inject_id; intros. inv H. - assert (~perm m1' b ofs p). eapply perm_free_2; eauto. omega. - contradiction. -(* - intros. - rewrite (bounds_free _ _ _ _ _ H0). - rewrite (bounds_free _ _ _ _ _ FREE). - auto. -*) + unfold inject_id; intros. inv H. + eapply perm_free_2. eexact H0. instantiate (1 := ofs); omega. eauto. Qed. Theorem valid_block_extends: @@ -3125,8 +2814,8 @@ Proof. Qed. Theorem perm_extends: - forall m1 m2 b ofs p, - extends m1 m2 -> perm m1 b ofs p -> perm m2 b ofs p. + forall m1 m2 b ofs k p, + extends m1 m2 -> perm m1 b ofs k p -> perm m2 b ofs k p. Proof. intros. inv H. replace ofs with (ofs + 0) by omega. eapply perm_inj; eauto. @@ -3149,15 +2838,6 @@ Proof. eapply valid_access_extends; eauto. Qed. -(* -Theorem bounds_extends: - forall m1 m2 b, - extends m1 m2 -> low_bound m2 b <= low_bound m1 b /\ high_bound m1 b <= high_bound m2 b. -Proof. - intros. inv H. auto. -Qed. -*) - (** * Memory injections *) (** A memory state [m1] injects into another memory state [m2] via the @@ -3188,15 +2868,15 @@ Record inject' (f: meminj) (m1 m2: mem) : Prop := f b = Some(b', delta) -> 0 <= delta <= Int.max_unsigned; mi_range_block: - forall b b' delta, + forall b b' delta ofs k p, f b = Some(b', delta) -> - delta = 0 \/ - (0 <= low_bound m2 b' /\ high_bound m2 b' <= Int.max_unsigned) + perm m2 b' ofs k p -> + delta = 0 \/ 0 <= ofs <= Int.max_unsigned }. Definition inject := inject'. -Hint Local Resolve mi_mappedblocks mi_range_offset: mem. +Local Hint Resolve mi_mappedblocks mi_range_offset: mem. (** Preservation of access validity and pointer validity *) @@ -3219,22 +2899,22 @@ Proof. intros. eapply mi_mappedblocks; eauto. Qed. -Hint Local Resolve valid_block_inject_1 valid_block_inject_2: mem. +Local Hint Resolve valid_block_inject_1 valid_block_inject_2: mem. Theorem perm_inject: - forall f m1 m2 b1 b2 delta ofs p, + forall f m1 m2 b1 b2 delta ofs k p, f b1 = Some(b2, delta) -> inject f m1 m2 -> - perm m1 b1 ofs p -> perm m2 b2 (ofs + delta) p. + perm m1 b1 ofs k p -> perm m2 b2 (ofs + delta) k p. Proof. intros. inv H0. eapply perm_inj; eauto. Qed. Theorem range_perm_inject: - forall f m1 m2 b1 b2 delta lo hi p, + forall f m1 m2 b1 b2 delta lo hi k p, f b1 = Some(b2, delta) -> inject f m1 m2 -> - range_perm m1 b1 lo hi p -> range_perm m2 b2 (lo + delta) (hi + delta) p. + range_perm m1 b1 lo hi k p -> range_perm m2 b2 (lo + delta) (hi + delta) k p. Proof. intros. inv H0. eapply range_perm_inj; eauto. Qed. @@ -3268,19 +2948,18 @@ Qed. Lemma address_inject: forall f m1 m2 b1 ofs1 b2 delta, inject f m1 m2 -> - perm m1 b1 (Int.unsigned ofs1) Nonempty -> + perm m1 b1 (Int.unsigned ofs1) Max Nonempty -> f b1 = Some (b2, delta) -> Int.unsigned (Int.add ofs1 (Int.repr delta)) = Int.unsigned ofs1 + delta. Proof. intros. exploit perm_inject; eauto. intro A. - exploit perm_in_bounds. eexact A. intros [B C]. - exploit mi_range_block; eauto. intros [D | [E F]]. + exploit mi_range_block; eauto. intros [D | E]. subst delta. rewrite Int.add_zero. omega. unfold Int.add. repeat rewrite Int.unsigned_repr. auto. eapply mi_range_offset; eauto. - omega. + auto. eapply mi_range_offset; eauto. Qed. @@ -3292,7 +2971,7 @@ Lemma address_inject': Int.unsigned (Int.add ofs1 (Int.repr delta)) = Int.unsigned ofs1 + delta. Proof. intros. destruct H0. eapply address_inject; eauto. - apply H0. generalize (size_chunk_pos chunk). omega. + apply perm_cur_max. apply H0. generalize (size_chunk_pos chunk). omega. Qed. Theorem valid_pointer_inject_no_overflow: @@ -3330,11 +3009,11 @@ Theorem inject_no_overlap: b1 <> b2 -> f b1 = Some (b1', delta1) -> f b2 = Some (b2', delta2) -> - perm m1 b1 ofs1 Nonempty -> - perm m1 b2 ofs2 Nonempty -> + perm m1 b1 ofs1 Max Nonempty -> + perm m1 b2 ofs2 Max Nonempty -> b1' <> b2' \/ ofs1 + delta1 <> ofs2 + delta2. Proof. - intros. inv H. eapply meminj_no_overlap_perm; eauto. + intros. inv H. eapply mi_no_overlap0; eauto. Qed. Theorem different_pointers_inject: @@ -3355,19 +3034,20 @@ Proof. rewrite (address_inject' _ _ _ _ _ _ _ _ H H1 H3). rewrite (address_inject' _ _ _ _ _ _ _ _ H H2 H4). inv H1. simpl in H5. inv H2. simpl in H1. - eapply meminj_no_overlap_perm. - eapply mi_no_overlap; eauto. eauto. eauto. eauto. - apply (H5 (Int.unsigned ofs1)). omega. - apply (H1 (Int.unsigned ofs2)). omega. + eapply mi_no_overlap; eauto. + apply perm_cur_max. apply (H5 (Int.unsigned ofs1)). omega. + apply perm_cur_max. apply (H1 (Int.unsigned ofs2)). omega. Qed. +Require Intv. + Theorem disjoint_or_equal_inject: forall f m m' b1 b1' delta1 b2 b2' delta2 ofs1 ofs2 sz, inject f m m' -> f b1 = Some(b1', delta1) -> f b2 = Some(b2', delta2) -> - range_perm m b1 ofs1 (ofs1 + sz) Nonempty -> - range_perm m b2 ofs2 (ofs2 + sz) Nonempty -> + range_perm m b1 ofs1 (ofs1 + sz) Max Nonempty -> + range_perm m b2 ofs2 (ofs2 + sz) Max Nonempty -> sz > 0 -> b1 <> b2 \/ ofs1 = ofs2 \/ ofs1 + sz <= ofs2 \/ ofs2 + sz <= ofs1 -> b1' <> b2' \/ ofs1 + delta1 = ofs2 + delta2 @@ -3375,12 +3055,19 @@ Theorem disjoint_or_equal_inject: \/ ofs2 + delta2 + sz <= ofs1 + delta1. Proof. intros. - exploit range_perm_in_bounds. eexact H2. omega. intros [LO1 HI1]. - exploit range_perm_in_bounds. eexact H3. omega. intros [LO2 HI2]. destruct (eq_block b1 b2). assert (b1' = b2') by congruence. assert (delta1 = delta2) by congruence. subst. destruct H5. congruence. right. destruct H5. left; congruence. right. omega. - exploit mi_no_overlap; eauto. intros [P | P]. auto. right. omega. + destruct (eq_block b1' b2'); auto. subst. right. right. + set (i1 := (ofs1 + delta1, ofs1 + delta1 + sz)). + set (i2 := (ofs2 + delta2, ofs2 + delta2 + sz)). + change (snd i1 <= fst i2 \/ snd i2 <= fst i1). + apply Intv.range_disjoint'; simpl; try omega. + unfold Intv.disjoint, Intv.In; simpl; intros. red; intros. + exploit mi_no_overlap; eauto. + instantiate (1 := x - delta1). apply H2. omega. + instantiate (1 := x - delta2). apply H3. omega. + unfold block; omega. Qed. Theorem aligned_area_inject: @@ -3388,7 +3075,7 @@ Theorem aligned_area_inject: inject f m m' -> al = 1 \/ al = 2 \/ al = 4 -> sz > 0 -> (al | sz) -> - range_perm m b ofs (ofs + sz) Nonempty -> + range_perm m b ofs (ofs + sz) Cur Nonempty -> (al | ofs) -> f b = Some(b', delta) -> (al | ofs + delta). @@ -3468,13 +3155,11 @@ Proof. (* mappedblocks *) eauto with mem. (* no overlap *) - red; intros. - repeat rewrite (bounds_store _ _ _ _ _ _ H0). - eauto. + red; intros. eauto with mem. (* range offset *) eauto. (* range blocks *) - intros. rewrite (bounds_store _ _ _ _ _ _ STORE). eauto. + eauto with mem. Qed. Theorem store_unmapped_inject: @@ -3493,9 +3178,7 @@ Proof. (* mappedblocks *) eauto with mem. (* no overlap *) - red; intros. - repeat rewrite (bounds_store _ _ _ _ _ _ H0). - eauto. + red; intros. eauto with mem. (* range offset *) eauto. (* range blocks *) @@ -3505,18 +3188,16 @@ Qed. Theorem store_outside_inject: forall f m1 m2 chunk b ofs v m2', inject f m1 m2 -> - (forall b' delta, + (forall b' delta ofs', f b' = Some(b, delta) -> - high_bound m1 b' + delta <= ofs - \/ ofs + size_chunk chunk <= low_bound m1 b' + delta) -> + perm m1 b' ofs' Cur Readable -> + ofs <= ofs' + delta < ofs + size_chunk chunk -> False) -> store chunk m2 b ofs v = Some m2' -> inject f m1 m2'. Proof. intros. inversion H. constructor. (* inj *) eapply store_outside_inj; eauto. - intros. exploit perm_in_bounds; eauto. intro. - exploit H0; eauto. intro. omega. (* freeblocks *) auto. (* mappedblocks *) @@ -3525,8 +3206,8 @@ Proof. auto. (* range offset *) auto. -(* rang blocks *) - intros. rewrite (bounds_store _ _ _ _ _ _ H1). eauto. +(* range blocks *) + intros. eauto with mem. Qed. Theorem storev_mapped_inject: @@ -3566,13 +3247,11 @@ Proof. (* mappedblocks *) intros. eapply storebytes_valid_block_1; eauto. (* no overlap *) - red; intros. - repeat rewrite (bounds_storebytes _ _ _ _ _ H0). - eauto. + red; intros. eapply mi_no_overlap0; eauto; eapply perm_storebytes_2; eauto. (* range offset *) eauto. (* range blocks *) - intros. rewrite (bounds_storebytes _ _ _ _ _ STORE). eauto. + intros. eapply mi_range_block0; eauto. eapply perm_storebytes_2; eauto. Qed. Theorem storebytes_unmapped_inject: @@ -3591,30 +3270,26 @@ Proof. (* mappedblocks *) eauto with mem. (* no overlap *) - red; intros. - repeat rewrite (bounds_storebytes _ _ _ _ _ H0). - eauto. + red; intros. eapply mi_no_overlap0; eauto; eapply perm_storebytes_2; eauto. (* range offset *) eauto. (* range blocks *) - auto. + eauto. Qed. Theorem storebytes_outside_inject: forall f m1 m2 b ofs bytes2 m2', inject f m1 m2 -> - (forall b' delta, + (forall b' delta ofs', f b' = Some(b, delta) -> - high_bound m1 b' + delta <= ofs - \/ ofs + Z_of_nat (length bytes2) <= low_bound m1 b' + delta) -> + perm m1 b' ofs' Cur Readable -> + ofs <= ofs' + delta < ofs + Z_of_nat (length bytes2) -> False) -> storebytes m2 b ofs bytes2 = Some m2' -> inject f m1 m2'. Proof. intros. inversion H. constructor. (* inj *) eapply storebytes_outside_inj; eauto. - intros. exploit perm_in_bounds; eauto. intro. - exploit H0; eauto. omega. (* freeblocks *) auto. (* mappedblocks *) @@ -3624,7 +3299,7 @@ Proof. (* range offset *) auto. (* range blocks *) - intros. rewrite (bounds_storebytes _ _ _ _ _ H1). eauto. + intros. eapply mi_range_block0; eauto. eapply perm_storebytes_2; eauto. Qed. (* Preservation of allocations *) @@ -3648,7 +3323,7 @@ Proof. (* range offset *) auto. (* range block *) - intros. rewrite (bounds_alloc_other _ _ _ _ _ H0). eauto. + intros. exploit perm_alloc_inv; eauto. rewrite zeq_false. eauto. eapply valid_not_valid_diff; eauto with mem. Qed. @@ -3663,39 +3338,43 @@ Theorem alloc_left_unmapped_inject: /\ (forall b, b <> b1 -> f' b = f b). Proof. intros. inversion H. - assert (inject_incr f (update b1 None f)). - red; unfold update; intros. destruct (zeq b b1). subst b. + set (f' := fun b => if zeq b b1 then None else f b). + assert (inject_incr f f'). + red; unfold f'; intros. destruct (zeq b b1). subst b. assert (f b1 = None). eauto with mem. congruence. auto. - assert (mem_inj (update b1 None f) m1 m2). + assert (mem_inj f' m1 m2). inversion mi_inj0; constructor; eauto with mem. - unfold update; intros. destruct (zeq b0 b1). congruence. eauto. - unfold update; intros. destruct (zeq b0 b1). congruence. + unfold f'; intros. destruct (zeq b0 b1). congruence. eauto. + unfold f'; intros. destruct (zeq b0 b1). congruence. eauto. + unfold f'; intros. destruct (zeq b0 b1). congruence. apply memval_inject_incr with f; auto. - exists (update b1 None f); split. constructor. + exists f'; split. constructor. (* inj *) - eapply alloc_left_unmapped_inj; eauto. apply update_s. + eapply alloc_left_unmapped_inj; eauto. unfold f'; apply zeq_true. (* freeblocks *) - intros. unfold update. destruct (zeq b b1). auto. + intros. unfold f'. destruct (zeq b b1). auto. apply mi_freeblocks0. red; intro; elim H3. eauto with mem. (* mappedblocks *) - unfold update; intros. destruct (zeq b b1). congruence. eauto. + unfold f'; intros. destruct (zeq b b1). congruence. eauto. (* no overlap *) - unfold update; red; intros. + unfold f'; red; intros. destruct (zeq b0 b1); destruct (zeq b2 b1); try congruence. - repeat rewrite (bounds_alloc_other _ _ _ _ _ H0); eauto. + eapply mi_no_overlap0. eexact H3. eauto. eauto. + exploit perm_alloc_inv. eauto. eexact H6. rewrite zeq_false; auto. + exploit perm_alloc_inv. eauto. eexact H7. rewrite zeq_false; auto. (* range offset *) - unfold update; intros. + unfold f'; intros. destruct (zeq b b1). congruence. eauto. (* range block *) - unfold update; intros. + unfold f'; intros. destruct (zeq b b1). congruence. eauto. (* incr *) split. auto. (* image *) - split. apply update_s. + split. unfold f'; apply zeq_true. (* incr *) - intros; apply update_o; auto. + intros; unfold f'; apply zeq_false; auto. Qed. Theorem alloc_left_mapped_inject: @@ -3704,13 +3383,13 @@ Theorem alloc_left_mapped_inject: alloc m1 lo hi = (m1', b1) -> valid_block m2 b2 -> 0 <= delta <= Int.max_unsigned -> - delta = 0 \/ 0 <= low_bound m2 b2 /\ high_bound m2 b2 <= Int.max_unsigned -> - (forall ofs p, lo <= ofs < hi -> perm m2 b2 (ofs + delta) p) -> + (forall ofs k p, perm m2 b2 ofs k p -> delta = 0 \/ 0 <= ofs <= Int.max_unsigned) -> + (forall ofs k p, lo <= ofs < hi -> perm m2 b2 (ofs + delta) k p) -> inj_offset_aligned delta (hi-lo) -> - (forall b ofs, - f b = Some (b2, ofs) -> - high_bound m1 b + ofs <= lo + delta \/ - hi + delta <= low_bound m1 b + ofs) -> + (forall b delta' ofs k p, + f b = Some (b2, delta') -> + perm m1 b ofs k p -> + lo + delta <= ofs + delta' < hi + delta -> False) -> exists f', inject f' m1' m2 /\ inject_incr f f' @@ -3718,48 +3397,57 @@ Theorem alloc_left_mapped_inject: /\ (forall b, b <> b1 -> f' b = f b). Proof. intros. inversion H. - assert (inject_incr f (update b1 (Some(b2, delta)) f)). - red; unfold update; intros. destruct (zeq b b1). subst b. + set (f' := fun b => if zeq b b1 then Some(b2, delta) else f b). + assert (inject_incr f f'). + red; unfold f'; intros. destruct (zeq b b1). subst b. assert (f b1 = None). eauto with mem. congruence. auto. - assert (mem_inj (update b1 (Some(b2, delta)) f) m1 m2). + assert (mem_inj f' m1 m2). inversion mi_inj0; constructor; eauto with mem. - unfold update; intros. destruct (zeq b0 b1). - inv H8. elim (fresh_block_alloc _ _ _ _ _ H0). eauto with mem. + unfold f'; intros. destruct (zeq b0 b1). + inversion H8. subst b0 b3 delta0. + elim (fresh_block_alloc _ _ _ _ _ H0). eauto with mem. + eauto. + unfold f'; intros. destruct (zeq b0 b1). + inversion H8. subst b0 b3 delta0. + elim (fresh_block_alloc _ _ _ _ _ H0). eauto with mem. eauto. - unfold update; intros. destruct (zeq b0 b1). - inv H8. elim (fresh_block_alloc _ _ _ _ _ H0). eauto with mem. + unfold f'; intros. destruct (zeq b0 b1). + inversion H8. subst b0 b3 delta0. + elim (fresh_block_alloc _ _ _ _ _ H0). eauto with mem. apply memval_inject_incr with f; auto. - exists (update b1 (Some(b2, delta)) f). split. constructor. + exists f'. split. constructor. (* inj *) - eapply alloc_left_mapped_inj; eauto. apply update_s. + eapply alloc_left_mapped_inj; eauto. unfold f'; apply zeq_true. (* freeblocks *) - unfold update; intros. destruct (zeq b b1). subst b. + unfold f'; intros. destruct (zeq b b1). subst b. elim H9. eauto with mem. eauto with mem. (* mappedblocks *) - unfold update; intros. destruct (zeq b b1). inv H9. auto. - eauto. + unfold f'; intros. destruct (zeq b b1). congruence. eauto. (* overlap *) - unfold update; red; intros. - repeat rewrite (bounds_alloc _ _ _ _ _ H0). unfold eq_block. - destruct (zeq b0 b1); destruct (zeq b3 b1); simpl. - inv H10; inv H11. congruence. - inv H10. destruct (zeq b1' b2'); auto. subst b2'. - right. generalize (H6 _ _ H11). tauto. - inv H11. destruct (zeq b1' b2'); auto. subst b2'. - right. eapply H6; eauto. + unfold f'; red; intros. + exploit perm_alloc_inv. eauto. eexact H12. intros P1. + exploit perm_alloc_inv. eauto. eexact H13. intros P2. + destruct (zeq b0 b1); destruct (zeq b3 b1). + congruence. + inversion H10; subst b0 b1' delta1. + destruct (zeq b2 b2'); auto. subst b2'. right; red; intros. + eapply H6; eauto. omega. + inversion H11; subst b3 b2' delta2. + destruct (zeq b1' b2); auto. subst b1'. right; red; intros. + eapply H6; eauto. omega. eauto. (* range offset *) - unfold update; intros. destruct (zeq b b1). inv H9. auto. eauto. + unfold f'; intros. destruct (zeq b b1). congruence. eauto. (* range block *) - unfold update; intros. destruct (zeq b b1). inv H9. auto. eauto. + unfold f'; intros. destruct (zeq b b1). inversion H9; subst b b' delta0. eauto. eauto. (* incr *) split. auto. (* image of b1 *) - split. apply update_s. + split. unfold f'; apply zeq_true. (* image of others *) - intros. apply update_o; auto. + intros. unfold f'; apply zeq_false; auto. Qed. Theorem alloc_parallel_inject: @@ -3782,11 +3470,10 @@ Proof. instantiate (1 := b2). eauto with mem. instantiate (1 := 0). unfold Int.max_unsigned. generalize Int.modulus_pos; omega. auto. - intros. - apply perm_implies with Freeable; auto with mem. + intros. apply perm_implies with Freeable; auto with mem. eapply perm_alloc_2; eauto. omega. red; intros. apply Zdivide_0. - intros. elimtype False. apply (valid_not_valid_diff m2 b2 b2); eauto with mem. + intros. apply (valid_not_valid_diff m2 b2 b2); eauto with mem. intros [f' [A [B [C D]]]]. exists f'; exists m2'; exists b2; auto. Qed. @@ -3807,7 +3494,7 @@ Proof. (* mappedblocks *) auto. (* no overlap *) - red; intros. repeat rewrite (bounds_free _ _ _ _ _ H0). eauto. + red; intros. eauto with mem. (* range offset *) auto. (* range block *) @@ -3831,8 +3518,8 @@ Lemma free_right_inject: forall f m1 m2 b lo hi m2', inject f m1 m2 -> free m2 b lo hi = Some m2' -> - (forall b1 delta ofs p, - f b1 = Some(b, delta) -> perm m1 b1 ofs p -> + (forall b1 delta ofs k p, + f b1 = Some(b, delta) -> perm m1 b1 ofs k p -> lo <= ofs + delta < hi -> False) -> inject f m1 m2'. Proof. @@ -3848,14 +3535,14 @@ Proof. (* range offset *) auto. (* range blocks *) - intros. rewrite (bounds_free _ _ _ _ _ H0). eauto. + intros. eauto with mem. Qed. Lemma perm_free_list: - forall l m m' b ofs p, + forall l m m' b ofs k p, free_list m l = Some m' -> - perm m' b ofs p -> - perm m b ofs p /\ + perm m' b ofs k p -> + perm m b ofs k p /\ (forall lo hi, In (b, lo, hi) l -> lo <= ofs < hi -> False). Proof. induction l; intros until p; simpl. @@ -3865,7 +3552,7 @@ Proof. exploit IHl; eauto. intros [A B]. split. eauto with mem. intros. destruct H2. inv H2. - elim (perm_free_2 _ _ _ _ _ H ofs p). auto. auto. + elim (perm_free_2 _ _ _ _ _ H ofs k p). auto. auto. eauto. Qed. @@ -3874,9 +3561,9 @@ Theorem free_inject: inject f m1 m2 -> free_list m1 l = Some m1' -> free m2 b lo hi = Some m2' -> - (forall b1 delta ofs p, + (forall b1 delta ofs k p, f b1 = Some(b, delta) -> - perm m1 b1 ofs p -> lo <= ofs + delta < hi -> + perm m1 b1 ofs k p -> lo <= ofs + delta < hi -> exists lo1, exists hi1, In (b1, lo1, hi1) l /\ lo1 <= ofs < hi1) -> inject f m1' m2'. Proof. @@ -3887,37 +3574,18 @@ Proof. exploit H2; eauto. intros [lo1 [hi1 [C D]]]. eauto. Qed. -(* -Theorem free_inject': - forall f m1 l m1' m2 b lo hi m2', - inject f m1 m2 -> - free_list m1 l = Some m1' -> - free m2 b lo hi = Some m2' -> - (forall b1 delta, - f b1 = Some(b, delta) -> In (b1, low_bound m1 b1, high_bound m1 b1) l) -> - inject f m1' m2'. -Proof. - intros. eapply free_inject; eauto. - intros. exists (low_bound m1 b1); exists (high_bound m1 b1). - split. eauto. apply perm_in_bounds with p. auto. -Qed. -*) - Lemma drop_outside_inject: forall f m1 m2 b lo hi p m2', inject f m1 m2 -> drop_perm m2 b lo hi p = Some m2' -> - (forall b' delta, + (forall b' delta ofs k p, f b' = Some(b, delta) -> - high_bound m1 b' + delta <= lo - \/ hi <= low_bound m1 b' + delta) -> + perm m1 b' ofs k p -> lo <= ofs + delta < hi -> False) -> inject f m1 m2'. Proof. intros. destruct H. constructor; eauto. eapply drop_outside_inj; eauto. - - intros. unfold valid_block in *. erewrite nextblock_drop; eauto. - - intros. erewrite bounds_drop; eauto. + intros. unfold valid_block in *. erewrite nextblock_drop; eauto. + intros. eapply mi_range_block0; eauto. eapply perm_drop_4; eauto. Qed. (** Injecting a memory into itself. *) @@ -3964,11 +3632,14 @@ Theorem empty_inject_neutral: forall thr, inject_neutral thr empty. Proof. intros; red; constructor. +(* perm *) + unfold flat_inj; intros. destruct (zlt b1 thr); inv H. + replace (ofs + 0) with ofs by omega; auto. (* access *) unfold flat_inj; intros. destruct (zlt b1 thr); inv H. replace (ofs + 0) with ofs by omega; auto. (* mem_contents *) - intros; simpl; constructor. + intros; simpl. repeat rewrite ZMap.gi. constructor. Qed. Theorem alloc_inject_neutral: @@ -4026,8 +3697,12 @@ Global Opaque Mem.alloc Mem.free Mem.store Mem.load Mem.storebytes Mem.loadbytes Hint Resolve Mem.valid_not_valid_diff Mem.perm_implies + Mem.perm_cur + Mem.perm_max Mem.perm_valid_block Mem.range_perm_implies + Mem.range_perm_cur + Mem.range_perm_max Mem.valid_access_implies Mem.valid_access_valid_block Mem.valid_access_perm @@ -4059,6 +3734,7 @@ Hint Resolve Mem.perm_alloc_1 Mem.perm_alloc_2 Mem.perm_alloc_3 + Mem.perm_alloc_4 Mem.perm_alloc_inv Mem.valid_access_alloc_other Mem.valid_access_alloc_same diff --git a/common/Memtype.v b/common/Memtype.v index 2e44331..a13e861 100644 --- a/common/Memtype.v +++ b/common/Memtype.v @@ -32,7 +32,8 @@ Require Import Memdata. (** Memory states are accessed by addresses [b, ofs]: pairs of a block identifier [b] and a byte offset [ofs] within that block. - Each address is in one of the following five states: + Each address is associated to permissions, also known as access rights. + The following permissions are expressible: - Freeable (exclusive access): all operations permitted - Writable: load, store and pointer comparison operations are permitted, but freeing is not. @@ -67,6 +68,21 @@ Proof. intros. inv H; inv H0; constructor. Qed. +(** Each address has not one, but two permissions associated + with it. The first is the current permission. It governs whether + operations (load, store, free, etc) over this address succeed or + not. The other is the maximal permission. It is always at least as + strong as the current permission. Once a block is allocated, the + maximal permission of an address within this block can only + decrease, as a result of [free] or [drop_perm] operations, or of + external calls. In contrast, the current permission of an address + can be temporarily lowered by an external call, then raised again by + another external call. *) + +Inductive perm_kind: Type := + | Max: perm_kind + | Cur: perm_kind. + Module Type MEM. (** The abstract type of memory states. *) @@ -143,8 +159,8 @@ Fixpoint free_list (m: mem) (l: list (block * Z * Z)) {struct l}: option mem := end. (** [drop_perm m b lo hi p] sets the permissions of the byte range - [(b, lo) ... (b, hi - 1)] to [p]. These bytes must have permissions - at least [p] in the initial memory state [m]. + [(b, lo) ... (b, hi - 1)] to [p]. These bytes must have [Freeable] permissions + in the initial memory state [m]. Returns updated memory state, or [None] if insufficient permissions. *) Parameter drop_perm: forall (m: mem) (b: block) (lo hi: Z) (p: permission), option mem. @@ -168,41 +184,52 @@ Definition valid_block (m: mem) (b: block) := Axiom valid_not_valid_diff: forall m b b', valid_block m b -> ~(valid_block m b') -> b <> b'. -(** [perm m b ofs p] holds if the address [b, ofs] in memory state [m] - has permission [p]: one of writable, readable, and nonempty. - If the address is empty, [perm m b ofs p] is false for all values of [p]. *) -Parameter perm: forall (m: mem) (b: block) (ofs: Z) (p: permission), Prop. +(** [perm m b ofs k p] holds if the address [b, ofs] in memory state [m] + has permission [p]: one of freeable, writable, readable, and nonempty. + If the address is empty, [perm m b ofs p] is false for all values of [p]. + [k] is the kind of permission we are interested in: either the current + permissions or the maximal permissions. *) +Parameter perm: forall (m: mem) (b: block) (ofs: Z) (k: perm_kind) (p: permission), Prop. (** Logical implications between permissions *) Axiom perm_implies: - forall m b ofs p1 p2, perm m b ofs p1 -> perm_order p1 p2 -> perm m b ofs p2. + forall m b ofs k p1 p2, perm m b ofs k p1 -> perm_order p1 p2 -> perm m b ofs k p2. + +(** The current permission is always less than or equal to the maximal permission. *) + +Axiom perm_cur_max: + forall m b ofs p, perm m b ofs Cur p -> perm m b ofs Max p. +Axiom perm_cur: + forall m b ofs k p, perm m b ofs Cur p -> perm m b ofs k p. +Axiom perm_max: + forall m b ofs k p, perm m b ofs k p -> perm m b ofs Max p. (** Having a (nonempty) permission implies that the block is valid. In other words, invalid blocks, not yet allocated, are all empty. *) Axiom perm_valid_block: - forall m b ofs p, perm m b ofs p -> valid_block m b. + forall m b ofs k p, perm m b ofs k p -> valid_block m b. (* Unused? (** The [Mem.perm] predicate is decidable. *) Axiom perm_dec: - forall m b ofs p, {perm m b ofs p} + {~ perm m b ofs p}. + forall m b ofs k p, {perm m b ofs k p} + {~ perm m b ofs k p}. *) (** [range_perm m b lo hi p] holds iff the addresses [b, lo] to [b, hi-1] - all have permission [p]. *) -Definition range_perm (m: mem) (b: block) (lo hi: Z) (p: permission) : Prop := - forall ofs, lo <= ofs < hi -> perm m b ofs p. + all have permission [p] of kind [k]. *) +Definition range_perm (m: mem) (b: block) (lo hi: Z) (k: perm_kind) (p: permission) : Prop := + forall ofs, lo <= ofs < hi -> perm m b ofs k p. Axiom range_perm_implies: - forall m b lo hi p1 p2, - range_perm m b lo hi p1 -> perm_order p1 p2 -> range_perm m b lo hi p2. + forall m b lo hi k p1 p2, + range_perm m b lo hi k p1 -> perm_order p1 p2 -> range_perm m b lo hi k p2. (** An access to a memory quantity [chunk] at address [b, ofs] with permission [p] is valid in [m] if the accessed addresses all have - permission [p] and moreover the offset is properly aligned. *) + current permission [p] and moreover the offset is properly aligned. *) Definition valid_access (m: mem) (chunk: memory_chunk) (b: block) (ofs: Z) (p: permission): Prop := - range_perm m b ofs (ofs + size_chunk chunk) p + range_perm m b ofs (ofs + size_chunk chunk) Cur p /\ (align_chunk chunk | ofs). Axiom valid_access_implies: @@ -216,9 +243,9 @@ Axiom valid_access_valid_block: valid_block m b. Axiom valid_access_perm: - forall m chunk b ofs p, + forall m chunk b ofs k p, valid_access m chunk b ofs p -> - perm m b ofs p. + perm m b ofs k p. (** [valid_pointer m b ofs] returns [true] if the address [b, ofs] is nonempty in [m] and [false] if it is empty. *) @@ -227,41 +254,17 @@ Parameter valid_pointer: forall (m: mem) (b: block) (ofs: Z), bool. Axiom valid_pointer_nonempty_perm: forall m b ofs, - valid_pointer m b ofs = true <-> perm m b ofs Nonempty. + valid_pointer m b ofs = true <-> perm m b ofs Cur Nonempty. Axiom valid_pointer_valid_access: forall m b ofs, valid_pointer m b ofs = true <-> valid_access m Mint8unsigned b ofs Nonempty. -(** Each block has associated low and high bounds. These are the bounds - that were given when the block was allocated. *) - -Parameter bounds: forall (m: mem) (b: block), Z*Z. - -Notation low_bound m b := (fst(bounds m b)). -Notation high_bound m b := (snd(bounds m b)). - -(** The crucial properties of bounds is that any offset below the low - bound or above the high bound is empty. *) - -Axiom perm_in_bounds: - forall m b ofs p, perm m b ofs p -> low_bound m b <= ofs < high_bound m b. - -Axiom range_perm_in_bounds: - forall m b lo hi p, - range_perm m b lo hi p -> lo < hi -> - low_bound m b <= lo /\ hi <= high_bound m b. - -Axiom valid_access_in_bounds: - forall m chunk b ofs p, - valid_access m chunk b ofs p -> - low_bound m b <= ofs /\ ofs + size_chunk chunk <= high_bound m b. - (** * Properties of the memory operations *) (** ** Properties of the initial memory state. *) Axiom nextblock_empty: nextblock empty = 1. -Axiom perm_empty: forall b ofs p, ~perm empty b ofs p. +Axiom perm_empty: forall b ofs k p, ~perm empty b ofs k p. Axiom valid_access_empty: forall chunk b ofs p, ~valid_access empty chunk b ofs p. @@ -315,12 +318,12 @@ Axiom load_int16_signed_unsigned: Axiom range_perm_loadbytes: forall m b ofs len, - range_perm m b ofs (ofs + len) Readable -> + range_perm m b ofs (ofs + len) Cur Readable -> exists bytes, loadbytes m b ofs len = Some bytes. Axiom loadbytes_range_perm: forall m b ofs len bytes, loadbytes m b ofs len = Some bytes -> - range_perm m b ofs (ofs + len) Readable. + range_perm m b ofs (ofs + len) Cur Readable. (** If [loadbytes] succeeds, the corresponding [load] succeeds and returns a value that is determined by the @@ -384,10 +387,10 @@ Axiom store_valid_block_2: Axiom perm_store_1: forall chunk m1 b ofs v m2, store chunk m1 b ofs v = Some m2 -> - forall b' ofs' p, perm m1 b' ofs' p -> perm m2 b' ofs' p. + forall b' ofs' k p, perm m1 b' ofs' k p -> perm m2 b' ofs' k p. Axiom perm_store_2: forall chunk m1 b ofs v m2, store chunk m1 b ofs v = Some m2 -> - forall b' ofs' p, perm m2 b' ofs' p -> perm m1 b' ofs' p. + forall b' ofs' k p, perm m2 b' ofs' k p -> perm m1 b' ofs' k p. Axiom valid_access_store: forall m1 chunk b ofs v, @@ -405,10 +408,6 @@ Axiom store_valid_access_3: forall chunk m1 b ofs v m2, store chunk m1 b ofs v = Some m2 -> valid_access m1 chunk b ofs Writable. -Axiom bounds_store: - forall chunk m1 b ofs v m2, store chunk m1 b ofs v = Some m2 -> - forall b', bounds m2 b' = bounds m1 b'. - (** Load-store properties. *) Axiom load_store_similar: @@ -502,17 +501,17 @@ Axiom store_float32_truncate: Axiom range_perm_storebytes: forall m1 b ofs bytes, - range_perm m1 b ofs (ofs + Z_of_nat (length bytes)) Writable -> + range_perm m1 b ofs (ofs + Z_of_nat (length bytes)) Cur Writable -> { m2 : mem | storebytes m1 b ofs bytes = Some m2 }. Axiom storebytes_range_perm: forall m1 b ofs bytes m2, storebytes m1 b ofs bytes = Some m2 -> - range_perm m1 b ofs (ofs + Z_of_nat (length bytes)) Writable. + range_perm m1 b ofs (ofs + Z_of_nat (length bytes)) Cur Writable. Axiom perm_storebytes_1: forall m1 b ofs bytes m2, storebytes m1 b ofs bytes = Some m2 -> - forall b' ofs' p, perm m1 b' ofs' p -> perm m2 b' ofs' p. + forall b' ofs' k p, perm m1 b' ofs' k p -> perm m2 b' ofs' k p. Axiom perm_storebytes_2: forall m1 b ofs bytes m2, storebytes m1 b ofs bytes = Some m2 -> - forall b' ofs' p, perm m2 b' ofs' p -> perm m1 b' ofs' p. + forall b' ofs' k p, perm m2 b' ofs' k p -> perm m1 b' ofs' k p. Axiom storebytes_valid_access_1: forall m1 b ofs bytes m2, storebytes m1 b ofs bytes = Some m2 -> forall chunk' b' ofs' p, @@ -530,9 +529,6 @@ Axiom storebytes_valid_block_1: Axiom storebytes_valid_block_2: forall m1 b ofs bytes m2, storebytes m1 b ofs bytes = Some m2 -> forall b', valid_block m2 b' -> valid_block m1 b'. -Axiom bounds_storebytes: - forall m1 b ofs bytes m2, storebytes m1 b ofs bytes = Some m2 -> - forall b', bounds m2 b' = bounds m1 b'. (** Connections between [store] and [storebytes]. *) @@ -581,8 +577,6 @@ Axiom storebytes_split: exists m1, storebytes m b ofs bytes1 = Some m1 /\ storebytes m1 b (ofs + Z_of_nat(length bytes1)) bytes2 = Some m2. -Axiom storebytes_empty: - forall m b ofs, storebytes m b ofs nil = Some m. (** ** Properties of [alloc]. *) @@ -616,18 +610,21 @@ Axiom valid_block_alloc_inv: Axiom perm_alloc_1: forall m1 lo hi m2 b, alloc m1 lo hi = (m2, b) -> - forall b' ofs p, perm m1 b' ofs p -> perm m2 b' ofs p. + forall b' ofs k p, perm m1 b' ofs k p -> perm m2 b' ofs k p. Axiom perm_alloc_2: forall m1 lo hi m2 b, alloc m1 lo hi = (m2, b) -> - forall ofs, lo <= ofs < hi -> perm m2 b ofs Freeable. + forall ofs k, lo <= ofs < hi -> perm m2 b ofs k Freeable. Axiom perm_alloc_3: forall m1 lo hi m2 b, alloc m1 lo hi = (m2, b) -> - forall ofs p, ofs < lo \/ hi <= ofs -> ~perm m2 b ofs p. + forall ofs k p, perm m2 b ofs k p -> lo <= ofs < hi. +Axiom perm_alloc_4: + forall m1 lo hi m2 b, alloc m1 lo hi = (m2, b) -> + forall b' ofs k p, perm m2 b' ofs k p -> b' <> b -> perm m1 b' ofs k p. Axiom perm_alloc_inv: forall m1 lo hi m2 b, alloc m1 lo hi = (m2, b) -> - forall b' ofs p, - perm m2 b' ofs p -> - if zeq b' b then lo <= ofs < hi else perm m1 b' ofs p. + forall b' ofs k p, + perm m2 b' ofs k p -> + if zeq b' b then lo <= ofs < hi else perm m1 b' ofs k p. (** Effect of [alloc] on access validity. *) @@ -649,20 +646,6 @@ Axiom valid_access_alloc_inv: then lo <= ofs /\ ofs + size_chunk chunk <= hi /\ (align_chunk chunk | ofs) else valid_access m1 chunk b' ofs p. -(** Effect of [alloc] on bounds. *) - -Axiom bounds_alloc: - forall m1 lo hi m2 b, alloc m1 lo hi = (m2, b) -> - forall b', bounds m2 b' = if eq_block b' b then (lo, hi) else bounds m1 b'. - -Axiom bounds_alloc_same: - forall m1 lo hi m2 b, alloc m1 lo hi = (m2, b) -> - bounds m2 b = (lo, hi). - -Axiom bounds_alloc_other: - forall m1 lo hi m2 b, alloc m1 lo hi = (m2, b) -> - forall b', b' <> b -> bounds m2 b' = bounds m1 b'. - (** Load-alloc properties. *) Axiom load_alloc_unchanged: @@ -689,15 +672,15 @@ Axiom load_alloc_same': (** ** Properties of [free]. *) (** [free] succeeds if and only if the correspond range of addresses - has [Freeable] permission. *) + has [Freeable] current permission. *) Axiom range_perm_free: forall m1 b lo hi, - range_perm m1 b lo hi Freeable -> + range_perm m1 b lo hi Cur Freeable -> { m2: mem | free m1 b lo hi = Some m2 }. Axiom free_range_perm: forall m1 bf lo hi m2, free m1 bf lo hi = Some m2 -> - range_perm m1 bf lo hi Freeable. + range_perm m1 bf lo hi Cur Freeable. (** Block validity is preserved by [free]. *) @@ -715,17 +698,17 @@ Axiom valid_block_free_2: Axiom perm_free_1: forall m1 bf lo hi m2, free m1 bf lo hi = Some m2 -> - forall b ofs p, + forall b ofs k p, b <> bf \/ ofs < lo \/ hi <= ofs -> - perm m1 b ofs p -> - perm m2 b ofs p. + perm m1 b ofs k p -> + perm m2 b ofs k p. Axiom perm_free_2: forall m1 bf lo hi m2, free m1 bf lo hi = Some m2 -> - forall ofs p, lo <= ofs < hi -> ~ perm m2 bf ofs p. + forall ofs k p, lo <= ofs < hi -> ~ perm m2 bf ofs k p. Axiom perm_free_3: forall m1 bf lo hi m2, free m1 bf lo hi = Some m2 -> - forall b ofs p, - perm m2 b ofs p -> perm m1 b ofs p. + forall b ofs k p, + perm m2 b ofs k p -> perm m1 b ofs k p. (** Effect of [free] on access validity. *) @@ -751,12 +734,6 @@ Axiom valid_access_free_inv_2: valid_access m2 chunk bf ofs p -> lo >= hi \/ ofs + size_chunk chunk <= lo \/ hi <= ofs. -(** [free] preserves bounds. *) - -Axiom bounds_free: - forall m1 bf lo hi m2, free m1 bf lo hi = Some m2 -> - forall b, bounds m2 b = bounds m1 b. - (** Load-free properties *) Axiom load_free: @@ -770,30 +747,32 @@ Axiom load_free: Axiom nextblock_drop: forall m b lo hi p m', drop_perm m b lo hi p = Some m' -> nextblock m' = nextblock m. +Axiom drop_perm_valid_block_1: + forall m b lo hi p m', drop_perm m b lo hi p = Some m' -> + forall b', valid_block m b' -> valid_block m' b'. +Axiom drop_perm_valid_block_2: + forall m b lo hi p m', drop_perm m b lo hi p = Some m' -> + forall b', valid_block m' b' -> valid_block m b'. Axiom range_perm_drop_1: forall m b lo hi p m', drop_perm m b lo hi p = Some m' -> - range_perm m b lo hi p. + range_perm m b lo hi Cur Freeable. Axiom range_perm_drop_2: forall m b lo hi p, - range_perm m b lo hi p -> { m' | drop_perm m b lo hi p = Some m' }. + range_perm m b lo hi Cur Freeable -> { m' | drop_perm m b lo hi p = Some m' }. Axiom perm_drop_1: forall m b lo hi p m', drop_perm m b lo hi p = Some m' -> - forall ofs, lo <= ofs < hi -> perm m' b ofs p. + forall ofs k, lo <= ofs < hi -> perm m' b ofs k p. Axiom perm_drop_2: forall m b lo hi p m', drop_perm m b lo hi p = Some m' -> - forall ofs p', lo <= ofs < hi -> perm m' b ofs p' -> perm_order p p'. + forall ofs k p', lo <= ofs < hi -> perm m' b ofs k p' -> perm_order p p'. Axiom perm_drop_3: forall m b lo hi p m', drop_perm m b lo hi p = Some m' -> - forall b' ofs p', b' <> b \/ ofs < lo \/ hi <= ofs -> perm m b' ofs p' -> perm m' b' ofs p'. + forall b' ofs k p', b' <> b \/ ofs < lo \/ hi <= ofs -> perm m b' ofs k p' -> perm m' b' ofs k p'. Axiom perm_drop_4: forall m b lo hi p m', drop_perm m b lo hi p = Some m' -> - forall b' ofs p', perm m' b' ofs p' -> perm m b' ofs p'. - -Axiom bounds_drop: - forall m b lo hi p m', drop_perm m b lo hi p = Some m' -> - forall b', bounds m' b' = bounds m b'. + forall b' ofs k p', perm m' b' ofs k p' -> perm m b' ofs k p'. Axiom load_drop: forall m b lo hi p m', drop_perm m b lo hi p = Some m' -> @@ -848,7 +827,7 @@ Axiom store_outside_extends: forall chunk m1 m2 b ofs v m2', extends m1 m2 -> store chunk m2 b ofs v = Some m2' -> - ofs + size_chunk chunk <= low_bound m1 b \/ high_bound m1 b <= ofs -> + (forall ofs', perm m1 b ofs' Cur Readable -> ofs <= ofs' < ofs + size_chunk chunk -> False) -> extends m1 m2'. Axiom storev_extends: @@ -874,7 +853,7 @@ Axiom storebytes_outside_extends: forall m1 m2 b ofs bytes2 m2', extends m1 m2 -> storebytes m2 b ofs bytes2 = Some m2' -> - ofs + Z_of_nat (length bytes2) <= low_bound m1 b \/ high_bound m1 b <= ofs -> + (forall ofs', perm m1 b ofs' Cur Readable -> ofs <= ofs' < ofs + Z_of_nat (length bytes2) -> False) -> extends m1 m2'. Axiom alloc_extends: @@ -896,7 +875,7 @@ Axiom free_right_extends: forall m1 m2 b lo hi m2', extends m1 m2 -> free m2 b lo hi = Some m2' -> - (forall ofs p, lo <= ofs < hi -> ~perm m1 b ofs p) -> + (forall ofs k p, perm m1 b ofs k p -> lo <= ofs < hi -> False) -> extends m1 m2'. Axiom free_parallel_extends: @@ -912,8 +891,8 @@ Axiom valid_block_extends: extends m1 m2 -> (valid_block m1 b <-> valid_block m2 b). Axiom perm_extends: - forall m1 m2 b ofs p, - extends m1 m2 -> perm m1 b ofs p -> perm m2 b ofs p. + forall m1 m2 b ofs k p, + extends m1 m2 -> perm m1 b ofs k p -> perm m2 b ofs k p. Axiom valid_access_extends: forall m1 m2 chunk b ofs p, extends m1 m2 -> valid_access m1 chunk b ofs p -> valid_access m2 chunk b ofs p. @@ -952,10 +931,10 @@ Axiom valid_block_inject_2: valid_block m2 b2. Axiom perm_inject: - forall f m1 m2 b1 b2 delta ofs p, + forall f m1 m2 b1 b2 delta ofs k p, f b1 = Some(b2, delta) -> inject f m1 m2 -> - perm m1 b1 ofs p -> perm m2 b2 (ofs + delta) p. + perm m1 b1 ofs k p -> perm m2 b2 (ofs + delta) k p. Axiom valid_access_inject: forall f m1 m2 chunk b1 ofs b2 delta p, @@ -974,7 +953,7 @@ Axiom valid_pointer_inject: Axiom address_inject: forall f m1 m2 b1 ofs1 b2 delta, inject f m1 m2 -> - perm m1 b1 (Int.unsigned ofs1) Nonempty -> + perm m1 b1 (Int.unsigned ofs1) Max Nonempty -> f b1 = Some (b2, delta) -> Int.unsigned (Int.add ofs1 (Int.repr delta)) = Int.unsigned ofs1 + delta. @@ -998,8 +977,8 @@ Axiom inject_no_overlap: b1 <> b2 -> f b1 = Some (b1', delta1) -> f b2 = Some (b2', delta2) -> - perm m1 b1 ofs1 Nonempty -> - perm m1 b2 ofs2 Nonempty -> + perm m1 b1 ofs1 Max Nonempty -> + perm m1 b2 ofs2 Max Nonempty -> b1' <> b2' \/ ofs1 + delta1 <> ofs2 + delta2. Axiom different_pointers_inject: @@ -1056,10 +1035,10 @@ Axiom store_unmapped_inject: Axiom store_outside_inject: forall f m1 m2 chunk b ofs v m2', inject f m1 m2 -> - (forall b' delta, + (forall b' delta ofs', f b' = Some(b, delta) -> - high_bound m1 b' + delta <= ofs - \/ ofs + size_chunk chunk <= low_bound m1 b' + delta) -> + perm m1 b' ofs' Cur Readable -> + ofs <= ofs' + delta < ofs + size_chunk chunk -> False) -> store chunk m2 b ofs v = Some m2' -> inject f m1 m2'. @@ -1092,10 +1071,10 @@ Axiom storebytes_unmapped_inject: Axiom storebytes_outside_inject: forall f m1 m2 b ofs bytes2 m2', inject f m1 m2 -> - (forall b' delta, + (forall b' delta ofs', f b' = Some(b, delta) -> - high_bound m1 b' + delta <= ofs - \/ ofs + Z_of_nat (length bytes2) <= low_bound m1 b' + delta) -> + perm m1 b' ofs' Cur Readable -> + ofs <= ofs' + delta < ofs + Z_of_nat (length bytes2) -> False) -> storebytes m2 b ofs bytes2 = Some m2' -> inject f m1 m2'. @@ -1124,13 +1103,13 @@ Axiom alloc_left_mapped_inject: alloc m1 lo hi = (m1', b1) -> valid_block m2 b2 -> 0 <= delta <= Int.max_unsigned -> - delta = 0 \/ 0 <= low_bound m2 b2 /\ high_bound m2 b2 <= Int.max_unsigned -> - (forall ofs p, lo <= ofs < hi -> perm m2 b2 (ofs + delta) p) -> + (forall ofs k p, perm m2 b2 ofs k p -> delta = 0 \/ 0 <= ofs <= Int.max_unsigned) -> + (forall ofs k p, lo <= ofs < hi -> perm m2 b2 (ofs + delta) k p) -> inj_offset_aligned delta (hi-lo) -> - (forall b ofs, - f b = Some (b2, ofs) -> - high_bound m1 b + ofs <= lo + delta \/ - hi + delta <= low_bound m1 b + ofs) -> + (forall b delta' ofs k p, + f b = Some (b2, delta') -> + perm m1 b ofs k p -> + lo + delta <= ofs + delta' < hi + delta -> False) -> exists f', inject f' m1' m2 /\ inject_incr f f' @@ -1154,8 +1133,8 @@ Axiom free_inject: inject f m1 m2 -> free_list m1 l = Some m1' -> free m2 b lo hi = Some m2' -> - (forall b1 delta ofs p, - f b1 = Some(b, delta) -> perm m1 b1 ofs p -> lo <= ofs + delta < hi -> + (forall b1 delta ofs k p, + f b1 = Some(b, delta) -> perm m1 b1 ofs k p -> lo <= ofs + delta < hi -> exists lo1, exists hi1, In (b1, lo1, hi1) l /\ lo1 <= ofs < hi1) -> inject f m1' m2'. @@ -1163,10 +1142,9 @@ Axiom drop_outside_inject: forall f m1 m2 b lo hi p m2', inject f m1 m2 -> drop_perm m2 b lo hi p = Some m2' -> - (forall b' delta, + (forall b' delta ofs k p, f b' = Some(b, delta) -> - high_bound m1 b' + delta <= lo - \/ hi <= low_bound m1 b' + delta) -> + perm m1 b' ofs k p -> lo <= ofs + delta < hi -> False) -> inject f m1 m2'. (** Memory states that inject into themselves. *) diff --git a/doc/index.html b/doc/index.html index f767b2a..2abb967 100644 --- a/doc/index.html +++ b/doc/index.html @@ -87,6 +87,7 @@ semi-lattices. inequations by fixpoint iteration. <LI> <A HREF="html/Parmov.html">Parmov</A>: compilation of parallel assignments. <LI> <A HREF="html/UnionFind.html">UnionFind</A>: a persistent union-find data structure. +<LI> <A HREF="html/Postorder.html">Postorder</A>: postorder numbering of a directed graph. </UL> <H3>Definitions and theorems used in many parts of the development</H3> @@ -102,6 +103,7 @@ See also: <A HREF="html/Memory.html">Memory</A> (implementation of the memory mo See also: <A HREF="html/Memdata.html">Memdata</A> (in-memory representation of data). <LI> <A HREF="html/Globalenvs.html">Globalenvs</A>: global execution environments. <LI> <A HREF="html/Smallstep.html">Smallstep</A>: tools for small-step semantics. +<LI> <A HREF="html/Behaviors.html">Behaviors</A>: from small-step semantics to observable behaviors of programs. <LI> <A HREF="html/Determinism.html">Determinism</A>: determinism properties of small-step semantics. <LI> <A HREF="html/Op.html"><I>Op</I></A>: operators, addressing modes and their semantics. @@ -115,7 +117,7 @@ semantics. <A HREF="html/Csem.html">semantics</A> and <A HREF="html/Cstrategy.html">determinized semantics</A>.<BR> See also: <A HREF="html/Cexec.html">reference interpreter</A>. -<LI> <A HREF="html/Clight.html">Clight</A>: a simpler version of Cmedium where expressions contain no side-effects. +<LI> <A HREF="html/Clight.html">Clight</A>: a simpler version of CompCert C where expressions contain no side-effects. <LI> <A HREF="html/Csharpminor.html">Csharpminor</A>: low-level structured language. <LI> <A HREF="html/Cminor.html">Cminor</A>: low-level structured @@ -201,6 +203,21 @@ code. </TR> <TR valign="top"> + <TD>Function inlining</TD> + <TD>RTL to RTL</TD> + <TD><A HREF="html/Inlining.html">Inlining</A></TD> + <TD><A HREF="html/Inliningspec.html">Inliningspec</A> + <A HREF="html/Inliningproof.html">Inliningproof</A></TD> +</TR> + +<TR valign="top"> + <TD>Postorder renumbering of the CFG</TD> + <TD>RTL to RTL</TD> + <TD><A HREF="html/Renumber.html">Renumber</A></TD> + <TD><A HREF="html/Renumberproof.html">Renumberproof</A></TD> +</TR> + +<TR valign="top"> <TD>Constant propagation</TD> <TD>RTL to RTL</TD> <TD><A HREF="html/Constprop.html">Constprop</A><br> diff --git a/driver/Clflags.ml b/driver/Clflags.ml index 5003e3e..2be48de 100644 --- a/driver/Clflags.ml +++ b/driver/Clflags.ml @@ -23,13 +23,14 @@ let option_fbitfields = ref false let option_fvararg_calls = ref true let option_fpacked_structs = ref false let option_fsse = ref true +let option_ffloatconstprop = ref 2 let option_dparse = ref false let option_dcmedium = ref false let option_dclight = ref false let option_dcminor = ref false let option_drtl = ref false let option_dtailcall = ref false -let option_dcastopt = ref false +let option_dinlining = ref false let option_dconstprop = ref false let option_dcse = ref false let option_dalloc = ref false diff --git a/driver/Compiler.v b/driver/Compiler.v index be4f981..6fbfacd 100644 --- a/driver/Compiler.v +++ b/driver/Compiler.v @@ -44,6 +44,8 @@ Require Cminorgen. Require Selection. Require RTLgen. Require Tailcall. +Require Inlining. +Require Renumber. Require Constprop. Require CSE. Require Allocation. @@ -67,6 +69,8 @@ Require Cminorgenproof. Require Selectionproof. Require RTLgenproof. Require Tailcallproof. +Require Inliningproof. +Require Renumberproof. Require Constpropproof. Require CSEproof. Require Allocproof. @@ -88,12 +92,13 @@ Require Asmgenproof. (** Pretty-printers (defined in Caml). *) Parameter print_Clight: Clight.program -> unit. Parameter print_Cminor: Cminor.program -> unit. -Parameter print_RTL: RTL.fundef -> unit. -Parameter print_RTL_tailcall: RTL.fundef -> unit. -Parameter print_RTL_constprop: RTL.fundef -> unit. -Parameter print_RTL_cse: RTL.fundef -> unit. -Parameter print_LTLin: LTLin.fundef -> unit. -Parameter print_Mach: Mach.fundef -> unit. +Parameter print_RTL: RTL.program -> unit. +Parameter print_RTL_tailcall: RTL.program -> unit. +Parameter print_RTL_inline: RTL.program -> unit. +Parameter print_RTL_constprop: RTL.program -> unit. +Parameter print_RTL_cse: RTL.program -> unit. +Parameter print_LTLin: LTLin.program -> unit. +Parameter print_Mach: Mach.program -> unit. Open Local Scope string_scope. @@ -120,56 +125,38 @@ Definition print {A: Type} (printer: A -> unit) (prog: A) : A := (** We define three translation functions for whole programs: one starting with a C program, one with a Cminor program, one with an RTL program. The three translations produce Asm programs ready for - pretty-printing and assembling. - - There are two ways to compose the compiler passes. The first - translates every function from the Cminor program from Cminor to - RTL, then to LTL, etc, all the way to Asm, and iterates this - transformation for every function. The second translates the whole - Cminor program to a RTL program, then to an LTL program, etc. - Between CminorSel and Asm, we follow the first approach because it has - lower memory requirements. The translation from Clight to Asm - follows the second approach. - - The translation of an RTL function to an Asm function is as follows. *) - -Definition transf_rtl_fundef (f: RTL.fundef) : res Asm.fundef := + pretty-printing and assembling. *) + +Definition transf_rtl_program (f: RTL.program) : res Asm.program := OK f @@ print print_RTL - @@ Tailcall.transf_fundef + @@ Tailcall.transf_program @@ print print_RTL_tailcall - @@ Constprop.transf_fundef + @@@ Inlining.transf_program + @@ Renumber.transf_program + @@ print print_RTL_inline + @@ Constprop.transf_program + @@ Renumber.transf_program @@ print print_RTL_constprop - @@@ CSE.transf_fundef + @@@ CSE.transf_program @@ print print_RTL_cse - @@@ Allocation.transf_fundef - @@ Tunneling.tunnel_fundef - @@@ Linearize.transf_fundef - @@ CleanupLabels.transf_fundef + @@@ Allocation.transf_program + @@ Tunneling.tunnel_program + @@@ Linearize.transf_program + @@ CleanupLabels.transf_program @@ print print_LTLin - @@ Reload.transf_fundef - @@ RRE.transf_fundef - @@@ Stacking.transf_fundef + @@ Reload.transf_program + @@ RRE.transf_program + @@@ Stacking.transf_program @@ print print_Mach - @@@ Asmgen.transf_fundef. - -(* Here is the translation of a CminorSel function to an Asm function. *) - -Definition transf_cminorsel_fundef (f: CminorSel.fundef) : res Asm.fundef := - OK f - @@@ RTLgen.transl_fundef - @@@ transf_rtl_fundef. - -(** The corresponding translations for whole program follow. *) - -Definition transf_rtl_program (p: RTL.program) : res Asm.program := - transform_partial_program transf_rtl_fundef p. + @@@ Asmgen.transf_program. Definition transf_cminor_program (p: Cminor.program) : res Asm.program := OK p @@ print print_Cminor @@ Selection.sel_program - @@@ transform_partial_program transf_cminorsel_fundef. + @@@ RTLgen.transl_program + @@@ transf_rtl_program. Definition transf_clight_program (p: Clight.program) : res Asm.program := OK p @@ -323,21 +310,40 @@ Theorem transf_rtl_program_correct: Proof. intros. assert (F: forward_simulation (RTL.semantics p) (Asm.semantics tp)). - unfold transf_rtl_program, transf_rtl_fundef in H. - repeat TransfProgInv. - repeat rewrite transform_program_print_identity in *. subst. - generalize (transform_partial_program_identity _ _ _ _ X). intro EQ. subst. - - generalize Alloctyping.program_typing_preserved - Tunnelingtyping.program_typing_preserved - Linearizetyping.program_typing_preserved - CleanupLabelstyping.program_typing_preserved - Reloadtyping.program_typing_preserved - RREtyping.program_typing_preserved - Stackingtyping.program_typing_preserved; intros. + unfold transf_rtl_program in H. + repeat rewrite compose_print_identity in H. + simpl in H. + set (p1 := Tailcall.transf_program p) in *. + destruct (Inlining.transf_program p1) as [p11|]_eqn; simpl in H; try discriminate. + set (p12 := Renumber.transf_program p11) in *. + set (p2 := Constprop.transf_program p12) in *. + set (p21 := Renumber.transf_program p2) in *. + destruct (CSE.transf_program p21) as [p3|]_eqn; simpl in H; try discriminate. + destruct (Allocation.transf_program p3) as [p4|]_eqn; simpl in H; try discriminate. + set (p5 := Tunneling.tunnel_program p4) in *. + destruct (Linearize.transf_program p5) as [p6|]_eqn; simpl in H; try discriminate. + set (p7 := CleanupLabels.transf_program p6) in *. + set (p8 := Reload.transf_program p7) in *. + set (p9 := RRE.transf_program p8) in *. + destruct (Stacking.transf_program p9) as [p10|]_eqn; simpl in H; try discriminate. + + assert(TY1: LTLtyping.wt_program p5). + eapply Tunnelingtyping.program_typing_preserved. + eapply Alloctyping.program_typing_preserved; eauto. + assert(TY2: LTLintyping.wt_program p7). + eapply CleanupLabelstyping.program_typing_preserved. + eapply Linearizetyping.program_typing_preserved; eauto. + assert(TY3: Lineartyping.wt_program p9). + eapply RREtyping.program_typing_preserved. + eapply Reloadtyping.program_typing_preserved; eauto. + assert(TY4: Machtyping.wt_program p10). + eapply Stackingtyping.program_typing_preserved; eauto. eapply compose_forward_simulation. apply Tailcallproof.transf_program_correct. + eapply compose_forward_simulation. apply Inliningproof.transf_program_correct. eassumption. + eapply compose_forward_simulation. apply Renumberproof.transf_program_correct. eapply compose_forward_simulation. apply Constpropproof.transf_program_correct. + eapply compose_forward_simulation. apply Renumberproof.transf_program_correct. eapply compose_forward_simulation. apply CSEproof.transf_program_correct. eassumption. eapply compose_forward_simulation. apply Allocproof.transf_program_correct. eassumption. eapply compose_forward_simulation. apply Tunnelingproof.transf_program_correct. @@ -345,8 +351,8 @@ Proof. eapply compose_forward_simulation. apply CleanupLabelsproof.transf_program_correct. eapply compose_forward_simulation. apply Reloadproof.transf_program_correct. eauto. eapply compose_forward_simulation. apply RREproof.transf_program_correct. eauto. - eapply compose_forward_simulation. apply Stackingproof.transf_program_correct. eassumption. eauto 8. - apply Asmgenproof.transf_program_correct; eauto 10. + eapply compose_forward_simulation. apply Stackingproof.transf_program_correct. eassumption. eauto. + apply Asmgenproof.transf_program_correct; eauto. split. auto. apply forward_to_backward_simulation. auto. apply RTL.semantics_receptive. @@ -361,11 +367,14 @@ Theorem transf_cminor_program_correct: Proof. intros. assert (F: forward_simulation (Cminor.semantics p) (Asm.semantics tp)). - unfold transf_cminor_program, transf_cminorsel_fundef in H. - simpl in H. repeat TransfProgInv. + unfold transf_cminor_program in H. + repeat rewrite compose_print_identity in H. + simpl in H. + set (p1 := Selection.sel_program p) in *. + destruct (RTLgen.transl_program p1) as [p2|]_eqn; simpl in H; try discriminate. eapply compose_forward_simulation. apply Selectionproof.transf_program_correct. eapply compose_forward_simulation. apply RTLgenproof.transf_program_correct. eassumption. - exact (fst (transf_rtl_program_correct _ _ P)). + exact (fst (transf_rtl_program_correct _ _ H)). split. auto. apply forward_to_backward_simulation. auto. diff --git a/driver/Driver.ml b/driver/Driver.ml index ff1046d..3d0cc16 100644 --- a/driver/Driver.ml +++ b/driver/Driver.ml @@ -134,7 +134,7 @@ let compile_c_ast sourcename csyntax ofile = set_dest PrintCminor.destination option_dcminor ".cm"; set_dest PrintRTL.destination_rtl option_drtl ".rtl"; set_dest PrintRTL.destination_tailcall option_dtailcall ".tailcall.rtl"; - set_dest PrintRTL.destination_castopt option_dcastopt ".castopt.rtl"; + set_dest PrintRTL.destination_inlining option_dinlining ".inlining.rtl"; set_dest PrintRTL.destination_constprop option_dconstprop ".constprop.rtl"; set_dest PrintRTL.destination_cse option_dcse ".cse.rtl"; set_dest PrintLTLin.destination option_dalloc ".alloc.ltl"; @@ -151,7 +151,7 @@ let compile_c_ast sourcename csyntax ofile = dump_asm asm (Filename.chop_suffix sourcename ".c" ^ ".sdump"); (* Print Asm in text form *) let oc = open_out ofile in - PrintAsm.print_program oc asm; + PrintAsm.print_program oc (Unusedglob.transf_program asm); close_out oc (* From C source to asm *) @@ -371,6 +371,8 @@ Code generation options: (use -fno-<opt> to turn off -f<opt>) : -fsse (IA32) Use SSE2 instructions for some integer operations [on] -fsmall-data <n> Set maximal size <n> for allocation in small data area -fsmall-const <n> Set maximal size <n> for allocation in small constant area + -ffloat-const-prop <n> Control constant propagation of floats + (<n>=0: none, <n>=1: limited, <n>=2: full; default is full) -Wa,<opt> Pass option <opt> to the assembler Tracing options: -dparse Save C file after parsing and elaboration in <file>.parse.c @@ -379,7 +381,7 @@ Tracing options: -dcminor Save generated Cminor in <file>.cm -drtl Save unoptimized generated RTL in <file>.rtl -dtailcall Save RTL after tail call optimization in <file>.tailcall.rtl - -dcastopt Save RTL after cast optimization in <file>.castopt.rtl + -dinlining Save RTL after inlining optimization in <file>.inlining.rtl -dconstprop Save RTL after constant propagation in <file>.constprop.rtl -dcse Save RTL after CSE optimization in <file>.cse.rtl -dalloc Save LTL after register allocation in <file>.alloc.ltl @@ -425,7 +427,7 @@ let cmdline_actions = "-dcminor", Set option_dcminor; "-drtl$", Set option_drtl; "-dtailcall$", Set option_dtailcall; - "-dcastopt$", Set option_dcastopt; + "-dinlining$", Set option_dinlining; "-dconstprop$", Set option_dconstprop; "-dcse$", Set option_dcse; "-dalloc$", Set option_dalloc; @@ -464,6 +466,7 @@ let cmdline_actions = linker_options := s :: !linker_options); "-fsmall-data$", Integer(fun n -> option_small_data := n); "-fsmall-const$", Integer(fun n -> option_small_const := n); + "-ffloat-const-prop$", Integer(fun n -> option_ffloatconstprop := n); "-fall$", Self (fun _ -> List.iter (fun r -> r := true) language_support_options); "-fnone$", Self (fun _ -> diff --git a/driver/Interp.ml b/driver/Interp.ml index 62f3093..a74d4d8 100644 --- a/driver/Interp.ml +++ b/driver/Interp.ml @@ -145,6 +145,12 @@ let mem_of_state = function (* Comparing memory states *) +let compare_mem m1 m2 = + Pervasives.compare (m1.Mem.nextblock, m1.Mem.mem_contents) + (m2.Mem.nextblock, m1.Mem.mem_contents) +(* FIXME: should permissions be taken into account? *) + +(* let rec compare_Z_range lo hi f = if coq_Zcompare lo hi = Lt then begin let c = f lo in if c <> 0 then c else compare_Z_range (coq_Zsucc lo) hi f @@ -154,6 +160,7 @@ let compare_mem m1 m2 = if m1 == m2 then 0 else let c = compare m1.Mem.nextblock m2.Mem.nextblock in if c <> 0 then c else compare_Z_range Z0 m1.Mem.nextblock (fun b -> + let ((lo, hi) as bnds) = m1.Mem.bounds b in let c = compare bnds (m2.Mem.bounds b) in if c <> 0 then c else let contents1 = m1.Mem.mem_contents b and contents2 = m2.Mem.mem_contents b in @@ -163,6 +170,7 @@ let compare_mem m1 m2 = let access1 = m1.Mem.mem_access b and access2 = m2.Mem.mem_access b in if access1 == access2 then 0 else compare_Z_range lo hi (fun ofs -> compare (access1 ofs) (access2 ofs))) +*) (* Comparing continuations *) diff --git a/extraction/extraction.v b/extraction/extraction.v index 4861ff9..1156d04 100644 --- a/extraction/extraction.v +++ b/extraction/extraction.v @@ -10,9 +10,12 @@ (* *) (* *********************************************************************) +Require Wfsimpl. Require Iteration. Require Floats. Require RTLgen. +Require Inlining. +Require Constprop. Require Coloring. Require Allocation. Require Compiler. @@ -22,6 +25,9 @@ Require Initializers. Require Import ExtrOcamlBasic. Require Import ExtrOcamlString. +(* Wfsimpl *) +Extraction Inline Wfsimpl.Fix Wfsimpl.Fixm. + (* Float *) Extract Inlined Constant Floats.float => "float". Extract Constant Floats.Float.zero => "0.". @@ -53,8 +59,6 @@ Extraction NoInline Memory.Mem.valid_pointer. Extraction Inline Errors.bind Errors.bind2. (* Iteration *) -Extract Constant Iteration.dependent_description' => - "fun x -> assert false". Extract Constant Iteration.GenIter.iterate => "let rec iter f a = @@ -66,9 +70,19 @@ Extract Constant RTLgen.compile_switch => "RTLgenaux.compile_switch". Extract Constant RTLgen.more_likely => "RTLgenaux.more_likely". Extraction Inline RTLgen.ret RTLgen.error RTLgen.bind RTLgen.bind2. +(* Inlining *) +Extract Inlined Constant Inlining.should_inline => "Inliningaux.should_inline". +Extraction Inline Inlining.ret Inlining.bind. + (* RTLtyping *) Extract Constant RTLtyping.infer_type_environment => "RTLtypingaux.infer_type_environment". +(* Constprop *) +Extract Constant ConstpropOp.propagate_float_constants => + "fun _ -> !Clflags.option_ffloatconstprop >= 1". +Extract Constant Constprop.generate_float_constants => + "fun _ -> !Clflags.option_ffloatconstprop >= 2". + (* Coloring *) Extract Constant Coloring.graph_coloring => "Coloringaux.graph_coloring". @@ -83,6 +97,7 @@ Extract Constant Compiler.print_Clight => "PrintClight.print_if". Extract Constant Compiler.print_Cminor => "PrintCminor.print_if". Extract Constant Compiler.print_RTL => "PrintRTL.print_rtl". Extract Constant Compiler.print_RTL_tailcall => "PrintRTL.print_tailcall". +Extract Constant Compiler.print_RTL_inline => "PrintRTL.print_inlining". Extract Constant Compiler.print_RTL_constprop => "PrintRTL.print_constprop". Extract Constant Compiler.print_RTL_cse => "PrintRTL.print_cse". Extract Constant Compiler.print_LTLin => "PrintLTLin.print_if". diff --git a/ia32/ConstpropOp.vp b/ia32/ConstpropOp.vp index b861107..b95ad66 100644 --- a/ia32/ConstpropOp.vp +++ b/ia32/ConstpropOp.vp @@ -91,11 +91,13 @@ Nondetfunction eval_static_addressing (addr: addressing) (vl: list approx) := | _, _ => Unknown end. +Parameter propagate_float_constants: unit -> bool. + Nondetfunction eval_static_operation (op: operation) (vl: list approx) := match op, vl with | Omove, v1::nil => v1 | Ointconst n, nil => I n - | Ofloatconst n, nil => F n + | Ofloatconst n, nil => if propagate_float_constants tt then F n else Unknown | Ocast8signed, I n1 :: nil => I(Int.sign_ext 8 n1) | Ocast8unsigned, I n1 :: nil => I(Int.zero_ext 8 n1) | Ocast16signed, I n1 :: nil => I(Int.sign_ext 16 n1) @@ -132,7 +134,7 @@ Nondetfunction eval_static_operation (op: operation) (vl: list approx) := | Odivf, F n1 :: F n2 :: nil => F(Float.div n1 n2) | Osingleoffloat, F n1 :: nil => F(Float.singleoffloat n1) | Ointoffloat, F n1 :: nil => eval_static_intoffloat n1 - | Ofloatofint, I n1 :: nil => F(Float.floatofint n1) + | Ofloatofint, I n1 :: nil => if propagate_float_constants tt then F(Float.floatofint n1) else Unknown | Ocmp c, vl => eval_static_condition_val c vl | _, _ => Unknown end. diff --git a/ia32/ConstpropOpproof.v b/ia32/ConstpropOpproof.v index 04a1725..1612bf6 100644 --- a/ia32/ConstpropOpproof.v +++ b/ia32/ConstpropOpproof.v @@ -141,7 +141,7 @@ Proof. unfold eval_static_operation. case (eval_static_operation_match op al); intros; InvVLMA; simpl in *; FuncInv; try subst v; auto. - + destruct (propagate_float_constants tt); simpl; auto. rewrite Int.sub_add_opp. rewrite shift_symbol_address. rewrite Val.sub_add_opp. auto. destruct (Int.eq n2 Int.zero); inv H0; simpl; auto. destruct (Int.eq n2 Int.zero); inv H0; simpl; auto. @@ -159,6 +159,7 @@ Proof. unfold eval_static_intoffloat. destruct (Float.intoffloat n1) as []_eqn; simpl in H0; inv H0. simpl; auto. + destruct (propagate_float_constants tt); simpl; auto. unfold eval_static_condition_val. destruct (eval_static_condition c vl0) as [b|]_eqn. rewrite (eval_static_condition_correct _ _ _ m _ H Heqo). destruct b; simpl; auto. diff --git a/ia32/Unusedglob1.ml b/ia32/Unusedglob1.ml new file mode 100644 index 0000000..fe962e2 --- /dev/null +++ b/ia32/Unusedglob1.ml @@ -0,0 +1,44 @@ +(* *********************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Xavier Leroy, INRIA Paris-Rocquencourt *) +(* *) +(* 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. *) +(* *) +(* *********************************************************************) + +(* Identifiers referenced from an IA32 Asm instruction *) + +open Datatypes +open AST +open Asm + +let referenced_addr (Addrmode(base, ofs, const)) = + match const with + | Coq_inl n -> [] + | Coq_inr(s, ofs) -> [s] + +let referenced_builtin ef = + match ef with + | EF_vload_global(chunk, id, ofs) -> [id] + | EF_vstore_global(chunk, id, ofs) -> [id] + | _ -> [] + +let referenced_instr = function + | Pmov_rm (_, a) | Pmov_mr (a, _) + | Pmovsd_fm (_, a) | Pmovsd_mf(a, _) + | Pfld_m a | Pfstp_m a + | Pmovb_mr (a, _) | Pmovw_mr (a, _) + | Pmovzb_rm (_, a) | Pmovsb_rm (_, a) + | Pmovzw_rm (_, a) | Pmovsw_rm (_, a) + | Pcvtss2sd_fm (_, a) | Pcvtsd2ss_mf (a, _) | Plea (_, a) -> referenced_addr a + | Pjmp_s s -> [s] + | Pcall_s s -> [s] + | Pbuiltin(ef, args, res) -> referenced_builtin ef + | _ -> [] + +let code_of_function f = f + diff --git a/lib/Coqlib.v b/lib/Coqlib.v index 87b19ca..50535fb 100644 --- a/lib/Coqlib.v +++ b/lib/Coqlib.v @@ -23,23 +23,6 @@ Require Export List. Require Export Bool. Require Import Wf_nat. -(*** - -(** * Logical axioms *) - -(** We use two logical axioms that are not provable in Coq but consistent - with the logic: function extensionality and proof irrelevance. - These are used in the memory model to show that two memory states - that have identical contents are equal. *) - -Axiom extensionality: - forall (A B: Type) (f g : A -> B), - (forall x, f x = g x) -> f = g. - -Axiom proof_irrelevance: - forall (P: Prop) (p1 p2: P), p1 = p2. -***) - (** * Useful tactics *) Ltac inv H := inversion H; clear H; subst. @@ -51,7 +34,7 @@ Ltac caseEq name := generalize (refl_equal name); pattern name at -1 in |- *; case name. Ltac destructEq name := - generalize (refl_equal name); pattern name at -1 in |- *; destruct name; intro. + destruct name as []_eqn. Ltac decEq := match goal with diff --git a/lib/Iteration.v b/lib/Iteration.v index 3625845..235b650 100644 --- a/lib/Iteration.v +++ b/lib/Iteration.v @@ -10,65 +10,88 @@ (* *) (* *********************************************************************) -(* Bounded and unbounded iterators *) +(** Bounded and unbounded iterators *) Require Import Axioms. Require Import Coqlib. -Require Import Classical. -Require Import Max. +Require Import Wfsimpl. -Module Type ITER. -Variable iterate - : forall A B : Type, (A -> B + A) -> A -> option B. -Hypothesis iterate_prop - : forall (A B : Type) (step : A -> B + A) (P : A -> Prop) (Q : B -> Prop), - (forall a : A, P a -> - match step a with inl b => Q b | inr a' => P a' end) -> - forall (a : A) (b : B), iterate A B step a = Some b -> P a -> Q b. -End ITER. +(** This modules defines several Coq encodings of a general "while" loop. + The loop is presented in functional style as the iteration + of a [step] function of type [A -> B + A]: +<< + let rec iterate step a = + match step a with + | inl b -> b + | inr a' -> iterate step a' +>> + This iteration cannot be defined directly in Coq using [Fixpoint], + because Coq is a logic of total functions, and therefore we must + guarantee termination of the loop. +*) -Axiom - dependent_description' : - forall (A:Type) (B:A -> Type) (R:forall x:A, B x -> Prop), - (forall x:A, - exists y : B x, R x y /\ (forall y':B x, R x y' -> y = y')) -> - sigT (fun f : forall x:A, B x => (forall x:A, R x (f x))). +(** * Terminating iteration *) -(* A constructive implementation using bounded iteration. *) +(** We first implement the case where termination is guaranteed because + the current state [a] decreases at each iteration. *) -Module PrimIter: ITER. +Module WfIter. Section ITERATION. Variables A B: Type. Variable step: A -> B + A. +Variable ord: A -> A -> Prop. +Hypothesis ord_wf: well_founded ord. +Hypothesis step_decr: forall a a', step a = inr _ a' -> ord a' a. -(** The [step] parameter represents one step of the iteration. From a - current iteration state [a: A], it either returns a value of type [B], - meaning that iteration is over and that this [B] value is the final - result of the iteration, or a value [a' : A] which is the next state - of the iteration. +Definition step_info (a: A) : {b | step a = inl _ b} + {a' | step a = inr _ a' & ord a' a}. +Proof. + caseEq (step a); intros. left; exists b; auto. right; exists a0; auto. +Qed. - The naive way to define the iteration is: -<< -Fixpoint iterate (a: A) : B := - match step a with - | inl b => b - | inr a' => iterate a' +Definition iterate_F (a: A) (rec: forall a', ord a' a -> B) : B := + match step_info a with + | inl (exist b P) => b + | inr (exist2 a' P Q) => rec a' Q end. ->> - However, this is a general recursion, not guaranteed to terminate, - and therefore not expressible in Coq. The standard way to work around - this difficulty is to use Noetherian recursion (Coq module [Wf]). - This requires that we equip the type [A] with a well-founded ordering [<] - (no infinite ascending chains) and we demand that [step] satisfies - [step a = inr a' -> a < a']. For the types [A] that are of interest to us - in this development, it is however very painful to define adequate - well-founded orderings, even though we know our iterations always - terminate. - - Instead, we choose to bound the number of iterations by an arbitrary - constant. [iterate] then becomes a function that can fail, + +Definition iterate (a: A) : B := Fix ord_wf iterate_F a. + +(** We now prove an invariance property [iterate_prop], similar to the Hoare + logic rule for "while" loops. *) + +Variable P: A -> Prop. +Variable Q: B -> Prop. + +Hypothesis step_prop: + forall a : A, P a -> + match step a with inl b => Q b | inr a' => P a' end. + +Lemma iterate_prop: + forall a, P a -> Q (iterate a). +Proof. + intros a0. pattern a0. apply well_founded_ind with (R := ord). auto. + intros. unfold iterate; rewrite unroll_Fix. unfold iterate_F. + destruct (step_info x) as [[b U] | [a' U V]]. + exploit step_prop; eauto. rewrite U; auto. + apply H. auto. exploit step_prop; eauto. rewrite U; auto. +Qed. + +End ITERATION. + +End WfIter. + +(** * Bounded iteration *) + +(** The presentation of iteration shown above is predicated on the existence + of a well-founded ordering that decreases at each step of the iteration. + In several parts of the CompCert development, it is very painful to define + such a well-founded ordering and to prove decrease, even though we know our + iterations always terminate. + + In the presentation below, we choose instead to bound the number of iterations + by an arbitrary constant. [iterate] then becomes a function that can fail, of type [A -> option B]. The [None] result denotes failure to reach a result in the number of iterations prescribed, or, in other terms, failure to find a solution to the dataflow problem. The compiler @@ -82,6 +105,13 @@ Fixpoint iterate (a: A) : B := course our proofs also cover the failure case and show that nothing bad happens in this hypothetical case either. *) +Module PrimIter. + +Section ITERATION. + +Variables A B: Type. +Variable step: A -> B + A. + Definition num_iterations := 1000000000000%positive. (** The simple definition of bounded iteration is: @@ -117,19 +147,7 @@ Definition iter_step (x: positive) end end. -Definition iter: positive -> A -> option B := - Fix Plt_wf (fun _ => A -> option B) iter_step. - -(** We then prove the expected unrolling equations for [iter]. *) - -Remark unroll_iter: - forall x, iter x = iter_step x (fun y _ => iter y). -Proof. - unfold iter; apply (Fix_eq Plt_wf (fun _ => A -> option B) iter_step). - intros. unfold iter_step. apply extensionality. intro s. - case (peq x xH); intro. auto. - rewrite H. auto. -Qed. +Definition iter: positive -> A -> option B := Fix Plt_wf iter_step. (** The [iterate] function is defined as [iter] up to [num_iterations] through the loop. *) @@ -150,11 +168,12 @@ Lemma iter_prop: Proof. apply (well_founded_ind Plt_wf (fun p => forall a b, P a -> iter p a = Some b -> Q b)). - intros until b. intro. rewrite unroll_iter. - unfold iter_step. case (peq x 1); intro. congruence. - generalize (step_prop a H0). - case (step a); intros. congruence. - apply H with (Ppred x) a0. apply Ppred_Plt; auto. auto. auto. + intros. unfold iter in H1. rewrite unroll_Fix in H1. unfold iter_step in H1. + destruct (peq x 1). discriminate. + specialize (step_prop a H0). + destruct (step a) as [b'|a']_eqn. + inv H1. auto. + apply H with (Ppred x) a'. apply Ppred_Plt; auto. auto. auto. Qed. Lemma iterate_prop: @@ -167,11 +186,21 @@ End ITERATION. End PrimIter. +(** * General iteration *) + (* An implementation using classical logic and unbounded iteration, in the style of Yves Bertot's paper, "Extending the Calculus - of Constructions with Tarski's fix-point theorem". *) + of Constructions with Tarski's fix-point theorem". -Module GenIter: ITER. + As in the bounded case, the [iterate] function returns an option type. + [None] means that iteration does not terminate. + [Some b] means that iteration terminates with the result [b]. *) + +Require Import Classical. +Require Import ClassicalDescription. +Require Import Max. + +Module GenIter. Section ITERATION. @@ -249,30 +278,29 @@ Proof. Qed. Lemma converges_to_exists_uniquely: - forall a, exists b, converges_to a b /\ forall b', converges_to a b' -> b = b'. + forall a, exists! b, converges_to a b . Proof. intro. destruct (converges_to_exists a) as [b CT]. exists b. split. assumption. exact (converges_to_unique _ _ CT). Qed. -Definition exists_iterate := - dependent_description' A (fun _ => option B) - converges_to converges_to_exists_uniquely. - -Definition iterate : A -> option B := - match exists_iterate with existT f P => f end. +Definition iterate (a: A) : option B := + proj1_sig (constructive_definite_description (converges_to a) (converges_to_exists_uniquely a)). Lemma converges_to_iterate: forall a b, converges_to a b -> iterate a = b. Proof. - intros. unfold iterate. destruct exists_iterate as [f P]. - apply converges_to_unique with a. apply P. auto. + intros. unfold iterate. + destruct (constructive_definite_description (converges_to a) (converges_to_exists_uniquely a)) as [b' P]. + simpl. apply converges_to_unique with a; auto. Qed. Lemma iterate_converges_to: forall a, converges_to a (iterate a). Proof. - intros. unfold iterate. destruct exists_iterate as [f P]. apply P. + intros. unfold iterate. + destruct (constructive_definite_description (converges_to a) (converges_to_exists_uniquely a)) as [b' P]. + simpl; auto. Qed. (** Invariance property. *) @@ -77,6 +77,9 @@ Module Type TREE. Hypothesis grspec: forall (A: Type) (i j: elt) (m: t A), get i (remove j m) = if elt_eq i j then None else get i m. + Hypothesis set2: + forall (A: Type) (i: elt) (m: t A) (v1 v2: A), + set i v2 (set i v1 m) = set i v2 m. (** Extensional equality between trees. *) Variable beq: forall (A: Type), (A -> A -> bool) -> t A -> t A -> bool. @@ -302,8 +305,15 @@ Module PTree <: TREE. rewrite (IHi m1 v H); congruence. Qed. - Lemma rleaf : forall (A : Type) (i : positive), remove i (Leaf : t A) = Leaf. - Proof. destruct i; simpl; auto. Qed. + Theorem set2: + forall (A: Type) (i: elt) (m: t A) (v1 v2: A), + set i v2 (set i v1 m) = set i v2 m. + Proof. + induction i; intros; destruct m; simpl; try (rewrite IHi); auto. + Qed. + + Lemma rleaf : forall (A : Type) (i : positive), remove i (Leaf : t A) = Leaf. + Proof. destruct i; simpl; auto. Qed. Theorem grs: forall (A: Type) (i: positive) (m: t A), get i (remove i m) = None. @@ -1116,6 +1126,13 @@ Module PMap <: MAP. unfold option_map. destruct (PTree.get i (snd m)); auto. Qed. + Theorem set2: + forall (A: Type) (i: elt) (x y: A) (m: t A), + set i y (set i x m) = set i y m. + Proof. + intros. unfold set. simpl. decEq. apply PTree.set2. + Qed. + End PMap. (** * An implementation of maps over any type that injects into type [positive] *) @@ -1178,6 +1195,13 @@ Module IMap(X: INDEXED_TYPE). intros. unfold map, get. apply PMap.gmap. Qed. + Lemma set2: + forall (A: Type) (i: elt) (x y: A) (m: t A), + set i y (set i x m) = set i y m. + Proof. + intros. unfold set. apply PMap.set2. + Qed. + End IMap. Module ZIndexed. @@ -1378,6 +1402,76 @@ Qed. End TREE_FOLD_IND. +(** A nonnegative measure over trees *) + +Section MEASURE. + +Variable V: Type. + +Definition cardinal (x: T.t V) : nat := List.length (T.elements x). + +Remark list_incl_length: + forall (A: Type) (l1: list A), list_norepet l1 -> + forall (l2: list A), List.incl l1 l2 -> (List.length l1 <= List.length l2)%nat. +Proof. + induction 1; simpl; intros. + omega. + exploit (List.in_split hd l2). auto with coqlib. intros [l3 [l4 EQ]]. subst l2. + assert (length tl <= length (l3 ++ l4))%nat. + apply IHlist_norepet. red; intros. + exploit (H1 a); auto with coqlib. + repeat rewrite in_app_iff. simpl. intuition. subst. contradiction. + repeat rewrite app_length in *. simpl. omega. +Qed. + +Remark list_length_incl: + forall (A: Type) (l1: list A), list_norepet l1 -> + forall l2, List.incl l1 l2 -> List.length l1 = List.length l2 -> List.incl l2 l1. +Proof. + induction 1; simpl; intros. + destruct l2; simpl in *. auto with coqlib. discriminate. + exploit (List.in_split hd l2). auto with coqlib. intros [l3 [l4 EQ]]. subst l2. + assert (incl (l3 ++ l4) tl). + apply IHlist_norepet. red; intros. + exploit (H1 a); auto with coqlib. + repeat rewrite in_app_iff. simpl. intuition. subst. contradiction. + repeat rewrite app_length in *. simpl in H2. omega. + red; simpl; intros. rewrite in_app_iff in H4; simpl in H4. intuition. +Qed. + +Remark list_strict_incl_length: + forall (A: Type) (l1 l2: list A) (x: A), + list_norepet l1 -> List.incl l1 l2 -> ~In x l1 -> In x l2 -> + (List.length l1 < List.length l2)%nat. +Proof. + intros. exploit list_incl_length; eauto. intros. + assert (length l1 = length l2 \/ length l1 < length l2)%nat by omega. + destruct H4; auto. elim H1. eapply list_length_incl; eauto. +Qed. + +Remark list_norepet_map: + forall (A B: Type) (f: A -> B) (l: list A), + list_norepet (List.map f l) -> list_norepet l. +Proof. + induction l; simpl; intros. + constructor. + inv H. constructor; auto. red; intros; elim H2. apply List.in_map; auto. +Qed. + +Theorem cardinal_remove: + forall x m y, T.get x m = Some y -> (cardinal (T.remove x m) < cardinal m)%nat. +Proof. + unfold cardinal; intros. apply list_strict_incl_length with (x := (x, y)). + apply list_norepet_map with (f := @fst T.elt V). apply T.elements_keys_norepet. + red; intros. destruct a as [x' y']. exploit T.elements_complete; eauto. + rewrite T.grspec. destruct (T.elt_eq x' x); intros; try discriminate. + apply T.elements_correct; auto. + red; intros. exploit T.elements_complete; eauto. rewrite T.grspec. rewrite dec_eq_true. congruence. + apply T.elements_correct; auto. +Qed. + +End MEASURE. + End Tree_Properties. Module PTree_Properties := Tree_Properties(PTree). @@ -1386,5 +1480,3 @@ Module PTree_Properties := Tree_Properties(PTree). Notation "a ! b" := (PTree.get b a) (at level 1). Notation "a !! b" := (PMap.get b a) (at level 1). - -(* $Id: Maps.v,v 1.12.4.4 2006/01/07 11:46:55 xleroy Exp $ *) diff --git a/lib/Postorder.v b/lib/Postorder.v new file mode 100644 index 0000000..fe06da7 --- /dev/null +++ b/lib/Postorder.v @@ -0,0 +1,316 @@ +(* *********************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Xavier Leroy, INRIA Paris-Rocquencourt *) +(* *) +(* 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. *) +(* *) +(* *********************************************************************) + +(** Postorder numbering of a directed graph. *) + +Require Import Wellfounded. +Require Import Coqlib. +Require Import Maps. +Require Import Iteration. + +(** The graph is presented as a finite map from nodes (of type [positive]) + to the lists of their successors. *) + +Definition node: Type := positive. + +Definition graph: Type := PTree.t (list node). + +(** The traversal is presented as an iteration that modifies the following state. *) + +Record state : Type := mkstate { + gr: graph; (**r current graph, without already-visited nodes *) + wrk: list (node * list node); (**r worklist *) + map: PTree.t positive; (**r current mapping node -> postorder number *) + next: positive (**r number to use for next numbering *) +}. + +Definition init_state (g: graph) (root: node) := + match g!root with + | Some succs => + {| gr := PTree.remove root g; + wrk := (root, succs) :: nil; + map := PTree.empty positive; + next := 1%positive |} + | None => + {| gr := g; + wrk := nil; + map := PTree.empty positive; + next := 1%positive |} + end. + +Definition transition (s: state) : PTree.t positive + state := + match s.(wrk) with + | nil => + inl _ s.(map) + | (x, nil) :: l => + inr _ {| gr := s.(gr); wrk := l; map := PTree.set x s.(next) s.(map); next := Psucc s.(next) |} + | (x, y :: succs_x) :: l => + match s.(gr)!y with + | None => + inr _ {| gr := s.(gr); wrk := (x, succs_x) :: l; map := s.(map); next := s.(next) |} + | Some succs_y => + inr _ {| gr := PTree.remove y s.(gr); wrk := (y, succs_y) :: (x, succs_x) :: l; map := s.(map); next := s.(next) |} + end + end. + +Section POSTORDER. + +Variable ginit: graph. +Variable root: node. + +Inductive invariant (s: state) : Prop := + Invariant + (* current graph is a subset of ginit *) + (SUB: forall x y, s.(gr)!x = Some y -> ginit!x = Some y) + (* root is not in current graph *) + (ROOT: s.(gr)!root = None) + (* mapped nodes have their numbers below next *) + (BELOW: forall x y, s.(map)!x = Some y -> Plt y s.(next)) + (* mapping is injective *) + (INJ: forall x1 x2 y, s.(map)!x1 = Some y -> s.(map)!x2 = Some y -> x1 = x2) + (* nodes not yet visited have no number *) + (REM: forall x y, s.(gr)!x = Some y -> s.(map)!x = None) + (* black nodes have no white son *) + (COLOR: forall x succs n y, + ginit!x = Some succs -> s.(map)!x = Some n -> + In y succs -> s.(gr)!y = None) + (* worklist is well-formed *) + (WKLIST: forall x l, In (x, l) s.(wrk) -> + s.(gr)!x = None /\ + exists l', ginit!x = Some(l' ++ l) + /\ forall y, In y l' -> s.(gr)!y = None) + (* all grey nodes are on the worklist *) + (GREY: forall x, ginit!x <> None -> s.(gr)!x = None -> s.(map)!x = None -> + exists l, In (x,l) s.(wrk)). + +Inductive postcondition (map: PTree.t positive) : Prop := + Postcondition + (INJ: forall x1 x2 y, map!x1 = Some y -> map!x2 = Some y -> x1 = x2) + (ROOT: ginit!root <> None -> map!root <> None) + (SUCCS: forall x succs y, ginit!x = Some succs -> map!x <> None -> In y succs -> ginit!y <> None -> map!y <> None). + +Lemma transition_spec: + forall s, invariant s -> + match transition s with inr s' => invariant s' | inl m => postcondition m end. +Proof. + intros. inv H. unfold transition. destruct (wrk s) as [ | [x succ_x] l]. + (* finished *) + constructor; intros. + eauto. + caseEq (s.(map)!root); intros. congruence. exploit GREY; eauto. intros [? ?]; contradiction. + destruct (s.(map)!x) as []_eqn; try congruence. + destruct (s.(map)!y) as []_eqn; try congruence. + exploit COLOR; eauto. intros. exploit GREY; eauto. intros [? ?]; contradiction. + (* not finished *) + destruct succ_x as [ | y succ_x ]. + (* all children of x were traversed *) + constructor; simpl; intros. + (* sub *) + eauto. + (* root *) + eauto. + (* below *) + rewrite PTree.gsspec in H. destruct (peq x0 x). inv H. + apply Plt_succ. + apply Plt_trans_succ. eauto. + (* inj *) + rewrite PTree.gsspec in H. rewrite PTree.gsspec in H0. + destruct (peq x1 x); destruct (peq x2 x); subst. + auto. + inv H. exploit BELOW; eauto. intros. eelim Plt_strict; eauto. + inv H0. exploit BELOW; eauto. intros. eelim Plt_strict; eauto. + eauto. + (* rem *) + intros. rewrite PTree.gso; eauto. red; intros; subst x0. + exploit (WKLIST x nil); auto with coqlib. intros [A B]. congruence. + (* color *) + rewrite PTree.gsspec in H0. destruct (peq x0 x). + inv H0. exploit (WKLIST x nil); auto with coqlib. + intros [A [l' [B C]]]. rewrite app_nil_r in B. + assert (l' = succs) by congruence. subst l'. eauto. + eauto. + (* wklist *) + apply WKLIST. auto with coqlib. + (* grey *) + rewrite PTree.gsspec in H1. destruct (peq x0 x). inv H1. + exploit GREY; eauto. intros [l' A]. simpl in A; destruct A. + congruence. + exists l'; auto. + + (* children y needs traversing *) + destruct ((gr s)!y) as [ succs_y | ]_eqn. + (* y has children *) + constructor; simpl; intros. + (* sub *) + rewrite PTree.grspec in H. destruct (PTree.elt_eq x0 y); eauto. inv H. + (* root *) + rewrite PTree.gro. auto. congruence. + (* below *) + eauto. + (* inj *) + eauto. + (* rem *) + rewrite PTree.grspec in H. destruct (PTree.elt_eq x0 y); eauto. inv H. + (* color *) + rewrite PTree.grspec. destruct (PTree.elt_eq y0 y); eauto. + (* wklist *) + destruct H. + inv H. split. apply PTree.grs. exists (@nil positive); simpl; intuition. + destruct H. + inv H. exploit WKLIST; eauto with coqlib. intros [A [l' [B C]]]. + split. rewrite PTree.grspec. destruct (PTree.elt_eq x0 y); auto. + exists (l' ++ y :: nil); split. rewrite app_ass. auto. + intros. rewrite in_app_iff in H. simpl in H. intuition. + rewrite PTree.grspec. destruct (PTree.elt_eq y0 y); auto. + subst y0. apply PTree.grs. + exploit (WKLIST x0 l0); eauto with coqlib. intros [A [l' [B C]]]. + split. rewrite PTree.grspec. destruct (PTree.elt_eq x0 y); auto. + exists l'; split; auto. intros. + rewrite PTree.grspec. destruct (PTree.elt_eq y0 y); auto. + (* grey *) + rewrite PTree.grspec in H0. destruct (PTree.elt_eq x0 y) in H0. + subst. exists succs_y; auto with coqlib. + exploit GREY; eauto. simpl. intros [l1 A]. destruct A. + inv H2. exists succ_x; auto. + exists l1; auto. + + (* y has no children *) + constructor; simpl; intros; eauto. + (* wklist *) + destruct H. inv H. + exploit (WKLIST x0); eauto with coqlib. intros [A [l' [B C]]]. + split. auto. exists (l' ++ y :: nil); split. rewrite app_ass; auto. + intros. rewrite in_app_iff in H; simpl in H. intuition. congruence. + eapply WKLIST; eauto with coqlib. + (* grey *) + exploit GREY; eauto. intros [l1 A]. simpl in A. destruct A. + inv H2. exists succ_x; auto. + exists l1; auto. +Qed. + +Lemma initial_state_spec: + invariant (init_state ginit root). +Proof. + unfold init_state. destruct (ginit!root) as [succs|]_eqn. + (* root has succs *) + constructor; simpl; intros. + (* sub *) + rewrite PTree.grspec in H. destruct (PTree.elt_eq x root). inv H. auto. + (* root *) + apply PTree.grs. + (* below *) + rewrite PTree.gempty in H; inv H. + (* inj *) + rewrite PTree.gempty in H; inv H. + (* rem *) + apply PTree.gempty. + (* color *) + rewrite PTree.gempty in H0; inv H0. + (* wklist *) + destruct H; inv H. + split. apply PTree.grs. exists (@nil positive); simpl; tauto. + (* grey *) + rewrite PTree.grspec in H0. destruct (PTree.elt_eq x root). + subst. exists succs; auto. + contradiction. + + (* root has no succs *) + constructor; simpl; intros. + (* sub *) + auto. + (* root *) + auto. + (* below *) + rewrite PTree.gempty in H; inv H. + (* inj *) + rewrite PTree.gempty in H; inv H. + (* rem *) + apply PTree.gempty. + (* color *) + rewrite PTree.gempty in H0; inv H0. + (* wklist *) + contradiction. + (* grey *) + contradiction. + +Qed. + +(** Termination criterion. *) + +Fixpoint size_worklist (w: list (positive * list positive)) : nat := + match w with + | nil => 0%nat + | (x, succs) :: w' => (S (List.length succs) + size_worklist w')%nat + end. + +Definition lt_state (s1 s2: state) : Prop := + lex_ord lt lt (PTree_Properties.cardinal s1.(gr), size_worklist s1.(wrk)) + (PTree_Properties.cardinal s2.(gr), size_worklist s2.(wrk)). + +Lemma lt_state_wf: well_founded lt_state. +Proof. + set (f := fun s => (PTree_Properties.cardinal s.(gr), size_worklist s.(wrk))). + change (well_founded (fun s1 s2 => lex_ord lt lt (f s1) (f s2))). + apply wf_inverse_image. + apply wf_lex_ord. + apply lt_wf. apply lt_wf. +Qed. + +Lemma transition_decreases: + forall s s', transition s = inr _ s' -> lt_state s' s. +Proof. + unfold transition, lt_state; intros. + destruct (wrk s) as [ | [x succs] l]. + discriminate. + destruct succs as [ | y succs ]. + inv H. simpl. apply lex_ord_right. omega. + destruct ((gr s)!y) as [succs'|]_eqn. + inv H. simpl. apply lex_ord_left. eapply PTree_Properties.cardinal_remove; eauto. + inv H. simpl. apply lex_ord_right. omega. +Qed. + +End POSTORDER. + +Definition postorder (g: graph) (root: node) := + WfIter.iterate _ _ transition lt_state lt_state_wf transition_decreases (init_state g root). + +Inductive reachable (g: graph) (root: positive) : positive -> Prop := + | reachable_root: + reachable g root root + | reachable_succ: forall x succs y, + reachable g root x -> g!x = Some succs -> In y succs -> + reachable g root y. + +Theorem postorder_correct: + forall g root, + let m := postorder g root in + (forall x1 x2 y, m!x1 = Some y -> m!x2 = Some y -> x1 = x2) + /\ (forall x, reachable g root x -> g!x <> None -> m!x <> None). +Proof. + intros. + assert (postcondition g root m). + unfold m. unfold postorder. + apply WfIter.iterate_prop with (P := invariant g root). + apply transition_spec. + apply initial_state_spec. + inv H. + split. auto. + induction 1; intros. + (* root case *) + apply ROOT; auto. + (* succ case *) + eapply SUCCS; eauto. apply IHreachable. congruence. +Qed. + diff --git a/lib/Wfsimpl.v b/lib/Wfsimpl.v new file mode 100644 index 0000000..1ed6326 --- /dev/null +++ b/lib/Wfsimpl.v @@ -0,0 +1,68 @@ +(* *********************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Xavier Leroy, INRIA Paris-Rocquencourt *) +(* *) +(* 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. *) +(* *) +(* *********************************************************************) + +(** Defining recursive functions by Noetherian induction. This is a simplified + interface to the [Wf] module of Coq's standard library, where the functions + to be defined have non-dependent types, and function extensionality is assumed. *) + +Require Import Axioms. +Require Import Wf. +Require Import Wf_nat. + +Set Implicit Arguments. + +Section FIX. + +Variables A B: Type. +Variable R: A -> A -> Prop. +Hypothesis Rwf: well_founded R. +Variable F: forall (x: A), (forall (y: A), R y x -> B) -> B. + +Definition Fix (x: A) : B := Wf.Fix Rwf (fun (x: A) => B) F x. + +Theorem unroll_Fix: + forall x, Fix x = F (fun (y: A) (P: R y x) => Fix y). +Proof. + unfold Fix; intros. apply Wf.Fix_eq with (P := fun (x: A) => B). + intros. assert (f = g). apply functional_extensionality_dep; intros. + apply functional_extensionality; intros. auto. + subst g; auto. +Qed. + +End FIX. + +(** Same, with a nonnegative measure instead of a well-founded ordering *) + +Section FIXM. + +Variables A B: Type. +Variable measure: A -> nat. +Variable F: forall (x: A), (forall (y: A), measure y < measure x -> B) -> B. + +Definition Fixm (x: A) : B := Wf.Fix (well_founded_ltof A measure) (fun (x: A) => B) F x. + +Theorem unroll_Fixm: + forall x, Fixm x = F (fun (y: A) (P: measure y < measure x) => Fixm y). +Proof. + unfold Fixm; intros. apply Wf.Fix_eq with (P := fun (x: A) => B). + intros. assert (f = g). apply functional_extensionality_dep; intros. + apply functional_extensionality; intros. auto. + subst g; auto. +Qed. + +End FIXM. + + + diff --git a/myocamlbuild.ml b/myocamlbuild.ml index 0e51489..08b9b13 100644 --- a/myocamlbuild.ml +++ b/myocamlbuild.ml @@ -13,7 +13,7 @@ dispatch begin function (* make sure libCparser.a is up to date *) dep ["link"; "ocaml"; "use_Cparser"] ["cparser/libCparser.a"]; - (* ocamlfind libraries *) + (* libraries and syntax extensions accessed via ocamlfind *) flag ["ocaml"; "link"; "pkg_unix"] & S[A"-package"; A "unix"]; flag ["ocaml"; "link"; "pkg_str"] & S[A"-package"; A "str"]; flag ["ocaml"; "compile"; "pkg_bitstring"] & S[A"-package"; A"bitstring,bitstring.syntax"; A"-syntax"; A"bitstring.syntax,camlp4o"]; diff --git a/powerpc/ConstpropOp.vp b/powerpc/ConstpropOp.vp index 3298671..60b5c63 100644 --- a/powerpc/ConstpropOp.vp +++ b/powerpc/ConstpropOp.vp @@ -70,11 +70,13 @@ Definition eval_static_condition_val (cond: condition) (vl: list approx) := Definition eval_static_intoffloat (f: float) := match Float.intoffloat f with Some x => I x | None => Unknown end. +Parameter propagate_float_constants: unit -> bool. + Nondetfunction eval_static_operation (op: operation) (vl: list approx) := match op, vl with | Omove, v1::nil => v1 | Ointconst n, nil => I n - | Ofloatconst n, nil => F n + | Ofloatconst n, nil => if propagate_float_constants tt then F n else Unknown | Oaddrsymbol s n, nil => G s n | Oaddrstack n, nil => S n | Ocast8signed, I n1 :: nil => I(Int.sign_ext 8 n1) @@ -119,11 +121,27 @@ Nondetfunction eval_static_operation (op: operation) (vl: list approx) := | Odivf, F n1 :: F n2 :: nil => F(Float.div n1 n2) | Osingleoffloat, F n1 :: nil => F(Float.singleoffloat n1) | Ointoffloat, F n1 :: nil => eval_static_intoffloat n1 - | Ofloatofwords, I n1 :: I n2 :: nil => F(Float.from_words n1 n2) + | Ofloatofwords, I n1 :: I n2 :: nil => if propagate_float_constants tt then F(Float.from_words n1 n2) else Unknown | Ocmp c, vl => eval_static_condition_val c vl | _, _ => Unknown end. +Nondetfunction eval_static_addressing (addr: addressing) (vl: list approx) := + match addr, vl with + | Aindexed n, I n1::nil => I (Int.add n1 n) + | Aindexed n, G id ofs::nil => G id (Int.add ofs n) + | Aindexed n, S ofs::nil => S (Int.add ofs n) + | Aindexed2, I n1::I n2::nil => I (Int.add n1 n2) + | Aindexed2, G id ofs::I n2::nil => G id (Int.add ofs n2) + | Aindexed2, I n1::G id ofs::nil => G id (Int.add ofs n1) + | Aindexed2, S ofs::I n2::nil => S (Int.add ofs n2) + | Aindexed2, I n1::S ofs::nil => S (Int.add ofs n1) + | Aglobal id ofs, nil => G id ofs + | Abased id ofs, I n1::nil => G id (Int.add ofs n1) + | Ainstack ofs, nil => S ofs + | _, _ => Unknown + end. + (** * Operator strength reduction *) (** We now define auxiliary functions for strength reduction of diff --git a/powerpc/ConstpropOpproof.v b/powerpc/ConstpropOpproof.v index 3b5021e..1c050bd 100644 --- a/powerpc/ConstpropOpproof.v +++ b/powerpc/ConstpropOpproof.v @@ -118,6 +118,8 @@ Proof. case (eval_static_operation_match op al); intros; InvVLMA; simpl in *; FuncInv; try subst v; auto. + destruct (propagate_float_constants tt); simpl; auto. + rewrite shift_symbol_address; auto. rewrite Int.add_commut. rewrite shift_symbol_address. rewrite Val.add_commut. auto. @@ -149,6 +151,8 @@ Proof. unfold eval_static_intoffloat. destruct (Float.intoffloat n1); simpl in H0; inv H0. simpl; auto. + destruct (propagate_float_constants tt); simpl; auto. + unfold eval_static_condition_val, Val.of_optbool. destruct (eval_static_condition c vl0) as []_eqn. rewrite (eval_static_condition_correct _ _ _ m _ H Heqo). @@ -156,6 +160,26 @@ Proof. simpl; auto. Qed. +Lemma eval_static_addressing_correct: + forall addr al vl v, + val_list_match_approx al vl -> + eval_addressing ge sp addr vl = Some v -> + val_match_approx (eval_static_addressing addr al) v. +Proof. + intros until v. unfold eval_static_addressing. + case (eval_static_addressing_match addr al); intros; + InvVLMA; simpl in *; FuncInv; try subst v; auto. + rewrite shift_symbol_address; auto. + rewrite Val.add_assoc. auto. + repeat rewrite shift_symbol_address. auto. + fold (Val.add (Vint n1) (symbol_address ge id ofs)). + repeat rewrite shift_symbol_address. apply Val.add_commut. + repeat rewrite Val.add_assoc. auto. + fold (Val.add (Vint n1) (Val.add sp (Vint ofs))). + rewrite Val.add_permut. decEq. rewrite Val.add_commut. auto. + rewrite shift_symbol_address. auto. +Qed. + (** * Correctness of strength reduction *) (** We now show that strength reduction over operators and addressing diff --git a/powerpc/Unusedglob1.ml b/powerpc/Unusedglob1.ml new file mode 100644 index 0000000..c16cd2f --- /dev/null +++ b/powerpc/Unusedglob1.ml @@ -0,0 +1,61 @@ +(* *********************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Xavier Leroy, INRIA Paris-Rocquencourt *) +(* *) +(* 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. *) +(* *) +(* *********************************************************************) + +(* Identifiers referenced from a PowerPC Asm instruction *) + +open Datatypes +open AST +open Asm + +let referenced_constant = function + | Cint n -> [] + | Csymbol_low(s, ofs) -> [s] + | Csymbol_high(s, ofs) -> [s] + | Csymbol_sda(s, ofs) -> [s] + +let referenced_builtin ef = + match ef with + | EF_vload_global(chunk, id, ofs) -> [id] + | EF_vstore_global(chunk, id, ofs) -> [id] + | _ -> [] + +let referenced_instr = function + | Pbl s -> [s] + | Pbs s -> [s] + | Paddi(_, _, c) + | Paddic(_, _, c) + | Paddis(_, _, c) + | Pandi_(_, _, c) + | Pandis_(_, _, c) + | Pcmplwi(_, c) + | Pcmpwi(_, c) + | Plbz(_, c, _) + | Plfd(_, c, _) + | Plfs(_, c, _) + | Plha(_, c, _) + | Plhz(_, c, _) + | Plwz(_, c, _) + | Pmulli(_, _, c) + | Pori(_, _, c) + | Poris(_, _, c) + | Pstb(_, c, _) + | Pstfd(_, c, _) + | Pstfs(_, c, _) + | Psth(_, c, _) + | Pstw(_, c, _) + | Psubfic(_, _, c) + | Pxori(_, _, c) + | Pxoris(_, _, c) -> referenced_constant c + | Pbuiltin(ef, _, _) -> referenced_builtin ef + | _ -> [] + +let code_of_function f = f |