diff options
93 files changed, 4136 insertions, 2601 deletions
@@ -35,12 +35,12 @@ backend/CminorSel.vo backend/CminorSel.glob backend/CminorSel.v.beautified: back $(ARCH)/SelectOp.vo $(ARCH)/SelectOp.glob $(ARCH)/SelectOp.v.beautified: $(ARCH)/SelectOp.v lib/Coqlib.vo driver/Compopts.vo common/AST.vo lib/Integers.vo lib/Floats.vo $(ARCH)/Op.vo backend/CminorSel.vo backend/SelectDiv.vo backend/SelectDiv.glob backend/SelectDiv.v.beautified: backend/SelectDiv.v lib/Coqlib.vo driver/Compopts.vo common/AST.vo lib/Integers.vo lib/Floats.vo $(ARCH)/Op.vo backend/CminorSel.vo $(ARCH)/SelectOp.vo backend/SelectLong.vo backend/SelectLong.glob backend/SelectLong.v.beautified: backend/SelectLong.v lib/Coqlib.vo common/AST.vo lib/Integers.vo lib/Floats.vo $(ARCH)/Op.vo backend/CminorSel.vo $(ARCH)/SelectOp.vo common/Errors.vo common/Globalenvs.vo -backend/Selection.vo backend/Selection.glob backend/Selection.v.beautified: backend/Selection.v lib/Coqlib.vo common/AST.vo common/Errors.vo lib/Integers.vo common/Globalenvs.vo common/Switch.vo backend/Cminor.vo $(ARCH)/Op.vo backend/CminorSel.vo $(ARCH)/SelectOp.vo backend/SelectDiv.vo backend/SelectLong.vo +backend/Selection.vo backend/Selection.glob backend/Selection.v.beautified: backend/Selection.v lib/Coqlib.vo common/AST.vo common/Errors.vo lib/Integers.vo common/Globalenvs.vo common/Switch.vo backend/Cminor.vo $(ARCH)/Op.vo backend/CminorSel.vo $(ARCH)/SelectOp.vo backend/SelectDiv.vo backend/SelectLong.vo $(ARCH)/Machregs.vo $(ARCH)/SelectOpproof.vo $(ARCH)/SelectOpproof.glob $(ARCH)/SelectOpproof.v.beautified: $(ARCH)/SelectOpproof.v lib/Coqlib.vo common/AST.vo lib/Integers.vo lib/Floats.vo common/Values.vo common/Memory.vo common/Globalenvs.vo backend/Cminor.vo $(ARCH)/Op.vo backend/CminorSel.vo $(ARCH)/SelectOp.vo backend/SelectDivproof.vo backend/SelectDivproof.glob backend/SelectDivproof.v.beautified: backend/SelectDivproof.v lib/Coqlib.vo common/AST.vo lib/Integers.vo lib/Floats.vo common/Values.vo common/Memory.vo common/Globalenvs.vo common/Events.vo backend/Cminor.vo $(ARCH)/Op.vo backend/CminorSel.vo $(ARCH)/SelectOp.vo $(ARCH)/SelectOpproof.vo backend/SelectDiv.vo backend/SelectLongproof.vo backend/SelectLongproof.glob backend/SelectLongproof.v.beautified: backend/SelectLongproof.v lib/Coqlib.vo common/AST.vo common/Errors.vo lib/Integers.vo lib/Floats.vo common/Values.vo common/Memory.vo common/Globalenvs.vo common/Events.vo backend/Cminor.vo $(ARCH)/Op.vo backend/CminorSel.vo $(ARCH)/SelectOp.vo $(ARCH)/SelectOpproof.vo backend/SelectLong.vo backend/Selectionproof.vo backend/Selectionproof.glob backend/Selectionproof.v.beautified: backend/Selectionproof.v lib/Coqlib.vo lib/Maps.vo common/AST.vo common/Errors.vo lib/Integers.vo common/Values.vo common/Memory.vo common/Events.vo common/Globalenvs.vo common/Smallstep.vo common/Switch.vo backend/Cminor.vo $(ARCH)/Op.vo backend/CminorSel.vo $(ARCH)/SelectOp.vo backend/SelectDiv.vo backend/SelectLong.vo backend/Selection.vo $(ARCH)/SelectOpproof.vo backend/SelectDivproof.vo backend/SelectLongproof.vo -backend/Registers.vo backend/Registers.glob backend/Registers.v.beautified: backend/Registers.v lib/Coqlib.vo common/AST.vo lib/Maps.vo lib/Ordered.vo +backend/Registers.vo backend/Registers.glob backend/Registers.v.beautified: backend/Registers.v lib/Coqlib.vo common/AST.vo lib/Maps.vo lib/Ordered.vo common/Values.vo backend/RTL.vo backend/RTL.glob backend/RTL.v.beautified: backend/RTL.v lib/Coqlib.vo lib/Maps.vo common/AST.vo lib/Integers.vo common/Values.vo common/Events.vo common/Memory.vo common/Globalenvs.vo common/Smallstep.vo $(ARCH)/Op.vo backend/Registers.vo backend/RTLgen.vo backend/RTLgen.glob backend/RTLgen.v.beautified: backend/RTLgen.v lib/Coqlib.vo common/Errors.vo lib/Maps.vo common/AST.vo lib/Integers.vo common/Switch.vo $(ARCH)/Op.vo backend/Registers.vo backend/CminorSel.vo backend/RTL.vo backend/RTLgenspec.vo backend/RTLgenspec.glob backend/RTLgenspec.v.beautified: backend/RTLgenspec.v lib/Coqlib.vo common/Errors.vo lib/Maps.vo common/AST.vo lib/Integers.vo common/Switch.vo $(ARCH)/Op.vo backend/Registers.vo backend/CminorSel.vo backend/RTL.vo backend/RTLgen.vo @@ -59,7 +59,7 @@ backend/ValueDomain.vo backend/ValueDomain.glob backend/ValueDomain.v.beautified $(ARCH)/ValueAOp.vo $(ARCH)/ValueAOp.glob $(ARCH)/ValueAOp.v.beautified: $(ARCH)/ValueAOp.v lib/Coqlib.vo driver/Compopts.vo common/AST.vo lib/Integers.vo lib/Floats.vo common/Values.vo common/Memory.vo common/Globalenvs.vo $(ARCH)/Op.vo backend/ValueDomain.vo backend/RTL.vo backend/ValueAnalysis.vo backend/ValueAnalysis.glob backend/ValueAnalysis.v.beautified: backend/ValueAnalysis.v lib/Coqlib.vo lib/Maps.vo driver/Compopts.vo common/AST.vo lib/Integers.vo lib/Floats.vo common/Values.vo common/Memory.vo common/Globalenvs.vo common/Events.vo lib/Lattice.vo backend/Kildall.vo backend/Registers.vo $(ARCH)/Op.vo backend/RTL.vo backend/ValueDomain.vo $(ARCH)/ValueAOp.vo backend/Liveness.vo lib/Axioms.vo $(ARCH)/ConstpropOp.vo $(ARCH)/ConstpropOp.glob $(ARCH)/ConstpropOp.v.beautified: $(ARCH)/ConstpropOp.v lib/Coqlib.vo driver/Compopts.vo common/AST.vo lib/Integers.vo lib/Floats.vo $(ARCH)/Op.vo backend/Registers.vo backend/ValueDomain.vo -backend/Constprop.vo backend/Constprop.glob backend/Constprop.v.beautified: backend/Constprop.v lib/Coqlib.vo lib/Maps.vo common/AST.vo lib/Integers.vo lib/Floats.vo $(ARCH)/Op.vo backend/Registers.vo backend/RTL.vo lib/Lattice.vo backend/Kildall.vo backend/Liveness.vo backend/ValueDomain.vo $(ARCH)/ValueAOp.vo backend/ValueAnalysis.vo $(ARCH)/ConstpropOp.vo +backend/Constprop.vo backend/Constprop.glob backend/Constprop.v.beautified: backend/Constprop.v lib/Coqlib.vo lib/Maps.vo common/AST.vo lib/Integers.vo lib/Floats.vo $(ARCH)/Op.vo $(ARCH)/Machregs.vo backend/Registers.vo backend/RTL.vo lib/Lattice.vo backend/Kildall.vo backend/Liveness.vo backend/ValueDomain.vo $(ARCH)/ValueAOp.vo backend/ValueAnalysis.vo $(ARCH)/ConstpropOp.vo $(ARCH)/ConstpropOpproof.vo $(ARCH)/ConstpropOpproof.glob $(ARCH)/ConstpropOpproof.v.beautified: $(ARCH)/ConstpropOpproof.v lib/Coqlib.vo driver/Compopts.vo lib/Integers.vo lib/Floats.vo common/Values.vo common/Memory.vo common/Globalenvs.vo common/Events.vo $(ARCH)/Op.vo backend/Registers.vo backend/RTL.vo backend/ValueDomain.vo $(ARCH)/ConstpropOp.vo backend/Constpropproof.vo backend/Constpropproof.glob backend/Constpropproof.v.beautified: backend/Constpropproof.v lib/Coqlib.vo lib/Maps.vo driver/Compopts.vo common/AST.vo lib/Integers.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 lib/Lattice.vo backend/Kildall.vo backend/ValueDomain.vo $(ARCH)/ValueAOp.vo backend/ValueAnalysis.vo $(ARCH)/ConstpropOp.vo backend/Constprop.vo $(ARCH)/ConstpropOpproof.vo backend/CSEdomain.vo backend/CSEdomain.glob backend/CSEdomain.v.beautified: backend/CSEdomain.v lib/Coqlib.vo lib/Maps.vo common/AST.vo common/Values.vo common/Memory.vo $(ARCH)/Op.vo backend/Registers.vo backend/RTL.vo @@ -88,6 +88,8 @@ backend/Linearize.vo backend/Linearize.glob backend/Linearize.v.beautified: back backend/Linearizeproof.vo backend/Linearizeproof.glob backend/Linearizeproof.v.beautified: backend/Linearizeproof.v lib/Coqlib.vo lib/Maps.vo lib/Ordered.vo lib/Lattice.vo common/AST.vo lib/Integers.vo common/Values.vo common/Memory.vo common/Events.vo common/Globalenvs.vo common/Errors.vo common/Smallstep.vo $(ARCH)/Op.vo backend/Locations.vo backend/LTL.vo backend/Linear.vo backend/Linearize.vo backend/CleanupLabels.vo backend/CleanupLabels.glob backend/CleanupLabels.v.beautified: backend/CleanupLabels.v lib/Coqlib.vo lib/Ordered.vo backend/Linear.vo backend/CleanupLabelsproof.vo backend/CleanupLabelsproof.glob backend/CleanupLabelsproof.v.beautified: backend/CleanupLabelsproof.v lib/Coqlib.vo lib/Ordered.vo common/AST.vo lib/Integers.vo common/Values.vo common/Memory.vo common/Events.vo common/Globalenvs.vo common/Smallstep.vo $(ARCH)/Op.vo backend/Locations.vo backend/Linear.vo backend/CleanupLabels.vo +backend/Debugvar.vo backend/Debugvar.glob backend/Debugvar.v.beautified: backend/Debugvar.v lib/Coqlib.vo lib/Axioms.vo lib/Maps.vo lib/Iteration.vo common/AST.vo lib/Integers.vo lib/Floats.vo common/Errors.vo $(ARCH)/Machregs.vo backend/Locations.vo backend/Conventions.vo backend/Linear.vo +backend/Debugvarproof.vo backend/Debugvarproof.glob backend/Debugvarproof.v.beautified: backend/Debugvarproof.v lib/Coqlib.vo lib/Axioms.vo lib/Maps.vo lib/Iteration.vo common/AST.vo lib/Integers.vo lib/Floats.vo common/Values.vo common/Memory.vo common/Events.vo common/Globalenvs.vo common/Smallstep.vo $(ARCH)/Op.vo common/Errors.vo $(ARCH)/Machregs.vo backend/Locations.vo backend/Conventions.vo backend/Linear.vo backend/Debugvar.vo backend/Mach.vo backend/Mach.glob backend/Mach.v.beautified: backend/Mach.v lib/Coqlib.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/Locations.vo backend/Conventions.vo $(ARCH)/Stacklayout.vo backend/Bounds.vo backend/Bounds.glob backend/Bounds.v.beautified: backend/Bounds.v lib/Coqlib.vo common/AST.vo $(ARCH)/Op.vo backend/Locations.vo backend/Linear.vo backend/Conventions.vo $(ARCH)/Stacklayout.vo $(ARCH)/Stacklayout.glob $(ARCH)/Stacklayout.v.beautified: $(ARCH)/Stacklayout.v lib/Coqlib.vo backend/Bounds.vo @@ -112,7 +114,7 @@ cfrontend/SimplExprspec.vo cfrontend/SimplExprspec.glob cfrontend/SimplExprspec. cfrontend/SimplExprproof.vo cfrontend/SimplExprproof.glob cfrontend/SimplExprproof.v.beautified: cfrontend/SimplExprproof.v lib/Coqlib.vo lib/Maps.vo common/AST.vo common/Errors.vo lib/Integers.vo common/Values.vo common/Memory.vo common/Events.vo common/Smallstep.vo common/Globalenvs.vo cfrontend/Ctypes.vo cfrontend/Cop.vo cfrontend/Csyntax.vo cfrontend/Csem.vo cfrontend/Cstrategy.vo cfrontend/Clight.vo cfrontend/SimplExpr.vo cfrontend/SimplExprspec.vo cfrontend/Clight.vo cfrontend/Clight.glob cfrontend/Clight.v.beautified: cfrontend/Clight.v lib/Coqlib.vo common/Errors.vo lib/Maps.vo lib/Integers.vo lib/Floats.vo common/Values.vo common/AST.vo common/Memory.vo common/Events.vo common/Globalenvs.vo common/Smallstep.vo cfrontend/Ctypes.vo cfrontend/Cop.vo cfrontend/ClightBigstep.vo cfrontend/ClightBigstep.glob cfrontend/ClightBigstep.v.beautified: cfrontend/ClightBigstep.v lib/Coqlib.vo lib/Maps.vo lib/Integers.vo lib/Floats.vo common/Values.vo common/AST.vo common/Memory.vo common/Events.vo common/Globalenvs.vo common/Smallstep.vo cfrontend/Ctypes.vo cfrontend/Cop.vo cfrontend/Clight.vo -cfrontend/SimplLocals.vo cfrontend/SimplLocals.glob cfrontend/SimplLocals.v.beautified: cfrontend/SimplLocals.v lib/Coqlib.vo lib/Ordered.vo common/Errors.vo common/AST.vo cfrontend/Ctypes.vo cfrontend/Cop.vo cfrontend/Clight.vo +cfrontend/SimplLocals.vo cfrontend/SimplLocals.glob cfrontend/SimplLocals.v.beautified: cfrontend/SimplLocals.v lib/Coqlib.vo lib/Ordered.vo common/Errors.vo common/AST.vo cfrontend/Ctypes.vo cfrontend/Cop.vo cfrontend/Clight.vo driver/Compopts.vo cfrontend/SimplLocalsproof.vo cfrontend/SimplLocalsproof.glob cfrontend/SimplLocalsproof.v.beautified: cfrontend/SimplLocalsproof.v lib/Coqlib.vo common/Errors.vo lib/Ordered.vo common/AST.vo lib/Maps.vo lib/Integers.vo lib/Floats.vo common/Values.vo common/Memory.vo common/Globalenvs.vo common/Events.vo common/Smallstep.vo cfrontend/Ctypes.vo cfrontend/Cop.vo cfrontend/Clight.vo cfrontend/SimplLocals.vo cfrontend/Cshmgen.vo cfrontend/Cshmgen.glob cfrontend/Cshmgen.v.beautified: cfrontend/Cshmgen.v lib/Coqlib.vo lib/Maps.vo common/Errors.vo lib/Integers.vo lib/Floats.vo common/AST.vo cfrontend/Ctypes.vo cfrontend/Cop.vo cfrontend/Clight.vo backend/Cminor.vo cfrontend/Csharpminor.vo cfrontend/Cshmgenproof.vo cfrontend/Cshmgenproof.glob cfrontend/Cshmgenproof.v.beautified: cfrontend/Cshmgenproof.v lib/Coqlib.vo common/Errors.vo lib/Maps.vo lib/Integers.vo lib/Floats.vo common/AST.vo common/Values.vo common/Events.vo common/Memory.vo common/Globalenvs.vo common/Smallstep.vo cfrontend/Ctypes.vo cfrontend/Cop.vo cfrontend/Clight.vo backend/Cminor.vo cfrontend/Csharpminor.vo cfrontend/Cshmgen.vo @@ -120,7 +122,7 @@ cfrontend/Csharpminor.vo cfrontend/Csharpminor.glob cfrontend/Csharpminor.v.beau cfrontend/Cminorgen.vo cfrontend/Cminorgen.glob cfrontend/Cminorgen.v.beautified: cfrontend/Cminorgen.v lib/Coqlib.vo common/Errors.vo lib/Maps.vo lib/Ordered.vo common/AST.vo lib/Integers.vo lib/Floats.vo cfrontend/Csharpminor.vo backend/Cminor.vo cfrontend/Cminorgenproof.vo cfrontend/Cminorgenproof.glob cfrontend/Cminorgenproof.v.beautified: 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/Memory.vo common/Events.vo common/Globalenvs.vo common/Smallstep.vo common/Switch.vo cfrontend/Csharpminor.vo backend/Cminor.vo cfrontend/Cminorgen.vo driver/Compopts.vo driver/Compopts.glob driver/Compopts.v.beautified: driver/Compopts.v -driver/Compiler.vo driver/Compiler.glob driver/Compiler.v.beautified: driver/Compiler.v lib/Coqlib.vo common/Errors.vo common/AST.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/Linear.vo backend/Mach.vo $(ARCH)/Asm.vo cfrontend/Initializers.vo cfrontend/SimplExpr.vo cfrontend/SimplLocals.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/Deadcode.vo backend/Unusedglob.vo backend/Allocation.vo backend/Tunneling.vo backend/Linearize.vo backend/CleanupLabels.vo backend/Stacking.vo $(ARCH)/Asmgen.vo cfrontend/SimplExprproof.vo cfrontend/SimplLocalsproof.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/Deadcodeproof.vo backend/Unusedglobproof.vo backend/Allocproof.vo backend/Tunnelingproof.vo backend/Linearizeproof.vo backend/CleanupLabelsproof.vo backend/Stackingproof.vo $(ARCH)/Asmgenproof.vo driver/Compopts.vo +driver/Compiler.vo driver/Compiler.glob driver/Compiler.v.beautified: driver/Compiler.v lib/Coqlib.vo common/Errors.vo common/AST.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/Linear.vo backend/Mach.vo $(ARCH)/Asm.vo cfrontend/Initializers.vo cfrontend/SimplExpr.vo cfrontend/SimplLocals.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/Deadcode.vo backend/Unusedglob.vo backend/Allocation.vo backend/Tunneling.vo backend/Linearize.vo backend/CleanupLabels.vo backend/Debugvar.vo backend/Stacking.vo $(ARCH)/Asmgen.vo cfrontend/SimplExprproof.vo cfrontend/SimplLocalsproof.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/Deadcodeproof.vo backend/Unusedglobproof.vo backend/Allocproof.vo backend/Tunnelingproof.vo backend/Linearizeproof.vo backend/CleanupLabelsproof.vo backend/Debugvarproof.vo backend/Stackingproof.vo $(ARCH)/Asmgenproof.vo driver/Compopts.vo driver/Complements.vo driver/Complements.glob driver/Complements.v.beautified: 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 flocq/Core/Fcore_Raux.vo flocq/Core/Fcore_Raux.glob flocq/Core/Fcore_Raux.v.beautified: flocq/Core/Fcore_Raux.v flocq/Core/Fcore_Zaux.vo flocq/Core/Fcore_Zaux.vo flocq/Core/Fcore_Zaux.glob flocq/Core/Fcore_Zaux.v.beautified: flocq/Core/Fcore_Zaux.v @@ -83,6 +83,7 @@ BACKEND=\ Linear.v Lineartyping.v \ Linearize.v Linearizeproof.v \ CleanupLabels.v CleanupLabelsproof.v \ + Debugvar.v Debugvarproof.v \ Mach.v \ Bounds.v Stacklayout.v Stacking.v Stackingproof.v \ Asm.v Asmgen.v Asmgenproof0.v Asmgenproof1.v Asmgenproof.v @@ -205,14 +205,13 @@ Inductive instruction : Type := | Ploadsymbol: ireg -> ident -> int -> instruction (**r load the address of a symbol *) | Pmovite: testcond -> ireg -> shift_op -> shift_op -> instruction (**r integer conditional move *) | Pbtbl: ireg -> list label -> instruction (**r N-way branch through a jump table *) - | Pbuiltin: external_function -> list preg -> list preg -> instruction (**r built-in function *) - | Pannot: external_function -> list (annot_arg preg) -> instruction (**r annotation statement *) + | Pbuiltin: external_function -> list (builtin_arg preg) -> builtin_res preg -> instruction (**r built-in function (pseudo) *) | Padc: ireg -> ireg -> shift_op -> instruction (**r add with carry *) | Pcfi_adjust: int -> instruction (**r .cfi_adjust debug directive *) - | Pclz: preg -> preg -> instruction (**r count leading zeros. *) + | Pclz: ireg -> ireg -> instruction (**r count leading zeros. *) | Pfsqrt: freg -> freg -> instruction (**r floating-point square root. *) - | Prev: preg -> preg -> instruction (**r reverse bytes and reverse bits. *) - | Prev16: preg -> preg -> instruction (**r reverse bytes and reverse bits. *) + | Prev: ireg -> ireg -> instruction (**r reverse bytes and reverse bits. *) + | Prev16: ireg -> ireg -> instruction (**r reverse bytes and reverse bits. *) | Prsc: ireg -> ireg -> shift_op -> instruction (**r reverse subtract without carry. *) | Psbc: ireg -> ireg -> shift_op -> instruction (**r add with carry *) (* Add, sub, rsb versions with s suffix *) @@ -319,6 +318,15 @@ Fixpoint set_regs (rl: list preg) (vl: list val) (rs: regset) : regset := | _, _ => rs end. +(** Assigning the result of a builtin *) + +Fixpoint set_res (res: builtin_res preg) (v: val) (rs: regset) : regset := + match res with + | BR r => rs#r <- v + | BR_none => rs + | BR_splitlong hi lo => set_res lo (Val.loword v) (set_res hi (Val.hiword v) rs) + end. + Section RELSEM. (** Looking up instructions in a code sequence by position. *) @@ -748,7 +756,6 @@ Definition exec_instr (f: function) (i: instruction) (rs: regset) (m: mem) : out | _ => Stuck end | Pbuiltin ef args res => Stuck (**r treated specially below *) - | Pannot ef args => Stuck (**r treated specially below *) (** The following instructions and directives are not generated directly by Asmgen, so we do not model them. *) | Ppush _ @@ -827,23 +834,16 @@ Inductive step: state -> trace -> state -> Prop := exec_instr f i rs m = Next rs' m' -> step (State rs m) E0 (State rs' m') | exec_step_builtin: - forall b ofs f ef args res rs m t vl rs' m', + forall b ofs f ef args res rs m vargs t vres rs' m', rs PC = Vptr b ofs -> Genv.find_funct_ptr ge b = Some (Internal f) -> - find_instr (Int.unsigned ofs) (fn_code f) = Some (Pbuiltin ef args res) -> - external_call' ef ge (map rs args) m t vl m' -> - rs' = nextinstr - (set_regs res vl + find_instr (Int.unsigned ofs) f.(fn_code) = Some (Pbuiltin ef args res) -> + eval_builtin_args ge rs (rs SP) m args vargs -> + external_call ef ge vargs m t vres m' -> + rs' = nextinstr + (set_res res vres (undef_regs (map preg_of (destroyed_by_builtin ef)) rs)) -> step (State rs m) t (State rs' m') - | exec_step_annot: - forall b ofs f ef args rs m vargs t v m', - rs PC = Vptr b ofs -> - Genv.find_funct_ptr ge b = Some (Internal f) -> - find_instr (Int.unsigned ofs) (fn_code f) = Some (Pannot ef args) -> - eval_annot_args ge rs (rs SP) m args vargs -> - external_call ef ge vargs m t v m' -> - step (State rs m) t (State (nextinstr rs) m') | exec_step_external: forall b ef args res rs m t rs' m', rs PC = Vptr b Int.zero -> @@ -907,12 +907,8 @@ Ltac Equalities := split. constructor. auto. discriminate. discriminate. - inv H11. - exploit external_call_determ'. eexact H4. eexact H9. intros [A B]. - split. auto. intros. destruct B; auto. subst. auto. - inv H12. - assert (vargs0 = vargs) by (eapply eval_annot_args_determ; eauto). subst vargs0. - exploit external_call_determ. eexact H5. eexact H13. intros [A B]. + assert (vargs0 = vargs) by (eapply eval_builtin_args_determ; eauto). subst vargs0. + exploit external_call_determ. eexact H5. eexact H11. intros [A B]. split. auto. intros. destruct B; auto. subst. auto. assert (args0 = args) by (eapply extcall_arguments_determ; eauto). subst args0. exploit external_call_determ'. eexact H3. eexact H8. intros [A B]. @@ -921,7 +917,6 @@ Ltac Equalities := red; intros; inv H; simpl. omega. inv H3; eapply external_call_trace_length; eauto. - eapply external_call_trace_length; eauto. inv H2; eapply external_call_trace_length; eauto. (* initial states *) inv H; inv H0. f_equal. congruence. diff --git a/arm/Asmexpand.ml b/arm/Asmexpand.ml index ca30924c..d13015ff 100644 --- a/arm/Asmexpand.ml +++ b/arm/Asmexpand.ml @@ -21,6 +21,8 @@ open AST open Camlcoq open Integers +exception Error of string + (* Useful constants and helper functions *) let _0 = Integers.Int.zero @@ -74,51 +76,83 @@ let expand_int64_arith conflict rl fn = (* Handling of annotations *) let expand_annot_val txt targ args res = - emit (Pannot (EF_annot(txt,[targ]), List.map (fun r -> AA_base r) args)); + emit (Pbuiltin (EF_annot(txt,[targ]), args, BR_none)); match args, res with - | [IR src], [IR dst] -> + | [BA(IR src)], BR(IR dst) -> if dst <> src then emit (Pmov (dst,SOreg src)) - | [FR src], [FR dst] -> + | [BA(FR src)], BR(FR dst) -> if dst <> src then emit (Pfcpyd (dst,src)) - | _, _ -> assert false - + | _, _ -> + raise (Error "ill-formed __builtin_annot_val") (* Handling of memcpy *) (* The ARM has strict alignment constraints for 2 and 4 byte accesses. 8-byte accesses must be 4-aligned. *) +let offset_in_range ofs = + let n = camlint_of_coqint ofs in n <= 128l && n >= -128l + +let memcpy_small_arg sz arg tmp = + match arg with + | BA (IR r) -> + (r, _0) + | BA_addrstack ofs -> + if offset_in_range ofs + && offset_in_range (Int.add ofs (Int.repr (Z.of_uint sz))) + then (IR13, ofs) + else begin expand_addimm tmp IR13 ofs; (tmp, _0) end + | _ -> + assert false + let expand_builtin_memcpy_small sz al src dst = - let rec copy ofs sz = + let (tsrc, tdst) = + if dst <> BA (IR IR2) then (IR2, IR3) else (IR3, IR2) in + let (rsrc, osrc) = memcpy_small_arg sz src tsrc in + let (rdst, odst) = memcpy_small_arg sz dst tdst in + let rec copy osrc odst sz = if sz >= 8 && al >= 4 && !Clflags.option_ffpu then begin - emit (Pfldd (FR7,src,ofs)); - emit (Pfstd (FR7,dst,ofs)); - copy (Int.add ofs _8) (sz - 8) + emit (Pfldd (FR7,rsrc,osrc)); + emit (Pfstd (FR7,rdst,odst)); + copy (Int.add osrc _8) (Int.add odst _8) (sz - 8) end else if sz >= 4 && al >= 4 then begin - emit (Pldr (IR14,src,SOimm ofs)); - emit (Pstr (IR14,dst,SOimm ofs)); - copy (Int.add ofs _4) (sz - 4) + emit (Pldr (IR14,rsrc,SOimm osrc)); + emit (Pstr (IR14,rdst,SOimm odst)); + copy (Int.add osrc _4) (Int.add odst _4) (sz - 4) end else if sz >= 2 && al >= 2 then begin - emit (Pldrh (IR14,src,SOimm ofs)); - emit (Pstrh (IR14,dst,SOimm ofs)); - copy (Int.add ofs _2) (sz - 2) + emit (Pldrh (IR14,rsrc,SOimm osrc)); + emit (Pstrh (IR14,rdst,SOimm odst)); + copy (Int.add osrc _2) (Int.add odst _2) (sz - 2) end else if sz >= 1 then begin - emit (Pldrb (IR14,src,SOimm ofs)); - emit (Pstrb (IR14,dst,SOimm ofs)); - copy (Int.add ofs _1) (sz - 1) - end else - () in - copy _0 sz + emit (Pldrb (IR14,rsrc,SOimm osrc)); + emit (Pstrb (IR14,rdst,SOimm odst)); + copy (Int.add osrc _1) (Int.add odst _1) (sz - 1) + end in + copy osrc odst sz + +let memcpy_big_arg arg tmp = + match arg with + | BA (IR r) -> + if r <> tmp then emit (Pmov(tmp, SOreg r)) + | BA_addrstack ofs -> + expand_addimm tmp IR13 ofs + | _ -> + assert false let expand_builtin_memcpy_big sz al src dst = assert (sz >= al); assert (sz mod al = 0); - assert (src = IR2); - assert (dst = IR3); + let (s, d) = + if dst <> BA (IR IR2) then (IR2, IR3) else (IR3, IR2) in + memcpy_big_arg src s; + memcpy_big_arg dst d; let (load, store, chunksize) = - if al >= 4 then (Pldr_p (IR12,src,SOimm _4), Pstr_p (IR12,dst,SOimm _4) , 4) - else if al = 2 then (Pldrh_p (IR12,src,SOimm _2), Pstrh_p (IR12,dst,SOimm _2), 2) - else (Pldrb_p (IR12,src,SOimm _1), Pstrb_p (IR12,dst,SOimm _1), 1) in + if al >= 4 then + (Pldr_p (IR12,s,SOimm _4), Pstr_p (IR12,d,SOimm _4) , 4) + else if al = 2 then + (Pldrh_p (IR12,s,SOimm _2), Pstrh_p (IR12,d,SOimm _2), 2) + else + (Pldrb_p (IR12,s,SOimm _1), Pstrb_p (IR12,d,SOimm _1), 1) in expand_movimm IR14 (coqint_of_camlint (Int32.of_int (sz / chunksize))); let lbl = new_label () in emit (Plabel lbl); @@ -129,71 +163,93 @@ let expand_builtin_memcpy_big sz al src dst = let expand_builtin_memcpy sz al args = let (dst, src) = - match args with [IR d; IR s] -> (d, s) | _ -> assert false in + match args with [d; s] -> (d, s) | _ -> assert false in if sz <= 32 then expand_builtin_memcpy_small sz al src dst else expand_builtin_memcpy_big sz al src dst (* Handling of volatile reads and writes *) -let expand_builtin_vload_common chunk args res = - match chunk, args, res with - | Mint8unsigned, [IR addr], [IR res] -> - emit (Pldrb (res, addr,SOimm _0)) - | Mint8signed, [IR addr], [IR res] -> - emit (Pldrsb (res, addr,SOimm _0)) - | Mint16unsigned, [IR addr], [IR res] -> - emit (Pldrh (res, addr, SOimm _0)) - | Mint16signed, [IR addr], [IR res] -> - emit (Pldrsh (res, addr, SOimm _0)) - | Mint32, [IR addr], [IR res] -> - emit (Pldr (res,addr, SOimm _0)) - | Mint64, [IR addr], [IR res1; IR res2] -> - if addr <> res2 then begin - emit (Pldr (res2, addr, SOimm _0)); - emit (Pldr (res1, addr, SOimm _4)) +let expand_builtin_vload_common chunk base ofs res = + match chunk, res with + | Mint8unsigned, BR(IR res) -> + emit (Pldrb (res, base, SOimm ofs)) + | Mint8signed, BR(IR res) -> + emit (Pldrsb (res, base, SOimm ofs)) + | Mint16unsigned, BR(IR res) -> + emit (Pldrh (res, base, SOimm ofs)) + | Mint16signed, BR(IR res) -> + emit (Pldrsh (res, base, SOimm ofs)) + | Mint32, BR(IR res) -> + emit (Pldr (res, base, SOimm ofs)) + | Mint64, BR_splitlong(BR(IR res1), BR(IR res2)) -> + let ofs' = Int.add ofs _4 in + if base <> res2 then begin + emit (Pldr (res2, base, SOimm ofs)); + emit (Pldr (res1, base, SOimm ofs')) end else begin - emit (Pldr (res1,addr, SOimm _4)); - emit (Pldr (res2,addr, SOimm _0)) + emit (Pldr (res1, base, SOimm ofs')); + emit (Pldr (res2, base, SOimm ofs)) end - | Mfloat32, [IR addr], [FR res] -> - emit (Pflds (res, addr, _0)) - | Mfloat64, [IR addr], [FR res] -> - emit (Pfldd (res,addr, _0)) + | Mfloat32, BR(FR res) -> + emit (Pflds (res, base, ofs)) + | Mfloat64, BR(FR res) -> + emit (Pfldd (res, base, ofs)) | _ -> assert false let expand_builtin_vload chunk args res = - expand_builtin_vload_common chunk args res - -let expand_builtin_vload_global chunk id ofs args res = - emit (Ploadsymbol (IR14,id,ofs)); - expand_builtin_vload_common chunk (IR IR14 :: args) res - -let expand_builtin_vstore_common chunk args = - match chunk, args with - | (Mint8signed | Mint8unsigned), [IR addr; IR src] -> - emit (Pstrb (src,addr, SOimm _0)) - | (Mint16signed | Mint16unsigned), [IR addr; IR src] -> - emit (Pstrh (src,addr, SOimm _0)) - | Mint32, [IR addr; IR src] -> - emit (Pstr (src,addr, SOimm _0)) - | Mint64, [IR addr; IR src1; IR src2] -> - emit (Pstr (src2,addr,SOimm _0)); - emit (Pstr (src1,addr,SOimm _4)) - | Mfloat32, [IR addr; FR src] -> - emit (Pfsts (src,addr,_0)) - | Mfloat64, [IR addr; FR src] -> - emit (Pfstd (src,addr,_0)); + match args with + | [BA(IR addr)] -> + expand_builtin_vload_common chunk addr _0 res + | [BA_addrstack ofs] -> + if offset_in_range (Int.add ofs (Memdata.size_chunk chunk)) then + expand_builtin_vload_common chunk IR13 ofs res + else begin + expand_addimm IR14 IR13 ofs; + expand_builtin_vload_common chunk IR14 _0 res + end + | [BA_addrglobal(id, ofs)] -> + emit (Ploadsymbol (IR14,id,ofs)); + expand_builtin_vload_common chunk IR14 _0 res + | _ -> + assert false + +let expand_builtin_vstore_common chunk base ofs src = + match chunk, src with + | (Mint8signed | Mint8unsigned), BA(IR src) -> + emit (Pstrb (src, base, SOimm ofs)) + | (Mint16signed | Mint16unsigned), BA(IR src) -> + emit (Pstrh (src, base, SOimm ofs)) + | Mint32, BA(IR src) -> + emit (Pstr (src, base, SOimm ofs)) + | Mint64, BA_splitlong(BA(IR src1), BA(IR src2)) -> + let ofs' = Int.add ofs _4 in + emit (Pstr (src2, base, SOimm ofs)); + emit (Pstr (src1, base, SOimm ofs')) + | Mfloat32, BA(FR src) -> + emit (Pfsts (src, base, ofs)) + | Mfloat64, BA(FR src) -> + emit (Pfstd (src, base, ofs)) | _ -> assert false let expand_builtin_vstore chunk args = - expand_builtin_vstore_common chunk args - -let expand_builtin_vstore_global chunk id ofs args = - emit (Ploadsymbol (IR14,id,ofs)); - expand_builtin_vstore_common chunk (IR IR14 :: args) + match args with + | [BA(IR addr); src] -> + expand_builtin_vstore_common chunk addr _0 src + | [BA_addrstack ofs; src] -> + if offset_in_range (Int.add ofs (Memdata.size_chunk chunk)) then + expand_builtin_vstore_common chunk IR13 ofs src + else begin + expand_addimm IR14 IR13 ofs; + expand_builtin_vstore_common chunk IR14 _0 src + end + | [BA_addrglobal(id, ofs); src] -> + emit (Ploadsymbol (IR14,id,ofs)); + expand_builtin_vstore_common chunk IR14 _0 src + | _ -> + assert false (* Handling of varargs *) @@ -223,22 +279,24 @@ let expand_builtin_va_start r = (* Handling of compiler-inlined builtins *) + let expand_builtin_inline name args res = match name, args, res with (* Integer arithmetic *) - | ("__builtin_bswap" | "__builtin_bswap32"), [IR a1], [IR res] -> - emit (Prev (IR res,IR a1)) - | "__builtin_bswap16", [IR a1], [IR res] -> - emit (Prev16 (IR res,IR a1)) - | "__builtin_clz", [IR a1], [IR res] -> - emit (Pclz (IR res, IR a1)) + | ("__builtin_bswap" | "__builtin_bswap32"), [BA(IR a1)], BR(IR res) -> + emit (Prev (res, a1)) + | "__builtin_bswap16", [BA(IR a1)], BR(IR res) -> + emit (Prev16 (res, a1)) + | "__builtin_clz", [BA(IR a1)], BR(IR res) -> + emit (Pclz (res, a1)) (* Float arithmetic *) - | "__builtin_fabs", [FR a1], [FR res] -> + | "__builtin_fabs", [BA(FR a1)], BR(FR res) -> emit (Pfabsd (res,a1)) - | "__builtin_fsqrt", [FR a1], [FR res] -> + | "__builtin_fsqrt", [BA(FR a1)], BR(FR res) -> emit (Pfsqrt (res,a1)) (* 64-bit integer arithmetic *) - | "__builtin_negl", [IR ah;IR al], [IR rh; IR rl] -> + | "__builtin_negl", [BA_splitlong(BA(IR ah), BA(IR al))], + BR_splitlong(BR(IR rh), BR(IR rl)) -> expand_int64_arith (rl = ah ) rl (fun rl -> emit (Prsbs (rl,al,SOimm _0)); (* No "rsc" instruction in Thumb2. Emulate based on @@ -250,30 +308,35 @@ let expand_builtin_inline name args res = end else begin emit (Prsc (rh,ah,SOimm _0)) end) - | "__builtin_addl", [IR ah; IR al; IR bh; IR bl], [IR rh; IR rl] -> + | "__builtin_addl", [BA_splitlong(BA(IR ah), BA(IR al)); + BA_splitlong(BA(IR bh), BA(IR bl))], + BR_splitlong(BR(IR rh), BR(IR rl)) -> expand_int64_arith (rl = ah || rl = bh) rl (fun rl -> emit (Padds (rl,al,SOreg bl)); emit (Padc (rh,ah,SOreg bh))) - | "__builtin_subl", [IR ah; IR al; IR bh; IR bl], [IR rh; IR rl] -> + | "__builtin_subl", [BA_splitlong(BA(IR ah), BA(IR al)); + BA_splitlong(BA(IR bh), BA(IR bl))], + BR_splitlong(BR(IR rh), BR(IR rl)) -> expand_int64_arith (rl = ah || rl = bh) rl (fun rl -> emit (Psubs (rl,al,SOreg bl)); emit (Psbc (rh,ah,SOreg bh))) - | "__builtin_mull", [IR a; IR b], [IR rh; IR rl] -> + | "__builtin_mull", [BA(IR a); BA(IR b)], + BR_splitlong(BR(IR rh), BR(IR rl)) -> emit (Pumull (rl,rh,a,b)) (* Memory accesses *) - | "__builtin_read16_reversed", [IR a1], [IR res] -> + | "__builtin_read16_reversed", [BA(IR a1)], BR(IR res) -> emit (Pldrh (res,a1,SOimm _0)); - emit (Prev16 (IR res,IR res)); - | "__builtin_read32_reversed", [IR a1], [IR res] -> + emit (Prev16 (res, res)); + | "__builtin_read32_reversed", [BA(IR a1)], BR(IR res) -> emit (Pldr (res,a1,SOimm _0)); - emit (Prev (IR res,IR res)); - | "__builtin_write16_reversed", [IR a1; IR a2], _ -> - emit (Prev16 (IR IR14, IR a2)); + emit (Prev (res, res)); + | "__builtin_write16_reversed", [BA(IR a1); BA(IR a2)], _ -> + emit (Prev16 (IR14, a2)); emit (Pstrh (IR14, a1, SOimm _0)) - | "__builtin_write32_reversed", [IR a1; IR a2], _ -> - emit (Prev (IR IR14, IR a2)); + | "__builtin_write32_reversed", [BA(IR a1); BA(IR a2)], _ -> + emit (Prev (IR14, a2)); emit (Pstr (IR14, a1, SOimm _0)) (* Synchronization *) | "__builtin_membar",[], _ -> @@ -285,11 +348,11 @@ let expand_builtin_inline name args res = | "__builtin_isb", [], _ -> emit Pisb (* Vararg stuff *) - | "__builtin_va_start", [IR a], _ -> + | "__builtin_va_start", [BA(IR a)], _ -> expand_builtin_va_start a (* Catch-all *) | _ -> - invalid_arg ("unrecognized builtin " ^ name) + raise (Error ("unrecognized builtin " ^ name)) let expand_instruction instr = match instr with @@ -319,30 +382,35 @@ let expand_instruction instr = expand_builtin_vload chunk args res | EF_vstore chunk -> expand_builtin_vstore chunk args - | EF_vload_global(chunk, id, ofs) -> - expand_builtin_vload_global chunk id ofs args res - | EF_vstore_global(chunk, id, ofs) -> - expand_builtin_vstore_global chunk id ofs args | EF_annot_val (txt,targ) -> expand_annot_val txt targ args res | EF_memcpy(sz, al) -> expand_builtin_memcpy (Int32.to_int (camlint_of_coqint sz)) (Int32.to_int (camlint_of_coqint al)) args - | EF_inline_asm(txt, sg, clob) -> + | EF_annot _ | EF_debug _ | EF_inline_asm _ -> emit instr - | _ -> assert false + | _ -> + assert false end | _ -> emit instr let expand_function fn = - set_current_function fn; - List.iter expand_instruction fn.fn_code; - get_current_function () + try + set_current_function fn; + List.iter expand_instruction fn.fn_code; + Errors.OK (get_current_function ()) + with Error s -> + Errors.Error (Errors.msg (coqstring_of_camlstring s)) let expand_fundef = function - | Internal f -> Internal (expand_function f) - | External ef -> External ef - -let expand_program (p: Asm.program) : Asm.program = - AST.transform_program expand_fundef p + | Internal f -> + begin match expand_function f with + | Errors.OK tf -> Errors.OK (Internal tf) + | Errors.Error msg -> Errors.Error msg + end + | External ef -> + Errors.OK (External ef) + +let expand_program (p: Asm.program) : Asm.program Errors.res = + AST.transform_partial_program expand_fundef p diff --git a/arm/Asmgen.v b/arm/Asmgen.v index 5a3a48e1..2365d1d2 100644 --- a/arm/Asmgen.v +++ b/arm/Asmgen.v @@ -727,9 +727,7 @@ Definition transl_instr (f: Mach.function) (i: Mach.instruction) OK (loadind_int IR13 f.(fn_retaddr_ofs) IR14 (Pfreeframe f.(fn_stacksize) f.(fn_link_ofs) :: Pbsymb symb sig :: k)) | Mbuiltin ef args res => - OK (Pbuiltin ef (map preg_of args) (map preg_of res) :: k) - | Mannot ef args => - OK (Pannot ef (List.map (map_annot_arg preg_of) args) :: k) + OK (Pbuiltin ef (List.map (map_builtin_arg preg_of) args) (map_builtin_res preg_of res) :: k) | Mlabel lbl => OK (Plabel lbl :: k) | Mgoto lbl => diff --git a/arm/Asmgenproof.v b/arm/Asmgenproof.v index 6d9b134f..93c50bfb 100644 --- a/arm/Asmgenproof.v +++ b/arm/Asmgenproof.v @@ -747,48 +747,32 @@ Opaque loadind. intros. Simpl. rewrite S; auto with asmgen. eapply preg_val; eauto. - (* Mbuiltin *) - inv AT. monadInv H3. + inv AT. monadInv H4. exploit functions_transl; eauto. intro FN. - generalize (transf_function_no_overflow _ _ H2); intro NOOV. - exploit external_call_mem_extends'; eauto. eapply preg_vals; eauto. + generalize (transf_function_no_overflow _ _ H3); intro NOOV. + exploit builtin_args_match; eauto. intros [vargs' [P Q]]. + exploit external_call_mem_extends; eauto. intros [vres' [m2' [A [B [C D]]]]]. left. econstructor; split. apply plus_one. eapply exec_step_builtin. eauto. eauto. eapply find_instr_tail; eauto. - eapply external_call_symbols_preserved'; eauto. + erewrite <- sp_val by eauto. + eapply eval_builtin_args_preserved with (ge1 := ge); eauto. exact symbols_preserved. + eapply external_call_symbols_preserved; eauto. exact symbols_preserved. exact public_preserved. exact varinfo_preserved. eauto. econstructor; eauto. - Simpl. rewrite set_pregs_other_2. rewrite undef_regs_other_2. rewrite <- H0. simpl. econstructor; eauto. + instantiate (2 := tf); instantiate (1 := x). + unfold nextinstr. rewrite Pregmap.gss. + rewrite set_res_other. rewrite undef_regs_other_2. + rewrite <- H1. simpl. econstructor; eauto. eapply code_tail_next_int; eauto. - apply preg_notin_charact. auto with asmgen. - apply preg_notin_charact. auto with asmgen. - apply agree_nextinstr. eapply agree_set_mregs; auto. + rewrite preg_notin_charact. intros. auto with asmgen. + auto with asmgen. + apply agree_nextinstr. eapply agree_set_res; auto. eapply agree_undef_regs; eauto. intros; apply undef_regs_other_2; auto. congruence. -- (* Mannot *) - inv AT. monadInv H4. - exploit functions_transl; eauto. intro FN. - generalize (transf_function_no_overflow _ _ H3); intro NOOV. - exploit annot_args_match; eauto. intros [vargs' [P Q]]. - exploit external_call_mem_extends; eauto. - intros [vres' [m2' [A [B [C D]]]]]. - left. econstructor; split. apply plus_one. - eapply exec_step_annot. eauto. eauto. - eapply find_instr_tail; eauto. eauto. - erewrite <- sp_val by eauto. - eapply eval_annot_args_preserved with (ge1 := ge); eauto. - exact symbols_preserved. - eapply external_call_symbols_preserved; eauto. - exact symbols_preserved. exact public_preserved. exact varinfo_preserved. - eapply match_states_intro with (ep := false); eauto with coqlib. - unfold nextinstr. rewrite Pregmap.gss. - rewrite <- H1; simpl. econstructor; eauto. - eapply code_tail_next_int; eauto. - apply agree_nextinstr. auto. - congruence. - - (* Mgoto *) assert (f0 = f) by congruence. subst f0. inv AT. monadInv H4. diff --git a/arm/Machregs.v b/arm/Machregs.v index f46f2904..f4bd4613 100644 --- a/arm/Machregs.v +++ b/arm/Machregs.v @@ -130,7 +130,7 @@ Fixpoint destroyed_by_clobber (cl: list string): list mreg := Definition destroyed_by_builtin (ef: external_function): list mreg := match ef with - | EF_memcpy sz al => if zle sz 32 then F7 :: nil else R2 :: R3 :: R12 :: nil + | EF_memcpy sz al => R2 :: R3 :: R12 :: F7 :: nil | EF_inline_asm txt sg clob => destroyed_by_clobber clob | _ => nil end. @@ -150,11 +150,7 @@ Definition mregs_for_operation (op: operation): list (option mreg) * option mreg end. Definition mregs_for_builtin (ef: external_function): list (option mreg) * list(option mreg) := - match ef with - | EF_memcpy sz al => - if zle sz 32 then (nil, nil) else (Some R3 :: Some R2 :: nil, nil) - | _ => (nil, nil) - end. + (nil, nil). Global Opaque destroyed_by_op destroyed_by_load destroyed_by_store @@ -171,3 +167,15 @@ Definition two_address_op (op: operation) : bool := Global Opaque two_address_op. +(* Constraints on constant propagation for builtins *) + +Definition builtin_constraints (ef: external_function) : + list builtin_arg_constraint := + match ef with + | EF_vload _ => OK_addrany :: nil + | EF_vstore _ => OK_addrany :: OK_default :: nil + | EF_memcpy _ _ => OK_addrstack :: OK_addrstack :: nil + | EF_annot txt targs => map (fun _ => OK_all) targs + | EF_debug kind txt targs => map (fun _ => OK_all) targs + | _ => nil + end. diff --git a/arm/SelectOp.vp b/arm/SelectOp.vp index fea99ef5..aec737ad 100644 --- a/arm/SelectOp.vp +++ b/arm/SelectOp.vp @@ -489,16 +489,18 @@ Nondetfunction addressing (chunk: memory_chunk) (e: expr) := | _ => (Aindexed Int.zero, e:::Enil) end. -(** ** Arguments of annotations *) +(** ** Arguments of builtins *) -Nondetfunction annot_arg (e: expr) := +Nondetfunction builtin_arg (e: expr) := match e with - | Eop (Ointconst n) Enil => AA_int n - | Eop (Oaddrsymbol id ofs) Enil => AA_addrglobal id ofs - | Eop (Oaddrstack ofs) Enil => AA_addrstack ofs + | Eop (Ointconst n) Enil => BA_int n + | Eop (Oaddrsymbol id ofs) Enil => BA_addrglobal id ofs + | Eop (Oaddrstack ofs) Enil => BA_addrstack ofs | Eop Omakelong (Eop (Ointconst h) Enil ::: Eop (Ointconst l) Enil ::: Enil) => - AA_long (Int64.ofwords h l) - | Eop Omakelong (h ::: l ::: Enil) => AA_longofwords (AA_base h) (AA_base l) - | Eload chunk (Ainstack ofs) Enil => AA_loadstack chunk ofs - | _ => AA_base e + BA_long (Int64.ofwords h l) + | Eop Omakelong (h ::: l ::: Enil) => BA_splitlong (BA h) (BA l) + | Eload chunk (Ainstack ofs) Enil => BA_loadstack chunk ofs + | Eload chunk (Aindexed ofs1) (Eop (Oaddrsymbol id ofs) Enil ::: Enil) => + BA_loadglobal chunk id (Int.add ofs ofs1) + | _ => BA e end. diff --git a/arm/SelectOpproof.v b/arm/SelectOpproof.v index d3c3239a..5f41e754 100644 --- a/arm/SelectOpproof.v +++ b/arm/SelectOpproof.v @@ -864,18 +864,20 @@ Proof. exists (v :: nil); split. eauto with evalexpr. subst. simpl. rewrite Int.add_zero; auto. Qed. -Theorem eval_annot_arg: +Theorem eval_builtin_arg: forall a v, eval_expr ge sp e m nil a v -> - CminorSel.eval_annot_arg ge sp e m (annot_arg a) v. + CminorSel.eval_builtin_arg ge sp e m (builtin_arg a) v. Proof. - intros until v. unfold annot_arg; case (annot_arg_match a); intros; InvEval. + intros until v. unfold builtin_arg; case (builtin_arg_match a); intros; InvEval. - constructor. - constructor. - constructor. - simpl in H5. inv H5. constructor. - subst v. constructor; auto. - inv H. InvEval. simpl in H6; inv H6. constructor; auto. +- inv H. InvEval. simpl in H6. rewrite <- Genv.shift_symbol_address in H6. + inv H6. constructor; auto. - constructor; auto. Qed. diff --git a/arm/TargetPrinter.ml b/arm/TargetPrinter.ml index 33071a9a..028ff6ed 100644 --- a/arm/TargetPrinter.ml +++ b/arm/TargetPrinter.ml @@ -305,17 +305,6 @@ module Target (Opt: PRINTER_OPTIONS) : TARGET = let print_location oc loc = if loc <> Cutil.no_loc then print_file_line oc (fst loc) (snd loc) -(* Handling of annotations *) - - let print_annot_stmt oc txt targs args = - if Str.string_match re_file_line txt 0 then begin - print_file_line oc (Str.matched_group 1 txt) - (int_of_string (Str.matched_group 2 txt)) - end else begin - fprintf oc "%s annotation: " comment; - print_annot_stmt preg "sp" oc txt targs args - end - (* Auxiliary for 64-bit integer arithmetic built-ins. They expand to two instructions, one computing the low 32 bits of the result, followed by another computing the high 32 bits. In cases where @@ -521,7 +510,7 @@ module Target (Opt: PRINTER_OPTIONS) : TARGET = fprintf oc " bic%t %a, %a, %a\n" thumbS ireg r1 ireg r2 shift_op so; 1 | Pclz (r1,r2) -> - fprintf oc " clz %a, %a\n" preg r1 preg r2; 1 + fprintf oc " clz %a, %a\n" ireg r1 ireg r2; 1 | Pcmp(r1, so) -> fprintf oc " cmp %a, %a\n" ireg r1 shift_op so; 1 | Pdmb -> @@ -571,9 +560,9 @@ module Target (Opt: PRINTER_OPTIONS) : TARGET = fprintf oc " orr%t %a, %a, %a\n" thumbS ireg r1 ireg r2 shift_op so; 1 | Prev (r1,r2) -> - fprintf oc " rev %a, %a\n" preg r1 preg r2; 1 + fprintf oc " rev %a, %a\n" ireg r1 ireg r2; 1 | Prev16 (r1,r2) -> - fprintf oc " rev16 %a, %a\n" preg r1 preg r2; 1 + fprintf oc " rev16 %a, %a\n" ireg r1 ireg r2; 1 | Prsb(r1, r2, so) -> fprintf oc " rsb%t %a, %a, %a\n" thumbS ireg r1 ireg r2 shift_op so; 1 @@ -782,6 +771,14 @@ module Target (Opt: PRINTER_OPTIONS) : TARGET = end | Pbuiltin(ef, args, res) -> begin match ef with + | EF_annot(txt, targs) -> + fprintf oc "%s annotation: " comment; + print_annot_text preg "sp" oc (extern_atom txt) args; + 0 + | EF_debug(kind, txt, targs) -> + print_debug_info comment print_file_line preg "sp" oc + (P.to_int kind) (extern_atom txt) args; + 0 | EF_inline_asm(txt, sg, clob) -> fprintf oc "%s begin inline assembly\n\t" comment; print_inline_asm preg oc (extern_atom txt) sg args res; @@ -790,13 +787,6 @@ module Target (Opt: PRINTER_OPTIONS) : TARGET = | _ -> assert false end - | Pannot(ef, args) -> - begin match ef with - | EF_annot(txt, targs) -> - print_annot_stmt oc (extern_atom txt) targs args; 0 - | _ -> - assert false - end | Pcfi_adjust sz -> cfi_adjust oc (camlint_of_coqint sz); 0 let no_fallthrough = function diff --git a/backend/Allocation.v b/backend/Allocation.v index 37b79a1a..196a4075 100644 --- a/backend/Allocation.v +++ b/backend/Allocation.v @@ -93,12 +93,10 @@ Inductive block_shape: Type := (mv1: moves) (ros': mreg + ident) (mv2: moves) (s: node) | BStailcall (sg: signature) (ros: reg + ident) (args: list reg) (mv1: moves) (ros': mreg + ident) - | BSbuiltin (ef: external_function) (args: list reg) (res: reg) - (mv1: moves) (args': list mreg) (res': list mreg) + | BSbuiltin (ef: external_function) + (args: list (builtin_arg reg)) (res: builtin_res reg) + (mv1: moves) (args': list (builtin_arg loc)) (res': builtin_res mreg) (mv2: moves) (s: node) - | BSannot (ef: external_function) - (args: list (annot_arg reg)) (args': list (annot_arg loc)) - (s: node) | BScond (cond: condition) (args: list reg) (mv: moves) (args': list mreg) (s1 s2: node) | BSjumptable (arg: reg) @@ -280,14 +278,6 @@ Definition pair_instr_block Some(BSbuiltin ef args res mv1 args' res' mv2 s) | _ => None end - | Iannot ef args s => - match b with - | Lannot ef' args' :: b1 => - assertion (external_function_eq ef ef'); - assertion (check_succ s b1); - Some(BSannot ef args args' s) - | _ => None - end | Icond cond args s1 s2 => let (mv1, b1) := extract_moves nil b in match b1 with @@ -699,54 +689,86 @@ Definition add_equation_ros (ros: reg + ident) (ros': mreg + ident) (e: eqs) : o | _, _ => None end. -(** [add_equations_annot_arg] adds the needed equations for annotation - arguments. *) +(** [add_equations_builtin_arg] adds the needed equations for arguments + to builtin functions. *) -Fixpoint add_equations_annot_arg (env: regenv) (arg: annot_arg reg) (arg': annot_arg loc) (e: eqs) : option eqs := +Fixpoint add_equations_builtin_arg + (env: regenv) (arg: builtin_arg reg) (arg': builtin_arg loc) (e: eqs) : option eqs := match arg, arg' with - | AA_base r, AA_base l => + | BA r, BA l => Some (add_equation (Eq Full r l) e) - | AA_base r, AA_longofwords (AA_base lhi) (AA_base llo) => + | BA r, BA_splitlong (BA lhi) (BA llo) => assertion (typ_eq (env r) Tlong); Some (add_equation (Eq Low r llo) (add_equation (Eq High r lhi) e)) - | AA_int n, AA_int n' => + | BA_int n, BA_int n' => assertion (Int.eq_dec n n'); Some e - | AA_long n, AA_long n' => + | BA_long n, BA_long n' => assertion (Int64.eq_dec n n'); Some e - | AA_float f, AA_float f' => + | BA_float f, BA_float f' => assertion (Float.eq_dec f f'); Some e - | AA_single f, AA_single f' => + | BA_single f, BA_single f' => assertion (Float32.eq_dec f f'); Some e - | AA_loadstack chunk ofs, AA_loadstack chunk' ofs' => + | BA_loadstack chunk ofs, BA_loadstack chunk' ofs' => assertion (chunk_eq chunk chunk'); assertion (Int.eq_dec ofs ofs'); Some e - | AA_addrstack ofs, AA_addrstack ofs' => + | BA_addrstack ofs, BA_addrstack ofs' => assertion (Int.eq_dec ofs ofs'); Some e - | AA_loadglobal chunk id ofs, AA_loadglobal chunk' id' ofs' => + | BA_loadglobal chunk id ofs, BA_loadglobal chunk' id' ofs' => assertion (chunk_eq chunk chunk'); assertion (ident_eq id id'); assertion (Int.eq_dec ofs ofs'); Some e - | AA_addrglobal id ofs, AA_addrglobal id' ofs' => + | BA_addrglobal id ofs, BA_addrglobal id' ofs' => assertion (ident_eq id id'); assertion (Int.eq_dec ofs ofs'); Some e - | AA_longofwords hi lo, AA_longofwords hi' lo' => - do e1 <- add_equations_annot_arg env hi hi' e; - add_equations_annot_arg env lo lo' e1 + | BA_splitlong hi lo, BA_splitlong hi' lo' => + do e1 <- add_equations_builtin_arg env hi hi' e; + add_equations_builtin_arg env lo lo' e1 | _, _ => None end. -Fixpoint add_equations_annot_args (env: regenv) - (args: list(annot_arg reg)) (args': list(annot_arg loc)) (e: eqs) : option eqs := +Fixpoint add_equations_builtin_args + (env: regenv) (args: list (builtin_arg reg)) + (args': list (builtin_arg loc)) (e: eqs) : option eqs := match args, args' with | nil, nil => Some e | a1 :: al, a1' :: al' => - do e1 <- add_equations_annot_arg env a1 a1' e; - add_equations_annot_args env al al' e1 + do e1 <- add_equations_builtin_arg env a1 a1' e; + add_equations_builtin_args env al al' e1 + | _, _ => None + end. + +(** For [EF_debug] builtins, some arguments can be removed. *) + +Fixpoint add_equations_debug_args + (env: regenv) (args: list (builtin_arg reg)) + (args': list (builtin_arg loc)) (e: eqs) : option eqs := + match args, args' with + | _, nil => Some e + | a1 :: al, a1' :: al' => + match add_equations_builtin_arg env a1 a1' e with + | None => add_equations_debug_args env al args' e + | Some e1 => add_equations_debug_args env al al' e1 + end + | _, _ => None + end. + +(** Checking of the result of a builtin *) + +Definition remove_equations_builtin_res + (env: regenv) (res: builtin_res reg) (res': builtin_res mreg) (e: eqs) : option eqs := + match res, res' with + | BR r, BR r' => Some (remove_equation (Eq Full r (R r')) e) + | BR r, BR_splitlong (BR rhi) (BR rlo) => + assertion (typ_eq (env r) Tlong); + if mreg_eq rhi rlo then None else + Some (remove_equation (Eq Low r (R rlo)) + (remove_equation (Eq High r (R rhi)) e)) + | BR_none, BR_none => Some e | _, _ => None end. @@ -972,16 +994,18 @@ Definition transfer_aux (f: RTL.function) (env: regenv) track_moves env mv1 e2 | BSbuiltin ef args res mv1 args' res' mv2 s => do e1 <- track_moves env mv2 e; - let args' := map R args' in - let res' := map R res' in - do e2 <- remove_equations_res res (sig_res (ef_sig ef)) res' e1; - assertion (reg_unconstrained res e2); - assertion (forallb (fun l => loc_unconstrained l e2) res'); + do e2 <- remove_equations_builtin_res env res res' e1; + assertion (forallb (fun r => reg_unconstrained r e2) + (params_of_builtin_res res)); + assertion (forallb (fun mr => loc_unconstrained (R mr) e2) + (params_of_builtin_res res')); assertion (can_undef (destroyed_by_builtin ef) e2); - do e3 <- add_equations_args args (sig_args (ef_sig ef)) args' e2; + do e3 <- + match ef with + | EF_debug _ _ _ => add_equations_debug_args env args args' e2 + | _ => add_equations_builtin_args env args args' e2 + end; track_moves env mv1 e3 - | BSannot ef args args' s => - add_equations_annot_args env args args' e | BScond cond args mv args' s1 s2 => assertion (can_undef (destroyed_by_cond cond) e); do e1 <- add_equations args args' e; @@ -1152,7 +1176,6 @@ Definition successors_block_shape (bsh: block_shape) : list node := | BScall sg ros args res mv1 ros' mv2 s => s :: nil | BStailcall sg ros args mv1 ros' => nil | BSbuiltin ef args res mv1 args' res' mv2 s => s :: nil - | BSannot ef args args' s => s :: nil | BScond cond args mv args' s1 s2 => s1 :: s2 :: nil | BSjumptable arg mv arg' tbl => tbl | BSreturn optarg mv => nil diff --git a/backend/Allocproof.v b/backend/Allocproof.v index 875d4929..57adf102 100644 --- a/backend/Allocproof.v +++ b/backend/Allocproof.v @@ -165,10 +165,6 @@ Inductive expand_block_shape: block_shape -> RTL.instruction -> LTL.bblock -> Pr (Ibuiltin ef args res s) (expand_moves mv1 (Lbuiltin ef args' res' :: expand_moves mv2 (Lbranch s :: k))) - | ebs_annot: forall ef args args' s k, - expand_block_shape (BSannot ef args args' s) - (Iannot ef args s) - (Lannot ef args' :: Lbranch s :: k) | ebs_cond: forall cond args mv args' s1 s2 k, wf_moves mv -> expand_block_shape (BScond cond args mv args' s1 s2) @@ -318,10 +314,8 @@ Proof. (* tailcall *) destruct b0; MonadInv. destruct i; MonadInv; UseParsingLemmas. econstructor; eauto. (* builtin *) - destruct b0; MonadInv. destruct i; MonadInv; UseParsingLemmas. + destruct b1; MonadInv. destruct i; MonadInv; UseParsingLemmas. econstructor; eauto. -(* annot *) - destruct b; MonadInv. destruct i; MonadInv. UseParsingLemmas. constructor. (* cond *) destruct b0; MonadInv. destruct i; MonadInv; UseParsingLemmas. econstructor; eauto. (* jumptable *) @@ -1347,9 +1341,9 @@ Proof. rewrite Int64.hi_ofwords, Int64.lo_ofwords; auto. Qed. -Lemma add_equations_annot_arg_satisf: +Lemma add_equations_builtin_arg_satisf: forall env rs ls arg arg' e e', - add_equations_annot_arg env arg arg' e = Some e' -> + add_equations_builtin_arg env arg arg' e = Some e' -> satisf rs ls e' -> satisf rs ls e. Proof. induction arg; destruct arg'; simpl; intros; MonadInv; eauto. @@ -1357,65 +1351,171 @@ Proof. destruct arg'1; MonadInv. destruct arg'2; MonadInv. eauto using add_equation_satisf. Qed. -Lemma add_equations_annot_arg_lessdef: +Lemma add_equations_builtin_arg_lessdef: forall env (ge: RTL.genv) sp rs ls m arg v, - eval_annot_arg ge (fun r => rs#r) sp m arg v -> + eval_builtin_arg ge (fun r => rs#r) sp m arg v -> forall e e' arg', - add_equations_annot_arg env arg arg' e = Some e' -> + add_equations_builtin_arg env arg arg' e = Some e' -> satisf rs ls e' -> wt_regset env rs -> - exists v', eval_annot_arg ge ls sp m arg' v' /\ Val.lessdef v v'. + exists v', eval_builtin_arg ge ls sp m arg' v' /\ Val.lessdef v v'. Proof. induction 1; simpl; intros e e' arg' AE SAT WT; destruct arg'; MonadInv. - exploit add_equation_lessdef; eauto. simpl; intros. - exists (ls x0); auto with aarg. + exists (ls x0); auto with barg. - destruct arg'1; MonadInv. destruct arg'2; MonadInv. exploit add_equation_lessdef. eauto. simpl; intros LD1. exploit add_equation_lessdef. eapply add_equation_satisf. eauto. simpl; intros LD2. - exists (Val.longofwords (ls x0) (ls x1)); split; auto with aarg. + exists (Val.longofwords (ls x0) (ls x1)); split; auto with barg. rewrite <- (val_longofwords_eq rs#x). apply Val.longofwords_lessdef; auto. rewrite <- e0; apply WT. -- econstructor; eauto with aarg. -- econstructor; eauto with aarg. -- econstructor; eauto with aarg. -- econstructor; eauto with aarg. -- econstructor; eauto with aarg. -- econstructor; eauto with aarg. -- econstructor; eauto with aarg. -- econstructor; eauto with aarg. -- exploit IHeval_annot_arg1; eauto. eapply add_equations_annot_arg_satisf; eauto. +- econstructor; eauto with barg. +- econstructor; eauto with barg. +- econstructor; eauto with barg. +- econstructor; eauto with barg. +- econstructor; eauto with barg. +- econstructor; eauto with barg. +- econstructor; eauto with barg. +- econstructor; eauto with barg. +- exploit IHeval_builtin_arg1; eauto. eapply add_equations_builtin_arg_satisf; eauto. intros (v1 & A & B). - exploit IHeval_annot_arg2; eauto. intros (v2 & C & D). - exists (Val.longofwords v1 v2); split; auto with aarg. apply Val.longofwords_lessdef; auto. + exploit IHeval_builtin_arg2; eauto. intros (v2 & C & D). + exists (Val.longofwords v1 v2); split; auto with barg. apply Val.longofwords_lessdef; auto. Qed. -Lemma add_equations_annot_args_satisf: +Lemma add_equations_builtin_args_satisf: forall env rs ls arg arg' e e', - add_equations_annot_args env arg arg' e = Some e' -> + add_equations_builtin_args env arg arg' e = Some e' -> satisf rs ls e' -> satisf rs ls e. Proof. - induction arg; destruct arg'; simpl; intros; MonadInv; eauto using add_equations_annot_arg_satisf. + induction arg; destruct arg'; simpl; intros; MonadInv; eauto using add_equations_builtin_arg_satisf. Qed. -Lemma add_equations_annot_args_lessdef: +Lemma add_equations_builtin_args_lessdef: forall env (ge: RTL.genv) sp rs ls m tm arg vl, - eval_annot_args ge (fun r => rs#r) sp m arg vl -> + eval_builtin_args ge (fun r => rs#r) sp m arg vl -> forall arg' e e', - add_equations_annot_args env arg arg' e = Some e' -> + add_equations_builtin_args env arg arg' e = Some e' -> satisf rs ls e' -> wt_regset env rs -> Mem.extends m tm -> - exists vl', eval_annot_args ge ls sp tm arg' vl' /\ Val.lessdef_list vl vl'. + exists vl', eval_builtin_args ge ls sp tm arg' vl' /\ Val.lessdef_list vl vl'. Proof. induction 1; simpl; intros; destruct arg'; MonadInv. - exists (@nil val); split; constructor. - exploit IHlist_forall2; eauto. intros (vl' & A & B). - exploit add_equations_annot_arg_lessdef; eauto. - eapply add_equations_annot_args_satisf; eauto. intros (v1' & C & D). - exploit (@eval_annot_arg_lessdef _ ge ls ls); eauto. intros (v1'' & E & F). + exploit add_equations_builtin_arg_lessdef; eauto. + eapply add_equations_builtin_args_satisf; eauto. intros (v1' & C & D). + exploit (@eval_builtin_arg_lessdef _ ge ls ls); eauto. intros (v1'' & E & F). exists (v1'' :: vl'); split; constructor; auto. eapply Val.lessdef_trans; eauto. Qed. +Lemma add_equations_debug_args_satisf: + forall env rs ls arg arg' e e', + add_equations_debug_args env arg arg' e = Some e' -> + satisf rs ls e' -> satisf rs ls e. +Proof. + induction arg; destruct arg'; simpl; intros; MonadInv; auto. + destruct (add_equations_builtin_arg env a b e) as [e1|] eqn:A; + eauto using add_equations_builtin_arg_satisf. +Qed. + +Lemma add_equations_debug_args_eval: + forall env (ge: RTL.genv) sp rs ls m tm arg vl, + eval_builtin_args ge (fun r => rs#r) sp m arg vl -> + forall arg' e e', + add_equations_debug_args env arg arg' e = Some e' -> + satisf rs ls e' -> + wt_regset env rs -> + Mem.extends m tm -> + exists vl', eval_builtin_args ge ls sp tm arg' vl'. +Proof. + induction 1; simpl; intros; destruct arg'; MonadInv. +- exists (@nil val); constructor. +- exists (@nil val); constructor. +- destruct (add_equations_builtin_arg env a1 b e) as [e1|] eqn:A. ++ exploit IHlist_forall2; eauto. intros (vl' & B). + exploit add_equations_builtin_arg_lessdef; eauto. + eapply add_equations_debug_args_satisf; eauto. intros (v1' & C & D). + exploit (@eval_builtin_arg_lessdef _ ge ls ls); eauto. intros (v1'' & E & F). + exists (v1'' :: vl'); constructor; auto. ++ eauto. +Qed. + +Lemma add_equations_builtin_eval: + forall ef env args args' e1 e2 m1 m1' rs ls (ge: RTL.genv) sp vargs t vres m2, + wt_regset env rs -> + match ef with + | EF_debug _ _ _ => add_equations_debug_args env args args' e1 + | _ => add_equations_builtin_args env args args' e1 + end = Some e2 -> + Mem.extends m1 m1' -> + satisf rs ls e2 -> + eval_builtin_args ge (fun r => rs # r) sp m1 args vargs -> + external_call ef ge vargs m1 t vres m2 -> + satisf rs ls e1 /\ + exists vargs' vres' m2', + eval_builtin_args ge ls sp m1' args' vargs' + /\ external_call ef ge vargs' m1' t vres' m2' + /\ Val.lessdef vres vres' + /\ Mem.extends m2 m2'. +Proof. + intros. + assert (DEFAULT: add_equations_builtin_args env args args' e1 = Some e2 -> + satisf rs ls e1 /\ + exists vargs' vres' m2', + eval_builtin_args ge ls sp m1' args' vargs' + /\ external_call ef ge vargs' m1' t vres' m2' + /\ Val.lessdef vres vres' + /\ Mem.extends m2 m2'). + { + intros. split. eapply add_equations_builtin_args_satisf; eauto. + exploit add_equations_builtin_args_lessdef; eauto. + intros (vargs' & A & B). + exploit external_call_mem_extends; eauto. + intros (vres' & m2' & C & D & E & F). + exists vargs', vres', m2'; auto. + } + destruct ef; auto. + split. eapply add_equations_debug_args_satisf; eauto. + exploit add_equations_debug_args_eval; eauto. + intros (vargs' & A). + simpl in H4; inv H4. + exists vargs', Vundef, m1'. intuition auto. simpl. constructor. +Qed. + +Lemma parallel_set_builtin_res_satisf: + forall env res res' e0 e1 rs ls v v', + remove_equations_builtin_res env res res' e0 = Some e1 -> + forallb (fun r => reg_unconstrained r e1) (params_of_builtin_res res) = true -> + forallb (fun mr => loc_unconstrained (R mr) e1) (params_of_builtin_res res') = true -> + satisf rs ls e1 -> + Val.lessdef v v' -> + satisf (regmap_setres res v rs) (Locmap.setres res' v' ls) e0. +Proof. + intros. rewrite forallb_forall in *. + destruct res, res'; simpl in *; inv H. +- apply parallel_assignment_satisf with (k := Full); auto. + unfold reg_loc_unconstrained. rewrite H0 by auto. rewrite H1 by auto. auto. +- destruct res'1; try discriminate. destruct res'2; try discriminate. + rename x0 into hi; rename x1 into lo. MonadInv. destruct (mreg_eq hi lo); inv H5. + set (e' := remove_equation {| ekind := High; ereg := x; eloc := R hi |} e0) in *. + set (e'' := remove_equation {| ekind := Low; ereg := x; eloc := R lo |} e') in *. + simpl in *. red; intros. + destruct (OrderedEquation.eq_dec q (Eq Low x (R lo))). + subst q; simpl. rewrite Regmap.gss. rewrite Locmap.gss. apply Val.loword_lessdef; auto. + destruct (OrderedEquation.eq_dec q (Eq High x (R hi))). + subst q; simpl. rewrite Regmap.gss. rewrite Locmap.gso by (red; auto). + rewrite Locmap.gss. apply Val.hiword_lessdef; auto. + assert (EqSet.In q e''). + { unfold e'', e', remove_equation; simpl; ESD.fsetdec. } + rewrite Regmap.gso. rewrite ! Locmap.gso. auto. + eapply loc_unconstrained_sound; eauto. + eapply loc_unconstrained_sound; eauto. + eapply reg_unconstrained_sound; eauto. +- auto. +Qed. + (** * Properties of the dataflow analysis *) Lemma analyze_successors: @@ -2071,29 +2171,22 @@ Proof. rewrite SIG. inv WTI. rewrite <- H6. apply wt_regset_list; auto. (* builtin *) -- assert (WTRS': wt_regset env (rs#res <- v)) by (eapply wt_exec_Ibuiltin; eauto). - exploit (exec_moves mv1); eauto. intros [ls1 [A1 B1]]. - exploit external_call_mem_extends; eauto. - eapply add_equations_args_lessdef; eauto. - inv WTI. rewrite <- H4. apply wt_regset_list; auto. - intros [v' [m'' [F [G [J K]]]]]. - assert (E: map ls1 (map R args') = reglist ls1 args'). - { unfold reglist. rewrite list_map_compose. auto. } - rewrite E in F. clear E. - set (vl' := encode_long (sig_res (ef_sig ef)) v'). - set (ls2 := Locmap.setlist (map R res') vl' (undef_regs (destroyed_by_builtin ef) ls1)). - assert (satisf (rs#res <- v) ls2 e0). - { eapply parallel_assignment_satisf_2; eauto. - eapply can_undef_satisf; eauto. - eapply add_equations_args_satisf; eauto. } +- exploit (exec_moves mv1); eauto. intros [ls1 [A1 B1]]. + exploit add_equations_builtin_eval; eauto. + intros (C & vargs' & vres' & m'' & D & E & F & G). + assert (WTRS': wt_regset env (regmap_setres res vres rs)) by (eapply wt_exec_Ibuiltin; eauto). + set (ls2 := Locmap.setres res' vres' (undef_regs (destroyed_by_builtin ef) ls1)). + assert (satisf (regmap_setres res vres rs) ls2 e0). + { eapply parallel_set_builtin_res_satisf; eauto. + eapply can_undef_satisf; eauto. } exploit (exec_moves mv2); eauto. intros [ls3 [A3 B3]]. econstructor; split. eapply plus_left. econstructor; eauto. eapply star_trans. eexact A1. - eapply star_left. econstructor. - econstructor. unfold reglist. eapply external_call_symbols_preserved; eauto. + eapply star_left. econstructor. + eapply eval_builtin_args_preserved with (ge1 := ge); eauto. exact symbols_preserved. + eapply external_call_symbols_preserved. eauto. exact symbols_preserved. exact public_preserved. exact varinfo_preserved. - instantiate (1 := vl'); auto. instantiate (1 := ls2); auto. eapply star_right. eexact A3. econstructor. @@ -2101,23 +2194,6 @@ Proof. exploit satisf_successors; eauto. simpl; eauto. intros [enext [U V]]. econstructor; eauto. - -(* annot *) -- exploit add_equations_annot_args_lessdef; eauto. - intros (vargs' & A & B). - exploit external_call_mem_extends; eauto. - intros [vres' [m'' [F [G [J K]]]]]. - econstructor; split. - eapply plus_left. econstructor; eauto. - eapply star_two. econstructor. - eapply eval_annot_args_preserved with (ge1 := ge); eauto. exact symbols_preserved. - eapply external_call_symbols_preserved with (ge1 := ge); eauto. - exact symbols_preserved. exact public_preserved. exact varinfo_preserved. - constructor. eauto. traceEq. - exploit satisf_successors. eauto. eauto. simpl; eauto. eauto. - eapply add_equations_annot_args_satisf; eauto. - intros [enext [U V]]. - econstructor; eauto. (* cond *) - exploit (exec_moves mv); eauto. intros [ls1 [A1 B1]]. diff --git a/backend/Asmgenproof0.v b/backend/Asmgenproof0.v index ba7fa3a6..0533d561 100644 --- a/backend/Asmgenproof0.v +++ b/backend/Asmgenproof0.v @@ -356,29 +356,55 @@ Proof. eapply extcall_args_match; eauto. Qed. -(** Translation of arguments to annotations. *) +(** Translation of arguments and results to builtins. *) -Remark annot_arg_match: +Remark builtin_arg_match: forall ge (rs: regset) sp m a v, - eval_annot_arg ge (fun r => rs (preg_of r)) sp m a v -> - eval_annot_arg ge rs sp m (map_annot_arg preg_of a) v. + eval_builtin_arg ge (fun r => rs (preg_of r)) sp m a v -> + eval_builtin_arg ge rs sp m (map_builtin_arg preg_of a) v. Proof. - induction 1; simpl; eauto with aarg. + induction 1; simpl; eauto with barg. Qed. -Lemma annot_args_match: +Lemma builtin_args_match: forall ge ms sp rs m m', agree ms sp rs -> Mem.extends m m' -> - forall al vl, eval_annot_args ge ms sp m al vl -> - exists vl', eval_annot_args ge rs sp m' (map (map_annot_arg preg_of) al) vl' + forall al vl, eval_builtin_args ge ms sp m al vl -> + exists vl', eval_builtin_args ge rs sp m' (map (map_builtin_arg preg_of) al) vl' /\ Val.lessdef_list vl vl'. Proof. induction 3; intros; simpl. exists (@nil val); split; constructor. - exploit (@eval_annot_arg_lessdef _ ge ms (fun r => rs (preg_of r))); eauto. + exploit (@eval_builtin_arg_lessdef _ ge ms (fun r => rs (preg_of r))); eauto. intros; eapply preg_val; eauto. intros (v1' & A & B). destruct IHlist_forall2 as [vl' [C D]]. - exists (v1' :: vl'); split; constructor; auto. apply annot_arg_match; auto. + exists (v1' :: vl'); split; constructor; auto. apply builtin_arg_match; auto. +Qed. + +Lemma agree_set_res: + forall res ms sp rs v v', + agree ms sp rs -> + Val.lessdef v v' -> + agree (Mach.set_res res v ms) sp (Asm.set_res (map_builtin_res preg_of res) v' rs). +Proof. + induction res; simpl; intros. +- eapply agree_set_mreg; eauto. rewrite Pregmap.gss. auto. + intros. apply Pregmap.gso; auto. +- auto. +- apply IHres2. apply IHres1. auto. + apply Val.hiword_lessdef; auto. + apply Val.loword_lessdef; auto. +Qed. + +Lemma set_res_other: + forall r res v rs, + data_preg r = false -> + set_res (map_builtin_res preg_of res) v rs r = rs r. +Proof. + induction res; simpl; intros. +- apply Pregmap.gso. red; intros; subst r. rewrite preg_of_data in H; discriminate. +- auto. +- rewrite IHres2, IHres1; auto. Qed. (** * Correspondence between Mach code and Asm code *) diff --git a/backend/Bounds.v b/backend/Bounds.v index 04c1328d..beb29965 100644 --- a/backend/Bounds.v +++ b/backend/Bounds.v @@ -67,9 +67,8 @@ Definition instr_within_bounds (i: instruction) := | Lload chunk addr args dst => mreg_within_bounds dst | Lcall sig ros => size_arguments sig <= bound_outgoing b | Lbuiltin ef args res => - forall r, In r res \/ In r (destroyed_by_builtin ef) -> mreg_within_bounds r - | Lannot ef args => - forall sl ofs ty, In (S sl ofs ty) (params_of_annot_args args) -> slot_within_bounds sl ofs ty + (forall r, In r (params_of_builtin_res res) \/ In r (destroyed_by_builtin ef) -> mreg_within_bounds r) + /\ (forall sl ofs ty, In (S sl ofs ty) (params_of_builtin_args args) -> slot_within_bounds sl ofs ty) | _ => True end. @@ -101,8 +100,7 @@ Definition regs_of_instr (i: instruction) : list mreg := | Lstore chunk addr args src => nil | Lcall sig ros => nil | Ltailcall sig ros => nil - | Lbuiltin ef args res => res ++ destroyed_by_builtin ef - | Lannot ef args => nil + | Lbuiltin ef args res => params_of_builtin_res res ++ destroyed_by_builtin ef | Llabel lbl => nil | Lgoto lbl => nil | Lcond cond args lbl => nil @@ -121,7 +119,7 @@ Definition slots_of_instr (i: instruction) : list (slot * Z * typ) := match i with | Lgetstack sl ofs ty r => (sl, ofs, ty) :: nil | Lsetstack r sl ofs ty => (sl, ofs, ty) :: nil - | Lannot ef args => slots_of_locs (params_of_annot_args args) + | Lbuiltin ef args res => slots_of_locs (params_of_builtin_args args) | _ => nil end. @@ -351,8 +349,8 @@ Proof. (* call *) eapply size_arguments_bound; eauto. (* builtin *) + split; intros. apply H1. apply in_or_app; auto. -(* annot *) apply H0. rewrite slots_of_locs_charact; auto. Qed. diff --git a/backend/CMparser.mly b/backend/CMparser.mly index f62e05d4..b48a486e 100644 --- a/backend/CMparser.mly +++ b/backend/CMparser.mly @@ -42,12 +42,6 @@ let mkef sg toks = EF_vload c | [EFT_tok "volatile"; EFT_tok "store"; EFT_chunk c] -> EF_vstore c - | [EFT_tok "volatile"; EFT_tok "load"; EFT_chunk c; - EFT_tok "global"; EFT_string s; EFT_int n] -> - EF_vload_global(c, intern_string s, coqint_of_camlint n) - | [EFT_tok "volatile"; EFT_tok "store"; EFT_chunk c; - EFT_tok "global"; EFT_string s; EFT_int n] -> - EF_vstore_global(c, intern_string s, coqint_of_camlint n) | [EFT_tok "malloc"] -> EF_malloc | [EFT_tok "free"] -> diff --git a/backend/CSE.v b/backend/CSE.v index c0efa941..ebeb921e 100644 --- a/backend/CSE.v +++ b/backend/CSE.v @@ -228,6 +228,12 @@ Definition set_unknown (n: numbering) (rd: reg) := num_reg := PTree.remove rd n.(num_reg); num_val := forget_reg n rd |}. +Definition set_res_unknown (n: numbering) (res: builtin_res reg) := + match res with + | BR r => set_unknown n r + | _ => n + end. + (** [kill_equations pred n] remove all equations satisfying predicate [pred]. *) Fixpoint kill_eqs (pred: rhs -> bool) (eqs: list equation) : list equation := @@ -307,16 +313,15 @@ Definition add_store_result (app: VA.t) (n: numbering) (chunk: memory_chunk) (ad num_val := n2.(num_val) |} else n. -(** [kill_loads_after_storebyte app n dst sz] removes all equations +(** [kill_loads_after_storebyte n dst sz] removes all equations involving loads that could be invalidated by a store of [sz] bytes starting at address [dst]. Loads that are disjoint from this store-bytes are preserved. Equations involving memory-dependent operators are also removed. *) Definition kill_loads_after_storebytes - (app: VA.t) (n: numbering) (dst: reg) (sz: Z) := - let p := aaddr app dst in - kill_equations (filter_after_store app n p sz) n. + (app: VA.t) (n: numbering) (dst: aptr) (sz: Z) := + kill_equations (filter_after_store app n dst sz) n. (** [add_memcpy app n1 n2 rsrc rdst sz] adds equations to [n2] that represent the effect of a [memcpy] block copy operation of [sz] bytes @@ -355,8 +360,8 @@ Fixpoint add_memcpy_eqs (src sz delta: Z) (eqs1 eqs2: list equation) := end end. -Definition add_memcpy (app: VA.t) (n1 n2: numbering) (rsrc rdst: reg) (sz: Z) := - match aaddr app rsrc, aaddr app rdst with +Definition add_memcpy (n1 n2: numbering) (asrc adst: aptr) (sz: Z) := + match asrc, adst with | Stk src, Stk dst => {| num_next := n2.(num_next); num_eqs := add_memcpy_eqs (Int.unsigned src) sz @@ -478,22 +483,22 @@ Definition transfer (f: function) (approx: PMap.t VA.t) (pc: node) (before: numb match ef with | EF_external _ _ | EF_malloc | EF_free | EF_inline_asm _ _ _ => empty_numbering - | EF_builtin _ _ | EF_vstore _ | EF_vstore_global _ _ _ => - set_unknown (kill_all_loads before) res + | EF_builtin _ _ | EF_vstore _ => + set_res_unknown (kill_all_loads before) res | EF_memcpy sz al => match args with - | rdst :: rsrc :: nil => + | dst :: src :: nil => let app := approx!!pc in - let n := kill_loads_after_storebytes app before rdst sz in - set_unknown (add_memcpy app before n rsrc rdst sz) res + let adst := aaddr_arg app dst in + let asrc := aaddr_arg app src in + let n := kill_loads_after_storebytes app before adst sz in + set_res_unknown (add_memcpy before n asrc adst sz) res | _ => empty_numbering end - | EF_vload _ | EF_vload_global _ _ _ | EF_annot _ _ | EF_annot_val _ _ => - set_unknown before res + | EF_vload _ | EF_annot _ _ | EF_annot_val _ _ | EF_debug _ _ _ => + set_res_unknown before res end - | Iannot ef args s => - before | Icond cond args ifso ifnot => before | Ijumptable arg tbl => diff --git a/backend/CSEproof.v b/backend/CSEproof.v index c24fa69b..70f9bfc7 100644 --- a/backend/CSEproof.v +++ b/backend/CSEproof.v @@ -419,6 +419,14 @@ Proof. rewrite Regmap.gso; eauto with cse. Qed. +Lemma set_res_unknown_holds: + forall valu ge sp rs m n r v, + numbering_holds valu ge sp rs m n -> + numbering_holds valu ge sp (regmap_setres r v rs) m (set_res_unknown n r). +Proof. + intros. destruct r; simpl; auto. apply set_unknown_holds; auto. +Qed. + Lemma kill_eqs_charact: forall pred l strict r eqs, In (Eq l strict r) (kill_eqs pred eqs) -> @@ -533,7 +541,7 @@ Qed. Lemma kill_loads_after_storebytes_holds: forall valu ge sp rs m n dst b ofs bytes m' bc approx ae am sz, numbering_holds valu ge (Vptr sp Int.zero) rs m n -> - rs#dst = Vptr b ofs -> + pmatch bc b ofs dst -> Mem.storebytes m b (Int.unsigned ofs) bytes = Some m' -> genv_match bc ge -> bc sp = BCstack -> @@ -556,7 +564,7 @@ Proof. eapply pdisjoint_sound. eauto. unfold aaddressing. apply match_aptr_of_aval. eapply eval_static_addressing_sound; eauto. erewrite <- regs_valnums_sound by eauto. eauto with va. - unfold aaddr. apply match_aptr_of_aval. rewrite <- H0. apply H4. + auto. Qed. Lemma load_memcpy: @@ -675,33 +683,25 @@ Proof. Qed. Lemma add_memcpy_holds: - forall m bsrc osrc sz bytes bdst odst m' valu ge sp rs n1 n2 bc approx ae am rsrc rdst, + forall m bsrc osrc sz bytes bdst odst m' valu ge sp rs n1 n2 bc asrc adst, Mem.loadbytes m bsrc (Int.unsigned osrc) sz = Some bytes -> Mem.storebytes m bdst (Int.unsigned odst) bytes = Some m' -> numbering_holds valu ge (Vptr sp Int.zero) rs m n1 -> numbering_holds valu ge (Vptr sp Int.zero) rs m' n2 -> - genv_match bc ge -> + pmatch bc bsrc osrc asrc -> + pmatch bc bdst odst adst -> bc sp = BCstack -> - ematch bc rs ae -> - approx = VA.State ae am -> - rs#rsrc = Vptr bsrc osrc -> - rs#rdst = Vptr bdst odst -> Ple (num_next n1) (num_next n2) -> - numbering_holds valu ge (Vptr sp Int.zero) rs m' (add_memcpy approx n1 n2 rsrc rdst sz). + numbering_holds valu ge (Vptr sp Int.zero) rs m' (add_memcpy n1 n2 asrc adst sz). Proof. intros. unfold add_memcpy. - destruct (aaddr approx rsrc) eqn:ASRC; auto. - destruct (aaddr approx rdst) eqn:ADST; auto. - assert (A: forall r b o i, - rs#r = Vptr b o -> aaddr approx r = Stk i -> b = sp /\ i = o). + destruct asrc; auto; destruct adst; auto. + assert (A: forall b o i, pmatch bc b o (Stk i) -> b = sp /\ i = o). { - intros until i. unfold aaddr; subst approx. intros. - specialize (H5 r). rewrite H6 in H5. apply match_aptr_of_aval in H5. - rewrite H10 in H5. inv H5. split; auto. eapply bc_stack; eauto. + intros. inv H7. split; auto. eapply bc_stack; eauto. } - exploit (A rsrc); eauto. intros [P Q]. - exploit (A rdst); eauto. intros [U V]. - subst bsrc ofs bdst ofs0. + apply A in H3; destruct H3. subst bsrc ofs. + apply A in H4; destruct H4. subst bdst ofs0. constructor; simpl; intros; eauto with cse. - constructor; simpl; eauto with cse. intros. exploit add_memcpy_eqs_charact; eauto. intros [X | (e0 & X & Y)]. @@ -1102,62 +1102,51 @@ Proof. apply regs_lessdef_regs; auto. - (* Ibuiltin *) + exploit (@eval_builtin_args_lessdef _ ge (fun r => rs#r) (fun r => rs'#r)); eauto. + intros (vargs' & A & B). exploit external_call_mem_extends; eauto. - instantiate (1 := rs'##args). apply regs_lessdef_regs; auto. intros (v' & m1' & P & Q & R & S). econstructor; split. - eapply exec_Ibuiltin; eauto. + eapply exec_Ibuiltin; eauto. + eapply eval_builtin_args_preserved with (ge1 := ge); eauto. exact symbols_preserved. eapply external_call_symbols_preserved; eauto. exact symbols_preserved. exact public_preserved. exact varinfo_preserved. econstructor; eauto. eapply analysis_correct_1; eauto. simpl; auto. * unfold transfer; rewrite H. destruct SAT as [valu NH]. - assert (CASE1: exists valu, numbering_holds valu ge sp (rs#res <- v) m' empty_numbering). + assert (CASE1: exists valu, numbering_holds valu ge sp (regmap_setres res vres rs) m' empty_numbering). { exists valu; apply empty_numbering_holds. } - assert (CASE2: m' = m -> exists valu, numbering_holds valu ge sp (rs#res <- v) m' (set_unknown approx#pc res)). - { intros. rewrite H1. exists valu. apply set_unknown_holds; auto. } - assert (CASE3: exists valu, numbering_holds valu ge sp (rs#res <- v) m' - (set_unknown (kill_all_loads approx#pc) res)). - { exists valu. apply set_unknown_holds. eapply kill_all_loads_hold; eauto. } + assert (CASE2: m' = m -> exists valu, numbering_holds valu ge sp (regmap_setres res vres rs) m' (set_res_unknown approx#pc res)). + { intros. subst m'. exists valu. apply set_res_unknown_holds; auto. } + assert (CASE3: exists valu, numbering_holds valu ge sp (regmap_setres res vres rs) m' + (set_res_unknown (kill_all_loads approx#pc) res)). + { exists valu. apply set_res_unknown_holds. eapply kill_all_loads_hold; eauto. } destruct ef. + apply CASE1. + apply CASE3. - + apply CASE2; inv H0; auto. + + apply CASE2; inv H1; auto. + apply CASE3. - + apply CASE2; inv H0; auto. - + apply CASE3; auto. + apply CASE1. + apply CASE1. - + destruct args as [ | rdst args]; auto. - destruct args as [ | rsrc args]; auto. - destruct args; auto. - simpl in H0. inv H0. - exists valu. - apply set_unknown_holds. - inv SOUND. eapply add_memcpy_holds; eauto. + + inv H0; auto. inv H3; auto. inv H4; auto. + simpl in H1. inv H1. + exists valu. + apply set_res_unknown_holds. + inv SOUND. unfold vanalyze, rm; rewrite AN. + assert (pmatch bc bsrc osrc (aaddr_arg (VA.State ae am) a0)) + by (eapply aaddr_arg_sound_1; eauto). + assert (pmatch bc bdst odst (aaddr_arg (VA.State ae am) a1)) + by (eapply aaddr_arg_sound_1; eauto). + eapply add_memcpy_holds; eauto. eapply kill_loads_after_storebytes_holds; eauto. eapply Mem.loadbytes_length; eauto. simpl. apply Ple_refl. - + apply CASE2; inv H0; auto. - + apply CASE2; inv H0; auto. + + apply CASE2; inv H1; auto. + + apply CASE2; inv H1; auto. + apply CASE1. -* apply set_reg_lessdef; auto. - -- (* Iannot *) - exploit (@eval_annot_args_lessdef _ ge (fun r => rs#r) (fun r => rs'#r)); eauto. - intros (vargs' & A & B). - exploit external_call_mem_extends; eauto. - intros (v' & m1' & P & Q & R & S). - econstructor; split. - eapply exec_Iannot; eauto. - eapply eval_annot_args_preserved with (ge1 := ge); eauto. exact symbols_preserved. - eapply external_call_symbols_preserved; eauto. - exact symbols_preserved. exact public_preserved. exact varinfo_preserved. - econstructor; eauto. - eapply analysis_correct_1; eauto. simpl; auto. - unfold transfer; rewrite H. replace m' with m; auto. - destruct ef; try contradiction. inv H2; auto. + + apply CASE2; inv H1; auto. +* apply set_res_lessdef; auto. - (* Icond *) destruct (valnum_regs approx!!pc args) as [n1 vl] eqn:?. diff --git a/backend/CleanupLabelsproof.v b/backend/CleanupLabelsproof.v index d48a0553..1e93dd7a 100644 --- a/backend/CleanupLabelsproof.v +++ b/backend/CleanupLabelsproof.v @@ -291,15 +291,11 @@ Proof. econstructor; eauto. (* Lbuiltin *) left; econstructor; split. - econstructor; eauto. eapply external_call_symbols_preserved'; eauto. - exact symbols_preserved. exact public_preserved. exact varinfo_preserved. - econstructor; eauto with coqlib. -(* Lannot *) - left; econstructor; split. - econstructor; eauto. - eapply eval_annot_args_preserved with (ge1 := ge); eauto. exact symbols_preserved. + econstructor. + eapply eval_builtin_args_preserved with (ge1 := ge); eauto. exact symbols_preserved. eapply external_call_symbols_preserved; eauto. exact symbols_preserved. exact public_preserved. exact varinfo_preserved. + eauto. econstructor; eauto with coqlib. (* Llabel *) case_eq (Labelset.mem lbl (labels_branched_to (fn_code f))); intros. diff --git a/backend/CminorSel.v b/backend/CminorSel.v index 668eb808..6a43eccd 100644 --- a/backend/CminorSel.v +++ b/backend/CminorSel.v @@ -78,8 +78,7 @@ Inductive stmt : Type := | Sstore : memory_chunk -> addressing -> exprlist -> expr -> stmt | Scall : option ident -> signature -> expr + ident -> exprlist -> stmt | Stailcall: signature -> expr + ident -> exprlist -> stmt - | Sbuiltin : option ident -> external_function -> exprlist -> stmt - | Sannot : external_function -> list (annot_arg expr) -> stmt + | Sbuiltin : builtin_res ident -> external_function -> list (builtin_arg expr) -> stmt | Sseq: stmt -> stmt -> stmt | Sifthenelse: condexpr -> stmt -> stmt -> stmt | Sloop: stmt -> stmt @@ -249,34 +248,42 @@ Inductive eval_expr_or_symbol: letenv -> expr + ident -> val -> Prop := Genv.find_symbol ge id = Some b -> eval_expr_or_symbol le (inr _ id) (Vptr b Int.zero). -Inductive eval_annot_arg: annot_arg expr -> val -> Prop := - | eval_AA_base: forall a v, +Inductive eval_builtin_arg: builtin_arg expr -> val -> Prop := + | eval_BA: forall a v, eval_expr nil a v -> - eval_annot_arg (AA_base a) v - | eval_AA_int: forall n, - eval_annot_arg (AA_int n) (Vint n) - | eval_AA_long: forall n, - eval_annot_arg (AA_long n) (Vlong n) - | eval_AA_float: forall n, - eval_annot_arg (AA_float n) (Vfloat n) - | eval_AA_single: forall n, - eval_annot_arg (AA_single n) (Vsingle n) - | eval_AA_loadstack: forall chunk ofs v, + eval_builtin_arg (BA a) v + | eval_BA_int: forall n, + eval_builtin_arg (BA_int n) (Vint n) + | eval_BA_long: forall n, + eval_builtin_arg (BA_long n) (Vlong n) + | eval_BA_float: forall n, + eval_builtin_arg (BA_float n) (Vfloat n) + | eval_BA_single: forall n, + eval_builtin_arg (BA_single n) (Vsingle n) + | eval_BA_loadstack: forall chunk ofs v, Mem.loadv chunk m (Val.add sp (Vint ofs)) = Some v -> - eval_annot_arg (AA_loadstack chunk ofs) v - | eval_AA_addrstack: forall ofs, - eval_annot_arg (AA_addrstack ofs) (Val.add sp (Vint ofs)) - | eval_AA_loadglobal: forall chunk id ofs v, + eval_builtin_arg (BA_loadstack chunk ofs) v + | eval_BA_addrstack: forall ofs, + eval_builtin_arg (BA_addrstack ofs) (Val.add sp (Vint ofs)) + | eval_BA_loadglobal: forall chunk id ofs v, Mem.loadv chunk m (Genv.symbol_address ge id ofs) = Some v -> - eval_annot_arg (AA_loadglobal chunk id ofs) v - | eval_AA_addrglobal: forall id ofs, - eval_annot_arg (AA_addrglobal id ofs) (Genv.symbol_address ge id ofs) - | eval_AA_longofwords: forall a1 a2 v1 v2, + eval_builtin_arg (BA_loadglobal chunk id ofs) v + | eval_BA_addrglobal: forall id ofs, + eval_builtin_arg (BA_addrglobal id ofs) (Genv.symbol_address ge id ofs) + | eval_BA_splitlong: forall a1 a2 v1 v2, eval_expr nil a1 v1 -> eval_expr nil a2 v2 -> - eval_annot_arg (AA_longofwords (AA_base a1) (AA_base a2)) (Val.longofwords v1 v2). + eval_builtin_arg (BA_splitlong (BA a1) (BA a2)) (Val.longofwords v1 v2). End EVAL_EXPR. +(** Update local environment with the result of a builtin. *) + +Definition set_builtin_res (res: builtin_res ident) (v: val) (e: env) : env := + match res with + | BR id => PTree.set id v e + | _ => e + end. + (** Pop continuation until a call or stop *) Fixpoint call_cont (k: cont) : cont := @@ -364,18 +371,11 @@ Inductive step: state -> trace -> state -> Prop := step (State f (Stailcall sig a bl) k (Vptr sp Int.zero) e m) E0 (Callstate fd vargs (call_cont k) m') - | step_builtin: forall f optid ef al k sp e m vl t v m', - eval_exprlist sp e m nil al vl -> - external_call ef ge vl m t v m' -> - step (State f (Sbuiltin optid ef al) k sp e m) - t (State f Sskip k sp (set_optvar optid v e) m') - - | step_annot: forall f ef al k sp e m vl t v m', - match ef with EF_annot _ _ => True | _ => False end -> - list_forall2 (eval_annot_arg sp e m) al vl -> + | step_builtin: forall f res ef al k sp e m vl t v m', + list_forall2 (eval_builtin_arg sp e m) al vl -> external_call ef ge vl m t v m' -> - step (State f (Sannot ef al) k sp e m) - t (State f Sskip k sp e m') + step (State f (Sbuiltin res ef al) k sp e m) + t (State f Sskip k sp (set_builtin_res res v e) m') | step_seq: forall f s1 s2 k sp e m, step (State f (Sseq s1 s2) k sp e m) diff --git a/backend/Constprop.v b/backend/Constprop.v index ce56ff62..cd844d30 100644 --- a/backend/Constprop.v +++ b/backend/Constprop.v @@ -20,6 +20,7 @@ Require Import AST. Require Import Integers. Require Import Floats. Require Import Op. +Require Machregs. Require Import Registers. Require Import RTL. Require Import Lattice. @@ -102,39 +103,58 @@ Definition num_iter := 10%nat. Definition successor (f: function) (ae: AE.t) (pc: node) : node := successor_rec num_iter f ae pc. -Fixpoint annot_strength_reduction (ae: AE.t) (a: annot_arg reg) := +Fixpoint builtin_arg_reduction (ae: AE.t) (a: builtin_arg reg) := match a with - | AA_base r => + | BA r => match areg ae r with - | I n => AA_int n - | L n => AA_long n - | F n => if Compopts.generate_float_constants tt then AA_float n else a - | FS n => if Compopts.generate_float_constants tt then AA_single n else a + | I n => BA_int n + | L n => BA_long n + | F n => if Compopts.generate_float_constants tt then BA_float n else a + | FS n => if Compopts.generate_float_constants tt then BA_single n else a | _ => a end - | AA_longofwords hi lo => - match annot_strength_reduction ae hi, annot_strength_reduction ae lo with - | AA_int nhi, AA_int nlo => AA_long (Int64.ofwords nhi nlo) - | hi', lo' => AA_longofwords hi' lo' + | BA_splitlong hi lo => + match builtin_arg_reduction ae hi, builtin_arg_reduction ae lo with + | BA_int nhi, BA_int nlo => BA_long (Int64.ofwords nhi nlo) + | hi', lo' => BA_splitlong hi' lo' end | _ => a end. -Function builtin_strength_reduction - (ae: AE.t) (ef: external_function) (args: list reg) := - match ef, args with - | EF_vload chunk, r1 :: nil => - match areg ae r1 with - | Ptr(Gl symb n1) => (EF_vload_global chunk symb n1, nil) - | _ => (ef, args) - end - | EF_vstore chunk, r1 :: r2 :: nil => - match areg ae r1 with - | Ptr(Gl symb n1) => (EF_vstore_global chunk symb n1, r2 :: nil) - | _ => (ef, args) +Definition builtin_arg_strength_reduction + (ae: AE.t) (a: builtin_arg reg) (c: builtin_arg_constraint) := + let a' := builtin_arg_reduction ae a in + if builtin_arg_ok a' c then a' else a. + +Fixpoint builtin_args_strength_reduction + (ae: AE.t) (al: list (builtin_arg reg)) (cl: list builtin_arg_constraint) := + match al with + | nil => nil + | a :: al => + builtin_arg_strength_reduction ae a (List.hd OK_default cl) + :: builtin_args_strength_reduction ae al (List.tl cl) + end. + +(** For debug annotations, add constant values to the original info + instead of replacing it. *) + +Fixpoint debug_strength_reduction (ae: AE.t) (al: list (builtin_arg reg)) := + match al with + | nil => nil + | a :: al => + let a' := builtin_arg_reduction ae a in + let al' := a :: debug_strength_reduction ae al in + match a' with + | BA_int _ | BA_long _ | BA_float _ | BA_single _ => a' :: al' + | _ => al' end - | _, _ => - (ef, args) + end. + +Definition builtin_strength_reduction + (ae: AE.t) (ef: external_function) (al: list (builtin_arg reg)) := + match ef with + | EF_debug _ _ _ => debug_strength_reduction ae al + | _ => builtin_args_strength_reduction ae al (Machregs.builtin_constraints ef) end. Definition transf_instr (f: function) (an: PMap.t VA.t) (rm: romem) @@ -174,10 +194,7 @@ Definition transf_instr (f: function) (an: PMap.t VA.t) (rm: romem) | Itailcall sig ros args => Itailcall sig (transf_ros ae ros) args | Ibuiltin ef args res s => - let (ef', args') := builtin_strength_reduction ae ef args in - Ibuiltin ef' args' res s - | Iannot ef args s => - Iannot ef (List.map (annot_strength_reduction ae) args) s + Ibuiltin ef (builtin_strength_reduction ae ef args) res s | Icond cond args s1 s2 => let aargs := aregs ae args in match resolve_branch (eval_static_condition cond aargs) with diff --git a/backend/Constpropproof.v b/backend/Constpropproof.v index 30bdd674..d9005f5e 100644 --- a/backend/Constpropproof.v +++ b/backend/Constpropproof.v @@ -93,24 +93,6 @@ Proof. intros. destruct f; reflexivity. Qed. -Definition regs_lessdef (rs1 rs2: regset) : Prop := - forall r, Val.lessdef (rs1#r) (rs2#r). - -Lemma regs_lessdef_regs: - forall rs1 rs2, regs_lessdef rs1 rs2 -> - forall rl, Val.lessdef_list rs1##rl rs2##rl. -Proof. - induction rl; constructor; auto. -Qed. - -Lemma set_reg_lessdef: - forall r v1 v2 rs1 rs2, - Val.lessdef v1 v2 -> regs_lessdef rs1 rs2 -> regs_lessdef (rs1#r <- v1) (rs2#r <- v2). -Proof. - intros; red; intros. repeat rewrite Regmap.gsspec. - destruct (peq r0 r); auto. -Qed. - Lemma init_regs_lessdef: forall rl vl1 vl2, Val.lessdef_list vl1 vl2 -> @@ -211,54 +193,79 @@ Proof. unfold successor; intros. apply match_successor_rec. Qed. -Lemma annot_strength_reduction_correct: +Lemma builtin_arg_reduction_correct: forall bc sp m rs ae, ematch bc rs ae -> forall a v, - eval_annot_arg ge (fun r => rs#r) sp m a v -> - eval_annot_arg ge (fun r => rs#r) sp m (annot_strength_reduction ae a) v. + eval_builtin_arg ge (fun r => rs#r) sp m a v -> + eval_builtin_arg ge (fun r => rs#r) sp m (builtin_arg_reduction ae a) v. Proof. - induction 2; simpl; eauto with aarg. + induction 2; simpl; eauto with barg. - specialize (H x). unfold areg. destruct (AE.get x ae); try constructor. + inv H. constructor. + inv H. constructor. + destruct (Compopts.generate_float_constants tt); [inv H|idtac]; constructor. + destruct (Compopts.generate_float_constants tt); [inv H|idtac]; constructor. -- destruct (annot_strength_reduction ae hi); auto with aarg. - destruct (annot_strength_reduction ae lo); auto with aarg. - inv IHeval_annot_arg1; inv IHeval_annot_arg2. constructor. +- destruct (builtin_arg_reduction ae hi); auto with barg. + destruct (builtin_arg_reduction ae lo); auto with barg. + inv IHeval_builtin_arg1; inv IHeval_builtin_arg2. constructor. Qed. -Lemma annot_strength_reduction_correct_2: +Lemma builtin_arg_strength_reduction_correct: + forall bc sp m rs ae a v c, + ematch bc rs ae -> + eval_builtin_arg ge (fun r => rs#r) sp m a v -> + eval_builtin_arg ge (fun r => rs#r) sp m (builtin_arg_strength_reduction ae a c) v. +Proof. + intros. unfold builtin_arg_strength_reduction. + destruct (builtin_arg_ok (builtin_arg_reduction ae a) c). + eapply builtin_arg_reduction_correct; eauto. + auto. +Qed. + +Lemma builtin_args_strength_reduction_correct: forall bc sp m rs ae, ematch bc rs ae -> forall al vl, - eval_annot_args ge (fun r => rs#r) sp m al vl -> - eval_annot_args ge (fun r => rs#r) sp m (List.map (annot_strength_reduction ae) al) vl. + eval_builtin_args ge (fun r => rs#r) sp m al vl -> + forall cl, + eval_builtin_args ge (fun r => rs#r) sp m (builtin_args_strength_reduction ae al cl) vl. Proof. - induction 2; simpl; constructor; auto. eapply annot_strength_reduction_correct; eauto. + induction 2; simpl; constructor. + eapply builtin_arg_strength_reduction_correct; eauto. + apply IHlist_forall2. +Qed. + +Lemma debug_strength_reduction_correct: + forall bc sp m rs ae, ematch bc rs ae -> + forall al vl, + eval_builtin_args ge (fun r => rs#r) sp m al vl -> + exists vl', eval_builtin_args ge (fun r => rs#r) sp m (debug_strength_reduction ae al) vl'. +Proof. + induction 2; simpl. +- exists (@nil val); constructor. +- destruct IHlist_forall2 as (vl' & A). + destruct (builtin_arg_reduction ae a1); repeat (eauto; econstructor). Qed. Lemma builtin_strength_reduction_correct: - forall bc ae rs ef args m t vres m', - genv_match bc ge -> + forall sp bc ae rs ef args vargs m t vres m', ematch bc rs ae -> - external_call ef ge rs##args m t vres m' -> - let (ef', args') := builtin_strength_reduction ae ef args in - external_call ef' ge rs##args' m t vres m'. + eval_builtin_args ge (fun r => rs#r) sp m args vargs -> + external_call ef ge vargs m t vres m' -> + exists vargs', + eval_builtin_args ge (fun r => rs#r) sp m (builtin_strength_reduction ae ef args) vargs' + /\ external_call ef ge vargs' m t vres m'. Proof. - intros until m'. intros GE MATCH. - assert (M: forall v id ofs, - vmatch bc v (Ptr (Gl id ofs)) -> - v = Vundef \/ exists b, Genv.find_symbol ge id = Some b /\ v = Vptr b ofs). - { intros. inv H; auto. inv H2. right; exists b; split; auto. eapply GE; eauto. } - functional induction (builtin_strength_reduction ae ef args); intros; auto. -+ simpl in H. assert (V: vmatch bc (rs#r1) (Ptr (Gl symb n1))) by (rewrite <- e1; apply MATCH). - exploit M; eauto. intros [A | [b [A B]]]. - * simpl in H; rewrite A in H; inv H. - * simpl; rewrite volatile_load_global_charact; simpl. exists b; split; congruence. -+ simpl in H. assert (V: vmatch bc (rs#r1) (Ptr (Gl symb n1))) by (rewrite <- e1; apply MATCH). - exploit M; eauto. intros [A | [b [A B]]]. - * simpl in H; rewrite A in H; inv H. - * simpl; rewrite volatile_store_global_charact; simpl. exists b; split; congruence. + intros. + assert (DEFAULT: forall cl, + exists vargs', + eval_builtin_args ge (fun r => rs#r) sp m (builtin_args_strength_reduction ae args cl) vargs' + /\ external_call ef ge vargs' m t vres m'). + { exists vargs; split; auto. eapply builtin_args_strength_reduction_correct; eauto. } + unfold builtin_strength_reduction. + destruct ef; auto. + exploit debug_strength_reduction_correct; eauto. intros (vargs' & P). + exists vargs'; split; auto. + inv H1; constructor. Qed. (** The proof of semantic preservation is a simulation argument @@ -478,36 +485,21 @@ Proof. apply regs_lessdef_regs; auto. (* Ibuiltin *) - rename pc'0 into pc. + rename pc'0 into pc. clear MATCH. TransfInstr; intros. Opaque builtin_strength_reduction. - exploit builtin_strength_reduction_correct; eauto. - TransfInstr. - destruct (builtin_strength_reduction ae ef args) as [ef' args']. - intros P Q. - exploit external_call_mem_extends; eauto. - instantiate (1 := rs'##args'). apply regs_lessdef_regs; auto. + exploit builtin_strength_reduction_correct; eauto. intros (vargs' & P & Q). + exploit (@eval_builtin_args_lessdef _ ge (fun r => rs#r) (fun r => rs'#r)). + apply REGS. eauto. eexact P. + intros (vargs'' & U & V). + exploit external_call_mem_extends; eauto. intros [v' [m2' [A [B [C D]]]]]. left; econstructor; econstructor; split. - eapply exec_Ibuiltin. eauto. - eapply external_call_symbols_preserved; eauto. - exact symbols_preserved. exact public_preserved. exact varinfo_preserved. - eapply match_states_succ; eauto. simpl; auto. - apply set_reg_lessdef; auto. - - (* Iannot *) - rename pc'0 into pc. TransfInstr; intros. - exploit (@eval_annot_args_lessdef _ ge (fun r => rs#r) (fun r => rs'#r)). - apply REGS. eauto. - eapply annot_strength_reduction_correct_2 with (ae := ae); eauto. - intros (vargs' & A & B). - exploit external_call_mem_extends; eauto. - intros (v' & P & Q & R & S & T). - left; econstructor; econstructor; split. - eapply exec_Iannot; eauto. - eapply eval_annot_args_preserved. eexact symbols_preserved. eauto. + eapply exec_Ibuiltin; eauto. + eapply eval_builtin_args_preserved. eexact symbols_preserved. eauto. eapply external_call_symbols_preserved; eauto. exact symbols_preserved. exact public_preserved. exact varinfo_preserved. eapply match_states_succ; eauto. + apply set_res_lessdef; auto. (* Icond, preserved *) rename pc' into pc. TransfInstr. diff --git a/backend/Deadcode.v b/backend/Deadcode.v index 9a8f85d2..9bf17d1d 100644 --- a/backend/Deadcode.v +++ b/backend/Deadcode.v @@ -70,41 +70,54 @@ Definition is_dead (v: nval) := Definition is_int_zero (v: nval) := match v with I n => Int.eq n Int.zero | _ => false end. -Fixpoint transfer_annot_arg (na: NA.t) (a: annot_arg reg) : NA.t := +Fixpoint transfer_builtin_arg (nv: nval) (na: NA.t) (a: builtin_arg reg) : NA.t := let (ne, nm) := na in match a with - | AA_base r => (add_need_all r ne, nm) - | AA_int _ | AA_long _ | AA_float _ | AA_single _ - | AA_addrstack _ | AA_addrglobal _ _ => (ne, nm) - | AA_loadstack chunk ofs => (ne, nmem_add nm (Stk ofs) (size_chunk chunk)) - | AA_loadglobal chunk id ofs => (ne, nmem_add nm (Gl id ofs) (size_chunk chunk)) - | AA_longofwords hi lo => transfer_annot_arg (transfer_annot_arg na hi) lo + | BA r => (add_need r nv ne, nm) + | BA_int _ | BA_long _ | BA_float _ | BA_single _ + | BA_addrstack _ | BA_addrglobal _ _ => (ne, nm) + | BA_loadstack chunk ofs => (ne, nmem_add nm (Stk ofs) (size_chunk chunk)) + | BA_loadglobal chunk id ofs => (ne, nmem_add nm (Gl id ofs) (size_chunk chunk)) + | BA_splitlong hi lo => + transfer_builtin_arg All (transfer_builtin_arg All na hi) lo end. -Function transfer_builtin (app: VA.t) (ef: external_function) (args: list reg) (res: reg) +Definition transfer_builtin_args (na: NA.t) (al: list (builtin_arg reg)) : NA.t := + List.fold_left (transfer_builtin_arg All) al na. + +Definition kill_builtin_res (res: builtin_res reg) (ne: NE.t) : NE.t := + match res with + | BR r => kill r ne + | _ => ne + end. + +Function transfer_builtin (app: VA.t) (ef: external_function) + (args: list (builtin_arg reg)) (res: builtin_res reg) (ne: NE.t) (nm: nmem) : NA.t := match ef, args with | EF_vload chunk, a1::nil => - (add_needs_all args (kill res ne), - nmem_add nm (aaddr app a1) (size_chunk chunk)) - | EF_vload_global chunk id ofs, nil => - (add_needs_all args (kill res ne), - nmem_add nm (Gl id ofs) (size_chunk chunk)) + transfer_builtin_arg All + (kill_builtin_res res ne, + nmem_add nm (aaddr_arg app a1) (size_chunk chunk)) + a1 | EF_vstore chunk, a1::a2::nil => - (add_need_all a1 (add_need a2 (store_argument chunk) (kill res ne)), nm) - | EF_vstore_global chunk id ofs, a1::nil => - (add_need a1 (store_argument chunk) (kill res ne), nm) + transfer_builtin_arg All + (transfer_builtin_arg (store_argument chunk) + (kill_builtin_res res ne, nm) a2) + a1 | EF_memcpy sz al, dst::src::nil => - if nmem_contains nm (aaddr app dst) sz then - (add_needs_all args (kill res ne), - nmem_add (nmem_remove nm (aaddr app dst) sz) (aaddr app src) sz) + if nmem_contains nm (aaddr_arg app dst) sz then + transfer_builtin_args + (kill_builtin_res res ne, + nmem_add (nmem_remove nm (aaddr_arg app dst) sz) (aaddr_arg app src) sz) + args else (ne, nm) - | EF_annot txt targs, _ => - (add_needs_all args (kill res ne), nm) - | EF_annot_val txt targ, _ => - (add_needs_all args (kill res ne), nm) + | (EF_annot _ _ | EF_annot_val _ _), _ => + transfer_builtin_args (kill_builtin_res res ne, nm) args + | EF_debug _ _ _, _ => + (kill_builtin_res res ne, nm) | _, _ => - (add_needs_all args (kill res ne), nmem_all) + transfer_builtin_args (kill_builtin_res res ne, nmem_all) args end. Definition transfer (f: function) (approx: PMap.t VA.t) @@ -139,8 +152,6 @@ Definition transfer (f: function) (approx: PMap.t VA.t) nmem_dead_stack f.(fn_stacksize)) | Some(Ibuiltin ef args res s) => transfer_builtin approx!!pc ef args res ne nm - | Some(Iannot ef args s) => - List.fold_left transfer_annot_arg args after | Some(Icond cond args s1 s2) => (add_needs args (needs_of_condition cond) ne, nm) | Some(Ijumptable arg tbl) => @@ -187,7 +198,7 @@ Definition transf_instr (approx: PMap.t VA.t) (an: PMap.t NA.t) then instr else Inop s | Ibuiltin (EF_memcpy sz al) (dst :: src :: nil) res s => - if nmem_contains (snd an!!pc) (aaddr approx!!pc dst) sz + if nmem_contains (snd an!!pc) (aaddr_arg approx!!pc dst) sz then instr else Inop s | _ => diff --git a/backend/Deadcodeproof.v b/backend/Deadcodeproof.v index b998c631..a45869d7 100644 --- a/backend/Deadcodeproof.v +++ b/backend/Deadcodeproof.v @@ -262,6 +262,16 @@ Proof. simpl. eapply ma_nextblock; eauto. Qed. +Lemma magree_valid_access: + forall m1 m2 (P: locset) chunk b ofs p, + magree m1 m2 P -> + Mem.valid_access m1 chunk b ofs p -> + Mem.valid_access m2 chunk b ofs p. +Proof. + intros. destruct H0; split; auto. + red; intros. eapply ma_perm; eauto. +Qed. + (** * Properties of the need environment *) Lemma add_need_all_eagree: @@ -547,33 +557,43 @@ Proof. eapply magree_monotone; eauto. intros; apply B; auto. Qed. -(** Annotation arguments *) +(** Builtin arguments and results *) -Lemma transfer_annot_arg_sound: +Lemma eagree_set_res: + forall e1 e2 v1 v2 res ne, + Val.lessdef v1 v2 -> + eagree e1 e2 (kill_builtin_res res ne) -> + eagree (regmap_setres res v1 e1) (regmap_setres res v2 e2) ne. +Proof. + intros. destruct res; simpl in *; auto. + apply eagree_update; eauto. apply vagree_lessdef; auto. +Qed. + +Lemma transfer_builtin_arg_sound: forall bc e e' sp m m' a v, - eval_annot_arg ge (fun r => e#r) (Vptr sp Int.zero) m a v -> - forall ne1 nm1 ne2 nm2, - transfer_annot_arg (ne1, nm1) a = (ne2, nm2) -> + eval_builtin_arg ge (fun r => e#r) (Vptr sp Int.zero) m a v -> + forall nv ne1 nm1 ne2 nm2, + transfer_builtin_arg nv (ne1, nm1) a = (ne2, nm2) -> eagree e e' ne2 -> magree m m' (nlive ge sp nm2) -> genv_match bc ge -> bc sp = BCstack -> exists v', - eval_annot_arg ge (fun r => e'#r) (Vptr sp Int.zero) m' a v' - /\ Val.lessdef v v' + eval_builtin_arg ge (fun r => e'#r) (Vptr sp Int.zero) m' a v' + /\ vagree v v' nv /\ eagree e e' ne1 /\ magree m m' (nlive ge sp nm1). Proof. induction 1; simpl; intros until nm2; intros TR EA MA GM SPM; inv TR. - exists e'#x; intuition auto. constructor. eauto 2 with na. eauto 2 with na. -- exists (Vint n); intuition auto. constructor. -- exists (Vlong n); intuition auto. constructor. -- exists (Vfloat n); intuition auto. constructor. -- exists (Vsingle n); intuition auto. constructor. +- exists (Vint n); intuition auto. constructor. apply vagree_same. +- exists (Vlong n); intuition auto. constructor. apply vagree_same. +- exists (Vfloat n); intuition auto. constructor. apply vagree_same. +- exists (Vsingle n); intuition auto. constructor. apply vagree_same. - simpl in H. exploit magree_load; eauto. intros. eapply nlive_add; eauto with va. rewrite Int.add_zero_l in H0; auto. intros (v' & A & B). - exists v'; intuition auto. constructor; auto. + exists v'; intuition auto. constructor; auto. apply vagree_lessdef; auto. eapply magree_monotone; eauto. intros; eapply incl_nmem_add; eauto. - exists (Vptr sp (Int.add Int.zero ofs)); intuition auto with na. constructor. - unfold Senv.symbol_address in H; simpl in H. @@ -583,40 +603,80 @@ Proof. intros (v' & A & B). exists v'; intuition auto. constructor. simpl. unfold Senv.symbol_address; simpl; rewrite FS; auto. + apply vagree_lessdef; auto. eapply magree_monotone; eauto. intros; eapply incl_nmem_add; eauto. - exists (Senv.symbol_address ge id ofs); intuition auto with na. constructor. -- destruct (transfer_annot_arg (ne1, nm1) hi) as [ne' nm'] eqn:TR. - exploit IHeval_annot_arg2; eauto. intros (vlo' & A & B & C & D). - exploit IHeval_annot_arg1; eauto. intros (vhi' & P & Q & R & S). +- destruct (transfer_builtin_arg All (ne1, nm1) hi) as [ne' nm'] eqn:TR. + exploit IHeval_builtin_arg2; eauto. intros (vlo' & A & B & C & D). + exploit IHeval_builtin_arg1; eauto. intros (vhi' & P & Q & R & S). exists (Val.longofwords vhi' vlo'); intuition auto. constructor; auto. - apply Val.longofwords_lessdef; auto. + apply vagree_lessdef. + apply Val.longofwords_lessdef; apply lessdef_vagree; auto. Qed. -Lemma transfer_annot_args_sound: +Lemma transfer_builtin_args_sound: forall e sp m e' m' bc al vl, - eval_annot_args ge (fun r => e#r) (Vptr sp Int.zero) m al vl -> + eval_builtin_args ge (fun r => e#r) (Vptr sp Int.zero) m al vl -> forall ne1 nm1 ne2 nm2, - List.fold_left transfer_annot_arg al (ne1, nm1) = (ne2, nm2) -> + transfer_builtin_args (ne1, nm1) al = (ne2, nm2) -> eagree e e' ne2 -> magree m m' (nlive ge sp nm2) -> genv_match bc ge -> bc sp = BCstack -> exists vl', - eval_annot_args ge (fun r => e'#r) (Vptr sp Int.zero) m' al vl' + eval_builtin_args ge (fun r => e'#r) (Vptr sp Int.zero) m' al vl' /\ Val.lessdef_list vl vl' /\ eagree e e' ne1 /\ magree m m' (nlive ge sp nm1). Proof. -Local Opaque transfer_annot_arg. +Local Opaque transfer_builtin_arg. induction 1; simpl; intros. - inv H. exists (@nil val); intuition auto. constructor. -- destruct (transfer_annot_arg (ne1, nm1) a1) as [ne' nm'] eqn:TR. +- destruct (transfer_builtin_arg All (ne1, nm1) a1) as [ne' nm'] eqn:TR. exploit IHlist_forall2; eauto. intros (vs' & A1 & B1 & C1 & D1). - exploit transfer_annot_arg_sound; eauto. intros (v1' & A2 & B2 & C2 & D2). + exploit transfer_builtin_arg_sound; eauto. intros (v1' & A2 & B2 & C2 & D2). exists (v1' :: vs'); intuition auto. constructor; auto. Qed. +Lemma can_eval_builtin_arg: + forall sp e m e' m' P, + magree m m' P -> + forall a v, + eval_builtin_arg ge (fun r => e#r) (Vptr sp Int.zero) m a v -> + exists v', eval_builtin_arg tge (fun r => e'#r) (Vptr sp Int.zero) m' a v'. +Proof. + intros until P; intros MA. + assert (LD: forall chunk addr v, + Mem.loadv chunk m addr = Some v -> + exists v', Mem.loadv chunk m' addr = Some v'). + { + intros. destruct addr; simpl in H; try discriminate. + eapply Mem.valid_access_load. eapply magree_valid_access; eauto. + eapply Mem.load_valid_access; eauto. } + induction 1; try (econstructor; now constructor). +- exploit LD; eauto. intros (v' & A). exists v'; constructor; auto. +- exploit LD; eauto. intros (v' & A). exists v'; constructor. + unfold Senv.symbol_address, Senv.find_symbol. rewrite symbols_preserved. assumption. +- destruct IHeval_builtin_arg1 as (v1' & A1). + destruct IHeval_builtin_arg2 as (v2' & A2). + exists (Val.longofwords v1' v2'); constructor; auto. +Qed. + +Lemma can_eval_builtin_args: + forall sp e m e' m' P, + magree m m' P -> + forall al vl, + eval_builtin_args ge (fun r => e#r) (Vptr sp Int.zero) m al vl -> + exists vl', eval_builtin_args tge (fun r => e'#r) (Vptr sp Int.zero) m' al vl'. +Proof. + induction 2. +- exists (@nil val); constructor. +- exploit can_eval_builtin_arg; eauto. intros (v' & A). + destruct IHlist_forall2 as (vl' & B). + exists (v' :: vl'); constructor; eauto. +Qed. + (** Properties of volatile memory accesses *) Lemma transf_volatile_store: @@ -821,168 +881,166 @@ Ltac UseTransfer := functional induction (transfer_builtin (vanalyze rm f)#pc ef args res ne nm); simpl in *; intros. + (* volatile load *) - assert (LD: Val.lessdef rs#a1 te#a1) by eauto 2 with na. - inv H0. rewrite <- H1 in LD; inv LD. - assert (X: exists tv, volatile_load ge chunk tm b ofs t tv /\ Val.lessdef v tv). + inv H0. inv H6. rename b1 into v1. + destruct (transfer_builtin_arg All + (kill_builtin_res res ne, + nmem_add nm (aaddr_arg (vanalyze rm f) # pc a1) + (size_chunk chunk)) a1) as (ne1, nm1) eqn: TR. + inversion SS; subst. exploit transfer_builtin_arg_sound; eauto. + intros (tv1 & A & B & C & D). + inv H1. simpl in B. inv B. + assert (X: exists tvres, volatile_load ge chunk tm b ofs t tvres /\ Val.lessdef vres tvres). { inv H2. - * exists (Val.load_result chunk v0); split; auto. constructor; auto. + * exists (Val.load_result chunk v); split; auto. constructor; auto. * exploit magree_load; eauto. - exploit aaddr_sound; eauto. intros (bc & A & B & C). + exploit aaddr_arg_sound_1; eauto. rewrite <- AN. intros. intros. eapply nlive_add; eassumption. intros (tv & P & Q). exists tv; split; auto. constructor; auto. } - destruct X as (tv & A & B). + destruct X as (tvres & P & Q). econstructor; split. eapply exec_Ibuiltin; eauto. + apply eval_builtin_args_preserved with (ge1 := ge). exact symbols_preserved. + constructor. eauto. constructor. eapply external_call_symbols_preserved. - simpl. rewrite <- H4. constructor. eauto. + constructor. simpl. eauto. exact symbols_preserved. exact public_preserved. exact varinfo_preserved. eapply match_succ_states; eauto. simpl; auto. - apply eagree_update; eauto 2 with na. - eapply magree_monotone; eauto. intros. apply incl_nmem_add; auto. -+ (* volatile global load *) - inv H0. - assert (X: exists tv, volatile_load ge chunk tm b ofs t tv /\ Val.lessdef v tv). - { - inv H2. - * exists (Val.load_result chunk v0); split; auto. constructor; auto. - * exploit magree_load; eauto. - inv SS. intros. eapply nlive_add; eauto. constructor. apply GE. auto. - intros (tv & P & Q). - exists tv; split; auto. constructor; auto. - } - destruct X as (tv & A & B). - econstructor; split. - eapply exec_Ibuiltin; eauto. - eapply external_call_symbols_preserved. - simpl. econstructor; eauto. - exact symbols_preserved. exact public_preserved. exact varinfo_preserved. - eapply match_succ_states; eauto. simpl; auto. - apply eagree_update; eauto 2 with na. + apply eagree_set_res; auto. eapply magree_monotone; eauto. intros. apply incl_nmem_add; auto. + (* volatile store *) - exploit transf_volatile_store. eauto. - instantiate (1 := te#a1). eauto 3 with na. - instantiate (1 := te#a2). eauto 3 with na. - eauto. - intros (EQ & tm' & A & B). subst v. + inv H0. inv H6. inv H7. rename b1 into v1. rename b0 into v2. + destruct (transfer_builtin_arg (store_argument chunk) + (kill_builtin_res res ne, nm) a2) as (ne2, nm2) eqn: TR2. + destruct (transfer_builtin_arg All (ne2, nm2) a1) as (ne1, nm1) eqn: TR1. + inversion SS; subst. + exploit transfer_builtin_arg_sound. eexact H4. eauto. eauto. eauto. eauto. eauto. + intros (tv1 & A1 & B1 & C1 & D1). + exploit transfer_builtin_arg_sound. eexact H3. eauto. eauto. eauto. eauto. eauto. + intros (tv2 & A2 & B2 & C2 & D2). + exploit transf_volatile_store; eauto. + intros (EQ & tm' & P & Q). subst vres. econstructor; split. eapply exec_Ibuiltin; eauto. + apply eval_builtin_args_preserved with (ge1 := ge). exact symbols_preserved. + constructor. eauto. constructor. eauto. constructor. eapply external_call_symbols_preserved. simpl; eauto. exact symbols_preserved. exact public_preserved. exact varinfo_preserved. eapply match_succ_states; eauto. simpl; auto. - apply eagree_update; eauto 3 with na. -+ (* volatile global store *) - rewrite volatile_store_global_charact in H0. destruct H0 as (b & P & Q). - exploit transf_volatile_store. eauto. eauto. - instantiate (1 := te#a1). eauto 2 with na. - eauto. - intros (EQ & tm' & A & B). subst v. - econstructor; split. - eapply exec_Ibuiltin; eauto. - eapply external_call_symbols_preserved. simpl. - rewrite volatile_store_global_charact. exists b; split; eauto. - exact symbols_preserved. exact public_preserved. exact varinfo_preserved. - eapply match_succ_states; eauto. simpl; auto. - apply eagree_update; eauto 2 with na. + apply eagree_set_res; auto. + (* memcpy *) rewrite e1 in TI. - inv H0. - set (adst := aaddr (vanalyze rm f) # pc dst) in *. - set (asrc := aaddr (vanalyze rm f) # pc src) in *. - exploit magree_loadbytes. eauto. eauto. - exploit aaddr_sound. eauto. symmetry; eexact H2. - intros (bc & A & B & C). - intros. eapply nlive_add; eassumption. + inv H0. inv H6. inv H7. rename b1 into v1. rename b0 into v2. + set (adst := aaddr_arg (vanalyze rm f) # pc dst) in *. + set (asrc := aaddr_arg (vanalyze rm f) # pc src) in *. + destruct (transfer_builtin_arg All + (kill_builtin_res res ne, + nmem_add (nmem_remove nm adst sz) asrc sz) dst) + as (ne2, nm2) eqn: TR2. + destruct (transfer_builtin_arg All (ne2, nm2) src) as (ne1, nm1) eqn: TR1. + inversion SS; subst. + exploit transfer_builtin_arg_sound. eexact H3. eauto. eauto. eauto. eauto. eauto. + intros (tv1 & A1 & B1 & C1 & D1). + exploit transfer_builtin_arg_sound. eexact H4. eauto. eauto. eauto. eauto. eauto. + intros (tv2 & A2 & B2 & C2 & D2). + inv H1. + exploit magree_loadbytes. eauto. eauto. + intros. eapply nlive_add; eauto. + unfold asrc, vanalyze, rm; rewrite AN; eapply aaddr_arg_sound_1; eauto. intros (tbytes & P & Q). exploit magree_storebytes_parallel. - eapply magree_monotone. eexact MEM. + eapply magree_monotone. eexact D2. instantiate (1 := nlive ge sp0 (nmem_remove nm adst sz)). intros. apply incl_nmem_add; auto. eauto. - instantiate (1 := nlive ge sp0 nm). - exploit aaddr_sound. eauto. symmetry; eexact H1. - intros (bc & A & B & C). - intros. eapply nlive_remove; eauto. - erewrite Mem.loadbytes_length in H10 by eauto. - rewrite nat_of_Z_eq in H10 by omega. auto. + instantiate (1 := nlive ge sp0 nm). + intros. eapply nlive_remove; eauto. + unfold adst, vanalyze, rm; rewrite AN; eapply aaddr_arg_sound_1; eauto. + erewrite Mem.loadbytes_length in H1 by eauto. + rewrite nat_of_Z_eq in H1 by omega. auto. eauto. intros (tm' & A & B). - assert (LD1: Val.lessdef rs#src te#src) by eauto 3 with na. rewrite <- H2 in LD1. - assert (LD2: Val.lessdef rs#dst te#dst) by eauto 3 with na. rewrite <- H1 in LD2. econstructor; split. eapply exec_Ibuiltin; eauto. + apply eval_builtin_args_preserved with (ge1 := ge). exact symbols_preserved. + constructor. eauto. constructor. eauto. constructor. eapply external_call_symbols_preserved. simpl. - inv LD1. inv LD2. econstructor; eauto. + simpl in B1; inv B1. simpl in B2; inv B2. econstructor; eauto. exact symbols_preserved. exact public_preserved. exact varinfo_preserved. eapply match_succ_states; eauto. simpl; auto. - apply eagree_update; eauto 3 with na. + apply eagree_set_res; auto. + (* memcpy eliminated *) - rewrite e1 in TI. inv H0. - set (adst := aaddr (vanalyze rm f) # pc dst) in *. - set (asrc := aaddr (vanalyze rm f) # pc src) in *. + rewrite e1 in TI. + inv H0. inv H6. inv H7. rename b1 into v1. rename b0 into v2. + set (adst := aaddr_arg (vanalyze rm f) # pc dst) in *. + set (asrc := aaddr_arg (vanalyze rm f) # pc src) in *. + inv H1. econstructor; split. eapply exec_Inop; eauto. eapply match_succ_states; eauto. simpl; auto. - apply eagree_set_undef; auto. + destruct res; auto. apply eagree_set_undef; auto. eapply magree_storebytes_left; eauto. - exploit aaddr_sound. eauto. symmetry; eexact H1. + exploit aaddr_arg_sound. eauto. eauto. intros (bc & A & B & C). intros. eapply nlive_contains; eauto. erewrite Mem.loadbytes_length in H0 by eauto. rewrite nat_of_Z_eq in H0 by omega. auto. + (* annot *) - inv H0. + destruct (transfer_builtin_args (kill_builtin_res res ne, nm) _x1) as (ne1, nm1) eqn:TR. + inversion SS; subst. + exploit transfer_builtin_args_sound; eauto. intros (tvl & A & B & C & D). + inv H1. econstructor; split. - eapply exec_Ibuiltin; eauto. + eapply exec_Ibuiltin; eauto. + apply eval_builtin_args_preserved with (ge1 := ge); eauto. exact symbols_preserved. eapply external_call_symbols_preserved. simpl; constructor. eapply eventval_list_match_lessdef; eauto 2 with na. exact symbols_preserved. exact public_preserved. exact varinfo_preserved. eapply match_succ_states; eauto. simpl; auto. - apply eagree_update; eauto 2 with na. -+ (* annot val *) - inv H0. destruct _x; inv H1. destruct _x; inv H4. + apply eagree_set_res; auto. ++ (* annot val *) + destruct (transfer_builtin_args (kill_builtin_res res ne, nm) _x1) as (ne1, nm1) eqn:TR. + inversion SS; subst. + exploit transfer_builtin_args_sound; eauto. intros (tvl & A & B & C & D). + inv H1. inv B. inv H6. econstructor; split. eapply exec_Ibuiltin; eauto. + apply eval_builtin_args_preserved with (ge1 := ge); eauto. exact symbols_preserved. eapply external_call_symbols_preserved. simpl; constructor. eapply eventval_match_lessdef; eauto 2 with na. exact symbols_preserved. exact public_preserved. exact varinfo_preserved. eapply match_succ_states; eauto. simpl; auto. - apply eagree_update; eauto 3 with na. + apply eagree_set_res; auto. ++ (* debug *) + inv H1. + exploit can_eval_builtin_args; eauto. intros (vargs' & A). + econstructor; split. + eapply exec_Ibuiltin; eauto. constructor. + eapply match_succ_states; eauto. simpl; auto. + apply eagree_set_res; auto. + (* all other builtins *) assert ((fn_code tf)!pc = Some(Ibuiltin _x _x0 res pc')). { destruct _x; auto. destruct _x0; auto. destruct _x0; auto. destruct _x0; auto. contradiction. } - clear y TI. + clear y TI. + destruct (transfer_builtin_args (kill_builtin_res res ne, nmem_all) _x0) as (ne1, nm1) eqn:TR. + inversion SS; subst. + exploit transfer_builtin_args_sound; eauto. intros (tvl & A & B & C & D). exploit external_call_mem_extends; eauto 2 with na. eapply magree_extends; eauto. intros. apply nlive_all. - intros (v' & tm' & A & B & C & D & E). + intros (v' & tm' & P & Q & R & S & T). econstructor; split. - eapply exec_Ibuiltin; eauto. + eapply exec_Ibuiltin; eauto. + apply eval_builtin_args_preserved with (ge1 := ge); eauto. exact symbols_preserved. eapply external_call_symbols_preserved. eauto. exact symbols_preserved. exact public_preserved. exact varinfo_preserved. eapply match_succ_states; eauto. simpl; auto. - apply eagree_update; eauto 3 with na. + apply eagree_set_res; auto. eapply mextends_agree; eauto. -- (* annot *) - TransfInstr; UseTransfer. - destruct (fold_left transfer_annot_arg args (ne, nm)) as [ne1 nm1] eqn:TR; simpl in *. - inv SS. exploit transfer_annot_args_sound; eauto. intros (vargs' & A & B & C & D). - assert (EC: m' = m /\ external_call ef ge vargs' tm t Vundef tm). - { destruct ef; try contradiction. inv H2. split; auto. simpl. constructor. - eapply eventval_list_match_lessdef; eauto. } - destruct EC as [EC1 EC2]; subst m'. - econstructor; split. - eapply exec_Iannot. eauto. auto. - eapply eval_annot_args_preserved with (ge1 := ge); eauto. exact symbols_preserved. - eapply external_call_symbols_preserved with (ge1 := ge); eauto. - exact symbols_preserved. exact public_preserved. exact varinfo_preserved. - eapply match_succ_states; eauto. simpl; auto. - - (* conditional *) TransfInstr; UseTransfer. econstructor; split. diff --git a/backend/Debugvar.v b/backend/Debugvar.v new file mode 100644 index 00000000..314f43fd --- /dev/null +++ b/backend/Debugvar.v @@ -0,0 +1,378 @@ +(* *********************************************************************) +(* *) +(* 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. *) +(* *) +(* *********************************************************************) + +(** Computation of live ranges for local variables that carry + debugging information. *) + +Require Import Coqlib. +Require Import Axioms. +Require Import Maps. +Require Import Iteration. +Require Import AST. +Require Import Integers. +Require Import Floats. +Require Import Errors. +Require Import Machregs. +Require Import Locations. +Require Import Conventions. +Require Import Linear. + +(** A debug info is a [builtin_arg loc] expression that safely evaluates + in any context. *) + +Fixpoint safe_builtin_arg {A: Type} (a: builtin_arg A) : Prop := + match a with + | BA _ | BA_int _ | BA_long _ | BA_float _ | BA_single _ => True + | BA_splitlong hi lo => safe_builtin_arg hi /\ safe_builtin_arg lo + | _ => False + end. + +Definition debuginfo := { a : builtin_arg loc | safe_builtin_arg a }. + +(** Normalization of debug info. Prefer an actual location to a constant. + Make sure that the debug info is safe to evaluate in any context. *) + +Definition normalize_debug_1 (a: builtin_arg loc) : option debuginfo := + match a with + | BA x => Some (exist _ (BA x) I) + | BA_int n => Some (exist _ (BA_int n) I) + | BA_long n => Some (exist _ (BA_long n) I) + | BA_float n => Some (exist _ (BA_float n) I) + | BA_single n => Some (exist _ (BA_single n) I) + | BA_splitlong (BA hi) (BA lo) => Some (exist _ (BA_splitlong (BA hi) (BA lo)) (conj I I)) + | _ => None + end. + +Fixpoint normalize_debug (l: list (builtin_arg loc)) : option debuginfo := + match l with + | nil => None + | a :: l' => + match a with + | BA_int _ | BA_long _ | BA_float _ | BA_single _ => + match normalize_debug l' with + | Some i => Some i + | None => normalize_debug_1 a + end + | _ => normalize_debug_1 a + end + end. + +(** * Availability analysis *) + +(** This static analysis tracks which locations (registers and stack slots) + contain the values of which C local variables. + + The abstraction of the program state at a program point is a list of + pairs (variable name, location). It is kept sorted by increasing name. + The location is represented by a safe [builtin_arg loc] expression. *) + +Definition avail : Type := list (ident * debuginfo). + +(** Operations on [avail] abstract states. *) + +Fixpoint set_state (v: ident) (i: debuginfo) (s: avail) : avail := + match s with + | nil => (v, i) :: nil + | (v', i') as vi' :: s' => + match Pos.compare v v' with + | Eq => (v, i) :: s' + | Lt => (v, i) :: s + | Gt => vi' :: set_state v i s' + end + end. + +Fixpoint remove_state (v: ident) (s: avail) : avail := + match s with + | nil => nil + | (v', i') as vi' :: s' => + match Pos.compare v v' with + | Eq => s' + | Lt => s + | Gt => vi' :: remove_state v s' + end + end. + +Fixpoint set_debug_info (v: ident) (info: list (builtin_arg loc)) (s: avail) := + match normalize_debug info with + | Some a => set_state v a s + | None => remove_state v s + end. + +(** When the program writes to a register or stack location, some + availability information is invalidated. *) + +Fixpoint arg_no_overlap (a: builtin_arg loc) (l: loc) : bool := + match a with + | BA l' => Loc.diff_dec l' l + | BA_splitlong hi lo => arg_no_overlap hi l && arg_no_overlap lo l + | _ => true + end. + +Definition kill (l: loc) (s: avail) : avail := + List.filter (fun vi => arg_no_overlap (proj1_sig (snd vi)) l) s. + +Fixpoint kill_res (r: builtin_res mreg) (s: avail) : avail := + match r with + | BR r => kill (R r) s + | BR_none => s + | BR_splitlong hi lo => kill_res hi (kill_res lo s) + end. + +(** Likewise when a function call takes place. *) + +Fixpoint arg_preserved (a: builtin_arg loc) : bool := + match a with + | BA (R r) => negb (List.In_dec mreg_eq r destroyed_at_call) + | BA (S _ _ _) => true + | BA_splitlong hi lo => arg_preserved hi && arg_preserved lo + | _ => true + end. + +Definition kill_at_call (s: avail) : avail := + List.filter (fun vi => arg_preserved (proj1_sig(snd vi))) s. + +(** The join of two availability states is the intersection of the + corresponding lists. *) + +Definition eq_arg (a1 a2: builtin_arg loc) : {a1=a2} + {a1<>a2}. +Proof. + generalize Loc.eq ident_eq Int.eq_dec Int64.eq_dec Float.eq_dec Float32.eq_dec chunk_eq; + decide equality. +Defined. +Global Opaque eq_arg. + +Definition eq_debuginfo (i1 i2: debuginfo) : {i1=i2} + {i1 <> i2}. +Proof. + destruct (eq_arg (proj1_sig i1) (proj1_sig i2)). + left. destruct i1, i2; simpl in *. subst x0. f_equal. apply proof_irr. + right. congruence. +Defined. +Global Opaque eq_debuginfo. + +Fixpoint join (s1: avail) (s2: avail) {struct s1} : avail := + match s1 with + | nil => nil + | (v1, i1) as vi1 :: s1' => + let fix join2 (s2: avail) : avail := + match s2 with + | nil => nil + | (v2, i2) as vi2 :: s2' => + match Pos.compare v1 v2 with + | Eq => if eq_debuginfo i1 i2 then vi1 :: join s1' s2' else join s1' s2' + | Lt => join s1' s2 + | Gt => join2 s2' + end + end + in join2 s2 + end. + +Definition eq_state (s1 s2: avail) : {s1=s2} + {s1<>s2}. +Proof. + apply list_eq_dec. decide equality. apply eq_debuginfo. apply ident_eq. +Defined. +Global Opaque eq_state. + +Definition top : avail := nil. + +(** Record availability information at labels. *) + +Definition labelmap := (PTree.t avail * bool)%type. + +Definition get_label (lbl: label) (lm: labelmap) : option avail := + PTree.get lbl (fst lm). + +Definition update_label (lbl: label) (s1: avail) (lm: labelmap) : + labelmap * avail := + match get_label lbl lm with + | None => + ((PTree.set lbl s1 (fst lm), true), s1) + | Some s2 => + let s := join s1 s2 in + if eq_state s s2 + then (lm, s2) + else ((PTree.set lbl s (fst lm), true), s) + end. + +Fixpoint update_labels (lbls: list label) (s: avail) (lm: labelmap) : + labelmap := + match lbls with + | nil => lm + | lbl1 :: lbls => + update_labels lbls s (fst (update_label lbl1 s lm)) + end. + +(** Classification of builtins *) + +Definition is_debug_setvar (ef: external_function) := + match ef with + | EF_debug 2%positive txt targs => Some txt + | _ => None + end. + +Definition is_builtin_debug_setvar (i: instruction) := + match i with + | Lbuiltin ef args BR_none => is_debug_setvar ef + | _ => None + end. + +(** The transfer function for the forward dataflow analysis. *) + +Definition transfer (lm: labelmap) (before: option avail) (i: instruction): + labelmap * option avail := + match before with + | None => + match i with + | Llabel lbl => (lm, get_label lbl lm) + | _ => (lm, None) + end + | Some s => + match i with + | Lgetstack sl ofs ty rd => + (lm, Some (kill (R rd) s)) + | Lsetstack rs sl ofs ty => + (lm, Some (kill (S sl ofs ty) s)) + | Lop op args dst => + (lm, Some (kill (R dst) s)) + | Lload chunk addr args dst => + (lm, Some (kill (R dst) s)) + | Lstore chunk addr args src => + (lm, before) + | Lcall sg ros => + (lm, Some (kill_at_call s)) + | Ltailcall sg ros => + (lm, None) + | Lbuiltin ef args res => + let s' := + match is_debug_setvar ef with + | Some v => set_debug_info v args s + | None => s + end in + (lm, Some (kill_res res s')) + | Llabel lbl => + let (lm1, s1) := update_label lbl s lm in + (lm1, Some s1) + | Lgoto lbl => + let (lm1, s1) := update_label lbl s lm in + (lm1, None) + | Lcond cond args lbl => + let (lm1, s1) := update_label lbl s lm in + (lm1, before) + | Ljumptable r lbls => + (update_labels lbls s lm, None) + | Lreturn => + (lm, None) + end + end. + +(** One pass of forward analysis over the code [c]. + Return an updated label map. *) + +Fixpoint ana_code (lm: labelmap) (before: option avail) (c: code) : labelmap := + match c with + | nil => lm + | i :: c => + let (lm1, after) := transfer lm before i in + ana_code lm1 after c + end. + +(** Iterate [ana_code] until the label map is stable. *) + +Definition ana_iter (c: code) (lm: labelmap) : labelmap + labelmap := + let lm' := ana_code (fst lm, false) (Some top) c in + if snd lm' then inr _ lm' else inl _ lm. + +Definition ana_function (f: function) : option labelmap := + PrimIter.iterate _ _ (ana_iter f.(fn_code)) (PTree.empty _, false). + +(** * Code transformation *) + +(** Compute the changes between two abstract states *) + +Fixpoint diff (s1 s2: avail) {struct s1} : avail := + match s1 with + | nil => nil + | (v1, i1) as vi1 :: s1' => + let fix diff2 (s2: avail) : avail := + match s2 with + | nil => s1 + | (v2, i2) :: s2' => + match Pos.compare v1 v2 with + | Eq => if eq_debuginfo i1 i2 then diff s1' s2' else vi1 :: diff s1' s2' + | Lt => vi1 :: diff s1' s2 + | Gt => diff2 s2' + end + end + in diff2 s2 + end. + +Definition delta_state (before after: option avail) : avail * avail := + match before, after with + | None, None => (nil, nil) + | Some b, None => (b, nil) + | None, Some a => (nil, a) + | Some b, Some a => (diff b a, diff a b) + end. + +(** Insert debug annotations at the beginning and end of live ranges + of locations that correspond to source local variables. *) + +Definition add_start_range (vi: ident * debuginfo) (c: code) : code := + let (v, i) := vi in + Lbuiltin (EF_debug 3%positive v nil) (proj1_sig i :: nil) BR_none :: c. + +Definition add_end_range (vi: ident * debuginfo) (c: code) : code := + let (v, i) := vi in + Lbuiltin (EF_debug 4%positive v nil) nil BR_none :: c. + +Definition add_delta_ranges (before after: option avail) (c: code) : code := + let (killed, born) := delta_state before after in + List.fold_right add_end_range (List.fold_right add_start_range c born) killed. + +Fixpoint skip_debug_setvar (lm: labelmap) (before: option avail) (c: code) := + match c with + | nil => before + | i :: c' => + match is_builtin_debug_setvar i with + | Some _ => skip_debug_setvar lm (snd (transfer lm before i)) c' + | None => before + end + end. + +Fixpoint transf_code (lm: labelmap) (before: option avail) (c: code) : code := + match c with + | nil => nil + | Lgoto lbl1 :: Llabel lbl2 :: c' => + (* This special case avoids some redundant start/end annotations *) + let after := get_label lbl2 lm in + Lgoto lbl1 :: Llabel lbl2 :: + add_delta_ranges before after (transf_code lm after c') + | i :: c' => + let after := skip_debug_setvar lm (snd (transfer lm before i)) c' in + i :: add_delta_ranges before after (transf_code lm after c') + end. + +Local Open Scope string_scope. + +Definition transf_function (f: function) : res function := + match ana_function f with + | None => Error (msg "Debugvar: analysis diverges") + | Some lm => + OK (mkfunction f.(fn_sig) f.(fn_stacksize) + (transf_code lm (Some top) f.(fn_code))) + end. + +Definition transf_fundef (fd: fundef) : res fundef := + AST.transf_partial_fundef transf_function fd. + +Definition transf_program (p: program) : res program := + transform_partial_program transf_fundef p. + diff --git a/backend/Debugvarproof.v b/backend/Debugvarproof.v new file mode 100644 index 00000000..6f0b8cda --- /dev/null +++ b/backend/Debugvarproof.v @@ -0,0 +1,575 @@ +(* *********************************************************************) +(* *) +(* 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. *) +(* *) +(* *********************************************************************) + +(** Correctness proof for the [Debugvar] pass. *) + +Require Import Coqlib. +Require Import Axioms. +Require Import Maps. +Require Import Iteration. +Require Import AST. +Require Import Integers. +Require Import Floats. +Require Import Values. +Require Import Memory. +Require Import Events. +Require Import Globalenvs. +Require Import Smallstep. +Require Import Op. +Require Import Errors. +Require Import Machregs. +Require Import Locations. +Require Import Conventions. +Require Import Linear. +Require Import Debugvar. + +(** * Relational characterization of the transformation *) + +Inductive match_code: code -> code -> Prop := + | match_code_nil: + match_code nil nil + | match_code_cons: forall i before after c c', + match_code c c' -> + match_code (i :: c) (i :: add_delta_ranges before after c'). + +Remark diff_same: + forall s, diff s s = nil. +Proof. + induction s as [ | [v i] s]; simpl. + auto. + rewrite Pos.compare_refl. rewrite dec_eq_true. auto. +Qed. + +Remark delta_state_same: + forall s, delta_state s s = (nil, nil). +Proof. + destruct s; simpl. rewrite ! diff_same; auto. auto. +Qed. + +Lemma transf_code_match: + forall lm c before, match_code c (transf_code lm before c). +Proof. + intros lm. fix REC 1. destruct c; intros before; simpl. +- constructor. +- assert (DEFAULT: forall before after, + match_code (i :: c) + (i :: add_delta_ranges before after (transf_code lm after c))). + { intros. constructor. apply REC. } + destruct i; auto. destruct c; auto. destruct i; auto. + set (after := get_label l0 lm). + set (c1 := Llabel l0 :: add_delta_ranges before after (transf_code lm after c)). + replace c1 with (add_delta_ranges before before c1). + constructor. constructor. apply REC. + unfold add_delta_ranges. rewrite delta_state_same. auto. +Qed. + +Inductive match_function: function -> function -> Prop := + | match_function_intro: forall f c, + match_code f.(fn_code) c -> + match_function f (mkfunction f.(fn_sig) f.(fn_stacksize) c). + +Lemma transf_function_match: + forall f tf, transf_function f = OK tf -> match_function f tf. +Proof. + unfold transf_function; intros. + destruct (ana_function f) as [lm|]; inv H. + constructor. apply transf_code_match. +Qed. + +Remark find_label_add_delta_ranges: + forall lbl c before after, find_label lbl (add_delta_ranges before after c) = find_label lbl c. +Proof. + intros. unfold add_delta_ranges. + destruct (delta_state before after) as [killed born]. + induction killed as [ | [v i] l]; simpl; auto. + induction born as [ | [v i] l]; simpl; auto. +Qed. + +Lemma find_label_match_rec: + forall lbl c' c tc, + match_code c tc -> + find_label lbl c = Some c' -> + exists before after tc', find_label lbl tc = Some (add_delta_ranges before after tc') /\ match_code c' tc'. +Proof. + induction 1; simpl; intros. +- discriminate. +- destruct (is_label lbl i). + inv H0. econstructor; econstructor; econstructor; eauto. + rewrite find_label_add_delta_ranges. auto. +Qed. + +Lemma find_label_match: + forall f tf lbl c, + match_function f tf -> + find_label lbl f.(fn_code) = Some c -> + exists before after tc, find_label lbl tf.(fn_code) = Some (add_delta_ranges before after tc) /\ match_code c tc. +Proof. + intros. inv H. eapply find_label_match_rec; eauto. +Qed. + +(** * Properties of availability sets *) + +(** These properties are not used in the semantic preservation proof, + but establish some confidence in the availability analysis. *) + +Definition avail_above (v: ident) (s: avail) : Prop := + forall v' i', In (v', i') s -> Plt v v'. + +Inductive wf_avail: avail -> Prop := + | wf_avail_nil: + wf_avail nil + | wf_avail_cons: forall v i s, + avail_above v s -> + wf_avail s -> + wf_avail ((v, i) :: s). + +Lemma set_state_1: + forall v i s, In (v, i) (set_state v i s). +Proof. + induction s as [ | [v' i'] s]; simpl. +- auto. +- destruct (Pos.compare v v'); simpl; auto. +Qed. + +Lemma set_state_2: + forall v i v' i' s, + v' <> v -> In (v', i') s -> In (v', i') (set_state v i s). +Proof. + induction s as [ | [v1 i1] s]; simpl; intros. +- contradiction. +- destruct (Pos.compare_spec v v1); simpl. ++ subst v1. destruct H0. congruence. auto. ++ auto. ++ destruct H0; auto. +Qed. + +Lemma set_state_3: + forall v i v' i' s, + wf_avail s -> + In (v', i') (set_state v i s) -> + (v' = v /\ i' = i) \/ (v' <> v /\ In (v', i') s). +Proof. + induction 1; simpl; intros. +- intuition congruence. +- destruct (Pos.compare_spec v v0); simpl in H1. ++ subst v0. destruct H1. inv H1; auto. right; split. + apply sym_not_equal. apply Plt_ne. eapply H; eauto. + auto. ++ destruct H1. inv H1; auto. + destruct H1. inv H1. right; split; auto. apply sym_not_equal. apply Plt_ne. auto. + right; split; auto. apply sym_not_equal. apply Plt_ne. apply Plt_trans with v0; eauto. ++ destruct H1. inv H1. right; split; auto. apply Plt_ne. auto. + destruct IHwf_avail as [A | [A B]]; auto. +Qed. + +Lemma wf_set_state: + forall v i s, wf_avail s -> wf_avail (set_state v i s). +Proof. + induction 1; simpl. +- constructor. red; simpl; tauto. constructor. +- destruct (Pos.compare_spec v v0). ++ subst v0. constructor; auto. ++ constructor. + red; simpl; intros. destruct H2. + inv H2. auto. apply Plt_trans with v0; eauto. + constructor; auto. ++ constructor. + red; intros. exploit set_state_3. eexact H0. eauto. intros [[A B] | [A B]]; subst; eauto. + auto. +Qed. + +Lemma remove_state_1: + forall v i s, wf_avail s -> ~ In (v, i) (remove_state v s). +Proof. + induction 1; simpl; red; intros. +- auto. +- destruct (Pos.compare_spec v v0); simpl in *. ++ subst v0. elim (Plt_strict v); eauto. ++ destruct H1. inv H1. elim (Plt_strict v); eauto. + elim (Plt_strict v). apply Plt_trans with v0; eauto. ++ destruct H1. inv H1. elim (Plt_strict v); eauto. tauto. +Qed. + +Lemma remove_state_2: + forall v v' i' s, v' <> v -> In (v', i') s -> In (v', i') (remove_state v s). +Proof. + induction s as [ | [v1 i1] s]; simpl; intros. +- auto. +- destruct (Pos.compare_spec v v1); simpl. ++ subst v1. destruct H0. congruence. auto. ++ auto. ++ destruct H0; auto. +Qed. + +Lemma remove_state_3: + forall v v' i' s, wf_avail s -> In (v', i') (remove_state v s) -> v' <> v /\ In (v', i') s. +Proof. + induction 1; simpl; intros. +- contradiction. +- destruct (Pos.compare_spec v v0); simpl in H1. ++ subst v0. split; auto. apply sym_not_equal; apply Plt_ne; eauto. ++ destruct H1. inv H1. split; auto. apply sym_not_equal; apply Plt_ne; eauto. + split; auto. apply sym_not_equal; apply Plt_ne. apply Plt_trans with v0; eauto. ++ destruct H1. inv H1. split; auto. apply Plt_ne; auto. + destruct IHwf_avail as [A B] ; auto. +Qed. + +Lemma wf_remove_state: + forall v s, wf_avail s -> wf_avail (remove_state v s). +Proof. + induction 1; simpl. +- constructor. +- destruct (Pos.compare_spec v v0). ++ auto. ++ constructor; auto. ++ constructor; auto. red; intros. + exploit remove_state_3. eexact H0. eauto. intros [A B]. eauto. +Qed. + +Lemma wf_filter: + forall pred s, wf_avail s -> wf_avail (List.filter pred s). +Proof. + induction 1; simpl. +- constructor. +- destruct (pred (v, i)) eqn:P; auto. + constructor; auto. + red; intros. apply filter_In in H1. destruct H1. eauto. +Qed. + +Lemma join_1: + forall v i s1, wf_avail s1 -> forall s2, wf_avail s2 -> + In (v, i) s1 -> In (v, i) s2 -> In (v, i) (join s1 s2). +Proof. + induction 1; simpl; try tauto; induction 1; simpl; intros I1 I2; auto. + destruct I1, I2. +- inv H3; inv H4. rewrite Pos.compare_refl. rewrite dec_eq_true; auto with coqlib. +- inv H3. + assert (L: Plt v1 v) by eauto. apply Pos.compare_gt_iff in L. rewrite L. auto. +- inv H4. + assert (L: Plt v0 v) by eauto. apply Pos.compare_lt_iff in L. rewrite L. apply IHwf_avail. constructor; auto. auto. auto with coqlib. +- destruct (Pos.compare v0 v1). ++ destruct (eq_debuginfo i0 i1); auto with coqlib. ++ apply IHwf_avail; auto with coqlib. constructor; auto. ++ eauto. +Qed. + +Lemma join_2: + forall v i s1, wf_avail s1 -> forall s2, wf_avail s2 -> + In (v, i) (join s1 s2) -> In (v, i) s1 /\ In (v, i) s2. +Proof. + induction 1; simpl; try tauto; induction 1; simpl; intros I; try tauto. + destruct (Pos.compare_spec v0 v1). +- subst v1. destruct (eq_debuginfo i0 i1). + + subst i1. destruct I. auto. exploit IHwf_avail; eauto. tauto. + + exploit IHwf_avail; eauto. tauto. +- exploit (IHwf_avail ((v1, i1) :: s0)); eauto. constructor; auto. + simpl. tauto. +- exploit IHwf_avail0; eauto. tauto. +Qed. + +Lemma wf_join: + forall s1, wf_avail s1 -> forall s2, wf_avail s2 -> wf_avail (join s1 s2). +Proof. + induction 1; simpl; induction 1; simpl; try constructor. + destruct (Pos.compare_spec v v0). +- subst v0. destruct (eq_debuginfo i i0); auto. constructor; auto. + red; intros. apply join_2 in H3; auto. destruct H3. eauto. +- apply IHwf_avail. constructor; auto. +- apply IHwf_avail0. +Qed. + +(** * Semantic preservation *) + +Section PRESERVATION. + +Variable prog: program. +Variable tprog: program. + +Hypothesis TRANSF: transf_program prog = OK tprog. + +Let ge := Genv.globalenv prog. +Let tge := Genv.globalenv tprog. + +Lemma functions_translated: + forall v f, + Genv.find_funct ge v = Some f -> + exists tf, + Genv.find_funct tge v = Some tf /\ transf_fundef f = OK tf. +Proof (Genv.find_funct_transf_partial transf_fundef _ TRANSF). + +Lemma function_ptr_translated: + forall v f, + Genv.find_funct_ptr ge v = Some f -> + exists tf, + Genv.find_funct_ptr tge v = Some tf /\ transf_fundef f = OK tf. +Proof (Genv.find_funct_ptr_transf_partial transf_fundef _ TRANSF). + +Lemma symbols_preserved: + forall id, + Genv.find_symbol tge id = Genv.find_symbol ge id. +Proof (Genv.find_symbol_transf_partial transf_fundef _ TRANSF). + +Lemma public_preserved: + forall id, + Genv.public_symbol tge id = Genv.public_symbol ge id. +Proof (Genv.public_symbol_transf_partial transf_fundef _ TRANSF). + +Lemma varinfo_preserved: + forall b, Genv.find_var_info tge b = Genv.find_var_info ge b. +Proof (Genv.find_var_info_transf_partial transf_fundef _ TRANSF). + +Lemma sig_preserved: + forall f tf, + transf_fundef f = OK tf -> + funsig tf = funsig f. +Proof. + unfold transf_fundef, transf_partial_fundef; intros. + destruct f. monadInv H. + exploit transf_function_match; eauto. intros M; inv M; auto. + inv H. reflexivity. +Qed. + +Lemma find_function_translated: + forall ros ls f, + find_function ge ros ls = Some f -> + exists tf, + find_function tge ros ls = Some tf /\ transf_fundef f = OK tf. +Proof. + unfold find_function; intros; destruct ros; simpl. + apply functions_translated; auto. + rewrite symbols_preserved. destruct (Genv.find_symbol ge i). + apply function_ptr_translated; auto. + congruence. +Qed. + +(** Evaluation of the debug annotations introduced by the transformation. *) + +Lemma can_eval_safe_arg: + forall (rs: locset) sp m (a: builtin_arg loc), + safe_builtin_arg a -> exists v, eval_builtin_arg tge rs sp m a v. +Proof. + induction a; simpl; intros; try contradiction; + try (econstructor; now eauto with barg). + destruct H as [S1 S2]. + destruct (IHa1 S1) as [v1 E1]. destruct (IHa2 S2) as [v2 E2]. + exists (Val.longofwords v1 v2); auto with barg. +Qed. + +Lemma eval_add_delta_ranges: + forall s f sp c rs m before after, + star step tge (State s f sp (add_delta_ranges before after c) rs m) + E0 (State s f sp c rs m). +Proof. + intros. unfold add_delta_ranges. + destruct (delta_state before after) as [killed born]. + induction killed as [ | [v i] l]; simpl. +- induction born as [ | [v i] l]; simpl. ++ apply star_refl. ++ destruct i as [a SAFE]; simpl. + exploit can_eval_safe_arg; eauto. intros [v1 E1]. + eapply star_step; eauto. + econstructor. + constructor. eexact E1. constructor. + simpl; constructor. + simpl; auto. + traceEq. +- eapply star_step; eauto. + econstructor. + constructor. + simpl; constructor. + simpl; auto. + traceEq. +Qed. + +(** Matching between program states. *) + +Inductive match_stackframes: Linear.stackframe -> Linear.stackframe -> Prop := + | match_stackframe_intro: + forall f sp rs c tf tc before after, + match_function f tf -> + match_code c tc -> + match_stackframes + (Stackframe f sp rs c) + (Stackframe tf sp rs (add_delta_ranges before after tc)). + +Inductive match_states: Linear.state -> Linear.state -> Prop := + | match_states_instr: + forall s f sp c rs m tf ts tc + (STACKS: list_forall2 match_stackframes s ts) + (TRF: match_function f tf) + (TRC: match_code c tc), + match_states (State s f sp c rs m) + (State ts tf sp tc rs m) + | match_states_call: + forall s f rs m tf ts, + list_forall2 match_stackframes s ts -> + transf_fundef f = OK tf -> + match_states (Callstate s f rs m) + (Callstate ts tf rs m) + | match_states_return: + forall s rs m ts, + list_forall2 match_stackframes s ts -> + match_states (Returnstate s rs m) + (Returnstate ts rs m). + +Lemma parent_locset_match: + forall s ts, + list_forall2 match_stackframes s ts -> + parent_locset ts = parent_locset s. +Proof. + induction 1; simpl. auto. inv H; auto. +Qed. + +(** The simulation diagram. *) + +Theorem transf_step_correct: + forall s1 t s2, step ge s1 t s2 -> + forall ts1 (MS: match_states s1 ts1), + exists ts2, plus step tge ts1 t ts2 /\ match_states s2 ts2. +Proof. + induction 1; intros ts1 MS; inv MS; try (inv TRC). +- (* getstack *) + econstructor; split. + eapply plus_left. constructor; auto. apply eval_add_delta_ranges. traceEq. + constructor; auto. +- (* setstack *) + econstructor; split. + eapply plus_left. constructor; auto. apply eval_add_delta_ranges. traceEq. + constructor; auto. +- (* op *) + econstructor; split. + eapply plus_left. + econstructor; eauto. + instantiate (1 := v). rewrite <- H; apply eval_operation_preserved; exact symbols_preserved. + apply eval_add_delta_ranges. traceEq. + constructor; auto. +- (* load *) + econstructor; split. + eapply plus_left. + eapply exec_Lload with (a := a). + rewrite <- H; apply eval_addressing_preserved; exact symbols_preserved. + eauto. eauto. + apply eval_add_delta_ranges. traceEq. + constructor; auto. +- (* store *) + econstructor; split. + eapply plus_left. + eapply exec_Lstore with (a := a). + rewrite <- H; apply eval_addressing_preserved; exact symbols_preserved. + eauto. eauto. + apply eval_add_delta_ranges. traceEq. + constructor; auto. +- (* call *) + exploit find_function_translated; eauto. intros (tf' & A & B). + econstructor; split. + apply plus_one. + econstructor. eexact A. symmetry; apply sig_preserved; auto. traceEq. + constructor; auto. constructor; auto. constructor; auto. +- (* tailcall *) + exploit find_function_translated; eauto. intros (tf' & A & B). + exploit parent_locset_match; eauto. intros PLS. + econstructor; split. + apply plus_one. + econstructor. eauto. rewrite PLS. eexact A. + symmetry; apply sig_preserved; auto. + inv TRF; eauto. traceEq. + rewrite PLS. constructor; auto. +- (* builtin *) + econstructor; split. + eapply plus_left. + econstructor; eauto. + eapply eval_builtin_args_preserved with (ge1 := ge); eauto. exact symbols_preserved. + eapply external_call_symbols_preserved. eauto. + exact symbols_preserved. exact public_preserved. exact varinfo_preserved. + apply eval_add_delta_ranges. traceEq. + constructor; auto. +- (* label *) + econstructor; split. + eapply plus_left. constructor; auto. apply eval_add_delta_ranges. traceEq. + constructor; auto. +- (* goto *) + exploit find_label_match; eauto. intros (before' & after' & tc' & A & B). + econstructor; split. + eapply plus_left. constructor; eauto. apply eval_add_delta_ranges; eauto. traceEq. + constructor; auto. +- (* cond taken *) + exploit find_label_match; eauto. intros (before' & after' & tc' & A & B). + econstructor; split. + eapply plus_left. eapply exec_Lcond_true; eauto. apply eval_add_delta_ranges; eauto. traceEq. + constructor; auto. +- (* cond not taken *) + econstructor; split. + eapply plus_left. eapply exec_Lcond_false; auto. apply eval_add_delta_ranges. traceEq. + constructor; auto. +- (* jumptable *) + exploit find_label_match; eauto. intros (before' & after' & tc' & A & B). + econstructor; split. + eapply plus_left. econstructor; eauto. + apply eval_add_delta_ranges. reflexivity. traceEq. + constructor; auto. +- (* return *) + econstructor; split. + apply plus_one. constructor. inv TRF; eauto. traceEq. + rewrite (parent_locset_match _ _ STACKS). constructor; auto. +- (* internal function *) + monadInv H7. rename x into tf. + assert (MF: match_function f tf) by (apply transf_function_match; auto). + inversion MF; subst. + econstructor; split. + apply plus_one. constructor. simpl; eauto. reflexivity. + constructor; auto. +- (* external function *) + monadInv H8. econstructor; split. + apply plus_one. econstructor; eauto. + eapply external_call_symbols_preserved'. eauto. + exact symbols_preserved. exact public_preserved. exact varinfo_preserved. + constructor; auto. +- (* return *) + inv H3. inv H1. + econstructor; split. + eapply plus_left. econstructor. apply eval_add_delta_ranges. traceEq. + constructor; auto. +Qed. + +Lemma transf_initial_states: + forall st1, initial_state prog st1 -> + exists st2, initial_state tprog st2 /\ match_states st1 st2. +Proof. + intros. inversion H. + exploit function_ptr_translated; eauto. intros [tf [A B]]. + exists (Callstate nil tf (Locmap.init Vundef) m0); split. + econstructor; eauto. eapply Genv.init_mem_transf_partial; eauto. + replace (prog_main tprog) with (prog_main prog). + rewrite symbols_preserved. eauto. + symmetry. apply (transform_partial_program_main transf_fundef _ TRANSF). + rewrite <- H3. apply sig_preserved. auto. + constructor. constructor. auto. +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. inv H6. econstructor; eauto. +Qed. + +Theorem transf_program_correct: + forward_simulation (semantics prog) (semantics tprog). +Proof. + eapply forward_simulation_plus. + eexact public_preserved. + eexact transf_initial_states. + eexact transf_final_states. + eexact transf_step_correct. +Qed. + +End PRESERVATION. diff --git a/backend/Inlining.v b/backend/Inlining.v index 4f17d59c..08f2bfc4 100644 --- a/backend/Inlining.v +++ b/backend/Inlining.v @@ -203,15 +203,21 @@ Definition sop (ctx: context) (op: operation) := Definition saddr (ctx: context) (addr: addressing) := shift_stack_addressing (Int.repr ctx.(dstk)) addr. -Fixpoint sannotarg (ctx: context) (a: annot_arg reg) : annot_arg reg := +Fixpoint sbuiltinarg (ctx: context) (a: builtin_arg reg) : builtin_arg reg := match a with - | AA_base x => AA_base (sreg ctx x) - | AA_loadstack chunk ofs => AA_loadstack chunk (Int.add ofs (Int.repr ctx.(dstk))) - | AA_addrstack ofs => AA_addrstack (Int.add ofs (Int.repr ctx.(dstk))) - | AA_longofwords hi lo => AA_longofwords (sannotarg ctx hi) (sannotarg ctx lo) + | BA x => BA (sreg ctx x) + | BA_loadstack chunk ofs => BA_loadstack chunk (Int.add ofs (Int.repr ctx.(dstk))) + | BA_addrstack ofs => BA_addrstack (Int.add ofs (Int.repr ctx.(dstk))) + | BA_splitlong hi lo => BA_splitlong (sbuiltinarg ctx hi) (sbuiltinarg ctx lo) | _ => a end. +Definition sbuiltinres (ctx: context) (a: builtin_res reg) : builtin_res reg := + match a with + | BR x => BR (sreg ctx x) + | _ => BR_none + end. + (** The initial context, used to copy the CFG of a toplevel function. *) Definition initcontext (dpc dreg nreg: positive) (sz: Z) := @@ -390,10 +396,7 @@ Definition expand_instr (ctx: context) (pc: node) (i: instruction): mon unit := end | Ibuiltin ef args res s => set_instr (spc ctx pc) - (Ibuiltin ef (sregs ctx args) (sreg ctx res) (spc ctx s)) - | Iannot ef args s => - set_instr (spc ctx pc) - (Iannot ef (map (sannotarg ctx) args) (spc ctx s)) + (Ibuiltin ef (map (sbuiltinarg ctx) args) (sbuiltinres 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)) diff --git a/backend/Inliningproof.v b/backend/Inliningproof.v index 993e0b34..c7cc8d8a 100644 --- a/backend/Inliningproof.v +++ b/backend/Inliningproof.v @@ -400,25 +400,25 @@ Proof. eapply function_ptr_translated; eauto. Qed. -(** Translation of annotation arguments. *) +(** Translation of builtin arguments. *) -Lemma tr_annot_arg: +Lemma tr_builtin_arg: forall F bound ctx rs rs' sp sp' m m', match_globalenvs F bound -> agree_regs F ctx rs rs' -> F sp = Some(sp', ctx.(dstk)) -> Mem.inject F m m' -> forall a v, - eval_annot_arg ge (fun r => rs#r) (Vptr sp Int.zero) m a v -> - exists v', eval_annot_arg tge (fun r => rs'#r) (Vptr sp' Int.zero) m' (sannotarg ctx a) v' + eval_builtin_arg ge (fun r => rs#r) (Vptr sp Int.zero) m a v -> + exists v', eval_builtin_arg tge (fun r => rs'#r) (Vptr sp' Int.zero) m' (sbuiltinarg ctx a) v' /\ Val.inject F v v'. Proof. intros until m'; intros MG AG SP MI. induction 1; simpl. - exists rs'#(sreg ctx x); split. constructor. eapply agree_val_reg; eauto. -- econstructor; eauto with aarg. -- econstructor; eauto with aarg. -- econstructor; eauto with aarg. -- econstructor; eauto with aarg. +- econstructor; eauto with barg. +- econstructor; eauto with barg. +- econstructor; eauto with barg. +- econstructor; eauto with barg. - exploit Mem.loadv_inject; eauto. instantiate (1 := Vptr sp' (Int.add ofs (Int.repr (dstk ctx)))). simpl. econstructor; eauto. rewrite Int.add_zero_l; auto. @@ -429,30 +429,30 @@ Proof. rewrite symbols_preserved. destruct (Genv.find_symbol ge id) as [b|] eqn:FS; auto. inv MG. econstructor. eauto. rewrite Int.add_zero; auto. } exploit Mem.loadv_inject; eauto. intros (v' & A & B). - exists v'; eauto with aarg. + exists v'; eauto with barg. - econstructor; split. constructor. unfold Senv.symbol_address; simpl; unfold Genv.symbol_address. rewrite symbols_preserved. destruct (Genv.find_symbol ge id) as [b|] eqn:FS; auto. inv MG. econstructor. eauto. rewrite Int.add_zero; auto. -- destruct IHeval_annot_arg1 as (v1 & A1 & B1). - destruct IHeval_annot_arg2 as (v2 & A2 & B2). - econstructor; split. eauto with aarg. apply Val.longofwords_inject; auto. +- destruct IHeval_builtin_arg1 as (v1 & A1 & B1). + destruct IHeval_builtin_arg2 as (v2 & A2 & B2). + econstructor; split. eauto with barg. apply Val.longofwords_inject; auto. Qed. -Lemma tr_annot_args: +Lemma tr_builtin_args: forall F bound ctx rs rs' sp sp' m m', match_globalenvs F bound -> agree_regs F ctx rs rs' -> F sp = Some(sp', ctx.(dstk)) -> Mem.inject F m m' -> forall al vl, - eval_annot_args ge (fun r => rs#r) (Vptr sp Int.zero) m al vl -> - exists vl', eval_annot_args tge (fun r => rs'#r) (Vptr sp' Int.zero) m' (map (sannotarg ctx) al) vl' + eval_builtin_args ge (fun r => rs#r) (Vptr sp Int.zero) m al vl -> + exists vl', eval_builtin_args tge (fun r => rs'#r) (Vptr sp' Int.zero) m' (map (sbuiltinarg ctx) al) vl' /\ Val.inject_list F vl vl'. Proof. induction 5; simpl. - exists (@nil val); split; constructor. -- exploit tr_annot_arg; eauto. intros (v1' & A & B). +- exploit tr_builtin_arg; eauto. intros (v1' & A & B). destruct IHlist_forall2 as (vl' & C & D). exists (v1' :: vl'); split; constructor; auto. Qed. @@ -663,6 +663,15 @@ Proof. intros. apply Regmap.gso. zify. unfold sreg; rewrite shiftpos_eq. xomega. Qed. +Lemma match_stacks_inside_set_res: + forall F m m' stk stk' f' ctx sp' rs' res v, + match_stacks_inside F m m' stk stk' f' ctx sp' rs' -> + match_stacks_inside F m m' stk stk' f' ctx sp' (regmap_setres (sbuiltinres ctx res) v rs'). +Proof. + intros. destruct res; simpl; auto. + apply match_stacks_inside_set_reg; auto. +Qed. + (** Preservation by a memory store *) Lemma match_stacks_inside_store: @@ -1064,46 +1073,23 @@ Proof. (* 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 public_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. - -(* annot *) - exploit tr_funbody_inv; eauto. intros TR; inv TR. exploit match_stacks_inside_globalenvs; eauto. intros [bound MG]. - exploit tr_annot_args; eauto. intros (vargs' & P & Q). + exploit tr_builtin_args; eauto. intros (vargs' & P & Q). exploit external_call_mem_inject; eauto. eapply match_stacks_inside_globals; eauto. intros [F1 [v1 [m1' [A [B [C [D [E [J K]]]]]]]]]. left; econstructor; split. - eapply plus_one. eapply exec_Iannot; eauto. + eapply plus_one. eapply exec_Ibuiltin; eauto. eapply external_call_symbols_preserved; eauto. exact symbols_preserved. exact public_preserved. exact varinfo_preserved. econstructor. + eapply match_stacks_inside_set_res. 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_regs_incr; eauto. auto. auto. + auto. + destruct res; simpl; [apply agree_set_reg;auto|idtac|idtac]; eapply agree_regs_incr; eauto. + auto. auto. eapply external_call_valid_block; eauto. eapply range_private_extcall; eauto. intros; eapply external_call_max_perm; eauto. diff --git a/backend/Inliningspec.v b/backend/Inliningspec.v index f7e6c317..161e2a6e 100644 --- a/backend/Inliningspec.v +++ b/backend/Inliningspec.v @@ -313,12 +313,9 @@ Inductive tr_instr: context -> node -> instruction -> code -> Prop := 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)) -> + match res with BR r => Ple r ctx.(mreg) | _ => True end -> + c!(spc ctx pc) = Some (Ibuiltin ef (map (sbuiltinarg ctx) args) (sbuiltinres ctx res) (spc ctx s)) -> tr_instr ctx pc (Ibuiltin ef args res s) c - | tr_annot: forall ctx pc c ef args s, - c!(spc ctx pc) = Some (Iannot ef (map (sannotarg ctx) args) (spc ctx s)) -> - tr_instr ctx pc (Iannot ef args 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 @@ -554,6 +551,8 @@ Proof. red; simpl. subst s2; simpl in *; xomega. red; auto. +(* builtin *) + eapply tr_builtin; eauto. destruct b; eauto. (* return *) destruct (retinfo ctx) as [[rpc rreg] | ] eqn:?. (* inlined *) diff --git a/backend/LTL.v b/backend/LTL.v index 8c2749a7..67fb0197 100644 --- a/backend/LTL.v +++ b/backend/LTL.v @@ -44,8 +44,7 @@ Inductive instruction: Type := | Lstore (chunk: memory_chunk) (addr: addressing) (args: list mreg) (src: mreg) | Lcall (sg: signature) (ros: mreg + ident) | Ltailcall (sg: signature) (ros: mreg + ident) - | Lbuiltin (ef: external_function) (args: list mreg) (res: list mreg) - | Lannot (ef: external_function) (args: list (annot_arg loc)) + | Lbuiltin (ef: external_function) (args: list (builtin_arg loc)) (res: builtin_res mreg) | Lbranch (s: node) | Lcond (cond: condition) (args: list mreg) (s1 s2: node) | Ljumptable (arg: mreg) (tbl: list node) @@ -239,16 +238,12 @@ Inductive step: state -> trace -> state -> Prop := Mem.free m sp 0 f.(fn_stacksize) = Some m' -> step (Block s f (Vptr sp Int.zero) (Ltailcall sig ros :: bb) rs m) E0 (Callstate s fd rs' m') - | exec_Lbuiltin: forall s f sp ef args res bb rs m t vl rs' m', - external_call' ef ge (reglist rs args) m t vl m' -> - rs' = Locmap.setlist (map R res) vl (undef_regs (destroyed_by_builtin ef) rs) -> + | exec_Lbuiltin: forall s f sp ef args res bb rs m vargs t vres rs' m', + eval_builtin_args ge rs sp m args vargs -> + external_call ef ge vargs m t vres m' -> + rs' = Locmap.setres res vres (undef_regs (destroyed_by_builtin ef) rs) -> step (Block s f sp (Lbuiltin ef args res :: bb) rs m) t (Block s f sp bb rs' m') - | exec_Lannot: forall s f sp ef args bb rs vl m t v' m', - eval_annot_args ge rs sp m args vl -> - external_call ef ge vl m t v' m' -> - step (Block s f sp (Lannot ef args :: bb) rs m) - t (Block s f sp bb rs m') | exec_Lbranch: forall s f sp pc bb rs m, step (Block s f sp (Lbranch pc :: bb) rs m) E0 (State s f sp pc rs m) diff --git a/backend/Linear.v b/backend/Linear.v index 5d1fc0d8..8c91a809 100644 --- a/backend/Linear.v +++ b/backend/Linear.v @@ -41,8 +41,7 @@ Inductive instruction: Type := | Lstore: memory_chunk -> addressing -> list mreg -> mreg -> instruction | Lcall: signature -> mreg + ident -> instruction | Ltailcall: signature -> mreg + ident -> instruction - | Lbuiltin: external_function -> list mreg -> list mreg -> instruction - | Lannot: external_function -> list (annot_arg loc) -> instruction + | Lbuiltin: external_function -> list (builtin_arg loc) -> builtin_res mreg -> instruction | Llabel: label -> instruction | Lgoto: label -> instruction | Lcond: condition -> list mreg -> label -> instruction @@ -198,17 +197,12 @@ Inductive step: state -> trace -> state -> Prop := step (State s f (Vptr stk Int.zero) (Ltailcall sig ros :: b) rs m) E0 (Callstate s f' rs' m') | exec_Lbuiltin: - forall s f sp rs m ef args res b t vl rs' m', - external_call' ef ge (reglist rs args) m t vl m' -> - rs' = Locmap.setlist (map R res) vl (undef_regs (destroyed_by_builtin ef) rs) -> + forall s f sp rs m ef args res b vargs t vres rs' m', + eval_builtin_args ge rs sp m args vargs -> + external_call ef ge vargs m t vres m' -> + rs' = Locmap.setres res vres (undef_regs (destroyed_by_builtin ef) rs) -> step (State s f sp (Lbuiltin ef args res :: b) rs m) t (State s f sp b rs' m') - | exec_Lannot: - forall s f sp rs m ef args vl b t v m', - eval_annot_args ge rs sp m args vl -> - external_call ef ge vl m t v m' -> - step (State s f sp (Lannot ef args :: b) rs m) - t (State s f sp b rs m') | exec_Llabel: forall s f sp lbl b rs m, step (State s f sp (Llabel lbl :: b) rs m) diff --git a/backend/Linearize.v b/backend/Linearize.v index b1102e23..78cdd743 100644 --- a/backend/Linearize.v +++ b/backend/Linearize.v @@ -187,8 +187,6 @@ Fixpoint linearize_block (b: LTL.bblock) (k: code) : code := Ltailcall sig ros :: k | LTL.Lbuiltin ef args res :: b' => Lbuiltin ef args res :: linearize_block b' k - | LTL.Lannot ef args :: b' => - Lannot ef args :: linearize_block b' k | LTL.Lbranch s :: b' => add_branch s k | LTL.Lcond cond args s1 s2 :: b' => diff --git a/backend/Linearizeproof.v b/backend/Linearizeproof.v index 08bcd3f3..dc4d11ea 100644 --- a/backend/Linearizeproof.v +++ b/backend/Linearizeproof.v @@ -644,14 +644,7 @@ Proof. (* Lbuiltin *) left; econstructor; split. simpl. apply plus_one. eapply exec_Lbuiltin; eauto. - eapply external_call_symbols_preserved'; eauto. - exact symbols_preserved. exact public_preserved. exact varinfo_preserved. - econstructor; eauto. - - (* Lannot *) - left; econstructor; split. simpl. - apply plus_one. eapply exec_Lannot; eauto. - eapply eval_annot_args_preserved with (ge1 := ge); eauto. exact symbols_preserved. + eapply eval_builtin_args_preserved with (ge1 := ge); eauto. exact symbols_preserved. eapply external_call_symbols_preserved; eauto. exact symbols_preserved. exact public_preserved. exact varinfo_preserved. econstructor; eauto. diff --git a/backend/Lineartyping.v b/backend/Lineartyping.v index c093b62d..62a0c585 100644 --- a/backend/Lineartyping.v +++ b/backend/Lineartyping.v @@ -55,6 +55,13 @@ Definition loc_valid (l: loc) : bool := | S _ _ _ => false end. +Fixpoint wt_builtin_res (ty: typ) (res: builtin_res mreg) : bool := + match res with + | BR r => subtype ty (mreg_type r) + | BR_none => true + | BR_splitlong hi lo => wt_builtin_res Tint hi && wt_builtin_res Tint lo + end. + Definition wt_instr (i: instruction) : bool := match i with | Lgetstack sl ofs ty r => @@ -74,9 +81,8 @@ Definition wt_instr (i: instruction) : bool := | Ltailcall sg ros => zeq (size_arguments sg) 0 | Lbuiltin ef args res => - subtype_list (proj_sig_res' (ef_sig ef)) (map mreg_type res) - | Lannot ef args => - forallb loc_valid (params_of_annot_args args) + wt_builtin_res (proj_sig_res (ef_sig ef)) res + && forallb loc_valid (params_of_builtin_args args) | _ => true end. @@ -161,6 +167,20 @@ Proof. destruct H. apply IHvl; auto. apply wt_setreg; auto. Qed. +Lemma wt_setres: + forall res ty v rs, + wt_builtin_res ty res = true -> + Val.has_type v ty -> + wt_locset rs -> + wt_locset (Locmap.setres res v rs). +Proof. + induction res; simpl; intros. +- apply wt_setreg; auto. eapply Val.has_subtype; eauto. +- auto. +- InvBooleans. eapply IHres2; eauto. destruct v; exact I. + eapply IHres1; eauto. destruct v; exact I. +Qed. + Lemma wt_find_label: forall f lbl c, wt_function f = true -> @@ -291,12 +311,8 @@ Proof. - (* builtin *) simpl in *; InvBooleans. econstructor; eauto. - apply wt_setlist. - eapply Val.has_subtype_list; eauto. eapply external_call_well_typed'; eauto. + eapply wt_setres; eauto. eapply external_call_well_typed; eauto. apply wt_undef_regs; auto. -- (* annot *) - simpl in *; InvBooleans. - econstructor; eauto. - (* label *) simpl in *. econstructor; eauto. - (* goto *) @@ -362,10 +378,10 @@ Proof. intros. inv H. simpl in WTC; InvBooleans. auto. Qed. -Lemma wt_state_annot: - forall s f sp ef args c rs m, - wt_state (State s f sp (Lannot ef args :: c) rs m) -> - forallb (loc_valid f) (params_of_annot_args args) = true. +Lemma wt_state_builtin: + forall s f sp ef args res c rs m, + wt_state (State s f sp (Lbuiltin ef args res :: c) rs m) -> + forallb (loc_valid f) (params_of_builtin_args args) = true. Proof. intros. inv H. simpl in WTC; InvBooleans. auto. Qed. diff --git a/backend/Liveness.v b/backend/Liveness.v index ce1a798a..b8a5f965 100644 --- a/backend/Liveness.v +++ b/backend/Liveness.v @@ -92,9 +92,8 @@ Definition transfer | Itailcall sig ros args => reg_list_live args (reg_sum_live ros Regset.empty) | Ibuiltin ef args res s => - reg_list_live args (reg_dead res after) - | Iannot ef args s => - reg_list_live (params_of_annot_args args) after + reg_list_live (params_of_builtin_args args) + (reg_list_dead (params_of_builtin_res res) after) | Icond cond args ifso ifnot => reg_list_live args after | Ijumptable arg tbl => diff --git a/backend/Locations.v b/backend/Locations.v index 5674b93a..439cd2dc 100644 --- a/backend/Locations.v +++ b/backend/Locations.v @@ -377,6 +377,14 @@ Module Locmap. destruct vl; auto. destruct H. rewrite IHll; auto. apply gso; auto. apply Loc.diff_sym; auto. Qed. + Fixpoint setres (res: builtin_res mreg) (v: val) (m: t) : t := + match res with + | BR r => set (R r) v m + | BR_none => m + | BR_splitlong hi lo => + setres lo (Val.loword v) (setres hi (Val.hiword v) m) + end. + End Locmap. (** * Total ordering over locations *) diff --git a/backend/Mach.v b/backend/Mach.v index fe00d42d..8853d9da 100644 --- a/backend/Mach.v +++ b/backend/Mach.v @@ -60,8 +60,7 @@ Inductive instruction: Type := | Mstore: memory_chunk -> addressing -> list mreg -> mreg -> instruction | Mcall: signature -> mreg + ident -> instruction | Mtailcall: signature -> mreg + ident -> instruction - | Mbuiltin: external_function -> list mreg -> list mreg -> instruction - | Mannot: external_function -> list (annot_arg mreg) -> instruction + | Mbuiltin: external_function -> list (builtin_arg mreg) -> builtin_res mreg -> instruction | Mlabel: label -> instruction | Mgoto: label -> instruction | Mcond: condition -> list mreg -> label -> instruction @@ -163,6 +162,13 @@ Fixpoint set_regs (rl: list mreg) (vl: list val) (rs: regset) : regset := | _, _ => rs end. +Fixpoint set_res (res: builtin_res mreg) (v: val) (rs: regset) : regset := + match res with + | BR r => Regmap.set r v rs + | BR_none => rs + | BR_splitlong hi lo => set_res lo (Val.loword v) (set_res hi (Val.hiword v) rs) + end. + Definition is_label (lbl: label) (instr: instruction) : bool := match instr with | Mlabel lbl' => if peq lbl lbl' then true else false @@ -328,17 +334,12 @@ Inductive step: state -> trace -> state -> Prop := step (State s fb (Vptr stk soff) (Mtailcall sig ros :: c) rs m) E0 (Callstate s f' rs m') | exec_Mbuiltin: - forall s f sp rs m ef args res b t vl rs' m', - external_call' ef ge rs##args m t vl m' -> - rs' = set_regs res vl (undef_regs (destroyed_by_builtin ef) rs) -> + forall s f sp rs m ef args res b vargs t vres rs' m', + eval_builtin_args ge rs sp m args vargs -> + external_call ef ge vargs m t vres m' -> + rs' = set_res res vres (undef_regs (destroyed_by_builtin ef) rs) -> step (State s f sp (Mbuiltin ef args res :: b) rs m) t (State s f sp b rs' m') - | exec_Mannot: - forall s f sp rs m ef args b vargs t v m', - eval_annot_args ge rs sp m args vargs -> - external_call ef ge vargs m t v m' -> - step (State s f sp (Mannot ef args :: b) rs m) - t (State s f sp b rs m') | exec_Mgoto: forall s fb f sp lbl c rs m c', Genv.find_funct_ptr ge fb = Some (Internal f) -> diff --git a/backend/PrintAsmaux.ml b/backend/PrintAsmaux.ml index efc8030f..324e7e66 100644 --- a/backend/PrintAsmaux.ml +++ b/backend/PrintAsmaux.ml @@ -138,9 +138,6 @@ let cfi_rel_offset = else (fun _ _ _ -> ()) -(* For handling of annotations *) -let re_file_line = Str.regexp "#line:\\(.*\\):\\([1-9][0-9]*\\)$" - (* Basic printing functions *) let coqint oc n = fprintf oc "%ld" (camlint_of_coqint n) @@ -216,36 +213,35 @@ let print_file_line_d2 oc pref file line = | Some fb -> Printlines.copy oc pref fb line line end - -(** "True" annotations *) +(** Programmer-supplied annotations (__builtin_annot). *) let re_annot_param = Str.regexp "%%\\|%[1-9][0-9]*" let rec print_annot print_preg sp_reg_name oc = function - | AA_base x -> print_preg oc x - | AA_int n -> fprintf oc "%ld" (camlint_of_coqint n) - | AA_long n -> fprintf oc "%Ld" (camlint64_of_coqint n) - | AA_float n -> fprintf oc "%.18g" (camlfloat_of_coqfloat n) - | AA_single n -> fprintf oc "%.18g" (camlfloat_of_coqfloat32 n) - | AA_loadstack(chunk, ofs) -> + | BA x -> print_preg oc x + | BA_int n -> fprintf oc "%ld" (camlint_of_coqint n) + | BA_long n -> fprintf oc "%Ld" (camlint64_of_coqint n) + | BA_float n -> fprintf oc "%.18g" (camlfloat_of_coqfloat n) + | BA_single n -> fprintf oc "%.18g" (camlfloat_of_coqfloat32 n) + | BA_loadstack(chunk, ofs) -> fprintf oc "mem(%s + %ld, %ld)" sp_reg_name (camlint_of_coqint ofs) (camlint_of_coqint (size_chunk chunk)) - | AA_addrstack ofs -> + | BA_addrstack ofs -> fprintf oc "(%s + %ld)" sp_reg_name (camlint_of_coqint ofs) - | AA_loadglobal(chunk, id, ofs) -> + | BA_loadglobal(chunk, id, ofs) -> fprintf oc "mem(\"%s\" + %ld, %ld)" (extern_atom id) (camlint_of_coqint ofs) (camlint_of_coqint (size_chunk chunk)) - | AA_addrglobal(id, ofs) -> + | BA_addrglobal(id, ofs) -> fprintf oc "(\"%s\" + %ld)" (extern_atom id) (camlint_of_coqint ofs) - | AA_longofwords(hi, lo) -> + | BA_splitlong(hi, lo) -> fprintf oc "(%a * 0x100000000 + %a)" (print_annot print_preg sp_reg_name) hi (print_annot print_preg sp_reg_name) lo @@ -265,32 +261,72 @@ let print_annot_text print_preg sp_reg_name oc txt args = List.iter print_fragment (Str.full_split re_annot_param txt); fprintf oc "\n" -let print_annot_stmt print_preg sp_reg_name oc txt tys args = - print_annot_text print_preg sp_reg_name oc txt args +(* Printing of [EF_debug] info. To be completed. *) -let print_annot_val print_preg oc txt args = - print_annot_text print_preg "<internal error>" oc txt - (List.map (fun r -> AA_base r) args) +let re_file_line = Str.regexp "#line:\\(.*\\):\\([1-9][0-9]*\\)$" +let print_debug_info comment print_line print_preg sp_name oc kind txt args = + let print_debug_args oc args = + List.iter + (fun a -> fprintf oc " %a" (print_annot print_preg sp_name) a) + args in + match kind with + | 1 -> (* line number *) + if Str.string_match re_file_line txt 0 then + print_line oc (Str.matched_group 1 txt) + (int_of_string (Str.matched_group 2 txt)) + | 2 -> (* assignment to local variable, not useful *) + () + | 3 -> (* beginning of live range for local variable *) + fprintf oc "%s debug: start live range %s =%a\n" + comment txt print_debug_args args + | 4 -> (* end of live range for local variable *) + fprintf oc "%s debug: end live range %s\n" + comment txt + | 5 -> (* local variable preallocated in stack *) + fprintf oc "%s debug: %s resides at%a\n" + comment txt print_debug_args args + | _ -> + () + (** Inline assembly *) -let re_asm_param = Str.regexp "%%\\|%[0-9]+" +let print_asm_argument print_preg oc modifier = function + | BA r -> print_preg oc r + | BA_splitlong(BA hi, BA lo) -> + begin match modifier with + | "R" -> print_preg oc hi + | "Q" -> print_preg oc lo + | _ -> fprintf oc "%a:%a" print_preg hi print_preg lo + (* Probably not what was intended *) + end + | _ -> failwith "bad asm argument" + +let builtin_arg_of_res = function + | BR r -> BA r + | BR_splitlong(BR hi, BR lo) -> BA_splitlong(BA hi, BA lo) + | _ -> assert false + +let re_asm_param_1 = Str.regexp "%%\\|%[QR]?[0-9]+" +let re_asm_param_2 = Str.regexp "%\\([QR]?\\)\\([0-9]+\\)" let print_inline_asm print_preg oc txt sg args res = let operands = - if sg.sig_res = None then args else res @ args in + if sg.sig_res = None then args else builtin_arg_of_res res :: args in let print_fragment = function | Str.Text s -> output_string oc s | Str.Delim "%%" -> output_char oc '%' | Str.Delim s -> - let n = int_of_string (String.sub s 1 (String.length s - 1)) in + assert (Str.string_match re_asm_param_2 s 0); + let modifier = Str.matched_group 1 s + and number = int_of_string (Str.matched_group 2 s) in try - print_preg oc (List.nth operands n) + print_asm_argument print_preg oc modifier (List.nth operands number) with Failure _ -> fprintf oc "<bad parameter %s>" s in - List.iter print_fragment (Str.full_split re_asm_param txt); + List.iter print_fragment (Str.full_split re_asm_param_1 txt); fprintf oc "\n" diff --git a/backend/PrintLTL.ml b/backend/PrintLTL.ml index 27936f9b..0f78bc58 100644 --- a/backend/PrintLTL.ml +++ b/backend/PrintLTL.ml @@ -79,10 +79,9 @@ let print_instruction pp succ = function fprintf pp "tailcall %a" ros fn | Lbuiltin(ef, args, res) -> fprintf pp "%a = %s(%a)" - mregs res (name_of_external ef) mregs args - | Lannot(ef, args) -> - fprintf pp "%s(%a)\n" - (name_of_external ef) (print_annot_args loc) args + (print_builtin_res mreg) res + (name_of_external ef) + (print_builtin_args loc) args | Lbranch s -> print_succ pp s succ | Lcond(cond, args, s1, s2) -> diff --git a/backend/PrintMach.ml b/backend/PrintMach.ml index 8484a5c3..0ce2e87b 100644 --- a/backend/PrintMach.ml +++ b/backend/PrintMach.ml @@ -67,10 +67,9 @@ let print_instruction pp i = fprintf pp "\ttailcall %a\n" ros fn | Mbuiltin(ef, args, res) -> fprintf pp "\t%a = %s(%a)\n" - regs res (name_of_external ef) regs args - | Mannot(ef, args) -> - fprintf pp "\t%s(%a)\n" - (name_of_external ef) (print_annot_args reg) args + (print_builtin_res reg) res + (name_of_external ef) + (print_builtin_args reg) args | Mlabel lbl -> fprintf pp "%5d:" (P.to_int lbl) | Mgoto lbl -> diff --git a/backend/PrintRTL.ml b/backend/PrintRTL.ml index ce2275cf..78ce1816 100644 --- a/backend/PrintRTL.ml +++ b/backend/PrintRTL.ml @@ -72,11 +72,9 @@ let print_instruction pp (pc, i) = ros fn regs args | Ibuiltin(ef, args, res, s) -> fprintf pp "%a = %s(%a)\n" - reg res (name_of_external ef) regs args; - print_succ pp s (pc - 1) - | Iannot(ef, args, s) -> - fprintf pp "%s(%a)\n" - (name_of_external ef) (print_annot_args reg) args; + (print_builtin_res reg) res + (name_of_external ef) + (print_builtin_args reg) args; print_succ pp s (pc - 1) | Icond(cond, args, s1, s2) -> fprintf pp "if (%a) goto %d else goto %d\n" diff --git a/backend/PrintXTL.ml b/backend/PrintXTL.ml index b9813db0..bb67dc96 100644 --- a/backend/PrintXTL.ml +++ b/backend/PrintXTL.ml @@ -101,10 +101,9 @@ let print_instruction pp succ = function fprintf pp "tailcall %a(%a)" ros fn vars args | Xbuiltin(ef, args, res) -> fprintf pp "%a = %s(%a)" - vars res (name_of_external ef) vars args - | Xannot(ef, args) -> - fprintf pp "%s(%a)" - (name_of_external ef) (print_annot_args var) args + (print_builtin_res var) res + (name_of_external ef) + (print_builtin_args var) args | Xbranch s -> print_succ pp s succ | Xcond(cond, args, s1, s2) -> diff --git a/backend/RTL.v b/backend/RTL.v index 83761c42..56a5efeb 100644 --- a/backend/RTL.v +++ b/backend/RTL.v @@ -70,13 +70,10 @@ Inductive instruction: Type := | Itailcall: signature -> reg + ident -> list reg -> instruction (** [Itailcall sig fn args] performs a function invocation in tail-call position. *) - | Ibuiltin: external_function -> list reg -> reg -> node -> instruction + | Ibuiltin: external_function -> list (builtin_arg reg) -> builtin_res reg -> node -> instruction (** [Ibuiltin ef args dest succ] calls the built-in function identified by [ef], giving it the values of [args] as arguments. It stores the return value in [dest] and branches to [succ]. *) - | Iannot: external_function -> list (annot_arg reg) -> node -> instruction - (** [Iannot ef args succ] is similar to [Ibuiltin] but specialized - to annotations. *) | Icond: condition -> list reg -> node -> node -> instruction (** [Icond cond args ifso ifnot] evaluates the boolean condition [cond] over the values of registers [args]. If the condition @@ -253,19 +250,12 @@ Inductive step: state -> trace -> state -> Prop := step (State s f (Vptr stk Int.zero) pc rs m) E0 (Callstate s fd rs##args m') | exec_Ibuiltin: - forall s f sp pc rs m ef args res pc' t v m', + forall s f sp pc rs m ef args res pc' vargs t vres m', (fn_code f)!pc = Some(Ibuiltin ef args res pc') -> - external_call ef ge rs##args m t v m' -> - step (State s f sp pc rs m) - t (State s f sp pc' (rs#res <- v) m') - | exec_Iannot: - forall s f sp pc rs m ef args pc' vargs vres t m', - (fn_code f)!pc = Some(Iannot ef args pc') -> - match ef with EF_annot _ _ => True | _ => False end -> - eval_annot_args ge (fun r => rs#r) sp m args vargs -> + eval_builtin_args ge (fun r => rs#r) sp m args vargs -> external_call ef ge vargs m t vres m' -> step (State s f sp pc rs m) - t (State s f sp pc' rs m') + t (State s f sp pc' (regmap_setres res vres rs) m') | exec_Icond: forall s f sp pc rs m cond args ifso ifnot b pc', (fn_code f)!pc = Some(Icond cond args ifso ifnot) -> @@ -367,16 +357,13 @@ Proof. intros. subst. inv H0. exists s1; auto. inversion H; subst; auto. exploit external_call_receptive; eauto. intros [vres2 [m2 EC2]]. - exists (State s0 f sp pc' (rs#res <- vres2) m2). eapply exec_Ibuiltin; eauto. - exploit external_call_receptive; eauto. intros [vres2 [m2 EC2]]. - exists (State s0 f sp pc' rs m2). eapply exec_Iannot; eauto. + exists (State s0 f sp pc' (regmap_setres res vres2 rs) m2). eapply exec_Ibuiltin; eauto. exploit external_call_receptive; eauto. intros [vres2 [m2 EC2]]. exists (Returnstate s0 vres2 m2). econstructor; eauto. (* trace length *) red; intros; inv H; simpl; try omega. eapply external_call_trace_length; eauto. eapply external_call_trace_length; eauto. - eapply external_call_trace_length; eauto. Qed. (** * Operations on RTL abstract syntax *) @@ -411,7 +398,6 @@ Definition successors_instr (i: instruction) : list node := | Icall sig ros args res s => s :: nil | Itailcall sig ros args => nil | Ibuiltin ef args res s => s :: nil - | Iannot ef args s => s :: nil | Icond cond args ifso ifnot => ifso :: ifnot :: nil | Ijumptable arg tbl => tbl | Ireturn optarg => nil @@ -432,8 +418,7 @@ Definition instr_uses (i: instruction) : list reg := | Icall sig (inr id) args res s => args | Itailcall sig (inl r) args => r :: args | Itailcall sig (inr id) args => args - | Ibuiltin ef args res s => args - | Iannot ef args s => params_of_annot_args args + | Ibuiltin ef args res s => params_of_builtin_args args | Icond cond args ifso ifnot => args | Ijumptable arg tbl => arg :: nil | Ireturn None => nil @@ -450,8 +435,8 @@ Definition instr_defs (i: instruction) : option reg := | Istore chunk addr args src s => None | Icall sig ros args res s => Some res | Itailcall sig ros args => None - | Ibuiltin ef args res s => Some res - | Iannot ef args s => None + | Ibuiltin ef args res s => + match res with BR r => Some r | _ => None end | Icond cond args ifso ifnot => None | Ijumptable arg tbl => None | Ireturn optarg => None @@ -492,8 +477,9 @@ Definition max_reg_instr (m: positive) (pc: node) (i: instruction) := | Icall sig (inr id) args res s => fold_left Pmax args (Pmax res m) | Itailcall sig (inl r) args => fold_left Pmax args (Pmax r m) | Itailcall sig (inr id) args => fold_left Pmax args m - | Ibuiltin ef args res s => fold_left Pmax args (Pmax res m) - | Iannot ef args s => fold_left Pmax (params_of_annot_args args) m + | Ibuiltin ef args res s => + fold_left Pmax (params_of_builtin_args args) + (fold_left Pmax (params_of_builtin_res res) m) | Icond cond args ifso ifnot => fold_left Pmax args m | Ijumptable arg tbl => Pmax arg m | Ireturn None => m @@ -513,7 +499,7 @@ Proof. { induction l; simpl; intros. auto. apply IHl. xomega. } - destruct i; simpl; try (destruct s0); try (apply X); try xomega. + destruct i; simpl; try (destruct s0); repeat (apply X); try xomega. destruct o; xomega. Qed. @@ -527,7 +513,7 @@ Proof. - apply X. xomega. - apply X. xomega. - destruct s0; apply X; xomega. -- apply X. xomega. +- destruct b; inv H1. apply X. simpl. xomega. Qed. Remark max_reg_instr_uses: diff --git a/backend/RTLgen.v b/backend/RTLgen.v index b1c36513..d818de58 100644 --- a/backend/RTLgen.v +++ b/backend/RTLgen.v @@ -381,6 +381,47 @@ Definition add_move (rs rd: reg) (nd: node) : mon node := then ret nd else add_instr (Iop Omove (rs::nil) rd nd). +(** Translation of arguments and results of builtins. *) + +Definition exprlist_of_expr_list (l: list expr) : exprlist := + List.fold_right Econs Enil l. + +Fixpoint convert_builtin_arg {A: Type} (a: builtin_arg expr) (rl: list A) : builtin_arg A * list A := + match a with + | BA a => + match rl with + | r :: rs => (BA r, rs) + | nil => (BA_int Int.zero, nil) (**r never happens *) + end + | BA_int n => (BA_int n, rl) + | BA_long n => (BA_long n, rl) + | BA_float n => (BA_float n, rl) + | BA_single n => (BA_single n, rl) + | BA_loadstack chunk ofs => (BA_loadstack chunk ofs, rl) + | BA_addrstack ofs => (BA_addrstack ofs, rl) + | BA_loadglobal chunk id ofs => (BA_loadglobal chunk id ofs, rl) + | BA_addrglobal id ofs => (BA_addrglobal id ofs, rl) + | BA_splitlong hi lo => + let (hi', rl1) := convert_builtin_arg hi rl in + let (lo', rl2) := convert_builtin_arg lo rl1 in + (BA_splitlong hi' lo', rl2) + end. + +Fixpoint convert_builtin_args {A: Type} (al: list (builtin_arg expr)) (rl: list A) : list (builtin_arg A) := + match al with + | nil => nil + | a1 :: al => + let (a1', rl1) := convert_builtin_arg a1 rl in + a1' :: convert_builtin_args al rl1 + end. + +Definition convert_builtin_res (map: mapping) (r: builtin_res ident) : mon (builtin_res reg) := + match r with + | BR id => do r <- find_var map id; ret (BR r) + | BR_none => ret BR_none + | _ => error (Errors.msg "RTLgen: bad builtin_res") + end. + (** Translation of an expression. [transl_expr map a rd nd] enriches the current CFG with the RTL instructions necessary to compute the value of CminorSel expression [a], leave its result @@ -413,7 +454,7 @@ Fixpoint transl_expr (map: mapping) (a: expr) (rd: reg) (nd: node) do r <- find_letvar map n; add_move r rd nd | Ebuiltin ef al => do rl <- alloc_regs map al; - do no <- add_instr (Ibuiltin ef rl rd nd); + do no <- add_instr (Ibuiltin ef (List.map (@BA reg) rl) (BR rd) nd); transl_exprlist map al rl no | Eexternal id sg al => do rl <- alloc_regs map al; @@ -455,39 +496,6 @@ with transl_condexpr (map: mapping) (a: condexpr) (ntrue nfalse: node) transl_expr map b r nc end. -(** Translation of arguments to annotations. *) - -Definition exprlist_of_expr_list (l: list expr) : exprlist := - List.fold_right Econs Enil l. - -Fixpoint convert_annot_arg {A: Type} (a: annot_arg expr) (rl: list A) : annot_arg A * list A := - match a with - | AA_base a => - match rl with - | r :: rs => (AA_base r, rs) - | nil => (AA_int Int.zero, nil) (**r never happens *) - end - | AA_int n => (AA_int n, rl) - | AA_long n => (AA_long n, rl) - | AA_float n => (AA_float n, rl) - | AA_single n => (AA_single n, rl) - | AA_loadstack chunk ofs => (AA_loadstack chunk ofs, rl) - | AA_addrstack ofs => (AA_addrstack ofs, rl) - | AA_loadglobal chunk id ofs => (AA_loadglobal chunk id ofs, rl) - | AA_addrglobal id ofs => (AA_addrglobal id ofs, rl) - | AA_longofwords hi lo => - let (hi', rl1) := convert_annot_arg hi rl in - let (lo', rl2) := convert_annot_arg lo rl1 in - (AA_longofwords hi' lo', rl2) - end. - -Fixpoint convert_annot_args {A: Type} (al: list (annot_arg expr)) (rl: list A) : list (annot_arg A) := - match al with - | nil => nil - | a1 :: al => - let (a1', rl1) := convert_annot_arg a1 rl in a1' :: convert_annot_args al rl1 - end. - (** Auxiliary for translating exit expressions. *) Definition transl_exit (nexits: list node) (n: nat) : mon node := @@ -586,15 +594,12 @@ Fixpoint transl_stmt (map: mapping) (s: stmt) (nd: node) 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; - do n1 <- add_instr (Ibuiltin ef rargs r nd); - transl_exprlist map al rargs n1 - | Sannot ef args => - let al := exprlist_of_expr_list (params_of_annot_args args) in + | Sbuiltin res ef args => + let al := exprlist_of_expr_list (params_of_builtin_args args) in do rargs <- alloc_regs map al; - do n1 <- add_instr (Iannot ef (convert_annot_args args rargs) nd); + let args' := convert_builtin_args args rargs in + do res' <- convert_builtin_res map res; + do n1 <- add_instr (Ibuiltin ef args' res' nd); transl_exprlist map al rargs n1 | Sseq s1 s2 => do ns <- transl_stmt map s2 nd nexits ngoto nret rret; diff --git a/backend/RTLgenaux.ml b/backend/RTLgenaux.ml index 40bb5c41..e3373bf9 100644 --- a/backend/RTLgenaux.ml +++ b/backend/RTLgenaux.ml @@ -12,6 +12,7 @@ open Datatypes open Camlcoq +open AST open Switch open CminorSel @@ -48,6 +49,10 @@ and size_condexpr = function | CElet(a, c) -> size_expr a + size_condexpr c +let size_exprlist al = List.fold_right (fun a s -> size_expr a + s) al 0 + +let size_builtin_args al = size_exprlist (params_of_builtin_args al) + let rec size_exitexpr = function | XEexit n -> 0 | XEjumptable(arg, tbl) -> 2 + size_expr arg @@ -72,8 +77,8 @@ let rec size_stmt = function 3 + size_eos eos + size_exprs args + length_exprs args | Stailcall(sg, eos, args) -> 3 + size_eos eos + size_exprs args + length_exprs args - | Sbuiltin(optid, ef, args) -> 1 + size_exprs args - | Sannot(txt, args) -> 0 + | Sbuiltin(_, (EF_annot _ | EF_debug _), _) -> 0 + | Sbuiltin(optid, ef, args) -> 1 + size_builtin_args args | Sseq(s1, s2) -> size_stmt s1 + size_stmt s2 | Sifthenelse(ce, s1, s2) -> size_condexpr ce + max (size_stmt s1) (size_stmt s2) diff --git a/backend/RTLgenproof.v b/backend/RTLgenproof.v index 02460f67..559ab3a2 100644 --- a/backend/RTLgenproof.v +++ b/backend/RTLgenproof.v @@ -220,6 +220,22 @@ Proof. Qed. Hint Resolve match_env_update_dest: rtlg. +(** A variant of [match_env_update_var] corresponding to the assignment + of the result of a builtin. *) + +Lemma match_env_update_res: + forall map res v e le tres tv rs, + Val.lessdef v tv -> + map_wf map -> + tr_builtin_res map res tres -> + match_env map e le rs -> + match_env map (set_builtin_res res v e) le (regmap_setres tres tv rs). +Proof. + intros. inv H1; simpl. +- eapply match_env_update_var; eauto. +- auto. +Qed. + (** Matching and [let]-bound variables. *) Lemma match_env_bind_letvar: @@ -677,6 +693,15 @@ Proof. auto. Qed. +Remark eval_builtin_args_trivial: + forall (ge: RTL.genv) (rs: regset) sp m rl, + eval_builtin_args ge (fun r => rs#r) sp m (List.map (@BA reg) rl) rs##rl. +Proof. + induction rl; simpl. +- constructor. +- constructor; auto. constructor. +Qed. + Lemma transl_expr_Ebuiltin_correct: forall le ef al vl v, eval_exprlist ge sp e m le al vl -> @@ -691,7 +716,9 @@ Proof. exists (rs1#rd <- v'); exists tm2. (* Exec *) split. eapply star_right. eexact EX1. + change (rs1#rd <- v') with (regmap_setres (BR rd) v' rs1). eapply exec_Ibuiltin; eauto. + eapply eval_builtin_args_trivial. eapply external_call_symbols_preserved; eauto. exact symbols_preserved. exact public_preserved. exact varinfo_preserved. reflexivity. @@ -972,7 +999,7 @@ Proof. auto. Qed. -(** Annotation arguments. *) +(** Builtin arguments. *) Lemma eval_exprlist_append: forall le al1 vl1 al2 vl2, @@ -985,54 +1012,54 @@ Proof. - simpl. constructor; eauto. Qed. -Lemma invert_eval_annot_arg: +Lemma invert_eval_builtin_arg: forall a v, - eval_annot_arg ge sp e m a v -> + eval_builtin_arg ge sp e m a v -> exists vl, - eval_exprlist ge sp e m nil (exprlist_of_expr_list (params_of_annot_arg a)) vl - /\ Events.eval_annot_arg ge (fun v => v) sp m (fst (convert_annot_arg a vl)) v - /\ (forall vl', convert_annot_arg a (vl ++ vl') = (fst (convert_annot_arg a vl), vl')). + eval_exprlist ge sp e m nil (exprlist_of_expr_list (params_of_builtin_arg a)) vl + /\ Events.eval_builtin_arg ge (fun v => v) sp m (fst (convert_builtin_arg a vl)) v + /\ (forall vl', convert_builtin_arg a (vl ++ vl') = (fst (convert_builtin_arg a vl), vl')). Proof. - induction 1; simpl; econstructor; intuition eauto with evalexpr aarg. + induction 1; simpl; econstructor; intuition eauto with evalexpr barg. constructor. constructor. repeat constructor. Qed. -Lemma invert_eval_annot_args: +Lemma invert_eval_builtin_args: forall al vl, - list_forall2 (eval_annot_arg ge sp e m) al vl -> + list_forall2 (eval_builtin_arg ge sp e m) al vl -> exists vl', - eval_exprlist ge sp e m nil (exprlist_of_expr_list (params_of_annot_args al)) vl' - /\ Events.eval_annot_args ge (fun v => v) sp m (convert_annot_args al vl') vl. + eval_exprlist ge sp e m nil (exprlist_of_expr_list (params_of_builtin_args al)) vl' + /\ Events.eval_builtin_args ge (fun v => v) sp m (convert_builtin_args al vl') vl. Proof. induction 1; simpl. - exists (@nil val); split; constructor. -- exploit invert_eval_annot_arg; eauto. intros (vl1 & A & B & C). +- exploit invert_eval_builtin_arg; eauto. intros (vl1 & A & B & C). destruct IHlist_forall2 as (vl2 & D & E). exists (vl1 ++ vl2); split. apply eval_exprlist_append; auto. rewrite C; simpl. constructor; auto. Qed. -Lemma transl_eval_annot_arg: +Lemma transl_eval_builtin_arg: forall rs a vl rl v, Val.lessdef_list vl rs##rl -> - Events.eval_annot_arg ge (fun v => v) sp m (fst (convert_annot_arg a vl)) v -> + Events.eval_builtin_arg ge (fun v => v) sp m (fst (convert_builtin_arg a vl)) v -> exists v', - Events.eval_annot_arg ge (fun r => rs#r) sp m (fst (convert_annot_arg a rl)) v' + Events.eval_builtin_arg ge (fun r => rs#r) sp m (fst (convert_builtin_arg a rl)) v' /\ Val.lessdef v v' - /\ Val.lessdef_list (snd (convert_annot_arg a vl)) rs##(snd (convert_annot_arg a rl)). + /\ Val.lessdef_list (snd (convert_builtin_arg a vl)) rs##(snd (convert_builtin_arg a rl)). Proof. induction a; simpl; intros until v; intros LD EV; - try (now (inv EV; econstructor; eauto with aarg)). + try (now (inv EV; econstructor; eauto with barg)). - destruct rl; simpl in LD; inv LD; inv EV; simpl. - econstructor; eauto with aarg. + econstructor; eauto with barg. exists (rs#p); intuition auto. constructor. -- destruct (convert_annot_arg a1 vl) as [a1' vl1] eqn:CV1; simpl in *. - destruct (convert_annot_arg a2 vl1) as [a2' vl2] eqn:CV2; simpl in *. - destruct (convert_annot_arg a1 rl) as [a1'' rl1] eqn:CV3; simpl in *. - destruct (convert_annot_arg a2 rl1) as [a2'' rl2] eqn:CV4; simpl in *. +- destruct (convert_builtin_arg a1 vl) as [a1' vl1] eqn:CV1; simpl in *. + destruct (convert_builtin_arg a2 vl1) as [a2' vl2] eqn:CV2; simpl in *. + destruct (convert_builtin_arg a1 rl) as [a1'' rl1] eqn:CV3; simpl in *. + destruct (convert_builtin_arg a2 rl1) as [a2'' rl2] eqn:CV4; simpl in *. inv EV. exploit IHa1; eauto. rewrite CV1; simpl; eauto. rewrite CV1, CV3; simpl. intros (v1' & A1 & B1 & C1). @@ -1042,164 +1069,25 @@ Proof. split; auto. apply Val.longofwords_lessdef; auto. Qed. -Lemma transl_eval_annot_args: +Lemma transl_eval_builtin_args: forall rs al vl1 rl vl, Val.lessdef_list vl1 rs##rl -> - Events.eval_annot_args ge (fun v => v) sp m (convert_annot_args al vl1) vl -> + Events.eval_builtin_args ge (fun v => v) sp m (convert_builtin_args al vl1) vl -> exists vl', - Events.eval_annot_args ge (fun r => rs#r) sp m (convert_annot_args al rl) vl' + Events.eval_builtin_args ge (fun r => rs#r) sp m (convert_builtin_args al rl) vl' /\ Val.lessdef_list vl vl'. Proof. induction al; simpl; intros until vl; intros LD EV. - inv EV. exists (@nil val); split; constructor. -- destruct (convert_annot_arg a vl1) as [a1' vl2] eqn:CV1; simpl in *. +- destruct (convert_builtin_arg a vl1) as [a1' vl2] eqn:CV1; simpl in *. inv EV. - exploit transl_eval_annot_arg. eauto. instantiate (2 := a). rewrite CV1; simpl; eauto. + exploit transl_eval_builtin_arg. eauto. instantiate (2 := a). rewrite CV1; simpl; eauto. rewrite CV1; simpl. intros (v1' & A1 & B1 & C1). exploit IHal. eexact C1. eauto. intros (vl' & A2 & B2). - destruct (convert_annot_arg a rl) as [a1'' rl2]; simpl in *. + destruct (convert_builtin_arg a rl) as [a1'' rl2]; simpl in *. exists (v1' :: vl'); split; constructor; auto. Qed. - -(* -Definition transl_annot_arg_prop (a: annot_arg expr) (v: val): Prop := - forall tm cs f map pr ns nd a' rs - (MWF: map_wf map) - (TR: tr_annot_arg f.(fn_code) map pr a ns nd a') - (ME: match_env map e nil rs) - (EXT: Mem.extends m tm), - exists rs', exists tm', exists v', - star step tge (State cs f sp ns rs tm) E0 (State cs f sp nd rs' tm') - /\ match_env map e nil rs' - /\ Events.eval_annot_arg tge (fun r => rs'#r) sp tm' a' v' - /\ Val.lessdef v v' - /\ (forall r, In r pr -> rs'#r = rs#r) - /\ Mem.extends m tm'. - -Theorem transl_annot_arg_correct: - forall a v, - eval_annot_arg ge sp e m a v -> - transl_annot_arg_prop a v. -Proof. - induction 1; red; intros; inv TR. -- exploit transl_expr_correct; eauto. intros (rs1 & tm1 & A1 & B1 & C1 & D1 & E1). - exists rs1, tm1, rs1#r; intuition eauto. constructor. -- exists rs, tm, (Vint n); intuition auto using star_refl with aarg. -- exists rs, tm, (Vlong n); intuition auto using star_refl with aarg. -- exists rs, tm, (Vfloat n); intuition auto using star_refl with aarg. -- exists rs, tm, (Vsingle n); intuition auto using star_refl with aarg. -- exploit Mem.loadv_extends; eauto. intros (v' & P & Q). - exists rs, tm, v'; intuition auto using star_refl with aarg. -- exists rs, tm, (Val.add sp (Vint ofs)); intuition auto using star_refl with aarg. -- exploit Mem.loadv_extends; eauto. intros (v' & P & Q). - replace (Genv.symbol_address ge id ofs) - with (Senv.symbol_address tge id ofs) in P. - exists rs, tm, v'; intuition auto using star_refl with aarg. - unfold Genv.symbol_address, Senv.symbol_address. simpl. - rewrite symbols_preserved; auto. -- exists rs, tm, (Senv.symbol_address tge id ofs); intuition auto using star_refl with aarg. - unfold Genv.symbol_address, Senv.symbol_address. simpl. - rewrite symbols_preserved; auto. -- inv H5. inv H9. simpl in H5. - exploit transl_expr_correct. eexact H. eauto. eauto. eauto. eauto. - intros (rs1 & tm1 & A1 & B1 & C1 & D1 & E1). - exploit transl_expr_correct. eexact H0. eauto. eauto. eauto. eauto. - intros (rs2 & tm2 & A2 & B2 & C2 & D2 & E2). - exists rs2, tm2, (Val.longofwords rs2#r rs2#r0); intuition auto. - eapply star_trans; eauto. - constructor. constructor. constructor. - rewrite (D2 r) by auto with coqlib. apply Val.longofwords_lessdef; auto. - transitivity rs1#r1; auto with coqlib. -Qed. - - -Definition transl_annot_args_prop (l: list (annot_arg expr)) (vl: list val): Prop := - forall tm cs f map pr ns nd l' rs - (MWF: map_wf map) - (TR: tr_annot_args f.(fn_code) map pr l ns nd l') - (ME: match_env map e nil rs) - (EXT: Mem.extends m tm), - exists rs', exists tm', exists vl', - star step tge (State cs f sp ns rs tm) E0 (State cs f sp nd rs' tm') - /\ match_env map e nil rs' - /\ eval_annot_args tge (fun r => rs'#r) sp tm' l' vl' - /\ Val.lessdef_list vl vl' - /\ (forall r, In r pr -> rs'#r = rs#r) - /\ Mem.extends m tm'. - -Theorem transl_annot_args_correct: - forall l vl, - list_forall2 (eval_annot_arg ge sp e m) l vl -> - transl_annot_args_prop l vl. -Proof. - induction 1; red; intros. -- inv TR. exists rs, tm, (@nil val). - split. constructor. - split. auto. - split. constructor. - split. constructor. - split. auto. - auto. -- inv TR. inv H; inv H5. - + exploit transl_expr_correct; eauto. - intros (rs1 & tm1 & A1 & B1 & C1 & D1 & E1). - exploit (IHlist_forall2 tm1 cs); eauto. - intros (rs2 & tm2 & vl2 & A2 & B2 & C2 & D2 & E2 & F2). simpl in E2. - exists rs2, tm2, (rs2#r :: vl2); intuition auto. - eapply star_trans; eauto. - constructor; auto. constructor. - rewrite E2; auto. - transitivity rs1#r0; auto. - + exploit (IHlist_forall2 tm cs); eauto. - intros (rs' & tm' & vl' & A & B & C & D & E & F). - exists rs', tm', (Vint n :: vl'); simpl; intuition auto. constructor; auto with aarg. - + exploit (IHlist_forall2 tm cs); eauto. - intros (rs' & tm' & vl' & A & B & C & D & E & F). - exists rs', tm', (Vlong n :: vl'); simpl; intuition auto. constructor; auto with aarg. - + exploit (IHlist_forall2 tm cs); eauto. - intros (rs' & tm' & vl' & A & B & C & D & E & F). - exists rs', tm', (Vfloat n :: vl'); simpl; intuition auto. constructor; auto with aarg. - + exploit (IHlist_forall2 tm cs); eauto. - intros (rs' & tm' & vl' & A & B & C & D & E & F). - exists rs', tm', (Vsingle n :: vl'); simpl; intuition auto. constructor; auto with aarg. - + exploit (IHlist_forall2 tm cs); eauto. - intros (rs' & tm' & vl' & A & B & C & D & E & F). - exploit Mem.loadv_extends; eauto. intros (v1' & P & Q). - exists rs', tm', (v1' :: vl'); simpl; intuition auto. constructor; eauto with aarg. - + exploit (IHlist_forall2 tm cs); eauto. - intros (rs' & tm' & vl' & A & B & C & D & E & F). - exists rs', tm', (Val.add sp (Vint ofs) :: vl'); simpl; intuition auto. constructor; auto with aarg. - + exploit (IHlist_forall2 tm cs); eauto. - intros (rs' & tm' & vl' & A & B & C & D & E & F). - exploit Mem.loadv_extends; eauto. intros (v1' & P & Q). - replace (Genv.symbol_address ge id ofs) - with (Senv.symbol_address tge id ofs) in P. - exists rs', tm', (v1' :: vl'); simpl; intuition auto. constructor; auto with aarg. - unfold Genv.symbol_address, Senv.symbol_address. simpl. - rewrite symbols_preserved; auto. - + exploit (IHlist_forall2 tm cs); eauto. - intros (rs' & tm' & vl' & A & B & C & D & E & F). - exists rs', tm', (Genv.symbol_address tge id ofs :: vl'); simpl; intuition auto. - constructor; auto with aarg. constructor. - unfold Genv.symbol_address. rewrite symbols_preserved; auto. - + inv H7. inv H12. - exploit transl_expr_correct. eexact H1. eauto. eauto. eauto. eauto. - intros (rs1 & tm1 & A1 & B1 & C1 & D1 & E1). - exploit transl_expr_correct. eexact H2. eauto. eauto. eauto. eexact E1. - intros (rs2 & tm2 & A2 & B2 & C2 & D2 & E2). simpl in D2. - exploit (IHlist_forall2 tm2 cs); eauto. - intros (rs3 & tm3 & vl3 & A3 & B3 & C3 & D3 & E3 & F3). simpl in E3. - exists rs3, tm3, (Val.longofwords rs3#r rs3#r0 :: vl3); intuition auto. - eapply star_trans; eauto. eapply star_trans; eauto. auto. - constructor; auto with aarg. constructor. constructor. constructor. - constructor; auto. apply Val.longofwords_lessdef. - rewrite E3, D2; auto. - rewrite E3; auto. - transitivity rs1#r1; auto. transitivity rs2#r1; auto. -Qed. -*) - End CORRECTNESS_EXPR. (** ** Measure over CminorSel states *) @@ -1520,36 +1408,24 @@ Proof. (* builtin *) inv TS. + exploit invert_eval_builtin_args; eauto. intros (vparams & P & Q). exploit transl_exprlist_correct; eauto. intros [rs' [tm' [E [F [G [J K]]]]]]. - edestruct external_call_mem_extends as [tv [tm'' [A [B [C D]]]]]; eauto. - econstructor; split. - left. eapply plus_right. eexact E. - eapply exec_Ibuiltin. eauto. - eapply external_call_symbols_preserved. eauto. - exact symbols_preserved. exact public_preserved. exact varinfo_preserved. - traceEq. - econstructor; eauto. constructor. - eapply match_env_update_dest; eauto. - - (* annot *) - inv TS. exploit invert_eval_annot_args; eauto. intros (vparams & P & Q). - exploit transl_exprlist_correct; eauto. - intros [rs' [tm' [E [F [G [J K]]]]]]. - exploit transl_eval_annot_args; eauto. + exploit transl_eval_builtin_args; eauto. intros (vargs' & U & V). - exploit (@eval_annot_args_lessdef _ ge (fun r => rs'#r) (fun r => rs'#r)); eauto. + exploit (@eval_builtin_args_lessdef _ ge (fun r => rs'#r) (fun r => rs'#r)); eauto. intros (vargs'' & X & Y). assert (Z: Val.lessdef_list vl vargs'') by (eapply Val.lessdef_list_trans; eauto). edestruct external_call_mem_extends as [tv [tm'' [A [B [C D]]]]]; eauto. econstructor; split. left. eapply plus_right. eexact E. - eapply exec_Iannot; eauto. - eapply eval_annot_args_preserved with (ge1 := ge); eauto. exact symbols_preserved. + eapply exec_Ibuiltin. eauto. + eapply eval_builtin_args_preserved with (ge1 := ge); eauto. exact symbols_preserved. eapply external_call_symbols_preserved. eauto. exact symbols_preserved. exact public_preserved. exact varinfo_preserved. traceEq. econstructor; eauto. constructor. + eapply match_env_update_res; eauto. (* seq *) inv TS. diff --git a/backend/RTLgenspec.v b/backend/RTLgenspec.v index 1ca9faa0..41b5016f 100644 --- a/backend/RTLgenspec.v +++ b/backend/RTLgenspec.v @@ -727,7 +727,7 @@ Inductive tr_expr (c: code): tr_expr c map pr (Eletvar n) ns nd rd dst | tr_Ebuiltin: forall map pr ef al ns nd rd dst n1 rl, tr_exprlist c map pr al ns n1 rl -> - c!n1 = Some (Ibuiltin ef rl rd nd) -> + c!n1 = Some (Ibuiltin ef (List.map (@BA reg) rl) (BR rd) nd) -> reg_map_ok map rd dst -> ~In rd pr -> tr_expr c map pr (Ebuiltin ef al) ns nd rd dst | tr_Eexternal: forall map pr id sg al ns nd rd dst n1 rl, @@ -807,6 +807,15 @@ Inductive tr_exitexpr (c: code): tr_exitexpr c (add_letvar map r) b n1 nexits -> tr_exitexpr c map (XElet a b) ns nexits. +(** Auxiliary for the compilation of [builtin] statements. *) + +Inductive tr_builtin_res: mapping -> builtin_res ident -> builtin_res reg -> Prop := + | tr_builtin_res_var: forall map id r, + map.(map_vars)!id = Some r -> + tr_builtin_res map (BR id) (BR r) + | tr_builtin_res_none: forall map, + tr_builtin_res map BR_none BR_none. + (** [tr_stmt c map stmt ns ncont nexits nret rret] holds if the graph [c], starting at node [ns], contains instructions that perform the Cminor statement [stmt]. These instructions branch to node [ncont] if @@ -849,15 +858,11 @@ Inductive tr_stmt (c: code) (map: mapping): 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) -> - reg_map_ok map rd optid -> - tr_stmt c map (Sbuiltin optid ef al) ns nd nexits ngoto nret rret - | tr_Sannot: forall ef al ns nd nexits ngoto nret rret n1 rargs, - tr_exprlist c map nil (exprlist_of_expr_list (params_of_annot_args al)) ns n1 rargs -> - c!n1 = Some (Iannot ef (convert_annot_args al rargs) nd) -> - tr_stmt c map (Sannot ef al) ns nd nexits ngoto nret rret + | tr_Sbuiltin: forall res ef args ns nd nexits ngoto nret rret res' n1 rargs, + tr_exprlist c map nil (exprlist_of_expr_list (params_of_builtin_args args)) ns n1 rargs -> + c!n1 = Some (Ibuiltin ef (convert_builtin_args args rargs) res' nd) -> + tr_builtin_res map res res' -> + tr_stmt c map (Sbuiltin res ef args) ns nd nexits ngoto nret rret | tr_Sseq: forall s1 s2 ns nd nexits ngoto nret rret n, tr_stmt c map s2 n nd nexits ngoto nret rret -> tr_stmt c map s1 ns n nexits ngoto nret rret -> @@ -1208,6 +1213,17 @@ Proof. apply add_letvar_valid; eauto with rtlg. Qed. +Lemma convert_builtin_res_charact: + forall map res s res' s' INCR + (TR: convert_builtin_res map res s = OK res' s' INCR) + (WF: map_valid map s), + tr_builtin_res map res res'. +Proof. + destruct res; simpl; intros; monadInv TR. +- constructor. unfold find_var in EQ. destruct (map_vars map)!x; inv EQ; auto. +- constructor. +Qed. + Lemma transl_stmt_charact: forall map stmt nd nexits ngoto nret rret s ns s' INCR (TR: transl_stmt map stmt nd nexits ngoto nret rret s = OK ns s' INCR) @@ -1260,10 +1276,7 @@ Proof. (* Sbuiltin *) econstructor; eauto 4 with rtlg. eapply transl_exprlist_charact; eauto 3 with rtlg. - eapply alloc_optreg_map_ok with (s1 := s0); eauto with rtlg. - (* Sannot *) - econstructor; eauto 4 with rtlg. - eapply transl_exprlist_charact; eauto 3 with rtlg. + eapply convert_builtin_res_charact; eauto with rtlg. (* Sseq *) econstructor. apply tr_stmt_incr with s0; auto. diff --git a/backend/RTLtyping.v b/backend/RTLtyping.v index 8961fc0b..effb0c7d 100644 --- a/backend/RTLtyping.v +++ b/backend/RTLtyping.v @@ -65,18 +65,24 @@ Variable env: regenv. Definition valid_successor (s: node) : Prop := exists i, funct.(fn_code)!s = Some i. -Definition type_of_annot_arg (a: annot_arg reg) : typ := +Definition type_of_builtin_arg (a: builtin_arg reg) : typ := match a with - | AA_base r => env r - | AA_int _ => Tint - | AA_long _ => Tlong - | AA_float _ => Tfloat - | AA_single _ => Tsingle - | AA_loadstack chunk ofs => type_of_chunk chunk - | AA_addrstack ofs => Tint - | AA_loadglobal chunk id ofs => type_of_chunk chunk - | AA_addrglobal id ofs => Tint - | AA_longofwords hi lo => Tlong + | BA r => env r + | BA_int _ => Tint + | BA_long _ => Tlong + | BA_float _ => Tfloat + | BA_single _ => Tsingle + | BA_loadstack chunk ofs => type_of_chunk chunk + | BA_addrstack ofs => Tint + | BA_loadglobal chunk id ofs => type_of_chunk chunk + | BA_addrglobal id ofs => Tint + | BA_splitlong hi lo => Tlong + end. + +Definition type_of_builtin_res (r: builtin_res reg) : typ := + match r with + | BR r => env r + | _ => Tint end. Inductive wt_instr : instruction -> Prop := @@ -124,15 +130,13 @@ Inductive wt_instr : instruction -> Prop := wt_instr (Itailcall sig ros args) | wt_Ibuiltin: forall ef args res s, - map env args = (ef_sig ef).(sig_args) -> - env res = proj_sig_res (ef_sig ef) -> + match ef with + | EF_annot _ _ | EF_debug _ _ _ => True + | _ => map type_of_builtin_arg args = (ef_sig ef).(sig_args) + end -> + type_of_builtin_res res = proj_sig_res (ef_sig ef) -> valid_successor s -> wt_instr (Ibuiltin ef args res s) - | wt_Iannot: - forall ef args s, - map type_of_annot_arg args = (ef_sig ef).(sig_args) -> - valid_successor s -> - wt_instr (Iannot ef args s) | wt_Icond: forall cond args s1 s2, map env args = type_of_condition cond -> @@ -233,27 +237,33 @@ Definition is_move (op: operation) : bool := Definition type_expect (e: S.typenv) (t1 t2: typ) : res S.typenv := if typ_eq t1 t2 then OK e else Error(msg "unexpected type"). -Definition type_annot_arg (e: S.typenv) (a: annot_arg reg) (ty: typ) : res S.typenv := +Definition type_builtin_arg (e: S.typenv) (a: builtin_arg reg) (ty: typ) : res S.typenv := match a with - | AA_base r => S.set e r ty - | AA_int _ => type_expect e ty Tint - | AA_long _ => type_expect e ty Tlong - | AA_float _ => type_expect e ty Tfloat - | AA_single _ => type_expect e ty Tsingle - | AA_loadstack chunk ofs => type_expect e ty (type_of_chunk chunk) - | AA_addrstack ofs => type_expect e ty Tint - | AA_loadglobal chunk id ofs => type_expect e ty (type_of_chunk chunk) - | AA_addrglobal id ofs => type_expect e ty Tint - | AA_longofwords hi lo => type_expect e ty Tlong + | BA r => S.set e r ty + | BA_int _ => type_expect e ty Tint + | BA_long _ => type_expect e ty Tlong + | BA_float _ => type_expect e ty Tfloat + | BA_single _ => type_expect e ty Tsingle + | BA_loadstack chunk ofs => type_expect e ty (type_of_chunk chunk) + | BA_addrstack ofs => type_expect e ty Tint + | BA_loadglobal chunk id ofs => type_expect e ty (type_of_chunk chunk) + | BA_addrglobal id ofs => type_expect e ty Tint + | BA_splitlong hi lo => type_expect e ty Tlong end. -Fixpoint type_annot_args (e: S.typenv) (al: list (annot_arg reg)) (tyl: list typ) : res S.typenv := +Fixpoint type_builtin_args (e: S.typenv) (al: list (builtin_arg reg)) (tyl: list typ) : res S.typenv := match al, tyl with | nil, nil => OK e | a1 :: al, ty1 :: tyl => - do e1 <- type_annot_arg e a1 ty1; type_annot_args e1 al tyl + do e1 <- type_builtin_arg e a1 ty1; type_builtin_args e1 al tyl | _, _ => - Error (msg "annotation arity mismatch") + Error (msg "builtin arity mismatch") + end. + +Definition type_builtin_res (e: S.typenv) (a: builtin_res reg) (ty: typ) : res S.typenv := + match a with + | BR r => S.set e r ty + | _ => type_expect e ty Tint end. Definition type_instr (e: S.typenv) (i: instruction) : res S.typenv := @@ -294,11 +304,12 @@ Definition type_instr (e: S.typenv) (i: instruction) : res S.typenv := | Ibuiltin ef args res s => let sig := ef_sig ef in do x <- check_successor s; - do e1 <- S.set_list e args sig.(sig_args); - S.set e1 res (proj_sig_res sig) - | Iannot ef args s => - do x <- check_successor s; - type_annot_args e args (sig_args (ef_sig ef)) + do e1 <- + match ef with + | EF_annot _ _ | EF_debug _ _ _ => OK e + | _ => type_builtin_args e args sig.(sig_args) + end; + type_builtin_res e1 res (proj_sig_res sig) | Icond cond args s1 s2 => do x1 <- check_successor s1; do x2 <- check_successor s2; @@ -394,41 +405,57 @@ Proof. unfold type_expect; intros. destruct (typ_eq ty1 ty2); inv H. auto. Qed. -Lemma type_annot_arg_incr: - forall e a ty e' te, type_annot_arg e a ty = OK e' -> S.satisf te e' -> S.satisf te e. +Lemma type_builtin_arg_incr: + forall e a ty e' te, type_builtin_arg e a ty = OK e' -> S.satisf te e' -> S.satisf te e. Proof. - unfold type_annot_arg; intros; destruct a; eauto with ty. + unfold type_builtin_arg; intros; destruct a; eauto with ty. Qed. -Lemma type_annot_args_incr: - forall a ty e e' te, type_annot_args e a ty = OK e' -> S.satisf te e' -> S.satisf te e. +Lemma type_builtin_args_incr: + forall a ty e e' te, type_builtin_args e a ty = OK e' -> S.satisf te e' -> S.satisf te e. Proof. induction a; destruct ty; simpl; intros; try discriminate. inv H; auto. - monadInv H. eapply type_annot_arg_incr; eauto. + monadInv H. eapply type_builtin_arg_incr; eauto. +Qed. + +Lemma type_builtin_res_incr: + forall e a ty e' te, type_builtin_res e a ty = OK e' -> S.satisf te e' -> S.satisf te e. +Proof. + unfold type_builtin_res; intros; destruct a; inv H; eauto with ty. Qed. -Hint Resolve type_annot_args_incr: ty. +Hint Resolve type_builtin_args_incr type_builtin_res_incr: ty. -Lemma type_annot_arg_sound: +Lemma type_builtin_arg_sound: forall e a ty e' te, - type_annot_arg e a ty = OK e' -> S.satisf te e' -> type_of_annot_arg te a = ty. + type_builtin_arg e a ty = OK e' -> S.satisf te e' -> type_of_builtin_arg te a = ty. Proof. intros. destruct a; simpl in *; try (symmetry; eapply type_expect_sound; eassumption). eapply S.set_sound; eauto. Qed. -Lemma type_annot_args_sound: +Lemma type_builtin_args_sound: forall al tyl e e' te, - type_annot_args e al tyl = OK e' -> S.satisf te e' -> List.map (type_of_annot_arg te) al = tyl. + type_builtin_args e al tyl = OK e' -> S.satisf te e' -> List.map (type_of_builtin_arg te) al = tyl. Proof. induction al as [|a al]; destruct tyl as [|ty tyl]; simpl; intros; try discriminate. - auto. - monadInv H. f_equal. - eapply type_annot_arg_sound; eauto with ty. + eapply type_builtin_arg_sound; eauto with ty. eauto. Qed. +Lemma type_builtin_res_sound: + forall e a ty e' te, + type_builtin_res e a ty = OK e' -> S.satisf te e' -> type_of_builtin_res te a = ty. +Proof. + intros. destruct a; simpl in *. + eapply S.set_sound; eauto. + symmetry; eapply type_expect_sound; eauto. + symmetry; eapply type_expect_sound; eauto. +Qed. + Lemma type_instr_incr: forall e i e' te, type_instr e i = OK e' -> S.satisf te e' -> S.satisf te e. @@ -442,6 +469,8 @@ Proof. destruct (opt_typ_eq (sig_res s) (sig_res (fn_sig f))); try discriminate. destruct (tailcall_is_possible s) eqn:TCIP; inv EQ2. eauto with ty. +- (* builtin *) + destruct e0; try monadInv EQ1; eauto with ty. - (* jumptable *) destruct (zle (list_length_z l * 4) Int.max_unsigned); inv EQ2. eauto with ty. @@ -497,12 +526,8 @@ Proof. apply tailcall_is_possible_correct; auto. - (* builtin *) constructor. - eapply S.set_list_sound; eauto with ty. - eapply S.set_sound; eauto with ty. - eauto with ty. -- (* annot *) - constructor. - eapply type_annot_args_sound; eauto. + destruct e0; auto; eapply type_builtin_args_sound; eauto with ty. + eapply type_builtin_res_sound; eauto. eauto with ty. - (* cond *) constructor. @@ -590,27 +615,38 @@ Proof. unfold type_expect; intros. rewrite dec_eq_true; auto. Qed. -Lemma type_annot_arg_complete: +Lemma type_builtin_arg_complete: forall te a e, S.satisf te e -> - exists e', type_annot_arg e a (type_of_annot_arg te a) = OK e' /\ S.satisf te e'. + exists e', type_builtin_arg e a (type_of_builtin_arg te a) = OK e' /\ S.satisf te e'. Proof. intros. destruct a; simpl; try (exists e; split; [apply type_expect_complete|assumption]). apply S.set_complete; auto. Qed. -Lemma type_annot_args_complete: +Lemma type_builtin_args_complete: forall te al e, S.satisf te e -> - exists e', type_annot_args e al (List.map (type_of_annot_arg te) al) = OK e' /\ S.satisf te e'. + exists e', type_builtin_args e al (List.map (type_of_builtin_arg te) al) = OK e' /\ S.satisf te e'. Proof. induction al; simpl; intros. - exists e; auto. -- destruct (type_annot_arg_complete te a e) as (e1 & A & B); auto. +- destruct (type_builtin_arg_complete te a e) as (e1 & A & B); auto. destruct (IHal e1) as (e2 & C & D); auto. exists e2; split; auto. rewrite A. auto. Qed. +Lemma type_builtin_res_complete: + forall te a e, + S.satisf te e -> + exists e', type_builtin_res e a (type_of_builtin_res te a) = OK e' /\ S.satisf te e'. +Proof. + intros. destruct a; simpl. + apply S.set_complete; auto. + exists e; auto. + exists e; auto. +Qed. + Lemma type_instr_complete: forall te e i, S.satisf te e -> @@ -662,15 +698,14 @@ Proof. exploit (H3 a); auto. intros. destruct a; try contradiction. apply IHl. intros; apply H3; auto. - (* builtin *) - exploit S.set_list_complete. eauto. eauto. intros [e1 [A B]]. - exploit S.set_complete. eexact B. eauto. intros [e2 [C D]]. - exists e2; split; auto. - rewrite check_successor_complete by auto; simpl. - rewrite A; simpl; rewrite C; auto. -- (* annot *) - exploit type_annot_args_complete; eauto. intros [e1 [A B]]. - exists e1; split; auto. rewrite check_successor_complete by auto. - simpl; rewrite <- H0; eauto. + exploit type_builtin_args_complete; eauto. instantiate (1 := args). intros [e1 [A B]]. + exploit type_builtin_res_complete; eauto. instantiate (1 := res). intros [e2 [C D]]. + exploit type_builtin_res_complete. eexact H. instantiate (1 := res). intros [e3 [E F]]. + rewrite check_successor_complete by auto. simpl. + exists (match ef with EF_annot _ _ | EF_debug _ _ _ => e3 | _ => e2 end); split. + rewrite H1 in C, E. + destruct ef; try (rewrite <- H0; rewrite A); simpl; auto. + destruct ef; auto. - (* cond *) exploit S.set_list_complete. eauto. eauto. intros [e1 [A B]]. exists e1; split; auto. @@ -772,6 +807,15 @@ Proof. split. apply H. apply IHrl. Qed. +Lemma wt_regset_setres: + forall env rs v res, + wt_regset env rs -> + Val.has_type v (type_of_builtin_res env res) -> + wt_regset env (regmap_setres res v rs). +Proof. + intros. destruct res; simpl in *; auto. apply wt_regset_assign; auto. +Qed. + Lemma wt_init_regs: forall env rl args, Val.has_type_list args (List.map env rl) -> @@ -812,11 +856,11 @@ Lemma wt_exec_Ibuiltin: wt_instr f env (Ibuiltin ef args res s) -> external_call ef ge vargs m t vres m' -> wt_regset env rs -> - wt_regset env (rs#res <- vres). + wt_regset env (regmap_setres res vres rs). Proof. intros. inv H. - eapply wt_regset_assign; eauto. - rewrite H7; eapply external_call_well_typed; eauto. + eapply wt_regset_setres; eauto. + rewrite H7. eapply external_call_well_typed; eauto. Qed. Lemma wt_instr_at: @@ -914,8 +958,6 @@ Proof. inv WTI. rewrite <- H7. apply wt_regset_list. auto. (* Ibuiltin *) econstructor; eauto. eapply wt_exec_Ibuiltin; eauto. - (* Iannot *) - econstructor; eauto. (* Icond *) econstructor; eauto. (* Ijumptable *) diff --git a/backend/Regalloc.ml b/backend/Regalloc.ml index aa4efc53..76288fb5 100644 --- a/backend/Regalloc.ml +++ b/backend/Regalloc.ml @@ -114,24 +114,60 @@ let xparmove srcs dsts k = | [src], [dst] -> move src dst k | _, _ -> Xparmove(srcs, dsts, new_temp Tint, new_temp Tfloat) :: k -let rec convert_annot_arg tyenv = function - | AA_base r -> +let rec convert_builtin_arg tyenv = function + | BA r -> begin match tyenv r with - | Tlong -> AA_longofwords(AA_base(V(r, Tint)), - AA_base(V(twin_reg r, Tint))) - | ty -> AA_base(V(r, ty)) + | Tlong -> BA_splitlong(BA(V(r, Tint)), BA(V(twin_reg r, Tint))) + | ty -> BA(V(r, ty)) end - | AA_int n -> AA_int n - | AA_long n -> AA_long n - | AA_float n -> AA_float n - | AA_single n -> AA_single n - | AA_loadstack(chunk, ofs) -> AA_loadstack(chunk, ofs) - | AA_addrstack(ofs) -> AA_addrstack(ofs) - | AA_loadglobal(chunk, id, ofs) -> AA_loadglobal(chunk, id, ofs) - | AA_addrglobal(id, ofs) -> AA_addrglobal(id, ofs) - | AA_longofwords(hi, lo) -> - AA_longofwords(convert_annot_arg tyenv hi, convert_annot_arg tyenv lo) - + | BA_int n -> BA_int n + | BA_long n -> BA_long n + | BA_float n -> BA_float n + | BA_single n -> BA_single n + | BA_loadstack(chunk, ofs) -> BA_loadstack(chunk, ofs) + | BA_addrstack(ofs) -> BA_addrstack(ofs) + | BA_loadglobal(chunk, id, ofs) -> BA_loadglobal(chunk, id, ofs) + | BA_addrglobal(id, ofs) -> BA_addrglobal(id, ofs) + | BA_splitlong(hi, lo) -> + BA_splitlong(convert_builtin_arg tyenv hi, convert_builtin_arg tyenv lo) + +let convert_builtin_res tyenv = function + | BR r -> + begin match tyenv r with + | Tlong -> BR_splitlong(BR(V(r, Tint)), BR(V(twin_reg r, Tint))) + | ty -> BR(V(r, ty)) + end + | BR_none -> BR_none + | BR_splitlong _ -> assert false + +let rec constrain_builtin_arg a cl = + match a, cl with + | BA x, None :: cl' -> (a, cl') + | BA x, Some mr :: cl' -> (BA (L(R mr)), cl') + | BA_splitlong(hi, lo), _ -> + let (hi', cl1) = constrain_builtin_arg hi cl in + let (lo', cl2) = constrain_builtin_arg lo cl1 in + (BA_splitlong(hi', lo'), cl2) + | _, _ -> (a, cl) + +let rec constrain_builtin_args al cl = + match al with + | [] -> ([], cl) + | a :: al -> + let (a', cl1) = constrain_builtin_arg a cl in + let (al', cl2) = constrain_builtin_args al cl1 in + (a' :: al', cl2) + +let rec constrain_builtin_res a cl = + match a, cl with + | BR x, None :: cl' -> (a, cl') + | BR x, Some mr :: cl' -> (BR (L(R mr)), cl') + | BR_splitlong(hi, lo), _ -> + let (hi', cl1) = constrain_builtin_res hi cl in + let (lo', cl2) = constrain_builtin_res lo cl1 in + (BR_splitlong(hi', lo'), cl2) + | _, _ -> (a, cl) + (* Return the XTL basic block corresponding to the given RTL instruction. Move and parallel move instructions are introduced to honor calling conventions and register constraints on some operations. @@ -206,12 +242,14 @@ let block_of_RTL_instr funsig tyenv = function [Xtailcall(sg, sum_left_map (vreg tyenv) ros, args')] | RTL.Ibuiltin(ef, args, res, s) -> let (cargs, cres) = mregs_for_builtin ef in - let args1 = expand_regs tyenv args and res1 = expand_regs tyenv [res] in - let args2 = constrain_regs args1 cargs and res2 = constrain_regs res1 cres in - movelist args1 args2 - (Xbuiltin(ef, args2, res2) :: movelist res2 res1 [Xbranch s]) - | RTL.Iannot(ef, args, s) -> - [Xannot(ef, List.map (convert_annot_arg tyenv) args); Xbranch s] + let args1 = List.map (convert_builtin_arg tyenv) args + and res1 = convert_builtin_res tyenv res in + let (args2, _) = constrain_builtin_args args1 cargs + and (res2, _) = constrain_builtin_res res1 cres in + movelist (params_of_builtin_args args1) (params_of_builtin_args args2) + (Xbuiltin(ef, args2, res2) :: + movelist (params_of_builtin_res res2) (params_of_builtin_res res1) + [Xbranch s]) | RTL.Icond(cond, args, s1, s2) -> [Xcond(cond, vregs tyenv args, s1, s2)] | RTL.Ijumptable(arg, tbl) -> @@ -249,14 +287,24 @@ let function_of_RTL_function f tyenv = let vset_removelist vl after = List.fold_right VSet.remove vl after let vset_addlist vl after = List.fold_right VSet.add vl after + let vset_addros vos after = match vos with Coq_inl v -> VSet.add v after | Coq_inr id -> after -let rec vset_addannot a after = + +let rec vset_addarg a after = match a with - | AA_base v -> VSet.add v after - | AA_longofwords(hi, lo) -> vset_addannot hi (vset_addannot lo after) + | BA v -> VSet.add v after + | BA_splitlong(hi, lo) -> vset_addarg hi (vset_addarg lo after) | _ -> after +let vset_addargs al after = List.fold_right vset_addarg al after + +let rec vset_removeres r after = + match r with + | BR v -> VSet.remove v after + | BR_none -> after + | BR_splitlong(hi, lo) -> vset_removeres hi (vset_removeres lo after) + let live_before instr after = match instr with | Xmove(src, dst) | Xspill(src, dst) | Xreload(src, dst) -> @@ -279,10 +327,10 @@ let live_before instr after = vset_addlist args (vset_addros ros (vset_removelist res after)) | Xtailcall(sg, ros, args) -> vset_addlist args (vset_addros ros VSet.empty) + | Xbuiltin(EF_debug _, args, res) -> + vset_removeres res after | Xbuiltin(ef, args, res) -> - vset_addlist args (vset_removelist res after) - | Xannot(ef, args) -> - List.fold_right vset_addannot args after + vset_addargs args (vset_removeres res after) | Xbranch s -> after | Xcond(cond, args, s1, s2) -> @@ -330,6 +378,7 @@ let pair_block_live blk after = (**************** Dead code elimination **********************) (* Eliminate pure instructions whose results are not used later. *) +(* Also: remove dead registers from debug annotations. *) let rec dce_parmove srcs dsts after = match srcs, dsts with @@ -341,6 +390,12 @@ let rec dce_parmove srcs dsts after = else (srcs', dsts') | _, _ -> assert false +let rec keep_builtin_arg after = function + | BA v -> VSet.mem v after + | BA_splitlong(hi, lo) -> + keep_builtin_arg after hi && keep_builtin_arg after lo + | _ -> true + let dce_instr instr after k = match instr with | Xmove(src, dst) -> @@ -361,6 +416,9 @@ let dce_instr instr after k = if VSet.mem dst after then instr :: k else k + | Xbuiltin(EF_debug _ as ef, args, res) -> + let across = vset_removeres res after in + Xbuiltin(ef, List.filter (keep_builtin_arg across) args, res) :: k | _ -> instr :: k @@ -455,17 +513,20 @@ let spill_costs f = charge_ros 10 vos | Xbuiltin(ef, args, res) -> begin match ef with - | EF_vstore _ | EF_vstore_global _ | EF_memcpy _ -> + | EF_annot _ | EF_debug _ -> + () + | EF_vstore _ | EF_memcpy _ -> (* result is not used but should not be spilled *) - charge_list 10 1 args; charge_list max_int 0 res + charge_list 10 1 (params_of_builtin_args args); + charge_list max_int 0 (params_of_builtin_res res) | EF_annot_val _ -> (* like a move *) - charge_list 1 1 args; charge_list 1 1 res + charge_list 1 1 (params_of_builtin_args args); + charge_list 1 1 (params_of_builtin_res res) | _ -> - charge_list 10 1 args; charge_list 10 1 res + charge_list 10 1 (params_of_builtin_args args); + charge_list 10 1 (params_of_builtin_res res) end - | Xannot(ef, args) -> - () | Xbranch _ -> () | Xcond(cond, args, _, _) -> charge_list 10 1 args @@ -575,28 +636,28 @@ let add_interfs_instr g instr live = () | Xbuiltin(ef, args, res) -> (* Interferences with live across *) - let across = vset_removelist res live in - List.iter (add_interfs_live g across) res; + let across = vset_removeres res live in + let vres = params_of_builtin_res res in + List.iter (add_interfs_live g across) vres; (* All results must be pairwise different *) - add_interfs_pairwise g res; + add_interfs_pairwise g vres; add_interfs_destroyed g across (destroyed_by_builtin ef); begin match ef, args, res with - | EF_annot_val _, [arg], [res] -> + | EF_annot_val _, [BA arg], BR res -> (* like a move *) IRC.add_pref g arg res | EF_inline_asm(txt, sg, clob), _, _ -> + let vargs = params_of_builtin_args args in (* clobbered regs interfere with res and args for GCC compatibility *) List.iter (fun c -> match Machregs.register_by_name c with | None -> () | Some mr -> - add_interfs_list_mreg g args mr; - if sg.sig_res <> None then add_interfs_list_mreg g res mr) + add_interfs_list_mreg g vargs mr; + add_interfs_list_mreg g vres mr) clob | _ -> () end - | Xannot(ef, args) -> - () | Xbranch s -> () | Xcond(cond, args, s1, s2) -> @@ -671,10 +732,11 @@ let tospill_instr alloc instr ts = addros_tospill alloc vos ts | Xtailcall(sg, vos, args) -> addros_tospill alloc vos ts - | Xbuiltin(ef, args, res) -> - addlist_tospill alloc args (addlist_tospill alloc res ts) - | Xannot(ef, args) -> + | Xbuiltin((EF_annot _ | EF_debug _), _, _) -> ts + | Xbuiltin(ef, args, res) -> + addlist_tospill alloc (params_of_builtin_args args) + (addlist_tospill alloc (params_of_builtin_res res) ts) | Xbranch s -> ts | Xcond(cond, args, s1, s2) -> @@ -734,6 +796,23 @@ let rec reload_vars tospill eqs vl = let (ts, cs, eqs2) = reload_vars tospill eqs1 vs in (t1 :: ts, c1 @ cs, eqs2) +let rec reload_arg tospill eqs = function + | BA v -> + let (t, c1, eqs1) = reload_var tospill eqs v in + (BA t, c1, eqs1) + | BA_splitlong(hi, lo) -> + let (hi', c1, eqs1) = reload_arg tospill eqs hi in + let (lo', c2, eqs2) = reload_arg tospill eqs1 lo in + (BA_splitlong(hi', lo'), c1 @ c2, eqs2) + | a -> (a, [], eqs) + +let rec reload_args tospill eqs = function + | [] -> ([], [], eqs) + | a1 :: al -> + let (t1, c1, eqs1) = reload_arg tospill eqs a1 in + let (tl, cl, eqs2) = reload_args tospill eqs1 al in + (t1 :: tl, c1 @ cl, eqs2) + let save_var tospill eqs v = if not (VSet.mem v tospill) then (v, [], kill v eqs) @@ -742,13 +821,16 @@ let save_var tospill eqs v = (t, [Xspill(t, v)], add v t (kill v eqs)) end -let rec save_vars tospill eqs vl = - match vl with - | [] -> ([], [], eqs) - | v1 :: vs -> - let (t1, c1, eqs1) = save_var tospill eqs v1 in - let (ts, cs, eqs2) = save_vars tospill eqs1 vs in - (t1 :: ts, c1 @ cs, eqs2) +let rec save_res tospill eqs = function + | BR v -> + let (t, c1, eqs1) = save_var tospill eqs v in + (BR t, c1, eqs1) + | BR_none -> + (BR_none, [], eqs) + | BR_splitlong(hi, lo) -> + let (hi', c1, eqs1) = save_res tospill eqs hi in + let (lo', c2, eqs2) = save_res tospill eqs1 lo in + (BR_splitlong(hi', lo'), c1 @ c2, eqs2) (* Trimming equations when we have too many or when they are too old. The goal is to limit the live range of unspillable temporaries. @@ -833,12 +915,12 @@ let spill_instr tospill eqs instr = (c1 @ [Xtailcall(sg, Coq_inl v', args)], []) | Xtailcall(sg, Coq_inr id, args) -> ([instr], []) + | Xbuiltin((EF_annot _ | EF_debug _), args, res) -> + ([instr], eqs) | Xbuiltin(ef, args, res) -> - let (args', c1, eqs1) = reload_vars tospill eqs args in - let (res', c2, eqs2) = save_vars tospill eqs1 res in + let (args', c1, eqs1) = reload_args tospill eqs args in + let (res', c2, eqs2) = save_res tospill eqs1 res in (c1 @ Xbuiltin(ef, args', res') :: c2, eqs2) - | Xannot(ef, args) -> - ([instr], eqs) | Xbranch s -> ([instr], eqs) | Xcond(cond, args, s1, s2) -> @@ -977,9 +1059,8 @@ let transl_instr alloc instr k = | Xtailcall(sg, vos, args) -> LTL.Ltailcall(sg, mros_of alloc vos) :: [] | Xbuiltin(ef, args, res) -> - LTL.Lbuiltin(ef, mregs_of alloc args, mregs_of alloc res) :: k - | Xannot(ef, args) -> - LTL.Lannot(ef, List.map (AST.map_annot_arg alloc) args) :: k + LTL.Lbuiltin(ef, List.map (AST.map_builtin_arg alloc) args, + AST.map_builtin_res (mreg_of alloc) res) :: k | Xbranch s -> LTL.Lbranch s :: [] | Xcond(cond, args, s1, s2) -> diff --git a/backend/Registers.v b/backend/Registers.v index 47e10fa4..20532e8c 100644 --- a/backend/Registers.v +++ b/backend/Registers.v @@ -22,6 +22,7 @@ Require Import AST. Require Import Maps. Require Import Ordered. Require FSetAVL. +Require Import Values. Definition reg: Type := positive. @@ -53,10 +54,45 @@ Definition regmap_optset | Some r => Regmap.set r v rs end. +Definition regmap_setres + (A: Type) (res: builtin_res reg) (v: A) (rs: Regmap.t A) : Regmap.t A := + match res with + | BR r => Regmap.set r v rs + | _ => rs + end. + Notation "a # b" := (Regmap.get b a) (at level 1). Notation "a ## b" := (List.map (fun r => Regmap.get r a) b) (at level 1). Notation "a # b <- c" := (Regmap.set b c a) (at level 1, b at next level). +(** Pointwise "less defined than" relation between register maps. *) + +Definition regs_lessdef (rs1 rs2: Regmap.t val) : Prop := + forall r, Val.lessdef (rs1#r) (rs2#r). + +Lemma regs_lessdef_regs: + forall rs1 rs2, regs_lessdef rs1 rs2 -> + forall rl, Val.lessdef_list rs1##rl rs2##rl. +Proof. + induction rl; constructor; auto. +Qed. + +Lemma set_reg_lessdef: + forall r v1 v2 rs1 rs2, + Val.lessdef v1 v2 -> regs_lessdef rs1 rs2 -> regs_lessdef (rs1#r <- v1) (rs2#r <- v2). +Proof. + intros; red; intros. repeat rewrite Regmap.gsspec. + destruct (peq r0 r); auto. +Qed. + +Lemma set_res_lessdef: + forall res v1 v2 rs1 rs2, + Val.lessdef v1 v2 -> regs_lessdef rs1 rs2 -> + regs_lessdef (regmap_setres res v1 rs1) (regmap_setres res v2 rs2). +Proof. + intros. destruct res; simpl; auto. apply set_reg_lessdef; auto. +Qed. + (** Sets of registers *) Module Regset := FSetAVL.Make(OrderedPositive). diff --git a/backend/Renumber.v b/backend/Renumber.v index 634fe56a..0a2c2f12 100644 --- a/backend/Renumber.v +++ b/backend/Renumber.v @@ -48,7 +48,6 @@ Definition renum_instr (i: instruction) : instruction := | 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) - | Iannot ef args s => Iannot ef args (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 diff --git a/backend/Renumberproof.v b/backend/Renumberproof.v index 09faa131..33d6aafa 100644 --- a/backend/Renumberproof.v +++ b/backend/Renumberproof.v @@ -198,13 +198,7 @@ Proof. (* builtin *) econstructor; split. eapply exec_Ibuiltin; eauto. - eapply external_call_symbols_preserved; eauto. - exact symbols_preserved. exact public_preserved. exact varinfo_preserved. - constructor; auto. eapply reach_succ; eauto. simpl; auto. -(* annot *) - econstructor; split. - eapply exec_Iannot; eauto. - eapply eval_annot_args_preserved with (ge1 := ge); eauto. exact symbols_preserved. + eapply eval_builtin_args_preserved with (ge1 := ge); eauto. exact symbols_preserved. eapply external_call_symbols_preserved; eauto. exact symbols_preserved. exact public_preserved. exact varinfo_preserved. constructor; auto. eapply reach_succ; eauto. simpl; auto. diff --git a/backend/Selection.v b/backend/Selection.v index ae9da0a7..2e631ad2 100644 --- a/backend/Selection.v +++ b/backend/Selection.v @@ -34,6 +34,7 @@ Require Import CminorSel. Require Import SelectOp. Require Import SelectDiv. Require Import SelectLong. +Require Machregs. Local Open Scope cminorsel_scope. Local Open Scope error_monad_scope. @@ -203,21 +204,27 @@ Definition classify_call (ge: Cminor.genv) (e: Cminor.expr) : call_kind := end end. -(** Annotations *) - -Definition builtin_is_annot (ef: external_function) (optid: option ident) : bool := - match ef, optid with - | EF_annot _ _, None => true - | _, _ => false +(** Builtin arguments and results *) + +Definition sel_builtin_arg + (e: Cminor.expr) (c: builtin_arg_constraint): AST.builtin_arg expr := + let e' := sel_expr e in + let ba := builtin_arg e' in + if builtin_arg_ok ba c then ba else BA e'. + +Fixpoint sel_builtin_args + (el: list Cminor.expr) + (cl: list builtin_arg_constraint): list (AST.builtin_arg expr) := + match el with + | nil => nil + | e :: el => + sel_builtin_arg e (List.hd OK_default cl) :: sel_builtin_args el (List.tl cl) end. -Function sel_annot_arg (e: Cminor.expr) : AST.annot_arg expr := - match e with - | Cminor.Econst (Cminor.Oaddrsymbol id ofs) => AA_addrglobal id ofs - | Cminor.Econst (Cminor.Oaddrstack ofs) => AA_addrstack ofs - | Cminor.Eload chunk (Cminor.Econst (Cminor.Oaddrsymbol id ofs)) => AA_loadglobal chunk id ofs - | Cminor.Eload chunk (Cminor.Econst (Cminor.Oaddrstack ofs)) => AA_loadstack chunk ofs - | _ => annot_arg (sel_expr e) +Definition sel_builtin_res (optid: option ident) : builtin_res ident := + match optid with + | None => BR_none + | Some id => BR id end. (** Conversion of Cminor [switch] statements to decision trees. *) @@ -277,12 +284,13 @@ Fixpoint sel_stmt (ge: Cminor.genv) (s: Cminor.stmt) : res stmt := OK (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) + | Call_builtin ef => Sbuiltin (sel_builtin_res optid) ef + (sel_builtin_args args + (Machregs.builtin_constraints ef)) end) | Cminor.Sbuiltin optid ef args => - OK (if builtin_is_annot ef optid - then Sannot ef (List.map sel_annot_arg args) - else Sbuiltin optid ef (sel_exprlist args)) + OK (Sbuiltin (sel_builtin_res optid) ef + (sel_builtin_args args (Machregs.builtin_constraints ef))) | Cminor.Stailcall sg fn args => OK (match classify_call ge fn with | Call_imm id => Stailcall sg (inr _ id) (sel_exprlist args) diff --git a/backend/Selectionproof.v b/backend/Selectionproof.v index d7b1e675..1d2f2b3a 100644 --- a/backend/Selectionproof.v +++ b/backend/Selectionproof.v @@ -598,45 +598,47 @@ Proof. exists (v1' :: vl'); split; auto. constructor; eauto. Qed. -Lemma sel_annot_arg_correct: - forall sp e e' m m', +Lemma sel_builtin_arg_correct: + forall sp e e' m m' a v c, env_lessdef e e' -> Mem.extends m m' -> - forall a v, Cminor.eval_expr ge sp e m a v -> exists v', - CminorSel.eval_annot_arg tge sp e' m' (sel_annot_arg a) v' + CminorSel.eval_builtin_arg tge sp e' m' (sel_builtin_arg a c) v' /\ Val.lessdef v v'. Proof. - intros until v. functional induction (sel_annot_arg a); intros EV. -- inv EV. simpl in H2; inv H2. econstructor; split. constructor. - unfold Genv.symbol_address. rewrite symbols_preserved. auto. -- inv EV. simpl in H2; inv H2. econstructor; split. constructor. auto. -- inv EV. inv H3. exploit Mem.loadv_extends; eauto. intros (v' & A & B). - exists v'; split; auto. constructor. - replace (Genv.symbol_address tge id ofs) with vaddr; auto. - simpl in H2; inv H2. unfold Genv.symbol_address. rewrite symbols_preserved. auto. -- inv EV. inv H3. simpl in H2; inv H2. exploit Mem.loadv_extends; eauto. intros (v' & A & B). - exists v'; split; auto. constructor; auto. -- exploit sel_expr_correct; eauto. intros (v1 & A & B). - exists v1; split; auto. eapply eval_annot_arg; eauto. -Qed. - -Lemma sel_annot_args_correct: + intros. unfold sel_builtin_arg. + exploit sel_expr_correct; eauto. intros (v1 & A & B). + exists v1; split; auto. + destruct (builtin_arg_ok (builtin_arg (sel_expr a)) c). + apply eval_builtin_arg; eauto. + constructor; auto. +Qed. + +Lemma sel_builtin_args_correct: forall sp e e' m m', env_lessdef e e' -> Mem.extends m m' -> forall al vl, Cminor.eval_exprlist ge sp e m al vl -> + forall cl, exists vl', - list_forall2 (CminorSel.eval_annot_arg tge sp e' m') - (List.map sel_annot_arg al) + list_forall2 (CminorSel.eval_builtin_arg tge sp e' m') + (sel_builtin_args al cl) vl' /\ Val.lessdef_list vl vl'. Proof. - induction 3; simpl. + induction 3; intros; simpl. - exists (@nil val); split; constructor. -- exploit sel_annot_arg_correct; eauto. intros (v1' & A & B). - destruct IHeval_exprlist as (vl' & C & D). - exists (v1' :: vl'); split; auto. constructor; auto. +- exploit sel_builtin_arg_correct; eauto. intros (v1' & A & B). + edestruct IHeval_exprlist as (vl' & C & D). + exists (v1' :: vl'); split; auto. constructor; eauto. +Qed. + +Lemma sel_builtin_res_correct: + forall oid v e v' e', + env_lessdef e e' -> Val.lessdef v v' -> + env_lessdef (set_optvar oid v e) (set_builtin_res (sel_builtin_res oid) v' e'). +Proof. + intros. destruct oid; simpl; auto. apply set_var_lessdef; auto. Qed. (** Semantic preservation for functions and statements. *) @@ -687,10 +689,10 @@ Inductive match_states: Cminor.state -> CminorSel.state -> Prop := (LDA: Val.lessdef_list args args') (LDE: env_lessdef e e') (ME: Mem.extends m m') - (EA: eval_exprlist tge sp e' m' nil al args'), + (EA: list_forall2 (CminorSel.eval_builtin_arg tge sp e' m') al args'), match_states (Cminor.Callstate (External ef) args (Cminor.Kcall optid f sp e k) m) - (State f' (Sbuiltin optid ef al) k' sp e' m') + (State f' (Sbuiltin (sel_builtin_res optid) ef al) k' sp e' m') | match_builtin_2: forall v v' optid f sp e k m f' e' m' k' (TF: sel_function ge f = OK f') (MC: match_cont k k') @@ -699,7 +701,7 @@ Inductive match_states: Cminor.state -> CminorSel.state -> Prop := (ME: Mem.extends m m'), match_states (Cminor.Returnstate v (Cminor.Kcall optid f sp e k) m) - (State f' Sskip k' sp (set_optvar optid v' e') m'). + (State f' Sskip k' sp (set_builtin_res (sel_builtin_res optid) v' e') m'). Remark call_cont_commut: forall k k', match_cont k k' -> match_cont (Cminor.call_cont k) (call_cont k'). @@ -724,8 +726,6 @@ Proof. destruct (classify_call ge e); simpl; auto. (* tailcall *) destruct (classify_call ge e); simpl; auto. -(* builtin *) - destruct (builtin_is_annot e); simpl; auto. (* seq *) exploit (IHs1 (Cminor.Kseq s2 k)). constructor; eauto. eauto. destruct (Cminor.find_label lbl s1 (Cminor.Kseq s2 k)) as [[sx kx] | ]; @@ -790,11 +790,11 @@ Proof. eapply eval_store; eauto. constructor; auto. - (* Scall *) - exploit sel_exprlist_correct; eauto. intros [vargs' [C D]]. exploit classify_call_correct; eauto. destruct (classify_call ge a) as [ | id | ef]. + (* indirect *) exploit sel_expr_correct; eauto. intros [vf' [A B]]. + exploit sel_exprlist_correct; eauto. intros [vargs' [C D]]. exploit functions_translated; eauto. intros (fd' & U & V). left; econstructor; split. econstructor; eauto. econstructor; eauto. @@ -802,6 +802,7 @@ Proof. constructor; auto. constructor; auto. + (* direct *) intros [b [U V]]. + exploit sel_exprlist_correct; eauto. intros [vargs' [C D]]. exploit functions_translated; eauto. intros (fd' & X & Y). left; econstructor; split. econstructor; eauto. @@ -809,7 +810,8 @@ Proof. apply sig_function_translated; auto. constructor; auto. constructor; auto. + (* turned into Sbuiltin *) - intros EQ. subst fd. + intros EQ. subst fd. + exploit sel_builtin_args_correct; eauto. intros [vargs' [C D]]. right; split. simpl. omega. split. auto. econstructor; eauto. - (* Stailcall *) @@ -827,32 +829,13 @@ Proof. econstructor; eauto. econstructor; eauto. apply sig_function_translated; auto. constructor; auto. apply call_cont_commut; auto. - (* Sbuiltin *) - destruct (builtin_is_annot ef optid) eqn:ISANNOT. -+ (* annotation *) - assert (X: exists text targs, ef = EF_annot text targs). - { destruct ef; try discriminate. econstructor; econstructor; eauto. } - destruct X as (text & targs & EQ). - assert (Y: optid = None). - { destruct ef; try discriminate. destruct optid; try discriminate. auto. } - exploit sel_annot_args_correct; eauto. - intros (vargs' & P & Q). - exploit external_call_mem_extends; eauto. - intros [vres' [m2 [A [B [C D]]]]]. - left; econstructor; split. - econstructor. - rewrite EQ; auto. - eauto. - eapply external_call_symbols_preserved; eauto. - exact symbols_preserved. exact public_preserved. exact varinfo_preserved. - rewrite Y. constructor; auto. -+ (* other builtin *) - exploit sel_exprlist_correct; eauto. intros [vargs' [P Q]]. + exploit sel_builtin_args_correct; eauto. intros [vargs' [P Q]]. exploit external_call_mem_extends; eauto. intros [vres' [m2 [A [B [C D]]]]]. left; econstructor; split. econstructor. eauto. eapply external_call_symbols_preserved; eauto. exact symbols_preserved. exact public_preserved. exact varinfo_preserved. - constructor; auto. apply set_optvar_lessdef; auto. + constructor; auto. apply sel_builtin_res_correct; auto. - (* Seq *) left; econstructor; split. constructor. constructor; auto. constructor; auto. @@ -942,8 +925,8 @@ Proof. econstructor. constructor; auto. destruct optid; simpl; auto. apply set_var_lessdef; auto. - (* return of an external call turned into a Sbuiltin *) - right; split. simpl; omega. split. auto. constructor; auto. - destruct optid; simpl; auto. apply set_var_lessdef; auto. + right; split. simpl; omega. split. auto. constructor; auto. + apply sel_builtin_res_correct; auto. Qed. Lemma sel_initial_states: diff --git a/backend/Splitting.ml b/backend/Splitting.ml index 53600c98..97b26a50 100644 --- a/backend/Splitting.ml +++ b/backend/Splitting.ml @@ -162,9 +162,8 @@ let ren_instr f maps pc i = | Itailcall(sg, ros, args) -> Itailcall(sg, ren_ros before ros, ren_regs before args) | Ibuiltin(ef, args, res, s) -> - Ibuiltin(ef, ren_regs before args, ren_reg after res, s) - | Iannot(ef, args, s) -> - Iannot(ef, List.map (AST.map_annot_arg (ren_reg before)) args, s) + Ibuiltin(ef, List.map (AST.map_builtin_arg (ren_reg before)) args, + AST.map_builtin_res (ren_reg after) res, s) | Icond(cond, args, s1, s2) -> Icond(cond, ren_regs before args, s1, s2) | Ijumptable(arg, tbl) -> diff --git a/backend/Stacking.v b/backend/Stacking.v index 21cf6b73..ef96e4b3 100644 --- a/backend/Stacking.v +++ b/backend/Stacking.v @@ -128,26 +128,26 @@ Definition transl_op (fe: frame_env) (op: operation) := Definition transl_addr (fe: frame_env) (addr: addressing) := shift_stack_addressing (Int.repr fe.(fe_stack_data)) addr. -(** Translation of an annotation argument. *) +(** Translation of a builtin argument. *) -Fixpoint transl_annot_arg (fe: frame_env) (a: annot_arg loc) : annot_arg mreg := +Fixpoint transl_builtin_arg (fe: frame_env) (a: builtin_arg loc) : builtin_arg mreg := match a with - | AA_base (R r) => AA_base r - | AA_base (S Local ofs ty) => - AA_loadstack (chunk_of_type ty) (Int.repr (offset_of_index fe (FI_local ofs ty))) - | AA_base (S _ _ _) => AA_int Int.zero (**r never happens *) - | AA_int n => AA_int n - | AA_long n => AA_long n - | AA_float n => AA_float n - | AA_single n => AA_single n - | AA_loadstack chunk ofs => - AA_loadstack chunk (Int.add ofs (Int.repr fe.(fe_stack_data))) - | AA_addrstack ofs => - AA_addrstack (Int.add ofs (Int.repr fe.(fe_stack_data))) - | AA_loadglobal chunk id ofs => AA_loadglobal chunk id ofs - | AA_addrglobal id ofs => AA_addrglobal id ofs - | AA_longofwords hi lo => - AA_longofwords (transl_annot_arg fe hi) (transl_annot_arg fe lo) + | BA (R r) => BA r + | BA (S Local ofs ty) => + BA_loadstack (chunk_of_type ty) (Int.repr (offset_of_index fe (FI_local ofs ty))) + | BA (S _ _ _) => BA_int Int.zero (**r never happens *) + | BA_int n => BA_int n + | BA_long n => BA_long n + | BA_float n => BA_float n + | BA_single n => BA_single n + | BA_loadstack chunk ofs => + BA_loadstack chunk (Int.add ofs (Int.repr fe.(fe_stack_data))) + | BA_addrstack ofs => + BA_addrstack (Int.add ofs (Int.repr fe.(fe_stack_data))) + | BA_loadglobal chunk id ofs => BA_loadglobal chunk id ofs + | BA_addrglobal id ofs => BA_addrglobal id ofs + | BA_splitlong hi lo => + BA_splitlong (transl_builtin_arg fe hi) (transl_builtin_arg fe lo) end. (** Translation of a Linear instruction. Prepends the corresponding @@ -192,9 +192,7 @@ Definition transl_instr restore_callee_save fe (Mtailcall sig ros :: k) | Lbuiltin ef args dst => - Mbuiltin ef args dst :: k - | Lannot ef args => - Mannot ef (map (transl_annot_arg fe) args) :: k + Mbuiltin ef (map (transl_builtin_arg fe) args) dst :: k | Llabel lbl => Mlabel lbl :: k | Lgoto lbl => diff --git a/backend/Stackingproof.v b/backend/Stackingproof.v index 7f41512e..dce49432 100644 --- a/backend/Stackingproof.v +++ b/backend/Stackingproof.v @@ -734,6 +734,20 @@ Proof. apply IHrl; auto. apply agree_regs_set_reg; auto. Qed. +Lemma agree_regs_set_res: + forall j res v v' ls rs, + agree_regs j ls rs -> + Val.inject j v v' -> + agree_regs j (Locmap.setres res v ls) (set_res res v' rs). +Proof. + induction res; simpl; intros. +- apply agree_regs_set_reg; auto. +- auto. +- apply IHres2. apply IHres1. auto. + apply Val.hiword_inject; auto. + apply Val.loword_inject; auto. +Qed. + Lemma agree_regs_exten: forall j ls rs ls' rs', agree_regs j ls rs -> @@ -811,6 +825,18 @@ Proof. eapply agree_frame_set_reg; eauto. Qed. +Lemma agree_frame_set_res: + forall j ls0 m sp m' sp' parent ra res v ls, + agree_frame j ls ls0 m sp m' sp' parent ra -> + (forall r, In r (params_of_builtin_res res) -> mreg_within_bounds b r) -> + agree_frame j (Locmap.setres res v ls) ls0 m sp m' sp' parent ra. +Proof. + induction res; simpl; intros. +- eapply agree_frame_set_reg; eauto. +- auto. +- apply IHres2; auto using in_or_app. +Qed. + Lemma agree_frame_undef_regs: forall j ls0 m sp m' sp' parent ra regs ls, agree_frame j ls ls0 m sp m' sp' parent ra -> @@ -2375,9 +2401,9 @@ Qed. End EXTERNAL_ARGUMENTS. -(** Preservation of the arguments to an annotation. *) +(** Preservation of the arguments to a builtin. *) -Section ANNOT_ARGUMENTS. +Section BUILTIN_ARGUMENTS. Variable f: Linear.function. Let b := function_bounds f. @@ -2395,67 +2421,67 @@ Hypothesis AGF: agree_frame f j ls ls0 m sp m' sp' parent retaddr. Hypothesis MINJ: Mem.inject j m m'. Hypothesis GINJ: meminj_preserves_globals ge j. -Lemma transl_annot_arg_correct: +Lemma transl_builtin_arg_correct: forall a v, - eval_annot_arg ge ls (Vptr sp Int.zero) m a v -> - (forall l, In l (params_of_annot_arg a) -> loc_valid f l = true) -> - (forall sl ofs ty, In (S sl ofs ty) (params_of_annot_arg a) -> slot_within_bounds b sl ofs ty) -> + eval_builtin_arg ge ls (Vptr sp Int.zero) m a v -> + (forall l, In l (params_of_builtin_arg a) -> loc_valid f l = true) -> + (forall sl ofs ty, In (S sl ofs ty) (params_of_builtin_arg a) -> slot_within_bounds b sl ofs ty) -> exists v', - eval_annot_arg ge rs (Vptr sp' Int.zero) m' (transl_annot_arg fe a) v' + eval_builtin_arg ge rs (Vptr sp' Int.zero) m' (transl_builtin_arg fe a) v' /\ Val.inject j v v'. Proof. Local Opaque fe offset_of_index. induction 1; simpl; intros VALID BOUNDS. - assert (loc_valid f x = true) by auto. destruct x as [r | [] ofs ty]; try discriminate. - + exists (rs r); auto with aarg. + + exists (rs r); auto with barg. + exploit agree_locals; eauto. intros [v [A B]]. inv A. exists v; split; auto. constructor. simpl. rewrite Int.add_zero_l. Local Transparent fe. unfold fe, b. erewrite offset_of_index_no_overflow by eauto. exact H1. -- econstructor; eauto with aarg. -- econstructor; eauto with aarg. -- econstructor; eauto with aarg. -- econstructor; eauto with aarg. +- econstructor; eauto with barg. +- econstructor; eauto with barg. +- econstructor; eauto with barg. +- econstructor; eauto with barg. - simpl in H. exploit Mem.load_inject; eauto. eapply agree_inj; eauto. intros (v' & A & B). exists v'; split; auto. constructor. unfold Mem.loadv, Val.add. rewrite <- Int.add_assoc. unfold fe, b; erewrite shifted_stack_offset_no_overflow; eauto. eapply agree_bounds; eauto. eapply Mem.valid_access_perm. eapply Mem.load_valid_access; eauto. -- econstructor; split; eauto with aarg. +- econstructor; split; eauto with barg. unfold Val.add. rewrite ! Int.add_zero_l. econstructor. eapply agree_inj; eauto. auto. - assert (Val.inject j (Senv.symbol_address ge id ofs) (Senv.symbol_address ge id ofs)). { unfold Senv.symbol_address; simpl; unfold Genv.symbol_address. destruct (Genv.find_symbol ge id) eqn:FS; auto. econstructor. eapply (proj1 GINJ); eauto. rewrite Int.add_zero; auto. } - exploit Mem.loadv_inject; eauto. intros (v' & A & B). exists v'; auto with aarg. -- econstructor; split; eauto with aarg. + exploit Mem.loadv_inject; eauto. intros (v' & A & B). exists v'; auto with barg. +- econstructor; split; eauto with barg. unfold Senv.symbol_address; simpl; unfold Genv.symbol_address. destruct (Genv.find_symbol ge id) eqn:FS; auto. econstructor. eapply (proj1 GINJ); eauto. rewrite Int.add_zero; auto. -- destruct IHeval_annot_arg1 as (v1 & A1 & B1); auto using in_or_app. - destruct IHeval_annot_arg2 as (v2 & A2 & B2); auto using in_or_app. - exists (Val.longofwords v1 v2); split; auto with aarg. +- destruct IHeval_builtin_arg1 as (v1 & A1 & B1); auto using in_or_app. + destruct IHeval_builtin_arg2 as (v2 & A2 & B2); auto using in_or_app. + exists (Val.longofwords v1 v2); split; auto with barg. apply Val.longofwords_inject; auto. Qed. -Lemma transl_annot_args_correct: +Lemma transl_builtin_args_correct: forall al vl, - eval_annot_args ge ls (Vptr sp Int.zero) m al vl -> - (forall l, In l (params_of_annot_args al) -> loc_valid f l = true) -> - (forall sl ofs ty, In (S sl ofs ty) (params_of_annot_args al) -> slot_within_bounds b sl ofs ty) -> + eval_builtin_args ge ls (Vptr sp Int.zero) m al vl -> + (forall l, In l (params_of_builtin_args al) -> loc_valid f l = true) -> + (forall sl ofs ty, In (S sl ofs ty) (params_of_builtin_args al) -> slot_within_bounds b sl ofs ty) -> exists vl', - eval_annot_args ge rs (Vptr sp' Int.zero) m' (List.map (transl_annot_arg fe) al) vl' + eval_builtin_args ge rs (Vptr sp' Int.zero) m' (List.map (transl_builtin_arg fe) al) vl' /\ Val.inject_list j vl vl'. Proof. induction 1; simpl; intros VALID BOUNDS. - exists (@nil val); split; constructor. -- exploit transl_annot_arg_correct; eauto using in_or_app. intros (v1' & A & B). +- exploit transl_builtin_arg_correct; eauto using in_or_app. intros (v1' & A & B). exploit IHlist_forall2; eauto using in_or_app. intros (vl' & C & D). exists (v1'::vl'); split; constructor; auto. Qed. -End ANNOT_ARGUMENTS. +End BUILTIN_ARGUMENTS. (** The proof of semantic preservation relies on simulation diagrams of the following form: @@ -2712,47 +2738,26 @@ Proof. apply zero_size_arguments_tailcall_possible. eapply wt_state_tailcall; eauto. - (* Lbuiltin *) - exploit external_call_mem_inject'; eauto. - eapply match_stacks_preserves_globals; eauto. - eapply agree_reglist; eauto. - intros [j' [res' [m1' [A [B [C [D [E [F G]]]]]]]]]. - econstructor; split. - apply plus_one. econstructor; eauto. - eapply external_call_symbols_preserved'; eauto. - exact symbols_preserved. exact public_preserved. exact varinfo_preserved. - econstructor; eauto with coqlib. - inversion H; inversion A; subst. - eapply match_stack_change_extcall; eauto. - apply Plt_Ple. change (Mem.valid_block m sp0). eapply agree_valid_linear; eauto. - apply Plt_Ple. change (Mem.valid_block m'0 sp'). eapply agree_valid_mach; eauto. - apply agree_regs_set_regs; auto. apply agree_regs_undef_regs; auto. eapply agree_regs_inject_incr; eauto. - apply agree_frame_set_regs; auto. apply agree_frame_undef_regs; auto. - eapply agree_frame_inject_incr; eauto. - apply agree_frame_extcall_invariant with m m'0; auto. - eapply external_call_valid_block'; eauto. - intros. inv H; eapply external_call_max_perm; eauto. eapply agree_valid_linear; eauto. - eapply external_call_valid_block'; eauto. - eapply agree_valid_mach; eauto. - -- (* Lannot *) - exploit transl_annot_args_correct; eauto. + destruct BOUND as [BND1 BND2]. + exploit transl_builtin_args_correct; eauto. eapply match_stacks_preserves_globals; eauto. - rewrite <- forallb_forall. eapply wt_state_annot; eauto. + rewrite <- forallb_forall. eapply wt_state_builtin; eauto. intros [vargs' [P Q]]. exploit external_call_mem_inject; eauto. eapply match_stacks_preserves_globals; eauto. intros [j' [res' [m1' [A [B [C [D [E [F G]]]]]]]]]. econstructor; split. apply plus_one. econstructor; eauto. - eapply eval_annot_args_preserved with (ge1 := ge); eauto. exact symbols_preserved. - eapply external_call_symbols_preserved; eauto. + eapply eval_builtin_args_preserved with (ge1 := ge); eauto. exact symbols_preserved. + eapply external_call_symbols_preserved. eauto. exact symbols_preserved. exact public_preserved. exact varinfo_preserved. econstructor; eauto with coqlib. eapply match_stack_change_extcall; eauto. apply Plt_Ple. change (Mem.valid_block m sp0). eapply agree_valid_linear; eauto. apply Plt_Ple. change (Mem.valid_block m'0 sp'). eapply agree_valid_mach; eauto. - eapply agree_regs_inject_incr; eauto. + apply agree_regs_set_res; auto. apply agree_regs_undef_regs; auto. eapply agree_regs_inject_incr; eauto. eapply agree_frame_inject_incr; eauto. + apply agree_frame_set_res; auto. apply agree_frame_undef_regs; auto. apply agree_frame_extcall_invariant with m m'0; auto. eapply external_call_valid_block; eauto. intros. eapply external_call_max_perm; eauto. eapply agree_valid_linear; eauto. diff --git a/backend/Tailcallproof.v b/backend/Tailcallproof.v index bd9b227f..1c25d244 100644 --- a/backend/Tailcallproof.v +++ b/backend/Tailcallproof.v @@ -199,33 +199,15 @@ Qed. relation between values and between memory states. We need to extend it pointwise to register states. *) -Definition regset_lessdef (rs rs': regset) : Prop := - forall r, Val.lessdef (rs#r) (rs'#r). - -Lemma regset_get_list: - forall rs rs' l, - regset_lessdef rs rs' -> Val.lessdef_list (rs##l) (rs'##l). -Proof. - induction l; simpl; intros; constructor; auto. -Qed. - -Lemma regset_set: - forall rs rs' v v' r, - regset_lessdef rs rs' -> Val.lessdef v v' -> - regset_lessdef (rs#r <- v) (rs'#r <- v'). -Proof. - intros; red; intros. repeat rewrite PMap.gsspec. destruct (peq r0 r); auto. -Qed. - -Lemma regset_init_regs: +Lemma regs_lessdef_init_regs: forall params vl vl', Val.lessdef_list vl vl' -> - regset_lessdef (init_regs vl params) (init_regs vl' params). + regs_lessdef (init_regs vl params) (init_regs vl' params). Proof. induction params; intros. simpl. red; intros. rewrite Regmap.gi. constructor. simpl. inv H. red; intros. rewrite Regmap.gi. constructor. - apply regset_set. auto. auto. + apply set_reg_lessdef. auto. auto. Qed. (** * Proof of semantic preservation *) @@ -278,7 +260,7 @@ Qed. Lemma find_function_translated: forall ros rs rs' f, find_function ge ros rs = Some f -> - regset_lessdef rs rs' -> + regs_lessdef rs rs' -> find_function tge ros rs' = Some (transf_fundef f). Proof. intros until f; destruct ros; simpl. @@ -331,7 +313,7 @@ Inductive match_stackframes: list stackframe -> list stackframe -> Prop := match_stackframes nil nil | match_stackframes_normal: forall stk stk' res sp pc rs rs' f, match_stackframes stk stk' -> - regset_lessdef rs rs' -> + regs_lessdef rs rs' -> match_stackframes (Stackframe res f (Vptr sp Int.zero) pc rs :: stk) (Stackframe res (transf_function f) (Vptr sp Int.zero) pc rs' :: stk') @@ -352,7 +334,7 @@ Inductive match_states: state -> state -> Prop := | match_states_normal: forall s sp pc rs m s' rs' m' f (STACKS: match_stackframes s s') - (RLD: regset_lessdef rs rs') + (RLD: regs_lessdef rs rs') (MLD: Mem.extends m m'), match_states (State s f (Vptr sp Int.zero) pc rs m) (State s' (transf_function f) (Vptr sp Int.zero) pc rs' m') @@ -437,13 +419,13 @@ Proof. (* op *) TransfInstr. - assert (Val.lessdef_list (rs##args) (rs'##args)). apply regset_get_list; auto. + assert (Val.lessdef_list (rs##args) (rs'##args)). apply regs_lessdef_regs; auto. exploit eval_operation_lessdef; eauto. intros [v' [EVAL' VLD]]. left. exists (State s' (transf_function f) (Vptr sp0 Int.zero) pc' (rs'#res <- v') m'); split. eapply exec_Iop; eauto. rewrite <- EVAL'. apply eval_operation_preserved. exact symbols_preserved. - econstructor; eauto. apply regset_set; auto. + econstructor; eauto. apply set_reg_lessdef; auto. (* eliminated move *) rewrite H1 in H. clear H1. inv H. right. split. simpl. omega. split. auto. @@ -451,7 +433,7 @@ Proof. (* load *) TransfInstr. - assert (Val.lessdef_list (rs##args) (rs'##args)). apply regset_get_list; auto. + assert (Val.lessdef_list (rs##args) (rs'##args)). apply regs_lessdef_regs; auto. exploit eval_addressing_lessdef; eauto. intros [a' [ADDR' ALD]]. exploit Mem.loadv_extends; eauto. @@ -459,11 +441,11 @@ Proof. left. exists (State s' (transf_function f) (Vptr sp0 Int.zero) pc' (rs'#dst <- v') m'); split. eapply exec_Iload with (a := a'). eauto. rewrite <- ADDR'. apply eval_addressing_preserved. exact symbols_preserved. eauto. - econstructor; eauto. apply regset_set; auto. + econstructor; eauto. apply set_reg_lessdef; auto. (* store *) TransfInstr. - assert (Val.lessdef_list (rs##args) (rs'##args)). apply regset_get_list; auto. + assert (Val.lessdef_list (rs##args) (rs'##args)). apply regs_lessdef_regs; auto. exploit eval_addressing_lessdef; eauto. intros [a' [ADDR' ALD]]. exploit Mem.storev_extends. 2: eexact H1. eauto. eauto. apply RLD. @@ -484,14 +466,14 @@ Proof. destruct X as [m'' FREE]. left. exists (Callstate s' (transf_fundef fd) (rs'##args) m''); split. eapply exec_Itailcall; eauto. apply sig_preserved. - constructor. eapply match_stackframes_tail; eauto. apply regset_get_list; auto. + constructor. eapply match_stackframes_tail; eauto. apply regs_lessdef_regs; auto. eapply Mem.free_right_extends; eauto. rewrite stacksize_preserved. rewrite H7. intros. omegaContradiction. (* call that remains a call *) left. exists (Callstate (Stackframe res (transf_function f) (Vptr sp0 Int.zero) pc' rs' :: s') (transf_fundef fd) (rs'##args) m'); split. eapply exec_Icall; eauto. apply sig_preserved. - constructor. constructor; auto. apply regset_get_list; auto. auto. + constructor. constructor; auto. apply regs_lessdef_regs; auto. auto. (* tailcall *) exploit find_function_translated; eauto. intro FIND'. @@ -500,37 +482,26 @@ Proof. left. exists (Callstate s' (transf_fundef fd) (rs'##args) m'1); split. eapply exec_Itailcall; eauto. apply sig_preserved. rewrite stacksize_preserved; auto. - constructor. auto. apply regset_get_list; auto. auto. + constructor. auto. apply regs_lessdef_regs; auto. auto. (* builtin *) TransfInstr. - assert (Val.lessdef_list (rs##args) (rs'##args)). apply regset_get_list; auto. - exploit external_call_mem_extends; eauto. - intros [v' [m'1 [A [B [C D]]]]]. - left. exists (State s' (transf_function f) (Vptr sp0 Int.zero) pc' (rs'#res <- v') m'1); split. - eapply exec_Ibuiltin; eauto. - eapply external_call_symbols_preserved; eauto. - exact symbols_preserved. exact public_preserved. exact varinfo_preserved. - econstructor; eauto. apply regset_set; auto. - -(* annot *) - TransfInstr. - exploit (@eval_annot_args_lessdef _ ge (fun r => rs#r) (fun r => rs'#r)); eauto. + exploit (@eval_builtin_args_lessdef _ ge (fun r => rs#r) (fun r => rs'#r)); eauto. intros (vargs' & P & Q). exploit external_call_mem_extends; eauto. intros [v' [m'1 [A [B [C D]]]]]. - left. exists (State s' (transf_function f) (Vptr sp0 Int.zero) pc' rs' m'1); split. - eapply exec_Iannot; eauto. - eapply eval_annot_args_preserved with (ge1 := ge); eauto. exact symbols_preserved. + left. exists (State s' (transf_function f) (Vptr sp0 Int.zero) pc' (regmap_setres res v' rs') m'1); split. + eapply exec_Ibuiltin; eauto. + eapply eval_builtin_args_preserved with (ge1 := ge); eauto. exact symbols_preserved. eapply external_call_symbols_preserved; eauto. exact symbols_preserved. exact public_preserved. exact varinfo_preserved. - econstructor; eauto. + econstructor; eauto. apply set_res_lessdef; auto. (* cond *) TransfInstr. left. exists (State s' (transf_function f) (Vptr sp0 Int.zero) (if b then ifso else ifnot) rs' m'); split. eapply exec_Icond; eauto. - apply eval_condition_lessdef with (rs##args) m; auto. apply regset_get_list; auto. + apply eval_condition_lessdef with (rs##args) m; auto. apply regs_lessdef_regs; auto. constructor; auto. (* jumptable *) @@ -576,7 +547,7 @@ Proof. left. econstructor; split. simpl. eapply exec_function_internal; eauto. rewrite EQ1; eauto. rewrite EQ2. rewrite EQ3. constructor; auto. - apply regset_init_regs. auto. + apply regs_lessdef_init_regs. auto. (* external call *) exploit external_call_mem_extends; eauto. @@ -592,7 +563,7 @@ Proof. (* synchronous return in both programs *) left. econstructor; split. apply exec_return. - constructor; auto. apply regset_set; auto. + constructor; auto. apply set_reg_lessdef; auto. (* return instr in source program, eliminated because of tailcall *) right. split. unfold measure. simpl length. change (S (length s) * (niter + 2))%nat diff --git a/backend/Tunnelingproof.v b/backend/Tunnelingproof.v index 52318ede..e9e4856e 100644 --- a/backend/Tunnelingproof.v +++ b/backend/Tunnelingproof.v @@ -339,14 +339,8 @@ Proof. (* Lbuiltin *) left; simpl; econstructor; split. eapply exec_Lbuiltin; eauto. - eapply external_call_symbols_preserved'; eauto. - exact symbols_preserved. exact public_preserved. exact varinfo_preserved. - econstructor; eauto. - (* Lannot *) - left; simpl; econstructor; split. - eapply exec_Lannot; eauto. - eapply eval_annot_args_preserved with (ge1 := ge); eauto. exact symbols_preserved. - eapply external_call_symbols_preserved; eauto. + eapply eval_builtin_args_preserved with (ge1 := ge); eauto. exact symbols_preserved. + eapply external_call_symbols_preserved. eauto. exact symbols_preserved. exact public_preserved. exact varinfo_preserved. econstructor; eauto. diff --git a/backend/Unusedglob.v b/backend/Unusedglob.v index 400c19d9..8725c9af 100644 --- a/backend/Unusedglob.v +++ b/backend/Unusedglob.v @@ -59,8 +59,7 @@ Definition ref_instruction (i: instruction) : list ident := | Icall _ (inr id) _ _ _ => id :: nil | Itailcall _ (inl r) _ => nil | Itailcall _ (inr id) _ => id :: nil - | Ibuiltin ef _ _ _ => globals_external ef - | Iannot _ args _ => globals_of_annot_args args + | Ibuiltin _ args _ _ => globals_of_builtin_args args | Icond cond _ _ _ => nil | Ijumptable _ _ => nil | Ireturn _ => nil @@ -87,7 +86,7 @@ Definition add_ref_definition (pm: prog_map) (id: ident) (w: workset): workset : match pm!id with | None => w | Some (Gfun (Internal f)) => add_ref_function f w - | Some (Gfun (External ef)) => addlist_workset (globals_external ef) w + | Some (Gfun (External ef)) => w | Some (Gvar gv) => add_ref_globvar gv w end. diff --git a/backend/Unusedglobproof.v b/backend/Unusedglobproof.v index 85e7a360..4d7547f0 100644 --- a/backend/Unusedglobproof.v +++ b/backend/Unusedglobproof.v @@ -111,7 +111,7 @@ Proof. unfold add_ref_definition; intros. destruct (pm!id) as [[[] | ? ] | ]. apply add_ref_function_incl. - apply addlist_workset_incl. + apply workset_incl_refl. apply add_ref_globvar_incl. apply workset_incl_refl. Qed. @@ -165,7 +165,7 @@ Proof. Qed. Definition ref_fundef (fd: fundef) (id: ident) : Prop := - match fd with Internal f => ref_function f id | External ef => In id (globals_external ef) end. + match fd with Internal f => ref_function f id | External ef => False end. Definition ref_def (gd: globdef fundef unit) (id: ident) : Prop := match gd with @@ -179,7 +179,7 @@ Lemma seen_add_ref_definition: Proof. unfold add_ref_definition; intros. rewrite H. red in H0; destruct gd as [[f|ef]|gv]. apply seen_add_ref_function; auto. - apply seen_addlist_workset; auto. + contradiction. destruct H0 as (ofs & IN). unfold add_ref_globvar. assert (forall l (w: workset), @@ -580,6 +580,14 @@ Proof. intros; red; intros. rewrite ! Regmap.gsspec. destruct (peq r0 r); auto. Qed. +Lemma set_res_inject: + forall f rs rs' res v v', + regset_inject f rs rs' -> Val.inject f v v' -> + regset_inject f (regmap_setres res v rs) (regmap_setres res v' rs'). +Proof. + intros. destruct res; auto. apply set_reg_inject; auto. +Qed. + Lemma regset_inject_incr: forall f f' rs rs', regset_inject f rs rs' -> inject_incr f f' -> regset_inject f' rs rs'. Proof. @@ -704,7 +712,6 @@ Lemma external_call_inject: forall ef vargs m1 t vres m2 f m1' vargs', meminj_preserves_globals f -> external_call ef ge vargs m1 t vres m2 -> - (forall id, In id (globals_external ef) -> kept id) -> Mem.inject f m1 m1' -> Val.inject_list f vargs vargs' -> exists f', exists vres', exists m2', @@ -717,9 +724,7 @@ Lemma external_call_inject: /\ inject_separated f f' m1 m1'. Proof. intros. eapply external_call_mem_inject_gen; eauto. -- apply globals_symbols_inject; auto. -- intros. exploit symbols_inject_2; eauto. - intros (b' & A & B); exists b'; auto. + apply globals_symbols_inject; auto. Qed. Lemma find_function_inject: @@ -741,60 +746,60 @@ Proof. auto. Qed. -Lemma eval_annot_arg_inject: +Lemma eval_builtin_arg_inject: forall rs sp m j rs' sp' m' a v, - eval_annot_arg ge (fun r => rs#r) (Vptr sp Int.zero) m a v -> + eval_builtin_arg ge (fun r => rs#r) (Vptr sp Int.zero) m a v -> j sp = Some(sp', 0) -> meminj_preserves_globals j -> regset_inject j rs rs' -> Mem.inject j m m' -> - (forall id, In id (globals_of_annot_arg a) -> kept id) -> + (forall id, In id (globals_of_builtin_arg a) -> kept id) -> exists v', - eval_annot_arg tge (fun r => rs'#r) (Vptr sp' Int.zero) m' a v' + eval_builtin_arg tge (fun r => rs'#r) (Vptr sp' Int.zero) m' a v' /\ Val.inject j v v'. Proof. induction 1; intros SP GL RS MI K; simpl in K. - exists rs'#x; split; auto. constructor. -- econstructor; eauto with aarg. -- econstructor; eauto with aarg. -- econstructor; eauto with aarg. -- econstructor; eauto with aarg. +- econstructor; eauto with barg. +- econstructor; eauto with barg. +- econstructor; eauto with barg. +- econstructor; eauto with barg. - simpl in H. exploit Mem.load_inject; eauto. rewrite Zplus_0_r. - intros (v' & A & B). exists v'; auto with aarg. -- econstructor; split; eauto with aarg. simpl. econstructor; eauto. rewrite Int.add_zero; auto. + intros (v' & A & B). exists v'; auto with barg. +- econstructor; split; eauto with barg. simpl. econstructor; eauto. rewrite Int.add_zero; auto. - assert (Val.inject j (Senv.symbol_address ge id ofs) (Senv.symbol_address tge id ofs)). { unfold Senv.symbol_address; simpl; unfold Genv.symbol_address. destruct (Genv.find_symbol ge id) as [b|] eqn:FS; auto. exploit symbols_inject_2; eauto. intros (b' & A & B). rewrite A. econstructor; eauto. rewrite Int.add_zero; auto. } - exploit Mem.loadv_inject; eauto. intros (v' & A & B). exists v'; auto with aarg. -- econstructor; split; eauto with aarg. + exploit Mem.loadv_inject; eauto. intros (v' & A & B). exists v'; auto with barg. +- econstructor; split; eauto with barg. unfold Senv.symbol_address; simpl; unfold Genv.symbol_address. destruct (Genv.find_symbol ge id) as [b|] eqn:FS; auto. exploit symbols_inject_2; eauto. intros (b' & A & B). rewrite A. econstructor; eauto. rewrite Int.add_zero; auto. -- destruct IHeval_annot_arg1 as (v1' & A1 & B1); eauto using in_or_app. - destruct IHeval_annot_arg2 as (v2' & A2 & B2); eauto using in_or_app. - exists (Val.longofwords v1' v2'); split; auto with aarg. +- destruct IHeval_builtin_arg1 as (v1' & A1 & B1); eauto using in_or_app. + destruct IHeval_builtin_arg2 as (v2' & A2 & B2); eauto using in_or_app. + exists (Val.longofwords v1' v2'); split; auto with barg. apply Val.longofwords_inject; auto. Qed. -Lemma eval_annot_args_inject: +Lemma eval_builtin_args_inject: forall rs sp m j rs' sp' m' al vl, - eval_annot_args ge (fun r => rs#r) (Vptr sp Int.zero) m al vl -> + eval_builtin_args ge (fun r => rs#r) (Vptr sp Int.zero) m al vl -> j sp = Some(sp', 0) -> meminj_preserves_globals j -> regset_inject j rs rs' -> Mem.inject j m m' -> - (forall id, In id (globals_of_annot_args al) -> kept id) -> + (forall id, In id (globals_of_builtin_args al) -> kept id) -> exists vl', - eval_annot_args tge (fun r => rs'#r) (Vptr sp' Int.zero) m' al vl' + eval_builtin_args tge (fun r => rs'#r) (Vptr sp' Int.zero) m' al vl' /\ Val.inject_list j vl vl'. Proof. induction 1; intros. - exists (@nil val); split; constructor. - simpl in H5. - exploit eval_annot_arg_inject; eauto using in_or_app. intros (v1' & A & B). + exploit eval_builtin_arg_inject; eauto using in_or_app. intros (v1' & A & B). destruct IHlist_forall2 as (vl' & C & D); eauto using in_or_app. exists (v1' :: vl'); split; constructor; auto. Qed. @@ -888,39 +893,22 @@ Proof. apply regs_inject; auto. - (* builtin *) - exploit external_call_inject; eauto. - eapply match_stacks_preserves_globals; eauto. - intros. apply KEPT. red. econstructor; econstructor; eauto. - apply regs_inject; eauto. - intros (j' & tv & tm' & A & B & C & D & E & F & G). - econstructor; split. - eapply exec_Ibuiltin; eauto. - eapply match_states_regular with (j := j'); eauto. - apply match_stacks_incr with j; auto. - intros. exploit G; eauto. intros [P Q]. - assert (Mem.valid_block m sp0) by (eapply Mem.valid_block_inject_1; eauto). - assert (Mem.valid_block tm tsp) by (eapply Mem.valid_block_inject_2; eauto). - unfold Mem.valid_block in *; xomega. - apply set_reg_inject; auto. apply regset_inject_incr with j; auto. - -- (* annot *) - exploit eval_annot_args_inject; eauto. + exploit eval_builtin_args_inject; eauto. eapply match_stacks_preserves_globals; eauto. intros. apply KEPT. red. econstructor; econstructor; eauto. intros (vargs' & P & Q). exploit external_call_inject; eauto. eapply match_stacks_preserves_globals; eauto. - destruct ef; contradiction. intros (j' & tv & tm' & A & B & C & D & E & F & G). econstructor; split. - eapply exec_Iannot; eauto. + eapply exec_Ibuiltin; eauto. eapply match_states_regular with (j := j'); eauto. apply match_stacks_incr with j; auto. intros. exploit G; eauto. intros [U V]. assert (Mem.valid_block m sp0) by (eapply Mem.valid_block_inject_1; eauto). assert (Mem.valid_block tm tsp) by (eapply Mem.valid_block_inject_2; eauto). unfold Mem.valid_block in *; xomega. - apply regset_inject_incr with j; auto. + apply set_res_inject; auto. apply regset_inject_incr with j; auto. - (* cond *) assert (C: eval_condition cond trs##args tm = Some b). diff --git a/backend/ValueAnalysis.v b/backend/ValueAnalysis.v index c559aa25..22121075 100644 --- a/backend/ValueAnalysis.v +++ b/backend/ValueAnalysis.v @@ -35,6 +35,11 @@ Definition areg (ae: aenv) (r: reg) : aval := AE.get r ae. Definition aregs (ae: aenv) (rl: list reg) : list aval := List.map (areg ae) rl. +(** Analysis of function calls. We treat specially the case where + neither the arguments nor the global variables point within the + stack frame of the current function. In this case, no pointer + within the stack frame escapes during the call. *) + Definition mafter_public_call : amem := mtop. Definition mafter_private_call (am_before: amem) : amem := @@ -43,53 +48,78 @@ Definition mafter_private_call (am_before: amem) : amem := am_nonstack := Nonstack; am_top := plub (ab_summary (am_stack am_before)) Nonstack |}. -Definition transfer_call (ae: aenv) (am: amem) (args: list reg) (res: reg) := +Definition analyze_call (am: amem) (aargs: list aval) := if pincl am.(am_nonstack) Nonstack - && forallb (fun r => vpincl (areg ae r) Nonstack) args - then - VA.State (AE.set res (Ifptr Nonstack) ae) (mafter_private_call am) - else - VA.State (AE.set res Vtop ae) mafter_public_call. - -Inductive builtin_kind : Type := - | Builtin_vload (chunk: memory_chunk) (aaddr: aval) - | Builtin_vstore (chunk: memory_chunk) (aaddr av: aval) - | Builtin_memcpy (sz al: Z) (adst asrc: aval) - | Builtin_annot_val (av: aval) - | Builtin_default. - -Definition classify_builtin (ef: external_function) (args: list reg) (ae: aenv) := - match ef, args with - | EF_vload chunk, a1::nil => Builtin_vload chunk (areg ae a1) - | EF_vload_global chunk id ofs, nil => Builtin_vload chunk (Ptr (Gl id ofs)) - | EF_vstore chunk, a1::a2::nil => Builtin_vstore chunk (areg ae a1) (areg ae a2) - | EF_vstore_global chunk id ofs, a1::nil => Builtin_vstore chunk (Ptr (Gl id ofs)) (areg ae a1) - | EF_memcpy sz al, a1::a2::nil => Builtin_memcpy sz al (areg ae a1) (areg ae a2) - | EF_annot_val _ _, a1::nil => Builtin_annot_val (areg ae a1) - | _, _ => Builtin_default + && forallb (fun av => vpincl av Nonstack) aargs + then (Ifptr Nonstack, mafter_private_call am) + else (Vtop, mafter_public_call). + +Definition transfer_call (ae: aenv) (am: amem) (args: list reg) (res: reg) := + let (av, am') := analyze_call am (aregs ae args) in + VA.State (AE.set res av ae) am'. + +(** Analysis of builtins. *) + +Fixpoint abuiltin_arg (ae: aenv) (am: amem) (rm: romem) (ba: builtin_arg reg) : aval := + match ba with + | BA r => areg ae r + | BA_int n => I n + | BA_long n => L n + | BA_float n => F n + | BA_single n => FS n + | BA_loadstack chunk ofs => loadv chunk rm am (Ptr (Stk ofs)) + | BA_addrstack ofs => Ptr (Stk ofs) + | BA_loadglobal chunk id ofs => loadv chunk rm am (Ptr (Gl id ofs)) + | BA_addrglobal id ofs => Ptr (Gl id ofs) + | BA_splitlong hi lo => longofwords (abuiltin_arg ae am rm hi) (abuiltin_arg ae am rm lo) end. -Definition transfer_builtin (ae: aenv) (am: amem) (rm: romem) (ef: external_function) (args: list reg) (res: reg) := - match classify_builtin ef args ae with - | Builtin_vload chunk aaddr => +Definition set_builtin_res (br: builtin_res reg) (av: aval) (ae: aenv) : aenv := + match br with + | BR r => AE.set r av ae + | _ => ae + end. + +Definition transfer_builtin_default + (ae: aenv) (am: amem) (rm: romem) + (args: list (builtin_arg reg)) (res: builtin_res reg) := + let (av, am') := analyze_call am (map (abuiltin_arg ae am rm) args) in + VA.State (set_builtin_res res av ae) am'. + +Definition transfer_builtin + (ae: aenv) (am: amem) (rm: romem) (ef: external_function) + (args: list (builtin_arg reg)) (res: builtin_res reg) := + match ef, args with + | EF_vload chunk, addr :: nil => + let aaddr := abuiltin_arg ae am rm addr in let a := if va_strict tt then vlub (loadv chunk rm am aaddr) (vnormalize chunk (Ifptr Glob)) else vnormalize chunk Vtop in - VA.State (AE.set res a ae) am - | Builtin_vstore chunk aaddr av => + VA.State (set_builtin_res res a ae) am + | EF_vstore chunk, addr :: v :: nil => + let aaddr := abuiltin_arg ae am rm addr in + let av := abuiltin_arg ae am rm v in let am' := storev chunk am aaddr av in - VA.State (AE.set res ntop ae) (mlub am am') - | Builtin_memcpy sz al adst asrc => + VA.State (set_builtin_res res ntop ae) (mlub am am') + | EF_memcpy sz al, dst :: src :: nil => + let adst := abuiltin_arg ae am rm dst in + let asrc := abuiltin_arg ae am rm src in let p := loadbytes am rm (aptr_of_aval asrc) in let am' := storebytes am (aptr_of_aval adst) sz p in - VA.State (AE.set res ntop ae) am' - | Builtin_annot_val av => - VA.State (AE.set res av ae) am - | Builtin_default => - transfer_call ae am args res + VA.State (set_builtin_res res ntop ae) am' + | (EF_annot _ _ | EF_debug _ _ _), _ => + VA.State (set_builtin_res res ntop ae) am + | EF_annot_val _ _, v :: nil => + let av := abuiltin_arg ae am rm v in + VA.State (set_builtin_res res av ae) am + | _, _ => + transfer_builtin_default ae am rm args res end. +(** The transfer function for one instruction. Given the abstract state + "before" the instruction, computes the abstract state "after". *) + Definition transfer (f: function) (rm: romem) (pc: node) (ae: aenv) (am: amem) : VA.t := match f.(fn_code)!pc with | None => @@ -111,8 +141,6 @@ Definition transfer (f: function) (rm: romem) (pc: node) (ae: aenv) (am: amem) : VA.Bot | Some(Ibuiltin ef args res s) => transfer_builtin ae am rm ef args res - | Some(Iannot ef args s) => - VA.State ae am | Some(Icond cond args s1 s2) => VA.State ae am | Some(Ijumptable arg tbl) => @@ -121,6 +149,9 @@ Definition transfer (f: function) (rm: romem) (pc: node) (ae: aenv) (am: amem) : VA.Bot end. +(** A wrapper on [transfer] that removes information associated with + dead registers, so as to reduce the sizes of abstract states. *) + Definition transfer' (f: function) (lastuses: PTree.t (list reg)) (rm: romem) (pc: node) (before: VA.t) : VA.t := match before with @@ -138,6 +169,8 @@ Definition transfer' (f: function) (lastuses: PTree.t (list reg)) (rm: romem) end end. +(** The forward dataflow analysis. *) + Module DS := Dataflow_Solver(VA)(NodeSetForward). Definition mfunction_entry := @@ -285,50 +318,65 @@ Proof. split. eapply ematch_ge; eauto. eauto. Qed. -(** Classification of builtin functions *) +(** ** Analysis of registers and builtin arguments *) -Lemma classify_builtin_sound: - forall bc e ae ef (ge: genv) args m t res m', - ematch bc e ae -> +Lemma areg_sound: + forall bc e ae r, ematch bc e ae -> vmatch bc (e#r) (areg ae r). +Proof. + intros. apply H. +Qed. + +Lemma aregs_sound: + forall bc e ae rl, ematch bc e ae -> list_forall2 (vmatch bc) (e##rl) (aregs ae rl). +Proof. + induction rl; simpl; intros. constructor. constructor; auto. apply areg_sound; auto. +Qed. + +Hint Resolve areg_sound aregs_sound: va. + +Lemma abuiltin_arg_sound: + forall bc ge rs sp m ae rm am, + ematch bc rs ae -> + romatch bc m rm -> + mmatch bc m am -> genv_match bc ge -> - external_call ef ge e##args m t res m' -> - match classify_builtin ef args ae with - | Builtin_vload chunk aaddr => - exists addr, - volatile_load_sem chunk ge (addr::nil) m t res m' /\ vmatch bc addr aaddr - | Builtin_vstore chunk aaddr av => - exists addr v, - volatile_store_sem chunk ge (addr::v::nil) m t res m' - /\ vmatch bc addr aaddr /\ vmatch bc v av - | Builtin_memcpy sz al adst asrc => - exists dst, exists src, - extcall_memcpy_sem sz al ge (dst::src::nil) m t res m' - /\ vmatch bc dst adst /\ vmatch bc src asrc - | Builtin_annot_val av => m' = m /\ vmatch bc res av - | Builtin_default => True - end. + bc sp = BCstack -> + forall a v, + eval_builtin_arg ge (fun r => rs#r) (Vptr sp Int.zero) m a v -> + vmatch bc v (abuiltin_arg ae am rm a). +Proof. + intros until am; intros EM RM MM GM SP. + induction 1; simpl; eauto with va. +- eapply loadv_sound; eauto. simpl. rewrite Int.add_zero_l. auto with va. +- simpl. rewrite Int.add_zero_l. auto with va. +- eapply loadv_sound; eauto. apply symbol_address_sound; auto. +- apply symbol_address_sound; auto. +Qed. + +Lemma abuiltin_args_sound: + forall bc ge rs sp m ae rm am, + ematch bc rs ae -> + romatch bc m rm -> + mmatch bc m am -> + genv_match bc ge -> + bc sp = BCstack -> + forall al vl, + eval_builtin_args ge (fun r => rs#r) (Vptr sp Int.zero) m al vl -> + list_forall2 (vmatch bc) vl (map (abuiltin_arg ae am rm) al). +Proof. + intros until am; intros EM RM MM GM SP. + induction 1; simpl. +- constructor. +- constructor; auto. eapply abuiltin_arg_sound; eauto. +Qed. + +Lemma set_builtin_res_sound: + forall bc rs ae v av res, + ematch bc rs ae -> + vmatch bc v av -> + ematch bc (regmap_setres res v rs) (set_builtin_res res av ae). Proof. - intros. unfold classify_builtin; destruct ef; auto. -- (* vload *) - destruct args; auto. destruct args; auto. - exists (e#p); split; eauto. -- (* vstore *) - destruct args; auto. destruct args; auto. destruct args; auto. - exists (e#p), (e#p0); eauto. -- (* vload global *) - destruct args; auto. simpl in H1. - rewrite volatile_load_global_charact in H1. destruct H1 as (b & A & B). - exists (Vptr b ofs); split; auto. constructor. constructor. eapply H0; eauto. -- (* vstore global *) - destruct args; auto. destruct args; auto. simpl in H1. - rewrite volatile_store_global_charact in H1. destruct H1 as (b & A & B). - exists (Vptr b ofs), (e#p); split; auto. split; eauto. constructor. constructor. eapply H0; eauto. -- (* memcpy *) - destruct args; auto. destruct args; auto. destruct args; auto. - exists (e#p), (e#p0); eauto. -- (* annot val *) - destruct args; auto. destruct args; auto. - simpl in H1. inv H1. eauto. + intros. destruct res; simpl; auto. apply ematch_update; auto. Qed. (** ** Constructing block classifications *) @@ -981,6 +1029,17 @@ Proof. apply UNCH1; auto. intros; red. unfold inj_of_bc; rewrite H0; auto. Qed. +Remark list_forall2_in_l: + forall (A B: Type) (P: A -> B -> Prop) x1 l1 l2, + list_forall2 P l1 l2 -> In x1 l1 -> exists x2, In x2 l2 /\ P x1 x2. +Proof. + induction 1; simpl; intros. +- contradiction. +- destruct H1. + + subst. exists b1; auto. + + exploit IHlist_forall2; eauto. intros (x2 & U & V). exists x2; auto. +Qed. + (** ** Semantic invariant *) Section SOUNDNESS. @@ -1170,20 +1229,6 @@ Proof. econstructor; eauto. Qed. -Lemma areg_sound: - forall bc e ae r, ematch bc e ae -> vmatch bc (e#r) (areg ae r). -Proof. - intros. apply H. -Qed. - -Lemma aregs_sound: - forall bc e ae rl, ematch bc e ae -> list_forall2 (vmatch bc) (e##rl) (aregs ae rl). -Proof. - induction rl; simpl; intros. constructor. constructor; auto. apply areg_sound; auto. -Qed. - -Hint Resolve areg_sound aregs_sound: va. - Theorem sound_step: forall st t st', RTL.step ge st t st' -> sound_state st -> sound_state st'. Proof. @@ -1215,9 +1260,9 @@ Proof. - (* call *) assert (TR: transfer f rm pc ae am = transfer_call ae am args res). { unfold transfer; rewrite H; auto. } - unfold transfer_call in TR. + unfold transfer_call, analyze_call in TR. destruct (pincl (am_nonstack am) Nonstack && - forallb (fun r : reg => vpincl (areg ae r) Nonstack) args) eqn:NOLEAK. + forallb (fun av => vpincl av Nonstack) (aregs ae args)) eqn:NOLEAK. + (* private call *) InvBooleans. exploit analyze_successor; eauto. simpl; eauto. rewrite TR. intros SUCC. @@ -1230,7 +1275,9 @@ Proof. eapply mmatch_stack; eauto. * intros. exploit list_in_map_inv; eauto. intros (r & P & Q). subst v. apply D with (areg ae r). - rewrite forallb_forall in H2. apply vpincl_ge. apply H2; auto. auto with va. + rewrite forallb_forall in H2. apply vpincl_ge. + apply H2. apply in_map; auto. + auto with va. + (* public call *) exploit analyze_successor; eauto. simpl; eauto. rewrite TR. intros SUCC. exploit anonymize_stack; eauto. intros (bc' & A & B & C & D & E & F & G). @@ -1259,61 +1306,24 @@ Proof. assert (SPVALID: Plt sp0 (Mem.nextblock m)) by (eapply mmatch_below; eauto with va). assert (TR: transfer f rm pc ae am = transfer_builtin ae am rm ef args res). { unfold transfer; rewrite H; auto. } - unfold transfer_builtin in TR. - exploit classify_builtin_sound; eauto. destruct (classify_builtin ef args ae). -+ (* volatile load *) - intros (addr & VLOAD & VADDR). inv VLOAD. - eapply sound_succ_state; eauto. simpl; auto. - apply ematch_update; auto. - inv H2. - * (* true volatile access *) - assert (V: vmatch bc v0 (Ifptr Glob)). - { inv H4; simpl in *; constructor. econstructor. eapply GE; eauto. } - destruct (va_strict tt). apply vmatch_lub_r. apply vnormalize_sound. auto. - apply vnormalize_sound. eapply vmatch_ge; eauto. constructor. constructor. - * (* normal memory access *) - exploit loadv_sound; eauto. simpl; eauto. intros V. - destruct (va_strict tt). - apply vmatch_lub_l. auto. - eapply vnormalize_cast; eauto. eapply vmatch_top; eauto. -+ (* volatile store *) - intros (addr & src & VSTORE & VADDR & VSRC). inv VSTORE. inv H7. - * (* true volatile access *) - eapply sound_succ_state; eauto. simpl; auto. - apply ematch_update; auto. constructor. - apply mmatch_lub_l; auto. - * (* normal memory access *) - eapply sound_succ_state; eauto. simpl; auto. - apply ematch_update; auto. constructor. - apply mmatch_lub_r. eapply storev_sound; eauto. auto. - eapply romatch_store; eauto. - eapply sound_stack_storev; eauto. simpl; eauto. -+ (* memcpy *) - intros (dst & src & MEMCPY & VDST & VSRC). inv MEMCPY. - eapply sound_succ_state; eauto. simpl; auto. - apply ematch_update; auto. constructor. - eapply storebytes_sound; eauto. - apply match_aptr_of_aval; auto. - eapply Mem.loadbytes_length; eauto. - intros. eapply loadbytes_sound; eauto. apply match_aptr_of_aval; auto. - eapply romatch_storebytes; eauto. - eapply sound_stack_storebytes; eauto. -+ (* annot val *) - intros (A & B); subst. - eapply sound_succ_state; eauto. simpl; auto. - apply ematch_update; auto. -+ (* general case *) - intros _. - unfold transfer_call in TR. + (* The default case *) + assert (DEFAULT: + transfer f rm pc ae am = transfer_builtin_default ae am rm args res -> + sound_state + (State s f (Vptr sp0 Int.zero) pc' (regmap_setres res vres rs) m')). + { unfold transfer_builtin_default, analyze_call; intros TR'. + set (aargs := map (abuiltin_arg ae am rm) args) in *. + assert (ARGS: list_forall2 (vmatch bc) vargs aargs) by (eapply abuiltin_args_sound; eauto). destruct (pincl (am_nonstack am) Nonstack && - forallb (fun r : reg => vpincl (areg ae r) Nonstack) args) eqn:NOLEAK. + forallb (fun av => vpincl av Nonstack) aargs) + eqn: NOLEAK. * (* private builtin call *) - InvBooleans. rewrite forallb_forall in H2. + InvBooleans. rewrite forallb_forall in H3. exploit hide_stack; eauto. apply pincl_ge; auto. intros (bc1 & A & B & C & D & E & F & G). exploit external_call_match; eauto. - intros. exploit list_in_map_inv; eauto. intros (r & P & Q). subst v0. - eapply D; eauto with va. apply vpincl_ge. apply H2; auto. + intros. exploit list_forall2_in_l; eauto. intros (av & U & V). + eapply D; eauto with va. apply vpincl_ge. apply H3; auto. intros (bc2 & J & K & L & M & N & O & P & Q). exploit (return_from_private_call bc bc2); eauto. eapply mmatch_below; eauto. @@ -1324,7 +1334,7 @@ Proof. eapply external_call_nextblock; eauto. intros (bc3 & U & V & W & X & Y & Z & AA). eapply sound_succ_state with (bc := bc3); eauto. simpl; auto. - apply ematch_update; auto. + apply set_builtin_res_sound; auto. apply sound_stack_exten with bc. apply sound_stack_inv with m. auto. intros. apply Q. red. eapply Plt_trans; eauto. @@ -1334,7 +1344,7 @@ Proof. exploit anonymize_stack; eauto. intros (bc1 & A & B & C & D & E & F & G). exploit external_call_match; eauto. - intros. exploit list_in_map_inv; eauto. intros (r & P & Q). subst v0. eapply D; eauto with va. + intros. exploit list_forall2_in_l; eauto. intros (av & U & V). eapply D; eauto with va. intros (bc2 & J & K & L & M & N & O & P & Q). exploit (return_from_public_call bc bc2); eauto. eapply mmatch_below; eauto. @@ -1343,17 +1353,66 @@ Proof. eapply external_call_nextblock; eauto. intros (bc3 & U & V & W & X & Y & Z & AA). eapply sound_succ_state with (bc := bc3); eauto. simpl; auto. - apply ematch_update; auto. + apply set_builtin_res_sound; auto. apply sound_stack_exten with bc. apply sound_stack_inv with m. auto. intros. apply Q. red. eapply Plt_trans; eauto. rewrite C; auto. exact AA. - -- (* annot *) - destruct ef; try contradiction. inv H2. + } + unfold transfer_builtin in TR. + destruct ef; auto. ++ (* volatile load *) + inv H0; auto. inv H3; auto. inv H1. + exploit abuiltin_arg_sound; eauto. intros VM1. + eapply sound_succ_state; eauto. simpl; auto. + apply set_builtin_res_sound; auto. + inv H3. + * (* true volatile access *) + assert (V: vmatch bc v (Ifptr Glob)). + { inv H4; simpl in *; constructor. econstructor. eapply GE; eauto. } + destruct (va_strict tt). apply vmatch_lub_r. apply vnormalize_sound. auto. + apply vnormalize_sound. eapply vmatch_ge; eauto. constructor. constructor. + * (* normal memory access *) + exploit loadv_sound; eauto. simpl; eauto. intros V. + destruct (va_strict tt). + apply vmatch_lub_l. auto. + eapply vnormalize_cast; eauto. eapply vmatch_top; eauto. ++ (* volatile store *) + inv H0; auto. inv H3; auto. inv H4; auto. inv H1. + exploit abuiltin_arg_sound. eauto. eauto. eauto. eauto. eauto. eexact H0. intros VM1. + exploit abuiltin_arg_sound. eauto. eauto. eauto. eauto. eauto. eexact H2. intros VM2. + inv H9. + * (* true volatile access *) + eapply sound_succ_state; eauto. simpl; auto. + apply set_builtin_res_sound; auto. constructor. + apply mmatch_lub_l; auto. + * (* normal memory access *) + eapply sound_succ_state; eauto. simpl; auto. + apply set_builtin_res_sound; auto. constructor. + apply mmatch_lub_r. eapply storev_sound; eauto. auto. + eapply romatch_store; eauto. + eapply sound_stack_storev; eauto. simpl; eauto. ++ (* memcpy *) + inv H0; auto. inv H3; auto. inv H4; auto. inv H1. + exploit abuiltin_arg_sound. eauto. eauto. eauto. eauto. eauto. eexact H0. intros VM1. + exploit abuiltin_arg_sound. eauto. eauto. eauto. eauto. eauto. eexact H2. intros VM2. eapply sound_succ_state; eauto. simpl; auto. - unfold transfer; rewrite H; eauto. + apply set_builtin_res_sound; auto. constructor. + eapply storebytes_sound; eauto. + apply match_aptr_of_aval; auto. + eapply Mem.loadbytes_length; eauto. + intros. eapply loadbytes_sound; eauto. apply match_aptr_of_aval; auto. + eapply romatch_storebytes; eauto. + eapply sound_stack_storebytes; eauto. ++ (* annot *) + inv H1. eapply sound_succ_state; eauto. simpl; auto. apply set_builtin_res_sound; auto. constructor. ++ (* annot val *) + inv H0; auto. inv H3; auto. inv H1. + eapply sound_succ_state; eauto. simpl; auto. + apply set_builtin_res_sound; auto. eapply abuiltin_arg_sound; eauto. ++ (* debug *) + inv H1. eapply sound_succ_state; eauto. simpl; auto. apply set_builtin_res_sound; auto. constructor. - (* cond *) eapply sound_succ_state; eauto. @@ -1830,7 +1889,46 @@ Proof. eapply eval_static_addressing_sound; eauto with va. Qed. +(** This is a less precise version of [abuiltin_arg], where memory + contents are not taken into account. *) - +Definition aaddr_arg (a: VA.t) (ba: builtin_arg reg) : aptr := + match a with + | VA.Bot => Pbot + | VA.State ae am => + match ba with + | BA r => aptr_of_aval (AE.get r ae) + | BA_addrstack ofs => Stk ofs + | BA_addrglobal id ofs => Gl id ofs + | _ => Ptop + end + end. +Lemma aaddr_arg_sound_1: + forall bc rs ae m rm am ge sp a b ofs, + ematch bc rs ae -> + romatch bc m rm -> + mmatch bc m am -> + genv_match bc ge -> + bc sp = BCstack -> + eval_builtin_arg ge (fun r : positive => rs # r) (Vptr sp Int.zero) m a (Vptr b ofs) -> + pmatch bc b ofs (aaddr_arg (VA.State ae am) a). +Proof. + intros. + apply pmatch_ge with (aptr_of_aval (abuiltin_arg ae am rm a)). + simpl. destruct a; try (apply pge_top); simpl; apply pge_refl. + apply match_aptr_of_aval. eapply abuiltin_arg_sound; eauto. +Qed. +Lemma aaddr_arg_sound: + forall prog s f sp pc e m a b ofs, + sound_state prog (State s f (Vptr sp Int.zero) pc e m) -> + eval_builtin_arg (Genv.globalenv prog) (fun r => e#r) (Vptr sp Int.zero) m a (Vptr b ofs) -> + exists bc, + pmatch bc b ofs (aaddr_arg (analyze (romem_for_program prog) f)!!pc a) + /\ genv_match bc (Genv.globalenv prog) + /\ bc sp = BCstack. +Proof. + intros. inv H. rewrite AN. exists bc; split; auto. + eapply aaddr_arg_sound_1; eauto. +Qed. diff --git a/backend/XTL.ml b/backend/XTL.ml index 0e5ce0c4..dde9bdb0 100644 --- a/backend/XTL.ml +++ b/backend/XTL.ml @@ -34,8 +34,7 @@ type instruction = | Xstore of memory_chunk * addressing * var list * var | Xcall of signature * (var, ident) sum * var list * var list | Xtailcall of signature * (var, ident) sum * var list - | Xbuiltin of external_function * var list * var list - | Xannot of external_function * var annot_arg list + | Xbuiltin of external_function * var builtin_arg list * var builtin_res | Xbranch of node | Xcond of condition * var list * node * node | Xjumptable of var * node list @@ -125,10 +124,22 @@ let rec set_vars_type vl tyl = let unify_var_type v1 v2 = if typeof v1 <> typeof v2 then raise Type_error -let rec type_annot_arg a ty = +let rec type_builtin_arg a ty = match a with - | AA_base v -> set_var_type v ty - | AA_longofwords(a1, a2) -> type_annot_arg a1 Tint; type_annot_arg a2 Tint + | BA v -> set_var_type v ty + | BA_splitlong(a1, a2) -> type_builtin_arg a1 Tint; type_builtin_arg a2 Tint + | _ -> () + +let rec type_builtin_args al tyl = + match al, tyl with + | [], [] -> () + | a :: al, ty :: tyl -> type_builtin_arg a ty; type_builtin_args al tyl + | _, _ -> raise Type_error + +let rec type_builtin_res a ty = + match a with + | BR v -> set_var_type v ty + | BR_splitlong(a1, a2) -> type_builtin_res a1 Tint; type_builtin_res a2 Tint | _ -> () let type_instr = function @@ -158,13 +169,8 @@ let type_instr = function () | Xbuiltin(ef, args, res) -> let sg = ef_sig ef in - set_vars_type args sg.sig_args; - set_vars_type res (Events.proj_sig_res' sg) - | Xannot(ef, args) -> - let sg = ef_sig ef in - if List.length args = List.length sg.sig_args - then List.iter2 type_annot_arg args sg.sig_args - else raise Type_error + type_builtin_args args sg.sig_args; + type_builtin_res res (proj_sig_res sg) | Xbranch s -> () | Xcond(cond, args, s1, s2) -> diff --git a/backend/XTL.mli b/backend/XTL.mli index 9794565c..6bdcc8c6 100644 --- a/backend/XTL.mli +++ b/backend/XTL.mli @@ -35,8 +35,7 @@ type instruction = | Xstore of memory_chunk * addressing * var list * var | Xcall of signature * (var, ident) sum * var list * var list | Xtailcall of signature * (var, ident) sum * var list - | Xbuiltin of external_function * var list * var list - | Xannot of external_function * var annot_arg list + | Xbuiltin of external_function * var builtin_arg list * var builtin_res | Xbranch of node | Xcond of condition * var list * node * node | Xjumptable of var * node list diff --git a/cfrontend/C2C.ml b/cfrontend/C2C.ml index f1c8ec8e..1a6abb6e 100644 --- a/cfrontend/C2C.ml +++ b/cfrontend/C2C.ml @@ -926,7 +926,7 @@ let add_lineno prev_loc this_loc s = if !Clflags.option_g && prev_loc <> this_loc && this_loc <> Cutil.no_loc then begin let txt = sprintf "#line:%s:%d" (fst this_loc) (snd this_loc) in - Ssequence(Sdo(Ebuiltin(EF_annot(intern_string txt, []), + Ssequence(Sdo(Ebuiltin(EF_debug(P.one, intern_string txt, []), Tnil, Enil, Tvoid)), s) end else diff --git a/cfrontend/Cexec.v b/cfrontend/Cexec.v index aba3c094..16d5823b 100644 --- a/cfrontend/Cexec.v +++ b/cfrontend/Cexec.v @@ -527,6 +527,10 @@ Definition do_ef_annot_val (text: ident) (targ: typ) | _ => None end. +Definition do_ef_debug (kind: positive) (text: ident) (targs: list typ) + (w: world) (vargs: list val) (m: mem) : option (world * trace * val * mem) := + Some(w, E0, Vundef, m). + Definition do_external (ef: external_function): world -> list val -> mem -> option (world * trace * val * mem) := match ef with @@ -534,14 +538,13 @@ Definition do_external (ef: external_function): | EF_builtin name sg => do_external_function name sg ge | EF_vload chunk => do_ef_volatile_load chunk | EF_vstore chunk => do_ef_volatile_store chunk - | EF_vload_global chunk id ofs => do_ef_volatile_load_global chunk id ofs - | EF_vstore_global chunk id ofs => do_ef_volatile_store_global chunk id ofs | EF_malloc => do_ef_malloc | EF_free => do_ef_free | EF_memcpy sz al => do_ef_memcpy sz al | EF_annot text targs => do_ef_annot text targs | EF_annot_val text targ => do_ef_annot_val text targ | EF_inline_asm text sg clob => do_inline_assembly text sg ge + | EF_debug kind text targs => do_ef_debug kind text targs end. Lemma do_ef_external_sound: @@ -550,40 +553,21 @@ Lemma do_ef_external_sound: external_call ef ge vargs m t vres m' /\ possible_trace w t w'. Proof with try congruence. intros until m'. - - assert (VLOAD: forall chunk vargs, - do_ef_volatile_load chunk w vargs m = Some (w', t, vres, m') -> - volatile_load_sem chunk ge vargs m t vres m' /\ possible_trace w t w'). - intros chunk vargs'. - unfold do_ef_volatile_load. destruct vargs'... destruct v... destruct vargs'... - mydestr. destruct p as [[w'' t''] v]; mydestr. - exploit do_volatile_load_sound; eauto. intuition. econstructor; eauto. - - assert (VSTORE: forall chunk vargs, - do_ef_volatile_store chunk w vargs m = Some (w', t, vres, m') -> - volatile_store_sem chunk ge vargs m t vres m' /\ possible_trace w t w'). - intros chunk vargs'. - unfold do_ef_volatile_store. destruct vargs'... destruct v... destruct vargs'... destruct vargs'... - mydestr. destruct p as [[w'' t''] m'']. mydestr. - exploit do_volatile_store_sound; eauto. intuition. econstructor; eauto. - destruct ef; simpl. (* EF_external *) eapply do_external_function_sound; eauto. (* EF_builtin *) eapply do_external_function_sound; eauto. (* EF_vload *) + unfold do_ef_volatile_load. destruct vargs... destruct v... destruct vargs... + mydestr. destruct p as [[w'' t''] v]; mydestr. + exploit do_volatile_load_sound; eauto. intuition. econstructor; eauto. auto. (* EF_vstore *) + unfold do_ef_volatile_store. destruct vargs... destruct v... destruct vargs... destruct vargs... + mydestr. destruct p as [[w'' t''] m'']. mydestr. + exploit do_volatile_store_sound; eauto. intuition. econstructor; eauto. auto. -(* EF_vload_global *) - rewrite volatile_load_global_charact; simpl. - unfold do_ef_volatile_load_global. destruct (Genv.find_symbol ge)... - intros. exploit VLOAD; eauto. intros [A B]. split; auto. exists b; auto. -(* EF_vstore_global *) - rewrite volatile_store_global_charact; simpl. - unfold do_ef_volatile_store_global. destruct (Genv.find_symbol ge)... - intros. exploit VSTORE; eauto. intros [A B]. split; auto. exists b; auto. (* EF_malloc *) unfold do_ef_malloc. destruct vargs... destruct v... destruct vargs... destruct (Mem.alloc m (-4) (Int.unsigned i)) as [m1 b] eqn:?. mydestr. @@ -606,6 +590,8 @@ Proof with try congruence. econstructor. constructor; eauto. constructor. (* EF_inline_asm *) eapply do_inline_assembly_sound; eauto. +(* EF_debug *) + unfold do_ef_debug. mydestr. split; constructor. Qed. Lemma do_ef_external_complete: @@ -613,35 +599,17 @@ Lemma do_ef_external_complete: external_call ef ge vargs m t vres m' -> possible_trace w t w' -> do_external ef w vargs m = Some(w', t, vres, m'). Proof. - intros. - - assert (VLOAD: forall chunk vargs, - volatile_load_sem chunk ge vargs m t vres m' -> - do_ef_volatile_load chunk w vargs m = Some (w', t, vres, m')). - intros. inv H1; unfold do_ef_volatile_load. - exploit do_volatile_load_complete; eauto. intros EQ; rewrite EQ; auto. - - assert (VSTORE: forall chunk vargs, - volatile_store_sem chunk ge vargs m t vres m' -> - do_ef_volatile_store chunk w vargs m = Some (w', t, vres, m')). - intros. inv H1; unfold do_ef_volatile_store. - exploit do_volatile_store_complete; eauto. intros EQ; rewrite EQ; auto. - - destruct ef; simpl in *. + intros. destruct ef; simpl in *. (* EF_external *) eapply do_external_function_complete; eauto. (* EF_builtin *) eapply do_external_function_complete; eauto. (* EF_vload *) - auto. -(* EF_vstore *) - auto. -(* EF_vload_global *) - rewrite volatile_load_global_charact in H; simpl in H. destruct H as [b [P Q]]. - unfold do_ef_volatile_load_global. rewrite P. auto. + inv H; unfold do_ef_volatile_load. + exploit do_volatile_load_complete; eauto. intros EQ; rewrite EQ; auto. (* EF_vstore *) - rewrite volatile_store_global_charact in H; simpl in H. destruct H as [b [P Q]]. - unfold do_ef_volatile_store_global. rewrite P. auto. + inv H; unfold do_ef_volatile_store. + exploit do_volatile_store_complete; eauto. intros EQ; rewrite EQ; auto. (* EF_malloc *) inv H; unfold do_ef_malloc. inv H0. rewrite H1. rewrite H2. auto. @@ -660,6 +628,8 @@ Proof. rewrite (eventval_of_val_complete _ _ _ H1). auto. (* EF_inline_asm *) eapply do_inline_assembly_complete; eauto. +(* EF_debug *) + inv H. inv H0. reflexivity. Qed. (** * Reduction of expressions *) diff --git a/cfrontend/SimplLocals.v b/cfrontend/SimplLocals.v index 52ee8377..7fc69324 100644 --- a/cfrontend/SimplLocals.v +++ b/cfrontend/SimplLocals.v @@ -22,6 +22,7 @@ Require Import AST. Require Import Ctypes. Require Import Cop. Require Import Clight. +Require Compopts. Open Scope error_monad_scope. Open Scope string_scope. @@ -54,6 +55,23 @@ Definition make_cast (a: expr) (tto: type) : expr := | _ => Ecast a tto end. +(** Insertion of debug annotations *) + +Definition Sdebug_temp (id: ident) (ty: type) := + Sbuiltin None (EF_debug 2%positive id (typ_of_type ty :: nil)) + (Tcons (typeconv ty) Tnil) + (Etempvar id ty :: nil). + +Definition Sdebug_var (id: ident) (ty: type) := + Sbuiltin None (EF_debug 5%positive id (AST.Tint :: nil)) + (Tcons (Tpointer ty noattr) Tnil) + (Eaddrof (Evar id ty) (Tpointer ty noattr) :: nil). + +Definition Sset_debug (id: ident) (ty: type) (a: expr) := + if Compopts.debug tt + then Ssequence (Sset id (make_cast a ty)) (Sdebug_temp id ty) + else Sset id (make_cast a ty). + (** Rewriting of expressions and statements. *) Fixpoint simpl_expr (cenv: compilenv) (a: expr) : expr := @@ -94,7 +112,7 @@ Fixpoint simpl_stmt (cenv: compilenv) (s: statement) : res statement := | Sassign a1 a2 => match is_liftable_var cenv a1 with | Some id => - OK (Sset id (make_cast (simpl_expr cenv a2) (typeof a1))) + OK (Sset_debug id (typeof a1) (simpl_expr cenv a2)) | None => OK (Sassign (simpl_expr cenv a1) (simpl_expr cenv a2)) end @@ -225,6 +243,22 @@ Definition cenv_for (f: function) : compilenv := (** Transform a function *) +Definition add_debug_var (id_ty: ident * type) (s: statement) := + let (id, ty) := id_ty in Ssequence (Sdebug_var id ty) s. + +Definition add_debug_vars (vars: list (ident * type)) (s: statement) := + if Compopts.debug tt + then List.fold_right add_debug_var s vars + else s. + +Definition add_debug_param (id_ty: ident * type) (s: statement) := + let (id, ty) := id_ty in Ssequence (Sdebug_temp id ty) s. + +Definition add_debug_params (params: list (ident * type)) (s: statement) := + if Compopts.debug tt + then List.fold_right add_debug_param s params + else s. + Definition remove_lifted (cenv: compilenv) (vars: list (ident * type)) := List.filter (fun id_ty => negb (VSet.mem (fst id_ty) cenv)) vars. @@ -235,12 +269,16 @@ Definition transf_function (f: function) : res function := let cenv := cenv_for f in assertion (list_disjoint_dec ident_eq (var_names f.(fn_params)) (var_names f.(fn_temps))); do body' <- simpl_stmt cenv f.(fn_body); + let vars' := remove_lifted cenv (f.(fn_params) ++ f.(fn_vars)) in + let temps' := add_lifted cenv f.(fn_vars) f.(fn_temps) in OK {| fn_return := f.(fn_return); fn_callconv := f.(fn_callconv); fn_params := f.(fn_params); - fn_vars := remove_lifted cenv (f.(fn_params) ++ f.(fn_vars)); - fn_temps := add_lifted cenv f.(fn_vars) f.(fn_temps); - fn_body := store_params cenv f.(fn_params) body' |}. + fn_vars := vars'; + fn_temps := temps'; + fn_body := add_debug_params f.(fn_params) + (store_params cenv f.(fn_params) + (add_debug_vars vars' body')) |}. (** Whole-program transformation *) diff --git a/cfrontend/SimplLocalsproof.v b/cfrontend/SimplLocalsproof.v index 2a50f985..73092ab9 100644 --- a/cfrontend/SimplLocalsproof.v +++ b/cfrontend/SimplLocalsproof.v @@ -334,6 +334,13 @@ Proof. inv H0; constructor. Qed. +Lemma forall2_val_casted_inject: + forall f vl vl', Val.inject_list f vl vl' -> + forall tyl, list_forall2 val_casted vl tyl -> list_forall2 val_casted vl' tyl. +Proof. + induction 1; intros tyl F; inv F; constructor; eauto. eapply val_casted_inject; eauto. +Qed. + Inductive val_casted_list: list val -> typelist -> Prop := | vcl_nil: val_casted_list nil Tnil @@ -376,6 +383,116 @@ Proof. inv H0; auto. Qed. +(** Debug annotations. *) + +Lemma cast_typeconv: + forall v ty, + val_casted v ty -> + sem_cast v ty (typeconv ty) = Some v. +Proof. + induction 1; simpl; auto. +- destruct sz; auto. +- unfold sem_cast. simpl. rewrite dec_eq_true; auto. +- unfold sem_cast. simpl. rewrite dec_eq_true; auto. +Qed. + +Lemma step_Sdebug_temp: + forall f id ty k e le m v, + le!id = Some v -> + val_casted v ty -> + step2 tge (State f (Sdebug_temp id ty) k e le m) + E0 (State f Sskip k e le m). +Proof. + intros. unfold Sdebug_temp. eapply step_builtin with (optid := None). + econstructor. constructor. eauto. simpl. eapply cast_typeconv; eauto. constructor. + simpl. constructor. +Qed. + +Lemma step_Sdebug_var: + forall f id ty k e le m b, + e!id = Some(b, ty) -> + step2 tge (State f (Sdebug_var id ty) k e le m) + E0 (State f Sskip k e le m). +Proof. + intros. unfold Sdebug_var. eapply step_builtin with (optid := None). + econstructor. constructor. constructor. eauto. + simpl. reflexivity. constructor. + simpl. constructor. +Qed. + +Lemma step_Sset_debug: + forall f id ty a k e le m v v', + eval_expr tge e le m a v -> + sem_cast v (typeof a) ty = Some v' -> + plus step2 tge (State f (Sset_debug id ty a) k e le m) + E0 (State f Sskip k e (PTree.set id v' le) m). +Proof. + intros; unfold Sset_debug. + assert (forall k, step2 tge (State f (Sset id (make_cast a ty)) k e le m) + E0 (State f Sskip k e (PTree.set id v' le) m)). + { intros. apply step_set. eapply make_cast_correct; eauto. } + destruct (Compopts.debug tt). +- eapply plus_left. constructor. + eapply star_left. apply H1. + eapply star_left. constructor. + apply star_one. apply step_Sdebug_temp with (v := v'). + apply PTree.gss. eapply cast_val_is_casted; eauto. + reflexivity. reflexivity. reflexivity. +- apply plus_one. apply H1. +Qed. + +Lemma step_add_debug_vars: + forall f s e le m vars k, + (forall id ty, In (id, ty) vars -> exists b, e!id = Some (b, ty)) -> + star step2 tge (State f (add_debug_vars vars s) k e le m) + E0 (State f s k e le m). +Proof. + unfold add_debug_vars. destruct (Compopts.debug tt). +- induction vars; simpl; intros. + + apply star_refl. + + destruct a as [id ty]. + exploit H; eauto. intros (b & TE). + simpl. eapply star_left. constructor. + eapply star_left. eapply step_Sdebug_var; eauto. + eapply star_left. constructor. + apply IHvars; eauto. + reflexivity. reflexivity. reflexivity. +- intros. apply star_refl. +Qed. + +Remark bind_parameter_temps_inv: + forall id params args le le', + bind_parameter_temps params args le = Some le' -> + ~In id (var_names params) -> + le'!id = le!id. +Proof. + induction params; simpl; intros. + destruct args; inv H. auto. + destruct a as [id1 ty1]. destruct args; try discriminate. + transitivity ((PTree.set id1 v le)!id). + eapply IHparams; eauto. apply PTree.gso. intuition. +Qed. + +Lemma step_add_debug_params: + forall f s k e le m params vl le1, + list_norepet (var_names params) -> + list_forall2 val_casted vl (map snd params) -> + bind_parameter_temps params vl le1 = Some le -> + star step2 tge (State f (add_debug_params params s) k e le m) + E0 (State f s k e le m). +Proof. + unfold add_debug_params. destruct (Compopts.debug tt). +- induction params as [ | [id ty] params ]; simpl; intros until le1; intros NR CAST BIND; inv CAST; inv NR. + + apply star_refl. + + assert (le!id = Some a1). { erewrite bind_parameter_temps_inv by eauto. apply PTree.gss. } + eapply star_left. constructor. + eapply star_left. eapply step_Sdebug_temp; eauto. + eapply star_left. constructor. + eapply IHparams; eauto. + reflexivity. reflexivity. reflexivity. +- intros; apply star_refl. +Qed. + (** Preservation by assignment to lifted variable. *) Lemma match_envs_assign_lifted: @@ -909,7 +1026,8 @@ Theorem match_envs_alloc_variables: /\ Mem.inject j' m' tm' /\ inject_incr j j' /\ (forall b, Mem.valid_block m b -> j' b = j b) - /\ (forall b b' delta, j' b = Some(b', delta) -> Mem.valid_block tm b' -> j' b = j b). + /\ (forall b b' delta, j' b = Some(b', delta) -> Mem.valid_block tm b' -> j' b = j b) + /\ (forall id ty, In (id, ty) vars -> VSet.mem id cenv = false -> exists b, te!id = Some(b, ty)). Proof. intros. exploit (match_alloc_variables cenv); eauto. instantiate (1 := empty_env). @@ -988,6 +1106,10 @@ Proof. (* incr *) eapply alloc_variables_nextblock; eauto. eapply alloc_variables_nextblock; eauto. + + (* other properties *) + intuition auto. edestruct F as (b & X & Y); eauto. rewrite H5 in Y. + destruct Y as (tb & U & V). exists tb; auto. Qed. Lemma assign_loc_inject: @@ -1067,19 +1189,6 @@ Proof. left. congruence. Qed. -Remark bind_parameter_temps_inv: - forall id params args le le', - bind_parameter_temps params args le = Some le' -> - ~In id (var_names params) -> - le'!id = le!id. -Proof. - induction params; simpl; intros. - destruct args; inv H. auto. - destruct a as [id1 ty1]. destruct args; try discriminate. - transitivity ((PTree.set id1 v le)!id). - eapply IHparams; eauto. apply PTree.gso. intuition. -Qed. - Lemma assign_loc_nextblock: forall ge ty m b ofs v m', assign_loc ge ty m b ofs v m' -> Mem.nextblock m' = Mem.nextblock m. @@ -1917,6 +2026,7 @@ Proof. monadInv TS; auto. (* var *) destruct (is_liftable_var cenv e); monadInv TS; auto. + unfold Sset_debug. destruct (Compopts.debug tt); auto. (* set *) monadInv TS; auto. (* call *) @@ -1975,12 +2085,26 @@ Proof. Qed. Lemma find_label_store_params: - forall lbl s k params, find_label lbl (store_params cenv params s) k = find_label lbl s k. + forall s k params, find_label lbl (store_params cenv params s) k = find_label lbl s k. Proof. induction params; simpl. auto. destruct a as [id ty]. destruct (VSet.mem id cenv); auto. Qed. +Lemma find_label_add_debug_vars: + forall s k vars, find_label lbl (add_debug_vars vars s) k = find_label lbl s k. +Proof. + unfold add_debug_vars. destruct (Compopts.debug tt); auto. + induction vars; simpl; auto. destruct a as [id ty]; simpl. auto. +Qed. + +Lemma find_label_add_debug_params: + forall s k vars, find_label lbl (add_debug_params vars s) k = find_label lbl s k. +Proof. + unfold add_debug_params. destruct (Compopts.debug tt); auto. + induction vars; simpl; auto. destruct a as [id ty]; simpl. auto. +Qed. + End FIND_LABEL. @@ -1999,8 +2123,8 @@ Proof. exploit me_vars; eauto. instantiate (1 := id). intros MV. inv H. (* local variable *) - econstructor; split. - apply plus_one. econstructor. eapply make_cast_correct. eexact A. rewrite typeof_simpl_expr. eexact C. + econstructor; split. + eapply step_Sset_debug. eauto. rewrite typeof_simpl_expr. eauto. econstructor; eauto with compat. eapply match_envs_assign_lifted; eauto. eapply cast_val_is_casted; eauto. eapply match_cont_assign_loc; eauto. exploit me_range; eauto. xomega. @@ -2154,7 +2278,8 @@ Proof. apply compat_cenv_for. rewrite H. intros [ts' [tk' [A [B [C D]]]]]. econstructor; split. - apply plus_one. econstructor; eauto. simpl. rewrite find_label_store_params. eexact A. + apply plus_one. econstructor; eauto. simpl. + rewrite find_label_add_debug_params. rewrite find_label_store_params. rewrite find_label_add_debug_vars. eexact A. econstructor; eauto. (* internal function *) @@ -2166,11 +2291,13 @@ Proof. instantiate (1 := cenv_for_gen (addr_taken_stmt f.(fn_body)) (fn_params f ++ fn_vars f)). intros. eapply cenv_for_gen_by_value; eauto. rewrite VSF.mem_iff. eexact H4. intros. eapply cenv_for_gen_domain. rewrite VSF.mem_iff. eexact H3. - intros [j' [te [tm0 [A [B [C [D [E F]]]]]]]]. + intros [j' [te [tm0 [A [B [C [D [E [F G]]]]]]]]]. + assert (K: list_forall2 val_casted vargs (map snd (fn_params f))). + { apply val_casted_list_params. unfold type_of_function in FUNTY. congruence. } exploit store_params_correct. eauto. eapply list_norepet_append_left; eauto. - apply val_casted_list_params. unfold type_of_function in FUNTY. congruence. + eexact K. apply val_inject_list_incr with j'; eauto. eexact B. eexact C. intros. apply (create_undef_temps_lifted id f). auto. @@ -2184,8 +2311,11 @@ Proof. econstructor; split. eapply plus_left. econstructor. econstructor. exact Y. exact X. exact Z. simpl. eexact A. simpl. eexact Q. - simpl. eexact P. - traceEq. + simpl. eapply star_trans. eapply step_add_debug_params. auto. eapply forall2_val_casted_inject; eauto. eexact Q. + eapply star_trans. eexact P. eapply step_add_debug_vars. + unfold remove_lifted; intros. rewrite List.filter_In in H3. destruct H3. + apply negb_true_iff in H4. eauto. + reflexivity. reflexivity. traceEq. econstructor; eauto. eapply match_cont_invariant; eauto. intros. transitivity (Mem.load chunk m0 b 0). diff --git a/common/AST.v b/common/AST.v index 387eb6b2..4d929f13 100644 --- a/common/AST.v +++ b/common/AST.v @@ -560,12 +560,6 @@ Inductive external_function : Type := (** A volatile store operation. If the adress given as first argument points within a volatile global variable, generate an event. Otherwise, produce no event and behave like a regular memory store. *) - | EF_vload_global (chunk: memory_chunk) (id: ident) (ofs: int) - (** A volatile load operation from a global variable. - Specialized version of [EF_vload]. *) - | EF_vstore_global (chunk: memory_chunk) (id: ident) (ofs: int) - (** A volatile store operation in a global variable. - Specialized version of [EF_vstore]. *) | EF_malloc (** Dynamic memory allocation. Takes the requested size in bytes as argument; returns a pointer to a fresh block of the given size. @@ -585,12 +579,16 @@ Inductive external_function : Type := (** Another form of annotation that takes one argument, produces an event carrying the text and the value of this argument, and returns the value of the argument. *) - | EF_inline_asm (text: ident) (sg: signature) (clobbers: list String.string). + | EF_inline_asm (text: ident) (sg: signature) (clobbers: list String.string) (** Inline [asm] statements. Semantically, treated like an annotation with no parameters ([EF_annot text nil]). To be used with caution, as it can invalidate the semantic preservation theorem. Generated only if [-finline-asm] is given. *) + | EF_debug (kind: positive) (text: ident) (targs: list typ). + (** Transport debugging information from the front-end to the generated + assembly. Takes zero, one or several arguments like [EF_annot]. + Unlike [EF_annot], produces no observable event. *) (** The type signature of an external function. *) @@ -600,14 +598,13 @@ Definition ef_sig (ef: external_function): signature := | EF_builtin name sg => sg | EF_vload chunk => mksignature (Tint :: nil) (Some (type_of_chunk chunk)) cc_default | EF_vstore chunk => mksignature (Tint :: type_of_chunk chunk :: nil) None cc_default - | EF_vload_global chunk _ _ => mksignature nil (Some (type_of_chunk chunk)) cc_default - | EF_vstore_global chunk _ _ => mksignature (type_of_chunk chunk :: nil) None cc_default | EF_malloc => mksignature (Tint :: nil) (Some Tint) cc_default | EF_free => mksignature (Tint :: nil) None cc_default | EF_memcpy sz al => mksignature (Tint :: Tint :: nil) None cc_default | EF_annot text targs => mksignature targs None cc_default | EF_annot_val text targ => mksignature (targ :: nil) (Some targ) cc_default | EF_inline_asm text sg clob => sg + | EF_debug kind text targs => mksignature targs None cc_default end. (** Whether an external function should be inlined by the compiler. *) @@ -618,14 +615,13 @@ Definition ef_inline (ef: external_function) : bool := | EF_builtin name sg => true | EF_vload chunk => true | EF_vstore chunk => true - | EF_vload_global chunk id ofs => true - | EF_vstore_global chunk id ofs => true | EF_malloc => false | EF_free => false | EF_memcpy sz al => true | EF_annot text targs => true | EF_annot_val text targ => true | EF_inline_asm text sg clob => true + | EF_debug kind text targs => true end. (** Whether an external function must reload its arguments. *) @@ -633,6 +629,7 @@ Definition ef_inline (ef: external_function) : bool := Definition ef_reloads (ef: external_function) : bool := match ef with | EF_annot text targs => false + | EF_debug kind text targs => false | _ => true end. @@ -640,22 +637,12 @@ Definition ef_reloads (ef: external_function) : bool := Definition external_function_eq: forall (ef1 ef2: external_function), {ef1=ef2} + {ef1<>ef2}. Proof. - generalize ident_eq signature_eq chunk_eq typ_eq zeq Int.eq_dec; intros. + generalize ident_eq signature_eq chunk_eq typ_eq list_eq_dec zeq Int.eq_dec; intros. decide equality. - apply list_eq_dec. auto. apply list_eq_dec. apply String.string_dec. Defined. Global Opaque external_function_eq. -(** Global variables referenced by an external function *) - -Definition globals_external (ef: external_function) : list ident := - match ef with - | EF_vload_global _ id _ => id :: nil - | EF_vstore_global _ id _ => id :: nil - | _ => nil - end. - (** Function definitions are the union of internal and external functions. *) Inductive fundef (F: Type): Type := @@ -690,55 +677,95 @@ Definition transf_partial_fundef (fd: fundef A): res (fundef B) := End TRANSF_PARTIAL_FUNDEF. -(** * Arguments to annotations *) +(** * Arguments and results to builtin functions *) Set Contextual Implicit. -Inductive annot_arg (A: Type) : Type := - | AA_base (x: A) - | AA_int (n: int) - | AA_long (n: int64) - | AA_float (f: float) - | AA_single (f: float32) - | AA_loadstack (chunk: memory_chunk) (ofs: int) - | AA_addrstack (ofs: int) - | AA_loadglobal (chunk: memory_chunk) (id: ident) (ofs: int) - | AA_addrglobal (id: ident) (ofs: int) - | AA_longofwords (hi lo: annot_arg A). - -Fixpoint globals_of_annot_arg (A: Type) (a: annot_arg A) : list ident := +Inductive builtin_arg (A: Type) : Type := + | BA (x: A) + | BA_int (n: int) + | BA_long (n: int64) + | BA_float (f: float) + | BA_single (f: float32) + | BA_loadstack (chunk: memory_chunk) (ofs: int) + | BA_addrstack (ofs: int) + | BA_loadglobal (chunk: memory_chunk) (id: ident) (ofs: int) + | BA_addrglobal (id: ident) (ofs: int) + | BA_splitlong (hi lo: builtin_arg A). + +Inductive builtin_res (A: Type) : Type := + | BR (x: A) + | BR_none + | BR_splitlong (hi lo: builtin_res A). + +Fixpoint globals_of_builtin_arg (A: Type) (a: builtin_arg A) : list ident := match a with - | AA_loadglobal chunk id ofs => id :: nil - | AA_addrglobal id ofs => id :: nil - | AA_longofwords hi lo => globals_of_annot_arg hi ++ globals_of_annot_arg lo + | BA_loadglobal chunk id ofs => id :: nil + | BA_addrglobal id ofs => id :: nil + | BA_splitlong hi lo => globals_of_builtin_arg hi ++ globals_of_builtin_arg lo | _ => nil end. -Definition globals_of_annot_args (A: Type) (al: list (annot_arg A)) : list ident := - List.fold_right (fun a l => globals_of_annot_arg a ++ l) nil al. +Definition globals_of_builtin_args (A: Type) (al: list (builtin_arg A)) : list ident := + List.fold_right (fun a l => globals_of_builtin_arg a ++ l) nil al. -Fixpoint params_of_annot_arg (A: Type) (a: annot_arg A) : list A := +Fixpoint params_of_builtin_arg (A: Type) (a: builtin_arg A) : list A := match a with - | AA_base x => x :: nil - | AA_longofwords hi lo => params_of_annot_arg hi ++ params_of_annot_arg lo + | BA x => x :: nil + | BA_splitlong hi lo => params_of_builtin_arg hi ++ params_of_builtin_arg lo | _ => nil end. -Definition params_of_annot_args (A: Type) (al: list (annot_arg A)) : list A := - List.fold_right (fun a l => params_of_annot_arg a ++ l) nil al. +Definition params_of_builtin_args (A: Type) (al: list (builtin_arg A)) : list A := + List.fold_right (fun a l => params_of_builtin_arg a ++ l) nil al. -Fixpoint map_annot_arg (A B: Type) (f: A -> B) (a: annot_arg A) : annot_arg B := +Fixpoint params_of_builtin_res (A: Type) (a: builtin_res A) : list A := match a with - | AA_base x => AA_base (f x) - | AA_int n => AA_int n - | AA_long n => AA_long n - | AA_float n => AA_float n - | AA_single n => AA_single n - | AA_loadstack chunk ofs => AA_loadstack chunk ofs - | AA_addrstack ofs => AA_addrstack ofs - | AA_loadglobal chunk id ofs => AA_loadglobal chunk id ofs - | AA_addrglobal id ofs => AA_addrglobal id ofs - | AA_longofwords hi lo => - AA_longofwords (map_annot_arg f hi) (map_annot_arg f lo) + | BR x => x :: nil + | BR_none => nil + | BR_splitlong hi lo => params_of_builtin_res hi ++ params_of_builtin_res lo end. +Fixpoint map_builtin_arg (A B: Type) (f: A -> B) (a: builtin_arg A) : builtin_arg B := + match a with + | BA x => BA (f x) + | BA_int n => BA_int n + | BA_long n => BA_long n + | BA_float n => BA_float n + | BA_single n => BA_single n + | BA_loadstack chunk ofs => BA_loadstack chunk ofs + | BA_addrstack ofs => BA_addrstack ofs + | BA_loadglobal chunk id ofs => BA_loadglobal chunk id ofs + | BA_addrglobal id ofs => BA_addrglobal id ofs + | BA_splitlong hi lo => + BA_splitlong (map_builtin_arg f hi) (map_builtin_arg f lo) + end. + +Fixpoint map_builtin_res (A B: Type) (f: A -> B) (a: builtin_res A) : builtin_res B := + match a with + | BR x => BR (f x) + | BR_none => BR_none + | BR_splitlong hi lo => + BR_splitlong (map_builtin_res f hi) (map_builtin_res f lo) + end. + +(** Which kinds of builtin arguments are supported by which external function. *) + +Inductive builtin_arg_constraint : Type := + | OK_default + | OK_const + | OK_addrstack + | OK_addrglobal + | OK_addrany + | OK_all. + +Definition builtin_arg_ok + (A: Type) (ba: builtin_arg A) (c: builtin_arg_constraint) := + match ba, c with + | (BA _ | BA_splitlong _ _), _ => true + | (BA_int _ | BA_long _ | BA_float _ | BA_single _), OK_const => true + | BA_addrstack _, (OK_addrstack | OK_addrany) => true + | BA_addrglobal _ _, (OK_addrglobal | OK_addrany) => true + | _, OK_all => true + | _, _ => false + end. diff --git a/common/Events.v b/common/Events.v index 78162fff..7cd9155e 100644 --- a/common/Events.v +++ b/common/Events.v @@ -606,8 +606,7 @@ Definition inject_separated (f f': meminj) (m1 m2: mem): Prop := f b1 = None -> f' b1 = Some(b2, delta) -> ~Mem.valid_block m1 b1 /\ ~Mem.valid_block m2 b2. -Record extcall_properties (sem: extcall_sem) - (sg: signature) (free_globals: list ident) : Prop := +Record extcall_properties (sem: extcall_sem) (sg: signature) : Prop := mk_extcall_properties { (** The return value of an external call must agree with its signature. *) @@ -664,9 +663,6 @@ Record extcall_properties (sem: extcall_sem) ec_mem_inject: forall ge1 ge2 vargs m1 t vres m2 f m1' vargs', symbols_inject f ge1 ge2 -> - (forall id b1, - In id free_globals -> Senv.find_symbol ge1 id = Some b1 -> - exists b2, f b1 = Some(b2, 0) /\ Senv.find_symbol ge2 id = Some b2) -> sem ge1 vargs m1 t vres m2 -> Mem.inject f m1 m1' -> Val.inject_list f vargs vargs' -> @@ -769,37 +765,36 @@ Qed. Lemma volatile_load_ok: forall chunk, extcall_properties (volatile_load_sem chunk) - (mksignature (Tint :: nil) (Some (type_of_chunk chunk)) cc_default) - nil. + (mksignature (Tint :: nil) (Some (type_of_chunk chunk)) cc_default). Proof. intros; constructor; intros. (* well typed *) - unfold proj_sig_res; simpl. inv H. inv H0. apply Val.load_result_type. +- unfold proj_sig_res; simpl. inv H. inv H0. apply Val.load_result_type. eapply Mem.load_type; eauto. (* symbols *) - inv H2. constructor. eapply volatile_load_preserved; eauto. +- inv H2. constructor. eapply volatile_load_preserved; eauto. (* valid blocks *) - inv H; auto. +- inv H; auto. (* max perms *) - inv H; auto. +- inv H; auto. (* readonly *) - inv H. apply Mem.unchanged_on_refl. +- inv H. apply Mem.unchanged_on_refl. (* mem extends *) - inv H. inv H1. inv H6. inv H4. +- inv H. inv H1. inv H6. inv H4. exploit volatile_load_extends; eauto. intros [v' [A B]]. exists v'; exists m1'; intuition. constructor; auto. (* mem injects *) - inv H1. inv H3. inv H8. inversion H6; subst. +- inv H0. inv H2. inv H7. inversion H5; subst. exploit volatile_load_inject; eauto. intros [v' [A B]]. exists f; exists v'; exists m1'; intuition. constructor; auto. red; intros. congruence. (* trace length *) - inv H; inv H0; simpl; omega. +- inv H; inv H0; simpl; omega. (* receptive *) - inv H. exploit volatile_load_receptive; eauto. intros [v2 A]. +- inv H. exploit volatile_load_receptive; eauto. intros [v2 A]. exists v2; exists m1; constructor; auto. (* determ *) - inv H; inv H0. inv H1; inv H7; try congruence. +- inv H; inv H0. inv H1; inv H7; try congruence. assert (id = id0) by (eapply Senv.find_symbol_injective; eauto). subst id0. split. constructor. eapply eventval_match_valid; eauto. @@ -811,64 +806,6 @@ Proof. split. constructor. intuition congruence. Qed. -Inductive volatile_load_global_sem (chunk: memory_chunk) (id: ident) (ofs: int) (ge: Senv.t): - list val -> mem -> trace -> val -> mem -> Prop := - | volatile_load_global_sem_intro: forall b t v m, - Senv.find_symbol ge id = Some b -> - volatile_load ge chunk m b ofs t v -> - volatile_load_global_sem chunk id ofs ge nil m t v m. - -Remark volatile_load_global_charact: - forall chunk id ofs ge vargs m t vres m', - volatile_load_global_sem chunk id ofs ge vargs m t vres m' <-> - exists b, Senv.find_symbol ge id = Some b /\ volatile_load_sem chunk ge (Vptr b ofs :: vargs) m t vres m'. -Proof. - intros; split. - intros. inv H. exists b; split; auto. constructor; auto. - intros [b [P Q]]. inv Q. econstructor; eauto. -Qed. - -Lemma volatile_load_global_ok: - forall chunk id ofs, - extcall_properties (volatile_load_global_sem chunk id ofs) - (mksignature nil (Some (type_of_chunk chunk)) cc_default) - (id :: nil). -Proof. - intros; constructor; intros. -(* well typed *) - unfold proj_sig_res; simpl. inv H. inv H1. apply Val.load_result_type. - eapply Mem.load_type; eauto. -(* symbols *) - inv H2. econstructor. rewrite H; eauto. eapply volatile_load_preserved; eauto. -(* valid blocks *) - inv H; auto. -(* max perm *) - inv H; auto. -(* readonly *) - inv H. apply Mem.unchanged_on_refl. -(* extends *) - inv H. inv H1. exploit volatile_load_extends; eauto. intros [v' [A B]]. - exists v'; exists m1'; intuition. econstructor; eauto. -(* inject *) - inv H1. inv H3. - exploit H0; eauto with coqlib. intros (b2 & INJ & FS2). - assert (Val.inject f (Vptr b ofs) (Vptr b2 ofs)). - econstructor; eauto. rewrite Int.add_zero; auto. - exploit volatile_load_inject; eauto. intros [v' [A B]]. - exists f; exists v'; exists m1'; intuition. econstructor; eauto. - red; intros; congruence. -(* trace length *) - inv H; inv H1; simpl; omega. -(* receptive *) - inv H. exploit volatile_load_receptive; eauto. intros [v2 A]. - exists v2; exists m1; econstructor; eauto. -(* determ *) - rewrite volatile_load_global_charact in *. - destruct H as [b1 [A1 B1]]. destruct H0 as [b2 [A2 B2]]. - rewrite A1 in A2; inv A2. - eapply ec_determ. eapply volatile_load_ok. eauto. eauto. -Qed. - (** ** Semantics of volatile stores *) Inductive volatile_store_sem (chunk: memory_chunk) (ge: Senv.t): @@ -981,99 +918,40 @@ Qed. Lemma volatile_store_ok: forall chunk, extcall_properties (volatile_store_sem chunk) - (mksignature (Tint :: type_of_chunk chunk :: nil) None cc_default) - nil. + (mksignature (Tint :: type_of_chunk chunk :: nil) None cc_default). Proof. intros; constructor; intros. (* well typed *) - unfold proj_sig_res; simpl. inv H; constructor. +- unfold proj_sig_res; simpl. inv H; constructor. (* symbols preserved *) - inv H2. constructor. eapply volatile_store_preserved; eauto. +- inv H2. constructor. eapply volatile_store_preserved; eauto. (* valid block *) - inv H. inv H1. auto. eauto with mem. +- inv H. inv H1. auto. eauto with mem. (* perms *) - inv H. inv H2. auto. eauto with mem. +- inv H. inv H2. auto. eauto with mem. (* readonly *) - inv H. eapply volatile_store_readonly; eauto. +- inv H. eapply volatile_store_readonly; eauto. (* mem extends*) - inv H. inv H1. inv H6. inv H7. inv H4. +- inv H. inv H1. inv H6. inv H7. inv H4. exploit volatile_store_extends; eauto. intros [m2' [A [B C]]]. exists Vundef; exists m2'; intuition. constructor; auto. (* mem inject *) - inv H1. inv H3. inv H8. inv H9. inversion H6; subst. +- inv H0. inv H2. inv H7. inv H8. inversion H5; subst. exploit volatile_store_inject; eauto. intros [m2' [A [B [C D]]]]. exists f; exists Vundef; exists m2'; intuition. constructor; auto. red; intros; congruence. (* trace length *) - inv H; inv H0; simpl; omega. +- inv H; inv H0; simpl; omega. (* receptive *) - assert (t1 = t2). inv H. eapply volatile_store_receptive; eauto. +- assert (t1 = t2). inv H. eapply volatile_store_receptive; eauto. subst t2; exists vres1; exists m1; auto. (* determ *) - inv H; inv H0. inv H1; inv H8; try congruence. +- inv H; inv H0. inv H1; inv H8; try congruence. assert (id = id0) by (eapply Senv.find_symbol_injective; eauto). subst id0. assert (ev = ev0) by (eapply eventval_match_determ_2; eauto). subst ev0. split. constructor. auto. split. constructor. intuition congruence. Qed. -Inductive volatile_store_global_sem (chunk: memory_chunk) (id: ident) (ofs: int) (ge: Senv.t): - list val -> mem -> trace -> val -> mem -> Prop := - | volatile_store_global_sem_intro: forall b m1 v t m2, - Senv.find_symbol ge id = Some b -> - volatile_store ge chunk m1 b ofs v t m2 -> - volatile_store_global_sem chunk id ofs ge (v :: nil) m1 t Vundef m2. - -Remark volatile_store_global_charact: - forall chunk id ofs ge vargs m t vres m', - volatile_store_global_sem chunk id ofs ge vargs m t vres m' <-> - exists b, Senv.find_symbol ge id = Some b /\ volatile_store_sem chunk ge (Vptr b ofs :: vargs) m t vres m'. -Proof. - intros; split. - intros. inv H; exists b; split; auto; econstructor; eauto. - intros [b [P Q]]. inv Q. econstructor; eauto. -Qed. - -Lemma volatile_store_global_ok: - forall chunk id ofs, - extcall_properties (volatile_store_global_sem chunk id ofs) - (mksignature (type_of_chunk chunk :: nil) None cc_default) - (id :: nil). -Proof. - intros; constructor; intros. -(* well typed *) - unfold proj_sig_res; simpl. inv H; constructor. -(* symbols preserved *) - inv H2. econstructor. rewrite H; eauto. eapply volatile_store_preserved; eauto. -(* valid block *) - inv H. inv H2. auto. eauto with mem. -(* 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. - intros [vres' [m2' [A [B [C D]]]]]. - exists vres'; exists m2'; intuition. rewrite volatile_store_global_charact. exists b; auto. -(* mem inject *) - rewrite volatile_store_global_charact in H1. destruct H1 as [b [P Q]]. - exploit H0; eauto with coqlib. intros (b2 & INJ & FS2). - assert (Val.inject f (Vptr b ofs) (Vptr b2 ofs)). econstructor; eauto. rewrite Int.add_zero; auto. - exploit ec_mem_inject. eapply volatile_store_ok. eauto. intuition. eexact Q. eauto. constructor. eauto. eauto. - intros [f' [vres' [m2' [A [B [C [D [E G]]]]]]]]. - exists f'; exists vres'; exists m2'; intuition. - rewrite volatile_store_global_charact. exists b2; auto. -(* trace length *) - inv H. inv H1; simpl; omega. -(* receptive *) - assert (t1 = t2). inv H. eapply volatile_store_receptive; eauto. subst t2. - exists vres1; exists m1; congruence. -(* determ *) - rewrite volatile_store_global_charact in *. - destruct H as [b1 [A1 B1]]. destruct H0 as [b2 [A2 B2]]. rewrite A1 in A2; inv A2. - eapply ec_determ. eapply volatile_store_ok. eauto. eauto. -Qed. - (** ** Semantics of dynamic memory allocation (malloc) *) Inductive extcall_malloc_sem (ge: Senv.t): @@ -1085,8 +963,7 @@ Inductive extcall_malloc_sem (ge: Senv.t): Lemma extcall_malloc_ok: extcall_properties extcall_malloc_sem - (mksignature (Tint :: nil) (Some Tint) cc_default) - nil. + (mksignature (Tint :: nil) (Some Tint) cc_default). Proof. assert (UNCHANGED: forall (P: block -> Z -> Prop) m n m' b m'', @@ -1104,19 +981,19 @@ Proof. constructor; intros. (* well typed *) - inv H. unfold proj_sig_res; simpl. auto. +- inv H. unfold proj_sig_res; simpl. auto. (* symbols preserved *) - inv H2; econstructor; eauto. +- inv H2; econstructor; eauto. (* valid block *) - inv H. eauto with mem. +- inv H. eauto with mem. (* perms *) - inv H. exploit Mem.perm_alloc_inv. eauto. eapply Mem.perm_store_2; eauto. +- inv H. exploit Mem.perm_alloc_inv. eauto. eapply Mem.perm_store_2; eauto. rewrite dec_eq_false. auto. apply Mem.valid_not_valid_diff with m1; eauto with mem. (* readonly *) - inv H. eapply UNCHANGED; eauto. +- inv H. eapply UNCHANGED; eauto. (* mem extends *) - inv H. inv H1. inv H5. inv H7. +- inv H. inv H1. inv H5. inv H7. exploit Mem.alloc_extends; eauto. apply Zle_refl. apply Zle_refl. intros [m3' [A B]]. exploit Mem.store_within_extends. eexact B. eauto. @@ -1126,7 +1003,7 @@ Proof. econstructor; eauto. eapply UNCHANGED; eauto. (* mem injects *) - inv H1. inv H3. inv H7. inv H9. +- inv H0. inv H2. inv H6. inv H8. exploit Mem.alloc_parallel_inject; eauto. apply Zle_refl. apply Zle_refl. intros [f' [m3' [b' [ALLOC [A [B [C D]]]]]]]. exploit Mem.store_mapped_inject. eexact A. eauto. eauto. @@ -1138,15 +1015,15 @@ Proof. eapply UNCHANGED; eauto. eapply UNCHANGED; eauto. red; intros. destruct (eq_block b1 b). - subst b1. rewrite C in H3. inv H3. eauto with mem. - rewrite D in H3 by auto. congruence. + subst b1. rewrite C in H2. inv H2. eauto with mem. + rewrite D in H2 by auto. congruence. (* trace length *) - inv H; simpl; omega. +- inv H; simpl; omega. (* receptive *) - assert (t1 = t2). inv H; inv H0; auto. subst t2. +- assert (t1 = t2). inv H; inv H0; auto. subst t2. exists vres1; exists m1; auto. (* determ *) - inv H; inv H0. split. constructor. intuition congruence. +- inv H; inv H0. split. constructor. intuition congruence. Qed. (** ** Semantics of dynamic memory deallocation (free) *) @@ -1161,25 +1038,24 @@ Inductive extcall_free_sem (ge: Senv.t): Lemma extcall_free_ok: extcall_properties extcall_free_sem - (mksignature (Tint :: nil) None cc_default) - nil. + (mksignature (Tint :: nil) None cc_default). Proof. constructor; intros. (* well typed *) - inv H. unfold proj_sig_res. simpl. auto. +- inv H. unfold proj_sig_res. simpl. auto. (* symbols preserved *) - inv H2; econstructor; eauto. +- inv H2; econstructor; eauto. (* valid block *) - inv H. eauto with mem. +- inv H. eauto with mem. (* perms *) - inv H. eapply Mem.perm_free_3; eauto. +- inv H. eapply Mem.perm_free_3; eauto. (* readonly *) - inv H. eapply Mem.free_unchanged_on; eauto. +- inv H. eapply Mem.free_unchanged_on; eauto. intros. red; intros. elim H3. apply Mem.perm_cur_max. apply Mem.perm_implies with Freeable; auto with mem. eapply Mem.free_range_perm; eauto. (* mem extends *) - inv H. inv H1. inv H8. inv H6. +- inv H. inv H1. inv H8. inv H6. exploit Mem.load_extends; eauto. intros [vsz [A B]]. inv B. exploit Mem.free_parallel_extends; eauto. intros [m2' [C D]]. exists Vundef; exists m2'; intuition. @@ -1191,13 +1067,13 @@ Proof. eapply Mem.free_range_perm. eexact H4. eauto. } tauto. (* mem inject *) - inv H1. inv H3. inv H8. inv H10. +- 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) Cur Freeable). eapply Mem.free_range_perm; eauto. exploit Mem.address_inject; eauto. apply Mem.perm_implies with Freeable; auto with mem. - apply H1. instantiate (1 := lo). omega. + apply H0. instantiate (1 := lo). omega. intro EQ. exploit Mem.free_parallel_inject; eauto. intros (m2' & C & D). exists f, Vundef, m2'; split. @@ -1209,18 +1085,18 @@ Proof. split. auto. split. eapply Mem.free_unchanged_on; eauto. unfold loc_unmapped. intros; congruence. split. eapply Mem.free_unchanged_on; eauto. unfold loc_out_of_reach. - intros. red; intros. eelim H8; eauto. + intros. red; intros. eelim H7; eauto. apply Mem.perm_cur_max. apply Mem.perm_implies with Freeable; auto with mem. - apply H1. omega. + apply H0. omega. split. auto. red; intros. congruence. (* trace length *) - inv H; simpl; omega. +- inv H; simpl; omega. (* receptive *) - assert (t1 = t2). inv H; inv H0; auto. subst t2. +- assert (t1 = t2). inv H; inv H0; auto. subst t2. exists vres1; exists m1; auto. (* determ *) - inv H; inv H0. split. constructor. intuition congruence. +- inv H; inv H0. split. constructor. intuition congruence. Qed. (** ** Semantics of [memcpy] operations. *) @@ -1241,8 +1117,7 @@ Inductive extcall_memcpy_sem (sz al: Z) (ge: Senv.t): Lemma extcall_memcpy_ok: forall sz al, extcall_properties (extcall_memcpy_sem sz al) - (mksignature (Tint :: Tint :: nil) None cc_default) - nil. + (mksignature (Tint :: Tint :: nil) None cc_default). Proof. intros. constructor. - (* return type *) @@ -1274,7 +1149,7 @@ Proof. erewrite list_forall2_length; eauto. tauto. - (* injections *) - intros. inv H1. inv H3. inv H15. inv H16. inv H12. inv H13. + intros. inv H0. inv H2. inv H14. inv H15. inv H11. inv H12. destruct (zeq sz 0). + (* special case sz = 0 *) assert (bytes = nil). @@ -1325,7 +1200,7 @@ Proof. split. eapply Mem.storebytes_unchanged_on; eauto. unfold loc_unmapped; intros. congruence. split. eapply Mem.storebytes_unchanged_on; eauto. unfold loc_out_of_reach; intros. red; intros. - eelim H3; eauto. + eelim H2; eauto. apply Mem.perm_cur_max. apply Mem.perm_implies with Writable; auto with mem. eapply Mem.storebytes_range_perm; eauto. erewrite list_forall2_length; eauto. @@ -1353,39 +1228,38 @@ Inductive extcall_annot_sem (text: ident) (targs: list typ) (ge: Senv.t): Lemma extcall_annot_ok: forall text targs, extcall_properties (extcall_annot_sem text targs) - (mksignature targs None cc_default) - nil. + (mksignature targs None cc_default). Proof. intros; constructor; intros. (* well typed *) - inv H. simpl. auto. +- inv H. simpl. auto. (* symbols *) - inv H2. econstructor; eauto. +- inv H2. econstructor; eauto. eapply eventval_list_match_preserved; eauto. (* valid blocks *) - inv H; auto. +- inv H; auto. (* perms *) - inv H; auto. +- inv H; auto. (* readonly *) - inv H. apply Mem.unchanged_on_refl. +- inv H. apply Mem.unchanged_on_refl. (* mem extends *) - inv H. +- inv H. exists Vundef; exists m1'; intuition. econstructor; eauto. eapply eventval_list_match_lessdef; eauto. (* mem injects *) - inv H1. +- inv H0. exists f; exists Vundef; exists m1'; intuition. econstructor; eauto. eapply eventval_list_match_inject; eauto. red; intros; congruence. (* trace length *) - inv H; simpl; omega. +- inv H; simpl; omega. (* receptive *) - assert (t1 = t2). inv H; inv H0; auto. +- assert (t1 = t2). inv H; inv H0; auto. exists vres1; exists m1; congruence. (* determ *) - inv H; inv H0. +- inv H; inv H0. assert (args = args0). eapply eventval_list_match_determ_2; eauto. subst args0. split. constructor. auto. Qed. @@ -1399,43 +1273,81 @@ Inductive extcall_annot_val_sem (text: ident) (targ: typ) (ge: Senv.t): Lemma extcall_annot_val_ok: forall text targ, extcall_properties (extcall_annot_val_sem text targ) - (mksignature (targ :: nil) (Some targ) cc_default) - nil. + (mksignature (targ :: nil) (Some targ) cc_default). Proof. intros; constructor; intros. (* well typed *) - inv H. unfold proj_sig_res; simpl. eapply eventval_match_type; eauto. +- inv H. unfold proj_sig_res; simpl. eapply eventval_match_type; eauto. (* symbols *) - inv H2. econstructor; eauto. +- inv H2. econstructor; eauto. eapply eventval_match_preserved; eauto. (* valid blocks *) - inv H; auto. +- inv H; auto. (* perms *) - inv H; auto. +- inv H; auto. (* readonly *) - inv H. apply Mem.unchanged_on_refl. +- inv H. apply Mem.unchanged_on_refl. (* mem extends *) - inv H. inv H1. inv H6. +- inv H. inv H1. inv H6. exists v2; exists m1'; intuition. econstructor; eauto. eapply eventval_match_lessdef; eauto. (* mem inject *) - inv H1. inv H3. inv H8. +- inv H0. inv H2. inv H7. exists f; exists v'; exists m1'; intuition. econstructor; eauto. eapply eventval_match_inject; eauto. red; intros; congruence. (* trace length *) - inv H; simpl; omega. +- inv H; simpl; omega. (* receptive *) - assert (t1 = t2). inv H; inv H0; auto. subst t2. +- assert (t1 = t2). inv H; inv H0; auto. subst t2. exists vres1; exists m1; auto. (* determ *) - inv H; inv H0. +- inv H; inv H0. assert (arg = arg0). eapply eventval_match_determ_2; eauto. subst arg0. split. constructor. auto. Qed. +Inductive extcall_debug_sem (ge: Senv.t): + list val -> mem -> trace -> val -> mem -> Prop := + | extcall_debug_sem_intro: forall vargs m, + extcall_debug_sem ge vargs m E0 Vundef m. + +Lemma extcall_debug_ok: + forall targs, + extcall_properties extcall_debug_sem + (mksignature targs None cc_default). +Proof. + intros; constructor; intros. +(* well typed *) +- inv H. simpl. auto. +(* symbols *) +- inv H2. econstructor; eauto. +(* valid blocks *) +- inv H; auto. +(* perms *) +- inv H; auto. +(* readonly *) +- inv H. apply Mem.unchanged_on_refl. +(* mem extends *) +- inv H. + exists Vundef; exists m1'; intuition. + econstructor; eauto. +(* mem injects *) +- inv H0. + exists f; exists Vundef; exists m1'; intuition. + econstructor; eauto. + red; intros; congruence. +(* trace length *) +- inv H; simpl; omega. +(* receptive *) +- inv H; inv H0. exists Vundef, m1; constructor. +(* determ *) +- inv H; inv H0. + split. constructor. auto. +Qed. + (** ** Semantics of external functions. *) (** For functions defined outside the program ([EF_external] and [EF_builtin]), @@ -1445,14 +1357,14 @@ Qed. Parameter external_functions_sem: ident -> signature -> extcall_sem. Axiom external_functions_properties: - forall id sg, extcall_properties (external_functions_sem id sg) sg nil. + forall id sg, extcall_properties (external_functions_sem id sg) sg. (** We treat inline assembly similarly. *) Parameter inline_assembly_sem: ident -> signature -> extcall_sem. Axiom inline_assembly_properties: - forall id sg, extcall_properties (inline_assembly_sem id sg) sg nil. + forall id sg, extcall_properties (inline_assembly_sem id sg) sg. (** ** Combined semantics of external calls *) @@ -1473,33 +1385,31 @@ Definition external_call (ef: external_function): extcall_sem := | EF_builtin name sg => external_functions_sem name sg | EF_vload chunk => volatile_load_sem chunk | EF_vstore chunk => volatile_store_sem chunk - | EF_vload_global chunk id ofs => volatile_load_global_sem chunk id ofs - | EF_vstore_global chunk id ofs => volatile_store_global_sem chunk id ofs | EF_malloc => extcall_malloc_sem | EF_free => extcall_free_sem | EF_memcpy sz al => extcall_memcpy_sem sz al | EF_annot txt targs => extcall_annot_sem txt targs | EF_annot_val txt targ => extcall_annot_val_sem txt targ | EF_inline_asm txt sg clb => inline_assembly_sem txt sg + | EF_debug kind txt targs => extcall_debug_sem end. Theorem external_call_spec: forall ef, - extcall_properties (external_call ef) (ef_sig ef) (globals_external ef). + extcall_properties (external_call ef) (ef_sig ef). Proof. - intros. unfold external_call, ef_sig, globals_external; destruct ef. + intros. unfold external_call, ef_sig; destruct ef. apply external_functions_properties. apply external_functions_properties. apply volatile_load_ok. apply volatile_store_ok. - apply volatile_load_global_ok. - apply volatile_store_global_ok. apply extcall_malloc_ok. apply extcall_free_ok. apply extcall_memcpy_ok. apply extcall_annot_ok. apply extcall_annot_val_ok. apply inline_assembly_properties. + apply extcall_debug_ok. Qed. Definition external_call_well_typed ef := ec_well_typed (external_call_spec ef). @@ -1563,7 +1473,7 @@ Lemma external_call_mem_inject: /\ inject_separated f f' m1 m1'. Proof. intros. destruct H as (A & B & C). eapply external_call_mem_inject_gen with (ge1 := ge); eauto. -- repeat split; intros. + repeat split; intros. + simpl in H3. exploit A; eauto. intros EQ; rewrite EQ in H; inv H. auto. + simpl in H3. exploit A; eauto. intros EQ; rewrite EQ in H; inv H. auto. + simpl in H3. exists b1; split; eauto. @@ -1572,7 +1482,6 @@ Proof. * exploit B; eauto. intros EQ; rewrite EQ in H; inv H. rewrite V1; auto. * destruct (Genv.find_var_info ge b2) as [gv2|] eqn:V2; auto. exploit C; eauto. intros EQ; subst b2. congruence. -- intros. exists b1; split; auto. apply A with id; auto. Qed. (** Corollaries of [external_call_determ]. *) @@ -1648,8 +1557,7 @@ Lemma decode_longs_inject: Proof. induction tyl; simpl; intros. auto. - destruct a; inv H; auto. inv H1; auto. constructor; auto. apply Val.longofwords_inject; auto. -Qed. + destruct a; inv H; auto. inv H1; auto. constructor; auto. apply Val.longofwords_inject; auto. Qed. Lemma encode_long_lessdef: forall oty v1 v2, Val.lessdef v1 v2 -> Val.lessdef_list (encode_long oty v1) (encode_long oty v2). @@ -1785,9 +1693,9 @@ Proof. split; congruence. Qed. -(** * Evaluation of annotation arguments *) +(** * Evaluation of builtin arguments *) -Section EVAL_ANNOT_ARG. +Section EVAL_BUILTIN_ARG. Variable A: Type. Variable ge: Senv.t. @@ -1795,54 +1703,54 @@ Variable e: A -> val. Variable sp: val. Variable m: mem. -Inductive eval_annot_arg: annot_arg A -> val -> Prop := - | eval_AA_base: forall x, - eval_annot_arg (AA_base x) (e x) - | eval_AA_int: forall n, - eval_annot_arg (AA_int n) (Vint n) - | eval_AA_long: forall n, - eval_annot_arg (AA_long n) (Vlong n) - | eval_AA_float: forall n, - eval_annot_arg (AA_float n) (Vfloat n) - | eval_AA_single: forall n, - eval_annot_arg (AA_single n) (Vsingle n) - | eval_AA_loadstack: forall chunk ofs v, +Inductive eval_builtin_arg: builtin_arg A -> val -> Prop := + | eval_BA: forall x, + eval_builtin_arg (BA x) (e x) + | eval_BA_int: forall n, + eval_builtin_arg (BA_int n) (Vint n) + | eval_BA_long: forall n, + eval_builtin_arg (BA_long n) (Vlong n) + | eval_BA_float: forall n, + eval_builtin_arg (BA_float n) (Vfloat n) + | eval_BA_single: forall n, + eval_builtin_arg (BA_single n) (Vsingle n) + | eval_BA_loadstack: forall chunk ofs v, Mem.loadv chunk m (Val.add sp (Vint ofs)) = Some v -> - eval_annot_arg (AA_loadstack chunk ofs) v - | eval_AA_addrstack: forall ofs, - eval_annot_arg (AA_addrstack ofs) (Val.add sp (Vint ofs)) - | eval_AA_loadglobal: forall chunk id ofs v, + eval_builtin_arg (BA_loadstack chunk ofs) v + | eval_BA_addrstack: forall ofs, + eval_builtin_arg (BA_addrstack ofs) (Val.add sp (Vint ofs)) + | eval_BA_loadglobal: forall chunk id ofs v, Mem.loadv chunk m (Senv.symbol_address ge id ofs) = Some v -> - eval_annot_arg (AA_loadglobal chunk id ofs) v - | eval_AA_addrglobal: forall id ofs, - eval_annot_arg (AA_addrglobal id ofs) (Senv.symbol_address ge id ofs) - | eval_AA_longofwords: forall hi lo vhi vlo, - eval_annot_arg hi vhi -> eval_annot_arg lo vlo -> - eval_annot_arg (AA_longofwords hi lo) (Val.longofwords vhi vlo). + eval_builtin_arg (BA_loadglobal chunk id ofs) v + | eval_BA_addrglobal: forall id ofs, + eval_builtin_arg (BA_addrglobal id ofs) (Senv.symbol_address ge id ofs) + | eval_BA_splitlong: forall hi lo vhi vlo, + eval_builtin_arg hi vhi -> eval_builtin_arg lo vlo -> + eval_builtin_arg (BA_splitlong hi lo) (Val.longofwords vhi vlo). -Definition eval_annot_args (al: list (annot_arg A)) (vl: list val) : Prop := - list_forall2 eval_annot_arg al vl. +Definition eval_builtin_args (al: list (builtin_arg A)) (vl: list val) : Prop := + list_forall2 eval_builtin_arg al vl. -Lemma eval_annot_arg_determ: - forall a v, eval_annot_arg a v -> forall v', eval_annot_arg a v' -> v' = v. +Lemma eval_builtin_arg_determ: + forall a v, eval_builtin_arg a v -> forall v', eval_builtin_arg a v' -> v' = v. Proof. induction 1; intros v' EV; inv EV; try congruence. f_equal; eauto. Qed. -Lemma eval_annot_args_determ: - forall al vl, eval_annot_args al vl -> forall vl', eval_annot_args al vl' -> vl' = vl. +Lemma eval_builtin_args_determ: + forall al vl, eval_builtin_args al vl -> forall vl', eval_builtin_args al vl' -> vl' = vl. Proof. - induction 1; intros v' EV; inv EV; f_equal; eauto using eval_annot_arg_determ. + induction 1; intros v' EV; inv EV; f_equal; eauto using eval_builtin_arg_determ. Qed. -End EVAL_ANNOT_ARG. +End EVAL_BUILTIN_ARG. -Hint Constructors eval_annot_arg: aarg. +Hint Constructors eval_builtin_arg: barg. (** Invariance by change of global environment. *) -Section EVAL_ANNOT_ARG_PRESERVED. +Section EVAL_BUILTIN_ARG_PRESERVED. Variables A F1 V1 F2 V2: Type. Variable ge1: Genv.t F1 V1. @@ -1854,25 +1762,25 @@ Variable m: mem. Hypothesis symbols_preserved: forall id, Genv.find_symbol ge2 id = Genv.find_symbol ge1 id. -Lemma eval_annot_arg_preserved: - forall a v, eval_annot_arg ge1 e sp m a v -> eval_annot_arg ge2 e sp m a v. +Lemma eval_builtin_arg_preserved: + forall a v, eval_builtin_arg ge1 e sp m a v -> eval_builtin_arg ge2 e sp m a v. Proof. assert (EQ: forall id ofs, Senv.symbol_address ge2 id ofs = Senv.symbol_address ge1 id ofs). { unfold Senv.symbol_address; simpl; intros. rewrite symbols_preserved; auto. } - induction 1; eauto with aarg. rewrite <- EQ in H; eauto with aarg. rewrite <- EQ; eauto with aarg. + induction 1; eauto with barg. rewrite <- EQ in H; eauto with barg. rewrite <- EQ; eauto with barg. Qed. -Lemma eval_annot_args_preserved: - forall al vl, eval_annot_args ge1 e sp m al vl -> eval_annot_args ge2 e sp m al vl. +Lemma eval_builtin_args_preserved: + forall al vl, eval_builtin_args ge1 e sp m al vl -> eval_builtin_args ge2 e sp m al vl. Proof. - induction 1; constructor; auto; eapply eval_annot_arg_preserved; eauto. + induction 1; constructor; auto; eapply eval_builtin_arg_preserved; eauto. Qed. -End EVAL_ANNOT_ARG_PRESERVED. +End EVAL_BUILTIN_ARG_PRESERVED. (** Compatibility with the "is less defined than" relation. *) -Section EVAL_ANNOT_ARG_LESSDEF. +Section EVAL_BUILTIN_ARG_LESSDEF. Variable A: Type. Variable ge: Senv.t. @@ -1883,35 +1791,35 @@ Variables m1 m2: mem. Hypothesis env_lessdef: forall x, Val.lessdef (e1 x) (e2 x). Hypothesis mem_extends: Mem.extends m1 m2. -Lemma eval_annot_arg_lessdef: - forall a v1, eval_annot_arg ge e1 sp m1 a v1 -> - exists v2, eval_annot_arg ge e2 sp m2 a v2 /\ Val.lessdef v1 v2. +Lemma eval_builtin_arg_lessdef: + forall a v1, eval_builtin_arg ge e1 sp m1 a v1 -> + exists v2, eval_builtin_arg ge e2 sp m2 a v2 /\ Val.lessdef v1 v2. Proof. induction 1. -- exists (e2 x); auto with aarg. -- econstructor; eauto with aarg. -- econstructor; eauto with aarg. -- econstructor; eauto with aarg. -- econstructor; eauto with aarg. -- exploit Mem.loadv_extends; eauto. intros (v' & P & Q). exists v'; eauto with aarg. -- econstructor; eauto with aarg. -- exploit Mem.loadv_extends; eauto. intros (v' & P & Q). exists v'; eauto with aarg. -- econstructor; eauto with aarg. -- destruct IHeval_annot_arg1 as (vhi' & P & Q). - destruct IHeval_annot_arg2 as (vlo' & R & S). - econstructor; split; eauto with aarg. apply Val.longofwords_lessdef; auto. -Qed. - -Lemma eval_annot_args_lessdef: - forall al vl1, eval_annot_args ge e1 sp m1 al vl1 -> - exists vl2, eval_annot_args ge e2 sp m2 al vl2 /\ Val.lessdef_list vl1 vl2. +- exists (e2 x); auto with barg. +- econstructor; eauto with barg. +- econstructor; eauto with barg. +- econstructor; eauto with barg. +- econstructor; eauto with barg. +- exploit Mem.loadv_extends; eauto. intros (v' & P & Q). exists v'; eauto with barg. +- econstructor; eauto with barg. +- exploit Mem.loadv_extends; eauto. intros (v' & P & Q). exists v'; eauto with barg. +- econstructor; eauto with barg. +- destruct IHeval_builtin_arg1 as (vhi' & P & Q). + destruct IHeval_builtin_arg2 as (vlo' & R & S). + econstructor; split; eauto with barg. apply Val.longofwords_lessdef; auto. +Qed. + +Lemma eval_builtin_args_lessdef: + forall al vl1, eval_builtin_args ge e1 sp m1 al vl1 -> + exists vl2, eval_builtin_args ge e2 sp m2 al vl2 /\ Val.lessdef_list vl1 vl2. Proof. induction 1. - econstructor; split. constructor. auto. -- exploit eval_annot_arg_lessdef; eauto. intros (v1' & P & Q). +- exploit eval_builtin_arg_lessdef; eauto. intros (v1' & P & Q). destruct IHlist_forall2 as (vl' & U & V). exists (v1'::vl'); split; constructor; auto. Qed. -End EVAL_ANNOT_ARG_LESSDEF. +End EVAL_BUILTIN_ARG_LESSDEF. diff --git a/common/PrintAST.ml b/common/PrintAST.ml index 76305d02..aea8ff0f 100644 --- a/common/PrintAST.ml +++ b/common/PrintAST.ml @@ -41,12 +41,6 @@ let name_of_external = function | EF_builtin(name, sg) -> sprintf "builtin %S" (extern_atom name) | EF_vload chunk -> sprintf "volatile load %s" (name_of_chunk chunk) | EF_vstore chunk -> sprintf "volatile store %s" (name_of_chunk chunk) - | EF_vload_global(chunk, id, ofs) -> - sprintf "volatile load %s global %S %ld" - (name_of_chunk chunk) (extern_atom id) (camlint_of_coqint ofs) - | EF_vstore_global(chunk, id, ofs) -> - sprintf "volatile store %s global %S %ld" - (name_of_chunk chunk) (extern_atom id) (camlint_of_coqint ofs) | EF_malloc -> "malloc" | EF_free -> "free" | EF_memcpy(sz, al) -> @@ -54,28 +48,38 @@ let name_of_external = function | EF_annot(text, targs) -> sprintf "annot %S" (extern_atom text) | EF_annot_val(text, targ) -> sprintf "annot_val %S" (extern_atom text) | EF_inline_asm(text, sg, clob) -> sprintf "inline_asm %S" (extern_atom text) + | EF_debug(kind, text, targs) -> + sprintf "debug%d %S" (P.to_int kind) (extern_atom text) -let rec print_annot_arg px oc = function - | AA_base x -> px oc x - | AA_int n -> fprintf oc "int %ld" (camlint_of_coqint n) - | AA_long n -> fprintf oc "long %Ld" (camlint64_of_coqint n) - | AA_float n -> fprintf oc "float %F" (camlfloat_of_coqfloat n) - | AA_single n -> fprintf oc "single %F" (camlfloat_of_coqfloat32 n) - | AA_loadstack(chunk, ofs) -> +let rec print_builtin_arg px oc = function + | BA x -> px oc x + | BA_int n -> fprintf oc "int %ld" (camlint_of_coqint n) + | BA_long n -> fprintf oc "long %Ld" (camlint64_of_coqint n) + | BA_float n -> fprintf oc "float %F" (camlfloat_of_coqfloat n) + | BA_single n -> fprintf oc "single %F" (camlfloat_of_coqfloat32 n) + | BA_loadstack(chunk, ofs) -> fprintf oc "%s[sp + %ld]" (name_of_chunk chunk) (camlint_of_coqint ofs) - | AA_addrstack(ofs) -> + | BA_addrstack(ofs) -> fprintf oc "sp + %ld" (camlint_of_coqint ofs) - | AA_loadglobal(chunk, id, ofs) -> + | BA_loadglobal(chunk, id, ofs) -> fprintf oc "%s[&%s + %ld]" (name_of_chunk chunk) (extern_atom id) (camlint_of_coqint ofs) - | AA_addrglobal(id, ofs) -> + | BA_addrglobal(id, ofs) -> fprintf oc "&%s + %ld" (extern_atom id) (camlint_of_coqint ofs) - | AA_longofwords(hi, lo) -> - fprintf oc "longofwords(%a, %a)" - (print_annot_arg px) hi (print_annot_arg px) lo + | BA_splitlong(hi, lo) -> + fprintf oc "splitlong(%a, %a)" + (print_builtin_arg px) hi (print_builtin_arg px) lo -let rec print_annot_args px oc = function +let rec print_builtin_args px oc = function | [] -> () - | [a] -> print_annot_arg px oc a + | [a] -> print_builtin_arg px oc a | a1 :: al -> - fprintf oc "%a, %a" (print_annot_arg px) a1 (print_annot_args px) al + fprintf oc "%a, %a" (print_builtin_arg px) a1 (print_builtin_args px) al + +let rec print_builtin_res px oc = function + | BR x -> px oc x + | BR_none -> fprintf oc "_" + | BR_splitlong(hi, lo) -> + fprintf oc "splitlong(%a, %a)" + (print_builtin_res px) hi (print_builtin_res px) lo + diff --git a/cparser/ExtendedAsm.ml b/cparser/ExtendedAsm.ml index fbf8d569..05084561 100644 --- a/cparser/ExtendedAsm.ml +++ b/cparser/ExtendedAsm.ml @@ -57,10 +57,9 @@ let set_label_reg lbl pos pos' subst = have this feature and with which syntax. *) let set_label_regpair lbl pos pos' subst = - StringMap.add (name_of_label ~modifier:"R" lbl pos) (sprintf "%%%d" pos') - (StringMap.add (name_of_label ~modifier:"Q" lbl pos) - (sprintf "%%%d" (pos' + 1)) - subst) + StringMap.add (name_of_label ~modifier:"R" lbl pos) (sprintf "%%R%d" pos') + (StringMap.add (name_of_label ~modifier:"Q" lbl pos) (sprintf "%%Q%d" pos') + subst) let set_label_mem lbl pos pos' subst = StringMap.add (name_of_label lbl pos) @@ -91,7 +90,7 @@ let rec transf_inputs loc env accu pos pos' subst = function let valid = Str.string_match re_valid_input cstr 0 in if valid && String.contains cstr 'r' then if is_reg_pair env e.etyp then - transf_inputs loc env (e :: accu) (pos + 1) (pos' + 2) + transf_inputs loc env (e :: accu) (pos + 1) (pos' + 1) (set_label_regpair lbl pos pos' subst) inputs else transf_inputs loc env (e :: accu) (pos + 1) (pos' + 1) @@ -133,7 +132,7 @@ let transf_outputs loc env = function let valid = Str.string_match re_valid_output cstr 0 in if valid && String.contains cstr 'r' then if is_reg_pair env e.etyp then - (Some e, [], set_label_regpair lbl 0 0 StringMap.empty, 1, 2) + (Some e, [], set_label_regpair lbl 0 0 StringMap.empty, 1, 1) else (Some e, [], set_label_reg lbl 0 0 StringMap.empty, 1, 1) else diff --git a/driver/Compiler.v b/driver/Compiler.v index 0afa7bfb..3920665e 100644 --- a/driver/Compiler.v +++ b/driver/Compiler.v @@ -51,6 +51,7 @@ Require Allocation. Require Tunneling. Require Linearize. Require CleanupLabels. +Require Debugvar. Require Stacking. Require Asmgen. (** Proofs of semantic preservation. *) @@ -71,6 +72,7 @@ Require Allocproof. Require Tunnelingproof. Require Linearizeproof. Require CleanupLabelsproof. +Require Debugvarproof. Require Stackingproof. Require Asmgenproof. (** Command-line flags. *) @@ -144,6 +146,7 @@ Definition transf_rtl_program (f: RTL.program) : res Asm.program := @@ time "Branch tunneling" Tunneling.tunnel_program @@@ time "CFG linearization" Linearize.transf_program @@ time "Label cleanup" CleanupLabels.transf_program + @@@ partial_if Compopts.debug (time "Debugging info for local variables" Debugvar.transf_program) @@@ time "Mach generation" Stacking.transf_program @@ print print_Mach @@@ time "Asm generation" Asmgen.transf_program. @@ -253,7 +256,8 @@ Proof. 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 *. - destruct (Stacking.transf_program p7) as [p8|] eqn:?; simpl in H; try discriminate. + destruct (partial_if debug Debugvar.transf_program p7) as [p71|] eqn:?; simpl in H; try discriminate. + destruct (Stacking.transf_program p71) as [p8|] eqn:?; simpl in H; try discriminate. apply compose_forward_simulation with (RTL.semantics p1). apply total_if_simulation. apply Tailcallproof.transf_program_correct. apply compose_forward_simulation with (RTL.semantics p11). @@ -278,6 +282,8 @@ Proof. apply Linearizeproof.transf_program_correct; auto. apply compose_forward_simulation with (Linear.semantics p7). apply CleanupLabelsproof.transf_program_correct. + apply compose_forward_simulation with (Linear.semantics p71). + eapply partial_if_simulation; eauto. apply Debugvarproof.transf_program_correct. apply compose_forward_simulation with (Mach.semantics Asmgenproof0.return_address_offset p8). apply Stackingproof.transf_program_correct. exact Asmgenproof.return_address_exists. diff --git a/driver/Compopts.v b/driver/Compopts.v index d0c6686e..2a213350 100644 --- a/driver/Compopts.v +++ b/driver/Compopts.v @@ -41,3 +41,6 @@ Parameter optim_redundancy: unit -> bool. (** Flag -fthumb. For the ARM back-end. *) Parameter thumb: unit -> bool. + +(** Flag -g. For insertion of debugging information. *) +Parameter debug: unit -> bool. diff --git a/driver/Driver.ml b/driver/Driver.ml index b646dc83..f53de821 100644 --- a/driver/Driver.ml +++ b/driver/Driver.ml @@ -179,9 +179,11 @@ let compile_c_ast sourcename csyntax ofile debug = set_dest PrintMach.destination option_dmach ".mach"; (* Convert to Asm *) let asm = - match Compiler.transf_c_program csyntax with + match Compiler.apply_partial + (Compiler.transf_c_program csyntax) + Asmexpand.expand_program with | Errors.OK asm -> - Asmexpand.expand_program asm + asm | Errors.Error msg -> eprintf "%s: %a" sourcename print_error msg; exit 2 in diff --git a/extraction/extraction.v b/extraction/extraction.v index ecd2853a..6327f871 100644 --- a/extraction/extraction.v +++ b/extraction/extraction.v @@ -100,6 +100,8 @@ Extract Constant Compopts.optim_redundancy => "fun _ -> !Clflags.option_fredundancy". Extract Constant Compopts.thumb => "fun _ -> !Clflags.option_mthumb". +Extract Constant Compopts.debug => + "fun _ -> !Clflags.option_g". (* Compiler *) Extract Constant Compiler.print_Clight => "PrintClight.print_if". @@ -211,8 +211,7 @@ Inductive instruction: Type := | Plabel(l: label) | Pallocframe(sz: Z)(ofs_ra ofs_link: int) | Pfreeframe(sz: Z)(ofs_ra ofs_link: int) - | Pbuiltin(ef: external_function)(args: list preg)(res: list preg) - | Pannot(ef: external_function)(args: list (annot_arg preg)) + | Pbuiltin(ef: external_function)(args: list (builtin_arg preg))(res: builtin_res preg) (** Instructions not generated by [Asmgen] *) | Padc_ri (rd: ireg) (n: int) | Padc_rr (rd: ireg) (r2: ireg) @@ -288,6 +287,15 @@ Fixpoint set_regs (rl: list preg) (vl: list val) (rs: regset) : regset := | _, _ => rs end. +(** Assigning the result of a builtin *) + +Fixpoint set_res (res: builtin_res preg) (v: val) (rs: regset) : regset := + match res with + | BR r => rs#r <- v + | BR_none => rs + | BR_splitlong hi lo => set_res lo (Val.loword v) (set_res hi (Val.hiword v) rs) + end. + Section RELSEM. (** Looking up instructions in a code sequence by position. *) @@ -782,8 +790,6 @@ Definition exec_instr (f: function) (i: instruction) (rs: regset) (m: mem) : out end | Pbuiltin ef args res => Stuck (**r treated specially below *) - | Pannot ef args => - Stuck (**r treated specially below *) (** The following instructions and directives are not generated directly by [Asmgen], so we do not model them. *) | Padc_ri _ _ @@ -879,24 +885,16 @@ Inductive step: state -> trace -> state -> Prop := exec_instr f i rs m = Next rs' m' -> step (State rs m) E0 (State rs' m') | exec_step_builtin: - forall b ofs f ef args res rs m t vl rs' m', + forall b ofs f ef args res rs m vargs t vres rs' m', rs PC = Vptr b ofs -> Genv.find_funct_ptr ge b = Some (Internal f) -> find_instr (Int.unsigned ofs) f.(fn_code) = Some (Pbuiltin ef args res) -> - external_call' ef ge (map rs args) m t vl m' -> + eval_builtin_args ge rs (rs ESP) m args vargs -> + external_call ef ge vargs m t vres m' -> rs' = nextinstr_nf - (set_regs res vl + (set_res res vres (undef_regs (map preg_of (destroyed_by_builtin ef)) rs)) -> step (State rs m) t (State rs' m') - | exec_step_annot: - forall b ofs f ef args rs m vargs t v m', - rs PC = Vptr b ofs -> - Genv.find_funct_ptr ge b = Some (Internal f) -> - find_instr (Int.unsigned ofs) f.(fn_code) = Some (Pannot ef args) -> - eval_annot_args ge rs (rs ESP) m args vargs -> - external_call ef ge vargs m t v m' -> - step (State rs m) t - (State (nextinstr rs) m') | exec_step_external: forall b ef args res rs m t rs' m', rs PC = Vptr b Int.zero -> @@ -960,12 +958,8 @@ Ltac Equalities := + split. constructor. auto. + discriminate. + discriminate. -+ inv H11. -+ exploit external_call_determ'. eexact H4. eexact H9. intros [A B]. - split. auto. intros. destruct B; auto. subst. auto. -+ inv H12. -+ assert (vargs0 = vargs) by (eapply eval_annot_args_determ; eauto). subst vargs0. - exploit external_call_determ. eexact H5. eexact H13. intros [A B]. ++ assert (vargs0 = vargs) by (eapply eval_builtin_args_determ; eauto). subst vargs0. + exploit external_call_determ. eexact H5. eexact H11. intros [A B]. split. auto. intros. destruct B; auto. subst. auto. + assert (args0 = args) by (eapply extcall_arguments_determ; eauto). subst args0. exploit external_call_determ'. eexact H4. eexact H9. intros [A B]. diff --git a/ia32/Asmexpand.ml b/ia32/Asmexpand.ml index 137b61b5..baf0523e 100644 --- a/ia32/Asmexpand.ml +++ b/ia32/Asmexpand.ml @@ -22,6 +22,8 @@ open Camlcoq open Datatypes open Integers +exception Error of string + (* Useful constants and helper functions *) let _0 = Int.zero @@ -59,13 +61,22 @@ let sp_adjustment sz = (* Handling of annotations *) let expand_annot_val txt targ args res = - emit (Pannot (EF_annot(txt,[targ]), List.map (fun r -> AA_base r) args)); + emit (Pbuiltin (EF_annot(txt,[targ]), args, BR_none)); match args, res with - | [IR src], [IR dst] -> + | [BA(IR src)], BR(IR dst) -> if dst <> src then emit (Pmov_rr (dst,src)) - | [FR src], [FR dst] -> + | [BA(FR src)], BR(FR dst) -> if dst <> src then emit (Pmovsd_ff (dst,src)) - | _, _ -> assert false + | _, _ -> + raise (Error "ill-formed __builtin_annot_val") + +(* Translate a builtin argument into an addressing mode *) + +let addressing_of_builtin_arg = function + | BA (IR r) -> Addrmode(Some r, None, Coq_inl Integers.Int.zero) + | BA_addrstack ofs -> Addrmode(Some ESP, None, Coq_inl ofs) + | BA_addrglobal(id, ofs) -> Addrmode(None, None, Coq_inr(id, ofs)) + | _ -> assert false (* Operations on addressing modes *) @@ -84,37 +95,36 @@ let global_addr id ofs = Addrmode(None, None, Coq_inr(id, ofs)) memory accesses regardless of alignment. *) let expand_builtin_memcpy_small sz al src dst = - assert (src = EDX && dst = EAX); - let rec copy ofs sz = + let rec copy src dst sz = if sz >= 8 && !Clflags.option_ffpu then begin - emit (Pmovq_rm (XMM7, linear_addr src ofs)); - emit (Pmovq_mr (linear_addr dst ofs, XMM7)); - copy (Int.add ofs _8) (sz - 8) + emit (Pmovq_rm (XMM7, src)); + emit (Pmovq_mr (dst, XMM7)); + copy (offset_addressing src _8) (offset_addressing dst _8) (sz - 8) end else if sz >= 4 then begin - emit (Pmov_rm (ECX, linear_addr src ofs)); - emit (Pmov_mr (linear_addr dst ofs, ECX)); - copy (Int.add ofs _4) (sz - 4) + emit (Pmov_rm (ECX, src)); + emit (Pmov_mr (dst, ECX)); + copy (offset_addressing src _4) (offset_addressing dst _4) (sz - 4) end else if sz >= 2 then begin - emit (Pmovw_rm (ECX, linear_addr src ofs)); - emit (Pmovw_mr (linear_addr dst ofs, ECX)); - copy (Int.add ofs _2) (sz - 2) + emit (Pmovw_rm (ECX, src)); + emit (Pmovw_mr (dst, ECX)); + copy (offset_addressing src _2) (offset_addressing dst _2) (sz - 2) end else if sz >= 1 then begin - emit (Pmovb_rm (ECX, linear_addr src ofs)); - emit (Pmovb_mr (linear_addr dst ofs, ECX)); - copy (Int.add ofs _1) (sz - 1) + emit (Pmovb_rm (ECX, src)); + emit (Pmovb_mr (dst, ECX)); + copy (offset_addressing src _1) (offset_addressing dst _1) (sz - 1) end in - copy _0 sz + copy (addressing_of_builtin_arg src) (addressing_of_builtin_arg dst) sz let expand_builtin_memcpy_big sz al src dst = - assert (src = ESI && dst = EDI); + if src <> BA (IR ESI) then emit (Plea (ESI, addressing_of_builtin_arg src)); + if dst <> BA (IR EDI) then emit (Plea (EDI, addressing_of_builtin_arg dst)); emit (Pmov_ri (ECX,coqint_of_camlint (Int32.of_int (sz / 4)))); emit Prep_movsl; if sz mod 4 >= 2 then emit Pmovsw; if sz mod 2 >= 1 then emit Pmovsb let expand_builtin_memcpy sz al args = - let (dst, src) = - match args with [IR d; IR s] -> (d, s) | _ -> assert false in + let (dst, src) = match args with [d; s] -> (d, s) | _ -> assert false in if sz <= 32 then expand_builtin_memcpy_small sz al src dst else expand_builtin_memcpy_big sz al src dst @@ -123,17 +133,17 @@ let expand_builtin_memcpy sz al args = let expand_builtin_vload_common chunk addr res = match chunk, res with - | Mint8unsigned, [IR res] -> + | Mint8unsigned, BR(IR res) -> emit (Pmovzb_rm (res,addr)) - | Mint8signed, [IR res] -> + | Mint8signed, BR(IR res) -> emit (Pmovsb_rm (res,addr)) - | Mint16unsigned, [IR res] -> + | Mint16unsigned, BR(IR res) -> emit (Pmovzw_rm (res,addr)) - | Mint16signed, [IR res] -> + | Mint16signed, BR(IR res) -> emit (Pmovsw_rm (res,addr)) - | Mint32, [IR res] -> + | Mint32, BR(IR res) -> emit (Pmov_rm (res,addr)) - | Mint64, [IR res1; IR res2] -> + | Mint64, BR_splitlong(BR(IR res1), BR(IR res2)) -> let addr' = offset_addressing addr _4 in if not (Asmgen.addressing_mentions addr res2) then begin emit (Pmov_rm (res2,addr)); @@ -142,56 +152,51 @@ let expand_builtin_vload_common chunk addr res = emit (Pmov_rm (res1,addr')); emit (Pmov_rm (res2,addr)) end - | Mfloat32, [FR res] -> + | Mfloat32, BR(FR res) -> emit (Pmovss_fm (res,addr)) - | Mfloat64, [FR res] -> + | Mfloat64, BR(FR res) -> emit (Pmovsd_fm (res,addr)) | _ -> assert false let expand_builtin_vload chunk args res = match args with - | [IR addr] -> expand_builtin_vload_common chunk (linear_addr addr _0) res - | _ -> assert false + | [addr] -> + expand_builtin_vload_common chunk (addressing_of_builtin_arg addr) res + | _ -> + assert false -let expand_builtin_vload_global chunk id ofs args res = - expand_builtin_vload_common chunk (global_addr id ofs) res - let expand_builtin_vstore_common chunk addr src tmp = match chunk, src with - | (Mint8signed | Mint8unsigned), [IR src] -> + | (Mint8signed | Mint8unsigned), BA(IR src) -> if Asmgen.low_ireg src then emit (Pmovb_mr (addr,src)) else begin emit (Pmov_rr (tmp,src)); emit (Pmovb_mr (addr,tmp)) end - | (Mint16signed | Mint16unsigned), [IR src] -> + | (Mint16signed | Mint16unsigned), BA(IR src) -> emit (Pmovw_mr (addr,src)) - | Mint32, [IR src] -> + | Mint32, BA(IR src) -> emit (Pmov_mr (addr,src)) - | Mint64, [IR src1; IR src2] -> + | Mint64, BA_splitlong(BA(IR src1), BA(IR src2)) -> let addr' = offset_addressing addr _4 in emit (Pmov_mr (addr,src2)); emit (Pmov_mr (addr',src1)) - | Mfloat32, [FR src] -> + | Mfloat32, BA(FR src) -> emit (Pmovss_mf (addr,src)) - | Mfloat64, [FR src] -> + | Mfloat64, BA(FR src) -> emit (Pmovsd_mf (addr,src)) | _ -> assert false let expand_builtin_vstore chunk args = match args with - | IR addr :: src -> - expand_builtin_vstore_common chunk (linear_addr addr _0) src - (if addr = EAX then ECX else EAX) + | [addr; src] -> + let addr = addressing_of_builtin_arg addr in + expand_builtin_vstore_common chunk addr src + (if Asmgen.addressing_mentions addr EAX then ECX else EAX) | _ -> assert false - - -let expand_builtin_vstore_global chunk id ofs args = - expand_builtin_vstore_common chunk (global_addr id ofs) args EAX - (* Handling of varargs *) @@ -216,7 +221,7 @@ let expand_builtin_va_start r = let expand_fma args res i132 i213 i231 = match args, res with - | [FR a1; FR a2; FR a3], [FR res] -> + | [BA(FR a1); BA(FR a2); BA(FR a3)], BR(FR res) -> if res = a1 then emit (i132 a1 a3 a2) (* a1 * a2 + a3 *) else if res = a2 then emit (i213 a2 a1 a3) (* a1 * a2 + a3 *) else if res = a3 then emit (i231 a3 a1 a2) (* a1 * a2 + a3 *) @@ -232,27 +237,27 @@ let expand_fma args res i132 i213 i231 = let expand_builtin_inline name args res = match name, args, res with (* Integer arithmetic *) - | ("__builtin_bswap"| "__builtin_bswap32"), [IR a1], [IR res] -> + | ("__builtin_bswap"| "__builtin_bswap32"), [BA(IR a1)], BR(IR res) -> if a1 <> res then emit (Pmov_rr (res,a1)); emit (Pbswap res) - | "__builtin_bswap16", [IR a1], [IR res] -> + | "__builtin_bswap16", [BA(IR a1)], BR(IR res) -> if a1 <> res then emit (Pmov_rr (res,a1)); emit (Pbswap16 res) - | "__builtin_clz", [IR a1], [IR res] -> + | "__builtin_clz", [BA(IR a1)], BR(IR res) -> emit (Pbsr (res,a1)); emit (Pxor_ri(res,coqint_of_camlint 31l)) - | "__builtin_ctz", [IR a1], [IR res] -> + | "__builtin_ctz", [BA(IR a1)], BR(IR res) -> emit (Pbsf (res,a1)) (* Float arithmetic *) - | "__builtin_fabs", [FR a1], [FR res] -> + | "__builtin_fabs", [BA(FR a1)], BR(FR res) -> if a1 <> res then emit (Pmovsd_ff (res,a1)); emit (Pabsd res) (* This ensures that need_masks is set to true *) - | "__builtin_fsqrt", [FR a1], [FR res] -> + | "__builtin_fsqrt", [BA(FR a1)], BR(FR res) -> emit (Psqrtsd (res,a1)) - | "__builtin_fmax", [FR a1; FR a2], [FR res] -> + | "__builtin_fmax", [BA(FR a1); BA(FR a2)], BR(FR res) -> if res = a1 then emit (Pmaxsd (res,a2)) else if res = a2 then @@ -261,7 +266,7 @@ let expand_builtin_inline name args res = emit (Pmovsd_ff (res,a1)); emit (Pmaxsd (res,a2)) end - | "__builtin_fmin", [FR a1; FR a2], [FR res] -> + | "__builtin_fmin", [BA(FR a1); BA(FR a2)], BR(FR res) -> if res = a1 then emit (Pminsd (res,a2)) else if res = a2 then @@ -291,55 +296,58 @@ let expand_builtin_inline name args res = (fun r1 r2 r3 -> Pfnmsub213(r1, r2, r3)) (fun r1 r2 r3 -> Pfnmsub231(r1, r2, r3)) (* 64-bit integer arithmetic *) - | "__builtin_negl", [IR ah; IR al], [IR rh; IR rl] -> + | "__builtin_negl", [BA_splitlong(BA(IR ah), BA(IR al))], + BR_splitlong(BR(IR rh), BR(IR rl)) -> assert (ah = EDX && al = EAX && rh = EDX && rl = EAX); emit (Pneg EAX); emit (Padc_ri (EDX,_0)); emit (Pneg EDX) - | "__builtin_addl", [IR ah; IR al; IR bh; IR bl], [IR rh; IR rl] -> + | "__builtin_addl", [BA_splitlong(BA(IR ah), BA(IR al)); + BA_splitlong(BA(IR bh), BA(IR bl))], + BR_splitlong(BR(IR rh), BR(IR rl)) -> assert (ah = EDX && al = EAX && bh = ECX && bl = EBX && rh = EDX && rl = EAX); emit (Padd_rr (EAX,EBX)); emit (Padc_rr (EDX,ECX)) - | "__builtin_subl", [IR ah; IR al; IR bh; IR bl], [IR rh; IR rl] -> + | "__builtin_subl", [BA_splitlong(BA(IR ah), BA(IR al)); + BA_splitlong(BA(IR bh), BA(IR bl))], + BR_splitlong(BR(IR rh), BR(IR rl)) -> assert (ah = EDX && al = EAX && bh = ECX && bl = EBX && rh = EDX && rl = EAX); emit (Psub_rr (EAX,EBX)); emit (Psbb_rr (EDX,ECX)) - | "__builtin_mull", [IR a; IR b], [IR rh; IR rl] -> + | "__builtin_mull", [BA(IR a); BA(IR b)], + BR_splitlong(BR(IR rh), BR(IR rl)) -> assert (a = EAX && b = EDX && rh = EDX && rl = EAX); emit (Pmul_r EDX) (* Memory accesses *) - | "__builtin_read16_reversed", [IR a1], [IR res] -> - let addr = Addrmode(Some a1,None,Coq_inl _0) in - emit (Pmovzw_rm (res,addr)); + | "__builtin_read16_reversed", [BA(IR a1)], BR(IR res) -> + emit (Pmovzw_rm (res, linear_addr a1 _0)); emit (Pbswap16 res) - | "__builtin_read32_reversed", [IR a1], [IR res] -> - let addr = Addrmode(Some a1,None,Coq_inl _0) in - emit (Pmov_rm (res,addr)); + | "__builtin_read32_reversed", [BA(IR a1)], BR(IR res) -> + emit (Pmov_rm (res, linear_addr a1 _0)); emit (Pbswap res) - | "__builtin_write16_reversed", [IR a1; IR a2], _ -> + | "__builtin_write16_reversed", [BA(IR a1); BA(IR a2)], _ -> let tmp = if a1 = ECX then EDX else ECX in if a2 <> tmp then emit (Pmov_rr (tmp,a2)); emit (Pbswap16 tmp); - emit (Pmovw_mr (linear_addr a1 _0,tmp)) - | "__builtin_write32_reversed", [IR a1; IR a2], _ -> + emit (Pmovw_mr (linear_addr a1 _0, tmp)) + | "__builtin_write32_reversed", [BA(IR a1); BA(IR a2)], _ -> let tmp = if a1 = ECX then EDX else ECX in - let addr = Addrmode(Some a1,None,Coq_inl _0) in if a2 <> tmp then emit (Pmov_rr (tmp,a2)); emit (Pbswap tmp); - emit (Pmov_mr (addr,tmp)) + emit (Pmov_mr (linear_addr a1 _0, tmp)) (* Vararg stuff *) - | "__builtin_va_start", [IR a], _ -> + | "__builtin_va_start", [BA(IR a)], _ -> expand_builtin_va_start a (* Synchronization *) | "__builtin_membar", [], _ -> () (* Catch-all *) | _ -> - invalid_arg ("unrecognized builtin " ^ name) - + raise (Error ("unrecognized builtin " ^ name)) +(* Expansion of instructions *) let expand_instruction instr = match instr with @@ -365,10 +373,6 @@ let expand_instruction instr = expand_builtin_vload chunk args res | EF_vstore chunk -> expand_builtin_vstore chunk args - | EF_vload_global(chunk, id, ofs) -> - expand_builtin_vload_global chunk id ofs args res - | EF_vstore_global(chunk, id, ofs) -> - expand_builtin_vstore_global chunk id ofs args | EF_memcpy(sz, al) -> expand_builtin_memcpy (Int32.to_int (camlint_of_coqint sz)) @@ -376,22 +380,48 @@ let expand_instruction instr = args | EF_annot_val(txt, targ) -> expand_annot_val txt targ args res - | EF_inline_asm(txt, sg, clob) -> + | EF_annot _ | EF_debug _ | EF_inline_asm _ -> emit instr - | _ -> assert false + | _ -> + assert false end | _ -> emit instr -let expand_program p = p +let expand_function fn = + try + set_current_function fn; + List.iter expand_instruction fn.fn_code; + Errors.OK (get_current_function ()) + with Error s -> + Errors.Error (Errors.msg (coqstring_of_camlstring s)) +let expand_fundef = function + | Internal f -> + begin match expand_function f with + | Errors.OK tf -> Errors.OK (Internal tf) + | Errors.Error msg -> Errors.Error msg + end + | External ef -> + Errors.OK (External ef) + +let expand_program (p: Asm.program) : Asm.program Errors.res = + AST.transform_partial_program expand_fundef p let expand_function fn = - set_current_function fn; - List.iter expand_instruction fn.fn_code; - get_current_function () + try + set_current_function fn; + List.iter expand_instruction fn.fn_code; + Errors.OK (get_current_function ()) + with Error s -> + Errors.Error (Errors.msg (coqstring_of_camlstring s)) let expand_fundef = function - | Internal f -> Internal (expand_function f) - | External ef -> External ef + | Internal f -> + begin match expand_function f with + | Errors.OK tf -> Errors.OK (Internal tf) + | Errors.Error msg -> Errors.Error msg + end + | External ef -> + Errors.OK (External ef) -let expand_program (p: Asm.program) : Asm.program = - AST.transform_program expand_fundef p +let expand_program (p: Asm.program) : Asm.program Errors.res = + AST.transform_partial_program expand_fundef p diff --git a/ia32/Asmgen.v b/ia32/Asmgen.v index 2c1afc11..1ccde43b 100644 --- a/ia32/Asmgen.v +++ b/ia32/Asmgen.v @@ -536,9 +536,7 @@ Definition transl_instr (f: Mach.function) (i: Mach.instruction) OK (Pfreeframe f.(fn_stacksize) f.(fn_retaddr_ofs) f.(fn_link_ofs) :: Pret :: k) | Mbuiltin ef args res => - OK (Pbuiltin ef (List.map preg_of args) (List.map preg_of res) :: k) - | Mannot ef args => - OK (Pannot ef (List.map (map_annot_arg preg_of) args) :: k) + OK (Pbuiltin ef (List.map (map_builtin_arg preg_of) args) (map_builtin_res preg_of res) :: k) end. (** Translation of a code sequence *) diff --git a/ia32/Asmgenproof.v b/ia32/Asmgenproof.v index 3570da2e..d91e17a2 100644 --- a/ia32/Asmgenproof.v +++ b/ia32/Asmgenproof.v @@ -671,53 +671,33 @@ Opaque loadind. rewrite Pregmap.gss. unfold Genv.symbol_address. rewrite symbols_preserved. rewrite H. auto. - (* Mbuiltin *) - inv AT. monadInv H3. + inv AT. monadInv H4. exploit functions_transl; eauto. intro FN. - generalize (transf_function_no_overflow _ _ H2); intro NOOV. - exploit external_call_mem_extends'; eauto. eapply preg_vals; eauto. + generalize (transf_function_no_overflow _ _ H3); intro NOOV. + exploit builtin_args_match; eauto. intros [vargs' [P Q]]. + exploit external_call_mem_extends; eauto. intros [vres' [m2' [A [B [C D]]]]]. left. econstructor; split. apply plus_one. eapply exec_step_builtin. eauto. eauto. eapply find_instr_tail; eauto. - eapply external_call_symbols_preserved'; eauto. + erewrite <- sp_val by eauto. + eapply eval_builtin_args_preserved with (ge1 := ge); eauto. exact symbols_preserved. + eapply external_call_symbols_preserved; eauto. exact symbols_preserved. exact public_preserved. exact varinfo_preserved. eauto. econstructor; eauto. instantiate (2 := tf); instantiate (1 := x). unfold nextinstr_nf, nextinstr. rewrite Pregmap.gss. - rewrite undef_regs_other. rewrite set_pregs_other_2. rewrite undef_regs_other_2. - rewrite <- H0. simpl. econstructor; eauto. + rewrite undef_regs_other. rewrite set_res_other. rewrite undef_regs_other_2. + rewrite <- H1. simpl. econstructor; eauto. eapply code_tail_next_int; eauto. rewrite preg_notin_charact. intros. auto with asmgen. - rewrite preg_notin_charact. intros. auto with asmgen. auto with asmgen. simpl; intros. intuition congruence. - apply agree_nextinstr_nf. eapply agree_set_mregs; auto. + apply agree_nextinstr_nf. eapply agree_set_res; auto. eapply agree_undef_regs; eauto. intros; apply undef_regs_other_2; auto. congruence. -- (* Mannot *) - inv AT. monadInv H4. - exploit functions_transl; eauto. intro FN. - generalize (transf_function_no_overflow _ _ H3); intro NOOV. - exploit annot_args_match; eauto. intros [vargs' [P Q]]. - exploit external_call_mem_extends; eauto. - intros [vres' [m2' [A [B [C D]]]]]. - left. econstructor; split. apply plus_one. - eapply exec_step_annot. eauto. eauto. - eapply find_instr_tail; eauto. eauto. - erewrite <- sp_val by eauto. - eapply eval_annot_args_preserved with (ge1 := ge); eauto. - exact symbols_preserved. - eapply external_call_symbols_preserved; eauto. - exact symbols_preserved. exact public_preserved. exact varinfo_preserved. - eapply match_states_intro with (ep := false); eauto with coqlib. - unfold nextinstr. rewrite Pregmap.gss. - rewrite <- H1; simpl. econstructor; eauto. - eapply code_tail_next_int; eauto. - apply agree_nextinstr. auto. - congruence. - - (* Mgoto *) assert (f0 = f) by congruence. subst f0. inv AT. monadInv H4. diff --git a/ia32/Machregs.v b/ia32/Machregs.v index 65e27599..ace193b7 100644 --- a/ia32/Machregs.v +++ b/ia32/Machregs.v @@ -137,7 +137,6 @@ Definition destroyed_by_builtin (ef: external_function): list mreg := | EF_memcpy sz al => if zle sz 32 then CX :: X7 :: nil else CX :: SI :: DI :: nil | EF_vstore (Mint8unsigned|Mint8signed) => AX :: CX :: nil - | EF_vstore_global (Mint8unsigned|Mint8signed) _ _ => AX :: nil | EF_builtin id sg => if ident_eq id builtin_write16_reversed || ident_eq id builtin_write32_reversed @@ -267,3 +266,15 @@ Definition two_address_op (op: operation) : bool := | Ocmp c => false end. +(* Constraints on constant propagation for builtins *) + +Definition builtin_constraints (ef: external_function) : + list builtin_arg_constraint := + match ef with + | EF_vload _ => OK_addrany :: nil + | EF_vstore _ => OK_addrany :: OK_default :: nil + | EF_memcpy _ _ => OK_addrany :: OK_addrany :: nil + | EF_annot txt targs => map (fun _ => OK_all) targs + | EF_debug kind txt targs => map (fun _ => OK_all) targs + | _ => nil + end. diff --git a/ia32/SelectOp.vp b/ia32/SelectOp.vp index 74e3fbd7..bc331b9c 100644 --- a/ia32/SelectOp.vp +++ b/ia32/SelectOp.vp @@ -507,17 +507,17 @@ Nondetfunction addressing (chunk: memory_chunk) (e: expr) := | _ => (Aindexed Int.zero, e:::Enil) end. -(** ** Arguments of annotations *) +(** ** Arguments of builtins *) -Nondetfunction annot_arg (e: expr) := +Nondetfunction builtin_arg (e: expr) := match e with - | Eop (Ointconst n) Enil => AA_int n - | Eop (Olea (Aglobal id ofs)) Enil => AA_addrglobal id ofs - | Eop (Olea (Ainstack ofs)) Enil => AA_addrstack ofs + | Eop (Ointconst n) Enil => BA_int n + | Eop (Olea (Aglobal id ofs)) Enil => BA_addrglobal id ofs + | Eop (Olea (Ainstack ofs)) Enil => BA_addrstack ofs | Eop Omakelong (Eop (Ointconst h) Enil ::: Eop (Ointconst l) Enil ::: Enil) => - AA_long (Int64.ofwords h l) - | Eop Omakelong (h ::: l ::: Enil) => AA_longofwords (AA_base h) (AA_base l) - | Eload chunk (Aglobal id ofs) Enil => AA_loadglobal chunk id ofs - | Eload chunk (Ainstack ofs) Enil => AA_loadstack chunk ofs - | _ => AA_base e + BA_long (Int64.ofwords h l) + | Eop Omakelong (h ::: l ::: Enil) => BA_splitlong (BA h) (BA l) + | Eload chunk (Aglobal id ofs) Enil => BA_loadglobal chunk id ofs + | Eload chunk (Ainstack ofs) Enil => BA_loadstack chunk ofs + | _ => BA e end. diff --git a/ia32/SelectOpproof.v b/ia32/SelectOpproof.v index 50f0d9b6..d40ec7af 100644 --- a/ia32/SelectOpproof.v +++ b/ia32/SelectOpproof.v @@ -898,12 +898,12 @@ Proof. exists (v :: nil); split. constructor; auto. constructor. subst; simpl. rewrite Int.add_zero; auto. Qed. -Theorem eval_annot_arg: +Theorem eval_builtin_arg: forall a v, eval_expr ge sp e m nil a v -> - CminorSel.eval_annot_arg ge sp e m (annot_arg a) v. + CminorSel.eval_builtin_arg ge sp e m (builtin_arg a) v. Proof. - intros until v. unfold annot_arg; case (annot_arg_match a); intros; InvEval. + intros until v. unfold builtin_arg; case (builtin_arg_match a); intros; InvEval. - constructor. - constructor. - constructor. diff --git a/ia32/TargetPrinter.ml b/ia32/TargetPrinter.ml index 992c97e2..d1e213e2 100644 --- a/ia32/TargetPrinter.ml +++ b/ia32/TargetPrinter.ml @@ -337,17 +337,6 @@ module Target(System: SYSTEM):TARGET = - inlined by the compiler: take their arguments in arbitrary registers; preserve all registers except ECX, EDX, XMM6 and XMM7. *) -(* Handling of annotations *) - - let print_annot_stmt oc txt targs args = - if Str.string_match re_file_line txt 0 then begin - print_file_line oc (Str.matched_group 1 txt) - (int_of_string (Str.matched_group 2 txt)) - end else begin - fprintf oc "%s annotation: " comment; - print_annot_stmt preg "%esp" oc txt targs args - end - (* Handling of varargs *) let print_builtin_va_start oc r = @@ -657,6 +646,12 @@ module Target(System: SYSTEM):TARGET = assert false | Pbuiltin(ef, args, res) -> begin match ef with + | EF_annot(txt, targs) -> + fprintf oc "%s annotation: " comment; + print_annot_text preg "%esp" oc (extern_atom txt) args + | EF_debug(kind, txt, targs) -> + print_debug_info comment print_file_line preg "%esp" oc + (P.to_int kind) (extern_atom txt) args | EF_inline_asm(txt, sg, clob) -> fprintf oc "%s begin inline assembly\n\t" comment; print_inline_asm preg oc (extern_atom txt) sg args res; @@ -664,13 +659,6 @@ module Target(System: SYSTEM):TARGET = | _ -> assert false end - | Pannot(ef, args) -> - begin match ef with - | EF_annot(txt, targs) -> - print_annot_stmt oc (extern_atom txt) targs args - | _ -> - assert false - end let print_literal64 oc (lbl, n) = fprintf oc "%a: .quad 0x%Lx\n" label lbl n diff --git a/powerpc/Asm.v b/powerpc/Asm.v index b7656dc4..863ed6a1 100644 --- a/powerpc/Asm.v +++ b/powerpc/Asm.v @@ -167,6 +167,10 @@ Inductive instruction : Type := | Pcrxor: crbit -> crbit -> crbit -> instruction (**r xor between condition bits *) | Pdcbf: ireg -> ireg -> instruction (**r data cache flush *) | Pdcbi: ireg -> ireg -> instruction (**r data cache invalidate *) + | Pdcbt: int -> ireg -> ireg -> instruction (**r data cache block touch *) + | Pdcbtst: int -> ireg -> ireg -> instruction (**r data cache block touch *) + | Pdcbtls: int -> ireg -> ireg -> instruction (**r data cache block touch and lock *) + | Pdcbz: ireg -> ireg -> instruction (**r data cache block zero *) | Pdivw: ireg -> ireg -> ireg -> instruction (**r signed division *) | Pdivwu: ireg -> ireg -> ireg -> instruction (**r unsigned division *) | Peieio: instruction (**r EIEIO barrier *) @@ -204,6 +208,7 @@ Inductive instruction : Type := | Pfsel: freg -> freg -> freg -> freg -> instruction (**r FP conditional move *) | Pisync: instruction (**r ISYNC barrier *) | Picbi: ireg -> ireg -> instruction (**r instruction cache invalidate *) + | Picbtls: int -> ireg -> ireg -> instruction (**r instruction cache block touch and lock set *) | Plbz: ireg -> constant -> ireg -> instruction (**r load 8-bit unsigned int *) | Plbzx: ireg -> ireg -> ireg -> instruction (**r same, with 2 index regs *) | Plfd: freg -> constant -> ireg -> instruction (**r load 64-bit float *) @@ -226,12 +231,15 @@ Inductive instruction : Type := | Plwzx_a: ireg -> ireg -> ireg -> instruction (**r same, with 2 index regs *) | Plwarx: ireg -> ireg -> ireg -> instruction (**r load with reservation *) | Plwbrx: ireg -> ireg -> ireg -> instruction (**r load 32-bit int and reverse endianness *) + | Pmbar: int -> instruction (**r memory barrier *) | Pmfcr: ireg -> instruction (**r move condition register to reg *) | Pmfcrbit: ireg -> crbit -> instruction (**r move condition bit to reg (pseudo) *) | Pmflr: ireg -> instruction (**r move LR to reg *) | Pmr: ireg -> ireg -> instruction (**r integer move *) | Pmtctr: ireg -> instruction (**r move ireg to CTR *) | Pmtlr: ireg -> instruction (**r move ireg to LR *) + | Pmfspr: ireg -> int -> instruction (**r move from special register *) + | Pmtspr: int -> ireg -> instruction (**r move to special register *) | Pmulli: ireg -> ireg -> constant -> instruction (**r integer multiply immediate *) | Pmullw: ireg -> ireg -> ireg -> instruction (**r integer multiply *) | Pmulhw: ireg -> ireg -> ireg -> instruction (**r multiply high signed *) @@ -279,8 +287,7 @@ Inductive instruction : Type := | Pxori: ireg -> ireg -> constant -> instruction (**r bitwise xor with immediate *) | Pxoris: ireg -> ireg -> constant -> instruction (**r bitwise xor with immediate high *) | Plabel: label -> instruction (**r define a code label *) - | Pbuiltin: external_function -> list preg -> list preg -> instruction (**r built-in function (pseudo) *) - | Pannot: external_function -> list (annot_arg preg) -> instruction (**r annotation statement (pseudo) *) + | Pbuiltin: external_function -> list (builtin_arg preg) -> builtin_res preg -> instruction (**r built-in function (pseudo) *) | Pcfi_adjust: int -> instruction (**r .cfi_adjust debug directive *) | Pcfi_rel_offset: int -> instruction. (**r .cfi_rel_offset lr debug directive *) @@ -386,6 +393,15 @@ Fixpoint set_regs (rl: list preg) (vl: list val) (rs: regset) : regset := | _, _ => rs end. +(** Assigning the result of a builtin *) + +Fixpoint set_res (res: builtin_res preg) (v: val) (rs: regset) : regset := + match res with + | BR r => rs#r <- v + | BR_none => rs + | BR_splitlong hi lo => set_res lo (Val.loword v) (set_res hi (Val.hiword v) rs) + end. + Section RELSEM. (** Looking up instructions in a code sequence by position. *) @@ -852,16 +868,18 @@ Definition exec_instr (f: function) (i: instruction) (rs: regset) (m: mem) : out Next (nextinstr rs) m | Pbuiltin ef args res => Stuck (**r treated specially below *) - | Pannot ef args => - Stuck (**r treated specially below *) - (** The following instructions and directives are not generated directly by Asmgen, - so we do not model them. *) + (** The following instructions and directives are not generated + directly by [Asmgen], so we do not model them. *) | Pbdnz _ | Pcntlzw _ _ | Pcreqv _ _ _ | Pcrxor _ _ _ | Pdcbf _ _ | Pdcbi _ _ + | Pdcbt _ _ _ + | Pdcbtst _ _ _ + | Pdcbtls _ _ _ + | Pdcbz _ _ | Peieio | Pfctiw _ _ | Pfctiwz _ _ @@ -876,11 +894,15 @@ Definition exec_instr (f: function) (i: instruction) (rs: regset) (m: mem) : out | Plwarx _ _ _ | Plwbrx _ _ _ | Picbi _ _ + | Picbtls _ _ _ | Pisync | Plwsync | Plhbrx _ _ _ | Plwzu _ _ _ + | Pmbar _ | Pmfcr _ + | Pmfspr _ _ + | Pmtspr _ _ | Pstwbrx _ _ _ | Pstwcx_ _ _ _ | Pstfdu _ _ _ @@ -954,24 +976,16 @@ Inductive step: state -> trace -> state -> Prop := exec_instr f i rs m = Next rs' m' -> step (State rs m) E0 (State rs' m') | exec_step_builtin: - forall b ofs f ef args res rs m t vl rs' m', + forall b ofs f ef args res rs m vargs t vres rs' m', rs PC = Vptr b ofs -> Genv.find_funct_ptr ge b = Some (Internal f) -> find_instr (Int.unsigned ofs) f.(fn_code) = Some (Pbuiltin ef args res) -> - external_call' ef ge (map rs args) m t vl m' -> + eval_builtin_args ge rs (rs GPR1) m args vargs -> + external_call ef ge vargs m t vres m' -> rs' = nextinstr - (set_regs res vl + (set_res res vres (undef_regs (map preg_of (destroyed_by_builtin ef)) rs)) -> step (State rs m) t (State rs' m') - | exec_step_annot: - forall b ofs f ef args rs m vargs t v m', - rs PC = Vptr b ofs -> - Genv.find_funct_ptr ge b = Some (Internal f) -> - find_instr (Int.unsigned ofs) f.(fn_code) = Some (Pannot ef args) -> - eval_annot_args ge rs (rs GPR1) m args vargs -> - external_call ef ge vargs m t v m' -> - step (State rs m) t - (State (nextinstr rs) m') | exec_step_external: forall b ef args res rs m t rs' m', rs PC = Vptr b Int.zero -> @@ -1035,12 +1049,8 @@ Ltac Equalities := split. constructor. auto. discriminate. discriminate. - inv H11. - exploit external_call_determ'. eexact H4. eexact H9. intros [A B]. - split. auto. intros. destruct B; auto. subst. auto. - inv H12. - assert (vargs0 = vargs) by (eapply eval_annot_args_determ; eauto). subst vargs0. - exploit external_call_determ. eexact H5. eexact H13. intros [A B]. + assert (vargs0 = vargs) by (eapply eval_builtin_args_determ; eauto). subst vargs0. + exploit external_call_determ. eexact H5. eexact H11. intros [A B]. split. auto. intros. destruct B; auto. subst. auto. assert (args0 = args) by (eapply extcall_arguments_determ; eauto). subst args0. exploit external_call_determ'. eexact H3. eexact H8. intros [A B]. @@ -1048,7 +1058,6 @@ Ltac Equalities := (* trace length *) red; intros. inv H; simpl. omega. - inv H3; eapply external_call_trace_length; eauto. eapply external_call_trace_length; eauto. inv H2; eapply external_call_trace_length; eauto. (* initial states *) @@ -1068,4 +1077,4 @@ Definition data_preg (r: preg) : bool := | CR0_0 => false | CR0_1 => false | CR0_2 => false | CR0_3 => false | CARRY => false | _ => true - end.
\ No newline at end of file + end. diff --git a/powerpc/AsmToJSON.ml b/powerpc/AsmToJSON.ml index d66dd163..5f875ebf 100644 --- a/powerpc/AsmToJSON.ml +++ b/powerpc/AsmToJSON.ml @@ -158,7 +158,7 @@ let p_instruction oc ic = | Pandi_ (ir1,ir2,c) -> fprintf oc "{\"Instruction Name\":\"Pandi_\",\"Args\":[%a,%a,%a]}" p_ireg ir1 p_ireg ir2 p_constant c | Pandis_ (ir1,ir2,c) -> fprintf oc "{\"Instruction Name\":\"Pandis_\",\"Args\":[%a,%a,%a]}" p_ireg ir1 p_ireg ir2 p_constant c | Pb l -> fprintf oc "{\"Instruction Name\":\"Pb\",\"Args\":[%a]}" p_label l - | Pbctr s -> assert false (* Should not occur *) + | Pbctr s -> fprintf oc "{\"Instruction Name\":\"Pbctr\",\"Args\":[]}" | Pbctrl s -> fprintf oc "{\"Instruction Name\":\"Pbctrl\",\"Args\":[]}" | Pbdnz l -> fprintf oc "{\"Instruction Name\":\"Pbdnz\",\"Args\":[%a]}" p_label l | Pbf (c,l) -> fprintf oc "{\"Instruction Name\":\"Pbf\",\"Args\":[%a,%a]}" p_crbit c p_label l @@ -177,6 +177,10 @@ let p_instruction oc ic = | Pcrxor (cr1,cr2,cr3) -> fprintf oc "{\"Instruction Name\":\"Pcrxor\",\"Args\":[%a,%a,%a]}" p_crbit cr1 p_crbit cr2 p_crbit cr3 | Pdcbf (ir1,ir2) -> fprintf oc "{\"Instruction Name\":\"Pdcbf\",\"Args\":[%a,%a]}" p_ireg ir1 p_ireg ir2 | Pdcbi (ir1,ir2) -> fprintf oc "{\"Instruction Name\":\"Pdcbi\",\"Args\":[%a,%a]}" p_ireg ir1 p_ireg ir2 + | Pdcbt (n,ir1,ir2) -> fprintf oc "{\"Instruction Name\":\"Pdcbt\",\"Args\":[%a,%a,%a]}" p_int_constant n p_ireg ir1 p_ireg ir2 + | Pdcbtst (n,ir1,ir2) -> fprintf oc "{\"Instruction Name\":\"Pdcbtst\",\"Args\":[%a,%a,%a]}" p_int_constant n p_ireg ir1 p_ireg ir2 + | Pdcbtls (n,ir1,ir2) -> fprintf oc "{\"Instruction Name\":\"Pdcbtls\",\"Args\":[%a,%a,%a]}" p_int_constant n p_ireg ir1 p_ireg ir2 + | Pdcbz (ir1,ir2) -> fprintf oc "{\"Instruction Name\":\"Pdcbz\",\"Args\":[%a,%a]}" p_ireg ir1 p_ireg ir2 | Pdivw (ir1,ir2,ir3) -> fprintf oc "{\"Instruction Name\":\"Pdivw\",\"Args\":[%a,%a,%a]}" p_ireg ir1 p_ireg ir2 p_ireg ir3 | Pdivwu (ir1,ir2,ir3) -> fprintf oc "{\"Instruction Name\":\"Pdivwu\",\"Args\":[%a,%a,%a]}" p_ireg ir1 p_ireg ir2 p_ireg ir3 | Peieio -> fprintf oc "{\"Instruction Name\":\"Peieio,\"Args\":[]}" @@ -213,10 +217,11 @@ let p_instruction oc ic = | Pfres (fr1,fr2) -> fprintf oc "{\"Instruction Name\":\"Pfres\",\"Args\":[%a,%a]}" p_freg fr1 p_freg fr2 | Pfsel (fr1,fr2,fr3,fr4) -> fprintf oc "{\"Instruction Name\":\"Pfsel\",\"Args\":[%a,%a,%a,%a]}" p_freg fr1 p_freg fr2 p_freg fr3 p_freg fr4 | Picbi (ir1,ir2) -> fprintf oc "{\"Instruction Name\":\"Picbi\",\"Args\":[%a,%a]}" p_ireg ir1 p_ireg ir2 + | Picbtls (n,ir1,ir2) -> fprintf oc "{\"Instruction Name\":\"Picbtls\",\"Args\":[%a,%a,%a]}" p_int_constant n p_ireg ir1 p_ireg ir2 | Pisync -> fprintf oc "{\"Instruction Name\":\"Pisync\",\"Args\":[]}" | Plwsync -> fprintf oc "{\"Instruction Name\":\"Plwsync\",\"Args\":[]}" | Plbz (ir1,c,ir2) -> fprintf oc "{\"Instruction Name\":\"Plbz\",\"Args\":[%a,%a,%a]}" p_ireg ir1 p_constant c p_ireg ir2 - | Plbzx (ir1,ir2,ir3) -> fprintf oc "{\"Instruction Name\":\"Pblzx\",\"Args\":[%a,%a,%a]}" p_ireg ir1 p_ireg ir2 p_ireg ir3 + | Plbzx (ir1,ir2,ir3) -> fprintf oc "{\"Instruction Name\":\"Plbzx\",\"Args\":[%a,%a,%a]}" p_ireg ir1 p_ireg ir2 p_ireg ir3 | Plfd (fr,c,ir) | Plfd_a (fr,c,ir) -> fprintf oc "{\"Instruction Name\":\"Plfd\",\"Args\":[%a,%a,%a]}" p_freg fr p_constant c p_ireg ir | Plfdx (fr,ir1,ir2) @@ -237,14 +242,17 @@ let p_instruction oc ic = | Plwzx_a (ir1,ir2,ir3) -> fprintf oc "{\"Instruction Name\":\"Plwzx\",\"Args\":[%a,%a,%a]}" p_ireg ir1 p_ireg ir2 p_ireg ir3 | Plwarx (ir1,ir2,ir3) -> fprintf oc "{\"Instruction Name\":\"Plwarx\",\"Args\":[%a,%a,%a]}" p_ireg ir1 p_ireg ir2 p_ireg ir3 | Plwbrx (ir1,ir2,ir3) -> fprintf oc "{\"Instruction Name\":\"Plwbrx\",\"Args\":[%a,%a,%a]}" p_ireg ir1 p_ireg ir2 p_ireg ir3 + | Pmbar c -> fprintf oc "{\"Instruction Name\":\"Pmbar\",\"Args\":[%a]}" p_int_constant c | Pmfcr ir -> fprintf oc "{\"Instruction Name\":\"Pmfcr\",\"Args\":[%a]}" p_ireg ir | Pmfcrbit (ir,crb) -> assert false (* Should not occur *) | Pmflr ir -> fprintf oc "{\"Instruction Name\":\"Pmflr\",\"Args\":[%a]}" p_ireg ir | Pmr (ir1,ir2) -> fprintf oc "{\"Instruction Name\":\"Pmr\",\"Args\":[%a,%a]}" p_ireg ir1 p_ireg ir2 | Pmtctr ir -> fprintf oc "{\"Instruction Name\":\"Pmtctr\",\"Args\":[%a]}" p_ireg ir | Pmtlr ir -> fprintf oc "{\"Instruction Name\":\"Pmtlr\",\"Args\":[%a]}" p_ireg ir + | Pmfspr(ir, n) -> fprintf oc "{\"Instruction Name\":\"Pmfspr\",\"Args\":[%a,%a]}" p_ireg ir p_int_constant n + | Pmtspr(n, ir) -> fprintf oc "{\"Instruction Name\":\"Pmtspr\",\"Args\":[%a,%a]}" p_int_constant n p_ireg ir | Pmulli (ir1,ir2,c) -> fprintf oc "{\"Instruction Name\":\"Pmulli\",\"Args\":[%a,%a,%a]}" p_ireg ir1 p_ireg ir2 p_constant c - | Pmullw (ir1,ir2,ir3) -> fprintf oc "{\"Instruction Name\":\"Pmulw\",\"Args\":[%a,%a,%a]}" p_ireg ir1 p_ireg ir2 p_ireg ir3 + | Pmullw (ir1,ir2,ir3) -> fprintf oc "{\"Instruction Name\":\"Pmullw\",\"Args\":[%a,%a,%a]}" p_ireg ir1 p_ireg ir2 p_ireg ir3 | Pmulhw (ir1,ir2,ir3) -> fprintf oc "{\"Instruction Name\":\"Pmulhw\",\"Args\":[%a,%a,%a]}" p_ireg ir1 p_ireg ir2 p_ireg ir3 | Pmulhwu (ir1,ir2,ir3) -> fprintf oc "{\"Instruction Name\":\"Pmulhwu\",\"Args\":[%a,%a,%a]}" p_ireg ir1 p_ireg ir2 p_ireg ir3 | Pnand (ir1,ir2,ir3) -> fprintf oc "{\"Instruction Name\":\"Pnand\",\"Args\":[%a,%a,%a]}" p_ireg ir1 p_ireg ir2 p_ireg ir3 @@ -263,7 +271,7 @@ let p_instruction oc ic = | Pstbx (ir1,ir2,ir3) -> fprintf oc "{\"Instruction Name\":\"Pstbx\",\"Args\":[%a,%a,%a]}" p_ireg ir1 p_ireg ir2 p_ireg ir3 | Pstfd (fr,c,ir) | Pstfd_a (fr,c,ir) -> fprintf oc "{\"Instruction Name\":\"Pstfd\",\"Args\":[%a,%a,%a]}" p_freg fr p_constant c p_ireg ir - | Pstfdu (fr,c,ir) -> fprintf oc "{\"Instruction Name\":\"Pstdu\",\"Args\":[%a,%a,%a]}" p_freg fr p_constant c p_ireg ir + | Pstfdu (fr,c,ir) -> fprintf oc "{\"Instruction Name\":\"Pstfdu\",\"Args\":[%a,%a,%a]}" p_freg fr p_constant c p_ireg ir | Pstfdx (fr,ir1,ir2) | Pstfdx_a (fr,ir1,ir2) -> fprintf oc "{\"Instruction Name\":\"Pstfdx\",\"Args\":[%a,%a,%a]}" p_freg fr p_ireg ir1 p_ireg ir2 | Pstfs (fr,c,ir) -> fprintf oc "{\"Instruction Name\":\"Pstfs\",\"Args\":[%a,%a,%a]}" p_freg fr p_constant c p_ireg ir @@ -289,7 +297,9 @@ let p_instruction oc ic = | Pxori (ir1,ir2,c) -> fprintf oc "{\"Instruction Name\":\"Pxori\",\"Args\":[%a,%a,%a]}" p_ireg ir1 p_ireg ir2 p_constant c | Pxoris (ir1,ir2,c) -> fprintf oc "{\"Instruction Name\":\"Pxoris\",\"Args\":[%a,%a,%a]}" p_ireg ir1 p_ireg ir2 p_constant c | Plabel l -> fprintf oc "{\"Instruction Name\":\"Plabel\",\"Args\":[%a]}" p_label l - | Pbuiltin (ef,args1,args2) -> + | Pbuiltin (ef,args1,args2) -> () +(* FIXME *) +(* begin match ef with | EF_inline_asm (i,s,il) -> fprintf oc "{\"Instruction Name\":\"Inline_asm\",\"Args\":[%a%a%a%a]}" p_atom_constant i (p_list_cont p_char_list) il @@ -297,7 +307,8 @@ let p_instruction oc ic = | _ -> (* Should all be folded away *) assert false end - | Pannot _ (* We do not check the annotations *) +*) +(* END FIXME *) | Pcfi_adjust _ (* Only debug relevant *) | Pcfi_rel_offset _ -> () (* Only debug relevant *) @@ -329,7 +340,7 @@ let p_fundef oc (name,f) = let alignment = atom_alignof name and inline = atom_is_inline name and static = atom_is_static name - and instr = List.filter (function Pannot _ | Pcfi_adjust _ | Pcfi_rel_offset _ -> false | _ -> true) f.fn_code in + and instr = List.filter (function Pbuiltin _| Pcfi_adjust _ | Pcfi_rel_offset _ -> false | _ -> true) f.fn_code in let c_section,l_section,j_section = match (atom_sections name) with [a;b;c] -> a,b,c | _ -> assert false in fprintf oc "{\"Fun Name\":%a,\n\"Fun Storage Class\":%a,\n\"Fun Alignment\":%a,\n\"Fun Section Code\":%a,\"Fun Section Literals\":%a,\"Fun Section Jumptable\":%a,\n\"Fun Inline\":%B,\n\"Fun Code\":%a}\n" p_atom name p_storage static p_int_opt alignment diff --git a/powerpc/Asmexpand.ml b/powerpc/Asmexpand.ml index ae4d694a..3e57cdbf 100644 --- a/powerpc/Asmexpand.ml +++ b/powerpc/Asmexpand.ml @@ -21,6 +21,7 @@ open Memdata open Asm open Asmexpandaux +exception Error of string (* Useful constants and helper functions *) @@ -44,14 +45,14 @@ let emit_addimm rd rs n = (* Handling of annotations *) let expand_annot_val txt targ args res = - emit (Pannot(EF_annot(txt, [targ]), List.map (fun r -> AA_base r) args)); + emit (Pbuiltin(EF_annot(txt, [targ]), args, BR_none)); begin match args, res with - | [IR src], [IR dst] -> + | [BA(IR src)], BR(IR dst) -> if dst <> src then emit (Pmr(dst, src)) - | [FR src], [FR dst] -> + | [BA(FR src)], BR(FR dst) -> if dst <> src then emit (Pfmr(dst, src)) | _, _ -> - assert false + raise (Error "ill-formed __builtin_annot_val") end (* Handling of memcpy *) @@ -62,34 +63,64 @@ let expand_annot_val txt targ args res = So, use 64-bit accesses only if alignment >= 4. Note that lfd and stfd cannot trap on ill-formed floats. *) +let offset_in_range ofs = + Int.eq (Asmgen.high_s ofs) Int.zero + +let memcpy_small_arg sz arg tmp = + match arg with + | BA (IR r) -> + (r, _0) + | BA_addrstack ofs -> + if offset_in_range ofs + && offset_in_range (Int.add ofs (Int.repr (Z.of_uint sz))) + then (GPR1, ofs) + else begin emit_addimm tmp GPR1 ofs; (tmp, _0) end + | _ -> + assert false + let expand_builtin_memcpy_small sz al src dst = - let rec copy ofs sz = + let (tsrc, tdst) = + if dst <> BA (IR GPR11) then (GPR11, GPR12) else (GPR12, GPR11) in + let (rsrc, osrc) = memcpy_small_arg sz src tsrc in + let (rdst, odst) = memcpy_small_arg sz dst tdst in + let rec copy osrc odst sz = if sz >= 8 && al >= 4 && !Clflags.option_ffpu then begin - emit (Plfd(FPR13, Cint ofs, src)); - emit (Pstfd(FPR13, Cint ofs, dst)); - copy (Int.add ofs _8) (sz - 8) + emit (Plfd(FPR13, Cint osrc, rsrc)); + emit (Pstfd(FPR13, Cint odst, rdst)); + copy (Int.add osrc _8) (Int.add odst _8) (sz - 8) end else if sz >= 4 then begin - emit (Plwz(GPR0, Cint ofs, src)); - emit (Pstw(GPR0, Cint ofs, dst)); - copy (Int.add ofs _4) (sz - 4) + emit (Plwz(GPR0, Cint osrc, rsrc)); + emit (Pstw(GPR0, Cint odst, rdst)); + copy (Int.add osrc _4) (Int.add odst _4) (sz - 4) end else if sz >= 2 then begin - emit (Plhz(GPR0, Cint ofs, src)); - emit (Psth(GPR0, Cint ofs, dst)); - copy (Int.add ofs _2) (sz - 2) + emit (Plhz(GPR0, Cint osrc, rsrc)); + emit (Psth(GPR0, Cint odst, rdst)); + copy (Int.add osrc _2) (Int.add odst _2) (sz - 2) end else if sz >= 1 then begin - emit (Plbz(GPR0, Cint ofs, src)); - emit (Pstb(GPR0, Cint ofs, dst)); - copy (Int.add ofs _1) (sz - 1) + emit (Plbz(GPR0, Cint osrc, rsrc)); + emit (Pstb(GPR0, Cint odst, rdst)); + copy (Int.add osrc _1) (Int.add odst _1) (sz - 1) end in - copy _0 sz + copy osrc odst sz + +let memcpy_big_arg arg tmp = + (* Set [tmp] to the value of [arg] minus 4 *) + match arg with + | BA (IR r) -> + emit (Paddi(tmp, r, Cint _m4)) + | BA_addrstack ofs -> + emit_addimm tmp GPR1 (Int.add ofs _m4) + | _ -> + assert false let expand_builtin_memcpy_big sz al src dst = assert (sz >= 4); emit_loadimm GPR0 (Z.of_uint (sz / 4)); emit (Pmtctr GPR0); - let (s,d) = if dst <> GPR11 then (GPR11, GPR12) else (GPR12, GPR11) in - emit (Paddi(s, src, Cint _m4)); - emit (Paddi(d, dst, Cint _m4)); + let (s, d) = + if dst <> BA (IR GPR11) then (GPR11, GPR12) else (GPR12, GPR11) in + memcpy_big_arg src s; + memcpy_big_arg dst d; let lbl = new_label() in emit (Plabel lbl); emit (Plwzu(GPR0, Cint _4, s)); @@ -109,7 +140,7 @@ let expand_builtin_memcpy_big sz al src dst = let expand_builtin_memcpy sz al args = let (dst, src) = - match args with [IR d; IR s] -> (d, s) | _ -> assert false in + match args with [d; s] -> (d, s) | _ -> assert false in if sz <= (if !Clflags.option_ffpu && al >= 4 then if !Clflags.option_Osize then 35 else 51 else if !Clflags.option_Osize then 19 else 27) @@ -118,140 +149,131 @@ let expand_builtin_memcpy sz al args = (* Handling of volatile reads and writes *) -let expand_builtin_vload_common chunk base offset res = +let offset_constant cst delta = + match cst with + | Cint n -> + let n' = Int.add n delta in + if offset_in_range n' then Some (Cint n') else None + | Csymbol_sda(id, ofs) -> + Some (Csymbol_sda(id, Int.add ofs delta)) + | _ -> None + +let rec expand_builtin_vload_common chunk base offset res = match chunk, res with - | Mint8unsigned, IR res -> + | Mint8unsigned, BR(IR res) -> emit (Plbz(res, offset, base)) - | Mint8signed, IR res -> + | Mint8signed, BR(IR res) -> emit (Plbz(res, offset, base)); emit (Pextsb(res, res)) - | Mint16unsigned, IR res -> + | Mint16unsigned, BR(IR res) -> emit (Plhz(res, offset, base)) - | Mint16signed, IR res -> + | Mint16signed, BR(IR res) -> emit (Plha(res, offset, base)) - | (Mint32 | Many32), IR res -> + | (Mint32 | Many32), BR(IR res) -> emit (Plwz(res, offset, base)) - | Mfloat32, FR res -> + | Mfloat32, BR(FR res) -> emit (Plfs(res, offset, base)) - | (Mfloat64 | Many64), FR res -> + | (Mfloat64 | Many64), BR(FR res) -> emit (Plfd(res, offset, base)) - (* Mint64 is special-cased below *) - | _ -> + | Mint64, BR_splitlong(BR(IR hi), BR(IR lo)) -> + begin match offset_constant offset _4 with + | Some offset' -> + if hi <> base then begin + emit (Plwz(hi, offset, base)); + emit (Plwz(lo, offset', base)) + end else begin + emit (Plwz(lo, offset', base)); + emit (Plwz(hi, offset, base)) + end + | None -> + emit (Paddi(GPR11, base, offset)); + expand_builtin_vload_common chunk GPR11 (Cint _0) res + end + | _, _ -> assert false let expand_builtin_vload chunk args res = - begin match args, res with - | [IR addr], [res] when chunk <> Mint64 -> + match args with + | [BA(IR addr)] -> expand_builtin_vload_common chunk addr (Cint _0) res - | [IR addr], [IR res1; IR res2] when chunk = Mint64 -> - if addr <> res1 then begin - emit (Plwz(res1, Cint _0, addr)); - emit (Plwz(res2, Cint _4, addr)) + | [BA_addrstack ofs] -> + if offset_in_range ofs then + expand_builtin_vload_common chunk GPR1 (Cint ofs) res + else begin + emit_addimm GPR11 GPR1 ofs; + expand_builtin_vload_common chunk GPR11 (Cint _0) res + end + | [BA_addrglobal(id, ofs)] -> + if symbol_is_small_data id ofs then + expand_builtin_vload_common chunk GPR0 (Csymbol_sda(id, ofs)) res + else if symbol_is_rel_data id ofs then begin + emit (Paddis(GPR11, GPR0, Csymbol_rel_high(id, ofs))); + expand_builtin_vload_common chunk GPR11 (Csymbol_rel_low(id, ofs)) res end else begin - emit (Plwz(res2, Cint _4, addr)); - emit (Plwz(res1, Cint _0, addr)) + emit (Paddis(GPR11, GPR0, Csymbol_high(id, ofs))); + expand_builtin_vload_common chunk GPR11 (Csymbol_low(id, ofs)) res end | _ -> assert false - end - -let expand_builtin_vload_global chunk id ofs args res = - begin match res with - | [res] when chunk <> Mint64 -> - emit (Paddis(GPR11, GPR0, Csymbol_high(id, ofs))); - expand_builtin_vload_common chunk GPR11 (Csymbol_low(id, ofs)) res - | [IR res1; IR res2] when chunk = Mint64 -> - emit (Paddis(res1, GPR0, Csymbol_high(id, ofs))); - emit (Plwz(res1, Csymbol_low(id, ofs), res1)); - let ofs = Int.add ofs _4 in - emit (Paddis(res2, GPR0, Csymbol_high(id, ofs))); - emit (Plwz(res2, Csymbol_low(id, ofs), res2)) - | _ -> - assert false - end - -let expand_builtin_vload_sda chunk id ofs args res = - begin match res with - | [res] when chunk <> Mint64 -> - expand_builtin_vload_common chunk GPR0 (Csymbol_sda(id, ofs)) res - | [IR res1; IR res2] when chunk = Mint64 -> - emit (Plwz(res1, Csymbol_sda(id, ofs), GPR0)); - let ofs = Int.add ofs _4 in - emit (Plwz(res2, Csymbol_sda(id, ofs), GPR0)) - | _ -> - assert false - end -let expand_builtin_vload_rel chunk id ofs args res = - emit (Paddis(GPR11, GPR0, Csymbol_rel_high(id, ofs))); - emit (Paddi(GPR11, GPR11, Csymbol_rel_low(id, ofs))); - expand_builtin_vload chunk [IR GPR11] res +let temp_for_vstore src = + let rl = AST.params_of_builtin_arg src in + if not (List.mem (IR GPR11) rl) then GPR11 + else if not (List.mem (IR GPR12) rl) then GPR12 + else GPR10 let expand_builtin_vstore_common chunk base offset src = match chunk, src with - | (Mint8signed | Mint8unsigned), IR src -> + | (Mint8signed | Mint8unsigned), BA(IR src) -> emit (Pstb(src, offset, base)) - | (Mint16signed | Mint16unsigned), IR src -> + | (Mint16signed | Mint16unsigned), BA(IR src) -> emit (Psth(src, offset, base)) - | (Mint32 | Many32), IR src -> + | (Mint32 | Many32), BA(IR src) -> emit (Pstw(src, offset, base)) - | Mfloat32, FR src -> + | Mfloat32, BA(FR src) -> emit (Pstfs(src, offset, base)) - | (Mfloat64 | Many64), FR src -> + | (Mfloat64 | Many64), BA(FR src) -> emit (Pstfd(src, offset, base)) - (* Mint64 is special-cased below *) - | _ -> + | Mint64, BA_splitlong(BA(IR hi), BA(IR lo)) -> + begin match offset_constant offset _4 with + | Some offset' -> + emit (Pstw(hi, offset, base)); + emit (Pstw(lo, offset', base)) + | None -> + let tmp = temp_for_vstore src in + emit (Paddi(tmp, base, offset)); + emit (Pstw(hi, Cint _0, tmp)); + emit (Pstw(lo, Cint _4, tmp)) + end + | _, _ -> assert false let expand_builtin_vstore chunk args = - begin match args with - | [IR addr; src] when chunk <> Mint64 -> + match args with + | [BA(IR addr); src] -> expand_builtin_vstore_common chunk addr (Cint _0) src - | [IR addr; IR src1; IR src2] when chunk = Mint64 -> - emit (Pstw(src1, Cint _0, addr)); - emit (Pstw(src2, Cint _4, addr)) - | _ -> - assert false - end - -let expand_builtin_vstore_global chunk id ofs args = - begin match args with - | [src] when chunk <> Mint64 -> - let tmp = if src = IR GPR11 then GPR12 else GPR11 in - emit (Paddis(tmp, GPR0, Csymbol_high(id, ofs))); - expand_builtin_vstore_common chunk tmp (Csymbol_low(id, ofs)) src - | [IR src1; IR src2] when chunk = Mint64 -> - let tmp = - if not (List.mem GPR12 [src1; src2]) then GPR12 else - if not (List.mem GPR11 [src1; src2]) then GPR11 else GPR10 in - emit (Paddis(tmp, GPR0, Csymbol_high(id, ofs))); - emit (Pstw(src1, Csymbol_low(id, ofs), tmp)); - let ofs = Int.add ofs _4 in - emit (Paddis(tmp, GPR0, Csymbol_high(id, ofs))); - emit (Pstw(src2, Csymbol_low(id, ofs), tmp)) - | _ -> - assert false - end - -let expand_builtin_vstore_sda chunk id ofs args = - begin match args with - | [src] when chunk <> Mint64 -> - expand_builtin_vstore_common chunk GPR0 (Csymbol_sda(id, ofs)) src - | [IR src1; IR src2] when chunk = Mint64 -> - emit (Pstw(src1, Csymbol_sda(id, ofs), GPR0)); - let ofs = Int.add ofs _4 in - emit (Pstw(src2, Csymbol_sda(id, ofs), GPR0)) + | [BA_addrstack ofs; src] -> + if offset_in_range ofs then + expand_builtin_vstore_common chunk GPR1 (Cint ofs) src + else begin + let tmp = temp_for_vstore src in + emit_addimm tmp GPR1 ofs; + expand_builtin_vstore_common chunk tmp (Cint _0) src + end + | [BA_addrglobal(id, ofs); src] -> + if symbol_is_small_data id ofs then + expand_builtin_vstore_common chunk GPR0 (Csymbol_sda(id, ofs)) src + else if symbol_is_rel_data id ofs then begin + let tmp = temp_for_vstore src in + emit (Paddis(tmp, GPR0, Csymbol_rel_high(id, ofs))); + expand_builtin_vstore_common chunk tmp (Csymbol_rel_low(id, ofs)) src + end else begin + let tmp = temp_for_vstore src in + emit (Paddis(tmp, GPR0, Csymbol_high(id, ofs))); + expand_builtin_vstore_common chunk tmp (Csymbol_low(id, ofs)) src + end | _ -> assert false - end - -let expand_builtin_vstore_rel chunk id ofs args = - let tmp = - if not (List.mem (IR GPR12) args) then GPR12 else - if not (List.mem (IR GPR11) args) then GPR11 else GPR10 in - emit (Paddis(tmp, GPR0, Csymbol_rel_high(id, ofs))); - emit (Paddi(tmp, tmp, Csymbol_rel_low(id, ofs))); - expand_builtin_vstore chunk (IR tmp :: args) (* Handling of varargs *) @@ -302,49 +324,99 @@ let expand_builtin_va_start r = let expand_int64_arith conflict rl fn = if conflict then (fn GPR0; emit (Pmr(rl, GPR0))) else fn rl +(* Handling of cache instructions *) + +(* Auxiliary function to generate address for the cache function *) +let expand_builtin_cache_common addr f = + let add = match addr with + | BA (IR a1) -> a1 + | BA_addrstack ofs -> + emit_addimm GPR11 GPR1 ofs; + GPR11 + | BA_addrglobal(id, ofs) -> + if symbol_is_small_data id ofs then begin + emit (Paddi (GPR11, GPR0, Csymbol_sda(id, ofs))); + GPR11 + end else if symbol_is_rel_data id ofs then begin + emit (Paddis(GPR11, GPR0, Csymbol_rel_high(id, ofs))); + emit (Paddi(GPR11, GPR11, Csymbol_rel_low(id, ofs))); + GPR11 + end else begin + emit (Paddis(GPR11, GPR0, Csymbol_high(id, ofs))); + emit (Paddi (GPR11, GPR11, Csymbol_low(id, ofs))); + GPR11 + end + | _ -> raise (Error "Argument is not an address") in + f add + +let expand_builtin_prefetch addr rw loc = + if not ((loc >= _0) && (loc <= _2)) then + raise (Error "the last argument of __builtin_prefetch must be a constant between 0 and 2"); + let emit_prefetch_instr addr = + if Int.eq rw _0 then begin + emit (Pdcbt (loc,GPR0,addr)); + end else if Int.eq rw _1 then begin + emit (Pdcbtst (loc,GPR0,addr)); + end else + raise (Error "the second argument of __builtin_prefetch must be either 0 or 1") + in + expand_builtin_cache_common addr emit_prefetch_instr + +let expand_builtin_dcbtls addr loc = + if not ((loc == _0) || (loc = _2)) then + raise (Error "the second argument of __builtin_dcbtls must be a constant between 0 and 2"); + let emit_inst addr = emit (Pdcbtls (loc,GPR0,addr)) in + expand_builtin_cache_common addr emit_inst + +let expand_builtin_icbtls addr loc = + if not ((loc == _0) || (loc = _2)) then + raise (Error "the second argument of __builtin_icbtls must be a constant between 0 and 2"); + let emit_inst addr = emit (Picbtls (loc,GPR0,addr)) in + expand_builtin_cache_common addr emit_inst + (* Handling of compiler-inlined builtins *) let expand_builtin_inline name args res = (* Can use as temporaries: GPR0, FPR13 *) match name, args, res with (* Integer arithmetic *) - | "__builtin_mulhw", [IR a1; IR a2], [IR res] -> + | "__builtin_mulhw", [BA(IR a1); BA(IR a2)], BR(IR res) -> emit (Pmulhw(res, a1, a2)) - | "__builtin_mulhwu", [IR a1; IR a2], [IR res] -> + | "__builtin_mulhwu", [BA(IR a1); BA(IR a2)], BR(IR res) -> emit (Pmulhwu(res, a1, a2)) - | "__builtin_clz", [IR a1], [IR res] -> + | "__builtin_clz", [BA(IR a1)], BR(IR res) -> emit (Pcntlzw(res, a1)) - | ("__builtin_bswap" | "__builtin_bswap32"), [IR a1], [IR res] -> + | ("__builtin_bswap" | "__builtin_bswap32"), [BA(IR a1)], BR(IR res) -> emit (Pstwu(a1, Cint _m8, GPR1)); emit (Pcfi_adjust _8); emit (Plwbrx(res, GPR0, GPR1)); emit (Paddi(GPR1, GPR1, Cint _8)); emit (Pcfi_adjust _m8) - | "__builtin_bswap16", [IR a1], [IR res] -> + | "__builtin_bswap16", [BA(IR a1)], BR(IR res) -> emit (Prlwinm(GPR0, a1, _8, coqint_of_camlint 0x0000FF00l)); emit (Prlwinm(res, a1, coqint_of_camlint 24l, coqint_of_camlint 0x000000FFl)); emit (Por(res, GPR0, res)) (* Float arithmetic *) - | "__builtin_fmadd", [FR a1; FR a2; FR a3], [FR res] -> + | "__builtin_fmadd", [BA(FR a1); BA(FR a2); BA(FR a3)], BR(FR res) -> emit (Pfmadd(res, a1, a2, a3)) - | "__builtin_fmsub", [FR a1; FR a2; FR a3], [FR res] -> + | "__builtin_fmsub", [BA(FR a1); BA(FR a2); BA(FR a3)], BR(FR res) -> emit (Pfmsub(res, a1, a2, a3)) - | "__builtin_fnmadd", [FR a1; FR a2; FR a3], [FR res] -> + | "__builtin_fnmadd", [BA(FR a1); BA(FR a2); BA(FR a3)], BR(FR res) -> emit (Pfnmadd(res, a1, a2, a3)) - | "__builtin_fnmsub", [FR a1; FR a2; FR a3], [FR res] -> + | "__builtin_fnmsub", [BA(FR a1); BA(FR a2); BA(FR a3)], BR(FR res) -> emit (Pfnmsub(res, a1, a2, a3)) - | "__builtin_fabs", [FR a1], [FR res] -> + | "__builtin_fabs", [BA(FR a1)], BR(FR res) -> emit (Pfabs(res, a1)) - | "__builtin_fsqrt", [FR a1], [FR res] -> + | "__builtin_fsqrt", [BA(FR a1)], BR(FR res) -> emit (Pfsqrt(res, a1)) - | "__builtin_frsqrte", [FR a1], [FR res] -> + | "__builtin_frsqrte", [BA(FR a1)], BR(FR res) -> emit (Pfrsqrte(res, a1)) - | "__builtin_fres", [FR a1], [FR res] -> + | "__builtin_fres", [BA(FR a1)], BR(FR res) -> emit (Pfres(res, a1)) - | "__builtin_fsel", [FR a1; FR a2; FR a3], [FR res] -> + | "__builtin_fsel", [BA(FR a1); BA(FR a2); BA(FR a3)], BR(FR res) -> emit (Pfsel(res, a1, a2, a3)) - | "__builtin_fcti", [FR a1], [IR res] -> + | "__builtin_fcti", [BA(FR a1)], BR(IR res) -> emit (Pfctiw(FPR13, a1)); emit (Pstfdu(FPR13, Cint _m8, GPR1)); emit (Pcfi_adjust _8); @@ -352,30 +424,36 @@ let expand_builtin_inline name args res = emit (Paddi(GPR1, GPR1, Cint _8)); emit (Pcfi_adjust _m8) (* 64-bit integer arithmetic *) - | "__builtin_negl", [IR ah; IR al], [IR rh; IR rl] -> + | "__builtin_negl", [BA_splitlong(BA(IR ah), BA(IR al))], + BR_splitlong(BR(IR rh), BR(IR rl)) -> expand_int64_arith (rl = ah) rl (fun rl -> emit (Psubfic(rl, al, Cint _0)); emit (Psubfze(rh, ah))) - | "__builtin_addl", [IR ah; IR al; IR bh; IR bl], [IR rh; IR rl] -> + | "__builtin_addl", [BA_splitlong(BA(IR ah), BA(IR al)); + BA_splitlong(BA(IR bh), BA(IR bl))], + BR_splitlong(BR(IR rh), BR(IR rl)) -> expand_int64_arith (rl = ah || rl = bh) rl (fun rl -> emit (Paddc(rl, al, bl)); emit (Padde(rh, ah, bh))) - | "__builtin_subl", [IR ah; IR al; IR bh; IR bl], [IR rh; IR rl] -> + | "__builtin_subl", [BA_splitlong(BA(IR ah), BA(IR al)); + BA_splitlong(BA(IR bh), BA(IR bl))], + BR_splitlong(BR(IR rh), BR(IR rl)) -> expand_int64_arith (rl = ah || rl = bh) rl (fun rl -> emit (Psubfc(rl, bl, al)); emit (Psubfe(rh, bh, ah))) - | "__builtin_mull", [IR a; IR b], [IR rh; IR rl] -> + | "__builtin_mull", [BA(IR a); BA(IR b)], + BR_splitlong(BR(IR rh), BR(IR rl)) -> expand_int64_arith (rl = a || rl = b) rl (fun rl -> emit (Pmullw(rl, a, b)); emit (Pmulhwu(rh, a, b))) (* Memory accesses *) - | "__builtin_read16_reversed", [IR a1], [IR res] -> + | "__builtin_read16_reversed", [BA(IR a1)], BR(IR res) -> emit (Plhbrx(res, GPR0, a1)) - | "__builtin_read32_reversed", [IR a1], [IR res] -> + | "__builtin_read32_reversed", [BA(IR a1)], BR(IR res) -> emit (Plwbrx(res, GPR0, a1)) - | "__builtin_write16_reversed", [IR a1; IR a2], _ -> + | "__builtin_write16_reversed", [BA(IR a1); BA(IR a2)], _ -> emit (Psthbrx(a2, GPR0, a1)) - | "__builtin_write32_reversed", [IR a1; IR a2], _ -> + | "__builtin_write32_reversed", [BA(IR a1); BA(IR a2)], _ -> emit (Pstwbrx(a2, GPR0, a1)) (* Synchronization *) | "__builtin_membar", [], _ -> @@ -388,20 +466,50 @@ let expand_builtin_inline name args res = emit (Pisync) | "__builtin_lwsync", [], _ -> emit (Plwsync) + | "__builtin_mbar", [BA_int mo], _ -> + if not (mo = _0 || mo = _1) then + raise (Error "the argument of __builtin_mbar must be either 0 or 1"); + emit (Pmbar mo) + | "__builin_mbar",_, _ -> + raise (Error "the argument of __builtin_mbar must be a constant"); | "__builtin_trap", [], _ -> emit (Ptrap) (* Vararg stuff *) - | "__builtin_va_start", [IR a], _ -> + | "__builtin_va_start", [BA(IR a)], _ -> expand_builtin_va_start a - (* Catch-all *) - | "__builtin_dcbf", [IR a1],_ -> + (* Cache control *) + | "__builtin_dcbf", [BA(IR a1)],_ -> emit (Pdcbf (GPR0,a1)) - | "__builtin_dcbi", [IR a1],_ -> + | "__builtin_dcbi", [BA(IR a1)],_ -> emit (Pdcbi (GPR0,a1)) - | "__builtin_icbi", [IR a1],_ -> + | "__builtin_icbi", [BA(IR a1)],_ -> emit (Picbi(GPR0,a1)) + | "__builtin_dcbtls", [a; BA_int loc],_ -> + expand_builtin_dcbtls a loc + | "__builtin_dcbtls",_,_ -> + raise (Error "the second argument of __builtin_dcbtls must be a constant") + | "__builtin_icbtls", [a; BA_int loc],_ -> + expand_builtin_icbtls a loc + | "__builtin_icbtls",_,_ -> + raise (Error "the second argument of __builtin_icbtls must be a constant") + | "__builtin_prefetch" , [a1 ;BA_int rw; BA_int loc],_ -> + expand_builtin_prefetch a1 rw loc + | "__builtin_prefetch" ,_,_ -> + raise (Error "the second and third argument of __builtin_prefetch must be a constant") + | "__builtin_dcbz",[BA (IR a1)],_ -> + emit (Pdcbz (GPR0,a1)) + (* Special registers *) + | "__builtin_get_spr", [BA_int n], BR(IR res) -> + emit (Pmfspr(res, n)) + | "__builtin_get_spr", _, _ -> + raise (Error "the argument of __builtin_get_spr must be a constant") + | "__builtin_set_spr", [BA_int n; BA(IR a1)], _ -> + emit (Pmtspr(n, a1)) + | "__builtin_set_spr", _, _ -> + raise (Error "the first argument of __builtin_set_spr must be a constant") + (* Catch-all *) | _ -> - invalid_arg ("unrecognized builtin " ^ name) + raise (Error ("unrecognized builtin " ^ name)) (* Calls to variadic functions: condition bit 6 must be set if at least one argument is a float; clear otherwise. @@ -484,25 +592,11 @@ let expand_instruction instr = expand_builtin_vload chunk args res | EF_vstore chunk -> expand_builtin_vstore chunk args - | EF_vload_global(chunk, id, ofs) -> - if symbol_is_small_data id ofs then - expand_builtin_vload_sda chunk id ofs args res - else if symbol_is_rel_data id ofs then - expand_builtin_vload_rel chunk id ofs args res - else - expand_builtin_vload_global chunk id ofs args res - | EF_vstore_global(chunk, id, ofs) -> - if symbol_is_small_data id ofs then - expand_builtin_vstore_sda chunk id ofs args - else if symbol_is_rel_data id ofs then - expand_builtin_vstore_rel chunk id ofs args - else - expand_builtin_vstore_global chunk id ofs args | EF_memcpy(sz, al) -> expand_builtin_memcpy (Z.to_int sz) (Z.to_int al) args | EF_annot_val(txt, targ) -> expand_annot_val txt targ args res - | EF_inline_asm(txt, sg, clob) -> + | EF_annot _ | EF_debug _ | EF_inline_asm _ -> emit instr | _ -> assert false @@ -511,13 +605,21 @@ let expand_instruction instr = emit instr let expand_function fn = - set_current_function fn; - List.iter expand_instruction fn.fn_code; - get_current_function () + try + set_current_function fn; + List.iter expand_instruction fn.fn_code; + Errors.OK (get_current_function ()) + with Error s -> + Errors.Error (Errors.msg (coqstring_of_camlstring s)) let expand_fundef = function - | Internal f -> Internal (expand_function f) - | External ef -> External ef + | Internal f -> + begin match expand_function f with + | Errors.OK tf -> Errors.OK (Internal tf) + | Errors.Error msg -> Errors.Error msg + end + | External ef -> + Errors.OK (External ef) -let expand_program (p: Asm.program) : Asm.program = - AST.transform_program expand_fundef p +let expand_program (p: Asm.program) : Asm.program Errors.res = + AST.transform_partial_program expand_fundef p diff --git a/powerpc/Asmgen.v b/powerpc/Asmgen.v index 7ee6c770..541fe7c6 100644 --- a/powerpc/Asmgen.v +++ b/powerpc/Asmgen.v @@ -648,9 +648,7 @@ Definition transl_instr (f: Mach.function) (i: Mach.instruction) Pfreeframe f.(fn_stacksize) f.(fn_link_ofs) :: Pbs symb sig :: k) | Mbuiltin ef args res => - OK (Pbuiltin ef (map preg_of args) (map preg_of res) :: k) - | Mannot ef args => - OK (Pannot ef (List.map (map_annot_arg preg_of) args) :: k) + OK (Pbuiltin ef (List.map (map_builtin_arg preg_of) args) (map_builtin_res preg_of res) :: k) | Mlabel lbl => OK (Plabel lbl :: k) | Mgoto lbl => diff --git a/powerpc/Asmgenproof.v b/powerpc/Asmgenproof.v index 27b32ba1..ece6af1a 100644 --- a/powerpc/Asmgenproof.v +++ b/powerpc/Asmgenproof.v @@ -754,48 +754,32 @@ Hint Resolve agree_nextinstr agree_set_other: asmgen. unfold rs5; auto 10 with asmgen. - (* Mbuiltin *) - inv AT. monadInv H3. + inv AT. monadInv H4. exploit functions_transl; eauto. intro FN. - generalize (transf_function_no_overflow _ _ H2); intro NOOV. - exploit external_call_mem_extends'; eauto. eapply preg_vals; eauto. + generalize (transf_function_no_overflow _ _ H3); intro NOOV. + exploit builtin_args_match; eauto. intros [vargs' [P Q]]. + exploit external_call_mem_extends; eauto. intros [vres' [m2' [A [B [C D]]]]]. left. econstructor; split. apply plus_one. eapply exec_step_builtin. eauto. eauto. eapply find_instr_tail; eauto. - eapply external_call_symbols_preserved'; eauto. + erewrite <- sp_val by eauto. + eapply eval_builtin_args_preserved with (ge1 := ge); eauto. exact symbols_preserved. + eapply external_call_symbols_preserved; eauto. exact symbols_preserved. exact public_preserved. exact varinfo_preserved. eauto. econstructor; eauto. - Simpl. rewrite set_pregs_other_2. rewrite undef_regs_other_2. rewrite <- H0. simpl. econstructor; eauto. + instantiate (2 := tf); instantiate (1 := x). + unfold nextinstr. rewrite Pregmap.gss. + rewrite set_res_other. rewrite undef_regs_other_2. + rewrite <- H1. simpl. econstructor; eauto. eapply code_tail_next_int; eauto. - apply preg_notin_charact; auto with asmgen. - apply preg_notin_charact; auto with asmgen. - apply agree_nextinstr. eapply agree_set_mregs; auto. + rewrite preg_notin_charact. intros. auto with asmgen. + auto with asmgen. + apply agree_nextinstr. eapply agree_set_res; auto. eapply agree_undef_regs; eauto. intros; apply undef_regs_other_2; auto. congruence. -- (* Mannot *) - inv AT. monadInv H4. - exploit functions_transl; eauto. intro FN. - generalize (transf_function_no_overflow _ _ H3); intro NOOV. - exploit annot_args_match; eauto. intros [vargs' [P Q]]. - exploit external_call_mem_extends; eauto. - intros [vres' [m2' [A [B [C D]]]]]. - left. econstructor; split. apply plus_one. - eapply exec_step_annot. eauto. eauto. - eapply find_instr_tail; eauto. eauto. - erewrite <- sp_val by eauto. - eapply eval_annot_args_preserved with (ge1 := ge); eauto. - exact symbols_preserved. - eapply external_call_symbols_preserved; eauto. - exact symbols_preserved. exact public_preserved. exact varinfo_preserved. - eapply match_states_intro with (ep := false); eauto with coqlib. - unfold nextinstr. rewrite Pregmap.gss. - rewrite <- H1; simpl. econstructor; eauto. - eapply code_tail_next_int; eauto. - apply agree_nextinstr. auto. - congruence. - - (* Mgoto *) assert (f0 = f) by congruence. subst f0. inv AT. monadInv H4. diff --git a/powerpc/CBuiltins.ml b/powerpc/CBuiltins.ml index 06a7e395..e18fdb2d 100644 --- a/powerpc/CBuiltins.ml +++ b/powerpc/CBuiltins.ml @@ -85,6 +85,8 @@ let builtins = { (TVoid [], [], false); "__builtin_lwsync", (TVoid [], [], false); + "__builtin_mbar", + (TVoid [], [TInt(IInt, [])], false); "__builtin_trap", (TVoid [], [], false); (* Cache isntructions *) @@ -93,7 +95,20 @@ let builtins = { "__builtin_dcbi", (TVoid [],[TPtr(TVoid [], [])],false); "__builtin_icbi", - (TVoid [],[TPtr(TVoid [], [])],false) + (TVoid [],[TPtr(TVoid [], [])],false); + "__builtin_prefetch", + (TVoid [], [TPtr (TVoid [],[]);TInt (IInt, []);TInt (IInt,[])],false); + "__builtin_dcbtls", + (TVoid[], [TPtr (TVoid [],[]);TInt (IInt,[])],false); + "__builtin_icbtls", + (TVoid[], [TPtr (TVoid [],[]);TInt (IInt,[])],false); + "__builtin_dcbz", + (TVoid[], [TPtr (TVoid [],[])],false); + (* Access to special registers *) + "__builtin_get_spr", + (TInt(IUInt, []), [TInt(IInt, [])], false); + "__builtin_set_spr", + (TVoid [], [TInt(IInt, []); TInt(IUInt, [])], false) ] } diff --git a/powerpc/Machregs.v b/powerpc/Machregs.v index 3b7cbb76..402f07d1 100644 --- a/powerpc/Machregs.v +++ b/powerpc/Machregs.v @@ -163,11 +163,9 @@ Fixpoint destroyed_by_clobber (cl: list string): list mreg := Definition destroyed_by_builtin (ef: external_function): list mreg := match ef with | EF_builtin _ _ => F13 :: nil - | EF_vload _ => nil - | EF_vstore _ => nil - | EF_vload_global _ _ _ => R11 :: nil - | EF_vstore_global Mint64 _ _ => R10 :: R11 :: R12 :: nil - | EF_vstore_global _ _ _ => R11 :: R12 :: nil + | EF_vload _ => R11 :: nil + | EF_vstore Mint64 => R10 :: R11 :: R12 :: nil + | EF_vstore _ => R11 :: R12 :: nil | EF_memcpy _ _ => R11 :: R12 :: F13 :: nil | EF_inline_asm txt sg clob => destroyed_by_clobber clob | _ => nil @@ -203,3 +201,31 @@ Definition two_address_op (op: operation) : bool := | Oroli _ _ => true | _ => false end. + +(* Constraints on constant propagation for builtins *) + +Definition builtin_get_spr := ident_of_string "__builtin_get_spr". +Definition builtin_set_spr := ident_of_string "__builtin_set_spr". +Definition builtin_prefetch := ident_of_string "__builtin_prefetch". +Definition builtin_dcbtls := ident_of_string "__builtin_dcbtls". +Definition builtin_icbtls := ident_of_string "__builtin_icbtls". +Definition builtin_mbar := ident_of_string "__builtin_mbar". + +Definition builtin_constraints (ef: external_function) : + list builtin_arg_constraint := + match ef with + | EF_builtin id sg => + if ident_eq id builtin_get_spr then OK_const :: nil + else if ident_eq id builtin_set_spr then OK_const :: OK_default :: nil + else if ident_eq id builtin_prefetch then OK_addrany :: OK_const :: OK_const :: nil + else if ident_eq id builtin_dcbtls then OK_addrany::OK_const::nil + else if ident_eq id builtin_icbtls then OK_addrany::OK_const::nil + else if ident_eq id builtin_mbar then OK_const::nil + else nil + | EF_vload _ => OK_addrany :: nil + | EF_vstore _ => OK_addrany :: OK_default :: nil + | EF_memcpy _ _ => OK_addrstack :: OK_addrstack :: nil + | EF_annot txt targs => map (fun _ => OK_all) targs + | EF_debug kind txt targs => map (fun _ => OK_all) targs + | _ => nil + end. diff --git a/powerpc/SelectOp.vp b/powerpc/SelectOp.vp index 618643b8..6d39569e 100644 --- a/powerpc/SelectOp.vp +++ b/powerpc/SelectOp.vp @@ -524,17 +524,17 @@ Nondetfunction addressing (chunk: memory_chunk) (e: expr) := | _ => (Aindexed Int.zero, e:::Enil) end. -(** ** Arguments of annotations *) +(** ** Arguments of builtins *) -Nondetfunction annot_arg (e: expr) := +Nondetfunction builtin_arg (e: expr) := match e with - | Eop (Ointconst n) Enil => AA_int n - | Eop (Oaddrsymbol id ofs) Enil => AA_addrglobal id ofs - | Eop (Oaddrstack ofs) Enil => AA_addrstack ofs + | Eop (Ointconst n) Enil => BA_int n + | Eop (Oaddrsymbol id ofs) Enil => BA_addrglobal id ofs + | Eop (Oaddrstack ofs) Enil => BA_addrstack ofs | Eop Omakelong (Eop (Ointconst h) Enil ::: Eop (Ointconst l) Enil ::: Enil) => - AA_long (Int64.ofwords h l) - | Eop Omakelong (h ::: l ::: Enil) => AA_longofwords (AA_base h) (AA_base l) - | Eload chunk (Aglobal id ofs) Enil => AA_loadglobal chunk id ofs - | Eload chunk (Ainstack ofs) Enil => AA_loadstack chunk ofs - | _ => AA_base e + BA_long (Int64.ofwords h l) + | Eop Omakelong (h ::: l ::: Enil) => BA_splitlong (BA h) (BA l) + | Eload chunk (Aglobal id ofs) Enil => BA_loadglobal chunk id ofs + | Eload chunk (Ainstack ofs) Enil => BA_loadstack chunk ofs + | _ => BA e end. diff --git a/powerpc/SelectOpproof.v b/powerpc/SelectOpproof.v index c51b650b..147132dd 100644 --- a/powerpc/SelectOpproof.v +++ b/powerpc/SelectOpproof.v @@ -999,12 +999,12 @@ Proof. rewrite Int.add_zero. auto. Qed. -Theorem eval_annot_arg: +Theorem eval_builtin_arg: forall a v, eval_expr ge sp e m nil a v -> - CminorSel.eval_annot_arg ge sp e m (annot_arg a) v. + CminorSel.eval_builtin_arg ge sp e m (builtin_arg a) v. Proof. - intros until v. unfold annot_arg; case (annot_arg_match a); intros; InvEval. + intros until v. unfold builtin_arg; case (builtin_arg_match a); intros; InvEval. - constructor. - constructor. - constructor. diff --git a/powerpc/TargetPrinter.ml b/powerpc/TargetPrinter.ml index 1e78f038..409f2cc0 100644 --- a/powerpc/TargetPrinter.ml +++ b/powerpc/TargetPrinter.ml @@ -358,17 +358,6 @@ module Target (System : SYSTEM):TARGET = assert (!count = 2 || (!count = 0 && !last)); (!mb, !me-1) - (* Handling of annotations *) - - let print_annot_stmt oc txt targs args = - if Str.string_match re_file_line txt 0 then begin - print_file_line oc (Str.matched_group 1 txt) - (int_of_string (Str.matched_group 2 txt)) - end else begin - fprintf oc "%s annotation: " comment; - print_annot_stmt preg_annot "R1" oc txt targs args - end - (* Determine if the displacement of a conditional branch fits the short form *) let short_cond_branch tbl pc lbl_dest = @@ -473,6 +462,14 @@ module Target (System : SYSTEM):TARGET = fprintf oc " dcbf %a, %a\n" ireg r1 ireg r2 | Pdcbi (r1,r2) -> fprintf oc " dcbi %a, %a\n" ireg r1 ireg r2 + | Pdcbt (c,r1,r2) -> + fprintf oc " dcbt %ld, %a, %a\n" (camlint_of_coqint c) ireg r1 ireg r2 + | Pdcbtst (c,r1,r2) -> + fprintf oc " dcbtst %ld, %a, %a\n" (camlint_of_coqint c) ireg r1 ireg r2 + | Pdcbtls (c,r1,r2) -> + fprintf oc " dcbtls %ld, %a, %a\n" (camlint_of_coqint c) ireg r1 ireg r2 + | Pdcbz (r1,r2) -> + fprintf oc " dcbz %a, %a\n" ireg r1 ireg r2 | Pdivw(r1, r2, r3) -> fprintf oc " divw %a, %a, %a\n" ireg r1 ireg r2 ireg r3 | Pdivwu(r1, r2, r3) -> @@ -541,6 +538,8 @@ module Target (System : SYSTEM):TARGET = fprintf oc " fsel %a, %a, %a, %a\n" freg r1 freg r2 freg r3 freg r4 | Picbi (r1,r2) -> fprintf oc " icbi %a,%a\n" ireg r1 ireg r2 + | Picbtls (n,r1,r2) -> + fprintf oc " icbtls %ld, %a, %a\n" (camlint_of_coqint n) ireg r1 ireg r2 | Pisync -> fprintf oc " isync\n" | Plwsync -> @@ -587,6 +586,8 @@ module Target (System : SYSTEM):TARGET = fprintf oc " lwzu %a, %a(%a)\n" ireg r1 constant c ireg r2 | Plwzx(r1, r2, r3) | Plwzx_a(r1, r2, r3) -> fprintf oc " lwzx %a, %a, %a\n" ireg r1 ireg r2 ireg r3 + | Pmbar mo -> + fprintf oc " mbar %ld\n" (camlint_of_coqint mo) | Pmfcr(r1) -> fprintf oc " mfcr %a\n" ireg r1 | Pmfcrbit(r1, bit) -> @@ -599,6 +600,10 @@ module Target (System : SYSTEM):TARGET = fprintf oc " mtctr %a\n" ireg r1 | Pmtlr(r1) -> fprintf oc " mtlr %a\n" ireg r1 + | Pmfspr(rd, spr) -> + fprintf oc " mfspr %a, %ld\n" ireg rd (camlint_of_coqint spr) + | Pmtspr(spr, rs) -> + fprintf oc " mtspr %ld, %a\n" (camlint_of_coqint spr) ireg rs | Pmulli(r1, r2, c) -> fprintf oc " mulli %a, %a, %a\n" ireg r1 ireg r2 constant c | Pmullw(r1, r2, r3) -> @@ -693,6 +698,12 @@ module Target (System : SYSTEM):TARGET = fprintf oc "%a:\n" label (transl_label lbl) | Pbuiltin(ef, args, res) -> begin match ef with + | EF_annot(txt, targs) -> + fprintf oc "%s annotation: " comment; + print_annot_text preg_annot "r1" oc (extern_atom txt) args + | EF_debug(kind, txt, targs) -> + print_debug_info comment print_file_line preg_annot "r1" oc + (P.to_int kind) (extern_atom txt) args | EF_inline_asm(txt, sg, clob) -> fprintf oc "%s begin inline assembly\n\t" comment; print_inline_asm preg oc (extern_atom txt) sg args res; @@ -700,13 +711,6 @@ module Target (System : SYSTEM):TARGET = | _ -> assert false end - | Pannot(ef, args) -> - begin match ef with - | EF_annot(txt, targs) -> - print_annot_stmt oc (extern_atom txt) targs args - | _ -> - assert false - end | Pcfi_adjust n -> cfi_adjust oc (camlint_of_coqint n) | Pcfi_rel_offset n -> @@ -731,8 +735,8 @@ module Target (System : SYSTEM):TARGET = | Plfi(r1, c) -> 2 | Plfis(r1, c) -> 2 | Plabel lbl -> 0 - | Pbuiltin(ef, args, res) -> 0 - | Pannot(ef, args) -> 0 + | Pbuiltin((EF_annot _ | EF_debug _), args, res) -> 0 + | Pbuiltin(ef, args, res) -> 3 | Pcfi_adjust _ | Pcfi_rel_offset _ -> 0 | _ -> 1 |