diff options
88 files changed, 11331 insertions, 8418 deletions
@@ -5,60 +5,68 @@ lib/union_find.vo: lib/union_find.v lib/Inclusion.vo: lib/Inclusion.v lib/Lattice.vo: lib/Lattice.v lib/Coqlib.vo lib/Maps.vo lib/Ordered.vo: lib/Ordered.v lib/Coqlib.vo lib/Maps.vo -lib/Integers.vo: lib/Integers.v lib/Coqlib.vo backend/AST.vo -lib/Floats.vo: lib/Floats.v backend/AST.vo lib/Integers.vo -backend/AST.vo: backend/AST.v lib/Coqlib.vo +lib/Iteration.vo: lib/Iteration.v lib/Coqlib.vo +lib/Integers.vo: lib/Integers.v lib/Coqlib.vo +lib/Floats.vo: lib/Floats.v lib/Integers.vo +lib/Parmov.vo: lib/Parmov.v lib/Coqlib.vo +backend/AST.vo: backend/AST.v lib/Coqlib.vo lib/Integers.vo lib/Floats.vo backend/Values.vo: backend/Values.v lib/Coqlib.vo backend/AST.vo lib/Integers.vo lib/Floats.vo backend/Mem.vo: backend/Mem.v lib/Coqlib.vo lib/Maps.vo backend/AST.vo lib/Integers.vo lib/Floats.vo backend/Values.vo +backend/Events.vo: backend/Events.v lib/Coqlib.vo backend/AST.vo lib/Integers.vo lib/Floats.vo backend/Values.vo backend/Mem.vo backend/Globalenvs.vo: backend/Globalenvs.v lib/Coqlib.vo lib/Maps.vo backend/AST.vo lib/Integers.vo backend/Values.vo backend/Mem.vo backend/Op.vo: backend/Op.v lib/Coqlib.vo backend/AST.vo lib/Integers.vo lib/Floats.vo backend/Values.vo backend/Mem.vo backend/Globalenvs.vo -backend/Cminor.vo: backend/Cminor.v lib/Coqlib.vo lib/Maps.vo backend/AST.vo lib/Integers.vo lib/Floats.vo backend/Values.vo backend/Mem.vo backend/Op.vo backend/Globalenvs.vo +backend/Cminor.vo: backend/Cminor.v lib/Coqlib.vo lib/Maps.vo backend/AST.vo lib/Integers.vo lib/Floats.vo backend/Events.vo backend/Values.vo backend/Mem.vo backend/Op.vo backend/Globalenvs.vo backend/Cmconstr.vo: backend/Cmconstr.v lib/Coqlib.vo lib/Maps.vo backend/AST.vo lib/Integers.vo lib/Floats.vo backend/Values.vo backend/Mem.vo backend/Op.vo backend/Globalenvs.vo backend/Cminor.vo -backend/Cmconstrproof.vo: backend/Cmconstrproof.v lib/Coqlib.vo lib/Maps.vo backend/AST.vo lib/Integers.vo lib/Floats.vo backend/Values.vo backend/Mem.vo backend/Op.vo backend/Globalenvs.vo backend/Cminor.vo backend/Cmconstr.vo -backend/Csharpminor.vo: backend/Csharpminor.v lib/Coqlib.vo lib/Maps.vo backend/AST.vo lib/Integers.vo lib/Floats.vo backend/Values.vo backend/Mem.vo backend/Globalenvs.vo +backend/Cmconstrproof.vo: backend/Cmconstrproof.v lib/Coqlib.vo lib/Maps.vo backend/AST.vo lib/Integers.vo lib/Floats.vo backend/Values.vo backend/Mem.vo backend/Events.vo backend/Op.vo backend/Globalenvs.vo backend/Cminor.vo backend/Cmconstr.vo +backend/Csharpminor.vo: backend/Csharpminor.v lib/Coqlib.vo lib/Maps.vo backend/AST.vo lib/Integers.vo lib/Floats.vo backend/Values.vo backend/Mem.vo backend/Events.vo backend/Globalenvs.vo backend/Cminorgen.vo: backend/Cminorgen.v lib/Coqlib.vo lib/Maps.vo lib/Sets.vo backend/AST.vo lib/Integers.vo backend/Mem.vo backend/Csharpminor.vo backend/Op.vo backend/Cminor.vo backend/Cmconstr.vo -backend/Cminorgenproof.vo: backend/Cminorgenproof.v lib/Coqlib.vo lib/Maps.vo lib/Sets.vo backend/AST.vo lib/Integers.vo lib/Floats.vo backend/Values.vo backend/Mem.vo backend/Globalenvs.vo backend/Csharpminor.vo backend/Op.vo backend/Cminor.vo backend/Cmconstr.vo backend/Cminorgen.vo backend/Cmconstrproof.vo +backend/Cminorgenproof.vo: backend/Cminorgenproof.v lib/Coqlib.vo lib/Maps.vo lib/Sets.vo backend/AST.vo lib/Integers.vo lib/Floats.vo backend/Values.vo backend/Mem.vo backend/Events.vo backend/Globalenvs.vo backend/Csharpminor.vo backend/Op.vo backend/Cminor.vo backend/Cmconstr.vo backend/Cminorgen.vo backend/Cmconstrproof.vo backend/Registers.vo: backend/Registers.v lib/Coqlib.vo backend/AST.vo lib/Maps.vo lib/Sets.vo -backend/RTL.vo: backend/RTL.v lib/Coqlib.vo lib/Maps.vo backend/AST.vo lib/Integers.vo backend/Values.vo backend/Mem.vo backend/Globalenvs.vo backend/Op.vo backend/Registers.vo +backend/RTL.vo: backend/RTL.v lib/Coqlib.vo lib/Maps.vo backend/AST.vo lib/Integers.vo backend/Values.vo backend/Events.vo backend/Mem.vo backend/Globalenvs.vo backend/Op.vo backend/Registers.vo backend/RTLgen.vo: backend/RTLgen.v lib/Coqlib.vo lib/Maps.vo backend/AST.vo lib/Integers.vo backend/Values.vo backend/Op.vo backend/Registers.vo backend/Cminor.vo backend/RTL.vo -backend/RTLgenproof1.vo: backend/RTLgenproof1.v lib/Coqlib.vo lib/Maps.vo backend/AST.vo lib/Integers.vo backend/Values.vo backend/Mem.vo backend/Globalenvs.vo backend/Op.vo backend/Registers.vo backend/Cminor.vo backend/RTL.vo backend/RTLgen.vo -backend/RTLgenproof.vo: backend/RTLgenproof.v lib/Coqlib.vo lib/Maps.vo backend/AST.vo lib/Integers.vo backend/Values.vo backend/Mem.vo backend/Globalenvs.vo backend/Op.vo backend/Registers.vo backend/Cminor.vo backend/RTL.vo backend/RTLgen.vo backend/RTLgenproof1.vo -backend/RTLtyping.vo: backend/RTLtyping.v lib/Coqlib.vo lib/Maps.vo backend/AST.vo backend/Op.vo backend/Registers.vo backend/RTL.vo lib/union_find.vo backend/Globalenvs.vo backend/Values.vo backend/Mem.vo lib/Integers.vo -backend/Kildall.vo: backend/Kildall.v lib/Coqlib.vo lib/Maps.vo lib/Lattice.vo +backend/RTLgenproof1.vo: backend/RTLgenproof1.v lib/Coqlib.vo lib/Maps.vo backend/AST.vo lib/Integers.vo backend/Values.vo backend/Events.vo backend/Mem.vo backend/Globalenvs.vo backend/Op.vo backend/Registers.vo backend/Cminor.vo backend/RTL.vo backend/RTLgen.vo +backend/RTLgenproof.vo: backend/RTLgenproof.v lib/Coqlib.vo lib/Maps.vo backend/AST.vo lib/Integers.vo backend/Values.vo backend/Mem.vo backend/Events.vo backend/Globalenvs.vo backend/Op.vo backend/Registers.vo backend/Cminor.vo backend/RTL.vo backend/RTLgen.vo backend/RTLgenproof1.vo +backend/RTLtyping.vo: backend/RTLtyping.v lib/Coqlib.vo lib/Maps.vo backend/AST.vo backend/Op.vo backend/Registers.vo backend/RTL.vo backend/Conventions.vo backend/Globalenvs.vo backend/Values.vo backend/Mem.vo lib/Integers.vo backend/Events.vo +backend/Kildall.vo: backend/Kildall.v lib/Coqlib.vo lib/Iteration.vo lib/Maps.vo lib/Lattice.vo backend/Constprop.vo: backend/Constprop.v lib/Coqlib.vo lib/Maps.vo backend/AST.vo lib/Integers.vo lib/Floats.vo backend/Values.vo backend/Globalenvs.vo backend/Op.vo backend/Registers.vo backend/RTL.vo lib/Lattice.vo backend/Kildall.vo -backend/Constpropproof.vo: backend/Constpropproof.v lib/Coqlib.vo lib/Maps.vo backend/AST.vo lib/Integers.vo lib/Floats.vo backend/Values.vo backend/Mem.vo backend/Globalenvs.vo backend/Op.vo backend/Registers.vo backend/RTL.vo lib/Lattice.vo backend/Kildall.vo backend/Constprop.vo +backend/Constpropproof.vo: backend/Constpropproof.v lib/Coqlib.vo lib/Maps.vo backend/AST.vo lib/Integers.vo lib/Floats.vo backend/Values.vo backend/Events.vo backend/Mem.vo backend/Globalenvs.vo backend/Op.vo backend/Registers.vo backend/RTL.vo lib/Lattice.vo backend/Kildall.vo backend/Constprop.vo backend/CSE.vo: backend/CSE.v lib/Coqlib.vo lib/Maps.vo backend/AST.vo lib/Integers.vo lib/Floats.vo backend/Values.vo backend/Mem.vo backend/Globalenvs.vo backend/Op.vo backend/Registers.vo backend/RTL.vo backend/Kildall.vo -backend/CSEproof.vo: backend/CSEproof.v lib/Coqlib.vo lib/Maps.vo backend/AST.vo lib/Integers.vo lib/Floats.vo backend/Values.vo backend/Mem.vo backend/Globalenvs.vo backend/Op.vo backend/Registers.vo backend/RTL.vo backend/Kildall.vo backend/CSE.vo +backend/CSEproof.vo: backend/CSEproof.v lib/Coqlib.vo lib/Maps.vo backend/AST.vo lib/Integers.vo lib/Floats.vo backend/Values.vo backend/Mem.vo backend/Events.vo backend/Globalenvs.vo backend/Op.vo backend/Registers.vo backend/RTL.vo backend/Kildall.vo backend/CSE.vo backend/Locations.vo: backend/Locations.v lib/Coqlib.vo lib/Maps.vo backend/AST.vo backend/Values.vo backend/Conventions.vo: backend/Conventions.v lib/Coqlib.vo backend/AST.vo backend/Locations.vo -backend/LTL.vo: backend/LTL.v lib/Coqlib.vo lib/Maps.vo backend/AST.vo lib/Integers.vo backend/Values.vo backend/Mem.vo backend/Globalenvs.vo backend/Op.vo backend/Locations.vo backend/Conventions.vo +backend/LTL.vo: backend/LTL.v lib/Coqlib.vo lib/Maps.vo backend/AST.vo lib/Integers.vo backend/Values.vo backend/Events.vo backend/Mem.vo backend/Globalenvs.vo backend/Op.vo backend/Locations.vo backend/Conventions.vo backend/LTLtyping.vo: backend/LTLtyping.v lib/Coqlib.vo lib/Maps.vo backend/AST.vo backend/Op.vo backend/RTL.vo backend/Locations.vo backend/LTL.vo backend/Conventions.vo backend/InterfGraph.vo: backend/InterfGraph.v lib/Coqlib.vo lib/Maps.vo lib/Ordered.vo backend/Registers.vo backend/Locations.vo backend/Coloring.vo: backend/Coloring.v lib/Coqlib.vo lib/Maps.vo backend/AST.vo backend/Op.vo backend/Registers.vo backend/RTL.vo backend/RTLtyping.vo backend/Locations.vo backend/Conventions.vo backend/InterfGraph.vo backend/Coloringproof.vo: backend/Coloringproof.v lib/Coqlib.vo lib/Maps.vo backend/AST.vo backend/Op.vo backend/Registers.vo backend/RTL.vo backend/RTLtyping.vo backend/Locations.vo backend/Conventions.vo backend/InterfGraph.vo backend/Coloring.vo -backend/Parallelmove.vo: backend/Parallelmove.v backend/Conventions.vo lib/Coqlib.vo backend/Values.vo backend/LTL.vo backend/Locations.vo backend/AST.vo +backend/Parallelmove.vo: backend/Parallelmove.v lib/Coqlib.vo lib/Parmov.vo backend/Values.vo backend/Events.vo backend/AST.vo backend/Locations.vo backend/Conventions.vo backend/Allocation.vo: backend/Allocation.v lib/Coqlib.vo lib/Maps.vo backend/AST.vo lib/Integers.vo backend/Values.vo backend/Globalenvs.vo backend/Op.vo backend/Registers.vo backend/RTL.vo backend/RTLtyping.vo backend/Kildall.vo backend/Locations.vo backend/Conventions.vo backend/Coloring.vo backend/Parallelmove.vo backend/LTL.vo -backend/Allocproof_aux.vo: backend/Allocproof_aux.v lib/Coqlib.vo backend/Values.vo backend/Parallelmove.vo backend/Allocation.vo backend/LTL.vo backend/Locations.vo backend/Conventions.vo -backend/Allocproof.vo: backend/Allocproof.v lib/Coqlib.vo lib/Maps.vo backend/AST.vo lib/Integers.vo backend/Values.vo backend/Mem.vo backend/Globalenvs.vo backend/Op.vo backend/Registers.vo backend/RTL.vo backend/RTLtyping.vo backend/Locations.vo backend/Conventions.vo backend/Coloring.vo backend/Coloringproof.vo backend/Allocation.vo backend/Allocproof_aux.vo backend/LTL.vo -backend/Alloctyping_aux.vo: backend/Alloctyping_aux.v lib/Coqlib.vo backend/Locations.vo backend/LTL.vo backend/Allocation.vo backend/LTLtyping.vo backend/Allocproof_aux.vo backend/Parallelmove.vo lib/Inclusion.vo -backend/Alloctyping.vo: backend/Alloctyping.v lib/Coqlib.vo lib/Maps.vo backend/AST.vo backend/Op.vo backend/Registers.vo backend/RTL.vo backend/Locations.vo backend/LTL.vo backend/Coloring.vo backend/Coloringproof.vo backend/Allocation.vo backend/Allocproof.vo backend/RTLtyping.vo backend/LTLtyping.vo backend/Conventions.vo backend/Alloctyping_aux.vo +backend/Allocproof.vo: backend/Allocproof.v lib/Coqlib.vo lib/Maps.vo backend/AST.vo lib/Integers.vo backend/Values.vo backend/Mem.vo backend/Events.vo backend/Globalenvs.vo backend/Op.vo backend/Registers.vo backend/RTL.vo backend/RTLtyping.vo backend/Locations.vo backend/Conventions.vo backend/Coloring.vo backend/Coloringproof.vo backend/Parallelmove.vo backend/Allocation.vo backend/LTL.vo +backend/Alloctyping.vo: backend/Alloctyping.v lib/Coqlib.vo lib/Maps.vo backend/AST.vo backend/Op.vo backend/Registers.vo backend/RTL.vo backend/Locations.vo backend/LTL.vo backend/Coloring.vo backend/Coloringproof.vo backend/Allocation.vo backend/Allocproof.vo backend/RTLtyping.vo backend/LTLtyping.vo backend/Conventions.vo backend/Parallelmove.vo backend/Tunneling.vo: backend/Tunneling.v lib/Coqlib.vo lib/Maps.vo backend/AST.vo backend/Values.vo backend/Globalenvs.vo backend/Op.vo backend/Locations.vo backend/LTL.vo -backend/Tunnelingproof.vo: backend/Tunnelingproof.v lib/Coqlib.vo lib/Maps.vo backend/AST.vo backend/Values.vo backend/Mem.vo backend/Globalenvs.vo backend/Op.vo backend/Locations.vo backend/LTL.vo backend/Tunneling.vo +backend/Tunnelingproof.vo: backend/Tunnelingproof.v lib/Coqlib.vo lib/Maps.vo backend/AST.vo backend/Values.vo backend/Mem.vo backend/Events.vo backend/Globalenvs.vo backend/Op.vo backend/Locations.vo backend/LTL.vo backend/Tunneling.vo backend/Tunnelingtyping.vo: backend/Tunnelingtyping.v lib/Coqlib.vo lib/Maps.vo backend/AST.vo backend/Values.vo backend/Mem.vo backend/Globalenvs.vo backend/Op.vo backend/Locations.vo backend/LTL.vo backend/LTLtyping.vo backend/Tunneling.vo -backend/Linear.vo: backend/Linear.v lib/Coqlib.vo lib/Maps.vo backend/AST.vo lib/Integers.vo backend/Values.vo backend/Mem.vo backend/Globalenvs.vo backend/Op.vo backend/Locations.vo backend/LTL.vo backend/Conventions.vo +backend/Linear.vo: backend/Linear.v lib/Coqlib.vo lib/Maps.vo backend/AST.vo lib/Integers.vo backend/Values.vo backend/Mem.vo backend/Events.vo backend/Globalenvs.vo backend/Op.vo backend/Locations.vo backend/LTL.vo backend/Conventions.vo backend/Lineartyping.vo: backend/Lineartyping.v lib/Coqlib.vo lib/Maps.vo backend/AST.vo backend/Op.vo backend/RTL.vo backend/Locations.vo backend/Linear.vo backend/Conventions.vo backend/Linearize.vo: backend/Linearize.v lib/Coqlib.vo lib/Maps.vo lib/Sets.vo backend/AST.vo backend/Values.vo backend/Globalenvs.vo backend/Op.vo backend/Locations.vo backend/LTL.vo backend/Linear.vo backend/Kildall.vo lib/Lattice.vo -backend/Linearizeproof.vo: backend/Linearizeproof.v lib/Coqlib.vo lib/Maps.vo backend/AST.vo lib/Integers.vo backend/Values.vo backend/Mem.vo backend/Globalenvs.vo backend/Op.vo backend/Locations.vo backend/LTL.vo backend/Linear.vo backend/Linearize.vo lib/Lattice.vo +backend/Linearizeproof.vo: backend/Linearizeproof.v lib/Coqlib.vo lib/Maps.vo backend/AST.vo lib/Integers.vo backend/Values.vo backend/Mem.vo backend/Events.vo backend/Globalenvs.vo backend/Op.vo backend/Locations.vo backend/LTL.vo backend/Linear.vo backend/Linearize.vo lib/Lattice.vo backend/Linearizetyping.vo: backend/Linearizetyping.v lib/Coqlib.vo lib/Maps.vo backend/AST.vo backend/Op.vo backend/Locations.vo backend/LTL.vo backend/Linear.vo backend/Linearize.vo backend/LTLtyping.vo backend/Lineartyping.vo backend/Conventions.vo -backend/Mach.vo: backend/Mach.v lib/Coqlib.vo lib/Maps.vo backend/AST.vo lib/Integers.vo backend/Values.vo backend/Mem.vo backend/Globalenvs.vo backend/Op.vo backend/Locations.vo -backend/Machabstr.vo: backend/Machabstr.v lib/Coqlib.vo lib/Maps.vo backend/AST.vo backend/Mem.vo lib/Integers.vo backend/Values.vo backend/Globalenvs.vo backend/Op.vo backend/Locations.vo backend/Conventions.vo backend/Mach.vo -backend/Machtyping.vo: backend/Machtyping.v lib/Coqlib.vo lib/Maps.vo backend/AST.vo backend/Mem.vo lib/Integers.vo backend/Values.vo backend/Globalenvs.vo backend/Op.vo backend/Locations.vo backend/Conventions.vo backend/Mach.vo backend/Machabstr.vo +backend/Mach.vo: backend/Mach.v lib/Coqlib.vo lib/Maps.vo backend/AST.vo lib/Integers.vo backend/Values.vo backend/Mem.vo backend/Events.vo backend/Globalenvs.vo backend/Op.vo backend/Locations.vo backend/Conventions.vo +backend/Machabstr.vo: backend/Machabstr.v lib/Coqlib.vo lib/Maps.vo backend/AST.vo backend/Mem.vo lib/Integers.vo backend/Values.vo backend/Events.vo backend/Globalenvs.vo backend/Op.vo backend/Locations.vo backend/Conventions.vo backend/Mach.vo +backend/Machtyping.vo: backend/Machtyping.v lib/Coqlib.vo lib/Maps.vo backend/AST.vo backend/Mem.vo lib/Integers.vo backend/Values.vo backend/Events.vo backend/Globalenvs.vo backend/Op.vo backend/Locations.vo backend/Conventions.vo backend/Mach.vo backend/Machabstr.vo backend/Stacking.vo: backend/Stacking.v lib/Coqlib.vo lib/Maps.vo backend/AST.vo lib/Integers.vo backend/Op.vo backend/RTL.vo backend/Locations.vo backend/Linear.vo backend/Lineartyping.vo backend/Mach.vo backend/Conventions.vo -backend/Stackingproof.vo: backend/Stackingproof.v lib/Coqlib.vo lib/Maps.vo backend/AST.vo lib/Integers.vo backend/Values.vo backend/Op.vo backend/Mem.vo backend/Globalenvs.vo backend/Locations.vo backend/Mach.vo backend/Machabstr.vo backend/Linear.vo backend/Lineartyping.vo backend/Conventions.vo backend/Stacking.vo +backend/Stackingproof.vo: backend/Stackingproof.v lib/Coqlib.vo lib/Maps.vo backend/AST.vo lib/Integers.vo backend/Values.vo backend/Op.vo backend/Mem.vo backend/Events.vo backend/Globalenvs.vo backend/Locations.vo backend/Mach.vo backend/Machabstr.vo backend/Linear.vo backend/Lineartyping.vo backend/Conventions.vo backend/Stacking.vo backend/Stackingtyping.vo: backend/Stackingtyping.v lib/Coqlib.vo lib/Maps.vo lib/Integers.vo backend/AST.vo backend/Op.vo backend/Locations.vo backend/Conventions.vo backend/Linear.vo backend/Lineartyping.vo backend/Mach.vo backend/Machtyping.vo backend/Stacking.vo backend/Stackingproof.vo -backend/Machabstr2mach.vo: backend/Machabstr2mach.v lib/Coqlib.vo lib/Maps.vo backend/AST.vo lib/Integers.vo backend/Values.vo backend/Mem.vo backend/Globalenvs.vo backend/Op.vo backend/Locations.vo backend/Machabstr.vo backend/Mach.vo backend/Machtyping.vo backend/Stackingproof.vo -backend/PPC.vo: backend/PPC.v lib/Coqlib.vo lib/Maps.vo backend/AST.vo lib/Integers.vo lib/Floats.vo backend/Values.vo backend/Mem.vo backend/Globalenvs.vo +backend/Machabstr2mach.vo: backend/Machabstr2mach.v lib/Coqlib.vo lib/Maps.vo backend/AST.vo lib/Integers.vo backend/Values.vo backend/Mem.vo backend/Events.vo backend/Globalenvs.vo backend/Op.vo backend/Locations.vo backend/Machabstr.vo backend/Mach.vo backend/Machtyping.vo backend/Stackingproof.vo +backend/PPC.vo: backend/PPC.v lib/Coqlib.vo lib/Maps.vo backend/AST.vo lib/Integers.vo lib/Floats.vo backend/Values.vo backend/Mem.vo backend/Events.vo backend/Globalenvs.vo backend/PPCgen.vo: backend/PPCgen.v lib/Coqlib.vo lib/Maps.vo backend/AST.vo lib/Integers.vo lib/Floats.vo backend/Values.vo backend/Mem.vo backend/Globalenvs.vo backend/Op.vo backend/Locations.vo backend/Mach.vo backend/PPC.vo -backend/PPCgenproof1.vo: backend/PPCgenproof1.v lib/Coqlib.vo lib/Maps.vo backend/AST.vo lib/Integers.vo lib/Floats.vo backend/Values.vo backend/Mem.vo backend/Globalenvs.vo backend/Op.vo backend/Locations.vo backend/Mach.vo backend/Machtyping.vo backend/PPC.vo backend/PPCgen.vo -backend/PPCgenproof.vo: backend/PPCgenproof.v lib/Coqlib.vo lib/Maps.vo backend/AST.vo lib/Integers.vo lib/Floats.vo backend/Values.vo backend/Mem.vo backend/Globalenvs.vo backend/Op.vo backend/Locations.vo backend/Mach.vo backend/Machtyping.vo backend/PPC.vo backend/PPCgen.vo backend/PPCgenproof1.vo +backend/PPCgenproof1.vo: backend/PPCgenproof1.v lib/Coqlib.vo lib/Maps.vo backend/AST.vo lib/Integers.vo lib/Floats.vo backend/Values.vo backend/Mem.vo backend/Globalenvs.vo backend/Op.vo backend/Locations.vo backend/Mach.vo backend/Machtyping.vo backend/PPC.vo backend/PPCgen.vo backend/Conventions.vo +backend/PPCgenproof.vo: backend/PPCgenproof.v lib/Coqlib.vo lib/Maps.vo backend/AST.vo lib/Integers.vo lib/Floats.vo backend/Values.vo backend/Mem.vo backend/Events.vo backend/Globalenvs.vo backend/Op.vo backend/Locations.vo backend/Mach.vo backend/Machtyping.vo backend/PPC.vo backend/PPCgen.vo backend/PPCgenproof1.vo backend/Main.vo: backend/Main.v lib/Coqlib.vo lib/Maps.vo backend/AST.vo backend/Values.vo backend/Csharpminor.vo backend/Cminor.vo backend/RTL.vo backend/LTL.vo backend/Linear.vo backend/Mach.vo backend/PPC.vo backend/Cminorgen.vo backend/RTLgen.vo backend/Constprop.vo backend/CSE.vo backend/Allocation.vo backend/Tunneling.vo backend/Linearize.vo backend/Stacking.vo backend/PPCgen.vo backend/RTLtyping.vo backend/LTLtyping.vo backend/Lineartyping.vo backend/Machtyping.vo backend/Cminorgenproof.vo backend/RTLgenproof.vo backend/Constpropproof.vo backend/CSEproof.vo backend/Allocproof.vo backend/Alloctyping.vo backend/Tunnelingproof.vo backend/Tunnelingtyping.vo backend/Linearizeproof.vo backend/Linearizetyping.vo backend/Stackingproof.vo backend/Stackingtyping.vo backend/Machabstr2mach.vo backend/PPCgenproof.vo +cfrontend/Csyntax.vo: cfrontend/Csyntax.v lib/Coqlib.vo lib/Integers.vo lib/Floats.vo backend/AST.vo +cfrontend/Csem.vo: cfrontend/Csem.v lib/Coqlib.vo lib/Maps.vo lib/Integers.vo lib/Floats.vo backend/Values.vo backend/AST.vo backend/Mem.vo backend/Events.vo backend/Globalenvs.vo cfrontend/Csyntax.vo +cfrontend/Ctyping.vo: cfrontend/Ctyping.v lib/Coqlib.vo lib/Maps.vo backend/AST.vo cfrontend/Csyntax.vo +cfrontend/Cshmgen.vo: cfrontend/Cshmgen.v lib/Coqlib.vo lib/Integers.vo lib/Floats.vo backend/AST.vo cfrontend/Csyntax.vo backend/Csharpminor.vo +cfrontend/Cshmgenproof1.vo: cfrontend/Cshmgenproof1.v lib/Coqlib.vo lib/Maps.vo lib/Integers.vo lib/Floats.vo backend/AST.vo backend/Values.vo backend/Events.vo backend/Mem.vo backend/Globalenvs.vo cfrontend/Csyntax.vo cfrontend/Csem.vo cfrontend/Ctyping.vo backend/Csharpminor.vo cfrontend/Cshmgen.vo +cfrontend/Cshmgenproof2.vo: cfrontend/Cshmgenproof2.v lib/Coqlib.vo lib/Maps.vo lib/Integers.vo lib/Floats.vo backend/AST.vo backend/Values.vo backend/Events.vo backend/Mem.vo backend/Globalenvs.vo cfrontend/Csyntax.vo cfrontend/Csem.vo cfrontend/Ctyping.vo backend/Csharpminor.vo cfrontend/Cshmgen.vo cfrontend/Cshmgenproof1.vo +cfrontend/Cshmgenproof3.vo: cfrontend/Cshmgenproof3.v lib/Coqlib.vo lib/Maps.vo lib/Integers.vo lib/Floats.vo backend/AST.vo backend/Values.vo backend/Events.vo backend/Mem.vo backend/Globalenvs.vo cfrontend/Csyntax.vo cfrontend/Csem.vo cfrontend/Ctyping.vo backend/Csharpminor.vo cfrontend/Cshmgen.vo cfrontend/Cshmgenproof1.vo cfrontend/Cshmgenproof2.vo @@ -2,16 +2,16 @@ COQC=coqc $(INCLUDES) COQDEP=coqdep $(INCLUDES) COQDOC=coqdoc -INCLUDES=-I lib -I backend +INCLUDES=-I lib -I backend -I cfrontend # Files in lib/ LIB=Coqlib.v Maps.v Sets.v union_find.v Inclusion.v Lattice.v Ordered.v \ - Integers.v Floats.v + Iteration.v Integers.v Floats.v Parmov.v # Files in backend/ -BACKEND=AST.v Values.v Mem.v Globalenvs.v \ +BACKEND=AST.v Values.v Mem.v Events.v Globalenvs.v \ Op.v Cminor.v \ Cmconstr.v Cmconstrproof.v \ Csharpminor.v Cminorgen.v Cminorgenproof.v \ @@ -24,8 +24,7 @@ BACKEND=AST.v Values.v Mem.v Globalenvs.v \ Locations.v Conventions.v LTL.v LTLtyping.v \ InterfGraph.v Coloring.v Coloringproof.v \ Parallelmove.v Allocation.v \ - Allocproof_aux.v Allocproof.v \ - Alloctyping_aux.v Alloctyping.v \ + Allocproof.v Alloctyping.v \ Tunneling.v Tunnelingproof.v Tunnelingtyping.v \ Linear.v Lineartyping.v \ Linearize.v Linearizeproof.v Linearizetyping.v \ @@ -35,11 +34,16 @@ BACKEND=AST.v Values.v Mem.v Globalenvs.v \ PPC.v PPCgen.v PPCgenproof1.v PPCgenproof.v \ Main.v +# Files in cfrontend/ + +CFRONTEND=Csyntax.v Csem.v Ctyping.v Cshmgen.v \ + Cshmgenproof1.v Cshmgenproof2.v Cshmgenproof3.v + # All source files -FILES=$(LIB:%=lib/%) $(BACKEND:%=backend/%) +FILES=$(LIB:%=lib/%) $(BACKEND:%=backend/%) $(CFRONTEND:%=cfrontend/%) -FLATFILES=$(LIB) $(BACKEND) +FLATFILES=$(LIB) $(BACKEND) $(CFRONTEND) proof: $(FILES:.v=.vo) diff --git a/backend/AST.v b/backend/AST.v index aae9e86..1342bef 100644 --- a/backend/AST.v +++ b/backend/AST.v @@ -2,6 +2,8 @@ the abstract syntax trees of many of the intermediate languages. *) Require Import Coqlib. +Require Import Integers. +Require Import Floats. Set Implicit Arguments. @@ -33,6 +35,12 @@ Record signature : Set := mksignature { sig_res: option typ }. +Definition proj_sig_res (s: signature) : typ := + match s.(sig_res) with + | None => Tint + | Some t => t + end. + (** Memory accesses (load and store instructions) are annotated by a ``memory chunk'' indicating the type, size and signedness of the chunk of memory being accessed. *) @@ -46,41 +54,20 @@ Inductive memory_chunk : Set := | Mfloat32 : memory_chunk (**r 32-bit single-precision float *) | Mfloat64 : memory_chunk. (**r 64-bit double-precision float *) -(** Comparison instructions can perform one of the six following comparisons - between their two operands. *) - -Inductive comparison : Set := - | Ceq : comparison (**r same *) - | Cne : comparison (**r different *) - | Clt : comparison (**r less than *) - | Cle : comparison (**r less than or equal *) - | Cgt : comparison (**r greater than *) - | Cge : comparison. (**r greater than or equal *) - -Definition negate_comparison (c: comparison): comparison := - match c with - | Ceq => Cne - | Cne => Ceq - | Clt => Cge - | Cle => Cgt - | Cgt => Cle - | Cge => Clt - end. +(** Initialization data for global variables. *) -Definition swap_comparison (c: comparison): comparison := - match c with - | Ceq => Ceq - | Cne => Cne - | Clt => Cgt - | Cle => Cge - | Cgt => Clt - | Cge => Cle - end. +Inductive init_data: Set := + | Init_int8: int -> init_data + | Init_int16: int -> init_data + | Init_int32: int -> init_data + | Init_float32: float -> init_data + | Init_float64: float -> init_data + | Init_space: Z -> init_data. (** Whole programs consist of: - a collection of function definitions (name and description); - the name of the ``main'' function that serves as entry point in the program; -- a collection of global variable declarations (name and size in bytes). +- a collection of global variable declarations (name and initializer). The type of function descriptions varies among the various intermediate languages and is taken as parameter to the [program] type. The other parts @@ -89,7 +76,7 @@ of whole programs are common to all languages. *) Record program (funct: Set) : Set := mkprogram { prog_funct: list (ident * funct); prog_main: ident; - prog_vars: list (ident * Z) + prog_vars: list (ident * list init_data) }. (** We now define a general iterator over programs that applies a given @@ -214,3 +201,50 @@ Proof. Qed. End TRANSF_PARTIAL_PROGRAM. + +(** For most languages, the functions composing the program are either + internal functions, defined within the language, or external functions + (a.k.a. system calls) that emit an event when applied. We define + a type for such functions and some generic transformation functions. *) + +Record external_function : Set := mkextfun { + ef_id: ident; + ef_sig: signature +}. + +Inductive fundef (F: Set): Set := + | Internal: F -> fundef F + | External: external_function -> fundef F. + +Implicit Arguments External [F]. + +Section TRANSF_FUNDEF. + +Variable A B: Set. +Variable transf: A -> B. + +Definition transf_fundef (fd: fundef A): fundef B := + match fd with + | Internal f => Internal (transf f) + | External ef => External ef + end. + +End TRANSF_FUNDEF. + +Section TRANSF_PARTIAL_FUNDEF. + +Variable A B: Set. +Variable transf_partial: A -> option B. + +Definition transf_partial_fundef (fd: fundef A): option (fundef B) := + match fd with + | Internal f => + match transf_partial f with + | None => None + | Some f' => Some (Internal f') + end + | External ef => Some (External ef) + end. + +End TRANSF_PARTIAL_FUNDEF. + diff --git a/backend/Allocation.v b/backend/Allocation.v index 30f9dcc..d919d1e 100644 --- a/backend/Allocation.v +++ b/backend/Allocation.v @@ -87,6 +87,8 @@ Definition transfer | Icall sig ros args res s => reg_list_live args (reg_sum_live ros (reg_dead res after)) + | Ialloc arg res s => + reg_live arg (reg_dead res after) | Icond cond args ifso ifnot => reg_list_live args after | Ireturn optarg => @@ -214,20 +216,10 @@ Definition add_move (src dst: loc) (k: block) := length. This is a parallel move, meaning that arbitrary overlap between the sources and destinations is permitted. *) -Fixpoint listsLoc2Moves (src dst : list loc) {struct src} : Moves := - match src, dst with - | nil, _ => nil - | s :: srcs, nil => nil - | s :: srcs, d :: dsts => (s, d) :: listsLoc2Moves srcs dsts - end. - -Definition parallel_move_order (src dst : list loc) := - Parallelmove.P_move (listsLoc2Moves src dst). - Definition parallel_move (srcs dsts: list loc) (k: block) : block := - List.fold_left - (fun k p => add_move (fst p) (snd p) k) - (parallel_move_order srcs dsts) k. + List.fold_right + (fun p k => add_move (fst p) (snd p) k) + k (parmove srcs dsts). (** ** Constructors for LTL instructions *) @@ -261,6 +253,10 @@ Definition add_store (chunk: memory_chunk) (addr: addressing) (Bstore chunk addr rargs rsrc (Bgoto s)) end. +Definition add_alloc (arg: loc) (res: loc) (s: node) := + add_reload arg Conventions.loc_alloc_argument + (Balloc (add_spill Conventions.loc_alloc_result res (Bgoto s))). + (** For function calls, we also add appropriate moves to and from the canonical locations for function arguments and function results, as dictated by the calling conventions. *) @@ -344,10 +340,12 @@ Definition transf_instr | Icall sig ros args res s => add_call sig (sum_left_map assign ros) (List.map assign args) (assign res) s + | Ialloc arg res s => + add_alloc (assign arg) (assign res) s | Icond cond args ifso ifnot => add_cond cond (List.map assign args) ifso ifnot | Ireturn optarg => - add_return (RTL.fn_sig f) (option_map assign optarg) + add_return f.(RTL.fn_sig) (option_map assign optarg) end. Definition transf_entrypoint @@ -391,7 +389,7 @@ Qed. transformation as described above. *) Definition transf_function (f: RTL.function) : option LTL.function := - match type_rtl_function f with + match type_function f with | None => None | Some env => match analyze f with @@ -413,6 +411,17 @@ Definition transf_function (f: RTL.function) : option LTL.function := end end. +Definition transf_fundef (fd: RTL.fundef) : option LTL.fundef := + match fd with + | External ef => + if type_external_function ef then Some (External ef) else None + | Internal f => + match transf_function f with + | None => None + | Some tf => Some (Internal tf) + end + end. + Definition transf_program (p: RTL.program) : option LTL.program := - transform_partial_program transf_function p. + transform_partial_program transf_fundef p. diff --git a/backend/Allocproof.v b/backend/Allocproof.v index 138e6d7..07c0f58 100644 --- a/backend/Allocproof.v +++ b/backend/Allocproof.v @@ -8,6 +8,7 @@ Require Import AST. Require Import Integers. Require Import Values. Require Import Mem. +Require Import Events. Require Import Globalenvs. Require Import Op. Require Import Registers. @@ -17,8 +18,8 @@ Require Import Locations. Require Import Conventions. Require Import Coloring. Require Import Coloringproof. +Require Import Parallelmove. Require Import Allocation. -Require Import Allocproof_aux. (** * Semantic properties of calling conventions *) @@ -473,7 +474,7 @@ Qed. Lemma add_reload_correct: forall src dst k rs m, exists rs', - exec_instrs ge sp (add_reload src dst k) rs m k rs' m /\ + exec_instrs ge sp (add_reload src dst k) rs m E0 k rs' m /\ rs' (R dst) = rs src /\ forall l, Loc.diff (R dst) l -> rs' l = rs l. Proof. @@ -493,7 +494,7 @@ Qed. Lemma add_spill_correct: forall src dst k rs m, exists rs', - exec_instrs ge sp (add_spill src dst k) rs m k rs' m /\ + exec_instrs ge sp (add_spill src dst k) rs m E0 k rs' m /\ rs' dst = rs (R src) /\ forall l, Loc.diff dst l -> rs' l = rs l. Proof. @@ -520,7 +521,7 @@ Lemma add_reloads_correct_rec: list_norepet itmps -> list_norepet ftmps -> exists rs', - exec_instrs ge sp (add_reloads srcs (regs_for_rec srcs itmps ftmps) k) rs m k rs' m /\ + exec_instrs ge sp (add_reloads srcs (regs_for_rec srcs itmps ftmps) k) rs m E0 k rs' m /\ reglist (regs_for_rec srcs itmps ftmps) rs' = map rs srcs /\ (forall r, ~(In r itmps) -> ~(In r ftmps) -> rs' (R r) = rs (R r)) /\ (forall s, rs' (S s) = rs (S s)). @@ -578,7 +579,7 @@ Proof. generalize (IHsrcs itmps ftmps k rs1 m R1 R2 R3 R4 R5 R6 R7). intros [rs' [EX [RES [OTH1 OTH2]]]]. exists rs'. - split. eapply exec_trans; eauto. + split. eapply exec_trans; eauto. traceEq. split. simpl. apply (f_equal2 (@cons val)). rewrite OTH1; auto. rewrite RES. apply list_map_exten. intros. @@ -599,7 +600,7 @@ Lemma add_reloads_correct: (List.length srcs <= 3)%nat -> Loc.disjoint srcs temporaries -> exists rs', - exec_instrs ge sp (add_reloads srcs (regs_for srcs) k) rs m k rs' m /\ + exec_instrs ge sp (add_reloads srcs (regs_for srcs) k) rs m E0 k rs' m /\ reglist (regs_for srcs) rs' = List.map rs srcs /\ forall l, Loc.notin l temporaries -> rs' l = rs l. Proof. @@ -638,7 +639,7 @@ Qed. Lemma add_move_correct: forall src dst k rs m, exists rs', - exec_instrs ge sp (add_move src dst k) rs m k rs' m /\ + exec_instrs ge sp (add_move src dst k) rs m E0 k rs' m /\ rs' dst = rs src /\ forall l, Loc.diff l dst -> Loc.diff l (R IT1) -> Loc.diff l (R FT1) -> rs' l = rs l. Proof. @@ -660,13 +661,33 @@ Proof. generalize (add_spill_correct tmp (S s0) k rs1 m); intros [rs2 [EX2 [RES2 OTH2]]]. exists rs2. split. - eapply exec_trans; eauto. + eapply exec_trans; eauto. traceEq. split. congruence. intros. rewrite OTH2. apply OTH1. apply Loc.diff_sym. unfold tmp; case (slot_type s); auto. apply Loc.diff_sym; auto. Qed. +Lemma effect_move_sequence: + forall k moves rs m, + let k' := List.fold_right (fun p k => add_move (fst p) (snd p) k) k moves in + exists rs', + exec_instrs ge sp k' rs m E0 k rs' m /\ + effect_seqmove moves rs rs'. +Proof. + induction moves; intros until m; simpl. + exists rs; split. constructor. constructor. + destruct a as [src dst]; simpl. + set (k1 := fold_right + (fun (p : loc * loc) (k : block) => add_move (fst p) (snd p) k) + k moves) in *. + destruct (add_move_correct src dst k1 rs m) as [rs1 [A [B C]]]. + destruct (IHmoves rs1 m) as [rs' [D E]]. + exists rs'; split. + eapply exec_trans; eauto. traceEq. + econstructor; eauto. red. tauto. +Qed. + Theorem parallel_move_correct: forall srcs dsts k rs m, List.length srcs = List.length dsts -> @@ -675,13 +696,16 @@ Theorem parallel_move_correct: Loc.disjoint srcs temporaries -> Loc.disjoint dsts temporaries -> exists rs', - exec_instrs ge sp (parallel_move srcs dsts k) rs m k rs' m /\ + exec_instrs ge sp (parallel_move srcs dsts k) rs m E0 k rs' m /\ List.map rs' dsts = List.map rs srcs /\ rs' (R IT3) = rs (R IT3) /\ forall l, Loc.notin l dsts -> Loc.notin l temporaries -> rs' l = rs l. Proof. - apply (parallel_move_correctX ge sp). - apply add_move_correct. + intros. + generalize (effect_move_sequence k (parmove srcs dsts) rs m). + intros [rs' [EXEC EFFECT]]. + exists rs'. split. exact EXEC. + apply effect_parmove; auto. Qed. Lemma add_op_correct: @@ -690,7 +714,7 @@ Lemma add_op_correct: Loc.disjoint args temporaries -> eval_operation ge sp op (List.map rs args) = Some v -> exists rs', - exec_block ge sp (add_op op args res s) rs m (Cont s) rs' m /\ + exec_block ge sp (add_op op args res s) rs m E0 (Cont s) rs' m /\ rs' res = v /\ forall l, Loc.diff l res -> Loc.notin l temporaries -> rs' l = rs l. Proof. @@ -721,7 +745,7 @@ Proof. split. apply exec_Bgoto. eapply exec_trans. eexact EX1. eapply exec_trans; eauto. apply exec_one. unfold rs2. apply exec_Bop. - unfold rargs. rewrite RES1. auto. + unfold rargs. rewrite RES1. auto. traceEq. split. rewrite RES3. unfold rs2; apply Locmap.gss. intros. rewrite OTHER3. unfold rs2. rewrite Locmap.gso. apply OTHER1. assumption. @@ -737,7 +761,7 @@ Lemma add_load_correct: eval_addressing ge sp addr (List.map rs args) = Some a -> loadv chunk m a = Some v -> exists rs', - exec_block ge sp (add_load chunk addr args res s) rs m (Cont s) rs' m /\ + exec_block ge sp (add_load chunk addr args res s) rs m E0 (Cont s) rs' m /\ rs' res = v /\ forall l, Loc.diff l res -> Loc.notin l temporaries -> rs' l = rs l. Proof. @@ -755,7 +779,7 @@ Proof. split. apply exec_Bgoto. eapply exec_trans; eauto. eapply exec_trans; eauto. apply exec_one. unfold rs2. apply exec_Bload with a. - unfold rargs; rewrite RES1. assumption. assumption. + unfold rargs; rewrite RES1. assumption. assumption. traceEq. split. rewrite RES3. unfold rs2; apply Locmap.gss. intros. rewrite OTHER3. unfold rs2. rewrite Locmap.gso. apply OTHER1. assumption. @@ -772,7 +796,7 @@ Lemma add_store_correct: eval_addressing ge sp addr (List.map rs args) = Some a -> storev chunk m a (rs src) = Some m' -> exists rs', - exec_block ge sp (add_store chunk addr args src s) rs m (Cont s) rs' m' /\ + exec_block ge sp (add_store chunk addr args src s) rs m E0 (Cont s) rs' m' /\ forall l, Loc.notin l temporaries -> rs' l = rs l. Proof. intros. @@ -795,10 +819,42 @@ Proof. split. apply exec_Bgoto. eapply exec_trans. rewrite <- EQ. eexact EX1. apply exec_one. apply exec_Bstore with a. - rewrite RES2. assumption. rewrite RES3. assumption. + rewrite RES2. assumption. rewrite RES3. assumption. traceEq. exact OTHER1. Qed. +Lemma add_alloc_correct: + forall arg res s rs m m' sz b, + rs arg = Vint sz -> + Mem.alloc m 0 (Int.signed sz) = (m', b) -> + exists rs', + exec_block ge sp (add_alloc arg res s) rs m E0 (Cont s) rs' m' /\ + rs' res = Vptr b Int.zero /\ + forall l, + Loc.diff l (R Conventions.loc_alloc_argument) -> + Loc.diff l (R Conventions.loc_alloc_result) -> + Loc.diff l res -> + rs' l = rs l. +Proof. + intros; unfold add_alloc. + generalize (add_reload_correct arg loc_alloc_argument + (Balloc (add_spill loc_alloc_result res (Bgoto s))) + rs m). + intros [rs1 [EX1 [RES1 OTHER1]]]. + pose (rs2 := Locmap.set (R loc_alloc_result) (Vptr b Int.zero) rs1). + generalize (add_spill_correct loc_alloc_result res (Bgoto s) rs2 m'). + intros [rs3 [EX3 [RES3 OTHER3]]]. + exists rs3. + split. apply exec_Bgoto. eapply exec_trans. eexact EX1. + eapply exec_trans. apply exec_one. eapply exec_Balloc; eauto. congruence. + fold rs2. eexact EX3. reflexivity. traceEq. + split. rewrite RES3; unfold rs2. apply Locmap.gss. + intros. rewrite OTHER3. unfold rs2. rewrite Locmap.gso. + apply OTHER1. apply Loc.diff_sym; auto. + apply Loc.diff_sym; auto. + apply Loc.diff_sym; auto. +Qed. + Lemma add_cond_correct: forall cond args ifso ifnot rs m b s, (List.length args <= 3)%nat -> @@ -806,7 +862,7 @@ Lemma add_cond_correct: eval_condition cond (List.map rs args) = Some b -> s = (if b then ifso else ifnot) -> exists rs', - exec_block ge sp (add_cond cond args ifso ifnot) rs m (Cont s) rs' m /\ + exec_block ge sp (add_cond cond args ifso ifnot) rs m E0 (Cont s) rs' m /\ forall l, Loc.notin l temporaries -> rs' l = rs l. Proof. intros. unfold add_cond. @@ -825,7 +881,7 @@ Proof. exact OTHER1. Qed. -Definition find_function2 (los: loc + ident) (ls: locset) : option function := +Definition find_function2 (los: loc + ident) (ls: locset) : option fundef := match los with | inl l => Genv.find_funct ge (ls l) | inr symb => @@ -836,21 +892,21 @@ Definition find_function2 (los: loc + ident) (ls: locset) : option function := end. Lemma add_call_correct: - forall f vargs m vres m' sig los args res s ls + forall f vargs m t vres m' sig los args res s ls (EXECF: forall lsi, - List.map lsi (loc_arguments f.(fn_sig)) = vargs -> + List.map lsi (loc_arguments (funsig f)) = vargs -> exists lso, - exec_function ge f lsi m lso m' - /\ lso (R (loc_result f.(fn_sig))) = vres) + exec_function ge f lsi m t lso m' + /\ lso (R (loc_result (funsig f))) = vres) (FIND: find_function2 los ls = Some f) - (SIG: sig = f.(fn_sig)) + (SIG: sig = funsig f) (VARGS: List.map ls args = vargs) (LARGS: List.length args = List.length sig.(sig_args)) (AARGS: locs_acceptable args) (RES: loc_acceptable res), exists ls', - exec_block ge sp (add_call sig los args res s) ls m (Cont s) ls' m' /\ + exec_block ge sp (add_call sig los args res s) ls m t (Cont s) ls' m' /\ ls' res = vres /\ forall l, Loc.notin l destroyed_at_call -> loc_acceptable l -> Loc.diff l res -> @@ -896,7 +952,7 @@ Proof. eapply exec_trans. apply exec_one. apply exec_Bcall with f. unfold find_function. rewrite TMP2. rewrite RES1. assumption. assumption. eexact EX3. - exact EX5. + eexact EX5. reflexivity. reflexivity. traceEq. (* Result *) split. rewrite RES5. unfold ls4. rewrite return_regs_result. assumption. @@ -936,7 +992,7 @@ Proof. eapply exec_trans. eexact EX2. eapply exec_trans. apply exec_one. apply exec_Bcall with f. unfold find_function. assumption. assumption. eexact EX3. - exact EX5. + eexact EX5. reflexivity. traceEq. (* Result *) split. rewrite RES5. unfold ls4. rewrite return_regs_result. @@ -955,7 +1011,7 @@ Lemma add_undefs_correct: (forall l, In l res -> loc_acceptable l) -> (forall ofs ty, In (S (Local ofs ty)) res -> ls (S (Local ofs ty)) = Vundef) -> exists ls', - exec_instrs ge sp (add_undefs res b) ls m b ls' m /\ + exec_instrs ge sp (add_undefs res b) ls m E0 b ls' m /\ (forall l, In l res -> ls' l = Vundef) /\ (forall l, Loc.notin l res -> ls' l = ls l). Proof. @@ -972,7 +1028,7 @@ Proof. intros [ls2 [EX2 [RES2 OTHER2]]]. exists ls2. split. eapply exec_trans. apply exec_one. apply exec_Bop. - simpl; reflexivity. exact EX2. + simpl; reflexivity. eexact EX2. traceEq. split. intros. case (In_dec Loc.eq l res); intro. apply RES2; auto. rewrite OTHER2. elim H1; intro. @@ -1006,7 +1062,7 @@ Lemma add_entry_correct: locs_acceptable undefs -> (forall ofs ty, ls (S (Local ofs ty)) = Vundef) -> exists ls', - exec_block ge sp (add_entry sig params undefs s) ls m (Cont s) ls' m /\ + exec_block ge sp (add_entry sig params undefs s) ls m E0 (Cont s) ls' m /\ List.map ls' params = List.map ls (loc_parameters sig) /\ (forall l, In l undefs -> ls' l = Vundef). Proof. @@ -1029,7 +1085,7 @@ Proof. intros [ls2 [EX2 [RES2 OTHER2]]]. exists ls2. split. apply exec_Bgoto. unfold add_entry. - eapply exec_trans. eexact EX1. eexact EX2. + eapply exec_trans. eexact EX1. eexact EX2. traceEq. split. rewrite <- RES1. apply list_map_exten. intros. symmetry. apply OTHER2. eapply Loc.disjoint_notin; eauto. exact RES2. @@ -1038,7 +1094,7 @@ Qed. Lemma add_return_correct: forall sig optarg ls m, exists ls', - exec_block ge sp (add_return sig optarg) ls m Return ls' m /\ + exec_block ge sp (add_return sig optarg) ls m E0 Return ls' m /\ match optarg with | Some arg => ls' (R (loc_result sig)) = ls arg | None => ls' (R (loc_result sig)) = Vundef @@ -1131,51 +1187,53 @@ Lemma symbols_preserved: forall (s: ident), Genv.find_symbol tge s = Genv.find_symbol ge s. Proof. intro. unfold ge, tge. - apply Genv.find_symbol_transf_partial with transf_function. + apply Genv.find_symbol_transf_partial with transf_fundef. exact TRANSF. Qed. Lemma functions_translated: - forall (v: val) (f: RTL.function), + forall (v: val) (f: RTL.fundef), Genv.find_funct ge v = Some f -> exists tf, - Genv.find_funct tge v = Some tf /\ transf_function f = Some tf. + Genv.find_funct tge v = Some tf /\ transf_fundef f = Some tf. Proof. intros. generalize - (Genv.find_funct_transf_partial transf_function TRANSF H). - case (transf_function f). + (Genv.find_funct_transf_partial transf_fundef TRANSF H). + case (transf_fundef f). intros tf [A B]. exists tf. tauto. intros [A B]. elim B. reflexivity. Qed. Lemma function_ptr_translated: - forall (b: Values.block) (f: RTL.function), + forall (b: Values.block) (f: RTL.fundef), Genv.find_funct_ptr ge b = Some f -> exists tf, - Genv.find_funct_ptr tge b = Some tf /\ transf_function f = Some tf. + Genv.find_funct_ptr tge b = Some tf /\ transf_fundef f = Some tf. Proof. intros. generalize - (Genv.find_funct_ptr_transf_partial transf_function TRANSF H). - case (transf_function f). + (Genv.find_funct_ptr_transf_partial transf_fundef TRANSF H). + case (transf_fundef f). intros tf [A B]. exists tf. tauto. intros [A B]. elim B. reflexivity. Qed. Lemma sig_function_translated: forall f tf, - transf_function f = Some tf -> - tf.(LTL.fn_sig) = f.(RTL.fn_sig). + transf_fundef f = Some tf -> + LTL.funsig tf = RTL.funsig f. Proof. - intros f tf. unfold transf_function. - destruct (type_rtl_function f). + intros f tf. destruct f; simpl. + unfold transf_function. + destruct (type_function f). destruct (analyze f). - destruct (regalloc f t0). + destruct (regalloc f t). intro EQ; injection EQ; intro EQ1; rewrite <- EQ1; simpl; auto. - intros; discriminate. - intros; discriminate. - intros; discriminate. + congruence. congruence. congruence. + destruct (type_external_function e). + intro EQ; inversion EQ; subst tf. reflexivity. + congruence. Qed. Lemma entrypoint_function_translated: @@ -1184,9 +1242,9 @@ Lemma entrypoint_function_translated: tf.(LTL.fn_entrypoint) = f.(RTL.fn_nextpc). Proof. intros f tf. unfold transf_function. - destruct (type_rtl_function f). + destruct (type_function f). destruct (analyze f). - destruct (regalloc f t0). + destruct (regalloc f t). intro EQ; injection EQ; intro EQ1; rewrite <- EQ1; simpl; auto. intros; discriminate. intros; discriminate. @@ -1220,43 +1278,43 @@ Qed. Definition exec_instr_prop (c: RTL.code) (sp: val) - (pc: node) (rs: regset) (m: mem) + (pc: node) (rs: regset) (m: mem) (t: trace) (pc': node) (rs': regset) (m': mem) : Prop := forall f env live assign ls (CF: c = f.(RTL.fn_code)) - (WT: wt_function env f) + (WT: wt_function f env) (ASG: regalloc f live (live0 f live) env = Some assign) (AG: agree assign (transfer f pc live!!pc) rs ls), let tc := PTree.map (transf_instr f live assign) c in exists ls', - exec_blocks tge tc sp pc ls m (Cont pc') ls' m' /\ + exec_blocks tge tc sp pc ls m t (Cont pc') ls' m' /\ agree assign live!!pc rs' ls'. Definition exec_instrs_prop (c: RTL.code) (sp: val) - (pc: node) (rs: regset) (m: mem) + (pc: node) (rs: regset) (m: mem) (t: trace) (pc': node) (rs': regset) (m': mem) : Prop := forall f env live assign ls, forall (CF: c = f.(RTL.fn_code)) - (WT: wt_function env f) + (WT: wt_function f env) (ANL: analyze f = Some live) (ASG: regalloc f live (live0 f live) env = Some assign) (AG: agree assign (transfer f pc live!!pc) rs ls) (VALIDPC': c!pc' <> None), let tc := PTree.map (transf_instr f live assign) c in exists ls', - exec_blocks tge tc sp pc ls m (Cont pc') ls' m' /\ + exec_blocks tge tc sp pc ls m t (Cont pc') ls' m' /\ agree assign (transfer f pc' live!!pc') rs' ls'. Definition exec_function_prop - (f: RTL.function) (args: list val) (m: mem) - (res: val) (m': mem) : Prop := + (f: RTL.fundef) (args: list val) (m: mem) + (t: trace) (res: val) (m': mem) : Prop := forall ls tf, - transf_function f = Some tf -> - List.map ls (Conventions.loc_arguments tf.(fn_sig)) = args -> + transf_fundef f = Some tf -> + List.map ls (Conventions.loc_arguments (funsig tf)) = args -> exists ls', - LTL.exec_function tge tf ls m ls' m' /\ - ls' (R (Conventions.loc_result tf.(fn_sig))) = res. + LTL.exec_function tge tf ls m t ls' m' /\ + ls' (R (Conventions.loc_result (funsig tf))) = res. (** The simulation proof is by structural induction over the RTL evaluation derivation. We prove each case of the proof as a separate lemma. @@ -1298,7 +1356,7 @@ Lemma transl_Inop_correct: forall (c : PTree.t instruction) (sp: val) (pc : positive) (rs : regset) (m : mem) (pc' : RTL.node), c ! pc = Some (Inop pc') -> - exec_instr_prop c sp pc rs m pc' rs m. + exec_instr_prop c sp pc rs m E0 pc' rs m. Proof. intros; red; intros; CleanupHyps. exists ls. split. @@ -1312,7 +1370,7 @@ Lemma transl_Iop_correct: (res : reg) (pc' : RTL.node) (v: val), c ! pc = Some (Iop op args res pc') -> eval_operation ge sp op (rs ## args) = Some v -> - exec_instr_prop c sp pc rs m pc' (rs # res <- v) m. + exec_instr_prop c sp pc rs m E0 pc' (rs # res <- v) m. Proof. intros; red; intros; CleanupHyps. caseEq (Regset.mem res live!!pc); intro LV; @@ -1364,7 +1422,7 @@ Lemma transl_Iload_correct: c ! pc = Some (Iload chunk addr args dst pc') -> eval_addressing ge sp addr rs ## args = Some a -> loadv chunk m a = Some v -> - exec_instr_prop c sp pc rs m pc' rs # dst <- v m. + exec_instr_prop c sp pc rs m E0 pc' rs # dst <- v m. Proof. intros; red; intros; CleanupHyps. caseEq (Regset.mem dst live!!pc); intro LV; @@ -1407,7 +1465,7 @@ Lemma transl_Istore_correct: c ! pc = Some (Istore chunk addr args src pc') -> eval_addressing ge sp addr rs ## args = Some a -> storev chunk m a rs # src = Some m' -> - exec_instr_prop c sp pc rs m pc' rs m'. + exec_instr_prop c sp pc rs m E0 pc' rs m'. Proof. intros; red; intros; CleanupHyps. assert (LL: (List.length (List.map assign args) <= 2)%nat). @@ -1444,19 +1502,19 @@ Lemma transl_Icall_correct: forall (c : PTree.t instruction) (sp: val) (pc : positive) (rs : regset) (m : mem) (sig : signature) (ros : reg + ident) (args : list reg) (res : reg) (pc' : RTL.node) - (f : RTL.function) (vres : val) (m' : mem), + (f : RTL.fundef) (vres : val) (m' : mem) (t: trace), c ! pc = Some (Icall sig ros args res pc') -> RTL.find_function ge ros rs = Some f -> - sig = RTL.fn_sig f -> - RTL.exec_function ge f (rs##args) m vres m' -> - exec_function_prop f (rs##args) m vres m' -> - exec_instr_prop c sp pc rs m pc' (rs#res <- vres) m'. + RTL.funsig f = sig -> + RTL.exec_function ge f (rs##args) m t vres m' -> + exec_function_prop f (rs##args) m t vres m' -> + exec_instr_prop c sp pc rs m t pc' (rs#res <- vres) m'. Proof. intros; red; intros; CleanupHyps. set (los := sum_left_map assign ros). assert (FIND: exists tf, find_function2 tge los ls = Some tf /\ - transf_function f = Some tf). + transf_fundef f = Some tf). unfold los. destruct ros; simpl; simpl in H0. apply functions_translated. replace (ls (assign r)) with rs#r. assumption. @@ -1466,7 +1524,7 @@ Proof. apply function_ptr_translated. auto. discriminate. elim FIND; intros tf [AFIND TRF]; clear FIND. - assert (ASIG: sig = fn_sig tf). + assert (ASIG: sig = funsig tf). rewrite (sig_function_translated _ _ TRF). auto. generalize (fun ls => H3 ls tf TRF); intro AEXECF. assert (AVARGS: List.map ls (List.map assign args) = rs##args). @@ -1482,7 +1540,7 @@ Proof. unfold correct_alloc_instr. intros [CORR1 CORR2]. assert (ARES: loc_acceptable (assign res)). eapply regalloc_acceptable; eauto. - generalize (add_call_correct tge sp tf _ _ _ _ _ _ _ _ pc' _ + generalize (add_call_correct tge sp tf _ _ _ _ _ _ _ _ _ pc' _ AEXECF AFIND ASIG AVARGS ALARGS AACCEPT ARES). intros [ls' [EX [RES OTHER]]]. @@ -1491,13 +1549,42 @@ Proof. simpl. eapply agree_call; eauto. Qed. +Lemma transl_Ialloc_correct: + forall (c : PTree.t instruction) (sp: val) (pc : positive) + (rs : Regmap.t val) (m : mem) (pc': RTL.node) (arg res: reg) + (sz: int) (m': mem) (b: Values.block), + c ! pc = Some (Ialloc arg res pc') -> + rs#arg = Vint sz -> + Mem.alloc m 0 (Int.signed sz) = (m', b) -> + exec_instr_prop c sp pc rs m E0 pc' (rs # res <- (Vptr b Int.zero)) m'. +Proof. + intros; red; intros; CleanupHyps. + assert (SZ: ls (assign arg) = Vint sz). + rewrite <- H0. eapply agree_eval_reg. eauto. + generalize (add_alloc_correct tge sp (assign arg) (assign res) + pc' ls m m' sz b SZ H1). + intros [ls' [EX [RES OTHER]]]. + exists ls'. + split. CleanupGoal. exact EX. + rewrite CF in H. + generalize (regalloc_correct_1 f env live _ _ _ _ ASG H). + unfold correct_alloc_instr. intros [CORR1 CORR2]. + eapply agree_call with (args := arg :: nil) (ros := inr reg 1%positive) (ls := ls) (ls' := ls'); eauto. + intros. apply OTHER. + eapply Loc.in_notin_diff; eauto. + unfold loc_alloc_argument, destroyed_at_call; simpl; tauto. + eapply Loc.in_notin_diff; eauto. + unfold loc_alloc_argument, destroyed_at_call; simpl; tauto. + auto. +Qed. + Lemma transl_Icond_true_correct: forall (c : PTree.t instruction) (sp: val) (pc : positive) (rs : Regmap.t val) (m : mem) (cond : condition) (args : list reg) (ifso ifnot : RTL.node), c ! pc = Some (Icond cond args ifso ifnot) -> eval_condition cond rs ## args = Some true -> - exec_instr_prop c sp pc rs m ifso rs m. + exec_instr_prop c sp pc rs m E0 ifso rs m. Proof. intros; red; intros; CleanupHyps. assert (LL: (List.length (map assign args) <= 3)%nat). @@ -1523,7 +1610,7 @@ Lemma transl_Icond_false_correct: (ifso ifnot : RTL.node), c ! pc = Some (Icond cond args ifso ifnot) -> eval_condition cond rs ## args = Some false -> - exec_instr_prop c sp pc rs m ifnot rs m. + exec_instr_prop c sp pc rs m E0 ifnot rs m. Proof. intros; red; intros; CleanupHyps. assert (LL: (List.length (map assign args) <= 3)%nat). @@ -1545,7 +1632,7 @@ Qed. Lemma transl_refl_correct: forall (c : RTL.code) (sp: val) (pc : RTL.node) (rs : regset) - (m : mem), exec_instrs_prop c sp pc rs m pc rs m. + (m : mem), exec_instrs_prop c sp pc rs m E0 pc rs m. Proof. intros; red; intros. exists ls. split. apply exec_blocks_refl. assumption. @@ -1553,10 +1640,10 @@ Qed. Lemma transl_one_correct: forall (c : RTL.code) (sp: val) (pc : RTL.node) (rs : regset) - (m : mem) (pc' : RTL.node) (rs' : regset) (m' : mem), - RTL.exec_instr ge c sp pc rs m pc' rs' m' -> - exec_instr_prop c sp pc rs m pc' rs' m' -> - exec_instrs_prop c sp pc rs m pc' rs' m'. + (m : mem) (t: trace) (pc' : RTL.node) (rs' : regset) (m' : mem), + RTL.exec_instr ge c sp pc rs m t pc' rs' m' -> + exec_instr_prop c sp pc rs m t pc' rs' m' -> + exec_instrs_prop c sp pc rs m t pc' rs' m'. Proof. intros; red; intros. generalize (H0 f env live assign ls CF WT ASG AG). @@ -1573,13 +1660,14 @@ Qed. Lemma transl_trans_correct: forall (c : RTL.code) (sp: val) (pc1 : RTL.node) (rs1 : regset) - (m1 : mem) (pc2 : RTL.node) (rs2 : regset) (m2 : mem) - (pc3 : RTL.node) (rs3 : regset) (m3 : mem), - RTL.exec_instrs ge c sp pc1 rs1 m1 pc2 rs2 m2 -> - exec_instrs_prop c sp pc1 rs1 m1 pc2 rs2 m2 -> - RTL.exec_instrs ge c sp pc2 rs2 m2 pc3 rs3 m3 -> - exec_instrs_prop c sp pc2 rs2 m2 pc3 rs3 m3 -> - exec_instrs_prop c sp pc1 rs1 m1 pc3 rs3 m3. + (m1 : mem) (t1: trace) (pc2 : RTL.node) (rs2 : regset) (m2 : mem) + (t2: trace) (pc3 : RTL.node) (rs3 : regset) (m3 : mem) (t3: trace), + RTL.exec_instrs ge c sp pc1 rs1 m1 t1 pc2 rs2 m2 -> + exec_instrs_prop c sp pc1 rs1 m1 t1 pc2 rs2 m2 -> + RTL.exec_instrs ge c sp pc2 rs2 m2 t2 pc3 rs3 m3 -> + exec_instrs_prop c sp pc2 rs2 m2 t2 pc3 rs3 m3 -> + t3 = t1 ** t2 -> + exec_instrs_prop c sp pc1 rs1 m1 t3 pc3 rs3 m3. Proof. intros; red; intros. assert (VALIDPC2: c!pc2 <> None). @@ -1589,7 +1677,7 @@ Proof. generalize (H2 f env live assign ls1 CF WT ANL ASG AG1 VALIDPC'). intros [ls2 [EX2 AG2]]. exists ls2. split. - eapply exec_blocks_trans. eexact EX1. exact EX2. + eapply exec_blocks_trans. eexact EX1. eexact EX2. auto. exact AG2. Qed. @@ -1609,14 +1697,14 @@ Qed. Lemma transf_entrypoint_correct: forall f env live assign c ls args sp m, - wt_function env f -> + wt_function f env -> regalloc f live (live0 f live) env = Some assign -> c!(RTL.fn_nextpc f) = None -> List.map ls (loc_parameters (RTL.fn_sig f)) = args -> (forall ofs ty, ls (S (Local ofs ty)) = Vundef) -> let tc := transf_entrypoint f live assign c in exists ls', - exec_blocks tge tc sp (RTL.fn_nextpc f) ls m + exec_blocks tge tc sp (RTL.fn_nextpc f) ls m E0 (Cont (RTL.fn_entrypoint f)) ls' m /\ agree assign (transfer f (RTL.fn_entrypoint f) live!!(RTL.fn_entrypoint f)) (init_regs args (RTL.fn_params f)) ls'. @@ -1680,20 +1768,20 @@ Qed. Lemma transl_function_correct: forall (f : RTL.function) (m m1 : mem) (stk : Values.block) - (args : list val) (pc : RTL.node) (rs : regset) (m2 : mem) + (args : list val) (t: trace) (pc : RTL.node) (rs : regset) (m2 : mem) (or : option reg) (vres : val), alloc m 0 (RTL.fn_stacksize f) = (m1, stk) -> RTL.exec_instrs ge (RTL.fn_code f) (Vptr stk Int.zero) - (RTL.fn_entrypoint f) (init_regs args (fn_params f)) m1 pc rs m2 -> + (RTL.fn_entrypoint f) (init_regs args (fn_params f)) m1 t pc rs m2 -> exec_instrs_prop (RTL.fn_code f) (Vptr stk Int.zero) - (RTL.fn_entrypoint f) (init_regs args (fn_params f)) m1 pc rs m2 -> + (RTL.fn_entrypoint f) (init_regs args (fn_params f)) m1 t pc rs m2 -> (RTL.fn_code f) ! pc = Some (Ireturn or) -> vres = regmap_optget or Vundef rs -> - exec_function_prop f args m vres (free m2 stk). + exec_function_prop (Internal f) args m t vres (free m2 stk). Proof. intros; red; intros until tf. - unfold transf_function. - caseEq (type_rtl_function f). + unfold transf_fundef, transf_function. + caseEq (type_function f). intros env TRF. caseEq (analyze f). intros live ANL. @@ -1704,7 +1792,7 @@ Proof. set (tc1 := PTree.map (transf_instr f live alloc) (RTL.fn_code f)). set (tc2 := transf_entrypoint f live alloc tc1). intro EQ; injection EQ; intro TF; clear EQ. intro VARGS. - generalize (type_rtl_function_correct _ _ TRF); intro WTF. + generalize (type_function_correct _ _ TRF); intro WTF. assert (NEWINSTR: tc1!(RTL.fn_nextpc f) = None). unfold tc1; rewrite PTree.gmap. unfold option_map. elim (RTL.fn_code_wf f (fn_nextpc f)); intro. @@ -1712,7 +1800,7 @@ Proof. rewrite H4. auto. pose (ls1 := call_regs ls). assert (VARGS1: List.map ls1 (loc_parameters (RTL.fn_sig f)) = args). - replace (RTL.fn_sig f) with (fn_sig tf). + replace (RTL.fn_sig f) with (funsig tf). rewrite <- VARGS. unfold loc_parameters. rewrite list_map_compose. apply list_map_exten. intros. symmetry. unfold ls1. eapply call_regs_param_of_arg; eauto. @@ -1732,9 +1820,9 @@ Proof. intros [ls4 [EX4 RES4]]. exists ls4. (* Execution *) - split. apply exec_funct with m1. - rewrite <- TF; simpl; assumption. - rewrite <- TF; simpl. fold ls1. + split. rewrite <- TF; apply exec_funct_internal with m1; simpl. + assumption. + fold ls1. eapply exec_blocks_trans. eexact EX2. apply exec_blocks_extends with tc1. intro p. unfold tc2. unfold transf_entrypoint. @@ -1746,7 +1834,7 @@ Proof. eapply exec_blocks_trans. eexact EX3. eapply exec_blocks_one. unfold tc1. rewrite PTree.gmap. rewrite H2. simpl. reflexivity. - exact EX4. + eexact EX4. reflexivity. traceEq. destruct or. simpl in RES4. simpl in H3. rewrite H3. rewrite <- TF; simpl. rewrite RES4. @@ -1760,6 +1848,20 @@ Proof. intros; discriminate. Qed. +Lemma transl_external_function_correct: + forall (ef : external_function) (args : list val) (m : mem) + (t: trace) (res: val), + event_match ef args t res -> + exec_function_prop (External ef) args m t res m. +Proof. + intros; red; intros. + simpl in H0. + destruct (type_external_function ef); simplify_eq H0; intro. + exists (Locmap.set (R (loc_result (funsig tf))) res ls); split. + subst tf. eapply exec_funct_external; eauto. + apply Locmap.gss. +Qed. + (** The correctness of the code transformation is obtained by structural induction (and case analysis on the last rule used) on the RTL evaluation derivation. @@ -1767,14 +1869,10 @@ Qed. [exec_instrs_prop] and [exec_function_prop] as the induction hypotheses, and the lemmas above as cases for the induction. *) -Scheme exec_instr_ind_3 := Minimality for RTL.exec_instr Sort Prop - with exec_instrs_ind_3 := Minimality for RTL.exec_instrs Sort Prop - with exec_function_ind_3 := Minimality for RTL.exec_function Sort Prop. - Theorem transl_function_correctness: - forall f args m res m', - RTL.exec_function ge f args m res m' -> - exec_function_prop f args m res m'. + forall f args m t res m', + RTL.exec_function ge f args m t res m' -> + exec_function_prop f args m t res m'. Proof (exec_function_ind_3 ge exec_instr_prop @@ -1786,6 +1884,7 @@ Proof transl_Iload_correct transl_Istore_correct transl_Icall_correct + transl_Ialloc_correct transl_Icond_true_correct transl_Icond_false_correct @@ -1793,23 +1892,24 @@ Proof transl_one_correct transl_trans_correct - transl_function_correct). + transl_function_correct + transl_external_function_correct). (** The semantic equivalence between the original and transformed programs follows easily. *) Theorem transl_program_correct: - forall (r: val), - RTL.exec_program prog r -> LTL.exec_program tprog r. + forall (t: trace) (r: val), + RTL.exec_program prog t r -> LTL.exec_program tprog t r. Proof. - intros r [b [f [m [FIND1 [FIND2 [SIG EXEC]]]]]]. + intros t r [b [f [m [FIND1 [FIND2 [SIG EXEC]]]]]]. generalize (function_ptr_translated _ _ FIND2). intros [tf [TFIND TRF]]. - assert (SIG2: tf.(fn_sig) = mksignature nil (Some Tint)). + assert (SIG2: funsig tf = mksignature nil (Some Tint)). rewrite <- SIG. apply sig_function_translated; auto. - assert (VPARAMS: map (Locmap.init Vundef) (loc_arguments (fn_sig tf)) = nil). + assert (VPARAMS: map (Locmap.init Vundef) (loc_arguments (funsig tf)) = nil). rewrite SIG2. reflexivity. - generalize (transl_function_correctness _ _ _ _ _ EXEC + generalize (transl_function_correctness _ _ _ _ _ _ EXEC (Locmap.init Vundef) tf TRF VPARAMS). intros [ls' [TEXEC RES]]. red. exists b; exists tf; exists ls'; exists m. diff --git a/backend/Allocproof_aux.v b/backend/Allocproof_aux.v deleted file mode 100644 index d1b213e..0000000 --- a/backend/Allocproof_aux.v +++ /dev/null @@ -1,850 +0,0 @@ -(** Correctness results for the [parallel_move] function defined in - file [Allocation]. - - The present file, contributed by Laurence Rideau, glues the general - results over the parallel move algorithm (see file [Parallelmove]) - with the correctness proof for register allocation (file [Allocproof]). -*) - -Require Import Coqlib. -Require Import Values. -Require Import Parallelmove. -Require Import Allocation. -Require Import LTL. -Require Import Locations. -Require Import Conventions. - -Section parallel_move_correction. -Variable ge : LTL.genv. -Variable sp : val. -Hypothesis - add_move_correct : - forall src dst k rs m, - (exists rs' , - exec_instrs ge sp (add_move src dst k) rs m k rs' m /\ - (rs' dst = rs src /\ - (forall l, - Loc.diff l dst -> - Loc.diff l (R IT1) -> Loc.diff l (R FT1) -> rs' l = rs l)) ). - -Lemma exec_instr_update: - forall a1 a2 k e m, - (exists rs' , - exec_instrs ge sp (add_move a1 a2 k) e m k rs' m /\ - (rs' a2 = update e a2 (e a1) a2 /\ - (forall l, - Loc.diff l a2 -> - Loc.diff l (R IT1) -> Loc.diff l (R FT1) -> rs' l = (update e a2 (e a1)) l)) - ). -Proof. -intros; destruct (add_move_correct a1 a2 k e m) as [rs' [Hf [R1 R2]]]. -exists rs'; (repeat split); auto. -generalize (get_update_id e a2); unfold get, Locmap.get; intros H; rewrite H; - auto. -intros l H0; generalize (get_update_diff e a2); unfold get, Locmap.get; - intros H; rewrite H; auto. -apply Loc.diff_sym; assumption. -Qed. - -Lemma map_inv: - forall (A B : Set) (f f' : A -> B) l, - map f l = map f' l -> forall x, In x l -> f x = f' x. -Proof. -induction l; simpl; intros Hmap x Hin. -elim Hin. -inversion Hmap. -elim Hin; intros H; [subst a | apply IHl]; auto. -Qed. - -Fixpoint reswellFormed (p : Moves) : Prop := - match p with - nil => True - | (s, d) :: l => Loc.notin s (getdst l) /\ reswellFormed l - end. - -Definition temporaries1 := R IT1 :: (R FT1 :: nil). - -Lemma no_overlap_list_pop: - forall p m, no_overlap_list (m :: p) -> no_overlap_list p. -Proof. -induction p; unfold no_overlap_list, no_overlap; destruct m as [m1 m2]; simpl; - auto. -Qed. - -Lemma exec_instrs_pmov: - forall p k rs m, - no_overlap_list p -> - Loc.disjoint (getdst p) temporaries1 -> - Loc.disjoint (getsrc p) temporaries1 -> - (exists rs' , - exec_instrs - ge sp - (fold_left - (fun (k0 : block) => fun (p0 : loc * loc) => add_move (fst p0) (snd p0) k0) - p k) rs m k rs' m /\ - (forall l, - (forall r, In r (getdst p) -> r = l \/ Loc.diff r l) -> - Loc.diff l (Locations.R IT1) -> - Loc.diff l (Locations.R FT1) -> rs' l = (sexec p rs) l) ). -Proof. -induction p; intros k rs m. -simpl; exists rs; (repeat split); auto; apply exec_refl. -destruct a as [a1 a2]; simpl; intros Hno_O Hdisd Hdiss; - elim (IHp (add_move a1 a2 k) rs m); - [idtac | apply no_overlap_list_pop with (a1, a2) | - apply (Loc.disjoint_cons_left a2) | apply (Loc.disjoint_cons_left a1)]; - (try assumption). -intros rs' Hexec; - destruct (add_move_correct a1 a2 k rs' m) as [rs'' [Hexec2 [R1 R2]]]. -exists rs''; elim Hexec; intros; (repeat split). -apply exec_trans with ( b2 := add_move a1 a2 k ) ( rs2 := rs' ) ( m2 := m ); - auto. -intros l Heqd Hdi Hdf; case (Loc.eq a2 l); intro. -subst l; generalize get_update_id; unfold get, Locmap.get; intros Hgui; - rewrite Hgui; rewrite R1. -apply H0; auto. -unfold no_overlap_list, no_overlap in Hno_O |-; simpl in Hno_O |-; intros; - generalize (Hno_O a1). -intros H8; elim H8 with ( s := r ); - [intros H9; left | intros H9; right; apply Loc.diff_sym | left | right]; auto. -unfold Loc.disjoint in Hdiss |-; apply Hdiss; simpl; left; trivial. -apply Hdiss; simpl; [left | right; left]; auto. -elim (Heqd a2); - [intros H7; absurd (a2 = l); auto | intros H7; auto | left; trivial]. -generalize get_update_diff; unfold get, Locmap.get; intros H6; rewrite H6; auto. -rewrite R2; auto. -apply Loc.diff_sym; auto. -Qed. - -Definition p_move := - fun (l : list (loc * loc)) => - fun (k : block) => - fold_left - (fun (k0 : block) => fun (p : loc * loc) => add_move (fst p) (snd p) k0) - (P_move l) k. - -Lemma norepet_SD: forall p, Loc.norepet (getdst p) -> simpleDest p. -Proof. -induction p; (simpl; auto). -destruct a as [a1 a2]. -intro; inversion H. -split. -apply notindst_nW; auto. -apply IHp; auto. -Qed. - -Theorem SDone_stepf: - forall S1, StateDone (stepf S1) = nil -> StateDone S1 = nil. -Proof. -destruct S1 as [[t b] d]; destruct t. -destruct b; auto. -destruct m as [m1 m2]; simpl. -destruct b. -simpl; intro; discriminate. -case (Loc.eq m2 (fst (last (m :: b)))); simpl; intros; discriminate. -destruct m as [a1 a2]; simpl. -destruct b. -case (Loc.eq a1 a2); simpl; intros; auto. -destruct m as [m1 m2]; case (Loc.eq a1 m2); intro; (try (simpl; auto; fail)). -case (split_move t m2). -(repeat destruct p); simpl; intros; auto. -destruct b; (try (simpl; intro; discriminate)); auto. -case (Loc.eq m2 (fst (last (m :: b)))); intro; simpl; intro; discriminate. -Qed. - -Theorem SDone_Pmov: forall S1, StateDone (Pmov S1) = nil -> StateDone S1 = nil. -Proof. -intros S1; elim S1 using (well_founded_ind (Wf_nat.well_founded_ltof _ mesure)). -clear S1; intros S1; intros Hrec. -destruct S1 as [[t b] d]. -rewrite Pmov_equation. -destruct t. -destruct b; auto. -intro; assert (StateDone (stepf (nil, m :: b, d)) = nil); - [apply Hrec; auto; apply stepf1_dec | apply SDone_stepf]; auto. -intro; assert (StateDone (stepf (m :: t, b, d)) = nil); - [apply Hrec; auto; apply stepf1_dec | apply SDone_stepf]; auto. -Qed. - -Lemma no_overlap_temp: forall r s, In s temporaries -> r = s \/ Loc.diff r s. -Proof. -intros r s H; case (Loc.eq r s); intros e; [left | right]; (try assumption). -unfold Loc.diff; destruct r. -destruct s; trivial. -red; intro; elim e; rewrite H0; auto. -destruct s0; destruct s; trivial; - (elim H; [intros H1 | intros [H1|[H1|[H1|[H1|[H1|H1]]]]]]; (try discriminate); - inversion H1). -Qed. - -Lemma getsrcdst_app: - forall l1 l2, - getdst l1 ++ getdst l2 = getsrc l1 ++ getsrc l2 -> - getdst l1 = getsrc l1 /\ getdst l2 = getsrc l2. -Proof. -induction l1; simpl; auto. -destruct a as [a1 a2]; intros; inversion H. -subst a1; inversion H; - (elim IHl1 with ( l2 := l2 ); - [intros H0 H3; (try clear IHl1); (try exact H0) | idtac]; auto). -rewrite H0; auto. -Qed. - -Lemma In_norepet: - forall r x l, Loc.norepet l -> In x l -> In r l -> r = x \/ Loc.diff r x. -Proof. -induction l; simpl; intros. -elim H1. -inversion H. -subst hd. -elim H1; intros H2; clear H1; elim H0; intros H1. -rewrite <- H1; rewrite <- H2; auto. -subst a; right; apply Loc.in_notin_diff with l; auto. -subst a; right; apply Loc.diff_sym; apply Loc.in_notin_diff with l; auto. -apply IHl; auto. -Qed. - -Definition no_overlap_stateD (S : State) := - no_overlap - (getsrc (StateToMove S ++ (StateBeing S ++ StateDone S))) - (getdst (StateToMove S ++ (StateBeing S ++ StateDone S))). - -Ltac -incl_tac_rec := -(auto with datatypes; fail) - || - (apply in_cons; incl_tac_rec) - || - (apply in_or_app; left; incl_tac_rec) - || - (apply in_or_app; right; incl_tac_rec) - || - (apply incl_appl; incl_tac_rec) || - (apply incl_appr; incl_tac_rec) || (apply incl_tl; incl_tac_rec). - -Ltac incl_tac := (repeat (apply incl_cons || apply incl_app)); incl_tac_rec. - -Ltac -in_tac := -match goal with -| |- In ?x ?L1 => -match goal with -| H:In x ?L2 |- _ => -let H1 := fresh "H" in -(assert (H1: incl L2 L1); [incl_tac | apply (H1 x)]); auto; fail -| _ => fail end end. - -Lemma in_cons_noteq: - forall (A : Set) (a b : A) (l : list A), In a (b :: l) -> a <> b -> In a l. -Proof. -intros A a b l; simpl; intros. -elim H; intros H1; (try assumption). -absurd (a = b); auto. -Qed. - -Lemma no_overlapD_inv: - forall S1 S2, step S1 S2 -> no_overlap_stateD S1 -> no_overlap_stateD S2. -Proof. -intros S1 S2 STEP; inversion STEP; unfold no_overlap_stateD, no_overlap; simpl; - auto; (repeat (rewrite getsrc_app; rewrite getdst_app; simpl)); intros. -apply H1; in_tac. -destruct m as [m1 m2]; apply H1; in_tac. -apply H1; in_tac. -case (Loc.eq r (T r0)); intros e. -elim (no_overlap_temp s0 r); - [intro; left; auto | intro; right; apply Loc.diff_sym; auto | unfold T in e |-]. -destruct (Loc.type r0); simpl; [right; left | right; right; right; right; left]; - auto. -case (Loc.eq s0 (T r0)); intros es. -apply (no_overlap_temp r s0); unfold T in es |-; destruct (Loc.type r0); simpl; - [right; left | right; right; right; right; left]; auto. -apply H1; apply in_cons_noteq with ( b := T r0 ); auto; in_tac. -apply H3; in_tac. -Qed. - -Lemma no_overlapD_invpp: - forall S1 S2, stepp S1 S2 -> no_overlap_stateD S1 -> no_overlap_stateD S2. -Proof. -intros; induction H as [r|r1 r2 r3 H H1 HrecH]; auto. -apply HrecH; auto. -apply no_overlapD_inv with r1; auto. -Qed. - -Lemma no_overlapD_invf: - forall S1, stepInv S1 -> no_overlap_stateD S1 -> no_overlap_stateD (stepf S1). -Proof. -intros; destruct S1 as [[t1 b1] d1]. -destruct t1; destruct b1; auto. -set (S1:=(nil (A:=Move), m :: b1, d1)). -apply (no_overlapD_invpp S1); [apply dstep_step; auto | assumption]. -apply f2ind; [unfold S1 | idtac | idtac]; auto. -generalize H0; clear H0; unfold no_overlap_stateD; destruct m as [m1 m2]. -intros; apply no_overlap_noOverlap. -unfold no_overlap_state; simpl. -generalize H0; clear H0; unfold no_overlap; (repeat rewrite getdst_app); - (repeat rewrite getsrc_app); simpl; intros. -apply H0. -elim H1; intros H4; [left; assumption | right; in_tac]. -elim H2; intros H4; [left; assumption | right; in_tac]. -set (S1:=(m :: t1, nil (A:=Move), d1)). -apply (no_overlapD_invpp S1); [apply dstep_step; auto | assumption]. -apply f2ind; [unfold S1 | idtac | idtac]; auto. -generalize H0; clear H0; unfold no_overlap_stateD; destruct m as [m1 m2]. -intros; apply no_overlap_noOverlap. -unfold no_overlap_state; simpl. -generalize H0; clear H0; unfold no_overlap; (repeat rewrite getdst_app); - (repeat rewrite getsrc_app); simpl; (repeat rewrite app_nil); intros. -apply H0. -elim H1; intros H4; [left; assumption | right; (try in_tac)]. -elim H2; intros H4; [left; assumption | right; in_tac]. -set (S1:=(m :: t1, m0 :: b1, d1)). -apply (no_overlapD_invpp S1); [apply dstep_step; auto | assumption]. -apply f2ind; [unfold S1 | idtac | idtac]; auto. -generalize H0; clear H0; unfold no_overlap_stateD; destruct m as [m1 m2]. -intros; apply no_overlap_noOverlap. -unfold no_overlap_state; simpl. -generalize H0; clear H0; unfold no_overlap; (repeat rewrite getdst_app); - (repeat rewrite getsrc_app); destruct m0; simpl; intros. -apply H0. -elim H1; intros H4; [left; assumption | right; in_tac]. -elim H2; intros H4; [left; assumption | right; in_tac]. -Qed. - -Lemma no_overlapD_res: - forall S1, stepInv S1 -> no_overlap_stateD S1 -> no_overlap_stateD (Pmov S1). -Proof. -intros S1; elim S1 using (well_founded_ind (Wf_nat.well_founded_ltof _ mesure)). -clear S1; intros S1 Hrec. -destruct S1 as [[t b] d]. -rewrite Pmov_equation. -destruct t; auto. -destruct b; auto. -intros; apply Hrec. -apply stepf1_dec; auto. -apply (dstep_inv (nil, m :: b, d)); auto. -apply f2ind'; auto. -apply no_overlap_noOverlap. -generalize H0; unfold no_overlap_stateD, no_overlap_state, no_overlap; simpl. -destruct m; (repeat rewrite getdst_app); (repeat rewrite getsrc_app). -intros H1 r1 H2 s H3; (try assumption). -apply H1; in_tac. -apply no_overlapD_invf; auto. -intros; apply Hrec. -apply stepf1_dec; auto. -apply (dstep_inv (m :: t, b, d)); auto. -apply f2ind'; auto. -apply no_overlap_noOverlap. -generalize H0; destruct m; - unfold no_overlap_stateD, no_overlap_state, no_overlap; simpl; - (repeat (rewrite getdst_app; simpl)); (repeat (rewrite getsrc_app; simpl)). -simpl; intros H1 r1 H2 s H3; (try assumption). -apply H1. -elim H2; intros H4; [left; (try assumption) | right; in_tac]. -elim H3; intros H4; [left; (try assumption) | right; in_tac]. -apply no_overlapD_invf; auto. -Qed. - -Definition temporaries1_3 := R IT1 :: (R FT1 :: (R IT3 :: nil)). - -Definition temporaries2 := R IT2 :: (R FT2 :: nil). - -Definition no_tmp13_state (S1 : State) := - Loc.disjoint (getsrc (StateDone S1)) temporaries1_3 /\ - Loc.disjoint (getdst (StateDone S1)) temporaries1_3. - -Definition Done_well_formed (S1 S2 : State) := - forall x, - (In x (getsrc (StateDone S2)) -> - In x temporaries2 \/ In x (getsrc (StateToMove S1 ++ StateBeing S1))) /\ - (In x (getdst (StateDone S2)) -> - In x temporaries2 \/ In x (getdst (StateToMove S1 ++ StateBeing S1))). - -Lemma Done_notmp3_inv: - forall S1 S2, - step S1 S2 -> - (forall x, - In x (getdst (StateToMove S1 ++ (StateBeing S1 ++ StateDone S1))) -> - Loc.diff x (R IT3)) -> - forall x, - In x (getdst (StateToMove S2 ++ (StateBeing S2 ++ StateDone S2))) -> - Loc.diff x (R IT3). -Proof. -intros S1 S2 STEP; inversion STEP; (try (simpl; trivial; fail)); - simpl StateDone; simpl StateToMove; simpl StateBeing; simpl getdst; - (repeat (rewrite getdst_app; simpl)); intros. -apply H1; in_tac. -destruct m; apply H1; in_tac. -apply H1; in_tac. -case (Loc.eq x (T r0)); intros e. -unfold T in e |-; destruct (Loc.type r0); rewrite e; simpl; red; intro; - discriminate. -apply H1; apply in_cons_noteq with ( b := T r0 ); auto; in_tac. -apply H3; in_tac. -Qed. - -Lemma Done_notmp3_invpp: - forall S1 S2, - stepp S1 S2 -> - (forall x, - In x (getdst (StateToMove S1 ++ (StateBeing S1 ++ StateDone S1))) -> - Loc.diff x (R IT3)) -> - forall x, - In x (getdst (StateToMove S2 ++ (StateBeing S2 ++ StateDone S2))) -> - Loc.diff x (R IT3). -Proof. -intros S1 S2 H H0; (try assumption). -induction H as [r|r1 r2 r3 H1 H2 Hrec]; auto. -apply Hrec; auto. -apply Done_notmp3_inv with r1; auto. -Qed. - -Lemma Done_notmp3_invf: - forall S1, - stepInv S1 -> - (forall x, - In x (getdst (StateToMove S1 ++ (StateBeing S1 ++ StateDone S1))) -> - Loc.diff x (R IT3)) -> - forall x, - In - x - (getdst - (StateToMove (stepf S1) ++ (StateBeing (stepf S1) ++ StateDone (stepf S1)))) -> - Loc.diff x (R IT3). -Proof. -intros S1 H H0; (try assumption). -generalize H; unfold stepInv; intros [Hpath [HSD [HnoO [Hnotmp HnotmpL]]]]. -destruct S1 as [[t1 b1] d1]; set (S1:=(t1, b1, d1)); destruct t1; destruct b1; - auto; apply (Done_notmp3_invpp S1); auto; apply dstep_step; auto; apply f2ind; - unfold S1; auto. -Qed. - -Lemma Done_notmp3_res: - forall S1, - stepInv S1 -> - (forall x, - In x (getdst (StateToMove S1 ++ (StateBeing S1 ++ StateDone S1))) -> - Loc.diff x (R IT3)) -> - forall x, - In - x - (getdst - (StateToMove (Pmov S1) ++ (StateBeing (Pmov S1) ++ StateDone (Pmov S1)))) -> - Loc.diff x (R IT3). -Proof. -intros S1; elim S1 using (well_founded_ind (Wf_nat.well_founded_ltof _ mesure)). -clear S1; intros S1 Hrec. -destruct S1 as [[t b] d]; set (S1:=(t, b, d)). -unfold S1; rewrite Pmov_equation. -intros H; generalize H; intros [Hpath [HSD [HnoO [Htmp HtmpL]]]]. -destruct t; [destruct b; auto | idtac]; - (intro; apply Hrec; - [apply stepf1_dec | apply (dstep_inv S1); auto; apply f2ind' - | apply Done_notmp3_invf]; auto). -Qed. - -Lemma Done_notmp1_inv: - forall S1 S2, - step S1 S2 -> - (forall x, - In x (getdst (StateToMove S1 ++ (StateBeing S1 ++ StateDone S1))) -> - Loc.diff x (R IT1) /\ Loc.diff x (R FT1)) -> - forall x, - In x (getdst (StateToMove S2 ++ (StateBeing S2 ++ StateDone S2))) -> - Loc.diff x (R IT1) /\ Loc.diff x (R FT1). -Proof. -intros S1 S2 STEP; inversion STEP; (try (simpl; trivial; fail)); - (repeat (rewrite getdst_app; simpl)); intros. -apply H1; in_tac. -destruct m; apply H1; in_tac. -apply H1; in_tac. -case (Loc.eq x (T r0)); intro. -rewrite e; unfold T; case (Loc.type r0); simpl; split; red; intro; discriminate. -apply H1; apply in_cons_noteq with ( b := T r0 ); (try assumption); in_tac. -apply H3; in_tac. -Qed. - -Lemma Done_notmp1_invpp: - forall S1 S2, - stepp S1 S2 -> - (forall x, - In x (getdst (StateToMove S1 ++ (StateBeing S1 ++ StateDone S1))) -> - Loc.diff x (R IT1) /\ Loc.diff x (R FT1)) -> - forall x, - In x (getdst (StateToMove S2 ++ (StateBeing S2 ++ StateDone S2))) -> - Loc.diff x (R IT1) /\ Loc.diff x (R FT1). -Proof. -intros S1 S2 H H0; (try assumption). -induction H as [r|r1 r2 r3 H1 H2 Hrec]; auto. -apply Hrec; auto. -apply Done_notmp1_inv with r1; auto. -Qed. - -Lemma Done_notmp1_invf: - forall S1, - stepInv S1 -> - (forall x, - In x (getdst (StateToMove S1 ++ (StateBeing S1 ++ StateDone S1))) -> - Loc.diff x (R IT1) /\ Loc.diff x (R FT1)) -> - forall x, - In - x - (getdst - (StateToMove (stepf S1) ++ (StateBeing (stepf S1) ++ StateDone (stepf S1)))) -> - Loc.diff x (R IT1) /\ Loc.diff x (R FT1). -Proof. -intros S1 H H0; (try assumption). -generalize H; unfold stepInv; intros [Hpath [HSD [HnoO [Hnotmp HnotmpL]]]]. -destruct S1 as [[t1 b1] d1]; set (S1:=(t1, b1, d1)); destruct t1; destruct b1; - auto; apply (Done_notmp1_invpp S1); auto; apply dstep_step; auto; apply f2ind; - unfold S1; auto. -Qed. - -Lemma Done_notmp1_res: - forall S1, - stepInv S1 -> - (forall x, - In x (getdst (StateToMove S1 ++ (StateBeing S1 ++ StateDone S1))) -> - Loc.diff x (R IT1) /\ Loc.diff x (R FT1)) -> - forall x, - In - x - (getdst - (StateToMove (Pmov S1) ++ (StateBeing (Pmov S1) ++ StateDone (Pmov S1)))) -> - Loc.diff x (R IT1) /\ Loc.diff x (R FT1). -Proof. -intros S1; elim S1 using (well_founded_ind (Wf_nat.well_founded_ltof _ mesure)). -clear S1; intros S1 Hrec. -destruct S1 as [[t b] d]; set (S1:=(t, b, d)). -intros H; generalize H; intros [Hpath [HSD [HnoO [Htmp HtmpL]]]]. -unfold S1; rewrite Pmov_equation. -destruct t; [destruct b; auto | idtac]; - (intro; apply Hrec; - [apply stepf1_dec | apply (dstep_inv S1); auto; apply f2ind' - | apply Done_notmp1_invf]; auto). -Qed. - -Lemma Done_notmp1src_inv: - forall S1 S2, - step S1 S2 -> - (forall x, - In x (getsrc (StateToMove S1 ++ (StateBeing S1 ++ StateDone S1))) -> - Loc.diff x (R IT1) /\ Loc.diff x (R FT1)) -> - forall x, - In x (getsrc (StateToMove S2 ++ (StateBeing S2 ++ StateDone S2))) -> - Loc.diff x (R IT1) /\ Loc.diff x (R FT1). -Proof. -intros S1 S2 STEP; inversion STEP; (try (simpl; trivial; fail)); - (repeat (rewrite getsrc_app; simpl)); intros. -apply H1; in_tac. -destruct m; apply H1; in_tac. -apply H1; in_tac. -case (Loc.eq x (T r0)); intro. -rewrite e; unfold T; case (Loc.type r0); simpl; split; red; intro; discriminate. -apply H1; apply in_cons_noteq with ( b := T r0 ); (try assumption); in_tac. -apply H3; in_tac. -Qed. - -Lemma Done_notmp1src_invpp: - forall S1 S2, - stepp S1 S2 -> - (forall x, - In x (getsrc (StateToMove S1 ++ (StateBeing S1 ++ StateDone S1))) -> - Loc.diff x (R IT1) /\ Loc.diff x (R FT1)) -> - forall x, - In x (getsrc (StateToMove S2 ++ (StateBeing S2 ++ StateDone S2))) -> - Loc.diff x (R IT1) /\ Loc.diff x (R FT1). -Proof. -intros S1 S2 H H0; (try assumption). -induction H as [r|r1 r2 r3 H1 H2 Hrec]; auto. -apply Hrec; auto. -apply Done_notmp1src_inv with r1; auto. -Qed. - -Lemma Done_notmp1src_invf: - forall S1, - stepInv S1 -> - (forall x, - In x (getsrc (StateToMove S1 ++ (StateBeing S1 ++ StateDone S1))) -> - Loc.diff x (R IT1) /\ Loc.diff x (R FT1)) -> - forall x, - In - x - (getsrc - (StateToMove (stepf S1) ++ (StateBeing (stepf S1) ++ StateDone (stepf S1)))) -> - Loc.diff x (R IT1) /\ Loc.diff x (R FT1). -Proof. -intros S1 H H0. -generalize H; unfold stepInv; intros [Hpath [HSD [HnoO [Hnotmp HnotmpL]]]]. -destruct S1 as [[t1 b1] d1]; set (S1:=(t1, b1, d1)); destruct t1; destruct b1; - auto; apply (Done_notmp1src_invpp S1); auto; apply dstep_step; auto; - apply f2ind; unfold S1; auto. -Qed. - -Lemma Done_notmp1src_res: - forall S1, - stepInv S1 -> - (forall x, - In x (getsrc (StateToMove S1 ++ (StateBeing S1 ++ StateDone S1))) -> - Loc.diff x (R IT1) /\ Loc.diff x (R FT1)) -> - forall x, - In - x - (getsrc - (StateToMove (Pmov S1) ++ (StateBeing (Pmov S1) ++ StateDone (Pmov S1)))) -> - Loc.diff x (R IT1) /\ Loc.diff x (R FT1). -Proof. -intros S1; elim S1 using (well_founded_ind (Wf_nat.well_founded_ltof _ mesure)). -clear S1; intros S1 Hrec. -destruct S1 as [[t b] d]; set (S1:=(t, b, d)). -intros H; generalize H; intros [Hpath [HSD [HnoO [Htmp HtmpL]]]]. -unfold S1; rewrite Pmov_equation. -destruct t; [destruct b; auto | idtac]; - (intro; apply Hrec; - [apply stepf1_dec | apply (dstep_inv S1); auto; apply f2ind' - | apply Done_notmp1src_invf]; auto). -Qed. - -Lemma dst_tmp2_step: - forall S1 S2, - step S1 S2 -> - forall x, - In x (getdst (StateToMove S2 ++ (StateBeing S2 ++ StateDone S2))) -> - In x temporaries2 \/ - In x (getdst (StateToMove S1 ++ (StateBeing S1 ++ StateDone S1))). -Proof. -intros S1 S2 STEP; inversion STEP; (repeat (rewrite getdst_app; simpl)); intros; - (try (right; in_tac)). -destruct m; right; in_tac. -case (Loc.eq x (T r0)); intro. -rewrite e; unfold T; case (Loc.type r0); left; [left | right; left]; trivial. -right; apply in_cons_noteq with ( b := T r0 ); auto; in_tac. -Qed. - -Lemma dst_tmp2_stepp: - forall S1 S2, - stepp S1 S2 -> - forall x, - In x (getdst (StateToMove S2 ++ (StateBeing S2 ++ StateDone S2))) -> - In x temporaries2 \/ - In x (getdst (StateToMove S1 ++ (StateBeing S1 ++ StateDone S1))). -Proof. -intros S1 S2 H. -induction H as [r|r1 r2 r3 H1 H2 Hrec]; auto. -intros. -elim Hrec with ( x := x ); - [intros H0; (try clear Hrec); (try exact H0) | intros H0; (try clear Hrec) - | try clear Hrec]; auto. -generalize (dst_tmp2_step r1 r2); auto. -Qed. - -Lemma dst_tmp2_stepf: - forall S1, - stepInv S1 -> - forall x, - In - x - (getdst - (StateToMove (stepf S1) ++ (StateBeing (stepf S1) ++ StateDone (stepf S1)))) -> - In x temporaries2 \/ - In x (getdst (StateToMove S1 ++ (StateBeing S1 ++ StateDone S1))). -Proof. -intros S1 H H0. -generalize H; unfold stepInv; intros [Hpath [HSD [HnoO [Hnotmp HnotmpL]]]]. -destruct S1 as [[t1 b1] d1]; set (S1:=(t1, b1, d1)); destruct t1; destruct b1; - auto; apply (dst_tmp2_stepp S1); auto; apply dstep_step; auto; apply f2ind; - unfold S1; auto. -Qed. - -Lemma dst_tmp2_res: - forall S1, - stepInv S1 -> - forall x, - In - x - (getdst - (StateToMove (Pmov S1) ++ (StateBeing (Pmov S1) ++ StateDone (Pmov S1)))) -> - In x temporaries2 \/ - In x (getdst (StateToMove S1 ++ (StateBeing S1 ++ StateDone S1))). -Proof. -intros S1; elim S1 using (well_founded_ind (Wf_nat.well_founded_ltof _ mesure)). -clear S1; intros S1 Hrec. -destruct S1 as [[t b] d]; set (S1:=(t, b, d)). -intros H; generalize H; intros [Hpath [HSD [HnoO [Htmp HtmpL]]]]. -unfold S1; rewrite Pmov_equation; intros. -destruct t; auto. -destruct b; auto. -elim Hrec with ( y := stepf S1 ) ( x := x ); - [intros H1 | intros H1 | try clear Hrec | try clear Hrec | try assumption]. -left; (try assumption). -apply dst_tmp2_stepf; auto. -apply stepf1_dec; auto. -apply (dstep_inv S1); auto; unfold S1; apply f2ind'; auto. -elim Hrec with ( y := stepf S1 ) ( x := x ); - [intro; left; (try assumption) | intros H1; apply dst_tmp2_stepf; auto | - apply stepf1_dec; auto | - apply (dstep_inv S1); auto; unfold S1; apply f2ind'; auto | try assumption]. -Qed. - -Lemma getdst_lists2moves: - forall srcs dsts, - length srcs = length dsts -> - getsrc (listsLoc2Moves srcs dsts) = srcs /\ - getdst (listsLoc2Moves srcs dsts) = dsts. -Proof. -induction srcs; intros dsts; destruct dsts; simpl; auto; intro; - (try discriminate). -inversion H. -elim IHsrcs with ( dsts := dsts ); auto; intros. -rewrite H2; rewrite H0; auto. -Qed. - -Lemma stepInv_pnilnil: - forall p, - simpleDest p -> - Loc.disjoint (getsrc p) temporaries -> - Loc.disjoint (getdst p) temporaries -> - no_overlap_list p -> stepInv (p, nil, nil). -Proof. -unfold stepInv; simpl; (repeat split); auto. -rewrite app_nil; auto. -generalize (no_overlap_noOverlap (p, nil, nil)). -simpl; (intros H3; apply H3). -generalize H2; unfold no_overlap_state, no_overlap_list; simpl; intro. -rewrite app_nil; auto. -apply disjoint_tmp__noTmp; auto. -Qed. - -Lemma noO_list_pnilnil: - forall (p : Moves), - simpleDest p -> - Loc.disjoint (getsrc p) temporaries -> - Loc.disjoint (getdst p) temporaries -> - no_overlap_list p -> no_overlap_list (StateDone (Pmov (p, nil, nil))). -Proof. -intros; generalize (no_overlapD_res (p, nil, nil)); - unfold no_overlap_stateD, no_overlap_list. -rewrite STM_Pmov; rewrite SB_Pmov; simpl; rewrite app_nil; intro. -apply H3; auto. -apply stepInv_pnilnil; auto. -Qed. - -Lemma dis_srctmp1_pnilnil: - forall (p : Moves), - simpleDest p -> - Loc.disjoint (getsrc p) temporaries -> - Loc.disjoint (getdst p) temporaries -> - no_overlap_list p -> - Loc.disjoint (getsrc (StateDone (Pmov (p, nil, nil)))) temporaries1. -Proof. -intros; generalize (Done_notmp1src_res (p, nil, nil)); simpl. -rewrite STM_Pmov; rewrite SB_Pmov; simpl; rewrite app_nil; intro. -unfold temporaries1. -apply Loc.notin_disjoint; auto. -simpl; intros. -assert (HsI: stepInv (p, nil, nil)); (try apply stepInv_pnilnil); auto. -elim H3 with x; (try assumption). -intros; (repeat split); auto. -intros; split; - (apply Loc.in_notin_diff with ( ll := temporaries ); - [apply Loc.disjoint_notin with (getsrc p) | simpl]; auto). -Qed. - -Lemma dis_dsttmp1_pnilnil: - forall (p : Moves), - simpleDest p -> - Loc.disjoint (getsrc p) temporaries -> - Loc.disjoint (getdst p) temporaries -> - no_overlap_list p -> - Loc.disjoint (getdst (StateDone (Pmov (p, nil, nil)))) temporaries1. -Proof. -intros; generalize (Done_notmp1_res (p, nil, nil)); simpl. -rewrite STM_Pmov; rewrite SB_Pmov; simpl; rewrite app_nil; intro. -unfold temporaries1. -apply Loc.notin_disjoint; auto. -simpl; intros. -assert (HsI: stepInv (p, nil, nil)); (try apply stepInv_pnilnil); auto. -elim H3 with x; (try assumption). -intros; (repeat split); auto. -intros; split; - (apply Loc.in_notin_diff with ( ll := temporaries ); - [apply Loc.disjoint_notin with (getdst p) | simpl]; auto). -Qed. - -Lemma parallel_move_correct': - forall p k rs m, - Loc.norepet (getdst p) -> - no_overlap_list p -> - Loc.disjoint (getsrc p) temporaries -> - Loc.disjoint (getdst p) temporaries -> - (exists rs' , - exec_instrs ge sp (p_move p k) rs m k rs' m /\ - (List.map rs' (getdst p) = List.map rs (getsrc p) /\ - (rs' (R IT3) = rs (R IT3) /\ - (forall l, - Loc.notin l (getdst p) -> Loc.notin l temporaries -> rs' l = rs l))) - ). -Proof. -unfold p_move, P_move. -intros p k rs m Hnorepet HnoOverlap Hdisjointsrc Hdisjointdst. -assert (HsD: simpleDest p); (try (apply norepet_SD; assumption)). -assert (HsI: stepInv (p, nil, nil)); (try (apply stepInv_pnilnil; assumption)). -generalize HsI; unfold stepInv; simpl StateToMove; simpl StateBeing; - (repeat rewrite app_nil); intros [_ [_ [HnoO [Hnotmp _]]]]. -elim (exec_instrs_pmov (StateDone (Pmov (p, nil, nil))) k rs m); auto; - (try apply noO_list_pnilnil); (try apply dis_dsttmp1_pnilnil); - (try apply dis_srctmp1_pnilnil); auto. -intros rs' [Hexec R]; exists rs'; (repeat split); auto. -rewrite <- (Fpmov_correct_map p rs); auto. -apply list_map_exten; intros; rewrite <- R; auto; - (try - (apply Loc.in_notin_diff with ( ll := temporaries ); - [apply Loc.disjoint_notin with (getdst p) | simpl]; auto)). -generalize (dst_tmp2_res (p, nil, nil)); intros. -elim H0 with ( x := r ); - [intros H2; right | - simpl; rewrite app_nil; intros H2; apply In_norepet with (getdst p); auto | - try assumption | rewrite STM_Pmov; rewrite SB_Pmov; auto]. -apply Loc.diff_sym; apply Loc.in_notin_diff with ( ll := temporaries ); - (try assumption). -apply Loc.disjoint_notin with (getdst p); auto. -generalize H2; unfold temporaries, temporaries2; intros; in_tac. -rewrite <- (Fpmov_correct_IT3 p rs); auto; rewrite <- R; - (try (simpl; intro; discriminate)); auto. -intros r H; right; apply (Done_notmp3_res (p, nil, nil)); auto; - (try (rewrite STM_Pmov; rewrite SB_Pmov; auto)). -simpl; rewrite app_nil; intros; apply Loc.in_notin_diff with temporaries; auto. -apply Loc.disjoint_notin with (getdst p); auto. -simpl; right; right; left; trivial. -intros; rewrite <- (Fpmov_correct_ext p rs); auto; rewrite <- R; auto; - (try (apply Loc.in_notin_diff with temporaries; simpl; auto)). -intros r H1; right; generalize (dst_tmp2_res (p, nil, nil)); intros. -elim H2 with ( x := r ); - [intros H3 | simpl; rewrite app_nil; intros H3 | assumption - | rewrite STM_Pmov; rewrite SB_Pmov; auto]. -apply Loc.diff_sym; apply Loc.in_notin_diff with temporaries; auto. -generalize H3; unfold temporaries, temporaries2; intros; in_tac. -apply Loc.diff_sym; apply Loc.in_notin_diff with ( ll := getdst p ); auto. -Qed. - -Lemma parallel_move_correctX: - forall srcs dsts k rs m, - List.length srcs = List.length dsts -> - no_overlap srcs dsts -> - Loc.norepet dsts -> - Loc.disjoint srcs temporaries -> - Loc.disjoint dsts temporaries -> - (exists rs' , - exec_instrs ge sp (parallel_move srcs dsts k) rs m k rs' m /\ - (List.map rs' dsts = List.map rs srcs /\ - (rs' (R IT3) = rs (R IT3) /\ - (forall l, Loc.notin l dsts -> Loc.notin l temporaries -> rs' l = rs l))) ). -Proof. -intros; unfold parallel_move, parallel_move_order; - generalize (parallel_move_correct' (listsLoc2Moves srcs dsts) k rs m). -elim (getdst_lists2moves srcs dsts); auto. -intros heq1 heq2; rewrite heq1; rewrite heq2; unfold p_move. -intros H4; apply H4; auto. -unfold no_overlap_list; rewrite heq1; rewrite heq2; auto. -Qed. - -End parallel_move_correction. diff --git a/backend/Alloctyping.v b/backend/Alloctyping.v index 39e53ee..e4f9f96 100644 --- a/backend/Alloctyping.v +++ b/backend/Alloctyping.v @@ -15,7 +15,7 @@ Require Import Allocproof. Require Import RTLtyping. Require Import LTLtyping. Require Import Conventions. -Require Import Alloctyping_aux. +Require Import Parallelmove. (** This file proves that register allocation (the translation from RTL to LTL defined in file [Allocation]) preserves typing: @@ -30,13 +30,13 @@ Variable live: PMap.t Regset.t. Variable alloc: reg -> loc. Variable tf: LTL.function. -Hypothesis TYPE_RTL: type_rtl_function f = Some env. +Hypothesis TYPE_RTL: type_function f = Some env. Hypothesis ALLOC: regalloc f live (live0 f live) env = Some alloc. Hypothesis TRANSL: transf_function f = Some tf. -Lemma wt_rtl_function: RTLtyping.wt_function env f. +Lemma wt_rtl_function: RTLtyping.wt_function f env. Proof. - apply type_rtl_function_correct; auto. + apply type_function_correct; auto. Qed. Lemma alloc_type: forall r, Loc.type (alloc r) = env r. @@ -213,15 +213,34 @@ Proof. auto. Qed. +Lemma wt_add_moves: + forall b moves, + (forall s d, In (s, d) moves -> + loc_read_ok s /\ loc_write_ok d /\ Loc.type s = Loc.type d) -> + wt_block tf b -> + wt_block tf + (List.fold_right (fun p k => add_move (fst p) (snd p) k) b moves). +Proof. + induction moves; simpl; intros. + auto. + destruct a as [s d]. simpl. + elim (H s d). intros A [B C]. apply wt_add_move; auto. auto. +Qed. + Theorem wt_parallel_move: forall srcs dsts b, List.map Loc.type srcs = List.map Loc.type dsts -> locs_read_ok srcs -> locs_write_ok dsts -> wt_block tf b -> wt_block tf (parallel_move srcs dsts b). Proof. - unfold locs_read_ok, locs_write_ok. - apply wt_parallel_moveX; simpl; auto. - exact wt_add_move. + intros. unfold parallel_move. apply wt_add_moves; auto. + intros. + elim (parmove_prop_2 _ _ _ _ H3); intros A B. + split. destruct A as [C|[C|C]]. + apply H0; auto. subst s; exact I. subst s; exact I. + split. destruct B as [C|[C|C]]. + apply H1; auto. subst d; exact I. subst d; exact I. + eapply parmove_prop_3; eauto. Qed. Lemma wt_add_op_move: @@ -340,6 +359,18 @@ Proof. rewrite loc_result_type. auto. constructor. Qed. +Lemma wt_add_alloc: + forall arg res s, + Loc.type arg = Tint -> Loc.type res = Tint -> + loc_read_ok arg -> loc_write_ok res -> + wt_block tf (add_alloc arg res s). +Proof. + intros. + unfold add_alloc. apply wt_add_reload. auto. rewrite H; reflexivity. + apply wt_Balloc. apply wt_add_spill. auto. rewrite H0; reflexivity. + apply wt_Bgoto. +Qed. + Lemma wt_add_cond: forall cond args ifso ifnot, List.map Loc.type args = type_of_condition cond -> @@ -387,7 +418,10 @@ Lemma wt_add_entry: Proof. set (sig := RTL.fn_sig f). assert (sig = tf.(fn_sig)). - unfold sig. symmetry. apply Allocproof.sig_function_translated. auto. + unfold sig. + assert (transf_fundef (Internal f) = Some (Internal tf)). + unfold transf_fundef; rewrite TRANSL; auto. + generalize (Allocproof.sig_function_translated _ _ H). simpl; auto. assert (locs_read_ok (loc_parameters sig)). red; unfold loc_parameters. intros. generalize (list_in_map_inv _ _ _ H0). intros [l1 [EQ IN]]. @@ -406,7 +440,7 @@ Qed. Lemma wt_transf_instr: forall pc instr, - RTLtyping.wt_instr env f instr -> + RTLtyping.wt_instr env f.(RTL.fn_sig) instr -> wt_block tf (transf_instr f live alloc pc instr). Proof. intros. inversion H; simpl. @@ -441,6 +475,9 @@ Proof. auto with allocty. destruct ros; simpl; auto with allocty. auto with allocty. + (* alloc *) + apply wt_add_alloc; auto with allocty. + rewrite alloc_type; auto. rewrite alloc_type; auto. (* cond *) apply wt_add_cond. rewrite alloc_types; auto. auto with allocty. (* return *) @@ -483,7 +520,7 @@ Lemma wt_transf_function: transf_function f = Some tf -> wt_function tf. Proof. intros. generalize H; unfold transf_function. - caseEq (type_rtl_function f). intros env TYP. + caseEq (type_function f). intros env TYP. caseEq (analyze f). intros live ANL. change (transfer f (RTL.fn_entrypoint f) live!!(RTL.fn_entrypoint f)) @@ -497,13 +534,26 @@ Proof. intros; discriminate. Qed. +Lemma wt_transf_fundef: + forall f tf, + transf_fundef f = Some tf -> wt_fundef tf. +Proof. + intros until tf; destruct f; simpl. + caseEq (transf_function f). intros g TF EQ. inversion EQ. + constructor. eapply wt_transf_function; eauto. + congruence. + caseEq (type_external_function e); intros. + inversion H0. constructor. apply type_external_function_correct. auto. + congruence. +Qed. + Lemma program_typing_preserved: forall (p: RTL.program) (tp: LTL.program), transf_program p = Some tp -> LTLtyping.wt_program tp. Proof. intros; red; intros. - generalize (transform_partial_program_function transf_function p i f H H0). + generalize (transform_partial_program_function transf_fundef p i f H H0). intros [f0 [IN TRANSF]]. - apply wt_transf_function with f0; auto. + apply wt_transf_fundef with f0; auto. Qed. diff --git a/backend/Alloctyping_aux.v b/backend/Alloctyping_aux.v deleted file mode 100644 index 0013c24..0000000 --- a/backend/Alloctyping_aux.v +++ /dev/null @@ -1,895 +0,0 @@ -(** Type preservation for parallel move compilation. *) - -(** This file, contributed by Laurence Rideau, shows that the parallel - move compilation algorithm (file [Parallelmove]) generates a well-typed - sequence of LTL instructions, provided the original problem is well-typed: - the types of source and destination locations match pairwise. *) - -Require Import Coqlib. -Require Import Locations. -Require Import LTL. -Require Import Allocation. -Require Import LTLtyping. -Require Import Allocproof_aux. -Require Import Parallelmove. -Require Import Inclusion. - -Section wt_move_correction. -Variable tf : LTL.function. -Variable loc_read_ok : loc -> Prop. -Hypothesis loc_read_ok_R : forall r, loc_read_ok (R r). -Variable loc_write_ok : loc -> Prop. -Hypothesis loc_write_ok_R : forall r, loc_write_ok (R r). - -Let locs_read_ok (ll : list loc) : Prop := - forall l, In l ll -> loc_read_ok l. - -Let locs_write_ok (ll : list loc) : Prop := - forall l, In l ll -> loc_write_ok l. - -Hypothesis - wt_add_move : - forall (src dst : loc) (b : LTL.block), - loc_read_ok src -> - loc_write_ok dst -> - Loc.type src = Loc.type dst -> - wt_block tf b -> wt_block tf (add_move src dst b). - -Lemma in_move__in_srcdst: - forall m p, In m p -> In (fst m) (getsrc p) /\ In (snd m) (getdst p). -Proof. -intros; induction p. -inversion H. -destruct a as [a1 a2]; destruct m as [m1 m2]; simpl. -elim H; intro. -inversion H0. -subst a2; subst a1. -split; [left; trivial | left; trivial]. -split; right; (elim IHp; simpl; intros; auto). -Qed. - -Lemma T_type: forall r, Loc.type r = Loc.type (T r). -Proof. -intro; unfold T. -case (Loc.type r); auto. -Qed. - -Theorem incl_nil: forall A (l : list A), incl nil l. -Proof. -intros A l a; simpl; intros H; case H. -Qed. -Hint Resolve incl_nil :datatypes. - -Lemma split_move_incl: - forall (l t1 t2 : Moves) (s d : Reg), - split_move l s = Some (t1, d, t2) -> incl t1 l /\ incl t2 l. -Proof. -induction l. -simpl; (intros; discriminate). -intros t1 t2 s d; destruct a as [a1 a2]; simpl. -case (Loc.eq a1 s); intro. -intros. -inversion H. -split; auto. -apply incl_nil. -apply incl_tl; apply incl_refl; auto. -caseEq (split_move l s); intro; (try (intros; discriminate)). -destruct p as [[p1 p2] p3]. -intros. -inversion H0. -elim (IHl p1 p3 s p2); intros; auto. -subst p3. -split; auto. -generalize H1; unfold incl; simpl. -intros H4 a [H7|H6]; [try exact H7 | idtac]. -left; (try assumption). -right; apply H4; auto. -apply incl_tl; auto. -Qed. - -Lemma in_split_move: - forall (l t1 t2 : Moves) (s d : Reg), - split_move l s = Some (t1, d, t2) -> In (s, d) l. -Proof. -induction l. -simpl; intros; discriminate. -intros t1 t2 s d; simpl. -destruct a as [a1 a2]. -case (Loc.eq a1 s). -intros. -inversion H. -subst a1; left; auto. -intro; caseEq (split_move l s); (intros; (try discriminate)). -destruct p as [[p1 p2] p3]. -right; inversion H0. -subst p2. -apply (IHl p1 p3); auto. -Qed. - -Lemma move_types_stepf: - forall S1, - (forall x1 x2, - In (x1, x2) (StateToMove S1 ++ (StateBeing S1 ++ StateDone S1)) -> - Loc.type x1 = Loc.type x2) -> - forall x1 x2, - In - (x1, x2) - (StateToMove (stepf S1) ++ (StateBeing (stepf S1) ++ StateDone (stepf S1))) -> - Loc.type x1 = Loc.type x2. -Proof. -intros S1 H x1 x2. -destruct S1 as [[t1 b1] d1]; set (S1:=(t1, b1, d1)); destruct t1; destruct b1; - auto; simpl StateToMove in H |-; simpl StateBeing in H |-; - simpl StateDone in H |-; simpl app in H |-. -intro; - elim - (in_app_or - (StateToMove (stepf S1)) (StateBeing (stepf S1) ++ StateDone (stepf S1)) - (x1, x2)); auto. -assert (StateToMove (stepf S1) = nil). -simpl stepf. -destruct m as [s d]. -case (Loc.eq d (fst (last b1))); case b1; simpl; auto. -rewrite H1; intros H2; inversion H2. -intro; elim (in_app_or (StateBeing (stepf S1)) (StateDone (stepf S1)) (x1, x2)); - auto. -assert - (StateBeing (stepf S1) = nil \/ - (StateBeing (stepf S1) = b1 \/ StateBeing (stepf S1) = replace_last_s b1)). -simpl stepf. -destruct m as [s d]. -case (Loc.eq d (fst (last b1))); case b1; simpl; auto. -elim H2; [intros H3; (try clear H2); (try exact H3) | intros H3; (try clear H2)]. -rewrite H3; intros H4; inversion H4. -elim H3; [intros H2; (try clear H3); (try exact H2) | intros H2; (try clear H3)]. -rewrite H2; intros H4. -apply H; (try in_tac). -rewrite H2; intros H4. -caseEq b1; intro; simpl; auto. -rewrite H3 in H4; simpl in H4 |-; inversion H4. -intros l H5; rewrite H5 in H4. -generalize (app_rewriter _ l m0). -intros [y [r H3]]; (try exact H3). -rewrite H3 in H4. -destruct y. -rewrite last_replace in H4. -elim (in_app_or r ((T r0, r1) :: nil) (x1, x2)); auto. -intro; apply H. -rewrite H5. -rewrite H3; in_tac. -intros H6; inversion H6. -inversion H7. -rewrite <- T_type. -rewrite <- H10; apply H. -rewrite H5; rewrite H3; (try in_tac). -assert (In (r0, r1) ((r0, r1) :: nil)); [simpl; auto | in_tac]. -inversion H7. -intro. -destruct m as [s d]. -assert - (StateDone (stepf S1) = (s, d) :: d1 \/ - StateDone (stepf S1) = (s, d) :: ((d, T d) :: d1)). -simpl. -case (Loc.eq d (fst (last b1))); case b1; simpl; auto. -elim H3; [intros H4; (try clear H3); (try exact H4) | intros H4; (try clear H3)]. -apply H; (try in_tac). -rewrite H4 in H2; in_tac. -rewrite H4 in H2. -simpl in H2 |-. -elim H2; [intros H3; apply H | intros H3; elim H3; intros; [idtac | apply H]]; - (try in_tac). -simpl; left; auto. -inversion H5; apply T_type. -intro; - elim - (in_app_or - (StateToMove (stepf S1)) (StateBeing (stepf S1) ++ StateDone (stepf S1)) - (x1, x2)); auto. -simpl stepf. -destruct m as [s d]. -case (Loc.eq s d); simpl; intros; apply H; in_tac. -intro; elim (in_app_or (StateBeing (stepf S1)) (StateDone (stepf S1)) (x1, x2)); - auto. -simpl stepf. -destruct m as [s d]. -case (Loc.eq s d); intros; apply H; (try in_tac). -inversion H2. -simpl stepf. -destruct m as [s d]. -case (Loc.eq s d); intros; apply H; (try in_tac). -simpl in H2 |-; in_tac. -simpl in H2 |-; in_tac. -intro; - elim - (in_app_or - (StateToMove (stepf S1)) (StateBeing (stepf S1) ++ StateDone (stepf S1)) - (x1, x2)); auto. -simpl stepf. -destruct m as [s d]. -destruct m0 as [s0 d0]. -case (Loc.eq s d0); [simpl; intros; apply H; in_tac | idtac]. -caseEq (split_move t1 d0); intro. -destruct p as [[t2 b2] d2]. -intros Hsplit Hd; simpl StateToMove; intro. -elim (split_move_incl t1 t2 d2 d0 b2 Hsplit); auto. -intros; apply H. -assert (In (x1, x2) ((s, d) :: (t1 ++ t1))). -generalize H1; simpl; intros. -elim H4; [intros H5; left; (try exact H5) | intros H5; right]. -elim (in_app_or t2 d2 (x1, x2)); auto; intro; apply in_or_app; left. -unfold incl in H2 |-. -apply H2; auto. -unfold incl in H3 |-; apply H3; auto. -in_tac. -intro; case (Loc.eq d0 (fst (last b1))); case b1; auto; simpl StateToMove; - intros; apply H; in_tac. -intro; elim (in_app_or (StateBeing (stepf S1)) (StateDone (stepf S1)) (x1, x2)); - auto. -simpl stepf. -destruct m as [s d]. -destruct m0 as [s0 d0]. -case (Loc.eq s d0). -intros e; rewrite <- e; simpl StateBeing. -rewrite <- e in H. -intro; apply H; in_tac. -caseEq (split_move t1 d0); intro. -destruct p as [[t2 b2] d2]. -simpl StateBeing. -intros. -apply H. -generalize (in_split_move t1 t2 d2 d0 b2 H2). -intros. -elim H3; intros. -rewrite <- H5. -in_tac. -in_tac. -caseEq b1. -simpl; intros e n F; elim F. -intros m l H3 H4. -case (Loc.eq d0 (fst (last (m :: l)))). -generalize (app_rewriter Move l m). -intros [y [r H5]]; rewrite H5. -simpl StateBeing. -destruct y as [y1 y2]; generalize (last_replace r y1 y2). -simpl; intros heq H6. -unfold Move in heq |-; unfold Move. -rewrite heq. -intro. -elim (in_app_or r ((T y1, y2) :: nil) (x1, x2)); auto. -intro; apply H. -rewrite H3; rewrite H5; in_tac. -simpl; intros [H8|H8]; inversion H8. -rewrite <- T_type. -apply H. -rewrite H3; rewrite H5. -rewrite <- H11; assert (In (y1, y2) ((y1, y2) :: nil)); auto. -simpl; auto. -in_tac. -simpl StateBeing; intros. -apply H; rewrite H3; (try in_tac). -simpl stepf. -destruct m as [s d]. -destruct m0 as [s0 d0]. -case (Loc.eq s d0); [simpl; intros; apply H; in_tac | idtac]. -caseEq (split_move t1 d0); intro. -destruct p as [[t2 b2] d2]. -intros Hsplit Hd; simpl StateDone; intro. -apply H; (try in_tac). -case (Loc.eq d0 (fst (last b1))); case b1; simpl StateDone; intros; - (try (apply H; in_tac)). -elim H3; intros. -apply H. -assert (In (x1, x2) ((s0, d0) :: nil)); auto. -rewrite H4; auto. -simpl; left; auto. -in_tac. -elim H4; intros. -inversion H5; apply T_type. -apply H; in_tac. -Qed. - -Lemma move_types_res: - forall S1, - (forall x1 x2, - In (x1, x2) (StateToMove S1 ++ (StateBeing S1 ++ StateDone S1)) -> - Loc.type x1 = Loc.type x2) -> - forall x1 x2, - In - (x1, x2) - (StateToMove (Pmov S1) ++ (StateBeing (Pmov S1) ++ StateDone (Pmov S1))) -> - Loc.type x1 = Loc.type x2. -Proof. -intros S1; elim S1 using (well_founded_ind (Wf_nat.well_founded_ltof _ mesure)). -clear S1; intros S1 Hrec. -destruct S1 as [[t b] d]; set (S1:=(t, b, d)). -unfold S1; rewrite Pmov_equation; intros. -destruct t; auto. -destruct b; auto. -apply (Hrec (stepf S1)). -apply stepf1_dec; auto. -apply move_types_stepf; auto. -unfold S1; auto. -apply (Hrec (stepf S1)). -apply stepf1_dec; auto. -apply move_types_stepf; auto. -unfold S1; auto. -Qed. - -Lemma srcdst_tmp2_stepf: - forall S1 x1 x2, - In - (x1, x2) - (StateToMove (stepf S1) ++ (StateBeing (stepf S1) ++ StateDone (stepf S1))) -> - (In x1 temporaries2 \/ - In x1 (getsrc (StateToMove S1 ++ (StateBeing S1 ++ StateDone S1)))) /\ - (In x2 temporaries2 \/ - In x2 (getdst (StateToMove S1 ++ (StateBeing S1 ++ StateDone S1)))). -Proof. -intros S1 x1 x2 H. -(repeat rewrite getsrc_app); (repeat rewrite getdst_app). -destruct S1 as [[t1 b1] d1]; set (S1:=(t1, b1, d1)); destruct t1; destruct b1; - auto. -simpl in H |-. -elim (in_move__in_srcdst (x1, x2) d1); intros; auto. -elim - (in_app_or - (StateToMove (stepf S1)) (StateBeing (stepf S1) ++ StateDone (stepf S1)) - (x1, x2)); auto. -assert (StateToMove (stepf S1) = nil). -simpl stepf. -destruct m as [s d]. -case (Loc.eq d (fst (last b1))); case b1; simpl; auto. -rewrite H0; intros H2; inversion H2. -intro; elim (in_app_or (StateBeing (stepf S1)) (StateDone (stepf S1)) (x1, x2)); - auto. -simpl stepf. -destruct m as [s d]. -caseEq b1. -simpl. -intros h1 h2; inversion h2. -intros m l heq; generalize (app_rewriter _ l m). -intros [y [r H3]]; (try exact H3). -rewrite H3. -destruct y. -rewrite last_app; simpl fst. -case (Loc.eq d r0). -intros heqd. -rewrite last_replace. -simpl. -intro; elim (in_app_or r ((T r0, r1) :: nil) (x1, x2)); auto. -rewrite heq; rewrite H3. -rewrite getsrc_app; simpl; rewrite getdst_app; simpl. -intro; elim (in_move__in_srcdst (x1, x2) r); auto; simpl; intros; split; right; - right; in_tac. -intro. -inversion H2; inversion H4. -split. -unfold T; case (Loc.type r0); left; [left | right]; auto. -right; right; (try assumption). -rewrite heq; rewrite H3. -rewrite H7; simpl. -rewrite getdst_app; simpl. -assert (In x2 (x2 :: nil)); simpl; auto. -in_tac. -simpl StateBeing. -intros; elim (in_move__in_srcdst (x1, x2) (r ++ ((r0, r1) :: nil))); auto; - intros; split; right; right. -unfold snd in H4 |-; unfold fst in H2 |-; rewrite heq; rewrite H3; (try in_tac). -unfold snd in H4 |-; unfold fst in H2 |-; rewrite heq; rewrite H3; (try in_tac). -simpl stepf. -destruct m as [s d]. -caseEq b1; intro. -simpl StateDone; intro. -unfold S1, StateToMove, StateBeing. -simpl app. -elim (in_move__in_srcdst (x1, x2) ((s, d) :: d1)); auto; intros; split; right. -simpl snd in H4 |-; simpl fst in H3 |-; simpl getdst in H4 |-; - simpl getsrc in H3 |-; (try in_tac). -simpl snd in H4 |-; simpl fst in H3 |-; simpl getdst in H4 |-; - simpl getsrc in H3 |-; (try in_tac). -intros; generalize (app_rewriter _ l m). -intros [y [r H4]]. -generalize H2; rewrite H4; rewrite last_app. -destruct y as [y1 y2]. -simpl fst. -case (Loc.eq d y1). -simpl StateDone; intros. -elim H3; [intros H6; inversion H6; (try exact H6) | intros H6; (try clear H5)]. -simpl; split; right; left; auto. -elim H6; [intros H5; inversion H5; (try exact H5) | intros H5; (try clear H6)]. -split; [right; simpl; right | left]. -rewrite H1; rewrite H4; rewrite getsrc_app; simpl getsrc. -rewrite <- e; rewrite H8; assert (In x1 (x1 :: nil)); simpl; auto; (try in_tac). -unfold T; case (Loc.type x1); simpl; auto. -elim (in_move__in_srcdst (x1, x2) d1); auto; intros; split; right; right; - (try in_tac). -intro; simpl StateDone. -unfold S1, StateToMove, StateBeing, StateDone. -simpl getsrc; simpl app; (try in_tac). -intro; elim (in_move__in_srcdst (x1, x2) ((s, d) :: d1)); - (auto; (simpl fst; simpl snd; simpl getsrc; simpl getdst); intros); - (split; right; (try in_tac)). -unfold S1, StateToMove, StateBeing, StateDone. -elim - (in_app_or - (StateToMove (stepf S1)) (StateBeing (stepf S1) ++ StateDone (stepf S1)) - (x1, x2)); auto. -simpl stepf. -destruct m as [s d]. -case (Loc.eq s d). -simpl StateToMove. -intros; elim (in_move__in_srcdst (x1, x2) t1); auto; - (repeat (rewrite getsrc_app; simpl getsrc)); - (repeat (rewrite getdst_app; simpl getdst)); simpl fst; simpl snd; intros; - split; right; simpl; right; (try in_tac). -simpl StateToMove. -intros; elim (in_move__in_srcdst (x1, x2) t1); auto; - (repeat (rewrite getsrc_app; simpl getsrc)); - (repeat (rewrite getdst_app; simpl getdst)); simpl fst; simpl snd; intros; - split; right; simpl; right; (try in_tac). -intro; elim (in_app_or (StateBeing (stepf S1)) (StateDone (stepf S1)) (x1, x2)); - auto. -simpl stepf. -destruct m as [s d]. -case (Loc.eq s d). -simpl StateBeing; intros h1 h2; inversion h2. -simpl StateBeing; intros h1 h2. -elim (in_move__in_srcdst (x1, x2) ((s, d) :: nil)); auto; simpl fst; simpl snd; - simpl; intros; split; right; (try in_tac). -elim H1; [intros H3; left; (try exact H3) | intros H3; inversion H3]. -elim H2; [intros H3; left; (try exact H3) | intros H3; inversion H3]. -simpl stepf. -destruct m as [s d]. -case (Loc.eq s d). -simpl StateDone; intros h1 h2. -elim (in_move__in_srcdst (x1, x2) d1); auto; simpl fst; simpl snd; simpl; - intros; split; right; right; (try in_tac). -simpl StateDone; intros h1 h2. -elim (in_move__in_srcdst (x1, x2) d1); auto; simpl fst; simpl snd; simpl; - intros; split; right; right; (try in_tac). -elim - (in_app_or - (StateToMove (stepf S1)) (StateBeing (stepf S1) ++ StateDone (stepf S1)) - (x1, x2)); auto. -simpl stepf. -destruct m as [s d]. -destruct m0 as [s0 d0]. -case (Loc.eq s d0). -unfold S1, StateToMove, StateBeing, StateDone. -simpl app at 1. -intros; elim (in_move__in_srcdst (x1, x2) t1); - (auto; simpl; intros; (split; right; right; (try in_tac))). -intro; caseEq (split_move t1 d0); intro. -destruct p as [[t2 b2] d2]. -intros Hsplit; unfold S1, StateToMove, StateBeing, StateDone; intro. -elim (split_move_incl t1 t2 d2 d0 b2 Hsplit); auto. -intros. -assert (In (x1, x2) ((s, d) :: (t1 ++ t1))). -generalize H0; simpl; intros. -elim H3; [intros H5; left; (try exact H5) | intros H5; right]. -elim (in_app_or t2 d2 (x1, x2)); auto; intro; apply in_or_app; left. -unfold incl in H1 |-. -apply H1; auto. -unfold incl in H2 |-; apply H2; auto. -split; right. -elim (in_move__in_srcdst (x1, x2) ((s, d) :: (t1 ++ t1))); - (auto; simpl; intros; (try in_tac)). -elim H4; [intros H6; (try clear H4); (try exact H6) | intros H6; (try clear H4)]. -left; (try assumption). -right; (try in_tac). -rewrite getsrc_app in H6; (try in_tac). -elim (in_move__in_srcdst (x1, x2) ((s, d) :: (t1 ++ t1))); - (auto; simpl; intros; (try in_tac)). -elim H5; [intros H6; (try clear H5); (try exact H6) | intros H6; (try clear H5)]. -left; (try assumption). -right; rewrite getdst_app in H6; (try in_tac). -caseEq b1; intro. -unfold S1, StateToMove, StateBeing, StateDone. -intro; elim (in_move__in_srcdst (x1, x2) ((s, d) :: t1)); (auto; intros). -simpl snd in H4 |-; simpl fst in H3 |-; split; right; (try in_tac). -intros l heq; generalize (app_rewriter _ l m). -intros [y [r H1]]; rewrite H1. -destruct y as [y1 y2]. -rewrite last_app; simpl fst. -case (Loc.eq d0 y1). -unfold S1, StateToMove, StateBeing, StateDone. -intros; elim (in_move__in_srcdst (x1, x2) ((s, d) :: t1)); auto; intros. -simpl snd in H4 |-; simpl fst in H3 |-; (split; right; (try in_tac)). -unfold S1, StateToMove, StateBeing, StateDone. -intros; elim (in_move__in_srcdst (x1, x2) ((s, d) :: t1)); auto; intros. -simpl snd in H4 |-; simpl fst in H3 |-; (split; right; (try in_tac)). -intro; elim (in_app_or (StateBeing (stepf S1)) (StateDone (stepf S1)) (x1, x2)); - auto. -simpl stepf. -destruct m as [s d]. -destruct m0 as [s0 d0]. -case (Loc.eq s d0). -intros e; rewrite <- e; simpl StateBeing. -unfold S1, StateToMove, StateBeing, StateDone. -intros; elim (in_move__in_srcdst (x1, x2) ((s, d) :: ((s0, s) :: b1))); auto; - simpl; intros. -split; right; (try in_tac). -elim H2; [intros H4; left; (try exact H4) | intros H4; (try clear H2)]. -elim H4; [intros H2; right; (try exact H2) | intros H2; (try clear H4)]. -assert (In x1 (s0 :: nil)); auto; (try in_tac). -simpl; auto. -right; (try in_tac). -elim H3; [intros H4; left; (try exact H4) | intros H4; (try clear H3)]. -elim H4; [intros H3; right; (try exact H3) | intros H3; (try clear H4)]. -rewrite <- e; (try in_tac). -assert (In x2 (s :: nil)); [simpl; auto | try in_tac]. -right; (try in_tac). -intro; caseEq (split_move t1 d0); intro. -destruct p as [[t2 b2] d2]. -simpl StateBeing. -intros. -generalize (in_split_move t1 t2 d2 d0 b2 H1). -intros. -split; right; elim H2; intros. -rewrite H4 in H3; elim (in_move__in_srcdst (x1, x2) t1); auto; intros. -simpl snd in H6 |-; simpl fst in H5 |-; (try in_tac). -unfold S1, StateToMove, StateBeing, StateDone. -simpl getsrc; (try in_tac). -elim (in_move__in_srcdst (x1, x2) ((s0, d0) :: b1)); (auto; intros). -simpl snd in H6 |-; simpl fst in H5 |-; (try in_tac). -unfold S1, StateToMove, StateBeing, StateDone. -simpl. -simpl in H5 |-. -elim H5; [intros H7; (try clear H5); (try exact H7) | intros H7; (try clear H5)]. -assert (In x1 (s0 :: nil)); simpl; auto. -right; in_tac. -right; in_tac. -inversion H4. -simpl. -subst b2. -rewrite H4 in H3. -elim (in_move__in_srcdst (x1, x2) t1); (auto; intros). -simpl snd in H7 |-. -right; in_tac. -unfold S1, StateToMove, StateBeing, StateDone. -elim (in_move__in_srcdst (x1, x2) ((s0, d0) :: b1)); auto; intros. -simpl snd in H6 |-; (try in_tac). -apply - (in_or_app (getdst ((s, d) :: t1)) (getdst ((s0, d0) :: b1) ++ getdst d1) x2); - right; (try in_tac). -caseEq b1. -intros h1 h2; inversion h2. -intros m l heq. -generalize (app_rewriter _ l m); intros [y [r H2]]; rewrite H2. -destruct y as [y1 y2]. -rewrite last_app; simpl fst. -case (Loc.eq d0 y1). -unfold S1, StateToMove, StateBeing, StateDone. -generalize (last_replace r y1 y2). -unfold Move; intros H3 H6. -rewrite H3. -intro. -elim (in_app_or r ((T y1, y2) :: nil) (x1, x2)); auto. -intro. -rewrite heq; rewrite H2; (split; right). -elim (in_move__in_srcdst (x1, x2) r); auto; simpl fst; simpl snd; intros; - (try in_tac). -simpl. -rewrite getsrc_app; (right; (try in_tac)). -elim (in_move__in_srcdst (x1, x2) r); auto; simpl fst; simpl snd; intros; - (try in_tac). -simpl. -rewrite getdst_app; right; (try in_tac). -intros h; inversion h; inversion H5. -split; [left; simpl; auto | right]. -unfold T; case (Loc.type y1); auto. -subst y2. -rewrite heq; rewrite H2. -simpl. -rewrite getdst_app; simpl. -assert (In x2 (x2 :: nil)); [simpl; auto | right; (try in_tac)]. -unfold S1, StateToMove, StateBeing, StateDone. -intro; rewrite heq; rewrite H2; (split; right). -intros; elim (in_move__in_srcdst (x1, x2) (r ++ ((y1, y2) :: nil))); auto; - intros. -simpl snd in H5 |-; simpl fst in H4 |-. -simpl. -right; (try in_tac). -apply in_or_app; right; simpl; right; (try in_tac). -elim (in_move__in_srcdst (x1, x2) (r ++ ((y1, y2) :: nil))); auto; intros. -simpl snd in H5 |-. -simpl. -right; (try in_tac). -apply in_or_app; right; simpl; right; (try in_tac). -simpl stepf. -destruct m as [s d]. -destruct m0 as [s0 d0]. -case (Loc.eq s d0). -unfold S1, StateToMove, StateBeing, StateDone. -intros; elim (in_move__in_srcdst (x1, x2) d1); auto; intros. -simpl in H3 |-; simpl in H2 |-. -split; right; (try in_tac). -intro; caseEq (split_move t1 d0); intro. -destruct p as [[t2 b2] d2]. -simpl StateDone. -unfold S1, StateToMove, StateBeing, StateDone. -intros; elim (in_move__in_srcdst (x1, x2) d1); auto; intros. -simpl in H3 |-; simpl in H4 |-. -split; right; (try in_tac). -caseEq b1. -unfold S1, StateToMove, StateBeing, StateDone. -intros; elim (in_move__in_srcdst (x1, x2) ((s0, d0) :: d1)); auto; intros. -simpl in H5 |-; simpl in H4 |-; split; right; (try in_tac). -simpl. -elim H4; [intros H6; right; (try exact H6) | intros H6; (try clear H4)]. -assert (In x1 (x1 :: nil)); [simpl; auto | rewrite H6; (try in_tac)]. -right; (try in_tac). -elim H5; [intros H6; right; simpl; (try exact H6) | intros H6; (try clear H5)]. -assert (In x2 (x2 :: nil)); [simpl; auto | rewrite H6; (try in_tac)]. -try in_tac. -intros m l heq. -generalize (app_rewriter _ l m); intros [y [r H2]]; rewrite H2. -destruct y as [y1 y2]. -rewrite last_app; simpl fst. -case (Loc.eq d0 y1). -unfold S1, StateToMove, StateBeing, StateDone. -unfold S1, StateToMove, StateBeing, StateDone. -intros. -elim H3; intros. -inversion H4. -simpl; split; right; auto. -right; apply in_or_app; right; simpl; auto. -right; apply in_or_app; right; simpl; auto. -elim H4; intros. -inversion H5. -simpl; split; [right | left]. -rewrite heq; rewrite H2; simpl. -rewrite <- e; rewrite H7. -rewrite getsrc_app; simpl. -right; assert (In x1 (x1 :: nil)); [simpl; auto | try in_tac]. -unfold T; case (Loc.type x1); auto. -elim (in_move__in_srcdst (x1, x2) d1); (auto; intros). -simpl snd in H7 |-; simpl fst in H6 |-; split; right; (try in_tac). -unfold S1, StateToMove, StateBeing, StateDone. -intros; elim (in_move__in_srcdst (x1, x2) ((s0, d0) :: d1)); - (auto; simpl; intros). -split; right. -elim H4; [intros H6; right; (try exact H6) | intros H6; (try clear H4)]. -apply in_or_app; right; simpl; auto. -right; (try in_tac). -elim H5; [intros H6; right; (try exact H6) | intros H6; (try clear H5)]. -apply in_or_app; right; simpl; auto. -right; (try in_tac). -Qed. - -Lemma getsrc_f: forall s l, In s (getsrc l) -> (exists d , In (s, d) l ). -Proof. -induction l; simpl getsrc. -simpl; (intros h; elim h). -intros; destruct a as [a1 a2]. -simpl in H |-. -elim H; [intros H0; (try clear H); (try exact H0) | intros H0; (try clear H)]. -subst a1. -exists a2; simpl; auto. -simpl. -elim IHl; [intros d H; (try clear IHl); (try exact H) | idtac]; auto. -exists d; [right; (try assumption)]. -Qed. - -Lemma incl_src: forall l1 l2, incl l1 l2 -> incl (getsrc l1) (getsrc l2). -Proof. -intros. -unfold incl in H |-. -unfold incl. -intros a H0; (try assumption). -generalize (getsrc_f a). -intros H1; elim H1 with ( l := l1 ); - [intros d H2; (try clear H1); (try exact H2) | idtac]; auto. -assert (In (a, d) l2). -apply H; auto. -elim (in_move__in_srcdst (a, d) l2); auto. -Qed. - -Lemma getdst_f: forall d l, In d (getdst l) -> (exists s , In (s, d) l ). -Proof. -induction l; simpl getdst. -simpl; (intros h; elim h). -intros; destruct a as [a1 a2]. -simpl in H |-. -elim H; [intros H0; (try clear H); (try exact H0) | intros H0; (try clear H)]. -subst a2. -exists a1; simpl; auto. -simpl. -elim IHl; [intros s H; (try clear IHl); (try exact H) | idtac]; auto. -exists s; [right; (try assumption)]. -Qed. - -Lemma incl_dst: forall l1 l2, incl l1 l2 -> incl (getdst l1) (getdst l2). -Proof. -intros. -unfold incl in H |-. -unfold incl. -intros a H0; (try assumption). -generalize (getdst_f a). -intros H1; elim H1 with ( l := l1 ); - [intros d H2; (try clear H1); (try exact H2) | idtac]; auto. -assert (In (d, a) l2). -apply H; auto. -elim (in_move__in_srcdst (d, a) l2); auto. -Qed. - -Lemma src_tmp2_res: - forall S1 x1 x2, - In - (x1, x2) - (StateToMove (Pmov S1) ++ (StateBeing (Pmov S1) ++ StateDone (Pmov S1))) -> - (In x1 temporaries2 \/ - In x1 (getsrc (StateToMove S1 ++ (StateBeing S1 ++ StateDone S1)))) /\ - (In x2 temporaries2 \/ - In x2 (getdst (StateToMove S1 ++ (StateBeing S1 ++ StateDone S1)))). -Proof. -intros S1; elim S1 using (well_founded_ind (Wf_nat.well_founded_ltof _ mesure)). -clear S1; intros S1 Hrec. -destruct S1 as [[t b] d]; set (S1:=(t, b, d)). -unfold S1; rewrite Pmov_equation; intros. -destruct t. -destruct b. -apply srcdst_tmp2_stepf; auto. -elim Hrec with ( y := stepf S1 ) ( x1 := x1 ) ( x2 := x2 ); - [idtac | apply stepf1_dec; auto | auto]. -intros. -elim H1; [intros H2; (try clear H1); (try exact H2) | intros H2; (try clear H1)]. -elim H0; [intros H1; (try clear H0); (try exact H1) | intros H1; (try clear H0)]. -split; [left; (try assumption) | idtac]. -left; (try assumption). -elim (getsrc_f x1) with ( 1 := H1 ); intros x3 H3. -split; auto. -elim srcdst_tmp2_stepf with ( 1 := H3 ); auto. -elim H0; [intros H1; (try clear H0); (try exact H1) | intros H1; (try clear H0)]. -elim (getdst_f x2) with ( 1 := H2 ); intros x3 H3. -split; auto. -elim srcdst_tmp2_stepf with ( 1 := H3 ); auto. -elim (getsrc_f x1) with ( 1 := H1 ); intros x3 H3. -elim srcdst_tmp2_stepf with ( 1 := H3 ); auto. -clear H3. -elim (getdst_f x2) with ( 1 := H2 ); intros x4 H3. -elim srcdst_tmp2_stepf with ( 1 := H3 ); auto. -elim Hrec with ( y := stepf S1 ) ( x1 := x1 ) ( x2 := x2 ); - [idtac | apply stepf1_dec; auto | auto]. -intros. -elim H1; [intros H2; (try clear H1); (try exact H2) | intros H2; (try clear H1)]. -elim H0; [intros H1; (try clear H0); (try exact H1) | intros H1; (try clear H0)]. -split; [left; (try assumption) | idtac]. -left; (try assumption). -elim (getsrc_f x1) with ( 1 := H1 ); intros x3 H3. -split; auto. -elim srcdst_tmp2_stepf with ( 1 := H3 ); auto. -elim H0; [intros H1; (try clear H0); (try exact H1) | intros H1; (try clear H0)]. -elim (getdst_f x2) with ( 1 := H2 ); intros x3 H3. -split; auto. -elim srcdst_tmp2_stepf with ( 1 := H3 ); auto. -elim (getsrc_f x1) with ( 1 := H1 ); intros x3 H3. -elim srcdst_tmp2_stepf with ( 1 := H3 ); auto. -clear H3. -elim (getdst_f x2) with ( 1 := H2 ); intros x4 H3. -elim srcdst_tmp2_stepf with ( 1 := H3 ); auto. -Qed. - -Lemma wt_add_moves: - forall p b, - List.map Loc.type (getsrc p) = List.map Loc.type (getdst p) -> - locs_read_ok (getsrc p) -> - locs_write_ok (getdst p) -> - wt_block tf b -> - wt_block - tf - (fold_left - (fun (k0 : LTL.block) => - fun (p0 : loc * loc) => add_move (fst p0) (snd p0) k0) p b). -Proof. -induction p. -intros; simpl; auto. -intros; destruct a as [a1 a2]; simpl. -apply IHp; auto. -inversion H; auto. -simpl in H0 |-. -unfold locs_read_ok in H0 |-. -simpl in H0 |-. -unfold locs_read_ok; auto. -generalize H1; unfold locs_write_ok; simpl; auto. -apply wt_add_move; (try assumption). -simpl in H0 |-. -unfold locs_read_ok in H0 |-. -apply H0. -simpl; left; trivial. -unfold locs_write_ok in H1 |-; apply H1. -simpl; left; trivial. -inversion H; auto. -Qed. - -Lemma map_f_getsrc_getdst: - forall (b : Set) (f : Reg -> b) p, - map f (getsrc p) = map f (getdst p) -> - forall x1 x2, In (x1, x2) p -> f x1 = f x2. -Proof. -intros b f0 p; induction p; simpl; auto. -intros; contradiction. -destruct a. -simpl. -intros heq; injection heq. -intros h1 h2. -intros x1 x2 [H3|H3]. -injection H3. -intros; subst; auto. -apply IHp; auto. -Qed. - -Lemma wt_parallel_move': - forall p b, - List.map Loc.type (getsrc p) = List.map Loc.type (getdst p) -> - locs_read_ok (getsrc p) -> - locs_write_ok (getdst p) -> wt_block tf b -> wt_block tf (p_move p b). -Proof. -unfold p_move. -unfold P_move. -intros; apply wt_add_moves; auto. -rewrite getsrc_map; rewrite getdst_map. -rewrite list_map_compose. -rewrite list_map_compose. -apply list_map_exten. -generalize (move_types_res (p, nil, nil)); auto. -destruct x as [x1 x2]; simpl; intros; auto. -symmetry; apply H3. -simpl. -rewrite app_nil. -apply map_f_getsrc_getdst; auto. -in_tac. -unfold locs_read_ok. -intros l H3. -elim getsrc_f with ( 1 := H3 ); intros x3 H4. -elim (src_tmp2_res (p, nil, nil) l x3). -simpl. -rewrite app_nil. -intros [[H'|[H'|H']]|H'] _. -subst l; hnf; auto. -subst l; hnf; auto. -contradiction. -apply H0; auto. -in_tac. -intros l H3. -elim getdst_f with ( 1 := H3 ); intros x3 H4. -elim (src_tmp2_res (p, nil, nil) x3 l). -simpl. -rewrite app_nil. -intros _ [[H'|[H'|H']]|H']. -subst l; hnf; auto. -subst l; hnf; auto. -contradiction. -apply H1; auto. -in_tac. -Qed. - -Theorem wt_parallel_moveX: - forall srcs dsts b, - List.map Loc.type srcs = List.map Loc.type dsts -> - locs_read_ok srcs -> - locs_write_ok dsts -> wt_block tf b -> wt_block tf (parallel_move srcs dsts b). -Proof. -unfold parallel_move, parallel_move_order, P_move. -intros. -generalize (wt_parallel_move' (listsLoc2Moves srcs dsts)); intros H'. -unfold p_move, P_move in H' |-. -apply H'; auto. -elim (getdst_lists2moves srcs dsts); auto. -unfold Allocation.listsLoc2Moves, listsLoc2Moves. -intros heq1 heq2; rewrite heq1; rewrite heq2; auto. -repeat rewrite <- (list_length_map Loc.type). -rewrite H; auto. -elim (getdst_lists2moves srcs dsts); auto. -unfold Allocation.listsLoc2Moves, listsLoc2Moves. -intros heq1 heq2; rewrite heq1; auto. -repeat rewrite <- (list_length_map Loc.type). -rewrite H; auto. -elim (getdst_lists2moves srcs dsts); auto. -unfold Allocation.listsLoc2Moves, listsLoc2Moves. -intros heq1 heq2; rewrite heq2; auto. -repeat rewrite <- (list_length_map Loc.type). -rewrite H; auto. -Qed. - -End wt_move_correction. diff --git a/backend/CSE.v b/backend/CSE.v index 243f6dd..6801013 100644 --- a/backend/CSE.v +++ b/backend/CSE.v @@ -178,6 +178,15 @@ Definition add_load (n: numbering) (rd: reg) let (n1, vs) := valnum_regs n rs in add_rhs n1 rd (Load chunk addr vs). +(** [add_unknown n rd] returns a numbering where [rd] is mapped to a + fresh value number, and no equations are added. This is useful + to model instructions with unpredictable results such as [Ialloc]. *) + +Definition add_unknown (n: numbering) (rd: reg) := + mknumbering (Psucc n.(num_next)) + n.(num_eqs) + (PTree.set rd n.(num_next) n.(num_reg)). + (** [kill_load n] removes all equations involving memory loads. It is used to reflect the effect of a memory store, which can potentially invalidate all such equations. *) @@ -328,6 +337,8 @@ Definition transfer (f: function) (pc: node) (before: numbering) := kill_loads before | Icall sig ros args res s => empty_numbering + | Ialloc arg res s => + add_unknown before res | Icond cond args ifso ifnot => before | Ireturn optarg => @@ -415,6 +426,8 @@ Definition transf_function (f: function) : function := f.(fn_nextpc) (transf_code_wf f approxs f.(fn_code_wf)). +Definition transf_fundef := AST.transf_fundef transf_function. + Definition transf_program (p: program) : program := - transform_program transf_function p. + transform_program transf_fundef p. diff --git a/backend/CSEproof.v b/backend/CSEproof.v index db8a973..4420269 100644 --- a/backend/CSEproof.v +++ b/backend/CSEproof.v @@ -7,6 +7,7 @@ Require Import Integers. Require Import Floats. Require Import Values. Require Import Mem. +Require Import Events. Require Import Globalenvs. Require Import Op. Require Import Registers. @@ -177,6 +178,18 @@ Proof. apply wf_add_rhs; auto. Qed. +Lemma wf_add_unknown: + forall n rd, + wf_numbering n -> + wf_numbering (add_unknown n rd). +Proof. + intros. inversion H. unfold add_unknown. constructor; simpl. + intros. eapply wf_equation_increasing; eauto. auto with coqlib. + intros until v. rewrite PTree.gsspec. case (peq r rd); intros. + inversion H2. auto with coqlib. + apply Plt_trans_succ. eauto. +Qed. + Lemma kill_load_eqs_incl: forall eqs, List.incl (kill_load_eqs eqs) eqs. Proof. @@ -205,6 +218,7 @@ Proof. apply wf_add_load; auto. apply wf_kill_loads; auto. apply wf_empty_numbering. + apply wf_add_unknown; auto. Qed. (** As a consequence, the numberings computed by the static analysis @@ -497,6 +511,47 @@ Proof. simpl. exists a; split; congruence. Qed. +(** [add_unknown] returns a numbering that is satisfiable in the + register set after setting the target register to any value. *) + +Lemma add_unknown_satisfiable: + forall n rs dst v, + wf_numbering n -> + numbering_satisfiable ge sp rs m n -> + numbering_satisfiable ge sp + (rs#dst <- v) m (add_unknown n dst). +Proof. + intros. destruct H0 as [valu A]. + set (valu' := VMap.set n.(num_next) v valu). + assert (numbering_holds valu' ge sp rs m n). + eapply numbering_holds_exten; eauto. + unfold valu'; red; intros. apply VMap.gso. auto with coqlib. + destruct H0 as [B C]. + exists valu'; split; simpl; intros. + eauto. + rewrite PTree.gsspec in H0. rewrite Regmap.gsspec. + destruct (peq r dst). inversion H0. unfold valu'. rewrite VMap.gss; auto. + eauto. +Qed. + +(** Allocation of a fresh memory block preserves satisfiability. *) + +Lemma alloc_satisfiable: + forall lo hi b m' rs n, + Mem.alloc m lo hi = (m', b) -> + numbering_satisfiable ge sp rs m n -> + numbering_satisfiable ge sp rs m' n. +Proof. + intros. destruct H0 as [valu [A B]]. + exists valu; split; intros. + generalize (A _ _ H0). destruct rh; simpl. + auto. + intros [addr [C D]]. exists addr; split. auto. + destruct addr; simpl in *; try discriminate. + eapply Mem.load_alloc_other; eauto. + eauto. +Qed. + (** [kill_load] preserves satisfiability. Moreover, the resulting numbering is satisfiable in any concrete memory state. *) @@ -612,8 +667,8 @@ End SATISFIABILITY. (** The transfer function preserves satisfiability of numberings. *) Lemma transfer_correct: - forall ge c sp pc rs m pc' rs' m' f n, - exec_instr ge c sp pc rs m pc' rs' m' -> + forall ge c sp pc rs m t pc' rs' m' f n, + exec_instr ge c sp pc rs m t pc' rs' m' -> c = f.(fn_code) -> wf_numbering n -> numbering_satisfiable ge sp rs m n -> @@ -628,6 +683,8 @@ Proof. eapply kill_load_satisfiable; eauto. (* Icall *) apply empty_numbering_satisfiable. + (* Ialloc *) + apply add_unknown_satisfiable; auto. eapply alloc_satisfiable; eauto. Qed. (** The numberings associated to each instruction by the static analysis @@ -637,8 +694,8 @@ Qed. satisfiability at [pc']. *) Theorem analysis_correct_1: - forall ge c sp pc rs m pc' rs' m' f, - exec_instr ge c sp pc rs m pc' rs' m' -> + forall ge c sp pc rs m t pc' rs' m' f, + exec_instr ge c sp pc rs m t pc' rs' m' -> c = f.(fn_code) -> numbering_satisfiable ge sp rs m (analyze f)!!pc -> numbering_satisfiable ge sp rs' m' (analyze f)!!pc'. @@ -655,15 +712,15 @@ Proof. eapply Solver.fixpoint_solution; eauto. elim (fn_code_wf f pc); intro. auto. rewrite <- CODE in H0. - elim (exec_instr_present _ _ _ _ _ _ _ _ _ EXEC H0). + elim (exec_instr_present _ _ _ _ _ _ _ _ _ _ EXEC H0). rewrite CODE in EXEC. eapply successors_correct; eauto. apply H0. auto. intros. rewrite PMap.gi. apply empty_numbering_satisfiable. Qed. Theorem analysis_correct_N: - forall ge c sp pc rs m pc' rs' m' f, - exec_instrs ge c sp pc rs m pc' rs' m' -> + forall ge c sp pc rs m t pc' rs' m' f, + exec_instrs ge c sp pc rs m t pc' rs' m' -> c = f.(fn_code) -> numbering_satisfiable ge sp rs m (analyze f)!!pc -> numbering_satisfiable ge sp rs' m' (analyze f)!!pc'. @@ -702,19 +759,26 @@ Let tge := Genv.globalenv tprog. Lemma symbols_preserved: forall (s: ident), Genv.find_symbol tge s = Genv.find_symbol ge s. -Proof (Genv.find_symbol_transf transf_function prog). +Proof (Genv.find_symbol_transf transf_fundef prog). Lemma functions_translated: - forall (v: val) (f: RTL.function), + forall (v: val) (f: RTL.fundef), Genv.find_funct ge v = Some f -> - Genv.find_funct tge v = Some (transf_function f). -Proof (@Genv.find_funct_transf _ _ transf_function prog). + Genv.find_funct tge v = Some (transf_fundef f). +Proof (@Genv.find_funct_transf _ _ transf_fundef prog). Lemma funct_ptr_translated: - forall (b: block) (f: RTL.function), + forall (b: block) (f: RTL.fundef), Genv.find_funct_ptr ge b = Some f -> - Genv.find_funct_ptr tge b = Some (transf_function f). -Proof (@Genv.find_funct_ptr_transf _ _ transf_function prog). + Genv.find_funct_ptr tge b = Some (transf_fundef f). +Proof (@Genv.find_funct_ptr_transf _ _ transf_fundef prog). + +Lemma sig_translated: + forall (f: RTL.fundef), + funsig (transf_fundef f) = funsig f. +Proof. + intros; case f; intros; reflexivity. +Qed. (** The proof of semantic preservation is a simulation argument using diagrams of the following form: @@ -732,26 +796,26 @@ Proof (@Genv.find_funct_ptr_transf _ _ transf_function prog). Definition exec_instr_prop (c: code) (sp: val) - (pc: node) (rs: regset) (m: mem) + (pc: node) (rs: regset) (m: mem) (t: trace) (pc': node) (rs': regset) (m': mem) : Prop := forall f (CF: c = f.(RTL.fn_code)) (SAT: numbering_satisfiable ge sp rs m (analyze f)!!pc), - exec_instr tge (transf_code (analyze f) c) sp pc rs m pc' rs' m'. + exec_instr tge (transf_code (analyze f) c) sp pc rs m t pc' rs' m'. Definition exec_instrs_prop (c: code) (sp: val) - (pc: node) (rs: regset) (m: mem) + (pc: node) (rs: regset) (m: mem) (t: trace) (pc': node) (rs': regset) (m': mem) : Prop := forall f (CF: c = f.(RTL.fn_code)) (SAT: numbering_satisfiable ge sp rs m (analyze f)!!pc), - exec_instrs tge (transf_code (analyze f) c) sp pc rs m pc' rs' m'. + exec_instrs tge (transf_code (analyze f) c) sp pc rs m t pc' rs' m'. Definition exec_function_prop - (f: RTL.function) (args: list val) (m: mem) + (f: RTL.fundef) (args: list val) (m: mem) (t: trace) (res: val) (m': mem) : Prop := - exec_function tge (transf_function f) args m res m'. + exec_function tge (transf_fundef f) args m t res m'. Ltac TransfInstr := match goal with @@ -766,9 +830,9 @@ Ltac TransfInstr := derivation for the source program. *) Lemma transf_function_correct: - forall f args m res m', - exec_function ge f args m res m' -> - exec_function_prop f args m res m'. + forall f args m t res m', + exec_function ge f args m t res m' -> + exec_function_prop f args m t res m'. Proof. apply (exec_function_ind_3 ge exec_instr_prop exec_instrs_prop exec_function_prop); @@ -804,12 +868,15 @@ Proof. rewrite <- H0. apply eval_addressing_preserved. exact symbols_preserved. intro; eapply exec_Istore; eauto. (* Icall *) - assert (find_function tge ros rs = Some (transf_function f)). + assert (find_function tge ros rs = Some (transf_fundef f)). destruct ros; simpl in H0; simpl. apply functions_translated; auto. rewrite symbols_preserved. destruct (Genv.find_symbol ge i). apply funct_ptr_translated; auto. discriminate. - intro; eapply exec_Icall with (f := transf_function f); eauto. + intro; eapply exec_Icall with (f := transf_fundef f); eauto. + generalize (sig_translated f); congruence. + (* Ialloc *) + intro; eapply exec_Ialloc; eauto. (* Icond true *) intro; eapply exec_Icond_true; eauto. (* Icond false *) @@ -821,22 +888,23 @@ Proof. (* trans *) eapply exec_trans; eauto. apply H2; auto. eapply analysis_correct_N; eauto. - (* function *) - intro. unfold transf_function; eapply exec_funct; simpl; eauto. + (* internal function *) + intro. unfold transf_function; simpl; eapply exec_funct_internal; simpl; eauto. eapply H1; eauto. eapply analysis_correct_entry; eauto. + (* external function *) + unfold transf_function; simpl. apply exec_funct_external; auto. Qed. Theorem transf_program_correct: - forall (r: val), - exec_program prog r -> exec_program tprog r. + forall (t: trace) (r: val), + exec_program prog t r -> exec_program tprog t r. Proof. - intros r [fptr [f [m [FINDS [FINDF [SIG EXEC]]]]]]. - red. exists fptr; exists (transf_function f); exists m. + intros t r [fptr [f [m [FINDS [FINDF [SIG EXEC]]]]]]. + red. exists fptr; exists (transf_fundef f); exists m. split. change (prog_main tprog) with (prog_main prog). rewrite symbols_preserved. assumption. split. apply funct_ptr_translated; auto. - split. unfold transf_function. - rewrite <- SIG. destruct (analyze f); reflexivity. + split. generalize (sig_translated f); congruence. apply transf_function_correct. unfold tprog, transf_program. rewrite Genv.init_mem_transf. exact EXEC. diff --git a/backend/Cmconstr.v b/backend/Cmconstr.v index e6168d1..f3a63fa 100644 --- a/backend/Cmconstr.v +++ b/backend/Cmconstr.v @@ -57,6 +57,8 @@ Fixpoint lift_expr (p: nat) (a: expr) {struct a}: expr := | Elet b c => Elet (lift_expr p b) (lift_expr (S p) c) | Eletvar n => if le_gt_dec p n then Eletvar (S n) else Eletvar n + | Ealloc b => + Ealloc (lift_expr p b) end with lift_condexpr (p: nat) (a: condexpr) {struct a}: condexpr := @@ -795,11 +797,6 @@ Definition divf (e1 e2: expr) := Eop Odivf (e1:::e2:::Enil). (** ** Truncations and sign extensions *) -Definition cast8unsigned (e: expr) := - rolm e Int.zero (Int.repr 255). -Definition cast16unsigned (e: expr) := - rolm e Int.zero (Int.repr 65535). - Inductive cast8signed_cases: forall (e1: expr), Set := | cast8signed_case1: forall (e2: expr), @@ -822,6 +819,28 @@ Definition cast8signed (e: expr) := | cast8signed_default e1 => Eop Ocast8signed (e1 ::: Enil) end. +Inductive cast8unsigned_cases: forall (e1: expr), Set := + | cast8unsigned_case1: + forall (e2: expr), + cast8unsigned_cases (Eop Ocast8unsigned (e2 ::: Enil)) + | cast8unsigned_default: + forall (e1: expr), + cast8unsigned_cases e1. + +Definition cast8unsigned_match (e1: expr) := + match e1 as z1 return cast8unsigned_cases z1 with + | Eop Ocast8unsigned (e2 ::: Enil) => + cast8unsigned_case1 e2 + | e1 => + cast8unsigned_default e1 + end. + +Definition cast8unsigned (e: expr) := + match cast8unsigned_match e with + | cast8unsigned_case1 e1 => e + | cast8unsigned_default e1 => Eop Ocast8unsigned (e1 ::: Enil) + end. + Inductive cast16signed_cases: forall (e1: expr), Set := | cast16signed_case1: forall (e2: expr), @@ -844,6 +863,28 @@ Definition cast16signed (e: expr) := | cast16signed_default e1 => Eop Ocast16signed (e1 ::: Enil) end. +Inductive cast16unsigned_cases: forall (e1: expr), Set := + | cast16unsigned_case1: + forall (e2: expr), + cast16unsigned_cases (Eop Ocast16unsigned (e2 ::: Enil)) + | cast16unsigned_default: + forall (e1: expr), + cast16unsigned_cases e1. + +Definition cast16unsigned_match (e1: expr) := + match e1 as z1 return cast16unsigned_cases z1 with + | Eop Ocast16unsigned (e2 ::: Enil) => + cast16unsigned_case1 e2 + | e1 => + cast16unsigned_default e1 + end. + +Definition cast16unsigned (e: expr) := + match cast16unsigned_match e with + | cast16unsigned_case1 e1 => e + | cast16unsigned_default e1 => Eop Ocast16unsigned (e1 ::: Enil) + end. + Inductive singleoffloat_cases: forall (e1: expr), Set := | singleoffloat_case1: forall (e2: expr), diff --git a/backend/Cmconstrproof.v b/backend/Cmconstrproof.v index f27fa73..b9976ee 100644 --- a/backend/Cmconstrproof.v +++ b/backend/Cmconstrproof.v @@ -16,6 +16,7 @@ Require Import Integers. Require Import Floats. Require Import Values. Require Import Mem. +Require Import Events. Require Import Op. Require Import Globalenvs. Require Import Cminor. @@ -67,34 +68,67 @@ Scheme eval_expr_ind_3 := Minimality for eval_expr Sort Prop with eval_exprlist_ind_3 := Minimality for eval_exprlist Sort Prop. Hint Resolve eval_Evar eval_Eassign eval_Eop eval_Eload eval_Estore - eval_Ecall eval_Econdition + eval_Ecall eval_Econdition eval_Ealloc eval_Elet eval_Eletvar eval_CEtrue eval_CEfalse eval_CEcond eval_CEcondition eval_Enil eval_Econs: evalexpr. +Lemma eval_list_one: + forall sp le e1 m1 a t e2 m2 v, + eval_expr ge sp le e1 m1 a t e2 m2 v -> + eval_exprlist ge sp le e1 m1 (a ::: Enil) t e2 m2 (v :: nil). +Proof. + intros. econstructor. eauto. constructor. traceEq. +Qed. + +Lemma eval_list_two: + forall sp le e1 m1 a1 t1 e2 m2 v1 a2 t2 e3 m3 v2 t, + eval_expr ge sp le e1 m1 a1 t1 e2 m2 v1 -> + eval_expr ge sp le e2 m2 a2 t2 e3 m3 v2 -> + t = t1 ** t2 -> + eval_exprlist ge sp le e1 m1 (a1 ::: a2 ::: Enil) t e3 m3 (v1 :: v2 :: nil). +Proof. + intros. econstructor. eauto. econstructor. eauto. constructor. + reflexivity. traceEq. +Qed. + +Lemma eval_list_three: + forall sp le e1 m1 a1 t1 e2 m2 v1 a2 t2 e3 m3 v2 a3 t3 e4 m4 v3 t, + eval_expr ge sp le e1 m1 a1 t1 e2 m2 v1 -> + eval_expr ge sp le e2 m2 a2 t2 e3 m3 v2 -> + eval_expr ge sp le e3 m3 a3 t3 e4 m4 v3 -> + t = t1 ** t2 ** t3 -> + eval_exprlist ge sp le e1 m1 (a1 ::: a2 ::: a3 ::: Enil) t e4 m4 (v1 :: v2 :: v3 :: nil). +Proof. + intros. econstructor. eauto. econstructor. eauto. econstructor. eauto. constructor. + reflexivity. reflexivity. traceEq. +Qed. + +Hint Resolve eval_list_one eval_list_two eval_list_three: evalexpr. + Lemma eval_lift_expr: - forall w sp le e1 m1 a e2 m2 v, - eval_expr ge sp le e1 m1 a e2 m2 v -> + forall w sp le e1 m1 a t e2 m2 v, + eval_expr ge sp le e1 m1 a t e2 m2 v -> forall p le', insert_lenv le p w le' -> - eval_expr ge sp le' e1 m1 (lift_expr p a) e2 m2 v. + eval_expr ge sp le' e1 m1 (lift_expr p a) t e2 m2 v. Proof. intros w. apply (eval_expr_ind_3 ge - (fun sp le e1 m1 a e2 m2 v => + (fun sp le e1 m1 a t e2 m2 v => forall p le', insert_lenv le p w le' -> - eval_expr ge sp le' e1 m1 (lift_expr p a) e2 m2 v) - (fun sp le e1 m1 a e2 m2 vb => + eval_expr ge sp le' e1 m1 (lift_expr p a) t e2 m2 v) + (fun sp le e1 m1 a t e2 m2 vb => forall p le', insert_lenv le p w le' -> - eval_condexpr ge sp le' e1 m1 (lift_condexpr p a) e2 m2 vb) - (fun sp le e1 m1 al e2 m2 vl => + eval_condexpr ge sp le' e1 m1 (lift_condexpr p a) t e2 m2 vb) + (fun sp le e1 m1 al t e2 m2 vl => forall p le', insert_lenv le p w le' -> - eval_exprlist ge sp le' e1 m1 (lift_exprlist p al) e2 m2 vl)); + eval_exprlist ge sp le' e1 m1 (lift_exprlist p al) t e2 m2 vl)); simpl; intros; eauto with evalexpr. destruct v1; eapply eval_Econdition; eauto with evalexpr; simpl; eauto with evalexpr. - eapply eval_Elet. eauto. apply H2. apply insert_lenv_S; auto. + eapply eval_Elet. eauto. apply H2. apply insert_lenv_S; auto. auto. case (le_gt_dec p n); intro. apply eval_Eletvar. eapply insert_lenv_lookup2; eauto. @@ -105,9 +139,9 @@ Proof. Qed. Lemma eval_lift: - forall sp le e1 m1 a e2 m2 v w, - eval_expr ge sp le e1 m1 a e2 m2 v -> - eval_expr ge sp (w::le) e1 m1 (lift a) e2 m2 v. + forall sp le e1 m1 a t e2 m2 v w, + eval_expr ge sp le e1 m1 a t e2 m2 v -> + eval_expr ge sp (w::le) e1 m1 (lift a) t e2 m2 v. Proof. intros. unfold lift. eapply eval_lift_expr. eexact H. apply insert_lenv_0. @@ -126,67 +160,69 @@ Ltac TrivialOp cstr := of operator applications. *) Lemma inv_eval_Eop_0: - forall sp le e1 m1 op e2 m2 v, - eval_expr ge sp le e1 m1 (Eop op Enil) e2 m2 v -> - e2 = e1 /\ m2 = m1 /\ eval_operation ge sp op nil = Some v. + forall sp le e1 m1 op t e2 m2 v, + eval_expr ge sp le e1 m1 (Eop op Enil) t e2 m2 v -> + t = E0 /\ e2 = e1 /\ m2 = m1 /\ eval_operation ge sp op nil = Some v. Proof. intros. inversion H. inversion H6. intuition. congruence. Qed. Lemma inv_eval_Eop_1: - forall sp le e1 m1 op a1 e2 m2 v, - eval_expr ge sp le e1 m1 (Eop op (a1 ::: Enil)) e2 m2 v -> + forall sp le e1 m1 op t a1 e2 m2 v, + eval_expr ge sp le e1 m1 (Eop op (a1 ::: Enil)) t e2 m2 v -> exists v1, - eval_expr ge sp le e1 m1 a1 e2 m2 v1 /\ + eval_expr ge sp le e1 m1 a1 t e2 m2 v1 /\ eval_operation ge sp op (v1 :: nil) = Some v. Proof. intros. - inversion H. inversion H6. inversion H21. - subst e4; subst m4. subst e6; subst m6. - exists v1; intuition. congruence. + inversion H. inversion H6. inversion H19. + subst. exists v1; intuition. rewrite E0_right. auto. Qed. Lemma inv_eval_Eop_2: - forall sp le e1 m1 op a1 a2 e3 m3 v, - eval_expr ge sp le e1 m1 (Eop op (a1 ::: a2 ::: Enil)) e3 m3 v -> - exists e2, exists m2, exists v1, exists v2, - eval_expr ge sp le e1 m1 a1 e2 m2 v1 /\ - eval_expr ge sp le e2 m2 a2 e3 m3 v2 /\ + forall sp le e1 m1 op a1 a2 t3 e3 m3 v, + eval_expr ge sp le e1 m1 (Eop op (a1 ::: a2 ::: Enil)) t3 e3 m3 v -> + exists t1, exists t2, exists e2, exists m2, exists v1, exists v2, + eval_expr ge sp le e1 m1 a1 t1 e2 m2 v1 /\ + eval_expr ge sp le e2 m2 a2 t2 e3 m3 v2 /\ + t3 = t1 ** t2 /\ eval_operation ge sp op (v1 :: v2 :: nil) = Some v. Proof. intros. - inversion H. inversion H6. inversion H21. inversion H32. - subst e7; subst m7. subst e9; subst m9. - exists e4; exists m4; exists v1; exists v2. intuition. congruence. + inversion H. subst. inversion H6. subst. inversion H8. subst. + inversion H10. subst. + exists t1; exists t0; exists e0; exists m0; exists v0; exists v1. + intuition. traceEq. Qed. Ltac SimplEval := match goal with - | [ |- (eval_expr _ ?sp ?le ?e1 ?m1 (Eop ?op Enil) ?e2 ?m2 ?v) -> _] => + | [ |- (eval_expr _ ?sp ?le ?e1 ?m1 (Eop ?op Enil) ?t ?e2 ?m2 ?v) -> _] => intro XX1; - generalize (inv_eval_Eop_0 sp le e1 m1 op e2 m2 v XX1); + generalize (inv_eval_Eop_0 sp le e1 m1 op t e2 m2 v XX1); clear XX1; - intros [XX1 [XX2 XX3]]; - subst e2; subst m2; simpl in XX3; - try (simplify_eq XX3; clear XX3; + intros [XX1 [XX2 [XX3 XX4]]]; + subst t e2 m2; simpl in XX4; + try (simplify_eq XX4; clear XX4; let EQ := fresh "EQ" in (intro EQ; rewrite EQ)) - | [ |- (eval_expr _ ?sp ?le ?e1 ?m1 (Eop ?op (?a1 ::: Enil)) ?e2 ?m2 ?v) -> _] => + | [ |- (eval_expr _ ?sp ?le ?e1 ?m1 (Eop ?op (?a1 ::: Enil)) ?t ?e2 ?m2 ?v) -> _] => intro XX1; - generalize (inv_eval_Eop_1 sp le e1 m1 op a1 e2 m2 v XX1); + generalize (inv_eval_Eop_1 sp le e1 m1 op t a1 e2 m2 v XX1); clear XX1; let v1 := fresh "v" in let EV := fresh "EV" in let EQ := fresh "EQ" in (intros [v1 [EV EQ]]; simpl in EQ) - | [ |- (eval_expr _ ?sp ?le ?e1 ?m1 (Eop ?op (?a1 ::: ?a2 ::: Enil)) ?e2 ?m2 ?v) -> _] => + | [ |- (eval_expr _ ?sp ?le ?e1 ?m1 (Eop ?op (?a1 ::: ?a2 ::: Enil)) ?t ?e2 ?m2 ?v) -> _] => intro XX1; - generalize (inv_eval_Eop_2 sp le e1 m1 op a1 a2 e2 m2 v XX1); + generalize (inv_eval_Eop_2 sp le e1 m1 op a1 a2 t e2 m2 v XX1); clear XX1; + let t1 := fresh "t" in let t2 := fresh "t" in let e := fresh "e" in let m := fresh "m" in let v1 := fresh "v" in let v2 := fresh "v" in let EV1 := fresh "EV" in let EV2 := fresh "EV" in - let EQ := fresh "EQ" in - (intros [e [m [v1 [v2 [EV1 [EV2 EQ]]]]]]; simpl in EQ) + let EQ := fresh "EQ" in let TR := fresh "TR" in + (intros [t1 [t2 [e [m [v1 [v2 [EV1 [EV2 [TR EQ]]]]]]]]]; simpl in EQ) | _ => idtac end. @@ -209,57 +245,57 @@ Ltac InvEval H := *) Theorem eval_negint: - forall sp le e1 m1 a e2 m2 x, - eval_expr ge sp le e1 m1 a e2 m2 (Vint x) -> - eval_expr ge sp le e1 m1 (negint a) e2 m2 (Vint (Int.neg x)). + forall sp le e1 m1 a t e2 m2 x, + eval_expr ge sp le e1 m1 a t e2 m2 (Vint x) -> + eval_expr ge sp le e1 m1 (negint a) t e2 m2 (Vint (Int.neg x)). Proof. TrivialOp negint. Qed. Theorem eval_negfloat: - forall sp le e1 m1 a e2 m2 x, - eval_expr ge sp le e1 m1 a e2 m2 (Vfloat x) -> - eval_expr ge sp le e1 m1 (negfloat a) e2 m2 (Vfloat (Float.neg x)). + forall sp le e1 m1 a t e2 m2 x, + eval_expr ge sp le e1 m1 a t e2 m2 (Vfloat x) -> + eval_expr ge sp le e1 m1 (negfloat a) t e2 m2 (Vfloat (Float.neg x)). Proof. TrivialOp negfloat. Qed. Theorem eval_absfloat: - forall sp le e1 m1 a e2 m2 x, - eval_expr ge sp le e1 m1 a e2 m2 (Vfloat x) -> - eval_expr ge sp le e1 m1 (absfloat a) e2 m2 (Vfloat (Float.abs x)). + forall sp le e1 m1 a t e2 m2 x, + eval_expr ge sp le e1 m1 a t e2 m2 (Vfloat x) -> + eval_expr ge sp le e1 m1 (absfloat a) t e2 m2 (Vfloat (Float.abs x)). Proof. TrivialOp absfloat. Qed. Theorem eval_intoffloat: - forall sp le e1 m1 a e2 m2 x, - eval_expr ge sp le e1 m1 a e2 m2 (Vfloat x) -> - eval_expr ge sp le e1 m1 (intoffloat a) e2 m2 (Vint (Float.intoffloat x)). + forall sp le e1 m1 a t e2 m2 x, + eval_expr ge sp le e1 m1 a t e2 m2 (Vfloat x) -> + eval_expr ge sp le e1 m1 (intoffloat a) t e2 m2 (Vint (Float.intoffloat x)). Proof. TrivialOp intoffloat. Qed. Theorem eval_floatofint: - forall sp le e1 m1 a e2 m2 x, - eval_expr ge sp le e1 m1 a e2 m2 (Vint x) -> - eval_expr ge sp le e1 m1 (floatofint a) e2 m2 (Vfloat (Float.floatofint x)). + forall sp le e1 m1 a t e2 m2 x, + eval_expr ge sp le e1 m1 a t e2 m2 (Vint x) -> + eval_expr ge sp le e1 m1 (floatofint a) t e2 m2 (Vfloat (Float.floatofint x)). Proof. TrivialOp floatofint. Qed. Theorem eval_floatofintu: - forall sp le e1 m1 a e2 m2 x, - eval_expr ge sp le e1 m1 a e2 m2 (Vint x) -> - eval_expr ge sp le e1 m1 (floatofintu a) e2 m2 (Vfloat (Float.floatofintu x)). + forall sp le e1 m1 a t e2 m2 x, + eval_expr ge sp le e1 m1 a t e2 m2 (Vint x) -> + eval_expr ge sp le e1 m1 (floatofintu a) t e2 m2 (Vfloat (Float.floatofintu x)). Proof. TrivialOp floatofintu. Qed. Theorem eval_notint: - forall sp le e1 m1 a e2 m2 x, - eval_expr ge sp le e1 m1 a e2 m2 (Vint x) -> - eval_expr ge sp le e1 m1 (notint a) e2 m2 (Vint (Int.not x)). + forall sp le e1 m1 a t e2 m2 x, + eval_expr ge sp le e1 m1 a t e2 m2 (Vint x) -> + eval_expr ge sp le e1 m1 (notint a) t e2 m2 (Vint (Int.not x)). Proof. unfold notint; intros until x; case (notint_match a); intros. InvEval H. FuncInv. EvalOp. simpl. congruence. @@ -269,15 +305,15 @@ Proof. eapply eval_Eop. eapply eval_Econs. apply eval_Eletvar. simpl. reflexivity. eapply eval_Econs. apply eval_Eletvar. simpl. reflexivity. - apply eval_Enil. - simpl. rewrite Int.or_idem. auto. + apply eval_Enil. reflexivity. reflexivity. + simpl. rewrite Int.or_idem. auto. traceEq. Qed. Lemma eval_notbool_base: - forall sp le e1 m1 a e2 m2 v b, - eval_expr ge sp le e1 m1 a e2 m2 v -> + forall sp le e1 m1 a t e2 m2 v b, + eval_expr ge sp le e1 m1 a t e2 m2 v -> Val.bool_of_val v b -> - eval_expr ge sp le e1 m1 (notbool_base a) e2 m2 (Val.of_bool (negb b)). + eval_expr ge sp le e1 m1 (notbool_base a) t e2 m2 (Val.of_bool (negb b)). Proof. TrivialOp notbool_base. simpl. inversion H0. @@ -290,10 +326,10 @@ Hint Resolve Val.bool_of_true_val Val.bool_of_false_val Val.bool_of_true_val_inv Val.bool_of_false_val_inv: valboolof. Theorem eval_notbool: - forall a sp le e1 m1 e2 m2 v b, - eval_expr ge sp le e1 m1 a e2 m2 v -> + forall a sp le e1 m1 t e2 m2 v b, + eval_expr ge sp le e1 m1 a t e2 m2 v -> Val.bool_of_val v b -> - eval_expr ge sp le e1 m1 (notbool a) e2 m2 (Val.of_bool (negb b)). + eval_expr ge sp le e1 m1 (notbool a) t e2 m2 (Val.of_bool (negb b)). Proof. assert (N1: forall v b, Val.is_false v -> Val.bool_of_val v b -> Val.is_true (Val.of_bool (negb b))). intros. inversion H0; simpl; auto; subst v; simpl in H. @@ -305,34 +341,33 @@ Proof. induction a; simpl; intros; try (eapply eval_notbool_base; eauto). destruct o; try (eapply eval_notbool_base; eauto). - destruct e. inversion H. inversion H7. subst vl. - simpl in H11. inversion H11. subst v0; subst v. + destruct e. InvEval H. injection XX4; clear XX4; intro; subst v. inversion H0. rewrite Int.eq_false; auto. simpl; eauto with evalexpr. rewrite Int.eq_true; simpl; eauto with evalexpr. eapply eval_notbool_base; eauto. - inversion H. subst sp0 le0 e0 m op al e3 m0 v0. - simpl in H11. eapply eval_Eop; eauto. + inversion H. subst. + simpl in H12. eapply eval_Eop; eauto. simpl. caseEq (eval_condition c vl); intros. - rewrite H1 in H11. + rewrite H1 in H12. assert (b0 = b). - destruct b0; inversion H11; subst v; inversion H0; auto. + destruct b0; inversion H12; subst v; inversion H0; auto. subst b0. rewrite (Op.eval_negate_condition _ _ H1). destruct b; reflexivity. - rewrite H1 in H11; discriminate. + rewrite H1 in H12; discriminate. inversion H; eauto 10 with evalexpr valboolof. inversion H; eauto 10 with evalexpr valboolof. - inversion H. eapply eval_Econdition. eexact H11. - destruct v1; eauto. + inversion H. subst. eapply eval_Econdition with (t2 := t8). eexact H36. + destruct v4; eauto. auto. Qed. Theorem eval_addimm: - forall sp le e1 m1 n a e2 m2 x, - eval_expr ge sp le e1 m1 a e2 m2 (Vint x) -> - eval_expr ge sp le e1 m1 (addimm n a) e2 m2 (Vint (Int.add x n)). + forall sp le e1 m1 n a t e2 m2 x, + eval_expr ge sp le e1 m1 a t e2 m2 (Vint x) -> + eval_expr ge sp le e1 m1 (addimm n a) t e2 m2 (Vint (Int.add x n)). Proof. unfold addimm; intros until x. generalize (Int.eq_spec n Int.zero). case (Int.eq n Int.zero); intro. @@ -341,16 +376,16 @@ Proof. InvEval H0. EvalOp. simpl. rewrite Int.add_commut. auto. InvEval H0. destruct (Genv.find_symbol ge s); discriminate. InvEval H0. - destruct sp; simpl in XX3; discriminate. + destruct sp; simpl in XX4; discriminate. InvEval H0. FuncInv. EvalOp. simpl. subst x. rewrite Int.add_assoc. decEq; decEq; decEq. apply Int.add_commut. EvalOp. Qed. Theorem eval_addimm_ptr: - forall sp le e1 m1 n a e2 m2 b ofs, - eval_expr ge sp le e1 m1 a e2 m2 (Vptr b ofs) -> - eval_expr ge sp le e1 m1 (addimm n a) e2 m2 (Vptr b (Int.add ofs n)). + forall sp le e1 m1 n t a e2 m2 b ofs, + eval_expr ge sp le e1 m1 a t e2 m2 (Vptr b ofs) -> + eval_expr ge sp le e1 m1 (addimm n a) t e2 m2 (Vptr b (Int.add ofs n)). Proof. unfold addimm; intros until ofs. generalize (Int.eq_spec n Int.zero). case (Int.eq n Int.zero); intro. @@ -361,8 +396,8 @@ Proof. destruct (Genv.find_symbol ge s). rewrite Int.add_commut. congruence. discriminate. - InvEval H0. destruct sp; simpl in XX3; try discriminate. - inversion XX3. EvalOp. simpl. decEq. decEq. + InvEval H0. destruct sp; simpl in XX4; try discriminate. + inversion XX4. EvalOp. simpl. decEq. decEq. rewrite Int.add_assoc. decEq. apply Int.add_commut. InvEval H0. FuncInv. subst b0; subst ofs. EvalOp. simpl. rewrite (Int.add_commut n m). rewrite Int.add_assoc. auto. @@ -370,13 +405,14 @@ Proof. Qed. Theorem eval_add: - forall sp le e1 m1 a e2 m2 x b e3 m3 y, - eval_expr ge sp le e1 m1 a e2 m2 (Vint x) -> - eval_expr ge sp le e2 m2 b e3 m3 (Vint y) -> - eval_expr ge sp le e1 m1 (add a b) e3 m3 (Vint (Int.add x y)). + forall sp le e1 m1 a t1 e2 m2 x b t2 e3 m3 y, + eval_expr ge sp le e1 m1 a t1 e2 m2 (Vint x) -> + eval_expr ge sp le e2 m2 b t2 e3 m3 (Vint y) -> + eval_expr ge sp le e1 m1 (add a b) (t1**t2) e3 m3 (Vint (Int.add x y)). Proof. intros until y. unfold add; case (add_match a b); intros. - InvEval H. rewrite Int.add_commut. apply eval_addimm. assumption. + InvEval H. rewrite Int.add_commut. apply eval_addimm. + rewrite E0_left; assumption. InvEval H. FuncInv. InvEval H0. FuncInv. replace (Int.add x y) with (Int.add (Int.add i i0) (Int.add n1 n2)). apply eval_addimm. EvalOp. @@ -387,7 +423,7 @@ Proof. apply eval_addimm. EvalOp. subst x. repeat rewrite Int.add_assoc. decEq. apply Int.add_commut. InvEval H0. FuncInv. - apply eval_addimm. auto. + apply eval_addimm. rewrite E0_right. auto. InvEval H0. FuncInv. replace (Int.add x y) with (Int.add (Int.add x i) n2). apply eval_addimm. EvalOp. @@ -396,10 +432,10 @@ Proof. Qed. Theorem eval_add_ptr: - forall sp le e1 m1 a e2 m2 p x b e3 m3 y, - eval_expr ge sp le e1 m1 a e2 m2 (Vptr p x) -> - eval_expr ge sp le e2 m2 b e3 m3 (Vint y) -> - eval_expr ge sp le e1 m1 (add a b) e3 m3 (Vptr p (Int.add x y)). + forall sp le e1 m1 a t1 e2 m2 p x b t2 e3 m3 y, + eval_expr ge sp le e1 m1 a t1 e2 m2 (Vptr p x) -> + eval_expr ge sp le e2 m2 b t2 e3 m3 (Vint y) -> + eval_expr ge sp le e1 m1 (add a b) (t1**t2) e3 m3 (Vptr p (Int.add x y)). Proof. intros until y. unfold add; case (add_match a b); intros. InvEval H. @@ -412,7 +448,7 @@ Proof. replace (Int.add x y) with (Int.add (Int.add i y) n1). apply eval_addimm_ptr. subst b0. EvalOp. subst x. repeat rewrite Int.add_assoc. decEq. apply Int.add_commut. - InvEval H0. apply eval_addimm_ptr. auto. + InvEval H0. apply eval_addimm_ptr. rewrite E0_right. auto. InvEval H0. FuncInv. replace (Int.add x y) with (Int.add (Int.add x i) n2). apply eval_addimm_ptr. EvalOp. @@ -421,14 +457,14 @@ Proof. Qed. Theorem eval_add_ptr_2: - forall sp le e1 m1 a e2 m2 p x b e3 m3 y, - eval_expr ge sp le e1 m1 a e2 m2 (Vint x) -> - eval_expr ge sp le e2 m2 b e3 m3 (Vptr p y) -> - eval_expr ge sp le e1 m1 (add a b) e3 m3 (Vptr p (Int.add y x)). + forall sp le e1 m1 a t1 e2 m2 p x b t2 e3 m3 y, + eval_expr ge sp le e1 m1 a t1 e2 m2 (Vint x) -> + eval_expr ge sp le e2 m2 b t2 e3 m3 (Vptr p y) -> + eval_expr ge sp le e1 m1 (add a b) (t1**t2) e3 m3 (Vptr p (Int.add y x)). Proof. intros until y. unfold add; case (add_match a b); intros. InvEval H. - apply eval_addimm_ptr. auto. + apply eval_addimm_ptr. rewrite E0_left. auto. InvEval H. FuncInv. InvEval H0. FuncInv. replace (Int.add y x) with (Int.add (Int.add i0 i) (Int.add n1 n2)). apply eval_addimm_ptr. subst b0. EvalOp. @@ -448,15 +484,15 @@ Proof. Qed. Theorem eval_sub: - forall sp le e1 m1 a e2 m2 x b e3 m3 y, - eval_expr ge sp le e1 m1 a e2 m2 (Vint x) -> - eval_expr ge sp le e2 m2 b e3 m3 (Vint y) -> - eval_expr ge sp le e1 m1 (sub a b) e3 m3 (Vint (Int.sub x y)). + forall sp le e1 m1 a t1 e2 m2 x b t2 e3 m3 y, + eval_expr ge sp le e1 m1 a t1 e2 m2 (Vint x) -> + eval_expr ge sp le e2 m2 b t2 e3 m3 (Vint y) -> + eval_expr ge sp le e1 m1 (sub a b) (t1**t2) e3 m3 (Vint (Int.sub x y)). Proof. intros until y. unfold sub; case (sub_match a b); intros. InvEval H0. rewrite Int.sub_add_opp. - apply eval_addimm. assumption. + apply eval_addimm. rewrite E0_right. assumption. InvEval H. FuncInv. InvEval H0. FuncInv. replace (Int.sub x y) with (Int.add (Int.sub i i0) (Int.sub n1 n2)). apply eval_addimm. EvalOp. @@ -476,15 +512,15 @@ Proof. Qed. Theorem eval_sub_ptr_int: - forall sp le e1 m1 a e2 m2 p x b e3 m3 y, - eval_expr ge sp le e1 m1 a e2 m2 (Vptr p x) -> - eval_expr ge sp le e2 m2 b e3 m3 (Vint y) -> - eval_expr ge sp le e1 m1 (sub a b) e3 m3 (Vptr p (Int.sub x y)). + forall sp le e1 m1 a t1 e2 m2 p x b t2 e3 m3 y, + eval_expr ge sp le e1 m1 a t1 e2 m2 (Vptr p x) -> + eval_expr ge sp le e2 m2 b t2 e3 m3 (Vint y) -> + eval_expr ge sp le e1 m1 (sub a b) (t1**t2) e3 m3 (Vptr p (Int.sub x y)). Proof. intros until y. unfold sub; case (sub_match a b); intros. InvEval H0. rewrite Int.sub_add_opp. - apply eval_addimm_ptr. assumption. + apply eval_addimm_ptr. rewrite E0_right. assumption. InvEval H. FuncInv. InvEval H0. FuncInv. subst b0. replace (Int.sub x y) with (Int.add (Int.sub i i0) (Int.sub n1 n2)). @@ -505,10 +541,10 @@ Proof. Qed. Theorem eval_sub_ptr_ptr: - forall sp le e1 m1 a e2 m2 p x b e3 m3 y, - eval_expr ge sp le e1 m1 a e2 m2 (Vptr p x) -> - eval_expr ge sp le e2 m2 b e3 m3 (Vptr p y) -> - eval_expr ge sp le e1 m1 (sub a b) e3 m3 (Vint (Int.sub x y)). + forall sp le e1 m1 a t1 e2 m2 p x b t2 e3 m3 y, + eval_expr ge sp le e1 m1 a t1 e2 m2 (Vptr p x) -> + eval_expr ge sp le e2 m2 b t2 e3 m3 (Vptr p y) -> + eval_expr ge sp le e1 m1 (sub a b) (t1**t2) e3 m3 (Vint (Int.sub x y)). Proof. intros until y. unfold sub; case (sub_match a b); intros. @@ -535,9 +571,9 @@ Proof. Qed. Lemma eval_rolm: - forall sp le e1 m1 a amount mask e2 m2 x, - eval_expr ge sp le e1 m1 a e2 m2 (Vint x) -> - eval_expr ge sp le e1 m1 (rolm a amount mask) e2 m2 (Vint (Int.rolm x amount mask)). + forall sp le e1 m1 a amount mask t e2 m2 x, + eval_expr ge sp le e1 m1 a t e2 m2 (Vint x) -> + eval_expr ge sp le e1 m1 (rolm a amount mask) t e2 m2 (Vint (Int.rolm x amount mask)). Proof. intros until x. unfold rolm; case (rolm_match a); intros. InvEval H. eauto with evalexpr. @@ -554,10 +590,10 @@ Proof. Qed. Theorem eval_shlimm: - forall sp le e1 m1 a n e2 m2 x, - eval_expr ge sp le e1 m1 a e2 m2 (Vint x) -> + forall sp le e1 m1 a n t e2 m2 x, + eval_expr ge sp le e1 m1 a t e2 m2 (Vint x) -> Int.ltu n (Int.repr 32) = true -> - eval_expr ge sp le e1 m1 (shlimm a n) e2 m2 (Vint (Int.shl x n)). + eval_expr ge sp le e1 m1 (shlimm a n) t e2 m2 (Vint (Int.shl x n)). Proof. intros. unfold shlimm. generalize (Int.eq_spec n Int.zero); case (Int.eq n Int.zero); intro. @@ -568,10 +604,10 @@ Proof. Qed. Theorem eval_shruimm: - forall sp le e1 m1 a n e2 m2 x, - eval_expr ge sp le e1 m1 a e2 m2 (Vint x) -> + forall sp le e1 m1 a n t e2 m2 x, + eval_expr ge sp le e1 m1 a t e2 m2 (Vint x) -> Int.ltu n (Int.repr 32) = true -> - eval_expr ge sp le e1 m1 (shruimm a n) e2 m2 (Vint (Int.shru x n)). + eval_expr ge sp le e1 m1 (shruimm a n) t e2 m2 (Vint (Int.shru x n)). Proof. intros. unfold shruimm. generalize (Int.eq_spec n Int.zero); case (Int.eq n Int.zero); intro. @@ -582,9 +618,9 @@ Proof. Qed. Lemma eval_mulimm_base: - forall sp le e1 m1 a n e2 m2 x, - eval_expr ge sp le e1 m1 a e2 m2 (Vint x) -> - eval_expr ge sp le e1 m1 (mulimm_base n a) e2 m2 (Vint (Int.mul x n)). + forall sp le e1 m1 a t n e2 m2 x, + eval_expr ge sp le e1 m1 a t e2 m2 (Vint x) -> + eval_expr ge sp le e1 m1 (mulimm_base n a) t e2 m2 (Vint (Int.mul x n)). Proof. intros; unfold mulimm_base. generalize (Int.one_bits_decomp n). @@ -597,7 +633,7 @@ Proof. rewrite Int.add_zero. rewrite <- Int.shl_mul. apply eval_shlimm. auto. auto with coqlib. destruct l. - intros. apply eval_Elet with e2 m2 (Vint x). auto. + intros. apply eval_Elet with t e2 m2 (Vint x) E0. auto. rewrite H1. simpl. rewrite Int.add_zero. rewrite Int.mul_add_distr_r. rewrite <- Int.shl_mul. @@ -609,18 +645,19 @@ Proof. apply eval_shlimm. apply eval_Eletvar. simpl. reflexivity. auto with coqlib. auto with evalexpr. - reflexivity. + reflexivity. traceEq. reflexivity. traceEq. intros. EvalOp. Qed. Theorem eval_mulimm: - forall sp le e1 m1 a n e2 m2 x, - eval_expr ge sp le e1 m1 a e2 m2 (Vint x) -> - eval_expr ge sp le e1 m1 (mulimm n a) e2 m2 (Vint (Int.mul x n)). + forall sp le e1 m1 a n t e2 m2 x, + eval_expr ge sp le e1 m1 a t e2 m2 (Vint x) -> + eval_expr ge sp le e1 m1 (mulimm n a) t e2 m2 (Vint (Int.mul x n)). Proof. intros until x; unfold mulimm. generalize (Int.eq_spec n Int.zero); case (Int.eq n Int.zero); intro. - subst n. rewrite Int.mul_zero. eauto with evalexpr. + subst n. rewrite Int.mul_zero. + intro. eapply eval_Elet; eauto with evalexpr. traceEq. generalize (Int.eq_spec n Int.one); case (Int.eq n Int.one); intro. subst n. rewrite Int.mul_one. auto. case (mulimm_match a); intros. @@ -633,24 +670,25 @@ Proof. Qed. Theorem eval_mul: - forall sp le e1 m1 a e2 m2 x b e3 m3 y, - eval_expr ge sp le e1 m1 a e2 m2 (Vint x) -> - eval_expr ge sp le e2 m2 b e3 m3 (Vint y) -> - eval_expr ge sp le e1 m1 (mul a b) e3 m3 (Vint (Int.mul x y)). + forall sp le e1 m1 a t1 e2 m2 x b t2 e3 m3 y, + eval_expr ge sp le e1 m1 a t1 e2 m2 (Vint x) -> + eval_expr ge sp le e2 m2 b t2 e3 m3 (Vint y) -> + eval_expr ge sp le e1 m1 (mul a b) (t1**t2) e3 m3 (Vint (Int.mul x y)). Proof. intros until y. unfold mul; case (mul_match a b); intros. - InvEval H. rewrite Int.mul_commut. apply eval_mulimm. auto. - InvEval H0. apply eval_mulimm. auto. + InvEval H. rewrite Int.mul_commut. apply eval_mulimm. + rewrite E0_left; auto. + InvEval H0. rewrite E0_right. apply eval_mulimm. auto. EvalOp. Qed. Theorem eval_divs: - forall sp le e1 m1 a e2 m2 x b e3 m3 y, - eval_expr ge sp le e1 m1 a e2 m2 (Vint x) -> - eval_expr ge sp le e2 m2 b e3 m3 (Vint y) -> + forall sp le e1 m1 a t1 e2 m2 x b t2 e3 m3 y, + eval_expr ge sp le e1 m1 a t1 e2 m2 (Vint x) -> + eval_expr ge sp le e2 m2 b t2 e3 m3 (Vint y) -> y <> Int.zero -> - eval_expr ge sp le e1 m1 (divs a b) e3 m3 (Vint (Int.divs x y)). + eval_expr ge sp le e1 m1 (divs a b) (t1**t2) e3 m3 (Vint (Int.divs x y)). Proof. TrivialOp divs. simpl. predSpec Int.eq Int.eq_spec y Int.zero. contradiction. auto. @@ -662,11 +700,11 @@ Lemma eval_mod_aux: y <> Int.zero -> eval_operation ge sp divop (Vint x :: Vint y :: nil) = Some (Vint (semdivop x y))) -> - forall sp le e1 m1 a e2 m2 x b e3 m3 y, - eval_expr ge sp le e1 m1 a e2 m2 (Vint x) -> - eval_expr ge sp le e2 m2 b e3 m3 (Vint y) -> + forall sp le e1 m1 a t1 e2 m2 x b t2 e3 m3 y, + eval_expr ge sp le e1 m1 a t1 e2 m2 (Vint x) -> + eval_expr ge sp le e2 m2 b t2 e3 m3 (Vint y) -> y <> Int.zero -> - eval_expr ge sp le e1 m1 (mod_aux divop a b) e3 m3 + eval_expr ge sp le e1 m1 (mod_aux divop a b) (t1**t2) e3 m3 (Vint (Int.sub x (Int.mul (semdivop x y) y))). Proof. intros; unfold mod_aux. @@ -678,18 +716,21 @@ Proof. eapply eval_Econs. eapply eval_Eop. eapply eval_Econs. apply eval_Eletvar. simpl; reflexivity. eapply eval_Econs. apply eval_Eletvar. simpl; reflexivity. - apply eval_Enil. apply H. assumption. + apply eval_Enil. reflexivity. reflexivity. + apply H. assumption. eapply eval_Econs. apply eval_Eletvar. simpl; reflexivity. - apply eval_Enil. simpl; reflexivity. apply eval_Enil. - reflexivity. + apply eval_Enil. reflexivity. reflexivity. + simpl; reflexivity. apply eval_Enil. + reflexivity. reflexivity. reflexivity. + reflexivity. traceEq. Qed. Theorem eval_mods: - forall sp le e1 m1 a e2 m2 x b e3 m3 y, - eval_expr ge sp le e1 m1 a e2 m2 (Vint x) -> - eval_expr ge sp le e2 m2 b e3 m3 (Vint y) -> + forall sp le e1 m1 a t1 e2 m2 x b t2 e3 m3 y, + eval_expr ge sp le e1 m1 a t1 e2 m2 (Vint x) -> + eval_expr ge sp le e2 m2 b t2 e3 m3 (Vint y) -> y <> Int.zero -> - eval_expr ge sp le e1 m1 (mods a b) e3 m3 (Vint (Int.mods x y)). + eval_expr ge sp le e1 m1 (mods a b) (t1**t2) e3 m3 (Vint (Int.mods x y)). Proof. intros; unfold mods. rewrite Int.mods_divs. @@ -699,44 +740,44 @@ Proof. Qed. Lemma eval_divu_base: - forall sp le e1 m1 a e2 m2 x b e3 m3 y, - eval_expr ge sp le e1 m1 a e2 m2 (Vint x) -> - eval_expr ge sp le e2 m2 b e3 m3 (Vint y) -> + forall sp le e1 m1 a t1 e2 m2 x b t2 e3 m3 y, + eval_expr ge sp le e1 m1 a t1 e2 m2 (Vint x) -> + eval_expr ge sp le e2 m2 b t2 e3 m3 (Vint y) -> y <> Int.zero -> - eval_expr ge sp le e1 m1 (Eop Odivu (a ::: b ::: Enil)) e3 m3 (Vint (Int.divu x y)). + eval_expr ge sp le e1 m1 (Eop Odivu (a ::: b ::: Enil)) (t1**t2) e3 m3 (Vint (Int.divu x y)). Proof. intros. EvalOp. simpl. predSpec Int.eq Int.eq_spec y Int.zero. contradiction. auto. Qed. Theorem eval_divu: - forall sp le e1 m1 a e2 m2 x b e3 m3 y, - eval_expr ge sp le e1 m1 a e2 m2 (Vint x) -> - eval_expr ge sp le e2 m2 b e3 m3 (Vint y) -> + forall sp le e1 m1 a t1 e2 m2 x b t2 e3 m3 y, + eval_expr ge sp le e1 m1 a t1 e2 m2 (Vint x) -> + eval_expr ge sp le e2 m2 b t2 e3 m3 (Vint y) -> y <> Int.zero -> - eval_expr ge sp le e1 m1 (divu a b) e3 m3 (Vint (Int.divu x y)). + eval_expr ge sp le e1 m1 (divu a b) (t1**t2) e3 m3 (Vint (Int.divu x y)). Proof. intros until y. unfold divu; case (divu_match b); intros. InvEval H0. caseEq (Int.is_power2 y). intros. rewrite (Int.divu_pow2 x y i H0). - apply eval_shruimm. auto. + apply eval_shruimm. rewrite E0_right. auto. apply Int.is_power2_range with y. auto. intros. subst n2. eapply eval_divu_base. eexact H. EvalOp. auto. eapply eval_divu_base; eauto. Qed. Theorem eval_modu: - forall sp le e1 m1 a e2 m2 x b e3 m3 y, - eval_expr ge sp le e1 m1 a e2 m2 (Vint x) -> - eval_expr ge sp le e2 m2 b e3 m3 (Vint y) -> + forall sp le e1 m1 a t1 e2 m2 x b t2 e3 m3 y, + eval_expr ge sp le e1 m1 a t1 e2 m2 (Vint x) -> + eval_expr ge sp le e2 m2 b t2 e3 m3 (Vint y) -> y <> Int.zero -> - eval_expr ge sp le e1 m1 (modu a b) e3 m3 (Vint (Int.modu x y)). + eval_expr ge sp le e1 m1 (modu a b) (t1**t2) e3 m3 (Vint (Int.modu x y)). Proof. intros until y; unfold modu; case (divu_match b); intros. InvEval H0. caseEq (Int.is_power2 y). intros. rewrite (Int.modu_and x y i H0). - rewrite <- Int.rolm_zero. apply eval_rolm. auto. + rewrite <- Int.rolm_zero. apply eval_rolm. rewrite E0_right; auto. intro. rewrite Int.modu_divu. eapply eval_mod_aux. intros. simpl. predSpec Int.eq Int.eq_spec y0 Int.zero. contradiction. auto. @@ -748,9 +789,9 @@ Proof. Qed. Theorem eval_andimm: - forall sp le e1 m1 n a e2 m2 x, - eval_expr ge sp le e1 m1 a e2 m2 (Vint x) -> - eval_expr ge sp le e1 m1 (andimm n a) e2 m2 (Vint (Int.and x n)). + forall sp le e1 m1 n a t e2 m2 x, + eval_expr ge sp le e1 m1 a t e2 m2 (Vint x) -> + eval_expr ge sp le e1 m1 (andimm n a) t e2 m2 (Vint (Int.and x n)). Proof. intros. unfold andimm. case (Int.is_rlw_mask n). rewrite <- Int.rolm_zero. apply eval_rolm; auto. @@ -758,25 +799,26 @@ Proof. Qed. Theorem eval_and: - forall sp le e1 m1 a e2 m2 x b e3 m3 y, - eval_expr ge sp le e1 m1 a e2 m2 (Vint x) -> - eval_expr ge sp le e2 m2 b e3 m3 (Vint y) -> - eval_expr ge sp le e1 m1 (and a b) e3 m3 (Vint (Int.and x y)). + forall sp le e1 m1 a t1 e2 m2 x b t2 e3 m3 y, + eval_expr ge sp le e1 m1 a t1 e2 m2 (Vint x) -> + eval_expr ge sp le e2 m2 b t2 e3 m3 (Vint y) -> + eval_expr ge sp le e1 m1 (and a b) (t1**t2) e3 m3 (Vint (Int.and x y)). Proof. intros until y; unfold and; case (mul_match a b); intros. - InvEval H. rewrite Int.and_commut. apply eval_andimm; auto. - InvEval H0. apply eval_andimm; auto. + InvEval H. rewrite Int.and_commut. + rewrite E0_left; apply eval_andimm; auto. + InvEval H0. rewrite E0_right; apply eval_andimm; auto. EvalOp. Qed. Remark eval_same_expr_pure: - forall a1 a2 sp le e1 m1 e2 m2 v1 e3 m3 v2, + forall a1 a2 sp le e1 m1 t1 e2 m2 v1 t2 e3 m3 v2, same_expr_pure a1 a2 = true -> - eval_expr ge sp le e1 m1 a1 e2 m2 v1 -> - eval_expr ge sp le e2 m2 a2 e3 m3 v2 -> - a2 = a1 /\ v2 = v1 /\ e2 = e1 /\ m2 = m1. + eval_expr ge sp le e1 m1 a1 t1 e2 m2 v1 -> + eval_expr ge sp le e2 m2 a2 t2 e3 m3 v2 -> + t1 = E0 /\ t2 = E0 /\ a2 = a1 /\ v2 = v1 /\ e2 = e1 /\ m2 = m1. Proof. - intros until v1. + intros until v2. destruct a1; simpl; try (intros; discriminate). destruct a2; simpl; try (intros; discriminate). case (ident_eq i i0); intros. @@ -786,22 +828,20 @@ Proof. Qed. Lemma eval_or: - forall sp le e1 m1 a e2 m2 x b e3 m3 y, - eval_expr ge sp le e1 m1 a e2 m2 (Vint x) -> - eval_expr ge sp le e2 m2 b e3 m3 (Vint y) -> - eval_expr ge sp le e1 m1 (or a b) e3 m3 (Vint (Int.or x y)). + forall sp le e1 m1 a t1 e2 m2 x b t2 e3 m3 y, + eval_expr ge sp le e1 m1 a t1 e2 m2 (Vint x) -> + eval_expr ge sp le e2 m2 b t2 e3 m3 (Vint y) -> + eval_expr ge sp le e1 m1 (or a b) (t1**t2) e3 m3 (Vint (Int.or x y)). Proof. intros until y; unfold or; case (or_match a b); intros. generalize (Int.eq_spec amount1 amount2); case (Int.eq amount1 amount2); intro. case (Int.is_rlw_mask (Int.or mask1 mask2)). - caseEq (same_expr_pure t1 t2); intro. + caseEq (same_expr_pure t0 t3); intro. simpl. InvEval H. FuncInv. InvEval H0. FuncInv. - generalize (eval_same_expr_pure _ _ _ _ _ _ _ _ _ _ _ _ H2 EV EV0). - intros [EQ1 [EQ2 [EQ3 EQ4]]]. - injection EQ2; intro EQ5. - subst t2; subst e2; subst m2; subst i0. - EvalOp. simpl. subst x; subst y; subst amount2. - rewrite Int.or_rolm. auto. + generalize (eval_same_expr_pure _ _ _ _ _ _ _ _ _ _ _ _ _ _ H2 EV EV0). + intros [EQ1 [EQ2 [EQ3 [EQ4 [EQ5 EQ6]]]]]. + injection EQ4; intro EQ7. subst. + EvalOp. simpl. rewrite Int.or_rolm. auto. simpl. EvalOp. simpl. EvalOp. simpl. EvalOp. @@ -809,173 +849,184 @@ Proof. Qed. Theorem eval_xor: - forall sp le e1 m1 a e2 m2 x b e3 m3 y, - eval_expr ge sp le e1 m1 a e2 m2 (Vint x) -> - eval_expr ge sp le e2 m2 b e3 m3 (Vint y) -> - eval_expr ge sp le e1 m1 (xor a b) e3 m3 (Vint (Int.xor x y)). + forall sp le e1 m1 a t1 e2 m2 x b t2 e3 m3 y, + eval_expr ge sp le e1 m1 a t1 e2 m2 (Vint x) -> + eval_expr ge sp le e2 m2 b t2 e3 m3 (Vint y) -> + eval_expr ge sp le e1 m1 (xor a b) (t1**t2) e3 m3 (Vint (Int.xor x y)). Proof. TrivialOp xor. Qed. Theorem eval_shl: - forall sp le e1 m1 a e2 m2 x b e3 m3 y, - eval_expr ge sp le e1 m1 a e2 m2 (Vint x) -> - eval_expr ge sp le e2 m2 b e3 m3 (Vint y) -> + forall sp le e1 m1 a t1 e2 m2 x b t2 e3 m3 y, + eval_expr ge sp le e1 m1 a t1 e2 m2 (Vint x) -> + eval_expr ge sp le e2 m2 b t2 e3 m3 (Vint y) -> Int.ltu y (Int.repr 32) = true -> - eval_expr ge sp le e1 m1 (shl a b) e3 m3 (Vint (Int.shl x y)). + eval_expr ge sp le e1 m1 (shl a b) (t1**t2) e3 m3 (Vint (Int.shl x y)). Proof. intros until y; unfold shl; case (shift_match b); intros. - InvEval H0. apply eval_shlimm; auto. + InvEval H0. rewrite E0_right. apply eval_shlimm; auto. EvalOp. simpl. rewrite H1. auto. Qed. Theorem eval_shr: - forall sp le e1 m1 a e2 m2 x b e3 m3 y, - eval_expr ge sp le e1 m1 a e2 m2 (Vint x) -> - eval_expr ge sp le e2 m2 b e3 m3 (Vint y) -> + forall sp le e1 m1 a t1 e2 m2 x b t2 e3 m3 y, + eval_expr ge sp le e1 m1 a t1 e2 m2 (Vint x) -> + eval_expr ge sp le e2 m2 b t2 e3 m3 (Vint y) -> Int.ltu y (Int.repr 32) = true -> - eval_expr ge sp le e1 m1 (shr a b) e3 m3 (Vint (Int.shr x y)). + eval_expr ge sp le e1 m1 (shr a b) (t1**t2) e3 m3 (Vint (Int.shr x y)). Proof. TrivialOp shr. simpl. rewrite H1. auto. Qed. Theorem eval_shru: - forall sp le e1 m1 a e2 m2 x b e3 m3 y, - eval_expr ge sp le e1 m1 a e2 m2 (Vint x) -> - eval_expr ge sp le e2 m2 b e3 m3 (Vint y) -> + forall sp le e1 m1 a t1 e2 m2 x b t2 e3 m3 y, + eval_expr ge sp le e1 m1 a t1 e2 m2 (Vint x) -> + eval_expr ge sp le e2 m2 b t2 e3 m3 (Vint y) -> Int.ltu y (Int.repr 32) = true -> - eval_expr ge sp le e1 m1 (shru a b) e3 m3 (Vint (Int.shru x y)). + eval_expr ge sp le e1 m1 (shru a b) (t1**t2) e3 m3 (Vint (Int.shru x y)). Proof. intros until y; unfold shru; case (shift_match b); intros. - InvEval H0. apply eval_shruimm; auto. + InvEval H0. rewrite E0_right; apply eval_shruimm; auto. EvalOp. simpl. rewrite H1. auto. Qed. Theorem eval_addf: - forall sp le e1 m1 a e2 m2 x b e3 m3 y, - eval_expr ge sp le e1 m1 a e2 m2 (Vfloat x) -> - eval_expr ge sp le e2 m2 b e3 m3 (Vfloat y) -> - eval_expr ge sp le e1 m1 (addf a b) e3 m3 (Vfloat (Float.add x y)). + forall sp le e1 m1 a t1 e2 m2 x b t2 e3 m3 y, + eval_expr ge sp le e1 m1 a t1 e2 m2 (Vfloat x) -> + eval_expr ge sp le e2 m2 b t2 e3 m3 (Vfloat y) -> + eval_expr ge sp le e1 m1 (addf a b) (t1**t2) e3 m3 (Vfloat (Float.add x y)). Proof. intros until y; unfold addf; case (addf_match a b); intros. - InvEval H. FuncInv. EvalOp. simpl. subst x. reflexivity. + InvEval H. FuncInv. EvalOp. + econstructor; eauto. econstructor; eauto. econstructor; eauto. constructor. + traceEq. simpl. subst x. reflexivity. InvEval H0. FuncInv. eapply eval_Elet. eexact H. EvalOp. - eapply eval_Econs. apply eval_lift. eexact EV. - eapply eval_Econs. apply eval_lift. eexact EV0. - eapply eval_Econs. apply eval_Eletvar. simpl; reflexivity. - apply eval_Enil. - subst y. rewrite Float.addf_commut. reflexivity. + econstructor; eauto with evalexpr. + econstructor; eauto with evalexpr. + econstructor. apply eval_Eletvar. simpl; reflexivity. + constructor. reflexivity. traceEq. + subst y. rewrite Float.addf_commut. reflexivity. auto. EvalOp. Qed. Theorem eval_subf: - forall sp le e1 m1 a e2 m2 x b e3 m3 y, - eval_expr ge sp le e1 m1 a e2 m2 (Vfloat x) -> - eval_expr ge sp le e2 m2 b e3 m3 (Vfloat y) -> - eval_expr ge sp le e1 m1 (subf a b) e3 m3 (Vfloat (Float.sub x y)). + forall sp le e1 m1 a t1 e2 m2 x b t2 e3 m3 y, + eval_expr ge sp le e1 m1 a t1 e2 m2 (Vfloat x) -> + eval_expr ge sp le e2 m2 b t2 e3 m3 (Vfloat y) -> + eval_expr ge sp le e1 m1 (subf a b) (t1**t2) e3 m3 (Vfloat (Float.sub x y)). Proof. intros until y; unfold subf; case (subf_match a b); intros. - InvEval H. FuncInv. EvalOp. subst x. reflexivity. + InvEval H. FuncInv. EvalOp. + econstructor; eauto. econstructor; eauto. econstructor; eauto. constructor. + traceEq. subst x. reflexivity. EvalOp. Qed. Theorem eval_mulf: - forall sp le e1 m1 a e2 m2 x b e3 m3 y, - eval_expr ge sp le e1 m1 a e2 m2 (Vfloat x) -> - eval_expr ge sp le e2 m2 b e3 m3 (Vfloat y) -> - eval_expr ge sp le e1 m1 (mulf a b) e3 m3 (Vfloat (Float.mul x y)). + forall sp le e1 m1 a t1 e2 m2 x b t2 e3 m3 y, + eval_expr ge sp le e1 m1 a t1 e2 m2 (Vfloat x) -> + eval_expr ge sp le e2 m2 b t2 e3 m3 (Vfloat y) -> + eval_expr ge sp le e1 m1 (mulf a b) (t1**t2) e3 m3 (Vfloat (Float.mul x y)). Proof. TrivialOp mulf. Qed. Theorem eval_divf: - forall sp le e1 m1 a e2 m2 x b e3 m3 y, - eval_expr ge sp le e1 m1 a e2 m2 (Vfloat x) -> - eval_expr ge sp le e2 m2 b e3 m3 (Vfloat y) -> - eval_expr ge sp le e1 m1 (divf a b) e3 m3 (Vfloat (Float.div x y)). + forall sp le e1 m1 a t1 e2 m2 x b t2 e3 m3 y, + eval_expr ge sp le e1 m1 a t1 e2 m2 (Vfloat x) -> + eval_expr ge sp le e2 m2 b t2 e3 m3 (Vfloat y) -> + eval_expr ge sp le e1 m1 (divf a b) (t1**t2) e3 m3 (Vfloat (Float.div x y)). Proof. TrivialOp divf. Qed. Theorem eval_cast8signed: - forall sp le e1 m1 a e2 m2 x, - eval_expr ge sp le e1 m1 a e2 m2 (Vint x) -> - eval_expr ge sp le e1 m1 (cast8signed a) e2 m2 (Vint (Int.cast8signed x)). + forall sp le e1 m1 a t e2 m2 v, + eval_expr ge sp le e1 m1 a t e2 m2 v -> + eval_expr ge sp le e1 m1 (cast8signed a) t e2 m2 (Val.cast8signed v). Proof. - intros until x; unfold cast8signed; case (cast8signed_match a); intros. - InvEval H. FuncInv. EvalOp. subst x. rewrite Int.cast8_signed_idem. reflexivity. + intros until v; unfold cast8signed; case (cast8signed_match a); intros. + replace (Val.cast8signed v) with v. auto. + InvEval H. inversion EQ. destruct v0; simpl; auto. rewrite Int.cast8_signed_idem. reflexivity. EvalOp. Qed. Theorem eval_cast8unsigned: - forall sp le e1 m1 a e2 m2 x, - eval_expr ge sp le e1 m1 a e2 m2 (Vint x) -> - eval_expr ge sp le e1 m1 (cast8unsigned a) e2 m2 (Vint (Int.cast8unsigned x)). + forall sp le e1 m1 a t e2 m2 v, + eval_expr ge sp le e1 m1 a t e2 m2 v -> + eval_expr ge sp le e1 m1 (cast8unsigned a) t e2 m2 (Val.cast8unsigned v). Proof. - intros. unfold cast8unsigned. rewrite Int.cast8unsigned_and. - rewrite <- Int.rolm_zero. eapply eval_rolm; eauto. + intros until v; unfold cast8unsigned; case (cast8unsigned_match a); intros. + replace (Val.cast8unsigned v) with v. auto. + InvEval H. inversion EQ. destruct v0; simpl; auto. rewrite Int.cast8_unsigned_idem. reflexivity. + EvalOp. Qed. - + Theorem eval_cast16signed: - forall sp le e1 m1 a e2 m2 x, - eval_expr ge sp le e1 m1 a e2 m2 (Vint x) -> - eval_expr ge sp le e1 m1 (cast16signed a) e2 m2 (Vint (Int.cast16signed x)). + forall sp le e1 m1 a t e2 m2 v, + eval_expr ge sp le e1 m1 a t e2 m2 v -> + eval_expr ge sp le e1 m1 (cast16signed a) t e2 m2 (Val.cast16signed v). Proof. - intros until x; unfold cast16signed; case (cast16signed_match a); intros. - InvEval H. FuncInv. EvalOp. subst x. rewrite Int.cast16_signed_idem. reflexivity. + intros until v; unfold cast16signed; case (cast16signed_match a); intros. + replace (Val.cast16signed v) with v. auto. + InvEval H. inversion EQ. destruct v0; simpl; auto. rewrite Int.cast16_signed_idem. reflexivity. EvalOp. Qed. Theorem eval_cast16unsigned: - forall sp le e1 m1 a e2 m2 x, - eval_expr ge sp le e1 m1 a e2 m2 (Vint x) -> - eval_expr ge sp le e1 m1 (cast16unsigned a) e2 m2 (Vint (Int.cast16unsigned x)). + forall sp le e1 m1 a t e2 m2 v, + eval_expr ge sp le e1 m1 a t e2 m2 v -> + eval_expr ge sp le e1 m1 (cast16unsigned a) t e2 m2 (Val.cast16unsigned v). Proof. - intros. unfold cast16unsigned. rewrite Int.cast16unsigned_and. - rewrite <- Int.rolm_zero. eapply eval_rolm; eauto. + intros until v; unfold cast16unsigned; case (cast16unsigned_match a); intros. + replace (Val.cast16unsigned v) with v. auto. + InvEval H. inversion EQ. destruct v0; simpl; auto. rewrite Int.cast16_unsigned_idem. reflexivity. + EvalOp. Qed. Theorem eval_singleoffloat: - forall sp le e1 m1 a e2 m2 x, - eval_expr ge sp le e1 m1 a e2 m2 (Vfloat x) -> - eval_expr ge sp le e1 m1 (singleoffloat a) e2 m2 (Vfloat (Float.singleoffloat x)). + forall sp le e1 m1 a t e2 m2 v, + eval_expr ge sp le e1 m1 a t e2 m2 v -> + eval_expr ge sp le e1 m1 (singleoffloat a) t e2 m2 (Val.singleoffloat v). Proof. - intros until x; unfold singleoffloat; case (singleoffloat_match a); intros. - InvEval H. FuncInv. EvalOp. subst x. rewrite Float.singleoffloat_idem. reflexivity. + intros until v; unfold singleoffloat; case (singleoffloat_match a); intros. + replace (Val.singleoffloat v) with v. auto. + InvEval H. inversion EQ. destruct v0; simpl; auto. rewrite Float.singleoffloat_idem. reflexivity. EvalOp. Qed. Theorem eval_cmp: - forall sp le c e1 m1 a e2 m2 x b e3 m3 y, - eval_expr ge sp le e1 m1 a e2 m2 (Vint x) -> - eval_expr ge sp le e2 m2 b e3 m3 (Vint y) -> - eval_expr ge sp le e1 m1 (cmp c a b) e3 m3 (Val.of_bool (Int.cmp c x y)). + forall sp le c e1 m1 a t1 e2 m2 x b t2 e3 m3 y, + eval_expr ge sp le e1 m1 a t1 e2 m2 (Vint x) -> + eval_expr ge sp le e2 m2 b t2 e3 m3 (Vint y) -> + eval_expr ge sp le e1 m1 (cmp c a b) (t1**t2) e3 m3 (Val.of_bool (Int.cmp c x y)). Proof. TrivialOp cmp. simpl. case (Int.cmp c x y); auto. Qed. Theorem eval_cmp_null_r: - forall sp le c e1 m1 a e2 m2 p x b e3 m3 v, - eval_expr ge sp le e1 m1 a e2 m2 (Vptr p x) -> - eval_expr ge sp le e2 m2 b e3 m3 (Vint Int.zero) -> + forall sp le c e1 m1 a t1 e2 m2 p x b t2 e3 m3 v, + eval_expr ge sp le e1 m1 a t1 e2 m2 (Vptr p x) -> + eval_expr ge sp le e2 m2 b t2 e3 m3 (Vint Int.zero) -> (c = Ceq /\ v = Vfalse) \/ (c = Cne /\ v = Vtrue) -> - eval_expr ge sp le e1 m1 (cmp c a b) e3 m3 v. + eval_expr ge sp le e1 m1 (cmp c a b) (t1**t2) e3 m3 v. Proof. TrivialOp cmp. simpl. elim H1; intros [EQ1 EQ2]; subst c; subst v; reflexivity. Qed. Theorem eval_cmp_null_l: - forall sp le c e1 m1 a e2 m2 p x b e3 m3 v, - eval_expr ge sp le e1 m1 a e2 m2 (Vint Int.zero) -> - eval_expr ge sp le e2 m2 b e3 m3 (Vptr p x) -> + forall sp le c e1 m1 a t1 e2 m2 p x b t2 e3 m3 v, + eval_expr ge sp le e1 m1 a t1 e2 m2 (Vint Int.zero) -> + eval_expr ge sp le e2 m2 b t2 e3 m3 (Vptr p x) -> (c = Ceq /\ v = Vfalse) \/ (c = Cne /\ v = Vtrue) -> - eval_expr ge sp le e1 m1 (cmp c a b) e3 m3 v. + eval_expr ge sp le e1 m1 (cmp c a b) (t1**t2) e3 m3 v. Proof. TrivialOp cmp. simpl. elim H1; intros [EQ1 EQ2]; subst c; subst v; reflexivity. Qed. Theorem eval_cmp_ptr: - forall sp le c e1 m1 a e2 m2 p x b e3 m3 y, - eval_expr ge sp le e1 m1 a e2 m2 (Vptr p x) -> - eval_expr ge sp le e2 m2 b e3 m3 (Vptr p y) -> - eval_expr ge sp le e1 m1 (cmp c a b) e3 m3 (Val.of_bool (Int.cmp c x y)). + forall sp le c e1 m1 a t1 e2 m2 p x b t2 e3 m3 y, + eval_expr ge sp le e1 m1 a t1 e2 m2 (Vptr p x) -> + eval_expr ge sp le e2 m2 b t2 e3 m3 (Vptr p y) -> + eval_expr ge sp le e1 m1 (cmp c a b) (t1**t2) e3 m3 (Val.of_bool (Int.cmp c x y)). Proof. TrivialOp cmp. simpl. unfold eq_block. rewrite zeq_true. @@ -983,32 +1034,32 @@ Proof. Qed. Theorem eval_cmpu: - forall sp le c e1 m1 a e2 m2 x b e3 m3 y, - eval_expr ge sp le e1 m1 a e2 m2 (Vint x) -> - eval_expr ge sp le e2 m2 b e3 m3 (Vint y) -> - eval_expr ge sp le e1 m1 (cmpu c a b) e3 m3 (Val.of_bool (Int.cmpu c x y)). + forall sp le c e1 m1 a t1 e2 m2 x b t2 e3 m3 y, + eval_expr ge sp le e1 m1 a t1 e2 m2 (Vint x) -> + eval_expr ge sp le e2 m2 b t2 e3 m3 (Vint y) -> + eval_expr ge sp le e1 m1 (cmpu c a b) (t1**t2) e3 m3 (Val.of_bool (Int.cmpu c x y)). Proof. TrivialOp cmpu. simpl. case (Int.cmpu c x y); auto. Qed. Theorem eval_cmpf: - forall sp le c e1 m1 a e2 m2 x b e3 m3 y, - eval_expr ge sp le e1 m1 a e2 m2 (Vfloat x) -> - eval_expr ge sp le e2 m2 b e3 m3 (Vfloat y) -> - eval_expr ge sp le e1 m1 (cmpf c a b) e3 m3 (Val.of_bool (Float.cmp c x y)). + forall sp le c e1 m1 a t1 e2 m2 x b t2 e3 m3 y, + eval_expr ge sp le e1 m1 a t1 e2 m2 (Vfloat x) -> + eval_expr ge sp le e2 m2 b t2 e3 m3 (Vfloat y) -> + eval_expr ge sp le e1 m1 (cmpf c a b) (t1**t2) e3 m3 (Val.of_bool (Float.cmp c x y)). Proof. TrivialOp cmpf. simpl. case (Float.cmp c x y); auto. Qed. Lemma eval_base_condition_of_expr: - forall sp le a e1 m1 e2 m2 v (b: bool), - eval_expr ge sp le e1 m1 a e2 m2 v -> + forall sp le a e1 m1 t e2 m2 v (b: bool), + eval_expr ge sp le e1 m1 a t e2 m2 v -> Val.bool_of_val v b -> eval_condexpr ge sp le e1 m1 (CEcond (Ccompuimm Cne Int.zero) (a ::: Enil)) - e2 m2 b. + t e2 m2 b. Proof. intros. eapply eval_CEcond. eauto with evalexpr. @@ -1016,62 +1067,60 @@ Proof. Qed. Lemma eval_condition_of_expr: - forall a sp le e1 m1 e2 m2 v (b: bool), - eval_expr ge sp le e1 m1 a e2 m2 v -> + forall a sp le e1 m1 t e2 m2 v (b: bool), + eval_expr ge sp le e1 m1 a t e2 m2 v -> Val.bool_of_val v b -> - eval_condexpr ge sp le e1 m1 (condexpr_of_expr a) e2 m2 b. + eval_condexpr ge sp le e1 m1 (condexpr_of_expr a) t e2 m2 b. Proof. induction a; simpl; intros; try (eapply eval_base_condition_of_expr; eauto; fail). destruct o; try (eapply eval_base_condition_of_expr; eauto; fail). - destruct e. inversion H. subst sp0 le0 e m op al e0 m0 v0. - inversion H7. subst sp0 le0 e m e1 m1 vl. - simpl in H11. inversion H11; subst v. + destruct e. InvEval H. inversion XX4; subst v. inversion H0. rewrite Int.eq_false; auto. constructor. subst i; rewrite Int.eq_true. constructor. eapply eval_base_condition_of_expr; eauto. - inversion H. eapply eval_CEcond; eauto. simpl in H11. + inversion H. subst. eapply eval_CEcond; eauto. simpl in H12. destruct (eval_condition c vl); try discriminate. - destruct b0; inversion H11; subst v0; subst v; inversion H0; congruence. + destruct b0; inversion H12; subst; inversion H0; congruence. - inversion H. + inversion H. subst. destruct v1; eauto with evalexpr. Qed. Theorem eval_conditionalexpr_true: - forall sp le e1 m1 a1 e2 m2 v1 a2 e3 m3 v2 a3, - eval_expr ge sp le e1 m1 a1 e2 m2 v1 -> + forall sp le e1 m1 a1 t1 e2 m2 v1 t2 a2 e3 m3 v2 a3, + eval_expr ge sp le e1 m1 a1 t1 e2 m2 v1 -> Val.is_true v1 -> - eval_expr ge sp le e2 m2 a2 e3 m3 v2 -> - eval_expr ge sp le e1 m1 (conditionalexpr a1 a2 a3) e3 m3 v2. + eval_expr ge sp le e2 m2 a2 t2 e3 m3 v2 -> + eval_expr ge sp le e1 m1 (conditionalexpr a1 a2 a3) (t1**t2) e3 m3 v2. Proof. intros; unfold conditionalexpr. - apply eval_Econdition with e2 m2 true; auto. + apply eval_Econdition with t1 e2 m2 true t2; auto. eapply eval_condition_of_expr; eauto with valboolof. Qed. Theorem eval_conditionalexpr_false: - forall sp le e1 m1 a1 e2 m2 v1 a2 e3 m3 v2 a3, - eval_expr ge sp le e1 m1 a1 e2 m2 v1 -> + forall sp le e1 m1 a1 t1 e2 m2 v1 a2 t2 e3 m3 v2 a3, + eval_expr ge sp le e1 m1 a1 t1 e2 m2 v1 -> Val.is_false v1 -> - eval_expr ge sp le e2 m2 a3 e3 m3 v2 -> - eval_expr ge sp le e1 m1 (conditionalexpr a1 a2 a3) e3 m3 v2. + eval_expr ge sp le e2 m2 a3 t2 e3 m3 v2 -> + eval_expr ge sp le e1 m1 (conditionalexpr a1 a2 a3) (t1**t2) e3 m3 v2. Proof. intros; unfold conditionalexpr. - apply eval_Econdition with e2 m2 false; auto. + apply eval_Econdition with t1 e2 m2 false t2; auto. eapply eval_condition_of_expr; eauto with valboolof. Qed. Lemma eval_addressing: - forall sp le e1 m1 a e2 m2 v b ofs, - eval_expr ge sp le e1 m1 a e2 m2 v -> + forall sp le e1 m1 a t e2 m2 v b ofs, + eval_expr ge sp le e1 m1 a t e2 m2 v -> v = Vptr b ofs -> match addressing a with (mode, args) => exists vl, - eval_exprlist ge sp le e1 m1 args e2 m2 vl /\ + eval_exprlist ge sp le e1 m1 args t e2 m2 vl /\ eval_addressing ge sp mode vl = Some v end. Proof. @@ -1080,19 +1129,13 @@ Proof. simpl. auto. InvEval H. exists (@nil val). split. eauto with evalexpr. simpl. auto. - InvEval H. FuncInv. + InvEval H. InvEval EV. rewrite E0_left in TR. subst t1. FuncInv. congruence. - InvEval EV. + destruct (Genv.find_symbol ge s); congruence. exists (Vint i0 :: nil). split. eauto with evalexpr. simpl. subst v. destruct (Genv.find_symbol ge s). congruence. discriminate. InvEval H. FuncInv. - destruct (Genv.find_symbol ge s); congruence. - InvEval EV. - exists (Vint i0 :: nil). split. eauto with evalexpr. - simpl. destruct (Genv.find_symbol ge s). congruence. - discriminate. - InvEval H. FuncInv. congruence. exists (Vptr b0 i :: nil). split. eauto with evalexpr. simpl. congruence. @@ -1108,56 +1151,56 @@ Proof. Qed. Theorem eval_load: - forall sp le e1 m1 a e2 m2 v chunk v', - eval_expr ge sp le e1 m1 a e2 m2 v -> + forall sp le e1 m1 a t e2 m2 v chunk v', + eval_expr ge sp le e1 m1 a t e2 m2 v -> Mem.loadv chunk m2 v = Some v' -> - eval_expr ge sp le e1 m1 (load chunk a) e2 m2 v'. + eval_expr ge sp le e1 m1 (load chunk a) t e2 m2 v'. Proof. intros. generalize H0; destruct v; simpl; intro; try discriminate. unfold load. - generalize (eval_addressing _ _ _ _ _ _ _ _ _ _ H (refl_equal _)). + generalize (eval_addressing _ _ _ _ _ _ _ _ _ _ _ H (refl_equal _)). destruct (addressing a). intros [vl [EV EQ]]. eapply eval_Eload; eauto. Qed. Theorem eval_store: - forall sp le e1 m1 a1 e2 m2 v1 a2 e3 m3 v2 chunk m4, - eval_expr ge sp le e1 m1 a1 e2 m2 v1 -> - eval_expr ge sp le e2 m2 a2 e3 m3 v2 -> + forall sp le e1 m1 a1 t1 e2 m2 v1 a2 t2 e3 m3 v2 chunk m4, + eval_expr ge sp le e1 m1 a1 t1 e2 m2 v1 -> + eval_expr ge sp le e2 m2 a2 t2 e3 m3 v2 -> Mem.storev chunk m3 v1 v2 = Some m4 -> - eval_expr ge sp le e1 m1 (store chunk a1 a2) e3 m4 v2. + eval_expr ge sp le e1 m1 (store chunk a1 a2) (t1**t2) e3 m4 v2. Proof. intros. generalize H1; destruct v1; simpl; intro; try discriminate. unfold store. - generalize (eval_addressing _ _ _ _ _ _ _ _ _ _ H (refl_equal _)). + generalize (eval_addressing _ _ _ _ _ _ _ _ _ _ _ H (refl_equal _)). destruct (addressing a1). intros [vl [EV EQ]]. eapply eval_Estore; eauto. Qed. Theorem exec_ifthenelse_true: - forall sp e1 m1 a e2 m2 v ifso ifnot e3 m3 out, - eval_expr ge sp nil e1 m1 a e2 m2 v -> + forall sp e1 m1 a t1 e2 m2 v ifso ifnot t2 e3 m3 out, + eval_expr ge sp nil e1 m1 a t1 e2 m2 v -> Val.is_true v -> - exec_stmt ge sp e2 m2 ifso e3 m3 out -> - exec_stmt ge sp e1 m1 (ifthenelse a ifso ifnot) e3 m3 out. + exec_stmt ge sp e2 m2 ifso t2 e3 m3 out -> + exec_stmt ge sp e1 m1 (ifthenelse a ifso ifnot) (t1**t2) e3 m3 out. Proof. intros. unfold ifthenelse. - apply exec_Sifthenelse with e2 m2 true. + apply exec_Sifthenelse with t1 e2 m2 true t2. eapply eval_condition_of_expr; eauto with valboolof. - auto. + auto. auto. Qed. Theorem exec_ifthenelse_false: - forall sp e1 m1 a e2 m2 v ifso ifnot e3 m3 out, - eval_expr ge sp nil e1 m1 a e2 m2 v -> + forall sp e1 m1 a t1 e2 m2 v ifso ifnot t2 e3 m3 out, + eval_expr ge sp nil e1 m1 a t1 e2 m2 v -> Val.is_false v -> - exec_stmt ge sp e2 m2 ifnot e3 m3 out -> - exec_stmt ge sp e1 m1 (ifthenelse a ifso ifnot) e3 m3 out. + exec_stmt ge sp e2 m2 ifnot t2 e3 m3 out -> + exec_stmt ge sp e1 m1 (ifthenelse a ifso ifnot) (t1**t2) e3 m3 out. Proof. intros. unfold ifthenelse. - apply exec_Sifthenelse with e2 m2 false. + apply exec_Sifthenelse with t1 e2 m2 false t2. eapply eval_condition_of_expr; eauto with valboolof. - auto. + auto. auto. Qed. End CMCONSTR. diff --git a/backend/Cminor.v b/backend/Cminor.v index 826c529..9eed009 100644 --- a/backend/Cminor.v +++ b/backend/Cminor.v @@ -5,6 +5,7 @@ Require Import Maps. Require Import AST. Require Import Integers. Require Import Floats. +Require Import Events. Require Import Values. Require Import Mem. Require Import Op. @@ -35,6 +36,7 @@ Inductive expr : Set := | Econdition : condexpr -> expr -> expr -> expr | Elet : expr -> expr -> expr | Eletvar : nat -> expr + | Ealloc : expr -> expr with condexpr : Set := | CEtrue: condexpr @@ -77,7 +79,14 @@ Record function : Set := mkfunction { fn_body: stmt }. -Definition program := AST.program function. +Definition fundef := AST.fundef function. +Definition program := AST.program fundef. + +Definition funsig (fd: fundef) := + match fd with + | Internal f => f.(fn_sig) + | External ef => ef.(ef_sig) + end. (** * Operational semantics *) @@ -120,7 +129,7 @@ Fixpoint switch_target (n: int) (dfl: nat) (cases: list (int * nat)) - [lenv]: let environments, map de Bruijn indices to values. *) -Definition genv := Genv.t function. +Definition genv := Genv.t fundef. Definition env := PTree.t val. Definition letenv := list val. @@ -157,56 +166,65 @@ Variable ge: genv. Inductive eval_expr: val -> letenv -> - env -> mem -> expr -> + env -> mem -> expr -> trace -> env -> mem -> val -> Prop := | eval_Evar: forall sp le e m id v, PTree.get id e = Some v -> - eval_expr sp le e m (Evar id) e m v + eval_expr sp le e m (Evar id) E0 e m v | eval_Eassign: - forall sp le e m id a e1 m1 v, - eval_expr sp le e m a e1 m1 v -> - eval_expr sp le e m (Eassign id a) (PTree.set id v e1) m1 v + forall sp le e m id a t e1 m1 v, + eval_expr sp le e m a t e1 m1 v -> + eval_expr sp le e m (Eassign id a) t (PTree.set id v e1) m1 v | eval_Eop: - forall sp le e m op al e1 m1 vl v, - eval_exprlist sp le e m al e1 m1 vl -> + forall sp le e m op al t e1 m1 vl v, + eval_exprlist sp le e m al t e1 m1 vl -> eval_operation ge sp op vl = Some v -> - eval_expr sp le e m (Eop op al) e1 m1 v + eval_expr sp le e m (Eop op al) t e1 m1 v | eval_Eload: - forall sp le e m chunk addr al e1 m1 v vl a, - eval_exprlist sp le e m al e1 m1 vl -> + forall sp le e m chunk addr al t e1 m1 v vl a, + eval_exprlist sp le e m al t e1 m1 vl -> eval_addressing ge sp addr vl = Some a -> Mem.loadv chunk m1 a = Some v -> - eval_expr sp le e m (Eload chunk addr al) e1 m1 v + eval_expr sp le e m (Eload chunk addr al) t e1 m1 v | eval_Estore: - forall sp le e m chunk addr al b e1 m1 vl e2 m2 m3 v a, - eval_exprlist sp le e m al e1 m1 vl -> - eval_expr sp le e1 m1 b e2 m2 v -> + forall sp le e m chunk addr al b t t1 e1 m1 vl t2 e2 m2 m3 v a, + eval_exprlist sp le e m al t1 e1 m1 vl -> + eval_expr sp le e1 m1 b t2 e2 m2 v -> eval_addressing ge sp addr vl = Some a -> Mem.storev chunk m2 a v = Some m3 -> - eval_expr sp le e m (Estore chunk addr al b) e2 m3 v + t = t1 ** t2 -> + eval_expr sp le e m (Estore chunk addr al b) t e2 m3 v | eval_Ecall: - forall sp le e m sig a bl e1 e2 m1 m2 m3 vf vargs vres f, - eval_expr sp le e m a e1 m1 vf -> - eval_exprlist sp le e1 m1 bl e2 m2 vargs -> + forall sp le e m sig a bl t t1 e1 m1 t2 e2 m2 t3 m3 vf vargs vres f, + eval_expr sp le e m a t1 e1 m1 vf -> + eval_exprlist sp le e1 m1 bl t2 e2 m2 vargs -> Genv.find_funct ge vf = Some f -> - f.(fn_sig) = sig -> - eval_funcall m2 f vargs m3 vres -> - eval_expr sp le e m (Ecall sig a bl) e2 m3 vres + funsig f = sig -> + eval_funcall m2 f vargs t3 m3 vres -> + t = t1 ** t2 ** t3 -> + eval_expr sp le e m (Ecall sig a bl) t e2 m3 vres | eval_Econdition: - forall sp le e m a b c e1 m1 v1 e2 m2 v2, - eval_condexpr sp le e m a e1 m1 v1 -> - eval_expr sp le e1 m1 (if v1 then b else c) e2 m2 v2 -> - eval_expr sp le e m (Econdition a b c) e2 m2 v2 + forall sp le e m a b c t t1 e1 m1 v1 t2 e2 m2 v2, + eval_condexpr sp le e m a t1 e1 m1 v1 -> + eval_expr sp le e1 m1 (if v1 then b else c) t2 e2 m2 v2 -> + t = t1 ** t2 -> + eval_expr sp le e m (Econdition a b c) t e2 m2 v2 | eval_Elet: - forall sp le e m a b e1 m1 v1 e2 m2 v2, - eval_expr sp le e m a e1 m1 v1 -> - eval_expr sp (v1::le) e1 m1 b e2 m2 v2 -> - eval_expr sp le e m (Elet a b) e2 m2 v2 + forall sp le e m a b t t1 e1 m1 v1 t2 e2 m2 v2, + eval_expr sp le e m a t1 e1 m1 v1 -> + eval_expr sp (v1::le) e1 m1 b t2 e2 m2 v2 -> + t = t1 ** t2 -> + eval_expr sp le e m (Elet a b) t e2 m2 v2 | eval_Eletvar: forall sp le e m n v, nth_error le n = Some v -> - eval_expr sp le e m (Eletvar n) e m v + eval_expr sp le e m (Eletvar n) E0 e m v + | eval_Ealloc: + forall sp le e m a t e1 m1 n m2 b, + eval_expr sp le e m a t e1 m1 (Vint n) -> + Mem.alloc m1 0 (Int.signed n) = (m2, b) -> + eval_expr sp le e m (Ealloc a) t e1 m2 (Vptr b Int.zero) (** Evaluation of a condition expression: [eval_condexpr ge sp le e m a e' m' b] @@ -216,24 +234,25 @@ Inductive eval_expr: with eval_condexpr: val -> letenv -> - env -> mem -> condexpr -> + env -> mem -> condexpr -> trace -> env -> mem -> bool -> Prop := | eval_CEtrue: forall sp le e m, - eval_condexpr sp le e m CEtrue e m true + eval_condexpr sp le e m CEtrue E0 e m true | eval_CEfalse: forall sp le e m, - eval_condexpr sp le e m CEfalse e m false + eval_condexpr sp le e m CEfalse E0 e m false | eval_CEcond: - forall sp le e m cond al e1 m1 vl b, - eval_exprlist sp le e m al e1 m1 vl -> + forall sp le e m cond al t1 e1 m1 vl b, + eval_exprlist sp le e m al t1 e1 m1 vl -> eval_condition cond vl = Some b -> - eval_condexpr sp le e m (CEcond cond al) e1 m1 b + eval_condexpr sp le e m (CEcond cond al) t1 e1 m1 b | eval_CEcondition: - forall sp le e m a b c e1 m1 vb1 e2 m2 vb2, - eval_condexpr sp le e m a e1 m1 vb1 -> - eval_condexpr sp le e1 m1 (if vb1 then b else c) e2 m2 vb2 -> - eval_condexpr sp le e m (CEcondition a b c) e2 m2 vb2 + forall sp le e m a b c t t1 e1 m1 vb1 t2 e2 m2 vb2, + eval_condexpr sp le e m a t1 e1 m1 vb1 -> + eval_condexpr sp le e1 m1 (if vb1 then b else c) t2 e2 m2 vb2 -> + t = t1 ** t2 -> + eval_condexpr sp le e m (CEcondition a b c) t e2 m2 vb2 (** Evaluation of a list of expressions: [eval_exprlist ge sp le al m a e' m' vl] @@ -244,16 +263,17 @@ with eval_condexpr: with eval_exprlist: val -> letenv -> - env -> mem -> exprlist -> + env -> mem -> exprlist -> trace -> env -> mem -> list val -> Prop := | eval_Enil: forall sp le e m, - eval_exprlist sp le e m Enil e m nil + eval_exprlist sp le e m Enil E0 e m nil | eval_Econs: - forall sp le e m a bl e1 m1 v e2 m2 vl, - eval_expr sp le e m a e1 m1 v -> - eval_exprlist sp le e1 m1 bl e2 m2 vl -> - eval_exprlist sp le e m (Econs a bl) e2 m2 (v :: vl) + forall sp le e m a bl t t1 e1 m1 v t2 e2 m2 vl, + eval_expr sp le e m a t1 e1 m1 v -> + eval_exprlist sp le e1 m1 bl t2 e2 m2 vl -> + t = t1 ** t2 -> + eval_exprlist sp le e m (Econs a bl) t e2 m2 (v :: vl) (** Evaluation of a function invocation: [eval_funcall ge m f args m' res] means that the function [f], applied to the arguments [args] in @@ -261,15 +281,19 @@ with eval_exprlist: *) with eval_funcall: - mem -> function -> list val -> + mem -> fundef -> list val -> trace -> mem -> val -> Prop := - | eval_funcall_intro: - forall m f vargs m1 sp e e2 m2 out vres, + | eval_funcall_internal: + forall m f vargs m1 sp e t e2 m2 out vres, Mem.alloc m 0 f.(fn_stackspace) = (m1, sp) -> set_locals f.(fn_vars) (set_params vargs f.(fn_params)) = e -> - exec_stmt (Vptr sp Int.zero) e m1 f.(fn_body) e2 m2 out -> + exec_stmt (Vptr sp Int.zero) e m1 f.(fn_body) t e2 m2 out -> outcome_result_value out f.(fn_sig).(sig_res) vres -> - eval_funcall m f vargs (Mem.free m2 sp) vres + eval_funcall m (Internal f) vargs t (Mem.free m2 sp) vres + | eval_funcall_external: + forall ef m args t res, + event_match ef args t res -> + eval_funcall m (External ef) args t m res (** Execution of a statement: [exec_stmt ge sp e m s e' m' out] means that statement [s] executes with outcome [out]. @@ -277,59 +301,62 @@ with eval_funcall: with exec_stmt: val -> - env -> mem -> stmt -> + env -> mem -> stmt -> trace -> env -> mem -> outcome -> Prop := | exec_Sskip: forall sp e m, - exec_stmt sp e m Sskip e m Out_normal + exec_stmt sp e m Sskip E0 e m Out_normal | exec_Sexpr: - forall sp e m a e1 m1 v, - eval_expr sp nil e m a e1 m1 v -> - exec_stmt sp e m (Sexpr a) e1 m1 Out_normal + forall sp e m a t e1 m1 v, + eval_expr sp nil e m a t e1 m1 v -> + exec_stmt sp e m (Sexpr a) t e1 m1 Out_normal | exec_Sifthenelse: - forall sp e m a s1 s2 e1 m1 v1 e2 m2 out, - eval_condexpr sp nil e m a e1 m1 v1 -> - exec_stmt sp e1 m1 (if v1 then s1 else s2) e2 m2 out -> - exec_stmt sp e m (Sifthenelse a s1 s2) e2 m2 out + forall sp e m a s1 s2 t t1 e1 m1 v1 t2 e2 m2 out, + eval_condexpr sp nil e m a t1 e1 m1 v1 -> + exec_stmt sp e1 m1 (if v1 then s1 else s2) t2 e2 m2 out -> + t = t1 ** t2 -> + exec_stmt sp e m (Sifthenelse a s1 s2) t e2 m2 out | exec_Sseq_continue: - forall sp e m s1 e1 m1 s2 e2 m2 out, - exec_stmt sp e m s1 e1 m1 Out_normal -> - exec_stmt sp e1 m1 s2 e2 m2 out -> - exec_stmt sp e m (Sseq s1 s2) e2 m2 out + forall sp e m t s1 t1 e1 m1 s2 t2 e2 m2 out, + exec_stmt sp e m s1 t1 e1 m1 Out_normal -> + exec_stmt sp e1 m1 s2 t2 e2 m2 out -> + t = t1 ** t2 -> + exec_stmt sp e m (Sseq s1 s2) t e2 m2 out | exec_Sseq_stop: - forall sp e m s1 s2 e1 m1 out, - exec_stmt sp e m s1 e1 m1 out -> + forall sp e m t s1 s2 e1 m1 out, + exec_stmt sp e m s1 t e1 m1 out -> out <> Out_normal -> - exec_stmt sp e m (Sseq s1 s2) e1 m1 out + exec_stmt sp e m (Sseq s1 s2) t e1 m1 out | exec_Sloop_loop: - forall sp e m s e1 m1 e2 m2 out, - exec_stmt sp e m s e1 m1 Out_normal -> - exec_stmt sp e1 m1 (Sloop s) e2 m2 out -> - exec_stmt sp e m (Sloop s) e2 m2 out + forall sp e m s t t1 e1 m1 t2 e2 m2 out, + exec_stmt sp e m s t1 e1 m1 Out_normal -> + exec_stmt sp e1 m1 (Sloop s) t2 e2 m2 out -> + t = t1 ** t2 -> + exec_stmt sp e m (Sloop s) t e2 m2 out | exec_Sloop_stop: - forall sp e m s e1 m1 out, - exec_stmt sp e m s e1 m1 out -> + forall sp e m t s e1 m1 out, + exec_stmt sp e m s t e1 m1 out -> out <> Out_normal -> - exec_stmt sp e m (Sloop s) e1 m1 out + exec_stmt sp e m (Sloop s) t e1 m1 out | exec_Sblock: - forall sp e m s e1 m1 out, - exec_stmt sp e m s e1 m1 out -> - exec_stmt sp e m (Sblock s) e1 m1 (outcome_block out) + forall sp e m s t e1 m1 out, + exec_stmt sp e m s t e1 m1 out -> + exec_stmt sp e m (Sblock s) t e1 m1 (outcome_block out) | exec_Sexit: forall sp e m n, - exec_stmt sp e m (Sexit n) e m (Out_exit n) + exec_stmt sp e m (Sexit n) E0 e m (Out_exit n) | exec_Sswitch: - forall sp e m a cases default e1 m1 n, - eval_expr sp nil e m a e1 m1 (Vint n) -> + forall sp e m a cases default t1 e1 m1 n, + eval_expr sp nil e m a t1 e1 m1 (Vint n) -> exec_stmt sp e m (Sswitch a cases default) - e1 m1 (Out_exit (switch_target n default cases)) + t1 e1 m1 (Out_exit (switch_target n default cases)) | exec_Sreturn_none: forall sp e m, - exec_stmt sp e m (Sreturn None) e m (Out_return None) + exec_stmt sp e m (Sreturn None) E0 e m (Out_return None) | exec_Sreturn_some: - forall sp e m a e1 m1 v, - eval_expr sp nil e m a e1 m1 v -> - exec_stmt sp e m (Sreturn (Some a)) e1 m1 (Out_return (Some v)). + forall sp e m a t e1 m1 v, + eval_expr sp nil e m a t e1 m1 v -> + exec_stmt sp e m (Sreturn (Some a)) t e1 m1 (Out_return (Some v)). End RELSEM. @@ -337,12 +364,12 @@ End RELSEM. holds if the application of [p]'s main function to no arguments in the initial memory state for [p] eventually returns value [r]. *) -Definition exec_program (p: program) (r: val) : Prop := +Definition exec_program (p: program) (t: trace) (r: val) : Prop := let ge := Genv.globalenv p in let m0 := Genv.init_mem p in exists b, exists f, exists m, Genv.find_symbol ge p.(prog_main) = Some b /\ Genv.find_funct_ptr ge b = Some f /\ - f.(fn_sig) = mksignature nil (Some Tint) /\ - eval_funcall ge m0 f nil m r. + funsig f = mksignature nil (Some Tint) /\ + eval_funcall ge m0 f nil t m r. diff --git a/backend/Cminorgen.v b/backend/Cminorgen.v index cb88992..4c611b4 100644 --- a/backend/Cminorgen.v +++ b/backend/Cminorgen.v @@ -104,18 +104,27 @@ Definition make_cast (chunk: memory_chunk) (e: expr): expr := Definition make_load (chunk: memory_chunk) (e: expr): expr := Cmconstr.load chunk e. -(** In Csharpminor, the value of a store expression is the stored data - normalized to the memory chunk. In Cminor, it is the stored data. - For the translation, we could normalize before storing. However, - the memory model performs automatic normalization of the stored - data. It is therefore correct to store the data as is, then - normalize the result value of the store expression. This is more - efficient in general because often the result value is ignored: - the normalization code will therefore be eliminated later as dead - code. *) - -Definition make_store (chunk: memory_chunk) (e1 e2: expr): expr := - make_cast chunk (Cmconstr.store chunk e1 e2). +Definition store_arg (chunk: memory_chunk) (e: expr) : expr := + match e with + | Eop op (Econs e1 Enil) => + match op with + | Ocast8signed => + match chunk with Mint8signed => e1 | _ => e end + | Ocast8unsigned => + match chunk with Mint8unsigned => e1 | _ => e end + | Ocast16signed => + match chunk with Mint16signed => e1 | _ => e end + | Ocast16unsigned => + match chunk with Mint16unsigned => e1 | _ => e end + | Osingleoffloat => + match chunk with Mfloat32 => e1 | _ => e end + | _ => e + end + | _ => e + end. + +Definition make_store (chunk: memory_chunk) (e1 e2: expr): stmt := + Sexpr(Cmconstr.store chunk e1 (store_arg chunk e2)). Definition make_stackaddr (ofs: Z): expr := Eop (Oaddrstack (Int.repr ofs)) Enil. @@ -156,10 +165,10 @@ Definition var_get (cenv: compilenv) (id: ident): option expr := None end. -Definition var_set (cenv: compilenv) (id: ident) (rhs: expr): option expr := +Definition var_set (cenv: compilenv) (id: ident) (rhs: expr): option stmt := match PMap.get id cenv with | Var_local chunk => - Some(Eassign id (make_cast chunk rhs)) + Some(Sexpr(Eassign id (make_cast chunk rhs))) | Var_stack_scalar chunk ofs => Some(make_store chunk (make_stackaddr ofs) rhs) | Var_global_scalar chunk => @@ -199,16 +208,10 @@ Fixpoint transl_expr (cenv: compilenv) (e: Csharpminor.expr) match e with | Csharpminor.Evar id => var_get cenv id | Csharpminor.Eaddrof id => var_addr cenv id - | Csharpminor.Eassign id e => - do te <- transl_expr cenv e; var_set cenv id te | Csharpminor.Eop op el => do tel <- transl_exprlist cenv el; make_op op tel | Csharpminor.Eload chunk e => do te <- transl_expr cenv e; Some (make_load chunk te) - | Csharpminor.Estore chunk e1 e2 => - do te1 <- transl_expr cenv e1; - do te2 <- transl_expr cenv e2; - Some (make_store chunk te1 te2) | Csharpminor.Ecall sig e el => do te <- transl_expr cenv e; do tel <- transl_exprlist cenv el; @@ -224,6 +227,9 @@ Fixpoint transl_expr (cenv: compilenv) (e: Csharpminor.expr) Some (Elet te1 te2) | Csharpminor.Eletvar n => Some (Eletvar n) + | Csharpminor.Ealloc e => + do te <- transl_expr cenv e; + Some (Ealloc te) end with transl_exprlist (cenv: compilenv) (el: Csharpminor.exprlist) @@ -246,6 +252,12 @@ Fixpoint transl_stmt (cenv: compilenv) (s: Csharpminor.stmt) Some Sskip | Csharpminor.Sexpr e => do te <- transl_expr cenv e; Some(Sexpr te) + | Csharpminor.Sassign id e => + do te <- transl_expr cenv e; var_set cenv id te + | Csharpminor.Sstore chunk e1 e2 => + do te1 <- transl_expr cenv e1; + do te2 <- transl_expr cenv e2; + Some (make_store chunk te1 te2) | Csharpminor.Sseq s1 s2 => do ts1 <- transl_stmt cenv s1; do ts2 <- transl_stmt cenv s2; @@ -280,11 +292,8 @@ Fixpoint addr_taken_expr (e: Csharpminor.expr): Identset.t := match e with | Csharpminor.Evar id => Identset.empty | Csharpminor.Eaddrof id => Identset.add id Identset.empty - | Csharpminor.Eassign id e => addr_taken_expr e | Csharpminor.Eop op el => addr_taken_exprlist el | Csharpminor.Eload chunk e => addr_taken_expr e - | Csharpminor.Estore chunk e1 e2 => - Identset.union (addr_taken_expr e1) (addr_taken_expr e2) | Csharpminor.Ecall sig e el => Identset.union (addr_taken_expr e) (addr_taken_exprlist el) | Csharpminor.Econdition e1 e2 e3 => @@ -293,6 +302,7 @@ Fixpoint addr_taken_expr (e: Csharpminor.expr): Identset.t := | Csharpminor.Elet e1 e2 => Identset.union (addr_taken_expr e1) (addr_taken_expr e2) | Csharpminor.Eletvar n => Identset.empty + | Csharpminor.Ealloc e => addr_taken_expr e end with addr_taken_exprlist (e: Csharpminor.exprlist): Identset.t := @@ -306,6 +316,9 @@ Fixpoint addr_taken_stmt (s: Csharpminor.stmt): Identset.t := match s with | Csharpminor.Sskip => Identset.empty | Csharpminor.Sexpr e => addr_taken_expr e + | Csharpminor.Sassign id e => addr_taken_expr e + | Csharpminor.Sstore chunk e1 e2 => + Identset.union (addr_taken_expr e1) (addr_taken_expr e2) | Csharpminor.Sseq s1 s2 => Identset.union (addr_taken_stmt s1) (addr_taken_stmt s2) | Csharpminor.Sifthenelse e s1 s2 => @@ -362,10 +375,10 @@ Definition build_compilenv (globenv, 0). Definition assign_global_variable - (ce: compilenv) (id_vi: ident * var_kind) : compilenv := - match id_vi with - | (id, Vscalar chunk) => PMap.set id (Var_global_scalar chunk) ce - | (id, Varray sz) => PMap.set id Var_global_array ce + (ce: compilenv) (info: ident * var_kind * list init_data) : compilenv := + match info with + | (id, Vscalar chunk, _) => PMap.set id (Var_global_scalar chunk) ce + | (id, Varray _, _) => PMap.set id Var_global_array ce end. Definition build_global_compilenv (p: Csharpminor.program) : compilenv := @@ -387,7 +400,7 @@ Fixpoint store_parameters Sseq (Sexpr (Eassign id (make_cast chunk (Evar id)))) (store_parameters cenv rem) | Var_stack_scalar chunk ofs => - Sseq (Sexpr (make_store chunk (make_stackaddr ofs) (Evar id))) + Sseq (make_store chunk (make_stackaddr ofs) (Evar id)) (store_parameters cenv rem) | _ => Sskip (* should never happen *) @@ -412,6 +425,9 @@ Definition transl_function (Sseq (store_parameters cenv f.(Csharpminor.fn_params)) tbody)) else None. +Definition transl_fundef (gce: compilenv) (f: Csharpminor.fundef): option fundef := + transf_partial_fundef (transl_function gce) f. + Definition transl_program (p: Csharpminor.program) : option program := let gce := build_global_compilenv p in - transform_partial_program (transl_function gce) (program_of_program p). + transform_partial_program (transl_fundef gce) (program_of_program p). diff --git a/backend/Cminorgenproof.v b/backend/Cminorgenproof.v index 7b3bc9b..7820095 100644 --- a/backend/Cminorgenproof.v +++ b/backend/Cminorgenproof.v @@ -8,6 +8,7 @@ Require Import Integers. Require Import Floats. Require Import Values. Require Import Mem. +Require Import Events. Require Import Globalenvs. Require Import Csharpminor. Require Import Op. @@ -29,38 +30,51 @@ Lemma symbols_preserved: forall (s: ident), Genv.find_symbol tge s = Genv.find_symbol ge s. Proof. intro. unfold ge, tge. - apply Genv.find_symbol_transf_partial with (transl_function gce). + apply Genv.find_symbol_transf_partial with (transl_fundef gce). exact TRANSL. Qed. Lemma function_ptr_translated: - forall (b: block) (f: Csharpminor.function), + forall (b: block) (f: Csharpminor.fundef), Genv.find_funct_ptr ge b = Some f -> exists tf, - Genv.find_funct_ptr tge b = Some tf /\ transl_function gce f = Some tf. + Genv.find_funct_ptr tge b = Some tf /\ transl_fundef gce f = Some tf. Proof. intros. generalize - (Genv.find_funct_ptr_transf_partial (transl_function gce) TRANSL H). - case (transl_function gce f). + (Genv.find_funct_ptr_transf_partial (transl_fundef gce) TRANSL H). + case (transl_fundef gce f). intros tf [A B]. exists tf. tauto. intros [A B]. elim B. reflexivity. Qed. Lemma functions_translated: - forall (v: val) (f: Csharpminor.function), + forall (v: val) (f: Csharpminor.fundef), Genv.find_funct ge v = Some f -> exists tf, - Genv.find_funct tge v = Some tf /\ transl_function gce f = Some tf. + Genv.find_funct tge v = Some tf /\ transl_fundef gce f = Some tf. Proof. intros. generalize - (Genv.find_funct_transf_partial (transl_function gce) TRANSL H). - case (transl_function gce f). + (Genv.find_funct_transf_partial (transl_fundef gce) TRANSL H). + case (transl_fundef gce f). intros tf [A B]. exists tf. tauto. intros [A B]. elim B. reflexivity. Qed. +Lemma sig_preserved: + forall f tf, + transl_fundef gce f = Some tf -> + Cminor.funsig tf = Csharpminor.funsig f. +Proof. + intros until tf; destruct f; simpl. + unfold transl_function. destruct (build_compilenv gce f). + case (zle z Int.max_signed); try congruence. + intro. case (transl_stmt c (Csharpminor.fn_body f)); simpl; try congruence. + intros. inversion H. reflexivity. + intro. inversion H; reflexivity. +Qed. + Definition global_compilenv_match (ce: compilenv) (gv: gvarenv) : Prop := forall id, match ce!!id with @@ -72,9 +86,9 @@ Definition global_compilenv_match (ce: compilenv) (gv: gvarenv) : Prop := Lemma global_compilenv_charact: global_compilenv_match gce (global_var_env prog). Proof. - set (mkgve := fun gv vars => + set (mkgve := fun gv (vars: list (ident * var_kind * list init_data)) => List.fold_left - (fun gv (id_vi: ident * var_kind) => PTree.set (fst id_vi) (snd id_vi) gv) + (fun gve x => match x with (id, k, init) => PTree.set id k gve end) vars gv). assert (forall vars gv ce, global_compilenv_match ce gv -> @@ -83,7 +97,7 @@ Proof. induction vars; simpl; intros. auto. apply IHvars. intro id1. unfold assign_global_variable. - destruct a as [id2 lv2]. destruct lv2; simpl; rewrite PMap.gsspec; rewrite PTree.gsspec. + destruct a as [[id2 lv2] init2]. destruct lv2; simpl; rewrite PMap.gsspec; rewrite PTree.gsspec. case (peq id1 id2); intro. auto. apply H. case (peq id1 id2); intro. auto. apply H. @@ -283,6 +297,7 @@ Qed. must be normalized with respect to the memory chunk of the variable, in the following sense. *) +(* Definition val_normalized (chunk: memory_chunk) (v: val) : Prop := exists v0, v = Val.load_result chunk v0. @@ -305,34 +320,31 @@ Lemma load_result_normalized: Proof. intros chunk v [v0 EQ]. rewrite EQ. apply load_result_idem. Qed. - +*) Lemma match_env_store_local: forall f cenv e m1 m2 te sp lo hi id b chunk v tv, e!id = Some(b, Vscalar chunk) -> - val_inject f v tv -> - val_normalized chunk tv -> + val_inject f (Val.load_result chunk v) tv -> store chunk m1 b 0 v = Some m2 -> match_env f cenv e m1 te sp lo hi -> match_env f cenv e m2 (PTree.set id tv te) sp lo hi. Proof. - intros. inversion H3. constructor; auto. + intros. inversion H2. constructor; auto. intros. generalize (me_vars0 id0); intro. - inversion H4; subst. + inversion H3; subst. (* var_local *) case (peq id id0); intro. (* the stored variable *) subst id0. - change Csharpminor.var_kind with var_kind in H5. - rewrite H in H6. injection H6; clear H6; intros; subst b0 chunk0. + change Csharpminor.var_kind with var_kind in H4. + rewrite H in H5. injection H5; clear H5; intros; subst b0 chunk0. econstructor. eauto. eapply load_store_same; eauto. auto. rewrite PTree.gss. reflexivity. - replace tv with (Val.load_result chunk tv). - apply Mem.load_result_inject. constructor; auto. - apply load_result_normalized; auto. + auto. (* a different variable *) econstructor; eauto. - rewrite <- H7. eapply load_store_other; eauto. + rewrite <- H6. eapply load_store_other; eauto. rewrite PTree.gso; auto. (* var_stack_scalar *) econstructor; eauto. @@ -375,16 +387,15 @@ Qed. Lemma match_callstack_store_local: forall f cenv e te sp lo hi cs bound tbound m1 m2 id b chunk v tv, e!id = Some(b, Vscalar chunk) -> - val_inject f v tv -> - val_normalized chunk tv -> + val_inject f (Val.load_result chunk v) tv -> store chunk m1 b 0 v = Some m2 -> match_callstack f (mkframe cenv e te sp lo hi :: cs) bound tbound m1 -> match_callstack f (mkframe cenv e (PTree.set id tv te) sp lo hi :: cs) bound tbound m2. Proof. - intros. inversion H3. constructor; auto. + intros. inversion H2. constructor; auto. eapply match_env_store_local; eauto. eapply match_callstack_store_above; eauto. - inversion H17. + inversion H16. generalize (me_bounded0 _ _ _ H). omega. Qed. @@ -409,20 +420,19 @@ Qed. Lemma match_callstack_store_local_unchanged: forall f cenv e te sp lo hi cs bound tbound m1 m2 id b chunk v tv, e!id = Some(b, Vscalar chunk) -> - val_inject f v tv -> - val_normalized chunk tv -> + val_inject f (Val.load_result chunk v) tv -> store chunk m1 b 0 v = Some m2 -> te!id = Some tv -> match_callstack f (mkframe cenv e te sp lo hi :: cs) bound tbound m1 -> match_callstack f (mkframe cenv e te sp lo hi :: cs) bound tbound m2. Proof. - intros. inversion H4. constructor; auto. + intros. inversion H3. constructor; auto. apply match_env_extensional with (PTree.set id tv te). eapply match_env_store_local; eauto. intros. rewrite PTree.gsspec. case (peq id0 id); intros. congruence. auto. eapply match_callstack_store_above; eauto. - inversion H18. + inversion H17. generalize (me_bounded0 _ _ _ H). omega. Qed. @@ -698,6 +708,90 @@ Proof. injection H; intros. rewrite <- H2; simpl. omega. Qed. +Lemma match_env_alloc: + forall m1 l h m2 b tm1 tm2 tb f1 ce e te sp lo hi, + alloc m1 l h = (m2, b) -> + alloc tm1 l h = (tm2, tb) -> + match_env f1 ce e m1 te sp lo hi -> + hi <= m1.(nextblock) -> + sp < tm1.(nextblock) -> + let f2 := extend_inject b (Some(tb, 0)) f1 in + inject_incr f1 f2 -> + match_env f2 ce e m2 te sp lo hi. +Proof. + intros. + assert (BEQ: b = m1.(nextblock)). injection H; auto. + assert (TBEQ: tb = tm1.(nextblock)). injection H0; auto. + inversion H1. constructor; auto. + (* me_vars *) + intros. generalize (me_vars0 id); intro. inversion H5. + (* var_local *) + econstructor; eauto. + generalize (me_bounded0 _ _ _ H7). intro. + unfold f2, extend_inject. case (eq_block b0 b); intro. + subst b0. rewrite BEQ in H12. omegaContradiction. + auto. + (* var_stack_scalar *) + econstructor; eauto. + (* var_stack_array *) + econstructor; eauto. + (* var_global_scalar *) + econstructor; eauto. + (* var_global_array *) + econstructor; eauto. + (* me_bounded *) + intros until delta. unfold f2, extend_inject. case (eq_block b0 b); intro. + intro. injection H5; clear H5; intros. + rewrite H6 in TBEQ. rewrite TBEQ in H3. omegaContradiction. + eauto. + (* me_inj *) + intros until delta. unfold f2, extend_inject. case (eq_block b0 b); intros. + injection H5; clear H5; intros; subst b0 tb0 delta. + rewrite BEQ in H6. omegaContradiction. + eauto. +Qed. + +Lemma match_callstack_alloc_rec: + forall f1 cs bound tbound m1, + match_callstack f1 cs bound tbound m1 -> + forall l h m2 b tm1 tm2 tb, + alloc m1 l h = (m2, b) -> + alloc tm1 l h = (tm2, tb) -> + bound <= m1.(nextblock) -> + tbound <= tm1.(nextblock) -> + let f2 := extend_inject b (Some(tb, 0)) f1 in + inject_incr f1 f2 -> + match_callstack f2 cs bound tbound m2. +Proof. + induction 1; intros. + constructor. + inversion H. constructor. + intros. elim (mg_symbols0 _ _ H5); intros. + split; auto. elim (H4 b0); intros; congruence. + intros. generalize (mg_functions0 _ H5). elim (H4 b0); congruence. + constructor. auto. auto. + unfold f2. eapply match_env_alloc; eauto. omega. omega. + unfold f2; eapply IHmatch_callstack; eauto. + inversion H1; omega. + omega. +Qed. + +Lemma match_callstack_alloc: + forall f1 cs m1 tm1 l h m2 b tm2 tb, + match_callstack f1 cs m1.(nextblock) tm1.(nextblock) m1 -> + alloc m1 l h = (m2, b) -> + alloc tm1 l h = (tm2, tb) -> + let f2 := extend_inject b (Some(tb, 0)) f1 in + inject_incr f1 f2 -> + match_callstack f2 cs m2.(nextblock) tm2.(nextblock) m2. +Proof. + intros. unfold f2 in *. + apply match_callstack_incr_bound with m1.(nextblock) tm1.(nextblock). + eapply match_callstack_alloc_rec; eauto. omega. omega. + injection H0; intros; subst m2; simpl; omega. + injection H1; intros; subst tm2; simpl; omega. +Qed. + (** [match_callstack] implies [match_globalenvs]. *) Lemma match_callstack_match_globalenvs: @@ -757,14 +851,14 @@ Qed. provided arguments match pairwise ([val_list_inject f] hypothesis). *) Lemma make_op_correct: - forall al a op vl m2 v sp le te1 tm1 te2 tm2 tvl f, + forall al a op vl m2 v sp le te1 tm1 t te2 tm2 tvl f, make_op op al = Some a -> Csharpminor.eval_operation op vl m2 = Some v -> - eval_exprlist tge (Vptr sp Int.zero) le te1 tm1 al te2 tm2 tvl -> + eval_exprlist tge (Vptr sp Int.zero) le te1 tm1 al t te2 tm2 tvl -> val_list_inject f vl tvl -> mem_inject f m2 tm2 -> exists tv, - eval_expr tge (Vptr sp Int.zero) le te1 tm1 a te2 tm2 tv + eval_expr tge (Vptr sp Int.zero) le te1 tm1 a t te2 tm2 tv /\ val_inject f v tv. Proof. intros. @@ -782,23 +876,27 @@ Proof. (* floatconst *) TrivialOp. econstructor. constructor. reflexivity. (* Unary operators *) - inversion H1. subst sp0 le0 e m a0 bl e2 m0 tvl. - inversion H14. subst sp0 le0 e m e1 m1 vl0. - inversion H2. subst vl v' vl'. inversion H8. subst vl0. + inversion H1; clear H1; subst. + inversion H11; clear H11; subst. + rewrite E0_right. + inversion H2; clear H2; subst. inversion H8; clear H8; subst. destruct op; simplify_eq H; intro; subst a; simpl in H0; destruct v1; simplify_eq H0; intro; subst v; inversion H7; subst v0; TrivialOp. + change (Vint (Int.cast8unsigned i)) with (Val.cast8unsigned (Vint i)). eauto with evalexpr. + change (Vint (Int.cast8signed i)) with (Val.cast8signed (Vint i)). eauto with evalexpr. + change (Vint (Int.cast16unsigned i)) with (Val.cast16unsigned (Vint i)). eauto with evalexpr. + change (Vint (Int.cast16signed i)) with (Val.cast16signed (Vint i)). eauto with evalexpr. + change (Vfloat (Float.singleoffloat f0)) with (Val.singleoffloat (Vfloat f0)). eauto with evalexpr. (* Binary operations *) - inversion H1. subst sp0 le0 e m a0 bl e2 m0 tvl. - inversion H14. subst sp0 le0 e m a0 bl e2 m3 vl0. - inversion H16. subst sp0 le0 e m e0 m0 vl1. - inversion H2. subst vl v' vl'. - inversion H8. subst vl0 v' vl'. - inversion H12. subst vl. + inversion H1; clear H1; subst. inversion H11; clear H11; subst. + inversion H12; clear H12; subst. rewrite E0_right. + inversion H2; clear H2; subst. inversion H9; clear H9; subst. + inversion H10; clear H10; subst. destruct op; simplify_eq H; intro; subst a; simpl in H0; destruct v2; destruct v3; simplify_eq H0; intro; try subst v; - inversion H7; inversion H9; subst v0; subst v1; + inversion H7; inversion H8; subst v0; subst v1; TrivialOp. (* add int ptr *) exists (Vptr b2 (Int.add ofs2 i)); split. @@ -815,7 +913,8 @@ Proof. (* sub ptr ptr *) destruct (eq_block b b0); simplify_eq H0; intro; subst v; subst b0. assert (b4 = b2). congruence. subst b4. - exists (Vint (Int.sub ofs2 ofs3)); split. eauto with evalexpr. + exists (Vint (Int.sub ofs3 ofs2)); split. + eauto with evalexpr. subst ofs2 ofs3. replace x0 with x. rewrite Int.sub_shifted. constructor. congruence. (* divs *) @@ -842,11 +941,11 @@ Proof. (* cmp int ptr *) elim (eval_compare_null_inv _ _ _ H0); intros; subst i1 i. exists v; split. eauto with evalexpr. - elim H18; intros [A B]; subst v; unfold Vtrue, Vfalse; constructor. + elim H12; intros [A B]; subst v; unfold Vtrue, Vfalse; constructor. (* cmp ptr int *) elim (eval_compare_null_inv _ _ _ H0); intros; subst i1 i0. exists v; split. eauto with evalexpr. - elim H18; intros [A B]; subst v; unfold Vtrue, Vfalse; constructor. + elim H12; intros [A B]; subst v; unfold Vtrue, Vfalse; constructor. (* cmp ptr ptr *) caseEq (valid_pointer m2 b (Int.signed i) && valid_pointer m2 b0 (Int.signed i0)); intro EQ; rewrite EQ in H0; try discriminate. @@ -854,7 +953,7 @@ Proof. assert (b4 = b2); [congruence|subst b4]. assert (x0 = x); [congruence|subst x0]. elim (andb_prop _ _ EQ); intros. - exists (Val.of_bool (Int.cmp c ofs2 ofs3)); split. + exists (Val.of_bool (Int.cmp c ofs3 ofs2)); split. eauto with evalexpr. subst ofs2 ofs3. rewrite Int.translate_cmp. apply val_inject_val_of_bool. @@ -866,55 +965,51 @@ Qed. normalized according to the given memory chunk. *) Lemma make_cast_correct: - forall f sp le te1 tm1 a te2 tm2 v chunk v' tv, - eval_expr tge (Vptr sp Int.zero) le te1 tm1 a te2 tm2 tv -> - cast chunk v = Some v' -> + forall f sp le te1 tm1 a t te2 tm2 v chunk tv, + eval_expr tge (Vptr sp Int.zero) le te1 tm1 a t te2 tm2 tv -> val_inject f v tv -> exists tv', eval_expr tge (Vptr sp Int.zero) le te1 tm1 (make_cast chunk a) - te2 tm2 tv' - /\ val_inject f v' tv' - /\ val_normalized chunk tv'. + t te2 tm2 tv' + /\ val_inject f (Val.load_result chunk v) tv'. Proof. - intros. destruct chunk; destruct v; simplify_eq H0; intro; subst v'; simpl; - inversion H1; subst tv. + intros. destruct chunk. - exists (Vint (Int.cast8signed i)). + exists (Val.cast8signed tv). split. apply eval_cast8signed; auto. - split. constructor. exists (Vint i); reflexivity. + inversion H0; simpl; constructor. - exists (Vint (Int.cast8unsigned i)). + exists (Val.cast8unsigned tv). split. apply eval_cast8unsigned; auto. - split. constructor. exists (Vint i); reflexivity. + inversion H0; simpl; constructor. - exists (Vint (Int.cast16signed i)). + exists (Val.cast16signed tv). split. apply eval_cast16signed; auto. - split. constructor. exists (Vint i); reflexivity. + inversion H0; simpl; constructor. - exists (Vint (Int.cast16unsigned i)). + exists (Val.cast16unsigned tv). split. apply eval_cast16unsigned; auto. - split. constructor. exists (Vint i); reflexivity. - - exists (Vint i). - split. auto. split. auto. exists (Vint i); reflexivity. + inversion H0; simpl; constructor. - exists (Vptr b2 ofs2). - split. auto. split. auto. exists (Vptr b2 ofs2); reflexivity. + exists tv. + split. simpl; auto. + inversion H0; simpl; econstructor; eauto. - exists (Vfloat (Float.singleoffloat f0)). + exists (Val.singleoffloat tv). split. apply eval_singleoffloat; auto. - split. constructor. exists (Vfloat f0); reflexivity. + inversion H0; simpl; constructor. - exists (Vfloat f0). - split. auto. split. auto. exists (Vfloat f0); reflexivity. + exists tv. + split. simpl; auto. + inversion H0; simpl; constructor. Qed. Lemma make_stackaddr_correct: forall sp le te tm ofs, eval_expr tge (Vptr sp Int.zero) le te tm (make_stackaddr ofs) - te tm (Vptr sp (Int.repr ofs)). + E0 te tm (Vptr sp (Int.repr ofs)). Proof. intros; unfold make_stackaddr. eapply eval_Eop. econstructor. simpl. decEq. decEq. @@ -926,7 +1021,7 @@ Lemma make_globaladdr_correct: Genv.find_symbol tge id = Some b -> eval_expr tge (Vptr sp Int.zero) le te tm (make_globaladdr id) - te tm (Vptr b Int.zero). + E0 te tm (Vptr b Int.zero). Proof. intros; unfold make_globaladdr. eapply eval_Eop. econstructor. simpl. rewrite H. auto. @@ -935,67 +1030,75 @@ Qed. (** Correctness of [make_load] and [make_store]. *) Lemma make_load_correct: - forall sp le te1 tm1 a te2 tm2 va chunk v, - eval_expr tge (Vptr sp Int.zero) le te1 tm1 a te2 tm2 va -> + forall sp le te1 tm1 a t te2 tm2 va chunk v, + eval_expr tge (Vptr sp Int.zero) le te1 tm1 a t te2 tm2 va -> Mem.loadv chunk tm2 va = Some v -> eval_expr tge (Vptr sp Int.zero) le te1 tm1 (make_load chunk a) - te2 tm2 v. + t te2 tm2 v. Proof. intros; unfold make_load. eapply eval_load; eauto. Qed. -Lemma val_content_inject_cast: - forall f chunk v1 v2 tv1, - cast chunk v1 = Some v2 -> - val_inject f v1 tv1 -> - val_content_inject f (mem_chunk chunk) v2 tv1. +Lemma store_arg_content_inject: + forall f sp le te1 tm1 a t te2 tm2 v va chunk, + eval_expr tge (Vptr sp Int.zero) le te1 tm1 a t te2 tm2 va -> + val_inject f v va -> + exists vb, + eval_expr tge (Vptr sp Int.zero) le te1 tm1 (store_arg chunk a) t te2 tm2 vb + /\ val_content_inject f (mem_chunk chunk) v vb. Proof. - intros. destruct chunk; destruct v1; simplify_eq H; intro; subst v2; - inversion H0; simpl. - apply val_content_inject_8. apply Int.cast8_unsigned_signed. - apply val_content_inject_8. apply Int.cast8_unsigned_idem. - apply val_content_inject_16. apply Int.cast16_unsigned_signed. - apply val_content_inject_16. apply Int.cast16_unsigned_idem. - constructor; constructor. - constructor; econstructor; eauto. - apply val_content_inject_32. apply Float.singleoffloat_idem. - constructor; constructor. + intros. + assert (exists vb, + eval_expr tge (Vptr sp Int.zero) le te1 tm1 a t te2 tm2 vb + /\ val_content_inject f (mem_chunk chunk) v vb). + exists va; split. assumption. constructor. assumption. + inversion H; clear H; subst; simpl; trivial. + inversion H2; clear H2; subst; trivial. + inversion H4; clear H4; subst; trivial. + rewrite E0_right. rewrite E0_right in H1. + destruct op; trivial; destruct chunk; trivial; + exists v0; (split; [auto| + simpl in H3; inversion H3; clear H3; subst va; + destruct v0; simpl in H0; inversion H0; subst; try (constructor; constructor)]). + apply val_content_inject_8. apply Int.cast8_unsigned_signed. + apply val_content_inject_8. apply Int.cast8_unsigned_idem. + apply val_content_inject_16. apply Int.cast16_unsigned_signed. + apply val_content_inject_16. apply Int.cast16_unsigned_idem. + apply val_content_inject_32. apply Float.singleoffloat_idem. Qed. Lemma make_store_correct: - forall f sp le te1 tm1 addr te2 tm2 tvaddr rhs te3 tm3 tvrhs - chunk vrhs v m3 vaddr m4, - eval_expr tge (Vptr sp Int.zero) le - te1 tm1 addr te2 tm2 tvaddr -> - eval_expr tge (Vptr sp Int.zero) le - te2 tm2 rhs te3 tm3 tvrhs -> - cast chunk vrhs = Some v -> - Mem.storev chunk m3 vaddr v = Some m4 -> + forall f sp te1 tm1 addr te2 tm2 tvaddr rhs te3 tm3 tvrhs + chunk vrhs m3 vaddr m4 t1 t2, + eval_expr tge (Vptr sp Int.zero) nil + te1 tm1 addr t1 te2 tm2 tvaddr -> + eval_expr tge (Vptr sp Int.zero) nil + te2 tm2 rhs t2 te3 tm3 tvrhs -> + Mem.storev chunk m3 vaddr vrhs = Some m4 -> mem_inject f m3 tm3 -> val_inject f vaddr tvaddr -> val_inject f vrhs tvrhs -> - exists tm4, exists tv, - eval_expr tge (Vptr sp Int.zero) le + exists tm4, + exec_stmt tge (Vptr sp Int.zero) te1 tm1 (make_store chunk addr rhs) - te3 tm4 tv + (t1**t2) te3 tm4 Out_normal /\ mem_inject f m4 tm4 - /\ val_inject f v tv /\ nextblock tm4 = nextblock tm3. Proof. intros. unfold make_store. - assert (val_content_inject f (mem_chunk chunk) v tvrhs). - eapply val_content_inject_cast; eauto. - elim (storev_mapped_inject_1 _ _ _ _ _ _ _ _ _ H3 H2 H4 H6). - intros tm4 [STORE MEMINJ]. - generalize (eval_store _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ H H0 STORE). + exploit store_arg_content_inject. eexact H0. eauto. + intros [tv [EVAL VCINJ]]. + exploit storev_mapped_inject_1; eauto. + intros [tm4 [STORE MEMINJ]]. + exploit eval_store. eexact H. eexact EVAL. eauto. intro EVALSTORE. - elim (make_cast_correct _ _ _ _ _ _ _ _ _ _ _ _ EVALSTORE H1 H5). - intros tv [EVALCAST [VALINJ VALNORM]]. - exists tm4; exists tv. intuition. + exists tm4. + split. apply exec_Sexpr with tv. auto. + split. auto. unfold storev in STORE; destruct tvaddr; try discriminate. - generalize (store_inv _ _ _ _ _ _ STORE). simpl. tauto. + exploit store_inv; eauto. simpl. tauto. Qed. (** Correctness of the variable accessors [var_get], [var_set] @@ -1009,7 +1112,7 @@ Lemma var_get_correct: eval_var_ref prog e id b chunk -> load chunk m b 0 = Some v -> exists tv, - eval_expr tge (Vptr sp Int.zero) le te tm a te tm tv /\ + eval_expr tge (Vptr sp Int.zero) le te tm a E0 te tm tv /\ val_inject f v tv. Proof. unfold var_get; intros. @@ -1025,8 +1128,8 @@ Proof. inversion H2; [subst|congruence]. assert (b0 = b). congruence. subst b0. assert (chunk0 = chunk). congruence. subst chunk0. - assert (loadv chunk m (Vptr b Int.zero) = Some v). assumption. - generalize (loadv_inject _ _ _ _ _ _ _ H1 H9 H7). + exploit loadv_inject; eauto. + unfold loadv. eexact H3. intros [tv [LOAD INJ]]. exists tv; split. eapply make_load_correct; eauto. eapply make_stackaddr_correct; eauto. @@ -1052,7 +1155,7 @@ Lemma var_addr_correct: var_addr cenv id = Some a -> eval_var_addr prog e id b -> exists tv, - eval_expr tge (Vptr sp Int.zero) le te tm a te tm tv /\ + eval_expr tge (Vptr sp Int.zero) le te tm a E0 te tm tv /\ val_inject f (Vptr b Int.zero) tv. Proof. unfold var_addr; intros. @@ -1086,65 +1189,61 @@ Proof. Qed. Lemma var_set_correct: - forall cenv id rhs a f e te2 sp lo hi m2 cs tm2 le te1 tm1 vrhs b chunk v1 v2 m3, + forall cenv id rhs a f e te2 sp lo hi m2 cs tm2 te1 tm1 tv b chunk v m3 t, var_set cenv id rhs = Some a -> match_callstack f (mkframe cenv e te2 sp lo hi :: cs) m2.(nextblock) tm2.(nextblock) m2 -> - eval_expr tge (Vptr sp Int.zero) le te1 tm1 rhs te2 tm2 vrhs -> - val_inject f v1 vrhs -> + eval_expr tge (Vptr sp Int.zero) nil te1 tm1 rhs t te2 tm2 tv -> + val_inject f v tv -> mem_inject f m2 tm2 -> eval_var_ref prog e id b chunk -> - cast chunk v1 = Some v2 -> - store chunk m2 b 0 v2 = Some m3 -> - exists te3, exists tm3, exists tv, - eval_expr tge (Vptr sp Int.zero) le te1 tm1 a te3 tm3 tv /\ - val_inject f v2 tv /\ + store chunk m2 b 0 v = Some m3 -> + exists te3, exists tm3, + exec_stmt tge (Vptr sp Int.zero) te1 tm1 a t te3 tm3 Out_normal /\ mem_inject f m3 tm3 /\ match_callstack f (mkframe cenv e te3 sp lo hi :: cs) m3.(nextblock) tm3.(nextblock) m3. Proof. unfold var_set; intros. assert (NEXTBLOCK: nextblock m3 = nextblock m2). - generalize (store_inv _ _ _ _ _ _ H6). simpl. tauto. + exploit store_inv; eauto. simpl; tauto. inversion H0. subst f0 cenv0 e0 te sp0 lo0 hi0 cs0 bound tbound m. - assert (match_var f id e m2 te2 sp cenv!!id). inversion H20; auto. - inversion H7; subst; rewrite <- H8 in H; inversion H; subst; clear H. + assert (match_var f id e m2 te2 sp cenv!!id). inversion H19; auto. + inversion H6; subst; rewrite <- H7 in H; inversion H; subst; clear H. (* var_local *) inversion H4; [subst|congruence]. assert (b0 = b). congruence. subst b0. assert (chunk0 = chunk). congruence. subst chunk0. - elim (make_cast_correct _ _ _ _ _ _ _ _ _ _ _ _ H1 H5 H2). - intros tv [EVAL [INJ NORM]]. - exists (PTree.set id tv te2); exists tm2; exists tv. - split. eapply eval_Eassign. auto. - split. auto. + exploit make_cast_correct; eauto. + intros [tv' [EVAL INJ]]. + exists (PTree.set id tv' te2); exists tm2. + split. eapply exec_Sexpr. eapply eval_Eassign. eauto. split. eapply store_unmapped_inject; eauto. rewrite NEXTBLOCK. eapply match_callstack_store_local; eauto. (* var_stack_scalar *) inversion H4; [subst|congruence]. assert (b0 = b). congruence. subst b0. assert (chunk0 = chunk). congruence. subst chunk0. - assert (storev chunk m2 (Vptr b Int.zero) v2 = Some m3). assumption. - generalize (make_stackaddr_correct sp le te1 tm1 ofs). intro EVALSTACKADDR. - generalize (make_store_correct _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ - EVALSTACKADDR H1 H5 H11 H3 H10 H2). - intros [tm3 [tv [EVAL [MEMINJ [VALINJ TNEXTBLOCK]]]]]. - exists te2; exists tm3; exists tv. - split. auto. split. auto. split. auto. + assert (storev chunk m2 (Vptr b Int.zero) v = Some m3). assumption. + exploit make_store_correct. + eapply make_stackaddr_correct. + eauto. eauto. eauto. eauto. eauto. + rewrite E0_left. intros [tm3 [EVAL [MEMINJ TNEXTBLOCK]]]. + exists te2; exists tm3. + split. auto. split. auto. rewrite NEXTBLOCK; rewrite TNEXTBLOCK. eapply match_callstack_mapped; eauto. - inversion H10; congruence. + inversion H9; congruence. (* var_global_scalar *) inversion H4; [congruence|subst]. assert (chunk0 = chunk). congruence. subst chunk0. - assert (storev chunk m2 (Vptr b Int.zero) v2 = Some m3). assumption. + assert (storev chunk m2 (Vptr b Int.zero) v = Some m3). assumption. assert (match_globalenvs f). eapply match_callstack_match_globalenvs; eauto. - inversion H14. destruct (mg_symbols0 _ _ H11) as [A B]. - assert (val_inject f (Vptr b Int.zero) (Vptr b Int.zero)). econstructor; eauto. - generalize (make_globaladdr_correct sp le te1 tm1 id b B). intro EVALGLOBALADDR. - generalize (make_store_correct _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ - EVALGLOBALADDR H1 H5 H13 H3 H15 H2). - intros [tm3 [tv [EVAL [MEMINJ [VALINJ TNEXTBLOCK]]]]]. - exists te2; exists tm3; exists tv. - split. auto. split. auto. split. auto. + inversion H13. destruct (mg_symbols0 _ _ H10) as [A B]. + exploit make_store_correct. + eapply make_globaladdr_correct; eauto. + eauto. eauto. eauto. eauto. eauto. + rewrite E0_left. intros [tm3 [EVAL [MEMINJ TNEXTBLOCK]]]. + exists te2; exists tm3. + split. auto. split. auto. rewrite NEXTBLOCK; rewrite TNEXTBLOCK. eapply match_callstack_mapped; eauto. congruence. Qed. @@ -1228,36 +1327,26 @@ Proof. omega. omega. omega. omega. unfold sizeof; rewrite LV. omega. intros. left. generalize (BOUND _ _ H5). omega. elim H3; intros MINJ1 INCR1; clear H3. - assert (MATCH1: match_callstack f1 - (mkframe cenv1 (PTree.set id (b1, lv) e) te sp lo (nextblock m1) :: cs) - (nextblock m1) (nextblock tm) m1). - unfold f1; rewrite <- H2; eapply match_callstack_alloc_left; eauto. - assert (SZ1POS: 0 <= sz1). rewrite <- H1. omega. - assert (BOUND1: forall b delta, f1 b = Some(sp, delta) -> - high_bound m1 b + delta <= sz1). + exploit IHalloc_variables; eauto. + unfold f1; rewrite <- H2; eapply match_callstack_alloc_left; eauto. + rewrite <- H1. omega. intros until delta; unfold f1, extend_inject, eq_block. rewrite (high_bound_alloc _ _ b _ _ _ H). case (zeq b b1); intros. inversion H3. unfold sizeof; rewrite LV. omega. generalize (BOUND _ _ H3). omega. - generalize (IHalloc_variables _ _ _ ASVS MATCH1 MINJ1 SZ1POS BOUND1 DEFINED1). intros [f' [INCR2 [MINJ2 MATCH2]]]. exists f'; intuition. eapply inject_incr_trans; eauto. (* 1.2 info = Var_local chunk *) intro EQ; injection EQ; intros; clear EQ. subst sz1. - generalize (alloc_unmapped_inject _ _ _ _ _ _ _ MINJ H). + exploit alloc_unmapped_inject; eauto. set (f1 := extend_inject b1 None f). intros [MINJ1 INCR1]. - assert (MATCH1: match_callstack f1 - (mkframe cenv1 (PTree.set id (b1, lv) e) te sp lo (nextblock m1) :: cs) - (nextblock m1) (nextblock tm) m1). - unfold f1; rewrite <- H2; eapply match_callstack_alloc_left; eauto. - assert (BOUND1: forall b delta, f1 b = Some(sp, delta) -> - high_bound m1 b + delta <= sz). + exploit IHalloc_variables; eauto. + unfold f1; rewrite <- H2; eapply match_callstack_alloc_left; eauto. intros until delta; unfold f1, extend_inject, eq_block. rewrite (high_bound_alloc _ _ b _ _ _ H). case (zeq b b1); intros. discriminate. eapply BOUND; eauto. - generalize (IHalloc_variables _ _ _ ASVS MATCH1 MINJ1 SZPOS BOUND1 DEFINED1). intros [f' [INCR2 [MINJ2 MATCH2]]]. exists f'; intuition. eapply inject_incr_trans; eauto. (* 2. lv = LVarray dim, info = Var_stack_array *) @@ -1273,20 +1362,15 @@ Proof. unfold f1; eapply alloc_mapped_inject; eauto. omega. omega. omega. omega. unfold sizeof; rewrite LV. omega. intros. left. generalize (BOUND _ _ H8). omega. - elim H6; intros MINJ1 INCR1; clear H6. - assert (MATCH1: match_callstack f1 - (mkframe cenv1 (PTree.set id (b1, lv) e) te sp lo (nextblock m1) :: cs) - (nextblock m1) (nextblock tm) m1). + destruct H6 as [MINJ1 INCR1]. + exploit IHalloc_variables; eauto. unfold f1; rewrite <- H2; eapply match_callstack_alloc_left; eauto. - assert (SZ1POS: 0 <= sz1). rewrite <- H1. omega. - assert (BOUND1: forall b delta, f1 b = Some(sp, delta) -> - high_bound m1 b + delta <= sz1). - intros until delta; unfold f1, extend_inject, eq_block. - rewrite (high_bound_alloc _ _ b _ _ _ H). - case (zeq b b1); intros. - inversion H6. unfold sizeof; rewrite LV. omega. - generalize (BOUND _ _ H6). omega. - generalize (IHalloc_variables _ _ _ ASVS MATCH1 MINJ1 SZ1POS BOUND1 DEFINED1). + rewrite <- H1. omega. + intros until delta; unfold f1, extend_inject, eq_block. + rewrite (high_bound_alloc _ _ b _ _ _ H). + case (zeq b b1); intros. + inversion H6. unfold sizeof; rewrite LV. omega. + generalize (BOUND _ _ H6). omega. intros [f' [INCR2 [MINJ2 MATCH2]]]. exists f'; intuition. eapply inject_incr_trans; eauto. Qed. @@ -1370,15 +1454,15 @@ Proof. (* me_inj *) intros until lv2. unfold Csharpminor.empty_env; rewrite PTree.gempty; congruence. (* me_inv *) - intros. elim (mi_mappedblocks _ _ _ H4 _ _ _ H5); intros. - elim (fresh_block_alloc _ _ _ _ _ H2 H6). + intros. exploit mi_mappedblocks; eauto. intros [A B]. + elim (fresh_block_alloc _ _ _ _ _ H2 A). (* me_incr *) - intros. elim (mi_mappedblocks _ _ _ H4 _ _ _ H5); intros. + intros. exploit mi_mappedblocks; eauto. intros [A B]. rewrite SP; auto. rewrite SP; auto. eapply alloc_right_inject; eauto. omega. - intros. elim (mi_mappedblocks _ _ _ H4 _ _ _ H5); intros. + intros. exploit mi_mappedblocks; eauto. intros [A B]. unfold block in SP; omegaContradiction. (* defined *) intros. unfold te. apply set_locals_params_defined. @@ -1421,7 +1505,7 @@ Proof. unfold block; rewrite H2; omega. elim H4; intro. left; congruence. right; auto. elim H3; intro. subst b b1. - generalize (alloc_variables_nextblock_incr _ _ _ _ _ _ H0). + generalize (alloc_variables_nextblock_incr _ _ _ _ _ _ H0). rewrite H2. omega. generalize (B H4). rewrite H2. omega. Qed. @@ -1465,7 +1549,7 @@ Lemma store_parameters_correct: exists te2, exists tm2, exec_stmt tge (Vptr sp Int.zero) te1 tm1 (store_parameters cenv params) - te2 tm2 Out_normal + E0 te2 tm2 Out_normal /\ mem_inject f m2 tm2 /\ match_callstack f (mkframe cenv e te2 sp lo hi :: cs) m2.(nextblock) tm2.(nextblock) m2. Proof. @@ -1476,59 +1560,54 @@ Proof. intros until tm1. intros VVM NOREPET MINJ MATCH. simpl. inversion VVM. subst f0 id0 chunk0 vars v vals te. inversion MATCH. subst f0 cenv0 e0 te sp0 lo0 hi0 cs0 bound tbound m0. - inversion H19. + inversion H18. inversion NOREPET. subst hd tl. assert (NEXT: nextblock m1 = nextblock m). - generalize (store_inv _ _ _ _ _ _ H1). simpl; tauto. - generalize (me_vars0 id). intro. inversion H3; subst. + exploit store_inv; eauto. simpl; tauto. + generalize (me_vars0 id). intro. inversion H2; subst. (* cenv!!id = Var_local chunk *) assert (b0 = b). congruence. subst b0. assert (chunk0 = chunk). congruence. subst chunk0. assert (v' = tv). congruence. subst v'. - assert (eval_expr tge (Vptr sp Int.zero) nil te1 tm1 (Evar id) te1 tm1 tv). - constructor. auto. - generalize (make_cast_correct _ _ _ _ _ _ _ _ _ _ _ _ - H15 H0 H11). - intros [tv' [EVAL1 [VINJ1 VNORM]]]. + exploit make_cast_correct. + apply eval_Evar with (id := id). eauto. + eexact H10. + intros [tv' [EVAL1 VINJ1]]. set (te2 := PTree.set id tv' te1). assert (VVM2: vars_vals_match f params vl te2). apply vars_vals_match_extensional with te1; auto. intros. unfold te2; apply PTree.gso. red; intro; subst id0. - elim H5. change id with (fst (id, lv)). apply List.in_map; auto. - generalize (store_unmapped_inject _ _ _ _ _ _ _ _ MINJ H1 H9); intro MINJ2. - generalize (match_callstack_store_local _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ - H VINJ1 VNORM H1 MATCH); + elim H4. change id with (fst (id, lv)). apply List.in_map; auto. + exploit store_unmapped_inject; eauto. intro MINJ2. + exploit match_callstack_store_local; eauto. fold te2; rewrite <- NEXT; intro MATCH2. - destruct (IHbind_parameters _ _ _ _ _ _ _ _ VVM2 H6 MINJ2 MATCH2) - as [te3 [tm3 [EXEC3 [MINJ3 MATCH3]]]]. + exploit IHbind_parameters; eauto. + intros [te3 [tm3 [EXEC3 [MINJ3 MATCH3]]]]. exists te3; exists tm3. (* execution *) - split. apply exec_Sseq_continue with te2 tm1. - econstructor. unfold te2. constructor. assumption. - assumption. + split. apply exec_Sseq_continue with E0 te2 tm1 E0. + econstructor. unfold te2. constructor. eassumption. + assumption. traceEq. (* meminj & match_callstack *) tauto. (* cenv!!id = Var_stack_scalar *) assert (b0 = b). congruence. subst b0. assert (chunk0 = chunk). congruence. subst chunk0. - pose (EVAL1 := make_stackaddr_correct sp nil te1 tm1 ofs). - assert (EVAL2: eval_expr tge (Vptr sp Int.zero) nil te1 tm1 (Evar id) te1 tm1 tv). - constructor. auto. - destruct (make_store_correct _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ - (Vptr b Int.zero) _ - EVAL1 EVAL2 H0 H1 MINJ H8 H11) - as [tm2 [tv' [EVAL3 [MINJ2 [VINJ NEXT1]]]]]. - assert (f b <> None). inversion H8. congruence. - generalize (match_callstack_mapped _ _ _ _ _ MATCH _ _ _ _ _ H9 H1). + exploit make_store_correct. + eapply make_stackaddr_correct. + apply eval_Evar with (id := id). + eauto. 2:eauto. 2:eauto. unfold storev; eexact H0. eauto. + intros [tm2 [EVAL3 [MINJ2 NEXT1]]]. + exploit match_callstack_mapped. + eexact MATCH. 2:eauto. inversion H7. congruence. rewrite <- NEXT; rewrite <- NEXT1; intro MATCH2. - destruct (IHbind_parameters _ _ _ _ _ _ _ _ - H12 H6 MINJ2 MATCH2) as [te3 [tm3 [EVAL4 [MINJ3 MATCH3]]]]. + exploit IHbind_parameters; eauto. + intros [te3 [tm3 [EVAL4 [MINJ3 MATCH3]]]]. exists te3; exists tm3. (* execution *) - split. apply exec_Sseq_continue with te1 tm2. - econstructor. eauto. - assumption. + split. apply exec_Sseq_continue with (E0**E0) te1 tm2 E0. + auto. assumption. traceEq. (* meminj & match_callstack *) tauto. @@ -1589,44 +1668,6 @@ Proof. induction 1; simpl; eauto. Qed. -(**** -Lemma build_compilenv_domain: - forall f id chunk, - In (id, chunk) f.(Csharpminor.fn_params) -> - (fst (build_compilenv gce f))!id <> None. -Proof. - assert (forall atk id lv cenv_sz id0, - let cenv_sz' := assign_variable atk (id, lv) cenv_sz in - (fst cenv_sz')!id <> None - /\ ((fst cenv_sz)!id0 <> None -> (fst cenv_sz')!id0 <> None)). - intros. unfold cenv_sz'. destruct cenv_sz as [cenv sz]. - unfold assign_variable. destruct lv. - case (Identset.mem id atk); simpl. split. rewrite PTree.gss. congruence. - rewrite PTree.gsspec. case (peq id0 id); intros. congruence. auto. - split. rewrite PTree.gss. congruence. - rewrite PTree.gsspec. case (peq id0 id); intros. congruence. auto. - simpl. split. rewrite PTree.gss. congruence. - rewrite PTree.gsspec. case (peq id0 id); intros. congruence. auto. - - assert (forall atk id_lv_list cenv_sz id lv, - In (id, lv) id_lv_list \/ (fst cenv_sz)!id <> None -> - (fst (assign_variables atk id_lv_list cenv_sz))!id <> None). - induction id_lv_list; simpl; intros. - tauto. - apply IHid_lv_list with lv. - destruct a as [id0 lv0]. - generalize (H atk id0 lv0 cenv_sz id). - simpl. intro. intuition. injection H0; intros; subst id0 lv0. intuition. - - intros. unfold build_compilenv. apply H0 with (Vscalar chunk). - left. unfold fn_variables. apply List.in_or_app. left. - set (g := fun (id_chunk : ident * memory_chunk) => (fst id_chunk, Vscalar (snd id_chunk))). - change positive with ident. - change (id, Vscalar chunk) with (g (id, chunk)). - apply List.in_map. auto. -Qed. -****) - (** The final result in this section: the behaviour of function entry in the generated Cminor code (allocate stack data block and store parameters whose address is taken) simulates what happens at function @@ -1649,7 +1690,7 @@ Lemma function_entry_ok: exists f2, exists te2, exists tm2, exec_stmt tge (Vptr sp Int.zero) te tm1 (store_parameters cenv fn.(Csharpminor.fn_params)) - te2 tm2 Out_normal + E0 te2 tm2 Out_normal /\ mem_inject f2 m2 tm2 /\ inject_incr f f2 /\ match_callstack f2 @@ -1658,24 +1699,21 @@ Lemma function_entry_ok: /\ (forall b, m.(nextblock) <= b < m1.(nextblock) <-> In b lb). Proof. intros. - generalize (bind_parameters_length _ _ _ _ _ H0); intro LEN1. - destruct (match_callstack_alloc_variables _ _ _ _ _ _ _ _ _ _ _ _ tvargs - H2 H3 H H4 H1 H6) - as [f1 [INCR1 [MINJ1 MATCH1]]]. - fold te in MATCH1. - assert (VLI: val_list_inject f1 vargs tvargs). - eapply val_list_inject_incr; eauto. - generalize (vars_vals_match_holds _ _ _ _ LEN1 VLI _ - (list_norepet_append_commut _ _ H7)). - fold te. intro VVM. - assert (NOREPET: list_norepet (List.map (@fst ident memory_chunk) fn.(Csharpminor.fn_params))). - unfold fn_params_names in H7. - eapply list_norepet_append_left; eauto. - destruct (store_parameters_correct _ _ _ _ _ H0 _ _ _ _ _ _ _ _ - VVM NOREPET MINJ1 MATCH1) - as [te2 [tm2 [EXEC [MINJ2 MATCH2]]]]. + exploit bind_parameters_length; eauto. intro LEN1. + exploit match_callstack_alloc_variables; eauto. + intros [f1 [INCR1 [MINJ1 MATCH1]]]. + exploit vars_vals_match_holds. + eauto. apply val_list_inject_incr with f. eauto. eauto. + apply list_norepet_append_commut. + unfold fn_vars_names in H7. eexact H7. + intro VVM. + exploit store_parameters_correct. + eauto. eauto. + unfold fn_params_names in H7. eapply list_norepet_append_left; eauto. + eexact MINJ1. eauto. + intros [te2 [tm2 [EXEC [MINJ2 MATCH2]]]]. exists f1; exists te2; exists tm2. - split. auto. split. auto. split. auto. split. auto. + split; auto. split; auto. split; auto. split; auto. intros; eapply alloc_variables_list_block; eauto. Qed. @@ -1745,7 +1783,7 @@ Ltac monadInv H := hypotheses in the proof of simulation. *) Definition eval_expr_prop - (le: Csharpminor.letenv) (e: Csharpminor.env) (m1: mem) (a: Csharpminor.expr) (m2: mem) (v: val) : Prop := + (le: Csharpminor.letenv) (e: Csharpminor.env) (m1: mem) (a: Csharpminor.expr) (t: trace) (m2: mem) (v: val) : Prop := forall cenv ta f1 tle te1 tm1 sp lo hi cs (TR: transl_expr cenv a = Some ta) (LINJ: val_list_inject f1 le tle) @@ -1754,7 +1792,7 @@ Definition eval_expr_prop (mkframe cenv e te1 sp lo hi :: cs) m1.(nextblock) tm1.(nextblock) m1), exists f2, exists te2, exists tm2, exists tv, - eval_expr tge (Vptr sp Int.zero) tle te1 tm1 ta te2 tm2 tv + eval_expr tge (Vptr sp Int.zero) tle te1 tm1 ta t te2 tm2 tv /\ val_inject f2 v tv /\ mem_inject f2 m2 tm2 /\ inject_incr f1 f2 @@ -1763,7 +1801,7 @@ Definition eval_expr_prop m2.(nextblock) tm2.(nextblock) m2. Definition eval_exprlist_prop - (le: Csharpminor.letenv) (e: Csharpminor.env) (m1: mem) (al: Csharpminor.exprlist) (m2: mem) (vl: list val) : Prop := + (le: Csharpminor.letenv) (e: Csharpminor.env) (m1: mem) (al: Csharpminor.exprlist) (t: trace) (m2: mem) (vl: list val) : Prop := forall cenv tal f1 tle te1 tm1 sp lo hi cs (TR: transl_exprlist cenv al = Some tal) (LINJ: val_list_inject f1 le tle) @@ -1772,7 +1810,7 @@ Definition eval_exprlist_prop (mkframe cenv e te1 sp lo hi :: cs) m1.(nextblock) tm1.(nextblock) m1), exists f2, exists te2, exists tm2, exists tvl, - eval_exprlist tge (Vptr sp Int.zero) tle te1 tm1 tal te2 tm2 tvl + eval_exprlist tge (Vptr sp Int.zero) tle te1 tm1 tal t te2 tm2 tvl /\ val_list_inject f2 vl tvl /\ mem_inject f2 m2 tm2 /\ inject_incr f1 f2 @@ -1781,14 +1819,14 @@ Definition eval_exprlist_prop m2.(nextblock) tm2.(nextblock) m2. Definition eval_funcall_prop - (m1: mem) (fn: Csharpminor.function) (args: list val) (m2: mem) (res: val) : Prop := + (m1: mem) (fn: Csharpminor.fundef) (args: list val) (t: trace) (m2: mem) (res: val) : Prop := forall tfn f1 tm1 cs targs - (TR: transl_function gce fn = Some tfn) + (TR: transl_fundef gce fn = Some tfn) (MINJ: mem_inject f1 m1 tm1) (MATCH: match_callstack f1 cs m1.(nextblock) tm1.(nextblock) m1) (ARGSINJ: val_list_inject f1 args targs), exists f2, exists tm2, exists tres, - eval_funcall tge tm1 tfn targs tm2 tres + eval_funcall tge tm1 tfn targs t tm2 tres /\ val_inject f2 res tres /\ mem_inject f2 m2 tm2 /\ inject_incr f1 f2 @@ -1807,7 +1845,7 @@ Inductive outcome_inject (f: meminj) : Csharpminor.outcome -> outcome -> Prop := outcome_inject f (Csharpminor.Out_return (Some v1)) (Out_return (Some v2)). Definition exec_stmt_prop - (e: Csharpminor.env) (m1: mem) (s: Csharpminor.stmt) (m2: mem) (out: Csharpminor.outcome): Prop := + (e: Csharpminor.env) (m1: mem) (s: Csharpminor.stmt) (t: trace) (m2: mem) (out: Csharpminor.outcome): Prop := forall cenv ts f1 te1 tm1 sp lo hi cs (TR: transl_stmt cenv s = Some ts) (MINJ: mem_inject f1 m1 tm1) @@ -1815,7 +1853,7 @@ Definition exec_stmt_prop (mkframe cenv e te1 sp lo hi :: cs) m1.(nextblock) tm1.(nextblock) m1), exists f2, exists te2, exists tm2, exists tout, - exec_stmt tge (Vptr sp Int.zero) te1 tm1 ts te2 tm2 tout + exec_stmt tge (Vptr sp Int.zero) te1 tm1 ts t te2 tm2 tout /\ outcome_inject f2 out tout /\ mem_inject f2 m2 tm2 /\ inject_incr f1 f2 @@ -1823,14 +1861,6 @@ Definition exec_stmt_prop (mkframe cenv e te2 sp lo hi :: cs) m2.(nextblock) tm2.(nextblock) m2. -(* -Check (eval_funcall_ind4 prog - eval_expr_prop - eval_exprlist_prop - eval_funcall_prop - exec_stmt_prop). -*) - (** There are as many cases in the inductive proof as there are evaluation rules in the Csharpminor semantics. We treat each case as a separate lemma. *) @@ -1841,33 +1871,12 @@ Lemma transl_expr_Evar_correct: (b : block) (chunk : memory_chunk) (v : val), eval_var_ref prog e id b chunk -> load chunk m b 0 = Some v -> - eval_expr_prop le e m (Csharpminor.Evar id) m v. + eval_expr_prop le e m (Csharpminor.Evar id) E0 m v. Proof. intros; red; intros. unfold transl_expr in TR. - generalize (var_get_correct _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ tle - TR MATCH MINJ H H0). + exploit var_get_correct; eauto. intros [tv [EVAL VINJ]]. - exists f1; exists te1; exists tm1; exists tv; intuition. -Qed. - -Lemma transl_expr_Eassign_correct: - forall (le : Csharpminor.letenv) (e : Csharpminor.env) (m : mem) - (id : positive) (a : Csharpminor.expr) (m1 : mem) (b : block) - (chunk : memory_chunk) (v1 v2 : val) (m2 : mem), - Csharpminor.eval_expr prog le e m a m1 v1 -> - eval_expr_prop le e m a m1 v1 -> - eval_var_ref prog e id b chunk -> - cast chunk v1 = Some v2 -> - store chunk m1 b 0 v2 = Some m2 -> - eval_expr_prop le e m (Csharpminor.Eassign id a) m2 v2. -Proof. - intros; red; intros. monadInv TR; intro EQ0. - generalize (H0 _ _ _ _ _ _ _ _ _ _ EQ LINJ MINJ MATCH). - intros [f2 [te2 [tm2 [tv1 [EVAL1 [VINJ1 [MINJ1 [INCR12 MATCH1]]]]]]]]. - generalize (var_set_correct _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ - EQ0 MATCH1 EVAL1 VINJ1 MINJ1 H1 H2 H3). - intros [te3 [tm3 [tv2 [EVAL2 [VINJ2 [MINJ2 MATCH2]]]]]]. - exists f2; exists te3; exists tm3; exists tv2. tauto. + exists f1; exists te1; exists tm1; exists tv; intuition eauto. Qed. Lemma transl_expr_Eaddrof_correct: @@ -1875,199 +1884,162 @@ Lemma transl_expr_Eaddrof_correct: (e : Csharpminor.env) (m : mem) (id : positive) (b : block), eval_var_addr prog e id b -> - eval_expr_prop le e m (Eaddrof id) m (Vptr b Int.zero). + eval_expr_prop le e m (Eaddrof id) E0 m (Vptr b Int.zero). Proof. intros; red; intros. simpl in TR. - generalize (var_addr_correct _ _ _ _ _ _ _ _ _ _ _ _ _ tle - MATCH TR H). + exploit var_addr_correct; eauto. intros [tv [EVAL VINJ]]. - exists f1; exists te1; exists tm1; exists tv. intuition. + exists f1; exists te1; exists tm1; exists tv. intuition eauto. Qed. Lemma transl_expr_Eop_correct: forall (le : Csharpminor.letenv) (e : Csharpminor.env) (m : mem) - (op : Csharpminor.operation) (al : Csharpminor.exprlist) (m1 : mem) - (vl : list val) (v : val), - Csharpminor.eval_exprlist prog le e m al m1 vl -> - eval_exprlist_prop le e m al m1 vl -> + (op : Csharpminor.operation) (al : Csharpminor.exprlist) + (t: trace) (m1 : mem) (vl : list val) (v : val), + Csharpminor.eval_exprlist prog le e m al t m1 vl -> + eval_exprlist_prop le e m al t m1 vl -> Csharpminor.eval_operation op vl m1 = Some v -> - eval_expr_prop le e m (Csharpminor.Eop op al) m1 v. + eval_expr_prop le e m (Csharpminor.Eop op al) t m1 v. Proof. intros; red; intros. monadInv TR; intro EQ0. - generalize (H0 _ _ _ _ _ _ _ _ _ _ EQ LINJ MINJ MATCH). + exploit H0; eauto. intros [f2 [te2 [tm2 [tvl [EVAL1 [VINJ1 [MINJ1 [INCR1 MATCH1]]]]]]]]. - generalize (make_op_correct _ _ _ _ _ _ _ _ _ _ _ _ _ _ - EQ0 H1 EVAL1 VINJ1 MINJ1). + exploit make_op_correct; eauto. intros [tv [EVAL2 VINJ2]]. exists f2; exists te2; exists tm2; exists tv. intuition. Qed. Lemma transl_expr_Eload_correct: forall (le : Csharpminor.letenv) (e : Csharpminor.env) (m : mem) - (chunk : memory_chunk) (a : Csharpminor.expr) (m1 : mem) + (chunk : memory_chunk) (a : Csharpminor.expr) (t: trace) (m1 : mem) (v1 v : val), - Csharpminor.eval_expr prog le e m a m1 v1 -> - eval_expr_prop le e m a m1 v1 -> + Csharpminor.eval_expr prog le e m a t m1 v1 -> + eval_expr_prop le e m a t m1 v1 -> loadv chunk m1 v1 = Some v -> - eval_expr_prop le e m (Csharpminor.Eload chunk a) m1 v. + eval_expr_prop le e m (Csharpminor.Eload chunk a) t m1 v. Proof. intros; red; intros. monadInv TR. - destruct (H0 _ _ _ _ _ _ _ _ _ _ EQ LINJ MINJ MATCH) - as [f2 [te2 [tm2 [tv1 [EVAL [VINJ1 [MINJ2 [INCR MATCH2]]]]]]]]. - destruct (loadv_inject _ _ _ _ _ _ _ MINJ2 H1 VINJ1) - as [tv [TLOAD VINJ]]. + exploit H0; eauto. + intros [f2 [te2 [tm2 [tv1 [EVAL [VINJ1 [MINJ2 [INCR MATCH2]]]]]]]]. + exploit loadv_inject; eauto. + intros [tv [TLOAD VINJ]]. exists f2; exists te2; exists tm2; exists tv. intuition. subst ta. eapply make_load_correct; eauto. Qed. -Lemma transl_expr_Estore_correct: - forall (le : Csharpminor.letenv) (e : Csharpminor.env) (m : mem) - (chunk : memory_chunk) (a b : Csharpminor.expr) (m1 : mem) - (v1 : val) (m2 : mem) (v2 : val) (m3 : mem) (v3 : val), - Csharpminor.eval_expr prog le e m a m1 v1 -> - eval_expr_prop le e m a m1 v1 -> - Csharpminor.eval_expr prog le e m1 b m2 v2 -> - eval_expr_prop le e m1 b m2 v2 -> - cast chunk v2 = Some v3 -> - storev chunk m2 v1 v3 = Some m3 -> - eval_expr_prop le e m (Csharpminor.Estore chunk a b) m3 v3. -Proof. - intros; red; intros. monadInv TR. - destruct (H0 _ _ _ _ _ _ _ _ _ _ EQ LINJ MINJ MATCH) - as [f2 [te2 [tm2 [tv1 [EVAL1 [VINJ1 [MINJ2 [INCR2 MATCH2]]]]]]]]. - assert (LINJ2: val_list_inject f2 le tle). eapply val_list_inject_incr; eauto. - destruct (H2 _ _ _ _ _ _ _ _ _ _ EQ0 LINJ2 MINJ2 MATCH2) - as [f3 [te3 [tm3 [tv2 [EVAL2 [VINJ2 [MINJ3 [INCR3 MATCH3]]]]]]]]. - assert (VINJ1': val_inject f3 v1 tv1). eapply val_inject_incr; eauto. - destruct (make_store_correct _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ - EVAL1 EVAL2 H3 H4 MINJ3 VINJ1' VINJ2) - as [tm4 [tv [EVAL [MINJ4 [VINJ4 NEXTBLOCK]]]]]. - exists f3; exists te3; exists tm4; exists tv. - rewrite <- H6. intuition. - eapply inject_incr_trans; eauto. - assert (val_inject f3 v1 tv1). eapply val_inject_incr; eauto. - unfold storev in H4; destruct v1; try discriminate. - inversion H5. - rewrite NEXTBLOCK. replace (nextblock m3) with (nextblock m2). - eapply match_callstack_mapped; eauto. congruence. - generalize (store_inv _ _ _ _ _ _ H4). simpl; symmetry; tauto. -Qed. - -Lemma sig_transl_function: - forall f tf, transl_function gce f = Some tf -> tf.(fn_sig) = f.(Csharpminor.fn_sig). -Proof. - intros f tf. unfold transl_function. - destruct (build_compilenv gce f). - case (zle z Int.max_signed); intros. - monadInv H. subst tf; reflexivity. - congruence. -Qed. - Lemma transl_expr_Ecall_correct: forall (le : Csharpminor.letenv) (e : Csharpminor.env) (m : mem) (sig : signature) (a : Csharpminor.expr) (bl : Csharpminor.exprlist) - (m1 m2 m3 : mem) (vf : val) (vargs : list val) (vres : val) - (f : Csharpminor.function), - Csharpminor.eval_expr prog le e m a m1 vf -> - eval_expr_prop le e m a m1 vf -> - Csharpminor.eval_exprlist prog le e m1 bl m2 vargs -> - eval_exprlist_prop le e m1 bl m2 vargs -> + (t1: trace) (m1: mem) (t2: trace) (m2: mem) (t3: trace) (m3: mem) + (vf : val) (vargs : list val) (vres : val) + (f : Csharpminor.fundef) (t: trace), + Csharpminor.eval_expr prog le e m a t1 m1 vf -> + eval_expr_prop le e m a t1 m1 vf -> + Csharpminor.eval_exprlist prog le e m1 bl t2 m2 vargs -> + eval_exprlist_prop le e m1 bl t2 m2 vargs -> Genv.find_funct ge vf = Some f -> - Csharpminor.fn_sig f = sig -> - Csharpminor.eval_funcall prog m2 f vargs m3 vres -> - eval_funcall_prop m2 f vargs m3 vres -> - eval_expr_prop le e m (Csharpminor.Ecall sig a bl) m3 vres. + Csharpminor.funsig f = sig -> + Csharpminor.eval_funcall prog m2 f vargs t3 m3 vres -> + eval_funcall_prop m2 f vargs t3 m3 vres -> + t = t1 ** t2 ** t3 -> + eval_expr_prop le e m (Csharpminor.Ecall sig a bl) t m3 vres. Proof. intros;red;intros. monadInv TR. subst ta. - generalize (H0 _ _ _ _ _ _ _ _ _ _ EQ LINJ MINJ MATCH). + exploit H0; eauto. intros [f2 [te2 [tm2 [tv1 [EVAL1 [VINJ1 [MINJ1 [INCR1 MATCH1]]]]]]]]. - assert (LINJ1: val_list_inject f2 le tle). eapply val_list_inject_incr; eauto. - generalize (H2 _ _ _ _ _ _ _ _ _ _ EQ0 LINJ1 MINJ1 MATCH1). + exploit H2. + eauto. eapply val_list_inject_incr; eauto. eauto. eauto. intros [f3 [te3 [tm3 [tv2 [EVAL2 [VINJ2 [MINJ2 [INCR2 MATCH2]]]]]]]]. assert (tv1 = vf). elim (Genv.find_funct_inv H3). intros bf VF. rewrite VF in H3. rewrite Genv.find_funct_find_funct_ptr in H3. generalize (Genv.find_funct_ptr_inv H3). intro. assert (match_globalenvs f2). eapply match_callstack_match_globalenvs; eauto. - generalize (mg_functions _ H8 _ H7). intro. + generalize (mg_functions _ H9 _ H8). intro. rewrite VF in VINJ1. inversion VINJ1. subst vf. decEq. congruence. subst ofs2. replace x with 0. reflexivity. congruence. subst tv1. elim (functions_translated _ _ H3). intros tf [FIND TRF]. - generalize (H6 _ _ _ _ _ TRF MINJ2 MATCH2 VINJ2). + exploit H6; eauto. intros [f4 [tm4 [tres [EVAL3 [VINJ3 [MINJ3 [INCR3 MATCH3]]]]]]]. exists f4; exists te3; exists tm4; exists tres. intuition. - eapply eval_Ecall; eauto. rewrite <- H4. apply sig_transl_function; auto. + eapply eval_Ecall; eauto. + rewrite <- H4. apply sig_preserved; auto. apply inject_incr_trans with f2; auto. apply inject_incr_trans with f3; auto. Qed. Lemma transl_expr_Econdition_true_correct: forall (le : Csharpminor.letenv) (e : Csharpminor.env) (m : mem) - (a b c : Csharpminor.expr) (m1 : mem) (v1 : val) (m2 : mem) - (v2 : val), - Csharpminor.eval_expr prog le e m a m1 v1 -> - eval_expr_prop le e m a m1 v1 -> + (a b c : Csharpminor.expr) (t1: trace) (m1 : mem) (v1 : val) + (t2: trace) (m2 : mem) (v2 : val) (t: trace), + Csharpminor.eval_expr prog le e m a t1 m1 v1 -> + eval_expr_prop le e m a t1 m1 v1 -> Val.is_true v1 -> - Csharpminor.eval_expr prog le e m1 b m2 v2 -> - eval_expr_prop le e m1 b m2 v2 -> - eval_expr_prop le e m (Csharpminor.Econdition a b c) m2 v2. + Csharpminor.eval_expr prog le e m1 b t2 m2 v2 -> + eval_expr_prop le e m1 b t2 m2 v2 -> + t = t1 ** t2 -> + eval_expr_prop le e m (Csharpminor.Econdition a b c) t m2 v2. Proof. intros; red; intros. monadInv TR. - destruct (H0 _ _ _ _ _ _ _ _ _ _ EQ LINJ MINJ MATCH) - as [f2 [te2 [tm2 [tv1 [EVAL1 [VINJ1 [MINJ1 [INCR1 MATCH1]]]]]]]]. - assert (LINJ1: val_list_inject f2 le tle). eapply val_list_inject_incr; eauto. - destruct (H3 _ _ _ _ _ _ _ _ _ _ EQ0 LINJ1 MINJ1 MATCH1) - as [f3 [te3 [tm3 [tv2 [EVAL2 [VINJ2 [MINJ2 [INCR2 MATCH2]]]]]]]]. + exploit H0; eauto. + intros [f2 [te2 [tm2 [tv1 [EVAL1 [VINJ1 [MINJ1 [INCR1 MATCH1]]]]]]]]. + exploit H3. + eauto. eapply val_list_inject_incr; eauto. eauto. eauto. + intros [f3 [te3 [tm3 [tv2 [EVAL2 [VINJ2 [MINJ2 [INCR2 MATCH2]]]]]]]]. exists f3; exists te3; exists tm3; exists tv2. intuition. - rewrite <- H5. eapply eval_conditionalexpr_true; eauto. + rewrite <- H6. subst t; eapply eval_conditionalexpr_true; eauto. inversion VINJ1; subst v1 tv1; simpl in H1; simpl; contradiction || auto. eapply inject_incr_trans; eauto. Qed. Lemma transl_expr_Econdition_false_correct: forall (le : Csharpminor.letenv) (e : Csharpminor.env) (m : mem) - (a b c : Csharpminor.expr) (m1 : mem) (v1 : val) (m2 : mem) - (v2 : val), - Csharpminor.eval_expr prog le e m a m1 v1 -> - eval_expr_prop le e m a m1 v1 -> + (a b c : Csharpminor.expr) (t1: trace) (m1 : mem) (v1 : val) + (t2: trace) (m2 : mem) (v2 : val) (t: trace), + Csharpminor.eval_expr prog le e m a t1 m1 v1 -> + eval_expr_prop le e m a t1 m1 v1 -> Val.is_false v1 -> - Csharpminor.eval_expr prog le e m1 c m2 v2 -> - eval_expr_prop le e m1 c m2 v2 -> - eval_expr_prop le e m (Csharpminor.Econdition a b c) m2 v2. + Csharpminor.eval_expr prog le e m1 c t2 m2 v2 -> + eval_expr_prop le e m1 c t2 m2 v2 -> + t = t1 ** t2 -> + eval_expr_prop le e m (Csharpminor.Econdition a b c) t m2 v2. Proof. intros; red; intros. monadInv TR. - destruct (H0 _ _ _ _ _ _ _ _ _ _ EQ LINJ MINJ MATCH) - as [f2 [te2 [tm2 [tv1 [EVAL1 [VINJ1 [MINJ1 [INCR1 MATCH1]]]]]]]]. - assert (LINJ1: val_list_inject f2 le tle). eapply val_list_inject_incr; eauto. - destruct (H3 _ _ _ _ _ _ _ _ _ _ EQ1 LINJ1 MINJ1 MATCH1) - as [f3 [te3 [tm3 [tv2 [EVAL2 [VINJ2 [MINJ2 [INCR2 MATCH2]]]]]]]]. + exploit H0; eauto. + intros [f2 [te2 [tm2 [tv1 [EVAL1 [VINJ1 [MINJ1 [INCR1 MATCH1]]]]]]]]. + exploit H3. + eauto. eapply val_list_inject_incr; eauto. eauto. eauto. + intros [f3 [te3 [tm3 [tv2 [EVAL2 [VINJ2 [MINJ2 [INCR2 MATCH2]]]]]]]]. exists f3; exists te3; exists tm3; exists tv2. intuition. - rewrite <- H5. eapply eval_conditionalexpr_false; eauto. + rewrite <- H6. subst t; eapply eval_conditionalexpr_false; eauto. inversion VINJ1; subst v1 tv1; simpl in H1; simpl; contradiction || auto. eapply inject_incr_trans; eauto. Qed. Lemma transl_expr_Elet_correct: forall (le : Csharpminor.letenv) (e : Csharpminor.env) (m : mem) - (a b : Csharpminor.expr) (m1 : mem) (v1 : val) (m2 : mem) (v2 : val), - Csharpminor.eval_expr prog le e m a m1 v1 -> - eval_expr_prop le e m a m1 v1 -> - Csharpminor.eval_expr prog (v1 :: le) e m1 b m2 v2 -> - eval_expr_prop (v1 :: le) e m1 b m2 v2 -> - eval_expr_prop le e m (Csharpminor.Elet a b) m2 v2. + (a b : Csharpminor.expr) (t1: trace) (m1 : mem) (v1 : val) + (t2: trace) (m2 : mem) (v2 : val) (t: trace), + Csharpminor.eval_expr prog le e m a t1 m1 v1 -> + eval_expr_prop le e m a t1 m1 v1 -> + Csharpminor.eval_expr prog (v1 :: le) e m1 b t2 m2 v2 -> + eval_expr_prop (v1 :: le) e m1 b t2 m2 v2 -> + t = t1 ** t2 -> + eval_expr_prop le e m (Csharpminor.Elet a b) t m2 v2. Proof. intros; red; intros. monadInv TR. - destruct (H0 _ _ _ _ _ _ _ _ _ _ EQ LINJ MINJ MATCH) - as [f2 [te2 [tm2 [tv1 [EVAL1 [VINJ1 [MINJ1 [INCR1 MATCH1]]]]]]]]. - assert (LINJ1: val_list_inject f2 (v1 :: le) (tv1 :: tle)). - constructor. auto. eapply val_list_inject_incr; eauto. - destruct (H2 _ _ _ _ _ _ _ _ _ _ EQ0 LINJ1 MINJ1 MATCH1) - as [f3 [te3 [tm3 [tv2 [EVAL2 [VINJ2 [MINJ2 [INCR2 MATCH2]]]]]]]]. + exploit H0; eauto. + intros [f2 [te2 [tm2 [tv1 [EVAL1 [VINJ1 [MINJ1 [INCR1 MATCH1]]]]]]]]. + exploit H2. + eauto. + constructor. eauto. eapply val_list_inject_incr; eauto. + eauto. eauto. + intros [f3 [te3 [tm3 [tv2 [EVAL2 [VINJ2 [MINJ2 [INCR2 MATCH2]]]]]]]]. exists f3; exists te3; exists tm3; exists tv2. intuition. subst ta; eapply eval_Elet; eauto. @@ -2089,19 +2061,46 @@ Lemma transl_expr_Eletvar_correct: forall (le : list val) (e : Csharpminor.env) (m : mem) (n : nat) (v : val), nth_error le n = Some v -> - eval_expr_prop le e m (Csharpminor.Eletvar n) m v. + eval_expr_prop le e m (Csharpminor.Eletvar n) E0 m v. Proof. intros; red; intros. monadInv TR. - destruct (val_list_inject_nth _ _ _ LINJ _ _ H) - as [tv [A B]]. + exploit val_list_inject_nth; eauto. intros [tv [A B]]. exists f1; exists te1; exists tm1; exists tv. intuition. subst ta. eapply eval_Eletvar; auto. Qed. +Lemma transl_expr_Ealloc_correct: + forall (le: list val) (e: Csharpminor.env) (m1: mem) (a: Csharpminor.expr) + (t: trace) (m2: mem) (n: int) (m3: mem) (b: block), + Csharpminor.eval_expr prog le e m1 a t m2 (Vint n) -> + eval_expr_prop le e m1 a t m2 (Vint n) -> + Mem.alloc m2 0 (Int.signed n) = (m3, b) -> + eval_expr_prop le e m1 (Csharpminor.Ealloc a) t m3 (Vptr b Int.zero). +Proof. + intros; red; intros. monadInv TR. + exploit H0; eauto. + intros [f2 [te2 [tm2 [tv1 [EVAL1 [VINJ1 [MINJ2 [INCR2 MATCH2]]]]]]]]. + inversion VINJ1. subst tv1 i. + caseEq (alloc tm2 0 (Int.signed n)). intros tm3 tb TALLOC. + assert (LB: Int.min_signed <= 0). compute. congruence. + assert (HB: Int.signed n <= Int.max_signed). + generalize (Int.signed_range n); omega. + exploit alloc_parallel_inject; eauto. + intros [MINJ3 INCR3]. + exists (extend_inject b (Some (tb, 0)) f2); + exists te2; exists tm3; exists (Vptr tb Int.zero). + split. subst ta; econstructor; eauto. + split. econstructor. unfold extend_inject, eq_block. rewrite zeq_true. reflexivity. + reflexivity. + split. assumption. + split. eapply inject_incr_trans; eauto. + eapply match_callstack_alloc; eauto. +Qed. + Lemma transl_exprlist_Enil_correct: forall (le : Csharpminor.letenv) (e : Csharpminor.env) (m : mem), - eval_exprlist_prop le e m Csharpminor.Enil m nil. + eval_exprlist_prop le e m Csharpminor.Enil E0 m nil. Proof. intros; red; intros. monadInv TR. exists f1; exists te1; exists tm1; exists (@nil val). @@ -2110,50 +2109,55 @@ Qed. Lemma transl_exprlist_Econs_correct: forall (le : Csharpminor.letenv) (e : Csharpminor.env) (m : mem) - (a : Csharpminor.expr) (bl : Csharpminor.exprlist) (m1 : mem) - (v : val) (m2 : mem) (vl : list val), - Csharpminor.eval_expr prog le e m a m1 v -> - eval_expr_prop le e m a m1 v -> - Csharpminor.eval_exprlist prog le e m1 bl m2 vl -> - eval_exprlist_prop le e m1 bl m2 vl -> - eval_exprlist_prop le e m (Csharpminor.Econs a bl) m2 (v :: vl). + (a : Csharpminor.expr) (bl : Csharpminor.exprlist) + (t1: trace) (m1 : mem) (v : val) + (t2: trace) (m2 : mem) (vl : list val) (t: trace), + Csharpminor.eval_expr prog le e m a t1 m1 v -> + eval_expr_prop le e m a t1 m1 v -> + Csharpminor.eval_exprlist prog le e m1 bl t2 m2 vl -> + eval_exprlist_prop le e m1 bl t2 m2 vl -> + t = t1 ** t2 -> + eval_exprlist_prop le e m (Csharpminor.Econs a bl) t m2 (v :: vl). Proof. intros; red; intros. monadInv TR. - destruct (H0 _ _ _ _ _ _ _ _ _ _ EQ LINJ MINJ MATCH) - as [f2 [te2 [tm2 [tv1 [EVAL1 [VINJ1 [MINJ2 [INCR2 MATCH2]]]]]]]]. - assert (LINJ2: val_list_inject f2 le tle). eapply val_list_inject_incr; eauto. - destruct (H2 _ _ _ _ _ _ _ _ _ _ EQ0 LINJ2 MINJ2 MATCH2) - as [f3 [te3 [tm3 [tv2 [EVAL2 [VINJ2 [MINJ3 [INCR3 MATCH3]]]]]]]]. - assert (VINJ1': val_inject f3 v tv1). eapply val_inject_incr; eauto. + exploit H0; eauto. + intros [f2 [te2 [tm2 [tv1 [EVAL1 [VINJ1 [MINJ2 [INCR2 MATCH2]]]]]]]]. + exploit H2. + eauto. eapply val_list_inject_incr; eauto. eauto. eauto. + intros [f3 [te3 [tm3 [tv2 [EVAL2 [VINJ2 [MINJ3 [INCR3 MATCH3]]]]]]]]. exists f3; exists te3; exists tm3; exists (tv1 :: tv2). intuition. subst tal; econstructor; eauto. + constructor. eapply val_inject_incr; eauto. auto. eapply inject_incr_trans; eauto. Qed. -Lemma transl_funcall_correct: +Lemma transl_funcall_internal_correct: forall (m : mem) (f : Csharpminor.function) (vargs : list val) - (e : Csharpminor.env) (m1 : mem) (lb : list block) (m2 m3 : mem) - (out : Csharpminor.outcome) (vres : val), + (e : Csharpminor.env) (m1 : mem) (lb : list block) (m2: mem) + (t: trace) (m3 : mem) (out : Csharpminor.outcome) (vres : val), list_norepet (fn_params_names f ++ fn_vars_names f) -> alloc_variables empty_env m (fn_variables f) e m1 lb -> bind_parameters e m1 (Csharpminor.fn_params f) vargs m2 -> - Csharpminor.exec_stmt prog e m2 (Csharpminor.fn_body f) m3 out -> - exec_stmt_prop e m2 (Csharpminor.fn_body f) m3 out -> + Csharpminor.exec_stmt prog e m2 (Csharpminor.fn_body f) t m3 out -> + exec_stmt_prop e m2 (Csharpminor.fn_body f) t m3 out -> Csharpminor.outcome_result_value out (sig_res (Csharpminor.fn_sig f)) vres -> - eval_funcall_prop m f vargs (free_list m3 lb) vres. + eval_funcall_prop m (Internal f) vargs t (free_list m3 lb) vres. Proof. intros; red. intros tfn f1 tm; intros. - unfold transl_function in TR. + generalize TR; clear TR. + unfold transl_fundef, transf_partial_fundef. + caseEq (transl_function gce f); try congruence. + intros tf TR EQ. inversion EQ; clear EQ; subst tfn. + unfold transl_function in TR. caseEq (build_compilenv gce f); intros cenv stacksize CENV. rewrite CENV in TR. destruct (zle stacksize Int.max_signed); try discriminate. monadInv TR. clear TR. caseEq (alloc tm 0 stacksize). intros tm1 sp ALLOC. - destruct (function_entry_ok _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ - H0 H1 MATCH CENV z ALLOC ARGSINJ MINJ H) - as [f2 [te2 [tm2 [STOREPARAM [MINJ2 [INCR12 [MATCH2 BLOCKS]]]]]]]. - destruct (H3 _ _ _ _ _ _ _ _ _ EQ MINJ2 MATCH2) - as [f3 [te3 [tm3 [tout [EXECBODY [OUTINJ [MINJ3 [INCR23 MATCH3]]]]]]]]. + exploit function_entry_ok; eauto. + intros [f2 [te2 [tm2 [STOREPARAM [MINJ2 [INCR12 [MATCH2 BLOCKS]]]]]]]. + red in H3; exploit H3; eauto. + intros [f3 [te3 [tm3 [tout [EXECBODY [OUTINJ [MINJ3 [INCR23 MATCH3]]]]]]]]. assert (exists tvres, outcome_result_value tout f.(Csharpminor.fn_sig).(sig_res) tvres /\ val_inject f3 vres tvres). @@ -2167,13 +2171,14 @@ Proof. destruct (sig_res (Csharpminor.fn_sig f)); intro. exists v2; split. auto. subst vres; auto. contradiction. - elim H5; clear H5; intros tvres [TOUT VINJRES]. + destruct H5 as [tvres [TOUT VINJRES]]. exists f3; exists (Mem.free tm3 sp); exists tvres. (* execution *) split. rewrite <- H6; econstructor; simpl; eauto. - apply exec_Sseq_continue with te2 tm2. + apply exec_Sseq_continue with E0 te2 tm2 t. exact STOREPARAM. eexact EXECBODY. + traceEq. (* val_inject *) split. assumption. (* mem_inject *) @@ -2190,9 +2195,22 @@ Proof. intros. elim (BLOCKS b); intros B1 B2. generalize (B2 H7). omega. Qed. +Lemma transl_funcall_external_correct: + forall (m : mem) (ef : external_function) (vargs : list val) + (t : trace) (vres : val), + event_match ef vargs t vres -> + eval_funcall_prop m (External ef) vargs t m vres. +Proof. + intros; red; intros. + simpl in TR. inversion TR; clear TR; subst tfn. + exploit event_match_inject; eauto. intros [A B]. + exists f1; exists tm1; exists vres; intuition. + constructor; auto. +Qed. + Lemma transl_stmt_Sskip_correct: forall (e : Csharpminor.env) (m : mem), - exec_stmt_prop e m Csharpminor.Sskip m Csharpminor.Out_normal. + exec_stmt_prop e m Csharpminor.Sskip E0 m Csharpminor.Out_normal. Proof. intros; red; intros. monadInv TR. exists f1; exists te1; exists tm1; exists Out_normal. @@ -2201,33 +2219,90 @@ Qed. Lemma transl_stmt_Sexpr_correct: forall (e : Csharpminor.env) (m : mem) (a : Csharpminor.expr) - (m1 : mem) (v : val), - Csharpminor.eval_expr prog nil e m a m1 v -> - eval_expr_prop nil e m a m1 v -> - exec_stmt_prop e m (Csharpminor.Sexpr a) m1 Csharpminor.Out_normal. + (t: trace) (m1 : mem) (v : val), + Csharpminor.eval_expr prog nil e m a t m1 v -> + eval_expr_prop nil e m a t m1 v -> + exec_stmt_prop e m (Csharpminor.Sexpr a) t m1 Csharpminor.Out_normal. Proof. intros; red; intros. monadInv TR. - destruct (H0 _ _ _ _ _ _ _ _ _ _ EQ (val_nil_inject f1) MINJ MATCH) - as [f2 [te2 [tm2 [tv1 [EVAL1 [VINJ1 [MINJ2 [INCR2 MATCH2]]]]]]]]. + exploit H0; eauto. + intros [f2 [te2 [tm2 [tv1 [EVAL1 [VINJ1 [MINJ2 [INCR2 MATCH2]]]]]]]]. exists f2; exists te2; exists tm2; exists Out_normal. intuition. subst ts. econstructor; eauto. constructor. Qed. +Lemma transl_stmt_Sassign_correct: + forall (e : Csharpminor.env) (m : mem) + (id : ident) (a : Csharpminor.expr) (t: trace) (m1 : mem) (b : block) + (chunk : memory_chunk) (v : val) (m2 : mem), + Csharpminor.eval_expr prog nil e m a t m1 v -> + eval_expr_prop nil e m a t m1 v -> + eval_var_ref prog e id b chunk -> + store chunk m1 b 0 v = Some m2 -> + exec_stmt_prop e m (Csharpminor.Sassign id a) t m2 Csharpminor.Out_normal. +Proof. + intros; red; intros. monadInv TR; intro EQ0. + exploit H0; eauto. + intros [f2 [te2 [tm2 [tv1 [EVAL1 [VINJ1 [MINJ1 [INCR12 MATCH1]]]]]]]]. + exploit var_set_correct; eauto. + intros [te3 [tm3 [EVAL2 [MINJ2 MATCH2]]]]. + exists f2; exists te3; exists tm3; exists Out_normal. + intuition. constructor. +Qed. + +Lemma transl_stmt_Sstore_correct: + forall (e : Csharpminor.env) (m : mem) + (chunk : memory_chunk) (a b : Csharpminor.expr) (t1: trace) (m1 : mem) + (v1 : val) (t2: trace) (m2 : mem) (v2 : val) + (t3: trace) (m3 : mem), + Csharpminor.eval_expr prog nil e m a t1 m1 v1 -> + eval_expr_prop nil e m a t1 m1 v1 -> + Csharpminor.eval_expr prog nil e m1 b t2 m2 v2 -> + eval_expr_prop nil e m1 b t2 m2 v2 -> + storev chunk m2 v1 v2 = Some m3 -> + t3 = t1 ** t2 -> + exec_stmt_prop e m (Csharpminor.Sstore chunk a b) t3 m3 Csharpminor.Out_normal. +Proof. + intros; red; intros. monadInv TR. + exploit H0; eauto. + intros [f2 [te2 [tm2 [tv1 [EVAL1 [VINJ1 [MINJ2 [INCR2 MATCH2]]]]]]]]. + exploit H2. + eauto. + eapply val_list_inject_incr; eauto. + eauto. eauto. + intros [f3 [te3 [tm3 [tv2 [EVAL2 [VINJ2 [MINJ3 [INCR3 MATCH3]]]]]]]]. + exploit make_store_correct. + eexact EVAL1. eexact EVAL2. eauto. eauto. + eapply val_inject_incr; eauto. eauto. + intros [tm4 [EVAL [MINJ4 NEXTBLOCK]]]. + exists f3; exists te3; exists tm4; exists Out_normal. + rewrite <- H6. subst t3. intuition. + constructor. + eapply inject_incr_trans; eauto. + assert (val_inject f3 v1 tv1). eapply val_inject_incr; eauto. + unfold storev in H3; destruct v1; try discriminate. + inversion H4. + rewrite NEXTBLOCK. replace (nextblock m3) with (nextblock m2). + eapply match_callstack_mapped; eauto. congruence. + exploit store_inv; eauto. simpl; symmetry; tauto. +Qed. + Lemma transl_stmt_Sseq_continue_correct: forall (e : Csharpminor.env) (m : mem) (s1 s2 : Csharpminor.stmt) - (m1 m2 : mem) (out : Csharpminor.outcome), - Csharpminor.exec_stmt prog e m s1 m1 Csharpminor.Out_normal -> - exec_stmt_prop e m s1 m1 Csharpminor.Out_normal -> - Csharpminor.exec_stmt prog e m1 s2 m2 out -> - exec_stmt_prop e m1 s2 m2 out -> - exec_stmt_prop e m (Csharpminor.Sseq s1 s2) m2 out. + (t1 t2: trace) (m1 m2 : mem) (t: trace) (out : Csharpminor.outcome), + Csharpminor.exec_stmt prog e m s1 t1 m1 Csharpminor.Out_normal -> + exec_stmt_prop e m s1 t1 m1 Csharpminor.Out_normal -> + Csharpminor.exec_stmt prog e m1 s2 t2 m2 out -> + exec_stmt_prop e m1 s2 t2 m2 out -> + t = t1 ** t2 -> + exec_stmt_prop e m (Csharpminor.Sseq s1 s2) t m2 out. Proof. intros; red; intros; monadInv TR. - destruct (H0 _ _ _ _ _ _ _ _ _ EQ MINJ MATCH) - as [f2 [te2 [tm2 [tout1 [EXEC1 [OINJ1 [MINJ2 [INCR2 MATCH2]]]]]]]]. - destruct (H2 _ _ _ _ _ _ _ _ _ EQ0 MINJ2 MATCH2) - as [f3 [te3 [tm3 [tout2 [EXEC2 [OINJ2 [MINJ3 [INCR3 MATCH3]]]]]]]]. + exploit H0; eauto. + intros [f2 [te2 [tm2 [tout1 [EXEC1 [OINJ1 [MINJ2 [INCR2 MATCH2]]]]]]]]. + exploit H2; eauto. + intros [f3 [te3 [tm3 [tout2 [EXEC2 [OINJ2 [MINJ3 [INCR3 MATCH3]]]]]]]]. exists f3; exists te3; exists tm3; exists tout2. intuition. subst ts; eapply exec_Sseq_continue; eauto. inversion OINJ1. subst tout1. auto. @@ -2236,15 +2311,15 @@ Qed. Lemma transl_stmt_Sseq_stop_correct: forall (e : Csharpminor.env) (m : mem) (s1 s2 : Csharpminor.stmt) - (m1 : mem) (out : Csharpminor.outcome), - Csharpminor.exec_stmt prog e m s1 m1 out -> - exec_stmt_prop e m s1 m1 out -> + (t1: trace) (m1 : mem) (out : Csharpminor.outcome), + Csharpminor.exec_stmt prog e m s1 t1 m1 out -> + exec_stmt_prop e m s1 t1 m1 out -> out <> Csharpminor.Out_normal -> - exec_stmt_prop e m (Csharpminor.Sseq s1 s2) m1 out. + exec_stmt_prop e m (Csharpminor.Sseq s1 s2) t1 m1 out. Proof. intros; red; intros; monadInv TR. - destruct (H0 _ _ _ _ _ _ _ _ _ EQ MINJ MATCH) - as [f2 [te2 [tm2 [tout1 [EXEC1 [OINJ1 [MINJ2 [INCR2 MATCH2]]]]]]]]. + exploit H0; eauto. + intros [f2 [te2 [tm2 [tout1 [EXEC1 [OINJ1 [MINJ2 [INCR2 MATCH2]]]]]]]]. exists f2; exists te2; exists tm2; exists tout1. intuition. subst ts; eapply exec_Sseq_stop; eauto. inversion OINJ1; subst out tout1; congruence. @@ -2252,64 +2327,70 @@ Qed. Lemma transl_stmt_Sifthenelse_true_correct: forall (e : Csharpminor.env) (m : mem) (a : Csharpminor.expr) - (sl1 sl2 : Csharpminor.stmt) (m1 : mem) (v1 : val) (m2 : mem) - (out : Csharpminor.outcome), - Csharpminor.eval_expr prog nil e m a m1 v1 -> - eval_expr_prop nil e m a m1 v1 -> + (sl1 sl2 : Csharpminor.stmt) + (t1: trace) (m1 : mem) (v1 : val) (t2: trace) (m2 : mem) + (out : Csharpminor.outcome) (t: trace), + Csharpminor.eval_expr prog nil e m a t1 m1 v1 -> + eval_expr_prop nil e m a t1 m1 v1 -> Val.is_true v1 -> - Csharpminor.exec_stmt prog e m1 sl1 m2 out -> - exec_stmt_prop e m1 sl1 m2 out -> - exec_stmt_prop e m (Csharpminor.Sifthenelse a sl1 sl2) m2 out. + Csharpminor.exec_stmt prog e m1 sl1 t2 m2 out -> + exec_stmt_prop e m1 sl1 t2 m2 out -> + t = t1 ** t2 -> + exec_stmt_prop e m (Csharpminor.Sifthenelse a sl1 sl2) t m2 out. Proof. intros; red; intros. monadInv TR. - destruct (H0 _ _ _ _ _ _ _ _ _ _ EQ (val_nil_inject f1) MINJ MATCH) - as [f2 [te2 [tm2 [tv1 [EVAL1 [VINJ1 [MINJ2 [INCR2 MATCH2]]]]]]]]. - destruct (H3 _ _ _ _ _ _ _ _ _ EQ0 MINJ2 MATCH2) - as [f3 [te3 [tm3 [tout [EVAL2 [OINJ [MINJ3 [INCR3 MATCH3]]]]]]]]. + exploit H0; eauto. + intros [f2 [te2 [tm2 [tv1 [EVAL1 [VINJ1 [MINJ2 [INCR2 MATCH2]]]]]]]]. + exploit H3; eauto. + intros [f3 [te3 [tm3 [tout [EVAL2 [OINJ [MINJ3 [INCR3 MATCH3]]]]]]]]. exists f3; exists te3; exists tm3; exists tout. intuition. - subst ts. eapply exec_ifthenelse_true; eauto. + subst ts t. eapply exec_ifthenelse_true; eauto. inversion VINJ1; subst v1 tv1; simpl in H1; simpl; contradiction || auto. eapply inject_incr_trans; eauto. Qed. Lemma transl_stmt_Sifthenelse_false_correct: forall (e : Csharpminor.env) (m : mem) (a : Csharpminor.expr) - (sl1 sl2 : Csharpminor.stmt) (m1 : mem) (v1 : val) (m2 : mem) - (out : Csharpminor.outcome), - Csharpminor.eval_expr prog nil e m a m1 v1 -> - eval_expr_prop nil e m a m1 v1 -> + (sl1 sl2 : Csharpminor.stmt) + (t1: trace) (m1 : mem) (v1 : val) (t2: trace) (m2 : mem) + (out : Csharpminor.outcome) (t: trace), + Csharpminor.eval_expr prog nil e m a t1 m1 v1 -> + eval_expr_prop nil e m a t1 m1 v1 -> Val.is_false v1 -> - Csharpminor.exec_stmt prog e m1 sl2 m2 out -> - exec_stmt_prop e m1 sl2 m2 out -> - exec_stmt_prop e m (Csharpminor.Sifthenelse a sl1 sl2) m2 out. + Csharpminor.exec_stmt prog e m1 sl2 t2 m2 out -> + exec_stmt_prop e m1 sl2 t2 m2 out -> + t = t1 ** t2 -> + exec_stmt_prop e m (Csharpminor.Sifthenelse a sl1 sl2) t m2 out. Proof. intros; red; intros. monadInv TR. - destruct (H0 _ _ _ _ _ _ _ _ _ _ EQ (val_nil_inject f1) MINJ MATCH) - as [f2 [te2 [tm2 [tv1 [EVAL1 [VINJ1 [MINJ2 [INCR2 MATCH2]]]]]]]]. - destruct (H3 _ _ _ _ _ _ _ _ _ EQ1 MINJ2 MATCH2) - as [f3 [te3 [tm3 [tout [EVAL2 [OINJ [MINJ3 [INCR3 MATCH3]]]]]]]]. + exploit H0; eauto. + intros [f2 [te2 [tm2 [tv1 [EVAL1 [VINJ1 [MINJ2 [INCR2 MATCH2]]]]]]]]. + exploit H3; eauto. + intros [f3 [te3 [tm3 [tout [EVAL2 [OINJ [MINJ3 [INCR3 MATCH3]]]]]]]]. exists f3; exists te3; exists tm3; exists tout. intuition. - subst ts. eapply exec_ifthenelse_false; eauto. + subst ts t. eapply exec_ifthenelse_false; eauto. inversion VINJ1; subst v1 tv1; simpl in H1; simpl; contradiction || auto. eapply inject_incr_trans; eauto. Qed. Lemma transl_stmt_Sloop_loop_correct: forall (e : Csharpminor.env) (m : mem) (sl : Csharpminor.stmt) - (m1 m2 : mem) (out : Csharpminor.outcome), - Csharpminor.exec_stmt prog e m sl m1 Csharpminor.Out_normal -> - exec_stmt_prop e m sl m1 Csharpminor.Out_normal -> - Csharpminor.exec_stmt prog e m1 (Csharpminor.Sloop sl) m2 out -> - exec_stmt_prop e m1 (Csharpminor.Sloop sl) m2 out -> - exec_stmt_prop e m (Csharpminor.Sloop sl) m2 out. + (t1: trace) (m1: mem) (t2: trace) (m2 : mem) + (out : Csharpminor.outcome) (t: trace), + Csharpminor.exec_stmt prog e m sl t1 m1 Csharpminor.Out_normal -> + exec_stmt_prop e m sl t1 m1 Csharpminor.Out_normal -> + Csharpminor.exec_stmt prog e m1 (Csharpminor.Sloop sl) t2 m2 out -> + exec_stmt_prop e m1 (Csharpminor.Sloop sl) t2 m2 out -> + t = t1 ** t2 -> + exec_stmt_prop e m (Csharpminor.Sloop sl) t m2 out. Proof. intros; red; intros. monadInv TR. - destruct (H0 _ _ _ _ _ _ _ _ _ EQ MINJ MATCH) - as [f2 [te2 [tm2 [tout1 [EVAL1 [OINJ1 [MINJ2 [INCR2 MATCH2]]]]]]]]. - destruct (H2 _ _ _ _ _ _ _ _ _ TR MINJ2 MATCH2) - as [f3 [te3 [tm3 [tout2 [EVAL2 [OINJ2 [MINJ3 [INCR3 MATCH3]]]]]]]]. + exploit H0; eauto. + intros [f2 [te2 [tm2 [tout1 [EVAL1 [OINJ1 [MINJ2 [INCR2 MATCH2]]]]]]]]. + exploit H2; eauto. + intros [f3 [te3 [tm3 [tout2 [EVAL2 [OINJ2 [MINJ3 [INCR3 MATCH3]]]]]]]]. exists f3; exists te3; exists tm3; exists tout2. intuition. subst ts. eapply exec_Sloop_loop; eauto. @@ -2317,18 +2398,17 @@ Proof. eapply inject_incr_trans; eauto. Qed. - Lemma transl_stmt_Sloop_exit_correct: forall (e : Csharpminor.env) (m : mem) (sl : Csharpminor.stmt) - (m1 : mem) (out : Csharpminor.outcome), - Csharpminor.exec_stmt prog e m sl m1 out -> - exec_stmt_prop e m sl m1 out -> + (t1: trace) (m1 : mem) (out : Csharpminor.outcome), + Csharpminor.exec_stmt prog e m sl t1 m1 out -> + exec_stmt_prop e m sl t1 m1 out -> out <> Csharpminor.Out_normal -> - exec_stmt_prop e m (Csharpminor.Sloop sl) m1 out. + exec_stmt_prop e m (Csharpminor.Sloop sl) t1 m1 out. Proof. intros; red; intros. monadInv TR. - destruct (H0 _ _ _ _ _ _ _ _ _ EQ MINJ MATCH) - as [f2 [te2 [tm2 [tout1 [EVAL1 [OINJ1 [MINJ2 [INCR2 MATCH2]]]]]]]]. + exploit H0; eauto. + intros [f2 [te2 [tm2 [tout1 [EVAL1 [OINJ1 [MINJ2 [INCR2 MATCH2]]]]]]]]. exists f2; exists te2; exists tm2; exists tout1. intuition. subst ts; eapply exec_Sloop_stop; eauto. inversion OINJ1; subst out tout1; congruence. @@ -2336,15 +2416,15 @@ Qed. Lemma transl_stmt_Sblock_correct: forall (e : Csharpminor.env) (m : mem) (sl : Csharpminor.stmt) - (m1 : mem) (out : Csharpminor.outcome), - Csharpminor.exec_stmt prog e m sl m1 out -> - exec_stmt_prop e m sl m1 out -> - exec_stmt_prop e m (Csharpminor.Sblock sl) m1 + (t1: trace) (m1 : mem) (out : Csharpminor.outcome), + Csharpminor.exec_stmt prog e m sl t1 m1 out -> + exec_stmt_prop e m sl t1 m1 out -> + exec_stmt_prop e m (Csharpminor.Sblock sl) t1 m1 (Csharpminor.outcome_block out). Proof. intros; red; intros. monadInv TR. - destruct (H0 _ _ _ _ _ _ _ _ _ EQ MINJ MATCH) - as [f2 [te2 [tm2 [tout1 [EVAL1 [OINJ1 [MINJ2 [INCR2 MATCH2]]]]]]]]. + exploit H0; eauto. + intros [f2 [te2 [tm2 [tout1 [EVAL1 [OINJ1 [MINJ2 [INCR2 MATCH2]]]]]]]]. exists f2; exists te2; exists tm2; exists (outcome_block tout1). intuition. subst ts; eapply exec_Sblock; eauto. inversion OINJ1; subst out tout1; simpl. @@ -2356,7 +2436,7 @@ Qed. Lemma transl_stmt_Sexit_correct: forall (e : Csharpminor.env) (m : mem) (n : nat), - exec_stmt_prop e m (Csharpminor.Sexit n) m (Csharpminor.Out_exit n). + exec_stmt_prop e m (Csharpminor.Sexit n) E0 m (Csharpminor.Out_exit n). Proof. intros; red; intros. monadInv TR. exists f1; exists te1; exists tm1; exists (Out_exit n). @@ -2366,15 +2446,15 @@ Qed. Lemma transl_stmt_Sswitch_correct: forall (e : Csharpminor.env) (m : mem) (a : Csharpminor.expr) (cases : list (int * nat)) (default : nat) - (m1 : mem) (n : int), - Csharpminor.eval_expr prog nil e m a m1 (Vint n) -> - eval_expr_prop nil e m a m1 (Vint n) -> - exec_stmt_prop e m (Csharpminor.Sswitch a cases default) m1 + (t1 : trace) (m1 : mem) (n : int), + Csharpminor.eval_expr prog nil e m a t1 m1 (Vint n) -> + eval_expr_prop nil e m a t1 m1 (Vint n) -> + exec_stmt_prop e m (Csharpminor.Sswitch a cases default) t1 m1 (Csharpminor.Out_exit (Csharpminor.switch_target n default cases)). Proof. intros; red; intros. monadInv TR. - destruct (H0 _ _ _ _ _ _ _ _ _ _ EQ (val_nil_inject f1) MINJ MATCH) - as [f2 [te2 [tm2 [tv1 [EVAL [VINJ1 [MINJ2 [INCR MATCH2]]]]]]]]. + exploit H0; eauto. + intros [f2 [te2 [tm2 [tv1 [EVAL [VINJ1 [MINJ2 [INCR MATCH2]]]]]]]]. exists f2; exists te2; exists tm2; exists (Out_exit (switch_target n default cases)). intuition. subst ts. constructor. inversion VINJ1. subst tv1. assumption. @@ -2383,7 +2463,7 @@ Qed. Lemma transl_stmt_Sreturn_none_correct: forall (e : Csharpminor.env) (m : mem), - exec_stmt_prop e m (Csharpminor.Sreturn None) m + exec_stmt_prop e m (Csharpminor.Sreturn None) E0 m (Csharpminor.Out_return None). Proof. intros; red; intros. monadInv TR. @@ -2393,15 +2473,15 @@ Qed. Lemma transl_stmt_Sreturn_some_correct: forall (e : Csharpminor.env) (m : mem) (a : Csharpminor.expr) - (m1 : mem) (v : val), - Csharpminor.eval_expr prog nil e m a m1 v -> - eval_expr_prop nil e m a m1 v -> - exec_stmt_prop e m (Csharpminor.Sreturn (Some a)) m1 + (t1: trace) (m1 : mem) (v : val), + Csharpminor.eval_expr prog nil e m a t1 m1 v -> + eval_expr_prop nil e m a t1 m1 v -> + exec_stmt_prop e m (Csharpminor.Sreturn (Some a)) t1 m1 (Csharpminor.Out_return (Some v)). Proof. intros; red; intros; monadInv TR. - destruct (H0 _ _ _ _ _ _ _ _ _ _ EQ (val_nil_inject f1) MINJ MATCH) - as [f2 [te2 [tm2 [tv1 [EVAL [VINJ1 [MINJ2 [INCR MATCH2]]]]]]]]. + exploit H0; eauto. + intros [f2 [te2 [tm2 [tv1 [EVAL [VINJ1 [MINJ2 [INCR MATCH2]]]]]]]]. exists f2; exists te2; exists tm2; exists (Out_return (Some tv1)). intuition. subst ts; econstructor; eauto. constructor; auto. Qed. @@ -2410,9 +2490,9 @@ Qed. evaluation derivation, using the lemmas above for each case. *) Lemma transl_function_correct: - forall m1 f vargs m2 vres, - Csharpminor.eval_funcall prog m1 f vargs m2 vres -> - eval_funcall_prop m1 f vargs m2 vres. + forall m1 f vargs t m2 vres, + Csharpminor.eval_funcall prog m1 f vargs t m2 vres -> + eval_funcall_prop m1 f vargs t m2 vres. Proof (eval_funcall_ind4 prog eval_expr_prop @@ -2421,21 +2501,23 @@ Proof exec_stmt_prop transl_expr_Evar_correct - transl_expr_Eassign_correct transl_expr_Eaddrof_correct transl_expr_Eop_correct transl_expr_Eload_correct - transl_expr_Estore_correct transl_expr_Ecall_correct transl_expr_Econdition_true_correct transl_expr_Econdition_false_correct transl_expr_Elet_correct transl_expr_Eletvar_correct + transl_expr_Ealloc_correct transl_exprlist_Enil_correct transl_exprlist_Econs_correct - transl_funcall_correct + transl_funcall_internal_correct + transl_funcall_external_correct transl_stmt_Sskip_correct transl_stmt_Sexpr_correct + transl_stmt_Sassign_correct + transl_stmt_Sstore_correct transl_stmt_Sseq_continue_correct transl_stmt_Sseq_stop_correct transl_stmt_Sifthenelse_true_correct @@ -2472,11 +2554,11 @@ Qed. follows. *) Theorem transl_program_correct: - forall n, - Csharpminor.exec_program prog (Vint n) -> - exec_program tprog (Vint n). + forall t n, + Csharpminor.exec_program prog t (Vint n) -> + exec_program tprog t (Vint n). Proof. - intros n [b [fn [m [FINDS [FINDF [SIG EVAL]]]]]]. + intros t n [b [fn [m [FINDS [FINDF [SIG EVAL]]]]]]. elim (function_ptr_translated _ _ FINDF). intros tfn [TFIND TR]. set (m0 := Genv.init_mem (program_of_program prog)) in *. set (f := fun b => if zlt b m0.(nextblock) then Some(b, 0) else None). @@ -2488,26 +2570,25 @@ Proof. split. auto. constructor. compute. split; congruence. left; auto. intros; omega. - generalize (Genv.initmem_undef (program_of_program prog) b0). fold m0. intros [lo [hi EQ]]. - rewrite EQ. simpl. constructor. + generalize (Genv.initmem_block_init (program_of_program prog) b0). fold m0. intros [idata EQ]. + rewrite EQ. simpl. apply Mem.contents_init_data_inject. destruct (zlt b1 (nextblock m0)); try discriminate. destruct (zlt b2 (nextblock m0)); try discriminate. left; congruence. assert (MATCH0: match_callstack f nil m0.(nextblock) m0.(nextblock) m0). constructor. unfold f; apply match_globalenvs_init. fold ge in EVAL. - destruct (transl_function_correct _ _ _ _ _ EVAL - _ _ _ _ _ TR MINJ0 MATCH0 (val_nil_inject f)) - as [f1 [tm1 [tres [TEVAL [VINJ [MINJ1 [INCR MATCH1]]]]]]]. + exploit transl_function_correct; eauto. + intros [f1 [tm1 [tres [TEVAL [VINJ [MINJ1 [INCR MATCH1]]]]]]]. exists b; exists tfn; exists tm1. split. fold tge. rewrite <- FINDS. replace (prog_main prog) with (AST.prog_main tprog). fold ge. apply symbols_preserved. transitivity (AST.prog_main (program_of_program prog)). - apply transform_partial_program_main with (transl_function gce). assumption. + apply transform_partial_program_main with (transl_fundef gce). assumption. reflexivity. split. assumption. - split. rewrite <- SIG. apply sig_transl_function; auto. - rewrite (Genv.init_mem_transf_partial (transl_function gce) _ TRANSL). + split. rewrite <- SIG. apply sig_preserved; auto. + rewrite (Genv.init_mem_transf_partial (transl_fundef gce) _ TRANSL). inversion VINJ; subst tres. assumption. Qed. diff --git a/backend/Coloring.v b/backend/Coloring.v index 1a34a12..0a2487c 100644 --- a/backend/Coloring.v +++ b/backend/Coloring.v @@ -150,6 +150,12 @@ Definition add_edges_instr (add_interf_op res live (add_interf_call (Regset.remove res live) destroyed_at_call_regs g))) + | Ialloc arg res s => + add_pref_mreg arg loc_alloc_argument + (add_pref_mreg res loc_alloc_result + (add_interf_op res live + (add_interf_call + (Regset.remove res live) destroyed_at_call_regs g))) | Ireturn (Some r) => add_pref_mreg r (loc_result sig) g | _ => g diff --git a/backend/Coloringproof.v b/backend/Coloringproof.v index 39b208e..54d24cc 100644 --- a/backend/Coloringproof.v +++ b/backend/Coloringproof.v @@ -332,6 +332,10 @@ Proof. eapply graph_incl_trans; [idtac|apply add_pref_mreg_incl]. eapply graph_incl_trans; [idtac|apply add_interf_op_incl]. apply add_interf_call_incl. + eapply graph_incl_trans; [idtac|apply add_pref_mreg_incl]. + eapply graph_incl_trans; [idtac|apply add_pref_mreg_incl]. + eapply graph_incl_trans; [idtac|apply add_interf_op_incl]. + apply add_interf_call_incl. destruct o. apply add_pref_mreg_incl. apply graph_incl_refl. @@ -370,6 +374,15 @@ Definition correct_interf_instr /\ (forall r, Regset.mem r live = true -> r <> res -> interfere r res g) + | Ialloc arg res s => + (forall r mr, + Regset.mem r live = true -> + In mr destroyed_at_call_regs -> + r <> res -> + interfere_mreg r mr g) + /\ (forall r, + Regset.mem r live = true -> + r <> res -> interfere r res g) | _ => True end. @@ -389,6 +402,9 @@ Proof. intros [A B]. split. intros. eapply interfere_mreg_incl; eauto. intros. eapply interfere_incl; eauto. + intros [A B]. split. + intros. eapply interfere_mreg_incl; eauto. + intros. eapply interfere_incl; eauto. Qed. Lemma add_edges_instr_correct: @@ -417,6 +433,19 @@ Proof. eapply graph_incl_trans; [idtac|apply add_prefs_call_incl]. apply add_pref_mreg_incl. apply add_interf_op_correct; auto. + + split; intros. + apply interfere_mreg_incl with + (add_interf_call (Regset.remove r0 live) destroyed_at_call_regs g). + eapply graph_incl_trans; [idtac|apply add_pref_mreg_incl]. + eapply graph_incl_trans; [idtac|apply add_pref_mreg_incl]. + apply add_interf_op_incl. + apply add_interf_call_correct; auto. + rewrite Regset.mem_remove_other; auto. + + eapply interfere_incl. + eapply graph_incl_trans; apply add_pref_mreg_incl. + apply add_interf_op_correct; auto. Qed. Lemma add_edges_instrs_incl_aux: @@ -541,7 +570,7 @@ Proof. then false else true)). red. unfold OrderedRegReg.eq. unfold OrderedReg.eq. intros x y [EQ1 EQ2]. rewrite EQ1; rewrite EQ2; auto. - generalize (SetRegReg.for_all_2 H1 H H0). + generalize (SetRegReg.for_all_2 _ _ H1 H _ H0). simpl. case (Loc.eq (coloring r1) (coloring r2)); intro. intro; discriminate. auto. Qed. @@ -558,7 +587,7 @@ Proof. then false else true)). red. unfold OrderedRegMreg.eq. unfold OrderedReg.eq. intros x y [EQ1 EQ2]. rewrite EQ1; rewrite EQ2; auto. - generalize (SetRegMreg.for_all_2 H1 H H0). + generalize (SetRegMreg.for_all_2 _ _ H1 H _ H0). simpl. case (Loc.eq (coloring r1) (R mr2)); intro. intro; discriminate. auto. Qed. @@ -702,6 +731,14 @@ Definition correct_alloc_instr /\ (forall r, Regset.mem r live!!pc = true -> r <> res -> alloc r <> alloc res) + | Ialloc arg res s => + (forall r, + Regset.mem r live!!pc = true -> + r <> res -> + ~(In (alloc r) Conventions.destroyed_at_call)) + /\ (forall r, + Regset.mem r live!!pc = true -> + r <> res -> alloc r <> alloc res) | _ => True end. @@ -780,6 +817,14 @@ Proof. generalize (A r0 mr H IN H0). intro. generalize (ALL2 _ _ H2). contradiction. auto. + intros [A B]. split. + intros; red; intros. + unfold destroyed_at_call in H1. + generalize (list_in_map_inv R _ _ H1). + intros [mr [EQ IN]]. + generalize (A r1 mr H IN H0). intro. + generalize (ALL2 _ _ H2). contradiction. + auto. Qed. Lemma regalloc_correct_1: diff --git a/backend/Constprop.v b/backend/Constprop.v index b1c5a2b..3820311 100644 --- a/backend/Constprop.v +++ b/backend/Constprop.v @@ -195,7 +195,9 @@ Definition eval_static_operation (op: operation) (vl: list approx) := | Ofloatconst n, nil => F n | Oaddrsymbol s n, nil => S s n | Ocast8signed, I n1 :: nil => I(Int.cast8signed n) + | Ocast8unsigned, I n1 :: nil => I(Int.cast8unsigned n) | Ocast16signed, I n1 :: nil => I(Int.cast16signed n) + | Ocast16unsigned, I n1 :: nil => I(Int.cast16unsigned n) | Oadd, I n1 :: I n2 :: nil => I(Int.add n1 n2) | Oadd, S s1 n1 :: I n2 :: nil => S s1 (Int.add n1 n2) | Oaddimm n, I n1 :: nil => I (Int.add n1 n) @@ -379,6 +381,12 @@ Inductive eval_static_operation_cases: forall (op: operation) (vl: list approx), | eval_static_operation_case47: forall c vl, eval_static_operation_cases (Ocmp c) (vl) + | eval_static_operation_case48: + forall n1, + eval_static_operation_cases (Ocast8unsigned) (I n1 :: nil) + | eval_static_operation_case49: + forall n1, + eval_static_operation_cases (Ocast16unsigned) (I n1 :: nil) | eval_static_operation_default: forall (op: operation) (vl: list approx), eval_static_operation_cases op vl. @@ -475,6 +483,10 @@ Definition eval_static_operation_match (op: operation) (vl: list approx) := eval_static_operation_case46 n1 | Ocmp c, vl => eval_static_operation_case47 c vl + | Ocast8unsigned, I n1 :: nil => + eval_static_operation_case48 n1 + | Ocast16unsigned, I n1 :: nil => + eval_static_operation_case49 n1 | op, vl => eval_static_operation_default op vl end. @@ -574,6 +586,10 @@ Definition eval_static_operation (op: operation) (vl: list approx) := | None => Unknown | Some b => I(if b then Int.one else Int.zero) end + | eval_static_operation_case48 n1 => + I(Int.cast8unsigned n1) + | eval_static_operation_case49 n1 => + I(Int.cast16unsigned n1) | eval_static_operation_default op vl => Unknown end. @@ -603,6 +619,8 @@ Definition transfer (f: function) (pc: node) (before: D.t) := before | Icall sig ros args res s => D.set res Unknown before + | Ialloc arg res s => + D.set res Unknown before | Icond cond args ifso ifnot => before | Ireturn optarg => @@ -986,6 +1004,8 @@ Definition transf_instr (approx: D.t) (instr: instruction) := | inr s => ros end in Icall sig ros' args res s + | Ialloc arg res s => + Ialloc arg res s | Icond cond args s1 s2 => match eval_static_condition cond (approx_regs args approx) with | Some b => @@ -1028,5 +1048,7 @@ Definition transf_function (f: function) : function := (transf_code_wf f approxs f.(fn_code_wf)) end. +Definition transf_fundef := AST.transf_fundef transf_function. + Definition transf_program (p: program) : program := - transform_program transf_function p. + transform_program transf_fundef p. diff --git a/backend/Constpropproof.v b/backend/Constpropproof.v index 080aa74..38ba38b 100644 --- a/backend/Constpropproof.v +++ b/backend/Constpropproof.v @@ -6,6 +6,7 @@ Require Import AST. Require Import Integers. Require Import Floats. Require Import Values. +Require Import Events. Require Import Mem. Require Import Globalenvs. Require Import Op. @@ -144,11 +145,12 @@ Proof. case (eval_static_operation_match op al); intros; InvVLMA; simpl in *; FuncInv; try congruence. - replace v with v0. auto. congruence. - destruct (Genv.find_symbol ge s). exists b. intuition congruence. congruence. + rewrite <- H3. replace v0 with (Vint n1). reflexivity. congruence. + rewrite <- H3. replace v0 with (Vint n1). reflexivity. congruence. + exists b. split. auto. congruence. exists b. split. auto. congruence. exists b. split. auto. congruence. @@ -178,12 +180,17 @@ Proof. replace n2 with i0. destruct (Int.ltu i0 (Int.repr 32)). injection H0; intro; subst v. simpl. congruence. discriminate. congruence. + rewrite <- H3. replace v0 with (Vfloat n1). reflexivity. congruence. + caseEq (eval_static_condition c vl0). intros. generalize (eval_static_condition_correct _ _ _ _ H H1). intro. rewrite H2 in H0. destruct b; injection H0; intro; subst v; simpl; auto. intros; simpl; auto. + rewrite <- H3. replace v0 with (Vint n1). reflexivity. congruence. + rewrite <- H3. replace v0 with (Vint n1). reflexivity. congruence. + auto. Qed. @@ -193,8 +200,8 @@ Qed. the static approximation returned by the transfer function. *) Lemma transfer_correct: - forall f c sp pc rs m pc' rs' m' ra, - exec_instr ge c sp pc rs m pc' rs' m' -> + forall f c sp pc rs m t pc' rs' m' ra, + exec_instr ge c sp pc rs m t pc' rs' m' -> c = f.(fn_code) -> regs_match_approx ra rs -> regs_match_approx (transfer f pc ra) rs'. @@ -208,6 +215,8 @@ Proof. apply regs_match_approx_update; auto. simpl; auto. (* Icall *) apply regs_match_approx_update; auto. simpl; auto. + (* Ialloc *) + apply regs_match_approx_update; auto. simpl; auto. Qed. (** The correctness of the static analysis follows from the results @@ -217,8 +226,8 @@ Qed. Lemma analyze_correct_1: forall f approxs, analyze f = Some approxs -> - forall c sp pc rs m pc' rs' m', - exec_instr ge c sp pc rs m pc' rs' m' -> + forall c sp pc rs m t pc' rs' m', + exec_instr ge c sp pc rs m t pc' rs' m' -> c = f.(fn_code) -> regs_match_approx approxs!!pc rs -> regs_match_approx approxs!!pc' rs'. @@ -228,7 +237,7 @@ Proof. eapply DS.fixpoint_solution. unfold analyze in H. eexact H. elim (fn_code_wf f pc); intro. auto. - generalize (exec_instr_present _ _ _ _ _ _ _ _ _ H0). + generalize (exec_instr_present _ _ _ _ _ _ _ _ _ _ H0). rewrite H1. intro. contradiction. eapply successors_correct. rewrite <- H1. eauto. eapply transfer_correct; eauto. @@ -237,8 +246,8 @@ Qed. Lemma analyze_correct_2: forall f approxs, analyze f = Some approxs -> - forall c sp pc rs m pc' rs' m', - exec_instrs ge c sp pc rs m pc' rs' m' -> + forall c sp pc rs m t pc' rs' m', + exec_instrs ge c sp pc rs m t pc' rs' m' -> c = f.(fn_code) -> regs_match_approx approxs!!pc rs -> regs_match_approx approxs!!pc' rs'. @@ -638,19 +647,28 @@ Let tge := Genv.globalenv tprog. Lemma symbols_preserved: forall (s: ident), Genv.find_symbol tge s = Genv.find_symbol ge s. -Proof (Genv.find_symbol_transf transf_function prog). +Proof (Genv.find_symbol_transf transf_fundef prog). Lemma functions_translated: - forall (v: val) (f: RTL.function), + forall (v: val) (f: RTL.fundef), Genv.find_funct ge v = Some f -> - Genv.find_funct tge v = Some (transf_function f). -Proof (@Genv.find_funct_transf _ _ transf_function prog). + Genv.find_funct tge v = Some (transf_fundef f). +Proof (@Genv.find_funct_transf _ _ transf_fundef prog). Lemma function_ptr_translated: - forall (v: block) (f: RTL.function), + forall (v: block) (f: RTL.fundef), Genv.find_funct_ptr ge v = Some f -> - Genv.find_funct_ptr tge v = Some (transf_function f). -Proof (@Genv.find_funct_ptr_transf _ _ transf_function prog). + Genv.find_funct_ptr tge v = Some (transf_fundef f). +Proof (@Genv.find_funct_ptr_transf _ _ transf_fundef prog). + +Lemma sig_translated: + forall (f: RTL.fundef), + funsig (transf_fundef f) = funsig f. +Proof. + intro. case f; intros; simpl. + unfold transf_function. case (analyze f0); intros; reflexivity. + reflexivity. +Qed. (** The proof of semantic preservation is a simulation argument based on diagrams of the following form: @@ -676,30 +694,30 @@ Proof (@Genv.find_funct_ptr_transf _ _ transf_function prog). Definition exec_instr_prop (c: code) (sp: val) - (pc: node) (rs: regset) (m: mem) + (pc: node) (rs: regset) (m: mem) (t: trace) (pc': node) (rs': regset) (m': mem) : Prop := - exec_instr tge c sp pc rs m pc' rs' m' /\ + exec_instr tge c sp pc rs m t pc' rs' m' /\ forall f approxs (CF: c = f.(RTL.fn_code)) (ANL: analyze f = Some approxs) (MATCH: regs_match_approx ge approxs!!pc rs), - exec_instr tge (transf_code approxs c) sp pc rs m pc' rs' m'. + exec_instr tge (transf_code approxs c) sp pc rs m t pc' rs' m'. Definition exec_instrs_prop (c: code) (sp: val) - (pc: node) (rs: regset) (m: mem) + (pc: node) (rs: regset) (m: mem) (t: trace) (pc': node) (rs': regset) (m': mem) : Prop := - exec_instrs tge c sp pc rs m pc' rs' m' /\ + exec_instrs tge c sp pc rs m t pc' rs' m' /\ forall f approxs (CF: c = f.(RTL.fn_code)) (ANL: analyze f = Some approxs) (MATCH: regs_match_approx ge approxs!!pc rs), - exec_instrs tge (transf_code approxs c) sp pc rs m pc' rs' m'. + exec_instrs tge (transf_code approxs c) sp pc rs m t pc' rs' m'. Definition exec_function_prop - (f: RTL.function) (args: list val) (m: mem) + (f: RTL.fundef) (args: list val) (m: mem) (t: trace) (res: val) (m': mem) : Prop := - exec_function tge (transf_function f) args m res m'. + exec_function tge (transf_fundef f) args m t res m'. Ltac TransfInstr := match goal with @@ -716,9 +734,9 @@ Ltac TransfInstr := evaluation derivation of the original code. *) Lemma transf_funct_correct: - forall f args m res m', - exec_function ge f args m res m' -> - exec_function_prop f args m res m'. + forall f args m t res m', + exec_function ge f args m t res m' -> + exec_function_prop f args m t res m'. Proof. apply (exec_function_ind_3 ge exec_instr_prop exec_instrs_prop exec_function_prop); @@ -773,13 +791,13 @@ Proof. rewrite ASR; simpl. congruence. intro. eapply exec_Istore; eauto. (* Icall *) - assert (find_function tge ros rs = Some (transf_function f)). + assert (find_function tge ros rs = Some (transf_fundef f)). generalize H0; unfold find_function; destruct ros. apply functions_translated. rewrite symbols_preserved. destruct (Genv.find_symbol ge i). apply function_ptr_translated. congruence. - assert (sig = fn_sig (transf_function f)). - rewrite H1. unfold transf_function. destruct (analyze f); reflexivity. + assert (funsig (transf_fundef f) = sig). + generalize (sig_translated f). congruence. split; [idtac| intros; TransfInstr]. eapply exec_Icall; eauto. set (ros' := @@ -803,6 +821,11 @@ Proof. generalize H4. simpl. rewrite A. rewrite B. subst i0. rewrite Genv.find_funct_find_funct_ptr. auto. + (* Ialloc *) + split; [idtac|intros; TransfInstr]. + eapply exec_Ialloc; eauto. + intros. eapply exec_Ialloc; eauto. + (* Icond, true *) split; [idtac| intros; TransfInstr]. eapply exec_Icond_true; eauto. @@ -844,37 +867,38 @@ Proof. (* trans *) elim H0; intros. elim H2; intros. split. - apply exec_trans with pc2 rs2 m2; auto. - intros; apply exec_trans with pc2 rs2 m2. - eapply H4; eauto. eapply H6; eauto. - eapply analyze_correct_2; eauto. + apply exec_trans with t1 pc2 rs2 m2 t2; auto. + intros; apply exec_trans with t1 pc2 rs2 m2 t2. + eapply H5; eauto. eapply H7; eauto. + eapply analyze_correct_2; eauto. auto. - (* function *) + (* internal function *) elim H1; intros. - unfold transf_function. + simpl. unfold transf_function. caseEq (analyze f). intros approxs ANL. - eapply exec_funct; simpl; eauto. + eapply exec_funct_internal; simpl; eauto. eapply H5. reflexivity. auto. apply analyze_correct_3; auto. TransfInstr; auto. - intros. eapply exec_funct; eauto. + intros. eapply exec_funct_internal; eauto. + (* external function *) + unfold transf_function; simpl. apply exec_funct_external; auto. Qed. (** The preservation of the observable behavior of the program then follows. *) Theorem transf_program_correct: - forall (r: val), - exec_program prog r -> exec_program tprog r. + forall (t: trace) (r: val), + exec_program prog t r -> exec_program tprog t r. Proof. - intros r [b [f [m [SYMB [FIND [SIG EXEC]]]]]]. - red. exists b. exists (transf_function f). exists m. + intros t r [b [f [m [SYMB [FIND [SIG EXEC]]]]]]. + red. exists b. exists (transf_fundef f). exists m. split. change (prog_main tprog) with (prog_main prog). rewrite symbols_preserved. auto. split. apply function_ptr_translated; auto. - split. unfold transf_function. - rewrite <- SIG. destruct (analyze f); reflexivity. + split. generalize (sig_translated f). congruence. apply transf_funct_correct. unfold tprog, transf_program. rewrite Genv.init_mem_transf. exact EXEC. diff --git a/backend/Conventions.v b/backend/Conventions.v index 99cc933..5b4222d 100644 --- a/backend/Conventions.v +++ b/backend/Conventions.v @@ -19,12 +19,11 @@ Require Import Locations. of callee- and caller-save registers. *) -Definition destroyed_at_call_regs := - R3 :: R4 :: R5 :: R6 :: R7 :: R8 :: R9 :: R10 :: - F1 :: F2 :: F3 :: F4 :: F5 :: F6 :: F7 :: F8 :: F9 :: F10 :: nil. +Definition int_caller_save_regs := + R3 :: R4 :: R5 :: R6 :: R7 :: R8 :: R9 :: R10 :: nil. -Definition destroyed_at_call := - List.map R destroyed_at_call_regs. +Definition float_caller_save_regs := + F1 :: F2 :: F3 :: F4 :: F5 :: F6 :: F7 :: F8 :: F9 :: F10 :: nil. Definition int_callee_save_regs := R13 :: R14 :: R15 :: R16 :: R17 :: R18 :: R19 :: R20 :: R21 :: R22 :: @@ -34,6 +33,12 @@ Definition float_callee_save_regs := F14 :: F15 :: F16 :: F17 :: F18 :: F19 :: F20 :: F21 :: F22 :: F23 :: F24 :: F25 :: F26 :: F27 :: F28 :: F29 :: F30 :: F31 :: nil. +Definition destroyed_at_call_regs := + int_caller_save_regs ++ float_caller_save_regs. + +Definition destroyed_at_call := + List.map R destroyed_at_call_regs. + Definition temporaries := R IT1 :: R IT2 :: R IT3 :: R FT1 :: R FT2 :: R FT3 :: nil. @@ -298,6 +303,18 @@ Proof. simpl; OrEq. Qed. +(** The result location is not a callee-save register. *) + +Lemma loc_result_not_callee_save: + forall (s: signature), + ~(In (loc_result s) int_callee_save_regs \/ In (loc_result s) float_callee_save_regs). +Proof. + intros. generalize (loc_result_acceptable s). + generalize (int_callee_save_not_destroyed (loc_result s)). + generalize (float_callee_save_not_destroyed (loc_result s)). + tauto. +Qed. + (** ** Location of function arguments *) (** The PowerPC ABI states the following convention for passing arguments @@ -316,11 +333,6 @@ Qed. These conventions are somewhat baroque, but they are mandated by the ABI. *) -Definition drop1 (x: list mreg) := - match x with nil => nil | hd :: tl => tl end. -Definition drop2 (x: list mreg) := - match x with nil => nil | hd :: nil => nil | hd1 :: hd2 :: tl => tl end. - Fixpoint loc_arguments_rec (tyl: list typ) (iregl: list mreg) (fregl: list mreg) (ofs: Z) {struct tyl} : list loc := @@ -331,13 +343,13 @@ Fixpoint loc_arguments_rec | nil => S (Outgoing ofs Tint) | ireg :: _ => R ireg end :: - loc_arguments_rec tys (drop1 iregl) fregl (ofs + 1) + loc_arguments_rec tys (list_drop1 iregl) fregl (ofs + 1) | Tfloat :: tys => match fregl with | nil => S (Outgoing ofs Tfloat) | freg :: _ => R freg end :: - loc_arguments_rec tys (drop2 iregl) (drop1 fregl) (ofs + 2) + loc_arguments_rec tys (list_drop2 iregl) (list_drop1 fregl) (ofs + 2) end. Definition int_param_regs := @@ -374,18 +386,6 @@ Definition loc_argument_acceptable (l: loc) : Prop := | _ => False end. -Remark drop1_incl: - forall x l, In x (drop1 l) -> In x l. -Proof. - intros. destruct l. elim H. simpl in H. auto with coqlib. -Qed. -Remark drop2_incl: - forall x l, In x (drop2 l) -> In x l. -Proof. - intros. destruct l. elim H. destruct l. elim H. - simpl in H. auto with coqlib. -Qed. - Remark loc_arguments_rec_charact: forall tyl iregl fregl ofs l, In l (loc_arguments_rec tyl iregl fregl ofs) -> @@ -400,12 +400,12 @@ Proof. destruct a; elim H; intros. destruct iregl; subst l. omega. left; auto with coqlib. generalize (IHtyl _ _ _ _ H0). - destruct l. intros [A|B]. left; apply drop1_incl; auto. tauto. + destruct l. intros [A|B]. left; apply list_drop1_incl; auto. tauto. destruct s; try contradiction. omega. destruct fregl; subst l. omega. right; auto with coqlib. generalize (IHtyl _ _ _ _ H0). - destruct l. intros [A|B]. left; apply drop2_incl; auto. - right; apply drop1_incl; auto. + destruct l. intros [A|B]. left; apply list_drop2_incl; auto. + right; apply list_drop1_incl; auto. destruct s; try contradiction. omega. Qed. @@ -425,18 +425,6 @@ Hint Resolve loc_arguments_acceptable: locs. (** Arguments are parwise disjoint (in the sense of [Loc.norepet]). *) -Remark drop1_norepet: - forall l, list_norepet l -> list_norepet (drop1 l). -Proof. - intros. destruct l; simpl. constructor. inversion H. auto. -Qed. -Remark drop2_norepet: - forall l, list_norepet l -> list_norepet (drop2 l). -Proof. - intros. destruct l; simpl. constructor. - destruct l; simpl. constructor. inversion H. inversion H3. auto. -Qed. - Remark loc_arguments_rec_notin_reg: forall tyl iregl fregl ofs r, ~(In r iregl) -> ~(In r fregl) -> @@ -446,10 +434,10 @@ Proof. auto. destruct a; simpl; split. destruct iregl. auto. red; intro; subst m. apply H. auto with coqlib. - apply IHtyl. red; intro. apply H. apply drop1_incl; auto. auto. + apply IHtyl. red; intro. apply H. apply list_drop1_incl; auto. auto. destruct fregl. auto. red; intro; subst m. apply H0. auto with coqlib. - apply IHtyl. red; intro. apply H. apply drop2_incl; auto. - red; intro. apply H0. apply drop1_incl; auto. + apply IHtyl. red; intro. apply H. apply list_drop2_incl; auto. + red; intro. apply H0. apply list_drop1_incl; auto. Qed. Remark loc_arguments_rec_notin_local: @@ -494,16 +482,16 @@ Proof. apply loc_arguments_rec_notin_outgoing. simpl; omega. apply loc_arguments_rec_notin_reg. simpl. inversion H. auto. apply list_disjoint_notin with (m :: iregl); auto with coqlib. - apply IHtyl. apply drop1_norepet; auto. auto. - red; intros. apply H1. apply drop1_incl; auto. auto. + apply IHtyl. apply list_drop1_norepet; auto. auto. + red; intros. apply H1. apply list_drop1_incl; auto. auto. destruct fregl. apply loc_arguments_rec_notin_outgoing. simpl; omega. apply loc_arguments_rec_notin_reg. simpl. - red; intro. apply (H1 m m). apply drop2_incl; auto. + red; intro. apply (H1 m m). apply list_drop2_incl; auto. auto with coqlib. auto. simpl. inversion H0. auto. - apply IHtyl. apply drop2_norepet; auto. apply drop1_norepet; auto. - red; intros. apply H1. apply drop2_incl; auto. apply drop1_incl; auto. + apply IHtyl. apply list_drop2_norepet; auto. apply list_drop1_norepet; auto. + red; intros. apply H1. apply list_drop2_incl; auto. apply list_drop1_incl; auto. intro. unfold loc_arguments. apply H. unfold int_param_regs. NoRepet. @@ -601,11 +589,11 @@ Proof. destruct a; simpl; apply (f_equal2 (@cons typ)). destruct iregl. reflexivity. simpl. apply H. auto with coqlib. apply IHtyl. - intros. apply H. apply drop1_incl. auto. auto. + intros. apply H. apply list_drop1_incl. auto. auto. destruct fregl. reflexivity. simpl. apply H0. auto with coqlib. apply IHtyl. - intros. apply H. apply drop2_incl. auto. - intros. apply H0. apply drop1_incl. auto. + intros. apply H. apply list_drop2_incl. auto. + intros. apply H0. apply list_drop1_incl. auto. intros. unfold loc_arguments. apply H. intro; simpl. ElimOrEq; reflexivity. @@ -688,3 +676,30 @@ Proof. intros; simpl. tauto. Qed. +(** ** Location of arguments to external functions *) + +Definition loc_external_arguments (s: signature) : list mreg := + List.map + (fun l => match l with R r => r | S _ => IT1 end) + (loc_arguments s). + +Definition sig_external_ok (s: signature) : Prop := + forall sl, ~In (S sl) (loc_arguments s). + +Lemma loc_external_arguments_loc_arguments: + forall s, + sig_external_ok s -> + loc_arguments s = List.map R (loc_external_arguments s). +Proof. + intros. unfold loc_external_arguments. + rewrite list_map_compose. + transitivity (List.map (fun x => x) (loc_arguments s)). + symmetry; apply list_map_identity. + apply list_map_exten; intros. + destruct x. auto. elim (H _ H0). +Qed. + +(** ** Location of argument and result of dynamic allocation *) + +Definition loc_alloc_argument := R3. +Definition loc_alloc_result := R3. diff --git a/backend/Csharpminor.v b/backend/Csharpminor.v index 49fd3df..246ebf5 100644 --- a/backend/Csharpminor.v +++ b/backend/Csharpminor.v @@ -7,13 +7,14 @@ Require Import Integers. Require Import Floats. Require Import Values. Require Import Mem. +Require Import Events. Require Import Globalenvs. (** Abstract syntax *) -(** Cminor is a low-level imperative language structured in expressions, +(** Csharpminor is a low-level imperative language structured in expressions, statements, functions and programs. Expressions include - reading and writing local variables, reading and writing store locations, + reading global or local variables, reading store locations, arithmetic operations, function calls, and conditional expressions (similar to [e1 ? e2 : e3] in C). The [Elet] and [Eletvar] constructs enable sharing the computations of subexpressions. De Bruijn notation @@ -67,20 +68,20 @@ Inductive operation : Set := Inductive expr : Set := | Evar : ident -> expr (**r reading a scalar variable *) | Eaddrof : ident -> expr (**r taking the address of a variable *) - | Eassign : ident -> expr -> expr (**r assignment to a scalar variable *) | Eop : operation -> exprlist -> expr (**r arithmetic operation *) | Eload : memory_chunk -> expr -> expr (**r memory read *) - | Estore : memory_chunk -> expr -> expr -> expr (**r memory write *) | Ecall : signature -> expr -> exprlist -> expr (**r function call *) | Econdition : expr -> expr -> expr -> expr (**r conditional expression *) | Elet : expr -> expr -> expr (**r let binding *) | Eletvar : nat -> expr (**r reference to a let-bound variable *) + | Ealloc : expr -> expr (**r memory allocation *) with exprlist : Set := | Enil: exprlist | Econs: expr -> exprlist -> exprlist. -(** Statements include expression evaluation, an if/then/else conditional, +(** Statements include expression evaluation, variable assignment, + memory stores, an if/then/else conditional, infinite loops, blocks and early block exits, and early function returns. [Sexit n] terminates prematurely the execution of the [n+1] enclosing [Sblock] statements. *) @@ -88,6 +89,8 @@ with exprlist : Set := Inductive stmt : Set := | Sskip: stmt | Sexpr: expr -> stmt + | Sassign : ident -> expr -> stmt + | Sstore : memory_chunk -> expr -> expr -> stmt | Sseq: stmt -> stmt -> stmt | Sifthenelse: expr -> stmt -> stmt -> stmt | Sloop: stmt -> stmt @@ -117,12 +120,20 @@ Record function : Set := mkfunction { fn_body: stmt }. +Definition fundef := AST.fundef function. + Record program : Set := mkprogram { - prog_funct: list (ident * function); + prog_funct: list (ident * fundef); prog_main: ident; - prog_vars: list (ident * var_kind) + prog_vars: list (ident * var_kind * list init_data) }. +Definition funsig (fd: fundef) := + match fd with + | Internal f => f.(fn_sig) + | External ef => ef.(ef_sig) + end. + (** * Operational semantics *) (** The operational semantics for Csharpminor is given in big-step operational @@ -164,7 +175,7 @@ Fixpoint switch_target (n: int) (dfl: nat) (cases: list (int * nat)) - [env]: local environments, map local variables to memory blocks + var info; - [lenv]: let environments, map de Bruijn indices to values. *) -Definition genv := Genv.t function. +Definition genv := Genv.t fundef. Definition gvarenv := PTree.t var_kind. Definition env := PTree.t (block * var_kind). Definition empty_env : env := PTree.empty (block * var_kind). @@ -176,11 +187,11 @@ Definition sizeof (lv: var_kind) : Z := | Varray sz => Zmax 0 sz end. -Definition program_of_program (p: program): AST.program function := +Definition program_of_program (p: program): AST.program fundef := AST.mkprogram p.(prog_funct) p.(prog_main) - (List.map (fun id_vi => (fst id_vi, sizeof (snd id_vi))) p.(prog_vars)). + (List.map (fun x => match x with (id, k, init) => (id, init) end) p.(prog_vars)). Definition fn_variables (f: function) := List.map @@ -195,7 +206,7 @@ Definition fn_vars_names (f: function) := Definition global_var_env (p: program): gvarenv := List.fold_left - (fun gve id_vi => PTree.set (fst id_vi) (snd id_vi) gve) + (fun gve x => match x with (id, k, init) => PTree.set id k gve end) p.(prog_vars) (PTree.empty var_kind). (** Evaluation of operator applications. *) @@ -270,22 +281,6 @@ Definition eval_operation (op: operation) (vl: list val) (m: mem): option val := | _, _ => None end. -(** ``Casting'' a value to a memory chunk. The value is truncated and - zero- or sign-extended as dictated by the memory chunk. *) - -Definition cast (chunk: memory_chunk) (v: val) : option val := - match chunk, v with - | Mint8signed, Vint n => Some (Vint (Int.cast8signed n)) - | Mint8unsigned, Vint n => Some (Vint (Int.cast8unsigned n)) - | Mint16signed, Vint n => Some (Vint (Int.cast16signed n)) - | Mint16unsigned, Vint n => Some (Vint (Int.cast16unsigned n)) - | Mint32, Vint n => Some(Vint n) - | Mint32, Vptr b ofs => Some(Vptr b ofs) - | Mfloat32, Vfloat f => Some(Vfloat(Float.singleoffloat f)) - | Mfloat64, Vfloat f => Some(Vfloat f) - | _, _ => None - end. - (** Allocation of local variables at function entry. Each variable is bound to the reference to a fresh block of the appropriate size. *) @@ -312,10 +307,9 @@ Inductive bind_parameters: env -> forall e m, bind_parameters e m nil nil m | bind_parameters_cons: - forall e m id chunk params v1 v2 vl b m1 m2, + forall e m id chunk params v1 vl b m1 m2, PTree.get id e = Some (b, Vscalar chunk) -> - cast chunk v1 = Some v2 -> - Mem.store chunk m b 0 v2 = Some m1 -> + Mem.store chunk m b 0 v1 = Some m1 -> bind_parameters e m1 params vl m2 -> bind_parameters e m ((id, chunk) :: params) (v1 :: vl) m2. @@ -364,69 +358,64 @@ Inductive eval_var_ref: env -> ident -> block -> memory_chunk -> Prop := Inductive eval_expr: letenv -> env -> - mem -> expr -> mem -> val -> Prop := + mem -> expr -> trace -> mem -> val -> Prop := | eval_Evar: forall le e m id b chunk v, eval_var_ref e id b chunk -> Mem.load chunk m b 0 = Some v -> - eval_expr le e m (Evar id) m v - | eval_Eassign: - forall le e m id a m1 b chunk v1 v2 m2, - eval_expr le e m a m1 v1 -> - eval_var_ref e id b chunk -> - cast chunk v1 = Some v2 -> - Mem.store chunk m1 b 0 v2 = Some m2 -> - eval_expr le e m (Eassign id a) m2 v2 + eval_expr le e m (Evar id) E0 m v | eval_Eaddrof: forall le e m id b, eval_var_addr e id b -> - eval_expr le e m (Eaddrof id) m (Vptr b Int.zero) + eval_expr le e m (Eaddrof id) E0 m (Vptr b Int.zero) | eval_Eop: - forall le e m op al m1 vl v, - eval_exprlist le e m al m1 vl -> + forall le e m op al t m1 vl v, + eval_exprlist le e m al t m1 vl -> eval_operation op vl m1 = Some v -> - eval_expr le e m (Eop op al) m1 v + eval_expr le e m (Eop op al) t m1 v | eval_Eload: - forall le e m chunk a m1 v1 v, - eval_expr le e m a m1 v1 -> + forall le e m chunk a t m1 v1 v, + eval_expr le e m a t m1 v1 -> Mem.loadv chunk m1 v1 = Some v -> - eval_expr le e m (Eload chunk a) m1 v - | eval_Estore: - forall le e m chunk a b m1 v1 m2 v2 m3 v3, - eval_expr le e m a m1 v1 -> - eval_expr le e m1 b m2 v2 -> - cast chunk v2 = Some v3 -> - Mem.storev chunk m2 v1 v3 = Some m3 -> - eval_expr le e m (Estore chunk a b) m3 v3 + eval_expr le e m (Eload chunk a) t m1 v | eval_Ecall: - forall le e m sig a bl m1 m2 m3 vf vargs vres f, - eval_expr le e m a m1 vf -> - eval_exprlist le e m1 bl m2 vargs -> + forall le e m sig a bl t1 m1 t2 m2 t3 m3 vf vargs vres f t, + eval_expr le e m a t1 m1 vf -> + eval_exprlist le e m1 bl t2 m2 vargs -> Genv.find_funct ge vf = Some f -> - f.(fn_sig) = sig -> - eval_funcall m2 f vargs m3 vres -> - eval_expr le e m (Ecall sig a bl) m3 vres + funsig f = sig -> + eval_funcall m2 f vargs t3 m3 vres -> + t = t1 ** t2 ** t3 -> + eval_expr le e m (Ecall sig a bl) t m3 vres | eval_Econdition_true: - forall le e m a b c m1 v1 m2 v2, - eval_expr le e m a m1 v1 -> + forall le e m a b c t1 m1 v1 t2 m2 v2 t, + eval_expr le e m a t1 m1 v1 -> Val.is_true v1 -> - eval_expr le e m1 b m2 v2 -> - eval_expr le e m (Econdition a b c) m2 v2 + eval_expr le e m1 b t2 m2 v2 -> + t = t1 ** t2 -> + eval_expr le e m (Econdition a b c) t m2 v2 | eval_Econdition_false: - forall le e m a b c m1 v1 m2 v2, - eval_expr le e m a m1 v1 -> + forall le e m a b c t1 m1 v1 t2 m2 v2 t, + eval_expr le e m a t1 m1 v1 -> Val.is_false v1 -> - eval_expr le e m1 c m2 v2 -> - eval_expr le e m (Econdition a b c) m2 v2 + eval_expr le e m1 c t2 m2 v2 -> + t = t1 ** t2 -> + eval_expr le e m (Econdition a b c) t m2 v2 | eval_Elet: - forall le e m a b m1 v1 m2 v2, - eval_expr le e m a m1 v1 -> - eval_expr (v1::le) e m1 b m2 v2 -> - eval_expr le e m (Elet a b) m2 v2 + forall le e m a b t1 m1 v1 t2 m2 v2 t, + eval_expr le e m a t1 m1 v1 -> + eval_expr (v1::le) e m1 b t2 m2 v2 -> + t = t1 ** t2 -> + eval_expr le e m (Elet a b) t m2 v2 | eval_Eletvar: forall le e m n v, nth_error le n = Some v -> - eval_expr le e m (Eletvar n) m v + eval_expr le e m (Eletvar n) E0 m v + | eval_Ealloc: + forall le e m a t m1 n m2 b, + eval_expr le e m a t m1 (Vint n) -> + Mem.alloc m1 0 (Int.signed n) = (m2, b) -> + eval_expr le e m (Ealloc a) t m2 (Vptr b Int.zero) (** Evaluation of a list of expressions: [eval_exprlist prg le al m a m' vl] @@ -437,32 +426,37 @@ Inductive eval_expr: with eval_exprlist: letenv -> env -> - mem -> exprlist -> + mem -> exprlist -> trace -> mem -> list val -> Prop := | eval_Enil: forall le e m, - eval_exprlist le e m Enil m nil + eval_exprlist le e m Enil E0 m nil | eval_Econs: - forall le e m a bl m1 v m2 vl, - eval_expr le e m a m1 v -> - eval_exprlist le e m1 bl m2 vl -> - eval_exprlist le e m (Econs a bl) m2 (v :: vl) + forall le e m a bl t1 m1 v t2 m2 vl t, + eval_expr le e m a t1 m1 v -> + eval_exprlist le e m1 bl t2 m2 vl -> + t = t1 ** t2 -> + eval_exprlist le e m (Econs a bl) t m2 (v :: vl) (** Evaluation of a function invocation: [eval_funcall prg m f args m' res] means that the function [f], applied to the arguments [args] in memory state [m], returns the value [res] in modified memory state [m']. *) with eval_funcall: - mem -> function -> list val -> + mem -> fundef -> list val -> trace -> mem -> val -> Prop := - | eval_funcall_intro: - forall m f vargs e m1 lb m2 m3 out vres, + | eval_funcall_internal: + forall m f vargs e m1 lb m2 t m3 out vres, list_norepet (fn_params_names f ++ fn_vars_names f) -> alloc_variables empty_env m (fn_variables f) e m1 lb -> bind_parameters e m1 f.(fn_params) vargs m2 -> - exec_stmt e m2 f.(fn_body) m3 out -> + exec_stmt e m2 f.(fn_body) t m3 out -> outcome_result_value out f.(fn_sig).(sig_res) vres -> - eval_funcall m f vargs (Mem.free_list m3 lb) vres + eval_funcall m (Internal f) vargs t (Mem.free_list m3 lb) vres + | eval_funcall_external: + forall m ef vargs t vres, + event_match ef vargs t vres -> + eval_funcall m (External ef) vargs t m vres (** Execution of a statement: [exec_stmt prg e m s m' out] means that statement [s] executes with outcome [out]. @@ -470,66 +464,83 @@ with eval_funcall: with exec_stmt: env -> - mem -> stmt -> + mem -> stmt -> trace -> mem -> outcome -> Prop := | exec_Sskip: forall e m, - exec_stmt e m Sskip m Out_normal + exec_stmt e m Sskip E0 m Out_normal | exec_Sexpr: - forall e m a m1 v, - eval_expr nil e m a m1 v -> - exec_stmt e m (Sexpr a) m1 Out_normal + forall e m a t m1 v, + eval_expr nil e m a t m1 v -> + exec_stmt e m (Sexpr a) t m1 Out_normal + | eval_Sassign: + forall e m id a t m1 b chunk v m2, + eval_expr nil e m a t m1 v -> + eval_var_ref e id b chunk -> + Mem.store chunk m1 b 0 v = Some m2 -> + exec_stmt e m (Sassign id a) t m2 Out_normal + | eval_Sstore: + forall e m chunk a b t1 m1 v1 t2 m2 v2 t3 m3, + eval_expr nil e m a t1 m1 v1 -> + eval_expr nil e m1 b t2 m2 v2 -> + Mem.storev chunk m2 v1 v2 = Some m3 -> + t3 = t1 ** t2 -> + exec_stmt e m (Sstore chunk a b) t3 m3 Out_normal | exec_Sseq_continue: - forall e m s1 s2 m1 m2 out, - exec_stmt e m s1 m1 Out_normal -> - exec_stmt e m1 s2 m2 out -> - exec_stmt e m (Sseq s1 s2) m2 out + forall e m s1 s2 t1 t2 m1 m2 t out, + exec_stmt e m s1 t1 m1 Out_normal -> + exec_stmt e m1 s2 t2 m2 out -> + t = t1 ** t2 -> + exec_stmt e m (Sseq s1 s2) t m2 out | exec_Sseq_stop: - forall e m s1 s2 m1 out, - exec_stmt e m s1 m1 out -> + forall e m s1 s2 t1 m1 out, + exec_stmt e m s1 t1 m1 out -> out <> Out_normal -> - exec_stmt e m (Sseq s1 s2) m1 out + exec_stmt e m (Sseq s1 s2) t1 m1 out | exec_Sifthenelse_true: - forall e m a sl1 sl2 m1 v1 m2 out, - eval_expr nil e m a m1 v1 -> + forall e m a sl1 sl2 t1 m1 v1 t2 m2 out t, + eval_expr nil e m a t1 m1 v1 -> Val.is_true v1 -> - exec_stmt e m1 sl1 m2 out -> - exec_stmt e m (Sifthenelse a sl1 sl2) m2 out + exec_stmt e m1 sl1 t2 m2 out -> + t = t1 ** t2 -> + exec_stmt e m (Sifthenelse a sl1 sl2) t m2 out | exec_Sifthenelse_false: - forall e m a sl1 sl2 m1 v1 m2 out, - eval_expr nil e m a m1 v1 -> + forall e m a sl1 sl2 t1 m1 v1 t2 m2 out t, + eval_expr nil e m a t1 m1 v1 -> Val.is_false v1 -> - exec_stmt e m1 sl2 m2 out -> - exec_stmt e m (Sifthenelse a sl1 sl2) m2 out + exec_stmt e m1 sl2 t2 m2 out -> + t = t1 ** t2 -> + exec_stmt e m (Sifthenelse a sl1 sl2) t m2 out | exec_Sloop_loop: - forall e m sl m1 m2 out, - exec_stmt e m sl m1 Out_normal -> - exec_stmt e m1 (Sloop sl) m2 out -> - exec_stmt e m (Sloop sl) m2 out + forall e m sl t1 m1 t2 m2 out t, + exec_stmt e m sl t1 m1 Out_normal -> + exec_stmt e m1 (Sloop sl) t2 m2 out -> + t = t1 ** t2 -> + exec_stmt e m (Sloop sl) t m2 out | exec_Sloop_stop: - forall e m sl m1 out, - exec_stmt e m sl m1 out -> + forall e m sl t1 m1 out, + exec_stmt e m sl t1 m1 out -> out <> Out_normal -> - exec_stmt e m (Sloop sl) m1 out + exec_stmt e m (Sloop sl) t1 m1 out | exec_Sblock: - forall e m sl m1 out, - exec_stmt e m sl m1 out -> - exec_stmt e m (Sblock sl) m1 (outcome_block out) + forall e m sl t1 m1 out, + exec_stmt e m sl t1 m1 out -> + exec_stmt e m (Sblock sl) t1 m1 (outcome_block out) | exec_Sexit: forall e m n, - exec_stmt e m (Sexit n) m (Out_exit n) + exec_stmt e m (Sexit n) E0 m (Out_exit n) | exec_Sswitch: - forall e m a cases default m1 n, - eval_expr nil e m a m1 (Vint n) -> + forall e m a cases default t1 m1 n, + eval_expr nil e m a t1 m1 (Vint n) -> exec_stmt e m (Sswitch a cases default) - m1 (Out_exit (switch_target n default cases)) + t1 m1 (Out_exit (switch_target n default cases)) | exec_Sreturn_none: forall e m, - exec_stmt e m (Sreturn None) m (Out_return None) + exec_stmt e m (Sreturn None) E0 m (Out_return None) | exec_Sreturn_some: - forall e m a m1 v, - eval_expr nil e m a m1 v -> - exec_stmt e m (Sreturn (Some a)) m1 (Out_return (Some v)). + forall e m a t1 m1 v, + eval_expr nil e m a t1 m1 v -> + exec_stmt e m (Sreturn (Some a)) t1 m1 (Out_return (Some v)). Scheme eval_expr_ind4 := Minimality for eval_expr Sort Prop with eval_exprlist_ind4 := Minimality for eval_exprlist Sort Prop @@ -542,12 +553,11 @@ End RELSEM. holds if the application of [p]'s main function to no arguments in the initial memory state for [p] eventually returns value [r]. *) -Definition exec_program (p: program) (r: val) : Prop := +Definition exec_program (p: program) (t: trace) (r: val) : Prop := let ge := Genv.globalenv (program_of_program p) in let m0 := Genv.init_mem (program_of_program p) in exists b, exists f, exists m, Genv.find_symbol ge p.(prog_main) = Some b /\ Genv.find_funct_ptr ge b = Some f /\ - f.(fn_sig) = mksignature nil (Some Tint) /\ - eval_funcall p m0 f nil m r. - + funsig f = mksignature nil (Some Tint) /\ + eval_funcall p m0 f nil t m r. diff --git a/backend/Events.v b/backend/Events.v new file mode 100644 index 0000000..a0559fd --- /dev/null +++ b/backend/Events.v @@ -0,0 +1,103 @@ +(** Representation of (traces of) observable events. *) + +Require Import Coqlib. +Require Import AST. +Require Import Integers. +Require Import Floats. +Require Import Values. + +Inductive eventval: Set := + | EVint: int -> eventval + | EVfloat: float -> eventval. + +Parameter trace: Set. +Parameter E0: trace. +Parameter Eextcall: ident -> list eventval -> eventval -> trace. +Parameter Eapp: trace -> trace -> trace. + +Infix "**" := Eapp (at level 60, right associativity). + +Axiom E0_left: forall t, E0 ** t = t. +Axiom E0_right: forall t, t ** E0 = t. +Axiom Eapp_assoc: forall t1 t2 t3, (t1 ** t2) ** t3 = t1 ** (t2 ** t3). + +Hint Rewrite E0_left E0_right Eapp_assoc: trace_rewrite. + +Ltac substTraceHyp := + match goal with + | [ H: (@eq trace ?x ?y) |- _ ] => + subst x || clear H + end. + +Ltac decomposeTraceEq := + match goal with + | [ |- (_ ** _) = (_ ** _) ] => + apply (f_equal2 Eapp); auto; decomposeTraceEq + | _ => + auto + end. + +Ltac traceEq := + repeat substTraceHyp; autorewrite with trace_rewrite; decomposeTraceEq. + +Inductive eventval_match: eventval -> typ -> val -> Prop := + | ev_match_int: + forall i, eventval_match (EVint i) Tint (Vint i) + | ev_match_float: + forall f, eventval_match (EVfloat f) Tfloat (Vfloat f). + +Inductive eventval_list_match: list eventval -> list typ -> list val -> Prop := + | evl_match_nil: + eventval_list_match nil nil nil + | evl_match_cons: + forall ev1 evl ty1 tyl v1 vl, + eventval_match ev1 ty1 v1 -> + eventval_list_match evl tyl vl -> + eventval_list_match (ev1::evl) (ty1::tyl) (v1::vl). + +Inductive event_match: + external_function -> list val -> trace -> val -> Prop := + event_match_intro: + forall ef vargs vres eargs eres, + eventval_list_match eargs (sig_args ef.(ef_sig)) vargs -> + eventval_match eres (proj_sig_res ef.(ef_sig)) vres -> + event_match ef vargs (Eextcall ef.(ef_id) eargs eres) vres. + +Require Import Mem. + +Section EVENT_MATCH_INJECT. + +Variable f: meminj. + +Remark eventval_match_inject: + forall ev ty v1, eventval_match ev ty v1 -> + forall v2, val_inject f v1 v2 -> + eventval_match ev ty v2. +Proof. + induction 1; intros; inversion H; constructor. +Qed. + +Remark eventval_list_match_inject: + forall evl tyl vl1, eventval_list_match evl tyl vl1 -> + forall vl2, val_list_inject f vl1 vl2 -> + eventval_list_match evl tyl vl2. +Proof. + induction 1; intros. + inversion H; constructor. + inversion H1; constructor. + eapply eventval_match_inject; eauto. + eauto. +Qed. + +Lemma event_match_inject: + forall ef args1 t res args2, + event_match ef args1 t res -> + val_list_inject f args1 args2 -> + event_match ef args2 t res /\ val_inject f res res. +Proof. + intros. inversion H; subst. + split. constructor. eapply eventval_list_match_inject; eauto. auto. + inversion H2; constructor. +Qed. + +End EVENT_MATCH_INJECT. diff --git a/backend/Globalenvs.v b/backend/Globalenvs.v index 55afc35..036fd8f 100644 --- a/backend/Globalenvs.v +++ b/backend/Globalenvs.v @@ -70,15 +70,20 @@ Module Type GENV. (forall id f, In (id, f) (prog_funct p) -> P f) -> find_funct (globalenv p) v = Some f -> P f. + Hypothesis find_funct_ptr_symbol_inversion: + forall (F: Set) (p: program F) (id: ident) (b: block) (f: F), + find_symbol (globalenv p) id = Some b -> + find_funct_ptr (globalenv p) b = Some f -> + In (id, f) p.(prog_funct). + Hypothesis initmem_nullptr: forall (F: Set) (p: program F), let m := init_mem p in valid_block m nullptr /\ m.(blocks) nullptr = empty_block 0 0. - Hypothesis initmem_undef: + Hypothesis initmem_block_init: forall (F: Set) (p: program F) (b: block), - exists lo, exists hi, - (init_mem p).(blocks) b = empty_block lo hi. + exists id, (init_mem p).(blocks) b = block_init_data id. Hypothesis find_funct_ptr_inv: forall (F: Set) (p: program F) (b: block) (f: F), find_funct_ptr (globalenv p) b = Some f -> b < 0. @@ -206,12 +211,12 @@ Definition add_functs (init: genv) (fns: list (ident * funct)) : genv := List.fold_right add_funct init fns. Definition add_globals - (init: genv * mem) (vars: list (ident * Z)) : genv * mem := + (init: genv * mem) (vars: list (ident * list init_data)) : genv * mem := List.fold_right - (fun (id_sz: ident * Z) (g_st: genv * mem) => - let (id, sz) := id_sz in + (fun (id_init: ident * list init_data) (g_st: genv * mem) => + let (id, init) := id_init in let (g, st) := g_st in - let (st', b) := Mem.alloc st 0 sz in + let (st', b) := Mem.alloc_init_data st init in (add_symbol id b g, st')) init vars. @@ -229,7 +234,7 @@ Lemma functions_globalenv: forall (p: program funct), functions (globalenv p) = functions (add_functs empty p.(prog_funct)). Proof. - assert (forall (init: genv * mem) (vars: list (ident * Z)), + assert (forall init vars, functions (fst (add_globals init vars)) = functions (fst init)). induction vars; simpl. reflexivity. @@ -248,11 +253,11 @@ Lemma initmem_nullptr: m.(blocks) nullptr = mkblock 0 0 (fun y => Undef) (undef_undef_outside 0 0). Proof. assert - (forall (init: genv * mem), + (forall init, let m1 := snd init in 0 < m1.(nextblock) -> m1.(blocks) nullptr = mkblock 0 0 (fun y => Undef) (undef_undef_outside 0 0) -> - forall (vars: list (ident * Z)), + forall vars, let m2 := snd (add_globals init vars) in 0 < m2.(nextblock) /\ m2.(blocks) nullptr = mkblock 0 0 (fun y => Undef) (undef_undef_outside 0 0)). @@ -268,23 +273,21 @@ Proof. unfold valid_block. apply H. simpl. omega. reflexivity. Qed. -Lemma initmem_undef: +Lemma initmem_block_init: forall (p: program funct) (b: block), - exists lo, exists hi, - (init_mem p).(blocks) b = empty_block lo hi. + exists id, (init_mem p).(blocks) b = block_init_data id. Proof. assert (forall g0 vars g1 m b, add_globals (g0, Mem.empty) vars = (g1, m) -> - exists lo, exists hi, - m.(blocks) b = empty_block lo hi). + exists id, m.(blocks) b = block_init_data id). induction vars; simpl. intros. inversion H. unfold Mem.empty; simpl. - exists 0; exists 0. auto. + exists (@nil init_data). symmetry. apply Mem.block_init_data_empty. destruct a. caseEq (add_globals (g0, Mem.empty) vars). intros g1 m1 EQ. intros g m b EQ1. injection EQ1; intros EQ2 EQ3; clear EQ1. rewrite <- EQ2; simpl. unfold update. case (zeq b (nextblock m1)); intro. - exists 0; exists z; auto. + exists l; auto. eauto. intros. caseEq (globalenv_initmem p). intros g m EQ. unfold init_mem; rewrite EQ; simpl. @@ -372,6 +375,59 @@ Proof. intros. eapply find_funct_ptr_prop; eauto. Qed. +Lemma find_funct_ptr_symbol_inversion: + forall (F: Set) (p: program F) (id: ident) (b: block) (f: F), + find_symbol (globalenv p) id = Some b -> + find_funct_ptr (globalenv p) b = Some f -> + In (id, f) p.(prog_funct). +Proof. + intros until f. + assert (forall fns, + let g := add_functs (empty F) fns in + PTree.get id g.(symbols) = Some b -> + b > g.(nextfunction)). + induction fns; simpl. + rewrite PTree.gempty. congruence. + rewrite PTree.gsspec. case (peq id (fst a)); intro. + intro EQ. inversion EQ. unfold Zpred. omega. + intros. generalize (IHfns H). unfold Zpred; omega. + assert (forall fns, + let g := add_functs (empty F) fns in + PTree.get id g.(symbols) = Some b -> + ZMap.get b g.(functions) = Some f -> + In (id, f) fns). + induction fns; simpl. + rewrite ZMap.gi. congruence. + set (g := add_functs (empty F) fns). + rewrite PTree.gsspec. rewrite ZMap.gsspec. + case (peq id (fst a)); intro. + intro EQ. inversion EQ. unfold ZIndexed.eq. rewrite zeq_true. + intro EQ2. left. destruct a. simpl in *. congruence. + intro. unfold ZIndexed.eq. rewrite zeq_false. intro. eauto. + generalize (H _ H0). fold g. unfold block. omega. + assert (forall g0 m0, b < 0 -> + forall vars g m, + @add_globals F (g0, m0) vars = (g, m) -> + PTree.get id g.(symbols) = Some b -> + PTree.get id g0.(symbols) = Some b). + induction vars; simpl. + intros. inversion H2. auto. + destruct a. caseEq (add_globals (g0, m0) vars). + intros g1 m1 EQ g m EQ1. injection EQ1; simpl; clear EQ1. + unfold add_symbol; intros A B. rewrite <- B. simpl. + rewrite PTree.gsspec. case (peq id i); intros. + assert (b > 0). injection H2; intros. rewrite <- H3. apply nextblock_pos. + omegaContradiction. + eauto. + intros. + generalize (find_funct_ptr_inv _ _ H3). intro. + pose (g := add_functs (empty F) (prog_funct p)). + apply H0. + apply H1 with Mem.empty (prog_vars p) (globalenv p) (init_mem p). + auto. unfold globalenv, init_mem. rewrite <- surjective_pairing. + reflexivity. assumption. rewrite <- functions_globalenv. assumption. +Qed. + (* Global environments and program transformations. *) Section TRANSF_PROGRAM_PARTIAL. @@ -420,7 +476,7 @@ Proof. Qed. Lemma mem_add_globals_transf: - forall (g1: genv A) (g2: genv B) (m: mem) (vars: list (ident * Z)), + forall (g1: genv A) (g2: genv B) (m: mem) (vars: list (ident * list init_data)), snd (add_globals (g1, m) vars) = snd (add_globals (g2, m) vars). Proof. induction vars; simpl. @@ -433,7 +489,7 @@ Qed. Lemma symbols_add_globals_transf: forall (g1: genv A) (g2: genv B) (m: mem), symbols g1 = symbols g2 -> - forall (vars: list (ident * Z)), + forall (vars: list (ident * list init_data)), symbols (fst (add_globals (g1, m) vars)) = symbols (fst (add_globals (g2, m) vars)). Proof. diff --git a/backend/InterfGraph.v b/backend/InterfGraph.v index 37248f5..78112c3 100644 --- a/backend/InterfGraph.v +++ b/backend/InterfGraph.v @@ -1,7 +1,8 @@ (** Representation of interference graphs for register allocation. *) Require Import Coqlib. -Require Import FSet. +Require Import FSets. +Require Import FSetAVL. Require Import Maps. Require Import Ordered. Require Import Registers. @@ -39,10 +40,14 @@ Module OrderedRegReg := OrderedPair(OrderedReg)(OrderedReg). Module OrderedMreg := OrderedIndexed(IndexedMreg). Module OrderedRegMreg := OrderedPair(OrderedReg)(OrderedMreg). +(* Module SetDepRegReg := FSetAVL.Make(OrderedRegReg). Module SetRegReg := NodepOfDep(SetDepRegReg). Module SetDepRegMreg := FSetAVL.Make(OrderedRegMreg). Module SetRegMreg := NodepOfDep(SetDepRegMreg). +*) +Module SetRegReg := FSetAVL.Make(OrderedRegReg). +Module SetRegMreg := FSetAVL.Make(OrderedRegMreg). Record graph: Set := mkgraph { interf_reg_reg: SetRegReg.t; @@ -197,12 +202,15 @@ Qed. (** [all_interf_regs g] returns the set of pseudo-registers that are nodes of [g]. *) +Definition add_intf2 (r1r2: reg * reg) (u: Regset.t) : Regset.t := + Regset.add (fst r1r2) (Regset.add (snd r1r2) u). +Definition add_intf1 (r1m2: reg * mreg) (u: Regset.t) : Regset.t := + Regset.add (fst r1m2) u. + Definition all_interf_regs (g: graph) : Regset.t := - SetRegReg.fold - (fun r1r2 u => Regset.add (fst r1r2) (Regset.add (snd r1r2) u)) + SetRegReg.fold _ add_intf2 g.(interf_reg_reg) - (SetRegMreg.fold - (fun r1m2 u => Regset.add (fst r1m2) u) + (SetRegMreg.fold _ add_intf1 g.(interf_reg_mreg) Regset.empty). @@ -215,53 +223,63 @@ Proof. rewrite Regset.mem_add_other; auto. Qed. -Lemma all_interf_regs_correct_aux_1: - forall l u r, - Regset.mem r u = true -> - Regset.mem r - (List.fold_right - (fun r1r2 u => Regset.add (fst r1r2) (Regset.add (snd r1r2) u)) - u l) = true. +Lemma in_setregreg_fold: + forall g r1 r2 u, + SetRegReg.In (r1, r2) g \/ Regset.mem r1 u = true /\ Regset.mem r2 u = true -> + Regset.mem r1 (SetRegReg.fold _ add_intf2 g u) = true /\ + Regset.mem r2 (SetRegReg.fold _ add_intf2 g u) = true. Proof. - induction l; simpl; intros. - auto. - apply mem_add_tail. apply mem_add_tail. auto. + set (add_intf2' := fun u r1r2 => add_intf2 r1r2 u). + assert (forall l r1 r2 u, + InA OrderedRegReg.eq (r1,r2) l \/ Regset.mem r1 u = true /\ Regset.mem r2 u = true -> + Regset.mem r1 (List.fold_left add_intf2' l u) = true /\ + Regset.mem r2 (List.fold_left add_intf2' l u) = true). + induction l; intros; simpl. + elim H; intro. inversion H0. auto. + apply IHl. destruct a as [a1 a2]. + elim H; intro. inversion H0; subst. + red in H2. simpl in H2. destruct H2. red in H1. red in H2. subst r1 r2. + right; unfold add_intf2', add_intf2; simpl; split. + apply Regset.mem_add_same. apply mem_add_tail. apply Regset.mem_add_same. + tauto. + right; unfold add_intf2', add_intf2; simpl; split; + apply mem_add_tail; apply mem_add_tail; tauto. + + intros. rewrite SetRegReg.fold_1. apply H. + intuition. left. apply SetRegReg.elements_1. auto. Qed. -Lemma all_interf_regs_correct_aux_2: - forall l u r1 r2, - InList OrderedRegReg.eq (r1, r2) l -> - let u' := - List.fold_right - (fun r1r2 u => Regset.add (fst r1r2) (Regset.add (snd r1r2) u)) - u l in - Regset.mem r1 u' = true /\ Regset.mem r2 u' = true. +Lemma in_setregreg_fold': + forall g r u, + Regset.mem r u = true -> + Regset.mem r (SetRegReg.fold _ add_intf2 g u) = true. Proof. - induction l; simpl; intros. - inversion H. - inversion H. elim H1. simpl. unfold OrderedReg.eq. - intros; subst r1; subst r2. - split. apply Regset.mem_add_same. - apply mem_add_tail. apply Regset.mem_add_same. - generalize (IHl u r1 r2 H1). intros [A B]. - split; repeat rewrite mem_add_tail; auto. + intros. exploit in_setregreg_fold. eauto. + intros [A B]. eauto. Qed. -Lemma all_interf_regs_correct_aux_3: - forall l u r1 r2, - InList OrderedRegMreg.eq (r1, r2) l -> - let u' := - List.fold_right - (fun r1r2 u => Regset.add (fst r1r2) u) - u l in - Regset.mem r1 u' = true. +Lemma in_setregmreg_fold: + forall g r1 mr2 u, + SetRegMreg.In (r1, mr2) g \/ Regset.mem r1 u = true -> + Regset.mem r1 (SetRegMreg.fold _ add_intf1 g u) = true. Proof. - induction l; simpl; intros. - inversion H. - inversion H. elim H1. simpl. unfold OrderedReg.eq. - intros; subst r1. + set (add_intf1' := fun u r1mr2 => add_intf1 r1mr2 u). + assert (forall l r1 mr2 u, + InA OrderedRegMreg.eq (r1,mr2) l \/ Regset.mem r1 u = true -> + Regset.mem r1 (List.fold_left add_intf1' l u) = true). + induction l; intros; simpl. + elim H; intro. inversion H0. auto. + apply IHl with mr2. destruct a as [a1 a2]. + elim H; intro. inversion H0; subst. + red in H2. simpl in H2. destruct H2. red in H1. red in H2. subst r1 mr2. + right; unfold add_intf1', add_intf1; simpl. apply Regset.mem_add_same. - apply mem_add_tail. apply IHl with r2. auto. + tauto. + right; unfold add_intf1', add_intf1; simpl. + apply mem_add_tail; auto. + + intros. rewrite SetRegMreg.fold_1. apply H with mr2. + intuition. left. apply SetRegMreg.elements_1. auto. Qed. Lemma all_interf_regs_correct_1: @@ -271,16 +289,7 @@ Lemma all_interf_regs_correct_1: Regset.mem r2 (all_interf_regs g) = true. Proof. intros. unfold all_interf_regs. - generalize (SetRegReg.fold_1 - g.(interf_reg_reg) - (SetRegMreg.fold - (fun (r1m2 : SetDepRegMreg.elt) (u : Regset.t) => - Regset.add (fst r1m2) u) (interf_reg_mreg g) Regset.empty) - (fun (r1r2 : SetDepRegReg.elt) (u : Regset.t) => - Regset.add (fst r1r2) (Regset.add (snd r1r2) u))). - intros [l [UN [INEQ EQ]]]. - rewrite EQ. apply all_interf_regs_correct_aux_2. - elim (INEQ (r1, r2)); intros. auto. + apply in_setregreg_fold. tauto. Qed. Lemma all_interf_regs_correct_2: @@ -289,22 +298,6 @@ Lemma all_interf_regs_correct_2: Regset.mem r1 (all_interf_regs g) = true. Proof. intros. unfold all_interf_regs. - generalize (SetRegReg.fold_1 - g.(interf_reg_reg) - (SetRegMreg.fold - (fun (r1m2 : SetDepRegMreg.elt) (u : Regset.t) => - Regset.add (fst r1m2) u) (interf_reg_mreg g) Regset.empty) - (fun (r1r2 : SetDepRegReg.elt) (u : Regset.t) => - Regset.add (fst r1r2) (Regset.add (snd r1r2) u))). - intros [l [UN [INEQ EQ]]]. - rewrite EQ. apply all_interf_regs_correct_aux_1. - generalize (SetRegMreg.fold_1 - g.(interf_reg_mreg) - Regset.empty - (fun (r1r2 : SetDepRegMreg.elt) (u : Regset.t) => - Regset.add (fst r1r2) u)). - change (PTree.t unit) with Regset.t. - intros [l' [UN' [INEQ' EQ']]]. - rewrite EQ'. apply all_interf_regs_correct_aux_3 with mr2. - elim (INEQ' (r1, mr2)); intros. auto. + apply in_setregreg_fold'. eapply in_setregmreg_fold. eauto. Qed. + diff --git a/backend/Kildall.v b/backend/Kildall.v index 10b2e1d..0210b73 100644 --- a/backend/Kildall.v +++ b/backend/Kildall.v @@ -1,6 +1,7 @@ (** Solvers for dataflow inequations. *) Require Import Coqlib. +Require Import Iteration. Require Import Maps. Require Import Lattice. @@ -40,128 +41,6 @@ sets [X(n) = top] for all merge points [n], that is, program points having several predecessors. This solver is useful when least upper bounds of approximations do not exist or are too expensive to compute. *) -(** * Bounded iteration *) - -(** The three solvers proceed iteratively, increasing the value of one of - the unknowns [X(n)] at each iteration until a solution is reached. - This section defines the general form of iteration used. *) - -Section BOUNDED_ITERATION. - -Variables A B: Set. -Variable step: A -> B + A. - -(** The [step] parameter represents one step of the iteration. From a - current iteration state [a: A], it either returns a value of type [B], - meaning that iteration is over and that this [B] value is the final - result of the iteration, or a value [a' : A] which is the next state - of the iteration. - - The naive way to define the iteration is: -<< -Fixpoint iterate (a: A) : B := - match step a with - | inl b => b - | inr a' => iterate a' - end. ->> - However, this is a general recursion, not guaranteed to terminate, - and therefore not expressible in Coq. The standard way to work around - this difficulty is to use Noetherian recursion (Coq module [Wf]). - This requires that we equip the type [A] with a well-founded ordering [<] - (no infinite ascending chains) and we demand that [step] satisfies - [step a = inr a' -> a < a']. For the types [A] that are of interest to us - in this development, it is however very painful to define adequate - well-founded orderings, even though we know our iterations always - terminate. - - Instead, we choose to bound the number of iterations by an arbitrary - constant. [iterate] then becomes a function that can fail, - of type [A -> option B]. The [None] result denotes failure to reach - a result in the number of iterations prescribed, or, in other terms, - failure to find a solution to the dataflow problem. The compiler - passes that exploit dataflow analysis (the [Constprop], [CSE] and - [Allocation] passes) will, in this case, either fail ([Allocation]) - or turn off the optimization pass ([Constprop] and [CSE]). - - Since we know (informally) that our computations terminate, we can - take a very large constant as the maximal number of iterations. - Failure will therefore never happen in practice, but of - course our proofs also cover the failure case and show that - nothing bad happens in this hypothetical case either. *) - -Definition num_iterations := 1000000000000%positive. - -(** The simple definition of bounded iteration is: -<< -Fixpoint iterate (niter: nat) (a: A) {struct niter} : option B := - match niter with - | O => None - | S niter' => - match step a with - | inl b => b - | inr a' => iterate niter' a' - end - end. ->> - This function is structural recursive over the parameter [niter] - (number of iterations), represented here as a Peano integer (type [nat]). - However, we want to use very large values of [niter]. As Peano integers, - these values would be much too large to fit in memory. Therefore, - we must express iteration counts as a binary integer (type [positive]). - However, Peano induction over type [positive] is not structural recursion, - so we cannot define [iterate] as a Coq fixpoint and must use - Noetherian recursion instead. *) - -Definition iter_step (x: positive) - (next: forall y, Plt y x -> A -> option B) - (s: A) : option B := - match peq x xH with - | left EQ => None - | right NOTEQ => - match step s with - | inl res => Some res - | inr s' => next (Ppred x) (Ppred_Plt x NOTEQ) s' - end - end. - -Definition iterate: positive -> A -> option B := - Fix Plt_wf (fun _ => A -> option B) iter_step. - -(** We then prove the expected unrolling equations for [iterate]. *) - -Remark unroll_iterate: - forall x, iterate x = iter_step x (fun y _ => iterate y). -Proof. - unfold iterate; apply (Fix_eq Plt_wf (fun _ => A -> option B) iter_step). - intros. unfold iter_step. apply extensionality. intro s. - case (peq x xH); intro. auto. - rewrite H. auto. -Qed. - -Lemma iterate_base: - forall s, iterate 1%positive s = None. -Proof. - intro; rewrite unroll_iterate; unfold iter_step. - case (peq 1 1); congruence. -Qed. - -Lemma iterate_step: - forall x s, - iterate (Psucc x) s = - match step s with - | inl res => Some res - | inr s' => iterate x s' - end. -Proof. - intro; rewrite unroll_iterate; unfold iter_step; intros. - case (peq (Psucc x) 1); intro. - destruct x; simpl in e; discriminate. - rewrite Ppred_succ. auto. -Qed. - -End BOUNDED_ITERATION. - (** * Solving forward dataflow problems using Kildall's algorithm *) (** A forward dataflow solver has the following generic interface. @@ -316,7 +195,7 @@ Definition step (s: state) : PMap.t L.t + state := the start state. *) Definition fixpoint : option (PMap.t L.t) := - iterate _ _ step num_iterations start_state. + PrimIter.iterate _ _ step start_state. (** ** Monotonicity properties *) @@ -361,33 +240,24 @@ Proof. apply propagate_succ_incr. auto. Qed. -Lemma iterate_incr: - forall n st res, - iterate _ _ step n st = Some res -> - in_incr st.(st_in) res. -Proof. - intro n; pattern n. apply positive_Peano_ind; intros until res. - rewrite iterate_base. congruence. - rewrite iterate_step. unfold step. - destruct st.(st_wrk); intros. - injection H0; intro; subst res. - red; intros; apply L.ge_refl. - apply in_incr_trans with - (propagate_succ_list (mkstate (st_in st) l) - (transf p (st_in st)!!p) - (successors p)).(st_in). - change (st_in st) with (st_in (mkstate (st_in st) l)). - apply propagate_succ_list_incr. - apply H. auto. -Qed. - Lemma fixpoint_incr: forall res, fixpoint = Some res -> in_incr (start_state_in entrypoints) res. Proof. unfold fixpoint; intros. change (start_state_in entrypoints) with start_state.(st_in). - apply iterate_incr with num_iterations; auto. + eapply (PrimIter.iterate_prop _ _ step + (fun st => in_incr start_state.(st_in) st.(st_in)) + (fun res => in_incr start_state.(st_in) res)). + + intros st INCR. unfold step. + destruct st.(st_wrk) as [ | n rem ]. + auto. + apply in_incr_trans with st.(st_in). auto. + change st.(st_in) with (mkstate st.(st_in) rem).(st_in). + apply propagate_succ_list_incr. + + eauto. apply in_incr_refl. Qed. (** ** Correctness invariant *) @@ -563,30 +433,8 @@ Qed. (** ** Correctness of the solution returned by [iterate]. *) (** As a consequence of the [good_state] invariant, the result of - [iterate], if defined, is a solution of the dataflow inequations, - since [st_wrk] is empty when [iterate] terminates. *) - -Lemma iterate_solution: - forall niter st res n s, - good_state st -> - iterate _ _ step niter st = Some res -> - Plt n topnode -> In s (successors n) -> - L.ge res!!s (transf n res!!n). -Proof. - intro niter; pattern niter; apply positive_Peano_ind; intros until s. - rewrite iterate_base. congruence. - intro GS. rewrite iterate_step. - unfold step; caseEq (st.(st_wrk)). - intros. injection H1; intros; subst res. - elim (GS n H2); intro. - rewrite H0 in H4. elim H4. - auto. - intros. apply H with - (propagate_succ_list (mkstate st.(st_in) l) - (transf p st.(st_in)!!p) (successors p)). - apply step_state_good; auto. - auto. auto. auto. -Qed. + [fixpoint], if defined, is a solution of the dataflow inequations, + since [st_wrk] is empty when the iteration terminates. *) Theorem fixpoint_solution: forall res n s, @@ -594,10 +442,20 @@ Theorem fixpoint_solution: Plt n topnode -> In s (successors n) -> L.ge res!!s (transf n res!!n). Proof. - unfold fixpoint. intros. - apply iterate_solution with num_iterations start_state. - apply start_state_good. - auto. auto. auto. + assert (forall res, fixpoint = Some res -> + forall n s, Plt n topnode -> In s (successors n) -> + L.ge res!!s (transf n res!!n)). + unfold fixpoint. intros res PI. pattern res. + eapply (PrimIter.iterate_prop _ _ step good_state). + + intros st GOOD. unfold step. + caseEq (st.(st_wrk)). + intros. elim (GOOD n H0); intro. + rewrite H in H2. contradiction. + auto. + intros n rem WRK. apply step_state_good; auto. + + eauto. apply start_state_good. eauto. Qed. (** As a consequence of the monotonicity property, the result of @@ -936,8 +794,7 @@ Definition basic_block_list (bb: bbmap) : list positive := Definition fixpoint : option result := let bb := basic_block_map in - iterate _ _ (step bb) num_iterations - (mkstate (PMap.init L.top) (basic_block_list bb)). + PrimIter.iterate _ _ (step bb) (mkstate (PMap.init L.top) (basic_block_list bb)). (** ** Properties of predecessors and multiple-predecessors nodes *) @@ -1121,23 +978,6 @@ Proof. right. assumption. Qed. -Lemma analyze_invariant: - forall res count st, - iterate _ _ (step basic_block_map) count st = Some res -> - state_invariant st -> - state_invariant (mkstate res nil). -Proof. - intros until count. pattern count. - apply positive_Peano_ind; intros until st. - rewrite iterate_base. congruence. - rewrite iterate_step. unfold step at 1. case st; intros r w; simpl. - case w. - intros. replace res with r. auto. congruence. - intros pc wl. case (plt pc topnode); intros. - eapply H. eauto. apply propagate_successors_invariant; auto. - eapply H. eauto. eapply discard_top_worklist_invariant; eauto. -Qed. - Lemma initial_state_invariant: state_invariant (mkstate (PMap.init L.top) (basic_block_list basic_block_map)). Proof. @@ -1146,6 +986,27 @@ Proof. right. intros. repeat rewrite PMap.gi. apply L.top_ge. Qed. +Lemma analyze_invariant: + forall res, + fixpoint = Some res -> + state_invariant (mkstate res nil). +Proof. + unfold fixpoint; intros. pattern res. + eapply (PrimIter.iterate_prop _ _ (step basic_block_map) + state_invariant). + + intros st INV. destruct st as [stin stwrk]. + unfold step. simpl. caseEq stwrk. + intro. congruence. + + intros pc rem WRK. case (plt pc topnode); intro. + apply propagate_successors_invariant; auto. congruence. + eapply discard_top_worklist_invariant; eauto. congruence. + + eauto. apply initial_state_invariant. +Qed. + + (** ** Correctness of the returned solution *) Theorem fixpoint_solution: @@ -1154,10 +1015,9 @@ Theorem fixpoint_solution: Plt n topnode -> In s (successors n) -> L.ge res!!s (transf n res!!n). Proof. - unfold fixpoint. intros. assert (state_invariant (mkstate res nil)). - eapply analyze_invariant; eauto. apply initial_state_invariant. + eapply analyze_invariant; eauto. elim H2; simpl; intros. elim (H4 n H0); intros. contradiction. @@ -1169,10 +1029,9 @@ Theorem fixpoint_entry: fixpoint = Some res -> res!!entrypoint = L.top. Proof. - unfold fixpoint. intros. assert (state_invariant (mkstate res nil)). - eapply analyze_invariant; eauto. apply initial_state_invariant. + eapply analyze_invariant; eauto. elim H0; simpl; intros. apply H1. unfold basic_block_map, is_basic_block_head. fold predecessors. @@ -1201,28 +1060,21 @@ Proof. auto. apply H0. Qed. -Lemma analyze_P: - forall bb res count st, - iterate _ _ (step bb) count st = Some res -> - Pstate st -> - (forall pc, P res!!pc). -Proof. - intros until count; pattern count; apply positive_Peano_ind; intros until st. - rewrite iterate_base. congruence. - rewrite iterate_step; unfold step at 1; destruct st.(st_wrk). - intros. inversion H0. apply H1. - destruct (plt p topnode). - intros. eapply H. eauto. - apply propagate_successors_P. apply Ptransf. apply H1. - red; intro; simpl. apply H1. - intros. eauto. -Qed. - Theorem fixpoint_invariant: forall res pc, fixpoint = Some res -> P res!!pc. Proof. - intros. unfold fixpoint in H. eapply analyze_P; eauto. - red; intro; simpl. rewrite PMap.gi. apply Ptop. + unfold fixpoint; intros. pattern res. + eapply (PrimIter.iterate_prop _ _ (step basic_block_map) Pstate). + + intros st PS. unfold step. destruct (st.(st_wrk)). + apply PS. + assert (PS2: Pstate (mkstate st.(st_in) l)). + red; intro; simpl. apply PS. + case (plt p topnode); intro. + apply propagate_successors_P. auto. auto. + auto. + + eauto. red; intro; simpl. rewrite PMap.gi. apply Ptop. Qed. End Solver. diff --git a/backend/LTL.v b/backend/LTL.v index 2c36cba..f20ba3f 100644 --- a/backend/LTL.v +++ b/backend/LTL.v @@ -9,6 +9,7 @@ Require Import Maps. Require Import AST. Require Import Integers. Require Import Values. +Require Import Events. Require Import Mem. Require Import Globalenvs. Require Import Op. @@ -39,6 +40,7 @@ Inductive block: Set := | Bload: memory_chunk -> addressing -> list mreg -> mreg -> block -> block | Bstore: memory_chunk -> addressing -> list mreg -> mreg -> block -> block | Bcall: signature -> mreg + ident -> block -> block + | Balloc: block -> block | Bgoto: node -> block | Bcond: condition -> list mreg -> node -> node -> block | Breturn: block. @@ -60,11 +62,19 @@ Record function: Set := mkfunction { forall (pc: node), Plt pc (Psucc fn_entrypoint) \/ fn_code!pc = None }. -Definition program := AST.program function. +Definition fundef := AST.fundef function. + +Definition program := AST.program fundef. + +Definition funsig (fd: fundef) := + match fd with + | Internal f => f.(fn_sig) + | External ef => ef.(ef_sig) + end. (** * Operational semantics *) -Definition genv := Genv.t function. +Definition genv := Genv.t fundef. Definition locset := Locmap.t. Section RELSEM. @@ -117,7 +127,7 @@ Definition return_regs (caller callee: locset) : locset := Variable ge: genv. -Definition find_function (ros: mreg + ident) (rs: locset) : option function := +Definition find_function (ros: mreg + ident) (rs: locset) : option fundef := match ros with | inl r => Genv.find_funct ge (rs (R r)) | inr symb => @@ -166,104 +176,119 @@ Inductive outcome: Set := | Return: outcome. Inductive exec_instr: val -> - block -> locset -> mem -> + block -> locset -> mem -> trace -> block -> locset -> mem -> Prop := | exec_Bgetstack: forall sp sl r b rs m, exec_instr sp (Bgetstack sl r b) rs m - b (Locmap.set (R r) (rs (S sl)) rs) m + E0 b (Locmap.set (R r) (rs (S sl)) rs) m | exec_Bsetstack: forall sp r sl b rs m, exec_instr sp (Bsetstack r sl b) rs m - b (Locmap.set (S sl) (rs (R r)) rs) m + E0 b (Locmap.set (S sl) (rs (R r)) rs) m | exec_Bop: forall sp op args res b rs m v, eval_operation ge sp op (reglist args rs) = Some v -> exec_instr sp (Bop op args res b) rs m - b (Locmap.set (R res) v rs) m + E0 b (Locmap.set (R res) v rs) m | exec_Bload: forall sp chunk addr args dst b rs m a v, eval_addressing ge sp addr (reglist args rs) = Some a -> loadv chunk m a = Some v -> exec_instr sp (Bload chunk addr args dst b) rs m - b (Locmap.set (R dst) v rs) m + E0 b (Locmap.set (R dst) v rs) m | exec_Bstore: forall sp chunk addr args src b rs m m' a, eval_addressing ge sp addr (reglist args rs) = Some a -> storev chunk m a (rs (R src)) = Some m' -> exec_instr sp (Bstore chunk addr args src b) rs m - b rs m' + E0 b rs m' | exec_Bcall: - forall sp sig ros b rs m f rs' m', + forall sp sig ros b rs m t f rs' m', find_function ros rs = Some f -> - sig = f.(fn_sig) -> - exec_function f rs m rs' m' -> + sig = funsig f -> + exec_function f rs m t rs' m' -> exec_instr sp (Bcall sig ros b) rs m - b (return_regs rs rs') m' + t b (return_regs rs rs') m' + | exec_Balloc: + forall sp b rs m sz m' blk, + rs (R Conventions.loc_alloc_argument) = Vint sz -> + Mem.alloc m 0 (Int.signed sz) = (m', blk) -> + exec_instr sp (Balloc b) rs m E0 b + (Locmap.set (R Conventions.loc_alloc_result) + (Vptr blk Int.zero) rs) m' with exec_instrs: val -> - block -> locset -> mem -> + block -> locset -> mem -> trace -> block -> locset -> mem -> Prop := | exec_refl: forall sp b rs m, - exec_instrs sp b rs m b rs m + exec_instrs sp b rs m E0 b rs m | exec_one: - forall sp b1 rs1 m1 b2 rs2 m2, - exec_instr sp b1 rs1 m1 b2 rs2 m2 -> - exec_instrs sp b1 rs1 m1 b2 rs2 m2 + forall sp b1 rs1 m1 t b2 rs2 m2, + exec_instr sp b1 rs1 m1 t b2 rs2 m2 -> + exec_instrs sp b1 rs1 m1 t b2 rs2 m2 | exec_trans: - forall sp b1 rs1 m1 b2 rs2 m2 b3 rs3 m3, - exec_instrs sp b1 rs1 m1 b2 rs2 m2 -> - exec_instrs sp b2 rs2 m2 b3 rs3 m3 -> - exec_instrs sp b1 rs1 m1 b3 rs3 m3 + forall sp b1 rs1 m1 t t1 b2 rs2 m2 t2 b3 rs3 m3, + exec_instrs sp b1 rs1 m1 t1 b2 rs2 m2 -> + exec_instrs sp b2 rs2 m2 t2 b3 rs3 m3 -> + t = t1 ** t2 -> + exec_instrs sp b1 rs1 m1 t b3 rs3 m3 with exec_block: val -> - block -> locset -> mem -> + block -> locset -> mem -> trace -> outcome -> locset -> mem -> Prop := | exec_Bgoto: - forall sp b rs m s rs' m', - exec_instrs sp b rs m (Bgoto s) rs' m' -> - exec_block sp b rs m (Cont s) rs' m' + forall sp b rs m t s rs' m', + exec_instrs sp b rs m t (Bgoto s) rs' m' -> + exec_block sp b rs m t (Cont s) rs' m' | exec_Bcond_true: - forall sp b rs m cond args ifso ifnot rs' m', - exec_instrs sp b rs m (Bcond cond args ifso ifnot) rs' m' -> + forall sp b rs m t cond args ifso ifnot rs' m', + exec_instrs sp b rs m t (Bcond cond args ifso ifnot) rs' m' -> eval_condition cond (reglist args rs') = Some true -> - exec_block sp b rs m (Cont ifso) rs' m' + exec_block sp b rs m t (Cont ifso) rs' m' | exec_Bcond_false: - forall sp b rs m cond args ifso ifnot rs' m', - exec_instrs sp b rs m (Bcond cond args ifso ifnot) rs' m' -> + forall sp b rs m t cond args ifso ifnot rs' m', + exec_instrs sp b rs m t (Bcond cond args ifso ifnot) rs' m' -> eval_condition cond (reglist args rs') = Some false -> - exec_block sp b rs m (Cont ifnot) rs' m' + exec_block sp b rs m t (Cont ifnot) rs' m' | exec_Breturn: - forall sp b rs m rs' m', - exec_instrs sp b rs m Breturn rs' m' -> - exec_block sp b rs m Return rs' m' + forall sp b rs m t rs' m', + exec_instrs sp b rs m t Breturn rs' m' -> + exec_block sp b rs m t Return rs' m' with exec_blocks: code -> val -> - node -> locset -> mem -> + node -> locset -> mem -> trace -> outcome -> locset -> mem -> Prop := | exec_blocks_refl: forall c sp pc rs m, - exec_blocks c sp pc rs m (Cont pc) rs m + exec_blocks c sp pc rs m E0 (Cont pc) rs m | exec_blocks_one: - forall c sp pc b m rs out rs' m', + forall c sp pc b m rs t out rs' m', c!pc = Some b -> - exec_block sp b rs m out rs' m' -> - exec_blocks c sp pc rs m out rs' m' + exec_block sp b rs m t out rs' m' -> + exec_blocks c sp pc rs m t out rs' m' | exec_blocks_trans: - forall c sp pc1 rs1 m1 pc2 rs2 m2 out rs3 m3, - exec_blocks c sp pc1 rs1 m1 (Cont pc2) rs2 m2 -> - exec_blocks c sp pc2 rs2 m2 out rs3 m3 -> - exec_blocks c sp pc1 rs1 m1 out rs3 m3 + forall c sp pc1 rs1 m1 t t1 pc2 rs2 m2 t2 out rs3 m3, + exec_blocks c sp pc1 rs1 m1 t1 (Cont pc2) rs2 m2 -> + exec_blocks c sp pc2 rs2 m2 t2 out rs3 m3 -> + t = t1 ** t2 -> + exec_blocks c sp pc1 rs1 m1 t out rs3 m3 -with exec_function: function -> locset -> mem -> +with exec_function: fundef -> locset -> mem -> trace -> locset -> mem -> Prop := - | exec_funct: - forall f rs m m1 stk rs2 m2, + | exec_funct_internal: + forall f rs m m1 stk t rs2 m2, alloc m 0 f.(fn_stacksize) = (m1, stk) -> exec_blocks f.(fn_code) (Vptr stk Int.zero) - f.(fn_entrypoint) (call_regs rs) m1 Return rs2 m2 -> - exec_function f rs m rs2 (free m2 stk). + f.(fn_entrypoint) (call_regs rs) m1 t Return rs2 m2 -> + exec_function (Internal f) rs m t rs2 (free m2 stk) + | exec_funct_external: + forall ef args res rs1 rs2 m t, + event_match ef args t res -> + args = List.map rs1 (Conventions.loc_arguments ef.(ef_sig)) -> + rs2 = Locmap.set (R (Conventions.loc_result ef.(ef_sig))) res rs1 -> + exec_function (External ef) rs1 m t rs2 m. End RELSEM. @@ -272,15 +297,15 @@ End RELSEM. main function, to be found in the machine register dictated by the calling conventions. *) -Definition exec_program (p: program) (r: val) : Prop := +Definition exec_program (p: program) (t: trace) (r: val) : Prop := let ge := Genv.globalenv p in let m0 := Genv.init_mem p in exists b, exists f, exists rs, exists m, Genv.find_symbol ge p.(prog_main) = Some b /\ Genv.find_funct_ptr ge b = Some f /\ - f.(fn_sig) = mksignature nil (Some Tint) /\ - exec_function ge f (Locmap.init Vundef) m0 rs m /\ - rs (R (Conventions.loc_result f.(fn_sig))) = r. + funsig f = mksignature nil (Some Tint) /\ + exec_function ge f (Locmap.init Vundef) m0 t rs m /\ + rs (R (Conventions.loc_result (funsig f))) = r. (** We remark that the [exec_blocks] relation is stable if the control-flow graph is extended by adding new basic blocks @@ -293,9 +318,9 @@ Variable c1 c2: code. Hypothesis EXT: forall pc, c2!pc = c1!pc \/ c1!pc = None. Lemma exec_blocks_extends: - forall sp pc1 rs1 m1 out rs2 m2, - exec_blocks ge c1 sp pc1 rs1 m1 out rs2 m2 -> - exec_blocks ge c2 sp pc1 rs1 m1 out rs2 m2. + forall sp pc1 rs1 m1 t out rs2 m2, + exec_blocks ge c1 sp pc1 rs1 m1 t out rs2 m2 -> + exec_blocks ge c2 sp pc1 rs1 m1 t out rs2 m2. Proof. induction 1. apply exec_blocks_refl. @@ -319,6 +344,7 @@ Fixpoint successors_aux (b: block) : list node := | Bload chunk addr args dst b => successors_aux b | Bstore chunk addr args src b => successors_aux b | Bcall sig ros b => successors_aux b + | Balloc b => successors_aux b | Bgoto n => n :: nil | Bcond cond args ifso ifnot => ifso :: ifnot :: nil | Breturn => nil @@ -331,8 +357,8 @@ Definition successors (f: function) (pc: node) : list node := end. Lemma successors_aux_invariant: - forall ge sp b rs m b' rs' m', - exec_instrs ge sp b rs m b' rs' m' -> + forall ge sp b rs m t b' rs' m', + exec_instrs ge sp b rs m t b' rs' m' -> successors_aux b = successors_aux b'. Proof. induction 1; simpl; intros. @@ -342,16 +368,16 @@ Proof. Qed. Lemma successors_correct: - forall ge f sp pc rs m pc' rs' m' b, + forall ge f sp pc rs m t pc' rs' m' b, f.(fn_code)!pc = Some b -> - exec_block ge sp b rs m (Cont pc') rs' m' -> + exec_block ge sp b rs m t (Cont pc') rs' m' -> In pc' (successors f pc). Proof. intros. unfold successors. rewrite H. inversion H0. - rewrite (successors_aux_invariant _ _ _ _ _ _ _ _ H6); simpl. + rewrite (successors_aux_invariant _ _ _ _ _ _ _ _ _ H7); simpl. tauto. - rewrite (successors_aux_invariant _ _ _ _ _ _ _ _ H2); simpl. + rewrite (successors_aux_invariant _ _ _ _ _ _ _ _ _ H2); simpl. tauto. - rewrite (successors_aux_invariant _ _ _ _ _ _ _ _ H2); simpl. + rewrite (successors_aux_invariant _ _ _ _ _ _ _ _ _ H2); simpl. tauto. Qed. diff --git a/backend/LTLtyping.v b/backend/LTLtyping.v index 3f13ac3..3450814 100644 --- a/backend/LTLtyping.v +++ b/backend/LTLtyping.v @@ -73,6 +73,10 @@ Inductive wt_block : block -> Prop := match ros with inl r => mreg_type r = Tint | _ => True end -> wt_block b -> wt_block (Bcall sig ros b) + | wt_Balloc: + forall b, + wt_block b -> + wt_block (Balloc b) | wt_Bgoto: forall lbl, wt_block (Bgoto lbl) @@ -88,6 +92,14 @@ End WT_BLOCK. Definition wt_function (f: function) : Prop := forall pc b, f.(fn_code)!pc = Some b -> wt_block f b. +Inductive wt_fundef: fundef -> Prop := + | wt_fundef_external: forall ef, + Conventions.sig_external_ok ef.(ef_sig) -> + wt_fundef (External ef) + | wt_function_internal: forall f, + wt_function f -> + wt_fundef (Internal f). + Definition wt_program (p: program) : Prop := - forall i f, In (i, f) (prog_funct p) -> wt_function f. + forall i f, In (i, f) (prog_funct p) -> wt_fundef f. diff --git a/backend/Linear.v b/backend/Linear.v index f4ed045..2520f5b 100644 --- a/backend/Linear.v +++ b/backend/Linear.v @@ -11,6 +11,7 @@ Require Import AST. Require Import Integers. Require Import Values. Require Import Mem. +Require Import Events. Require Import Globalenvs. Require Import Op. Require Import Locations. @@ -37,6 +38,7 @@ Inductive instruction: Set := | Lload: memory_chunk -> addressing -> list mreg -> mreg -> instruction | Lstore: memory_chunk -> addressing -> list mreg -> mreg -> instruction | Lcall: signature -> mreg + ident -> instruction + | Lalloc: instruction | Llabel: label -> instruction | Lgoto: label -> instruction | Lcond: condition -> list mreg -> label -> instruction @@ -50,9 +52,17 @@ Record function: Set := mkfunction { fn_code: code }. -Definition program := AST.program function. +Definition fundef := AST.fundef function. -Definition genv := Genv.t function. +Definition program := AST.program fundef. + +Definition funsig (fd: fundef) := + match fd with + | Internal f => f.(fn_sig) + | External ef => ef.(ef_sig) + end. + +Definition genv := Genv.t fundef. Definition locset := Locmap.t. (** * Operational semantics *) @@ -88,7 +98,7 @@ Section RELSEM. Variable ge: genv. -Definition find_function (ros: mreg + ident) (rs: locset) : option function := +Definition find_function (ros: mreg + ident) (rs: locset) : option fundef := match ros with | inl r => Genv.find_funct ge (rs (R r)) | inr symb => @@ -106,84 +116,99 @@ Definition find_function (ros: mreg + ident) (rs: locset) : option function := [ls'] and [m'] are the final location state and memory state. *) Inductive exec_instr: function -> val -> - code -> locset -> mem -> + code -> locset -> mem -> trace -> code -> locset -> mem -> Prop := | exec_Lgetstack: forall f sp sl r b rs m, exec_instr f sp (Lgetstack sl r :: b) rs m - b (Locmap.set (R r) (rs (S sl)) rs) m + E0 b (Locmap.set (R r) (rs (S sl)) rs) m | exec_Lsetstack: forall f sp r sl b rs m, exec_instr f sp (Lsetstack r sl :: b) rs m - b (Locmap.set (S sl) (rs (R r)) rs) m + E0 b (Locmap.set (S sl) (rs (R r)) rs) m | exec_Lop: forall f sp op args res b rs m v, eval_operation ge sp op (reglist args rs) = Some v -> exec_instr f sp (Lop op args res :: b) rs m - b (Locmap.set (R res) v rs) m + E0 b (Locmap.set (R res) v rs) m | exec_Lload: forall f sp chunk addr args dst b rs m a v, eval_addressing ge sp addr (reglist args rs) = Some a -> loadv chunk m a = Some v -> exec_instr f sp (Lload chunk addr args dst :: b) rs m - b (Locmap.set (R dst) v rs) m + E0 b (Locmap.set (R dst) v rs) m | exec_Lstore: forall f sp chunk addr args src b rs m m' a, eval_addressing ge sp addr (reglist args rs) = Some a -> storev chunk m a (rs (R src)) = Some m' -> exec_instr f sp (Lstore chunk addr args src :: b) rs m - b rs m' + E0 b rs m' | exec_Lcall: - forall f sp sig ros b rs m f' rs' m', + forall f sp sig ros b rs m t f' rs' m', find_function ros rs = Some f' -> - sig = f'.(fn_sig) -> - exec_function f' rs m rs' m' -> + sig = funsig f' -> + exec_function f' rs m t rs' m' -> exec_instr f sp (Lcall sig ros :: b) rs m - b (return_regs rs rs') m' + t b (return_regs rs rs') m' + | exec_Lalloc: + forall f sp b rs m sz m' blk, + rs (R Conventions.loc_alloc_argument) = Vint sz -> + Mem.alloc m 0 (Int.signed sz) = (m', blk) -> + exec_instr f sp (Lalloc :: b) rs m + E0 b (Locmap.set (R Conventions.loc_alloc_result) + (Vptr blk Int.zero) rs) m' | exec_Llabel: forall f sp lbl b rs m, exec_instr f sp (Llabel lbl :: b) rs m - b rs m + E0 b rs m | exec_Lgoto: forall f sp lbl b rs m b', find_label lbl f.(fn_code) = Some b' -> exec_instr f sp (Lgoto lbl :: b) rs m - b' rs m + E0 b' rs m | exec_Lcond_true: forall f sp cond args lbl b rs m b', eval_condition cond (reglist args rs) = Some true -> find_label lbl f.(fn_code) = Some b' -> exec_instr f sp (Lcond cond args lbl :: b) rs m - b' rs m + E0 b' rs m | exec_Lcond_false: forall f sp cond args lbl b rs m, eval_condition cond (reglist args rs) = Some false -> exec_instr f sp (Lcond cond args lbl :: b) rs m - b rs m + E0 b rs m with exec_instrs: function -> val -> - code -> locset -> mem -> + code -> locset -> mem -> trace -> code -> locset -> mem -> Prop := | exec_refl: forall f sp b rs m, - exec_instrs f sp b rs m b rs m + exec_instrs f sp b rs m E0 b rs m | exec_one: - forall f sp b1 rs1 m1 b2 rs2 m2, - exec_instr f sp b1 rs1 m1 b2 rs2 m2 -> - exec_instrs f sp b1 rs1 m1 b2 rs2 m2 + forall f sp b1 rs1 m1 t b2 rs2 m2, + exec_instr f sp b1 rs1 m1 t b2 rs2 m2 -> + exec_instrs f sp b1 rs1 m1 t b2 rs2 m2 | exec_trans: - forall f sp b1 rs1 m1 b2 rs2 m2 b3 rs3 m3, - exec_instrs f sp b1 rs1 m1 b2 rs2 m2 -> - exec_instrs f sp b2 rs2 m2 b3 rs3 m3 -> - exec_instrs f sp b1 rs1 m1 b3 rs3 m3 - -with exec_function: function -> locset -> mem -> locset -> mem -> Prop := - | exec_funct: - forall f rs m m1 stk rs2 m2 b, + forall f sp b1 rs1 m1 t1 b2 rs2 m2 t2 b3 rs3 m3 t, + exec_instrs f sp b1 rs1 m1 t1 b2 rs2 m2 -> + exec_instrs f sp b2 rs2 m2 t2 b3 rs3 m3 -> + t = t1 ** t2 -> + exec_instrs f sp b1 rs1 m1 t b3 rs3 m3 + +with exec_function: fundef -> locset -> mem -> trace -> locset -> mem -> Prop := + | exec_funct_internal: + forall f rs m t m1 stk rs2 m2 b, alloc m 0 f.(fn_stacksize) = (m1, stk) -> exec_instrs f (Vptr stk Int.zero) - f.(fn_code) (call_regs rs) m1 (Lreturn :: b) rs2 m2 -> - exec_function f rs m rs2 (free m2 stk). + f.(fn_code) (call_regs rs) m1 + t (Lreturn :: b) rs2 m2 -> + exec_function (Internal f) rs m t rs2 (free m2 stk) + | exec_funct_external: + forall ef args res rs1 rs2 m t, + event_match ef args t res -> + args = List.map rs1 (Conventions.loc_arguments ef.(ef_sig)) -> + rs2 = Locmap.set (R (Conventions.loc_result ef.(ef_sig))) res rs1 -> + exec_function (External ef) rs1 m t rs2 m. Scheme exec_instr_ind3 := Minimality for exec_instr Sort Prop with exec_instrs_ind3 := Minimality for exec_instrs Sort Prop @@ -191,13 +216,13 @@ Scheme exec_instr_ind3 := Minimality for exec_instr Sort Prop End RELSEM. -Definition exec_program (p: program) (r: val) : Prop := +Definition exec_program (p: program) (t: trace) (r: val) : Prop := let ge := Genv.globalenv p in let m0 := Genv.init_mem p in exists b, exists f, exists rs, exists m, Genv.find_symbol ge p.(prog_main) = Some b /\ Genv.find_funct_ptr ge b = Some f /\ - f.(fn_sig) = mksignature nil (Some Tint) /\ - exec_function ge f (Locmap.init Vundef) m0 rs m /\ - rs (R (Conventions.loc_result f.(fn_sig))) = r. + funsig f = mksignature nil (Some Tint) /\ + exec_function ge f (Locmap.init Vundef) m0 t rs m /\ + rs (R (Conventions.loc_result (funsig f))) = r. diff --git a/backend/Linearize.v b/backend/Linearize.v index af70b0f..f5b2a9e 100644 --- a/backend/Linearize.v +++ b/backend/Linearize.v @@ -148,6 +148,8 @@ Fixpoint linearize_block (b: block) (k: code) {struct b} : code := Lstore chunk addr args src :: linearize_block b k | Bcall sig ros b => Lcall sig ros :: linearize_block b k + | Balloc b => + Lalloc :: linearize_block b k | Bgoto s => Lgoto s :: k | Bcond cond args s1 s2 => @@ -208,5 +210,8 @@ Definition cleanup_function (f: Linear.function) : Linear.function := Definition transf_function (f: LTL.function) : Linear.function := cleanup_function (linearize_function f). +Definition transf_fundef (f: LTL.fundef) : Linear.fundef := + AST.transf_fundef transf_function f. + Definition transf_program (p: LTL.program) : Linear.program := - transform_program transf_function p. + transform_program transf_fundef p. diff --git a/backend/Linearizeproof.v b/backend/Linearizeproof.v index b80acb4..22bf19c 100644 --- a/backend/Linearizeproof.v +++ b/backend/Linearizeproof.v @@ -6,6 +6,7 @@ Require Import AST. Require Import Integers. Require Import Values. Require Import Mem. +Require Import Events. Require Import Globalenvs. Require Import Op. Require Import Locations. @@ -25,19 +26,25 @@ Let tge := Genv.globalenv tprog. Lemma functions_translated: forall v f, Genv.find_funct ge v = Some f -> - Genv.find_funct tge v = Some (transf_function f). -Proof (@Genv.find_funct_transf _ _ transf_function prog). + Genv.find_funct tge v = Some (transf_fundef f). +Proof (@Genv.find_funct_transf _ _ transf_fundef prog). Lemma function_ptr_translated: forall v f, Genv.find_funct_ptr ge v = Some f -> - Genv.find_funct_ptr tge v = Some (transf_function f). -Proof (@Genv.find_funct_ptr_transf _ _ transf_function prog). + Genv.find_funct_ptr tge v = Some (transf_fundef f). +Proof (@Genv.find_funct_ptr_transf _ _ transf_fundef prog). Lemma symbols_preserved: forall id, Genv.find_symbol tge id = Genv.find_symbol ge id. -Proof (@Genv.find_symbol_transf _ _ transf_function prog). +Proof (@Genv.find_symbol_transf _ _ transf_fundef prog). + +Lemma sig_preserved: + forall f, funsig (transf_fundef f) = LTL.funsig f. +Proof. + destruct f; reflexivity. +Qed. (** * Correctness of reachability analysis *) @@ -80,9 +87,9 @@ Qed. [pc] is reachable, then [pc'] is reachable. *) Lemma reachable_correct_1: - forall f sp pc rs m pc' rs' m' b, + forall f sp pc rs m t pc' rs' m' b, f.(LTL.fn_code)!pc = Some b -> - exec_block ge sp b rs m (Cont pc') rs' m' -> + exec_block ge sp b rs m t (Cont pc') rs' m' -> (reachable f)!!pc = true -> (reachable f)!!pc' = true. Proof. @@ -92,8 +99,8 @@ Proof. Qed. Lemma reachable_correct_2: - forall c sp pc rs m out rs' m', - exec_blocks ge c sp pc rs m out rs' m' -> + forall c sp pc rs m t out rs' m', + exec_blocks ge c sp pc rs m t out rs' m' -> forall f pc', c = f.(LTL.fn_code) -> out = Cont pc' -> @@ -236,18 +243,19 @@ Lemma starts_with_correct: starts_with lbl c1 = true -> find_label lbl c2 = Some c3 -> exec_instrs tge f sp (cleanup_code c1) ls m - (cleanup_code c3) ls m. + E0 (cleanup_code c3) ls m. Proof. induction c1. simpl; intros; discriminate. simpl starts_with. destruct a; try (intros; discriminate). - intros. apply exec_trans with (cleanup_code c1) ls m. + intros. apply exec_trans with E0 (cleanup_code c1) ls m E0. simpl. constructor. constructor. destruct (peq lbl l). subst l. replace c3 with c1. constructor. apply find_label_unique with lbl c2; auto. apply IHc1 with c2; auto. eapply is_tail_cons_left; eauto. + traceEq. Qed. (** Code cleanup preserves the labeling of the code. *) @@ -273,13 +281,13 @@ Qed. or one transitions in the cleaned-up code. *) Lemma cleanup_code_correct_1: - forall f sp c1 ls1 m1 c2 ls2 m2, - exec_instr tge f sp c1 ls1 m1 c2 ls2 m2 -> + forall f sp c1 ls1 m1 t c2 ls2 m2, + exec_instr tge f sp c1 ls1 m1 t c2 ls2 m2 -> is_tail c1 f.(fn_code) -> unique_labels f.(fn_code) -> exec_instrs tge (cleanup_function f) sp (cleanup_code c1) ls1 m1 - (cleanup_code c2) ls2 m2. + t (cleanup_code c2) ls2 m2. Proof. induction 1; simpl; intros; try (apply exec_one; econstructor; eauto; fail). @@ -310,8 +318,8 @@ Proof. Qed. Lemma is_tail_exec_instr: - forall f sp c1 ls1 m1 c2 ls2 m2, - exec_instr tge f sp c1 ls1 m1 c2 ls2 m2 -> + forall f sp c1 ls1 m1 t c2 ls2 m2, + exec_instr tge f sp c1 ls1 m1 t c2 ls2 m2 -> is_tail c1 f.(fn_code) -> is_tail c2 f.(fn_code). Proof. induction 1; intros; @@ -321,8 +329,8 @@ Proof. Qed. Lemma is_tail_exec_instrs: - forall f sp c1 ls1 m1 c2 ls2 m2, - exec_instrs tge f sp c1 ls1 m1 c2 ls2 m2 -> + forall f sp c1 ls1 m1 t c2 ls2 m2, + exec_instrs tge f sp c1 ls1 m1 t c2 ls2 m2 -> is_tail c1 f.(fn_code) -> is_tail c2 f.(fn_code). Proof. induction 1; intros. @@ -335,31 +343,32 @@ Qed. to zero, one or several transitions in the cleaned-up code. *) Lemma cleanup_code_correct_2: - forall f sp c1 ls1 m1 c2 ls2 m2, - exec_instrs tge f sp c1 ls1 m1 c2 ls2 m2 -> + forall f sp c1 ls1 m1 t c2 ls2 m2, + exec_instrs tge f sp c1 ls1 m1 t c2 ls2 m2 -> is_tail c1 f.(fn_code) -> unique_labels f.(fn_code) -> exec_instrs tge (cleanup_function f) sp (cleanup_code c1) ls1 m1 - (cleanup_code c2) ls2 m2. + t (cleanup_code c2) ls2 m2. Proof. induction 1; simpl; intros. apply exec_refl. eapply cleanup_code_correct_1; eauto. - apply exec_trans with (cleanup_code b2) rs2 m2. + apply exec_trans with t1 (cleanup_code b2) rs2 m2 t2. auto. apply IHexec_instrs2; auto. eapply is_tail_exec_instrs; eauto. + auto. Qed. Lemma cleanup_function_correct: - forall f ls1 m1 ls2 m2, - exec_function tge f ls1 m1 ls2 m2 -> + forall f ls1 m1 t ls2 m2, + exec_function tge (Internal f) ls1 m1 t ls2 m2 -> unique_labels f.(fn_code) -> - exec_function tge (cleanup_function f) ls1 m1 ls2 m2. + exec_function tge (Internal (cleanup_function f)) ls1 m1 t ls2 m2. Proof. - induction 1; intro. - generalize (cleanup_code_correct_2 _ _ _ _ _ _ _ _ H0 (is_tail_refl _) H1). + intros. inversion H; subst. + generalize (cleanup_code_correct_2 _ _ _ _ _ _ _ _ _ H3 (is_tail_refl _) H0). simpl. intro. econstructor; eauto. Qed. @@ -479,8 +488,8 @@ Definition valid_outcome (f: LTL.function) (out: outcome) := (** Auxiliary lemma used to establish the [valid_outcome] property. *) Lemma exec_blocks_valid_outcome: - forall c sp pc ls1 m1 out ls2 m2, - exec_blocks ge c sp pc ls1 m1 out ls2 m2 -> + forall c sp pc ls1 m1 t out ls2 m2, + exec_blocks ge c sp pc ls1 m1 t out ls2 m2 -> forall f, c = f.(LTL.fn_code) -> (reachable f)!!pc = true -> @@ -514,34 +523,34 @@ Inductive cont_for_outcome: LTL.function -> outcome -> code -> Prop := Definition exec_instr_prop (sp: val) (b1: block) (ls1: locset) (m1: mem) - (b2: block) (ls2: locset) (m2: mem) : Prop := + (t: trace) (b2: block) (ls2: locset) (m2: mem) : Prop := forall f k, exec_instr tge (linearize_function f) sp (linearize_block b1 k) ls1 m1 - (linearize_block b2 k) ls2 m2. + t (linearize_block b2 k) ls2 m2. Definition exec_instrs_prop (sp: val) (b1: block) (ls1: locset) (m1: mem) - (b2: block) (ls2: locset) (m2: mem) : Prop := + (t: trace) (b2: block) (ls2: locset) (m2: mem) : Prop := forall f k, exec_instrs tge (linearize_function f) sp (linearize_block b1 k) ls1 m1 - (linearize_block b2 k) ls2 m2. + t (linearize_block b2 k) ls2 m2. Definition exec_block_prop (sp: val) (b: block) (ls1: locset) (m1: mem) - (out: outcome) (ls2: locset) (m2: mem): Prop := + (t: trace) (out: outcome) (ls2: locset) (m2: mem): Prop := forall f k, valid_outcome f out -> exists k', exec_instrs tge (linearize_function f) sp (linearize_block b k) ls1 m1 - k' ls2 m2 + t k' ls2 m2 /\ cont_for_outcome f out k'. Definition exec_blocks_prop (c: LTL.code) (sp: val) (pc: node) (ls1: locset) (m1: mem) - (out: outcome) (ls2: locset) (m2: mem): Prop := + (t: trace) (out: outcome) (ls2: locset) (m2: mem): Prop := forall f k, c = f.(LTL.fn_code) -> (reachable f)!!pc = true -> @@ -550,12 +559,13 @@ Definition exec_blocks_prop exists k', exec_instrs tge (linearize_function f) sp k ls1 m1 - k' ls2 m2 + t k' ls2 m2 /\ cont_for_outcome f out k'. Definition exec_function_prop - (f: LTL.function) (ls1: locset) (m1: mem) (ls2: locset) (m2: mem): Prop := - exec_function tge (transf_function f) ls1 m1 ls2 m2. + (f: LTL.fundef) (ls1: locset) (m1: mem) (t: trace) + (ls2: locset) (m2: mem): Prop := + exec_function tge (transf_fundef f) ls1 m1 t ls2 m2. Scheme exec_instr_ind5 := Minimality for LTL.exec_instr Sort Prop with exec_instrs_ind5 := Minimality for LTL.exec_instrs Sort Prop @@ -567,9 +577,9 @@ Scheme exec_instr_ind5 := Minimality for LTL.exec_instr Sort Prop derivation. *) Lemma transf_function_correct: - forall f ls1 m1 ls2 m2, - LTL.exec_function ge f ls1 m1 ls2 m2 -> - exec_function_prop f ls1 m1 ls2 m2. + forall f ls1 m1 t ls2 m2, + LTL.exec_function ge f ls1 m1 t ls2 m2 -> + exec_function_prop f ls1 m1 t ls2 m2. Proof. apply (exec_function_ind5 ge exec_instr_prop @@ -596,27 +606,29 @@ Proof. exact symbols_preserved. auto. (* call *) - apply exec_Lcall with (transf_function f). + apply exec_Lcall with (transf_fundef f). generalize H. destruct ros; simpl. intro; apply functions_translated; auto. rewrite symbols_preserved. destruct (Genv.find_symbol ge i). intro; apply function_ptr_translated; auto. congruence. - rewrite H0; reflexivity. + generalize (sig_preserved f). congruence. apply H2. + (* alloc *) + eapply exec_Lalloc; eauto. (* instr_refl *) apply exec_refl. (* instr_one *) apply exec_one. apply H0. (* instr_trans *) - apply exec_trans with (linearize_block b2 k) rs2 m2. - apply H0. apply H2. + apply exec_trans with t1 (linearize_block b2 k) rs2 m2 t2. + apply H0. apply H2. auto. (* goto *) elim H1. intros REACH [b2 AT2]. generalize (H0 f k). simpl. intro. elim (find_label_lin f s b2 AT2 REACH). intros k2 FIND. exists (linearize_block b2 k2). split. - eapply exec_trans. eexact H2. constructor. constructor. auto. + eapply exec_trans. eexact H2. constructor. constructor. auto. traceEq. constructor. auto. (* cond, true *) elim H2. intros REACH [b2 AT2]. @@ -628,10 +640,10 @@ Proof. eapply exec_trans. eexact H3. eapply exec_trans. apply exec_one. apply exec_Lcond_false. change false with (negb true). apply eval_negate_condition. auto. - apply exec_one. apply exec_Lgoto. auto. + apply exec_one. apply exec_Lgoto. auto. reflexivity. traceEq. eapply exec_trans. eexact H3. apply exec_one. apply exec_Lcond_true. - auto. auto. + auto. auto. traceEq. constructor; auto. (* cond, false *) elim H2. intros REACH [b2 AT2]. @@ -643,10 +655,10 @@ Proof. eapply exec_trans. eexact H3. apply exec_one. apply exec_Lcond_true. change true with (negb false). apply eval_negate_condition. auto. - auto. + auto. traceEq. eapply exec_trans. eexact H3. eapply exec_trans. apply exec_one. apply exec_Lcond_false. auto. - apply exec_one. apply exec_Lgoto. auto. + apply exec_one. apply exec_Lgoto. auto. reflexivity. traceEq. constructor; auto. (* return *) exists (Lreturn :: k). split. @@ -663,11 +675,11 @@ Proof. eapply reachable_correct_2. eexact H. auto. auto. auto. assert (valid_outcome f (Cont pc2)). eapply exec_blocks_valid_outcome; eauto. - generalize (H0 f k H3 H4 H5 H8). intros [k1 [EX1 CFO2]]. + generalize (H0 f k H4 H5 H6 H9). intros [k1 [EX1 CFO2]]. inversion CFO2. - generalize (H2 f k1 H3 H7 H11 H6). intros [k2 [EX2 CFO3]]. + generalize (H2 f k1 H4 H8 H12 H7). intros [k2 [EX2 CFO3]]. exists k2. split. eapply exec_trans; eauto. auto. - (* function -- TA-DA! *) + (* internal function -- TA-DA! *) assert (REACH0: (reachable f)!!(fn_entrypoint f) = true). apply reachable_entrypoint. assert (VO2: valid_outcome f Return). simpl; auto. @@ -687,25 +699,27 @@ Proof. inversion CO. subst k'. unfold transf_function. apply cleanup_function_correct. econstructor. eauto. rewrite EQ. eapply exec_trans. - apply exec_one. constructor. eauto. + apply exec_one. constructor. eauto. traceEq. apply unique_labels_lin_function. + (* external function *) + econstructor; eauto. Qed. End LINEARIZATION. Theorem transf_program_correct: - forall (p: LTL.program) (r: val), - LTL.exec_program p r -> - Linear.exec_program (transf_program p) r. + forall (p: LTL.program) (t: trace) (r: val), + LTL.exec_program p t r -> + Linear.exec_program (transf_program p) t r. Proof. - intros p r [b [f [ls [m [FIND1 [FIND2 [SIG [EX RES]]]]]]]]. - red. exists b; exists (transf_function f); exists ls; exists m. + intros p t r [b [f [ls [m [FIND1 [FIND2 [SIG [EX RES]]]]]]]]. + red. exists b; exists (transf_fundef f); exists ls; exists m. split. change (prog_main (transf_program p)) with (prog_main p). rewrite symbols_preserved; auto. split. apply function_ptr_translated. auto. - split. auto. + split. generalize (sig_preserved f); congruence. split. apply transf_function_correct. unfold transf_program. rewrite Genv.init_mem_transf. auto. - exact RES. + rewrite sig_preserved. exact RES. Qed. diff --git a/backend/Linearizetyping.v b/backend/Linearizetyping.v index 6cebca8..66926e9 100644 --- a/backend/Linearizetyping.v +++ b/backend/Linearizetyping.v @@ -274,6 +274,8 @@ Proof. (* call *) constructor; auto. eapply size_arguments_bound; eauto. + (* alloc *) + constructor. (* goto *) constructor. (* cond *) @@ -327,14 +329,24 @@ Proof. apply cleanup_function_conservation_2; auto. Qed. +Lemma wt_transf_fundef: + forall f, + LTLtyping.wt_fundef f -> + wt_fundef (transf_fundef f). +Proof. + induction 1; simpl. + constructor; assumption. + constructor; apply wt_transf_function; assumption. +Qed. + Lemma program_typing_preserved: forall (p: LTL.program), LTLtyping.wt_program p -> Lineartyping.wt_program (transf_program p). Proof. intros; red; intros. - generalize (transform_program_function transf_function p i f H0). + generalize (transform_program_function transf_fundef p i f H0). intros [f0 [IN TR]]. - subst f. apply wt_transf_function; auto. + subst f. apply wt_transf_fundef; auto. apply (H i f0 IN). Qed. diff --git a/backend/Lineartyping.v b/backend/Lineartyping.v index 0b13b40..bf41908 100644 --- a/backend/Lineartyping.v +++ b/backend/Lineartyping.v @@ -38,6 +38,7 @@ Definition regs_of_instr (i: instruction) : list mreg := | Lstore chunk addr args src => src :: args | Lcall sig (inl fn) => fn :: nil | Lcall sig (inr _) => nil + | Lalloc => nil | Llabel lbl => nil | Lgoto lbl => nil | Lcond cond args lbl => args @@ -231,6 +232,8 @@ Inductive wt_instr : instruction -> Prop := size_arguments sig <= bound_outgoing b -> match ros with inl r => mreg_type r = Tint | _ => True end -> wt_instr (Lcall sig ros) + | wt_Lalloc: + wt_instr Lalloc | wt_Llabel: forall lbl, wt_instr (Llabel lbl) @@ -249,6 +252,14 @@ End WT_INSTR. Definition wt_function (f: function) : Prop := forall instr, In instr f.(fn_code) -> wt_instr f instr. +Inductive wt_fundef: fundef -> Prop := + | wt_fundef_external: forall ef, + Conventions.sig_external_ok ef.(ef_sig) -> + wt_fundef (External ef) + | wt_function_internal: forall f, + wt_function f -> + wt_fundef (Internal f). + Definition wt_program (p: program) : Prop := - forall i f, In (i, f) (prog_funct p) -> wt_function f. + forall i f, In (i, f) (prog_funct p) -> wt_fundef f. diff --git a/backend/Mach.v b/backend/Mach.v index f953798..1a9a94a 100644 --- a/backend/Mach.v +++ b/backend/Mach.v @@ -10,9 +10,11 @@ Require Import AST. Require Import Integers. Require Import Values. Require Import Mem. +Require Import Events. Require Import Globalenvs. Require Import Op. Require Import Locations. +Require Conventions. (** * Abstract syntax *) @@ -43,6 +45,7 @@ Inductive instruction: Set := | Mload: memory_chunk -> addressing -> list mreg -> mreg -> instruction | Mstore: memory_chunk -> addressing -> list mreg -> mreg -> instruction | Mcall: signature -> mreg + ident -> instruction + | Malloc: instruction | Mlabel: label -> instruction | Mgoto: label -> instruction | Mcond: condition -> list mreg -> label -> instruction @@ -56,9 +59,17 @@ Record function: Set := mkfunction fn_stacksize: Z; fn_framesize: Z }. -Definition program := AST.program function. +Definition fundef := AST.fundef function. -Definition genv := Genv.t function. +Definition program := AST.program fundef. + +Definition funsig (fd: fundef) := + match fd with + | Internal f => f.(fn_sig) + | External ef => ef.(ef_sig) + end. + +Definition genv := Genv.t fundef. (** * Dynamic semantics *) @@ -122,7 +133,7 @@ Section RELSEM. Variable ge: genv. -Definition find_function (ros: mreg + ident) (rs: regset) : option function := +Definition find_function (ros: mreg + ident) (rs: regset) : option fundef := match ros with | inl r => Genv.find_funct ge (rs r) | inr symb => @@ -141,95 +152,104 @@ Definition find_function (ros: mreg + ident) (rs: regset) : option function := Inductive exec_instr: function -> val -> - code -> regset -> mem -> + code -> regset -> mem -> trace -> code -> regset -> mem -> Prop := | exec_Mlabel: forall f sp lbl c rs m, exec_instr f sp (Mlabel lbl :: c) rs m - c rs m + E0 c rs m | exec_Mgetstack: forall f sp ofs ty dst c rs m v, load_stack m sp ty ofs = Some v -> exec_instr f sp (Mgetstack ofs ty dst :: c) rs m - c (rs#dst <- v) m + E0 c (rs#dst <- v) m | exec_Msetstack: forall f sp src ofs ty c rs m m', store_stack m sp ty ofs (rs src) = Some m' -> exec_instr f sp (Msetstack src ofs ty :: c) rs m - c rs m' + E0 c rs m' | exec_Mgetparam: forall f sp parent ofs ty dst c rs m v, load_stack m sp Tint (Int.repr 0) = Some parent -> load_stack m parent ty ofs = Some v -> exec_instr f sp (Mgetparam ofs ty dst :: c) rs m - c (rs#dst <- v) m + E0 c (rs#dst <- v) m | exec_Mop: forall f sp op args res c rs m v, eval_operation ge sp op rs##args = Some v -> exec_instr f sp (Mop op args res :: c) rs m - c (rs#res <- v) m + E0 c (rs#res <- v) m | exec_Mload: forall f sp chunk addr args dst c rs m a v, eval_addressing ge sp addr rs##args = Some a -> Mem.loadv chunk m a = Some v -> exec_instr f sp (Mload chunk addr args dst :: c) rs m - c (rs#dst <- v) m + E0 c (rs#dst <- v) m | exec_Mstore: forall f sp chunk addr args src c rs m m' a, eval_addressing ge sp addr rs##args = Some a -> Mem.storev chunk m a (rs src) = Some m' -> exec_instr f sp (Mstore chunk addr args src :: c) rs m - c rs m' + E0 c rs m' | exec_Mcall: - forall f sp sig ros c rs m f' rs' m', + forall f sp sig ros c rs m f' t rs' m', find_function ros rs = Some f' -> - exec_function f' sp rs m rs' m' -> + exec_function f' sp rs m t rs' m' -> exec_instr f sp (Mcall sig ros :: c) rs m - c rs' m' + t c rs' m' + | exec_Malloc: + forall f sp c rs m sz m' blk, + rs (Conventions.loc_alloc_argument) = Vint sz -> + Mem.alloc m 0 (Int.signed sz) = (m', blk) -> + exec_instr f sp + (Malloc :: c) rs m + E0 c (rs#Conventions.loc_alloc_result <- + (Vptr blk Int.zero)) m' | exec_Mgoto: forall f sp lbl c rs m c', find_label lbl f.(fn_code) = Some c' -> exec_instr f sp (Mgoto lbl :: c) rs m - c' rs m + E0 c' rs m | exec_Mcond_true: forall f sp cond args lbl c rs m c', eval_condition cond rs##args = Some true -> find_label lbl f.(fn_code) = Some c' -> exec_instr f sp (Mcond cond args lbl :: c) rs m - c' rs m + E0 c' rs m | exec_Mcond_false: forall f sp cond args lbl c rs m, eval_condition cond rs##args = Some false -> exec_instr f sp (Mcond cond args lbl :: c) rs m - c rs m + E0 c rs m with exec_instrs: function -> val -> - code -> regset -> mem -> + code -> regset -> mem -> trace -> code -> regset -> mem -> Prop := | exec_refl: forall f sp c rs m, - exec_instrs f sp c rs m c rs m + exec_instrs f sp c rs m E0 c rs m | exec_one: - forall f sp c rs m c' rs' m', - exec_instr f sp c rs m c' rs' m' -> - exec_instrs f sp c rs m c' rs' m' + forall f sp c rs m t c' rs' m', + exec_instr f sp c rs m t c' rs' m' -> + exec_instrs f sp c rs m t c' rs' m' | exec_trans: - forall f sp c1 rs1 m1 c2 rs2 m2 c3 rs3 m3, - exec_instrs f sp c1 rs1 m1 c2 rs2 m2 -> - exec_instrs f sp c2 rs2 m2 c3 rs3 m3 -> - exec_instrs f sp c1 rs1 m1 c3 rs3 m3 + forall f sp c1 rs1 m1 t1 c2 rs2 m2 t2 c3 rs3 m3 t3, + exec_instrs f sp c1 rs1 m1 t1 c2 rs2 m2 -> + exec_instrs f sp c2 rs2 m2 t2 c3 rs3 m3 -> + t3 = t1 ** t2 -> + exec_instrs f sp c1 rs1 m1 t3 c3 rs3 m3 (** In addition to reserving the word at offset 0 in the activation record for maintaining the linking of activation records, @@ -252,9 +272,9 @@ with exec_instrs: with exec_function_body: function -> val -> val -> - regset -> mem -> regset -> mem -> Prop := + regset -> mem -> trace -> regset -> mem -> Prop := | exec_funct_body: - forall f parent ra rs m rs' m1 m2 m3 m4 stk c, + forall f parent ra rs m t rs' m1 m2 m3 m4 stk c, Mem.alloc m (- f.(fn_framesize)) (align_16_top (- f.(fn_framesize)) f.(fn_stacksize)) = (m1, stk) -> @@ -263,19 +283,25 @@ with exec_function_body: store_stack m2 sp Tint (Int.repr 4) ra = Some m3 -> exec_instrs f sp f.(fn_code) rs m3 - (Mreturn :: c) rs' m4 -> + t (Mreturn :: c) rs' m4 -> load_stack m4 sp Tint (Int.repr 0) = Some parent -> load_stack m4 sp Tint (Int.repr 4) = Some ra -> - exec_function_body f parent ra rs m rs' (Mem.free m4 stk) + exec_function_body f parent ra rs m t rs' (Mem.free m4 stk) with exec_function: - function -> val -> regset -> mem -> regset -> mem -> Prop := - | exec_funct: - forall f parent rs m rs' m', + fundef -> val -> regset -> mem -> trace -> regset -> mem -> Prop := + | exec_funct_internal: + forall f parent rs m t rs' m', (forall ra, Val.has_type ra Tint -> - exec_function_body f parent ra rs m rs' m') -> - exec_function f parent rs m rs' m'. + exec_function_body f parent ra rs m t rs' m') -> + exec_function (Internal f) parent rs m t rs' m' + | exec_funct_external: + forall ef parent args res rs1 rs2 m t, + event_match ef args t res -> + args = rs1##(Conventions.loc_external_arguments ef.(ef_sig)) -> + rs2 = (rs1#(Conventions.loc_result ef.(ef_sig)) <- res) -> + exec_function (External ef) parent rs1 m t rs2 m. Scheme exec_instr_ind4 := Minimality for exec_instr Sort Prop with exec_instrs_ind4 := Minimality for exec_instrs Sort Prop @@ -284,12 +310,13 @@ Scheme exec_instr_ind4 := Minimality for exec_instr Sort Prop End RELSEM. -Definition exec_program (p: program) (r: val) : Prop := +Definition exec_program (p: program) (t: trace) (r: val) : Prop := let ge := Genv.globalenv p in let m0 := Genv.init_mem p in exists b, exists f, exists rs, exists m, Genv.find_symbol ge p.(prog_main) = Some b /\ Genv.find_funct_ptr ge b = Some f /\ - exec_function ge f (Vptr Mem.nullptr Int.zero) (Regmap.init Vundef) m0 rs m /\ + exec_function ge f (Vptr Mem.nullptr Int.zero) (Regmap.init Vundef) m0 + t rs m /\ rs R3 = r. diff --git a/backend/Machabstr.v b/backend/Machabstr.v index 25458dc..8d5d72a 100644 --- a/backend/Machabstr.v +++ b/backend/Machabstr.v @@ -7,6 +7,7 @@ Require Import Mem. Require Import Integers. Require Import Values. Require Import Mem. +Require Import Events. Require Import Globalenvs. Require Import Op. Require Import Locations. @@ -99,117 +100,132 @@ Variable ge: genv. Inductive exec_instr: function -> val -> frame -> - code -> regset -> frame -> mem -> + code -> regset -> frame -> mem -> trace -> code -> regset -> frame -> mem -> Prop := | exec_Mlabel: forall f sp parent lbl c rs fr m, exec_instr f sp parent (Mlabel lbl :: c) rs fr m - c rs fr m + E0 c rs fr m | exec_Mgetstack: forall f sp parent ofs ty dst c rs fr m v, get_slot fr ty (Int.signed ofs) v -> exec_instr f sp parent (Mgetstack ofs ty dst :: c) rs fr m - c (rs#dst <- v) fr m + E0 c (rs#dst <- v) fr m | exec_Msetstack: forall f sp parent src ofs ty c rs fr m fr', set_slot fr ty (Int.signed ofs) (rs src) fr' -> exec_instr f sp parent (Msetstack src ofs ty :: c) rs fr m - c rs fr' m + E0 c rs fr' m | exec_Mgetparam: forall f sp parent ofs ty dst c rs fr m v, get_slot parent ty (Int.signed ofs) v -> exec_instr f sp parent (Mgetparam ofs ty dst :: c) rs fr m - c (rs#dst <- v) fr m + E0 c (rs#dst <- v) fr m | exec_Mop: forall f sp parent op args res c rs fr m v, eval_operation ge sp op rs##args = Some v -> exec_instr f sp parent (Mop op args res :: c) rs fr m - c (rs#res <- v) fr m + E0 c (rs#res <- v) fr m | exec_Mload: forall f sp parent chunk addr args dst c rs fr m a v, eval_addressing ge sp addr rs##args = Some a -> Mem.loadv chunk m a = Some v -> exec_instr f sp parent (Mload chunk addr args dst :: c) rs fr m - c (rs#dst <- v) fr m + E0 c (rs#dst <- v) fr m | exec_Mstore: forall f sp parent chunk addr args src c rs fr m m' a, eval_addressing ge sp addr rs##args = Some a -> Mem.storev chunk m a (rs src) = Some m' -> exec_instr f sp parent (Mstore chunk addr args src :: c) rs fr m - c rs fr m' + E0 c rs fr m' | exec_Mcall: - forall f sp parent sig ros c rs fr m f' rs' m', + forall f sp parent sig ros c rs fr m t f' rs' m', find_function ge ros rs = Some f' -> - exec_function f' fr rs m rs' m' -> + exec_function f' fr rs m t rs' m' -> exec_instr f sp parent (Mcall sig ros :: c) rs fr m - c rs' fr m' + t c rs' fr m' + | exec_Malloc: + forall f sp parent c rs fr m sz m' blk, + rs (Conventions.loc_alloc_argument) = Vint sz -> + Mem.alloc m 0 (Int.signed sz) = (m', blk) -> + exec_instr f sp parent + (Malloc :: c) rs fr m + E0 c (rs#Conventions.loc_alloc_result <- + (Vptr blk Int.zero)) fr m' | exec_Mgoto: forall f sp parent lbl c rs fr m c', find_label lbl f.(fn_code) = Some c' -> exec_instr f sp parent (Mgoto lbl :: c) rs fr m - c' rs fr m + E0 c' rs fr m | exec_Mcond_true: forall f sp parent cond args lbl c rs fr m c', eval_condition cond rs##args = Some true -> find_label lbl f.(fn_code) = Some c' -> exec_instr f sp parent (Mcond cond args lbl :: c) rs fr m - c' rs fr m + E0 c' rs fr m | exec_Mcond_false: forall f sp parent cond args lbl c rs fr m, eval_condition cond rs##args = Some false -> exec_instr f sp parent (Mcond cond args lbl :: c) rs fr m - c rs fr m + E0 c rs fr m with exec_instrs: function -> val -> frame -> - code -> regset -> frame -> mem -> + code -> regset -> frame -> mem -> trace -> code -> regset -> frame -> mem -> Prop := | exec_refl: forall f sp parent c rs fr m, - exec_instrs f sp parent c rs fr m c rs fr m + exec_instrs f sp parent c rs fr m E0 c rs fr m | exec_one: - forall f sp parent c rs fr m c' rs' fr' m', - exec_instr f sp parent c rs fr m c' rs' fr' m' -> - exec_instrs f sp parent c rs fr m c' rs' fr' m' + forall f sp parent c rs fr m t c' rs' fr' m', + exec_instr f sp parent c rs fr m t c' rs' fr' m' -> + exec_instrs f sp parent c rs fr m t c' rs' fr' m' | exec_trans: - forall f sp parent c1 rs1 fr1 m1 c2 rs2 fr2 m2 c3 rs3 fr3 m3, - exec_instrs f sp parent c1 rs1 fr1 m1 c2 rs2 fr2 m2 -> - exec_instrs f sp parent c2 rs2 fr2 m2 c3 rs3 fr3 m3 -> - exec_instrs f sp parent c1 rs1 fr1 m1 c3 rs3 fr3 m3 + forall f sp parent c1 rs1 fr1 m1 t1 c2 rs2 fr2 m2 t2 c3 rs3 fr3 m3 t3, + exec_instrs f sp parent c1 rs1 fr1 m1 t1 c2 rs2 fr2 m2 -> + exec_instrs f sp parent c2 rs2 fr2 m2 t2 c3 rs3 fr3 m3 -> + t3 = t1 ** t2 -> + exec_instrs f sp parent c1 rs1 fr1 m1 t3 c3 rs3 fr3 m3 with exec_function_body: function -> frame -> val -> val -> - regset -> mem -> regset -> mem -> Prop := + regset -> mem -> trace -> regset -> mem -> Prop := | exec_funct_body: - forall f parent link ra rs m rs' m1 m2 stk fr1 fr2 fr3 c, + forall f parent link ra rs m t rs' m1 m2 stk fr1 fr2 fr3 c, Mem.alloc m 0 f.(fn_stacksize) = (m1, stk) -> set_slot (init_frame f) Tint 0 link fr1 -> set_slot fr1 Tint 4 ra fr2 -> exec_instrs f (Vptr stk (Int.repr (-f.(fn_framesize)))) parent f.(fn_code) rs fr2 m1 - (Mreturn :: c) rs' fr3 m2 -> - exec_function_body f parent link ra rs m rs' (Mem.free m2 stk) + t (Mreturn :: c) rs' fr3 m2 -> + exec_function_body f parent link ra rs m t rs' (Mem.free m2 stk) with exec_function: - function -> frame -> regset -> mem -> regset -> mem -> Prop := - | exec_funct: - forall f parent rs m rs' m', + fundef -> frame -> regset -> mem -> trace -> regset -> mem -> Prop := + | exec_funct_internal: + forall f parent rs m t rs' m', (forall link ra, Val.has_type link Tint -> Val.has_type ra Tint -> - exec_function_body f parent link ra rs m rs' m') -> - exec_function f parent rs m rs' m'. + exec_function_body f parent link ra rs m t rs' m') -> + exec_function (Internal f) parent rs m t rs' m' + | exec_funct_external: + forall ef parent args res rs1 rs2 m t, + event_match ef args t res -> + args = rs1##(Conventions.loc_external_arguments ef.(ef_sig)) -> + rs2 = (rs1#(Conventions.loc_result ef.(ef_sig)) <- res) -> + exec_function (External ef) parent rs1 m t rs2 m. Scheme exec_instr_ind4 := Minimality for exec_instr Sort Prop with exec_instrs_ind4 := Minimality for exec_instrs Sort Prop @@ -222,134 +238,155 @@ Scheme exec_instr_ind4 := Minimality for exec_instr Sort Prop by the [Scheme] command above. *) Lemma exec_mutual_induction: - forall (P + forall + (P P0 : function -> val -> frame -> code -> regset -> - frame -> mem -> code -> regset -> frame -> mem -> Prop) + frame -> + mem -> trace -> code -> regset -> frame -> mem -> Prop) (P1 : function -> - frame -> val -> val -> regset -> mem -> regset -> mem -> Prop) - (P2 : function -> frame -> regset -> mem -> regset -> mem -> Prop), + frame -> + val -> val -> regset -> mem -> trace -> regset -> mem -> Prop) + (P2 : fundef -> + frame -> regset -> mem -> trace -> regset -> mem -> Prop), (forall (f : function) (sp : val) (parent : frame) (lbl : label) (c : list instruction) (rs : regset) (fr : frame) (m : mem), - P f sp parent (Mlabel lbl :: c) rs fr m c rs fr m) -> - (forall (f : function) (sp : val) (parent : frame) (ofs : int) + P f sp parent (Mlabel lbl :: c) rs fr m E0 c rs fr m) -> + (forall (f0 : function) (sp : val) (parent : frame) (ofs : int) (ty : typ) (dst : mreg) (c : list instruction) (rs : regset) (fr : frame) (m : mem) (v : val), get_slot fr ty (Int.signed ofs) v -> - P f sp parent (Mgetstack ofs ty dst :: c) rs fr m c rs # dst <- v fr - m) -> - (forall (f : function) (sp : val) (parent : frame) (src : mreg) + P f0 sp parent (Mgetstack ofs ty dst :: c) rs fr m E0 c rs # dst <- v + fr m) -> + (forall (f1 : function) (sp : val) (parent : frame) (src : mreg) (ofs : int) (ty : typ) (c : list instruction) (rs : mreg -> val) (fr : frame) (m : mem) (fr' : frame), set_slot fr ty (Int.signed ofs) (rs src) fr' -> - P f sp parent (Msetstack src ofs ty :: c) rs fr m c rs fr' m) -> - (forall (f : function) (sp : val) (parent : frame) (ofs : int) + P f1 sp parent (Msetstack src ofs ty :: c) rs fr m E0 c rs fr' m) -> + (forall (f2 : function) (sp : val) (parent : frame) (ofs : int) (ty : typ) (dst : mreg) (c : list instruction) (rs : regset) (fr : frame) (m : mem) (v : val), get_slot parent ty (Int.signed ofs) v -> - P f sp parent (Mgetparam ofs ty dst :: c) rs fr m c rs # dst <- v fr - m) -> - (forall (f : function) (sp : val) (parent : frame) (op : operation) + P f2 sp parent (Mgetparam ofs ty dst :: c) rs fr m E0 c rs # dst <- v + fr m) -> + (forall (f3 : function) (sp : val) (parent : frame) (op : operation) (args : list mreg) (res : mreg) (c : list instruction) (rs : mreg -> val) (fr : frame) (m : mem) (v : val), eval_operation ge sp op rs ## args = Some v -> - P f sp parent (Mop op args res :: c) rs fr m c rs # res <- v fr m) -> - (forall (f : function) (sp : val) (parent : frame) + P f3 sp parent (Mop op args res :: c) rs fr m E0 c rs # res <- v fr m) -> + (forall (f4 : function) (sp : val) (parent : frame) (chunk : memory_chunk) (addr : addressing) (args : list mreg) (dst : mreg) (c : list instruction) (rs : mreg -> val) (fr : frame) (m : mem) (a v : val), eval_addressing ge sp addr rs ## args = Some a -> loadv chunk m a = Some v -> - P f sp parent (Mload chunk addr args dst :: c) rs fr m c + P f4 sp parent (Mload chunk addr args dst :: c) rs fr m E0 c rs # dst <- v fr m) -> - (forall (f : function) (sp : val) (parent : frame) + (forall (f5 : function) (sp : val) (parent : frame) (chunk : memory_chunk) (addr : addressing) (args : list mreg) (src : mreg) (c : list instruction) (rs : mreg -> val) (fr : frame) (m m' : mem) (a : val), eval_addressing ge sp addr rs ## args = Some a -> storev chunk m a (rs src) = Some m' -> - P f sp parent (Mstore chunk addr args src :: c) rs fr m c rs fr m') -> - (forall (f : function) (sp : val) (parent : frame) (sig : signature) + P f5 sp parent (Mstore chunk addr args src :: c) rs fr m E0 c rs fr + m') -> + (forall (f6 : function) (sp : val) (parent : frame) (sig : signature) (ros : mreg + ident) (c : list instruction) (rs : regset) - (fr : frame) (m : mem) (f' : function) (rs' : regset) (m' : mem), + (fr : frame) (m : mem) (t : trace) (f' : fundef) (rs' : regset) + (m' : mem), find_function ge ros rs = Some f' -> - exec_function f' fr rs m rs' m' -> - P2 f' fr rs m rs' m' -> - P f sp parent (Mcall sig ros :: c) rs fr m c rs' fr m') -> - (forall (f : function) (sp : val) (parent : frame) (lbl : label) - (c : list instruction) (rs : regset) (fr : frame) (m : mem) - (c' : code), - find_label lbl (fn_code f) = Some c' -> - P f sp parent (Mgoto lbl :: c) rs fr m c' rs fr m) -> - (forall (f : function) (sp : val) (parent : frame) - (cond : condition) (args : list mreg) (lbl : label) + exec_function f' fr rs m t rs' m' -> + P2 f' fr rs m t rs' m' -> + P f6 sp parent (Mcall sig ros :: c) rs fr m t c rs' fr m') -> + (forall (f7 : function) (sp : val) (parent : frame) (c : list instruction) (rs : mreg -> val) (fr : frame) (m : mem) + (sz : int) (m' : mem) (blk : block), + rs Conventions.loc_alloc_argument = Vint sz -> + alloc m 0 (Int.signed sz) = (m', blk) -> + P f7 sp parent (Malloc :: c) rs fr m E0 c + rs # Conventions.loc_alloc_result <- (Vptr blk Int.zero) fr m') -> + (forall (f7 : function) (sp : val) (parent : frame) (lbl : label) + (c : list instruction) (rs : regset) (fr : frame) (m : mem) (c' : code), + find_label lbl (fn_code f7) = Some c' -> + P f7 sp parent (Mgoto lbl :: c) rs fr m E0 c' rs fr m) -> + (forall (f8 : function) (sp : val) (parent : frame) (cond : condition) + (args : list mreg) (lbl : label) (c : list instruction) + (rs : mreg -> val) (fr : frame) (m : mem) (c' : code), eval_condition cond rs ## args = Some true -> - find_label lbl (fn_code f) = Some c' -> - P f sp parent (Mcond cond args lbl :: c) rs fr m c' rs fr m) -> - (forall (f : function) (sp : val) (parent : frame) - (cond : condition) (args : list mreg) (lbl : label) - (c : list instruction) (rs : mreg -> val) (fr : frame) (m : mem), + find_label lbl (fn_code f8) = Some c' -> + P f8 sp parent (Mcond cond args lbl :: c) rs fr m E0 c' rs fr m) -> + (forall (f9 : function) (sp : val) (parent : frame) (cond : condition) + (args : list mreg) (lbl : label) (c : list instruction) + (rs : mreg -> val) (fr : frame) (m : mem), eval_condition cond rs ## args = Some false -> - P f sp parent (Mcond cond args lbl :: c) rs fr m c rs fr m) -> - (forall (f : function) (sp : val) (parent : frame) (c : code) + P f9 sp parent (Mcond cond args lbl :: c) rs fr m E0 c rs fr m) -> + (forall (f10 : function) (sp : val) (parent : frame) (c : code) (rs : regset) (fr : frame) (m : mem), - P0 f sp parent c rs fr m c rs fr m) -> - (forall (f : function) (sp : val) (parent : frame) (c : code) - (rs : regset) (fr : frame) (m : mem) (c' : code) (rs' : regset) - (fr' : frame) (m' : mem), - exec_instr f sp parent c rs fr m c' rs' fr' m' -> - P f sp parent c rs fr m c' rs' fr' m' -> - P0 f sp parent c rs fr m c' rs' fr' m') -> - (forall (f : function) (sp : val) (parent : frame) (c1 : code) - (rs1 : regset) (fr1 : frame) (m1 : mem) (c2 : code) (rs2 : regset) - (fr2 : frame) (m2 : mem) (c3 : code) (rs3 : regset) (fr3 : frame) - (m3 : mem), - exec_instrs f sp parent c1 rs1 fr1 m1 c2 rs2 fr2 m2 -> - P0 f sp parent c1 rs1 fr1 m1 c2 rs2 fr2 m2 -> - exec_instrs f sp parent c2 rs2 fr2 m2 c3 rs3 fr3 m3 -> - P0 f sp parent c2 rs2 fr2 m2 c3 rs3 fr3 m3 -> - P0 f sp parent c1 rs1 fr1 m1 c3 rs3 fr3 m3) -> - (forall (f : function) (parent : frame) (link ra : val) (rs : regset) - (m : mem) (rs' : regset) (m1 m2 : mem) (stk : block) - (fr1 fr2 fr3 : frame) (c : list instruction), - alloc m 0 (fn_stacksize f) = (m1, stk) -> - set_slot (init_frame f) Tint 0 link fr1 -> + P0 f10 sp parent c rs fr m E0 c rs fr m) -> + (forall (f11 : function) (sp : val) (parent : frame) (c : code) + (rs : regset) (fr : frame) (m : mem) (t : trace) (c' : code) + (rs' : regset) (fr' : frame) (m' : mem), + exec_instr f11 sp parent c rs fr m t c' rs' fr' m' -> + P f11 sp parent c rs fr m t c' rs' fr' m' -> + P0 f11 sp parent c rs fr m t c' rs' fr' m') -> + (forall (f12 : function) (sp : val) (parent : frame) (c1 : code) + (rs1 : regset) (fr1 : frame) (m1 : mem) (t1 : trace) (c2 : code) + (rs2 : regset) (fr2 : frame) (m2 : mem) (t2 : trace) (c3 : code) + (rs3 : regset) (fr3 : frame) (m3 : mem) (t3 : trace), + exec_instrs f12 sp parent c1 rs1 fr1 m1 t1 c2 rs2 fr2 m2 -> + P0 f12 sp parent c1 rs1 fr1 m1 t1 c2 rs2 fr2 m2 -> + exec_instrs f12 sp parent c2 rs2 fr2 m2 t2 c3 rs3 fr3 m3 -> + P0 f12 sp parent c2 rs2 fr2 m2 t2 c3 rs3 fr3 m3 -> + t3 = t1 ** t2 -> P0 f12 sp parent c1 rs1 fr1 m1 t3 c3 rs3 fr3 m3) -> + (forall (f13 : function) (parent : frame) (link ra : val) + (rs : regset) (m : mem) (t : trace) (rs' : regset) (m1 m2 : mem) + (stk : block) (fr1 fr2 fr3 : frame) (c : list instruction), + alloc m 0 (fn_stacksize f13) = (m1, stk) -> + set_slot (init_frame f13) Tint 0 link fr1 -> set_slot fr1 Tint 4 ra fr2 -> - exec_instrs f (Vptr stk (Int.repr (-f.(fn_framesize)))) parent (fn_code f) rs fr2 m1 (Mreturn :: c) rs' fr3 - m2 -> - P0 f (Vptr stk (Int.repr (-f.(fn_framesize)))) parent (fn_code f) rs fr2 m1 (Mreturn :: c) rs' fr3 m2 -> - P1 f parent link ra rs m rs' (free m2 stk)) -> - (forall (f : function) (parent : frame) (rs : regset) (m : mem) - (rs' : regset) (m' : mem), + exec_instrs f13 (Vptr stk (Int.repr (- fn_framesize f13))) parent + (fn_code f13) rs fr2 m1 t (Mreturn :: c) rs' fr3 m2 -> + P0 f13 (Vptr stk (Int.repr (- fn_framesize f13))) parent + (fn_code f13) rs fr2 m1 t (Mreturn :: c) rs' fr3 m2 -> + P1 f13 parent link ra rs m t rs' (free m2 stk)) -> + (forall (f14 : function) (parent : frame) (rs : regset) (m : mem) + (t : trace) (rs' : regset) (m' : mem), (forall link ra : val, Val.has_type link Tint -> Val.has_type ra Tint -> - exec_function_body f parent link ra rs m rs' m') -> + exec_function_body f14 parent link ra rs m t rs' m') -> (forall link ra : val, Val.has_type link Tint -> - Val.has_type ra Tint -> P1 f parent link ra rs m rs' m') -> - P2 f parent rs m rs' m') -> - (forall (f15 : function) (sp : val) (f16 : frame) (c : code) - (r : regset) (f17 : frame) (m : mem) (c0 : code) (r0 : regset) - (f18 : frame) (m0 : mem), - exec_instr f15 sp f16 c r f17 m c0 r0 f18 m0 -> - P f15 sp f16 c r f17 m c0 r0 f18 m0) - /\ (forall (f15 : function) (sp : val) (f16 : frame) (c : code) - (r : regset) (f17 : frame) (m : mem) (c0 : code) (r0 : regset) - (f18 : frame) (m0 : mem), - exec_instrs f15 sp f16 c r f17 m c0 r0 f18 m0 -> - P0 f15 sp f16 c r f17 m c0 r0 f18 m0) - /\ (forall (f15 : function) (f16 : frame) (v1 v2 : val) (r : regset) (m : mem) - (r0 : regset) (m0 : mem), - exec_function_body f15 f16 v1 v2 r m r0 m0 -> P1 f15 f16 v1 v2 r m r0 m0) - /\ (forall (f15 : function) (f16 : frame) (r : regset) (m : mem) + Val.has_type ra Tint -> P1 f14 parent link ra rs m t rs' m') -> + P2 (Internal f14) parent rs m t rs' m') -> + (forall (ef : external_function) (parent : frame) (args : list val) + (res : val) (rs1 : mreg -> val) (rs2 : RegEq.t -> val) (m : mem) + (t0 : trace), + event_match ef args t0 res -> + args = rs1 ## (Conventions.loc_external_arguments (ef_sig ef)) -> + rs2 = rs1 # (Conventions.loc_result (ef_sig ef)) <- res -> + P2 (External ef) parent rs1 m t0 rs2 m) -> + (forall (f16 : function) (v : val) (f17 : frame) (c : code) + (r : regset) (f18 : frame) (m : mem) (t : trace) (c0 : code) + (r0 : regset) (f19 : frame) (m0 : mem), + exec_instr f16 v f17 c r f18 m t c0 r0 f19 m0 -> + P f16 v f17 c r f18 m t c0 r0 f19 m0) + /\ (forall (f16 : function) (v : val) (f17 : frame) (c : code) + (r : regset) (f18 : frame) (m : mem) (t : trace) (c0 : code) + (r0 : regset) (f19 : frame) (m0 : mem), + exec_instrs f16 v f17 c r f18 m t c0 r0 f19 m0 -> + P0 f16 v f17 c r f18 m t c0 r0 f19 m0) + /\ (forall (f16 : function) (f17 : frame) (v v0 : val) (r : regset) + (m : mem) (t : trace) (r0 : regset) (m0 : mem), + exec_function_body f16 f17 v v0 r m t r0 m0 -> + P1 f16 f17 v v0 r m t r0 m0) + /\ (forall (f16 : fundef) (f17 : frame) (r : regset) (m : mem) (t : trace) (r0 : regset) (m0 : mem), - exec_function f15 f16 r m r0 m0 -> P2 f15 f16 r m r0 m0). + exec_function f16 f17 r m t r0 m0 -> P2 f16 f17 r m t r0 m0). Proof. intros. split. apply (exec_instr_ind4 P P0 P1 P2); assumption. split. apply (exec_instrs_ind4 P P0 P1 P2); assumption. @@ -359,13 +396,12 @@ Qed. End RELSEM. -Definition exec_program (p: program) (r: val) : Prop := +Definition exec_program (p: program) (t: trace) (r: val) : Prop := let ge := Genv.globalenv p in let m0 := Genv.init_mem p in exists b, exists f, exists rs, exists m, Genv.find_symbol ge p.(prog_main) = Some b /\ Genv.find_funct_ptr ge b = Some f /\ - f.(fn_sig) = mksignature nil (Some Tint) /\ - exec_function ge f empty_frame (Regmap.init Vundef) m0 rs m /\ - rs (Conventions.loc_result f.(fn_sig)) = r. + exec_function ge f empty_frame (Regmap.init Vundef) m0 t rs m /\ + rs R3 = r. diff --git a/backend/Machabstr2mach.v b/backend/Machabstr2mach.v index 8549cef..0513cbe 100644 --- a/backend/Machabstr2mach.v +++ b/backend/Machabstr2mach.v @@ -6,6 +6,7 @@ Require Import AST. Require Import Integers. Require Import Values. Require Import Mem. +Require Import Events. Require Import Globalenvs. Require Import Op. Require Import Locations. @@ -757,6 +758,36 @@ Proof. exists ms'. split. auto. eapply callstack_store_aux; eauto. Qed. +(** Allocations of heap blocks can be performed in parallel in + both semantics, preserving [callstack_invariant]. *) + +Lemma callstack_alloc: + forall cs mm ms lo hi mm' blk, + callstack_invariant cs mm ms -> + Mem.alloc mm lo hi = (mm', blk) -> + exists ms', + Mem.alloc ms lo hi = (ms', blk) /\ + callstack_invariant cs mm' ms'. +Proof. + intros. inversion H. + caseEq (alloc ms lo hi). intros ms' blk' ALLOC'. + injection H0; intros. injection ALLOC'; intros. + assert (blk' = blk). congruence. rewrite H5 in H3. rewrite H5. + exists ms'; split. auto. + constructor. + (* frame *) + intros; eapply frame_match_alloc; eauto. + (* linked *) + auto. + (* others *) + intros. rewrite <- H2; rewrite <- H4; simpl. + rewrite H1; rewrite H3. unfold update. case (zeq b blk); auto. + (* next *) + rewrite <- H2; rewrite <- H4; simpl; congruence. + (* dom *) + eapply callstack_dom_incr; eauto. rewrite <- H4; simpl. omega. +Qed. + (** At function entry, a new frame is pushed on the call stack, and memory blocks are allocated in both semantics. Moreover, the back link to the caller's activation record is set up @@ -905,7 +936,7 @@ Let ge := Genv.globalenv p. Definition exec_instr_prop (f: function) (sp: val) (parent: frame) - (c: code) (rs: regset) (fr: frame) (mm: mem) + (c: code) (rs: regset) (fr: frame) (mm: mem) (t: trace) (c': code) (rs': regset) (fr': frame) (mm': mem) : Prop := forall ms stk base pstk pbase cs (WTF: wt_function f) @@ -916,12 +947,12 @@ Definition exec_instr_prop (CSI: callstack_invariant ((fr, stk, base) :: (parent, pstk, pbase) :: cs) mm ms) (SP: sp = Vptr stk base), exists ms', - exec_instr ge f sp c rs ms c' rs' ms' /\ + exec_instr ge f sp c rs ms t c' rs' ms' /\ callstack_invariant ((fr', stk, base) :: (parent, pstk, pbase) :: cs) mm' ms'. Definition exec_instrs_prop (f: function) (sp: val) (parent: frame) - (c: code) (rs: regset) (fr: frame) (mm: mem) + (c: code) (rs: regset) (fr: frame) (mm: mem) (t: trace) (c': code) (rs': regset) (fr': frame) (mm': mem) : Prop := forall ms stk base pstk pbase cs (WTF: wt_function f) @@ -932,12 +963,12 @@ Definition exec_instrs_prop (CSI: callstack_invariant ((fr, stk, base) :: (parent, pstk, pbase) :: cs) mm ms) (SP: sp = Vptr stk base), exists ms', - exec_instrs ge f sp c rs ms c' rs' ms' /\ + exec_instrs ge f sp c rs ms t c' rs' ms' /\ callstack_invariant ((fr', stk, base) :: (parent, pstk, pbase) :: cs) mm' ms'. Definition exec_function_body_prop (f: function) (parent: frame) (link ra: val) - (rs: regset) (mm: mem) + (rs: regset) (mm: mem) (t: trace) (rs': regset) (mm': mem) : Prop := forall ms pstk pbase cs (WTF: wt_function f) @@ -947,26 +978,26 @@ Definition exec_function_body_prop (LINK: link = Vptr pstk pbase) (CSI: callstack_invariant ((parent, pstk, pbase) :: cs) mm ms), exists ms', - exec_function_body ge f (Vptr pstk pbase) ra rs ms rs' ms' /\ + exec_function_body ge f (Vptr pstk pbase) ra rs ms t rs' ms' /\ callstack_invariant ((parent, pstk, pbase) :: cs) mm' ms'. Definition exec_function_prop - (f: function) (parent: frame) - (rs: regset) (mm: mem) + (f: fundef) (parent: frame) + (rs: regset) (mm: mem) (t: trace) (rs': regset) (mm': mem) : Prop := forall ms pstk pbase cs - (WTF: wt_function f) + (WTF: wt_fundef f) (WTRS: wt_regset rs) (WTPA: wt_frame parent) (CSI: callstack_invariant ((parent, pstk, pbase) :: cs) mm ms), exists ms', - exec_function ge f (Vptr pstk pbase) rs ms rs' ms' /\ + exec_function ge f (Vptr pstk pbase) rs ms t rs' ms' /\ callstack_invariant ((parent, pstk, pbase) :: cs) mm' ms'. Lemma exec_function_equiv: - forall f parent rs mm rs' mm', - Machabstr.exec_function ge f parent rs mm rs' mm' -> - exec_function_prop f parent rs mm rs' mm'. + forall f parent rs mm t rs' mm', + Machabstr.exec_function ge f parent rs mm t rs' mm' -> + exec_function_prop f parent rs mm t rs' mm'. Proof. apply (Machabstr.exec_function_ind4 ge exec_instr_prop @@ -1009,16 +1040,22 @@ Proof. auto. (* Mcall *) red in H1. - assert (WTF': wt_function f'). + assert (WTF': wt_fundef f'). destruct ros; simpl in H. - apply (Genv.find_funct_prop wt_function wt_p H). + apply (Genv.find_funct_prop wt_fundef wt_p H). destruct (Genv.find_symbol ge i); try discriminate. - apply (Genv.find_funct_ptr_prop wt_function wt_p H). + apply (Genv.find_funct_ptr_prop wt_fundef wt_p H). generalize (H1 _ _ _ _ WTF' WTRS WTFR CSI). intros [ms' [EXF CSI']]. exists ms'. split. apply exec_Mcall with f'; auto. rewrite SP. auto. auto. + (* Malloc *) + generalize (callstack_alloc _ _ _ _ _ _ _ CSI H0). + intros [ms' [ALLOC' CSI']]. + exists ms'; split. + eapply exec_Malloc; eauto. + auto. (* Mgoto *) exists ms. split. constructor; auto. auto. (* Mcond *) @@ -1033,7 +1070,7 @@ Proof. exists ms'. split. apply exec_one; auto. auto. (* trans *) generalize (subject_reduction_instrs p wt_p - _ _ _ _ _ _ _ _ _ _ _ H WTF INCL WTRS WTFR WTPA). + _ _ _ _ _ _ _ _ _ _ _ _ H WTF INCL WTRS WTFR WTPA). intros [INCL2 [WTRS2 WTFR2]]. generalize (H0 _ _ _ _ _ _ WTF INCL WTRS WTFR WTPA CSI SP). intros [ms1 [EX1 CSI1]]. @@ -1069,7 +1106,7 @@ Proof. generalize (H3 _ _ _ _ _ _ WTF (incl_refl _) WTRS WTFR2 WTPA CSI3 (refl_equal _)). intros [ms4 [EXEC CSI4]]. - generalize (exec_instrs_link_invariant _ _ _ _ _ _ _ _ _ _ _ _ + generalize (exec_instrs_link_invariant _ _ _ _ _ _ _ _ _ _ _ _ _ H2 WTF (incl_refl _)). intros [INCL LINKINV]. exists (free ms4 stk). split. @@ -1082,39 +1119,42 @@ Proof. apply LINKINV. rewrite FOUR. omega. eapply slot_gss; eauto. auto. eapply callstack_function_return; eauto. - (* function *) + (* internal function *) + inversion WTF. subst f0. generalize (H0 (Vptr pstk pbase) Vzero I I - ms pstk pbase cs WTF WTRS WTPA I (refl_equal _) CSI). + ms pstk pbase cs H2 WTRS WTPA I (refl_equal _) CSI). intros [ms' [EXEC CSI']]. exists ms'. split. constructor. intros. generalize (H0 (Vptr pstk pbase) ra I H1 - ms pstk pbase cs WTF WTRS WTPA H1 (refl_equal _) CSI). + ms pstk pbase cs H2 WTRS WTPA H1 (refl_equal _) CSI). intros [ms1 [EXEC1 CSI1]]. rewrite (callstack_exten _ _ _ _ CSI' CSI1). auto. auto. + + (* external function *) + exists ms; split. econstructor; eauto. auto. Qed. End SIMULATION. Theorem exec_program_equiv: - forall p r, + forall p t r, wt_program p -> - Machabstr.exec_program p r -> - Mach.exec_program p r. + Machabstr.exec_program p t r -> + Mach.exec_program p t r. Proof. - intros p r WTP [fptr [f [rs [mm [FINDPTR [FINDF [SIG [EXEC RES]]]]]]]]. - assert (WTF: wt_function f). - apply (Genv.find_funct_ptr_prop wt_function WTP FINDF). + intros p t r WTP [fptr [f [rs [mm [FINDPTR [FINDF [EXEC RES]]]]]]]. + assert (WTF: wt_fundef f). + apply (Genv.find_funct_ptr_prop wt_fundef WTP FINDF). assert (WTRS: wt_regset (Regmap.init Vundef)). red; intros. rewrite Regmap.gi; simpl; auto. assert (WTFR: wt_frame empty_frame). red; intros. simpl. auto. generalize (exec_function_equiv p WTP f empty_frame - (Regmap.init Vundef) (Genv.init_mem p) rs mm + (Regmap.init Vundef) (Genv.init_mem p) t rs mm EXEC (Genv.init_mem p) nullptr Int.zero nil WTF WTRS WTFR (callstack_init p)). intros [ms' [EXEC' CSI]]. - red. exists fptr; exists f; exists rs; exists ms'. - intuition. rewrite SIG in RES. exact RES. + red. exists fptr; exists f; exists rs; exists ms'. tauto. Qed. diff --git a/backend/Machtyping.v b/backend/Machtyping.v index 987269b..92f283b 100644 --- a/backend/Machtyping.v +++ b/backend/Machtyping.v @@ -7,6 +7,7 @@ Require Import Mem. Require Import Integers. Require Import Values. Require Import Mem. +Require Import Events. Require Import Globalenvs. Require Import Op. Require Import Locations. @@ -57,6 +58,8 @@ Inductive wt_instr : instruction -> Prop := forall sig ros, match ros with inl r => mreg_type r = Tint | inr s => True end -> wt_instr (Mcall sig ros) + | wt_Malloc: + wt_instr Malloc | wt_Mgoto: forall lbl, wt_instr (Mgoto lbl) @@ -78,8 +81,16 @@ Record wt_function (f: function) : Prop := mk_wt_function { f.(fn_framesize) <= -Int.min_signed }. +Inductive wt_fundef: fundef -> Prop := + | wt_fundef_external: forall ef, + Conventions.sig_external_ok ef.(ef_sig) -> + wt_fundef (External ef) + | wt_function_internal: forall f, + wt_function f -> + wt_fundef (Internal f). + Definition wt_program (p: program) : Prop := - forall i f, In (i, f) (prog_funct p) -> wt_function f. + forall i f, In (i, f) (prog_funct p) -> wt_fundef f. (** * Type soundness *) @@ -89,8 +100,8 @@ Require Import Machabstr. of Mach: for a well-typed Mach program, if a transition is taken from a state where registers hold values of their static types, registers in the final state hold values of their static types - as well. This is a progress theorem for our type system. - It is used in the proof of implcation from the abstract Mach + as well. This is a subject reduction theorem for our type system. + It is used in the proof of implication from the abstract Mach semantics to the concrete Mach semantics (file [Machabstr2mach]). *) @@ -183,6 +194,14 @@ Proof. apply incl_tl; auto. Qed. +Lemma wt_event_match: + forall ef args t res, + event_match ef args t res -> + Val.has_type res (proj_sig_res ef.(ef_sig)). +Proof. + induction 1. inversion H0; exact I. +Qed. + Section SUBJECT_REDUCTION. Variable p: program. @@ -191,7 +210,7 @@ Let ge := Genv.globalenv p. Definition exec_instr_prop (f: function) (sp: val) (parent: frame) - (c1: code) (rs1: regset) (fr1: frame) (m1: mem) + (c1: code) (rs1: regset) (fr1: frame) (m1: mem) (t: trace) (c2: code) (rs2: regset) (fr2: frame) (m2: mem) := forall (WTF: wt_function f) (INCL: incl c1 f.(fn_code)) @@ -201,7 +220,7 @@ Definition exec_instr_prop incl c2 f.(fn_code) /\ wt_regset rs2 /\ wt_frame fr2. Definition exec_function_body_prop (f: function) (parent: frame) (link ra: val) - (rs1: regset) (m1: mem) (rs2: regset) (m2: mem) := + (rs1: regset) (m1: mem) (t: trace) (rs2: regset) (m2: mem) := forall (WTF: wt_function f) (WTRS: wt_regset rs1) (WTPA: wt_frame parent) @@ -209,26 +228,26 @@ Definition exec_function_body_prop (WTRA: Val.has_type ra Tint), wt_regset rs2. Definition exec_function_prop - (f: function) (parent: frame) - (rs1: regset) (m1: mem) (rs2: regset) (m2: mem) := - forall (WTF: wt_function f) + (f: fundef) (parent: frame) + (rs1: regset) (m1: mem) (t: trace) (rs2: regset) (m2: mem) := + forall (WTF: wt_fundef f) (WTRS: wt_regset rs1) (WTPA: wt_frame parent), wt_regset rs2. Lemma subject_reduction: - (forall f sp parent c1 rs1 fr1 m1 c2 rs2 fr2 m2, - exec_instr ge f sp parent c1 rs1 fr1 m1 c2 rs2 fr2 m2 -> - exec_instr_prop f sp parent c1 rs1 fr1 m1 c2 rs2 fr2 m2) -/\ (forall f sp parent c1 rs1 fr1 m1 c2 rs2 fr2 m2, - exec_instrs ge f sp parent c1 rs1 fr1 m1 c2 rs2 fr2 m2 -> - exec_instr_prop f sp parent c1 rs1 fr1 m1 c2 rs2 fr2 m2) -/\ (forall f parent link ra rs1 m1 rs2 m2, - exec_function_body ge f parent link ra rs1 m1 rs2 m2 -> - exec_function_body_prop f parent link ra rs1 m1 rs2 m2) -/\ (forall f parent rs1 m1 rs2 m2, - exec_function ge f parent rs1 m1 rs2 m2 -> - exec_function_prop f parent rs1 m1 rs2 m2). + (forall f sp parent c1 rs1 fr1 m1 t c2 rs2 fr2 m2, + exec_instr ge f sp parent c1 rs1 fr1 m1 t c2 rs2 fr2 m2 -> + exec_instr_prop f sp parent c1 rs1 fr1 m1 t c2 rs2 fr2 m2) +/\ (forall f sp parent c1 rs1 fr1 m1 t c2 rs2 fr2 m2, + exec_instrs ge f sp parent c1 rs1 fr1 m1 t c2 rs2 fr2 m2 -> + exec_instr_prop f sp parent c1 rs1 fr1 m1 t c2 rs2 fr2 m2) +/\ (forall f parent link ra rs1 m1 t rs2 m2, + exec_function_body ge f parent link ra rs1 m1 t rs2 m2 -> + exec_function_body_prop f parent link ra rs1 m1 t rs2 m2) +/\ (forall f parent rs1 m1 t rs2 m2, + exec_function ge f parent rs1 m1 t rs2 m2 -> + exec_function_prop f parent rs1 m1 t rs2 m2). Proof. apply exec_mutual_induction; red; intros; try (generalize (wt_function_instrs _ WTF _ (INCL _ (in_eq _ _))); intro; @@ -249,7 +268,7 @@ Proof. subst args; subst op. simpl in H. replace v with Vundef. simpl; auto. congruence. replace (mreg_type res) with (snd (type_of_operation op)). - apply type_of_operation_sound with function ge rs##args sp; auto. + apply type_of_operation_sound with fundef ge rs##args sp; auto. rewrite <- H6; reflexivity. apply wt_setreg; auto. inversion H1. rewrite H7. @@ -257,11 +276,13 @@ Proof. apply H1; auto. destruct ros; simpl in H. - apply (Genv.find_funct_prop wt_function wt_p H). + apply (Genv.find_funct_prop wt_fundef wt_p H). destruct (Genv.find_symbol ge i). - apply (Genv.find_funct_ptr_prop wt_function wt_p H). + apply (Genv.find_funct_ptr_prop wt_fundef wt_p H). discriminate. + apply wt_setreg; auto. exact I. + apply incl_find_label with lbl; auto. apply incl_find_label with lbl; auto. @@ -277,26 +298,34 @@ Proof. generalize (H3 WTF (incl_refl _) WTRS WTFR2 WTPA). tauto. - apply (H0 Vzero Vzero). exact I. exact I. auto. auto. auto. + apply (H0 Vzero Vzero). exact I. exact I. + inversion WTF; auto. auto. auto. exact I. exact I. + + rewrite H1. apply wt_setreg; auto. + generalize (wt_event_match _ _ _ _ H). + unfold proj_sig_res, Conventions.loc_result. + destruct (sig_res (ef_sig ef)). + destruct t; simpl; auto. + simpl; auto. Qed. Lemma subject_reduction_instr: - forall f sp parent c1 rs1 fr1 m1 c2 rs2 fr2 m2, - exec_instr ge f sp parent c1 rs1 fr1 m1 c2 rs2 fr2 m2 -> - exec_instr_prop f sp parent c1 rs1 fr1 m1 c2 rs2 fr2 m2. + forall f sp parent c1 rs1 fr1 m1 t c2 rs2 fr2 m2, + exec_instr ge f sp parent c1 rs1 fr1 m1 t c2 rs2 fr2 m2 -> + exec_instr_prop f sp parent c1 rs1 fr1 m1 t c2 rs2 fr2 m2. Proof (proj1 subject_reduction). Lemma subject_reduction_instrs: - forall f sp parent c1 rs1 fr1 m1 c2 rs2 fr2 m2, - exec_instrs ge f sp parent c1 rs1 fr1 m1 c2 rs2 fr2 m2 -> - exec_instr_prop f sp parent c1 rs1 fr1 m1 c2 rs2 fr2 m2. + forall f sp parent c1 rs1 fr1 m1 t c2 rs2 fr2 m2, + exec_instrs ge f sp parent c1 rs1 fr1 m1 t c2 rs2 fr2 m2 -> + exec_instr_prop f sp parent c1 rs1 fr1 m1 t c2 rs2 fr2 m2. Proof (proj1 (proj2 subject_reduction)). Lemma subject_reduction_function: - forall f parent rs1 m1 rs2 m2, - exec_function ge f parent rs1 m1 rs2 m2 -> - exec_function_prop f parent rs1 m1 rs2 m2. + forall f parent rs1 m1 t rs2 m2, + exec_function ge f parent rs1 m1 t rs2 m2 -> + exec_function_prop f parent rs1 m1 t rs2 m2. Proof (proj2 (proj2 (proj2 subject_reduction))). End SUBJECT_REDUCTION. @@ -335,8 +364,8 @@ Proof. Qed. Lemma exec_instr_link_invariant: - forall ge f sp parent c1 rs1 fr1 m1 c2 rs2 fr2 m2, - exec_instr ge f sp parent c1 rs1 fr1 m1 c2 rs2 fr2 m2 -> + forall ge f sp parent c1 rs1 fr1 m1 t c2 rs2 fr2 m2, + exec_instr ge f sp parent c1 rs1 fr1 m1 t c2 rs2 fr2 m2 -> wt_function f -> incl c1 f.(fn_code) -> incl c2 f.(fn_code) /\ link_invariant fr1 fr2. @@ -351,8 +380,8 @@ Proof. Qed. Lemma exec_instrs_link_invariant: - forall ge f sp parent c1 rs1 fr1 m1 c2 rs2 fr2 m2, - exec_instrs ge f sp parent c1 rs1 fr1 m1 c2 rs2 fr2 m2 -> + forall ge f sp parent c1 rs1 fr1 m1 t c2 rs2 fr2 m2, + exec_instrs ge f sp parent c1 rs1 fr1 m1 t c2 rs2 fr2 m2 -> wt_function f -> incl c1 f.(fn_code) -> incl c2 f.(fn_code) /\ link_invariant fr1 fr2. @@ -360,8 +389,8 @@ Proof. induction 1; intros. split. auto. apply link_invariant_refl. eapply exec_instr_link_invariant; eauto. - generalize (IHexec_instrs1 H1 H2); intros [A B]. - generalize (IHexec_instrs2 H1 A); intros [C D]. + generalize (IHexec_instrs1 H2 H3); intros [A B]. + generalize (IHexec_instrs2 H2 A); intros [C D]. split. auto. red; auto. Qed. diff --git a/backend/Main.v b/backend/Main.v index 80a0577..95dc4e6 100644 --- a/backend/Main.v +++ b/backend/Main.v @@ -78,34 +78,34 @@ Notation "a @@ b" := The translation of a Cminor function to a PPC function is as follows. *) -Definition transf_cminor_function (f: Cminor.function) : option PPC.code := +Definition transf_cminor_fundef (f: Cminor.fundef) : option PPC.fundef := Some f - @@@ RTLgen.transl_function - @@ Constprop.transf_function - @@ CSE.transf_function - @@@ Allocation.transf_function - @@ Tunneling.tunnel_function - @@ Linearize.transf_function - @@@ Stacking.transf_function - @@@ PPCgen.transf_function. + @@@ RTLgen.transl_fundef + @@ Constprop.transf_fundef + @@ CSE.transf_fundef + @@@ Allocation.transf_fundef + @@ Tunneling.tunnel_fundef + @@ Linearize.transf_fundef + @@@ Stacking.transf_fundef + @@@ PPCgen.transf_fundef. (** And here is the translation for Csharpminor functions. *) -Definition transf_csharpminor_function - (gce: Cminorgen.compilenv) (f: Csharpminor.function) : option PPC.code := +Definition transf_csharpminor_fundef + (gce: Cminorgen.compilenv) (f: Csharpminor.fundef) : option PPC.fundef := Some f - @@@ Cminorgen.transl_function gce - @@@ transf_cminor_function. + @@@ Cminorgen.transl_fundef gce + @@@ transf_cminor_fundef. (** The corresponding translations for whole program follow. *) Definition transf_cminor_program (p: Cminor.program) : option PPC.program := - transform_partial_program transf_cminor_function p. + transform_partial_program transf_cminor_fundef p. Definition transf_csharpminor_program (p: Csharpminor.program) : option PPC.program := let gce := Cminorgen.build_global_compilenv p in transform_partial_program - (transf_csharpminor_function gce) + (transf_csharpminor_fundef gce) (Csharpminor.program_of_program p). (** * Equivalence with whole program transformations *) @@ -194,7 +194,7 @@ Qed. Lemma transf_cminor_program_equiv: forall p, transf_cminor_program2 p = transf_cminor_program p. Proof. - intro. unfold transf_cminor_program, transf_cminor_program2, transf_cminor_function. + intro. unfold transf_cminor_program, transf_cminor_program2, transf_cminor_fundef. simpl. unfold RTLgen.transl_program, Constprop.transf_program, RTL.program. @@ -223,7 +223,7 @@ Lemma transf_csharpminor_program_equiv: forall p, transf_csharpminor_program2 p = transf_csharpminor_program p. Proof. intros. - unfold transf_csharpminor_program2, transf_csharpminor_program, transf_csharpminor_function. + unfold transf_csharpminor_program2, transf_csharpminor_program, transf_csharpminor_fundef. simpl. replace transf_cminor_program2 with transf_cminor_program. unfold transf_cminor_program, Cminorgen.transl_program, Cminor.program, PPC.program. @@ -237,10 +237,10 @@ Qed. composes the semantic preservation results for each pass. *) Lemma transf_cminor_program2_correct: - forall p tp n, + forall p tp t n, transf_cminor_program2 p = Some tp -> - Cminor.exec_program p (Vint n) -> - PPC.exec_program tp (Vint n). + Cminor.exec_program p t (Vint n) -> + PPC.exec_program tp t (Vint n). Proof. intros until n. unfold transf_cminor_program2. @@ -274,10 +274,10 @@ Proof. Qed. Lemma transf_csharpminor_program2_correct: - forall p tp n, + forall p tp t n, transf_csharpminor_program2 p = Some tp -> - Csharpminor.exec_program p (Vint n) -> - PPC.exec_program tp (Vint n). + Csharpminor.exec_program p t (Vint n) -> + PPC.exec_program tp t (Vint n). Proof. intros until n; unfold transf_csharpminor_program2; simpl. caseEq (Cminorgen.transl_program p). @@ -291,20 +291,20 @@ Qed. (** It follows that the whole compiler is semantic-preserving. *) Theorem transf_cminor_program_correct: - forall p tp n, + forall p tp t n, transf_cminor_program p = Some tp -> - Cminor.exec_program p (Vint n) -> - PPC.exec_program tp (Vint n). + Cminor.exec_program p t (Vint n) -> + PPC.exec_program tp t (Vint n). Proof. intros. apply transf_cminor_program2_correct with p. rewrite transf_cminor_program_equiv. assumption. assumption. Qed. Theorem transf_csharpminor_program_correct: - forall p tp n, + forall p tp t n, transf_csharpminor_program p = Some tp -> - Csharpminor.exec_program p (Vint n) -> - PPC.exec_program tp (Vint n). + Csharpminor.exec_program p t (Vint n) -> + PPC.exec_program tp t (Vint n). Proof. intros. apply transf_csharpminor_program2_correct with p. rewrite transf_csharpminor_program_equiv. assumption. assumption. diff --git a/backend/Mem.v b/backend/Mem.v index 26d4c49..7af696e 100644 --- a/backend/Mem.v +++ b/backend/Mem.v @@ -619,6 +619,88 @@ Qed. Hint Resolve store_in_bounds store_inv. +(** Build a block filled with the given initialization data. *) + +Fixpoint contents_init_data (pos: Z) (id: list init_data) {struct id}: contentmap := + match id with + | nil => (fun y => Undef) + | Init_int8 n :: id' => + store_contents Size8 (contents_init_data (pos + 1) id') pos (Vint n) + | Init_int16 n :: id' => + store_contents Size16 (contents_init_data (pos + 2) id') pos (Vint n) + | Init_int32 n :: id' => + store_contents Size32 (contents_init_data (pos + 4) id') pos (Vint n) + | Init_float32 f :: id' => + store_contents Size32 (contents_init_data (pos + 4) id') pos (Vfloat f) + | Init_float64 f :: id' => + store_contents Size64 (contents_init_data (pos + 8) id') pos (Vfloat f) + | Init_space n :: id' => + contents_init_data (pos + Zmax n 0) id' + end. + +Definition size_init_data (id: init_data) : Z := + match id with + | Init_int8 _ => 1 + | Init_int16 _ => 2 + | Init_int32 _ => 4 + | Init_float32 _ => 4 + | Init_float64 _ => 8 + | Init_space n => Zmax n 0 + end. + +Definition size_init_data_list (id: list init_data): Z := + List.fold_right (fun id sz => size_init_data id + sz) 0 id. + +Remark size_init_data_list_pos: + forall id, size_init_data_list id >= 0. +Proof. + induction id; simpl. + omega. + assert (size_init_data a >= 0). destruct a; simpl; try omega. + generalize (Zmax2 z 0). omega. omega. +Qed. + +Remark contents_init_data_undef_outside: + forall id pos x, + x < pos \/ x >= pos + size_init_data_list id -> + contents_init_data pos id x = Undef. +Proof. + induction id; simpl; intros. + auto. + generalize (size_init_data_list_pos id); intro. + assert (forall n delta dt, + delta = 1 + Z_of_nat n -> + x < pos \/ x >= pos + (delta + size_init_data_list id) -> + setN n pos dt (contents_init_data (pos + delta) id) x = Undef). + intros. unfold setN. rewrite update_o. + transitivity (contents_init_data (pos + delta) id x). + apply set_cont_outside. omega. + apply IHid. omega. omega. + unfold size_init_data in H; destruct a; + try (apply H1; [reflexivity|assumption]). + apply IHid. generalize (Zmax2 z 0). omega. +Qed. + +Definition block_init_data (id: list init_data) : block_contents := + mkblock 0 (size_init_data_list id) + (contents_init_data 0 id) + (contents_init_data_undef_outside id 0). + +Definition alloc_init_data (m: mem) (id: list init_data) : mem * block := + (mkmem (update m.(nextblock) + (block_init_data id) + m.(blocks)) + (Zsucc m.(nextblock)) + (succ_nextblock_pos m), + m.(nextblock)). + +Remark block_init_data_empty: + block_init_data nil = empty_block 0 0. +Proof. + unfold block_init_data, empty_block. simpl. + decEq. apply proof_irrelevance. +Qed. + (** * Properties of the memory operations *) (** ** Properties related to block validity *) @@ -2032,6 +2114,32 @@ Proof. apply free_first_list_inject. auto. Qed. +Lemma contents_init_data_inject: + forall id, contentmap_inject (contents_init_data 0 id) (contents_init_data 0 id) 0 (size_init_data_list id) 0. +Proof. + intro id0. + set (sz0 := size_init_data_list id0). + assert (forall id pos, + 0 <= pos -> pos + size_init_data_list id <= sz0 -> + contentmap_inject (contents_init_data pos id) (contents_init_data pos id) 0 sz0 0). + induction id; simpl; intros. + red; intros; constructor. + assert (forall n dt, + size_init_data a = 1 + Z_of_nat n -> + content_inject dt dt -> + contentmap_inject (setN n pos dt (contents_init_data (pos + size_init_data a) id)) + (setN n pos dt (contents_init_data (pos + size_init_data a) id)) + 0 sz0 0). + intros. set (pos' := pos) in |- * at 3. replace pos' with (pos + 0). + apply setN_inject. apply IHid. omega. omega. auto. auto. + generalize (size_init_data_list_pos id). omega. unfold pos'; omega. + destruct a; + try (apply H1; [reflexivity|repeat constructor]). + apply IHid. generalize (Zmax2 z 0). omega. simpl in H0; omega. + + apply H. omega. unfold sz0. omega. +Qed. + End MEM_INJECT. Hint Resolve val_inject_int val_inject_float val_inject_ptr val_inject_undef. @@ -2251,3 +2359,27 @@ Proof. right. intros. omega. left. auto. apply mi_no_overlap0; auto. Qed. + +Lemma alloc_parallel_inject: + forall f m1 m2 lo hi m1' m2' b1 b2, + mem_inject f m1 m2 -> + alloc m1 lo hi = (m1', b1) -> + alloc m2 lo hi = (m2', b2) -> + Int.min_signed <= lo -> hi <= Int.max_signed -> + mem_inject (extend_inject b1 (Some(b2,0)) f) m1' m2' /\ + inject_incr f (extend_inject b1 (Some(b2,0)) f). +Proof. + intros. + generalize (low_bound_alloc _ _ b2 _ _ _ H1). rewrite zeq_true; intro LOW. + generalize (high_bound_alloc _ _ b2 _ _ _ H1). rewrite zeq_true; intro HIGH. + eapply alloc_mapped_inject; eauto. + eapply alloc_right_inject; eauto. + eapply valid_new_block; eauto. + compute. intuition congruence. + rewrite LOW; auto. + rewrite HIGH; auto. + rewrite LOW; omega. + rewrite HIGH; omega. + intros. elim (mi_mappedblocks _ _ _ H _ _ _ H4); intros. + injection H1; intros. rewrite H7 in H5. omegaContradiction. +Qed. diff --git a/backend/Op.v b/backend/Op.v index e0dcfa4..efd0d9c 100644 --- a/backend/Op.v +++ b/backend/Op.v @@ -46,7 +46,9 @@ Inductive operation : Set := | Oundef: operation (**r set [rd] to undefined value *) (*c Integer arithmetic: *) | Ocast8signed: operation (**r [rd] is 8-bit sign extension of [r1] *) + | Ocast8unsigned: operation (**r [rd] is 8-bit zero extension of [r1] *) | Ocast16signed: operation (**r [rd] is 16-bit sign extension of [r1] *) + | Ocast16unsigned: operation (**r [rd] is 16-bit zero extension of [r1] *) | Oadd: operation (**r [rd = r1 + r2] *) | Oaddimm: int -> operation (**r [rd = r1 + n] *) | Osub: operation (**r [rd = r1 - r2] *) @@ -166,8 +168,10 @@ Definition eval_operation end | Oaddrstack ofs, nil => offset_sp sp ofs | Oundef, nil => Some Vundef - | Ocast8signed, Vint n1 :: nil => Some (Vint (Int.cast8signed n1)) - | Ocast16signed, Vint n1 :: nil => Some (Vint (Int.cast16signed n1)) + | Ocast8signed, v1 :: nil => Some (Val.cast8signed v1) + | Ocast8unsigned, v1 :: nil => Some (Val.cast8unsigned v1) + | Ocast16signed, v1 :: nil => Some (Val.cast16signed v1) + | Ocast16unsigned, v1 :: nil => Some (Val.cast16unsigned v1) | Oadd, Vint n1 :: Vint n2 :: nil => Some (Vint (Int.add n1 n2)) | Oadd, Vint n1 :: Vptr b2 n2 :: nil => Some (Vptr b2 (Int.add n2 n1)) | Oadd, Vptr b1 n1 :: Vint n2 :: nil => Some (Vptr b1 (Int.add n1 n2)) @@ -215,8 +219,8 @@ Definition eval_operation Some (Vfloat (Float.add (Float.mul f1 f2) f3)) | Omulsubf, Vfloat f1 :: Vfloat f2 :: Vfloat f3 :: nil => Some (Vfloat (Float.sub (Float.mul f1 f2) f3)) - | Osingleoffloat, Vfloat f1 :: nil => - Some (Vfloat (Float.singleoffloat f1)) + | Osingleoffloat, v1 :: nil => + Some (Val.singleoffloat v1) | Ointoffloat, Vfloat f1 :: nil => Some (Vint (Float.intoffloat f1)) | Ofloatofint, Vint n1 :: nil => @@ -396,7 +400,9 @@ Definition type_of_operation (op: operation) : list typ * typ := | Oaddrstack _ => (nil, Tint) | Oundef => (nil, Tint) (* treated specially *) | Ocast8signed => (Tint :: nil, Tint) + | Ocast8unsigned => (Tint :: nil, Tint) | Ocast16signed => (Tint :: nil, Tint) + | Ocast16unsigned => (Tint :: nil, Tint) | Oadd => (Tint :: Tint :: nil, Tint) | Oaddimm _ => (Tint :: nil, Tint) | Osub => (Tint :: Tint :: nil, Tint) @@ -476,6 +482,10 @@ Proof. destruct (Genv.find_symbol genv i); simplify_eq H1; intro; subst v; exact I. simpl. unfold offset_sp in H1. destruct sp; try discriminate. inversion H1. exact I. + destruct v0; exact I. + destruct v0; exact I. + destruct v0; exact I. + destruct v0; exact I. destruct (eq_block b b0). injection H1; intro; subst v; exact I. discriminate. destruct (Int.eq i0 Int.zero). discriminate. @@ -492,6 +502,7 @@ Proof. injection H1; intro; subst v; exact I. discriminate. destruct (Int.ltu i0 (Int.repr 32)). injection H1; intro; subst v; exact I. discriminate. + destruct v0; exact I. destruct (eval_condition c vl). destruct b; injection H1; intro; subst v; exact I. discriminate. @@ -550,7 +561,9 @@ Definition eval_operation_total (sp: val) (op: operation) (vl: list val) : val : | Oaddrstack ofs, nil => Val.add sp (Vint ofs) | Oundef, nil => Vundef | Ocast8signed, v1::nil => Val.cast8signed v1 + | Ocast8unsigned, v1::nil => Val.cast8unsigned v1 | Ocast16signed, v1::nil => Val.cast16signed v1 + | Ocast16unsigned, v1::nil => Val.cast16unsigned v1 | Oadd, v1::v2::nil => Val.add v1 v2 | Oaddimm n, v1::nil => Val.add v1 (Vint n) | Osub, v1::v2::nil => Val.sub v1 v2 diff --git a/backend/PPC.v b/backend/PPC.v index 64bd90a..37f882b 100644 --- a/backend/PPC.v +++ b/backend/PPC.v @@ -7,6 +7,7 @@ Require Import Integers. Require Import Floats. Require Import Values. Require Import Mem. +Require Import Events. Require Import Globalenvs. (** * Abstract syntax *) @@ -85,6 +86,7 @@ Inductive instruction : Set := | Paddi: ireg -> ireg -> constant -> instruction (**r add immediate *) | Paddis: ireg -> ireg -> constant -> instruction (**r add immediate high *) | Paddze: ireg -> ireg -> instruction (**r add Carry bit *) + | Pallocblock: instruction (**r allocate new heap block *) | Pallocframe: Z -> Z -> instruction (**r allocate new stack frame *) | Pand_: ireg -> ireg -> ireg -> instruction (**r bitwise and *) | Pandc: ireg -> ireg -> ireg -> instruction (**r bitwise and-complement *) @@ -260,6 +262,12 @@ lbl: .long 0x43300000, 0x00000000 Again, our memory model cannot comprehend that this operation frees (logically) the current stack frame. +- [Pallocheap]: in the formal semantics, this pseudo-instruction + allocates a heap block of size the contents of [GPR3], and leaves + a pointer to this block in [GPR3]. In the generated assembly code, + it is turned into a call to the allocation function of the run-time + system. + - [Piundef] and [Pfundef]: set an integer or float register (respectively) to the [Vundef] value. Expand to nothing, as the PowerPC processor has no notion of ``undefined value''. These two pseudo-instructions are used @@ -277,7 +285,8 @@ lbl: .long 0x43300000, 0x00000000 *) Definition code := list instruction. -Definition program := AST.program code. +Definition fundef := AST.fundef code. +Definition program := AST.program fundef. (** * Operational semantics *) @@ -317,7 +326,7 @@ Module Pregmap := EMap(PregEq). [Vzero] or [Vone]. *) Definition regset := Pregmap.t val. -Definition genv := Genv.t code. +Definition genv := Genv.t fundef. Notation "a # b" := (a b) (at level 1, only parsing). Notation "a # b <- c" := (Pregmap.set b c a) (at level 1, b at next level). @@ -540,6 +549,14 @@ Definition exec_instr (c: code) (i: instruction) (rs: regset) (m: mem) : outcome OK (nextinstr (rs#rd <- (Val.add (gpr_or_zero rs r1) (const_high cst)))) m | Paddze rd r1 => OK (nextinstr (rs#rd <- (Val.add rs#r1 rs#CARRY))) m + | Pallocblock => + match rs#GPR3 with + | Vint n => + let (m', b) := Mem.alloc m 0 (Int.signed n) in + OK (nextinstr (rs#GPR3 <- (Vptr b Int.zero) + #LR <- (Val.add rs#PC Vone))) m' + | _ => Error + end | Pallocframe lo hi => let (m1, stk) := Mem.alloc m lo hi in let sp := Vptr stk (Int.repr lo) in @@ -735,36 +752,84 @@ Definition exec_instr (c: code) (i: instruction) (rs: regset) (m: mem) : outcome OK (nextinstr rs) m end. +(** Calling conventions for external functions. These are compatible with + the calling conventions in module [Conventions], except that + we use PPC registers instead of locations. *) + +Fixpoint loc_external_arguments_rec + (tyl: list typ) (iregl: list ireg) (fregl: list freg) + {struct tyl} : list preg := + match tyl with + | nil => nil + | Tint :: tys => + match iregl with + | nil => IR GPR11 (* should not happen *) + | ireg :: _ => IR ireg + end :: + loc_external_arguments_rec tys (list_drop1 iregl) fregl + | Tfloat :: tys => + match fregl with + | nil => IR GPR11 (* should not happen *) + | freg :: _ => FR freg + end :: + loc_external_arguments_rec tys (list_drop2 iregl) (list_drop1 fregl) + end. + +Definition int_param_regs := + GPR3 :: GPR4 :: GPR5 :: GPR6 :: GPR7 :: GPR8 :: GPR9 :: GPR10 :: nil. +Definition float_param_regs := + FPR1 :: FPR2 :: FPR3 :: FPR4 :: FPR5 :: FPR6 :: FPR7 :: FPR8 :: FPR9 :: FPR10 :: nil. + +Definition loc_external_arguments (s: signature) : list preg := + loc_external_arguments_rec s.(sig_args) int_param_regs float_param_regs. + +Definition loc_external_result (s: signature) : preg := + match s.(sig_res) with + | None => GPR3 + | Some Tint => GPR3 + | Some Tfloat => FPR1 + end. + (** Execution of the instruction at [rs#PC]. *) -Inductive exec_step: regset -> mem -> regset -> mem -> Prop := - | exec_step_intro: +Inductive exec_step: regset -> mem -> trace -> regset -> mem -> Prop := + | exec_step_internal: forall b ofs c i rs m rs' m', rs PC = Vptr b ofs -> - Genv.find_funct_ptr ge b = Some c -> + Genv.find_funct_ptr ge b = Some (Internal c) -> find_instr (Int.unsigned ofs) c = Some i -> exec_instr c i rs m = OK rs' m' -> - exec_step rs m rs' m'. + exec_step rs m E0 rs' m' + | exec_step_external: + forall b ef args res rs m t rs', + rs PC = Vptr b Int.zero -> + Genv.find_funct_ptr ge b = Some (External ef) -> + event_match ef args t res -> + args = List.map (fun r => rs#r) (loc_external_arguments ef.(ef_sig)) -> + rs' = (rs#(loc_external_result ef.(ef_sig)) <- res + #PC <- (rs LR)) -> + exec_step rs m t rs' m. (** Execution of zero, one or several instructions starting at [rs#PC]. *) -Inductive exec_steps: regset -> mem -> regset -> mem -> Prop := +Inductive exec_steps: regset -> mem -> trace -> regset -> mem -> Prop := | exec_refl: forall rs m, - exec_steps rs m rs m + exec_steps rs m E0 rs m | exec_one: - forall rs m rs' m', - exec_step rs m rs' m' -> - exec_steps rs m rs' m' + forall rs m t rs' m', + exec_step rs m t rs' m' -> + exec_steps rs m t rs' m' | exec_trans: - forall rs1 m1 rs2 m2 rs3 m3, - exec_steps rs1 m1 rs2 m2 -> - exec_steps rs2 m2 rs3 m3 -> - exec_steps rs1 m1 rs3 m3. + forall rs1 m1 t1 rs2 m2 t2 rs3 m3 t3, + exec_steps rs1 m1 t1 rs2 m2 -> + exec_steps rs2 m2 t2 rs3 m3 -> + t3 = t1 ** t2 -> + exec_steps rs1 m1 t3 rs3 m3. End RELSEM. -Definition exec_program (p: program) (r: val) : Prop := +Definition exec_program (p: program) (t: trace) (r: val) : Prop := let ge := Genv.globalenv p in let m0 := Genv.init_mem p in let rs0 := @@ -772,4 +837,4 @@ Definition exec_program (p: program) (r: val) : Prop := # LR <- Vzero # GPR1 <- (Vptr Mem.nullptr Int.zero) in exists rs, exists m, - exec_steps ge rs0 m0 rs m /\ rs#PC = Vzero /\ rs#GPR3 = r. + exec_steps ge rs0 m0 t rs m /\ rs#PC = Vzero /\ rs#GPR3 = r. diff --git a/backend/PPCgen.v b/backend/PPCgen.v index dc8ed40..6cf0699 100644 --- a/backend/PPCgen.v +++ b/backend/PPCgen.v @@ -275,8 +275,12 @@ Definition transl_op end | Ocast8signed, a1 :: nil => Pextsb (ireg_of r) (ireg_of a1) :: k + | Ocast8unsigned, a1 :: nil => + Prlwinm (ireg_of r) (ireg_of a1) Int.zero (Int.repr 255) :: k | Ocast16signed, a1 :: nil => Pextsh (ireg_of r) (ireg_of a1) :: k + | Ocast16unsigned, a1 :: nil => + Prlwinm (ireg_of r) (ireg_of a1) Int.zero (Int.repr 65535) :: k | Oadd, a1 :: a2 :: nil => Padd (ireg_of r) (ireg_of a1) (ireg_of a2) :: k | Oaddimm n, a1 :: nil => @@ -470,6 +474,8 @@ Definition transl_instr (i: Mach.instruction) (k: code) := Pmtctr (ireg_of r) :: Pbctrl :: k | Mcall sig (inr symb) => Pbl symb :: k + | Malloc => + Pallocblock :: k | Mlabel lbl => Plabel lbl :: k | Mgoto lbl => @@ -504,11 +510,14 @@ Fixpoint code_size (c: code) : Z := | instr :: c' => code_size c' + 1 end. -Definition transf_function (f: Mach.function) := +Definition transf_function (f: Mach.function) : option PPC.code := let c := transl_function f in if zlt Int.max_unsigned (code_size c) then None else Some c. +Definition transf_fundef (f: Mach.fundef) : option PPC.fundef := + transf_partial_fundef transf_function f. + Definition transf_program (p: Mach.program) : option PPC.program := - transform_partial_program transf_function p. + transform_partial_program transf_fundef p. diff --git a/backend/PPCgenproof.v b/backend/PPCgenproof.v index 99aa4c8..3264999 100644 --- a/backend/PPCgenproof.v +++ b/backend/PPCgenproof.v @@ -7,6 +7,7 @@ Require Import Integers. Require Import Floats. Require Import Values. Require Import Mem. +Require Import Events. Require Import Globalenvs. Require Import Op. Require Import Locations. @@ -29,53 +30,44 @@ Lemma symbols_preserved: forall id, Genv.find_symbol tge id = Genv.find_symbol ge id. Proof. intros. unfold ge, tge. - apply Genv.find_symbol_transf_partial with transf_function. + apply Genv.find_symbol_transf_partial with transf_fundef. exact TRANSF. Qed. Lemma functions_translated: forall f b, Genv.find_funct_ptr ge b = Some f -> - Genv.find_funct_ptr tge b = Some (transl_function f). + exists tf, Genv.find_funct_ptr tge b = Some tf /\ transf_fundef f = Some tf. Proof. intros. - generalize (Genv.find_funct_ptr_transf_partial - transf_function TRANSF H). - intros [A B]. - unfold tge. change code with (list instruction). rewrite A. - generalize B. unfold transf_function. - case (zlt Int.max_unsigned (code_size (transl_function f))); intro. - tauto. auto. + generalize (Genv.find_funct_ptr_transf_partial transf_fundef TRANSF H). + case (transf_fundef f). + intros f' [A B]. exists f'; split. assumption. auto. + tauto. Qed. -Lemma functions_translated_2: - forall f v, - Genv.find_funct ge v = Some f -> - Genv.find_funct tge v = Some (transl_function f). +Lemma functions_transl: + forall f b, + Genv.find_funct_ptr ge b = Some (Internal f) -> + Genv.find_funct_ptr tge b = Some (Internal (transl_function f)). Proof. intros. - generalize (Genv.find_funct_transf_partial - transf_function TRANSF H). - intros [A B]. - unfold tge. change code with (list instruction). rewrite A. - generalize B. unfold transf_function. + destruct (functions_translated _ _ H) as [tf [A B]]. + rewrite A. generalize B. unfold transf_fundef, transf_partial_fundef, transf_function. case (zlt Int.max_unsigned (code_size (transl_function f))); intro. - tauto. auto. + congruence. auto. Qed. -Lemma functions_translated_no_overflow: +Lemma functions_transl_no_overflow: forall b f, - Genv.find_funct_ptr ge b = Some f -> + Genv.find_funct_ptr ge b = Some (Internal f) -> code_size (transl_function f) <= Int.max_unsigned. Proof. - intros. - generalize (Genv.find_funct_ptr_transf_partial - transf_function TRANSF H). - intros [A B]. - generalize B. - unfold transf_function. + intros. + destruct (functions_translated _ _ H) as [tf [A B]]. + generalize B. unfold transf_fundef, transf_partial_fundef, transf_function. case (zlt Int.max_unsigned (code_size (transl_function f))); intro. - tauto. intro. omega. + congruence. intro; omega. Qed. (** * Properties of control flow *) @@ -180,7 +172,7 @@ Qed. Inductive transl_code_at_pc: val -> Mach.function -> Mach.code -> Prop := transl_code_at_pc_intro: forall b ofs f c, - Genv.find_funct_ptr ge b = Some f -> + Genv.find_funct_ptr ge b = Some (Internal f) -> code_tail (Int.unsigned ofs) (transl_function f) = transl_code c -> transl_code_at_pc (Vptr b ofs) f c. @@ -194,19 +186,20 @@ Lemma exec_straight_steps_1: code_size fn <= Int.max_unsigned -> forall b ofs, rs#PC = Vptr b ofs -> - Genv.find_funct_ptr tge b = Some fn -> + Genv.find_funct_ptr tge b = Some (Internal fn) -> code_tail (Int.unsigned ofs) fn = c -> - exec_steps tge rs m rs' m'. + exec_steps tge rs m E0 rs' m'. Proof. induction 1. intros. apply exec_refl. - intros. apply exec_trans with rs2 m2. + intros. apply exec_trans with E0 rs2 m2 E0. apply exec_one; econstructor; eauto. rewrite find_instr_tail. rewrite H5. auto. apply IHexec_straight with b (Int.add ofs Int.one). auto. rewrite H0. rewrite H3. reflexivity. auto. apply code_tail_next_int with i; auto. + traceEq. Qed. Lemma exec_straight_steps_2: @@ -215,7 +208,7 @@ Lemma exec_straight_steps_2: code_size fn <= Int.max_unsigned -> forall b ofs, rs#PC = Vptr b ofs -> - Genv.find_funct_ptr tge b = Some fn -> + Genv.find_funct_ptr tge b = Some (Internal fn) -> code_tail (Int.unsigned ofs) fn = c -> exists ofs', rs'#PC = Vptr b ofs' @@ -233,11 +226,11 @@ Lemma exec_straight_steps: transl_code_at_pc (rs PC) f c -> exec_straight tge (transl_function f) (transl_code c) rs m (transl_code c') rs' m' -> - exec_steps tge rs m rs' m' /\ transl_code_at_pc (rs' PC) f c'. + exec_steps tge rs m E0 rs' m' /\ transl_code_at_pc (rs' PC) f c'. Proof. intros. inversion H. - generalize (functions_translated_no_overflow _ _ H2). intro. - generalize (functions_translated _ _ H2). intro. + generalize (functions_transl_no_overflow _ _ H2). intro. + generalize (functions_transl _ _ H2). intro. split. eapply exec_straight_steps_1; eauto. generalize (exec_straight_steps_2 _ _ _ _ _ _ _ H0 H6 _ _ (sym_equal H1) H7 H3). @@ -490,7 +483,7 @@ End TRANSL_LABEL. Lemma find_label_goto_label: forall f lbl rs m c' b ofs, - Genv.find_funct_ptr ge b = Some f -> + Genv.find_funct_ptr ge b = Some (Internal f) -> rs PC = Vptr b ofs -> Mach.find_label lbl f.(fn_code) = Some c' -> exists rs', @@ -509,7 +502,7 @@ Proof. split. rewrite Pregmap.gss. constructor. auto. rewrite Int.unsigned_repr. replace (pos' - 0) with pos' in B. auto. omega. - generalize (functions_translated_no_overflow _ _ H). + generalize (functions_transl_no_overflow _ _ H). omega. intros. apply Pregmap.gso; auto. Qed. @@ -575,7 +568,7 @@ Qed. Definition exec_instr_prop (f: Mach.function) (sp: val) - (c1: Mach.code) (ms1: Mach.regset) (m1: mem) + (c1: Mach.code) (ms1: Mach.regset) (m1: mem) (t: trace) (c2: Mach.code) (ms2: Mach.regset) (m2: mem) := forall rs1 (WTF: wt_function f) @@ -584,36 +577,36 @@ Definition exec_instr_prop (AG: agree ms1 sp rs1), exists rs2, agree ms2 sp rs2 - /\ exec_steps tge rs1 m1 rs2 m2 + /\ exec_steps tge rs1 m1 t rs2 m2 /\ transl_code_at_pc (rs2 PC) f c2. Definition exec_function_body_prop (f: Mach.function) (parent: val) (ra: val) - (ms1: Mach.regset) (m1: mem) + (ms1: Mach.regset) (m1: mem) (t: trace) (ms2: Mach.regset) (m2: mem) := forall rs1 (WTRA: Val.has_type ra Tint) (RALR: rs1 LR = ra) (WTF: wt_function f) - (AT: Genv.find_funct ge (rs1 PC) = Some f) + (AT: Genv.find_funct ge (rs1 PC) = Some (Internal f)) (AG: agree ms1 parent rs1), exists rs2, agree ms2 parent rs2 - /\ exec_steps tge rs1 m1 rs2 m2 + /\ exec_steps tge rs1 m1 t rs2 m2 /\ rs2 PC = rs1 LR. Definition exec_function_prop - (f: Mach.function) (parent: val) - (ms1: Mach.regset) (m1: mem) + (f: Mach.fundef) (parent: val) + (ms1: Mach.regset) (m1: mem) (t: trace) (ms2: Mach.regset) (m2: mem) := forall rs1 - (WTF: wt_function f) + (WTF: wt_fundef f) (AT: Genv.find_funct ge (rs1 PC) = Some f) (AG: agree ms1 parent rs1) (WTRA: Val.has_type (rs1 LR) Tint), exists rs2, agree ms2 parent rs2 - /\ exec_steps tge rs1 m1 rs2 m2 + /\ exec_steps tge rs1 m1 t rs2 m2 /\ rs2 PC = rs1 LR. (** We show each case of the inductive proof of simulation as a separate @@ -622,7 +615,7 @@ Definition exec_function_prop Lemma exec_Mlabel_prop: forall (f : function) (sp : val) (lbl : Mach.label) (c : list Mach.instruction) (rs : Mach.regset) (m : mem), - exec_instr_prop f sp (Mlabel lbl :: c) rs m c rs m. + exec_instr_prop f sp (Mlabel lbl :: c) rs m E0 c rs m. Proof. intros; red; intros. assert (exec_straight tge (transl_function f) @@ -637,7 +630,7 @@ Lemma exec_Mgetstack_prop: forall (f : function) (sp : val) (ofs : int) (ty : typ) (dst : mreg) (c : list Mach.instruction) (ms : Mach.regset) (m : mem) (v : val), load_stack m sp ty ofs = Some v -> - exec_instr_prop f sp (Mgetstack ofs ty dst :: c) ms m c (Regmap.set dst v ms) m. + exec_instr_prop f sp (Mgetstack ofs ty dst :: c) ms m E0 c (Regmap.set dst v ms) m. Proof. intros; red; intros. unfold load_stack in H. @@ -661,7 +654,7 @@ Lemma exec_Msetstack_prop: forall (f : function) (sp : val) (src : mreg) (ofs : int) (ty : typ) (c : list Mach.instruction) (ms : mreg -> val) (m m' : mem), store_stack m sp ty ofs (ms src) = Some m' -> - exec_instr_prop f sp (Msetstack src ofs ty :: c) ms m c ms m'. + exec_instr_prop f sp (Msetstack src ofs ty :: c) ms m E0 c ms m'. Proof. intros; red; intros. unfold store_stack in H. @@ -684,7 +677,7 @@ Lemma exec_Mgetparam_prop: (m : mem) (v : val), load_stack m sp Tint (Int.repr 0) = Some parent -> load_stack m parent ty ofs = Some v -> - exec_instr_prop f sp (Mgetparam ofs ty dst :: c) ms m c (Regmap.set dst v ms) m. + exec_instr_prop f sp (Mgetparam ofs ty dst :: c) ms m E0 c (Regmap.set dst v ms) m. Proof. intros; red; intros. set (rs2 := nextinstr (rs1#GPR2 <- parent)). @@ -723,7 +716,7 @@ Lemma exec_straight_exec_prop: /\ agree ms' sp rs2) -> (exists rs2, agree ms' sp rs2 - /\ exec_steps tge rs1 m1 rs2 m2 + /\ exec_steps tge rs1 m1 E0 rs2 m2 /\ transl_code_at_pc (rs2 PC) f c2). Proof. intros until ms'. intros TRANS1 [rs2 [EX AG]]. @@ -736,7 +729,7 @@ Lemma exec_Mop_prop: (res : mreg) (c : list Mach.instruction) (ms: Mach.regset) (m : mem) (v: val), eval_operation ge sp op ms ## args = Some v -> - exec_instr_prop f sp (Mop op args res :: c) ms m c (Regmap.set res v ms) m. + exec_instr_prop f sp (Mop op args res :: c) ms m E0 c (Regmap.set res v ms) m. Proof. intros; red; intros. generalize (wt_function_instrs _ WTF _ (INCL _ (in_eq _ _))). @@ -753,7 +746,7 @@ Lemma exec_Mload_prop: (a v : val), eval_addressing ge sp addr ms ## args = Some a -> loadv chunk m a = Some v -> - exec_instr_prop f sp (Mload chunk addr args dst :: c) ms m c (Regmap.set dst v ms) m. + exec_instr_prop f sp (Mload chunk addr args dst :: c) ms m E0 c (Regmap.set dst v ms) m. Proof. intros; red; intros. generalize (wt_function_instrs _ WTF _ (INCL _ (in_eq _ _))). @@ -801,7 +794,7 @@ Lemma exec_Mstore_prop: (a : val), eval_addressing ge sp addr ms ## args = Some a -> storev chunk m a (ms src) = Some m' -> - exec_instr_prop f sp (Mstore chunk addr args src :: c) ms m c ms m'. + exec_instr_prop f sp (Mstore chunk addr args src :: c) ms m E0 c ms m'. Proof. intros; red; intros. generalize (wt_function_instrs _ WTF _ (INCL _ (in_eq _ _))). @@ -820,23 +813,23 @@ Hypothesis wt_prog: wt_program prog. Lemma exec_Mcall_prop: forall (f : function) (sp : val) (sig : signature) (mos : mreg + ident) (c : list Mach.instruction) (ms : Mach.regset) - (m : mem) (f' : function) (ms' : Mach.regset) (m' : mem), + (m : mem) (f' : Mach.fundef) (t: trace) (ms' : Mach.regset) (m' : mem), find_function ge mos ms = Some f' -> - exec_function ge f' sp ms m ms' m' -> - exec_function_prop f' sp ms m ms' m' -> - exec_instr_prop f sp (Mcall sig mos :: c) ms m c ms' m'. + exec_function ge f' sp ms m t ms' m' -> + exec_function_prop f' sp ms m t ms' m' -> + exec_instr_prop f sp (Mcall sig mos :: c) ms m t c ms' m'. Proof. intros; red; intros. generalize (wt_function_instrs _ WTF _ (INCL _ (in_eq _ _))). intro WTI. inversion WTI. inversion AT. - assert (WTF': wt_function f'). + assert (WTF': wt_fundef f'). destruct mos; simpl in H. - apply (Genv.find_funct_prop wt_function wt_prog H). + apply (Genv.find_funct_prop wt_fundef wt_prog H). destruct (Genv.find_symbol ge i); try discriminate. - apply (Genv.find_funct_ptr_prop wt_function wt_prog H). + apply (Genv.find_funct_ptr_prop wt_fundef wt_prog H). assert (NOOV: code_size (transl_function f) <= Int.max_unsigned). - eapply functions_translated_no_overflow; eauto. + eapply functions_transl_no_overflow; eauto. destruct mos; simpl in H; simpl transl_code in H7. (* Indirect call *) generalize (code_tail_next_int _ _ _ _ NOOV H7). intro CT1. @@ -853,19 +846,19 @@ Proof. generalize (H1 rs3 WTF' TFIND AG3 WTRA). intros [rs4 [AG4 [EXF' PC4]]]. exists rs4. split. auto. split. - apply exec_trans with rs2 m. apply exec_one. econstructor. - eauto. apply functions_translated. eexact H6. + apply exec_trans with E0 rs2 m t. apply exec_one. econstructor. + eauto. apply functions_transl. eexact H6. rewrite find_instr_tail. rewrite H7. reflexivity. simpl. rewrite <- (ireg_val ms sp rs1); auto. - apply exec_trans with rs3 m. apply exec_one. econstructor. + apply exec_trans with E0 rs3 m t. apply exec_one. econstructor. unfold rs2, nextinstr. rewrite Pregmap.gss. rewrite Pregmap.gso. rewrite <- H5. simpl. reflexivity. - discriminate. apply functions_translated. eexact H6. + discriminate. apply functions_transl. eexact H6. rewrite find_instr_tail. rewrite CT1. reflexivity. simpl. replace (rs2 CTR) with (ms m0). reflexivity. unfold rs2. rewrite nextinstr_inv. rewrite Pregmap.gss. auto. discriminate. - exact EXF'. + exact EXF'. traceEq. traceEq. rewrite PC4. unfold rs3. rewrite Pregmap.gso. rewrite Pregmap.gss. unfold rs2, nextinstr. rewrite Pregmap.gss. rewrite Pregmap.gso. rewrite <- H5. simpl. constructor. auto. auto. @@ -888,23 +881,36 @@ Proof. generalize (H1 rs2 WTF' TFIND AG2 WTRA). intros [rs3 [AG3 [EXF' PC3]]]. exists rs3. split. auto. split. - apply exec_trans with rs2 m. apply exec_one. econstructor. - eauto. apply functions_translated. eexact H6. + apply exec_trans with E0 rs2 m t. apply exec_one. econstructor. + eauto. apply functions_transl. eexact H6. rewrite find_instr_tail. rewrite H7. reflexivity. - simpl. reflexivity. - exact EXF'. + simpl. reflexivity. + exact EXF'. traceEq. rewrite PC3. unfold rs2. rewrite Pregmap.gso. rewrite Pregmap.gss. rewrite <- H5. simpl. constructor. auto. auto. discriminate. intro FINDS. rewrite FINDS in H. discriminate. Qed. +Lemma exec_Malloc_prop: + forall (f : function) (sp : val) (c : list Mach.instruction) + (ms : Mach.regset) (m : mem) (sz : int) (m' : mem) (blk : block), + ms Conventions.loc_alloc_argument = Vint sz -> + Mem.alloc m 0 (Int.signed sz) = (m', blk) -> + exec_instr_prop f sp (Malloc :: c) ms m E0 c + (Regmap.set Conventions.loc_alloc_result (Vptr blk Int.zero) ms) m'. +Proof. + intros; red; intros. + eapply exec_straight_exec_prop; eauto. + simpl. eapply transl_alloc_correct; eauto. +Qed. + Lemma exec_Mgoto_prop: forall (f : function) (sp : val) (lbl : Mach.label) (c : list Mach.instruction) (ms : Mach.regset) (m : mem) (c' : Mach.code), Mach.find_label lbl (fn_code f) = Some c' -> - exec_instr_prop f sp (Mgoto lbl :: c) ms m c' ms m. + exec_instr_prop f sp (Mgoto lbl :: c) ms m E0 c' ms m. Proof. intros; red; intros. inversion AT. @@ -912,7 +918,7 @@ Proof. intros [rs2 [GOTO [AT2 INV]]]. exists rs2. split. apply agree_exten_2 with rs1; auto. split. inversion AT. apply exec_one. econstructor; eauto. - apply functions_translated; eauto. + apply functions_transl; eauto. rewrite find_instr_tail. rewrite H7. simpl. reflexivity. simpl. rewrite GOTO. auto. auto. Qed. @@ -923,7 +929,7 @@ Lemma exec_Mcond_true_prop: (ms: Mach.regset) (m : mem) (c' : Mach.code), eval_condition cond ms ## args = Some true -> Mach.find_label lbl (fn_code f) = Some c' -> - exec_instr_prop f sp (Mcond cond args lbl :: c) ms m c' ms m. + exec_instr_prop f sp (Mcond cond args lbl :: c) ms m E0 c' ms m. Proof. intros; red; intros. generalize (wt_function_instrs _ WTF _ (INCL _ (in_eq _ _))). @@ -936,8 +942,8 @@ Proof. cond args k1 ms sp rs1 m true H2 AG H). simpl. intros [rs2 [EX [RES AG2]]]. inversion AT. - generalize (functions_translated _ _ H6); intro FN. - generalize (functions_translated_no_overflow _ _ H6); intro NOOV. + generalize (functions_transl _ _ H6); intro FN. + generalize (functions_transl_no_overflow _ _ H6); intro NOOV. simpl in H7. generalize (exec_straight_steps_2 _ _ _ _ _ _ _ EX NOOV _ _ (sym_equal H5) FN H7). @@ -955,7 +961,7 @@ Proof. apply exec_one. econstructor; eauto. rewrite find_instr_tail. rewrite CT2. unfold k1. rewrite ISSET. reflexivity. simpl. rewrite RES. simpl. auto. - auto. + traceEq. auto. Qed. Lemma exec_Mcond_false_prop: @@ -963,7 +969,7 @@ Lemma exec_Mcond_false_prop: (args : list mreg) (lbl : Mach.label) (c : list Mach.instruction) (ms : Mach.regset) (m : mem), eval_condition cond ms ## args = Some false -> - exec_instr_prop f sp (Mcond cond args lbl :: c) ms m c ms m. + exec_instr_prop f sp (Mcond cond args lbl :: c) ms m E0 c ms m. Proof. intros; red; intros. generalize (wt_function_instrs _ WTF _ (INCL _ (in_eq _ _))). @@ -989,8 +995,8 @@ Proof. Qed. Lemma exec_instr_incl: - forall f sp c rs m c' rs' m', - Mach.exec_instr ge f sp c rs m c' rs' m' -> + forall f sp c rs m t c' rs' m', + Mach.exec_instr ge f sp c rs m t c' rs' m' -> incl c f.(fn_code) -> incl c' f.(fn_code). Proof. induction 1; intros; eauto with coqlib. @@ -999,8 +1005,8 @@ Proof. Qed. Lemma exec_instrs_incl: - forall f sp c rs m c' rs' m', - Mach.exec_instrs ge f sp c rs m c' rs' m' -> + forall f sp c rs m t c' rs' m', + Mach.exec_instrs ge f sp c rs m t c' rs' m' -> incl c f.(fn_code) -> incl c' f.(fn_code). Proof. induction 1; intros. @@ -1011,7 +1017,7 @@ Qed. Lemma exec_refl_prop: forall (f : function) (sp : val) (c : Mach.code) (ms : Mach.regset) - (m : mem), exec_instr_prop f sp c ms m c ms m. + (m : mem), exec_instr_prop f sp c ms m E0 c ms m. Proof. intros; red; intros. exists rs1. split. auto. split. apply exec_refl. auto. @@ -1019,28 +1025,29 @@ Qed. Lemma exec_one_prop: forall (f : function) (sp : val) (c : Mach.code) (ms : Mach.regset) - (m : mem) (c' : Mach.code) (ms' : Mach.regset) (m' : mem), - Mach.exec_instr ge f sp c ms m c' ms' m' -> - exec_instr_prop f sp c ms m c' ms' m' -> - exec_instr_prop f sp c ms m c' ms' m'. + (m : mem) (t: trace) (c' : Mach.code) (ms' : Mach.regset) (m' : mem), + Mach.exec_instr ge f sp c ms m t c' ms' m' -> + exec_instr_prop f sp c ms m t c' ms' m' -> + exec_instr_prop f sp c ms m t c' ms' m'. Proof. auto. Qed. Lemma exec_trans_prop: forall (f : function) (sp : val) (c1 : Mach.code) (ms1 : Mach.regset) - (m1 : mem) (c2 : Mach.code) (ms2 : Mach.regset) (m2 : mem) - (c3 : Mach.code) (ms3 : Mach.regset) (m3 : mem), - exec_instrs ge f sp c1 ms1 m1 c2 ms2 m2 -> - exec_instr_prop f sp c1 ms1 m1 c2 ms2 m2 -> - exec_instrs ge f sp c2 ms2 m2 c3 ms3 m3 -> - exec_instr_prop f sp c2 ms2 m2 c3 ms3 m3 -> - exec_instr_prop f sp c1 ms1 m1 c3 ms3 m3. + (m1 : mem) (t1: trace) (c2 : Mach.code) (ms2 : Mach.regset) (m2 : mem) + (t2: trace) (c3 : Mach.code) (ms3 : Mach.regset) (m3 : mem) (t3: trace), + exec_instrs ge f sp c1 ms1 m1 t1 c2 ms2 m2 -> + exec_instr_prop f sp c1 ms1 m1 t1 c2 ms2 m2 -> + exec_instrs ge f sp c2 ms2 m2 t2 c3 ms3 m3 -> + exec_instr_prop f sp c2 ms2 m2 t2 c3 ms3 m3 -> + t3 = t1 ** t2 -> + exec_instr_prop f sp c1 ms1 m1 t3 c3 ms3 m3. Proof. intros; red; intros. generalize (H0 rs1 WTF INCL AT AG). intros [rs2 [AG2 [EX2 AT2]]]. - generalize (exec_instrs_incl _ _ _ _ _ _ _ _ H INCL). intro INCL2. + generalize (exec_instrs_incl _ _ _ _ _ _ _ _ _ H INCL). intro INCL2. generalize (H2 rs2 WTF INCL2 AT2 AG2). intros [rs3 [AG3 [EX3 AT3]]]. exists rs3. split. auto. split. eapply exec_trans; eauto. auto. @@ -1048,23 +1055,23 @@ Qed. Lemma exec_function_body_prop_: forall (f : function) (parent ra : val) (ms : Mach.regset) (m : mem) - (ms' : Mach.regset) (m1 m2 m3 m4 : mem) (stk : block) + (t: trace) (ms' : Mach.regset) (m1 m2 m3 m4 : mem) (stk : block) (c : list Mach.instruction), alloc m (- fn_framesize f) (align_16_top (- fn_framesize f) (fn_stacksize f)) = (m1, stk) -> let sp := Vptr stk (Int.repr (- fn_framesize f)) in store_stack m1 sp Tint (Int.repr 0) parent = Some m2 -> store_stack m2 sp Tint (Int.repr 4) ra = Some m3 -> - exec_instrs ge f sp (fn_code f) ms m3 (Mreturn :: c) ms' m4 -> - exec_instr_prop f sp (fn_code f) ms m3 (Mreturn :: c) ms' m4 -> + exec_instrs ge f sp (fn_code f) ms m3 t (Mreturn :: c) ms' m4 -> + exec_instr_prop f sp (fn_code f) ms m3 t (Mreturn :: c) ms' m4 -> load_stack m4 sp Tint (Int.repr 0) = Some parent -> load_stack m4 sp Tint (Int.repr 4) = Some ra -> - exec_function_body_prop f parent ra ms m ms' (free m4 stk). + exec_function_body_prop f parent ra ms m t ms' (free m4 stk). Proof. intros; red; intros. generalize (Genv.find_funct_inv AT). intros [b EQPC]. generalize AT. rewrite EQPC. rewrite Genv.find_funct_find_funct_ptr. intro FN. - generalize (functions_translated_no_overflow _ _ FN); intro NOOV. + generalize (functions_transl_no_overflow _ _ FN); intro NOOV. set (rs2 := nextinstr (rs1#GPR1 <- sp #GPR2 <- Vundef)). set (rs3 := nextinstr (rs2#GPR2 <- ra)). set (rs4 := nextinstr rs3). @@ -1132,18 +1139,18 @@ Proof. elim AG7; auto. auto with ppcgen. auto with ppcgen. unfold rs9; auto with ppcgen. (* execution *) - split. apply exec_trans with rs4 m3. + split. apply exec_trans with E0 rs4 m3 t. eapply exec_straight_steps_1; eauto. - apply functions_translated; auto. - apply exec_trans with rs5 m4. assumption. + apply functions_transl; auto. + apply exec_trans with t rs5 m4 E0. assumption. inversion AT5. - apply exec_trans with rs8 (free m4 stk). + apply exec_trans with E0 rs8 (free m4 stk) E0. eapply exec_straight_steps_1; eauto. - apply functions_translated; auto. + apply functions_transl; auto. apply exec_one. econstructor. change rs8#PC with (Val.add (Val.add (Val.add rs5#PC Vone) Vone) Vone). rewrite <- H8. simpl. reflexivity. - apply functions_translated; eauto. + apply functions_transl; eauto. assert (code_tail (Int.unsigned (Int.add (Int.add (Int.add ofs Int.one) Int.one) Int.one)) (transl_function f) = Pblr :: transl_code c). eapply code_tail_next_int; auto. @@ -1153,35 +1160,62 @@ Proof. rewrite find_instr_tail. rewrite H13. reflexivity. reflexivity. + traceEq. traceEq. traceEq. (* LR preservation *) change rs9#PC with ra. auto. Qed. -Lemma exec_function_prop_: +Lemma exec_function_internal_prop: forall (f : function) (parent : val) (ms : Mach.regset) (m : mem) - (ms' : Mach.regset) (m' : mem), + (t: trace) (ms' : Mach.regset) (m' : mem), (forall ra : val, Val.has_type ra Tint -> - exec_function_body ge f parent ra ms m ms' m') -> + exec_function_body ge f parent ra ms m t ms' m') -> (forall ra : val, Val.has_type ra Tint -> - exec_function_body_prop f parent ra ms m ms' m') -> - exec_function_prop f parent ms m ms' m'. + exec_function_body_prop f parent ra ms m t ms' m') -> + exec_function_prop (Internal f) parent ms m t ms' m'. Proof. intros; red; intros. - apply (H0 rs1#LR WTRA rs1 WTRA (refl_equal _) WTF AT AG). + inversion WTF. subst f0. + apply (H0 rs1#LR WTRA rs1 WTRA (refl_equal _) H2 AT AG). +Qed. + +Lemma exec_function_external_prop: + forall (ef : external_function) (parent : val) (args : list val) + (res : val) (ms1 ms2: Mach.regset) (m : mem) + (t : trace), + event_match ef args t res -> + args = ms1 ## (Conventions.loc_external_arguments (ef_sig ef)) -> + ms2 = Regmap.set (Conventions.loc_result (ef_sig ef)) res ms1 -> + exec_function_prop (External ef) parent ms1 m t ms2 m. +Proof. + intros; red; intros. + destruct (Genv.find_funct_inv AT) as [b EQ]. + rewrite EQ in AT. rewrite Genv.find_funct_find_funct_ptr in AT. + exists (rs1#(loc_external_result (ef_sig ef)) <- res #PC <- (rs1 LR)). + split. rewrite loc_external_result_match. rewrite H1. auto with ppcgen. + split. apply exec_one. eapply exec_step_external; eauto. + destruct (functions_translated _ _ AT) as [tf [A B]]. + simpl in B. congruence. + rewrite H0. rewrite loc_external_arguments_match. + rewrite list_map_compose. apply list_map_exten; intros. + symmetry; eapply preg_val; eauto. + reflexivity. Qed. (** We then conclude by induction on the structure of the Mach execution derivation. *) Theorem transf_function_correct: - forall f parent ms m ms' m', - Mach.exec_function ge f parent ms m ms' m' -> - exec_function_prop f parent ms m ms' m'. + forall f parent ms m t ms' m', + Mach.exec_function ge f parent ms m t ms' m' -> + exec_function_prop f parent ms m t ms' m'. Proof (Mach.exec_function_ind4 ge - exec_instr_prop exec_instr_prop - exec_function_body_prop exec_function_prop + exec_instr_prop + exec_instr_prop + exec_function_body_prop + exec_function_prop exec_Mlabel_prop exec_Mgetstack_prop @@ -1191,6 +1225,7 @@ Proof exec_Mload_prop exec_Mstore_prop exec_Mcall_prop + exec_Malloc_prop exec_Mgoto_prop exec_Mcond_true_prop exec_Mcond_false_prop @@ -1198,21 +1233,22 @@ Proof exec_one_prop exec_trans_prop exec_function_body_prop_ - exec_function_prop_). + exec_function_internal_prop + exec_function_external_prop). End PRESERVATION. Theorem transf_program_correct: - forall (p: Mach.program) (tp: PPC.program) (r: val), + forall (p: Mach.program) (tp: PPC.program) (t: trace) (r: val), wt_program p -> transf_program p = Some tp -> - Mach.exec_program p r -> - PPC.exec_program tp r. + Mach.exec_program p t r -> + PPC.exec_program tp t r. Proof. intros. destruct H1 as [fptr [f [ms [m [FINDS [FINDF [EX RES]]]]]]]. - assert (WTF: wt_function f). - apply (Genv.find_funct_ptr_prop wt_function H FINDF). + assert (WTF: wt_fundef f). + apply (Genv.find_funct_ptr_prop wt_fundef H FINDF). set (ge := Genv.globalenv p) in *. set (ms0 := Regmap.init Vundef) in *. set (tge := Genv.globalenv tp). @@ -1232,7 +1268,7 @@ Proof. assert (WTRA: Val.has_type (rs0 LR) Tint). exact I. generalize (transf_function_correct p tp H0 H - _ _ _ _ _ _ EX rs0 WTF AT AG WTRA). + _ _ _ _ _ _ _ EX rs0 WTF AT AG WTRA). intros [rs [AG' [EX' RPC]]]. red. exists rs; exists m. split. rewrite (Genv.init_mem_transf_partial _ _ H0). exact EX'. diff --git a/backend/PPCgenproof1.v b/backend/PPCgenproof1.v index 30eb336..4a9ac94 100644 --- a/backend/PPCgenproof1.v +++ b/backend/PPCgenproof1.v @@ -14,6 +14,7 @@ Require Import Mach. Require Import Machtyping. Require Import PPC. Require Import PPCgen. +Require Conventions. (** * Properties of low half/high half decomposition *) @@ -430,6 +431,75 @@ Proof. Qed. Hint Resolve gpr_or_zero_not_zero gpr_or_zero_zero: ppcgen. +(** Connection between Mach and PPC calling conventions for external + functions. *) + +Lemma loc_external_result_match: + forall sg, + PPC.loc_external_result sg = preg_of (Conventions.loc_result sg). +Proof. + intros. destruct sg as [sargs sres]. + destruct sres. destruct t; reflexivity. reflexivity. +Qed. + +Remark list_map_drop1: + forall (A B: Set) (f: A -> B) (l: list A), list_drop1 (map f l) = map f (list_drop1 l). +Proof. + intros; destruct l; reflexivity. +Qed. + +Remark list_map_drop2: + forall (A B: Set) (f: A -> B) (l: list A), list_drop2 (map f l) = map f (list_drop2 l). +Proof. + intros; destruct l. reflexivity. destruct l; reflexivity. +Qed. + +Lemma loc_external_arguments_rec_match: + forall tyl iregl fregl ofs, + (forall r, In r iregl -> mreg_type r = Tint) -> + (forall r, In r fregl -> mreg_type r = Tfloat) -> + PPC.loc_external_arguments_rec tyl (map ireg_of iregl) (map freg_of fregl) = + List.map + (fun l => preg_of (match l with R r => r | S _ => IT1 end)) + (Conventions.loc_arguments_rec tyl iregl fregl ofs). +Proof. + induction tyl; intros; simpl. + auto. + destruct a; simpl; apply (f_equal2 (@cons preg)). + destruct iregl; simpl. + reflexivity. unfold preg_of; rewrite (H m); auto with coqlib. + rewrite list_map_drop1. apply IHtyl. + intros; apply H; apply list_drop1_incl; auto. + assumption. + destruct fregl; simpl. + reflexivity. unfold preg_of; rewrite (H0 m); auto with coqlib. + rewrite list_map_drop1. rewrite list_map_drop2. apply IHtyl. + intros; apply H; apply list_drop2_incl; auto. + intros; apply H0; apply list_drop1_incl; auto. +Qed. + +Ltac ElimOrEq := + match goal with + | |- (?x = ?y) \/ _ -> _ => + let H := fresh in + (intro H; elim H; clear H; + [intro H; rewrite <- H; clear H | ElimOrEq]) + | |- False -> _ => + let H := fresh in (intro H; contradiction) + end. + +Lemma loc_external_arguments_match: + forall sg, + PPC.loc_external_arguments sg = List.map preg_of (Conventions.loc_external_arguments sg). +Proof. + intros. destruct sg as [sgargs sgres]; unfold loc_external_arguments, Conventions.loc_external_arguments. + rewrite list_map_compose. unfold Conventions.loc_arguments. + rewrite <- loc_external_arguments_rec_match. + reflexivity. + intro; simpl; ElimOrEq; reflexivity. + intro; simpl; ElimOrEq; reflexivity. +Qed. + (** * Execution of straight-line code *) Section STRAIGHTLINE. @@ -1198,6 +1268,22 @@ Proof. rewrite (sp_val ms sp rs). auto. auto. (* Oundef again *) congruence. + (* Ocast8unsigned *) + exists (nextinstr (rs#(ireg_of res) <- (Val.rolm (ms m0) Int.zero (Int.repr 255)))). + split. apply exec_straight_one. repeat (rewrite (ireg_val ms sp rs)); auto. reflexivity. + replace (Val.cast8unsigned (ms m0)) + with (Val.rolm (ms m0) Int.zero (Int.repr 255)). + auto with ppcgen. + unfold Val.rolm, Val.cast8unsigned. destruct (ms m0); auto. + rewrite Int.rolm_zero. rewrite Int.cast8unsigned_and. auto. + (* Ocast16unsigned *) + exists (nextinstr (rs#(ireg_of res) <- (Val.rolm (ms m0) Int.zero (Int.repr 65535)))). + split. apply exec_straight_one. repeat (rewrite (ireg_val ms sp rs)); auto. reflexivity. + replace (Val.cast16unsigned (ms m0)) + with (Val.rolm (ms m0) Int.zero (Int.repr 65535)). + auto with ppcgen. + unfold Val.rolm, Val.cast16unsigned. destruct (ms m0); auto. + rewrite Int.rolm_zero. rewrite Int.cast16unsigned_and. auto. (* Oaddimm *) generalize (addimm_correct (ireg_of res) (ireg_of m0) i k rs m (ireg_of_not_GPR2 m0)). @@ -1562,5 +1648,31 @@ Proof. auto. auto. Qed. +(** Translation of allocations *) + +Lemma transl_alloc_correct: + forall ms sp rs sz m m' blk k, + agree ms sp rs -> + ms Conventions.loc_alloc_argument = Vint sz -> + Mem.alloc m 0 (Int.signed sz) = (m', blk) -> + let ms' := Regmap.set Conventions.loc_alloc_result (Vptr blk Int.zero) ms in + exists rs', + exec_straight (Pallocblock :: k) rs m k rs' m' + /\ agree ms' sp rs'. +Proof. + intros. + pose (rs' := nextinstr (rs#GPR3 <- (Vptr blk Int.zero) #LR <- (Val.add rs#PC Vone))). + exists rs'; split. + apply exec_straight_one. unfold exec_instr. + generalize (preg_val _ _ _ Conventions.loc_alloc_argument H). + unfold preg_of; intro. simpl in H2. rewrite <- H2. rewrite H0. + rewrite H1. reflexivity. + reflexivity. + unfold ms', rs'. apply agree_nextinstr. apply agree_set_other. + change (IR GPR3) with (preg_of Conventions.loc_alloc_result). + apply agree_set_mreg. auto. + simpl. tauto. +Qed. + End STRAIGHTLINE. diff --git a/backend/Parallelmove.v b/backend/Parallelmove.v index f95416e..b2ec930 100644 --- a/backend/Parallelmove.v +++ b/backend/Parallelmove.v @@ -1,2529 +1,290 @@ -(** Translation of parallel moves into sequences of individual moves *) +Require Import Coqlib. +Require Parmov. +Require Import Values. +Require Import Events. +Require Import AST. +Require Import Locations. +Require Import Conventions. -(** The ``parallel move'' problem, also known as ``parallel assignment'', - is the following. We are given a list of (source, destination) pairs - of locations. The goal is to find a sequence of elementary - moves ([loc <- loc] assignments) such that, at the end of the sequence, - location [dst] contains the value of location [src] at the beginning of - the sequence, for each ([src], [dst]) pairs in the given problem. - Moreover, other locations should keep their values, except one register - of each type, which can be used as temporaries in the generated sequences. +Definition temp_for (l: loc) : loc := + match Loc.type l with Tint => R IT2 | Tfloat => R FT2 end. - The parallel move problem is trivial if the sources and destinations do - not overlap. For instance, -<< - (R1, R2) <- (R3, R4) becomes R1 <- R3; R2 <- R4 ->> - However, arbitrary overlap is allowed between sources and destinations. - This requires some care in ordering the individual moves, as in -<< - (R1, R2) <- (R3, R1) becomes R2 <- R1; R1 <- R3 ->> - Worse, cycles (permutations) can require the use of temporaries, as in -<< - (R1, R2, R3) <- (R2, R3, R1) becomes T <- R1; R1 <- R2; R2 <- R3; R3 <- T; ->> - An amazing fact is that for any parallel move problem, at most one temporary - (or in our case one integer temporary and one float temporary) is needed. +Definition parmove (srcs dsts: list loc) := + Parmov.parmove2 loc temp_for Loc.eq srcs dsts. - The development in this section was contributed by Laurence Rideau and - Bernard Serpette. It is described in their paper - ``Coq à la conquête des moulins'', JFLA 2005, - #<A HREF="http://www-sop.inria.fr/lemme/Laurence.Rideau/RideauSerpetteJFLA05.ps"># - http://www-sop.inria.fr/lemme/Laurence.Rideau/RideauSerpetteJFLA05.ps - #</A># -*) +Definition moves := (list (loc * loc))%type. -Require Omega. -Require Import Wf_nat. -Require Import Conventions. -Require Import Coqlib. -Require Import Bool_nat. -Require Import TheoryList. -Require Import Bool. -Require Import Arith. -Require Import Peano_dec. -Require Import EqNat. -Require Import Values. -Require Import LTL. -Require Import EqNat. -Require Import Locations. -Require Import AST. - -Section pmov. - -Ltac caseEq name := generalize (refl_equal name); pattern name at -1; case name. -Hint Resolve beq_nat_eq . - -Lemma neq_is_neq: forall (x y : nat), x <> y -> beq_nat x y = false. -Proof. -unfold not; intros. -caseEq (beq_nat x y); auto. -intro. -elim H; auto. -Qed. -Hint Resolve neq_is_neq . - -Lemma app_nil: forall (A : Set) (l : list A), l ++ nil = l. -Proof. -intros A l; induction l as [|a l Hrecl]; auto; simpl; rewrite Hrecl; auto. -Qed. - -Lemma app_cons: - forall (A : Set) (l1 l2 : list A) (a : A), (a :: l1) ++ l2 = a :: (l1 ++ l2). -Proof. -auto. -Qed. - -Lemma app_app: - forall (A : Set) (l1 l2 l3 : list A), l1 ++ (l2 ++ l3) = (l1 ++ l2) ++ l3. -Proof. -intros A l1; induction l1 as [|a l1 Hrecl1]; simpl; auto; intros; - rewrite Hrecl1; auto. -Qed. - -Lemma app_rewrite: - forall (A : Set) (l : list A) (x : A), - (exists y : A , exists r : list A , l ++ (x :: nil) = y :: r ). -Proof. -intros A l x; induction l as [|a l Hrecl]. -exists x; exists (nil (A:=A)); auto. -inversion Hrecl; inversion H. -exists a; exists (l ++ (x :: nil)); auto. -Qed. - -Lemma app_rewrite2: - forall (A : Set) (l l2 : list A) (x : A), - (exists y : A , exists r : list A , l ++ (x :: l2) = y :: r ). -Proof. -intros A l l2 x; induction l as [|a l Hrecl]. -exists x; exists l2; auto. -inversion Hrecl; inversion H. -exists a; exists (l ++ (x :: l2)); auto. -Qed. - -Lemma app_rewriter: - forall (A : Set) (l : list A) (x : A), - (exists y : A , exists r : list A , x :: l = r ++ (y :: nil) ). -Proof. -intros A l x; induction l as [|a l Hrecl]. -exists x; exists (nil (A:=A)); auto. -inversion Hrecl; inversion H. -generalize H0; case x1; simpl; intros; inversion H1. -exists a; exists (x0 :: nil); simpl; auto. -exists x0; exists (a0 :: (a :: l0)); simpl; auto. -Qed. -Hint Resolve app_rewriter . - -Definition Reg := loc. - -Definition T := - fun (r : loc) => - match Loc.type r with Tint => R IT2 | Tfloat => R FT2 end. - -Definition notemporary := fun (r : loc) => forall x, Loc.diff r (T x). - -Definition Move := (Reg * Reg)%type. - -Definition Moves := list Move. - -Definition State := ((Moves * Moves) * Moves)%type. - -Definition StateToMove (r : State) : Moves := - match r with ((t, b), l) => t end. - -Definition StateBeing (r : State) : Moves := - match r with ((t, b), l) => b end. - -Definition StateDone (r : State) : Moves := - match r with ((t, b), l) => l end. - -Fixpoint noRead (p : Moves) (r : Reg) {struct p} : Prop := - match p with - nil => True - | (s, d) :: l => Loc.diff s r /\ noRead l r - end. - -Lemma noRead_app: - forall (l1 l2 : Moves) (r : Reg), - noRead l1 r -> noRead l2 r -> noRead (l1 ++ l2) r. -Proof. -intros; induction l1 as [|a l1 Hrecl1]; simpl; auto. -destruct a. -elim H; intros; split; auto. -Qed. - -Inductive step : State -> State -> Prop := - step_nop: - forall (r : Reg) (t1 t2 l : Moves), - step (t1 ++ ((r, r) :: t2), nil, l) (t1 ++ t2, nil, l) - | step_start: - forall (t1 t2 l : Moves) (m : Move), - step (t1 ++ (m :: t2), nil, l) (t1 ++ t2, m :: nil, l) - | step_push: - forall (t1 t2 b l : Moves) (s d r : Reg), - step - (t1 ++ ((d, r) :: t2), (s, d) :: b, l) - (t1 ++ t2, (d, r) :: ((s, d) :: b), l) - | step_loop: - forall (t b l : Moves) (s d r0 r0ounon : Reg), - step - (t, (s, r0ounon) :: (b ++ ((r0, d) :: nil)), l) - (t, (s, r0ounon) :: (b ++ ((T r0, d) :: nil)), (r0, T r0) :: l) - | step_pop: - forall (t b l : Moves) (s0 d0 sn dn : Reg), - noRead t dn -> - Loc.diff dn s0 -> - step - (t, (sn, dn) :: (b ++ ((s0, d0) :: nil)), l) - (t, b ++ ((s0, d0) :: nil), (sn, dn) :: l) - | step_last: - forall (t l : Moves) (s d : Reg), - noRead t d -> step (t, (s, d) :: nil, l) (t, nil, (s, d) :: l) . -Hint Resolve step_nop step_start step_push step_loop step_pop step_last . - -Fixpoint path (l : Moves) : Prop := - match l with - nil => True - | (s, d) :: l => - match l with - nil => True - | (ss, dd) :: l2 => s = dd /\ path l - end - end. - -Lemma path_pop: forall (m : Move) (l : Moves), path (m :: l) -> path l. -Proof. -simpl; intros m l; destruct m as [ms md]; case l; auto. -intros m0; destruct m0; intros; inversion H; auto. -Qed. - -Fixpoint noWrite (p : Moves) (r : Reg) {struct p} : Prop := - match p with - nil => True - | (s, d) :: l => Loc.diff d r /\ noWrite l r - end. - -Lemma noWrite_pop: - forall (p1 p2 : Moves) (m : Move) (r : Reg), - noWrite (p1 ++ (m :: p2)) r -> noWrite (p1 ++ p2) r. -Proof. -intros; induction p1 as [|a p1 Hrecp1]. -generalize H; simpl; case m; intros; inversion H0; auto. -generalize H; rewrite app_cons; rewrite app_cons. -simpl; case a; intros. -inversion H0; split; auto. -Qed. - -Lemma noWrite_in: - forall (p1 p2 : Moves) (r0 r1 r2 : Reg), - noWrite (p1 ++ ((r1, r2) :: p2)) r0 -> Loc.diff r0 r2. -Proof. -intros; induction p1 as [|a p1 Hrecp1]; simpl; auto. -generalize H; simpl; intros; inversion H0; auto. -apply Loc.diff_sym; auto. -generalize H; rewrite app_cons; simpl; case a; intros. -apply Hrecp1; inversion H0; auto. -Qed. - -Lemma noWrite_swap: - forall (p : Moves) (m1 m2 : Move) (r : Reg), - noWrite (m1 :: (m2 :: p)) r -> noWrite (m2 :: (m1 :: p)) r. -Proof. -intros p m1 m2 r; simpl; case m1; case m2. -intros; inversion H; inversion H1; split; auto. -Qed. - -Lemma noWrite_movFront: - forall (p1 p2 : Moves) (m : Move) (r0 : Reg), - noWrite (p1 ++ (m :: p2)) r0 -> noWrite (m :: (p1 ++ p2)) r0. -Proof. -intros p1 p2 m r0; induction p1 as [|a p1 Hrecp1]; auto. -case a; intros r1 r2; rewrite app_cons; rewrite app_cons. -intros; apply noWrite_swap; rewrite <- app_cons. -simpl in H |-; inversion H; unfold noWrite; fold noWrite; auto. -Qed. - -Lemma noWrite_insert: - forall (p1 p2 : Moves) (m : Move) (r0 : Reg), - noWrite (m :: (p1 ++ p2)) r0 -> noWrite (p1 ++ (m :: p2)) r0. -Proof. -intros p1 p2 m r0; induction p1 as [|a p1 Hrecp1]. -simpl; auto. -destruct a; simpl. -destruct m. -intros [H1 [H2 H3]]; split; auto. -apply Hrecp1. -simpl; auto. -Qed. - -Lemma noWrite_tmpLast: - forall (t : Moves) (r s d : Reg), - noWrite (t ++ ((s, d) :: nil)) r -> - forall (x : Reg), noWrite (t ++ ((x, d) :: nil)) r. -Proof. -intros; induction t as [|a t Hrect]. -simpl; auto. -generalize H; simpl; case a; intros; inversion H0; split; auto. -Qed. - -Fixpoint simpleDest (p : Moves) : Prop := - match p with - nil => True - | (s, d) :: l => noWrite l d /\ simpleDest l - end. - -Lemma simpleDest_Pop: - forall (m : Move) (l1 l2 : Moves), - simpleDest (l1 ++ (m :: l2)) -> simpleDest (l1 ++ l2). -Proof. -intros; induction l1 as [|a l1 Hrecl1]. -generalize H; simpl; case m; intros; inversion H0; auto. -generalize H; rewrite app_cons; rewrite app_cons. -simpl; case a; intros; inversion H0; split; auto. -apply (noWrite_pop l1 l2 m); auto. -Qed. - -Lemma simpleDest_pop: - forall (m : Move) (l : Moves), simpleDest (m :: l) -> simpleDest l. -Proof. -intros m l; simpl; case m; intros _ r [X Y]; auto. -Qed. - -Lemma simpleDest_right: - forall (l1 l2 : Moves), simpleDest (l1 ++ l2) -> simpleDest l2. -Proof. -intros l1; induction l1 as [|a l1 Hrecl1]; auto. -intros l2; rewrite app_cons; intros; apply Hrecl1. -apply (simpleDest_pop a); auto. -Qed. - -Lemma simpleDest_swap: - forall (m1 m2 : Move) (l : Moves), - simpleDest (m1 :: (m2 :: l)) -> simpleDest (m2 :: (m1 :: l)). -Proof. -intros m1 m2 l; simpl; case m1; case m2. -intros _ r0 _ r2 [[X Y] [Z U]]; auto. -(repeat split); auto. -apply Loc.diff_sym; auto. -Qed. - -Lemma simpleDest_pop2: - forall (m1 m2 : Move) (l : Moves), - simpleDest (m1 :: (m2 :: l)) -> simpleDest (m1 :: l). -Proof. -intros; apply (simpleDest_pop m2); apply simpleDest_swap; auto. -Qed. - -Lemma simpleDest_movFront: - forall (p1 p2 : Moves) (m : Move), - simpleDest (p1 ++ (m :: p2)) -> simpleDest (m :: (p1 ++ p2)). -Proof. -intros p1 p2 m; induction p1 as [|a p1 Hrecp1]. -simpl; auto. -rewrite app_cons; rewrite app_cons. -case a; intros; simpl in H |-; inversion H. -apply simpleDest_swap; simpl; auto. -destruct m. -cut (noWrite ((r1, r2) :: (p1 ++ p2)) r0). -cut (simpleDest ((r1, r2) :: (p1 ++ p2))). -intro; (repeat split); elim H3; elim H2; intros; auto. -apply Hrecp1; auto. -apply noWrite_movFront; auto. -Qed. - -Lemma simpleDest_insert: - forall (p1 p2 : Moves) (m : Move), - simpleDest (m :: (p1 ++ p2)) -> simpleDest (p1 ++ (m :: p2)). -Proof. -intros p1 p2 m; induction p1 as [|a p1 Hrecp1]. -simpl; auto. -rewrite app_cons; intros. -simpl. -destruct a as [a1 a2]. -split. -destruct m; simpl in H |-. -apply noWrite_insert. -simpl; split; elim H; intros [H1 H2] [H3 H4]; auto. -apply Loc.diff_sym; auto. -apply Hrecp1. -apply simpleDest_pop2 with (a1, a2); auto. -Qed. - -Lemma simpleDest_movBack: - forall (p1 p2 : Moves) (m : Move), - simpleDest (p1 ++ (m :: p2)) -> simpleDest ((p1 ++ p2) ++ (m :: nil)). -Proof. -intros. -apply (simpleDest_insert (p1 ++ p2) nil m). -rewrite app_nil; apply simpleDest_movFront; auto. -Qed. - -Lemma simpleDest_swap_app: - forall (t1 t2 t3 : Moves) (m : Move), - simpleDest (t1 ++ (m :: (t2 ++ t3))) -> simpleDest ((t1 ++ t2) ++ (m :: t3)). -Proof. -intros. -apply (simpleDest_insert (t1 ++ t2) t3 m). -rewrite <- app_app. -apply simpleDest_movFront; auto. -Qed. - -Lemma simpleDest_tmpLast: - forall (t : Moves) (s d : Reg), - simpleDest (t ++ ((s, d) :: nil)) -> - forall (r : Reg), simpleDest (t ++ ((r, d) :: nil)). -Proof. -intros t s d; induction t as [|a t Hrect]. -simpl; auto. -simpl; case a; intros; inversion H; split; auto. -apply (noWrite_tmpLast t r0 s); auto. -Qed. - -Fixpoint noTmp (b : Moves) : Prop := - match b with - nil => True - | (s, d) :: l => - (forall r, Loc.diff s (T r)) /\ - ((forall r, Loc.diff d (T r)) /\ noTmp l) - end. - -Fixpoint noTmpLast (b : Moves) : Prop := - match b with - nil => True - | (s, d) :: nil => forall r, Loc.diff d (T r) - | (s, d) :: l => - (forall r, Loc.diff s (T r)) /\ - ((forall r, Loc.diff d (T r)) /\ noTmpLast l) - end. - -Lemma noTmp_app: - forall (l1 l2 : Moves) (m : Move), - noTmp l1 -> noTmpLast (m :: l2) -> noTmpLast (l1 ++ (m :: l2)). -Proof. -intros. -induction l1 as [|a l1 Hrecl1]. -simpl; auto. -simpl. -caseEq (l1 ++ (m :: l2)); intro. -destruct a. -elim H; intros; auto. -inversion H; auto. -elim H3; auto. -intros; destruct a as [a1 a2]. -elim H; intros H2 [H3 H4]; auto. -(repeat split); auto. -rewrite H1 in Hrecl1; apply Hrecl1; auto. -Qed. - -Lemma noTmpLast_popBack: - forall (t : Moves) (m : Move), noTmpLast (t ++ (m :: nil)) -> noTmp t. -Proof. -intros. -induction t as [|a t Hrect]. -simpl; auto. -destruct a as [a1 a2]. -rewrite app_cons in H. -simpl. -simpl in H |-. -generalize H; caseEq (t ++ (m :: nil)); intros. -destruct t; inversion H0. -elim H1. -intros H2 [H3 H4]; (repeat split); auto. -rewrite <- H0 in H4. -apply Hrect; auto. -Qed. - -Fixpoint getsrc (p : Moves) : list Reg := - match p with - nil => nil - | (s, d) :: l => s :: getsrc l - end. - -Fixpoint getdst (p : Moves) : list Reg := - match p with - nil => nil - | (s, d) :: l => d :: getdst l - end. - -Fixpoint noOverlap_aux (r : Reg) (l : list Reg) {struct l} : Prop := - match l with - nil => True - | b :: m => (b = r \/ Loc.diff b r) /\ noOverlap_aux r m - end. - -Definition noOverlap (p : Moves) : Prop := - forall l, In l (getsrc p) -> noOverlap_aux l (getdst p). - -Definition stepInv (r : State) : Prop := - path (StateBeing r) /\ - (simpleDest (StateToMove r ++ StateBeing r) /\ - (noOverlap (StateToMove r ++ StateBeing r) /\ - (noTmp (StateToMove r) /\ noTmpLast (StateBeing r)))). - -Definition Value := val. - -Definition Env := locset. - -Definition get (e : Env) (r : Reg) := Locmap.get r e. - -Definition update (e : Env) (r : Reg) (v : Value) : Env := Locmap.set r v e. - -Fixpoint sexec (p : Moves) (e : Env) {struct p} : Env := - match p with - nil => e - | (s, d) :: l => let e' := sexec l e in - update e' d (get e' s) - end. - -Fixpoint pexec (p : Moves) (e : Env) {struct p} : Env := - match p with - nil => e - | (s, d) :: l => update (pexec l e) d (get e s) - end. - -Lemma get_update: - forall (e : Env) (r1 r2 : Reg) (v : Value), - get (update e r1 v) r2 = - (if Loc.eq r1 r2 then v else if Loc.overlap r1 r2 then Vundef else get e r2). -Proof. -intros. -unfold update, get, Locmap.get, Locmap.set; trivial. -Qed. - -Lemma get_update_id: - forall (e : Env) (r1 : Reg) (v : Value), get (update e r1 v) r1 = v. -Proof. -intros e r1 v; rewrite (get_update e r1 r1); auto. -case (Loc.eq r1 r1); auto. -intros H; elim H; trivial. -Qed. - -Lemma get_update_diff: - forall (e : Env) (r1 r2 : Reg) (v : Value), - Loc.diff r1 r2 -> get (update e r1 v) r2 = get e r2. -Proof. -intros; unfold update, get, Locmap.get, Locmap.set. -case (Loc.eq r1 r2); intro. -absurd (r1 = r2); [apply Loc.diff_not_eq; trivial | trivial]. -caseEq (Loc.overlap r1 r2); intro; trivial. -absurd (Loc.diff r1 r2); [apply Loc.overlap_not_diff; assumption | assumption]. -Qed. - -Lemma get_update_ndiff: - forall (e : Env) (r1 r2 : Reg) (v : Value), - r1 <> r2 -> not (Loc.diff r1 r2) -> get (update e r1 v) r2 = Vundef. -Proof. -intros; unfold update, get, Locmap.get, Locmap.set. -case (Loc.eq r1 r2); intro. -absurd (r1 = r2); assumption. -caseEq (Loc.overlap r1 r2); intro; trivial. -absurd (Loc.diff r1 r2); (try assumption). -apply Loc.non_overlap_diff; assumption. -Qed. - -Lemma pexec_swap: - forall (m1 m2 : Move) (t : Moves), - simpleDest (m1 :: (m2 :: t)) -> - forall (e : Env) (r : Reg), - get (pexec (m1 :: (m2 :: t)) e) r = get (pexec (m2 :: (m1 :: t)) e) r. -Proof. -intros; destruct m1 as [m1s m1d]; destruct m2 as [m2s m2d]. -generalize H; simpl; intros [[NEQ NW] [NW2 HSD]]; clear H. -case (Loc.eq m1d r); case (Loc.eq m2d r); intros. -absurd (m1d = m2d); - [apply Loc.diff_not_eq; apply Loc.diff_sym; assumption | - rewrite e0; rewrite e1; trivial]. -caseEq (Loc.overlap m2d r); intro. -absurd (Loc.diff m2d m1d); [apply Loc.overlap_not_diff; rewrite e0 | idtac]; - (try assumption). -subst m1d; rewrite get_update_id; rewrite get_update_diff; - (try rewrite get_update_id); auto. -caseEq (Loc.overlap m1d r); intro. -absurd (Loc.diff m1d m2d); - [apply Loc.overlap_not_diff; rewrite e0 | apply Loc.diff_sym]; assumption. -subst m2d; (repeat rewrite get_update_id); rewrite get_update_diff; - [rewrite get_update_id; trivial | apply Loc.diff_sym; trivial]. -caseEq (Loc.overlap m1d r); caseEq (Loc.overlap m2d r); intros. -(repeat rewrite get_update_ndiff); - (try (apply Loc.overlap_not_diff; assumption)); trivial. -assert (~ Loc.diff m1d r); - [apply Loc.overlap_not_diff; assumption | - intros; rewrite get_update_ndiff; auto]. -rewrite get_update_diff; - [rewrite get_update_ndiff; auto | apply Loc.non_overlap_diff; auto]. -cut (~ Loc.diff m2d r); [idtac | apply Loc.overlap_not_diff; auto]. -cut (Loc.diff m1d r); [idtac | apply Loc.non_overlap_diff; auto]. -intros; rewrite get_update_diff; auto. -(repeat rewrite get_update_ndiff); auto. -cut (Loc.diff m1d r); [idtac | apply Loc.non_overlap_diff; auto]. -cut (Loc.diff m2d r); [idtac | apply Loc.non_overlap_diff; auto]. -intros; (repeat rewrite get_update_diff); auto. -Qed. - -Lemma pexec_add: - forall (t1 t2 : Moves) (r : Reg) (e : Env), - get (pexec t1 e) r = get (pexec t2 e) r -> - forall (a : Move), get (pexec (a :: t1) e) r = get (pexec (a :: t2) e) r. -Proof. -intros. -case a. -simpl. -intros a1 a2. -unfold get, update, Locmap.set, Locmap.get. -case (Loc.eq a2 r); case (Loc.overlap a2 r); auto. -Qed. - -Lemma pexec_movBack: - forall (t1 t2 : Moves) (m : Move), - simpleDest (m :: (t1 ++ t2)) -> - forall (e : Env) (r : Reg), - get (pexec (m :: (t1 ++ t2)) e) r = get (pexec (t1 ++ (m :: t2)) e) r. -Proof. -intros t1 t2 m; induction t1 as [|a t1 Hrect1]. -simpl; auto. -rewrite app_cons. -intros; rewrite pexec_swap; auto; rewrite app_cons; auto. -apply pexec_add. -apply Hrect1. -apply (simpleDest_pop2 m a); auto. -Qed. - -Lemma pexec_movFront: - forall (t1 t2 : Moves) (m : Move), - simpleDest (t1 ++ (m :: t2)) -> - forall (e : Env) (r : Reg), - get (pexec (t1 ++ (m :: t2)) e) r = get (pexec (m :: (t1 ++ t2)) e) r. -Proof. -intros; rewrite <- pexec_movBack; eauto. -apply simpleDest_movFront; auto. -Qed. - -Lemma pexec_mov: - forall (t1 t2 t3 : Moves) (m : Move), - simpleDest ((t1 ++ (m :: t2)) ++ t3) -> - forall (e : Env) (r : Reg), - get (pexec ((t1 ++ (m :: t2)) ++ t3) e) r = - get (pexec ((t1 ++ t2) ++ (m :: t3)) e) r. -Proof. -intros t1 t2 t3 m. -rewrite <- app_app. -rewrite app_cons. -intros. -rewrite pexec_movFront; auto. -cut (simpleDest (m :: (t1 ++ (t2 ++ t3)))). -rewrite app_app. -rewrite <- pexec_movFront; auto. -apply simpleDest_swap_app; auto. -apply simpleDest_movFront; auto. -Qed. - -Definition diff_dec: - forall (x y : Reg), ({ Loc.diff x y }) + ({ not (Loc.diff x y) }). -intros. -case (Loc.eq x y). -intros heq; right. -red; intro; absurd (x = y); auto. -apply Loc.diff_not_eq; auto. -intro; caseEq (Loc.overlap x y). -intro; right. -apply Loc.overlap_not_diff; auto. -intro; left; apply Loc.non_overlap_diff; auto. -Defined. - -Lemma get_pexec_id_noWrite: - forall (t : Moves) (d : Reg), - noWrite t d -> - forall (e : Env) (v : Value), v = get (pexec t (update e d v)) d. -Proof. -intros. -induction t as [|a t Hrect]. -simpl. -rewrite get_update_id; auto. -generalize H; destruct a as [a1 a2]; simpl; intros [NEQ R]. -rewrite get_update_diff; auto. -Qed. - -Lemma pexec_nop: - forall (t : Moves) (r : Reg) (e : Env) (x : Reg), - Loc.diff r x -> get (pexec ((r, r) :: t) e) x = get (pexec t e) x. -Proof. -intros. -simpl. -rewrite get_update_diff; auto. -Qed. - -Lemma sD_nW: forall t r s, simpleDest ((s, r) :: t) -> noWrite t r. -Proof. -induction t. -simpl; auto. -simpl. -destruct a. -intros r1 r2 H; split; [try assumption | idtac]. -elim H; - [intros H0 H1; elim H0; [intros H2 H3; (try clear H0 H); (try exact H2)]]. -elim H; - [intros H0 H1; elim H0; [intros H2 H3; (try clear H0 H); (try exact H3)]]. -Qed. - -Lemma sD_pexec: - forall (t : Moves) (s d : Reg), - simpleDest ((s, d) :: t) -> forall (e : Env), get (pexec t e) d = get e d. -Proof. -intros. -induction t as [|a t Hrect]; simpl; auto. -destruct a as [a1 a2]. -simpl in H |-; elim H; intros [H0 H1] [H2 H3]; clear H. -case (Loc.eq a2 d); intro. -absurd (a2 = d); [apply Loc.diff_not_eq | trivial]; assumption. -rewrite get_update_diff; (try assumption). -apply Hrect. -simpl; (split; assumption). -Qed. - -Lemma noOverlap_nil: noOverlap nil. -Proof. -unfold noOverlap, noOverlap_aux, getsrc, getdst; trivial. -Qed. - -Lemma getsrc_add: - forall (m : Move) (l1 l2 : Moves) (l : Reg), - In l (getsrc (l1 ++ l2)) -> In l (getsrc (l1 ++ (m :: l2))). -Proof. -intros m l1 l2 l; destruct m; induction l1; simpl; auto. -destruct a; simpl; intros. -elim H; intros H0; [left | right]; auto. -Qed. - -Lemma getdst_add: - forall (r1 r2 : Reg) (l1 l2 : Moves), - getdst (l1 ++ ((r1, r2) :: l2)) = getdst l1 ++ (r2 :: getdst l2). -Proof. -intros r1 r2 l1 l2; induction l1; simpl; auto. -destruct a; simpl; rewrite IHl1; auto. -Qed. - -Lemma getdst_app: - forall (l1 l2 : Moves), getdst (l1 ++ l2) = getdst l1 ++ getdst l2. -Proof. -intros; induction l1; simpl; auto. -destruct a; simpl; rewrite IHl1; auto. -Qed. - -Lemma noOverlap_auxpop: - forall (x r : Reg) (l : list Reg), - noOverlap_aux x (r :: l) -> noOverlap_aux x l. -Proof. -induction l; simpl; auto. -intros [H1 [H2 H3]]; split; auto. -Qed. - -Lemma noOverlap_auxPop: - forall (x r : Reg) (l1 l2 : list Reg), - noOverlap_aux x (l1 ++ (r :: l2)) -> noOverlap_aux x (l1 ++ l2). -Proof. -intros x r l1 l2; (try assumption). -induction l1 as [|a l1 Hrecl1]; simpl app. -intro; apply (noOverlap_auxpop x r); auto. -(repeat rewrite app_cons); simpl. -intros [H1 H2]; split; auto. -Qed. - -Lemma noOverlap_pop: - forall (m : Move) (l : Moves), noOverlap (m :: l) -> noOverlap l. -Proof. -induction l. -intro; apply noOverlap_nil. -unfold noOverlap; simpl; destruct m; destruct a; simpl; intros. -elim (H l0); intros; (try assumption). -elim H0; intros H1; right; [left | right]; assumption. -Qed. - -Lemma noOverlap_Pop: - forall (m : Move) (l1 l2 : Moves), - noOverlap (l1 ++ (m :: l2)) -> noOverlap (l1 ++ l2). -Proof. -intros m l1 l2; induction l1 as [|a l1 Hrecl1]; simpl. -simpl; apply noOverlap_pop. -(repeat rewrite app_cons); unfold noOverlap; destruct a; simpl. -intros H l H0; split. -elim (H l); [intros H1 H2 | idtac]; auto. -elim H0; [intros H3; left | intros H3; right; apply getsrc_add]; auto. -unfold noOverlap in Hrecl1 |-. -elim H0; intros H1; clear H0. -destruct m; rewrite getdst_app; apply noOverlap_auxPop with ( r := r2 ). -rewrite getdst_add in H. -elim H with ( l := l ); [intros H0 H2; (try clear H); (try exact H2) | idtac]. -left; (try assumption). -apply Hrecl1 with ( l := l ); auto. -intros l0 H0; (try assumption). -elim H with ( l := l0 ); [intros H2 H3; (try clear H); (try exact H3) | idtac]; - auto. -Qed. - -Lemma noOverlap_right: - forall (l1 l2 : Moves), noOverlap (l1 ++ l2) -> noOverlap l2. -Proof. -intros l1; induction l1 as [|a l1 Hrecl1]; auto. -intros l2; rewrite app_cons; intros; apply Hrecl1. -apply (noOverlap_pop a); auto. -Qed. - -Lemma pexec_update: - forall t e d r v, - Loc.diff d r -> - noRead t d -> get (pexec t (update e d v)) r = get (pexec t e) r. -Proof. -induction t; simpl. -intros; rewrite get_update_diff; auto. -destruct a as [a1 a2]; intros; case (Loc.eq a2 r); intro. -subst a2; (repeat rewrite get_update_id). -rewrite get_update_diff; auto; apply Loc.diff_sym; elim H0; auto. -case (diff_dec a2 r); intro. -(repeat rewrite get_update_diff); auto. -apply IHt; auto. -elim H0; auto. -(repeat rewrite get_update_ndiff); auto. -Qed. - -Lemma pexec_push: - forall (t l : Moves) (s d : Reg), - noRead t d -> - simpleDest ((s, d) :: t) -> - forall (e : Env) (r : Reg), - r = d \/ Loc.diff d r -> - get (pexec ((s, d) :: t) (sexec l e)) r = - get (pexec t (sexec ((s, d) :: l) e)) r. -Proof. -intros; simpl. -elim H1; intros e1. -rewrite e1; rewrite get_update_id; auto. -rewrite (sD_pexec t s d); auto; rewrite get_update_id; auto. -rewrite pexec_update; auto. -rewrite get_update_diff; auto. -Qed. - -Definition exec (s : State) (e : Env) := - pexec (StateToMove s ++ StateBeing s) (sexec (StateDone s) e). - -Definition sameEnv (e1 e2 : Env) := - forall (r : Reg), notemporary r -> get e1 r = get e2 r. - -Definition NoOverlap (r : Reg) (s : State) := - noOverlap ((r, r) :: (StateToMove s ++ StateBeing s)). - -Lemma noOverlapaux_swap2: - forall (l1 l2 : list Reg) (m l : Reg), - noOverlap_aux l (l1 ++ (m :: l2)) -> noOverlap_aux l (m :: (l1 ++ l2)). -Proof. -intros l1 l2 m l; induction l1; simpl noOverlap_aux; auto. -intros; elim H; intros H0 H1; (repeat split); auto. -simpl in IHl1 |-. -elim IHl1; [intros H2 H3; (try exact H2) | idtac]; auto. -apply (noOverlap_auxpop l m). -apply IHl1; auto. -Qed. - -Lemma noTmp_noReadTmp: forall t, noTmp t -> forall s, noRead t (T s). -Proof. -induction t; simpl; auto. -destruct a as [a1 a2]; intros. -split; [idtac | apply IHt]; elim H; intros H1 [H2 H3]; auto. -Qed. - -Lemma noRead_by_path: - forall (b t : Moves) (r0 r1 r7 r8 : Reg), - simpleDest ((r7, r8) :: (b ++ ((r0, r1) :: nil))) -> - path (b ++ ((r0, r1) :: nil)) -> Loc.diff r8 r0 -> noRead b r8. -Proof. -intros; induction b as [|a b Hrecb]; simpl; auto. -destruct a as [a1 a2]; generalize H H0; rewrite app_cons; intros; split. -simpl in H3 |-; caseEq (b ++ ((r0, r1) :: nil)); intro. -destruct b; inversion H4. -intros l H4. -rewrite H4 in H3. -destruct m. -rewrite H4 in H2; simpl in H2 |-. -elim H3; [intros H5 H6; (try clear H3); (try exact H5)]. -rewrite H5. -elim H2; intros [H3 [H7 H8]] [H9 [H10 H11]]; (try assumption). -apply Hrecb. -apply (simpleDest_pop (a1, a2)); apply simpleDest_swap; auto. -apply (path_pop (a1, a2)); auto. -Qed. - -Lemma noOverlap_swap: - forall (m1 m2 : Move) (l : Moves), - noOverlap (m1 :: (m2 :: l)) -> noOverlap (m2 :: (m1 :: l)). -Proof. -intros m1 m2 l; simpl; destruct m1 as [m1s m1d]; destruct m2 as [m2s m2d]. -unfold noOverlap; simpl; intros. -assert (m1s = l0 \/ (m2s = l0 \/ In l0 (getsrc l))). -elim H0; [intros H1 | intros [H1|H2]]. -right; left; (try assumption). -left; (try assumption). -right; right; (try assumption). -(repeat split); - (elim (H l0); [intros H2 H3; elim H3; [intros H4 H5] | idtac]; auto). -Qed. - -Lemma getsrc_add1: - forall (r1 r2 : Reg) (l1 l2 : Moves), - getsrc (l1 ++ ((r1, r2) :: l2)) = getsrc l1 ++ (r1 :: getsrc l2). -Proof. -intros r1 r2 l1 l2; induction l1; simpl; auto. -destruct a; simpl; rewrite IHl1; auto. -Qed. - -Lemma getsrc_app: - forall (l1 l2 : Moves), getsrc (l1 ++ l2) = getsrc l1 ++ getsrc l2. -Proof. -intros; induction l1; simpl; auto. -destruct a; simpl; rewrite IHl1; auto. -Qed. - -Lemma Ingetsrc_swap: - forall (m : Move) (l1 l2 : Moves) (l : Reg), - In l (getsrc (m :: (l1 ++ l2))) -> In l (getsrc (l1 ++ (m :: l2))). -Proof. -intros; destruct m as [m1 m2]; simpl; auto. -simpl in H |-. -elim H; intros H0; auto. -rewrite H0; rewrite getsrc_add1; auto. -apply (in_or_app (getsrc l1) (l :: getsrc l2)); auto. -right; apply in_eq; auto. -apply getsrc_add; auto. -Qed. - -Lemma noOverlap_movFront: - forall (p1 p2 : Moves) (m : Move), - noOverlap (p1 ++ (m :: p2)) -> noOverlap (m :: (p1 ++ p2)). -Proof. -intros p1 p2 m; unfold noOverlap. -destruct m; rewrite getdst_add; simpl getdst; rewrite getdst_app; intros. -apply noOverlapaux_swap2. -apply (H l); apply Ingetsrc_swap; auto. -Qed. - -Lemma step_inv_loop_aux: - forall (t l : Moves) (s d : Reg), - simpleDest (t ++ ((s, d) :: nil)) -> - noTmp t -> - forall (e : Env) (r : Reg), - notemporary r -> - d = r \/ Loc.diff d r -> - get (pexec (t ++ ((s, d) :: nil)) (sexec l e)) r = - get (pexec (t ++ ((T s, d) :: nil)) (sexec ((s, T s) :: l) e)) r. -Proof. -intros; (repeat rewrite pexec_movFront); auto. -(repeat rewrite app_nil); simpl; elim H2; intros e1. -subst d; (repeat rewrite get_update_id); auto. -(repeat rewrite get_update_diff); auto. -rewrite pexec_update; auto. -apply Loc.diff_sym; unfold notemporary in H1 |-; auto. -apply noTmp_noReadTmp; auto. -apply (simpleDest_tmpLast t s); auto. -Qed. - -Lemma step_inv_loop: - forall (t l : Moves) (s d : Reg), - simpleDest (t ++ ((s, d) :: nil)) -> - noTmpLast (t ++ ((s, d) :: nil)) -> - forall (e : Env) (r : Reg), - notemporary r -> - d = r \/ Loc.diff d r -> - get (pexec (t ++ ((s, d) :: nil)) (sexec l e)) r = - get (pexec (t ++ ((T s, d) :: nil)) (sexec ((s, T s) :: l) e)) r. -Proof. -intros; apply step_inv_loop_aux; auto. -apply (noTmpLast_popBack t (s, d)); auto. -Qed. - -Definition sameExec (s1 s2 : State) := - forall (e : Env) (r : Reg), - (let A := - getdst - ((StateToMove s1 ++ StateBeing s1) ++ (StateToMove s2 ++ StateBeing s2)) - in - notemporary r -> - (forall x, In x A -> r = x \/ Loc.diff r x) -> - get (exec s1 e) r = get (exec s2 e) r). - -Lemma get_noWrite: - forall (t : Moves) (d : Reg), - noWrite t d -> forall (e : Env), get e d = get (pexec t e) d. -Proof. -intros; induction t as [|a t Hrect]; simpl; auto. -generalize H; destruct a as [a1 a2]; simpl; intros [NEQ R]. -unfold get, Locmap.get, update, Locmap.set. -case (Loc.eq a2 d); intro; auto. -absurd (a2 = d); auto; apply Loc.diff_not_eq; (try assumption). -caseEq (Loc.overlap a2 d); intro. -absurd (Loc.diff a2 d); auto; apply Loc.overlap_not_diff; auto. -unfold get, Locmap.get in Hrect |-; apply Hrect; auto. -Qed. - -Lemma step_sameExec: - forall (r1 r2 : State), step r1 r2 -> stepInv r1 -> sameExec r1 r2. -Proof. -intros r1 r2 STEP; inversion STEP; - unfold stepInv, sameExec, NoOverlap, exec, StateToMove, StateBeing, StateDone; - (repeat rewrite app_nil); intros [P [SD [NO [TT TB]]]]; intros. -rewrite pexec_movFront; simpl; auto. -case (Loc.eq r r0); intros e0. -subst r0; rewrite get_update_id; apply get_noWrite; apply sD_nW with r; - apply simpleDest_movFront; auto. -elim H2 with ( x := r ); - [intros H3; absurd (r = r0); auto | - intros H3; rewrite get_update_diff; auto; apply Loc.diff_sym; auto | idtac]. -(repeat (rewrite getdst_app; simpl)); apply in_or_app; left; apply in_or_app; - right; simpl; auto. -(repeat rewrite pexec_movFront); auto. -rewrite app_nil; auto. -apply simpleDest_movBack; auto. -apply pexec_mov; auto. -repeat (rewrite <- app_cons; rewrite app_app). -apply step_inv_loop; auto. -repeat (rewrite <- app_app; rewrite app_cons; auto). -repeat (rewrite <- app_app; rewrite app_cons; auto). -apply noTmp_app; auto. -elim H2 with ( x := d ); - [intros H3; left; auto | intros H3; right; apply Loc.diff_sym; auto - | try clear H2]. -repeat (rewrite getdst_app; simpl). -apply in_or_app; left; apply in_or_app; right; simpl; right; apply in_or_app; - right; simpl; left; trivial. -rewrite pexec_movFront; auto; apply pexec_push; auto. -apply noRead_app; auto. -apply noRead_app. -apply (noRead_by_path b b s0 d0 sn dn); auto. -apply (simpleDest_right t); auto. -apply (path_pop (sn, dn)); auto. -simpl; split; [apply Loc.diff_sym | idtac]; auto. -apply simpleDest_movFront; auto. -elim H4 with ( x := dn ); [intros H5 | intros H5 | try clear H4]. -left; (try assumption). -right; apply Loc.diff_sym; (try assumption). -repeat (rewrite getdst_app; simpl). -apply in_or_app; left; apply in_or_app; right; simpl; left; trivial. -rewrite pexec_movFront; auto. -rewrite app_nil; auto. -apply pexec_push; auto. -rewrite <- (app_nil _ t). -apply simpleDest_movFront; auto. -elim (H3 d); (try intros H4). -left; (try assumption). -right; apply Loc.diff_sym; (try assumption). -(repeat rewrite getdst_app); simpl; apply in_or_app; left; apply in_or_app; - right; simpl; left; trivial. -Qed. - -Lemma path_tmpLast: - forall (s d : Reg) (l : Moves), - path (l ++ ((s, d) :: nil)) -> path (l ++ ((T s, d) :: nil)). -Proof. -intros; induction l as [|a l Hrecl]. -simpl; auto. -generalize H; (repeat rewrite app_cons). -case a; generalize Hrecl; case l; intros; auto. -destruct m; intros. -inversion H0; split; auto. -Qed. - -Lemma step_inv_path: - forall (r1 r2 : State), step r1 r2 -> stepInv r1 -> path (StateBeing r2). -Proof. -intros r1 r2 STEP; inversion_clear STEP; unfold stepInv; - unfold stepInv, sameExec, sameEnv, exec, StateToMove, StateBeing, StateDone; - intros [P [SD [TT TB]]]; (try (simpl; auto; fail)). -simpl; case m; auto. -generalize P; rewrite <- app_cons; rewrite <- app_cons. -apply (path_tmpLast r0). -generalize P; apply path_pop. -Qed. - -Lemma step_inv_simpleDest: - forall (r1 r2 : State), - step r1 r2 -> stepInv r1 -> simpleDest (StateToMove r2 ++ StateBeing r2). -Proof. -intros r1 r2 STEP; inversion_clear STEP; unfold stepInv; - unfold stepInv, sameExec, sameEnv, exec, StateToMove, StateBeing, StateDone; - (repeat rewrite app_nil); intros [P [SD [TT TB]]]. -apply (simpleDest_Pop (r, r)); assumption. -apply simpleDest_movBack; assumption. -apply simpleDest_insert; rewrite <- app_app; apply simpleDest_movFront. -rewrite <- app_cons; rewrite app_app; auto. -generalize SD; (repeat rewrite <- app_cons); (repeat rewrite app_app). -generalize (simpleDest_tmpLast (t ++ ((s, r0ounon) :: b)) r0 d); auto. -generalize SD; apply simpleDest_Pop. -rewrite <- (app_nil _ t); generalize SD; apply simpleDest_Pop. -Qed. - -Lemma noTmp_pop: - forall (m : Move) (l1 l2 : Moves), noTmp (l1 ++ (m :: l2)) -> noTmp (l1 ++ l2). -Proof. -intros; induction l1 as [|a l1 Hrecl1]; generalize H. -simpl; case m; intros; inversion H0; inversion H2; auto. -rewrite app_cons; rewrite app_cons; simpl; case a. -intros; inversion H0; inversion H2; auto. -Qed. - -Lemma step_inv_noTmp: - forall (r1 r2 : State), step r1 r2 -> stepInv r1 -> noTmp (StateToMove r2). -Proof. -intros r1 r2 STEP; inversion_clear STEP; unfold stepInv; - unfold stepInv, sameExec, sameEnv, exec, StateToMove, StateBeing, StateDone; - intros [P [SD [NO [TT TB]]]]; generalize TT; (try apply noTmp_pop); auto. -Qed. - -Lemma noTmp_noTmpLast: forall (l : Moves), noTmp l -> noTmpLast l. -Proof. -intros; induction l as [|a l Hrecl]; (try (simpl; auto; fail)). -generalize H; simpl; case a; generalize Hrecl; case l; - (intros; inversion H0; inversion H2; auto). -Qed. - -Lemma noTmpLast_pop: - forall (m : Move) (l : Moves), noTmpLast (m :: l) -> noTmpLast l. -Proof. -intros m l; simpl; case m; case l. -simpl; auto. -intros; inversion H; inversion H1; auto. -Qed. - -Lemma noTmpLast_Pop: - forall (m : Move) (l1 l2 : Moves), - noTmpLast (l1 ++ (m :: l2)) -> noTmpLast (l1 ++ l2). -Proof. -intros; induction l1 as [|a l1 Hrecl1]; generalize H. -simpl; case m; case l2. -simpl; auto. -intros. -elim H0; [intros H1 H2; elim H2; [intros H3 H4; (try exact H4)]]. -(repeat rewrite app_cons); simpl; case a. -generalize Hrecl1; case l1. -simpl; case m; case l2; intros; inversion H0; inversion H2; auto. -intros m0 l R r r0; rewrite app_cons; rewrite app_cons. -intros; inversion H0; inversion H2; auto. -Qed. - -Lemma noTmpLast_push: - forall (m : Move) (t1 t2 t3 : Moves), - noTmp (t1 ++ (m :: t2)) -> noTmpLast t3 -> noTmpLast (m :: t3). -Proof. -intros; induction t1 as [|a t1 Hrect1]; generalize H. -simpl; case m; intros r r0 [N1 [N2 NT]]; generalize H0; case t3; auto. -rewrite app_cons; intros; apply Hrect1. -generalize H1. -simpl; case m; case a; intros; inversion H2; inversion H4; auto. -Qed. - -Lemma noTmpLast_tmpLast: - forall (s d : Reg) (l : Moves), - noTmpLast (l ++ ((s, d) :: nil)) -> noTmpLast (l ++ ((T s, d) :: nil)). +Definition exec_seq (m: moves) (e: Locmap.t) : Locmap.t := + Parmov.exec_seq loc val Loc.eq m e. + +Lemma temp_for_charact: + forall l, temp_for l = R IT2 \/ temp_for l = R FT2. Proof. -intros; induction l as [|a l Hrecl]. -simpl; auto. -generalize H; rewrite app_cons; rewrite app_cons; simpl. -case a; generalize Hrecl; case l. -simpl; auto. -intros m l0 REC r r0; generalize REC; rewrite app_cons; rewrite app_cons. -case m; intros; inversion H0; inversion H2; split; auto. + intro; unfold temp_for. destruct (Loc.type l); tauto. Qed. - -Lemma step_inv_noTmpLast: - forall (r1 r2 : State), step r1 r2 -> stepInv r1 -> noTmpLast (StateBeing r2). -Proof. -intros r1 r2 STEP; inversion_clear STEP; unfold stepInv; - unfold stepInv, sameExec, sameEnv, exec, StateToMove, StateBeing, StateDone; - intros [P [SD [NO [TT TB]]]]; auto. -apply (noTmpLast_push m t1 t2); auto. -apply (noTmpLast_push (d, r) t1 t2); auto. -generalize TB; rewrite <- app_cons; rewrite <- app_cons; apply noTmpLast_tmpLast. -apply (noTmpLast_pop (sn, dn)); auto. -Qed. - -Lemma noOverlapaux_insert: - forall (l1 l2 : list Reg) (r x : Reg), - noOverlap_aux x (r :: (l1 ++ l2)) -> noOverlap_aux x (l1 ++ (r :: l2)). -Proof. -simpl; intros; induction l1; simpl; split. -elim H; [intros H0 H1; (try exact H0)]. -elim H; [intros H0 H1; (try exact H1)]. -simpl in H |-. -elim H; - [intros H0 H1; elim H1; [intros H2 H3; (try clear H1 H); (try exact H2)]]. -apply IHl1. -split. -elim H; [intros H0 H1; (try exact H0)]. -rewrite app_cons in H. -apply noOverlap_auxpop with ( r := a ). -elim H; [intros H0 H1; (try exact H1)]. -Qed. - -Lemma Ingetsrc_swap2: - forall (m : Move) (l1 l2 : Moves) (l : Reg), - In l (getsrc (l1 ++ (m :: l2))) -> In l (getsrc (m :: (l1 ++ l2))). -Proof. -intros; destruct m as [m1 m2]; simpl; auto. -induction l1; simpl. -simpl in H |-; auto. -destruct a; simpl. -simpl in H |-. -elim H; [intros H0 | intros H0; (try exact H0)]. -right; left; (try assumption). -elim IHl1; intros; auto. -Qed. - -Lemma noOverlap_insert: - forall (p1 p2 : Moves) (m : Move), - noOverlap (m :: (p1 ++ p2)) -> noOverlap (p1 ++ (m :: p2)). -Proof. -unfold noOverlap; destruct m; rewrite getdst_add; simpl getdst; - rewrite getdst_app. -intros. -apply noOverlapaux_insert. -generalize (H l); intros H1; lapply H1; - [intros H2; (try clear H1); (try exact H2) | idtac]. -simpl getsrc. -generalize (Ingetsrc_swap2 (r, r0)); simpl; (intros; auto). -Qed. - -Lemma noOverlap_movBack: - forall (p1 p2 : Moves) (m : Move), - noOverlap (p1 ++ (m :: p2)) -> noOverlap ((p1 ++ p2) ++ (m :: nil)). -Proof. -intros. -apply (noOverlap_insert (p1 ++ p2) nil m). -rewrite app_nil; apply noOverlap_movFront; auto. -Qed. - -Lemma noOverlap_movBack0: - forall (t : Moves) (s d : Reg), - noOverlap ((s, d) :: t) -> noOverlap (t ++ ((s, d) :: nil)). -Proof. -intros t s d H; (try assumption). -apply noOverlap_insert. -rewrite app_nil; auto. -Qed. - -Lemma noOverlap_Front0: - forall (t : Moves) (s d : Reg), - noOverlap (t ++ ((s, d) :: nil)) -> noOverlap ((s, d) :: t). -Proof. -intros t s d H; (try assumption). -cut ((s, d) :: t = (s, d) :: (t ++ nil)). -intros e; rewrite e. -apply noOverlap_movFront; auto. -rewrite app_nil; auto. -Qed. - -Lemma noTmpL_diff: - forall (t : Moves) (s d : Reg), - noTmpLast (t ++ ((s, d) :: nil)) -> notemporary d. -Proof. -intros t s d; unfold notemporary; induction t; (try (simpl; intros; auto; fail)). -rewrite app_cons. -intros; apply IHt. -apply (noTmpLast_pop a); auto. -Qed. - -Lemma noOverlap_aux_app: - forall l1 l2 (r : Reg), - noOverlap_aux r l1 -> noOverlap_aux r l2 -> noOverlap_aux r (l1 ++ l2). -Proof. -induction l1; simpl; auto. -intros; split. -elim H; [intros H1 H2; (try clear H); (try exact H1)]. -apply IHl1; auto. -elim H; [intros H1 H2; (try clear H); (try exact H2)]. -Qed. - -Lemma noTmP_noOverlap_aux: - forall t (r : Reg), noTmp t -> noOverlap_aux (T r) (getdst t). -Proof. -induction t; simpl; auto. -destruct a; simpl; (intros; split). -elim H; intros; elim H1; intros. -right; apply H2. -apply IHt; auto. -elim H; - [intros H0 H1; elim H1; [intros H2 H3; (try clear H1 H); (try exact H3)]]. -Qed. - -Lemma noTmp_append: forall l1 l2, noTmp l1 -> noTmp l2 -> noTmp (l1 ++ l2). -Proof. -induction l1; simpl; auto. -destruct a. -intros l2 [H1 [H2 H3]] H4. -(repeat split); auto. -Qed. - -Lemma step_inv_noOverlap: - forall (r1 r2 : State), - step r1 r2 -> stepInv r1 -> noOverlap (StateToMove r2 ++ StateBeing r2). -Proof. -intros r1 r2 STEP; inversion_clear STEP; unfold stepInv; - unfold stepInv, sameExec, sameEnv, exec, StateToMove, StateBeing, StateDone; - (repeat rewrite app_nil); intros [P [SD [NO [TT TB]]]]; - (try (generalize NO; apply noOverlap_Pop; auto; fail)). -apply noOverlap_movBack; auto. -apply noOverlap_insert; rewrite <- app_app; apply noOverlap_movFront; - rewrite <- app_cons; rewrite app_app; auto. -generalize NO; (repeat rewrite <- app_cons); (repeat rewrite app_app); - (clear NO; intros NO); apply noOverlap_movBack0. -assert (noOverlap ((r0, d) :: (t ++ ((s, r0ounon) :: b)))); - [apply noOverlap_Front0; auto | idtac]. -generalize H; unfold noOverlap; simpl; clear H; intros. -elim H0; intros; [idtac | apply (H l0); (right; (try assumption))]. -split; [right; (try assumption) | idtac]. -generalize TB; simpl; caseEq (b ++ ((r0, d) :: nil)); intro. -elim (app_eq_nil b ((r0, d) :: nil)); intros; auto; inversion H4. -subst l0; intros; rewrite <- H1 in TB0. -elim TB0; [intros H2 H3; elim H3; [intros H4 H5; (try clear H3 TB0)]]. -generalize (noTmpL_diff b r0 d); unfold notemporary; intro; apply H3; auto. -rewrite <- H1; apply noTmP_noOverlap_aux; apply noTmp_append; auto; - rewrite <- app_cons in TB; apply noTmpLast_popBack with (r0, d); auto. -rewrite <- (app_nil _ t); apply (noOverlap_Pop (s, d)); assumption. -Qed. - -Lemma step_inv: forall (r1 r2 : State), step r1 r2 -> stepInv r1 -> stepInv r2. -Proof. -intros; unfold stepInv; (repeat split). -apply (step_inv_path r1 r2); auto. -apply (step_inv_simpleDest r1 r2); auto. -apply (step_inv_noOverlap r1 r2); auto. -apply (step_inv_noTmp r1 r2); auto. -apply (step_inv_noTmpLast r1 r2); auto. -Qed. - -Definition step_NF (r : State) : Prop := ~ (exists s : State , step r s ). - -Inductive stepp : State -> State -> Prop := - stepp_refl: forall (r : State), stepp r r - | stepp_trans: - forall (r1 r2 r3 : State), step r1 r2 -> stepp r2 r3 -> stepp r1 r3 . -Hint Resolve stepp_refl stepp_trans . - -Lemma stepp_transitive: - forall (r1 r2 r3 : State), stepp r1 r2 -> stepp r2 r3 -> stepp r1 r3. -Proof. -intros; induction H as [r|r1 r2 r0 H H1 HrecH]; eauto. -Qed. - -Lemma step_stepp: forall (s1 s2 : State), step s1 s2 -> stepp s1 s2. -Proof. -eauto. -Qed. - -Lemma stepp_inv: - forall (r1 r2 : State), stepp r1 r2 -> stepInv r1 -> stepInv r2. -Proof. -intros; induction H as [r|r1 r2 r3 H H1 HrecH]; auto. -apply HrecH; auto. -apply (step_inv r1 r2); auto. -Qed. - -Lemma noTmpLast_lastnoTmp: - forall l s d, noTmpLast (l ++ ((s, d) :: nil)) -> notemporary d. -Proof. -induction l. -simpl. -intros; unfold notemporary; auto. -destruct a as [a1 a2]; intros. -change (noTmpLast ((a1, a2) :: (l ++ ((s, d) :: nil)))) in H |-. -apply IHl with s. -apply noTmpLast_pop with (a1, a2); auto. + +Lemma is_not_temp_charact: + forall l, + Parmov.is_not_temp loc temp_for l <-> l <> R IT2 /\ l <> R FT2. +Proof. + intros. unfold Parmov.is_not_temp. + destruct (Loc.eq l (R IT2)). + subst l. intuition. apply (H (R IT2)). reflexivity. discriminate. + destruct (Loc.eq l (R FT2)). + subst l. intuition. apply (H (R FT2)). reflexivity. + assert (forall d, l <> temp_for d). + intro. elim (temp_for_charact d); congruence. + intuition. Qed. - -Lemma step_inv_NoOverlap: - forall (s1 s2 : State) r, - step s1 s2 -> notemporary r -> stepInv s1 -> NoOverlap r s1 -> NoOverlap r s2. + +Lemma disjoint_temp_not_temp: + forall l, Loc.notin l temporaries -> Parmov.is_not_temp loc temp_for l. Proof. -intros s1 s2 r STEP notempr; inversion_clear STEP; unfold stepInv; - unfold stepInv, sameExec, sameEnv, exec, StateToMove, StateBeing, StateDone; - intros [P [SD [NO [TT TB]]]]; unfold NoOverlap; simpl. -simpl; (repeat rewrite app_nil); simpl; (repeat rewrite <- app_cons); intro; - apply noOverlap_Pop with ( m := (r0, r0) ); auto. -(repeat rewrite app_nil); simpl; rewrite app_ass; (repeat rewrite <- app_cons); - intro; rewrite ass_app; apply noOverlap_movBack; auto. -simpl; (repeat (rewrite app_ass; simpl)); (repeat rewrite <- app_cons); intro. -rewrite ass_app; apply noOverlap_insert; rewrite app_ass; - apply noOverlap_movFront; auto. -simpl; (repeat rewrite <- app_cons); intro; rewrite ass_app; - apply noOverlap_movBack0; auto. -generalize H; (repeat (rewrite app_ass; simpl)); intro. -assert (noOverlap ((r0, d) :: (((r, r) :: t) ++ ((s, r0ounon) :: b)))); - [apply noOverlap_Front0 | idtac]; auto. -generalize H0; (repeat (rewrite app_ass; simpl)); auto. -generalize H1; unfold noOverlap; simpl; intros. -elim H3; intros H4; clear H3. -split. -right; assert (notemporary d). -change (noTmpLast (((s, r0ounon) :: b) ++ ((r0, d) :: nil))) in TB |-; - apply (noTmpLast_lastnoTmp ((s, r0ounon) :: b) r0); auto. -rewrite <- H4; unfold notemporary in H3 |-; apply H3. -split. -right; rewrite <- H4; unfold notemporary in notempr |-; apply notempr. -rewrite <- H4; apply noTmP_noOverlap_aux; auto. -apply noTmp_append; auto. -change (noTmpLast (((s, r0ounon) :: b) ++ ((r0, d) :: nil))) in TB |-; - apply noTmpLast_popBack with ( m := (r0, d) ); auto. -apply (H2 l0). -elim H4; intros H3; right; [left | right]; assumption. -intro; - change (noOverlap (((r, r) :: t) ++ ((sn, dn) :: (b ++ ((s0, d0) :: nil))))) in - H1 |-. -change (noOverlap (((r, r) :: t) ++ (b ++ ((s0, d0) :: nil)))); - apply (noOverlap_Pop (sn, dn)); auto. -(repeat rewrite <- app_cons); apply noOverlap_Pop. + intros. rewrite is_not_temp_charact. + unfold temporaries in H; simpl in H. + split; apply Loc.diff_not_eq; tauto. Qed. - -Lemma step_inv_getdst: - forall (s1 s2 : State) r, - step s1 s2 -> - In r (getdst (StateToMove s2 ++ StateBeing s2)) -> - In r (getdst (StateToMove s1 ++ StateBeing s1)). + +Lemma loc_norepet_norepet: + forall l, Loc.norepet l -> list_norepet l. Proof. -intros s1 s2 r STEP; inversion_clear STEP; - unfold StateToMove, StateBeing, StateDone. -(repeat rewrite getdst_app); simpl; (repeat rewrite app_nil); intro; - apply in_or_app. -elim (in_app_or (getdst t1) (getdst t2) r); auto. -intro; right; simpl; right; assumption. -(repeat rewrite getdst_app); destruct m as [m1 m2]; simpl; - (repeat rewrite app_nil); intro; apply in_or_app. -elim (in_app_or (getdst t1 ++ getdst t2) (m2 :: nil) r); auto; intro. -elim (in_app_or (getdst t1) (getdst t2) r); auto; intro. -right; simpl; right; assumption. -elim H0; intros H1; [right; simpl; left; (try assumption) | inversion H1]. -(repeat rewrite getdst_app); simpl; (repeat rewrite app_nil); intro; - apply in_or_app. -elim (in_app_or (getdst t1 ++ getdst t2) (r0 :: (d :: getdst b)) r); auto; - intro. -elim (in_app_or (getdst t1) (getdst t2) r); auto; intro. -left; apply in_or_app; left; assumption. -left; apply in_or_app; right; simpl; right; assumption. -elim H0; intro. -left; apply in_or_app; right; simpl; left; trivial. -elim H1; intro. -right; (simpl; left; trivial). -right; simpl; right; assumption. -(repeat (rewrite getdst_app; simpl)); trivial. -(repeat (rewrite getdst_app; simpl)); intro. -elim (in_app_or (getdst t) (getdst b ++ (d0 :: nil)) r); auto; intro; - apply in_or_app; auto. -elim (in_app_or (getdst b) (d0 :: nil) r); auto; intro. -right; simpl; right; apply in_or_app; auto. -elim H3; intro. -right; simpl; right; apply in_or_app; right; simpl; auto. -inversion H4. -rewrite app_nil; (repeat (rewrite getdst_app; simpl)); intro. -apply in_or_app; left; assumption. + induction 1; constructor. + apply Loc.notin_not_in; auto. auto. Qed. - -Lemma stepp_sameExec: - forall (r1 r2 : State), stepp r1 r2 -> stepInv r1 -> sameExec r1 r2. -Proof. -intros; induction H as [r|r1 r2 r3 H H1 HrecH]. -unfold sameExec; intros; auto. -cut (sameExec r1 r2); [idtac | apply (step_sameExec r1); auto]. -unfold sameExec; unfold sameExec in HrecH |-; intros. -rewrite H2; auto. -rewrite HrecH; auto. -apply (step_inv r1); auto. -intros x H5; apply H4. -generalize H5; (repeat rewrite getdst_app); intros; apply in_or_app. -elim - (in_app_or - (getdst (StateToMove r2) ++ getdst (StateBeing r2)) - (getdst (StateToMove r3) ++ getdst (StateBeing r3)) x); auto; intro. -generalize (step_inv_getdst r1 r2 x); (repeat rewrite getdst_app); intro. -left; apply H8; auto. -intros x H5; apply H4. -generalize H5; (repeat rewrite getdst_app); intros; apply in_or_app. -elim - (in_app_or - (getdst (StateToMove r1) ++ getdst (StateBeing r1)) - (getdst (StateToMove r2) ++ getdst (StateBeing r2)) x); auto; intro. -generalize (step_inv_getdst r1 r2 x); (repeat rewrite getdst_app); intro. -left; apply H8; auto. + +Lemma parmove_prop_1: + forall srcs dsts, + List.length srcs = List.length dsts -> + Loc.norepet dsts -> + Loc.disjoint srcs temporaries -> + Loc.disjoint dsts temporaries -> + forall e, + let e' := exec_seq (parmove srcs dsts) e in + List.map e' dsts = List.map e srcs /\ + forall l, ~In l dsts -> l <> R IT2 -> l <> R FT2 -> e' l = e l. +Proof. + intros. + assert (NR: list_norepet dsts) by (apply loc_norepet_norepet; auto). + assert (NTS: forall r, In r srcs -> Parmov.is_not_temp loc temp_for r). + intros. apply disjoint_temp_not_temp. apply Loc.disjoint_notin with srcs; auto. + assert (NTD: forall r, In r dsts -> Parmov.is_not_temp loc temp_for r). + intros. apply disjoint_temp_not_temp. apply Loc.disjoint_notin with dsts; auto. + generalize (Parmov.parmove2_correctness loc temp_for val Loc.eq srcs dsts H NR NTS NTD e). + change (Parmov.exec_seq loc val Loc.eq (Parmov.parmove2 loc temp_for Loc.eq srcs dsts) e) with e'. + intros [A B]. + split. auto. intros. apply B. auto. rewrite is_not_temp_charact; auto. Qed. - -Inductive dstep : State -> State -> Prop := - dstep_nop: - forall (r : Reg) (t l : Moves), dstep ((r, r) :: t, nil, l) (t, nil, l) - | dstep_start: - forall (t l : Moves) (s d : Reg), - s <> d -> dstep ((s, d) :: t, nil, l) (t, (s, d) :: nil, l) - | dstep_push: - forall (t1 t2 b l : Moves) (s d r : Reg), - noRead t1 d -> - dstep - (t1 ++ ((d, r) :: t2), (s, d) :: b, l) - (t1 ++ t2, (d, r) :: ((s, d) :: b), l) - | dstep_pop_loop: - forall (t b l : Moves) (s d r0 : Reg), - noRead t r0 -> - dstep - (t, (s, r0) :: (b ++ ((r0, d) :: nil)), l) - (t, b ++ ((T r0, d) :: nil), (s, r0) :: ((r0, T r0) :: l)) - | dstep_pop: - forall (t b l : Moves) (s0 d0 sn dn : Reg), - noRead t dn -> - Loc.diff dn s0 -> - dstep - (t, (sn, dn) :: (b ++ ((s0, d0) :: nil)), l) - (t, b ++ ((s0, d0) :: nil), (sn, dn) :: l) - | dstep_last: - forall (t l : Moves) (s d : Reg), - noRead t d -> dstep (t, (s, d) :: nil, l) (t, nil, (s, d) :: l) . -Hint Resolve dstep_nop dstep_start dstep_push . -Hint Resolve dstep_pop_loop dstep_pop dstep_last . - -Lemma dstep_step: - forall (r1 r2 : State), dstep r1 r2 -> stepInv r1 -> stepp r1 r2. -Proof. -intros r1 r2 DS; inversion_clear DS; intros SI; eauto. -change (stepp (nil ++ ((r, r) :: t), nil, l) (t, nil, l)); apply step_stepp; - apply (step_nop r nil t). -change (stepp (nil ++ ((s, d) :: t), nil, l) (t, (s, d) :: nil, l)); - apply step_stepp; apply (step_start nil t l). -apply - (stepp_trans - (t, (s, r0) :: (b ++ ((r0, d) :: nil)), l) - (t, (s, r0) :: (b ++ ((T r0, d) :: nil)), (r0, T r0) :: l) - (t, b ++ ((T r0, d) :: nil), (s, r0) :: ((r0, T r0) :: l))); auto. -apply step_stepp; apply step_pop; auto. -unfold stepInv in SI |-; generalize SI; intros [X [Y [Z [U V]]]]. -generalize V; unfold StateBeing, noTmpLast. -case (b ++ ((r0, d) :: nil)); auto. -intros m l0 [R1 [OK PP]]; auto. + +Lemma parmove_prop_2: + forall srcs dsts s d, + In (s, d) (parmove srcs dsts) -> + (In s srcs \/ s = R IT2 \/ s = R FT2) + /\ (In d dsts \/ d = R IT2 \/ d = R FT2). +Proof. + intros srcs dsts. + set (mu := List.combine srcs dsts). + assert (forall s d, Parmov.wf_move loc temp_for mu s d -> + (In s srcs \/ s = R IT2 \/ s = R FT2) + /\ (In d dsts \/ d = R IT2 \/ d = R FT2)). + unfold mu; induction 1. + split. + left. eapply List.in_combine_l; eauto. + left. eapply List.in_combine_r; eauto. + split. + right. apply temp_for_charact. + tauto. + split. + tauto. + right. apply temp_for_charact. + intros. apply H. + apply (Parmov.parmove2_wf_moves loc temp_for Loc.eq srcs dsts s d H0). Qed. - -Lemma dstep_inv: - forall (r1 r2 : State), dstep r1 r2 -> stepInv r1 -> stepInv r2. + +Lemma loc_type_temp_for: + forall l, Loc.type (temp_for l) = Loc.type l. Proof. -intros. -apply (stepp_inv r1 r2); auto. -apply dstep_step; auto. + intros; unfold temp_for. destruct (Loc.type l); reflexivity. Qed. - -Inductive dstepp : State -> State -> Prop := - dstepp_refl: forall (r : State), dstepp r r - | dstepp_trans: - forall (r1 r2 r3 : State), dstep r1 r2 -> dstepp r2 r3 -> dstepp r1 r3 . -Hint Resolve dstepp_refl dstepp_trans . - -Lemma dstepp_stepp: - forall (s1 s2 : State), stepInv s1 -> dstepp s1 s2 -> stepp s1 s2. -Proof. -intros; induction H0 as [r|r1 r2 r3 H0 H1 HrecH0]; auto. -apply (stepp_transitive r1 r2 r3); auto. -apply dstep_step; auto. -apply HrecH0; auto. -apply (dstep_inv r1 r2); auto. + +Lemma loc_type_combine: + forall srcs dsts, + List.map Loc.type srcs = List.map Loc.type dsts -> + forall s d, + In (s, d) (List.combine srcs dsts) -> + Loc.type s = Loc.type d. +Proof. + induction srcs; destruct dsts; simpl; intros; try discriminate. + elim H0. + elim H0; intros. inversion H1; subst. congruence. + apply IHsrcs with dsts. congruence. auto. Qed. - -Lemma dstepp_sameExec: - forall (r1 r2 : State), dstepp r1 r2 -> stepInv r1 -> sameExec r1 r2. -Proof. -intros; apply stepp_sameExec; auto. -apply dstepp_stepp; auto. + +Lemma parmove_prop_3: + forall srcs dsts, + List.map Loc.type srcs = List.map Loc.type dsts -> + forall s d, + In (s, d) (parmove srcs dsts) -> Loc.type s = Loc.type d. +Proof. + intros srcs dsts TYP. + set (mu := List.combine srcs dsts). + assert (forall s d, Parmov.wf_move loc temp_for mu s d -> + Loc.type s = Loc.type d). + unfold mu; induction 1. + eapply loc_type_combine; eauto. + rewrite loc_type_temp_for; auto. + rewrite loc_type_temp_for; auto. + intros. apply H. + apply (Parmov.parmove2_wf_moves loc temp_for Loc.eq srcs dsts s d H0). Qed. - -End pmov. -Fixpoint split_move' (m : Moves) (r : Reg) {struct m} : - option ((Moves * Reg) * Moves) := - match m with - (s, d) :: tail => - match diff_dec s r with - right _ => Some (nil, d, tail) - | left _ => - match split_move' tail r with - Some ((t1, r2, t2)) => Some ((s, d) :: t1, r2, t2) - | None => None - end - end - | nil => None - end. - -Fixpoint split_move (m : Moves) (r : Reg) {struct m} : - option ((Moves * Reg) * Moves) := - match m with - (s, d) :: tail => - match Loc.eq s r with - left _ => Some (nil, d, tail) - | right _ => - match split_move tail r with - Some ((t1, r2, t2)) => Some ((s, d) :: t1, r2, t2) - | None => None - end - end - | nil => None - end. +Section EQUIVALENCE. -Definition def : Move := (R IT1, R IT1). - -Fixpoint last (M : Moves) : Move := - match M with nil => def - | m :: nil => m - | m :: tail => last tail end. - -Fixpoint head_but_last (M : Moves) : Moves := - match M with - nil => nil - | m' :: nil => nil - | m' :: tail => m' :: head_but_last tail - end. - -Fixpoint replace_last_s (M : Moves) : Moves := - match M with - nil => nil - | m :: nil => - match m with (s, d) => (T s, d) :: nil end - | m :: tail => m :: replace_last_s tail - end. - -Ltac CaseEq name := generalize (refl_equal name); pattern name at -1; case name. - -Definition stepf' (S1 : State) : State := - match S1 with - (nil, nil, _) => S1 - | ((s, d) :: tl, nil, l) => - match diff_dec s d with - right _ => (tl, nil, l) - | left _ => (tl, (s, d) :: nil, l) - end - | (t, (s, d) :: b, l) => - match split_move t d with - Some ((t1, r, t2)) => - (t1 ++ t2, (d, r) :: ((s, d) :: b), l) - | None => - match b with - nil => (t, nil, (s, d) :: l) - | _ => - match diff_dec d (fst (last b)) with - right _ => - (t, replace_last_s b, (s, d) :: ((d, T d) :: l)) - | left _ => (t, b, (s, d) :: l) - end - end - end - end. - -Definition stepf (S1 : State) : State := - match S1 with - (nil, nil, _) => S1 - | ((s, d) :: tl, nil, l) => - match Loc.eq s d with - left _ => (tl, nil, l) - | right _ => (tl, (s, d) :: nil, l) - end - | (t, (s, d) :: b, l) => - match split_move t d with - Some ((t1, r, t2)) => - (t1 ++ t2, (d, r) :: ((s, d) :: b), l) - | None => - match b with - nil => (t, nil, (s, d) :: l) - | _ => - match Loc.eq d (fst (last b)) with - left _ => - (t, replace_last_s b, (s, d) :: ((d, T d) :: l)) - | right _ => (t, b, (s, d) :: l) - end - end - end - end. - -Lemma rebuild_l: - forall (l : Moves) (m : Move), - m :: l = head_but_last (m :: l) ++ (last (m :: l) :: nil). -Proof. -induction l; simpl; auto. -intros m; rewrite (IHl a); auto. -Qed. - -Lemma splitSome: - forall (l t1 t2 : Moves) (s d r : Reg), - noOverlap (l ++ ((r, s) :: nil)) -> - split_move l s = Some (t1, d, t2) -> noRead t1 s. -Proof. -induction l; simpl. -intros; discriminate. -destruct a as [a1 a2]. -intros t1 t2 s d r Hno; case (Loc.eq a1 s). -intros e H1; inversion H1. -simpl; auto. -CaseEq (split_move l s). -intros; (repeat destruct p). -inversion H0; auto. -simpl; split; auto. -change (noOverlap (((a1, a2) :: l) ++ ((r, s) :: nil))) in Hno |-. -assert (noOverlap ((r, s) :: ((a1, a2) :: l))). -apply noOverlap_Front0; auto. -unfold noOverlap in H1 |-; simpl in H1 |-. -elim H1 with ( l0 := a1 ); - [intros H5 H6; (try clear H1); (try exact H5) | idtac]. -elim H5; [intros H1; (try clear H5); (try exact H1) | intros H1; (try clear H5)]. -absurd (a1 = s); auto. -apply Loc.diff_sym; auto. -right; left; trivial. -apply (IHl m0 m s r0 r); auto. -apply (noOverlap_pop (a1, a2)); auto. -intros; discriminate. -Qed. - -Lemma unsplit_move: - forall (l t1 t2 : Moves) (s d r : Reg), - noOverlap (l ++ ((r, s) :: nil)) -> - split_move l s = Some (t1, d, t2) -> l = t1 ++ ((s, d) :: t2). -Proof. -induction l. -simpl; intros; discriminate. -intros t1 t2 s d r HnoO; destruct a as [a1 a2]; simpl; case (diff_dec a1 s); - intro. -case (Loc.eq a1 s); intro. -absurd (Loc.diff a1 s); auto. -rewrite e; apply Loc.same_not_diff. -CaseEq (split_move l s); intros; (try discriminate). -(repeat destruct p); inversion H0. -rewrite app_cons; subst t2; subst d; rewrite (IHl m0 m s r0 r); auto. -apply (noOverlap_pop (a1, a2)); auto. -case (Loc.eq a1 s); intros e H; inversion H; simpl. -rewrite e; auto. -cut (noOverlap_aux a1 (getdst ((r, s) :: nil))). -intros [[H5|H4] H0]; [try exact H5 | idtac]. -absurd (s = a1); auto. -absurd (Loc.diff a1 s); auto; apply Loc.diff_sym; auto. -generalize HnoO; rewrite app_cons; intro. -assert (noOverlap (l ++ ((a1, a2) :: ((r, s) :: nil)))); - (try (apply noOverlap_insert; assumption)). -assert (noOverlap ((a1, a2) :: ((r, s) :: nil))). -apply (noOverlap_right l); auto. -generalize H2; unfold noOverlap; simpl. -intros H5; elim (H5 a1); [idtac | left; trivial]. -intros H6 [[H7|H8] H9]. -absurd (s = a1); auto. -split; [right; (try assumption) | auto]. -Qed. - -Lemma cons_replace: - forall (a : Move) (l : Moves), - l <> nil -> replace_last_s (a :: l) = a :: replace_last_s l. -Proof. -intros; simpl. -CaseEq l. -intro; contradiction. -intros m l0 H0; auto. -Qed. - -Lemma last_replace: - forall (l : Moves) (s d : Reg), - replace_last_s (l ++ ((s, d) :: nil)) = l ++ ((T s, d) :: nil). -Proof. -induction l; (try (simpl; auto; fail)). -intros; (repeat rewrite <- app_comm_cons). -rewrite cons_replace. -rewrite IHl; auto. -red; intro. -elim (app_eq_nil l ((s, d) :: nil)); auto; intros; discriminate. -Qed. - -Lemma last_app: forall (l : Moves) (m : Move), last (l ++ (m :: nil)) = m. -Proof. -induction l; simpl; auto. -intros m; CaseEq (l ++ (m :: nil)). -intro; elim (app_eq_nil l (m :: nil)); auto; intros; discriminate. -intros m0 l0 H; (rewrite <- H; apply IHl). -Qed. - -Lemma last_cons: - forall (l : Moves) (m m0 : Move), last (m0 :: (m :: l)) = last (m :: l). -Proof. -intros; simpl; auto. -Qed. - -Lemma stepf_popLoop: - forall (t b l : Moves) (s d r0 : Reg), - split_move t d = None -> - stepf (t, (s, d) :: (b ++ ((d, r0) :: nil)), l) = - (t, b ++ ((T d, r0) :: nil), (s, d) :: ((d, T d) :: l)). -Proof. -intros; simpl; rewrite H; CaseEq (b ++ ((d, r0) :: nil)); intros. -destruct b; discriminate. -rewrite <- H0; rewrite last_app; simpl; rewrite last_replace. -case (Loc.eq d d); intro; intuition. -destruct t; (try destruct m0); simpl; auto. -Qed. - -Lemma stepf_pop: - forall (t b l : Moves) (s d r r0 : Reg), - split_move t d = None -> - d <> r -> - stepf (t, (s, d) :: (b ++ ((r, r0) :: nil)), l) = - (t, b ++ ((r, r0) :: nil), (s, d) :: l). -Proof. -intros; simpl; rewrite H; CaseEq (b ++ ((r, r0) :: nil)); intros. -destruct b; discriminate. -rewrite <- H1; rewrite last_app; simpl. -case (Loc.eq d r); intro. -absurd (d = r); auto. -destruct t; (try destruct m0); simpl; auto. -Qed. - -Lemma noOverlap_head: - forall l1 l2 m, noOverlap (l1 ++ (m :: l2)) -> noOverlap (l1 ++ (m :: nil)). -Proof. -induction l2; simpl; auto. -intros; apply IHl2. -cut (l1 ++ (m :: (a :: l2)) = (l1 ++ (m :: nil)) ++ (a :: l2)); - [idtac | rewrite app_ass; auto]. -intros e; rewrite e in H. -cut (l1 ++ (m :: l2) = (l1 ++ (m :: nil)) ++ l2); - [idtac | rewrite app_ass; auto]. -intros e'; rewrite e'; auto. -apply noOverlap_Pop with a; auto. -Qed. - -Lemma splitNone: - forall (l : Moves) (s d : Reg), - split_move l d = None -> noOverlap (l ++ ((s, d) :: nil)) -> noRead l d. -Proof. -induction l; intros s d; simpl; auto. -destruct a as [a1 a2]; case (Loc.eq a1 d); intro; (try (intro; discriminate)). -CaseEq (split_move l d); intros. -(repeat destruct p); discriminate. -split; (try assumption). -change (noOverlap (((a1, a2) :: l) ++ ((s, d) :: nil))) in H1 |-. -assert (noOverlap ((s, d) :: ((a1, a2) :: l))). -apply noOverlap_Front0; auto. -assert (noOverlap ((a1, a2) :: ((s, d) :: l))). -apply noOverlap_swap; auto. -unfold noOverlap in H3 |-; simpl in H3 |-. -elim H3 with ( l0 := a1 ); - [intros H5 H6; (try clear H1); (try exact H5) | idtac]. -elim H6; - [intros H1 H4; elim H1; - [intros H7; (try clear H1 H6); (try exact H7) | intros H7; (try clear H1 H6)]]. -absurd (a1 = d); auto. -apply Loc.diff_sym; auto. -left; trivial. -apply IHl with s; auto. -apply noOverlap_pop with (a1, a2); auto. -Qed. - -Lemma noO_diff: - forall l1 l2 s d r r0, - noOverlap (l1 ++ ((s, d) :: (l2 ++ ((r, r0) :: nil)))) -> - r = d \/ Loc.diff d r. -Proof. -intros. -assert (noOverlap ((s, d) :: (l2 ++ ((r, r0) :: nil)))); auto. -apply (noOverlap_right l1); auto. -assert (noOverlap ((l2 ++ ((r, r0) :: nil)) ++ ((s, d) :: nil))); auto. -apply (noOverlap_movBack0 (l2 ++ ((r, r0) :: nil))); auto. -assert - ((l2 ++ ((r, r0) :: nil)) ++ ((s, d) :: nil) = - l2 ++ (((r, r0) :: nil) ++ ((s, d) :: nil))); auto. -rewrite app_ass; auto. -rewrite H2 in H1. -simpl in H1 |-. -assert (noOverlap ((r, r0) :: ((s, d) :: nil))); auto. -apply (noOverlap_right l2); auto. -unfold noOverlap in H3 |-. -generalize (H3 r); simpl. -intros H4; elim H4; intros; [idtac | left; trivial]. -elim H6; intros [H9|H9] H10; [left | right]; auto. -Qed. - -Lemma f2ind: - forall (S1 S2 : State), - (forall (l : Moves), (S1 <> (nil, nil, l))) -> - noOverlap (StateToMove S1 ++ StateBeing S1) -> stepf S1 = S2 -> dstep S1 S2. -Proof. -intros S1 S2 Hneq HnoO; destruct S1 as [[t b] l]; destruct b. -destruct t. -elim (Hneq l); auto. -destruct m; simpl; case (Loc.eq r r0). -intros. -rewrite e; rewrite <- H; apply dstep_nop. -intros n H; rewrite <- H; generalize (dstep_start t l r r0); auto. -intros H; rewrite <- H; destruct m as [s d]. -CaseEq (split_move t d). -intros p H0; destruct p as [[t1 s0] t2]; simpl; rewrite H0; destruct t; simpl. -simpl in H0 |-; discriminate. -rewrite (unsplit_move (m :: t) t1 t2 d s0 s); auto. -destruct m; generalize dstep_push; intros H1; apply H1. -unfold StateToMove, StateBeing in HnoO |-. -apply (splitSome ((r, r0) :: t) t1 t2 d s0 s); auto. -apply noOverlap_head with b; auto. -unfold StateToMove, StateBeing in HnoO |-. -apply noOverlap_head with b; auto. -intros H0; destruct b. -simpl. -rewrite H0. -destruct t; (try destruct m); generalize dstep_last; intros H1; apply H1. -simpl; auto. -unfold StateToMove, StateBeing in HnoO |-. -apply splitNone with s; auto. -unfold StateToMove, StateBeing in HnoO |-. -generalize HnoO; clear HnoO; rewrite (rebuild_l b m); intros HnoO. -destruct (last (m :: b)). -case (Loc.eq d r). -intros e; rewrite <- e. -CaseEq (head_but_last (m :: b)); intros; [simpl | idtac]; - (try - (destruct t; (try destruct m0); rewrite H0; - (case (Loc.eq d d); intros h; (try (elim h; auto))))). -generalize (dstep_pop_loop nil nil); simpl; intros H3; apply H3; auto. -generalize (dstep_pop_loop ((r1, r2) :: t) nil); unfold T; simpl app; - intros H3; apply H3; clear H3; apply splitNone with s; (try assumption). -apply noOverlap_head with (head_but_last (m :: b) ++ ((r, r0) :: nil)); auto. -rewrite stepf_popLoop; auto. -generalize (dstep_pop_loop t (m0 :: l0)); simpl; intros H3; apply H3; clear H3; - apply splitNone with s; (try assumption). -apply noOverlap_head with (head_but_last (m :: b) ++ ((r, r0) :: nil)); auto. -intro; assert (Loc.diff d r). -assert (r = d \/ Loc.diff d r). -apply (noO_diff t (head_but_last (m :: b)) s d r r0); auto. -elim H1; [intros H2; absurd (d = r); auto | intros H2; auto]. -rewrite stepf_pop; auto. -generalize (dstep_pop t (head_but_last (m :: b))); intros H3; apply H3; auto. -clear H3; apply splitNone with s; (try assumption). -apply noOverlap_head with (head_but_last (m :: b) ++ ((r, r0) :: nil)); auto. -Qed. - -Lemma f2ind': - forall (S1 : State), - (forall (l : Moves), (S1 <> (nil, nil, l))) -> - noOverlap (StateToMove S1 ++ StateBeing S1) -> dstep S1 (stepf S1). -Proof. -intros S1 H noO; apply f2ind; auto. -Qed. - -Lemma appcons_length: - forall (l1 l2 : Moves) (m : Move), - length (l1 ++ (m :: l2)) = (length (l1 ++ l2) + 1%nat)%nat. -Proof. -induction l1; simpl; intros; [omega | idtac]. -rewrite IHl1; omega. -Qed. - -Definition mesure (S0 : State) : nat := - let (p, _) := S0 in let (t, b) := p in (2 * length t + length b)%nat. - -Lemma step_dec0: - forall (t1 t2 b1 b2 : Moves) (l1 l2 : Moves), - dstep (t1, b1, l1) (t2, b2, l2) -> - (2 * length t2 + length b2 < 2 * length t1 + length b1)%nat. -Proof. -intros t1 t2 b1 b2 l1 l2 H; inversion H; simpl; (try omega). -rewrite appcons_length; omega. -cut (length (b ++ ((T r0, d) :: nil)) = length (b ++ ((r0, d) :: nil))); - (try omega). -induction b; simpl; auto. -(repeat rewrite appcons_length); auto. -Qed. - -Lemma step_dec: - forall (S1 S2 : State), dstep S1 S2 -> (mesure S2 < mesure S1)%nat. -Proof. -unfold mesure; destruct S1 as [[t1 b1] l1]; destruct S2 as [[t2 b2] l2]. -intro; apply (step_dec0 t1 t2 b1 b2 l1 l2); trivial. -Qed. - -Lemma stepf_dec0: - forall (S1 S2 : State), - (forall (l : Moves), (S1 <> (nil, nil, l))) /\ - (S2 = stepf S1 /\ noOverlap (StateToMove S1 ++ StateBeing S1)) -> - (mesure S2 < mesure S1)%nat. -Proof. -intros S1 S2 [H1 [H2 H3]]; apply step_dec. -apply f2ind; trivial. -rewrite H2; reflexivity. -Qed. - -Lemma stepf_dec: - forall (S1 S2 : State), - S2 = stepf S1 /\ - ((forall (l : Moves), (S1 <> (nil, nil, l))) /\ - noOverlap (StateToMove S1 ++ StateBeing S1)) -> ltof _ mesure S2 S1. -Proof. -unfold ltof. -intros S1 S2 [H1 [H2 H3]]; apply step_dec. -apply f2ind; trivial. -rewrite H1; reflexivity. -Qed. - -Lemma replace_last_id: - forall l m m0, replace_last_s (m :: (m0 :: l)) = m :: replace_last_s (m0 :: l). -Proof. -intros; case l; simpl. -destruct m0; simpl; auto. -intros; case l0; auto. -Qed. - -Lemma length_replace: forall l, length (replace_last_s l) = length l. -Proof. -induction l; simpl; auto. -destruct l; destruct a; simpl; auto. -Qed. - -Lemma length_app: - forall (A : Set) (l1 l2 : list A), - (length (l1 ++ l2) = length l1 + length l2)%nat. -Proof. -intros A l1 l2; (try assumption). -induction l1; simpl; auto. -Qed. - -Lemma split_length: - forall (l t1 t2 : Moves) (s d : Reg), - split_move l s = Some (t1, d, t2) -> - (length l = (length t1 + length t2) + 1)%nat. -Proof. -induction l. -intros; discriminate. -intros t1 t2 s d; destruct a as [r r0]; simpl; case (Loc.eq r s); intro. -intros H; inversion H. -simpl; omega. -CaseEq (split_move l s); (try (intros; discriminate)). -(repeat destruct p); intros H H0; inversion H0. -rewrite H2; rewrite (IHl m0 m s r1); auto. -rewrite H4; rewrite <- H2; simpl; omega. -Qed. - -Lemma stepf_dec0': - forall (S1 : State), - (forall (l : Moves), (S1 <> (nil, nil, l))) -> - (mesure (stepf S1) < mesure S1)%nat. -Proof. -intros S1 H. -unfold mesure; destruct S1 as [[t1 b1] l1]. -destruct t1. -destruct b1. -generalize (H l1); intros H1; elim H1; auto. -destruct m; simpl. -destruct b1. -simpl; auto. -case (Loc.eq r0 (fst (last (m :: b1)))). -intros; rewrite length_replace; simpl; omega. -simpl; case b1; intros; simpl; omega. -destruct m. -destruct b1. -simpl. -case (Loc.eq r r0); intros; simpl; omega. -destruct m; simpl; case (Loc.eq r r2). -intros; simpl; omega. -CaseEq (split_move t1 r2); intros. -destruct p; destruct p; simpl. -rewrite (split_length t1 m0 m r2 r3); auto. -rewrite length_app; auto. -omega. -destruct b1. -simpl; omega. -case (Loc.eq r2 (fst (last (m :: b1)))); intros. -rewrite length_replace; simpl; omega. -simpl; omega. -Qed. - -Lemma stepf1_dec: - forall (S1 S2 : State), - (forall (l : Moves), (S1 <> (nil, nil, l))) -> - S2 = stepf S1 -> ltof _ mesure S2 S1. -Proof. -unfold ltof; intros S1 S2 H H0; rewrite H0. -apply stepf_dec0'; (try assumption). -Qed. - -Lemma disc1: - forall (a : Move) (l1 l2 l3 l4 : list Move), - ((a :: l1, l2, l3) <> (nil, nil, l4)). -Proof. -intros; discriminate. -Qed. - -Lemma disc2: - forall (a : Move) (l1 l2 l3 l4 : list Move), - ((l1, a :: l2, l3) <> (nil, nil, l4)). -Proof. -intros; discriminate. -Qed. -Hint Resolve disc1 disc2 . - -Lemma sameExec_reflexive: forall (r : State), sameExec r r. -Proof. -intros r; unfold sameExec, sameEnv, exec. -destruct r as [[t b] d]; trivial. -Qed. - -Definition base_case_Pmov_dec: - forall (s : State), - ({ exists l : list Move , s = (nil, nil, l) }) + - ({ forall l, (s <> (nil, nil, l)) }). -Proof. -destruct s as [[[|x tl] [|y tl']] l]; (try (right; intro; discriminate)). -left; exists l; auto. -Defined. - -Definition Pmov := - Fix - (well_founded_ltof _ mesure) (fun _ => State) - (fun (S1 : State) => - fun (Pmov : forall x, ltof _ mesure x S1 -> State) => - match base_case_Pmov_dec S1 with - left h => S1 - | right h => Pmov (stepf S1) (stepf_dec0' S1 h) end). - -Theorem Pmov_equation: forall S1, Pmov S1 = match S1 with - ((nil, nil), _) => S1 - | _ => Pmov (stepf S1) - end. -Proof. -intros S1; unfold Pmov at 1; - rewrite (Fix_eq - (well_founded_ltof _ mesure) (fun _ => State) - (fun (S1 : State) => - fun (Pmov : forall x, ltof _ mesure x S1 -> State) => - match base_case_Pmov_dec S1 with - left h => S1 - | right h => Pmov (stepf S1) (stepf_dec0' S1 h) end)). -fold Pmov. -destruct S1 as [[[|x tl] [|y tl']] l]; - match goal with - | |- match ?a with left _ => _ | right _ => _ end = _ => case a end; - (try (intros [l0 Heq]; discriminate Heq)); auto. -intros H; elim (H l); auto. -intros x f g Hfg_ext. -match goal with -| |- match ?a with left _ => _ | right _ => _ end = _ => case a end; auto. -Qed. - -Lemma sameExec_transitive: - forall (r1 r2 r3 : State), - (forall r, - In r (getdst (StateToMove r2 ++ StateBeing r2)) -> - In r (getdst (StateToMove r1 ++ StateBeing r1))) -> - (forall r, - In r (getdst (StateToMove r3 ++ StateBeing r3)) -> - In r (getdst (StateToMove r2 ++ StateBeing r2))) -> - sameExec r1 r2 -> sameExec r2 r3 -> sameExec r1 r3. -Proof. -intros r1 r2 r3; unfold sameExec, exec; (repeat rewrite getdst_app). -destruct r1 as [[t1 b1] d1]; destruct r2 as [[t2 b2] d2]; - destruct r3 as [[t3 b3] d3]; simpl. -intros Hin; intros. -rewrite H0; auto. -rewrite H1; auto. -intros. -apply (H3 x). -apply in_or_app; auto. -elim (in_app_or (getdst t2 ++ getdst b2) (getdst t3 ++ getdst b3) x); auto. -intros. -apply (H3 x). -apply in_or_app; auto. -elim (in_app_or (getdst t1 ++ getdst b1) (getdst t2 ++ getdst b2) x); auto. -Qed. - -Lemma dstep_inv_getdst: - forall (s1 s2 : State) r, - dstep s1 s2 -> - In r (getdst (StateToMove s2 ++ StateBeing s2)) -> - In r (getdst (StateToMove s1 ++ StateBeing s1)). -intros s1 s2 r STEP; inversion_clear STEP; - unfold StateToMove, StateBeing, StateDone; (repeat rewrite app_nil); - (repeat (rewrite getdst_app; simpl)); intro; auto. -Proof. -right; (try assumption). -elim (in_app_or (getdst t) (d :: nil) r); auto; (simpl; intros [H1|H1]); - [left; assumption | inversion H1]. -elim (in_app_or (getdst t1 ++ getdst t2) (r0 :: (d :: getdst b)) r); auto; - (simpl; intros). -elim (in_app_or (getdst t1) (getdst t2) r); auto; (simpl; intros). -apply in_or_app; left; apply in_or_app; left; assumption. -apply in_or_app; left; apply in_or_app; right; simpl; right; assumption. -elim H1; [intros H2 | intros [H2|H2]]. -apply in_or_app; left; apply in_or_app; right; simpl; left; auto. -apply in_or_app; right; simpl; left; auto. -apply in_or_app; right; simpl; right; assumption. -elim (in_app_or (getdst t) (getdst b ++ (d :: nil)) r); auto; (simpl; intros). -apply in_or_app; left; assumption. -elim (in_app_or (getdst b) (d :: nil) r); auto; (simpl; intros). -apply in_or_app; right; simpl; right; apply in_or_app; left; assumption. -elim H2; [intros H3 | intros H3; inversion H3]. -apply in_or_app; right; simpl; right; apply in_or_app; right; simpl; auto. -elim (in_app_or (getdst t) (getdst b ++ (d0 :: nil)) r); auto; (simpl; intros). -apply in_or_app; left; assumption. -elim (in_app_or (getdst b) (d0 :: nil) r); auto; simpl; - [intros H3 | intros [H3|H3]; [idtac | inversion H3]]. -apply in_or_app; right; simpl; right; apply in_or_app; left; assumption. -apply in_or_app; right; simpl; right; apply in_or_app; right; simpl; auto. -apply in_or_app; left; assumption. -Qed. - -Theorem STM_Pmov: forall (S1 : State), StateToMove (Pmov S1) = nil. -Proof. -intros S1; elim S1 using (well_founded_ind (Wf_nat.well_founded_ltof _ mesure)). -clear S1; intros S1; intros Hrec; destruct S1 as [[t b] d]; - rewrite Pmov_equation; destruct t. -destruct b; auto. -apply Hrec; apply stepf1_dec; auto. -apply Hrec; apply stepf1_dec; auto. -Qed. - -Theorem SB_Pmov: forall (S1 : State), StateBeing (Pmov S1) = nil. -Proof. -intros S1; elim S1 using (well_founded_ind (Wf_nat.well_founded_ltof _ mesure)). -clear S1; intros S1; intros Hrec; destruct S1 as [[t b] d]; - rewrite Pmov_equation; destruct t. -destruct b; auto. -apply Hrec; apply stepf1_dec; auto. -apply Hrec; apply stepf1_dec; auto. -Qed. - -Theorem Fpmov_correct: - forall (S1 : State), stepInv S1 -> sameExec S1 (Pmov S1). -Proof. -intros S1; elim S1 using (well_founded_ind (Wf_nat.well_founded_ltof _ mesure)). -clear S1; intros S1; intros Hrec Hinv; rewrite Pmov_equation; - destruct S1 as [[t b] d]. -assert - (forall (r : Reg) S1, - In r (getdst (StateToMove (Pmov (stepf S1)) ++ StateBeing (Pmov (stepf S1)))) -> - In r (getdst (StateToMove (stepf S1) ++ StateBeing (stepf S1)))). -intros r S1; rewrite (STM_Pmov (stepf S1)); rewrite SB_Pmov; simpl; intros. -inversion H. -destruct t. -destruct b. -apply sameExec_reflexive. -set (S1:=(nil (A:=Move), m :: b, d)). -assert (dstep S1 (stepf S1)); (try apply f2ind); unfold S1; auto. -elim Hinv; intros Hpath [SD [NO NT]]; assumption. -apply sameExec_transitive with (stepf S1); auto. -intros r; apply dstep_inv_getdst; auto. -apply dstepp_sameExec; auto; apply dstepp_trans with (stepf S1); auto. -apply dstepp_refl; auto. -apply Hrec; auto. -unfold ltof; apply step_dec; assumption. -apply (dstep_inv S1); assumption. -set (S1:=(m :: t, b, d)). -assert (dstep S1 (stepf S1)); (try apply f2ind); unfold S1; auto. -elim Hinv; intros Hpath [SD [NO NT]]; assumption. -apply sameExec_transitive with (stepf S1); auto. -intros r; apply dstep_inv_getdst; auto. -apply dstepp_sameExec; auto; apply dstepp_trans with (stepf S1); auto. -apply dstepp_refl; auto. -apply Hrec; auto. -unfold ltof; apply step_dec; assumption. -apply (dstep_inv S1); assumption. -Qed. - -Definition P_move := fun (p : Moves) => StateDone (Pmov (p, nil, nil)). - -Definition Sexec := sexec. - -Definition Get := get. - -Fixpoint listsLoc2Moves (src dst : list loc) {struct src} : Moves := - match src with - nil => nil - | s :: srcs => - match dst with - nil => nil - | d :: dsts => (s, d) :: listsLoc2Moves srcs dsts - end - end. - -Definition no_overlap (l1 l2 : list loc) := - forall r, In r l1 -> forall s, In s l2 -> r = s \/ Loc.diff r s. - -Definition no_overlap_state (S : State) := - no_overlap - (getsrc (StateToMove S ++ StateBeing S)) - (getdst (StateToMove S ++ StateBeing S)). - -Definition no_overlap_list := fun l => no_overlap (getsrc l) (getdst l). - -Lemma Indst_noOverlap_aux: - forall l1 l, - (forall (s : Reg), In s (getdst l1) -> l = s \/ Loc.diff l s) -> - noOverlap_aux l (getdst l1). -Proof. -intros; induction l1; simpl; auto. -destruct a as [a1 a2]; simpl; split. -elim (H a2); (try intros H0). -left; auto. -right; apply Loc.diff_sym; auto. -simpl; left; trivial. -apply IHl1; intros. -apply H; simpl; right; (try assumption). -Qed. - -Lemma no_overlap_noOverlap: - forall r, no_overlap_state r -> noOverlap (StateToMove r ++ StateBeing r). -Proof. -intros r; unfold noOverlap, no_overlap_state. -set (l1:=StateToMove r ++ StateBeing r). -unfold no_overlap; intros H l H0. -apply Indst_noOverlap_aux; intros; apply H; auto. -Qed. - -Theorem Fpmov_correctMoves: - forall p e r, - simpleDest p -> - no_overlap_list p -> - noTmp p -> - notemporary r -> - (forall (x : Reg), In x (getdst p) -> r = x \/ Loc.diff r x) -> - get (pexec p e) r = get (sexec (StateDone (Pmov (p, nil, nil))) e) r. -Proof. -intros p e r SD no_O notmp notempo. -generalize (Fpmov_correct (p, nil, nil)); unfold sameExec, exec; simpl; - rewrite SB_Pmov; rewrite STM_Pmov; simpl. -(repeat rewrite app_nil); intro. -apply H; auto. -unfold stepInv; simpl; (repeat split); (try (rewrite app_nil; assumption)); auto. -generalize (no_overlap_noOverlap (p, nil, nil)); simpl; intros; auto. -apply H0; auto; unfold no_overlap_list in H0 |-. -unfold no_overlap_state; simpl; (repeat rewrite app_nil); auto. -Qed. - -Theorem Fpmov_correct1: - forall (p : Moves) (e : Env) (r : Reg), - simpleDest p -> - no_overlap_list p -> - noTmp p -> - notemporary r -> - (forall (x : Reg), In x (getdst p) -> r = x \/ Loc.diff r x) -> - noWrite p r -> get e r = get (sexec (StateDone (Pmov (p, nil, nil))) e) r. -Proof. -intros p e r Hsd Hno_O HnoTmp Hrnotempo Hrno_Overlap Hnw. -rewrite <- (Fpmov_correctMoves p e); (try assumption). -destruct p; auto. -destruct m as [m1 m2]; simpl; case (Loc.eq m2 r); intros. -elim Hnw; intros; absurd (Loc.diff m2 r); auto. -rewrite e0; apply Loc.same_not_diff. -elim Hnw; intros H1 H2. -rewrite get_update_diff; (try assumption). -apply get_noWrite; (try assumption). -Qed. - -Lemma In_SD_diff: - forall (s d a1 a2 : Reg) (p : Moves), - In (s, d) p -> simpleDest ((a1, a2) :: p) -> Loc.diff a2 d. -Proof. -intros; induction p. -inversion H. -elim H; auto. -intro; subst a; elim H0; intros H1 H2; elim H1; intros; apply Loc.diff_sym; - assumption. -intro; apply IHp; auto. -apply simpleDest_pop2 with a; (try assumption). -Qed. - -Theorem pexec_correct: - forall (e : Env) (m : Move) (p : Moves), - In m p -> simpleDest p -> (let (s, d) := m in get (pexec p e) d = get e s). -Proof. -induction p; intros. -elim H. -destruct m. -elim (in_inv H); intro. -rewrite H1; simpl; rewrite get_update_id; auto. -destruct a as [a1 a2]; simpl. -rewrite get_update_diff. -apply IHp; auto. -apply (simpleDest_pop (a1, a2)); (try assumption). -apply (In_SD_diff r) with ( p := p ) ( a1 := a1 ); auto. -Qed. - -Lemma In_noTmp_notempo: - forall (s d : Reg) (p : Moves), In (s, d) p -> noTmp p -> notemporary d. -Proof. -intros; unfold notemporary; induction p. -inversion H. -elim H; intro. -subst a; elim H0; intros H1 [H3 H2]; (try assumption). -intro; apply IHp; auto. -destruct a; elim H0; intros _ [H2 H3]; (try assumption). -Qed. - -Lemma In_Indst: forall s d p, In (s, d) p -> In d (getdst p). -Proof. -intros; induction p; auto. -destruct a; simpl. -elim H; intro. -left; inversion H0; trivial. -right; apply IHp; auto. -Qed. - -Lemma In_SD_diff': - forall (d a1 a2 : Reg) (p : Moves), - In d (getdst p) -> simpleDest ((a1, a2) :: p) -> Loc.diff a2 d. -Proof. -intros d a1 a2 p H H0; induction p. -inversion H. -destruct a; elim H. -elim H0; simpl; intros. -subst r0. -elim H1; intros H3 H4; apply Loc.diff_sym; assumption. -intro; apply IHp; (try assumption). -apply simpleDest_pop2 with (r, r0); (try assumption). -Qed. - -Lemma In_SD_no_o: - forall (s d : Reg) (p : Moves), - In (s, d) p -> - simpleDest p -> forall (x : Reg), In x (getdst p) -> d = x \/ Loc.diff d x. -Proof. -intros s d p Hin Hsd; induction p. -inversion Hin. -destruct a as [a1 a2]; elim Hin; intros. -inversion H; subst d; subst s. -elim H0; intros H1; [left | right]; (try assumption). -apply (In_SD_diff' x a1 a2 p); auto. -elim H0. -intro; subst x. -right; apply Loc.diff_sym; apply (In_SD_diff s d a1 a2 p); auto. -intro; apply IHp; auto. -apply (simpleDest_pop (a1, a2)); assumption. -Qed. - -Lemma getdst_map: forall p, getdst p = map (fun x => snd x) p. -Proof. -induction p. -simpl; auto. -destruct a; simpl. -rewrite IHp; auto. +Variables srcs dsts: list loc. +Hypothesis LENGTH: List.length srcs = List.length dsts. +Hypothesis NOREPET: Loc.norepet dsts. +Hypothesis NO_OVERLAP: Loc.no_overlap srcs dsts. +Hypothesis NO_SRCS_TEMP: Loc.disjoint srcs temporaries. +Hypothesis NO_DSTS_TEMP: Loc.disjoint dsts temporaries. + +Definition no_overlap_dests (l: loc) : Prop := + forall d, In d dsts -> l = d \/ Loc.diff l d. + +Lemma dests_no_overlap_dests: + forall l, In l dsts -> no_overlap_dests l. +Proof. + assert (forall d, Loc.norepet d -> + forall l1 l2, In l1 d -> In l2 d -> l1 = l2 \/ Loc.diff l1 l2). + induction 1; simpl; intros. + contradiction. + elim H1; intro; elim H2; intro. + left; congruence. + right. subst l1. eapply Loc.in_notin_diff; eauto. + right. subst l2. apply Loc.diff_sym. eapply Loc.in_notin_diff; eauto. + eauto. + intros; red; intros. eauto. Qed. - -Lemma getsrc_map: forall p, getsrc p = map (fun x => fst x) p. + +Lemma notin_dests_no_overlap_dests: + forall l, Loc.notin l dsts -> no_overlap_dests l. Proof. -induction p. -simpl; auto. -destruct a; simpl. -rewrite IHp; auto. + intros; red; intros. + right. eapply Loc.in_notin_diff; eauto. Qed. - -Theorem Fpmov_correct2: - forall (p : Moves) (e : Env) (m : Move), - In m p -> - simpleDest p -> - no_overlap_list p -> - noTmp p -> - (let (s, d) := m in get (sexec (StateDone (Pmov (p, nil, nil))) e) d = get e s). + +Lemma source_no_overlap_dests: + forall s, In s srcs \/ s = R IT2 \/ s = R FT2 -> no_overlap_dests s. Proof. -intros p e m Hin Hsd Hno_O HnoTmp; destruct m as [s d]; - generalize (Fpmov_correctMoves p e); intros. -rewrite <- H; auto. -apply pexec_correct with ( m := (s, d) ); auto. -apply (In_noTmp_notempo s d p); auto. -apply (In_SD_no_o s d p Hin Hsd). + intros. elim H; intro. exact (NO_OVERLAP s H0). + elim H0; intro; subst s; red; intros; + right; apply Loc.diff_sym; apply NO_DSTS_TEMP; auto; simpl; tauto. Qed. - -Lemma notindst_nW: forall a p, Loc.notin a (getdst p) -> noWrite p a. + +Lemma source_not_temp1: + forall s, In s srcs \/ s = R IT2 \/ s = R FT2 -> Loc.diff s (R IT1) /\ Loc.diff s (R FT1). Proof. -induction p; simpl; auto. -destruct a0 as [a1 a2]. -simpl. -intros H; elim H; intro; split. -apply Loc.diff_sym; (try assumption). -apply IHp; auto. + intros. elim H; intro. + split; apply NO_SRCS_TEMP; auto; simpl; tauto. + elim H0; intro; subst s; simpl; split; congruence. Qed. - -Lemma disjoint_tmp__noTmp: - forall p, - Loc.disjoint (getsrc p) temporaries -> - Loc.disjoint (getdst p) temporaries -> noTmp p. -Proof. -induction p; simpl; auto. -destruct a as [a1 a2]; simpl getsrc; simpl getdst; unfold Loc.disjoint; intros; - (repeat split). -intro; unfold T; case (Loc.type r); apply H; (try (left; trivial; fail)). -right; left; trivial. -right; right; right; right; left; trivial. -intro; unfold T; case (Loc.type r); apply H0; (try (left; trivial; fail)). -right; left; trivial. -right; right; right; right; left; trivial. -apply IHp. -apply Loc.disjoint_cons_left with a1; auto. -apply Loc.disjoint_cons_left with a2; auto. + +Lemma dest_noteq_diff: + forall d l, + In d dsts \/ d = R IT2 \/ d = R FT2 -> + l <> d -> + no_overlap_dests l -> + Loc.diff l d. +Proof. + intros. elim H; intro. + elim (H1 d H2); intro. congruence. auto. + assert (forall r, l <> R r -> Loc.diff l (R r)). + intros. destruct l; simpl. congruence. destruct s; auto. + elim H2; intro; subst d; auto. Qed. - -Theorem Fpmov_correct_IT3: - forall p rs, - simpleDest p -> - no_overlap_list p -> - Loc.disjoint (getsrc p) temporaries -> - Loc.disjoint (getdst p) temporaries -> - (sexec (StateDone (Pmov (p, nil, nil))) rs) (R IT3) = rs (R IT3). -Proof. -intros p rs Hsd Hno_O Hdistmpsrc Hdistmpdst. -generalize (Fpmov_correctMoves p rs); unfold get, Locmap.get; intros H2. -rewrite <- H2; auto. -generalize (get_noWrite p (R IT3)); unfold get, Locmap.get; intros. -rewrite <- H; auto. -apply notindst_nW. -apply (Loc.disjoint_notin temporaries). -apply Loc.disjoint_sym; auto. -right; right; left; trivial. -apply disjoint_tmp__noTmp; auto. -unfold notemporary, T. -intros x; case (Loc.type x); simpl; intro; discriminate. -intros x H; right; apply Loc.in_notin_diff with (getdst p); auto. -apply Loc.disjoint_notin with temporaries; auto. -apply Loc.disjoint_sym; auto. -right; right; left; trivial. + +Definition locmap_equiv (e1 e2: Locmap.t): Prop := + forall l, + no_overlap_dests l -> Loc.diff l (R IT1) -> Loc.diff l (R FT1) -> e2 l = e1 l. + +Definition effect_move (src dst: loc) (e e': Locmap.t): Prop := + e' dst = e src /\ + forall l, Loc.diff l dst -> Loc.diff l (R IT1) -> Loc.diff l (R FT1) -> e' l = e l. + +Inductive effect_seqmove: list (loc * loc) -> Locmap.t -> Locmap.t -> Prop := + | effect_seqmove_nil: forall e, + effect_seqmove nil e e + | effect_seqmove_cons: forall s d m e1 e2 e3, + effect_move s d e1 e2 -> + effect_seqmove m e2 e3 -> + effect_seqmove ((s, d) :: m) e1 e3. + +Lemma effect_move_equiv: + forall s d e1 e2 e1', + (In s srcs \/ s = R IT2 \/ s = R FT2) -> + (In d dsts \/ d = R IT2 \/ d = R FT2) -> + locmap_equiv e1 e2 -> effect_move s d e1 e1' -> + locmap_equiv e1' (Parmov.update loc val Loc.eq d (e2 s) e2). +Proof. + intros. destruct H2. red; intros. + unfold Parmov.update. destruct (Loc.eq l d). + subst l. elim (source_not_temp1 _ H); intros. + rewrite H2. apply H1; auto. apply source_no_overlap_dests; auto. + rewrite H3; auto. apply dest_noteq_diff; auto. Qed. - -Theorem Fpmov_correct_map: - forall p rs, - simpleDest p -> - no_overlap_list p -> - Loc.disjoint (getsrc p) temporaries -> - Loc.disjoint (getdst p) temporaries -> - List.map (sexec (StateDone (Pmov (p, nil, nil))) rs) (getdst p) = - List.map rs (getsrc p). -Proof. -intros; rewrite getsrc_map; rewrite getdst_map; rewrite list_map_compose; - rewrite list_map_compose; apply list_map_exten; intros. -generalize (Fpmov_correct2 p rs x). -destruct x; simpl. -unfold get, Locmap.get; intros; auto. -rewrite H4; auto. -apply disjoint_tmp__noTmp; auto. + +Lemma effect_seqmove_equiv: + forall mu e1 e1', + effect_seqmove mu e1 e1' -> + forall e2, + (forall s d, In (s, d) mu -> + (In s srcs \/ s = R IT2 \/ s = R FT2) /\ + (In d dsts \/ d = R IT2 \/ d = R FT2)) -> + locmap_equiv e1 e2 -> + locmap_equiv e1' (exec_seq mu e2). +Proof. + induction 1; intros. + simpl. auto. + simpl. apply IHeffect_seqmove. + intros. apply H1. apply in_cons; auto. + destruct (H1 s d (in_eq _ _)). + eapply effect_move_equiv; eauto. Qed. - -Theorem Fpmov_correct_ext: - forall p rs, - simpleDest p -> - no_overlap_list p -> - Loc.disjoint (getsrc p) temporaries -> - Loc.disjoint (getdst p) temporaries -> - forall l, - Loc.notin l (getdst p) -> - Loc.notin l temporaries -> - (sexec (StateDone (Pmov (p, nil, nil))) rs) l = rs l. -Proof. -intros; generalize (Fpmov_correct1 p rs l); unfold get, Locmap.get; intros. -rewrite <- H5; auto. -apply disjoint_tmp__noTmp; auto. -unfold notemporary; simpl in H4 |-; unfold T; intros x; case (Loc.type x). -elim H4; - [intros H6 H7; elim H7; [intros H8 H9; (try clear H7 H4); (try exact H8)]]. -elim H4; - [intros H6 H7; elim H7; - [intros H8 H9; elim H9; - [intros H10 H11; elim H11; - [intros H12 H13; elim H13; - [intros H14 H15; (try clear H13 H11 H9 H7 H4); (try exact H14)]]]]]. -unfold no_overlap_list, no_overlap in H0 |-; intros. -case (Loc.eq l x). -intros e; left; (try assumption). -intros n; right; (try assumption). -apply Loc.in_notin_diff with (getdst p); auto. -apply notindst_nW; auto. + +Lemma effect_parmove: + forall e e', + effect_seqmove (parmove srcs dsts) e e' -> + List.map e' dsts = List.map e srcs /\ + e' (R IT3) = e (R IT3) /\ + forall l, Loc.notin l dsts -> Loc.notin l temporaries -> e' l = e l. +Proof. + set (mu := parmove srcs dsts). intros. + assert (locmap_equiv e e) by (red; auto). + generalize (effect_seqmove_equiv mu e e' H e (parmove_prop_2 srcs dsts) H0). + intro. + generalize (parmove_prop_1 srcs dsts LENGTH NOREPET NO_SRCS_TEMP NO_DSTS_TEMP e). + fold mu. intros [A B]. + (* e' dsts = e srcs *) + split. rewrite <- A. apply list_map_exten; intros. + apply H1. apply dests_no_overlap_dests; auto. + apply NO_DSTS_TEMP; auto; simpl; tauto. + apply NO_DSTS_TEMP; auto; simpl; tauto. + (* e' IT3 = e IT3 *) + split. + assert (Loc.notin (R IT3) dsts). + apply Loc.disjoint_notin with temporaries. + apply Loc.disjoint_sym; auto. simpl; tauto. + transitivity (exec_seq mu e (R IT3)). + symmetry. apply H1. apply notin_dests_no_overlap_dests. auto. + simpl; congruence. simpl; congruence. + apply B. apply Loc.notin_not_in; auto. congruence. congruence. + (* other locations *) + intros. transitivity (exec_seq mu e l). + symmetry. apply H1. apply notin_dests_no_overlap_dests; auto. + eapply Loc.in_notin_diff; eauto. simpl; tauto. + eapply Loc.in_notin_diff; eauto. simpl; tauto. + apply B. apply Loc.notin_not_in; auto. + apply Loc.diff_not_eq. eapply Loc.in_notin_diff; eauto. simpl; tauto. + apply Loc.diff_not_eq. eapply Loc.in_notin_diff; eauto. simpl; tauto. Qed. + +End EQUIVALENCE. + diff --git a/backend/RTL.v b/backend/RTL.v index ac9a415..4a3f8e8 100644 --- a/backend/RTL.v +++ b/backend/RTL.v @@ -4,12 +4,13 @@ after Cminor. *) -Require Import Relations. +(*Require Import Relations.*) Require Import Coqlib. Require Import Maps. Require Import AST. Require Import Integers. Require Import Values. +Require Import Events. Require Import Mem. Require Import Globalenvs. Require Import Op. @@ -54,6 +55,10 @@ Inductive instruction: Set := function name), giving it the values of registers [args] as arguments. It stores the return value in [dest] and branches to [succ]. *) + | Ialloc: reg -> reg -> node -> instruction + (** [Ialloc arg dest succ] allocates a fresh block of size + the contents of register [arg], stores a pointer to this + block in [dest], and branches to [succ]. *) | 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 @@ -85,11 +90,19 @@ Record function: Set := mkfunction { in the CFG. [fn_code_wf] asserts that all instructions of the function have nodes no greater than [fn_nextpc]. *) -Definition program := AST.program function. +Definition fundef := AST.fundef function. + +Definition program := AST.program fundef. + +Definition funsig (fd: fundef) := + match fd with + | Internal f => f.(fn_sig) + | External ef => ef.(ef_sig) + end. (** * Operational semantics *) -Definition genv := Genv.t function. +Definition genv := Genv.t fundef. Definition regset := Regmap.t val. Fixpoint init_regs (vl: list val) (rl: list reg) {struct rl} : regset := @@ -102,7 +115,8 @@ Section RELSEM. Variable ge: genv. -Definition find_function (ros: reg + ident) (rs: regset) : option function := +Definition find_function + (ros: reg + ident) (rs: regset) : option fundef := match ros with | inl r => Genv.find_funct ge rs#r | inr symb => @@ -132,66 +146,73 @@ Definition find_function (ros: reg + ident) (rs: regset) : option function := and memory state [m]. The final state is [pc'], [rs'] and [m']. *) Inductive exec_instr: code -> val -> - node -> regset -> mem -> + node -> regset -> mem -> trace -> node -> regset -> mem -> Prop := | exec_Inop: forall c sp pc rs m pc', c!pc = Some(Inop pc') -> - exec_instr c sp pc rs m pc' rs m + exec_instr c sp pc rs m E0 pc' rs m | exec_Iop: forall c sp pc rs m op args res pc' v, c!pc = Some(Iop op args res pc') -> eval_operation ge sp op rs##args = Some v -> - exec_instr c sp pc rs m pc' (rs#res <- v) m + exec_instr c sp pc rs m E0 pc' (rs#res <- v) m | exec_Iload: forall c sp pc rs m chunk addr args dst pc' a v, c!pc = Some(Iload chunk addr args dst pc') -> eval_addressing ge sp addr rs##args = Some a -> Mem.loadv chunk m a = Some v -> - exec_instr c sp pc rs m pc' (rs#dst <- v) m + exec_instr c sp pc rs m E0 pc' (rs#dst <- v) m | exec_Istore: forall c sp pc rs m chunk addr args src pc' a m', c!pc = Some(Istore chunk addr args src pc') -> eval_addressing ge sp addr rs##args = Some a -> Mem.storev chunk m a rs#src = Some m' -> - exec_instr c sp pc rs m pc' rs m' + exec_instr c sp pc rs m E0 pc' rs m' | exec_Icall: - forall c sp pc rs m sig ros args res pc' f vres m', + forall c sp pc rs m sig ros args res pc' f vres m' t, c!pc = Some(Icall sig ros args res pc') -> find_function ros rs = Some f -> - sig = f.(fn_sig) -> - exec_function f rs##args m vres m' -> - exec_instr c sp pc rs m pc' (rs#res <- vres) m' + funsig f = sig -> + exec_function f rs##args m t vres m' -> + exec_instr c sp pc rs m t pc' (rs#res <- vres) m' + | exec_Ialloc: + forall c sp pc rs m pc' arg res sz m' b, + c!pc = Some(Ialloc arg res pc') -> + rs#arg = Vint sz -> + Mem.alloc m 0 (Int.signed sz) = (m', b) -> + exec_instr c sp pc rs m E0 pc' (rs#res <- (Vptr b Int.zero)) m' | exec_Icond_true: forall c sp pc rs m cond args ifso ifnot, c!pc = Some(Icond cond args ifso ifnot) -> eval_condition cond rs##args = Some true -> - exec_instr c sp pc rs m ifso rs m + exec_instr c sp pc rs m E0 ifso rs m | exec_Icond_false: forall c sp pc rs m cond args ifso ifnot, c!pc = Some(Icond cond args ifso ifnot) -> eval_condition cond rs##args = Some false -> - exec_instr c sp pc rs m ifnot rs m + exec_instr c sp pc rs m E0 ifnot rs m (** [exec_instrs ge c sp pc rs m pc' rs' m'] is the reflexive transitive closure of [exec_instr]. It corresponds to the execution of zero, one or finitely many transitions. *) with exec_instrs: code -> val -> - node -> regset -> mem -> + node -> regset -> mem -> trace -> node -> regset -> mem -> Prop := | exec_refl: forall c sp pc rs m, - exec_instrs c sp pc rs m pc rs m + exec_instrs c sp pc rs m E0 pc rs m | exec_one: - forall c sp pc rs m pc' rs' m', - exec_instr c sp pc rs m pc' rs' m' -> - exec_instrs c sp pc rs m pc' rs' m' + forall c sp pc rs m t pc' rs' m', + exec_instr c sp pc rs m t pc' rs' m' -> + exec_instrs c sp pc rs m t pc' rs' m' | exec_trans: - forall c sp pc1 rs1 m1 pc2 rs2 m2 pc3 rs3 m3, - exec_instrs c sp pc1 rs1 m1 pc2 rs2 m2 -> - exec_instrs c sp pc2 rs2 m2 pc3 rs3 m3 -> - exec_instrs c sp pc1 rs1 m1 pc3 rs3 m3 + forall c sp pc1 rs1 m1 t1 pc2 rs2 m2 t2 pc3 rs3 m3 t3, + exec_instrs c sp pc1 rs1 m1 t1 pc2 rs2 m2 -> + exec_instrs c sp pc2 rs2 m2 t2 pc3 rs3 m3 -> + t3 = t1 ** t2 -> + exec_instrs c sp pc1 rs1 m1 t3 pc3 rs3 m3 (** [exec_function ge f args m res m'] executes a function application. [f] is the called function, [args] the values of its arguments, @@ -205,17 +226,21 @@ with exec_instrs: code -> val -> (Non-parameter registers are initialized to [Vundef].) Before returning, the stack activation block is freed. *) -with exec_function: function -> list val -> mem -> - val -> mem -> Prop := - | exec_funct: - forall f m m1 stk args pc rs m2 or vres, +with exec_function: fundef -> list val -> mem -> trace -> + val -> mem -> Prop := + | exec_funct_internal: + forall f m m1 stk args t pc rs m2 or vres, Mem.alloc m 0 f.(fn_stacksize) = (m1, stk) -> - exec_instrs f.(fn_code) (Vptr stk Int.zero) + exec_instrs f.(fn_code) (Vptr stk Int.zero) f.(fn_entrypoint) (init_regs args f.(fn_params)) m1 - pc rs m2 -> + t pc rs m2 -> f.(fn_code)!pc = Some(Ireturn or) -> vres = regmap_optget or Vundef rs -> - exec_function f args m vres (Mem.free m2 stk). + exec_function (Internal f) args m t vres (Mem.free m2 stk) + | exec_funct_external: + forall ef args m t res, + event_match ef args t res -> + exec_function (External ef) args m t res m. Scheme exec_instr_ind_3 := Minimality for exec_instr Sort Prop with exec_instrs_ind_3 := Minimality for exec_instrs Sort Prop @@ -224,12 +249,13 @@ Scheme exec_instr_ind_3 := Minimality for exec_instr Sort Prop (** Some derived execution rules. *) Lemma exec_step: - forall c sp pc1 rs1 m1 pc2 rs2 m2 pc3 rs3 m3, - exec_instr c sp pc1 rs1 m1 pc2 rs2 m2 -> - exec_instrs c sp pc2 rs2 m2 pc3 rs3 m3 -> - exec_instrs c sp pc1 rs1 m1 pc3 rs3 m3. + forall c sp pc1 rs1 m1 t1 pc2 rs2 m2 t2 pc3 rs3 m3 t3, + exec_instr c sp pc1 rs1 m1 t1 pc2 rs2 m2 -> + exec_instrs c sp pc2 rs2 m2 t2 pc3 rs3 m3 -> + t3 = t1 ** t2 -> + exec_instrs c sp pc1 rs1 m1 t3 pc3 rs3 m3. Proof. - intros. eapply exec_trans. apply exec_one. eauto. eauto. + intros. eapply exec_trans. apply exec_one. eauto. eauto. auto. Qed. Lemma exec_Iop': @@ -237,7 +263,7 @@ Lemma exec_Iop': c!pc = Some(Iop op args res pc') -> eval_operation ge sp op rs##args = Some v -> rs' = (rs#res <- v) -> - exec_instr c sp pc rs m pc' rs' m. + exec_instr c sp pc rs m E0 pc' rs' m. Proof. intros. subst rs'. eapply exec_Iop; eauto. Qed. @@ -248,7 +274,7 @@ Lemma exec_Iload': eval_addressing ge sp addr rs##args = Some a -> Mem.loadv chunk m a = Some v -> rs' = (rs#dst <- v) -> - exec_instr c sp pc rs m pc' rs' m. + exec_instr c sp pc rs m E0 pc' rs' m. Proof. intros. subst rs'. eapply exec_Iload; eauto. Qed. @@ -257,16 +283,16 @@ Qed. is defined in the CFG. *) Lemma exec_instr_present: - forall c sp pc rs m pc' rs' m', - exec_instr c sp pc rs m pc' rs' m' -> + forall c sp pc rs m t pc' rs' m', + exec_instr c sp pc rs m t pc' rs' m' -> c!pc <> None. Proof. induction 1; congruence. Qed. Lemma exec_instrs_present: - forall c sp pc rs m pc' rs' m', - exec_instrs c sp pc rs m pc' rs' m' -> + forall c sp pc rs m t pc' rs' m', + exec_instrs c sp pc rs m t pc' rs' m' -> c!pc' <> None -> c!pc <> None. Proof. induction 1; intros. @@ -280,14 +306,14 @@ End RELSEM. (** Execution of whole programs. As in Cminor, we call the ``main'' function with no arguments and observe its return value. *) -Definition exec_program (p: program) (r: val) : Prop := +Definition exec_program (p: program) (t: trace) (r: val) : Prop := let ge := Genv.globalenv p in let m0 := Genv.init_mem p in exists b, exists f, exists m, Genv.find_symbol ge p.(prog_main) = Some b /\ Genv.find_funct_ptr ge b = Some f /\ - f.(fn_sig) = mksignature nil (Some Tint) /\ - exec_function ge f nil m0 r m. + funsig f = mksignature nil (Some Tint) /\ + exec_function ge f nil m0 t r m. (** * Operations on RTL abstract syntax *) @@ -304,14 +330,15 @@ Definition successors (f: function) (pc: node) : list node := | Iload chunk addr args dst s => s :: nil | Istore chunk addr args src s => s :: nil | Icall sig ros args res s => s :: nil + | Ialloc arg res s => s :: nil | Icond cond args ifso ifnot => ifso :: ifnot :: nil | Ireturn optarg => nil end end. Lemma successors_correct: - forall ge f sp pc rs m pc' rs' m', - exec_instr ge f.(fn_code) sp pc rs m pc' rs' m' -> + forall ge f sp pc rs m t pc' rs' m', + exec_instr ge f.(fn_code) sp pc rs m t pc' rs' m' -> In pc' (successors f pc). Proof. intros ge f. unfold successors. generalize (fn_code f). @@ -345,5 +372,5 @@ Definition transf_function (f: function) : function := f.(fn_entrypoint) f.(fn_nextpc) (transf_code_wf f.(fn_code) f.(fn_nextpc) f.(fn_code_wf)). - + End TRANSF. diff --git a/backend/RTLgen.v b/backend/RTLgen.v index 38b19a0..a5c3ae7 100644 --- a/backend/RTLgen.v +++ b/backend/RTLgen.v @@ -28,6 +28,7 @@ Fixpoint mutated_expr (a: expr) : list ident := | Econdition b c d => mutated_condexpr b ++ mutated_expr c ++ mutated_expr d | Elet b c => mutated_expr b ++ mutated_expr c | Eletvar n => nil + | Ealloc b => mutated_expr b end with mutated_condexpr (a: condexpr) : list ident := @@ -328,6 +329,10 @@ Fixpoint transl_expr (map: mapping) (mut: list ident) transl_expr map mut b r nc | Eletvar n => do r <- find_letvar map n; add_move r rd nd + | Ealloc a => + do r <- alloc_reg map mut a; + do no <- add_instr (Ialloc r rd nd); + transl_expr map mut a r no end (** Translation of a conditional expression. Similar to [transl_expr], @@ -473,16 +478,18 @@ Definition transl_function (f: Cminor.function) : option RTL.function := | Error => None | OK (nentry, rparams) s => Some (RTL.mkfunction - f.(Cminor.fn_sig) - rparams - f.(Cminor.fn_stackspace) - s.(st_code) - nentry - s.(st_nextnode) - s.(st_wf)) + f.(Cminor.fn_sig) + rparams + f.(Cminor.fn_stackspace) + s.(st_code) + nentry + s.(st_nextnode) + s.(st_wf)) end. +Definition transl_fundef := transf_partial_fundef transl_function. + (** Translation of a whole program. *) Definition transl_program (p: Cminor.program) : option RTL.program := - transform_partial_program transl_function p. + transform_partial_program transl_fundef p. diff --git a/backend/RTLgenproof.v b/backend/RTLgenproof.v index d34bae9..24cc41b 100644 --- a/backend/RTLgenproof.v +++ b/backend/RTLgenproof.v @@ -6,6 +6,7 @@ Require Import AST. Require Import Integers. Require Import Values. Require Import Mem. +Require Import Events. Require Import Globalenvs. Require Import Op. Require Import Registers. @@ -30,45 +31,59 @@ Lemma symbols_preserved: forall (s: ident), Genv.find_symbol tge s = Genv.find_symbol ge s. Proof. intro. unfold ge, tge. - apply Genv.find_symbol_transf_partial with transl_function. + apply Genv.find_symbol_transf_partial with transl_fundef. exact TRANSL. Qed. Lemma function_ptr_translated: - forall (b: block) (f: Cminor.function), + forall (b: block) (f: Cminor.fundef), Genv.find_funct_ptr ge b = Some f -> exists tf, - Genv.find_funct_ptr tge b = Some tf /\ transl_function f = Some tf. + Genv.find_funct_ptr tge b = Some tf /\ transl_fundef f = Some tf. Proof. intros. generalize - (Genv.find_funct_ptr_transf_partial transl_function TRANSL H). - case (transl_function f). + (Genv.find_funct_ptr_transf_partial transl_fundef TRANSL H). + case (transl_fundef f). intros tf [A B]. exists tf. tauto. intros [A B]. elim B. reflexivity. Qed. Lemma functions_translated: - forall (v: val) (f: Cminor.function), + forall (v: val) (f: Cminor.fundef), Genv.find_funct ge v = Some f -> exists tf, - Genv.find_funct tge v = Some tf /\ transl_function f = Some tf. + Genv.find_funct tge v = Some tf /\ transl_fundef f = Some tf. Proof. intros. generalize - (Genv.find_funct_transf_partial transl_function TRANSL H). - case (transl_function f). + (Genv.find_funct_transf_partial transl_fundef TRANSL H). + case (transl_fundef f). intros tf [A B]. exists tf. tauto. intros [A B]. elim B. reflexivity. Qed. +Lemma sig_transl_function: + forall (f: Cminor.fundef) (tf: RTL.fundef), + transl_fundef f = Some tf -> + RTL.funsig tf = Cminor.funsig f. +Proof. + intros until tf. unfold transl_fundef, transf_partial_fundef. + case f; intro. + unfold transl_function. + case (transl_fun f0 init_state); intros. + discriminate. + destruct p. inversion H. reflexivity. + intro. inversion H. reflexivity. +Qed. + (** Correctness of the code generated by [add_move]. *) Lemma add_move_correct: forall r1 r2 sp nd s ns s' rs m, add_move r1 r2 nd s = OK ns s' -> exists rs', - exec_instrs tge s'.(st_code) sp ns rs m nd rs' m /\ + exec_instrs tge s'.(st_code) sp ns rs m E0 nd rs' m /\ rs'#r2 = rs#r1 /\ (forall r, r <> r2 -> rs'#r = rs#r). Proof. @@ -118,7 +133,7 @@ Qed. Definition transl_expr_correct (sp: val) (le: letenv) (e: env) (m: mem) (a: expr) - (e': env) (m': mem) (v: val) : Prop := + (t: trace) (e': env) (m': mem) (v: val) : Prop := forall map mut rd nd s ns s' rs (MWF: map_wf map s) (TE: transl_expr map mut a rd nd s = OK ns s') @@ -126,7 +141,7 @@ Definition transl_expr_correct (MUT: incl (mutated_expr a) mut) (TRG: target_reg_ok s map mut a rd), exists rs', - exec_instrs tge s'.(st_code) sp ns rs m nd rs' m' + exec_instrs tge s'.(st_code) sp ns rs m t nd rs' m' /\ match_env map e' le rs' /\ rs'#rd = v /\ (forall r, @@ -139,7 +154,7 @@ Definition transl_expr_correct Definition transl_exprlist_correct (sp: val) (le: letenv) (e: env) (m: mem) (al: exprlist) - (e': env) (m': mem) (vl: list val) : Prop := + (t: trace) (e': env) (m': mem) (vl: list val) : Prop := forall map mut rl nd s ns s' rs (MWF: map_wf map s) (TE: transl_exprlist map mut al rl nd s = OK ns s') @@ -147,7 +162,7 @@ Definition transl_exprlist_correct (MUT: incl (mutated_exprlist al) mut) (TRG: target_regs_ok s map mut al rl), exists rs', - exec_instrs tge s'.(st_code) sp ns rs m nd rs' m' + exec_instrs tge s'.(st_code) sp ns rs m t nd rs' m' /\ match_env map e' le rs' /\ rs'##rl = vl /\ (forall r, @@ -157,14 +172,14 @@ Definition transl_exprlist_correct Definition transl_condition_correct (sp: val) (le: letenv) (e: env) (m: mem) (a: condexpr) - (e': env) (m': mem) (vb: bool) : Prop := + (t: trace) (e': env) (m': mem) (vb: bool) : Prop := forall map mut ntrue nfalse s ns s' rs (MWF: map_wf map s) (TE: transl_condition map mut a ntrue nfalse s = OK ns s') (ME: match_env map e le rs) (MUT: incl (mutated_condexpr a) mut), exists rs', - exec_instrs tge s'.(st_code) sp ns rs m (if vb then ntrue else nfalse) rs' m' + exec_instrs tge s'.(st_code) sp ns rs m t (if vb then ntrue else nfalse) rs' m' /\ match_env map e' le rs' /\ (forall r, reg_valid r s -> ~(mutated_reg map mut r) -> @@ -233,7 +248,7 @@ Definition match_return_outcome Definition transl_stmt_correct (sp: val) (e: env) (m: mem) (a: stmt) - (e': env) (m': mem) (out: outcome) : Prop := + (t: trace) (e': env) (m': mem) (out: outcome) : Prop := forall map ncont nexits nret rret s ns s' nd rs (MWF: map_wf map s) (TE: transl_stmt map a ncont nexits nret rret s = OK ns s') @@ -241,7 +256,7 @@ Definition transl_stmt_correct (OUT: outcome_node out ncont nexits nret nd) (RRG: return_reg_ok s map rret), exists rs', - exec_instrs tge s'.(st_code) sp ns rs m nd rs' m' + exec_instrs tge s'.(st_code) sp ns rs m t nd rs' m' /\ match_env map e' nil rs' /\ match_return_outcome out rret rs'. @@ -251,11 +266,11 @@ Definition transl_stmt_correct the same modifications on the memory state. *) Definition transl_function_correct - (m: mem) (f: Cminor.function) (vargs: list val) - (m':mem) (vres: val) : Prop := + (m: mem) (f: Cminor.fundef) (vargs: list val) + (t: trace) (m':mem) (vres: val) : Prop := forall tf - (TE: transl_function f = Some tf), - exec_function tge tf vargs m vres m'. + (TE: transl_fundef f = Some tf), + exec_function tge tf vargs m t vres m'. (** The correctness of the translation is a huge induction over the Cminor evaluation derivation for the source program. To keep @@ -268,7 +283,7 @@ Definition transl_function_correct Lemma transl_expr_Evar_correct: forall (sp: val) (le: letenv) (e: env) (m: mem) (id: ident) (v: val), e!id = Some v -> - transl_expr_correct sp le e m (Evar id) e m v. + transl_expr_correct sp le e m (Evar id) E0 e m v. Proof. intros; red; intros. monadInv TE. intro. generalize EQ; unfold find_var. caseEq (map_vars map)!id. @@ -303,12 +318,12 @@ Qed. Lemma transl_expr_Eop_correct: forall (sp: val) (le : letenv) (e : env) (m : mem) (op : operation) - (al : exprlist) (e1 : env) (m1 : mem) (vl : list val) + (al : exprlist) (t: trace) (e1 : env) (m1 : mem) (vl : list val) (v: val), - eval_exprlist ge sp le e m al e1 m1 vl -> - transl_exprlist_correct sp le e m al e1 m1 vl -> + eval_exprlist ge sp le e m al t e1 m1 vl -> + transl_exprlist_correct sp le e m al t e1 m1 vl -> eval_operation ge sp op vl = Some v -> - transl_expr_correct sp le e m (Eop op al) e1 m1 v. + transl_expr_correct sp le e m (Eop op al) t e1 m1 v. Proof. intros until v. intros EEL TEL EOP. red; intros. simpl in TE. monadInv TE. intro EQ1. @@ -323,9 +338,9 @@ Proof. apply exec_instrs_incr with s1. eauto with rtlg. apply exec_one; eapply exec_Iop. eauto with rtlg. subst vl. - rewrite (@eval_operation_preserved Cminor.function RTL.function ge tge). + rewrite (@eval_operation_preserved Cminor.fundef RTL.fundef ge tge). eexact EOP. - exact symbols_preserved. + exact symbols_preserved. traceEq. (* Match-env *) split. inversion TRG. eauto with rtlg. (* Result reg *) @@ -344,11 +359,11 @@ Qed. Lemma transl_expr_Eassign_correct: forall (sp: val) (le : letenv) (e : env) (m : mem) - (id : ident) (a : expr) (e1 : env) (m1 : mem) + (id : ident) (a : expr) (t: trace) (e1 : env) (m1 : mem) (v : val), - eval_expr ge sp le e m a e1 m1 v -> - transl_expr_correct sp le e m a e1 m1 v -> - transl_expr_correct sp le e m (Eassign id a) (PTree.set id v e1) m1 v. + eval_expr ge sp le e m a t e1 m1 v -> + transl_expr_correct sp le e m a t e1 m1 v -> + transl_expr_correct sp le e m (Eassign id a) t (PTree.set id v e1) m1 v. Proof. intros; red; intros. simpl in TE. monadInv TE. intro EQ1. @@ -366,7 +381,7 @@ Proof. (* Exec *) split. eapply exec_trans. eexact EX1. apply exec_instrs_incr with s1. eauto with rtlg. - exact EX2. + eexact EX2. traceEq. (* Match-env *) split. apply match_env_update_var with rs1 r s s0; auto. @@ -387,13 +402,13 @@ Qed. Lemma transl_expr_Eload_correct: forall (sp: val) (le : letenv) (e : env) (m : mem) (chunk : memory_chunk) (addr : addressing) - (al : exprlist) (e1 : env) (m1 : mem) (v : val) + (al : exprlist) (t: trace) (e1 : env) (m1 : mem) (v : val) (vl : list val) (a: val), - eval_exprlist ge sp le e m al e1 m1 vl -> - transl_exprlist_correct sp le e m al e1 m1 vl -> + eval_exprlist ge sp le e m al t e1 m1 vl -> + transl_exprlist_correct sp le e m al t e1 m1 vl -> eval_addressing ge sp addr vl = Some a -> Mem.loadv chunk m1 a = Some v -> - transl_expr_correct sp le e m (Eload chunk addr al) e1 m1 v. + transl_expr_correct sp le e m (Eload chunk addr al) t e1 m1 v. Proof. intros; red; intros. simpl in TE. monadInv TE. intro EQ1. clear TE. simpl in MUT. @@ -407,7 +422,7 @@ Proof. apply exec_instrs_incr with s1. eauto with rtlg. apply exec_one. eapply exec_Iload. eauto with rtlg. rewrite RES1. rewrite (@eval_addressing_preserved _ _ ge tge). - eexact H1. exact symbols_preserved. assumption. + eexact H1. exact symbols_preserved. assumption. traceEq. (* Match-env *) split. eapply match_env_update_temp. assumption. inversion TRG. assumption. (* Result *) @@ -425,16 +440,17 @@ Qed. Lemma transl_expr_Estore_correct: forall (sp: val) (le : letenv) (e : env) (m : mem) (chunk : memory_chunk) (addr : addressing) - (al : exprlist) (b : expr) (e1 : env) (m1 : mem) - (vl : list val) (e2 : env) (m2 m3 : mem) + (al : exprlist) (b : expr) (t t1: trace) (e1 : env) (m1 : mem) + (vl : list val) (t2: trace) (e2 : env) (m2 m3 : mem) (v : val) (a: val), - eval_exprlist ge sp le e m al e1 m1 vl -> - transl_exprlist_correct sp le e m al e1 m1 vl -> - eval_expr ge sp le e1 m1 b e2 m2 v -> - transl_expr_correct sp le e1 m1 b e2 m2 v -> + eval_exprlist ge sp le e m al t1 e1 m1 vl -> + transl_exprlist_correct sp le e m al t1 e1 m1 vl -> + eval_expr ge sp le e1 m1 b t2 e2 m2 v -> + transl_expr_correct sp le e1 m1 b t2 e2 m2 v -> eval_addressing ge sp addr vl = Some a -> Mem.storev chunk m2 a v = Some m3 -> - transl_expr_correct sp le e m (Estore chunk addr al b) e2 m3 v. + t = t1 ** t2 -> + transl_expr_correct sp le e m (Estore chunk addr al b) t e2 m3 v. Proof. intros; red; intros. simpl in TE; monadInv TE. intro EQ2; clear TE. simpl in MUT. @@ -467,10 +483,11 @@ Proof. tauto. right. apply sym_not_equal. apply valid_fresh_different with s. inversion TRG; assumption. assumption. - rewrite H5; rewrite RES1. + rewrite H6; rewrite RES1. rewrite (@eval_addressing_preserved _ _ ge tge). eexact H3. exact symbols_preserved. rewrite RES2. assumption. + reflexivity. traceEq. (* Match-env *) split. assumption. (* Result *) @@ -488,18 +505,20 @@ Qed. Lemma transl_expr_Ecall_correct: forall (sp: val) (le : letenv) (e : env) (m : mem) - (sig : signature) (a : expr) (bl : exprlist) - (e1 e2 : env) (m1 m2 m3 : mem) (vf : val) - (vargs : list val) (vres : val) (f : Cminor.function), - eval_expr ge sp le e m a e1 m1 vf -> - transl_expr_correct sp le e m a e1 m1 vf -> - eval_exprlist ge sp le e1 m1 bl e2 m2 vargs -> - transl_exprlist_correct sp le e1 m1 bl e2 m2 vargs -> + (sig : signature) (a : expr) (bl : exprlist) (t t1: trace) + (e1: env) (m1: mem) (t2: trace) (e2 : env) (m2 : mem) + (t3: trace) (m3: mem) (vf : val) + (vargs : list val) (vres : val) (f : Cminor.fundef), + eval_expr ge sp le e m a t1 e1 m1 vf -> + transl_expr_correct sp le e m a t1 e1 m1 vf -> + eval_exprlist ge sp le e1 m1 bl t2 e2 m2 vargs -> + transl_exprlist_correct sp le e1 m1 bl t2 e2 m2 vargs -> Genv.find_funct ge vf = Some f -> - Cminor.fn_sig f = sig -> - eval_funcall ge m2 f vargs m3 vres -> - transl_function_correct m2 f vargs m3 vres -> - transl_expr_correct sp le e m (Ecall sig a bl) e2 m3 vres. + Cminor.funsig f = sig -> + eval_funcall ge m2 f vargs t3 m3 vres -> + transl_function_correct m2 f vargs t3 m3 vres -> + t = t1 ** t2 ** t3 -> + transl_expr_correct sp le e m (Ecall sig a bl) t e2 m3 vres. Proof. intros. red; simpl; intros. monadInv TE. intro EQ3. clear TE. @@ -530,7 +549,7 @@ Proof. generalize (H6 tf TF). intro EXF. assert (EX3: exec_instrs tge (st_code s2) sp n rs2 m2 - nd (rs2#rd <- vres) m3). + t3 nd (rs2#rd <- vres) m3). apply exec_one. eapply exec_Icall. eauto with rtlg. simpl. replace (rs2#r) with vf. eexact TFIND. rewrite <- RES1. symmetry. apply OTHER2. @@ -543,10 +562,7 @@ Proof. tauto. byContradiction. apply valid_fresh_absurd with r s0. eauto with rtlg. assumption. tauto. - generalize TF. unfold transl_function. - destruct (transl_fun f init_state). - intro; discriminate. destruct p. intros. injection TF0. intro. - rewrite <- H7; simpl. auto. + generalize (sig_transl_function _ _ TF). congruence. rewrite RES2. assumption. exists (rs2#rd <- vres). @@ -555,7 +571,7 @@ Proof. apply exec_instrs_incr with s3. eauto with rtlg. eapply exec_trans. eexact EX2. apply exec_instrs_incr with s2. eauto with rtlg. - exact EX3. + eexact EX3. reflexivity. traceEq. (* Match env *) split. apply match_env_update_temp. assumption. inversion TRG. assumption. @@ -591,13 +607,14 @@ Qed. Lemma transl_expr_Econdition_correct: forall (sp: val) (le : letenv) (e : env) (m : mem) - (a : condexpr) (b c : expr) (e1 : env) (m1 : mem) - (v1 : bool) (e2 : env) (m2 : mem) (v2 : val), - eval_condexpr ge sp le e m a e1 m1 v1 -> - transl_condition_correct sp le e m a e1 m1 v1 -> - eval_expr ge sp le e1 m1 (if v1 then b else c) e2 m2 v2 -> - transl_expr_correct sp le e1 m1 (if v1 then b else c) e2 m2 v2 -> - transl_expr_correct sp le e m (Econdition a b c) e2 m2 v2. + (a : condexpr) (b c : expr) (t t1: trace) (e1 : env) (m1 : mem) + (v1 : bool) (t2: trace) (e2 : env) (m2 : mem) (v2 : val), + eval_condexpr ge sp le e m a t1 e1 m1 v1 -> + transl_condition_correct sp le e m a t1 e1 m1 v1 -> + eval_expr ge sp le e1 m1 (if v1 then b else c) t2 e2 m2 v2 -> + transl_expr_correct sp le e1 m1 (if v1 then b else c) t2 e2 m2 v2 -> + t = t1 ** t2 -> + transl_expr_correct sp le e m (Econdition a b c) t e2 m2 v2. Proof. intros; red; intros. simpl in TE; monadInv TE. intro EQ1; clear TE. simpl in MUT. @@ -619,7 +636,7 @@ Proof. (* Exec *) split. eapply exec_trans. eexact EX1. apply exec_instrs_incr with s1. eauto with rtlg. - exact EX2. + eexact EX2. auto. (* Match-env *) split. assumption. (* Result value *) @@ -639,7 +656,7 @@ Proof. (* Exec *) split. eapply exec_trans. eexact EX1. apply exec_instrs_incr with s0. eauto with rtlg. - exact EX2. + eexact EX2. auto. (* Match-env *) split. assumption. (* Result value *) @@ -653,13 +670,14 @@ Qed. Lemma transl_expr_Elet_correct: forall (sp: val) (le : letenv) (e : env) (m : mem) - (a b : expr) (e1 : env) (m1 : mem) (v1 : val) - (e2 : env) (m2 : mem) (v2 : val), - eval_expr ge sp le e m a e1 m1 v1 -> - transl_expr_correct sp le e m a e1 m1 v1 -> - eval_expr ge sp (v1 :: le) e1 m1 b e2 m2 v2 -> - transl_expr_correct sp (v1 :: le) e1 m1 b e2 m2 v2 -> - transl_expr_correct sp le e m (Elet a b) e2 m2 v2. + (a b : expr) (t t1: trace) (e1 : env) (m1 : mem) (v1 : val) + (t2: trace) (e2 : env) (m2 : mem) (v2 : val), + eval_expr ge sp le e m a t1 e1 m1 v1 -> + transl_expr_correct sp le e m a t1 e1 m1 v1 -> + eval_expr ge sp (v1 :: le) e1 m1 b t2 e2 m2 v2 -> + transl_expr_correct sp (v1 :: le) e1 m1 b t2 e2 m2 v2 -> + t = t1 ** t2 -> + transl_expr_correct sp le e m (Elet a b) t e2 m2 v2. Proof. intros; red; intros. simpl in TE; monadInv TE. intro EQ1. @@ -678,17 +696,17 @@ Proof. assert (TRG2: target_reg_ok s0 (add_letvar map r) mut b rd). inversion TRG. apply target_reg_other. unfold reg_in_map, add_letvar; simpl. red; intro. - elim H10; intro. apply H3. left. assumption. - elim H11; intro. apply valid_fresh_absurd with rd s. - assumption. rewrite <- H12. eauto with rtlg. - apply H3. right. assumption. + elim H11; intro. apply H4. left. assumption. + elim H12; intro. apply valid_fresh_absurd with rd s. + assumption. rewrite <- H13. eauto with rtlg. + apply H4. right. assumption. eauto with rtlg. generalize (H2 _ _ _ _ _ _ _ _ MWF2 EQ0 ME2 MUT2 TRG2). intros [rs2 [EX2 [ME3 [RES2 OTHER2]]]]. exists rs2. (* Exec *) split. eapply exec_trans. eexact EX1. - apply exec_instrs_incr with s1. eauto with rtlg. exact EX2. + apply exec_instrs_incr with s1. eauto with rtlg. eexact EX2. auto. (* Match-env *) split. apply mk_match_env. exact (me_vars _ _ _ _ ME3). generalize (me_letvars _ _ _ _ ME3). @@ -699,21 +717,21 @@ Proof. intros. transitivity (rs1#r0). apply OTHER2. eauto with rtlg. unfold mutated_reg. unfold add_letvar; simpl. assumption. - elim H5; intro. left. + elim H6; intro. left. unfold reg_in_map, add_letvar; simpl. - unfold reg_in_map in H6; tauto. + unfold reg_in_map in H7; tauto. tauto. apply OTHER1. eauto with rtlg. assumption. right. red; intro. apply valid_fresh_absurd with r0 s. - assumption. rewrite H6. eauto with rtlg. + assumption. rewrite H7. eauto with rtlg. Qed. Lemma transl_expr_Eletvar_correct: forall (sp: val) (le : list val) (e : env) (m : mem) (n : nat) (v : val), nth_error le n = Some v -> - transl_expr_correct sp le e m (Eletvar n) e m v. + transl_expr_correct sp le e m (Eletvar n) E0 e m v. Proof. intros; red; intros. simpl in TE; monadInv TE. intro EQ1. @@ -746,9 +764,46 @@ Proof. intro; monadSimpl. Qed. +Lemma transl_expr_Ealloc_correct: + forall (sp: val) (le : letenv) (e : env) (m : mem) + (a : expr) (t: trace) (e1 : env) (m1 : mem) (n: int) + (m2: mem) (b: block), + eval_expr ge sp le e m a t e1 m1 (Vint n) -> + transl_expr_correct sp le e m a t e1 m1 (Vint n) -> + Mem.alloc m1 0 (Int.signed n) = (m2, b) -> + transl_expr_correct sp le e m (Ealloc a) t e1 m2 (Vptr b Int.zero). +Proof. + intros until b; intros EE TEC ALLOC; red; intros. + simpl in TE. monadInv TE. intro EQ1. + simpl in MUT. + assert (TRG': target_reg_ok s1 map mut a r); eauto with rtlg. + assert (MWF': map_wf map s1). eauto with rtlg. + generalize (TEC _ _ _ _ _ _ _ _ MWF' EQ1 ME MUT TRG'). + intros [rs1 [EX1 [ME1 [RR1 RO1]]]]. + exists (rs1#rd <- (Vptr b Int.zero)). +(* Exec *) + split. eapply exec_trans. eexact EX1. + apply exec_instrs_incr with s1. eauto with rtlg. + apply exec_one; eapply exec_Ialloc. eauto with rtlg. + eexact RR1. assumption. traceEq. +(* Match-env *) + split. inversion TRG. eauto with rtlg. +(* Result *) + split. apply Regmap.gss. +(* Other regs *) + intros. rewrite Regmap.gso. + apply RO1. eauto with rtlg. assumption. + case (Reg.eq r0 r); intro. + subst r0. left. elim (alloc_reg_fresh_or_in_map _ _ _ _ _ _ MWF EQ); intro. + auto. byContradiction; eauto with rtlg. + right; assumption. + elim H1; intro. red; intro. subst r0. inversion TRG. contradiction. + auto. +Qed. + Lemma transl_condition_CEtrue_correct: forall (sp: val) (le : letenv) (e : env) (m : mem), - transl_condition_correct sp le e m CEtrue e m true. + transl_condition_correct sp le e m CEtrue E0 e m true. Proof. intros; red; intros. simpl in TE; monadInv TE. subst ns. exists rs. split. apply exec_refl. split. auto. auto. @@ -756,7 +811,7 @@ Qed. Lemma transl_condition_CEfalse_correct: forall (sp: val) (le : letenv) (e : env) (m : mem), - transl_condition_correct sp le e m CEfalse e m false. + transl_condition_correct sp le e m CEfalse E0 e m false. Proof. intros; red; intros. simpl in TE; monadInv TE. subst ns. exists rs. split. apply exec_refl. split. auto. auto. @@ -764,12 +819,12 @@ Qed. Lemma transl_condition_CEcond_correct: forall (sp: val) (le : letenv) (e : env) (m : mem) - (cond : condition) (al : exprlist) (e1 : env) + (cond : condition) (al : exprlist) (t1: trace) (e1 : env) (m1 : mem) (vl : list val) (b : bool), - eval_exprlist ge sp le e m al e1 m1 vl -> - transl_exprlist_correct sp le e m al e1 m1 vl -> + eval_exprlist ge sp le e m al t1 e1 m1 vl -> + transl_exprlist_correct sp le e m al t1 e1 m1 vl -> eval_condition cond vl = Some b -> - transl_condition_correct sp le e m (CEcond cond al) e1 m1 b. + transl_condition_correct sp le e m (CEcond cond al) t1 e1 m1 b. Proof. intros; red; intros. simpl in TE; monadInv TE. intro EQ1; clear TE. assert (MWF1: map_wf map s1). eauto with rtlg. @@ -788,6 +843,7 @@ Proof. rewrite RES1. assumption. eapply exec_Icond_false. eauto with rtlg. rewrite RES1. assumption. + traceEq. (* Match-env *) split. assumption. (* Regs *) @@ -800,13 +856,14 @@ Qed. Lemma transl_condition_CEcondition_correct: forall (sp: val) (le : letenv) (e : env) (m : mem) - (a b c : condexpr) (e1 : env) (m1 : mem) - (vb1 : bool) (e2 : env) (m2 : mem) (vb2 : bool), - eval_condexpr ge sp le e m a e1 m1 vb1 -> - transl_condition_correct sp le e m a e1 m1 vb1 -> - eval_condexpr ge sp le e1 m1 (if vb1 then b else c) e2 m2 vb2 -> - transl_condition_correct sp le e1 m1 (if vb1 then b else c) e2 m2 vb2 -> - transl_condition_correct sp le e m (CEcondition a b c) e2 m2 vb2. + (a b c : condexpr) (t t1: trace) (e1 : env) (m1 : mem) + (vb1 : bool) (t2: trace) (e2 : env) (m2 : mem) (vb2 : bool), + eval_condexpr ge sp le e m a t1 e1 m1 vb1 -> + transl_condition_correct sp le e m a t1 e1 m1 vb1 -> + eval_condexpr ge sp le e1 m1 (if vb1 then b else c) t2 e2 m2 vb2 -> + transl_condition_correct sp le e1 m1 (if vb1 then b else c) t2 e2 m2 vb2 -> + t = t1 ** t2 -> + transl_condition_correct sp le e m (CEcondition a b c) t e2 m2 vb2. Proof. intros; red; intros. simpl in TE; monadInv TE. intro EQ1; clear TE. simpl in MUT. @@ -823,7 +880,7 @@ Proof. exists rs2. split. eapply exec_trans. eexact EX1. apply exec_instrs_incr with s1. eauto with rtlg. - exact EX2. + eexact EX2. auto. split. assumption. intros. transitivity (rs1#r). apply OTHER2; eauto with rtlg. @@ -835,7 +892,7 @@ Proof. exists rs2. split. eapply exec_trans. eexact EX1. apply exec_instrs_incr with s0. eauto with rtlg. - exact EX2. + eexact EX2. auto. split. assumption. intros. transitivity (rs1#r). apply OTHER2; eauto with rtlg. @@ -844,7 +901,7 @@ Qed. Lemma transl_exprlist_Enil_correct: forall (sp: val) (le : letenv) (e : env) (m : mem), - transl_exprlist_correct sp le e m Enil e m nil. + transl_exprlist_correct sp le e m Enil E0 e m nil. Proof. intros; red; intros. generalize TE. simpl. destruct rl; monadSimpl. @@ -857,17 +914,18 @@ Qed. Lemma transl_exprlist_Econs_correct: forall (sp: val) (le : letenv) (e : env) (m : mem) - (a : expr) (bl : exprlist) (e1 : env) (m1 : mem) - (v : val) (e2 : env) (m2 : mem) (vl : list val), - eval_expr ge sp le e m a e1 m1 v -> - transl_expr_correct sp le e m a e1 m1 v -> - eval_exprlist ge sp le e1 m1 bl e2 m2 vl -> - transl_exprlist_correct sp le e1 m1 bl e2 m2 vl -> - transl_exprlist_correct sp le e m (Econs a bl) e2 m2 (v :: vl). + (a : expr) (bl : exprlist) (t t1: trace) (e1 : env) (m1 : mem) + (v : val) (t2: trace) (e2 : env) (m2 : mem) (vl : list val), + eval_expr ge sp le e m a t1 e1 m1 v -> + transl_expr_correct sp le e m a t1 e1 m1 v -> + eval_exprlist ge sp le e1 m1 bl t2 e2 m2 vl -> + transl_exprlist_correct sp le e1 m1 bl t2 e2 m2 vl -> + t = t1 ** t2 -> + transl_exprlist_correct sp le e m (Econs a bl) t e2 m2 (v :: vl). Proof. intros. red. intros. inversion TRG. - rewrite <- H10 in TE. simpl in TE. monadInv TE. intro EQ1. + rewrite <- H11 in TE. simpl in TE. monadInv TE. intro EQ1. simpl in MUT. assert (MUT1: incl (mutated_expr a) mut); eauto with coqlib. assert (MUT2: incl (mutated_exprlist bl) mut); eauto with coqlib. @@ -875,12 +933,13 @@ Proof. assert (TRG1: target_reg_ok s1 map mut a r); eauto with rtlg. generalize (H0 _ _ _ _ _ _ _ _ MWF1 EQ1 ME MUT1 TRG1). intros [rs1 [EX1 [ME1 [RES1 OTHER1]]]]. - generalize (H2 _ _ _ _ _ _ _ _ MWF EQ ME1 MUT2 H11). + generalize (H2 _ _ _ _ _ _ _ _ MWF EQ ME1 MUT2 H12). intros [rs2 [EX2 [ME2 [RES2 OTHER2]]]]. exists rs2. (* Exec *) split. eapply exec_trans. eexact EX1. - apply exec_instrs_incr with s1. eauto with rtlg. assumption. + apply exec_instrs_incr with s1. eauto with rtlg. + eexact EX2. auto. (* Match-env *) split. assumption. (* Results *) @@ -894,22 +953,23 @@ Proof. transitivity (rs1#r0). apply OTHER2; auto. tauto. apply OTHER1; auto. eauto with rtlg. - elim H14; intro. left; assumption. right; apply sym_not_equal; tauto. + elim H15; intro. left; assumption. right; apply sym_not_equal; tauto. Qed. -Lemma transl_funcall_correct: - forall (m : mem) (f : Cminor.function) (vargs : list val) - (m1 : mem) (sp : block) (e e2 : env) (m2 : mem) - (out : outcome) (vres : val), +Lemma transl_funcall_internal_correct: + forall (m : mem) (f : Cminor.function) + (vargs : list val) (m1 : mem) (sp : block) (e : env) (t : trace) + (e2 : env) (m2 : mem) (out : outcome) (vres : val), Mem.alloc m 0 (fn_stackspace f) = (m1, sp) -> - set_locals (Cminor.fn_vars f) (set_params vargs (Cminor.fn_params f)) = e -> - exec_stmt ge (Vptr sp Int.zero) e m1 (fn_body f) e2 m2 out -> - transl_stmt_correct (Vptr sp Int.zero) e m1 (fn_body f) e2 m2 out -> + set_locals (fn_vars f) (set_params vargs (Cminor.fn_params f)) = e -> + exec_stmt ge (Vptr sp Int.zero) e m1 (fn_body f) t e2 m2 out -> + transl_stmt_correct (Vptr sp Int.zero) e m1 (fn_body f) t e2 m2 out -> outcome_result_value out f.(Cminor.fn_sig).(sig_res) vres -> - transl_function_correct m f vargs (Mem.free m2 sp) vres. + transl_function_correct m (Internal f) + vargs t (Mem.free m2 sp) vres. Proof. intros; red; intros. - generalize TE. unfold transl_function. + generalize TE. unfold transl_fundef, transl_function; simpl. caseEq (transl_fun f init_state). intros; discriminate. intros ns s. unfold transl_fun. monadSimpl. @@ -934,30 +994,41 @@ Proof. apply map_wf_incr with s1. apply state_incr_trans with s2; eauto with rtlg. assumption. - assert (RRG: return_reg_ok s3 y0 (ret_reg (Cminor.fn_sig f) r)). + set (rr := ret_reg (Cminor.fn_sig f) r) in *. + assert (RRG: return_reg_ok s3 y0 rr). apply return_reg_ok_incr with s2. eauto with rtlg. - apply new_reg_return_ok with s1; assumption. + unfold rr; apply new_reg_return_ok with s1; assumption. generalize (H2 _ _ _ _ _ _ _ _ _ rs MWF EQ3 ME OUT RRG). intros [rs1 [EX1 [ME1 MR1]]]. - apply exec_funct with m1 n rs1 (ret_reg (Cminor.fn_sig f) r). - rewrite <- TF; simpl; assumption. - rewrite <- TF; simpl. exact EX1. - rewrite <- TF; simpl. apply instr_at_incr with s3. + rewrite <- TF. apply exec_funct_internal with m1 n rs1 rr; simpl. + assumption. + exact EX1. + apply instr_at_incr with s3. eauto with rtlg. discriminate. eauto with rtlg. generalize MR1. unfold match_return_outcome. generalize H3. unfold outcome_result_value. - unfold ret_reg; destruct (sig_res (Cminor.fn_sig f)). + unfold rr, ret_reg; destruct (sig_res (Cminor.fn_sig f)). unfold regmap_optget. destruct out; try contradiction. destruct o; try contradiction. intros; congruence. unfold regmap_optget. destruct out; contradiction||auto. destruct o; contradiction||auto. Qed. +Lemma transl_funcall_external_correct: + forall (ef : external_function) (m : mem) (args : list val) (t: trace) (res : val), + event_match ef args t res -> + transl_function_correct m (External ef) args t m res. +Proof. + intros; red; intros. unfold transl_function in TE; simpl in TE. + inversion TE; subst tf. + apply exec_funct_external. auto. +Qed. + Lemma transl_stmt_Sskip_correct: forall (sp: val) (e : env) (m : mem), - transl_stmt_correct sp e m Sskip e m Out_normal. + transl_stmt_correct sp e m Sskip E0 e m Out_normal. Proof. intros; red; intros. simpl in TE. monadInv TE. subst s'; subst ns. @@ -966,13 +1037,15 @@ Proof. Qed. Lemma transl_stmt_Sseq_continue_correct: - forall (sp : val) (e : env) (m : mem) (s1 : stmt) (e1 : env) - (m1 : mem) (s2 : stmt) (e2 : env) (m2 : mem) (out : outcome), - exec_stmt ge sp e m s1 e1 m1 Out_normal -> - transl_stmt_correct sp e m s1 e1 m1 Out_normal -> - exec_stmt ge sp e1 m1 s2 e2 m2 out -> - transl_stmt_correct sp e1 m1 s2 e2 m2 out -> - transl_stmt_correct sp e m (Sseq s1 s2) e2 m2 out. + forall (sp : val) (e : env) (m : mem) (t: trace) (s1 : stmt) + (t1: trace) (e1 : env) (m1 : mem) (s2 : stmt) (t2: trace) + (e2 : env) (m2 : mem) (out : outcome), + exec_stmt ge sp e m s1 t1 e1 m1 Out_normal -> + transl_stmt_correct sp e m s1 t1 e1 m1 Out_normal -> + exec_stmt ge sp e1 m1 s2 t2 e2 m2 out -> + transl_stmt_correct sp e1 m1 s2 t2 e2 m2 out -> + t = t1 ** t2 -> + transl_stmt_correct sp e m (Sseq s1 s2) t e2 m2 out. Proof. intros; red; intros. simpl in TE; monadInv TE. intro EQ0. assert (MWF1: map_wf map s0). eauto with rtlg. @@ -987,18 +1060,18 @@ Proof. (* Exec *) split. eapply exec_trans. eexact EX1. apply exec_instrs_incr with s0. eauto with rtlg. - exact EX2. + eexact EX2. auto. (* Match-env + return *) tauto. Qed. Lemma transl_stmt_Sseq_stop_correct: - forall (sp : val) (e : env) (m : mem) (s1 s2 : stmt) (e1 : env) + forall (sp : val) (e : env) (m : mem) (t: trace) (s1 s2 : stmt) (e1 : env) (m1 : mem) (out : outcome), - exec_stmt ge sp e m s1 e1 m1 out -> - transl_stmt_correct sp e m s1 e1 m1 out -> + exec_stmt ge sp e m s1 t e1 m1 out -> + transl_stmt_correct sp e m s1 t e1 m1 out -> out <> Out_normal -> - transl_stmt_correct sp e m (Sseq s1 s2) e1 m1 out. + transl_stmt_correct sp e m (Sseq s1 s2) t e1 m1 out. Proof. intros; red; intros. simpl in TE; monadInv TE. intro EQ0; clear TE. @@ -1010,11 +1083,11 @@ Proof. Qed. Lemma transl_stmt_Sexpr_correct: - forall (sp: val) (e : env) (m : mem) (a : expr) + forall (sp: val) (e : env) (m : mem) (a : expr) (t: trace) (e1 : env) (m1 : mem) (v : val), - eval_expr ge sp nil e m a e1 m1 v -> - transl_expr_correct sp nil e m a e1 m1 v -> - transl_stmt_correct sp e m (Sexpr a) e1 m1 Out_normal. + eval_expr ge sp nil e m a t e1 m1 v -> + transl_expr_correct sp nil e m a t e1 m1 v -> + transl_stmt_correct sp e m (Sexpr a) t e1 m1 Out_normal. Proof. intros; red; intros. simpl in OUT. subst nd. @@ -1028,17 +1101,18 @@ Qed. Lemma transl_stmt_Sifthenelse_correct: forall (sp: val) (e : env) (m : mem) (a : condexpr) - (sl1 sl2 : stmt) (e1 : env) (m1 : mem) - (v1 : bool) (e2 : env) (m2 : mem) (out : outcome), - eval_condexpr ge sp nil e m a e1 m1 v1 -> - transl_condition_correct sp nil e m a e1 m1 v1 -> - exec_stmt ge sp e1 m1 (if v1 then sl1 else sl2) e2 m2 out -> - transl_stmt_correct sp e1 m1 (if v1 then sl1 else sl2) e2 m2 out -> - transl_stmt_correct sp e m (Sifthenelse a sl1 sl2) e2 m2 out. + (s1 s2 : stmt) (t t1: trace) (e1 : env) (m1 : mem) + (v1 : bool) (t2: trace) (e2 : env) (m2 : mem) (out : outcome), + eval_condexpr ge sp nil e m a t1 e1 m1 v1 -> + transl_condition_correct sp nil e m a t1 e1 m1 v1 -> + exec_stmt ge sp e1 m1 (if v1 then s1 else s2) t2 e2 m2 out -> + transl_stmt_correct sp e1 m1 (if v1 then s1 else s2) t2 e2 m2 out -> + t = t1 ** t2 -> + transl_stmt_correct sp e m (Sifthenelse a s1 s2) t e2 m2 out. Proof. intros; red; intros until rs; intro MWF. - simpl. case (more_likely a sl1 sl2); monadSimpl; intro EQ2; intros. - assert (MWF1: map_wf map s1). eauto with rtlg. + simpl. case (more_likely a s1 s2); monadSimpl; intro EQ2; intros. + assert (MWF1: map_wf map s3). eauto with rtlg. generalize (H0 _ _ _ _ _ _ _ rs MWF1 EQ2 ME (incl_refl _)). intros [rs1 [EX1 [ME1 OTHER1]]]. destruct v1. @@ -1047,17 +1121,17 @@ Proof. generalize (H2 _ _ _ _ _ _ _ _ _ _ MWF0 EQ0 ME1 OUT RRG0). intros [rs2 [EX2 [ME2 MRE2]]]. exists rs2. split. - eapply exec_trans. eexact EX1. apply exec_instrs_incr with s1. - eauto with rtlg. exact EX2. + eapply exec_trans. eexact EX1. apply exec_instrs_incr with s3. + eauto with rtlg. eexact EX2. auto. tauto. generalize (H2 _ _ _ _ _ _ _ _ _ _ MWF EQ ME1 OUT RRG). intros [rs2 [EX2 [ME2 MRE2]]]. exists rs2. split. eapply exec_trans. eexact EX1. apply exec_instrs_incr with s0. - eauto with rtlg. exact EX2. + eauto with rtlg. eexact EX2. auto. tauto. - assert (MWF1: map_wf map s1). eauto with rtlg. + assert (MWF1: map_wf map s3). eauto with rtlg. generalize (H0 _ _ _ _ _ _ _ rs MWF1 EQ2 ME (incl_refl _)). intros [rs1 [EX1 [ME1 OTHER1]]]. destruct v1. @@ -1065,27 +1139,28 @@ Proof. intros [rs2 [EX2 [ME2 MRE2]]]. exists rs2. split. eapply exec_trans. eexact EX1. apply exec_instrs_incr with s0. - eauto with rtlg. exact EX2. + eauto with rtlg. eexact EX2. auto. tauto. assert (MWF0: map_wf map s0). eauto with rtlg. assert (RRG0: return_reg_ok s0 map rret). eauto with rtlg. generalize (H2 _ _ _ _ _ _ _ _ _ _ MWF0 EQ0 ME1 OUT RRG0). intros [rs2 [EX2 [ME2 MRE2]]]. exists rs2. split. - eapply exec_trans. eexact EX1. apply exec_instrs_incr with s1. - eauto with rtlg. exact EX2. + eapply exec_trans. eexact EX1. apply exec_instrs_incr with s3. + eauto with rtlg. eexact EX2. auto. tauto. Qed. Lemma transl_stmt_Sloop_loop_correct: - forall (sp: val) (e : env) (m : mem) (sl : stmt) - (e1 : env) (m1 : mem) (e2 : env) (m2 : mem) + forall (sp: val) (e : env) (m : mem) (sl : stmt) (t t1: trace) + (e1 : env) (m1 : mem) (t2: trace) (e2 : env) (m2 : mem) (out : outcome), - exec_stmt ge sp e m sl e1 m1 Out_normal -> - transl_stmt_correct sp e m sl e1 m1 Out_normal -> - exec_stmt ge sp e1 m1 (Sloop sl) e2 m2 out -> - transl_stmt_correct sp e1 m1 (Sloop sl) e2 m2 out -> - transl_stmt_correct sp e m (Sloop sl) e2 m2 out. + exec_stmt ge sp e m sl t1 e1 m1 Out_normal -> + transl_stmt_correct sp e m sl t1 e1 m1 Out_normal -> + exec_stmt ge sp e1 m1 (Sloop sl) t2 e2 m2 out -> + transl_stmt_correct sp e1 m1 (Sloop sl) t2 e2 m2 out -> + t = t1 ** t2 -> + transl_stmt_correct sp e m (Sloop sl) t e2 m2 out. Proof. intros; red; intros. generalize TE. simpl. monadSimpl. subst s2; subst n0. intros. @@ -1107,22 +1182,23 @@ Proof. apply exec_instrs_extends with s1. eapply update_instr_extends. eexact EQ. eauto with rtlg. eexact EQ1. eexact EX1. - apply exec_trans with ns rs1 m1. + apply exec_trans with E0 ns rs1 m1 t2. apply exec_one. apply exec_Inop. generalize EQ1. unfold update_instr. case (plt n (st_nextnode s1)); intro; monadSimpl. - rewrite <- H4. simpl. apply PTree.gss. + rewrite <- H5. simpl. apply PTree.gss. exact EX2. + reflexivity. traceEq. tauto. Qed. Lemma transl_stmt_Sloop_stop_correct: - forall (sp: val) (e : env) (m : mem) (sl : stmt) + forall (sp: val) (e : env) (m : mem) (t: trace) (sl : stmt) (e1 : env) (m1 : mem) (out : outcome), - exec_stmt ge sp e m sl e1 m1 out -> - transl_stmt_correct sp e m sl e1 m1 out -> + exec_stmt ge sp e m sl t e1 m1 out -> + transl_stmt_correct sp e m sl t e1 m1 out -> out <> Out_normal -> - transl_stmt_correct sp e m (Sloop sl) e1 m1 out. + transl_stmt_correct sp e m (Sloop sl) t e1 m1 out. Proof. intros; red; intros. simpl in TE. monadInv TE. subst s2; subst n0. @@ -1145,11 +1221,11 @@ Proof. Qed. Lemma transl_stmt_Sblock_correct: - forall (sp: val) (e : env) (m : mem) (sl : stmt) + forall (sp: val) (e : env) (m : mem) (sl : stmt) (t: trace) (e1 : env) (m1 : mem) (out : outcome), - exec_stmt ge sp e m sl e1 m1 out -> - transl_stmt_correct sp e m sl e1 m1 out -> - transl_stmt_correct sp e m (Sblock sl) e1 m1 (outcome_block out). + exec_stmt ge sp e m sl t e1 m1 out -> + transl_stmt_correct sp e m sl t e1 m1 out -> + transl_stmt_correct sp e m (Sblock sl) t e1 m1 (outcome_block out). Proof. intros; red; intros. simpl in TE. assert (OUT': outcome_node out ncont (ncont :: nexits) nret nd). @@ -1180,7 +1256,7 @@ Qed. Lemma transl_stmt_Sexit_correct: forall (sp: val) (e : env) (m : mem) (n : nat), - transl_stmt_correct sp e m (Sexit n) e m (Out_exit n). + transl_stmt_correct sp e m (Sexit n) E0 e m (Out_exit n). Proof. intros; red; intros. simpl in TE. simpl in OUT. @@ -1194,7 +1270,7 @@ Lemma transl_switch_correct: transl_switch r nexits cases default s = OK ns s' -> nth_error nexits (switch_target i default cases) = Some nd -> rs#r = Vint i -> - exec_instrs tge s'.(st_code) sp ns rs m nd rs m. + exec_instrs tge s'.(st_code) sp ns rs m E0 nd rs m. Proof. induction cases; simpl; intros. generalize (transl_exit_correct _ _ _ _ _ H). intros. @@ -1202,23 +1278,23 @@ Proof. destruct a as [key1 exit1]. monadInv H. clear H. intro EQ1. caseEq (Int.eq i key1); intro IEQ; rewrite IEQ in H0. (* i = key1 *) - apply exec_trans with n0 rs m. apply exec_one. + apply exec_trans with E0 n0 rs m E0. apply exec_one. eapply exec_Icond_true. eauto with rtlg. simpl. rewrite H1. congruence. generalize (transl_exit_correct _ _ _ _ _ EQ0); intro. - assert (n0 = nd). congruence. subst n0. apply exec_refl. + assert (n0 = nd). congruence. subst n0. apply exec_refl. traceEq. (* i <> key1 *) - apply exec_trans with n rs m. apply exec_one. + apply exec_trans with E0 n rs m E0. apply exec_one. eapply exec_Icond_false. eauto with rtlg. simpl. rewrite H1. congruence. - apply exec_instrs_incr with s0; eauto with rtlg. + apply exec_instrs_incr with s0; eauto with rtlg. traceEq. Qed. Lemma transl_stmt_Sswitch_correct: forall (sp : val) (e : env) (m : mem) (a : expr) - (cases : list (int * nat)) (default : nat) (e1 : env) (m1 : mem) - (n : int), - eval_expr ge sp nil e m a e1 m1 (Vint n) -> - transl_expr_correct sp nil e m a e1 m1 (Vint n) -> - transl_stmt_correct sp e m (Sswitch a cases default) e1 m1 + (cases : list (int * nat)) (default : nat) + (t1 : trace) (e1 : env) (m1 : mem) (n : int), + eval_expr ge sp nil e m a t1 e1 m1 (Vint n) -> + transl_expr_correct sp nil e m a t1 e1 m1 (Vint n) -> + transl_stmt_correct sp e m (Sswitch a cases default) t1 e1 m1 (Out_exit (switch_target n default cases)). Proof. intros; red; intros. monadInv TE. clear TE; intros EQ1. @@ -1234,14 +1310,14 @@ Proof. (* execution *) split. eapply exec_trans. eexact EXEC1. apply exec_instrs_incr with s1. eauto with rtlg. - eapply transl_switch_correct; eauto. + eapply transl_switch_correct; eauto. traceEq. (* match_env & match_reg *) tauto. Qed. Lemma transl_stmt_Sreturn_none_correct: forall (sp: val) (e : env) (m : mem), - transl_stmt_correct sp e m (Sreturn None) e m (Out_return None). + transl_stmt_correct sp e m (Sreturn None) E0 e m (Out_return None). Proof. intros; red; intros. generalize TE. simpl. destruct rret; monadSimpl. @@ -1250,11 +1326,11 @@ Proof. Qed. Lemma transl_stmt_Sreturn_some_correct: - forall (sp: val) (e : env) (m : mem) (a : expr) + forall (sp: val) (e : env) (m : mem) (a : expr) (t: trace) (e1 : env) (m1 : mem) (v : val), - eval_expr ge sp nil e m a e1 m1 v -> - transl_expr_correct sp nil e m a e1 m1 v -> - transl_stmt_correct sp e m (Sreturn (Some a)) e1 m1 (Out_return (Some v)). + eval_expr ge sp nil e m a t e1 m1 v -> + transl_expr_correct sp nil e m a t e1 m1 v -> + transl_stmt_correct sp e m (Sreturn (Some a)) t e1 m1 (Out_return (Some v)). Proof. intros; red; intros. generalize TE; simpl. destruct rret. intro EQ. @@ -1278,9 +1354,9 @@ Scheme eval_expr_ind_5 := Minimality for eval_expr Sort Prop with exec_stmt_ind_5 := Minimality for exec_stmt Sort Prop. Theorem transl_function_correctness: - forall m f vargs m' vres, - eval_funcall ge m f vargs m' vres -> - transl_function_correct m f vargs m' vres. + forall m f vargs t m' vres, + eval_funcall ge m f vargs t m' vres -> + transl_function_correct m f vargs t m' vres. Proof (eval_funcall_ind_5 ge transl_expr_correct @@ -1298,13 +1374,15 @@ Proof transl_expr_Econdition_correct transl_expr_Elet_correct transl_expr_Eletvar_correct + transl_expr_Ealloc_correct transl_condition_CEtrue_correct transl_condition_CEfalse_correct transl_condition_CEcond_correct transl_condition_CEcondition_correct transl_exprlist_Enil_correct transl_exprlist_Econs_correct - transl_funcall_correct + transl_funcall_internal_correct + transl_funcall_external_correct transl_stmt_Sskip_correct transl_stmt_Sexpr_correct transl_stmt_Sifthenelse_correct @@ -1319,26 +1397,23 @@ Proof transl_stmt_Sreturn_some_correct). Theorem transl_program_correct: - forall (r: val), - Cminor.exec_program prog r -> - RTL.exec_program tprog r. + forall (t: trace) (r: val), + Cminor.exec_program prog t r -> + RTL.exec_program tprog t r. Proof. - intros r [b [f [m [SYMB [FUNC [SIG EVAL]]]]]]. + intros t r [b [f [m [SYMB [FUNC [SIG EVAL]]]]]]. generalize (function_ptr_translated _ _ FUNC). intros [tf [TFIND TRANSLF]]. red; exists b; exists tf; exists m. split. rewrite symbols_preserved. replace (prog_main tprog) with (prog_main prog). assumption. - symmetry; apply transform_partial_program_main with transl_function. + symmetry; apply transform_partial_program_main with transl_fundef. exact TRANSL. split. exact TFIND. - split. generalize TRANSLF. unfold transl_function. - destruct (transl_fun f init_state). - intro; discriminate. destruct p; intro EQ; injection EQ; intro EQ1. - rewrite <- EQ1. simpl. congruence. - rewrite (Genv.init_mem_transf_partial transl_function prog TRANSL). - exact (transl_function_correctness _ _ _ _ _ EVAL _ TRANSLF). + split. generalize (sig_transl_function _ _ TRANSLF). congruence. + unfold fundef; rewrite (Genv.init_mem_transf_partial transl_fundef prog TRANSL). + exact (transl_function_correctness _ _ _ _ _ _ EVAL _ TRANSLF). Qed. End CORRECTNESS. diff --git a/backend/RTLgenproof1.v b/backend/RTLgenproof1.v index 85d420e..8b14901 100644 --- a/backend/RTLgenproof1.v +++ b/backend/RTLgenproof1.v @@ -5,6 +5,7 @@ Require Import Maps. Require Import AST. Require Import Integers. Require Import Values. +Require Import Events. Require Import Mem. Require Import Globalenvs. Require Import Op. @@ -200,28 +201,28 @@ Variable s1 s2: state. Hypothesis EXT: state_extends s1 s2. Lemma exec_instr_not_halt: - forall ge c sp pc rs m pc' rs' m', - exec_instr ge c sp pc rs m pc' rs' m' -> c!pc <> None. + forall ge c sp pc rs m t pc' rs' m', + exec_instr ge c sp pc rs m t pc' rs' m' -> c!pc <> None. Proof. induction 1; rewrite H; discriminate. Qed. Lemma exec_instr_in_s2: - forall ge sp pc rs m pc' rs' m', - exec_instr ge s1.(st_code) sp pc rs m pc' rs' m' -> + forall ge sp pc rs m t pc' rs' m', + exec_instr ge s1.(st_code) sp pc rs m t pc' rs' m' -> s2.(st_code)!pc = s1.(st_code)!pc. Proof. intros. elim (EXT pc); intro. - elim (exec_instr_not_halt _ _ _ _ _ _ _ _ _ H H0). + elim (exec_instr_not_halt _ _ _ _ _ _ _ _ _ _ H H0). assumption. Qed. Lemma exec_instr_extends_rec: - forall ge c sp pc rs m pc' rs' m', - exec_instr ge c sp pc rs m pc' rs' m' -> + forall ge c sp pc rs m t pc' rs' m', + exec_instr ge c sp pc rs m t pc' rs' m' -> forall c', c!pc = c'!pc -> - exec_instr ge c' sp pc rs m pc' rs' m'. + exec_instr ge c' sp pc rs m t pc' rs' m'. Proof. induction 1; intros. apply exec_Inop. congruence. @@ -230,14 +231,15 @@ Proof. apply exec_Istore with chunk addr args src a. congruence. auto. auto. apply exec_Icall with sig ros args f; auto. congruence. + apply exec_Ialloc with arg sz; auto. congruence. apply exec_Icond_true with cond args ifnot; auto. congruence. apply exec_Icond_false with cond args ifso; auto. congruence. Qed. Lemma exec_instr_extends: - forall ge sp pc rs m pc' rs' m', - exec_instr ge s1.(st_code) sp pc rs m pc' rs' m' -> - exec_instr ge s2.(st_code) sp pc rs m pc' rs' m'. + forall ge sp pc rs m t pc' rs' m', + exec_instr ge s1.(st_code) sp pc rs m t pc' rs' m' -> + exec_instr ge s2.(st_code) sp pc rs m t pc' rs' m'. Proof. intros. apply exec_instr_extends_rec with (st_code s1). @@ -246,21 +248,21 @@ Proof. Qed. Lemma exec_instrs_extends_rec: - forall ge c sp pc rs m pc' rs' m', - exec_instrs ge c sp pc rs m pc' rs' m' -> + forall ge c sp pc rs m t pc' rs' m', + exec_instrs ge c sp pc rs m t pc' rs' m' -> c = s1.(st_code) -> - exec_instrs ge s2.(st_code) sp pc rs m pc' rs' m'. + exec_instrs ge s2.(st_code) sp pc rs m t pc' rs' m'. Proof. induction 1; intros. apply exec_refl. apply exec_one. apply exec_instr_extends; auto. rewrite <- H0; auto. - apply exec_trans with pc2 rs2 m2; auto. + apply exec_trans with t1 pc2 rs2 m2 t2; auto. Qed. Lemma exec_instrs_extends: - forall ge sp pc rs m pc' rs' m', - exec_instrs ge s1.(st_code) sp pc rs m pc' rs' m' -> - exec_instrs ge s2.(st_code) sp pc rs m pc' rs' m'. + forall ge sp pc rs m t pc' rs' m', + exec_instrs ge s1.(st_code) sp pc rs m t pc' rs' m' -> + exec_instrs ge s2.(st_code) sp pc rs m t pc' rs' m'. Proof. intros. apply exec_instrs_extends_rec with (st_code s1); auto. @@ -281,9 +283,9 @@ Variable s1 s2: state. Hypothesis INCR: state_incr s1 s2. Lemma exec_instr_incr: - forall ge sp pc rs m pc' rs' m', - exec_instr ge s1.(st_code) sp pc rs m pc' rs' m' -> - exec_instr ge s2.(st_code) sp pc rs m pc' rs' m'. + forall ge sp pc rs m t pc' rs' m', + exec_instr ge s1.(st_code) sp pc rs m t pc' rs' m' -> + exec_instr ge s2.(st_code) sp pc rs m t pc' rs' m'. Proof. intros. apply exec_instr_extends with s1. @@ -292,9 +294,9 @@ Proof. Qed. Lemma exec_instrs_incr: - forall ge sp pc rs m pc' rs' m', - exec_instrs ge s1.(st_code) sp pc rs m pc' rs' m' -> - exec_instrs ge s2.(st_code) sp pc rs m pc' rs' m'. + forall ge sp pc rs m t pc' rs' m', + exec_instrs ge s1.(st_code) sp pc rs m t pc' rs' m' -> + exec_instrs ge s2.(st_code) sp pc rs m t pc' rs' m'. Proof. intros. apply exec_instrs_extends with s1. @@ -1318,6 +1320,7 @@ forall (P : expr -> Prop) (P0 : condexpr -> Prop) P e -> forall e0 : expr, P e0 -> P (Econdition c e e0)) -> (forall e : expr, P e -> forall e0 : expr, P e0 -> P (Elet e e0)) -> (forall n : nat, P (Eletvar n)) -> + (forall e : expr, P e -> P (Ealloc e)) -> P0 CEtrue -> P0 CEfalse -> (forall (c : condition) (e : exprlist), P1 e -> P0 (CEcond c e)) -> diff --git a/backend/RTLtyping.v b/backend/RTLtyping.v index d15dbb8..33338d3 100644 --- a/backend/RTLtyping.v +++ b/backend/RTLtyping.v @@ -6,7 +6,7 @@ Require Import AST. Require Import Op. Require Import Registers. Require Import RTL. -Require Import union_find. +Require Conventions. (** * The type system *) @@ -38,7 +38,7 @@ Definition regenv := reg -> typ. Section WT_INSTR. Variable env: regenv. -Variable funct: function. +Variable funsig: signature. Inductive wt_instr : instruction -> Prop := | wt_Inop: @@ -72,13 +72,17 @@ Inductive wt_instr : instruction -> Prop := List.map env args = sig.(sig_args) -> env res = match sig.(sig_res) with None => Tint | Some ty => ty end -> wt_instr (Icall sig ros args res s) + | wt_Ialloc: + forall arg res s, + env arg = Tint -> env res = Tint -> + wt_instr (Ialloc arg res s) | wt_Icond: forall cond args s1 s2, List.map env args = type_of_condition cond -> wt_instr (Icond cond args s1 s2) | wt_Ireturn: forall optres, - option_map env optres = funct.(fn_sig).(sig_res) -> + option_map env optres = funsig.(sig_res) -> wt_instr (Ireturn optres). End WT_INSTR. @@ -88,15 +92,27 @@ End WT_INSTR. parameters agree in types with the function signature, and names of parameters are pairwise distinct. *) -Record wt_function (env: regenv) (f: function) : Prop := +Record wt_function (f: function) (env: regenv): Prop := mk_wt_function { wt_params: List.map env f.(fn_params) = f.(fn_sig).(sig_args); wt_norepet: list_norepet f.(fn_params); wt_instrs: - forall pc instr, f.(fn_code)!pc = Some instr -> wt_instr env f instr - }. + forall pc instr, + f.(fn_code)!pc = Some instr -> wt_instr env f.(fn_sig) instr +}. + +Inductive wt_fundef: fundef -> Prop := + | wt_fundef_external: forall ef, + Conventions.sig_external_ok ef.(ef_sig) -> + wt_fundef (External ef) + | wt_function_internal: forall f env, + wt_function f env -> + wt_fundef (Internal f). + +Definition wt_program (p: program): Prop := + forall i f, In (i, f) (prog_funct p) -> wt_fundef f. (** * Type inference *) @@ -109,1022 +125,221 @@ Record wt_function (env: regenv) (f: function) : Prop := each pseudo-register from its uses in the code. We follow the second approach. - The algorithm and its correctness proof in this section were - contributed by Damien Doligez. *) + We delegate the task of determining the type of each pseudo-register + to an external ``oracle'': a function written in Caml and not + proved correct. We verify the returned type environment using + the following Coq code, which we will prove correct. *) -(** ** Type inference algorithm *) +Parameter infer_type_environment: + function -> list (node * instruction) -> option regenv. -Set Implicit Arguments. +(** ** Algorithm to check the correctness of a type environment *) -(** Type inference for RTL is similar to that for simply-typed - lambda-calculus: we use type variables to represent the types - of registers that have not yet been determined to be [Tint] or [Tfloat] - based on their uses. We need exactly one type variable per pseudo-register, - therefore type variables can be conveniently equated with registers. - The type of a register during inference is therefore either - [tTy t] (with [t = Tint] or [t = Tfloat]) for a known type, - or [tReg r] to mean ``the same type as that of register [r]''. *) +Section TYPECHECKING. -Inductive myT : Set := - | tTy : typ -> myT - | tReg : reg -> myT. +Variable funct: function. +Variable env: regenv. -(** The algorithm proceeds by unification of the currently inferred - type for a pseudo-register with the type dictated by its uses. - Unification builds on a ``union-find'' data structure representing - equivalence classes of types (see module [Union_find]). -*) +Lemma typ_eq: forall (t1 t2: typ), {t1=t2} + {t1<>t2}. +Proof. decide equality. Qed. -Module myreg. - Definition T := myT. - Definition eq : forall (x y : T), {x=y}+{x<>y}. - Proof. - destruct x; destruct y; auto; - try (apply right; discriminate); try (apply left; discriminate). - destruct t; destruct t0; - try (apply right; congruence); try (apply left; congruence). - elim (peq r r0); intros. - rewrite a; apply left; apply refl_equal. - apply right; congruence. - Defined. -End myreg. - -Module mymap. - Definition elt := myreg.T. - Definition encode (t : myreg.T) : positive := - match t with - | tTy Tint => xH - | tTy Tfloat => xI xH - | tReg r => xO r - end. - Definition decode (p : positive) : elt := - match p with - | xH => tTy Tint - | xI _ => tTy Tfloat - | xO r => tReg r - end. - - Lemma encode_decode : forall x : myreg.T, decode (encode x) = x. - Proof. - destruct x; try destruct t; simpl; auto. - Qed. - - Lemma encode_injective : - forall (x y : myreg.T), encode x = encode y -> x = y. - Proof. - intros. - unfold encode in H. destruct x; destruct y; try congruence; - try destruct t; try destruct t0; congruence. - Qed. - - Definition T := PTree.t positive. - Definition empty := PTree.empty positive. - Definition get (adr : elt) (t : T) := - option_map decode (PTree.get (encode adr) t). - Definition add (adr dat : elt) (t : T) := - PTree.set (encode adr) (encode dat) t. - - Theorem get_empty : forall (x : elt), get x empty = None. - Proof. - intro. - unfold get. unfold empty. - rewrite PTree.gempty. - simpl; auto. - Qed. - Theorem get_add_1 : - forall (x y : elt) (m : T), get x (add x y m) = Some y. - Proof. - intros. - unfold add. unfold get. - rewrite PTree.gss. - simpl; rewrite encode_decode; auto. - Qed. - Theorem get_add_2 : - forall (x y z : elt) (m : T), z <> x -> get z (add x y m) = get z m. - Proof. - intros. - unfold get. unfold add. - rewrite PTree.gso; auto. - intro. apply H. apply encode_injective. auto. - Qed. -End mymap. - -Module Uf := Unionfind (myreg) (mymap). - -Definition error := Uf.identify Uf.empty (tTy Tint) (tTy Tfloat). - -Fixpoint fold2 (A B : Set) (f : Uf.T -> A -> B -> Uf.T) - (init : Uf.T) (la : list A) (lb : list B) {struct la} - : Uf.T := - match la, lb with - | ha::ta, hb::tb => fold2 f (f init ha hb) ta tb - | nil, nil => init - | _, _ => error - end. +Definition check_reg (r: reg) (ty: typ): bool := + if typ_eq (env r) ty then true else false. -Definition option_fold2 (A B : Set) (f : Uf.T -> A -> B -> Uf.T) - (init : Uf.T) (oa : option A) (ob : option B) - : Uf.T := - match oa, ob with - | Some a, Some b => f init a b - | None, None => init - | _, _ => error - end. - -Definition teq (ty1 ty2 : typ) : bool := - match ty1, ty2 with - | Tint, Tint => true - | Tfloat, Tfloat => true +Fixpoint check_regs (rl: list reg) (tyl: list typ) {struct rl}: bool := + match rl, tyl with + | nil, nil => true + | r1::rs, ty::tys => check_reg r1 ty && check_regs rs tys | _, _ => false end. -Definition type_rtl_arg (u : Uf.T) (r : reg) (t : typ) := - Uf.identify u (tReg r) (tTy t). - -Definition type_rtl_ros (u : Uf.T) (ros : reg+ident) := - match ros with - | inl r => Uf.identify u (tReg r) (tTy Tint) - | inr s => u - end. +Definition check_op (op: operation) (args: list reg) (res: reg): bool := + let (targs, tres) := type_of_operation op in + check_regs args targs && check_reg res tres. -Definition type_of_sig_res (sig : signature) := - match sig.(sig_res) with None => Tint | Some ty => ty end. - -(** This is the core type inference function. The [u] argument is - the current substitution / equivalence classes between types. - An updated set of equivalence classes, reflecting unifications - possibly performed during the type-checking of [i], is returned. - Note that [type_rtl_instr] never fails explicitly. However, - in case of type error (e.g. applying the [Oadd] integer operation - to float registers), the equivalence relation returned will - put [tTy Tint] and [tTy Tfloat] in the same equivalence class. - This fact will propagate through type inference for other instructions, - and be detected at the end of type inference, indicating a typing failure. -*) - -Definition type_rtl_instr (rtyp : option typ) - (u : Uf.T) (_ : positive) (i : instruction) := +Definition check_instr (i: instruction) : bool := match i with - | Inop _ => u - | Iop Omove (r1 :: nil) r0 _ => Uf.identify u (tReg r0) (tReg r1) - | Iop Omove _ _ _ => error - | Iop Oundef nil _ _ => u - | Iop Oundef _ _ _ => error - | Iop op args r0 _ => - let (argtyp, restyp) := type_of_operation op in - let u1 := type_rtl_arg u r0 restyp in - fold2 type_rtl_arg u1 args argtyp - | Iload chunk addr args r0 _ => - let u1 := type_rtl_arg u r0 (type_of_chunk chunk) in - fold2 type_rtl_arg u1 args (type_of_addressing addr) - | Istore chunk addr args r0 _ => - let u1 := type_rtl_arg u r0 (type_of_chunk chunk) in - fold2 type_rtl_arg u1 args (type_of_addressing addr) - | Icall sign ros args r0 _ => - let u1 := type_rtl_ros u ros in - let u2 := type_rtl_arg u1 r0 (type_of_sig_res sign) in - fold2 type_rtl_arg u2 args sign.(sig_args) + | Inop _ => + true + | Iop Omove (arg::nil) res _ => + if typ_eq (env arg) (env res) then true else false + | Iop Omove args res _ => + false + | Iop Oundef nil res _ => + true + | Iop Oundef args res _ => + false + | Iop op args res _ => + check_op op args res + | Iload chunk addr args dst _ => + check_regs args (type_of_addressing addr) + && check_reg dst (type_of_chunk chunk) + | Istore chunk addr args src _ => + check_regs args (type_of_addressing addr) + && check_reg src (type_of_chunk chunk) + | Icall sig ros args res _ => + match ros with inl r => check_reg r Tint | inr s => true end + && check_regs args sig.(sig_args) + && check_reg res (match sig.(sig_res) with None => Tint | Some ty => ty end) + | Ialloc arg res _ => + check_reg arg Tint && check_reg res Tint | Icond cond args _ _ => - fold2 type_rtl_arg u args (type_of_condition cond) - | Ireturn o => option_fold2 type_rtl_arg u o rtyp + check_regs args (type_of_condition cond) + | Ireturn optres => + match optres, funct.(fn_sig).(sig_res) with + | None, None => true + | Some r, Some t => check_reg r t + | _, _ => false + end end. -Definition mk_env (u : Uf.T) (r : reg) := - if myreg.eq (Uf.repr u (tReg r)) (Uf.repr u (tTy Tfloat)) - then Tfloat - else Tint. +Definition check_params_norepet (params: list reg): bool := + if list_norepet_dec Reg.eq params then true else false. -Fixpoint member (x : reg) (l : list reg) {struct l} : bool := - match l with - | nil => false - | y :: rest => if peq x y then true else member x rest +Fixpoint check_instrs (instrs: list (node * instruction)) : bool := + match instrs with + | nil => true + | (pc, i) :: rem => check_instr i && check_instrs rem end. -Fixpoint repet (l : list reg) : bool := - match l with - | nil => false - | x :: rest => member x rest || repet rest - end. +(** ** Correctness of the type-checking algorithm *) -Definition type_rtl_function (f : function) := - let u1 := PTree.fold (type_rtl_instr f.(fn_sig).(sig_res)) - f.(fn_code) Uf.empty in - let u2 := fold2 type_rtl_arg u1 f.(fn_params) f.(fn_sig).(sig_args) in - if repet f.(fn_params) then - None - else - if myreg.eq (Uf.repr u2 (tTy Tint)) (Uf.repr u2 (tTy Tfloat)) - then None - else Some (mk_env u2). - -Unset Implicit Arguments. - -(** ** Correctness proof for type inference *) - -(** General properties of the type equivalence relation. *) - -Definition consistent (u : Uf.T) := - Uf.repr u (tTy Tint) <> Uf.repr u (tTy Tfloat). - -Lemma consistent_not_eq : forall (u : Uf.T) (A : Type) (x y : A), - consistent u -> - (if myreg.eq (Uf.repr u (tTy Tint)) (Uf.repr u (tTy Tfloat)) then x else y) - = y. - Proof. - intros. - unfold consistent in H. - destruct (myreg.eq (Uf.repr u (tTy Tint)) (Uf.repr u (tTy Tfloat))); - congruence. - Qed. - -Lemma equal_eq : forall (t : myT) (A : Type) (x y : A), - (if myreg.eq t t then x else y) = x. - Proof. - intros. - destruct (myreg.eq t t); congruence. - Qed. - -Lemma error_inconsistent : forall (A : Prop), consistent error -> A. - Proof. - intros. - absurd (consistent error); auto. - intro. - unfold error in H. unfold consistent in H. - rewrite Uf.sameclass_identify_1 in H. - congruence. - Qed. - -Lemma teq_correct : forall (t1 t2 : typ), teq t1 t2 = true -> t1 = t2. - Proof. - intros; destruct t1; destruct t2; try simpl in H; congruence. - Qed. - -Definition included (u1 u2 : Uf.T) : Prop := - forall (e1 e2: myT), - Uf.repr u1 e1 = Uf.repr u1 e2 -> Uf.repr u2 e1 = Uf.repr u2 e2. - -Lemma included_refl : - forall (e : Uf.T), included e e. - Proof. - unfold included. auto. - Qed. - -Lemma included_trans : - forall (e1 e2 e3 : Uf.T), - included e3 e2 -> included e2 e1 -> included e3 e1. - Proof. - unfold included. auto. - Qed. - -Lemma included_consistent : - forall (u1 u2 : Uf.T), - included u1 u2 -> consistent u2 -> consistent u1. - Proof. - unfold consistent. unfold included. - intros. - intro. apply H0. apply H. - auto. - Qed. - -Lemma included_identify : - forall (u : Uf.T) (t1 t2 : myT), included u (Uf.identify u t1 t2). - Proof. - unfold included. - intros. - apply Uf.sameclass_identify_2; auto. - Qed. - -Lemma type_arg_correct_1 : - forall (u : Uf.T) (r : reg) (t : typ), - consistent (type_rtl_arg u r t) - -> Uf.repr (type_rtl_arg u r t) (tReg r) - = Uf.repr (type_rtl_arg u r t) (tTy t). - Proof. - intros. - unfold type_rtl_arg. - rewrite Uf.sameclass_identify_1. - auto. - Qed. - -Lemma type_arg_correct : - forall (u : Uf.T) (r : reg) (t : typ), - consistent (type_rtl_arg u r t) -> mk_env (type_rtl_arg u r t) r = t. - Proof. - intros. - unfold mk_env. - rewrite type_arg_correct_1. - destruct t. - apply consistent_not_eq; auto. - destruct (myreg.eq (Uf.repr (type_rtl_arg u r Tfloat) (tTy Tfloat))); - congruence. - auto. - Qed. - -Lemma type_arg_included : - forall (u : Uf.T) (r : reg) (t : typ), included u (type_rtl_arg u r t). - Proof. - intros. - unfold type_rtl_arg. - apply included_identify. - Qed. - -Lemma type_arg_extends : - forall (u : Uf.T) (r : reg) (t : typ), - consistent (type_rtl_arg u r t) -> consistent u. - Proof. - intros. - apply included_consistent with (u2 := type_rtl_arg u r t). - apply type_arg_included. - auto. - Qed. - -Lemma type_args_included : - forall (l1 : list reg) (l2 : list typ) (u : Uf.T), - consistent (fold2 type_rtl_arg u l1 l2) - -> included u (fold2 type_rtl_arg u l1 l2). - Proof. - induction l1; intros; destruct l2. - simpl in H; simpl; apply included_refl. - simpl in H. apply error_inconsistent. auto. - simpl in H. apply error_inconsistent. auto. - simpl. - simpl in H. - apply included_trans with (e2 := type_rtl_arg u a t). - apply type_arg_included. - apply IHl1. - auto. - Qed. - -Lemma type_args_extends : - forall (l1 : list reg) (l2 : list typ) (u : Uf.T), - consistent (fold2 type_rtl_arg u l1 l2) -> consistent u. - Proof. - intros. - apply (included_consistent _ _ (type_args_included l1 l2 u H)). - auto. - Qed. - -Lemma type_args_correct : - forall (l1 : list reg) (l2 : list typ) (u : Uf.T), - consistent (fold2 type_rtl_arg u l1 l2) - -> map (mk_env (fold2 type_rtl_arg u l1 l2)) l1 = l2. - Proof. - induction l1. - intros. - destruct l2. - unfold map; simpl; auto. - simpl in H; apply error_inconsistent; auto. - intros. - destruct l2. - simpl in H; apply error_inconsistent; auto. - simpl. - simpl in H. - rewrite (IHl1 l2 (type_rtl_arg u a t) H). - unfold mk_env. - destruct t. - rewrite (type_args_included _ _ _ H (tReg a) (tTy Tint)). - rewrite consistent_not_eq; auto. - apply type_arg_correct_1. - apply type_args_extends with (l1 := l1) (l2 := l2); auto. - rewrite (type_args_included _ _ _ H (tReg a) (tTy Tfloat)). - rewrite equal_eq; auto. - apply type_arg_correct_1. - apply type_args_extends with (l1 := l1) (l2 := l2); auto. - Qed. - -(** Correctness of [wt_params]. *) - -Lemma type_rtl_function_params : - forall (f: function) (env: regenv), - type_rtl_function f = Some env - -> List.map env f.(fn_params) = f.(fn_sig).(sig_args). - Proof. - destruct f; unfold type_rtl_function; simpl. - destruct (repet fn_params); simpl; intros; try congruence. - pose (u := PTree.fold (type_rtl_instr (sig_res fn_sig)) fn_code Uf.empty). - fold u in H. - cut (consistent (fold2 type_rtl_arg u fn_params (sig_args fn_sig))). - intro. - pose (R := Uf.repr (fold2 type_rtl_arg u fn_params (sig_args fn_sig))). - fold R in H. - destruct (myreg.eq (R (tTy Tint)) (R (tTy Tfloat))). - congruence. - injection H. - intro. - rewrite <- H1. - apply type_args_correct. - auto. - intro. - rewrite H0 in H. - rewrite equal_eq in H. - congruence. - Qed. - -(** Correctness of [wt_norepet]. *) - -Lemma member_correct : - forall (l : list reg) (a : reg), member a l = false -> ~In a l. - Proof. - induction l; simpl; intros; try tauto. - destruct (peq a0 a); simpl; try congruence. - intro. destruct H0; try congruence. - generalize H0; apply IHl; auto. - Qed. - -Lemma repet_correct : - forall (l : list reg), repet l = false -> list_norepet l. - Proof. - induction l; simpl; intros. - exact (list_norepet_nil reg). - elim (orb_false_elim (member a l) (repet l) H); intros. - apply list_norepet_cons. - apply member_correct; auto. - apply IHl; auto. - Qed. - -Lemma type_rtl_function_norepet : - forall (f: function) (env: regenv), - type_rtl_function f = Some env - -> list_norepet f.(fn_params). - Proof. - destruct f; unfold type_rtl_function; simpl. - intros. cut (repet fn_params = false). - intro. apply repet_correct. auto. - destruct (repet fn_params); congruence. - Qed. - -(** Correctness of [wt_instrs]. *) - -Lemma step1 : - forall (f : function) (env : regenv), - type_rtl_function f = Some env - -> exists u2 : Uf.T, - included (PTree.fold (type_rtl_instr f.(fn_sig).(sig_res)) - f.(fn_code) Uf.empty) - u2 - /\ env = mk_env u2 - /\ consistent u2. - Proof. - intros f env. - pose (u1 := (PTree.fold (type_rtl_instr f.(fn_sig).(sig_res)) - f.(fn_code) Uf.empty)). - fold u1. - unfold type_rtl_function. - intros. - destruct (repet f.(fn_params)). - congruence. - fold u1 in H. - pose (u2 := (fold2 type_rtl_arg u1 f.(fn_params) f.(fn_sig).(sig_args))). - fold u2 in H. - exists u2. - caseEq (myreg.eq (Uf.repr u2 (tTy Tint)) (Uf.repr u2 (tTy Tfloat))). - intros. - rewrite e in H. - rewrite equal_eq in H. - congruence. - intros. - rewrite consistent_not_eq in H. - apply conj. - unfold u2. - apply type_args_included. - auto. - apply conj; auto. - congruence. - auto. - Qed. - -Lemma let_fold_args_res : - forall (u : Uf.T) (l : list reg) (r : reg) (e : list typ * typ), - (let (argtyp, restyp) := e in - fold2 type_rtl_arg (type_rtl_arg u r restyp) l argtyp) - = fold2 type_rtl_arg (type_rtl_arg u r (snd e)) l (fst e). - Proof. - intros. rewrite (surjective_pairing e). simpl. auto. - Qed. - -Lemma type_args_res_included : - forall (l1 : list reg) (l2 : list typ) (u : Uf.T) (r : reg) (t : typ), - consistent (fold2 type_rtl_arg (type_rtl_arg u r t) l1 l2) - -> included u (fold2 type_rtl_arg (type_rtl_arg u r t) l1 l2). - Proof. - intros. - apply included_trans with (e2 := type_rtl_arg u r t). - apply type_arg_included. - apply type_args_included; auto. - Qed. - -Lemma type_args_res_ros_included : - forall (l1 : list reg) (l2 : list typ) (u : Uf.T) (r : reg) (t : typ) - (ros : reg+ident), - consistent (fold2 type_rtl_arg (type_rtl_arg (type_rtl_ros u ros) r t) l1 l2) - -> included u (fold2 type_rtl_arg (type_rtl_arg (type_rtl_ros u ros) r t) l1 l2). +Lemma check_reg_correct: + forall r ty, check_reg r ty = true -> env r = ty. Proof. - intros. - apply included_trans with (e2 := type_rtl_ros u ros). - unfold type_rtl_ros; destruct ros. - apply included_identify. - apply included_refl. - apply type_args_res_included; auto. + unfold check_reg; intros. + destruct (typ_eq (env r) ty). auto. discriminate. Qed. -Lemma type_instr_included : - forall (p : positive) (i : instruction) (u : Uf.T) (res_ty : option typ), - consistent (type_rtl_instr res_ty u p i) - -> included u (type_rtl_instr res_ty u p i). - Proof. - intros. - destruct i; simpl; simpl in H; try apply type_args_res_included; auto. - apply included_refl; auto. - destruct o; simpl; simpl in H; try apply type_args_res_included; auto. - destruct l; simpl; simpl in H; auto. - apply error_inconsistent; auto. - destruct l; simpl; simpl in H; auto. - apply included_identify. - apply error_inconsistent; auto. - destruct l; simpl; simpl in H; auto. - apply included_refl. - apply error_inconsistent; auto. - apply type_args_res_ros_included; auto. - apply type_args_included; auto. - destruct res_ty; destruct o; simpl; simpl in H; - try (apply error_inconsistent; auto; fail). - apply type_arg_included. - apply included_refl. - Qed. - -Lemma type_instrs_extends : - forall (l : list (positive * instruction)) (u : Uf.T) (res_ty : option typ), - consistent - (fold_left (fun v p => type_rtl_instr res_ty v (fst p) (snd p)) l u) - -> consistent u. +Lemma check_regs_correct: + forall rl tyl, check_regs rl tyl = true -> List.map env rl = tyl. Proof. - induction l; simpl; intros. - auto. - apply included_consistent - with (u2 := (type_rtl_instr res_ty u (fst a) (snd a))). - apply type_instr_included. - apply IHl with (res_ty := res_ty); auto. - apply IHl with (res_ty := res_ty); auto. + induction rl; destruct tyl; simpl; intros. + auto. discriminate. discriminate. + elim (andb_prop _ _ H); intros. + rewrite (check_reg_correct _ _ H0). rewrite (IHrl tyl H1). auto. Qed. -Lemma type_instrs_included : - forall (l : list (positive * instruction)) (u : Uf.T) (res_ty : option typ), - consistent - (fold_left (fun v p => type_rtl_instr res_ty v (fst p) (snd p)) l u) - -> included u - (fold_left (fun v p => type_rtl_instr res_ty v (fst p) (snd p)) l u). - Proof. - induction l; simpl; intros. - apply included_refl; auto. - apply included_trans with (e2 := (type_rtl_instr res_ty u (fst a) (snd a))). - apply type_instr_included. - apply type_instrs_extends with (res_ty := res_ty) (l := l); auto. - apply IHl; auto. - Qed. - -Lemma step2 : - forall (res_ty : option typ) (c : code) (u0 : Uf.T), - consistent (PTree.fold (type_rtl_instr res_ty) c u0) -> - forall (pc : positive) (i : instruction), - c!pc = Some i - -> exists u : Uf.T, - consistent (type_rtl_instr res_ty u pc i) - /\ included (type_rtl_instr res_ty u pc i) - (PTree.fold (type_rtl_instr res_ty) c u0). - Proof. - intros. - rewrite PTree.fold_spec. - rewrite PTree.fold_spec in H. - pose (H1 := PTree.elements_correct _ _ H0). - generalize H. clear H. - generalize u0. clear u0. - generalize H1. clear H1. - induction (PTree.elements c). - intros. - absurd (In (pc, i) nil). - apply in_nil. - auto. - intros. - simpl in H. - elim H1. - intro. - rewrite H2 in H. - simpl in H. - rewrite H2. simpl. - exists u0. - apply conj. - apply type_instrs_extends with (res_ty := res_ty) (l := l). - auto. - apply type_instrs_included. - auto. - intro. - simpl. - apply IHl. - auto. - auto. - Qed. - -Definition mapped (u : Uf.T) (r : reg) := - Uf.repr u (tReg r) = Uf.repr u (tTy Tfloat) - \/ Uf.repr u (tReg r) = Uf.repr u (tTy Tint). - -Definition definite (u : Uf.T) (i : instruction) := - match i with - | Inop _ => True - | Iop Omove (r1 :: nil) r0 _ => Uf.repr u (tReg r1) = Uf.repr u (tReg r0) - | Iop Oundef _ _ _ => True - | Iop _ args r0 _ => - mapped u r0 /\ forall r : reg, In r args -> mapped u r - | Iload _ _ args r0 _ => - mapped u r0 /\ forall r : reg, In r args -> mapped u r - | Istore _ _ args r0 _ => - mapped u r0 /\ forall r : reg, In r args -> mapped u r - | Icall _ ros args r0 _ => - match ros with inl r => mapped u r | _ => True end - /\ mapped u r0 /\ forall r : reg, In r args -> mapped u r - | Icond _ args _ _ => - forall r : reg, In r args -> mapped u r - | Ireturn None => True - | Ireturn (Some r) => mapped u r - end. - -Lemma type_arg_complete : - forall (u : Uf.T) (r : reg) (t : typ), - mapped (type_rtl_arg u r t) r. -Proof. - intros. - unfold type_rtl_arg. - unfold mapped. - destruct t. - right; apply Uf.sameclass_identify_1. - left; apply Uf.sameclass_identify_1. -Qed. - -Lemma type_arg_mapped : - forall (u : Uf.T) (r r0 : reg) (t : typ), - mapped u r0 -> mapped (type_rtl_arg u r t) r0. -Proof. - unfold mapped. - unfold type_rtl_arg. - intros. - elim H; intros. - left; apply Uf.sameclass_identify_2; auto. - right; apply Uf.sameclass_identify_2; auto. -Qed. - -Lemma type_args_mapped : - forall (lr : list reg) (lt : list typ) (u : Uf.T) (r : reg), - consistent (fold2 type_rtl_arg u lr lt) -> - mapped u r -> - mapped (fold2 type_rtl_arg u lr lt) r. +Lemma check_op_correct: + forall op args res, + check_op op args res = true -> + (List.map env args, env res) = type_of_operation op. Proof. - induction lr; simpl; intros. - destruct lt; simpl; auto; try (apply error_inconsistent; auto; fail). - destruct lt; simpl; auto; try (apply error_inconsistent; auto; fail). - apply IHlr. + unfold check_op; intros. + destruct (type_of_operation op) as [targs tres]. + elim (andb_prop _ _ H); intros. + rewrite (check_regs_correct _ _ H0). + rewrite (check_reg_correct _ _ H1). auto. - apply type_arg_mapped; auto. -Qed. - -Lemma type_args_complete : - forall (lr : list reg) (lt : list typ) (u : Uf.T), - consistent (fold2 type_rtl_arg u lr lt) - -> forall r, (In r lr -> mapped (fold2 type_rtl_arg u lr lt) r). -Proof. - induction lr; simpl; intros. - destruct lt; simpl; try tauto. - destruct lt; simpl. - apply error_inconsistent; auto. - elim H0; intros. - rewrite H1. - rewrite H1 in H. - apply type_args_mapped; auto. - apply type_arg_complete. - apply IHlr; auto. -Qed. - -Lemma type_res_complete : - forall (u : Uf.T) (lr : list reg) (lt : list typ) (r : reg) (t : typ), - consistent (fold2 type_rtl_arg (type_rtl_arg u r t) lr lt) - -> mapped (fold2 type_rtl_arg (type_rtl_arg u r t) lr lt) r. -Proof. - intros. - apply type_args_mapped; auto. - apply type_arg_complete. Qed. -Lemma type_args_res_complete : - forall (u : Uf.T) (lr : list reg) (lt : list typ) (r : reg) (t : typ), - consistent (fold2 type_rtl_arg (type_rtl_arg u r t) lr lt) - -> mapped (fold2 type_rtl_arg (type_rtl_arg u r t) lr lt) r - /\ forall rr, (In rr lr -> mapped (fold2 type_rtl_arg (type_rtl_arg u r t) - lr lt) - rr). +Lemma check_instr_correct: + forall i, check_instr i = true -> wt_instr env funct.(fn_sig) i. Proof. - intros. - apply conj. - apply type_res_complete; auto. - apply type_args_complete; auto. + unfold check_instr; intros; destruct i. + (* nop *) + constructor. + (* op *) + destruct o; + try (apply wt_Iop; [congruence|congruence|apply check_op_correct;auto]). + destruct l; try discriminate. destruct l; try discriminate. + destruct (typ_eq (env r0) (env r)); try discriminate. + apply wt_Iopmove; auto. + destruct l; try discriminate. + apply wt_Iopundef. + (* load *) + elim (andb_prop _ _ H); intros. + constructor. apply check_regs_correct; auto. apply check_reg_correct; auto. + (* store *) + elim (andb_prop _ _ H); intros. + constructor. apply check_regs_correct; auto. apply check_reg_correct; auto. + (* call *) + elim (andb_prop _ _ H); clear H; intros. + elim (andb_prop _ _ H); clear H; intros. + constructor. + destruct s0; auto. apply check_reg_correct; auto. + apply check_regs_correct; auto. + apply check_reg_correct; auto. + (* alloc *) + elim (andb_prop _ _ H); intros. + constructor; apply check_reg_correct; auto. + (* cond *) + constructor. apply check_regs_correct; auto. + (* return *) + constructor. + destruct o; simpl; destruct funct.(fn_sig).(sig_res); try discriminate. + rewrite (check_reg_correct _ _ H); auto. + auto. Qed. -Lemma type_ros_complete : - forall (u : Uf.T) (lr : list reg) (lt : list typ) (r r1 : reg) (t : typ), - consistent (fold2 type_rtl_arg (type_rtl_arg - (type_rtl_ros u (inl ident r1)) r t) lr lt) - -> - mapped (fold2 type_rtl_arg (type_rtl_arg - (type_rtl_ros u (inl ident r1)) r t) lr lt) r1. +Lemma check_instrs_correct: + forall instrs, + check_instrs instrs = true -> + forall pc i, In (pc, i) instrs -> wt_instr env funct.(fn_sig) i. Proof. - intros. - apply type_args_mapped; auto. - apply type_arg_mapped. - unfold type_rtl_ros. - unfold mapped. - right. - apply Uf.sameclass_identify_1; auto. + induction instrs; simpl; intros. + elim H0. + destruct a as [pc' i']. elim (andb_prop _ _ H); clear H; intros. + elim H0; intro. + inversion H2; subst pc' i'. apply check_instr_correct; auto. + eauto. Qed. -Lemma type_res_correct : - forall (u : Uf.T) (lr : list reg) (lt : list typ) (r : reg) (t : typ), - consistent (fold2 type_rtl_arg (type_rtl_arg u r t) lr lt) - -> mk_env (fold2 type_rtl_arg (type_rtl_arg u r t) lr lt) r = t. -Proof. - intros. - unfold mk_env. - rewrite (type_args_included _ _ _ H (tReg r) (tTy t)). - destruct t. - apply consistent_not_eq; auto. - apply equal_eq; auto. - unfold type_rtl_arg; apply Uf.sameclass_identify_1; auto. -Qed. +End TYPECHECKING. -Lemma type_ros_correct : - forall (u : Uf.T) (lr : list reg) (lt : list typ) (r r1 : reg) (t : typ), - consistent (fold2 type_rtl_arg (type_rtl_arg - (type_rtl_ros u (inl ident r1)) r t) lr lt) - -> - mk_env (fold2 type_rtl_arg (type_rtl_arg - (type_rtl_ros u (inl ident r1)) r t) lr lt) r1 - = Tint. -Proof. - intros. - unfold mk_env. - rewrite (type_args_included _ _ _ H (tReg r1) (tTy Tint)). - apply consistent_not_eq; auto. - rewrite (type_arg_included (type_rtl_ros u (inl ident r1)) r t (tReg r1) (tTy Tint)). - auto. - simpl. - apply Uf.sameclass_identify_1; auto. -Qed. - -Lemma step3 : - forall (u : Uf.T) (f : function) (c : code) (i : instruction) (pc : positive), - c!pc = Some i -> - consistent (type_rtl_instr f.(fn_sig).(sig_res) u pc i) - -> wt_instr (mk_env (type_rtl_instr f.(fn_sig).(sig_res) u pc i)) f i - /\ definite (type_rtl_instr f.(fn_sig).(sig_res) u pc i) i. - Proof. - Opaque type_rtl_arg. - intros. - destruct i; simpl in H0; simpl. - (* Inop *) - apply conj; auto. apply wt_Inop. - (* Iop *) - destruct o; - try (apply conj; [ - apply wt_Iop; try congruence; simpl; - rewrite (type_args_correct _ _ _ H0); - rewrite (type_res_correct _ _ _ _ _ H0); - auto - |apply (type_args_res_complete _ _ _ _ _ H0)]). - (* Omove *) - destruct l; [apply error_inconsistent; auto | idtac]. - destruct l; [idtac | apply error_inconsistent; auto]. - apply conj. - apply wt_Iopmove. - simpl. - unfold mk_env. - rewrite Uf.sameclass_identify_1. - congruence. - simpl. - rewrite Uf.sameclass_identify_1; congruence. - (* Oundef *) - destruct l; [idtac | apply error_inconsistent; auto]. - apply conj. apply wt_Iopundef. - unfold definite. auto. - (* Iload *) - apply conj. - apply wt_Iload. - rewrite (type_args_correct _ _ _ H0); auto. - rewrite (type_res_correct _ _ _ _ _ H0); auto. - simpl; apply (type_args_res_complete _ _ _ _ _ H0). - (* IStore *) - apply conj. - apply wt_Istore. - rewrite (type_args_correct _ _ _ H0); auto. - rewrite (type_res_correct _ _ _ _ _ H0); auto. - simpl; apply (type_args_res_complete _ _ _ _ _ H0). - (* Icall *) - apply conj. - apply wt_Icall. - destruct s0; auto. apply type_ros_correct. auto. - apply type_args_correct. auto. - fold (type_of_sig_res s). apply type_res_correct. auto. - destruct s0. - apply conj. - apply type_ros_complete. auto. - apply type_args_res_complete. auto. - apply conj; auto. - apply type_args_res_complete. auto. - (* Icond *) - apply conj. - apply wt_Icond. - apply (type_args_correct _ _ _ H0). - simpl; apply (type_args_complete _ _ _ H0). - (* Ireturn *) - destruct o; simpl. - apply conj. - apply wt_Ireturn. - destruct f.(fn_sig).(sig_res); simpl; simpl in H0. - rewrite type_arg_correct; auto. - apply error_inconsistent; auto. - destruct f.(fn_sig).(sig_res); simpl; simpl in H0. - apply type_arg_complete. - apply error_inconsistent; auto. - apply conj; auto. apply wt_Ireturn. - destruct f.(fn_sig).(sig_res); simpl; simpl in H0. - apply error_inconsistent; auto. - congruence. - Transparent type_rtl_arg. - Qed. - -Lemma mapped_included_consistent : - forall (u1 u2 : Uf.T) (r : reg), - mapped u1 r -> - included u1 u2 -> - consistent u2 -> - mk_env u2 r = mk_env u1 r. -Proof. - intros. - unfold mk_env. - unfold mapped in H. - elim H; intros; rewrite H2; rewrite (H0 _ _ H2). - rewrite equal_eq; rewrite equal_eq; auto. - rewrite (consistent_not_eq u2). - rewrite (consistent_not_eq u1). - auto. - apply included_consistent with (u2 := u2). - auto. - auto. - auto. -Qed. +(** ** The type inference function **) -Lemma mapped_list_included : - forall (u1 u2 : Uf.T) (lr : list reg), - (forall r, In r lr -> mapped u1 r) -> - included u1 u2 -> - consistent u2 -> - map (mk_env u2) lr = map (mk_env u1) lr. -Proof. - induction lr; simpl; intros. - auto. - rewrite (mapped_included_consistent u1 u2 a). - rewrite IHlr; auto. - apply (H a); intros. - left; auto. - auto. - auto. -Qed. +Definition type_function (f: function): option regenv := + let instrs := PTree.elements f.(fn_code) in + match infer_type_environment f instrs with + | None => None + | Some env => + if check_regs env f.(fn_params) f.(fn_sig).(sig_args) + && check_params_norepet f.(fn_params) + && check_instrs f env instrs + then Some env else None + end. -Lemma included_mapped : - forall (u1 u2 : Uf.T) (r : reg), - included u1 u2 -> - mapped u1 r -> - mapped u2 r. -Proof. - unfold mapped. - intros. - elim H0; intros. - left; rewrite (H _ _ H1); auto. - right; rewrite (H _ _ H1); auto. -Qed. +Definition type_external_function (ef: external_function): bool := + List.fold_right + (fun l b => match l with Locations.S _ => false | Locations.R _ => b end) + true (Conventions.loc_arguments ef.(ef_sig)). -Lemma included_mapped_forall : - forall (u1 u2 : Uf.T) (r : reg) (l : list reg), - included u1 u2 -> - mapped u1 r /\ (forall r, In r l -> mapped u1 r) -> - mapped u2 r /\ (forall r, In r l -> mapped u2 r). +Lemma type_function_correct: + forall f env, + type_function f = Some env -> + wt_function f env. Proof. - intros. - elim H0; intros. - apply conj. - apply (included_mapped _ _ r H); auto. - intros. - apply (included_mapped _ _ r0 H). - apply H2; auto. + unfold type_function; intros until env. + set (instrs := PTree.elements f.(fn_code)). + case (infer_type_environment f instrs). + intro env'. + caseEq (check_regs env' f.(fn_params) f.(fn_sig).(sig_args)); intro; simpl; try congruence. + caseEq (check_params_norepet f.(fn_params)); intro; simpl; try congruence. + caseEq (check_instrs f env' instrs); intro; simpl; try congruence. + intro EQ; inversion EQ; subst env'. + constructor. + apply check_regs_correct; auto. + unfold check_params_norepet in H0. + destruct (list_norepet_dec Reg.eq (fn_params f)). auto. discriminate. + intros. eapply check_instrs_correct. eauto. + unfold instrs. apply PTree.elements_correct. eauto. + congruence. Qed. -Lemma definite_included : - forall (u1 u2 : Uf.T) (i : instruction), - included u1 u2 -> definite u1 i -> definite u2 i. +Lemma type_external_function_correct: + forall ef, + type_external_function ef = true -> + Conventions.sig_external_ok ef.(ef_sig). Proof. - unfold definite. - intros. - destruct i; try apply (included_mapped_forall _ _ _ _ H H0); auto. - destruct o; try apply (included_mapped_forall _ _ _ _ H H0); auto. - destruct l; auto. - apply (included_mapped_forall _ _ _ _ H H0). - destruct l; auto. - apply (included_mapped_forall _ _ _ _ H H0). - destruct s0; auto. - elim H0; intros. - apply conj. - apply (included_mapped _ _ _ H H1). - apply (included_mapped_forall _ _ _ _ H H2). - elim H0; intros. - apply conj; auto. - apply (included_mapped_forall _ _ _ _ H H2). - intros. - apply (included_mapped _ _ _ H (H0 r H1)). - destruct o; auto. - apply (included_mapped _ _ _ H H0). + intro ef. unfold type_external_function, Conventions.sig_external_ok. + generalize (Conventions.loc_arguments (ef_sig ef)). + induction l; simpl. + tauto. + destruct a. intros. firstorder congruence. + congruence. Qed. -Lemma step4 : - forall (f : function) (u1 u3 : Uf.T) (i : instruction), - included u3 u1 -> - wt_instr (mk_env u3) f i -> - definite u3 i -> - consistent u1 -> - wt_instr (mk_env u1) f i. - Proof. - intros f u1 u3 i H1 H H0 X. - destruct H; try simpl in H0; try (elim H0; intros). - apply wt_Inop. - apply wt_Iopmove. unfold mk_env. rewrite (H1 _ _ H0). auto. - apply wt_Iopundef. - apply wt_Iop; auto. - destruct op; try congruence; simpl; simpl in H3; - simpl in H0; elim H0; intros; rewrite (mapped_included_consistent _ _ _ H4 H1 X); - rewrite (mapped_list_included _ _ _ H5 H1); auto. - apply wt_Iload. - rewrite (mapped_list_included _ _ _ H4 H1); auto. - rewrite (mapped_included_consistent _ _ _ H3 H1 X). auto. - apply wt_Istore. - rewrite (mapped_list_included _ _ _ H4 H1); auto. - rewrite (mapped_included_consistent _ _ _ H3 H1 X). auto. - elim H5; intros; destruct ros; apply wt_Icall. - rewrite (mapped_included_consistent _ _ _ H4 H1 X); auto. - rewrite (mapped_list_included _ _ _ H7 H1); auto. - rewrite (mapped_included_consistent _ _ _ H6 H1 X); auto. - auto. - rewrite (mapped_list_included _ _ _ H7 H1); auto. - rewrite (mapped_included_consistent _ _ _ H6 H1 X); auto. - apply wt_Icond. rewrite (mapped_list_included _ _ _ H0 H1); auto. - apply wt_Ireturn. - destruct optres; destruct f.(fn_sig).(sig_res); - simpl in H; simpl; try congruence. - rewrite (mapped_included_consistent _ _ _ H0 H1 X); auto. - Qed. - -Lemma type_rtl_function_instrs : - forall (f: function) (env: regenv), - type_rtl_function f = Some env - -> forall pc i, f.(fn_code)!pc = Some i -> wt_instr env f i. - Proof. - intros. - elim (step1 _ _ H). - intros. - elim H1. - intros. - elim H3. - intros. - rewrite H4. - elim (step2 _ _ _ (included_consistent _ _ H2 H5) _ _ H0). - intros. - elim H6. intros. - elim (step3 x0 f _ _ _ H0); auto. intros. - apply (step4 f _ _ i H2); auto. - apply (step4 _ _ _ _ H8 H9 H10). - apply (included_consistent _ _ H2); auto. - apply (definite_included _ _ _ H8 H10); auto. - Qed. - -(** Combining the sub-proofs. *) - -Theorem type_rtl_function_correct: - forall (f: function) (env: regenv), - type_rtl_function f = Some env -> wt_function env f. - Proof. - intros. - exact (mk_wt_function env f (type_rtl_function_params f _ H) - (type_rtl_function_norepet f _ H) - (type_rtl_function_instrs f _ H)). - Qed. - -Definition wt_program (p: program) : Prop := - forall i f, In (i, f) (prog_funct p) -> type_rtl_function f <> None. - (** * Type preservation during evaluation *) (** The type system for RTL is not sound in that it does not guarantee @@ -1143,6 +358,7 @@ Require Import Globalenvs. Require Import Values. Require Import Mem. Require Import Integers. +Require Import Events. Definition wt_regset (env: regenv) (rs: regset) : Prop := forall r, Val.has_type (rs#r) (env r). @@ -1180,6 +396,14 @@ Proof. apply wt_regset_assign; auto. Qed. +Lemma wt_event_match: + forall ef args t res, + event_match ef args t res -> + Val.has_type res (proj_sig_res ef.(ef_sig)). +Proof. + induction 1. inversion H0; exact I. +Qed. + Section SUBJECT_REDUCTION. Variable p: program. @@ -1190,26 +414,24 @@ Let ge := Genv.globalenv p. Definition exec_instr_subject_reduction (c: code) (sp: val) - (pc: node) (rs: regset) (m: mem) + (pc: node) (rs: regset) (m: mem) (t: trace) (pc': node) (rs': regset) (m': mem) : Prop := forall env f (CODE: c = fn_code f) - (WT_FN: wt_function env f) + (WT_FN: wt_function f env) (WT_RS: wt_regset env rs), wt_regset env rs'. Definition exec_function_subject_reduction - (f: function) (args: list val) (m: mem) (res: val) (m': mem) : Prop := - forall env, - wt_function env f -> - Val.has_type_list args f.(fn_sig).(sig_args) -> - Val.has_type res - (match f.(fn_sig).(sig_res) with None => Tint | Some ty => ty end). + (f: fundef) (args: list val) (m: mem) (t: trace) (res: val) (m': mem) : Prop := + wt_fundef f -> + Val.has_type_list args (sig_args (funsig f)) -> + Val.has_type res (proj_sig_res (funsig f)). Lemma subject_reduction: - forall f args m res m', - exec_function ge f args m res m' -> - exec_function_subject_reduction f args m res m'. + forall f args m t res m', + exec_function ge f args m t res m' -> + exec_function_subject_reduction f args m t res m'. Proof. apply (exec_function_ind_3 ge exec_instr_subject_reduction @@ -1217,7 +439,7 @@ Proof. exec_function_subject_reduction); intros; red; intros; try (rewrite CODE in H; - generalize (wt_instrs env _ WT_FN pc _ H); + generalize (wt_instrs _ _ WT_FN pc _ H); intro WT_INSTR; inversion WT_INSTR). @@ -1233,7 +455,7 @@ Proof. apply wt_regset_assign. auto. replace (env res) with (snd (type_of_operation op)). - apply type_of_operation_sound with function ge rs##args sp; auto. + apply type_of_operation_sound with fundef ge rs##args sp; auto. rewrite <- H7. reflexivity. apply wt_regset_assign. auto. rewrite H8. @@ -1241,37 +463,39 @@ Proof. assumption. - apply wt_regset_assign. auto. rewrite H11. rewrite H1. - assert (type_rtl_function f <> None). + apply wt_regset_assign. auto. rewrite H11. rewrite <- H1. + assert (wt_fundef f). destruct ros; simpl in H0. - pattern f. apply Genv.find_funct_prop with function p (rs#r). + pattern f. apply Genv.find_funct_prop with fundef p (rs#r). exact wt_p. exact H0. caseEq (Genv.find_symbol ge i); intros; rewrite H12 in H0. - pattern f. apply Genv.find_funct_ptr_prop with function p b. + pattern f. apply Genv.find_funct_ptr_prop with fundef p b. exact wt_p. exact H0. discriminate. - assert (exists env1, wt_function env1 f). - caseEq (type_rtl_function f); intros; try congruence. - exists t. apply type_rtl_function_correct; auto. - elim H13; intros env1 WT_FN1. - eapply H3. eexact WT_FN1. rewrite <- H1. rewrite <- H10. + eapply H3. auto. rewrite H1. rewrite <- H10. apply wt_regset_list; auto. + apply wt_regset_assign. auto. rewrite H6; exact I. + assumption. assumption. assumption. eauto. eauto. + inversion H4; subst f0. assert (WT_INIT: wt_regset env (init_regs args (fn_params f))). - apply wt_init_regs. rewrite (wt_params env f H4). assumption. - generalize (H1 env f (refl_equal (fn_code f)) H4 WT_INIT). + apply wt_init_regs. rewrite (wt_params _ _ H7). assumption. + generalize (H1 env f (refl_equal (fn_code f)) H7 WT_INIT). intro WT_RS. - generalize (wt_instrs env _ H4 pc _ H2). + generalize (wt_instrs _ _ H7 pc _ H2). intro WT_INSTR; inversion WT_INSTR. - destruct or; simpl in H3; simpl in H7; rewrite <- H7. + unfold proj_sig_res; simpl. + destruct or; simpl in H3; simpl in H8; rewrite <- H8. rewrite H3. apply WT_RS. rewrite H3. simpl; auto. + + simpl. eapply wt_event_match; eauto. Qed. End SUBJECT_REDUCTION. diff --git a/backend/Stacking.v b/backend/Stacking.v index 1f0c454..85ac933 100644 --- a/backend/Stacking.v +++ b/backend/Stacking.v @@ -186,6 +186,8 @@ Definition transl_instr Mstore chunk (transl_addr fe addr) args src :: k | Lcall sig ros => Mcall sig ros :: k + | Lalloc => + Malloc :: k | Llabel lbl => Mlabel lbl :: k | Lgoto lbl => @@ -222,5 +224,8 @@ Definition transf_function (f: Linear.function) : option Mach.function := f.(Linear.fn_stacksize) fe.(fe_size)). +Definition transf_fundef (f: Linear.fundef) : option Mach.fundef := + AST.transf_partial_fundef transf_function f. + Definition transf_program (p: Linear.program) : option Mach.program := - transform_partial_program transf_function p. + transform_partial_program transf_fundef p. diff --git a/backend/Stackingproof.v b/backend/Stackingproof.v index 002ca8d..9692670 100644 --- a/backend/Stackingproof.v +++ b/backend/Stackingproof.v @@ -15,6 +15,7 @@ Require Import Integers. Require Import Values. Require Import Op. Require Import Mem. +Require Import Events. Require Import Globalenvs. Require Import Locations. Require Import Mach. @@ -299,7 +300,7 @@ Lemma exec_Mgetstack': get_slot fr ty (offset_of_index fe idx) v -> Machabstr.exec_instrs tge tf sp parent (Mgetstack (Int.repr (offset_of_index fe idx)) ty dst :: c) rs fr m - c (rs#dst <- v) fr m. + E0 c (rs#dst <- v) fr m. Proof. intros. apply Machabstr.exec_one. apply Machabstr.exec_Mgetstack. rewrite offset_of_index_no_overflow. auto. auto. @@ -311,7 +312,7 @@ Lemma exec_Msetstack': set_slot fr ty (offset_of_index fe idx) (rs src) fr' -> Machabstr.exec_instrs tge tf sp parent (Msetstack src (Int.repr (offset_of_index fe idx)) ty :: c) rs fr m - c rs fr' m. + E0 c rs fr' m. Proof. intros. apply Machabstr.exec_one. apply Machabstr.exec_Msetstack. rewrite offset_of_index_no_overflow. auto. auto. @@ -632,7 +633,7 @@ Lemma save_int_callee_save_correct_rec: exists fr', Machabstr.exec_instrs tge tf sp parent (List.fold_right (save_int_callee_save fe) k l) rs fr m - k rs fr' m + E0 k rs fr' m /\ fr'.(high) = 0 /\ fr'.(low) = -fe.(fe_size) /\ (forall r, @@ -670,7 +671,7 @@ Proof. intros [fr' [A [B [C [D E]]]]]. exists fr'. split. eapply Machabstr.exec_trans. apply exec_Msetstack'; eauto with stacking. - exact A. + eexact A. traceEq. split. auto. split. auto. split. intros. elim H3; intros. subst r. @@ -701,7 +702,7 @@ Lemma save_int_callee_save_correct: exists fr', Machabstr.exec_instrs tge tf sp parent (List.fold_right (save_int_callee_save fe) k int_callee_save_regs) rs fr m - k rs fr' m + E0 k rs fr' m /\ fr'.(high) = 0 /\ fr'.(low) = -fe.(fe_size) /\ (forall r, @@ -733,7 +734,7 @@ Lemma save_float_callee_save_correct_rec: exists fr', Machabstr.exec_instrs tge tf sp parent (List.fold_right (save_float_callee_save fe) k l) rs fr m - k rs fr' m + E0 k rs fr' m /\ fr'.(high) = 0 /\ fr'.(low) = -fe.(fe_size) /\ (forall r, @@ -771,7 +772,7 @@ Proof. intros [fr' [A [B [C [D E]]]]]. exists fr'. split. eapply Machabstr.exec_trans. apply exec_Msetstack'; eauto with stacking. - exact A. + eexact A. traceEq. split. auto. split. auto. split. intros. elim H3; intros. subst r. @@ -802,7 +803,7 @@ Lemma save_float_callee_save_correct: exists fr', Machabstr.exec_instrs tge tf sp parent (List.fold_right (save_float_callee_save fe) k float_callee_save_regs) rs fr m - k rs fr' m + E0 k rs fr' m /\ fr'.(high) = 0 /\ fr'.(low) = -fe.(fe_size) /\ (forall r, @@ -846,7 +847,7 @@ Lemma save_callee_save_correct: exists fr', Machabstr.exec_instrs tge tf sp parent (save_callee_save fe k) rs fr m - k rs fr' m + E0 k rs fr' m /\ agree (LTL.call_regs ls) rs fr' parent rs. Proof. intros. unfold save_callee_save. @@ -857,7 +858,7 @@ Proof. generalize (save_float_callee_save_correct k sp parent rs fr1 m B1 C1). intros [fr2 [A2 [B2 [C2 [D2 E2]]]]]. exists fr2. - split. eapply Machabstr.exec_trans. eexact A1. eexact A2. + split. eapply Machabstr.exec_trans. eexact A1. eexact A2. traceEq. constructor; unfold LTL.call_regs; auto. (* agree_local *) intros. rewrite E2; auto with stacking. @@ -886,7 +887,7 @@ Lemma restore_int_callee_save_correct_rec: exists ls', exists rs', Machabstr.exec_instrs tge tf sp parent (List.fold_right (restore_int_callee_save fe) k l) rs fr m - k rs' fr m + E0 k rs' fr m /\ (forall r, In r l -> rs' r = rs0 r) /\ (forall r, ~(In r l) -> rs' r = rs r) /\ agree ls' rs' fr parent rs0. @@ -916,11 +917,11 @@ Proof. generalize (IHl ls1 rs1 R1 R2 R3). intros [ls' [rs' [A [B [C D]]]]]. exists ls'. exists rs'. - split. apply Machabstr.exec_trans with k1 rs1 fr m. + split. apply Machabstr.exec_trans with E0 k1 rs1 fr m E0. unfold rs1; apply exec_Mgetstack'; eauto with stacking. apply get_slot_index; eauto with stacking. symmetry. eauto with stacking. - eauto with stacking. + eauto with stacking. traceEq. split. intros. elim H2; intros. subst r. rewrite C. unfold rs1. apply Regmap.gss. inversion H0; auto. auto. @@ -945,7 +946,7 @@ Lemma restore_int_callee_save_correct: exists ls', exists rs', Machabstr.exec_instrs tge tf sp parent (List.fold_right (restore_int_callee_save fe) k int_callee_save_regs) rs fr m - k rs' fr m + E0 k rs' fr m /\ (forall r, In r int_callee_save_regs -> rs' r = rs0 r) /\ (forall r, ~(In r int_callee_save_regs) -> rs' r = rs r) /\ agree ls' rs' fr parent rs0. @@ -962,7 +963,7 @@ Lemma restore_float_callee_save_correct_rec: exists ls', exists rs', Machabstr.exec_instrs tge tf sp parent (List.fold_right (restore_float_callee_save fe) k l) rs fr m - k rs' fr m + E0 k rs' fr m /\ (forall r, In r l -> rs' r = rs0 r) /\ (forall r, ~(In r l) -> rs' r = rs r) /\ agree ls' rs' fr parent rs0. @@ -992,11 +993,11 @@ Proof. generalize (IHl ls1 rs1 R1 R2 R3). intros [ls' [rs' [A [B [C D]]]]]. exists ls'. exists rs'. - split. apply Machabstr.exec_trans with k1 rs1 fr m. + split. apply Machabstr.exec_trans with E0 k1 rs1 fr m E0. unfold rs1; apply exec_Mgetstack'; eauto with stacking. apply get_slot_index; eauto with stacking. symmetry. eauto with stacking. - exact A. + exact A. traceEq. split. intros. elim H2; intros. subst r. rewrite C. unfold rs1. apply Regmap.gss. inversion H0; auto. auto. @@ -1021,7 +1022,7 @@ Lemma restore_float_callee_save_correct: exists ls', exists rs', Machabstr.exec_instrs tge tf sp parent (List.fold_right (restore_float_callee_save fe) k float_callee_save_regs) rs fr m - k rs' fr m + E0 k rs' fr m /\ (forall r, In r float_callee_save_regs -> rs' r = rs0 r) /\ (forall r, ~(In r float_callee_save_regs) -> rs' r = rs r) /\ agree ls' rs' fr parent rs0. @@ -1036,7 +1037,7 @@ Lemma restore_callee_save_correct: exists rs', Machabstr.exec_instrs tge tf sp parent (restore_callee_save fe k) rs fr m - k rs' fr m + E0 k rs' fr m /\ (forall r, In r int_callee_save_regs \/ In r float_callee_save_regs -> rs' r = rs0 r) @@ -1053,7 +1054,7 @@ Proof. generalize (restore_float_callee_save_correct sp parent k fr m rs0 ls1 rs1 D). intros [ls2 [rs2 [P [Q [R S]]]]]. - exists rs2. split. eapply Machabstr.exec_trans. eexact A. exact P. + exists rs2. split. eapply Machabstr.exec_trans. eexact A. eexact P. traceEq. split. intros. elim H0; intros. rewrite R. apply B. auto. apply list_disjoint_notin with int_callee_save_regs. apply int_float_callee_save_disjoint. auto. @@ -1148,8 +1149,8 @@ Proof. Qed. Lemma exec_instr_incl: - forall f sp c1 ls1 m1 c2 ls2 m2, - Linear.exec_instr ge f sp c1 ls1 m1 c2 ls2 m2 -> + forall f sp c1 ls1 m1 t c2 ls2 m2, + Linear.exec_instr ge f sp c1 ls1 m1 t c2 ls2 m2 -> incl c1 f.(fn_code) -> incl c2 f.(fn_code). Proof. @@ -1159,8 +1160,8 @@ Proof. Qed. Lemma exec_instrs_incl: - forall f sp c1 ls1 m1 c2 ls2 m2, - Linear.exec_instrs ge f sp c1 ls1 m1 c2 ls2 m2 -> + forall f sp c1 ls1 m1 t c2 ls2 m2, + Linear.exec_instrs ge f sp c1 ls1 m1 t c2 ls2 m2 -> incl c1 f.(fn_code) -> incl c2 f.(fn_code). Proof. @@ -1174,7 +1175,7 @@ Lemma symbols_preserved: forall id, Genv.find_symbol tge id = Genv.find_symbol ge id. Proof. intros. unfold ge, tge. - apply Genv.find_symbol_transf_partial with transf_function. + apply Genv.find_symbol_transf_partial with transf_fundef. exact TRANSF. Qed. @@ -1182,11 +1183,11 @@ Lemma functions_translated: forall f v, Genv.find_funct ge v = Some f -> exists tf, - Genv.find_funct tge v = Some tf /\ transf_function f = Some tf. + Genv.find_funct tge v = Some tf /\ transf_fundef f = Some tf. Proof. intros. - generalize (Genv.find_funct_transf_partial transf_function TRANSF H). - case (transf_function f). + generalize (Genv.find_funct_transf_partial transf_fundef TRANSF H). + case (transf_fundef f). intros tf [A B]. exists tf. tauto. intros. tauto. Qed. @@ -1195,15 +1196,26 @@ Lemma function_ptr_translated: forall f v, Genv.find_funct_ptr ge v = Some f -> exists tf, - Genv.find_funct_ptr tge v = Some tf /\ transf_function f = Some tf. + Genv.find_funct_ptr tge v = Some tf /\ transf_fundef f = Some tf. Proof. intros. - generalize (Genv.find_funct_ptr_transf_partial transf_function TRANSF H). - case (transf_function f). + generalize (Genv.find_funct_ptr_transf_partial transf_fundef TRANSF H). + case (transf_fundef f). intros tf [A B]. exists tf. tauto. intros. tauto. Qed. +Lemma sig_preserved: + forall f tf, transf_fundef f = Some tf -> Mach.funsig tf = Linear.funsig f. +Proof. + intros until tf; unfold transf_fundef, transf_partial_fundef. + destruct f. unfold transf_function. + destruct (zlt (fn_stacksize f) 0). congruence. + destruct (zlt (- Int.min_signed) (fe_size (make_env (function_bounds f)))). congruence. + intros. inversion H; reflexivity. + intro. inversion H. reflexivity. +Qed. + (** Correctness of stack pointer relocation in operations and addressing modes. *) @@ -1287,7 +1299,7 @@ Qed. Definition exec_instr_prop (f: function) (sp: val) - (c: code) (ls: locset) (m: mem) + (c: code) (ls: locset) (m: mem) (t: trace) (c': code) (ls': locset) (m': mem) := forall tf rs fr parent rs0 (TRANSL: transf_function f = Some tf) @@ -1297,7 +1309,7 @@ Definition exec_instr_prop exists rs', exists fr', Machabstr.exec_instrs tge tf (shift_sp tf sp) parent (transl_code (make_env (function_bounds f)) c) rs fr m - (transl_code (make_env (function_bounds f)) c') rs' fr' m' + t (transl_code (make_env (function_bounds f)) c') rs' fr' m' /\ agree f ls' rs' fr' parent rs0. (** The simulation property for function calls has different preconditions @@ -1306,19 +1318,19 @@ Definition exec_instr_prop postconditions (preservation of callee-save registers). *) Definition exec_function_prop - (f: function) - (ls: locset) (m: mem) + (f: fundef) + (ls: locset) (m: mem) (t: trace) (ls': locset) (m': mem) := forall tf rs parent - (TRANSL: transf_function f = Some tf) - (WTF: wt_function f) + (TRANSL: transf_fundef f = Some tf) + (WTF: wt_fundef f) (AG1: forall r, rs r = ls (R r)) (AG2: forall ofs ty, 6 <= ofs -> - ofs + typesize ty <= size_arguments f.(fn_sig) -> + ofs + typesize ty <= size_arguments (funsig f) -> get_slot parent ty (Int.signed (Int.repr (4 * ofs))) (ls (S (Outgoing ofs ty)))), exists rs', - Machabstr.exec_function tge tf parent rs m rs' m' + Machabstr.exec_function tge tf parent rs m t rs' m' /\ (forall r, In (R r) temporaries \/ In (R r) destroyed_at_call -> rs' r = ls' (R r)) @@ -1329,9 +1341,9 @@ Definition exec_function_prop Hypothesis wt_prog: wt_program prog. Lemma transf_function_correct: - forall f ls m ls' m', - Linear.exec_function ge f ls m ls' m' -> - exec_function_prop f ls m ls' m'. + forall f ls m t ls' m', + Linear.exec_function ge f ls m t ls' m' -> + exec_function_prop f ls m t ls' m'. Proof. assert (RED: forall f i c, transl_code (make_env (function_bounds f)) (i :: c) = @@ -1412,13 +1424,13 @@ Proof. (* Lcall *) inversion WTI. - assert (WTF': wt_function f'). + assert (WTF': wt_fundef f'). destruct ros; simpl in H. - apply (Genv.find_funct_prop wt_function wt_prog H). + apply (Genv.find_funct_prop wt_fundef wt_prog H). destruct (Genv.find_symbol ge i); try discriminate. - apply (Genv.find_funct_ptr_prop wt_function wt_prog H). + apply (Genv.find_funct_ptr_prop wt_fundef wt_prog H). assert (TR: exists tf', Mach.find_function tge ros rs0 = Some tf' - /\ transf_function f' = Some tf'). + /\ transf_fundef f' = Some tf'). destruct ros; simpl in H; simpl. eapply functions_translated. rewrite (agree_eval_reg _ _ _ _ _ _ m0 AG). auto. @@ -1430,7 +1442,7 @@ Proof. intro. symmetry. eapply agree_reg; eauto. assert (AG2: forall ofs ty, 6 <= ofs -> - ofs + typesize ty <= size_arguments f'.(fn_sig) -> + ofs + typesize ty <= size_arguments (funsig f') -> get_slot fr ty (Int.signed (Int.repr (4 * ofs))) (rs (S (Outgoing ofs ty)))). intros. assert (slot_bounded f (Outgoing ofs ty)). @@ -1446,6 +1458,13 @@ Proof. apply Machabstr.exec_one; apply Machabstr.exec_Mcall with tf'; auto. apply agree_return_regs with rs0; auto. + (* Lalloc *) + exists (rs0#loc_alloc_result <- (Vptr blk Int.zero)); exists fr. split. + apply Machabstr.exec_one; eapply Machabstr.exec_Malloc; eauto. + rewrite (agree_eval_reg _ _ _ _ _ _ loc_alloc_argument AG). auto. + apply agree_set_reg; auto. + red. simpl. generalize (max_over_regs_of_funct_pos f int_callee_save). omega. + (* Llabel *) exists rs0; exists fr. split. apply Machabstr.exec_one; apply Machabstr.exec_Mlabel. @@ -1483,25 +1502,30 @@ Proof. generalize (H2 tf rs' fr' parent rs0 TRANSL WTF B INCL'). intros [rs'' [fr'' [C D]]]. exists rs''; exists fr''. split. - eapply Machabstr.exec_trans. eexact A. eexact C. + eapply Machabstr.exec_trans. eexact A. eexact C. auto. auto. (* function *) + generalize TRANSL; clear TRANSL. + unfold transf_fundef, transf_partial_fundef. + caseEq (transf_function f); try congruence. + intros tfn TRANSL EQ. inversion EQ; clear EQ; subst tf. + inversion WTF as [|f' WTFN]. subst f'. assert (X: forall link ra, exists rs' : regset, - Machabstr.exec_function_body tge tf parent link ra rs0 m rs' (free m2 stk) /\ + Machabstr.exec_function_body tge tfn parent link ra rs0 m t rs' (free m2 stk) /\ (forall r : mreg, In (R r) temporaries \/ In (R r) destroyed_at_call -> rs' r = rs2 (R r)) /\ (forall r : mreg, In r int_callee_save_regs \/ In r float_callee_save_regs -> rs' r = rs0 r)). intros. set (sp := Vptr stk Int.zero) in *. - set (tsp := shift_sp tf sp). + set (tsp := shift_sp tfn sp). set (fe := make_env (function_bounds f)). - assert (low (init_frame tf) = -fe.(fe_size)). + assert (low (init_frame tfn) = -fe.(fe_size)). simpl low. rewrite (unfold_transf_function _ _ TRANSL). reflexivity. - assert (exists fr1, set_slot (init_frame tf) Tint 0 link fr1). + assert (exists fr1, set_slot (init_frame tfn) Tint 0 link fr1). apply set_slot_ok. reflexivity. omega. rewrite H2. generalize (size_pos f). unfold fe. simpl typesize. omega. elim H3; intros fr1 SET1; clear H3. @@ -1526,28 +1550,29 @@ Proof. apply slot_gi. omega. omega. simpl typesize. omega. simpl typesize. omega. inversion H8. symmetry. exact H11. - generalize (save_callee_save_correct f tf TRANSL + generalize (save_callee_save_correct f tfn TRANSL tsp parent (transl_code (make_env (function_bounds f)) f.(fn_code)) rs0 fr2 m1 rs AG1 AG2 H5 H6 UNDEF). intros [fr [EXP AG]]. - generalize (H1 tf rs0 fr parent rs0 TRANSL WTF AG (incl_refl _)). + generalize (H1 tfn rs0 fr parent rs0 TRANSL WTFN AG (incl_refl _)). intros [rs' [fr' [EXB AG']]]. - generalize (restore_callee_save_correct f tf TRANSL tsp parent + generalize (restore_callee_save_correct f tfn TRANSL tsp parent (Mreturn :: transl_code (make_env (function_bounds f)) b) fr' m2 rs0 rs2 rs' AG'). intros [rs'' [EXX [REGS1 REGS2]]]. exists rs''. split. eapply Machabstr.exec_funct_body. - rewrite (unfold_transf_function f tf TRANSL); eexact H. + rewrite (unfold_transf_function f tfn TRANSL); eexact H. eexact SET1. eexact SET2. - replace (Mach.fn_code tf) with + replace (Mach.fn_code tfn) with (transl_body f (make_env (function_bounds f))). - replace (Vptr stk (Int.repr (- fn_framesize tf))) with tsp. + replace (Vptr stk (Int.repr (- fn_framesize tfn))) with tsp. eapply Machabstr.exec_trans. eexact EXP. - eapply Machabstr.exec_trans. eexact EXB. eexact EXX. + eapply Machabstr.exec_trans. eexact EXB. eexact EXX. + reflexivity. traceEq. unfold tsp, shift_sp, sp. unfold Val.add. rewrite Int.add_commut. rewrite Int.add_zero. auto. - rewrite (unfold_transf_function f tf TRANSL). simpl. auto. + rewrite (unfold_transf_function f tfn TRANSL). simpl. auto. split. intros. rewrite REGS2. symmetry; eapply agree_reg; eauto. apply int_callee_save_not_destroyed; auto. apply float_callee_save_not_destroyed; auto. @@ -1563,21 +1588,36 @@ Proof. rewrite REGS2'. apply REGS2. auto. auto. rewrite H4. auto. split; auto. + + (* external function *) + simpl in TRANSL. inversion TRANSL; subst tf. + inversion WTF. subst ef0. set (sg := ef_sig ef) in *. + exists (rs#(loc_result sg) <- res). + split. econstructor. eauto. + fold sg. rewrite H0. rewrite Conventions.loc_external_arguments_loc_arguments; auto. + rewrite list_map_compose. apply list_map_exten; intros. auto. + reflexivity. + split; intros. rewrite H1. + unfold Regmap.set. case (RegEq.eq r (loc_result sg)); intro. + rewrite e. rewrite Locmap.gss; auto. rewrite Locmap.gso; auto. + red; auto. + apply Regmap.gso. red; intro; subst r. + elim (Conventions.loc_result_not_callee_save _ H2). Qed. End PRESERVATION. Theorem transl_program_correct: - forall (p: Linear.program) (tp: Mach.program) (r: val), + forall (p: Linear.program) (tp: Mach.program) (t: trace) (r: val), wt_program p -> transf_program p = Some tp -> - Linear.exec_program p r -> - Machabstr.exec_program tp r. + Linear.exec_program p t r -> + Machabstr.exec_program tp t r. Proof. - intros p tp r WTP TRANSF + intros p tp t r WTP TRANSF [fptr [f [ls' [m [FINDSYMB [FINDFUNC [SIG [EXEC RES]]]]]]]]. - assert (WTF: wt_function f). - apply (Genv.find_funct_ptr_prop wt_function WTP FINDFUNC). + assert (WTF: wt_fundef f). + apply (Genv.find_funct_ptr_prop wt_fundef WTP FINDFUNC). set (ls := Locmap.init Vundef) in *. set (rs := Regmap.init Vundef). set (fr := empty_frame). @@ -1585,26 +1625,25 @@ Proof. intros; reflexivity. assert (AG2: forall ofs ty, 6 <= ofs -> - ofs + typesize ty <= size_arguments f.(fn_sig) -> + ofs + typesize ty <= size_arguments (funsig f) -> get_slot fr ty (Int.signed (Int.repr (4 * ofs))) (ls (S (Outgoing ofs ty)))). rewrite SIG. unfold size_arguments, sig_args, size_arguments_rec. intros. generalize (typesize_pos ty). intro. omegaContradiction. generalize (function_ptr_translated p tp TRANSF f _ FINDFUNC). intros [tf [TFIND TRANSL]]. - generalize (transf_function_correct p tp TRANSF WTP _ _ _ _ _ EXEC + generalize (transf_function_correct p tp TRANSF WTP _ _ _ _ _ _ EXEC tf rs fr TRANSL WTF AG1 AG2). intros [rs' [A [B C]]]. red. exists fptr; exists tf; exists rs'; exists m. split. rewrite (symbols_preserved p tp TRANSF). - rewrite (transform_partial_program_main transf_function p TRANSF). + rewrite (transform_partial_program_main transf_fundef p TRANSF). assumption. split. assumption. - split. rewrite (unfold_transf_function f tf TRANSL); simpl. - assumption. split. replace (Genv.init_mem tp) with (Genv.init_mem p). - exact A. symmetry. apply Genv.init_mem_transf_partial with transf_function. + exact A. symmetry. apply Genv.init_mem_transf_partial with transf_fundef. exact TRANSF. - rewrite <- RES. rewrite (unfold_transf_function f tf TRANSL); simpl. + rewrite <- RES. replace R3 with (loc_result (funsig f)). apply B. right. apply loc_result_acceptable. + rewrite SIG; reflexivity. Qed. diff --git a/backend/Stackingtyping.v b/backend/Stackingtyping.v index 85d1922..996ada4 100644 --- a/backend/Stackingtyping.v +++ b/backend/Stackingtyping.v @@ -166,6 +166,8 @@ Proof. (* call *) apply wt_instrs_cons; auto. constructor; auto. + (* alloc *) + apply wt_instrs_cons; auto. constructor. (* label *) apply wt_instrs_cons; auto. constructor. @@ -208,6 +210,20 @@ Proof. rewrite H2. eapply size_no_overflow; eauto. Qed. +Lemma wt_transf_fundef: + forall f tf, + Lineartyping.wt_fundef f -> + transf_fundef f = Some tf -> + wt_fundef tf. +Proof. + intros f tf WT. inversion WT; subst. + simpl; intros; inversion H0. constructor; auto. + unfold transf_fundef, transf_partial_fundef. + caseEq (transf_function f0); try congruence. + intros tfn TRANSF EQ. inversion EQ; subst tf. + constructor; eapply wt_transf_function; eauto. +Qed. + Lemma program_typing_preserved: forall (p: Linear.program) (tp: Mach.program), transf_program p = Some tp -> @@ -215,8 +231,8 @@ Lemma program_typing_preserved: Machtyping.wt_program tp. Proof. intros; red; intros. - generalize (transform_partial_program_function transf_function p i f H H1). + generalize (transform_partial_program_function transf_fundef p i f H H1). intros [f0 [IN TRANSF]]. - apply wt_transf_function with f0; auto. + apply wt_transf_fundef with f0; auto. eapply H0; eauto. Qed. diff --git a/backend/Tunneling.v b/backend/Tunneling.v index 9c3e82c..4fbdc9f 100644 --- a/backend/Tunneling.v +++ b/backend/Tunneling.v @@ -100,6 +100,8 @@ Fixpoint tunnel_block (f: LTL.function) (b: block) {struct b} : block := Bstore chunk addr args src (tunnel_block f b) | Bcall sig ros b => Bcall sig ros (tunnel_block f b) + | Balloc b => + Balloc (tunnel_block f b) | Bgoto s => Bgoto (branch_target f s) | Bcond cond args s1 s2 => @@ -126,6 +128,9 @@ Definition tunnel_function (f: LTL.function) : LTL.function := (fn_entrypoint f) (wf_tunneled_code f). +Definition tunnel_fundef (f: LTL.fundef) : LTL.fundef := + transf_fundef tunnel_function f. + Definition tunnel_program (p: LTL.program) : LTL.program := - transform_program tunnel_function p. + transform_program tunnel_fundef p. diff --git a/backend/Tunnelingproof.v b/backend/Tunnelingproof.v index 111d1d8..88547e7 100644 --- a/backend/Tunnelingproof.v +++ b/backend/Tunnelingproof.v @@ -5,6 +5,7 @@ Require Import Maps. Require Import AST. Require Import Values. Require Import Mem. +Require Import Events. Require Import Globalenvs. Require Import Op. Require Import Locations. @@ -82,68 +83,75 @@ Let tge := Genv.globalenv tp. Lemma functions_translated: forall v f, Genv.find_funct ge v = Some f -> - Genv.find_funct tge v = Some (tunnel_function f). -Proof (@Genv.find_funct_transf _ _ tunnel_function p). + Genv.find_funct tge v = Some (tunnel_fundef f). +Proof (@Genv.find_funct_transf _ _ tunnel_fundef p). Lemma function_ptr_translated: forall v f, Genv.find_funct_ptr ge v = Some f -> - Genv.find_funct_ptr tge v = Some (tunnel_function f). -Proof (@Genv.find_funct_ptr_transf _ _ tunnel_function p). + Genv.find_funct_ptr tge v = Some (tunnel_fundef f). +Proof (@Genv.find_funct_ptr_transf _ _ tunnel_fundef p). Lemma symbols_preserved: forall id, Genv.find_symbol tge id = Genv.find_symbol ge id. -Proof (@Genv.find_symbol_transf _ _ tunnel_function p). +Proof (@Genv.find_symbol_transf _ _ tunnel_fundef p). + +Lemma sig_preserved: + forall f, funsig (tunnel_fundef f) = funsig f. +Proof. + destruct f; reflexivity. +Qed. (** These are inversion lemmas, characterizing what happens in the LTL semantics when executing [Bgoto] instructions or basic blocks. *) Lemma exec_instrs_Bgoto_inv: - forall sp b1 ls1 m1 b2 ls2 m2, - exec_instrs ge sp b1 ls1 m1 b2 ls2 m2 -> + forall sp b1 ls1 m1 t b2 ls2 m2, + exec_instrs ge sp b1 ls1 m1 t b2 ls2 m2 -> forall s1, - b1 = Bgoto s1 -> b2 = b1 /\ ls2 = ls1 /\ m2 = m1. + b1 = Bgoto s1 -> t = E0 /\ b2 = b1 /\ ls2 = ls1 /\ m2 = m1. Proof. induction 1. intros. tauto. - intros. subst b1. inversion H. - intros. generalize (IHexec_instrs1 s1 H1). intros [A [B C]]. - subst b2; subst rs2; subst m2. eauto. + intros. subst b1. inversion H. + intros. generalize (IHexec_instrs1 s1 H2). intros [A [B [C D]]]. + subst t1 b2 rs2 m2. + generalize (IHexec_instrs2 s1 H2). intros [A [B [C D]]]. + subst t2 b3 rs3 m3. intuition. traceEq. Qed. Lemma exec_block_Bgoto_inv: - forall sp s ls1 m1 out ls2 m2, - exec_block ge sp (Bgoto s) ls1 m1 out ls2 m2 -> - out = Cont s /\ ls2 = ls1 /\ m2 = m1. + forall sp s ls1 m1 t out ls2 m2, + exec_block ge sp (Bgoto s) ls1 m1 t out ls2 m2 -> + t = E0 /\ out = Cont s /\ ls2 = ls1 /\ m2 = m1. Proof. intros. inversion H; - generalize (exec_instrs_Bgoto_inv _ _ _ _ _ _ _ H0 s (refl_equal _)); - intros [A [B C]]. - split. congruence. tauto. - discriminate. - discriminate. - discriminate. + generalize (exec_instrs_Bgoto_inv _ _ _ _ _ _ _ _ H0 s (refl_equal _)); + intros [A [B [C D]]]; + try discriminate. + intuition congruence. Qed. Lemma exec_blocks_Bgoto_inv: - forall c sp pc1 ls1 m1 out ls2 m2 s, - exec_blocks ge c sp pc1 ls1 m1 out ls2 m2 -> + forall c sp pc1 ls1 m1 t out ls2 m2 s, + exec_blocks ge c sp pc1 ls1 m1 t out ls2 m2 -> c!pc1 = Some (Bgoto s) -> - (out = Cont pc1 /\ ls2 = ls1 /\ m2 = m1) - \/ exec_blocks ge c sp s ls1 m1 out ls2 m2. + (t = E0 /\ out = Cont pc1 /\ ls2 = ls1 /\ m2 = m1) + \/ exec_blocks ge c sp s ls1 m1 t out ls2 m2. Proof. induction 1; intros. left; tauto. assert (b = Bgoto s). congruence. subst b. - generalize (exec_block_Bgoto_inv _ _ _ _ _ _ _ H0). - intros [A [B C]]. subst out; subst rs'; subst m'. + generalize (exec_block_Bgoto_inv _ _ _ _ _ _ _ _ H0). + intros [A [B [C D]]]. subst t out rs' m'. right. apply exec_blocks_refl. - elim (IHexec_blocks1 H1). - intros [A [B C]]. - assert (pc2 = pc1). congruence. subst rs2; subst m2; subst pc2. - apply IHexec_blocks2; auto. - intro. right. apply exec_blocks_trans with pc2 rs2 m2; auto. + elim (IHexec_blocks1 H2). + intros [A [B [C D]]]. + assert (pc2 = pc1). congruence. subst t1 rs2 m2 pc2. + replace t with t2. apply IHexec_blocks2; auto. traceEq. + intro. right. + eapply exec_blocks_trans; eauto. Qed. (** The following [exec_*_prop] predicates state the correctness @@ -163,43 +171,43 @@ Definition tunnel_outcome (f: function) (out: outcome) := end. Definition exec_instr_prop - (sp: val) (b1: block) (ls1: locset) (m1: mem) + (sp: val) (b1: block) (ls1: locset) (m1: mem) (t: trace) (b2: block) (ls2: locset) (m2: mem) : Prop := forall f, exec_instr tge sp (tunnel_block f b1) ls1 m1 - (tunnel_block f b2) ls2 m2. + t (tunnel_block f b2) ls2 m2. Definition exec_instrs_prop - (sp: val) (b1: block) (ls1: locset) (m1: mem) + (sp: val) (b1: block) (ls1: locset) (m1: mem) (t: trace) (b2: block) (ls2: locset) (m2: mem) : Prop := forall f, exec_instrs tge sp (tunnel_block f b1) ls1 m1 - (tunnel_block f b2) ls2 m2. + t (tunnel_block f b2) ls2 m2. Definition exec_block_prop - (sp: val) (b1: block) (ls1: locset) (m1: mem) + (sp: val) (b1: block) (ls1: locset) (m1: mem) (t: trace) (out: outcome) (ls2: locset) (m2: mem) : Prop := forall f, exec_block tge sp (tunnel_block f b1) ls1 m1 - (tunnel_outcome f out) ls2 m2. + t (tunnel_outcome f out) ls2 m2. Definition tunneled_code (f: function) := PTree.map (fun pc b => tunnel_block f b) (fn_code f). Definition exec_blocks_prop (c: code) (sp: val) - (pc: node) (ls1: locset) (m1: mem) + (pc: node) (ls1: locset) (m1: mem) (t: trace) (out: outcome) (ls2: locset) (m2: mem) : Prop := forall f, f.(fn_code) = c -> exec_blocks tge (tunneled_code f) sp (branch_target f pc) ls1 m1 - (tunnel_outcome f out) ls2 m2. + t (tunnel_outcome f out) ls2 m2. Definition exec_function_prop - (f: function) (ls1: locset) (m1: mem) - (ls2: locset) (m2: mem) : Prop := - exec_function tge (tunnel_function f) ls1 m1 ls2 m2. + (f: fundef) (ls1: locset) (m1: mem) (t: trace) + (ls2: locset) (m2: mem) : Prop := + exec_function tge (tunnel_fundef f) ls1 m1 t ls2 m2. Scheme exec_instr_ind5 := Minimality for LTL.exec_instr Sort Prop with exec_instrs_ind5 := Minimality for LTL.exec_instrs Sort Prop @@ -212,9 +220,9 @@ Scheme exec_instr_ind5 := Minimality for LTL.exec_instr Sort Prop using the [exec_*_prop] predicates above as induction hypotheses. *) Lemma tunnel_function_correct: - forall f ls1 m1 ls2 m2, - exec_function ge f ls1 m1 ls2 m2 -> - exec_function_prop f ls1 m1 ls2 m2. + forall f ls1 m1 t ls2 m2, + exec_function ge f ls1 m1 t ls2 m2 -> + exec_function_prop f ls1 m1 t ls2 m2. Proof. apply (exec_function_ind5 ge exec_instr_prop @@ -239,19 +247,21 @@ Proof. apply eval_addressing_preserved. exact symbols_preserved. auto. (* call *) - apply exec_Bcall with (tunnel_function f). + apply exec_Bcall with (tunnel_fundef f). generalize H; unfold find_function; destruct ros. intro. apply functions_translated; auto. rewrite symbols_preserved. destruct (Genv.find_symbol ge i). intro. apply function_ptr_translated; auto. congruence. - rewrite H0; reflexivity. + generalize (sig_preserved f). congruence. apply H2. + (* alloc *) + eapply exec_Balloc; eauto. (* instr_refl *) apply exec_refl. (* instr_one *) apply exec_one. apply H0. (* instr_trans *) - apply exec_trans with (tunnel_block f b2) rs2 m2; auto. + apply exec_trans with t1 (tunnel_block f b2) rs2 m2 t2; auto. (* goto *) apply exec_Bgoto. red in H0. simpl in H0. apply H0. (* cond, true *) @@ -270,13 +280,13 @@ Proof. reflexivity. apply H1. intros [pc' [ATpc BTS]]. assert (b = Bgoto pc'). congruence. subst b. - generalize (exec_block_Bgoto_inv _ _ _ _ _ _ _ H0). - intros [A [B C]]. subst out; subst rs'; subst m'. + generalize (exec_block_Bgoto_inv _ _ _ _ _ _ _ _ H0). + intros [A [B [C D]]]. subst t out rs' m'. simpl. rewrite BTS. apply exec_blocks_refl. (* blocks_trans *) - apply exec_blocks_trans with (branch_target f pc2) rs2 m2. - exact (H0 f H3). exact (H2 f H3). - (* function *) + apply exec_blocks_trans with t1 (branch_target f pc2) rs2 m2 t2. + exact (H0 f H4). exact (H2 f H4). auto. + (* internal function *) econstructor. eexact H. change (fn_code (tunnel_function f)) with (tunneled_code f). simpl. @@ -284,28 +294,30 @@ Proof. intro BT. rewrite <- BT. exact (H1 f (refl_equal _)). intros [pc [ATpc BT]]. apply exec_blocks_trans with - (branch_target f (fn_entrypoint f)) (call_regs rs) m1. + E0 (branch_target f (fn_entrypoint f)) (call_regs rs) m1 t. eapply exec_blocks_one. unfold tunneled_code. rewrite PTree.gmap. rewrite ATpc. simpl. reflexivity. apply exec_Bgoto. rewrite BT. apply exec_refl. - exact (H1 f (refl_equal _)). + exact (H1 f (refl_equal _)). traceEq. + (* external function *) + econstructor; eauto. Qed. End PRESERVATION. Theorem transf_program_correct: - forall (p: program) (r: val), - exec_program p r -> - exec_program (tunnel_program p) r. + forall (p: program) (t: trace) (r: val), + exec_program p t r -> + exec_program (tunnel_program p) t r. Proof. - intros p r [b [f [ls [m [FIND1 [FIND2 [SIG [EX RES]]]]]]]]. - red. exists b; exists (tunnel_function f); exists ls; exists m. + intros p t r [b [f [ls [m [FIND1 [FIND2 [SIG [EX RES]]]]]]]]. + red. exists b; exists (tunnel_fundef f); exists ls; exists m. split. change (prog_main (tunnel_program p)) with (prog_main p). rewrite <- FIND1. apply symbols_preserved. split. apply function_ptr_translated. assumption. - split. rewrite <- SIG. reflexivity. + split. generalize (sig_preserved f). congruence. split. apply tunnel_function_correct. unfold tunnel_program. rewrite Genv.init_mem_transf. auto. - exact RES. + rewrite sig_preserved. exact RES. Qed. diff --git a/backend/Tunnelingtyping.v b/backend/Tunnelingtyping.v index 29b74f1..6281afa 100644 --- a/backend/Tunnelingtyping.v +++ b/backend/Tunnelingtyping.v @@ -33,12 +33,19 @@ Proof. intros; discriminate. Qed. +Lemma wt_tunnel_fundef: + forall f, wt_fundef f -> wt_fundef (tunnel_fundef f). +Proof. + intros. inversion H; simpl. constructor; auto. + constructor. apply wt_tunnel_function; auto. +Qed. + Lemma program_typing_preserved: forall (p: LTL.program), wt_program p -> wt_program (tunnel_program p). Proof. intros; red; intros. - generalize (transform_program_function tunnel_function p i f H0). + generalize (transform_program_function tunnel_fundef p i f H0). intros [f0 [IN TRANSF]]. - subst f. apply wt_tunnel_function. eauto. + subst f. apply wt_tunnel_fundef. eauto. Qed. diff --git a/caml/Allocationaux.ml b/caml/Allocationaux.ml deleted file mode 100644 index c682c3c..0000000 --- a/caml/Allocationaux.ml +++ /dev/null @@ -1,39 +0,0 @@ -open Camlcoq -open Datatypes -open CList -open AST -open Locations - -type status = To_move | Being_moved | Moved - -let parallel_move_order lsrc ldst = - let src = array_of_coqlist lsrc - and dst = array_of_coqlist ldst in - let n = Array.length src in - let status = Array.make n To_move in - let moves = ref Coq_nil in - let rec move_one i = - if src.(i) <> dst.(i) then begin - status.(i) <- Being_moved; - for j = 0 to n - 1 do - if src.(j) = dst.(i) then - match status.(j) with - To_move -> - move_one j - | Being_moved -> - let tmp = - match Loc.coq_type src.(j) with - | Tint -> R IT2 - | Tfloat -> R FT2 in - moves := Coq_cons (Coq_pair(src.(j), tmp), !moves); - src.(j) <- tmp - | Moved -> - () - done; - moves := Coq_cons(Coq_pair(src.(i), dst.(i)), !moves); - status.(i) <- Moved - end in - for i = 0 to n - 1 do - if status.(i) = To_move then move_one i - done; - CList.rev !moves diff --git a/caml/Allocationaux.mli b/caml/Allocationaux.mli deleted file mode 100644 index 0cf3b94..0000000 --- a/caml/Allocationaux.mli +++ /dev/null @@ -1,5 +0,0 @@ -open Datatypes -open List -open Locations - -val parallel_move_order: loc list -> loc list -> (loc, loc) prod list diff --git a/caml/CMlexer.mll b/caml/CMlexer.mll index b8d3ae7..49d0dbd 100644 --- a/caml/CMlexer.mll +++ b/caml/CMlexer.mll @@ -20,6 +20,7 @@ rule token = parse | blank + { token lexbuf } | "/*" { comment lexbuf; token lexbuf } | "absf" { ABSF } + | "alloc" { ALLOC } | "&" { AMPERSAND } | "&&" { AMPERSANDAMPERSAND } | "!" { BANG } @@ -38,6 +39,7 @@ rule token = parse | "==f" { EQUALEQUALF } | "==u" { EQUALEQUALU } | "exit" { EXIT } + | "extern" { EXTERN } | "float" { FLOAT } | "float32" { FLOAT32 } | "float64" { FLOAT64 } diff --git a/caml/CMparser.mly b/caml/CMparser.mly index d461a15..5595afe 100644 --- a/caml/CMparser.mly +++ b/caml/CMparser.mly @@ -24,6 +24,7 @@ let orbool e1 e2 = %token ABSF %token AMPERSAND %token AMPERSANDAMPERSAND +%token ALLOC %token BANG %token BANGEQUAL %token BANGEQUALF @@ -41,6 +42,7 @@ let orbool e1 e2 = %token EQUALEQUALU %token EOF %token EXIT +%token EXTERN %token FLOAT %token FLOAT32 %token FLOAT64 @@ -120,7 +122,7 @@ let orbool e1 e2 = %left LESSLESS GREATERGREATER GREATERGREATERU %left PLUS PLUSF MINUS MINUSF %left STAR SLASH PERCENT STARF SLASHF SLASHU PERCENTU -%nonassoc BANG TILDE p_uminus ABSF INTOFFLOAT FLOATOFINT FLOATOFINTU INT8S INT8U INT16S INT16U FLOAT32 +%nonassoc BANG TILDE p_uminus ABSF INTOFFLOAT FLOATOFINT FLOATOFINTU INT8S INT8U INT16S INT16U FLOAT32 ALLOC %left LPAREN /* Entry point */ @@ -145,7 +147,8 @@ global_declarations: ; global_declaration: - VAR STRINGLIT LBRACKET INTLIT RBRACKET { Coq_pair($2, z_of_camlint $4) } + VAR STRINGLIT LBRACKET INTLIT RBRACKET + { Coq_pair($2, Coq_cons(Init_space (z_of_camlint $4), Coq_nil)) } ; proc_list: @@ -163,11 +166,15 @@ proc: stmt_list RBRACE { Coq_pair($1, - { fn_sig = $6; - fn_params = CList.rev $3; - fn_vars = CList.rev $9; - fn_stackspace = $8; - fn_body = $10 }) } + Internal { fn_sig = $6; + fn_params = CList.rev $3; + fn_vars = CList.rev $9; + fn_stackspace = $8; + fn_body = $10 }) } + | EXTERN STRINGLIT COLON signature + { Coq_pair($2, + External { ef_id = $2; + ef_sig = $4 }) } ; signature: @@ -250,6 +257,7 @@ expr: | INT16S expr { Cmconstr.cast16signed $2 } | INT16U expr { Cmconstr.cast16unsigned $2 } | FLOAT32 expr { Cmconstr.singleoffloat $2 } + | ALLOC expr { Ealloc $2 } | expr PLUS expr { Cmconstr.add $1 $3 } | expr MINUS expr { Cmconstr.sub $1 $3 } | expr STAR expr { Cmconstr.mul $1 $3 } diff --git a/caml/CMtypecheck.ml b/caml/CMtypecheck.ml index b6f94cb..4e700d7 100644 --- a/caml/CMtypecheck.ml +++ b/caml/CMtypecheck.ml @@ -5,6 +5,7 @@ open Datatypes open CList open Camlcoq open AST +open Integers open Op open Cminor @@ -95,6 +96,8 @@ let type_operation = function | Oundef -> [], newvar() | Ocast8signed -> [tint], tint | Ocast16signed -> [tint], tint + | Ocast8unsigned -> [tint], tint + | Ocast16unsigned -> [tint], tint | Oadd -> [tint;tint], tint | Oaddimm _ -> [tint], tint | Osub -> [tint;tint], tint @@ -141,6 +144,8 @@ let name_of_operation = function | Oundef -> "undef" | Ocast8signed -> "cast8signed" | Ocast16signed -> "cast16signed" + | Ocast8unsigned -> "cast8unsigned" + | Ocast16unsigned -> "cast16unsigned" | Oadd -> "add" | Oaddimm n -> sprintf "addimm %ld" (camlint_of_coqint n) | Osub -> "sub" @@ -282,6 +287,14 @@ let rec type_expr env lenv e = te2 | Eletvar n -> type_letvar lenv n + | Ealloc e -> + let te = type_expr env lenv e in + begin try + unify tint te + with Error s -> + raise (Error (sprintf "In alloc:\n%s" s)) + end; + tint and type_exprlist env lenv el = match el with @@ -349,7 +362,7 @@ let rec env_of_vars idl = | Coq_nil -> [] | Coq_cons(id1, idt) -> (id1, newvar()) :: env_of_vars idt -let type_function (Coq_pair (id, f)) = +let type_function id f = try type_stmt (env_of_vars f.fn_vars @ env_of_vars f.fn_params) @@ -357,5 +370,10 @@ let type_function (Coq_pair (id, f)) = with Error s -> raise (Error (sprintf "In function %s:\n%s" (extern_atom id) s)) +let type_fundef (Coq_pair (id, fd)) = + match fd with + | Internal f -> type_function id f + | External ef -> () + let type_program p = - coqlist_iter type_function p.prog_funct; p + coqlist_iter type_fundef p.prog_funct; p diff --git a/caml/Camlcoq.ml b/caml/Camlcoq.ml index b0bb4ff..fc5d2d8 100644 --- a/caml/Camlcoq.ml +++ b/caml/Camlcoq.ml @@ -7,6 +7,11 @@ open BinInt (* Integers *) +let rec camlint_of_nat n = + match n with + | O -> 0l + | S n -> Int32.add (camlint_of_nat n) 1l + let rec camlint_of_positive = function | Coq_xI p -> Int32.add (Int32.shift_left (camlint_of_positive p) 1) 1l | Coq_xO p -> Int32.shift_left (camlint_of_positive p) 1 diff --git a/caml/Coloringaux.ml b/caml/Coloringaux.ml index f4f4bcd..a7c8db5 100644 --- a/caml/Coloringaux.ml +++ b/caml/Coloringaux.ml @@ -266,15 +266,13 @@ let class_of_type = function Tint -> 0 | Tfloat -> 1 let num_register_classes = 2 let caller_save_registers = [| - [| R3; R4; R5; R6; R7; R8; R9; R10 |]; - [| F1; F2; F3; F4; F5; F6; F7; F8; F9; F10 |] + array_of_coqlist Conventions.int_caller_save_regs; + array_of_coqlist Conventions.float_caller_save_regs |] let callee_save_registers = [| - [| R13; R14; R15; R16; R17; R18; R19; R20; R21; R22; - R23; R24; R25; R26; R27; R28; R29; R30; R31 |]; - [| F14; F15; F16; F17; F18; F19; F20; F21; F22; - F23; F24; F25; F26; F27; F28; F29; F30; F31 |] + array_of_coqlist Conventions.int_callee_save_regs; + array_of_coqlist Conventions.float_callee_save_regs |] let num_available_registers = diff --git a/caml/Floataux.ml b/caml/Floataux.ml index f43efa2..f61bd5b 100644 --- a/caml/Floataux.ml +++ b/caml/Floataux.ml @@ -1,4 +1,5 @@ open Camlcoq +open Integers let singleoffloat f = Int32.float_of_bits (Int32.bits_of_float f) @@ -15,9 +16,9 @@ let floatofintu i = let cmp c (x: float) (y: float) = match c with - | AST.Ceq -> x = y - | AST.Cne -> x <> y - | AST.Clt -> x < y - | AST.Cle -> x <= y - | AST.Cgt -> x > y - | AST.Cge -> x >= y + | Ceq -> x = y + | Cne -> x <> y + | Clt -> x < y + | Cle -> x <= y + | Cgt -> x > y + | Cge -> x >= y diff --git a/caml/PrintPPC.ml b/caml/PrintPPC.ml index 830de0d..eaa383b 100644 --- a/caml/PrintPPC.ml +++ b/caml/PrintPPC.ml @@ -26,10 +26,23 @@ let label_for_label lbl = Hashtbl.add current_function_labels lbl lbl'; lbl' +(* Record identifiers of external functions *) + +module IdentSet = Set.Make(struct type t = ident let compare = compare end) + +let extfuns = ref IdentSet.empty + +let record_extfun (Coq_pair(name, defn)) = + match defn with + | Internal _ -> () + | External _ -> extfuns := IdentSet.add name !extfuns + (* Basic printing functions *) let print_symb oc symb = - fprintf oc "_%s" (extern_atom symb) + if IdentSet.mem symb !extfuns + then fprintf oc "L%s$stub" (extern_atom symb) + else fprintf oc "_%s" (extern_atom symb) let print_label oc lbl = fprintf oc "L%d" (label_for_label lbl) @@ -99,6 +112,8 @@ let print_instruction oc labels = function fprintf oc " addis %a, %a, %a\n" ireg r1 ireg_or_zero r2 print_constant c | Paddze(r1, r2) -> fprintf oc " addze %a, %a\n" ireg r1 ireg r2 + | Pallocblock -> + fprintf oc " bl _compcert_alloc\n" | Pallocframe(lo, hi) -> let lo = camlint_of_coqint lo and hi = camlint_of_coqint hi in @@ -317,7 +332,7 @@ let rec labels_of_code = function Labelset.add lbl (labels_of_code c) | Coq_cons(_, c) -> labels_of_code c -let print_function oc (Coq_pair(name, code)) = +let print_function oc name code = Hashtbl.clear current_function_labels; fprintf oc " .text\n"; fprintf oc " .align 2\n"; @@ -325,10 +340,52 @@ let print_function oc (Coq_pair(name, code)) = fprintf oc "%a:\n" print_symb name; coqlist_iter (print_instruction oc (labels_of_code code)) code -let print_var oc (Coq_pair(name, size)) = - fprintf oc " .comm %a, %ld\n" print_symb name (camlint_of_z size) +let print_external_function oc name = + let name = extern_atom name in + fprintf oc " .text\n"; + fprintf oc " .align 2\n"; + fprintf oc "L%s$stub:\n" name; + fprintf oc " addis r11, 0, ha16(L%s$ptr)\n" name; + fprintf oc " lwz r11, lo16(L%s$ptr)(r11)\n" name; + fprintf oc " mtctr r11\n"; + fprintf oc " bctr\n"; + fprintf oc " .non_lazy_symbol_pointer\n"; + fprintf oc "L%s$ptr:\n" name; + fprintf oc " .indirect_symbol _%s\n" name; + fprintf oc " .long 0\n" + +let print_fundef oc (Coq_pair(name, defn)) = + match defn with + | Internal code -> print_function oc name code + | External ef -> print_external_function oc name + +let print_init_data oc = function + | Init_int8 n -> + fprintf oc " .byte %ld\n" (camlint_of_coqint n) + | Init_int16 n -> + fprintf oc " .short %ld\n" (camlint_of_coqint n) + | Init_int32 n -> + fprintf oc " .long %ld\n" (camlint_of_coqint n) + | Init_float32 n -> + fprintf oc " .long %ld # %g \n" (Int32.bits_of_float n) n + | Init_float64 n -> + fprintf oc " .quad %Ld # %g \n" (Int64.bits_of_float n) n + | Init_space n -> + let n = camlint_of_z n in + if n > 0l then fprintf oc " .space %ld\n" n + +let print_var oc (Coq_pair(name, init_data)) = + match init_data with + | Coq_nil -> () + | _ -> + fprintf oc " .data\n"; + fprintf oc " .globl %a\n" print_symb name; + fprintf oc "%a:" print_symb name; + coqlist_iter (print_init_data oc) init_data let print_program oc p = + extfuns := IdentSet.empty; + coqlist_iter record_extfun p.prog_funct; coqlist_iter (print_var oc) p.prog_vars; - coqlist_iter (print_function oc) p.prog_funct + coqlist_iter (print_fundef oc) p.prog_funct diff --git a/caml/RTLtypingaux.ml b/caml/RTLtypingaux.ml new file mode 100644 index 0000000..b76a0bb --- /dev/null +++ b/caml/RTLtypingaux.ml @@ -0,0 +1,122 @@ +(* Type inference for RTL *) + +open Datatypes +open CList +open Camlcoq +open Maps +open AST +open Op +open Registers +open RTL + +exception Type_error of string + +let env = ref (PTree.empty : typ PTree.t) + +let set_type r ty = + match PTree.get r !env with + | None -> env := PTree.set r ty !env + | Some ty' -> if ty <> ty' then raise (Type_error "type mismatch") + +let rec set_types rl tyl = + match rl, tyl with + | Coq_nil, Coq_nil -> () + | Coq_cons(r1, rs), Coq_cons(ty1, tys) -> set_type r1 ty1; set_types rs tys + | _, _ -> raise (Type_error "arity mismatch") + +(* First pass: process constraints of the form typeof(r) = ty *) + +let type_instr retty (Coq_pair(pc, i)) = + match i with + | Inop(_) -> + () + | Iop(Omove, _, _, _) -> + () + | Iop(Oundef, Coq_nil, res, _) -> + () + | Iop(Oundef, _, _, _) -> + raise (Type_error "wrong Oundef") + | Iop(op, args, res, _) -> + let (Coq_pair(targs, tres)) = type_of_operation op in + set_types args targs; set_type res tres + | Iload(chunk, addr, args, dst, _) -> + set_types args (type_of_addressing addr); + set_type dst (type_of_chunk chunk) + | Istore(chunk, addr, args, src, _) -> + set_types args (type_of_addressing addr); + set_type src (type_of_chunk chunk) + | Icall(sg, ros, args, res, _) -> + begin match ros with + | Coq_inl r -> set_type r Tint + | Coq_inr _ -> () + end; + set_types args sg.sig_args; + set_type res (match sg.sig_res with None -> Tint | Some ty -> ty) + | Ialloc(arg, res, _) -> + set_type arg Tint; set_type res Tint + | Icond(cond, args, _, _) -> + set_types args (type_of_condition cond) + | Ireturn(optres) -> + begin match optres, retty with + | None, None -> () + | Some r, Some ty -> set_type r ty + | _, _ -> raise (Type_error "type mismatch in Ireturn") + end + +let type_pass1 retty instrs = + coqlist_iter (type_instr retty) instrs + +(* Second pass: extract move constraints typeof(r1) = typeof(r2) + and solve them iteratively *) + +let rec extract_moves = function + | Coq_nil -> [] + | Coq_cons(Coq_pair(pc, i), rem) -> + match i with + | Iop(Omove, Coq_cons(r1, Coq_nil), r2, _) -> + (r1, r2) :: extract_moves rem + | Iop(Omove, _, _, _) -> + raise (Type_error "wrong Omove") + | _ -> + extract_moves rem + +let changed = ref false + +let rec solve_moves = function + | [] -> [] + | (r1, r2) :: rem -> + match (PTree.get r1 !env, PTree.get r2 !env) with + | Some ty1, Some ty2 -> + if ty1 = ty2 + then (changed := true; solve_moves rem) + else raise (Type_error "type mismatch in Omove") + | Some ty1, None -> + env := PTree.set r2 ty1 !env; changed := true; solve_moves rem + | None, Some ty2 -> + env := PTree.set r1 ty2 !env; changed := true; solve_moves rem + | None, None -> + (r1, r2) :: solve_moves rem + +let rec iter_solve_moves mvs = + changed := false; + let mvs' = solve_moves mvs in + if !changed then iter_solve_moves mvs' + +let type_pass2 instrs = + iter_solve_moves (extract_moves instrs) + +let typeof e r = + match PTree.get r e with Some ty -> ty | None -> Tint + +let infer_type_environment f instrs = + try + env := PTree.empty; + set_types f.fn_params f.fn_sig.sig_args; + type_pass1 f.fn_sig.sig_res instrs; + type_pass2 instrs; + let e = !env in + env := PTree.empty; + Some(typeof e) + with Type_error msg -> + Printf.eprintf "Error during RTL type inference: %s\n" msg; + None diff --git a/cfrontend/Csem.v b/cfrontend/Csem.v new file mode 100644 index 0000000..b73e83c --- /dev/null +++ b/cfrontend/Csem.v @@ -0,0 +1,752 @@ +(** * Dynamic semantics for the Clight language *) + +Require Import Coqlib. +Require Import Maps. +Require Import Integers. +Require Import Floats. +Require Import Values. +Require Import AST. +Require Import Mem. +Require Import Events. +Require Import Globalenvs. +Require Import Csyntax. + +(** ** Semantics of type-dependent operations *) + +Inductive is_false: val -> type -> Prop := + | is_false_int: forall sz sg, + is_false (Vint Int.zero) (Tint sz sg) + | is_false_pointer: forall t, + is_false (Vint Int.zero) (Tpointer t) + | is_false_float: forall sz, + is_false (Vfloat Float.zero) (Tfloat sz). + +Inductive is_true: val -> type -> Prop := + | is_true_int_int: forall n sz sg, + n <> Int.zero -> + is_true (Vint n) (Tint sz sg) + | is_true_pointer_int: forall b ofs sz sg, + is_true (Vptr b ofs) (Tint sz sg) + | is_true_int_pointer: forall n t, + n <> Int.zero -> + is_true (Vint n) (Tpointer t) + | is_true_pointer_pointer: forall b ofs t, + is_true (Vptr b ofs) (Tpointer t) + | is_true_float: forall f sz, + f <> Float.zero -> + is_true (Vfloat f) (Tfloat sz). + +Inductive bool_of_val : val -> type -> val -> Prop := + | bool_of_val_true: forall v ty, + is_true v ty -> + bool_of_val v ty Vtrue + | bool_of_val_false: forall v ty, + is_false v ty -> + bool_of_val v ty Vfalse. + +Function sem_neg (v: val) (ty: type) : option val := + match ty with + | Tint _ _ => + match v with + | Vint n => Some (Vint (Int.neg n)) + | _ => None + end + | Tfloat _ => + match v with + | Vfloat f => Some (Vfloat (Float.neg f)) + | _ => None + end + | _ => None + end. + +Function sem_notint (v: val) : option val := + match v with + | Vint n => Some (Vint (Int.xor n Int.mone)) + | _ => None + end. + +Function sem_notbool (v: val) (ty: type) : option val := + match ty with + | Tint _ _ => + match v with + | Vint n => Some (Val.of_bool (Int.eq n Int.zero)) + | Vptr _ _ => Some Vfalse + | _ => None + end + | Tpointer _ => + match v with + | Vint n => Some (Val.of_bool (Int.eq n Int.zero)) + | Vptr _ _ => Some Vfalse + | _ => None + end + | Tfloat _ => + match v with + | Vfloat f => Some (Val.of_bool (Float.cmp Ceq f Float.zero)) + | _ => None + end + | _ => None + end. + +Function sem_add (v1:val) (t1:type) (v2: val) (t2:type) : option val := + match classify_add t1 t2 with + | add_case_ii => + match v1, v2 with + | Vint n1, Vint n2 => Some (Vint (Int.add n1 n2)) + | _, _ => None + end + | add_case_ff => + match v1, v2 with + | Vfloat n1, Vfloat n2 => Some (Vfloat (Float.add n1 n2)) + | _, _ => None + end + | add_case_pi ty=> + match v1,v2 with + | Vptr b1 ofs1, Vint n2 => + Some (Vptr b1 (Int.add ofs1 (Int.mul (Int.repr (sizeof ty)) n2))) + | _, _ => None + end + | add_default => None +end. + +Function sem_sub (v1:val) (t1:type) (v2: val) (t2:type) : option val := + match classify_sub t1 t2 with + | sub_case_ii => (* integer subtraction *) + match v1,v2 with + | Vint n1, Vint n2 => Some (Vint (Int.sub n1 n2)) + | _, _ => None + end + | sub_case_ff => (* float subtraction *) + match v1,v2 with + | Vfloat f1, Vfloat f2 => Some (Vfloat(Float.sub f1 f2)) + | _, _ => None + end + | sub_case_pi ty => (*array| pointer - offset *) + match v1,v2 with + | Vptr b1 ofs1, Vint n2 => + Some (Vptr b1 (Int.sub ofs1 (Int.mul (Int.repr (sizeof ty)) n2))) + | _, _ => None + end + | sub_case_pp ty => (* array|pointer - array|pointer *) + match v1,v2 with + | Vptr b1 ofs1, Vptr b2 ofs2 => + if zeq b1 b2 then + if Int.eq (Int.repr (sizeof ty)) Int.zero then None + else Some (Vint (Int.divu (Int.sub ofs1 ofs2) (Int.repr (sizeof ty)))) + else None + | _, _ => None + end + | sub_default => None + end. + +Function sem_mul (v1:val) (t1:type) (v2: val) (t2:type) : option val := + match classify_mul t1 t2 with + | mul_case_ii => + match v1,v2 with + | Vint n1, Vint n2 => Some (Vint (Int.mul n1 n2)) + | _, _ => None + end + | mul_case_ff => + match v1,v2 with + | Vfloat f1, Vfloat f2 => Some (Vfloat (Float.mul f1 f2)) + | _, _ => None + end + | mul_default => + None +end. + +Function sem_div (v1:val) (t1:type) (v2: val) (t2:type) : option val := + match classify_div t1 t2 with + | div_case_I32unsi => + match v1,v2 with + | Vint n1, Vint n2 => + if Int.eq n2 Int.zero then None else Some (Vint (Int.divu n1 n2)) + | _,_ => None + end + | div_case_ii => + match v1,v2 with + | Vint n1, Vint n2 => + if Int.eq n2 Int.zero then None else Some (Vint(Int.divs n1 n2)) + | _,_ => None + end + | div_case_ff => + match v1,v2 with + | Vfloat f1, Vfloat f2 => Some (Vfloat(Float.div f1 f2)) + | _, _ => None + end + | div_default => + None +end. + +Function sem_mod (v1:val) (t1:type) (v2: val) (t2:type) : option val := + match classify_mod t1 t2 with + | mod_case_I32unsi => + match v1, v2 with + | Vint n1, Vint n2 => + if Int.eq n2 Int.zero then None else Some (Vint (Int.modu n1 n2)) + | _, _ => None + end + | mod_case_ii => + match v1,v2 with + | Vint n1, Vint n2 => + if Int.eq n2 Int.zero then None else Some (Vint (Int.mods n1 n2)) + | _, _ => None + end + | mod_default => + None + end. + +Function sem_and (v1 v2: val) : option val := + match v1, v2 with + | Vint n1, Vint n2 => Some (Vint(Int.and n1 n2)) + | _, _ => None + end . + +Function sem_or (v1 v2: val) : option val := + match v1, v2 with + | Vint n1, Vint n2 => Some (Vint(Int.or n1 n2)) + | _, _ => None + end. + +Function sem_xor (v1 v2: val): option val := + match v1, v2 with + | Vint n1, Vint n2 => Some (Vint(Int.xor n1 n2)) + | _, _ => None + end. + +Function sem_shl (v1 v2: val): option val := + match v1, v2 with + | Vint n1, Vint n2 => + if Int.ltu n2 (Int.repr 32) then Some (Vint(Int.shl n1 n2)) else None + | _, _ => None + end. + +Function sem_shr (v1: val) (t1: type) (v2: val) (t2: type): option val := + match classify_shr t1 t2 with + | shr_case_I32unsi => + match v1,v2 with + | Vint n1, Vint n2 => + if Int.ltu n2 (Int.repr 32) then Some (Vint (Int.shru n1 n2)) else None + | _,_ => None + end + | shr_case_ii => + match v1,v2 with + | Vint n1, Vint n2 => + if Int.ltu n2 (Int.repr 32) then Some (Vint (Int.shr n1 n2)) else None + | _, _ => None + end + | shr_default=> + None + end. + +Function sem_cmp_mismatch (c: comparison): option val := + match c with + | Ceq => Some Vfalse + | Cne => Some Vtrue + | _ => None + end. + +Function sem_cmp (c:comparison) + (v1: val) (t1: type) (v2: val) (t2: type) + (m: mem): option val := + match classify_cmp t1 t2 with + | cmp_case_I32unsi => + match v1,v2 with + | Vint n1, Vint n2 =>Some (Val.of_bool (Int.cmpu c n1 n2)) + | _, _ => None + end + | cmp_case_ii => + match v1,v2 with + | Vint n1, Vint n2 =>Some (Val.of_bool (Int.cmp c n1 n2)) + | _, _ => None + end + | cmp_case_ff => + match v1,v2 with + | Vfloat f1, Vfloat f2 =>Some (Val.of_bool (Float.cmp c f1 f2)) + | _, _ => None + end + | cmp_case_pi => + match v1,v2 with + | Vptr b ofs, Vint n2 => + if Int.eq n2 Int.zero then sem_cmp_mismatch c else None + | _, _ => None + end + | cmp_case_pp => + match v1,v2 with + | Vptr b1 ofs1, Vptr b2 ofs2 => + if valid_pointer m b1 (Int.signed ofs1) && valid_pointer m b2 (Int.signed ofs2) then + if zeq b1 b2 + then Some (Val.of_bool (Int.cmp c ofs1 ofs2)) + else None + else None + | _, _ => None + end + | cmp_default => None + end. + +Definition sem_unary_operation + (op: unary_operation) (v: val) (ty: type): option val := + match op with + | Onotbool => sem_notbool v ty + | Onotint => sem_notint v + | Oneg => sem_neg v ty + end. + +Definition sem_binary_operation + (op: binary_operation) + (v1: val) (t1: type) (v2: val) (t2:type) + (m: mem): option val := + match op with + | Oadd => sem_add v1 t1 v2 t2 + | Osub => sem_sub v1 t1 v2 t2 + | Omul => sem_mul v1 t1 v2 t2 + | Omod => sem_mod v1 t1 v2 t2 + | Odiv => sem_div v1 t1 v2 t2 + | Oand => sem_and v1 v2 + | Oor => sem_or v1 v2 + | Oxor => sem_xor v1 v2 + | Oshl => sem_shl v1 v2 + | Oshr => sem_shr v1 t1 v2 t2 + | Oeq => sem_cmp Ceq v1 t1 v2 t2 m + | One => sem_cmp Cne v1 t1 v2 t2 m + | Olt => sem_cmp Clt v1 t1 v2 t2 m + | Ogt => sem_cmp Cgt v1 t1 v2 t2 m + | Ole => sem_cmp Cle v1 t1 v2 t2 m + | Oge => sem_cmp Cge v1 t1 v2 t2 m + end. + +Definition cast_int_int (sz: intsize) (sg: signedness) (i: int) : int := + match sz, sg with + | I8, Signed => Int.cast8signed i + | I8, Unsigned => Int.cast8unsigned i + | I16, Signed => Int.cast16signed i + | I16, Unsigned => Int.cast16unsigned i + | I32 , _ => i + end. + +Definition cast_int_float (si : signedness) (i: int) : float := + match si with + | Signed => Float.floatofint i + | Unsigned => Float.floatofintu i + end. + +Definition cast_float_float (sz: floatsize) (f: float) : float := + match sz with + | F32 => Float.singleoffloat f + | F64 => f + end. + +Inductive cast : val -> type -> type -> val -> Prop := + | cast_ii: forall i sz2 sz1 si1 si2, + cast (Vint i) (Tint sz1 si1) (Tint sz2 si2) + (Vint (cast_int_int sz2 si2 i)) + | cast_fi: forall f sz1 sz2 si2, + cast (Vfloat f) (Tfloat sz1) (Tint sz2 si2) + (Vint (cast_int_int sz2 si2 (Float.intoffloat f))) + | cast_if: forall i sz1 sz2 si1, + cast (Vint i) (Tint sz1 si1) (Tfloat sz2) + (Vfloat (cast_float_float sz2 (cast_int_float si1 i))) + | cast_ff: forall f sz1 sz2, + cast (Vfloat f) (Tfloat sz1) (Tfloat sz2) + (Vfloat (cast_float_float sz2 f)) + | cast_ip_p: forall b ofs t1 si2, + cast (Vptr b ofs) (Tint I32 si2) (Tpointer t1) (Vptr b ofs) + | cast_pi_p: forall b ofs t1 si2, + cast (Vptr b ofs) (Tpointer t1) (Tint I32 si2) (Vptr b ofs) + | cast_pp_p: forall b ofs t1 t2, + cast (Vptr b ofs) (Tpointer t1) (Tpointer t2) (Vptr b ofs) + | cast_ip_i: forall n t1 si2, + cast (Vint n) (Tint I32 si2) (Tpointer t1) (Vint n) + | cast_pi_i: forall n t1 si2, + cast (Vint n) (Tpointer t1) (Tint I32 si2) (Vint n) + | cast_pp_i: forall n t1 t2, + cast (Vint n) (Tpointer t1) (Tpointer t2) (Vint n). + +(** ** Operational semantics *) + +(** Global environment *) + +Definition genv := Genv.t fundef. + +Definition globalenv (p: program) : genv := + Genv.globalenv (program_of_program p). + +Definition init_mem (p: program) : mem := + Genv.init_mem (program_of_program p). + +(** Local environment *) + +Definition env := PTree.t block. (* map variable -> location *) + +Definition empty_env: env := (PTree.empty block). + +(** Outcomes for statements *) + +Inductive outcome: Set := + | Out_break: outcome + | Out_continue: outcome + | Out_normal: outcome + | Out_return: option val -> outcome. + +Inductive out_normal_or_continue : outcome -> Prop := + | Out_normal_or_continue_N: out_normal_or_continue Out_normal + | Out_normal_or_continue_C: out_normal_or_continue Out_continue. + +Inductive out_break_or_return : outcome -> outcome -> Prop := + | Out_break_or_return_B: out_break_or_return Out_break Out_normal + | Out_break_or_return_R: forall ov, + out_break_or_return (Out_return ov) (Out_return ov). + +Definition outcome_switch (out: outcome) : outcome := + match out with + | Out_break => Out_normal + | o => o + end. + +Definition outcome_result_value (out: outcome) (t: type) (v: val) : Prop := + match out, t with + | Out_normal, Tvoid => v = Vundef + | Out_return None, Tvoid => v = Vundef + | Out_return (Some v'), ty => ty <> Tvoid /\ v'=v + | _, _ => False + end. + +(** Selection of the appropriate case of a [switch] *) + +Fixpoint select_switch (n: int) (sl: labeled_statements) + {struct sl}: labeled_statements := + match sl with + | LSdefault _ => sl + | LScase c s sl' => if Int.eq c n then sl else select_switch n sl' + end. + +(** Loads and stores by type *) + +Definition load_value_of_type (ty: type) (m: mem) (b: block) (ofs: int) : option val := + match access_mode ty with + | By_value chunk => Mem.loadv chunk m (Vptr b ofs) + | By_reference => Some (Vptr b ofs) + | By_nothing => None + end. + +Definition store_value_of_type (ty_dest: type) (m: mem) (loc: block) (ofs: int) (v: val) : option mem := + match access_mode ty_dest with + | By_value chunk => Mem.storev chunk m (Vptr loc ofs) v + | By_reference => None + | By_nothing => None + end. + +(** Allocation and initialization of function-local variables *) + +Inductive alloc_variables: env -> mem -> + list (ident * type) -> + env -> mem -> list block -> Prop := + | alloc_variables_nil: + forall e m, + alloc_variables e m nil e m nil + | alloc_variables_cons: + forall e m id ty vars m1 b1 m2 e2 lb, + Mem.alloc m 0 (sizeof ty) = (m1, b1) -> + alloc_variables (PTree.set id b1 e) m1 vars e2 m2 lb -> + alloc_variables e m ((id, ty) :: vars) e2 m2 (b1 :: lb). + +Inductive bind_parameters: env -> + mem -> list (ident * type) -> list val -> + mem -> Prop := + | bind_parameters_nil: + forall e m, + bind_parameters e m nil nil m + | bind_parameters_cons: + forall e m id ty params v1 vl b m1 m2, + PTree.get id e = Some b -> + store_value_of_type ty m b Int.zero v1 = Some m1 -> + bind_parameters e m1 params vl m2 -> + bind_parameters e m ((id, ty) :: params) (v1 :: vl) m2. + +Section RELSEM. + +Variable ge: genv. + +(** Evaluation of an expression in r-value position *) + +Inductive eval_expr: env -> mem -> expr -> trace -> mem -> val -> Prop := + | eval_Econst_int: forall e m i ty, + eval_expr e m (Expr (Econst_int i) ty) + E0 m (Vint i) + | eval_Econst_float: forall e m f ty, + eval_expr e m (Expr (Econst_float f) ty) + E0 m (Vfloat f) + | eval_Elvalue: forall e m a ty t m1 loc ofs v, + eval_lvalue e m (Expr a ty) t m1 loc ofs -> + load_value_of_type ty m1 loc ofs = Some v -> + eval_expr e m (Expr a ty) + t m1 v + | eval_Eaddrof: forall e m a t m1 loc ofs ty, + eval_lvalue e m a t m1 loc ofs -> + eval_expr e m (Expr (Eaddrof a) ty) + t m1 (Vptr loc ofs) + | eval_Esizeof: forall e m ty' ty, + eval_expr e m (Expr (Esizeof ty') ty) + E0 m (Vint (Int.repr (sizeof ty'))) + | eval_Eunop: forall e m op a ty t m1 v1 v, + eval_expr e m a t m1 v1 -> + sem_unary_operation op v1 (typeof a) = Some v -> + eval_expr e m (Expr (Eunop op a) ty) + t m1 v + | eval_Ebinop: forall e m op a1 a2 ty t1 m1 v1 t2 m2 v2 v, + eval_expr e m a1 t1 m1 v1 -> + eval_expr e m1 a2 t2 m2 v2 -> + sem_binary_operation op v1 (typeof a1) v2 (typeof a2) m2 = Some v -> + eval_expr e m (Expr (Ebinop op a1 a2) ty) + (t1 ** t2) m2 v + | eval_Eorbool_1: forall e m a1 a2 t m1 v1 ty, + eval_expr e m a1 t m1 v1 -> + is_true v1 (typeof a1) -> + eval_expr e m (Expr (Eorbool a1 a2) ty) + t m1 Vtrue + | eval_Eorbool_2: forall e m a1 a2 ty t1 m1 v1 t2 m2 v2 v, + eval_expr e m a1 t1 m1 v1 -> + is_false v1 (typeof a1) -> + eval_expr e m1 a2 t2 m2 v2 -> + bool_of_val v2 (typeof a2) v -> + eval_expr e m (Expr (Eorbool a1 a2) ty) + (t1 ** t2) m2 v + | eval_Eandbool_1: forall e m a1 a2 t m1 v1 ty, + eval_expr e m a1 t m1 v1 -> + is_false v1 (typeof a1) -> + eval_expr e m (Expr (Eandbool a1 a2) ty) + t m1 Vfalse + | eval_Eandbool_2: forall e m a1 a2 ty t1 m1 v1 t2 m2 v2 v, + eval_expr e m a1 t1 m1 v1 -> + is_true v1 (typeof a1) -> + eval_expr e m1 a2 t2 m2 v2 -> + bool_of_val v2 (typeof a2) v -> + eval_expr e m (Expr (Eandbool a1 a2) ty) + (t1 ** t2) m2 v + | eval_Ecast: forall e m a ty t m1 v1 v, + eval_expr e m a t m1 v1 -> + cast v1 (typeof a) ty v -> + eval_expr e m (Expr (Ecast ty a) ty) + t m1 v + | eval_Ecall: forall e m a bl ty m3 vres t1 m1 vf t2 m2 vargs f t3, + eval_expr e m a t1 m1 vf -> + eval_exprlist e m1 bl t2 m2 vargs -> + Genv.find_funct ge vf = Some f -> + type_of_fundef f = typeof a -> + eval_funcall m2 f vargs t3 m3 vres -> + eval_expr e m (Expr (Ecall a bl) ty) + (t1 ** t2 ** t3) m3 vres + +(** Evaluation of an expression in l-value position *) + +with eval_lvalue: env -> mem -> expr -> trace -> mem -> block -> int -> Prop := + | eval_Evar_local: forall e m id l ty, + e!id = Some l -> + eval_lvalue e m (Expr (Evar id) ty) + E0 m l Int.zero + | eval_Evar_global: forall e m id l ty, + e!id = None -> + Genv.find_symbol ge id = Some l -> + eval_lvalue e m (Expr (Evar id) ty) + E0 m l Int.zero + | eval_Ederef: forall e m m1 a t ofs ty l, + eval_expr e m a t m1 (Vptr l ofs) -> + eval_lvalue e m (Expr (Ederef a) ty) + t m1 l ofs + | eval_Eindex: forall e m a1 t1 m1 v1 a2 t2 m2 v2 l ofs ty, + eval_expr e m a1 t1 m1 v1 -> + eval_expr e m1 a2 t2 m2 v2 -> + sem_add v1 (typeof a1) v2 (typeof a2) = Some (Vptr l ofs) -> + eval_lvalue e m (Expr (Eindex a1 a2) ty) + (t1 ** t2) m2 l ofs + | eval_Efield_struct: forall e m a t m1 l ofs fList i ty delta, + eval_lvalue e m a t m1 l ofs -> + typeof a = Tstruct fList -> + field_offset i fList = Some delta -> + eval_lvalue e m (Expr (Efield a i) ty) + t m1 l (Int.add ofs (Int.repr delta)) + | eval_Efield_union: forall e m a t m1 l ofs fList i ty, + eval_lvalue e m a t m1 l ofs -> + typeof a = Tunion fList -> + eval_lvalue e m (Expr (Efield a i) ty) + t m1 l ofs + +(** Evaluation of a list of expressions *) + +with eval_exprlist: env -> mem -> exprlist -> trace -> mem -> list val -> Prop := + | eval_Enil: forall e m, + eval_exprlist e m Enil E0 m nil + | eval_Econs: forall e m a bl t1 m1 v t2 m2 vl, + eval_expr e m a t1 m1 v -> + eval_exprlist e m1 bl t2 m2 vl -> + eval_exprlist e m (Econs a bl) + (t1 ** t2) m2 (v :: vl) + +(** Execution of a statement *) + +with exec_stmt: env -> mem -> statement -> trace -> mem -> outcome -> Prop := + | exec_Sskip: forall e m, + exec_stmt e m Sskip + E0 m Out_normal + | exec_Sexpr: forall e m a t m1 v, + eval_expr e m a t m1 v -> + exec_stmt e m (Sexpr a) + t m1 Out_normal + | exec_Sassign: forall e m a1 a2 t1 m1 loc ofs t2 m2 v2 m3, + eval_lvalue e m a1 t1 m1 loc ofs -> + eval_expr e m1 a2 t2 m2 v2 -> + store_value_of_type (typeof a1) m2 loc ofs v2 = Some m3 -> + exec_stmt e m (Sassign a1 a2) + (t1 ** t2) m3 Out_normal + | exec_Sseq_1: forall e m s1 s2 t1 m1 t2 m2 out, + exec_stmt e m s1 t1 m1 Out_normal -> + exec_stmt e m1 s2 t2 m2 out -> + exec_stmt e m (Ssequence s1 s2) + (t1 ** t2) m2 out + | exec_Sseq_2: forall e m s1 s2 t1 m1 out, + exec_stmt e m s1 t1 m1 out -> + out <> Out_normal -> + exec_stmt e m (Ssequence s1 s2) + t1 m1 out + | exec_Sifthenelse_true: forall e m a s1 s2 t1 m1 v1 t2 m2 out, + eval_expr e m a t1 m1 v1 -> + is_true v1 (typeof a) -> + exec_stmt e m1 s1 t2 m2 out -> + exec_stmt e m (Sifthenelse a s1 s2) + (t1 ** t2) m2 out + | exec_Sifthenelse_false: forall e m a s1 s2 t1 m1 v1 t2 m2 out, + eval_expr e m a t1 m1 v1 -> + is_false v1 (typeof a) -> + exec_stmt e m1 s2 t2 m2 out -> + exec_stmt e m (Sifthenelse a s1 s2) + (t1 ** t2) m2 out + | exec_Sreturn_none: forall e m, + exec_stmt e m (Sreturn None) + E0 m (Out_return None) + | exec_Sreturn_some: forall e m a t m1 v, + eval_expr e m a t m1 v -> + exec_stmt e m (Sreturn (Some a)) + t m1 (Out_return (Some v)) + | exec_Sbreak: forall e m, + exec_stmt e m Sbreak + E0 m Out_break + | exec_Scontinue: forall e m, + exec_stmt e m Scontinue + E0 m Out_continue + | exec_Swhile_false: forall e m s a t v m1, + eval_expr e m a t m1 v -> + is_false v (typeof a) -> + exec_stmt e m (Swhile a s) + t m1 Out_normal + | exec_Swhile_stop: forall e m a t1 m1 v s m2 t2 out2 out, + eval_expr e m a t1 m1 v -> + is_true v (typeof a) -> + exec_stmt e m1 s t2 m2 out2 -> + out_break_or_return out2 out -> + exec_stmt e m (Swhile a s) + (t1 ** t2) m2 out + | exec_Swhile_loop: forall e m a t1 m1 v s out2 out t2 m2 t3 m3, + eval_expr e m a t1 m1 v -> + is_true v (typeof a) -> + exec_stmt e m1 s t2 m2 out2 -> + out_normal_or_continue out2 -> + exec_stmt e m2 (Swhile a s) t3 m3 out -> + exec_stmt e m (Swhile a s) + (t1 ** t2 ** t3) m3 out + | exec_Sdowhile_false: forall e m s a t1 m1 out1 v t2 m2, + exec_stmt e m s t1 m1 out1 -> + out_normal_or_continue out1 -> + eval_expr e m1 a t2 m2 v -> + is_false v (typeof a) -> + exec_stmt e m (Sdowhile a s) + (t1 ** t2) m2 Out_normal + | exec_Sdowhile_stop: forall e m s a t m1 out1 out, + exec_stmt e m s t m1 out1 -> + out_break_or_return out1 out -> + exec_stmt e m (Sdowhile a s) + t m1 out + | exec_Sdowhile_loop: forall e m s a m1 m2 m3 t1 t2 t3 out out1 v, + exec_stmt e m s t1 m1 out1 -> + out_normal_or_continue out1 -> + eval_expr e m1 a t2 m2 v -> + is_true v (typeof a) -> + exec_stmt e m2 (Sdowhile a s) t3 m3 out -> + exec_stmt e m (Sdowhile a s) + (t1 ** t2 ** t3) m3 out + | exec_Sfor_start: forall e m s a1 a2 a3 out m1 m2 t1 t2, + exec_stmt e m a1 t1 m1 Out_normal -> + exec_stmt e m1 (Sfor Sskip a2 a3 s) t2 m2 out -> + exec_stmt e m (Sfor a1 a2 a3 s) + (t1 ** t2) m2 out + | exec_Sfor_false: forall e m s a2 a3 t v m1, + eval_expr e m a2 t m1 v -> + is_false v (typeof a2) -> + exec_stmt e m (Sfor Sskip a2 a3 s) + t m1 Out_normal + | exec_Sfor_stop: forall e m s a2 a3 v m1 m2 t1 t2 out2 out, + eval_expr e m a2 t1 m1 v -> + is_true v (typeof a2) -> + exec_stmt e m1 s t2 m2 out2 -> + out_break_or_return out2 out -> + exec_stmt e m (Sfor Sskip a2 a3 s) + (t1 ** t2) m2 out + | exec_Sfor_loop: forall e m s a2 a3 v m1 m2 m3 m4 t1 t2 t3 t4 out2 out, + eval_expr e m a2 t1 m1 v -> + is_true v (typeof a2) -> + exec_stmt e m1 s t2 m2 out2 -> + out_normal_or_continue out2 -> + exec_stmt e m2 a3 t3 m3 Out_normal -> + exec_stmt e m3 (Sfor Sskip a2 a3 s) t4 m4 out -> + exec_stmt e m (Sfor Sskip a2 a3 s) + (t1 ** t2 ** t3 ** t4) m4 out + | exec_Sswitch: forall e m a t1 m1 n sl t2 m2 out, + eval_expr e m a t1 m1 (Vint n) -> + exec_lblstmts e m1 (select_switch n sl) t2 m2 out -> + exec_stmt e m (Sswitch a sl) + (t1 ** t2) m2 (outcome_switch out) + +(** Execution of a list of labeled statements *) + +with exec_lblstmts: env -> mem -> labeled_statements -> trace -> mem -> outcome -> Prop := + | exec_LSdefault: forall e m s t m1 out, + exec_stmt e m s t m1 out -> + exec_lblstmts e m (LSdefault s) t m1 out + | exec_LScase_fallthrough: forall e m n s ls t1 m1 t2 m2 out, + exec_stmt e m s t1 m1 Out_normal -> + exec_lblstmts e m1 ls t2 m2 out -> + exec_lblstmts e m (LScase n s ls) (t1 ** t2) m2 out + | exec_LScase_stop: forall e m n s ls t m1 out, + exec_stmt e m s t m1 out -> out <> Out_normal -> + exec_lblstmts e m (LScase n s ls) t m1 out + +(** Evaluation of a function invocation *) + +with eval_funcall: mem -> fundef -> list val -> trace -> mem -> val -> Prop := + | eval_funcall_internal: forall m f vargs t e m1 lb m2 m3 out vres, + alloc_variables empty_env m (f.(fn_params) ++ f.(fn_vars)) e m1 lb -> + bind_parameters e m1 f.(fn_params) vargs m2 -> + exec_stmt e m2 f.(fn_body) t m3 out -> + outcome_result_value out f.(fn_return) vres -> + eval_funcall m (Internal f) vargs t (Mem.free_list m3 lb) vres + | eval_funcall_external: forall m id targs tres vargs t vres, + event_match (external_function id targs tres) vargs t vres -> + eval_funcall m (External id targs tres) vargs t m vres. + +Scheme eval_expr_ind6 := Minimality for eval_expr Sort Prop + with eval_lvalue_ind6 := Minimality for eval_lvalue Sort Prop + with eval_exprlist_ind6 := Minimality for eval_exprlist Sort Prop + with exec_stmt_ind6 := Minimality for exec_stmt Sort Prop + with exec_lblstmts_ind6 := Minimality for exec_lblstmts Sort Prop + with eval_funcall_ind6 := Minimality for eval_funcall Sort Prop. + +End RELSEM. + +(** Execution of a whole program *) + +Definition exec_program (p: program) (t: trace) (r: val) : Prop := + let ge := globalenv p in + let m0 := init_mem p in + exists b, exists f, exists m1, + Genv.find_symbol ge p.(prog_main) = Some b /\ + Genv.find_funct_ptr ge b = Some f /\ + type_of_fundef f = Tfunction Tnil (Tint I32 Signed) /\ + eval_funcall ge m0 f nil t m1 r. diff --git a/cfrontend/Cshmgen.v b/cfrontend/Cshmgen.v new file mode 100644 index 0000000..58c0bb8 --- /dev/null +++ b/cfrontend/Cshmgen.v @@ -0,0 +1,598 @@ +Require Import Coqlib. +Require Import Integers. +Require Import Floats. +Require Import AST. +Require Import Csyntax. +Require Import Csharpminor. + +(** The error monad *) + +Definition bind (A B: Set) (f: option A) (g: A -> option B) := + match f with None => None | Some x => g x end. + +Implicit Arguments bind [A B]. + +Notation "'do' X <- A ; B" := (bind A (fun X => B)) + (at level 200, X ident, A at level 100, B at level 200). + +(** ** Operations on C types *) + +Definition signature_of_function (f: Csyntax.function) : signature := + mksignature + (typlist_of_typelist (type_of_params (Csyntax.fn_params f))) + (opttyp_of_type (Csyntax.fn_return f)). + +Definition chunk_of_type (ty: type): option memory_chunk := + match access_mode ty with + | By_value chunk => Some chunk + | _ => None + end. + +Definition var_kind_of_type (ty: type): option var_kind := + match ty with + | Tint I8 Signed => Some(Vscalar Mint8signed) + | Tint I8 Unsigned => Some(Vscalar Mint8unsigned) + | Tint I16 Signed => Some(Vscalar Mint16signed) + | Tint I16 Unsigned => Some(Vscalar Mint16unsigned) + | Tint I32 _ => Some(Vscalar Mint32) + | Tfloat F32 => Some(Vscalar Mfloat32) + | Tfloat F64 => Some(Vscalar Mfloat64) + | Tvoid => None + | Tpointer _ => Some(Vscalar Mint32) + | Tarray _ _ => Some(Varray (Csyntax.sizeof ty)) + | Tfunction _ _ => None + | Tstruct fList => Some(Varray (Csyntax.sizeof ty)) + | Tunion fList => Some(Varray (Csyntax.sizeof ty)) +end. + +(** ** Csharpminor constructors *) + +(* The following functions build Csharpminor expressions that compute + the value of a C operation. Most construction functions take + as arguments + - Csharpminor subexpressions that compute the values of the + arguments of the operation; + - The C types of the arguments of the operation. These types + are used to insert the necessary numeric conversions and to + resolve operation overloading. + Most of these functions return an [option expr], with [None] + denoting a case where the operation is not defined at the given types. +*) + +Definition make_intconst (n: int) := Eop (Ointconst n) Enil. + +Definition make_floatconst (f: float) := Eop (Ofloatconst f) Enil. + +Definition make_unop (op: operation) (e: expr) := Eop op (Econs e Enil). + +Definition make_binop (op: operation) (e1 e2: expr) := + Eop op (Econs e1 (Econs e2 Enil)). + +Definition make_floatofint (e: expr) (sg: signedness) := + match sg with + | Signed => make_unop Ofloatofint e + | Unsigned => make_unop Ofloatofintu e + end. + +(* [make_boolean e ty] returns a Csharpminor expression that evaluates + to the boolean value of [e]. Recall that: + - in Csharpminor, [false] is the integer 0, + [true] any non-zero integer or any pointer + - in C, [false] is the integer 0, the null pointer, the float 0.0 + [true] is any non-zero integer, non-null pointer, non-null float. +*) +Definition make_boolean (e: expr) (ty: type) := + match ty with + | Tfloat _ => make_binop (Ocmpf Cne) e (make_floatconst Float.zero) + | _ => e + end. + +Definition make_neg (e: expr) (ty: type) := + match ty with + | Tint _ _ => Some (make_binop Osub (make_intconst Int.zero) e) + | Tfloat _ => Some (make_unop Onegf e) + | _ => None + end. + +Definition make_notbool (e: expr) (ty: type) := + make_binop (Ocmp Ceq) (make_boolean e ty) (make_intconst Int.zero). + +Definition make_notint (e: expr) (ty: type) := + make_unop Onotint e. + +Definition make_add (e1: expr) (ty1: type) (e2: expr) (ty2: type) := + match classify_add ty1 ty2 with + | add_case_ii => Some (make_binop Oadd e1 e2) + | add_case_ff => Some (make_binop Oaddf e1 e2) + | add_case_pi ty => + let n := make_intconst (Int.repr (Csyntax.sizeof ty)) in + Some (make_binop Oadd e1 (make_binop Omul n e2)) + | add_default => None + end. + +Definition make_sub (e1: expr) (ty1: type) (e2: expr) (ty2: type) := + match classify_sub ty1 ty2 with + | sub_case_ii => Some (make_binop Osub e1 e2) + | sub_case_ff => Some (make_binop Osubf e1 e2) + | sub_case_pi ty => + let n := make_intconst (Int.repr (Csyntax.sizeof ty)) in + Some (make_binop Osub e1 (make_binop Omul n e2)) + | sub_case_pp ty => + let n := make_intconst (Int.repr (Csyntax.sizeof ty)) in + Some (make_binop Odivu (make_binop Osub e1 e2) n) + | sub_default => None + end. + +Definition make_mul (e1: expr) (ty1: type) (e2: expr) (ty2: type) := + match classify_mul ty1 ty2 with + | mul_case_ii => Some (make_binop Omul e1 e2) + | mul_case_ff => Some (make_binop Omulf e1 e2) + | mul_default => None + end. + +Definition make_div (e1: expr) (ty1: type) (e2: expr) (ty2: type) := + match classify_div ty1 ty2 with + | div_case_I32unsi => Some (make_binop Odivu e1 e2) + | div_case_ii => Some (make_binop Odiv e1 e2) + | div_case_ff => Some (make_binop Odivf e1 e2) + | div_default => None + end. + +Definition make_mod (e1: expr) (ty1: type) (e2: expr) (ty2: type) := + match classify_mod ty1 ty2 with + | mod_case_I32unsi => Some (make_binop Omodu e1 e2) + | mod_case_ii=> Some (make_binop Omod e1 e2) + | mod_default => None + end. + +Definition make_and (e1: expr) (ty1: type) (e2: expr) (ty2: type) := + Some(make_binop Oand e1 e2). + +Definition make_or (e1: expr) (ty1: type) (e2: expr) (ty2: type) := + Some(make_binop Oor e1 e2). + +Definition make_xor (e1: expr) (ty1: type) (e2: expr) (ty2: type) := + Some(make_binop Oxor e1 e2). + +Definition make_shl (e1: expr) (ty1: type) (e2: expr) (ty2: type) := + Some(make_binop Oshl e1 e2). + +Definition make_shr (e1: expr) (ty1: type) (e2: expr) (ty2: type) := + match classify_shr ty1 ty2 with + | shr_case_I32unsi => Some (make_binop Oshru e1 e2) + | shr_case_ii=> Some (make_binop Oshr e1 e2) + | shr_default => None + end. + +Definition make_cmp (c: comparison) (e1: expr) (ty1: type) (e2: expr) (ty2: type) := + match classify_cmp ty1 ty2 with + | cmp_case_I32unsi => Some (make_binop (Ocmpu c) e1 e2) + | cmp_case_ii => Some (make_binop (Ocmp c) e1 e2) + | cmp_case_ff => Some (make_binop (Ocmpf c) e1 e2) + | cmp_case_pi => Some (make_binop (Ocmp c) e1 e2) + | cmp_case_pp => Some (make_binop (Ocmp c) e1 e2) + | cmp_default => None + end. + +Definition make_andbool (e1: expr) (ty1: type) (e2: expr) (ty2: type) := + Econdition + (make_boolean e1 ty1) + (Econdition + (make_boolean e2 ty2) + (make_intconst Int.one) + (make_intconst Int.zero)) + (make_intconst Int.zero). + +Definition make_orbool (e1: expr) (ty1: type) (e2: expr) (ty2: type) := + Econdition + (make_boolean e1 ty1) + (make_intconst Int.one) + (Econdition + (make_boolean e2 ty2) + (make_intconst Int.one) + (make_intconst Int.zero)). + +(* [make_cast from to e] applies to [e] the numeric conversions needed + to transform a result of type [from] to a result of type [to]. + It is decomposed in two functions: + - [make_cast1] converts between int/pointer and float if necessary + - [make_cast2] converts to a "smaller" int or float type if necessary. +*) + +Definition make_cast1 (from to: type) (e: expr) := + match from, to with + | Tint _ uns, Tfloat _ => make_floatofint e uns + | Tfloat _, Tint _ _ => make_unop Ointoffloat e + | _, _ => e + end. + +Definition make_cast2 (from to: type) (e: expr) := + match to with + | Tint I8 Signed => make_unop Ocast8signed e + | Tint I8 Unsigned => make_unop Ocast8unsigned e + | Tint I16 Signed => make_unop Ocast16signed e + | Tint I16 Unsigned => make_unop Ocast16unsigned e + | Tfloat F32 => make_unop Osingleoffloat e + | _ => e + end. + +Definition make_cast (from to: type) (e: expr) := + make_cast2 from to (make_cast1 from to e). + +(* [make_load addr ty_res] loads a value of type [ty_res] from + the memory location denoted by the Csharpminor expression [addr]. + If [ty_res] is an array or function type, returns [addr] instead, + as consistent with C semantics. +*) + +Definition make_load (addr: expr) (ty_res: type) := + match (access_mode ty_res) with + | By_value chunk => Some (Eload chunk addr) + | By_reference => Some addr + | By_nothing => None + end. + +(* [make_store addr ty_res rhs ty_rhs] stores the value of the + Csharpminor expression [rhs] into the memory location denoted by the + Csharpminor expression [addr]. + [ty] is the type of the memory location. *) + +Definition make_store (addr: expr) (ty: type) (rhs: expr) := + match access_mode ty with + | By_value chunk => Some (Sstore chunk addr rhs) + | _ => None + end. + +(** ** Reading and writing variables *) + +(* [var_get id ty] builds Csharpminor code that evaluates to the + value of C variable [id] with type [ty]. Note that + C variables of array or function type evaluate to the address + of the corresponding CabsCoq memory block, while variables of other types + evaluate to the contents of the corresponding C memory block. +*) + +Definition var_get (id: ident) (ty: type) := + match access_mode ty with + | By_value chunk => Some (Evar id) + | By_reference => Some (Eaddrof id) + | _ => None + end. + +(* [var_set id ty rhs] stores the value of the Csharpminor + expression [rhs] into the CabsCoq variable [id] of type [ty]. +*) + +Definition var_set (id: ident) (ty: type) (rhs: expr) := + match access_mode ty with + | By_value chunk => Some (Sassign id rhs) + | _ => None + end. + +(** ** Translation of operators *) + +Definition transl_unop (op: unary_operation) (a: expr) (ta: type) : option expr := + match op with + | Csyntax.Onotbool => Some(make_notbool a ta) + | Csyntax.Onotint => Some(make_notint a ta) + | Csyntax.Oneg => make_neg a ta + end. + +Definition transl_binop (op: binary_operation) (a: expr) (ta: type) + (b: expr) (tb: type) : option expr := + match op with + | Csyntax.Oadd => make_add a ta b tb + | Csyntax.Osub => make_sub a ta b tb + | Csyntax.Omul => make_mul a ta b tb + | Csyntax.Odiv => make_div a ta b tb + | Csyntax.Omod => make_mod a ta b tb + | Csyntax.Oand => make_and a ta b tb + | Csyntax.Oor => make_or a ta b tb + | Csyntax.Oxor => make_xor a ta b tb + | Csyntax.Oshl => make_shl a ta b tb + | Csyntax.Oshr => make_shr a ta b tb + | Csyntax.Oeq => make_cmp Ceq a ta b tb + | Csyntax.One => make_cmp Cne a ta b tb + | Csyntax.Olt => make_cmp Clt a ta b tb + | Csyntax.Ogt => make_cmp Cgt a ta b tb + | Csyntax.Ole => make_cmp Cle a ta b tb + | Csyntax.Oge => make_cmp Cge a ta b tb + end. + +(** ** Translation of expressions *) + +(* [transl_expr a] returns the Csharpminor code that computes the value + of expression [a]. The result is an option type to enable error reporting. + + Most cases are self-explanatory. We outline the non-obvious cases: + + a && b ---> a ? (b ? 1 : 0) : 0 + + a || b ---> a ? 1 : (b ? 1 : 0) +*) + +Fixpoint transl_expr (a: Csyntax.expr) {struct a} : option expr := + match a with + | Expr (Csyntax.Econst_int n) _ => + Some(make_intconst n) + | Expr (Csyntax.Econst_float n) _ => + Some(make_floatconst n) + | Expr (Csyntax.Evar id) ty => + var_get id ty + | Expr (Csyntax.Ederef b) _ => + do tb <- transl_expr b; + make_load tb (typeof a) + | Expr (Csyntax.Eaddrof b) _ => + transl_lvalue b + | Expr (Csyntax.Eunop op b) _ => + do tb <- transl_expr b; + transl_unop op tb (typeof b) + | Expr (Csyntax.Ebinop op b c) _ => + do tb <- transl_expr b; + do tc <- transl_expr c; + transl_binop op tb (typeof b) tc (typeof c) + | Expr (Csyntax.Ecast ty b) _ => + do tb <- transl_expr b; + Some (make_cast (typeof b) ty tb) + | Expr (Csyntax.Eindex b c) ty => + do tb <- transl_expr b; + do tc <- transl_expr c; + do ts <- make_add tb (typeof b) tc (typeof c); + make_load ts ty + | Expr (Csyntax.Ecall b cl) _ => + match (classify_fun (typeof b)) with + | fun_case_f args res => + do tb <- transl_expr b; + do tcl <- transl_exprlist cl; + Some(Ecall (signature_of_type args res) tb tcl) + | _ => None + end + | Expr (Csyntax.Eandbool b c) _ => + do tb <- transl_expr b; + do tc <- transl_expr c; + Some(make_andbool tb (typeof b) tc (typeof c)) + | Expr (Csyntax.Eorbool b c) _ => + do tb <- transl_expr b; + do tc <- transl_expr c; + Some(make_orbool tb (typeof b) tc (typeof c)) + | Expr (Csyntax.Esizeof ty) _ => + Some(make_intconst (Int.repr (Csyntax.sizeof ty))) + | Expr (Csyntax.Efield b i) ty => + match typeof b with + | Tstruct fld => + do tb <- transl_lvalue b; + do ofs <- field_offset i fld; + make_load + (make_binop Oadd tb (make_intconst (Int.repr ofs))) + ty + | Tunion fld => + do tb <- transl_lvalue b; + make_load tb ty + | _ => None + end + end + +(* [transl_lvalue a] returns the Csharpminor code that evaluates + [a] as a lvalue, that is, code that returns the memory address + where the value of [a] is stored. +*) + +with transl_lvalue (a: Csyntax.expr) {struct a} : option expr := + match a with + | Expr (Csyntax.Evar id) _ => + Some (Eaddrof id) + | Expr (Csyntax.Ederef b) _ => + transl_expr b + | Expr (Csyntax.Eindex b c) _ => + do tb <- transl_expr b; + do tc <- transl_expr c; + make_add tb (typeof b) tc (typeof c) + | Expr (Csyntax.Efield b i) ty => + match typeof b with + | Tstruct fld => + do tb <- transl_lvalue b; + do ofs <- field_offset i fld; + Some (make_binop Oadd tb (make_intconst (Int.repr ofs))) + | Tunion fld => + transl_lvalue b + | _ => None + end + | _ => None + end + +(* [transl_exprlist al] returns a list of Csharpminor expressions + that compute the values of the list [al] of Csyntax expressions. + Used for function applications. *) + +with transl_exprlist (al: Csyntax.exprlist): option exprlist := + match al with + | Csyntax.Enil => Some Enil + | Csyntax.Econs a1 a2 => + do ta1 <- transl_expr a1; + do ta2 <- transl_exprlist a2; + Some (Econs ta1 ta2) + end. + +(** ** Translation of statements *) + +(** Determine if a C expression is a variable *) + +Definition is_variable (e: Csyntax.expr) : option ident := + match e with + | Expr (Csyntax.Evar id) _ => Some id + | _ => None + end. + +(* [exit_if_false e] return the statement that tests the boolean + value of the CabsCoq expression [e] and performs an [exit 0] if [e] + evaluates to false. +*) +Definition exit_if_false (e: Csyntax.expr) : option stmt := + do te <- transl_expr e; + Some(Sifthenelse + (make_notbool te (typeof e)) + (Sexit 0%nat) + Sskip). + +(* [transl_statement nbrk ncnt s] returns a Csharpminor statement + that performs the same computations as the CabsCoq statement [s]. + + If the statement [s] terminates prematurely on a [break] construct, + the generated Csharpminor statement terminates prematurely on an + [exit nbrk] construct. + + If the statement [s] terminates prematurely on a [continue] + construct, the generated Csharpminor statement terminates + prematurely on an [exit ncnt] construct. + + Immediately within a loop, [nbrk = 1] and [ncnt = 0], but this + changes when we're inside a [switch] construct. + + The general translation for loops is as follows: + +while (e1) s; ---> block { + loop { + if (!e1) exit 0; + block { s } + // continue in s branches here + } + } + // break in s branches here + +do s; while (e1); ---> block { + loop { + block { s } + // continue in s branches here + if (!e1) exit 0; + } + } + // break in s branches here + +for (e1;e2;e3) s; ---> e1; + block { + loop { + if (!e2) exit 0; + block { s } + // continue in s branches here + e3; + } + } + // break in s branches here + +switch (e) { ---> block { block { block { block { + case N1: s1; switch (e) { N1: exit 0; N2: exit 1; default: exit 2; } + case N2: s2; } ; s1 // with break -> exit 2 and continue -> exit 3 + default: s; } ; s2 // with break -> exit 1 and continue -> exit 2 +} } ; s // with break -> exit 0 and continue -> exit 1 + } +*) + +Fixpoint switch_table (sl: labeled_statements) (k: nat) {struct sl} : list (int * nat) := + match sl with + | LSdefault _ => nil + | LScase ni _ rem => (ni, k) :: switch_table rem (k+1) + end. + +Fixpoint transl_statement (nbrk ncnt: nat) (s: Csyntax.statement) {struct s} : option stmt := + match s with + | Csyntax.Sskip => + Some Sskip + | Csyntax.Sexpr e => + do te <- transl_expr e; + Some (Sexpr te) + | Csyntax.Sassign b c => + match (is_variable b) with + | Some id => + do tc <- transl_expr c; + var_set id (typeof b) tc + | None => + do tb <- transl_lvalue b; + do tc <- transl_expr c; + make_store tb (typeof b) tc + end + | Csyntax.Ssequence s1 s2 => + do ts1 <- transl_statement nbrk ncnt s1; + do ts2 <- transl_statement nbrk ncnt s2; + Some (Sseq ts1 ts2) + | Csyntax.Sifthenelse e s1 s2 => + do te <- transl_expr e; + do ts1 <- transl_statement nbrk ncnt s1; + do ts2 <- transl_statement nbrk ncnt s2; + Some (Sifthenelse (make_boolean te (typeof e)) ts1 ts2) + | Csyntax.Swhile e s1 => + do te <- exit_if_false e; + do ts1 <- transl_statement 1%nat 0%nat s1; + Some (Sblock (Sloop (Sseq te (Sblock ts1)))) + | Csyntax.Sdowhile e s1 => + do te <- exit_if_false e; + do ts1 <- transl_statement 1%nat 0%nat s1; + Some (Sblock (Sloop (Sseq (Sblock ts1) te))) + | Csyntax.Sfor e1 e2 e3 s1 => + do te1 <- transl_statement nbrk ncnt e1; + do te2 <- exit_if_false e2; + do te3 <- transl_statement nbrk ncnt e3; + do ts1 <- transl_statement 1%nat 0%nat s1; + Some (Sseq te1 (Sblock (Sloop (Sseq te2 (Sseq (Sblock ts1) te3))))) + | Csyntax.Sbreak => + Some (Sexit nbrk) + | Csyntax.Scontinue => + Some (Sexit ncnt) + | Csyntax.Sreturn (Some e) => + do te <- transl_expr e; + Some (Sreturn (Some te)) + | Csyntax.Sreturn None => + Some (Sreturn None) + | Csyntax.Sswitch e sl => + let cases := switch_table sl 0 in + let ncases := List.length cases in + do te <- transl_expr e; + transl_lblstmts ncases (ncnt + ncases + 1)%nat sl (Sblock (Sswitch te cases ncases)) + end + +with transl_lblstmts (nbrk ncnt: nat) (sl: labeled_statements) (body: stmt) + {struct sl}: option stmt := + match sl with + | LSdefault s => + do ts <- transl_statement nbrk ncnt s; + Some (Sblock (Sseq body ts)) + | LScase _ s rem => + do ts <- transl_statement nbrk ncnt s; + transl_lblstmts (pred nbrk) (pred ncnt) rem (Sblock (Sseq body ts)) + end. + +(*** Translation of functions *) + +Definition transl_params := transf_partial_program chunk_of_type. +Definition transl_vars := transf_partial_program var_kind_of_type. + +Definition transl_function (f: Csyntax.function) : option function := + do tparams <- transl_params (Csyntax.fn_params f); + do tvars <- transl_vars (Csyntax.fn_vars f); + do tbody <- transl_statement 1%nat 0%nat (Csyntax.fn_body f); + Some (mkfunction (signature_of_function f) tparams tvars tbody). + +Definition transl_fundef (f: Csyntax.fundef) : option fundef := + match f with + | Csyntax.Internal g => + do tg <- transl_function g; Some(AST.Internal tg) + | Csyntax.External id args res => + Some(AST.External (external_function id args res)) + end. + +(** ** Translation of programs *) + +Fixpoint transl_global_vars + (vl: list (ident * type * list init_data)) : + option (list (ident * var_kind * list init_data)) := + match vl with + | nil => Some nil + | (id, ty, init) :: rem => + do vk <- var_kind_of_type ty; + do trem <- transl_global_vars rem; + Some ((id, vk, init) :: trem) + end. + +Definition transl_program (p: Csyntax.program) : option program := + do tfun <- transf_partial_program transl_fundef (Csyntax.prog_funct p); + do tvars <- transl_global_vars (Csyntax.prog_defs p); + Some (mkprogram tfun (Csyntax.prog_main p) tvars). diff --git a/cfrontend/Cshmgenproof1.v b/cfrontend/Cshmgenproof1.v new file mode 100644 index 0000000..17f7aa9 --- /dev/null +++ b/cfrontend/Cshmgenproof1.v @@ -0,0 +1,288 @@ +(** * Correctness of the C front end, part 1: syntactic properties *) + +Require Import Coqlib. +Require Import Maps. +Require Import Integers. +Require Import Floats. +Require Import AST. +Require Import Values. +Require Import Events. +Require Import Mem. +Require Import Globalenvs. +Require Import Csyntax. +Require Import Csem. +Require Import Ctyping. +Require Import Csharpminor. +Require Import Cshmgen. + +(** Monadic simplification *) + +Ltac monadSimpl1 := + match goal with + | [ |- (bind ?F ?G = Some ?X) -> _ ] => + unfold bind at 1; + generalize (refl_equal F); + pattern F at -1 in |- *; + case F; + [ (let EQ := fresh "EQ" in + (intro; intro EQ; try monadSimpl1)) + | intro; intro; discriminate ] + | [ |- (None = Some _) -> _ ] => + intro; discriminate + | [ |- (Some _ = Some _) -> _ ] => + let h := fresh "H" in + (intro h; injection h; intro; clear h) + | [ |- (_ = Some _) -> _ ] => + let EQ := fresh "EQ" in intro EQ + end. + +Ltac monadSimpl := + match goal with + | [ |- (bind ?F ?G = Some ?X) -> _ ] => monadSimpl1 + | [ |- (None = Some _) -> _ ] => monadSimpl1 + | [ |- (Some _ = Some _) -> _ ] => monadSimpl1 + | [ |- (?F _ _ _ _ _ _ = Some _) -> _ ] => unfold F; fold F; monadSimpl1 + | [ |- (?F _ _ _ _ _ = Some _) -> _ ] => unfold F; fold F; monadSimpl1 + | [ |- (?F _ _ _ _ = Some _) -> _ ] => unfold F; fold F; monadSimpl1 + | [ |- (?F _ _ _ = Some _) -> _ ] => unfold F; fold F; monadSimpl1 + | [ |- (?F _ _ = Some _) -> _ ] => unfold F; fold F; monadSimpl1 + | [ |- (?F _ = Some _) -> _ ] => unfold F; fold F; monadSimpl1 + end. + +Ltac monadInv H := + generalize H; monadSimpl. + +(** Operations on types *) + +Lemma transl_fundef_sig1: + forall f tf args res, + transl_fundef f = Some tf -> + classify_fun (type_of_fundef f) = fun_case_f args res -> + funsig tf = signature_of_type args res. +Proof. + intros. destruct f; monadInv H. + monadInv EQ. rewrite <- H2. rewrite <- H3. simpl. + simpl in H0. inversion H0. reflexivity. + rewrite <- H2. simpl. + simpl in H0. congruence. +Qed. + +Lemma transl_fundef_sig2: + forall f tf args res, + transl_fundef f = Some tf -> + type_of_fundef f = Tfunction args res -> + funsig tf = signature_of_type args res. +Proof. + intros. eapply transl_fundef_sig1; eauto. + rewrite H0; reflexivity. +Qed. + +Lemma var_kind_by_value: + forall ty chunk, + access_mode ty = By_value chunk -> + var_kind_of_type ty = Some(Vscalar chunk). +Proof. + intros ty chunk; destruct ty; simpl; try congruence. + destruct i; try congruence; destruct s; congruence. + destruct f; congruence. +Qed. + +Lemma sizeof_var_kind_of_type: + forall ty vk, + var_kind_of_type ty = Some vk -> + Csharpminor.sizeof vk = Csyntax.sizeof ty. +Proof. + intros ty vk. + assert (sizeof (Varray (Csyntax.sizeof ty)) = Csyntax.sizeof ty). + simpl. rewrite Zmax_spec. apply zlt_false. + generalize (Csyntax.sizeof_pos ty). omega. + destruct ty; try (destruct i; try destruct s); try (destruct f); + simpl; intro EQ; inversion EQ; subst vk; auto. +Qed. + +(** Transformation of programs and functions *) + +Lemma transform_program_of_program: + forall prog tprog, + transl_program prog = Some tprog -> + transform_partial_program transl_fundef (Csyntax.program_of_program prog) = + Some (program_of_program tprog). +Proof. + intros prog tprog TRANSL. + monadInv TRANSL. rewrite <- H0. unfold program_of_program; simpl. + unfold transform_partial_program, Csyntax.program_of_program; simpl. + rewrite EQ. decEq. decEq. + generalize EQ0. generalize l0. generalize (prog_defs prog). + induction l1; simpl; intros. + inversion EQ1; subst l1. reflexivity. + destruct a as [[id ty] init]. monadInv EQ1. subst l2. simpl. decEq. apply IHl1. auto. +Qed. + +(** ** Some properties of the translation functions *) + +Lemma transf_partial_program_names: + forall (A B: Set) (f: A -> option B) + (l: list (ident * A)) (tl: list (ident * B)), + transf_partial_program f l = Some tl -> + List.map (@fst ident B) tl = List.map (@fst ident A) l. +Proof. + induction l; simpl. + intros. inversion H. reflexivity. + intro tl. destruct a as [id x]. destruct (f x); try congruence. + caseEq (transf_partial_program f l); intros; try congruence. + inversion H0; subst tl. simpl. decEq. auto. +Qed. + +Lemma transf_partial_program_append: + forall (A B: Set) (f: A -> option B) + (l1 l2: list (ident * A)) (tl1 tl2: list (ident * B)), + transf_partial_program f l1 = Some tl1 -> + transf_partial_program f l2 = Some tl2 -> + transf_partial_program f (l1 ++ l2) = Some (tl1 ++ tl2). +Proof. + induction l1; intros until tl2; simpl. + intros. inversion H. simpl; auto. + destruct a as [id x]. destruct (f x); try congruence. + caseEq (transf_partial_program f l1); intros; try congruence. + inversion H0. rewrite (IHl1 _ _ _ H H1). auto. +Qed. + +Lemma transl_params_names: + forall vars tvars, + transl_params vars = Some tvars -> + List.map (@fst ident memory_chunk) tvars = Ctyping.var_names vars. +Proof. + exact (transf_partial_program_names _ _ chunk_of_type). +Qed. + +Lemma transl_vars_names: + forall vars tvars, + transl_vars vars = Some tvars -> + List.map (@fst ident var_kind) tvars = Ctyping.var_names vars. +Proof. + exact (transf_partial_program_names _ _ var_kind_of_type). +Qed. + +Lemma transl_names_norepet: + forall params vars sg tparams tvars body, + list_norepet (var_names params ++ var_names vars) -> + transl_params params = Some tparams -> + transl_vars vars = Some tvars -> + let f := Csharpminor.mkfunction sg tparams tvars body in + list_norepet (fn_params_names f ++ fn_vars_names f). +Proof. + intros. unfold fn_params_names, fn_vars_names, f. simpl. + rewrite (transl_params_names _ _ H0). + rewrite (transl_vars_names _ _ H1). + auto. +Qed. + +Lemma transl_vars_append: + forall l1 l2 tl1 tl2, + transl_vars l1 = Some tl1 -> transl_vars l2 = Some tl2 -> + transl_vars (l1 ++ l2) = Some (tl1 ++ tl2). +Proof. + exact (transf_partial_program_append _ _ var_kind_of_type). +Qed. + +Lemma transl_params_vars: + forall params tparams, + transl_params params = Some tparams -> + transl_vars params = + Some (List.map (fun id_chunk => (fst id_chunk, Vscalar (snd id_chunk))) tparams). +Proof. + induction params; intro tparams; simpl. + intros. inversion H. reflexivity. + destruct a as [id x]. + unfold chunk_of_type. caseEq (access_mode x); try congruence. + intros chunk AM. + caseEq (transl_params params); intros; try congruence. + inversion H0. + rewrite (var_kind_by_value _ _ AM). + rewrite (IHparams _ H). reflexivity. +Qed. + +Lemma transl_fn_variables: + forall params vars sg tparams tvars body, + transl_params params = Some tparams -> + transl_vars vars = Some tvars -> + let f := Csharpminor.mkfunction sg tparams tvars body in + transl_vars (params ++ vars) = Some (fn_variables f). +Proof. + intros. + generalize (transl_params_vars _ _ H); intro. + rewrite (transl_vars_append _ _ _ _ H1 H0). + reflexivity. +Qed. + +(** Transformation of expressions and statements *) + +Lemma is_variable_correct: + forall a id, + is_variable a = Some id -> + a = Csyntax.Expr (Csyntax.Evar id) (typeof a). +Proof. + intros until id. destruct a as [ad aty]; simpl. + destruct ad; intros; try discriminate. + congruence. +Qed. + +Lemma transl_expr_lvalue: + forall ge e m1 a ty t m2 loc ofs ta, + Csem.eval_lvalue ge e m1 (Expr a ty) t m2 loc ofs -> + transl_expr (Expr a ty) = Some ta -> + (exists id, a = Csyntax.Evar id /\ var_get id ty = Some ta) \/ + (exists tb, transl_lvalue (Expr a ty) = Some tb /\ + make_load tb ty = Some ta). +Proof. + intros. inversion H; subst; clear H; simpl in H0. + left; exists id; auto. + left; exists id; auto. + monadInv H0. right. exists e0; split; auto. + simpl. monadInv H0. right. exists e2; split; auto. + simpl. rewrite H6 in H0. rewrite H6. + monadInv H0. right. + exists (make_binop Oadd e0 (make_intconst (Int.repr z))). split; auto. + simpl. rewrite H10 in H0. rewrite H10. + monadInv H0. right. + exists e0; auto. +Qed. + +Lemma transl_stmt_Sfor_start: + forall nbrk ncnt s1 e2 s3 s4 ts, + transl_statement nbrk ncnt (Sfor s1 e2 s3 s4) = Some ts -> + exists ts1, exists ts2, + ts = Sseq ts1 ts2 + /\ transl_statement nbrk ncnt s1 = Some ts1 + /\ transl_statement nbrk ncnt (Sfor Csyntax.Sskip e2 s3 s4) = Some (Sseq Sskip ts2). +Proof. + intros. monadInv H. simpl. + exists s; exists (Sblock (Sloop (Sseq s0 (Sseq (Sblock s5) s2)))). + intuition. +Qed. + +(** Properties related to switch constructs *) + +Fixpoint lblstmts_length (sl: labeled_statements) : nat := + match sl with + | LSdefault _ => 0%nat + | LScase _ _ sl' => S (lblstmts_length sl') + end. + +Lemma switch_target_table_shift: + forall n sl base dfl, + switch_target n (S dfl) (switch_table sl (S base)) = + S(switch_target n dfl (switch_table sl base)). +Proof. + induction sl; intros; simpl. + auto. + case (Int.eq n i). auto. auto. +Qed. + +Lemma length_switch_table: + forall sl base, List.length (switch_table sl base) = lblstmts_length sl. +Proof. + induction sl; intro; simpl. auto. decEq; auto. +Qed. + + diff --git a/cfrontend/Cshmgenproof2.v b/cfrontend/Cshmgenproof2.v new file mode 100644 index 0000000..602e33a --- /dev/null +++ b/cfrontend/Cshmgenproof2.v @@ -0,0 +1,419 @@ +(** * Correctness of the C front end, part 2: Csharpminor construction functions *) + +Require Import Coqlib. +Require Import Maps. +Require Import Integers. +Require Import Floats. +Require Import AST. +Require Import Values. +Require Import Events. +Require Import Mem. +Require Import Globalenvs. +Require Import Csyntax. +Require Import Csem. +Require Import Ctyping. +Require Import Csharpminor. +Require Import Cshmgen. +Require Import Cshmgenproof1. + +Section CONSTRUCTORS. + +Variable tprog: Csharpminor.program. + +(** Properties of the translation of [switch] constructs. *) + +Lemma transl_lblstmts_exit: + forall e m1 t m2 sl body n tsl nbrk ncnt, + exec_stmt tprog e m1 body t m2 (Out_exit (lblstmts_length sl + n)) -> + transl_lblstmts nbrk ncnt sl body = Some tsl -> + exec_stmt tprog e m1 tsl t m2 (outcome_block (Out_exit n)). +Proof. + induction sl; intros. + simpl in H; simpl in H0; monadInv H0. + rewrite <- H2. constructor. apply exec_Sseq_stop. auto. congruence. + simpl in H; simpl in H0; monadInv H0. + eapply IHsl with (body := Sblock (Sseq body s0)); eauto. + change (Out_exit (lblstmts_length sl + n)) + with (outcome_block (Out_exit (S (lblstmts_length sl + n)))). + constructor. apply exec_Sseq_stop. auto. congruence. +Qed. + +Lemma transl_lblstmts_return: + forall e m1 t m2 sl body optv tsl nbrk ncnt, + exec_stmt tprog e m1 body t m2 (Out_return optv) -> + transl_lblstmts nbrk ncnt sl body = Some tsl -> + exec_stmt tprog e m1 tsl t m2 (Out_return optv). +Proof. + induction sl; intros. + simpl in H; simpl in H0; monadInv H0. + rewrite <- H2. change (Out_return optv) with (outcome_block (Out_return optv)). + constructor. apply exec_Sseq_stop. auto. congruence. + simpl in H; simpl in H0; monadInv H0. + eapply IHsl with (body := Sblock (Sseq body s0)); eauto. + change (Out_return optv) with (outcome_block (Out_return optv)). + constructor. apply exec_Sseq_stop. auto. congruence. +Qed. + + +(** Correctness of Csharpminor construction functions *) + +Lemma make_intconst_correct: + forall n le e m1, + Csharpminor.eval_expr tprog le e m1 (make_intconst n) E0 m1 (Vint n). +Proof. + intros. unfold make_intconst. econstructor. constructor. reflexivity. +Qed. + +Lemma make_floatconst_correct: + forall n le e m1, + Csharpminor.eval_expr tprog le e m1 (make_floatconst n) E0 m1 (Vfloat n). +Proof. + intros. unfold make_floatconst. econstructor. constructor. reflexivity. +Qed. + +Lemma make_unop_correct: + forall op le e m1 a ta m2 va v, + Csharpminor.eval_expr tprog le e m1 a ta m2 va -> + eval_operation op (va :: nil) m2 = Some v -> + Csharpminor.eval_expr tprog le e m1 (make_unop op a) ta m2 v. +Proof. + intros. unfold make_unop. econstructor. econstructor. eauto. constructor. + traceEq. auto. +Qed. + +Lemma make_binop_correct: + forall op le e m1 a ta m2 va b tb m3 vb t v, + Csharpminor.eval_expr tprog le e m1 a ta m2 va -> + Csharpminor.eval_expr tprog le e m2 b tb m3 vb -> + eval_operation op (va :: vb :: nil) m3 = Some v -> + t = ta ** tb -> + Csharpminor.eval_expr tprog le e m1 (make_binop op a b) t m3 v. +Proof. + intros. unfold make_binop. + econstructor. econstructor. eauto. econstructor. eauto. constructor. + reflexivity. traceEq. auto. +Qed. + +Hint Resolve make_intconst_correct make_floatconst_correct + make_unop_correct make_binop_correct: cshm. +Hint Extern 2 (@eq trace _ _) => traceEq: cshm. + +Remark Vtrue_is_true: Val.is_true Vtrue. +Proof. + simpl. apply Int.one_not_zero. +Qed. + +Remark Vfalse_is_false: Val.is_false Vfalse. +Proof. + simpl. auto. +Qed. + +Lemma make_boolean_correct_true: + forall le e m1 a t m2 v ty, + Csharpminor.eval_expr tprog le e m1 a t m2 v -> + is_true v ty -> + exists vb, + Csharpminor.eval_expr tprog le e m1 (make_boolean a ty) t m2 vb + /\ Val.is_true vb. +Proof. + intros until ty; intros EXEC VTRUE. + destruct ty; simpl; + try (exists v; intuition; inversion VTRUE; simpl; auto; fail). + exists Vtrue; split. + eapply make_binop_correct; eauto with cshm. + inversion VTRUE; simpl. + replace (Float.cmp Cne f0 Float.zero) with (negb (Float.cmp Ceq f0 Float.zero)). + rewrite Float.eq_zero_false. reflexivity. auto. + rewrite Float.cmp_ne_eq. auto. + apply Vtrue_is_true. +Qed. + +Lemma make_boolean_correct_false: + forall le e m1 a t m2 v ty, + Csharpminor.eval_expr tprog le e m1 a t m2 v -> + is_false v ty -> + exists vb, + Csharpminor.eval_expr tprog le e m1 (make_boolean a ty) t m2 vb + /\ Val.is_false vb. +Proof. + intros until ty; intros EXEC VFALSE. + destruct ty; simpl; + try (exists v; intuition; inversion VFALSE; simpl; auto; fail). + exists Vfalse; split. + eapply make_binop_correct; eauto with cshm. + inversion VFALSE; simpl. + replace (Float.cmp Cne Float.zero Float.zero) with (negb (Float.cmp Ceq Float.zero Float.zero)). + rewrite Float.eq_zero_true. reflexivity. + rewrite Float.cmp_ne_eq. auto. + apply Vfalse_is_false. +Qed. + +Lemma make_neg_correct: + forall a tya c ta va v le e m1 m2, + sem_neg va tya = Some v -> + make_neg a tya = Some c -> + eval_expr tprog le e m1 a ta m2 va -> + eval_expr tprog le e m1 c ta m2 v. +Proof. + intros until m2; intro SEM. unfold make_neg. + functional inversion SEM; intros. + inversion H4. eapply make_binop_correct; eauto with cshm. + inversion H4. eauto with cshm. +Qed. + +Lemma make_notbool_correct: + forall a tya c ta va v le e m1 m2, + sem_notbool va tya = Some v -> + make_notbool a tya = c -> + eval_expr tprog le e m1 a ta m2 va -> + eval_expr tprog le e m1 c ta m2 v. +Proof. + intros until m2; intro SEM. unfold make_notbool. + functional inversion SEM; intros; inversion H4; simpl; + eauto with cshm. + eapply make_binop_correct. + eapply make_binop_correct. eauto. eauto with cshm. + simpl; reflexivity. reflexivity. eauto with cshm. + simpl. rewrite Float.cmp_ne_eq. + destruct (Float.cmp Ceq f Float.zero); reflexivity. + traceEq. +Qed. + +Lemma make_notint_correct: + forall a tya c ta va v le e m1 m2, + sem_notint va = Some v -> + make_notint a tya = c -> + eval_expr tprog le e m1 a ta m2 va -> + eval_expr tprog le e m1 c ta m2 v. +Proof. + intros until m2; intro SEM. unfold make_notint. + functional inversion SEM; intros. + inversion H2; eauto with cshm. +Qed. + +Definition binary_constructor_correct + (make: expr -> type -> expr -> type -> option expr) + (sem: val -> type -> val -> type -> option val): Prop := + forall a tya b tyb c ta va tb vb v le e m1 m2 m3, + sem va tya vb tyb = Some v -> + make a tya b tyb = Some c -> + eval_expr tprog le e m1 a ta m2 va -> + eval_expr tprog le e m2 b tb m3 vb -> + eval_expr tprog le e m1 c (ta ** tb) m3 v. + +Definition binary_constructor_correct' + (make: expr -> type -> expr -> type -> option expr) + (sem: val -> val -> option val): Prop := + forall a tya b tyb c ta va tb vb v le e m1 m2 m3, + sem va vb = Some v -> + make a tya b tyb = Some c -> + eval_expr tprog le e m1 a ta m2 va -> + eval_expr tprog le e m2 b tb m3 vb -> + eval_expr tprog le e m1 c (ta ** tb) m3 v. + +Lemma make_add_correct: binary_constructor_correct make_add sem_add. +Proof. + red; intros until m3. intro SEM. unfold make_add. + functional inversion SEM; rewrite H0; intros. + inversion H7. eauto with cshm. + inversion H7. eauto with cshm. + inversion H7. + eapply make_binop_correct. eauto. + eapply make_binop_correct. eauto with cshm. eauto. + simpl. reflexivity. reflexivity. + simpl. reflexivity. traceEq. +Qed. + +Lemma make_sub_correct: binary_constructor_correct make_sub sem_sub. +Proof. + red; intros until m3. intro SEM. unfold make_sub. + functional inversion SEM; rewrite H0; intros; + inversion H7; eauto with cshm. + eapply make_binop_correct. eauto. + eapply make_binop_correct. eauto with cshm. eauto. + simpl. reflexivity. reflexivity. + simpl. reflexivity. traceEq. + inversion H9. eapply make_binop_correct. + eapply make_binop_correct; eauto. + simpl. unfold eq_block; rewrite H3. reflexivity. + eauto with cshm. simpl. rewrite H8. reflexivity. traceEq. +Qed. + +Lemma make_mul_correct: binary_constructor_correct make_mul sem_mul. +Proof. + red; intros until m3. intro SEM. unfold make_mul. + functional inversion SEM; rewrite H0; intros; + inversion H7; eauto with cshm. +Qed. + +Lemma make_div_correct: binary_constructor_correct make_div sem_div. +Proof. + red; intros until m3. intro SEM. unfold make_div. + functional inversion SEM; rewrite H0; intros. + inversion H8. eapply make_binop_correct; eauto with cshm. + simpl. rewrite H7; auto. + inversion H8. eapply make_binop_correct; eauto with cshm. + simpl. rewrite H7; auto. + inversion H7; eauto with cshm. +Qed. + +Lemma make_mod_correct: binary_constructor_correct make_mod sem_mod. + red; intros until m3. intro SEM. unfold make_mod. + functional inversion SEM; rewrite H0; intros. + inversion H8. eapply make_binop_correct; eauto with cshm. + simpl. rewrite H7; auto. + inversion H8. eapply make_binop_correct; eauto with cshm. + simpl. rewrite H7; auto. +Qed. + +Lemma make_and_correct: binary_constructor_correct' make_and sem_and. +Proof. + red; intros until m3. intro SEM. unfold make_and. + functional inversion SEM. intros. inversion H4. + eauto with cshm. +Qed. + +Lemma make_or_correct: binary_constructor_correct' make_or sem_or. +Proof. + red; intros until m3. intro SEM. unfold make_or. + functional inversion SEM. intros. inversion H4. + eauto with cshm. +Qed. + +Lemma make_xor_correct: binary_constructor_correct' make_xor sem_xor. +Proof. + red; intros until m3. intro SEM. unfold make_xor. + functional inversion SEM. intros. inversion H4. + eauto with cshm. +Qed. + +Lemma make_shl_correct: binary_constructor_correct' make_shl sem_shl. +Proof. + red; intros until m3. intro SEM. unfold make_shl. + functional inversion SEM. intros. inversion H5. + eapply make_binop_correct; eauto with cshm. + simpl. rewrite H4. auto. +Qed. + +Lemma make_shr_correct: binary_constructor_correct make_shr sem_shr. +Proof. + red; intros until m3. intro SEM. unfold make_shr. + functional inversion SEM; intros; rewrite H0 in H8; inversion H8. + eapply make_binop_correct; eauto with cshm. + simpl; rewrite H7; auto. + eapply make_binop_correct; eauto with cshm. + simpl; rewrite H7; auto. +Qed. + +Lemma make_cmp_correct: + forall cmp a tya b tyb c ta va tb vb v le e m1 m2 m3, + sem_cmp cmp va tya vb tyb m3 = Some v -> + make_cmp cmp a tya b tyb = Some c -> + eval_expr tprog le e m1 a ta m2 va -> + eval_expr tprog le e m2 b tb m3 vb -> + eval_expr tprog le e m1 c (ta ** tb) m3 v. +Proof. + intros until m3. intro SEM. unfold make_cmp. + functional inversion SEM; rewrite H0; intros. + inversion H8. eauto with cshm. + inversion H8. eauto with cshm. + inversion H8. eauto with cshm. + inversion H9. eapply make_binop_correct; eauto with cshm. + simpl. functional inversion H; subst; unfold eval_compare_null; + rewrite H8; auto. + inversion H10. eapply make_binop_correct; eauto with cshm. + simpl. rewrite H3. unfold eq_block; rewrite H9. auto. +Qed. + +Lemma transl_unop_correct: + forall op a tya c ta va v le e m1 m2, + transl_unop op a tya = Some c -> + sem_unary_operation op va tya = Some v -> + eval_expr tprog le e m1 a ta m2 va -> + eval_expr tprog le e m1 c ta m2 v. +Proof. + intros. destruct op; simpl in *. + eapply make_notbool_correct; eauto. congruence. + eapply make_notint_correct with (tya := tya); eauto. congruence. + eapply make_neg_correct; eauto. +Qed. + +Lemma transl_binop_correct: +forall op a tya b tyb c ta va tb vb v le e m1 m2 m3, + transl_binop op a tya b tyb = Some c -> + sem_binary_operation op va tya vb tyb m3 = Some v -> + eval_expr tprog le e m1 a ta m2 va -> + eval_expr tprog le e m2 b tb m3 vb -> + eval_expr tprog le e m1 c (ta ** tb) m3 v. +Proof. + intros. destruct op; simpl in *. + eapply make_add_correct; eauto. + eapply make_sub_correct; eauto. + eapply make_mul_correct; eauto. + eapply make_div_correct; eauto. + eapply make_mod_correct; eauto. + eapply make_and_correct; eauto. + eapply make_or_correct; eauto. + eapply make_xor_correct; eauto. + eapply make_shl_correct; eauto. + eapply make_shr_correct; eauto. + eapply make_cmp_correct; eauto. + eapply make_cmp_correct; eauto. + eapply make_cmp_correct; eauto. + eapply make_cmp_correct; eauto. + eapply make_cmp_correct; eauto. + eapply make_cmp_correct; eauto. +Qed. + +Lemma make_cast_correct: + forall le e m1 a t m2 v ty1 ty2 v', + eval_expr tprog le e m1 a t m2 v -> + cast v ty1 ty2 v' -> + eval_expr tprog le e m1 (make_cast ty1 ty2 a) t m2 v'. +Proof. + unfold make_cast, make_cast1, make_cast2, make_unop. + intros until v'; intros EVAL CAST. + inversion CAST; clear CAST; subst; auto. + (* cast_int_int *) + destruct sz2; destruct si2; repeat econstructor; eauto with cshm. + (* cast_float_int *) + destruct sz2; destruct si2; repeat econstructor; eauto with cshm; simpl; auto. + (* cast_int_float *) + destruct sz2; destruct si1; unfold make_floatofint, make_unop; repeat econstructor; eauto with cshm; simpl; auto. + (* cast_float_float *) + destruct sz2; repeat econstructor; eauto with cshm. +Qed. + +Lemma make_load_correct: + forall addr ty code b ofs v le e m1 t m2, + make_load addr ty = Some code -> + eval_expr tprog le e m1 addr t m2 (Vptr b ofs) -> + load_value_of_type ty m2 b ofs = Some v -> + eval_expr tprog le e m1 code t m2 v. +Proof. + unfold make_load, load_value_of_type. + intros until m2; intros MKLOAD EVEXP LDVAL. + destruct (access_mode ty); inversion MKLOAD. + (* access_mode ty = By_value m *) + apply eval_Eload with (Vptr b ofs); auto. + (* access_mode ty = By_reference *) + subst code. inversion LDVAL. auto. +Qed. + +Lemma make_store_correct: + forall addr ty rhs code e m1 t1 m2 b ofs t2 m3 v m4, + make_store addr ty rhs = Some code -> + eval_expr tprog nil e m1 addr t1 m2 (Vptr b ofs) -> + eval_expr tprog nil e m2 rhs t2 m3 v -> + store_value_of_type ty m3 b ofs v = Some m4 -> + exec_stmt tprog e m1 code (t1 ** t2) m4 Out_normal. +Proof. + unfold make_store, store_value_of_type. + intros until m4; intros MKSTORE EV1 EV2 STVAL. + destruct (access_mode ty); inversion MKSTORE. + (* access_mode ty = By_value m *) + eapply eval_Sstore; eauto. +Qed. + +End CONSTRUCTORS. + diff --git a/cfrontend/Cshmgenproof3.v b/cfrontend/Cshmgenproof3.v new file mode 100644 index 0000000..b33771b --- /dev/null +++ b/cfrontend/Cshmgenproof3.v @@ -0,0 +1,1503 @@ +(** * Correctness of the C front end, part 3: semantic preservation *) + +Require Import Coqlib. +Require Import Maps. +Require Import Integers. +Require Import Floats. +Require Import AST. +Require Import Values. +Require Import Events. +Require Import Mem. +Require Import Globalenvs. +Require Import Csyntax. +Require Import Csem. +Require Import Ctyping. +Require Import Csharpminor. +Require Import Cshmgen. +Require Import Cshmgenproof1. +Require Import Cshmgenproof2. + +Section CORRECTNESS. + +Variable prog: Csyntax.program. +Variable tprog: Csharpminor.program. +Hypothesis WTPROG: wt_program prog. +Hypothesis TRANSL: transl_program prog = Some tprog. + +Let ge := Csem.globalenv prog. +Let tge := Genv.globalenv (Csharpminor.program_of_program tprog). + +Lemma symbols_preserved: + forall s, Genv.find_symbol tge s = Genv.find_symbol ge s. +Proof. + intros. unfold ge, Csem.globalenv, tge. + apply Genv.find_symbol_transf_partial with transl_fundef. + apply transform_program_of_program; auto. +Qed. + +Lemma functions_translated: + forall v f, + Genv.find_funct ge v = Some f -> + exists tf, Genv.find_funct tge v = Some tf /\ transl_fundef f = Some tf. +Proof. + intros. + generalize (Genv.find_funct_transf_partial transl_fundef (transform_program_of_program _ _ TRANSL) H). + intros [A B]. + destruct (transl_fundef f). exists f0; split. assumption. auto. congruence. +Qed. + +Lemma function_ptr_translated: + forall b f, + Genv.find_funct_ptr ge b = Some f -> + exists tf, Genv.find_funct_ptr tge b = Some tf /\ transl_fundef f = Some tf. +Proof. + intros. + generalize (Genv.find_funct_ptr_transf_partial transl_fundef (transform_program_of_program _ _ TRANSL) H). + intros [A B]. + destruct (transl_fundef f). exists f0; split. assumption. auto. congruence. +Qed. + +Lemma functions_well_typed: + forall v f, + Genv.find_funct ge v = Some f -> + wt_fundef (global_typenv prog) f. +Proof. + intros. inversion WTPROG. + apply (@Genv.find_funct_prop _ (wt_fundef (global_typenv prog)) + (Csyntax.program_of_program prog) v f). + intros. apply wt_program_funct with id. assumption. + assumption. +Qed. + +Lemma function_ptr_well_typed: + forall b f, + Genv.find_funct_ptr ge b = Some f -> + wt_fundef (global_typenv prog) f. +Proof. + intros. inversion WTPROG. + apply (@Genv.find_funct_ptr_prop _ (wt_fundef (global_typenv prog)) + (Csyntax.program_of_program prog) b f). + intros. apply wt_program_funct with id. assumption. + assumption. +Qed. + +(** ** Matching between environments *) + +Definition match_var_kind (ty: type) (vk: var_kind) : Prop := + match access_mode ty with + | By_value chunk => vk = Vscalar chunk + | _ => True + end. + +Record match_env (tyenv: typenv) (e: Csem.env) (te: Csharpminor.env) : Prop := + mk_match_env { + me_local: + forall id b ty, + e!id = Some b -> tyenv!id = Some ty -> + exists vk, match_var_kind ty vk /\ te!id = Some (b, vk); + me_global: + forall id ty, + e!id = None -> tyenv!id = Some ty -> + te!id = None /\ + (forall chunk, access_mode ty = By_value chunk -> (global_var_env tprog)!id = Some (Vscalar chunk)) + }. + +Definition match_globalenv (tyenv: typenv) (gv: gvarenv): Prop := + forall id ty chunk, + tyenv!id = Some ty -> access_mode ty = By_value chunk -> + gv!id = Some (Vscalar chunk). + +Lemma match_globalenv_match_env_empty: + forall tyenv, + match_globalenv tyenv (global_var_env tprog) -> + match_env tyenv Csem.empty_env Csharpminor.empty_env. +Proof. + intros. unfold Csem.empty_env, Csharpminor.empty_env. + constructor. + intros until ty. repeat rewrite PTree.gempty. congruence. + intros. split. + apply PTree.gempty. + intros. red in H. eauto. +Qed. + +Lemma match_var_kind_of_type: + forall ty vk, var_kind_of_type ty = Some vk -> match_var_kind ty vk. +Proof. + intros; red. + caseEq (access_mode ty); auto. + intros chunk AM. generalize (var_kind_by_value _ _ AM). congruence. +Qed. + +Lemma match_env_alloc_variables: + forall e1 m1 vars e2 m2 lb, + Csem.alloc_variables e1 m1 vars e2 m2 lb -> + forall tyenv te1 tvars, + match_env tyenv e1 te1 -> + transl_vars vars = Some tvars -> + exists te2, + Csharpminor.alloc_variables te1 m1 tvars te2 m2 lb + /\ match_env (Ctyping.add_vars tyenv vars) e2 te2. +Proof. + induction 1; intros. + simpl in H0. inversion H0; subst; clear H0. + exists te1; split. constructor. simpl. auto. + generalize H2. simpl. + caseEq (var_kind_of_type ty); [intros vk VK | congruence]. + caseEq (transl_vars vars); [intros tvrs TVARS | congruence]. + intro EQ; inversion EQ; subst tvars; clear EQ. + set (te2 := PTree.set id (b1, vk) te1). + assert (match_env (add_var tyenv (id, ty)) (PTree.set id b1 e) te2). + inversion H1. unfold te2, add_var. constructor. + (* me_local *) + intros until ty0. repeat rewrite PTree.gsspec. simpl. destruct (peq id0 id); intros. + subst id0. exists vk; split. + apply match_var_kind_of_type. congruence. congruence. + auto. + (* me_global *) + intros until ty0. repeat rewrite PTree.gsspec. simpl. destruct (peq id0 id); intros. + discriminate. + auto. + destruct (IHalloc_variables _ _ _ H3 TVARS) as [te3 [ALLOC MENV]]. + exists te3; split. + econstructor; eauto. + rewrite (sizeof_var_kind_of_type _ _ VK). auto. + auto. +Qed. + +Lemma bind_parameters_match_rec: + forall e m1 vars vals m2, + Csem.bind_parameters e m1 vars vals m2 -> + forall tyenv te tvars, + (forall id ty, In (id, ty) vars -> tyenv!id = Some ty) -> + match_env tyenv e te -> + transl_params vars = Some tvars -> + Csharpminor.bind_parameters te m1 tvars vals m2. +Proof. + induction 1; intros. + simpl in H1. inversion H1. constructor. + generalize H4; clear H4; simpl. + caseEq (chunk_of_type ty); [intros chunk CHK | congruence]. + caseEq (transl_params params); [intros tparams TPARAMS | congruence]. + intro EQ; inversion EQ; clear EQ; subst tvars. + generalize CHK. unfold chunk_of_type. + caseEq (access_mode ty); intros; try discriminate. + inversion CHK0; clear CHK0; subst m0. + unfold store_value_of_type in H0. rewrite H4 in H0. + apply bind_parameters_cons with b m1. + assert (tyenv!id = Some ty). apply H2. apply in_eq. + destruct (me_local _ _ _ H3 _ _ _ H H5) as [vk [A B]]. + red in A; rewrite H4 in A. congruence. + assumption. + apply IHbind_parameters with tyenv; auto. + intros. apply H2. apply in_cons; auto. +Qed. + +Lemma tyenv_add_vars_norepet: + forall vars tyenv, + list_norepet (var_names vars) -> + (forall id ty, + In (id, ty) vars -> (Ctyping.add_vars tyenv vars)!id = Some ty) + /\ + (forall id, + ~In id (var_names vars) -> (Ctyping.add_vars tyenv vars)!id = tyenv!id). +Proof. + induction vars; simpl; intros. + tauto. + destruct a as [id1 ty1]. simpl in *. inversion H; clear H; subst. + destruct (IHvars (add_var tyenv (id1, ty1)) H3) as [A B]. + split; intros. + destruct H. inversion H; subst id1 ty1; clear H. + rewrite B. unfold add_var. simpl. apply PTree.gss. auto. + auto. + rewrite B. unfold add_var; simpl. apply PTree.gso. apply sym_not_equal; tauto. tauto. +Qed. + +Lemma bind_parameters_match: + forall e m1 params vals vars m2 tyenv tvars te, + Csem.bind_parameters e m1 params vals m2 -> + list_norepet (var_names params ++ var_names vars) -> + match_env (Ctyping.add_vars tyenv (params ++ vars)) e te -> + transl_params params = Some tvars -> + Csharpminor.bind_parameters te m1 tvars vals m2. +Proof. + intros. + eapply bind_parameters_match_rec; eauto. + assert (list_norepet (var_names (params ++ vars))). + unfold var_names. rewrite List.map_app. assumption. + destruct (tyenv_add_vars_norepet _ tyenv H3) as [A B]. + intros. apply A. apply List.in_or_app. auto. +Qed. + +Definition globvarenv + (gv: gvarenv) + (vars: list (ident * var_kind * list init_data)) := + List.fold_left + (fun gve x => match x with (id, k, init) => PTree.set id k gve end) + vars gv. + +Definition type_not_by_value (ty: type) : Prop := + match access_mode ty with + | By_value _ => False + | _ => True + end. + +Lemma add_global_funs_charact: + forall fns tyenv, + (forall id ty, tyenv!id = Some ty -> type_not_by_value ty) -> + (forall id ty, (add_global_funs tyenv fns)!id = Some ty -> type_not_by_value ty). +Proof. + induction fns; simpl; intros. + eauto. + apply IHfns with (add_global_fun tyenv a) id. + intros until ty0. destruct a as [id1 fn1]. + unfold add_global_fun; simpl. rewrite PTree.gsspec. + destruct (peq id0 id1). + intros. inversion H1. + unfold type_of_fundef. destruct fn1; exact I. + eauto. + auto. +Qed. + +Definition global_fun_typenv := + add_global_funs (PTree.empty type) (Csyntax.prog_funct prog). + +Lemma add_global_funs_match_global_env: + match_globalenv global_fun_typenv (PTree.empty var_kind). +Proof. + intros; red; intros. + assert (type_not_by_value ty). + apply add_global_funs_charact with (Csyntax.prog_funct prog) (PTree.empty type) id. + intros until ty0. rewrite PTree.gempty. congruence. + assumption. + red in H1. rewrite H0 in H1. contradiction. +Qed. + +Lemma add_global_var_match_globalenv: + forall vars tenv gv tvars, + match_globalenv tenv gv -> + transl_global_vars vars = Some tvars -> + match_globalenv (add_global_vars tenv vars) (globvarenv gv tvars). +Proof. + induction vars; intros; simpl. + simpl in H0. inversion H0. simpl. auto. + destruct a as [[id ty] init]. monadInv H0. subst tvars. + simpl. apply IHvars; auto. + red. intros until chunk. repeat rewrite PTree.gsspec. + destruct (peq id0 id); intros. + inversion H1; clear H1; subst id0 ty0. + generalize (var_kind_by_value _ _ H2). congruence. + red in H. eauto. +Qed. + +Lemma match_global_typenv: + match_globalenv (global_typenv prog) (global_var_env tprog). +Proof. + change (global_var_env tprog) + with (globvarenv (PTree.empty var_kind) (prog_vars tprog)). + unfold global_typenv. + apply add_global_var_match_globalenv. + apply add_global_funs_match_global_env. + monadInv TRANSL. rewrite <- H0. reflexivity. +Qed. + +(** ** Variable accessors *) + +Lemma var_get_correct: + forall e m id ty loc ofs v tyenv code te le, + Csem.eval_lvalue ge e m (Expr (Csyntax.Evar id) ty) E0 m loc ofs -> + load_value_of_type ty m loc ofs = Some v -> + wt_expr tyenv (Expr (Csyntax.Evar id) ty) -> + var_get id ty = Some code -> + match_env tyenv e te -> + eval_expr tprog le te m code E0 m v. +Proof. + intros. inversion H1; subst; clear H1. + unfold load_value_of_type in H0. + unfold var_get in H2. + caseEq (access_mode ty). + (* access mode By_value *) + intros chunk ACC. rewrite ACC in H0. rewrite ACC in H2. + inversion H2; clear H2; subst. + inversion H; subst; clear H. + (* local variable *) + exploit me_local; eauto. intros [vk [A B]]. + red in A; rewrite ACC in A. + subst vk. + eapply eval_Evar. + eapply eval_var_ref_local. eauto. assumption. + (* global variable *) + exploit me_global; eauto. intros [A B]. + eapply eval_Evar. + eapply eval_var_ref_global. auto. + fold tge. rewrite symbols_preserved. eauto. + eauto. assumption. + (* access mode By_reference *) + intros ACC. rewrite ACC in H0. rewrite ACC in H2. + inversion H0; clear H0; subst. + inversion H2; clear H2; subst. + inversion H; subst; clear H. + (* local variable *) + exploit me_local; eauto. intros [vk [A B]]. + eapply eval_Eaddrof. + eapply eval_var_addr_local. eauto. + (* global variable *) + exploit me_global; eauto. intros [A B]. + eapply eval_Eaddrof. + eapply eval_var_addr_global. auto. + fold tge. rewrite symbols_preserved. eauto. + (* access mode By_nothing *) + intros. rewrite H1 in H0; discriminate. +Qed. + +Lemma var_set_correct: + forall e m id ty m1 loc ofs t1 m2 v t2 m3 tyenv code te rhs, + Csem.eval_lvalue ge e m (Expr (Csyntax.Evar id) ty) t1 m1 loc ofs -> + store_value_of_type ty m2 loc ofs v = Some m3 -> + wt_expr tyenv (Expr (Csyntax.Evar id) ty) -> + var_set id ty rhs = Some code -> + match_env tyenv e te -> + eval_expr tprog nil te m1 rhs t2 m2 v -> + exec_stmt tprog te m code (t1 ** t2) m3 Out_normal. +Proof. + intros. inversion H1; subst; clear H1. + unfold store_value_of_type in H0. + unfold var_set in H2. + caseEq (access_mode ty). + (* access mode By_value *) + intros chunk ACC. rewrite ACC in H0. rewrite ACC in H2. + inversion H2; clear H2; subst. + inversion H; subst; clear H; rewrite E0_left. + (* local variable *) + exploit me_local; eauto. intros [vk [A B]]. + red in A; rewrite ACC in A; subst vk. + eapply eval_Sassign. eauto. + eapply eval_var_ref_local. eauto. assumption. + (* global variable *) + exploit me_global; eauto. intros [A B]. + eapply eval_Sassign. eauto. + eapply eval_var_ref_global. auto. + fold tge. rewrite symbols_preserved. eauto. + eauto. assumption. + (* access mode By_reference *) + intros ACC. rewrite ACC in H0. discriminate. + (* access mode By_nothing *) + intros. rewrite H1 in H0; discriminate. +Qed. + +(** ** Proof of semantic simulation *) + +(** Inductive properties *) + +Definition eval_expr_prop + (e: Csem.env) (m1: mem) (a: Csyntax.expr) (t: trace) (m2: mem) (v: val) : Prop := + forall tyenv ta te tle + (WT: wt_expr tyenv a) + (TR: transl_expr a = Some ta) + (MENV: match_env tyenv e te), + Csharpminor.eval_expr tprog tle te m1 ta t m2 v. + +Definition eval_lvalue_prop + (e: Csem.env) (m1: mem) (a: Csyntax.expr) (t: trace) + (m2: mem) (b: block) (ofs: int) : Prop := + forall tyenv ta te tle + (WT: wt_expr tyenv a) + (TR: transl_lvalue a = Some ta) + (MENV: match_env tyenv e te), + Csharpminor.eval_expr tprog tle te m1 ta t m2 (Vptr b ofs). + +Definition eval_exprlist_prop + (e: Csem.env) (m1: mem) (al: Csyntax.exprlist) (t: trace) + (m2: mem) (vl: list val) : Prop := + forall tyenv tal te tle + (WT: wt_exprlist tyenv al) + (TR: transl_exprlist al = Some tal) + (MENV: match_env tyenv e te), + Csharpminor.eval_exprlist tprog tle te m1 tal t m2 vl. + +Definition transl_outcome (nbrk ncnt: nat) (out: Csem.outcome): Csharpminor.outcome := + match out with + | Csem.Out_normal => Csharpminor.Out_normal + | Csem.Out_break => Csharpminor.Out_exit nbrk + | Csem.Out_continue => Csharpminor.Out_exit ncnt + | Csem.Out_return vopt => Csharpminor.Out_return vopt + end. + +Definition exec_stmt_prop + (e: Csem.env) (m1: mem) (s: Csyntax.statement) (t: trace) + (m2: mem) (out: Csem.outcome) : Prop := + forall tyenv nbrk ncnt ts te + (WT: wt_stmt tyenv s) + (TR: transl_statement nbrk ncnt s = Some ts) + (MENV: match_env tyenv e te), + Csharpminor.exec_stmt tprog te m1 ts t m2 (transl_outcome nbrk ncnt out). + +Definition exec_lblstmts_prop + (e: Csem.env) (m1: mem) (s: Csyntax.labeled_statements) + (t: trace) (m2: mem) (out: Csem.outcome) : Prop := + forall tyenv nbrk ncnt body ts te m0 t0 + (WT: wt_lblstmts tyenv s) + (TR: transl_lblstmts (lblstmts_length s) + (1 + lblstmts_length s + ncnt) + s body = Some ts) + (MENV: match_env tyenv e te) + (BODY: Csharpminor.exec_stmt tprog te m0 body t0 m1 Out_normal), + Csharpminor.exec_stmt tprog te m0 ts (t0 ** t) m2 + (transl_outcome nbrk ncnt (outcome_switch out)). + +Definition eval_funcall_prop + (m1: mem) (f: Csyntax.fundef) (params: list val) + (t: trace) (m2: mem) (res: val) : Prop := + forall tf + (WT: wt_fundef (global_typenv prog) f) + (TR: transl_fundef f = Some tf), + Csharpminor.eval_funcall tprog m1 tf params t m2 res. + +(* +Set Printing Depth 100. +Check (Csem.eval_funcall_ind6 ge eval_expr_prop eval_lvalue_prop + eval_exprlist_prop exec_stmt_prop exec_lblstmts_prop eval_funcall_prop). +*) + +Lemma transl_Econst_int_correct: + (forall (e : Csem.env) (m : mem) (i : int) (ty : type), + eval_expr_prop e m (Expr (Econst_int i) ty) E0 m (Vint i)). +Proof. + intros; red; intros. + monadInv TR. subst ta. apply make_intconst_correct. +Qed. + +Lemma transl_Econst_float_correct: + (forall (e : Csem.env) (m : mem) (f0 : float) (ty : type), + eval_expr_prop e m (Expr (Econst_float f0) ty) E0 m (Vfloat f0)). +Proof. + intros; red; intros. + monadInv TR. subst ta. apply make_floatconst_correct. +Qed. + +Lemma transl_Elvalue_correct: + (forall (e : Csem.env) (m : mem) (a : expr_descr) (ty : type) + (t : trace) (m1 : mem) (loc : block) (ofs : int) (v : val), + eval_lvalue ge e m (Expr a ty) t m1 loc ofs -> + eval_lvalue_prop e m (Expr a ty) t m1 loc ofs -> + load_value_of_type ty m1 loc ofs = Some v -> + eval_expr_prop e m (Expr a ty) t m1 v). +Proof. + intros; red; intros. + exploit transl_expr_lvalue; eauto. + intros [[id [EQ VARGET]] | [tb [TRLVAL MKLOAD]]]. + (* Case a is a variable *) + subst a. + assert (t = E0 /\ m1 = m). inversion H; auto. + destruct H2; subst t m1. + eapply var_get_correct; eauto. + (* Case a is another lvalue *) + eapply make_load_correct; eauto. +Qed. + +Lemma transl_Eaddrof_correct: + (forall (e : Csem.env) (m : mem) (a : Csyntax.expr) (t : trace) + (m1 : mem) (loc : block) (ofs : int) (ty : type), + eval_lvalue ge e m a t m1 loc ofs -> + eval_lvalue_prop e m a t m1 loc ofs -> + eval_expr_prop e m (Expr (Csyntax.Eaddrof a) ty) t m1 (Vptr loc ofs)). +Proof. + intros; red; intros. inversion WT; clear WT; subst. simpl in TR. + eauto. +Qed. + +Lemma transl_Esizeof_correct: + (forall (e : Csem.env) (m : mem) (ty' ty : type), + eval_expr_prop e m (Expr (Esizeof ty') ty) E0 m + (Vint (Int.repr (Csyntax.sizeof ty')))). +Proof. + intros; red; intros. monadInv TR. subst ta. apply make_intconst_correct. +Qed. + +Lemma transl_Eunop_correct: + (forall (e : Csem.env) (m : mem) (op : unary_operation) + (a : Csyntax.expr) (ty : type) (t : trace) (m1 : mem) (v1 v : val), + Csem.eval_expr ge e m a t m1 v1 -> + eval_expr_prop e m a t m1 v1 -> + sem_unary_operation op v1 (typeof a) = Some v -> + eval_expr_prop e m (Expr (Eunop op a) ty) t m1 v). +Proof. + intros; red; intros. + inversion WT; clear WT; subst. + monadInv TR. + eapply transl_unop_correct; eauto. +Qed. + +Lemma transl_Ebinop_correct: + (forall (e : Csem.env) (m : mem) (op : binary_operation) + (a1 a2 : Csyntax.expr) (ty : type) (t1 : trace) (m1 : mem) + (v1 : val) (t2 : trace) (m2 : mem) (v2 v : val), + Csem.eval_expr ge e m a1 t1 m1 v1 -> + eval_expr_prop e m a1 t1 m1 v1 -> + Csem.eval_expr ge e m1 a2 t2 m2 v2 -> + eval_expr_prop e m1 a2 t2 m2 v2 -> + sem_binary_operation op v1 (typeof a1) v2 (typeof a2) m2 = Some v -> + eval_expr_prop e m (Expr (Ebinop op a1 a2) ty) (t1 ** t2) m2 v). +Proof. + intros; red; intros. + inversion WT; clear WT; subst. + monadInv TR. + eapply transl_binop_correct; eauto. +Qed. + +Lemma transl_Eorbool_1_correct: + (forall (e : Csem.env) (m : mem) (a1 a2 : Csyntax.expr) (t : trace) + (m1 : mem) (v1 : val) (ty : type), + Csem.eval_expr ge e m a1 t m1 v1 -> + eval_expr_prop e m a1 t m1 v1 -> + is_true v1 (typeof a1) -> + eval_expr_prop e m (Expr (Eorbool a1 a2) ty) t m1 Vtrue). +Proof. + intros; red; intros. inversion WT; clear WT; subst. monadInv TR. + rewrite <- H3; unfold make_orbool. + exploit make_boolean_correct_true; eauto. intros [vb [EVAL ISTRUE]]. + eapply eval_Econdition_true; eauto. + unfold Vtrue; apply make_intconst_correct. traceEq. +Qed. + +Lemma transl_Eorbool_2_correct: + (forall (e : Csem.env) (m : mem) (a1 a2 : Csyntax.expr) (ty : type) + (t1 : trace) (m1 : mem) (v1 : val) (t2 : trace) (m2 : mem) + (v2 v : val), + Csem.eval_expr ge e m a1 t1 m1 v1 -> + eval_expr_prop e m a1 t1 m1 v1 -> + is_false v1 (typeof a1) -> + Csem.eval_expr ge e m1 a2 t2 m2 v2 -> + eval_expr_prop e m1 a2 t2 m2 v2 -> + bool_of_val v2 (typeof a2) v -> + eval_expr_prop e m (Expr (Eorbool a1 a2) ty) (t1 ** t2) m2 v). +Proof. + intros; red; intros. inversion WT; clear WT; subst. monadInv TR. + rewrite <- H6; unfold make_orbool. + exploit make_boolean_correct_false. eapply H0; eauto. eauto. intros [vb [EVAL ISFALSE]]. + eapply eval_Econdition_false; eauto. + inversion H4; subst. + exploit make_boolean_correct_true. eapply H3; eauto. eauto. intros [vc [EVAL' ISTRUE']]. + eapply eval_Econdition_true; eauto. + unfold Vtrue; apply make_intconst_correct. traceEq. + exploit make_boolean_correct_false. eapply H3; eauto. eauto. intros [vc [EVAL' ISFALSE']]. + eapply eval_Econdition_false; eauto. + unfold Vfalse; apply make_intconst_correct. traceEq. +Qed. + +Lemma transl_Eandbool_1_correct: + (forall (e : Csem.env) (m : mem) (a1 a2 : Csyntax.expr) (t : trace) + (m1 : mem) (v1 : val) (ty : type), + Csem.eval_expr ge e m a1 t m1 v1 -> + eval_expr_prop e m a1 t m1 v1 -> + is_false v1 (typeof a1) -> + eval_expr_prop e m (Expr (Eandbool a1 a2) ty) t m1 Vfalse). +Proof. + intros; red; intros. inversion WT; clear WT; subst. monadInv TR. + rewrite <- H3; unfold make_andbool. + exploit make_boolean_correct_false; eauto. intros [vb [EVAL ISFALSE]]. + eapply eval_Econdition_false; eauto. + unfold Vfalse; apply make_intconst_correct. traceEq. +Qed. + +Lemma transl_Eandbool_2_correct: + (forall (e : Csem.env) (m : mem) (a1 a2 : Csyntax.expr) (ty : type) + (t1 : trace) (m1 : mem) (v1 : val) (t2 : trace) (m2 : mem) + (v2 v : val), + Csem.eval_expr ge e m a1 t1 m1 v1 -> + eval_expr_prop e m a1 t1 m1 v1 -> + is_true v1 (typeof a1) -> + Csem.eval_expr ge e m1 a2 t2 m2 v2 -> + eval_expr_prop e m1 a2 t2 m2 v2 -> + bool_of_val v2 (typeof a2) v -> + eval_expr_prop e m (Expr (Eandbool a1 a2) ty) (t1 ** t2) m2 v). +Proof. + intros; red; intros. inversion WT; clear WT; subst. monadInv TR. + rewrite <- H6; unfold make_andbool. + exploit make_boolean_correct_true. eapply H0; eauto. eauto. intros [vb [EVAL ISTRUE]]. + eapply eval_Econdition_true; eauto. + inversion H4; subst. + exploit make_boolean_correct_true. eapply H3; eauto. eauto. intros [vc [EVAL' ISTRUE']]. + eapply eval_Econdition_true; eauto. + unfold Vtrue; apply make_intconst_correct. traceEq. + exploit make_boolean_correct_false. eapply H3; eauto. eauto. intros [vc [EVAL' ISFALSE']]. + eapply eval_Econdition_false; eauto. + unfold Vfalse; apply make_intconst_correct. traceEq. +Qed. + +Lemma transl_Ecast_correct: + (forall (e : Csem.env) (m : mem) (a : Csyntax.expr) (ty : type) + (t : trace) (m1 : mem) (v1 v : val), + Csem.eval_expr ge e m a t m1 v1 -> + eval_expr_prop e m a t m1 v1 -> + cast v1 (typeof a) ty v -> + eval_expr_prop e m (Expr (Ecast ty a) ty) t m1 v). +Proof. + intros; red; intros. inversion WT; clear WT; subst. monadInv TR. subst ta. + eapply make_cast_correct; eauto. +Qed. + +Lemma transl_Ecall_correct: + (forall (e : Csem.env) (m : mem) (a : Csyntax.expr) + (bl : Csyntax.exprlist) (ty : type) (m3 : mem) (vres : val) + (t1 : trace) (m1 : mem) (vf : val) (t2 : trace) (m2 : mem) + (vargs : list val) (f : Csyntax.fundef) (t3 : trace), + Csem.eval_expr ge e m a t1 m1 vf -> + eval_expr_prop e m a t1 m1 vf -> + Csem.eval_exprlist ge e m1 bl t2 m2 vargs -> + eval_exprlist_prop e m1 bl t2 m2 vargs -> + Genv.find_funct ge vf = Some f -> + type_of_fundef f = typeof a -> + Csem.eval_funcall ge m2 f vargs t3 m3 vres -> + eval_funcall_prop m2 f vargs t3 m3 vres -> + eval_expr_prop e m (Expr (Csyntax.Ecall a bl) ty) (t1 ** t2 ** t3) m3 + vres). +Proof. + intros; red; intros. + inversion WT; clear WT; subst. + simpl in TR. + caseEq (classify_fun (typeof a)). + 2: intros; rewrite H7 in TR; discriminate. + intros targs tres EQ. rewrite EQ in TR. + monadInv TR. clear TR. subst ta. + rewrite <- H4 in EQ. + exploit functions_translated; eauto. intros [tf [FIND TRL]]. + econstructor. + eapply H0; eauto. + eapply H2; eauto. + eexact FIND. + eapply transl_fundef_sig1; eauto. + eapply H6; eauto. + eapply functions_well_typed; eauto. + auto. +Qed. + +Lemma transl_Evar_local_correct: + (forall (e : Csem.env) (m : mem) (id : positive) (l : block) + (ty : type), + e ! id = Some l -> + eval_lvalue_prop e m (Expr (Csyntax.Evar id) ty) E0 m l Int.zero). +Proof. + intros; red; intros. inversion WT; clear WT; subst. monadInv TR. subst ta. + exploit (me_local _ _ _ MENV); eauto. intros [vk [A B]]. + econstructor. eapply eval_var_addr_local. eauto. +Qed. + +Lemma transl_Evar_global_correct: + (forall (e : PTree.t block) (m : mem) (id : positive) (l : block) + (ty : type), + e ! id = None -> + Genv.find_symbol ge id = Some l -> + eval_lvalue_prop e m (Expr (Csyntax.Evar id) ty) E0 m l Int.zero). +Proof. + intros; red; intros. inversion WT; clear WT; subst. monadInv TR. subst ta. + exploit (me_global _ _ _ MENV); eauto. intros [A B]. + econstructor. eapply eval_var_addr_global. eauto. + rewrite symbols_preserved. auto. +Qed. + +Lemma transl_Ederef_correct: + (forall (e : Csem.env) (m m1 : mem) (a : Csyntax.expr) (t : trace) + (ofs : int) (ty : type) (l : block), + Csem.eval_expr ge e m a t m1 (Vptr l ofs) -> + eval_expr_prop e m a t m1 (Vptr l ofs) -> + eval_lvalue_prop e m (Expr (Ederef a) ty) t m1 l ofs). +Proof. + intros; red; intros. inversion WT; clear WT; subst. simpl in TR. + eauto. +Qed. + +Lemma transl_Eindex_correct: + (forall (e : Csem.env) (m : mem) (a1 : Csyntax.expr) (t1 : trace) + (m1 : mem) (v1 : val) (a2 : Csyntax.expr) (t2 : trace) (m2 : mem) + (v2 : val) (l : block) (ofs : int) (ty : type), + Csem.eval_expr ge e m a1 t1 m1 v1 -> + eval_expr_prop e m a1 t1 m1 v1 -> + Csem.eval_expr ge e m1 a2 t2 m2 v2 -> + eval_expr_prop e m1 a2 t2 m2 v2 -> + sem_add v1 (typeof a1) v2 (typeof a2) = Some (Vptr l ofs) -> + eval_lvalue_prop e m (Expr (Eindex a1 a2) ty) (t1 ** t2) m2 l ofs). +Proof. + intros; red; intros. inversion WT; clear WT; subst. simpl in TR. monadInv TR. + eapply (make_add_correct tprog); eauto. +Qed. + +Lemma transl_Efield_struct_correct: + (forall (e : Csem.env) (m : mem) (a : Csyntax.expr) (t : trace) + (m1 : mem) (l : block) (ofs : int) (fList : fieldlist) (i : ident) + (ty : type) (delta : Z), + eval_lvalue ge e m a t m1 l ofs -> + eval_lvalue_prop e m a t m1 l ofs -> + typeof a = Tstruct fList -> + field_offset i fList = Some delta -> + eval_lvalue_prop e m (Expr (Efield a i) ty) t m1 l + (Int.add ofs (Int.repr delta))). +Proof. + intros; red; intros. inversion WT; clear WT; subst. + simpl in TR. rewrite H1 in TR. monadInv TR. + rewrite <- H5. eapply make_binop_correct; eauto. + apply make_intconst_correct. + simpl. congruence. traceEq. +Qed. + +Lemma transl_Efield_union_correct: + (forall (e : Csem.env) (m : mem) (a : Csyntax.expr) (t : trace) + (m1 : mem) (l : block) (ofs : int) (fList : fieldlist) (i : ident) + (ty : type), + eval_lvalue ge e m a t m1 l ofs -> + eval_lvalue_prop e m a t m1 l ofs -> + typeof a = Tunion fList -> + eval_lvalue_prop e m (Expr (Efield a i) ty) t m1 l ofs). +Proof. + intros; red; intros. inversion WT; clear WT; subst. + simpl in TR. rewrite H1 in TR. eauto. +Qed. + +Lemma transl_Enil_correct: + (forall (e : Csem.env) (m : mem), + eval_exprlist_prop e m Csyntax.Enil E0 m nil). +Proof. + intros; red; intros. monadInv TR. subst tal. constructor. +Qed. + +Lemma transl_Econs_correct: + (forall (e : Csem.env) (m : mem) (a : Csyntax.expr) + (bl : Csyntax.exprlist) (t1 : trace) (m1 : mem) (v : val) + (t2 : trace) (m2 : mem) (vl : list val), + Csem.eval_expr ge e m a t1 m1 v -> + eval_expr_prop e m a t1 m1 v -> + Csem.eval_exprlist ge e m1 bl t2 m2 vl -> + eval_exprlist_prop e m1 bl t2 m2 vl -> + eval_exprlist_prop e m (Csyntax.Econs a bl) (t1 ** t2) m2 (v :: vl)). +Proof. + intros; red; intros. inversion WT; clear WT; subst. simpl in TR; monadInv TR. + subst tal. econstructor; eauto. +Qed. + +Lemma transl_Sskip_correct: + (forall (e : Csem.env) (m : mem), + exec_stmt_prop e m Csyntax.Sskip E0 m Csem.Out_normal). +Proof. + intros; red; intros. monadInv TR. subst ts. simpl. constructor. +Qed. + +Lemma transl_Sexpr_correct: + (forall (e : Csem.env) (m : mem) (a : Csyntax.expr) (t : trace) + (m1 : mem) (v : val), + Csem.eval_expr ge e m a t m1 v -> + eval_expr_prop e m a t m1 v -> + exec_stmt_prop e m (Csyntax.Sexpr a) t m1 Csem.Out_normal). +Proof. + intros; red; intros; simpl. inversion WT; clear WT; subst. + monadInv TR. subst ts. + econstructor; eauto. +Qed. + +Lemma transl_Sassign_correct: + (forall (e : Csem.env) (m : mem) (a1 a2 : Csyntax.expr) (t1 : trace) + (m1 : mem) (loc : block) (ofs : int) (t2 : trace) (m2 : mem) + (v2 : val) (m3 : mem), + eval_lvalue ge e m a1 t1 m1 loc ofs -> + eval_lvalue_prop e m a1 t1 m1 loc ofs -> + Csem.eval_expr ge e m1 a2 t2 m2 v2 -> + eval_expr_prop e m1 a2 t2 m2 v2 -> + store_value_of_type (typeof a1) m2 loc ofs v2 = Some m3 -> + exec_stmt_prop e m (Csyntax.Sassign a1 a2) (t1 ** t2) m3 + Csem.Out_normal). +Proof. + intros; red; intros. + inversion WT; subst; clear WT. + simpl in TR. + caseEq (is_variable a1). + (* a = variable id *) + intros id ISVAR. rewrite ISVAR in TR. + generalize (is_variable_correct _ _ ISVAR). intro EQ. + rewrite EQ in H; rewrite EQ in H0; rewrite EQ in H6. + monadInv TR. + eapply var_set_correct; eauto. + (* a is not a variable *) + intro ISVAR; rewrite ISVAR in TR. monadInv TR. + eapply make_store_correct; eauto. +Qed. + +Lemma transl_Ssequence_1_correct: + (forall (e : Csem.env) (m : mem) (s1 s2 : statement) (t1 : trace) + (m1 : mem) (t2 : trace) (m2 : mem) (out : Csem.outcome), + Csem.exec_stmt ge e m s1 t1 m1 Csem.Out_normal -> + exec_stmt_prop e m s1 t1 m1 Csem.Out_normal -> + Csem.exec_stmt ge e m1 s2 t2 m2 out -> + exec_stmt_prop e m1 s2 t2 m2 out -> + exec_stmt_prop e m (Ssequence s1 s2) (t1 ** t2) m2 out). +Proof. + intros; red; intros. inversion WT; clear WT; subst. simpl in TR; monadInv TR. + subst ts. red in H0; simpl in H0. eapply exec_Sseq_continue; eauto. +Qed. + +Lemma transl_Ssequence_2_correct: + (forall (e : Csem.env) (m : mem) (s1 s2 : statement) (t1 : trace) + (m1 : mem) (out : Csem.outcome), + Csem.exec_stmt ge e m s1 t1 m1 out -> + exec_stmt_prop e m s1 t1 m1 out -> + out <> Csem.Out_normal -> + exec_stmt_prop e m (Ssequence s1 s2) t1 m1 out). +Proof. + intros; red; intros. inversion WT; clear WT; subst. simpl in TR; monadInv TR. + subst ts. eapply exec_Sseq_stop; eauto. + destruct out; simpl; congruence. +Qed. + +Lemma transl_Sifthenelse_true_correct: + (forall (e : Csem.env) (m : mem) (a : Csyntax.expr) + (s1 s2 : statement) (t1 : trace) (m1 : mem) (v1 : val) (t2 : trace) + (m2 : mem) (out : Csem.outcome), + Csem.eval_expr ge e m a t1 m1 v1 -> + eval_expr_prop e m a t1 m1 v1 -> + is_true v1 (typeof a) -> + Csem.exec_stmt ge e m1 s1 t2 m2 out -> + exec_stmt_prop e m1 s1 t2 m2 out -> + exec_stmt_prop e m (Csyntax.Sifthenelse a s1 s2) (t1 ** t2) m2 out). +Proof. + intros; red; intros. inversion WT; clear WT; subst. simpl in TR; monadInv TR. + exploit make_boolean_correct_true. eapply H0; eauto. eauto. intros [vb [EVAL ISTRUE]]. + subst ts. eapply exec_Sifthenelse_true; eauto. +Qed. + +Lemma transl_Sifthenelse_false_correct: + (forall (e : Csem.env) (m : mem) (a : Csyntax.expr) + (s1 s2 : statement) (t1 : trace) (m1 : mem) (v1 : val) (t2 : trace) + (m2 : mem) (out : Csem.outcome), + Csem.eval_expr ge e m a t1 m1 v1 -> + eval_expr_prop e m a t1 m1 v1 -> + is_false v1 (typeof a) -> + Csem.exec_stmt ge e m1 s2 t2 m2 out -> + exec_stmt_prop e m1 s2 t2 m2 out -> + exec_stmt_prop e m (Csyntax.Sifthenelse a s1 s2) (t1 ** t2) m2 out). +Proof. + intros; red; intros. inversion WT; clear WT; subst. simpl in TR; monadInv TR. + exploit make_boolean_correct_false. eapply H0; eauto. eauto. intros [vb [EVAL ISFALSE]]. + subst ts. eapply exec_Sifthenelse_false; eauto. +Qed. + +Lemma transl_Sreturn_none_correct: + (forall (e : Csem.env) (m : mem), + exec_stmt_prop e m (Csyntax.Sreturn None) E0 m (Csem.Out_return None)). +Proof. + intros; red; intros. inversion WT; clear WT; subst. simpl in TR; monadInv TR. + subst ts. simpl. apply exec_Sreturn_none. +Qed. + +Lemma transl_Sreturn_some_correct: + (forall (e : Csem.env) (m : mem) (a : Csyntax.expr) (t : trace) + (m1 : mem) (v : val), + Csem.eval_expr ge e m a t m1 v -> + eval_expr_prop e m a t m1 v -> + exec_stmt_prop e m (Csyntax.Sreturn (Some a)) t m1 + (Csem.Out_return (Some v))). +Proof. + intros; red; intros. inversion WT; clear WT; subst. simpl in TR; monadInv TR. + subst ts. simpl. eapply exec_Sreturn_some; eauto. +Qed. + +Lemma transl_Sbreak_correct: + (forall (e : Csem.env) (m : mem), + exec_stmt_prop e m Sbreak E0 m Out_break). +Proof. + intros; red; intros. inversion WT; clear WT; subst. simpl in TR; monadInv TR. + subst ts. simpl. apply exec_Sexit. +Qed. + +Lemma transl_Scontinue_correct: + (forall (e : Csem.env) (m : mem), + exec_stmt_prop e m Scontinue E0 m Out_continue). +Proof. + intros; red; intros. inversion WT; clear WT; subst. simpl in TR; monadInv TR. + subst ts. simpl. apply exec_Sexit. +Qed. + +Lemma exit_if_false_true: + forall a ts e m1 t m2 v tyenv te, + exit_if_false a = Some ts -> + eval_expr_prop e m1 a t m2 v -> + match_env tyenv e te -> + wt_expr tyenv a -> + is_true v (typeof a) -> + exec_stmt tprog te m1 ts t m2 Out_normal. +Proof. + intros. monadInv H. rewrite <- H5. + eapply exec_Sifthenelse_false with (v1 := Vfalse). + eapply make_notbool_correct with (va := v); eauto. + inversion H3; subst; simpl; auto. + rewrite Int.eq_false; auto. + rewrite Int.eq_false; auto. + rewrite Float.eq_zero_false; auto. + simpl; auto. + constructor. traceEq. +Qed. + +Lemma exit_if_false_false: + forall a ts e m1 t m2 v tyenv te, + exit_if_false a = Some ts -> + eval_expr_prop e m1 a t m2 v -> + match_env tyenv e te -> + wt_expr tyenv a -> + is_false v (typeof a) -> + exec_stmt tprog te m1 ts t m2 (Out_exit 0). +Proof. + intros. monadInv H. rewrite <- H5. + eapply exec_Sifthenelse_true with (v1 := Vtrue). + eapply make_notbool_correct with (va := v); eauto. + inversion H3; subst; simpl; auto. + rewrite Float.eq_zero_true; auto. + simpl; apply Int.one_not_zero. + constructor. traceEq. +Qed. + +Lemma transl_Swhile_false_correct: + (forall (e : Csem.env) (m : mem) (s : statement) (a : Csyntax.expr) + (t : trace) (v : val) (m1 : mem), + Csem.eval_expr ge e m a t m1 v -> + eval_expr_prop e m a t m1 v -> + is_false v (typeof a) -> + exec_stmt_prop e m (Swhile a s) t m1 Csem.Out_normal). +Proof. + intros; red; intros. inversion WT; clear WT; subst. simpl in TR; monadInv TR. + subst ts. simpl. + change Out_normal with (outcome_block (Out_exit 0)). + apply exec_Sblock. apply exec_Sloop_stop. apply exec_Sseq_stop. + eapply exit_if_false_false; eauto. congruence. congruence. +Qed. + +Lemma transl_out_break_or_return: + forall out1 out2 nbrk ncnt, + out_break_or_return out1 out2 -> + transl_outcome nbrk ncnt out2 = + outcome_block (outcome_block (transl_outcome 1 0 out1)). +Proof. + intros. inversion H; subst; reflexivity. +Qed. + +Lemma transl_out_normal_or_continue: + forall out, + out_normal_or_continue out -> + Out_normal = outcome_block (transl_outcome 1 0 out). +Proof. + intros; inversion H; reflexivity. +Qed. + +Lemma transl_Swhile_stop_correct: + (forall (e : Csem.env) (m : mem) (a : Csyntax.expr) (t1 : trace) + (m1 : mem) (v : val) (s : statement) (m2 : mem) (t2 : trace) + (out2 out : Csem.outcome), + Csem.eval_expr ge e m a t1 m1 v -> + eval_expr_prop e m a t1 m1 v -> + is_true v (typeof a) -> + Csem.exec_stmt ge e m1 s t2 m2 out2 -> + exec_stmt_prop e m1 s t2 m2 out2 -> + out_break_or_return out2 out -> + exec_stmt_prop e m (Swhile a s) (t1 ** t2) m2 out). +Proof. + intros; red; intros. inversion WT; clear WT; subst. simpl in TR; monadInv TR. + subst ts. rewrite (transl_out_break_or_return _ _ nbrk ncnt H4). + apply exec_Sblock. apply exec_Sloop_stop. + eapply exec_Sseq_continue. + eapply exit_if_false_true; eauto. + apply exec_Sblock. eauto. + auto. inversion H4; simpl; congruence. +Qed. + +Lemma transl_Swhile_loop_correct: + (forall (e : Csem.env) (m : mem) (a : Csyntax.expr) (t1 : trace) + (m1 : mem) (v : val) (s : statement) (out2 out : Csem.outcome) + (t2 : trace) (m2 : mem) (t3 : trace) (m3 : mem), + Csem.eval_expr ge e m a t1 m1 v -> + eval_expr_prop e m a t1 m1 v -> + is_true v (typeof a) -> + Csem.exec_stmt ge e m1 s t2 m2 out2 -> + exec_stmt_prop e m1 s t2 m2 out2 -> + out_normal_or_continue out2 -> + Csem.exec_stmt ge e m2 (Swhile a s) t3 m3 out -> + exec_stmt_prop e m2 (Swhile a s) t3 m3 out -> + exec_stmt_prop e m (Swhile a s) (t1 ** t2 ** t3) m3 out). +Proof. + intros; red; intros. + exploit H6; eauto. intro NEXTITER. + inversion WT; clear WT; subst. simpl in TR; monadInv TR. + subst ts. + inversion NEXTITER; subst. + apply exec_Sblock. + eapply exec_Sloop_loop. eapply exec_Sseq_continue. + eapply exit_if_false_true; eauto. + rewrite (transl_out_normal_or_continue _ H4). + apply exec_Sblock. eauto. + reflexivity. eassumption. + traceEq. +Qed. + +Lemma transl_Sdowhile_false_correct: + (forall (e : Csem.env) (m : mem) (s : statement) (a : Csyntax.expr) + (t1 : trace) (m1 : mem) (out1 : Csem.outcome) (v : val) + (t2 : trace) (m2 : mem), + Csem.exec_stmt ge e m s t1 m1 out1 -> + exec_stmt_prop e m s t1 m1 out1 -> + out_normal_or_continue out1 -> + Csem.eval_expr ge e m1 a t2 m2 v -> + eval_expr_prop e m1 a t2 m2 v -> + is_false v (typeof a) -> + exec_stmt_prop e m (Sdowhile a s) (t1 ** t2) m2 Csem.Out_normal). +Proof. + intros; red; intros. inversion WT; clear WT; subst. simpl in TR; monadInv TR. + subst ts. simpl. + change Out_normal with (outcome_block (Out_exit 0)). + apply exec_Sblock. apply exec_Sloop_stop. eapply exec_Sseq_continue. + rewrite (transl_out_normal_or_continue out1 H1). + apply exec_Sblock. eauto. + eapply exit_if_false_false; eauto. auto. congruence. +Qed. + +Lemma transl_Sdowhile_stop_correct: + (forall (e : Csem.env) (m : mem) (s : statement) (a : Csyntax.expr) + (t : trace) (m1 : mem) (out1 out : Csem.outcome), + Csem.exec_stmt ge e m s t m1 out1 -> + exec_stmt_prop e m s t m1 out1 -> + out_break_or_return out1 out -> + exec_stmt_prop e m (Sdowhile a s) t m1 out). +Proof. + intros; red; intros. inversion WT; clear WT; subst. simpl in TR; monadInv TR. + subst ts. simpl. + assert (outcome_block (transl_outcome 1 0 out1) <> Out_normal). + inversion H1; simpl; congruence. + rewrite (transl_out_break_or_return _ _ nbrk ncnt H1). + apply exec_Sblock. apply exec_Sloop_stop. + apply exec_Sseq_stop. apply exec_Sblock. eauto. + auto. auto. +Qed. + +Lemma transl_Sdowhile_loop_correct: + (forall (e : Csem.env) (m : mem) (s : statement) (a : Csyntax.expr) + (m1 m2 m3 : mem) (t1 t2 t3 : trace) (out out1 : Csem.outcome) + (v : val), + Csem.exec_stmt ge e m s t1 m1 out1 -> + exec_stmt_prop e m s t1 m1 out1 -> + out_normal_or_continue out1 -> + Csem.eval_expr ge e m1 a t2 m2 v -> + eval_expr_prop e m1 a t2 m2 v -> + is_true v (typeof a) -> + Csem.exec_stmt ge e m2 (Sdowhile a s) t3 m3 out -> + exec_stmt_prop e m2 (Sdowhile a s) t3 m3 out -> + exec_stmt_prop e m (Sdowhile a s) (t1 ** t2 ** t3) m3 out). +Proof. + intros; red; intros. + exploit H6; eauto. intro NEXTITER. + inversion WT; clear WT; subst. simpl in TR; monadInv TR. + subst ts. + inversion NEXTITER; subst. + apply exec_Sblock. + eapply exec_Sloop_loop. eapply exec_Sseq_continue. + rewrite (transl_out_normal_or_continue _ H1). + apply exec_Sblock. eauto. + eapply exit_if_false_true; eauto. + reflexivity. eassumption. traceEq. +Qed. + +Lemma transl_Sfor_start_correct: + (forall (e : Csem.env) (m : mem) (s a1 : statement) + (a2 : Csyntax.expr) (a3 : statement) (out : Csem.outcome) + (m1 m2 : mem) (t1 t2 : trace), + Csem.exec_stmt ge e m a1 t1 m1 Csem.Out_normal -> + exec_stmt_prop e m a1 t1 m1 Csem.Out_normal -> + Csem.exec_stmt ge e m1 (Sfor Csyntax.Sskip a2 a3 s) t2 m2 out -> + exec_stmt_prop e m1 (Sfor Csyntax.Sskip a2 a3 s) t2 m2 out -> + exec_stmt_prop e m (Sfor a1 a2 a3 s) (t1 ** t2) m2 out). +Proof. + intros; red; intros. + exploit transl_stmt_Sfor_start; eauto. + intros [ts1 [ts2 [A [B C]]]]. + clear TR; subst ts. + inversion WT; subst. + assert (WT': wt_stmt tyenv (Sfor Csyntax.Sskip a2 a3 s)). + constructor; auto. constructor. + exploit H0; eauto. simpl. intro EXEC1. + exploit H2; eauto. intro EXEC2. + assert (EXEC3: exec_stmt tprog te m1 ts2 t2 m2 (transl_outcome nbrk ncnt out)). + inversion EXEC2; subst. + inversion H5; subst. rewrite E0_left; auto. + inversion H11; subst. congruence. + eapply exec_Sseq_continue; eauto. +Qed. + +Lemma transl_Sfor_false_correct: + (forall (e : Csem.env) (m : mem) (s : statement) (a2 : Csyntax.expr) + (a3 : statement) (t : trace) (v : val) (m1 : mem), + Csem.eval_expr ge e m a2 t m1 v -> + eval_expr_prop e m a2 t m1 v -> + is_false v (typeof a2) -> + exec_stmt_prop e m (Sfor Csyntax.Sskip a2 a3 s) t m1 Csem.Out_normal). +Proof. + intros; red; intros. inversion WT; clear WT; subst. simpl in TR; monadInv TR. + subst ts. simpl. + eapply exec_Sseq_continue. apply exec_Sskip. + change Out_normal with (outcome_block (Out_exit 0)). + apply exec_Sblock. apply exec_Sloop_stop. + apply exec_Sseq_stop. eapply exit_if_false_false; eauto. + congruence. congruence. traceEq. +Qed. + +Lemma transl_Sfor_stop_correct: + (forall (e : Csem.env) (m : mem) (s : statement) (a2 : Csyntax.expr) + (a3 : statement) (v : val) (m1 m2 : mem) (t1 t2 : trace) + (out2 out : Csem.outcome), + Csem.eval_expr ge e m a2 t1 m1 v -> + eval_expr_prop e m a2 t1 m1 v -> + is_true v (typeof a2) -> + Csem.exec_stmt ge e m1 s t2 m2 out2 -> + exec_stmt_prop e m1 s t2 m2 out2 -> + out_break_or_return out2 out -> + exec_stmt_prop e m (Sfor Csyntax.Sskip a2 a3 s) (t1 ** t2) m2 out). +Proof. + intros; red; intros. inversion WT; clear WT; subst. simpl in TR; monadInv TR. + subst ts. simpl. + assert (outcome_block (transl_outcome 1 0 out2) <> Out_normal). + inversion H4; simpl; congruence. + rewrite (transl_out_break_or_return _ _ nbrk ncnt H4). + eapply exec_Sseq_continue. apply exec_Sskip. + apply exec_Sblock. apply exec_Sloop_stop. + eapply exec_Sseq_continue. eapply exit_if_false_true; eauto. + apply exec_Sseq_stop. apply exec_Sblock. eauto. + auto. reflexivity. auto. traceEq. +Qed. + +Lemma transl_Sfor_loop_correct: + (forall (e : Csem.env) (m : mem) (s : statement) (a2 : Csyntax.expr) + (a3 : statement) (v : val) (m1 m2 m3 m4 : mem) + (t1 t2 t3 t4 : trace) (out2 out : Csem.outcome), + Csem.eval_expr ge e m a2 t1 m1 v -> + eval_expr_prop e m a2 t1 m1 v -> + is_true v (typeof a2) -> + Csem.exec_stmt ge e m1 s t2 m2 out2 -> + exec_stmt_prop e m1 s t2 m2 out2 -> + out_normal_or_continue out2 -> + Csem.exec_stmt ge e m2 a3 t3 m3 Csem.Out_normal -> + exec_stmt_prop e m2 a3 t3 m3 Csem.Out_normal -> + Csem.exec_stmt ge e m3 (Sfor Csyntax.Sskip a2 a3 s) t4 m4 out -> + exec_stmt_prop e m3 (Sfor Csyntax.Sskip a2 a3 s) t4 m4 out -> + exec_stmt_prop e m (Sfor Csyntax.Sskip a2 a3 s) + (t1 ** t2 ** t3 ** t4) m4 out). +Proof. + intros; red; intros. + exploit H8; eauto. intro NEXTITER. + inversion WT; clear WT; subst. simpl in TR; monadInv TR. + subst ts. + inversion NEXTITER; subst. + inversion H11; subst. + inversion H18; subst. + eapply exec_Sseq_continue. apply exec_Sskip. + apply exec_Sblock. + eapply exec_Sloop_loop. eapply exec_Sseq_continue. + eapply exit_if_false_true; eauto. + eapply exec_Sseq_continue. + rewrite (transl_out_normal_or_continue _ H4). + apply exec_Sblock. eauto. + red in H6; simpl in H6; eauto. + reflexivity. reflexivity. eassumption. + reflexivity. traceEq. + inversion H17. congruence. +Qed. + +Lemma transl_lblstmts_switch: + forall e m0 t1 m1 n nbrk ncnt tyenv te t2 m2 out sl body ts, + exec_stmt tprog te m0 body t1 m1 + (Out_exit (switch_target n (lblstmts_length sl) (switch_table sl 0))) -> + transl_lblstmts + (lblstmts_length sl) + (S (lblstmts_length sl + ncnt)) + sl (Sblock body) = Some ts -> + wt_lblstmts tyenv sl -> + match_env tyenv e te -> + exec_lblstmts_prop e m1 (select_switch n sl) t2 m2 out -> + Csharpminor.exec_stmt tprog te m0 ts (t1 ** t2) m2 + (transl_outcome nbrk ncnt (outcome_switch out)). +Proof. + induction sl; intros. + simpl in H. simpl in H3. + eapply H3; eauto. + change Out_normal with (outcome_block (Out_exit 0)). + apply exec_Sblock. auto. + (* Inductive case *) + simpl in H. simpl in H3. rewrite Int.eq_sym in H3. destruct (Int.eq n i). + (* first case selected *) + eapply H3; eauto. + change Out_normal with (outcome_block (Out_exit 0)). + apply exec_Sblock. auto. + (* next case selected *) + inversion H1; clear H1; subst. + simpl in H0; monadInv H0. + eapply IHsl with (body := Sseq (Sblock body) s0); eauto. + apply exec_Sseq_stop. + change (Out_exit (switch_target n (lblstmts_length sl) (switch_table sl 0))) + with (outcome_block (Out_exit (S (switch_target n (lblstmts_length sl) (switch_table sl 0))))). + apply exec_Sblock. + rewrite switch_target_table_shift in H. auto. congruence. +Qed. + +Lemma transl_Sswitch_correct: + (forall (e : Csem.env) (m : mem) (a : Csyntax.expr) (t1 : trace) + (m1 : mem) (n : int) (sl : labeled_statements) (t2 : trace) + (m2 : mem) (out : Csem.outcome), + Csem.eval_expr ge e m a t1 m1 (Vint n) -> + eval_expr_prop e m a t1 m1 (Vint n) -> + exec_lblstmts ge e m1 (select_switch n sl) t2 m2 out -> + exec_lblstmts_prop e m1 (select_switch n sl) t2 m2 out -> + exec_stmt_prop e m (Csyntax.Sswitch a sl) (t1 ** t2) m2 + (outcome_switch out)). +Proof. + intros; red; intros. + inversion WT; clear WT; subst. + simpl in TR. monadInv TR; clear TR. + rewrite length_switch_table in EQ0. + replace (ncnt + lblstmts_length sl + 1)%nat + with (S (lblstmts_length sl + ncnt))%nat in EQ0 by omega. + eapply transl_lblstmts_switch; eauto. + constructor. eapply H0; eauto. +Qed. + +Lemma transl_LSdefault_correct: + (forall (e : Csem.env) (m : mem) (s : statement) (t : trace) + (m1 : mem) (out : Csem.outcome), + Csem.exec_stmt ge e m s t m1 out -> + exec_stmt_prop e m s t m1 out -> + exec_lblstmts_prop e m (LSdefault s) t m1 out). +Proof. + intros; red; intros. + inversion WT; subst. + simpl in TR. monadInv TR. + rewrite <- H3. + replace (transl_outcome nbrk ncnt (outcome_switch out)) + with (outcome_block (transl_outcome 0 (S ncnt) out)). + constructor. + eapply exec_Sseq_continue. eauto. + eapply H0; eauto. traceEq. + destruct out; simpl; auto. +Qed. + +Lemma transl_LScase_fallthrough_correct: + (forall (e : Csem.env) (m : mem) (n : int) (s : statement) + (ls : labeled_statements) (t1 : trace) (m1 : mem) (t2 : trace) + (m2 : mem) (out : Csem.outcome), + Csem.exec_stmt ge e m s t1 m1 Csem.Out_normal -> + exec_stmt_prop e m s t1 m1 Csem.Out_normal -> + exec_lblstmts ge e m1 ls t2 m2 out -> + exec_lblstmts_prop e m1 ls t2 m2 out -> + exec_lblstmts_prop e m (LScase n s ls) (t1 ** t2) m2 out). +Proof. + intros; red; intros. + inversion WT; subst. + simpl in TR. monadInv TR; clear TR. + assert (exec_stmt tprog te m0 (Sblock (Sseq body s0)) + (t0 ** t1) m1 Out_normal). + change Out_normal with + (outcome_block (transl_outcome (S (lblstmts_length ls)) + (S (S (lblstmts_length ls + ncnt))) + Csem.Out_normal)). + apply exec_Sblock. eapply exec_Sseq_continue. eexact BODY. + eapply H0; eauto. + auto. + exploit H2. eauto. simpl; eauto. eauto. eauto. simpl. + rewrite Eapp_assoc. eauto. +Qed. + +Lemma transl_LScase_stop_correct: + (forall (e : Csem.env) (m : mem) (n : int) (s : statement) + (ls : labeled_statements) (t : trace) (m1 : mem) + (out : Csem.outcome), + Csem.exec_stmt ge e m s t m1 out -> + exec_stmt_prop e m s t m1 out -> + out <> Csem.Out_normal -> + exec_lblstmts_prop e m (LScase n s ls) t m1 out). +Proof. + intros; red; intros. + inversion WT; subst. + simpl in TR. monadInv TR; clear TR. + exploit H0; eauto. intro EXEC. + destruct out; simpl; simpl in EXEC. + (* out = Out_break *) + change Out_normal with (outcome_block (Out_exit 0)). + eapply transl_lblstmts_exit with (body := Sblock (Sseq body s0)); eauto. + rewrite plus_0_r. + change (Out_exit (lblstmts_length ls)) + with (outcome_block (Out_exit (S (lblstmts_length ls)))). + constructor. eapply exec_Sseq_continue; eauto. + (* out = Out_continue *) + change (Out_exit ncnt) with (outcome_block (Out_exit (S ncnt))). + eapply transl_lblstmts_exit with (body := Sblock (Sseq body s0)); eauto. + replace (Out_exit (lblstmts_length ls + S ncnt)) + with (outcome_block (Out_exit (S (S (lblstmts_length ls + ncnt))))). + constructor. eapply exec_Sseq_continue; eauto. + simpl. decEq. omega. + (* out = Out_normal *) + congruence. + (* out = Out_return *) + eapply transl_lblstmts_return with (body := Sblock (Sseq body s0)); eauto. + change (Out_return o) + with (outcome_block (Out_return o)). + constructor. eapply exec_Sseq_continue; eauto. +Qed. + +Remark outcome_result_value_match: + forall out ty v nbrk ncnt, + Csem.outcome_result_value out ty v -> + Csharpminor.outcome_result_value (transl_outcome nbrk ncnt out) (opttyp_of_type ty) v. +Proof. + intros until ncnt. + destruct out; simpl; try contradiction. + destruct ty; simpl; auto. + destruct o. intros [A B]. destruct ty; simpl; congruence. + destruct ty; simpl; auto. +Qed. + +Lemma transl_funcall_internal_correct: + (forall (m : mem) (f : Csyntax.function) (vargs : list val) + (t : trace) (e : Csem.env) (m1 : mem) (lb : list block) + (m2 m3 : mem) (out : Csem.outcome) (vres : val), + Csem.alloc_variables Csem.empty_env m + (Csyntax.fn_params f ++ Csyntax.fn_vars f) e m1 lb -> + Csem.bind_parameters e m1 (Csyntax.fn_params f) vargs m2 -> + Csem.exec_stmt ge e m2 (Csyntax.fn_body f) t m3 out -> + exec_stmt_prop e m2 (Csyntax.fn_body f) t m3 out -> + Csem.outcome_result_value out (fn_return f) vres -> + eval_funcall_prop m (Internal f) vargs t (free_list m3 lb) vres). +Proof. + intros; red; intros. + (* Exploitation of typing hypothesis *) + inversion WT; clear WT; subst. + inversion H6; clear H6; subst. + (* Exploitation of translation hypothesis *) + monadInv TR. subst tf. clear TR. + monadInv EQ. clear EQ. subst f0. + (* Allocation of variables *) + exploit match_env_alloc_variables; eauto. + apply match_globalenv_match_env_empty. + apply match_global_typenv. + eexact (transl_fn_variables _ _ (signature_of_function f) _ _ s EQ0 EQ1). + intros [te [ALLOCVARS MATCHENV]]. + (* Execution *) + econstructor; simpl. + (* Norepet *) + eapply transl_names_norepet; eauto. + (* Alloc *) + eexact ALLOCVARS. + (* Bind *) + eapply bind_parameters_match; eauto. + (* Execution of body *) + eapply H2; eauto. + (* Outcome_result_value *) + apply outcome_result_value_match; auto. +Qed. + +Lemma transl_funcall_external_correct: + (forall (m : mem) (id : ident) (targs : typelist) (tres : type) + (vargs : list val) (t : trace) (vres : val), + event_match (external_function id targs tres) vargs t vres -> + eval_funcall_prop m (External id targs tres) vargs t m vres). +Proof. + intros; red; intros. + monadInv TR. subst tf. constructor. auto. +Qed. + +Theorem transl_funcall_correct: + forall (m : mem) (f : Csyntax.fundef) (l : list val) (t : trace) + (m0 : mem) (v : val), + Csem.eval_funcall ge m f l t m0 v -> + eval_funcall_prop m f l t m0 v. +Proof + (Csem.eval_funcall_ind6 ge + eval_expr_prop + eval_lvalue_prop + eval_exprlist_prop + exec_stmt_prop + exec_lblstmts_prop + eval_funcall_prop + + transl_Econst_int_correct + transl_Econst_float_correct + transl_Elvalue_correct + transl_Eaddrof_correct + transl_Esizeof_correct + transl_Eunop_correct + transl_Ebinop_correct + transl_Eorbool_1_correct + transl_Eorbool_2_correct + transl_Eandbool_1_correct + transl_Eandbool_2_correct + transl_Ecast_correct + transl_Ecall_correct + transl_Evar_local_correct + transl_Evar_global_correct + transl_Ederef_correct + transl_Eindex_correct + transl_Efield_struct_correct + transl_Efield_union_correct + transl_Enil_correct + transl_Econs_correct + transl_Sskip_correct + transl_Sexpr_correct + transl_Sassign_correct + transl_Ssequence_1_correct + transl_Ssequence_2_correct + transl_Sifthenelse_true_correct + transl_Sifthenelse_false_correct + transl_Sreturn_none_correct + transl_Sreturn_some_correct + transl_Sbreak_correct + transl_Scontinue_correct + transl_Swhile_false_correct + transl_Swhile_stop_correct + transl_Swhile_loop_correct + transl_Sdowhile_false_correct + transl_Sdowhile_stop_correct + transl_Sdowhile_loop_correct + transl_Sfor_start_correct + transl_Sfor_false_correct + transl_Sfor_stop_correct + transl_Sfor_loop_correct + transl_Sswitch_correct + transl_LSdefault_correct + transl_LScase_fallthrough_correct + transl_LScase_stop_correct + transl_funcall_internal_correct + transl_funcall_external_correct). + +End CORRECTNESS. + +(** Semantic preservation for whole programs. *) + +Theorem transl_program_correct: + forall prog tprog t r, + transl_program prog = Some tprog -> + Ctyping.wt_program prog -> + Csem.exec_program prog t r -> + Csharpminor.exec_program tprog t r. +Proof. + intros until r. intros TRANSL WT [b [f [m1 [FINDS [FINDF [TYP EVAL]]]]]]. + inversion WT; subst. + + assert (type_of_fundef f = Tfunction Tnil (Tint I32 Signed)). + apply wt_program_main. + change (Csyntax.prog_funct prog) + with (AST.prog_funct (Csyntax.program_of_program prog)). + eapply Genv.find_funct_ptr_symbol_inversion; eauto. + exploit function_ptr_translated; eauto. intros [tf [TFINDF TRANSLFD]]. + exists b; exists tf; exists m1. + split. + rewrite (symbols_preserved _ _ TRANSL). + monadInv TRANSL. rewrite <- H1. simpl. auto. + split. auto. + split. + generalize (transl_fundef_sig2 _ _ _ _ TRANSLFD H). simpl; auto. + rewrite (@Genv.init_mem_transf_partial _ _ transl_fundef + (Csyntax.program_of_program prog) + (Csharpminor.program_of_program tprog)). + generalize (transl_funcall_correct _ _ WT TRANSL _ _ _ _ _ _ EVAL). + intro. eapply H0. + eapply function_ptr_well_typed; eauto. + auto. + apply transform_program_of_program; auto. +Qed. diff --git a/cfrontend/Csyntax.v b/cfrontend/Csyntax.v new file mode 100644 index 0000000..d3bd8d6 --- /dev/null +++ b/cfrontend/Csyntax.v @@ -0,0 +1,456 @@ +(** * Abstract syntax for the Clight language *) + +Require Import Coqlib. +Require Import Integers. +Require Import Floats. +Require Import AST. + +(** ** Abstract syntax *) + +(** Types *) + +Inductive signedness : Set := + | Signed: signedness + | Unsigned: signedness. + +Inductive intsize : Set := + | I8: intsize + | I16: intsize + | I32: intsize. + +Inductive floatsize : Set := + | F32: floatsize + | F64: floatsize. + +Inductive type : Set := + | Tvoid: type + | Tint: intsize -> signedness -> type + | Tfloat: floatsize -> type + | Tpointer: type -> type + | Tarray: type -> Z -> type + | Tfunction: typelist -> type -> type + | Tstruct: fieldlist -> type + | Tunion: fieldlist -> type + +with typelist : Set := + | Tnil: typelist + | Tcons: type -> typelist -> typelist + +with fieldlist : Set := + | Fnil: fieldlist + | Fcons: ident -> type -> fieldlist -> fieldlist. + +(** Arithmetic and logical operators *) + +Inductive unary_operation : Set := + | Onotbool : unary_operation + | Onotint : unary_operation + | Oneg : unary_operation. + +Inductive binary_operation : Set := + | Oadd : binary_operation + | Osub : binary_operation + | Omul : binary_operation + | Odiv : binary_operation + | Omod : binary_operation + | Oand : binary_operation + | Oor : binary_operation + | Oxor : binary_operation + | Oshl : binary_operation + | Oshr : binary_operation + | Oeq: binary_operation + | One: binary_operation + | Olt: binary_operation + | Ogt: binary_operation + | Ole: binary_operation + | Oge: binary_operation. + +(** Expressions *) + +Inductive expr : Set := + | Expr: expr_descr -> type -> expr + +with expr_descr : Set := + | Econst_int: int -> expr_descr + | Econst_float: float -> expr_descr + | Evar: ident -> expr_descr + | Ederef: expr -> expr_descr + | Eaddrof: expr -> expr_descr + | Eunop: unary_operation -> expr -> expr_descr + | Ebinop: binary_operation -> expr -> expr -> expr_descr + | Ecast: type -> expr -> expr_descr + | Eindex: expr -> expr -> expr_descr + | Ecall: expr -> exprlist -> expr_descr + | Eandbool: expr -> expr -> expr_descr + | Eorbool: expr -> expr -> expr_descr + | Esizeof: type -> expr_descr + | Efield: expr -> ident -> expr_descr + +with exprlist : Set := + | Enil: exprlist + | Econs: expr -> exprlist -> exprlist. + +(** Extract the type part of a type-annotated Clight expression. *) + +Definition typeof (e: expr) : type := + match e with Expr de te => te end. + +(** Statements *) + +Inductive statement : Set := + | Sskip : statement + | Sexpr : expr -> statement + | Sassign : expr -> expr -> statement + | Ssequence : statement -> statement -> statement + | Sifthenelse : expr -> statement -> statement -> statement + | Swhile : expr -> statement -> statement + | Sdowhile : expr -> statement -> statement + | Sfor: statement -> expr -> statement -> statement -> statement + | Sbreak : statement + | Scontinue : statement + | Sreturn : option expr -> statement + | Sswitch : expr -> labeled_statements -> statement + +with labeled_statements : Set := + | LSdefault: statement -> labeled_statements + | LScase: int -> statement -> labeled_statements -> labeled_statements. + +(** Function definition *) + +Record function : Set := mkfunction { + fn_return: type; + fn_params: list (ident * type); + fn_vars: list (ident * type); + fn_body: statement +}. + +Inductive fundef : Set := + | Internal: function -> fundef + | External: ident -> typelist -> type -> fundef. + +(** Program *) + +Record program : Set := mkprogram { + prog_funct: list (ident * fundef); + prog_defs: list (ident * type * list init_data); + prog_main: ident +}. + +(** ** Operations over types *) + +(** The type of a function definition *) + +Fixpoint type_of_params (params: list (ident * type)) : typelist := + match params with + | nil => Tnil + | (id, ty) :: rem => Tcons ty (type_of_params rem) + end. + +Definition type_of_function (f: function) : type := + Tfunction (type_of_params (fn_params f)) (fn_return f). + +Definition type_of_fundef (f: fundef) : type := + match f with + | Internal fd => type_of_function fd + | External id args res => Tfunction args res + end. + +(** Natural alignment of a type *) + +Fixpoint alignof (t: type) : Z := + match t with + | Tvoid => 1 + | Tint I8 _ => 1 + | Tint I16 _ => 2 + | Tint I32 _ => 4 + | Tfloat F32 => 4 + | Tfloat F64 => 8 + | Tpointer _ => 4 + | Tarray t' n => alignof t' + | Tfunction _ _ => 1 + | Tstruct fld => alignof_fields fld + | Tunion fld => alignof_fields fld + end + +with alignof_fields (f: fieldlist) : Z := + match f with + | Fnil => 1 + | Fcons id t f' => Zmax (alignof t) (alignof_fields f') + end. + +Scheme type_ind2 := Induction for type Sort Prop + with fieldlist_ind2 := Induction for fieldlist Sort Prop. + +Lemma alignof_fields_pos: + forall f, alignof_fields f > 0. +Proof. + induction f; simpl. + omega. + generalize (Zmax2 (alignof t) (alignof_fields f)). omega. +Qed. + +Lemma alignof_pos: + forall t, alignof t > 0. +Proof. + induction t; simpl; auto; try omega. + destruct i; omega. + destruct f; omega. + apply alignof_fields_pos. + apply alignof_fields_pos. +Qed. + +(** Size of a type (in bytes) *) + +Fixpoint sizeof (t: type) : Z := + match t with + | Tvoid => 1 + | Tint I8 _ => 1 + | Tint I16 _ => 2 + | Tint I32 _ => 4 + | Tfloat F32 => 4 + | Tfloat F64 => 8 + | Tpointer _ => 4 + | Tarray t' n => sizeof t' * Zmax 1 n + | Tfunction _ _ => 1 + | Tstruct fld => align (Zmax 1 (sizeof_struct fld 0)) (alignof t) + | Tunion fld => align (Zmax 1 (sizeof_union fld)) (alignof t) + end + +with sizeof_struct (fld: fieldlist) (pos: Z) {struct fld} : Z := + match fld with + | Fnil => pos + | Fcons id t fld' => sizeof_struct fld' (align pos (alignof t) + sizeof t) + end + +with sizeof_union (fld: fieldlist) : Z := + match fld with + | Fnil => 0 + | Fcons id t fld' => Zmax (sizeof t) (sizeof_union fld') + end. + +Lemma sizeof_pos: + forall t, sizeof t > 0. +Proof. + intro t0. + apply (type_ind2 (fun t => sizeof t > 0) + (fun f => sizeof_union f >= 0 /\ forall pos, pos >= 0 -> sizeof_struct f pos >= 0)); + intros; simpl; auto; try omega. + destruct i; omega. + destruct f; omega. + apply Zmult_gt_0_compat. auto. generalize (Zmax1 1 z); omega. + destruct H. + generalize (align_le (Zmax 1 (sizeof_struct f 0)) (alignof_fields f) (alignof_fields_pos f)). + generalize (Zmax1 1 (sizeof_struct f 0)). omega. + generalize (align_le (Zmax 1 (sizeof_union f)) (alignof_fields f) (alignof_fields_pos f)). + generalize (Zmax1 1 (sizeof_union f)). omega. + split. omega. auto. + destruct H0. split; intros. + generalize (Zmax2 (sizeof t) (sizeof_union f)). omega. + apply H1. + generalize (align_le pos (alignof t) (alignof_pos t)). omega. +Qed. + +(** Byte offset for a field in a struct. *) + +Fixpoint field_offset_rec (id: ident) (fld: fieldlist) (pos: Z) + {struct fld} : option Z := + match fld with + | Fnil => None + | Fcons id' t fld' => + if ident_eq id id' + then Some (align pos (alignof t)) + else field_offset_rec id fld' (align pos (alignof t) + sizeof t) + end. + +Definition field_offset (id: ident) (fld: fieldlist) : option Z := + field_offset_rec id fld 0. + +(* Describe how a variable of the given type must be accessed: + - by value, i.e. by loading from the address of the variable + with the given chunk + - by reference, i.e. by just returning the address of the variable + - not at all, e.g. the [void] type. *) + +Inductive mode: Set := + | By_value: memory_chunk -> mode + | By_reference: mode + | By_nothing: mode. + +Definition access_mode (ty: type) : mode := + match ty with + | Tint I8 Signed => By_value Mint8signed + | Tint I8 Unsigned => By_value Mint8unsigned + | Tint I16 Signed => By_value Mint16signed + | Tint I16 Unsigned => By_value Mint16unsigned + | Tint I32 _ => By_value Mint32 + | Tfloat F32 => By_value Mfloat32 + | Tfloat F64 => By_value Mfloat64 + | Tvoid => By_nothing + | Tpointer _ => By_value Mint32 + | Tarray _ _ => By_reference + | Tfunction _ _ => By_reference + | Tstruct fList => By_nothing + | Tunion fList => By_nothing +end. + +(** Conversion of a Clight program into an AST program *) + +Definition extract_global_var (id_ty_init: ident * type * list init_data) := + match id_ty_init with (id, ty, init) => (id, init) end. + +Definition program_of_program (p: program) : AST.program fundef := + AST.mkprogram + p.(prog_funct) + p.(prog_main) + (List.map extract_global_var p.(prog_defs)). + +(** Classification of arithmetic operations and comparisons *) + +Inductive classify_add_cases : Set := + | add_case_ii: classify_add_cases (* int , int *) + | add_case_ff: classify_add_cases (* float , float *) + | add_case_pi: type -> classify_add_cases (* ptr | array, int *) + | add_default: classify_add_cases. (* other *) + +Definition classify_add (ty1: type) (ty2: type) := + match ty1, ty2 with + | Tint _ _, Tint _ _ => add_case_ii + | Tfloat _, Tfloat _ => add_case_ff + | Tpointer ty, Tint _ _ => add_case_pi ty + | Tarray ty _, Tint _ _ => add_case_pi ty + | _, _ => add_default + end. + +Inductive classify_sub_cases : Set := + | sub_case_ii: classify_sub_cases (* int , int *) + | sub_case_ff: classify_sub_cases (* float , float *) + | sub_case_pi: type -> classify_sub_cases (* ptr | array , int *) + | sub_case_pp: type -> classify_sub_cases (* ptr | array , ptr | array *) + | sub_default: classify_sub_cases . (* other *) + +Definition classify_sub (ty1: type) (ty2: type) := + match ty1, ty2 with + | Tint _ _ , Tint _ _ => sub_case_ii + | Tfloat _ , Tfloat _ => sub_case_ff + | Tpointer ty , Tint _ _ => sub_case_pi ty + | Tarray ty _ , Tint _ _ => sub_case_pi ty + | Tpointer ty , Tpointer _ => sub_case_pp ty + | Tpointer ty , Tarray _ _=> sub_case_pp ty + | Tarray ty _ , Tpointer _ => sub_case_pp ty + | Tarray ty _ , Tarray _ _ => sub_case_pp ty + | _ ,_ => sub_default + end. + +Inductive classify_mul_cases : Set:= + | mul_case_ii: classify_mul_cases (* int , int *) + | mul_case_ff: classify_mul_cases (* float , float *) + | mul_default: classify_mul_cases . (* other *) + +Definition classify_mul (ty1: type) (ty2: type) := + match ty1,ty2 with + | Tint _ _, Tint _ _ => mul_case_ii + | Tfloat _ , Tfloat _ => mul_case_ff + | _,_ => mul_default +end. + +Inductive classify_div_cases : Set:= + | div_case_I32unsi: classify_div_cases (* uns int32 , int *) + | div_case_ii: classify_div_cases (* int , int *) + | div_case_ff: classify_div_cases (* float , float *) + | div_default: classify_div_cases. (* other *) + +Definition classify_div (ty1: type) (ty2: type) := + match ty1,ty2 with + | Tint I32 Unsigned, Tint _ _ => div_case_I32unsi + | Tint _ _ , Tint I32 Unsigned => div_case_I32unsi + | Tint _ _ , Tint _ _ => div_case_ii + | Tfloat _ , Tfloat _ => div_case_ff + | _ ,_ => div_default +end. + +Inductive classify_mod_cases : Set:= + | mod_case_I32unsi: classify_mod_cases (* uns I32 , int *) + | mod_case_ii: classify_mod_cases (* int , int *) + | mod_default: classify_mod_cases . (* other *) + +Definition classify_mod (ty1: type) (ty2: type) := + match ty1,ty2 with + | Tint I32 Unsigned , Tint _ _ => mod_case_I32unsi + | Tint _ _ , Tint I32 Unsigned => mod_case_I32unsi + | Tint _ _ , Tint _ _ => mod_case_ii + | _ , _ => mod_default +end . + +Inductive classify_shr_cases :Set:= + | shr_case_I32unsi: classify_shr_cases (* uns I32 , int *) + | shr_case_ii :classify_shr_cases (* int , int *) + | shr_default : classify_shr_cases . (* other *) + +Definition classify_shr (ty1: type) (ty2: type) := + match ty1,ty2 with + | Tint I32 Unsigned , Tint _ _ => shr_case_I32unsi + | Tint _ _ , Tint _ _ => shr_case_ii + | _ , _ => shr_default + end. + +Inductive classify_cmp_cases : Set:= + | cmp_case_I32unsi: classify_cmp_cases (* uns I32 , int *) + | cmp_case_ii: classify_cmp_cases (* int , int*) + | cmp_case_ff: classify_cmp_cases (* float , float *) + | cmp_case_pi: classify_cmp_cases (* ptr | array , int *) + | cmp_case_pp:classify_cmp_cases (* ptr | array , ptr | array *) + | cmp_default: classify_cmp_cases . (* other *) + +Definition classify_cmp (ty1: type) (ty2: type) := + match ty1,ty2 with + | Tint I32 Unsigned , Tint _ _ => cmp_case_I32unsi + | Tint _ _ , Tint I32 Unsigned => cmp_case_I32unsi + | Tint _ _ , Tint _ _ => cmp_case_ii + | Tfloat _ , Tfloat _ => cmp_case_ff + | Tpointer _ , Tint _ _ => cmp_case_pi + | Tarray _ _ , Tint _ _ => cmp_case_pi + | Tpointer _ , Tpointer _ => cmp_case_pp + | Tpointer _ , Tarray _ _ => cmp_case_pp + | Tarray _ _ ,Tpointer _ => cmp_case_pp + | Tarray _ _ ,Tarray _ _ => cmp_case_pp + | _ , _ => cmp_default + end. + +Inductive classify_fun_cases : Set:= + | fun_case_f: typelist -> type -> classify_fun_cases (* type fun | ptr fun*) + | fun_default: classify_fun_cases . (* other *) + +Definition classify_fun (ty: type) := + match ty with + | Tfunction args res => fun_case_f args res + | Tpointer (Tfunction args res) => fun_case_f args res + | _ => fun_default + end. + +(** Mapping between Clight types and Cminor types and external functions *) + +Definition typ_of_type (t: type) : AST.typ := + match t with + | Tfloat _ => AST.Tfloat + | _ => AST.Tint + end. + +Definition opttyp_of_type (t: type) : option AST.typ := + match t with + | Tvoid => None + | Tfloat _ => Some AST.Tfloat + | _ => Some AST.Tint + end. + +Fixpoint typlist_of_typelist (tl: typelist) : list AST.typ := + match tl with + | Tnil => nil + | Tcons hd tl => typ_of_type hd :: typlist_of_typelist tl + end. + +Definition signature_of_type (args: typelist) (res: type) : signature := + mksignature (typlist_of_typelist args) (opttyp_of_type res). + +Definition external_function + (id: ident) (targs: typelist) (tres: type) : AST.external_function := + mkextfun id (signature_of_type targs tres). diff --git a/cfrontend/Ctyping.v b/cfrontend/Ctyping.v new file mode 100644 index 0000000..8b2f90f --- /dev/null +++ b/cfrontend/Ctyping.v @@ -0,0 +1,420 @@ +(** * Type well-formedness of C programs *) + +Require Import Coqlib. +Require Import Maps. +Require Import AST. +Require Import Csyntax. + +(** ** Typing rules *) + +(** This ``type system'' is very coarse: we check only the typing properties + that matter for the translation to be correct. Essentially, + we need to check that the types attached to variable references + match the declaration types for those variables. *) + +Definition typenv := PTree.t type. + +Section TYPING. + +Variable env: typenv. + +Inductive wt_expr: expr -> Prop := + | wt_Econst_int: forall i ty, + wt_expr (Expr (Econst_int i) ty) + | wt_Econst_float: forall f ty, + wt_expr (Expr (Econst_float f) ty) + | wt_Evar: forall id ty, + env!id = Some ty -> + wt_expr (Expr (Evar id) ty) + | wt_Ederef: forall e ty, + wt_expr e -> + wt_expr (Expr (Ederef e) ty) + | wt_Eaddrof: forall e ty, + wt_expr e -> + wt_expr (Expr (Eaddrof e) ty) + | wt_Eunop: forall op e ty, + wt_expr e -> + wt_expr (Expr (Eunop op e) ty) + | wt_Ebinop: forall op e1 e2 ty, + wt_expr e1 -> wt_expr e2 -> + wt_expr (Expr (Ebinop op e1 e2) ty) + | wt_Ecast: forall e ty ty', + wt_expr e -> + wt_expr (Expr (Ecast ty' e) ty) + | wt_Eindex: forall e1 e2 ty, + wt_expr e1 -> wt_expr e2 -> + wt_expr (Expr (Eindex e1 e2) ty) + | wt_Ecall: forall e1 el ty, + wt_expr e1 -> + wt_exprlist el -> + wt_expr (Expr (Ecall e1 el) ty) + | wt_Eandbool: forall e1 e2 ty, + wt_expr e1 -> wt_expr e2 -> + wt_expr (Expr (Eandbool e1 e2) ty) + | wt_Eorbool: forall e1 e2 ty, + wt_expr e1 -> wt_expr e2 -> + wt_expr (Expr (Eorbool e1 e2) ty) + | wt_Esizeof: forall ty' ty, + wt_expr (Expr (Esizeof ty') ty) + | wt_Efield: forall e id ty, + wt_expr e -> + wt_expr (Expr (Efield e id) ty) + +with wt_exprlist: exprlist -> Prop := + | wt_Enil: + wt_exprlist Enil + | wt_Econs: forall e el, + wt_expr e -> wt_exprlist el -> wt_exprlist (Econs e el). + +Inductive wt_stmt: statement -> Prop := + | wt_Sskip: + wt_stmt Sskip + | wt_Sexpr: forall e, + wt_expr e -> + wt_stmt (Sexpr e) + | wt_Sassign: forall e1 e2, + wt_expr e1 -> wt_expr e2 -> + wt_stmt (Sassign e1 e2) + | wt_Ssequence: forall s1 s2, + wt_stmt s1 -> wt_stmt s2 -> + wt_stmt (Ssequence s1 s2) + | wt_Sifthenelse: forall e s1 s2, + wt_expr e -> wt_stmt s1 -> wt_stmt s2 -> + wt_stmt (Sifthenelse e s1 s2) + | wt_Swhile: forall e s, + wt_expr e -> wt_stmt s -> + wt_stmt (Swhile e s) + | wt_Sdowhile: forall e s, + wt_expr e -> wt_stmt s -> + wt_stmt (Sdowhile e s) + | wt_Sfor: forall e s1 s2 s3, + wt_expr e -> wt_stmt s1 -> wt_stmt s2 -> wt_stmt s3 -> + wt_stmt (Sfor s1 e s2 s3) + | wt_Sbreak: + wt_stmt Sbreak + | wt_Scontinue: + wt_stmt Scontinue + | wt_Sreturn_some: forall e, + wt_expr e -> + wt_stmt (Sreturn (Some e)) + | wt_Sreturn_none: + wt_stmt (Sreturn None) + | wt_Sswitch: forall e sl, + wt_expr e -> wt_lblstmts sl -> + wt_stmt (Sswitch e sl) + +with wt_lblstmts: labeled_statements -> Prop := + | wt_LSdefault: forall s, + wt_stmt s -> + wt_lblstmts (LSdefault s) + | wt_LScase: forall n s sl, + wt_stmt s -> wt_lblstmts sl -> + wt_lblstmts (LScase n s sl). + +End TYPING. + +Definition add_var (env: typenv) (id_ty: ident * type) : typenv := + PTree.set (fst id_ty) (snd id_ty) env. + +Definition add_vars (env: typenv) (vars: list(ident * type)) : typenv := + List.fold_left add_var vars env. + +Definition var_names (vars: list(ident * type)) : list ident := + List.map (@fst ident type) vars. + +Inductive wt_function: typenv -> function -> Prop := + | wt_function_intro: forall env f, + list_norepet (var_names f.(fn_params) ++ var_names f.(fn_vars)) -> + wt_stmt (add_vars env (f.(fn_params) ++ f.(fn_vars))) f.(fn_body) -> + wt_function env f. + +Inductive wt_fundef: typenv -> fundef -> Prop := + | wt_fundef_Internal: forall env f, + wt_function env f -> + wt_fundef env (Internal f) + | wt_fundef_External: forall env id args res, + wt_fundef env (External id args res). + +Definition add_global_var + (env: typenv) (id_ty_init: ident * type * list init_data) : typenv := + match id_ty_init with (id, ty, init) => PTree.set id ty env end. + +Definition add_global_vars + (env: typenv) (vars: list(ident * type * list init_data)) : typenv := + List.fold_left add_global_var vars env. + +Definition add_global_fun + (env: typenv) (id_fd: ident * fundef) : typenv := + PTree.set (fst id_fd) (type_of_fundef (snd id_fd)) env. + +Definition add_global_funs + (env: typenv) (funs: list(ident * fundef)) : typenv := + List.fold_left add_global_fun funs env. + +Definition global_typenv (p: program) := + add_global_vars (add_global_funs (PTree.empty type) p.(prog_funct)) p.(prog_defs). + +Record wt_program (p: program) : Prop := mk_wt_program { + wt_program_funct: + forall id fd, + In (id, fd) p.(prog_funct) -> + wt_fundef (global_typenv p) fd; + wt_program_main: + forall fd, + In (p.(prog_main), fd) p.(prog_funct) -> + type_of_fundef fd = Tfunction Tnil (Tint I32 Signed) +}. + +(** ** Type-checking algorithm *) + +Lemma eq_signedness: forall (s1 s2: signedness), {s1=s2} + {s1<>s2}. +Proof. decide equality. Qed. + +Lemma eq_intsize: forall (s1 s2: intsize), {s1=s2} + {s1<>s2}. +Proof. decide equality. Qed. + +Lemma eq_floatsize: forall (s1 s2: floatsize), {s1=s2} + {s1<>s2}. +Proof. decide equality. Qed. + +Fixpoint eq_type (t1 t2: type) {struct t1}: bool := + match t1, t2 with + | Tvoid, Tvoid => true + | Tint sz1 sg1, Tint sz2 sg2 => + if eq_intsize sz1 sz2 + then if eq_signedness sg1 sg2 then true else false + else false + | Tfloat sz1, Tfloat sz2 => + if eq_floatsize sz1 sz2 then true else false + | Tpointer u1, Tpointer u2 => eq_type u1 u2 + | Tarray u1 sz1, Tarray u2 sz2 => + eq_type u1 u2 && if zeq sz1 sz2 then true else false + | Tfunction args1 res1, Tfunction args2 res2 => + eq_typelist args1 args2 && eq_type res1 res2 + | Tstruct f1, Tstruct f2 => eq_fieldlist f1 f2 + | Tunion f1, Tunion f2 => eq_fieldlist f1 f2 + | _, _ => false + end + +with eq_typelist (t1 t2: typelist) {struct t1} : bool := + match t1, t2 with + | Tnil, Tnil => true + | Tcons u1 r1, Tcons u2 r2 => eq_type u1 u2 && eq_typelist r1 r2 + | _, _ => false + end + +with eq_fieldlist (f1 f2: fieldlist) {struct f1} : bool := + match f1, f2 with + | Fnil, Fnil => true + | Fcons id1 t1 r1, Fcons id2 t2 r2 => + if ident_eq id1 id2 + then eq_type t1 t2 && eq_fieldlist r1 r2 + else false + | _, _ => false + end. + +Ltac TrueInv := + match goal with + | [ H: ((if ?x then ?y else false) = true) |- _ ] => + destruct x; [TrueInv | discriminate] + | [ H: (?x && ?y = true) |- _ ] => + elim (andb_prop _ _ H); clear H; intros; TrueInv + | _ => + idtac + end. + +Scheme type_ind_3 := Induction for type Sort Prop + with typelist_ind_3 := Induction for typelist Sort Prop + with fieldlist_ind_3 := Induction for fieldlist Sort Prop. + +Lemma eq_type_correct: + forall t1 t2, eq_type t1 t2 = true -> t1 = t2. +Proof. + apply (type_ind_3 (fun t1 => forall t2, eq_type t1 t2 = true -> t1 = t2) + (fun t1 => forall t2, eq_typelist t1 t2 = true -> t1 = t2) + (fun t1 => forall t2, eq_fieldlist t1 t2 = true -> t1 = t2)); + intros; destruct t2; simpl in *; try discriminate. + auto. + TrueInv. congruence. + TrueInv. congruence. + decEq; auto. + TrueInv. decEq; auto. + TrueInv. decEq; auto. + decEq; auto. + decEq; auto. + auto. + TrueInv. decEq; auto. + auto. + TrueInv. decEq; auto. +Qed. + +Section TYPECHECKING. + +Variable env: typenv. + +Fixpoint typecheck_expr (a: Csyntax.expr) {struct a} : bool := + match a with + | Expr ad aty => typecheck_exprdescr ad aty + end + +with typecheck_exprdescr (a: Csyntax.expr_descr) (ty: type) {struct a} : bool := + match a with + | Csyntax.Econst_int n => true + | Csyntax.Econst_float n => true + | Csyntax.Evar id => + match env!id with + | None => false + | Some ty' => eq_type ty ty' + end + | Csyntax.Ederef b => typecheck_expr b + | Csyntax.Eaddrof b => typecheck_expr b + | Csyntax.Eunop op b => typecheck_expr b + | Csyntax.Ebinop op b c => typecheck_expr b && typecheck_expr c + | Csyntax.Ecast ty b => typecheck_expr b + | Csyntax.Eindex b c => typecheck_expr b && typecheck_expr c + | Csyntax.Ecall b cl => typecheck_expr b && typecheck_exprlist cl + | Csyntax.Eandbool b c => typecheck_expr b && typecheck_expr c + | Csyntax.Eorbool b c => typecheck_expr b && typecheck_expr c + | Csyntax.Esizeof ty => true + | Csyntax.Efield b i => typecheck_expr b + end + +with typecheck_exprlist (al: Csyntax.exprlist): bool := + match al with + | Csyntax.Enil => true + | Csyntax.Econs a1 a2 => typecheck_expr a1 && typecheck_exprlist a2 + end. + +Scheme expr_ind_3 := Induction for expr Sort Prop + with expr_descr_ind_3 := Induction for expr_descr Sort Prop + with exprlist_ind_3 := Induction for exprlist Sort Prop. + +Lemma typecheck_expr_correct: + forall a, typecheck_expr a = true -> wt_expr env a. +Proof. + apply (expr_ind_3 (fun a => typecheck_expr a = true -> wt_expr env a) + (fun a => forall ty, typecheck_exprdescr a ty = true -> wt_expr env (Expr a ty)) + (fun a => typecheck_exprlist a = true -> wt_exprlist env a)); + simpl; intros; TrueInv. + auto. + constructor. + constructor. + constructor. destruct (env!i). decEq; symmetry; apply eq_type_correct; auto. + discriminate. + constructor; auto. + constructor; auto. + constructor; auto. + constructor; auto. + constructor; auto. + constructor; auto. + constructor; auto. + constructor; auto. + constructor; auto. + auto. + constructor; auto. + constructor; auto. + constructor. + constructor; auto. +Qed. + +Lemma typecheck_exprlist_correct: + forall a, typecheck_exprlist a = true -> wt_exprlist env a. +Proof. + induction a; simpl; intros. + constructor. + TrueInv. constructor; auto. apply typecheck_expr_correct; auto. +Qed. + +Fixpoint typecheck_stmt (s: Csyntax.statement) {struct s} : bool := + match s with + | Csyntax.Sskip => true + | Csyntax.Sexpr e => typecheck_expr e + | Csyntax.Sassign b c => typecheck_expr b && typecheck_expr c + | Csyntax.Ssequence s1 s2 => typecheck_stmt s1 && typecheck_stmt s2 + | Csyntax.Sifthenelse e s1 s2 => + typecheck_expr e && typecheck_stmt s1 && typecheck_stmt s2 + | Csyntax.Swhile e s1 => typecheck_expr e && typecheck_stmt s1 + | Csyntax.Sdowhile e s1 => typecheck_expr e && typecheck_stmt s1 + | Csyntax.Sfor e1 e2 e3 s1 => + typecheck_stmt e1 && typecheck_expr e2 && + typecheck_stmt e3 && typecheck_stmt s1 + | Csyntax.Sbreak => true + | Csyntax.Scontinue => true + | Csyntax.Sreturn (Some e) => typecheck_expr e + | Csyntax.Sreturn None => true + | Csyntax.Sswitch e sl => typecheck_expr e && typecheck_lblstmts sl + end + +with typecheck_lblstmts (sl: labeled_statements) {struct sl}: bool := + match sl with + | LSdefault s => typecheck_stmt s + | LScase _ s rem => typecheck_stmt s && typecheck_lblstmts rem + end. + +Scheme stmt_ind_2 := Induction for statement Sort Prop + with lblstmts_ind_2 := Induction for labeled_statements Sort Prop. + +Lemma typecheck_stmt_correct: + forall s, typecheck_stmt s = true -> wt_stmt env s. +Proof. + generalize typecheck_expr_correct; intro. + apply (stmt_ind_2 (fun s => typecheck_stmt s = true -> wt_stmt env s) + (fun s => typecheck_lblstmts s = true -> wt_lblstmts env s)); + simpl; intros; TrueInv; try constructor; auto. + destruct o; constructor; auto. +Qed. + +End TYPECHECKING. + +Definition typecheck_function (env: typenv) (f: function) : bool := + if list_norepet_dec ident_eq + (var_names f.(fn_params) ++ var_names f.(fn_vars)) + then typecheck_stmt (add_vars env (f.(fn_params) ++ f.(fn_vars))) + f.(fn_body) + else false. + +Lemma typecheck_function_correct: + forall env f, typecheck_function env f = true -> wt_function env f. +Proof. + unfold typecheck_function; intros; TrueInv. + constructor. auto. apply typecheck_stmt_correct; auto. +Qed. + +Definition typecheck_fundef (main: ident) (env: typenv) (id_fd: ident * fundef) : bool := + let (id, fd) := id_fd in + match fd with + | Internal f => typecheck_function env f + | External _ _ _ => true + end && + if ident_eq id main + then eq_type (type_of_fundef fd) (Tfunction Tnil (Tint I32 Signed)) + else true. + +Lemma typecheck_fundef_correct: + forall main env id fd, + typecheck_fundef main env (id, fd) = true -> + wt_fundef env fd /\ + (id = main -> type_of_fundef fd = Tfunction Tnil (Tint I32 Signed)). +Proof. + intros. unfold typecheck_fundef in H; TrueInv. + split. + destruct fd. + constructor. apply typecheck_function_correct; auto. + constructor. + intro. destruct (ident_eq id main). + apply eq_type_correct; auto. + congruence. +Qed. + +Definition typecheck_program (p: program) : bool := + List.forallb (typecheck_fundef p.(prog_main) (global_typenv p)) + p.(prog_funct). + +Lemma typecheck_program_correct: + forall p, typecheck_program p = true -> wt_program p. +Proof. + unfold typecheck_program; intros. + rewrite List.forallb_forall in H. + constructor; intros. + exploit typecheck_fundef_correct; eauto. tauto. + exploit typecheck_fundef_correct; eauto. tauto. +Qed. diff --git a/extraction/.depend b/extraction/.depend index 9d6895d..20f0876 100644 --- a/extraction/.depend +++ b/extraction/.depend @@ -1,14 +1,9 @@ -../caml/Allocationaux.cmi: Locations.cmi Datatypes.cmi ../caml/CMlexer.cmi: ../caml/CMparser.cmi ../caml/CMparser.cmi: Cminor.cmi AST.cmi ../caml/CMtypecheck.cmi: Cminor.cmi ../caml/Coloringaux.cmi: Registers.cmi RTLtyping.cmi RTL.cmi Locations.cmi \ InterfGraph.cmi ../caml/PrintPPC.cmi: PPC.cmi -../caml/Allocationaux.cmo: Locations.cmi Datatypes.cmi ../caml/Camlcoq.cmo \ - CList.cmi AST.cmi ../caml/Allocationaux.cmi -../caml/Allocationaux.cmx: Locations.cmx Datatypes.cmx ../caml/Camlcoq.cmx \ - CList.cmx AST.cmx ../caml/Allocationaux.cmi ../caml/Camlcoq.cmo: Integers.cmi Datatypes.cmi CList.cmi BinPos.cmi \ BinInt.cmi ../caml/Camlcoq.cmx: Integers.cmx Datatypes.cmx CList.cmx BinPos.cmx \ @@ -17,24 +12,24 @@ ../caml/CMlexer.cmi ../caml/CMlexer.cmx: ../caml/Camlcoq.cmx ../caml/CMparser.cmx \ ../caml/CMlexer.cmi -../caml/CMparser.cmo: Op.cmi Integers.cmi Datatypes.cmi Cminor.cmi \ +../caml/CMparser.cmo: Op.cmi Integers.cmi Int.cmi Datatypes.cmi Cminor.cmi \ Cmconstr.cmi ../caml/Camlcoq.cmo CList.cmi BinPos.cmi BinInt.cmi AST.cmi \ ../caml/CMparser.cmi -../caml/CMparser.cmx: Op.cmx Integers.cmx Datatypes.cmx Cminor.cmx \ +../caml/CMparser.cmx: Op.cmx Integers.cmx Int.cmx Datatypes.cmx Cminor.cmx \ Cmconstr.cmx ../caml/Camlcoq.cmx CList.cmx BinPos.cmx BinInt.cmx AST.cmx \ ../caml/CMparser.cmi -../caml/CMtypecheck.cmo: Op.cmi Datatypes.cmi Cminor.cmi ../caml/Camlcoq.cmo \ - CList.cmi AST.cmi ../caml/CMtypecheck.cmi -../caml/CMtypecheck.cmx: Op.cmx Datatypes.cmx Cminor.cmx ../caml/Camlcoq.cmx \ - CList.cmx AST.cmx ../caml/CMtypecheck.cmi +../caml/CMtypecheck.cmo: Op.cmi Integers.cmi Datatypes.cmi Cminor.cmi \ + ../caml/Camlcoq.cmo CList.cmi AST.cmi ../caml/CMtypecheck.cmi +../caml/CMtypecheck.cmx: Op.cmx Integers.cmx Datatypes.cmx Cminor.cmx \ + ../caml/Camlcoq.cmx CList.cmx AST.cmx ../caml/CMtypecheck.cmi ../caml/Coloringaux.cmo: Registers.cmi RTLtyping.cmi RTL.cmi Maps.cmi \ Locations.cmi InterfGraph.cmi Datatypes.cmi Conventions.cmi \ ../caml/Camlcoq.cmo BinPos.cmi BinInt.cmi AST.cmi ../caml/Coloringaux.cmi ../caml/Coloringaux.cmx: Registers.cmx RTLtyping.cmx RTL.cmx Maps.cmx \ Locations.cmx InterfGraph.cmx Datatypes.cmx Conventions.cmx \ ../caml/Camlcoq.cmx BinPos.cmx BinInt.cmx AST.cmx ../caml/Coloringaux.cmi -../caml/Floataux.cmo: ../caml/Camlcoq.cmo AST.cmi -../caml/Floataux.cmx: ../caml/Camlcoq.cmx AST.cmx +../caml/Floataux.cmo: Integers.cmi ../caml/Camlcoq.cmo +../caml/Floataux.cmx: Integers.cmx ../caml/Camlcoq.cmx ../caml/Main2.cmo: ../caml/PrintPPC.cmi Main.cmi Datatypes.cmi \ ../caml/CMtypecheck.cmi ../caml/CMparser.cmi ../caml/CMlexer.cmi ../caml/Main2.cmx: ../caml/PrintPPC.cmx Main.cmx Datatypes.cmx \ @@ -45,18 +40,23 @@ AST.cmx ../caml/PrintPPC.cmi ../caml/RTLgenaux.cmo: Cminor.cmi ../caml/RTLgenaux.cmx: Cminor.cmx +../caml/RTLtypingaux.cmo: Registers.cmi RTL.cmi Op.cmi Maps.cmi Datatypes.cmi \ + ../caml/Camlcoq.cmo CList.cmi AST.cmi +../caml/RTLtypingaux.cmx: Registers.cmx RTL.cmx Op.cmx Maps.cmx Datatypes.cmx \ + ../caml/Camlcoq.cmx CList.cmx AST.cmx Allocation.cmi: Specif.cmi Registers.cmi RTLtyping.cmi RTL.cmi \ Parallelmove.cmi Op.cmi Maps.cmi Locations.cmi LTL.cmi Datatypes.cmi \ Conventions.cmi Coloring.cmi CList.cmi BinPos.cmi AST.cmi -AST.cmi: Specif.cmi Datatypes.cmi Coqlib.cmi CList.cmi BinPos.cmi BinInt.cmi +AST.cmi: Specif.cmi Integers.cmi Floats.cmi Datatypes.cmi Coqlib.cmi \ + CList.cmi BinPos.cmi BinInt.cmi BinInt.cmi: Datatypes.cmi BinPos.cmi BinNat.cmi -BinNat.cmi: Datatypes.cmi BinPos.cmi +BinNat.cmi: Specif.cmi Datatypes.cmi BinPos.cmi BinPos.cmi: Peano.cmi Datatypes.cmi Bool.cmi: Specif.cmi Datatypes.cmi CList.cmi: Specif.cmi Datatypes.cmi Cmconstr.cmi: Specif.cmi Op.cmi Integers.cmi Datatypes.cmi Compare_dec.cmi \ Cminor.cmi CList.cmi BinPos.cmi BinInt.cmi AST.cmi -Cminorgen.cmi: Zmin.cmi Specif.cmi Op.cmi Mem.cmi Maps.cmi Integers.cmi \ +Cminorgen.cmi: Zmax.cmi Specif.cmi Op.cmi Mem.cmi Maps.cmi Integers.cmi \ Datatypes.cmi Csharpminor.cmi Coqlib.cmi Cminor.cmi Cmconstr.cmi \ CList.cmi BinPos.cmi BinInt.cmi AST.cmi Cminor.cmi: Values.cmi Op.cmi Maps.cmi Integers.cmi Globalenvs.cmi \ @@ -67,43 +67,45 @@ Coloring.cmi: Specif.cmi Registers.cmi RTLtyping.cmi RTL.cmi Op.cmi Maps.cmi \ Compare_dec.cmi: Specif.cmi Datatypes.cmi Constprop.cmi: Specif.cmi Registers.cmi RTL.cmi Op.cmi Maps.cmi Integers.cmi \ Floats.cmi Datatypes.cmi CList.cmi Bool.cmi BinPos.cmi BinInt.cmi AST.cmi -Conventions.cmi: Locations.cmi Datatypes.cmi CList.cmi BinPos.cmi BinInt.cmi \ - AST.cmi +Conventions.cmi: Locations.cmi Datatypes.cmi Coqlib.cmi CList.cmi BinPos.cmi \ + BinInt.cmi AST.cmi Coqlib.cmi: Zdiv.cmi ZArith_dec.cmi Wf.cmi Specif.cmi Datatypes.cmi CList.cmi \ BinPos.cmi BinInt.cmi CSE.cmi: Specif.cmi Registers.cmi RTL.cmi Op.cmi Maps.cmi Integers.cmi \ Floats.cmi Datatypes.cmi Coqlib.cmi CList.cmi BinPos.cmi AST.cmi -Csharpminor.cmi: Zmin.cmi Values.cmi Specif.cmi Mem.cmi Maps.cmi Integers.cmi \ +Csharpminor.cmi: Zmax.cmi Values.cmi Specif.cmi Mem.cmi Maps.cmi Integers.cmi \ Globalenvs.cmi Floats.cmi Datatypes.cmi CList.cmi BinPos.cmi BinInt.cmi \ AST.cmi -Floats.cmi: Specif.cmi Integers.cmi Datatypes.cmi AST.cmi -FSetAVL.cmi: ZArith_dec.cmi Wf.cmi Specif.cmi Peano.cmi FSetInterface.cmi \ +Floats.cmi: Specif.cmi Integers.cmi Datatypes.cmi +FSetAVL.cmi: Wf.cmi Specif.cmi Peano.cmi OrderedType.cmi Int.cmi \ Datatypes.cmi CList.cmi BinPos.cmi BinInt.cmi FSetBridge.cmi: Specif.cmi FSetInterface.cmi Datatypes.cmi CList.cmi FSetInterface.cmi: Specif.cmi Datatypes.cmi CList.cmi -FSetList.cmi: Specif.cmi FSetInterface.cmi Datatypes.cmi CList.cmi +FSetList.cmi: Specif.cmi OrderedType.cmi Datatypes.cmi CList.cmi Globalenvs.cmi: Values.cmi Mem.cmi Maps.cmi Integers.cmi Datatypes.cmi \ CList.cmi BinPos.cmi BinInt.cmi AST.cmi Integers.cmi: Zpower.cmi Zdiv.cmi Specif.cmi Datatypes.cmi Coqlib.cmi \ - CList.cmi Bool.cmi BinPos.cmi BinInt.cmi AST.cmi -InterfGraph.cmi: Specif.cmi Registers.cmi Locations.cmi FSetInterface.cmi \ - Datatypes.cmi Coqlib.cmi CList.cmi BinPos.cmi BinInt.cmi -Kildall.cmi: Wf.cmi Specif.cmi Maps.cmi Lattice.cmi Datatypes.cmi Coqlib.cmi \ - CList.cmi BinPos.cmi + CList.cmi Bool.cmi BinPos.cmi BinInt.cmi +InterfGraph.cmi: Specif.cmi Registers.cmi OrderedType.cmi Locations.cmi \ + Int.cmi Datatypes.cmi Coqlib.cmi CList.cmi BinPos.cmi BinInt.cmi +Int.cmi: Zmax.cmi ZArith_dec.cmi Specif.cmi BinPos.cmi BinInt.cmi +Iteration.cmi: Wf.cmi Specif.cmi Datatypes.cmi Coqlib.cmi BinPos.cmi +Kildall.cmi: Specif.cmi Maps.cmi Lattice.cmi Iteration.cmi Datatypes.cmi \ + Coqlib.cmi CList.cmi BinPos.cmi Lattice.cmi: Specif.cmi Maps.cmi Datatypes.cmi BinPos.cmi Linearize.cmi: Specif.cmi Op.cmi Maps.cmi Linear.cmi Lattice.cmi LTL.cmi \ Datatypes.cmi Coqlib.cmi CList.cmi BinPos.cmi AST.cmi Linear.cmi: Values.cmi Specif.cmi Op.cmi Locations.cmi Integers.cmi \ Globalenvs.cmi Datatypes.cmi Coqlib.cmi CList.cmi BinPos.cmi BinInt.cmi \ AST.cmi -Lineartyping.cmi: Zmin.cmi Locations.cmi Linear.cmi Datatypes.cmi \ +Lineartyping.cmi: Zmax.cmi Locations.cmi Linear.cmi Datatypes.cmi \ Conventions.cmi CList.cmi BinPos.cmi BinInt.cmi AST.cmi Locations.cmi: Values.cmi Specif.cmi Datatypes.cmi Coqlib.cmi BinPos.cmi \ BinInt.cmi AST.cmi LTL.cmi: Values.cmi Specif.cmi Op.cmi Maps.cmi Locations.cmi Integers.cmi \ Globalenvs.cmi Datatypes.cmi Conventions.cmi CList.cmi BinPos.cmi \ BinInt.cmi AST.cmi -Mach.cmi: Zmin.cmi Zdiv.cmi Values.cmi Specif.cmi Op.cmi Mem.cmi \ +Mach.cmi: Zmax.cmi Zdiv.cmi Values.cmi Specif.cmi Op.cmi Mem.cmi \ Locations.cmi Integers.cmi Globalenvs.cmi Datatypes.cmi Coqlib.cmi \ CList.cmi BinPos.cmi BinInt.cmi AST.cmi Main.cmi: Tunneling.cmi Stacking.cmi RTLgen.cmi PPCgen.cmi PPC.cmi \ @@ -111,14 +113,15 @@ Main.cmi: Tunneling.cmi Stacking.cmi RTLgen.cmi PPCgen.cmi PPC.cmi \ Cminor.cmi CSE.cmi Allocation.cmi AST.cmi Maps.cmi: Specif.cmi Datatypes.cmi Coqlib.cmi CList.cmi BinPos.cmi BinNat.cmi \ BinInt.cmi -Mem.cmi: Values.cmi Specif.cmi Integers.cmi Datatypes.cmi Coqlib.cmi \ +Mem.cmi: Zmax.cmi Values.cmi Specif.cmi Integers.cmi Datatypes.cmi Coqlib.cmi \ CList.cmi BinPos.cmi BinInt.cmi AST.cmi Op.cmi: Values.cmi Specif.cmi Integers.cmi Globalenvs.cmi Floats.cmi \ Datatypes.cmi CList.cmi Bool.cmi BinPos.cmi BinInt.cmi AST.cmi -Ordered.cmi: Specif.cmi Maps.cmi FSetInterface.cmi Datatypes.cmi Coqlib.cmi \ +Ordered.cmi: Specif.cmi OrderedType.cmi Maps.cmi Datatypes.cmi Coqlib.cmi \ BinPos.cmi -Parallelmove.cmi: Wf.cmi Values.cmi Specif.cmi Peano.cmi Locations.cmi \ - LTL.cmi Datatypes.cmi CList.cmi AST.cmi +OrderedType.cmi: Specif.cmi Datatypes.cmi +Parallelmove.cmi: Parmov.cmi Locations.cmi Datatypes.cmi CList.cmi AST.cmi +Parmov.cmi: Specif.cmi Peano.cmi Datatypes.cmi CList.cmi Peano.cmi: Datatypes.cmi PPCgen.cmi: Specif.cmi PPC.cmi Op.cmi Mach.cmi Locations.cmi Integers.cmi \ Datatypes.cmi Coqlib.cmi CList.cmi Bool.cmi BinPos.cmi BinInt.cmi AST.cmi @@ -130,8 +133,8 @@ RTLgen.cmi: Specif.cmi Registers.cmi RTL.cmi Op.cmi Maps.cmi Integers.cmi \ Datatypes.cmi Coqlib.cmi Cminor.cmi CList.cmi BinPos.cmi AST.cmi RTL.cmi: Values.cmi Registers.cmi Op.cmi Maps.cmi Integers.cmi Globalenvs.cmi \ Datatypes.cmi CList.cmi BinPos.cmi BinInt.cmi AST.cmi -RTLtyping.cmi: Specif.cmi Registers.cmi RTL.cmi Op.cmi Maps.cmi Datatypes.cmi \ - Coqlib.cmi CList.cmi BinPos.cmi AST.cmi +RTLtyping.cmi: Specif.cmi Registers.cmi RTL.cmi Op.cmi Maps.cmi Locations.cmi \ + Datatypes.cmi Coqlib.cmi Conventions.cmi CList.cmi AST.cmi Sets.cmi: Specif.cmi Maps.cmi Datatypes.cmi CList.cmi Specif.cmi: Datatypes.cmi Stacking.cmi: Specif.cmi Op.cmi Mach.cmi Locations.cmi Lineartyping.cmi \ @@ -148,6 +151,7 @@ Zbool.cmi: Zeven.cmi ZArith_dec.cmi Sumbool.cmi Specif.cmi Datatypes.cmi \ Zdiv.cmi: Zbool.cmi ZArith_dec.cmi Specif.cmi Datatypes.cmi BinPos.cmi \ BinInt.cmi Zeven.cmi: Specif.cmi Datatypes.cmi BinPos.cmi BinInt.cmi +Zmax.cmi: Datatypes.cmi BinInt.cmi Zmin.cmi: Datatypes.cmi BinInt.cmi Zmisc.cmi: Datatypes.cmi BinPos.cmi BinInt.cmi Zpower.cmi: Zmisc.cmi Datatypes.cmi BinPos.cmi BinInt.cmi @@ -159,14 +163,14 @@ Allocation.cmx: Specif.cmx Registers.cmx RTLtyping.cmx RTL.cmx \ Parallelmove.cmx Op.cmx Maps.cmx Locations.cmx LTL.cmx Kildall.cmx \ Datatypes.cmx Conventions.cmx Coloring.cmx CList.cmx BinPos.cmx AST.cmx \ Allocation.cmi -AST.cmo: Specif.cmi Datatypes.cmi Coqlib.cmi CList.cmi BinPos.cmi BinInt.cmi \ - AST.cmi -AST.cmx: Specif.cmx Datatypes.cmx Coqlib.cmx CList.cmx BinPos.cmx BinInt.cmx \ - AST.cmi +AST.cmo: Specif.cmi Integers.cmi Floats.cmi Datatypes.cmi Coqlib.cmi \ + CList.cmi BinPos.cmi BinInt.cmi AST.cmi +AST.cmx: Specif.cmx Integers.cmx Floats.cmx Datatypes.cmx Coqlib.cmx \ + CList.cmx BinPos.cmx BinInt.cmx AST.cmi BinInt.cmo: Datatypes.cmi BinPos.cmi BinNat.cmi BinInt.cmi BinInt.cmx: Datatypes.cmx BinPos.cmx BinNat.cmx BinInt.cmi -BinNat.cmo: Datatypes.cmi BinPos.cmi BinNat.cmi -BinNat.cmx: Datatypes.cmx BinPos.cmx BinNat.cmi +BinNat.cmo: Specif.cmi Datatypes.cmi BinPos.cmi BinNat.cmi +BinNat.cmx: Specif.cmx Datatypes.cmx BinPos.cmx BinNat.cmi BinPos.cmo: Peano.cmi Datatypes.cmi BinPos.cmi BinPos.cmx: Peano.cmx Datatypes.cmx BinPos.cmi Bool.cmo: Specif.cmi Datatypes.cmi Bool.cmi @@ -177,10 +181,10 @@ Cmconstr.cmo: Specif.cmi Op.cmi Integers.cmi Datatypes.cmi Compare_dec.cmi \ Cminor.cmi CList.cmi BinPos.cmi BinInt.cmi AST.cmi Cmconstr.cmi Cmconstr.cmx: Specif.cmx Op.cmx Integers.cmx Datatypes.cmx Compare_dec.cmx \ Cminor.cmx CList.cmx BinPos.cmx BinInt.cmx AST.cmx Cmconstr.cmi -Cminorgen.cmo: Zmin.cmi Specif.cmi Sets.cmi Op.cmi Mem.cmi Maps.cmi \ +Cminorgen.cmo: Zmax.cmi Specif.cmi Sets.cmi Op.cmi Mem.cmi Maps.cmi \ Integers.cmi Datatypes.cmi Csharpminor.cmi Coqlib.cmi Cminor.cmi \ Cmconstr.cmi CList.cmi BinPos.cmi BinInt.cmi AST.cmi Cminorgen.cmi -Cminorgen.cmx: Zmin.cmx Specif.cmx Sets.cmx Op.cmx Mem.cmx Maps.cmx \ +Cminorgen.cmx: Zmax.cmx Specif.cmx Sets.cmx Op.cmx Mem.cmx Maps.cmx \ Integers.cmx Datatypes.cmx Csharpminor.cmx Coqlib.cmx Cminor.cmx \ Cmconstr.cmx CList.cmx BinPos.cmx BinInt.cmx AST.cmx Cminorgen.cmi Cminor.cmo: Values.cmi Op.cmi Maps.cmi Integers.cmi Globalenvs.cmi \ @@ -201,10 +205,10 @@ Constprop.cmo: Specif.cmi Registers.cmi RTL.cmi Op.cmi Maps.cmi Lattice.cmi \ Constprop.cmx: Specif.cmx Registers.cmx RTL.cmx Op.cmx Maps.cmx Lattice.cmx \ Kildall.cmx Integers.cmx Floats.cmx Datatypes.cmx CList.cmx Bool.cmx \ BinPos.cmx BinInt.cmx AST.cmx Constprop.cmi -Conventions.cmo: Locations.cmi Datatypes.cmi CList.cmi BinPos.cmi BinInt.cmi \ - AST.cmi Conventions.cmi -Conventions.cmx: Locations.cmx Datatypes.cmx CList.cmx BinPos.cmx BinInt.cmx \ - AST.cmx Conventions.cmi +Conventions.cmo: Locations.cmi Datatypes.cmi Coqlib.cmi CList.cmi BinPos.cmi \ + BinInt.cmi AST.cmi Conventions.cmi +Conventions.cmx: Locations.cmx Datatypes.cmx Coqlib.cmx CList.cmx BinPos.cmx \ + BinInt.cmx AST.cmx Conventions.cmi Coqlib.cmo: Zdiv.cmi ZArith_dec.cmi Wf.cmi Specif.cmi Datatypes.cmi CList.cmi \ BinPos.cmi BinInt.cmi Coqlib.cmi Coqlib.cmx: Zdiv.cmx ZArith_dec.cmx Wf.cmx Specif.cmx Datatypes.cmx CList.cmx \ @@ -215,52 +219,54 @@ CSE.cmo: Specif.cmi Registers.cmi RTL.cmi Op.cmi Maps.cmi Kildall.cmi \ CSE.cmx: Specif.cmx Registers.cmx RTL.cmx Op.cmx Maps.cmx Kildall.cmx \ Integers.cmx Floats.cmx Datatypes.cmx Coqlib.cmx CList.cmx BinPos.cmx \ AST.cmx CSE.cmi -Csharpminor.cmo: Zmin.cmi Values.cmi Specif.cmi Mem.cmi Maps.cmi Integers.cmi \ +Csharpminor.cmo: Zmax.cmi Values.cmi Specif.cmi Mem.cmi Maps.cmi Integers.cmi \ Globalenvs.cmi Floats.cmi Datatypes.cmi CList.cmi BinPos.cmi BinInt.cmi \ AST.cmi Csharpminor.cmi -Csharpminor.cmx: Zmin.cmx Values.cmx Specif.cmx Mem.cmx Maps.cmx Integers.cmx \ +Csharpminor.cmx: Zmax.cmx Values.cmx Specif.cmx Mem.cmx Maps.cmx Integers.cmx \ Globalenvs.cmx Floats.cmx Datatypes.cmx CList.cmx BinPos.cmx BinInt.cmx \ AST.cmx Csharpminor.cmi Datatypes.cmo: Datatypes.cmi Datatypes.cmx: Datatypes.cmi Floats.cmo: Specif.cmi Integers.cmi ../caml/Floataux.cmo Datatypes.cmi \ - AST.cmi Floats.cmi + Floats.cmi Floats.cmx: Specif.cmx Integers.cmx ../caml/Floataux.cmx Datatypes.cmx \ - AST.cmx Floats.cmi -FSetAVL.cmo: ZArith_dec.cmi Wf.cmi Specif.cmi Peano.cmi FSetList.cmi \ - FSetInterface.cmi Datatypes.cmi CList.cmi BinPos.cmi BinInt.cmi \ - FSetAVL.cmi -FSetAVL.cmx: ZArith_dec.cmx Wf.cmx Specif.cmx Peano.cmx FSetList.cmx \ - FSetInterface.cmx Datatypes.cmx CList.cmx BinPos.cmx BinInt.cmx \ - FSetAVL.cmi + Floats.cmi +FSetAVL.cmo: Wf.cmi Specif.cmi Peano.cmi OrderedType.cmi Int.cmi FSetList.cmi \ + Datatypes.cmi CList.cmi BinPos.cmi BinInt.cmi FSetAVL.cmi +FSetAVL.cmx: Wf.cmx Specif.cmx Peano.cmx OrderedType.cmx Int.cmx FSetList.cmx \ + Datatypes.cmx CList.cmx BinPos.cmx BinInt.cmx FSetAVL.cmi FSetBridge.cmo: Specif.cmi FSetInterface.cmi Datatypes.cmi CList.cmi \ FSetBridge.cmi FSetBridge.cmx: Specif.cmx FSetInterface.cmx Datatypes.cmx CList.cmx \ FSetBridge.cmi FSetInterface.cmo: Specif.cmi Datatypes.cmi CList.cmi FSetInterface.cmi FSetInterface.cmx: Specif.cmx Datatypes.cmx CList.cmx FSetInterface.cmi -FSetList.cmo: Specif.cmi FSetInterface.cmi Datatypes.cmi CList.cmi \ - FSetList.cmi -FSetList.cmx: Specif.cmx FSetInterface.cmx Datatypes.cmx CList.cmx \ - FSetList.cmi +FSetList.cmo: Specif.cmi OrderedType.cmi Datatypes.cmi CList.cmi FSetList.cmi +FSetList.cmx: Specif.cmx OrderedType.cmx Datatypes.cmx CList.cmx FSetList.cmi Globalenvs.cmo: Values.cmi Mem.cmi Maps.cmi Integers.cmi Datatypes.cmi \ CList.cmi BinPos.cmi BinInt.cmi AST.cmi Globalenvs.cmi Globalenvs.cmx: Values.cmx Mem.cmx Maps.cmx Integers.cmx Datatypes.cmx \ CList.cmx BinPos.cmx BinInt.cmx AST.cmx Globalenvs.cmi Integers.cmo: Zpower.cmi Zdiv.cmi Specif.cmi Datatypes.cmi Coqlib.cmi \ - CList.cmi Bool.cmi BinPos.cmi BinInt.cmi AST.cmi Integers.cmi + CList.cmi Bool.cmi BinPos.cmi BinInt.cmi Integers.cmi Integers.cmx: Zpower.cmx Zdiv.cmx Specif.cmx Datatypes.cmx Coqlib.cmx \ - CList.cmx Bool.cmx BinPos.cmx BinInt.cmx AST.cmx Integers.cmi -InterfGraph.cmo: Specif.cmi Registers.cmi Ordered.cmi Locations.cmi \ - FSetInterface.cmi FSetBridge.cmi FSetAVL.cmi Datatypes.cmi Coqlib.cmi \ - CList.cmi BinPos.cmi BinInt.cmi InterfGraph.cmi -InterfGraph.cmx: Specif.cmx Registers.cmx Ordered.cmx Locations.cmx \ - FSetInterface.cmx FSetBridge.cmx FSetAVL.cmx Datatypes.cmx Coqlib.cmx \ - CList.cmx BinPos.cmx BinInt.cmx InterfGraph.cmi -Kildall.cmo: Wf.cmi Specif.cmi Maps.cmi Lattice.cmi Datatypes.cmi Coqlib.cmi \ - CList.cmi BinPos.cmi Kildall.cmi -Kildall.cmx: Wf.cmx Specif.cmx Maps.cmx Lattice.cmx Datatypes.cmx Coqlib.cmx \ - CList.cmx BinPos.cmx Kildall.cmi + CList.cmx Bool.cmx BinPos.cmx BinInt.cmx Integers.cmi +InterfGraph.cmo: Specif.cmi Registers.cmi OrderedType.cmi Ordered.cmi \ + Locations.cmi Int.cmi FSetAVL.cmi Datatypes.cmi Coqlib.cmi CList.cmi \ + BinPos.cmi BinInt.cmi InterfGraph.cmi +InterfGraph.cmx: Specif.cmx Registers.cmx OrderedType.cmx Ordered.cmx \ + Locations.cmx Int.cmx FSetAVL.cmx Datatypes.cmx Coqlib.cmx CList.cmx \ + BinPos.cmx BinInt.cmx InterfGraph.cmi +Int.cmo: Zmax.cmi ZArith_dec.cmi Specif.cmi BinPos.cmi BinInt.cmi Int.cmi +Int.cmx: Zmax.cmx ZArith_dec.cmx Specif.cmx BinPos.cmx BinInt.cmx Int.cmi +Iteration.cmo: Wf.cmi Specif.cmi Datatypes.cmi Coqlib.cmi BinPos.cmi \ + Iteration.cmi +Iteration.cmx: Wf.cmx Specif.cmx Datatypes.cmx Coqlib.cmx BinPos.cmx \ + Iteration.cmi +Kildall.cmo: Specif.cmi Maps.cmi Lattice.cmi Iteration.cmi Datatypes.cmi \ + Coqlib.cmi CList.cmi BinPos.cmi Kildall.cmi +Kildall.cmx: Specif.cmx Maps.cmx Lattice.cmx Iteration.cmx Datatypes.cmx \ + Coqlib.cmx CList.cmx BinPos.cmx Kildall.cmi Lattice.cmo: Specif.cmi Maps.cmi Datatypes.cmi BinPos.cmi Lattice.cmi Lattice.cmx: Specif.cmx Maps.cmx Datatypes.cmx BinPos.cmx Lattice.cmi Linearize.cmo: Specif.cmi Op.cmi Maps.cmi Linear.cmi Lattice.cmi LTL.cmi \ @@ -275,9 +281,9 @@ Linear.cmo: Values.cmi Specif.cmi Op.cmi Locations.cmi Integers.cmi \ Linear.cmx: Values.cmx Specif.cmx Op.cmx Locations.cmx Integers.cmx \ Globalenvs.cmx Datatypes.cmx Coqlib.cmx CList.cmx BinPos.cmx BinInt.cmx \ AST.cmx Linear.cmi -Lineartyping.cmo: Zmin.cmi Locations.cmi Linear.cmi Datatypes.cmi \ +Lineartyping.cmo: Zmax.cmi Locations.cmi Linear.cmi Datatypes.cmi \ Conventions.cmi CList.cmi BinPos.cmi BinInt.cmi AST.cmi Lineartyping.cmi -Lineartyping.cmx: Zmin.cmx Locations.cmx Linear.cmx Datatypes.cmx \ +Lineartyping.cmx: Zmax.cmx Locations.cmx Linear.cmx Datatypes.cmx \ Conventions.cmx CList.cmx BinPos.cmx BinInt.cmx AST.cmx Lineartyping.cmi Locations.cmo: Values.cmi Specif.cmi Datatypes.cmi Coqlib.cmi BinPos.cmi \ BinInt.cmi AST.cmi Locations.cmi @@ -291,10 +297,10 @@ LTL.cmo: Values.cmi Specif.cmi Op.cmi Maps.cmi Locations.cmi Integers.cmi \ LTL.cmx: Values.cmx Specif.cmx Op.cmx Maps.cmx Locations.cmx Integers.cmx \ Globalenvs.cmx Datatypes.cmx Conventions.cmx CList.cmx BinPos.cmx \ BinInt.cmx AST.cmx LTL.cmi -Mach.cmo: Zmin.cmi Zdiv.cmi Values.cmi Specif.cmi Op.cmi Mem.cmi Maps.cmi \ +Mach.cmo: Zmax.cmi Zdiv.cmi Values.cmi Specif.cmi Op.cmi Mem.cmi Maps.cmi \ Locations.cmi Integers.cmi Globalenvs.cmi Datatypes.cmi Coqlib.cmi \ CList.cmi BinPos.cmi BinInt.cmi AST.cmi Mach.cmi -Mach.cmx: Zmin.cmx Zdiv.cmx Values.cmx Specif.cmx Op.cmx Mem.cmx Maps.cmx \ +Mach.cmx: Zmax.cmx Zdiv.cmx Values.cmx Specif.cmx Op.cmx Mem.cmx Maps.cmx \ Locations.cmx Integers.cmx Globalenvs.cmx Datatypes.cmx Coqlib.cmx \ CList.cmx BinPos.cmx BinInt.cmx AST.cmx Mach.cmi Main.cmo: Tunneling.cmi Stacking.cmi RTLgen.cmi PPCgen.cmi PPC.cmi \ @@ -307,22 +313,26 @@ Maps.cmo: Specif.cmi Datatypes.cmi Coqlib.cmi CList.cmi BinPos.cmi BinNat.cmi \ BinInt.cmi Maps.cmi Maps.cmx: Specif.cmx Datatypes.cmx Coqlib.cmx CList.cmx BinPos.cmx BinNat.cmx \ BinInt.cmx Maps.cmi -Mem.cmo: Values.cmi Specif.cmi Integers.cmi Datatypes.cmi Coqlib.cmi \ +Mem.cmo: Zmax.cmi Values.cmi Specif.cmi Integers.cmi Datatypes.cmi Coqlib.cmi \ CList.cmi BinPos.cmi BinInt.cmi AST.cmi Mem.cmi -Mem.cmx: Values.cmx Specif.cmx Integers.cmx Datatypes.cmx Coqlib.cmx \ +Mem.cmx: Zmax.cmx Values.cmx Specif.cmx Integers.cmx Datatypes.cmx Coqlib.cmx \ CList.cmx BinPos.cmx BinInt.cmx AST.cmx Mem.cmi Op.cmo: Values.cmi Specif.cmi Integers.cmi Globalenvs.cmi Floats.cmi \ Datatypes.cmi CList.cmi Bool.cmi BinPos.cmi BinInt.cmi AST.cmi Op.cmi Op.cmx: Values.cmx Specif.cmx Integers.cmx Globalenvs.cmx Floats.cmx \ Datatypes.cmx CList.cmx Bool.cmx BinPos.cmx BinInt.cmx AST.cmx Op.cmi -Ordered.cmo: Specif.cmi Maps.cmi FSetInterface.cmi Datatypes.cmi Coqlib.cmi \ +Ordered.cmo: Specif.cmi OrderedType.cmi Maps.cmi Datatypes.cmi Coqlib.cmi \ BinPos.cmi Ordered.cmi -Ordered.cmx: Specif.cmx Maps.cmx FSetInterface.cmx Datatypes.cmx Coqlib.cmx \ +Ordered.cmx: Specif.cmx OrderedType.cmx Maps.cmx Datatypes.cmx Coqlib.cmx \ BinPos.cmx Ordered.cmi -Parallelmove.cmo: Wf.cmi Values.cmi Specif.cmi Peano.cmi Locations.cmi \ - LTL.cmi Datatypes.cmi CList.cmi AST.cmi Parallelmove.cmi -Parallelmove.cmx: Wf.cmx Values.cmx Specif.cmx Peano.cmx Locations.cmx \ - LTL.cmx Datatypes.cmx CList.cmx AST.cmx Parallelmove.cmi +OrderedType.cmo: Specif.cmi Datatypes.cmi OrderedType.cmi +OrderedType.cmx: Specif.cmx Datatypes.cmx OrderedType.cmi +Parallelmove.cmo: Parmov.cmi Locations.cmi Datatypes.cmi CList.cmi AST.cmi \ + Parallelmove.cmi +Parallelmove.cmx: Parmov.cmx Locations.cmx Datatypes.cmx CList.cmx AST.cmx \ + Parallelmove.cmi +Parmov.cmo: Specif.cmi Peano.cmi Datatypes.cmi CList.cmi Parmov.cmi +Parmov.cmx: Specif.cmx Peano.cmx Datatypes.cmx CList.cmx Parmov.cmi Peano.cmo: Datatypes.cmi Peano.cmi Peano.cmx: Datatypes.cmx Peano.cmi PPCgen.cmo: Specif.cmi PPC.cmi Op.cmi Mach.cmi Locations.cmi Integers.cmi \ @@ -351,12 +361,12 @@ RTL.cmo: Values.cmi Registers.cmi Op.cmi Maps.cmi Integers.cmi Globalenvs.cmi \ Datatypes.cmi CList.cmi BinPos.cmi BinInt.cmi AST.cmi RTL.cmi RTL.cmx: Values.cmx Registers.cmx Op.cmx Maps.cmx Integers.cmx Globalenvs.cmx \ Datatypes.cmx CList.cmx BinPos.cmx BinInt.cmx AST.cmx RTL.cmi -RTLtyping.cmo: union_find.cmi Specif.cmi Registers.cmi RTL.cmi Op.cmi \ - Maps.cmi Datatypes.cmi Coqlib.cmi CList.cmi BinPos.cmi AST.cmi \ - RTLtyping.cmi -RTLtyping.cmx: union_find.cmx Specif.cmx Registers.cmx RTL.cmx Op.cmx \ - Maps.cmx Datatypes.cmx Coqlib.cmx CList.cmx BinPos.cmx AST.cmx \ - RTLtyping.cmi +RTLtyping.cmo: Specif.cmi Registers.cmi ../caml/RTLtypingaux.cmo RTL.cmi \ + Op.cmi Maps.cmi Locations.cmi Datatypes.cmi Coqlib.cmi Conventions.cmi \ + CList.cmi AST.cmi RTLtyping.cmi +RTLtyping.cmx: Specif.cmx Registers.cmx ../caml/RTLtypingaux.cmx RTL.cmx \ + Op.cmx Maps.cmx Locations.cmx Datatypes.cmx Coqlib.cmx Conventions.cmx \ + CList.cmx AST.cmx RTLtyping.cmi Sets.cmo: Specif.cmi Maps.cmi Datatypes.cmi CList.cmi Sets.cmi Sets.cmx: Specif.cmx Maps.cmx Datatypes.cmx CList.cmx Sets.cmi Specif.cmo: Datatypes.cmi Specif.cmi @@ -393,6 +403,8 @@ Zdiv.cmx: Zbool.cmx ZArith_dec.cmx Specif.cmx Datatypes.cmx BinPos.cmx \ BinInt.cmx Zdiv.cmi Zeven.cmo: Specif.cmi Datatypes.cmi BinPos.cmi BinInt.cmi Zeven.cmi Zeven.cmx: Specif.cmx Datatypes.cmx BinPos.cmx BinInt.cmx Zeven.cmi +Zmax.cmo: Datatypes.cmi BinInt.cmi Zmax.cmi +Zmax.cmx: Datatypes.cmx BinInt.cmx Zmax.cmi Zmin.cmo: Datatypes.cmi BinInt.cmi Zmin.cmi Zmin.cmx: Datatypes.cmx BinInt.cmx Zmin.cmi Zmisc.cmo: Datatypes.cmi BinPos.cmi BinInt.cmi Zmisc.cmi diff --git a/extraction/Makefile b/extraction/Makefile index 687c5c5..6ae8e35 100644 --- a/extraction/Makefile +++ b/extraction/Makefile @@ -1,19 +1,20 @@ FILES=\ Datatypes.ml Logic.ml Wf.ml Peano.ml Specif.ml Compare_dec.ml \ Bool.ml CList.ml Sumbool.ml BinPos.ml BinNat.ml BinInt.ml \ - ZArith_dec.ml Zeven.ml Zmin.ml Zmisc.ml Zbool.ml Zpower.ml Zdiv.ml \ - FSetInterface.ml FSetBridge.ml FSetList.ml FSetAVL.ml \ - Coqlib.ml Maps.ml Sets.ml union_find.ml AST.ml Integers.ml \ - ../caml/Camlcoq.ml ../caml/Floataux.ml Floats.ml Values.ml \ + ZArith_dec.ml Zeven.ml Zmax.ml Zmisc.ml Zbool.ml Zpower.ml Zdiv.ml \ + Int.ml OrderedType.ml FSetList.ml FSetAVL.ml \ + Coqlib.ml Maps.ml Sets.ml AST.ml Iteration.ml Integers.ml \ + ../caml/Camlcoq.ml ../caml/Floataux.ml Floats.ml Parmov.ml Values.ml \ Mem.ml Globalenvs.ml \ Op.ml Cminor.ml Cmconstr.ml \ Csharpminor.ml Cminorgen.ml \ Registers.ml RTL.ml \ ../caml/RTLgenaux.ml RTLgen.ml \ - RTLtyping.ml \ + Locations.ml Conventions.ml \ + ../caml/RTLtypingaux.ml RTLtyping.ml \ Lattice.ml Kildall.ml \ Constprop.ml CSE.ml \ - Locations.ml Conventions.ml LTL.ml \ + LTL.ml \ Ordered.ml InterfGraph.ml ../caml/Coloringaux.ml Coloring.ml \ Parallelmove.ml Allocation.ml \ Tunneling.ml Linear.ml Lineartyping.ml Linearize.ml \ diff --git a/extraction/extraction.v b/extraction/extraction.v index 1717882..47c6f36 100644 --- a/extraction/extraction.v +++ b/extraction/extraction.v @@ -1,9 +1,8 @@ +Require Iteration. Require Floats. -Require Kildall. Require RTLgen. Require Coloring. Require Allocation. -Require Cmconstr. Require Main. (* Standard lib *) @@ -28,9 +27,22 @@ Extract Constant Floats.Float.div => "( /. )". Extract Constant Floats.Float.cmp => "Floataux.cmp". Extract Constant Floats.Float.eq_dec => "fun (x: float) (y: float) -> x = y". +(* Iteration *) +Extract Constant Iteration.dependent_description' => + "fun x -> assert false". + +Extract Constant Iteration.GenIter.iterate => + "let rec iter f a = + match f a with Coq_inl b -> Some b | Coq_inr a' -> iter f a' + in iter". + + (* RTLgen *) Extract Constant RTLgen.more_likely => "RTLgenaux.more_likely". +(* RTLtyping *) +Extract Constant RTLtyping.infer_type_environment => "RTLtypingaux.infer_type_environment". + (* Coloring *) Extract Constant Coloring.graph_coloring => "Coloringaux.graph_coloring". @@ -49,5 +61,3 @@ Extract Constant PPC.preg_eq => "fun (x: preg) (y: preg) -> x = y". (* Go! *) Recursive Extraction Library Main. -(*Extraction Library Compare_dec. - Extraction Library Cmconstr.*) diff --git a/lib/Coqlib.v b/lib/Coqlib.v index 039dd03..3bcc8a6 100644 --- a/lib/Coqlib.v +++ b/lib/Coqlib.v @@ -33,20 +33,7 @@ Ltac destructEq name := Ltac decEq := match goal with - | [ |- (_, _) = (_, _) ] => - apply injective_projections; unfold fst,snd; try reflexivity - | [ |- (@Some ?T _ = @Some ?T _) ] => - apply (f_equal (@Some T)); try reflexivity - | [ |- (?X _ _ _ _ _ = ?X _ _ _ _ _) ] => - apply (f_equal5 X); try reflexivity - | [ |- (?X _ _ _ _ = ?X _ _ _ _) ] => - apply (f_equal4 X); try reflexivity - | [ |- (?X _ _ _ = ?X _ _ _) ] => - apply (f_equal3 X); try reflexivity - | [ |- (?X _ _ = ?X _ _) ] => - apply (f_equal2 X); try reflexivity - | [ |- (?X _ = ?X _) ] => - apply (f_equal X); try reflexivity + | [ |- _ = _ ] => f_equal | [ |- (?X ?A <> ?X ?B) ] => cut (A <> B); [intro; congruence | try discriminate] end. @@ -57,6 +44,46 @@ Ltac byContradiction := Ltac omegaContradiction := cut False; [contradiction|omega]. +Lemma modusponens: forall (P Q: Prop), P -> (P -> Q) -> Q. +Proof. auto. Qed. + +Ltac exploit x := + refine (modusponens _ _ (x _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _) + || refine (modusponens _ _ (x _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _) + || refine (modusponens _ _ (x _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _) + || refine (modusponens _ _ (x _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _) + || refine (modusponens _ _ (x _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _) + || refine (modusponens _ _ (x _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _) + || refine (modusponens _ _ (x _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _) + || refine (modusponens _ _ (x _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _) + || refine (modusponens _ _ (x _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _) + || refine (modusponens _ _ (x _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _) + || refine (modusponens _ _ (x _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _) + || refine (modusponens _ _ (x _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _) + || refine (modusponens _ _ (x _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _) + || refine (modusponens _ _ (x _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _) + || refine (modusponens _ _ (x _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _) + || refine (modusponens _ _ (x _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _) + || refine (modusponens _ _ (x _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _) + || refine (modusponens _ _ (x _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _) + || refine (modusponens _ _ (x _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _) + || refine (modusponens _ _ (x _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _) + || refine (modusponens _ _ (x _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _) + || refine (modusponens _ _ (x _ _ _ _ _ _ _ _ _ _ _ _ _ _) _) + || refine (modusponens _ _ (x _ _ _ _ _ _ _ _ _ _ _ _ _) _) + || refine (modusponens _ _ (x _ _ _ _ _ _ _ _ _ _ _ _) _) + || refine (modusponens _ _ (x _ _ _ _ _ _ _ _ _ _ _) _) + || refine (modusponens _ _ (x _ _ _ _ _ _ _ _ _ _) _) + || refine (modusponens _ _ (x _ _ _ _ _ _ _ _ _) _) + || refine (modusponens _ _ (x _ _ _ _ _ _ _ _) _) + || refine (modusponens _ _ (x _ _ _ _ _ _ _) _) + || refine (modusponens _ _ (x _ _ _ _ _ _) _) + || refine (modusponens _ _ (x _ _ _ _ _) _) + || refine (modusponens _ _ (x _ _ _ _) _) + || refine (modusponens _ _ (x _ _ _) _) + || refine (modusponens _ _ (x _ _) _) + || refine (modusponens _ _ (x _) _). + (** * Definitions and theorems over the type [positive] *) Definition peq (x y: positive): {x = y} + {x <> y}. @@ -510,6 +537,13 @@ Proof. induction l; simpl. reflexivity. rewrite IHl; reflexivity. Qed. +Lemma list_map_identity: + forall (A: Set) (l: list A), + List.map (fun (x:A) => x) l = l. +Proof. + induction l; simpl; congruence. +Qed. + Lemma list_map_nth: forall (A B: Set) (f: A -> B) (l: list A) (n: nat), nth_error (List.map f l) n = option_map f (nth_error l n). @@ -546,6 +580,27 @@ Proof. auto. rewrite IHl1. auto. Qed. +(** Properties of list membership. *) + +Lemma in_cns: + forall (A: Set) (x y: A) (l: list A), In x (y :: l) <-> y = x \/ In x l. +Proof. + intros. simpl. tauto. +Qed. + +Lemma in_app: + forall (A: Set) (x: A) (l1 l2: list A), In x (l1 ++ l2) <-> In x l1 \/ In x l2. +Proof. + intros. split; intro. apply in_app_or. auto. apply in_or_app. auto. +Qed. + +Lemma list_in_insert: + forall (A: Set) (x: A) (l1 l2: list A) (y: A), + In x (l1 ++ l2) -> In x (l1 ++ y :: l2). +Proof. + intros. apply in_or_app; simpl. elim (in_app_or _ _ _ H); intro; auto. +Qed. + (** [list_disjoint l1 l2] holds iff [l1] and [l2] have no elements in common. *) @@ -644,35 +699,42 @@ Proof. red; intro; elim H3. apply in_or_app. tauto. Qed. +Lemma list_norepet_app: + forall (A: Set) (l1 l2: list A), + list_norepet (l1 ++ l2) <-> + list_norepet l1 /\ list_norepet l2 /\ list_disjoint l1 l2. +Proof. + induction l1; simpl; intros; split; intros. + intuition. constructor. red;simpl;auto. + tauto. + inversion H; subst. rewrite IHl1 in H3. rewrite in_app in H2. + intuition. + constructor; auto. red; intros. elim H2; intro. congruence. auto. + destruct H as [B [C D]]. inversion B; subst. + constructor. rewrite in_app. intuition. elim (D a a); auto. apply in_eq. + rewrite IHl1. intuition. red; intros. apply D; auto. apply in_cons; auto. +Qed. + Lemma list_norepet_append: forall (A: Set) (l1 l2: list A), list_norepet l1 -> list_norepet l2 -> list_disjoint l1 l2 -> list_norepet (l1 ++ l2). Proof. - induction l1; simpl; intros. - auto. - inversion H. subst hd tl. - constructor. red; intro. apply (H1 a a). auto with coqlib. - elim (in_app_or _ _ _ H2); tauto. auto. - apply IHl1. auto. auto. - red; intros; apply H1; auto with coqlib. + generalize list_norepet_app; firstorder. Qed. Lemma list_norepet_append_right: forall (A: Set) (l1 l2: list A), list_norepet (l1 ++ l2) -> list_norepet l2. Proof. - induction l1; intros. - assumption. - simpl in H. inversion H. eauto. + generalize list_norepet_app; firstorder. Qed. Lemma list_norepet_append_left: forall (A: Set) (l1 l2: list A), list_norepet (l1 ++ l2) -> list_norepet l1. Proof. - intros. apply list_norepet_append_right with l2. - apply list_norepet_append_commut. auto. + generalize list_norepet_app; firstorder. Qed. (** [list_forall2 P [x1 ... xN] [y1 ... yM] holds iff [N = M] and @@ -707,3 +769,37 @@ Proof. constructor. auto with coqlib. apply IHlist_forall2; auto. intros. auto with coqlib. Qed. + +(** Dropping the first or first two elements of a list. *) + +Definition list_drop1 (A: Set) (x: list A) := + match x with nil => nil | hd :: tl => tl end. +Definition list_drop2 (A: Set) (x: list A) := + match x with nil => nil | hd :: nil => nil | hd1 :: hd2 :: tl => tl end. + +Lemma list_drop1_incl: + forall (A: Set) (x: A) (l: list A), In x (list_drop1 l) -> In x l. +Proof. + intros. destruct l. elim H. simpl in H. auto with coqlib. +Qed. + +Lemma list_drop2_incl: + forall (A: Set) (x: A) (l: list A), In x (list_drop2 l) -> In x l. +Proof. + intros. destruct l. elim H. destruct l. elim H. + simpl in H. auto with coqlib. +Qed. + +Lemma list_drop1_norepet: + forall (A: Set) (l: list A), list_norepet l -> list_norepet (list_drop1 l). +Proof. + intros. destruct l; simpl. constructor. inversion H. auto. +Qed. + +Lemma list_drop2_norepet: + forall (A: Set) (l: list A), list_norepet l -> list_norepet (list_drop2 l). +Proof. + intros. destruct l; simpl. constructor. + destruct l; simpl. constructor. inversion H. inversion H3. auto. +Qed. + diff --git a/lib/Floats.v b/lib/Floats.v index b95789e..67b0e53 100644 --- a/lib/Floats.v +++ b/lib/Floats.v @@ -6,7 +6,6 @@ and the associated operations. *) Require Import Bool. -Require Import AST. Require Import Integers. Parameter float: Set. diff --git a/lib/Integers.v b/lib/Integers.v index 6b605bd..5a18dc0 100644 --- a/lib/Integers.v +++ b/lib/Integers.v @@ -1,29 +1,48 @@ (** Formalizations of integers modulo $2^32$ #2<sup>32</sup>#. *) Require Import Coqlib. -Require Import AST. Definition wordsize : nat := 32%nat. Definition modulus : Z := two_power_nat wordsize. Definition half_modulus : Z := modulus / 2. +(** * Comparisons *) + +Inductive comparison : Set := + | Ceq : comparison (**r same *) + | Cne : comparison (**r different *) + | Clt : comparison (**r less than *) + | Cle : comparison (**r less than or equal *) + | Cgt : comparison (**r greater than *) + | Cge : comparison. (**r greater than or equal *) + +Definition negate_comparison (c: comparison): comparison := + match c with + | Ceq => Cne + | Cne => Ceq + | Clt => Cge + | Cle => Cgt + | Cgt => Cle + | Cge => Clt + end. + +Definition swap_comparison (c: comparison): comparison := + match c with + | Ceq => Ceq + | Cne => Cne + | Clt => Cgt + | Cle => Cge + | Cgt => Clt + | Cge => Cle + end. + (** * Representation of machine integers *) (** A machine integer (type [int]) is represented as a Coq arbitrary-precision integer (type [Z]) plus a proof that it is in the range 0 (included) to [modulus] (excluded. *) -Definition in_range (x: Z) := - match x ?= 0 with - | Lt => False - | _ => - match x ?= modulus with - | Lt => True - | _ => False - end - end. - -Record int: Set := mkint { intval: Z; intrange: in_range intval }. +Record int: Set := mkint { intval: Z; intrange: 0 <= intval < modulus }. Module Int. @@ -43,14 +62,10 @@ Definition signed (n: int) : Z := else unsigned n - modulus. Lemma mod_in_range: - forall x, in_range (Zmod x modulus). + forall x, 0 <= Zmod x modulus < modulus. Proof. intro. - generalize (Z_mod_lt x modulus (two_power_nat_pos wordsize)). - intros [A B]. - assert (C: x mod modulus >= 0). omega. - red. red in C. red in B. - rewrite B. destruct (x mod modulus ?= 0); auto. + exact (Z_mod_lt x modulus (two_power_nat_pos wordsize)). Qed. (** Conversely, [repr] takes a Coq integer and returns the corresponding @@ -550,26 +565,10 @@ Proof. apply eqmod_refl. red; exists (-1); ring. Qed. -Lemma in_range_range: - forall z, in_range z -> 0 <= z < modulus. -Proof. - intros. - assert (z >= 0 /\ z < modulus). - generalize H. unfold in_range, Zge, Zlt. - destruct (z ?= 0). - destruct (z ?= modulus); try contradiction. - intuition congruence. - contradiction. - destruct (z ?= modulus); try contradiction. - intuition congruence. - omega. -Qed. - Theorem unsigned_range: forall i, 0 <= unsigned i < modulus. Proof. - destruct i; simpl. - apply in_range_range. auto. + destruct i; simpl. auto. Qed. Hint Resolve unsigned_range: ints. @@ -597,7 +596,7 @@ Theorem repr_unsigned: forall i, repr (unsigned i) = i. Proof. destruct i; simpl. unfold repr. apply mkint_eq. - apply Zmod_small. apply in_range_range; auto. + apply Zmod_small. auto. Qed. Hint Resolve repr_unsigned: ints. diff --git a/lib/Iteration.v b/lib/Iteration.v new file mode 100644 index 0000000..85c5ded --- /dev/null +++ b/lib/Iteration.v @@ -0,0 +1,293 @@ +(* Bounded and unbounded iterators *) + +Require Import Coqlib. +Require Import Classical. +Require Import Max. + +Module Type ITER. +Variable iterate + : forall A B : Set, (A -> B + A) -> A -> option B. +Hypothesis iterate_prop + : forall (A B : Set) (step : A -> B + A) (P : A -> Prop) (Q : B -> Prop), + (forall a : A, P a -> + match step a with inl b => Q b | inr a' => P a' end) -> + forall (a : A) (b : B), iterate A B step a = Some b -> P a -> Q b. +End ITER. + +Axiom + dependent_description' : + forall (A:Type) (B:A -> Type) (R:forall x:A, B x -> Prop), + (forall x:A, + exists y : B x, R x y /\ (forall y':B x, R x y' -> y = y')) -> + sigT (fun f : forall x:A, B x => (forall x:A, R x (f x))). + +(* A constructive implementation using bounded iteration. *) + +Module PrimIter: ITER. + +Section ITERATION. + +Variables A B: Set. +Variable step: A -> B + A. + +(** The [step] parameter represents one step of the iteration. From a + current iteration state [a: A], it either returns a value of type [B], + meaning that iteration is over and that this [B] value is the final + result of the iteration, or a value [a' : A] which is the next state + of the iteration. + + The naive way to define the iteration is: +<< +Fixpoint iterate (a: A) : B := + match step a with + | inl b => b + | inr a' => iterate a' + end. +>> + However, this is a general recursion, not guaranteed to terminate, + and therefore not expressible in Coq. The standard way to work around + this difficulty is to use Noetherian recursion (Coq module [Wf]). + This requires that we equip the type [A] with a well-founded ordering [<] + (no infinite ascending chains) and we demand that [step] satisfies + [step a = inr a' -> a < a']. For the types [A] that are of interest to us + in this development, it is however very painful to define adequate + well-founded orderings, even though we know our iterations always + terminate. + + Instead, we choose to bound the number of iterations by an arbitrary + constant. [iterate] then becomes a function that can fail, + of type [A -> option B]. The [None] result denotes failure to reach + a result in the number of iterations prescribed, or, in other terms, + failure to find a solution to the dataflow problem. The compiler + passes that exploit dataflow analysis (the [Constprop], [CSE] and + [Allocation] passes) will, in this case, either fail ([Allocation]) + or turn off the optimization pass ([Constprop] and [CSE]). + + Since we know (informally) that our computations terminate, we can + take a very large constant as the maximal number of iterations. + Failure will therefore never happen in practice, but of + course our proofs also cover the failure case and show that + nothing bad happens in this hypothetical case either. *) + +Definition num_iterations := 1000000000000%positive. + +(** The simple definition of bounded iteration is: +<< +Fixpoint iterate (niter: nat) (a: A) {struct niter} : option B := + match niter with + | O => None + | S niter' => + match step a with + | inl b => b + | inr a' => iterate niter' a' + end + end. +>> + This function is structural recursive over the parameter [niter] + (number of iterations), represented here as a Peano integer (type [nat]). + However, we want to use very large values of [niter]. As Peano integers, + these values would be much too large to fit in memory. Therefore, + we must express iteration counts as a binary integer (type [positive]). + However, Peano induction over type [positive] is not structural recursion, + so we cannot define [iterate] as a Coq fixpoint and must use + Noetherian recursion instead. *) + +Definition iter_step (x: positive) + (next: forall y, Plt y x -> A -> option B) + (s: A) : option B := + match peq x xH with + | left EQ => None + | right NOTEQ => + match step s with + | inl res => Some res + | inr s' => next (Ppred x) (Ppred_Plt x NOTEQ) s' + end + end. + +Definition iter: positive -> A -> option B := + Fix Plt_wf (fun _ => A -> option B) iter_step. + +(** We then prove the expected unrolling equations for [iter]. *) + +Remark unroll_iter: + forall x, iter x = iter_step x (fun y _ => iter y). +Proof. + unfold iter; apply (Fix_eq Plt_wf (fun _ => A -> option B) iter_step). + intros. unfold iter_step. apply extensionality. intro s. + case (peq x xH); intro. auto. + rewrite H. auto. +Qed. + +(** The [iterate] function is defined as [iter] up to + [num_iterations] through the loop. *) + +Definition iterate := iter num_iterations. + +(** We now prove the invariance property [iterate_prop]. *) + +Variable P: A -> Prop. +Variable Q: B -> Prop. + +Hypothesis step_prop: + forall a : A, P a -> + match step a with inl b => Q b | inr a' => P a' end. + +Lemma iter_prop: + forall n a b, P a -> iter n a = Some b -> Q b. +Proof. + apply (well_founded_ind Plt_wf + (fun p => forall a b, P a -> iter p a = Some b -> Q b)). + intros until b. intro. rewrite unroll_iter. + unfold iter_step. case (peq x 1); intro. congruence. + generalize (step_prop a H0). + case (step a); intros. congruence. + apply H with (Ppred x) a0. apply Ppred_Plt; auto. auto. auto. +Qed. + +Lemma iterate_prop: + forall a b, iterate a = Some b -> P a -> Q b. +Proof. + intros. apply iter_prop with num_iterations a; assumption. +Qed. + +End ITERATION. + +End PrimIter. + +(* An implementation using classical logic and unbounded iteration, + in the style of Yves Bertot's paper, "Extending the Calculus + of Constructions with Tarski's fix-point theorem". *) + +Module GenIter: ITER. + +Section ITERATION. + +Variables A B: Set. +Variable step: A -> B + A. + +Definition B_le (x y: option B) : Prop := x = None \/ y = x. +Definition F_le (x y: A -> option B) : Prop := forall a, B_le (x a) (y a). + +Definition F_iter (next: A -> option B) (a: A) : option B := + match step a with + | inl b => Some b + | inr a' => next a' + end. + +Lemma F_iter_monot: + forall f g, F_le f g -> F_le (F_iter f) (F_iter g). +Proof. + intros; red; intros. unfold F_iter. + destruct (step a) as [b | a']. red; auto. apply H. +Qed. + +Fixpoint iter (n: nat) : A -> option B := + match n with + | O => (fun a => None) + | S m => F_iter (iter m) + end. + +Lemma iter_monot: + forall p q, (p <= q)%nat -> F_le (iter p) (iter q). +Proof. + induction p; intros. + simpl. red; intros; red; auto. + destruct q. elimtype False; omega. + simpl. apply F_iter_monot. apply IHp. omega. +Qed. + +Lemma iter_either: + forall a, + (exists n, exists b, iter n a = Some b) \/ + (forall n, iter n a = None). +Proof. + intro a. elim (classic (forall n, iter n a = None)); intro. + right; assumption. + left. generalize (not_all_ex_not nat (fun n => iter n a = None) H). + intros [n D]. exists n. generalize D. + case (iter n a); intros. exists b; auto. congruence. +Qed. + +Definition converges_to (a: A) (b: option B) : Prop := + exists n, forall m, (n <= m)%nat -> iter m a = b. + +Lemma converges_to_Some: + forall a n b, iter n a = Some b -> converges_to a (Some b). +Proof. + intros. exists n. intros. + assert (B_le (iter n a) (iter m a)). apply iter_monot. auto. + elim H1; intro; congruence. +Qed. + +Lemma converges_to_exists: + forall a, exists b, converges_to a b. +Proof. + intros. elim (iter_either a). + intros [n [b EQ]]. exists (Some b). apply converges_to_Some with n. assumption. + intro. exists (@None B). exists O. intros. auto. +Qed. + +Lemma converges_to_unique: + forall a b, converges_to a b -> forall b', converges_to a b' -> b = b'. +Proof. + intros a b [n C] b' [n' C']. + rewrite <- (C (max n n')). rewrite <- (C' (max n n')). auto. + apply le_max_r. apply le_max_l. +Qed. + +Lemma converges_to_exists_uniquely: + forall a, exists b, converges_to a b /\ forall b', converges_to a b' -> b = b'. +Proof. + intro. destruct (converges_to_exists a) as [b CT]. + exists b. split. assumption. exact (converges_to_unique _ _ CT). +Qed. + +Definition exists_iterate := + dependent_description' A (fun _ => option B) + converges_to converges_to_exists_uniquely. + +Definition iterate : A -> option B := + match exists_iterate with existT f P => f end. + +Lemma converges_to_iterate: + forall a b, converges_to a b -> iterate a = b. +Proof. + intros. unfold iterate. destruct exists_iterate as [f P]. + apply converges_to_unique with a. apply P. auto. +Qed. + +Lemma iterate_converges_to: + forall a, converges_to a (iterate a). +Proof. + intros. unfold iterate. destruct exists_iterate as [f P]. apply P. +Qed. + +(** Invariance property. *) + +Variable P: A -> Prop. +Variable Q: B -> Prop. + +Hypothesis step_prop: + forall a : A, P a -> + match step a with inl b => Q b | inr a' => P a' end. + +Lemma iter_prop: + forall n a b, P a -> iter n a = Some b -> Q b. +Proof. + induction n; intros until b; intro H; simpl. + congruence. + unfold F_iter. generalize (step_prop a H). + case (step a); intros. congruence. + apply IHn with a0; auto. +Qed. + +Lemma iterate_prop: + forall a b, iterate a = Some b -> P a -> Q b. +Proof. + intros. destruct (iterate_converges_to a) as [n IT]. + rewrite H in IT. apply iter_prop with n a. auto. apply IT. auto. +Qed. + +End ITERATION. + +End GenIter. diff --git a/lib/Ordered.v b/lib/Ordered.v index 1747bbb..ad47314 100644 --- a/lib/Ordered.v +++ b/lib/Ordered.v @@ -1,7 +1,7 @@ (** Constructions of ordered types, for use with the [FSet] functors for finite sets. *) -Require Import FSet. +Require Import FSets. Require Import Coqlib. Require Import Maps. @@ -26,10 +26,10 @@ Proof Plt_ne. Lemma compare : forall x y : t, Compare lt eq x y. Proof. intros. case (plt x y); intro. - apply Lt. auto. + apply LT. auto. case (peq x y); intro. - apply Eq. auto. - apply Gt. red; unfold Plt in *. + apply EQ. auto. + apply GT. red; unfold Plt in *. assert (Zpos x <> Zpos y). congruence. omega. Qed. @@ -64,9 +64,9 @@ Qed. Lemma compare : forall x y : t, Compare lt eq x y. Proof. intros. case (OrderedPositive.compare (A.index x) (A.index y)); intro. - apply Lt. exact l. - apply Eq. red; red in e. apply A.index_inj; auto. - apply Gt. exact l. + apply LT. exact l. + apply EQ. red; red in e. apply A.index_inj; auto. + apply GT. exact l. Qed. End OrderedIndexed. @@ -144,12 +144,12 @@ Lemma compare : forall x y : t, Compare lt eq x y. Proof. intros. case (A.compare (fst x) (fst y)); intro. - apply Lt. red. left. auto. + apply LT. red. left. auto. case (B.compare (snd x) (snd y)); intro. - apply Lt. red. right. tauto. - apply Eq. red. tauto. - apply Gt. red. right. split. apply A.eq_sym. auto. auto. - apply Gt. red. left. auto. + apply LT. red. right. tauto. + apply EQ. red. tauto. + apply GT. red. right. split. apply A.eq_sym. auto. auto. + apply GT. red. left. auto. Qed. End OrderedPair. diff --git a/lib/Parmov.v b/lib/Parmov.v new file mode 100644 index 0000000..cd24dd9 --- /dev/null +++ b/lib/Parmov.v @@ -0,0 +1,1206 @@ +(** Translation of parallel moves into sequences of individual moves *) + +(** The ``parallel move'' problem, also known as ``parallel assignment'', + is the following. We are given a list of (source, destination) pairs + of locations. The goal is to find a sequence of elementary + moves ([loc <- loc] assignments) such that, at the end of the sequence, + location [dst] contains the value of location [src] at the beginning of + the sequence, for each ([src], [dst]) pairs in the given problem. + Moreover, other locations should keep their values, except one register + of each type, which can be used as temporaries in the generated sequences. + + The parallel move problem is trivial if the sources and destinations do + not overlap. For instance, +<< + (R1, R2) <- (R3, R4) becomes R1 <- R3; R2 <- R4 +>> + However, arbitrary overlap is allowed between sources and destinations. + This requires some care in ordering the individual moves, as in +<< + (R1, R2) <- (R3, R1) becomes R2 <- R1; R1 <- R3 +>> + Worse, cycles (permutations) can require the use of temporaries, as in +<< + (R1, R2, R3) <- (R2, R3, R1) becomes T <- R1; R1 <- R2; R2 <- R3; R3 <- T; +>> + An amazing fact is that for any parallel move problem, at most one temporary + (or in our case one integer temporary and one float temporary) is needed. + + The development in this section was contributed by Laurence Rideau and + Bernard Serpette. It is described in their paper + ``Coq à la conquête des moulins'', JFLA 2005, + #<A HREF="http://www-sop.inria.fr/lemme/Laurence.Rideau/RideauSerpetteJFLA05.ps"># + http://www-sop.inria.fr/lemme/Laurence.Rideau/RideauSerpetteJFLA05.ps + #</A># +*) + +Require Import Coqlib. +Require Recdef. + +Section PARMOV. + +Variable reg: Set. +Variable temp: reg -> reg. + +Definition moves := (list (reg * reg))%type. (* src -> dst *) + +Definition srcs (m: moves) := List.map (@fst reg reg) m. +Definition dests (m: moves) := List.map (@snd reg reg) m. + +(* Semantics of moves *) + +Variable val: Set. +Definition env := reg -> val. +Variable reg_eq : forall (r1 r2: reg), {r1=r2} + {r1<>r2}. + +Lemma env_ext: + forall (e1 e2: env), + (forall r, e1 r = e2 r) -> e1 = e2. +Proof (extensionality reg val). + +Definition update (r: reg) (v: val) (e: env) : env := + fun r' => if reg_eq r' r then v else e r'. + +Lemma update_s: + forall r v e, update r v e r = v. +Proof. + unfold update; intros. destruct (reg_eq r r). auto. congruence. +Qed. + +Lemma update_o: + forall r v e r', r' <> r -> update r v e r' = e r'. +Proof. + unfold update; intros. destruct (reg_eq r' r). congruence. auto. +Qed. + +Lemma update_ident: + forall r e, update r (e r) e = e. +Proof. + intros. apply env_ext; intro. unfold update. destruct (reg_eq r0 r); congruence. +Qed. + +Lemma update_commut: + forall r1 v1 r2 v2 e, + r1 <> r2 -> + update r1 v1 (update r2 v2 e) = update r2 v2 (update r1 v1 e). +Proof. + intros. apply env_ext; intro; unfold update. + destruct (reg_eq r r1); destruct (reg_eq r r2); auto. + congruence. +Qed. + +Lemma update_twice: + forall r v e, + update r v (update r v e) = update r v e. +Proof. + intros. apply env_ext; intro; unfold update. + destruct (reg_eq r0 r); auto. +Qed. + +Fixpoint exec_par (m: moves) (e: env) {struct m}: env := + match m with + | nil => e + | (s, d) :: m' => update d (e s) (exec_par m' e) + end. + +Fixpoint exec_seq (m: moves) (e: env) {struct m}: env := + match m with + | nil => e + | (s, d) :: m' => exec_seq m' (update d (e s) e) + end. + +Fixpoint exec_seq_rev (m: moves) (e: env) {struct m}: env := + match m with + | nil => e + | (s, d) :: m' => + let e' := exec_seq_rev m' e in + update d (e' s) e' + end. + +(* Specification of the parallel move *) + +Definition no_read (mu: moves) (d: reg) : Prop := + ~In d (srcs mu). + +Inductive transition: moves -> moves -> moves + -> moves -> moves -> moves -> Prop := + | tr_nop: forall mu1 r mu2 sigma tau, + transition (mu1 ++ (r, r) :: mu2) sigma tau + (mu1 ++ mu2) sigma tau + | tr_start: forall mu1 s d mu2 tau, + transition (mu1 ++ (s, d) :: mu2) nil tau + (mu1 ++ mu2) ((s, d) :: nil) tau + | tr_push: forall mu1 d r mu2 s sigma tau, + transition (mu1 ++ (d, r) :: mu2) ((s, d) :: sigma) tau + (mu1 ++ mu2) ((d, r) :: (s, d) :: sigma) tau + | tr_loop: forall mu sigma s d tau, + transition mu (sigma ++ (s, d) :: nil) tau + mu (sigma ++ (temp s, d) :: nil) ((s, temp s) :: tau) + | tr_pop: forall mu s0 d0 s1 d1 sigma tau, + no_read mu d1 -> d1 <> s0 -> + transition mu ((s1, d1) :: sigma ++ (s0, d0) :: nil) tau + mu (sigma ++ (s0, d0) :: nil) ((s1, d1) :: tau) + | tr_last: forall mu s d tau, + no_read mu d -> + transition mu ((s, d) :: nil) tau + mu nil ((s, d) :: tau). + +Inductive transitions: moves -> moves -> moves + -> moves -> moves -> moves -> Prop := + | tr_refl: + forall mu sigma tau, + transitions mu sigma tau mu sigma tau + | tr_one: + forall mu1 sigma1 tau1 mu2 sigma2 tau2, + transition mu1 sigma1 tau1 mu2 sigma2 tau2 -> + transitions mu1 sigma1 tau1 mu2 sigma2 tau2 + | tr_trans: + forall mu1 sigma1 tau1 mu2 sigma2 tau2 mu3 sigma3 tau3, + transitions mu1 sigma1 tau1 mu2 sigma2 tau2 -> + transitions mu2 sigma2 tau2 mu3 sigma3 tau3 -> + transitions mu1 sigma1 tau1 mu3 sigma3 tau3. + +(* Well-formedness properties *) + +Definition is_mill (m: moves) : Prop := + list_norepet (dests m). + +Definition is_not_temp (r: reg) : Prop := + forall d, r <> temp d. + +Definition move_no_temp (m: moves) : Prop := + forall s d, In (s, d) m -> is_not_temp s /\ is_not_temp d. + +Definition temp_last (m: moves) : Prop := + match List.rev m with + | nil => True + | (s, d) :: m' => is_not_temp d /\ move_no_temp m' + end. + +Definition is_first_dest (m: moves) (d: reg) : Prop := + match m with + | nil => True + | (s0, d0) :: _ => d = d0 + end. + +Inductive is_path: moves -> Prop := + | is_path_nil: + is_path nil + | is_path_cons: forall s d m, + is_first_dest m s -> + is_path m -> + is_path ((s, d) :: m). + +Definition state_wf (mu sigma tau: moves) : Prop := + is_mill (mu ++ sigma) + /\ move_no_temp mu + /\ temp_last sigma + /\ is_path sigma. + +(* Some properties of srcs and dests *) + +Lemma dests_append: + forall m1 m2, dests (m1 ++ m2) = dests m1 ++ dests m2. +Proof. + intros. unfold dests. apply map_app. +Qed. + +Lemma dests_decomp: + forall m1 s d m2, dests (m1 ++ (s, d) :: m2) = dests m1 ++ d :: dests m2. +Proof. + intros. unfold dests. rewrite map_app. reflexivity. +Qed. + +Lemma srcs_append: + forall m1 m2, srcs (m1 ++ m2) = srcs m1 ++ srcs m2. +Proof. + intros. unfold srcs. apply map_app. +Qed. + +Lemma srcs_decomp: + forall m1 s d m2, srcs (m1 ++ (s, d) :: m2) = srcs m1 ++ s :: srcs m2. +Proof. + intros. unfold srcs. rewrite map_app. reflexivity. +Qed. + +Lemma srcs_dests_combine: + forall s d, + List.length s = List.length d -> + srcs (List.combine s d) = s /\ + dests (List.combine s d) = d. +Proof. + induction s; destruct d; simpl; intros. + tauto. + discriminate. + discriminate. + elim (IHs d); intros. split; congruence. congruence. +Qed. + +(* Some properties of is_mill and dests_disjoint *) + +Definition dests_disjoint (m1 m2: moves) : Prop := + list_disjoint (dests m1) (dests m2). + +Lemma dests_disjoint_sym: + forall m1 m2, + dests_disjoint m1 m2 <-> dests_disjoint m2 m1. +Proof. + unfold dests_disjoint; intros. + split; intros; apply list_disjoint_sym; auto. +Qed. + +Lemma dests_disjoint_cons_left: + forall m1 s d m2, + dests_disjoint ((s, d) :: m1) m2 <-> + dests_disjoint m1 m2 /\ ~In d (dests m2). +Proof. + unfold dests_disjoint, list_disjoint. + simpl; intros; split; intros. + split. auto. firstorder. + destruct H. elim H0; intro. + red; intro; subst. contradiction. + apply H; auto. +Qed. + +Lemma dests_disjoint_cons_right: + forall m1 s d m2, + dests_disjoint m1 ((s, d) :: m2) <-> + dests_disjoint m1 m2 /\ ~In d (dests m1). +Proof. + intros. rewrite dests_disjoint_sym. rewrite dests_disjoint_cons_left. + rewrite dests_disjoint_sym. tauto. +Qed. + +Lemma dests_disjoint_append_left: + forall m1 m2 m3, + dests_disjoint (m1 ++ m2) m3 <-> + dests_disjoint m1 m3 /\ dests_disjoint m2 m3. +Proof. + unfold dests_disjoint, list_disjoint. + intros; split; intros. split; intros. + apply H; eauto. rewrite dests_append. apply in_or_app. auto. + apply H; eauto. rewrite dests_append. apply in_or_app. auto. + destruct H. + rewrite dests_append in H0. elim (in_app_or _ _ _ H0); auto. +Qed. + +Lemma dests_disjoint_append_right: + forall m1 m2 m3, + dests_disjoint m1 (m2 ++ m3) <-> + dests_disjoint m1 m2 /\ dests_disjoint m1 m3. +Proof. + intros. rewrite dests_disjoint_sym. rewrite dests_disjoint_append_left. + intuition; rewrite dests_disjoint_sym; assumption. +Qed. + +Lemma is_mill_cons: + forall s d m, + is_mill ((s, d) :: m) <-> + is_mill m /\ ~In d (dests m). +Proof. + unfold is_mill, dests_disjoint; intros. simpl. + split; intros. + inversion H; tauto. + constructor; tauto. +Qed. + +Lemma is_mill_append: + forall m1 m2, + is_mill (m1 ++ m2) <-> + is_mill m1 /\ is_mill m2 /\ dests_disjoint m1 m2. +Proof. + unfold is_mill, dests_disjoint; intros. rewrite dests_append. + apply list_norepet_app. +Qed. + +(* Some properties of move_no_temp *) + +Lemma move_no_temp_append: + forall m1 m2, + move_no_temp m1 -> move_no_temp m2 -> move_no_temp (m1 ++ m2). +Proof. + intros; red; intros. elim (in_app_or _ _ _ H1); intro. + apply H; auto. apply H0; auto. +Qed. + +Lemma move_no_temp_rev: + forall m, move_no_temp (List.rev m) -> move_no_temp m. +Proof. + intros; red; intros. apply H. rewrite <- List.In_rev. auto. +Qed. + +(* Some properties of temp_last *) + +Lemma temp_last_change_last_source: + forall s d s' sigma, + temp_last (sigma ++ (s, d) :: nil) -> + temp_last (sigma ++ (s', d) :: nil). +Proof. + intros until sigma. unfold temp_last. + repeat rewrite rev_unit. auto. +Qed. + +Lemma temp_last_push: + forall s1 d1 s2 d2 sigma, + temp_last ((s2, d2) :: sigma) -> + is_not_temp s1 -> is_not_temp d1 -> + temp_last ((s1, d1) :: (s2, d2) :: sigma). +Proof. + unfold temp_last; intros. simpl. simpl in H. + destruct (rev sigma); simpl in *. + intuition. red; simpl; intros. + elim H; intros. inversion H4. subst; tauto. tauto. + destruct p as [sN dN]. intuition. + red; intros. elim (in_app_or _ _ _ H); intros. + apply H3; auto. + elim H4; intros. inversion H5; subst; tauto. elim H5. +Qed. + +Lemma temp_last_pop: + forall s1 d1 sigma s2 d2, + temp_last ((s1, d1) :: sigma ++ (s2, d2) :: nil) -> + temp_last (sigma ++ (s2, d2) :: nil). +Proof. + intros until d2. + change ((s1, d1) :: sigma ++ (s2, d2) :: nil) + with ((((s1, d1) :: nil) ++ sigma) ++ ((s2, d2) :: nil)). + unfold temp_last. repeat rewrite rev_unit. + intuition. simpl in H1. red; intros. apply H1. + apply in_or_app. auto. +Qed. + +(* Some properties of is_path *) + +Lemma is_path_pop: + forall s d m, + is_path ((s, d) :: m) -> is_path m. +Proof. + intros. inversion H; subst. auto. +Qed. + +Lemma is_path_change_last_source: + forall s s' d sigma, + is_path (sigma ++ (s, d) :: nil) -> + is_path (sigma ++ (s', d) :: nil). +Proof. + induction sigma; simpl; intros. + constructor. red; auto. constructor. + inversion H; subst; clear H. + constructor. + destruct sigma as [ | [s1 d1] sigma']; simpl; simpl in H2; auto. + auto. +Qed. + +Lemma path_sources_dests: + forall s0 d0 sigma, + is_path (sigma ++ (s0, d0) :: nil) -> + List.incl (srcs (sigma ++ (s0, d0) :: nil)) + (s0 :: dests (sigma ++ (s0, d0) :: nil)). +Proof. + induction sigma; simpl; intros. + red; simpl; tauto. + inversion H; subst; clear H. simpl. + assert (In s (dests (sigma ++ (s0, d0) :: nil))). + destruct sigma as [ | [s1 d1] sigma']; simpl; simpl in H2; intuition. + apply incl_cons. simpl; tauto. + apply incl_tran with (s0 :: dests (sigma ++ (s0, d0) :: nil)). + eapply IHsigma; eauto. + red; simpl; tauto. +Qed. + +Lemma no_read_path: + forall d1 sigma s0 d0, + d1 <> s0 -> + is_path (sigma ++ (s0, d0) :: nil) -> + ~In d1 (dests (sigma ++ (s0, d0) :: nil)) -> + no_read (sigma ++ (s0, d0) :: nil) d1. +Proof. + intros. + generalize (path_sources_dests _ _ _ H0). intro. + intro. elim H1. elim (H2 _ H3); intro. congruence. auto. +Qed. + +(* Populating a rewrite database. *) + +Lemma notin_dests_cons: + forall x s d m, + ~In x (dests ((s, d) :: m)) <-> x <> d /\ ~In x (dests m). +Proof. + intros. simpl. intuition auto. +Qed. + +Lemma notin_dests_append: + forall d m1 m2, + ~In d (dests (m1 ++ m2)) <-> ~In d (dests m1) /\ ~In d (dests m2). +Proof. + intros. rewrite dests_append. rewrite in_app. tauto. +Qed. + +Hint Rewrite is_mill_cons is_mill_append + dests_disjoint_cons_left dests_disjoint_cons_right + dests_disjoint_append_left dests_disjoint_append_right + notin_dests_cons notin_dests_append: pmov. + +(* Preservation of well-formedness *) + +Lemma transition_preserves_wf: + forall mu sigma tau mu' sigma' tau', + transition mu sigma tau mu' sigma' tau' -> + state_wf mu sigma tau -> state_wf mu' sigma' tau'. +Proof. + induction 1; unfold state_wf; intros [A [B [C D]]]; + autorewrite with pmov in A; autorewrite with pmov. + + (* Nop *) + split. tauto. + split. red; intros. apply B. apply list_in_insert; auto. + split; auto. + + (* Start *) + split. tauto. + split. red; intros. apply B. apply list_in_insert; auto. + split. red. simpl. split. elim (B s d). auto. + apply in_or_app. right. apply in_eq. + red; simpl; tauto. + constructor. exact I. constructor. + + (* Push *) + split. intuition. + split. red; intros. apply B. apply list_in_insert; auto. + split. elim (B d r). apply temp_last_push; auto. + apply in_or_app; right; apply in_eq. + constructor. simpl. auto. auto. + + (* Loop *) + split. tauto. + split. auto. + split. eapply temp_last_change_last_source; eauto. + eapply is_path_change_last_source; eauto. + + (* Pop *) + split. intuition. + split. auto. + split. eapply temp_last_pop; eauto. + eapply is_path_pop; eauto. + + (* Last *) + split. intuition. + split. auto. + split. unfold temp_last. simpl. auto. + constructor. +Qed. + +Lemma transitions_preserve_wf: + forall mu sigma tau mu' sigma' tau', + transitions mu sigma tau mu' sigma' tau' -> + state_wf mu sigma tau -> state_wf mu' sigma' tau'. +Proof. + induction 1; intros; eauto. + eapply transition_preserves_wf; eauto. +Qed. + +(* Properties of exec_ *) + +Lemma exec_par_outside: + forall m e r, ~In r (dests m) -> exec_par m e r = e r. +Proof. + induction m; simpl; intros. auto. + destruct a as [s d]. rewrite update_o. apply IHm. tauto. + simpl in H. intuition. +Qed. + +Lemma exec_par_lift: + forall m1 s d m2 e, + ~In d (dests m1) -> + exec_par (m1 ++ (s, d) :: m2) e = exec_par ((s, d) :: m1 ++ m2) e. +Proof. + induction m1; simpl; intros. + auto. + destruct a as [s0 d0]. simpl in H. rewrite IHm1. simpl. + apply update_commut. tauto. tauto. +Qed. + +Lemma exec_par_ident: + forall m1 r m2 e, + is_mill (m1 ++ (r, r) :: m2) -> + exec_par (m1 ++ (r, r) :: m2) e = exec_par (m1 ++ m2) e. +Proof. + intros. autorewrite with pmov in H. + rewrite exec_par_lift. simpl. + replace (e r) with (exec_par (m1 ++ m2) e r). apply update_ident. + apply exec_par_outside. autorewrite with pmov. tauto. tauto. +Qed. + +Lemma exec_seq_app: + forall m1 m2 e, + exec_seq (m1 ++ m2) e = exec_seq m2 (exec_seq m1 e). +Proof. + induction m1; simpl; intros. auto. + destruct a as [s d]. rewrite IHm1. auto. +Qed. + +Lemma exec_seq_rev_app: + forall m1 m2 e, + exec_seq_rev (m1 ++ m2) e = exec_seq_rev m1 (exec_seq_rev m2 e). +Proof. + induction m1; simpl; intros. auto. + destruct a as [s d]. rewrite IHm1. auto. +Qed. + +Lemma exec_seq_exec_seq_rev: + forall m e, + exec_seq_rev m e = exec_seq (List.rev m) e. +Proof. + induction m; simpl; intros. + auto. + destruct a as [s d]. rewrite exec_seq_app. simpl. rewrite IHm. auto. +Qed. + +Lemma exec_seq_rev_exec_seq: + forall m e, + exec_seq m e = exec_seq_rev (List.rev m) e. +Proof. + intros. generalize (exec_seq_exec_seq_rev (List.rev m) e). + rewrite List.rev_involutive. auto. +Qed. + +Lemma exec_par_update_no_read: + forall s d m e, + no_read m d -> + ~In d (dests m) -> + exec_par m (update d (e s) e) = + update d (e s) (exec_par m e). +Proof. + unfold no_read; induction m; simpl; intros. + auto. + destruct a as [s0 d0]; simpl in *. rewrite IHm. + rewrite update_commut. f_equal. f_equal. + apply update_o. tauto. tauto. tauto. tauto. +Qed. + +Lemma exec_par_append_eq: + forall m1 m2 m3 e2 e3, + exec_par m2 e2 = exec_par m3 e3 -> + (forall r, In r (srcs m1) -> e2 r = e3 r) -> + exec_par (m1 ++ m2) e2 = exec_par (m1 ++ m3) e3. +Proof. + induction m1; simpl; intros. + auto. destruct a as [s d]. f_equal; eauto. +Qed. + +Lemma exec_par_combine: + forall e sl dl, + List.length sl = List.length dl -> + list_norepet dl -> + let e' := exec_par (combine sl dl) e in + List.map e' dl = List.map e sl /\ + (forall l, ~In l dl -> e' l = e l). +Proof. + induction sl; destruct dl; simpl; intros; try discriminate. + split; auto. + inversion H0; subst; clear H0. + injection H; intro; clear H. + destruct (IHsl dl H0 H4) as [A B]. + set (e' := exec_par (combine sl dl) e) in *. + split. + decEq. apply update_s. + rewrite <- A. apply list_map_exten; intros. + rewrite update_o. auto. congruence. + intros. rewrite update_o. apply B. tauto. intuition. +Qed. + +(* Semantics of triples (mu, sigma, tau) *) + +Definition statemove (mu sigma tau: moves) (e: env) := + exec_par (mu ++ sigma) (exec_seq_rev tau e). + +(* Equivalence over non-temp regs *) + +Definition env_equiv (e1 e2: env) : Prop := + forall r, is_not_temp r -> e1 r = e2 r. + +Lemma env_equiv_refl: + forall e, env_equiv e e. +Proof. + unfold env_equiv; auto. +Qed. + +Lemma env_equiv_refl': + forall e1 e2, e1 = e2 -> env_equiv e1 e2. +Proof. + unfold env_equiv; intros. rewrite H. auto. +Qed. + +Lemma env_equiv_sym: + forall e1 e2, env_equiv e1 e2 -> env_equiv e2 e1. +Proof. + unfold env_equiv; intros. symmetry; auto. +Qed. + +Lemma env_equiv_trans: + forall e1 e2 e3, env_equiv e1 e2 -> env_equiv e2 e3 -> env_equiv e1 e3. +Proof. + unfold env_equiv; intros. transitivity (e2 r); auto. +Qed. + +Lemma exec_par_env_equiv: + forall m e1 e2, + move_no_temp m -> + env_equiv e1 e2 -> + env_equiv (exec_par m e1) (exec_par m e2). +Proof. + unfold move_no_temp; induction m; simpl; intros. + auto. + destruct a as [s d]. + red; intros. unfold update. destruct (reg_eq r d). + apply H0. elim (H s d); tauto. + apply IHm; auto. +Qed. + +(* Preservation of semantics by transformations. *) + +Lemma transition_preserves_semantics: + forall mu1 sigma1 tau1 mu2 sigma2 tau2 e, + transition mu1 sigma1 tau1 mu2 sigma2 tau2 -> + state_wf mu1 sigma1 tau1 -> + env_equiv (statemove mu2 sigma2 tau2 e) (statemove mu1 sigma1 tau1 e). +Proof. + induction 1; intros [A [B [C D]]]. + + (* nop *) + apply env_equiv_refl'. unfold statemove. + repeat rewrite app_ass. simpl. symmetry. apply exec_par_ident. + rewrite app_ass in A. exact A. + + (* start *) + apply env_equiv_refl'. unfold statemove. + autorewrite with pmov in A. + rewrite exec_par_lift. repeat rewrite app_ass. simpl. rewrite exec_par_lift. reflexivity. + tauto. autorewrite with pmov. tauto. + + (* push *) + apply env_equiv_refl'. unfold statemove. + autorewrite with pmov in A. + rewrite exec_par_lift. rewrite exec_par_lift. simpl. + rewrite exec_par_lift. repeat rewrite app_ass. simpl. rewrite exec_par_lift. + simpl. apply update_commut. intuition. + tauto. autorewrite with pmov; tauto. + autorewrite with pmov; intuition. + autorewrite with pmov; intuition. + + (* loop *) + unfold statemove. simpl exec_seq_rev. + set (e1 := exec_seq_rev tau e). + autorewrite with pmov in A. + repeat rewrite <- app_ass. + assert (~In d (dests (mu ++ sigma))). autorewrite with pmov. tauto. + repeat rewrite exec_par_lift; auto. simpl. + repeat rewrite <- app_nil_end. + assert (move_no_temp (mu ++ sigma)). + red in C. rewrite rev_unit in C. destruct C. + apply move_no_temp_append; auto. apply move_no_temp_rev; auto. + set (e2 := update (temp s) (e1 s) e1). + set (e3 := exec_par (mu ++ sigma) e1). + set (e4 := exec_par (mu ++ sigma) e2). + assert (env_equiv e2 e1). + unfold e2; red; intros. apply update_o. apply H1. + assert (env_equiv e4 e3). + unfold e4, e3. apply exec_par_env_equiv; auto. + red; intros. unfold update. destruct (reg_eq r d). + unfold e2. apply update_s. apply H2. auto. + + (* pop *) + apply env_equiv_refl'. unfold statemove. simpl exec_seq_rev. + set (e1 := exec_seq_rev tau e). + autorewrite with pmov in A. + apply exec_par_append_eq. simpl. + apply exec_par_update_no_read. + apply no_read_path; auto. eapply is_path_pop; eauto. + autorewrite with pmov; tauto. + autorewrite with pmov; tauto. + intros. apply update_o. red; intro; subst r. elim (H H1). + + (* last *) + apply env_equiv_refl'. unfold statemove. simpl exec_seq_rev. + set (e1 := exec_seq_rev tau e). + apply exec_par_append_eq. simpl. auto. + intros. apply update_o. red; intro; subst r. elim (H H0). +Qed. + +Lemma transitions_preserve_semantics: + forall mu1 sigma1 tau1 mu2 sigma2 tau2 e, + transitions mu1 sigma1 tau1 mu2 sigma2 tau2 -> + state_wf mu1 sigma1 tau1 -> + env_equiv (statemove mu2 sigma2 tau2 e) (statemove mu1 sigma1 tau1 e). +Proof. + induction 1; intros. + apply env_equiv_refl. + eapply transition_preserves_semantics; eauto. + apply env_equiv_trans with (statemove mu2 sigma2 tau2 e). + apply IHtransitions2. eapply transitions_preserve_wf; eauto. + apply IHtransitions1. auto. +Qed. + +Lemma state_wf_start: + forall mu, + move_no_temp mu -> + is_mill mu -> + state_wf mu nil nil. +Proof. + split. rewrite <- app_nil_end. auto. + split. auto. + split. red. simpl. auto. + constructor. +Qed. + +Theorem transitions_correctness: + forall mu tau, + move_no_temp mu -> + is_mill mu -> + transitions mu nil nil nil nil tau -> + forall e, env_equiv (exec_seq (List.rev tau) e) (exec_par mu e). +Proof. + intros. + generalize (transitions_preserve_semantics _ _ _ _ _ _ e H1 + (state_wf_start _ H H0)). + unfold statemove. simpl. rewrite <- app_nil_end. + rewrite exec_seq_exec_seq_rev. auto. +Qed. + +(* Determinisation of the transition relation *) + +Inductive dtransition: moves -> moves -> moves + -> moves -> moves -> moves -> Prop := + | dtr_nop: forall r mu tau, + dtransition ((r, r) :: mu) nil tau + mu nil tau + | dtr_start: forall s d mu tau, + s <> d -> + dtransition ((s, d) :: mu) nil tau + mu ((s, d) :: nil) tau + | dtr_push: forall mu1 d r mu2 s sigma tau, + no_read mu1 d -> + dtransition (mu1 ++ (d, r) :: mu2) ((s, d) :: sigma) tau + (mu1 ++ mu2) ((d, r) :: (s, d) :: sigma) tau + | dtr_loop_pop: forall mu s r0 d sigma tau, + no_read mu r0 -> + dtransition mu ((s, r0) :: sigma ++ (r0, d) :: nil) tau + mu (sigma ++ (temp r0, d) :: nil) ((s, r0) :: (r0, temp r0) :: tau) + | dtr_pop: forall mu s0 d0 s1 d1 sigma tau, + no_read mu d1 -> d1 <> s0 -> + dtransition mu ((s1, d1) :: sigma ++ (s0, d0) :: nil) tau + mu (sigma ++ (s0, d0) :: nil) ((s1, d1) :: tau) + | dtr_last: forall mu s d tau, + no_read mu d -> + dtransition mu ((s, d) :: nil) tau + mu nil ((s, d) :: tau). + +Inductive dtransitions: moves -> moves -> moves + -> moves -> moves -> moves -> Prop := + | dtr_refl: + forall mu sigma tau, + dtransitions mu sigma tau mu sigma tau + | dtr_one: + forall mu1 sigma1 tau1 mu2 sigma2 tau2, + dtransition mu1 sigma1 tau1 mu2 sigma2 tau2 -> + dtransitions mu1 sigma1 tau1 mu2 sigma2 tau2 + | dtr_trans: + forall mu1 sigma1 tau1 mu2 sigma2 tau2 mu3 sigma3 tau3, + dtransitions mu1 sigma1 tau1 mu2 sigma2 tau2 -> + dtransitions mu2 sigma2 tau2 mu3 sigma3 tau3 -> + dtransitions mu1 sigma1 tau1 mu3 sigma3 tau3. + +Lemma transition_determ: + forall mu1 sigma1 tau1 mu2 sigma2 tau2, + dtransition mu1 sigma1 tau1 mu2 sigma2 tau2 -> + state_wf mu1 sigma1 tau1 -> + transitions mu1 sigma1 tau1 mu2 sigma2 tau2. +Proof. + induction 1; intro. + apply tr_one. exact (tr_nop nil r mu nil tau). + apply tr_one. exact (tr_start nil s d mu tau). + apply tr_one. apply tr_push. + eapply tr_trans. + apply tr_one. + change ((s, r0) :: sigma ++ (r0, d) :: nil) + with (((s, r0) :: sigma) ++ (r0, d) :: nil). + apply tr_loop. + apply tr_one. simpl. apply tr_pop. auto. + destruct H0 as [A [B [C D]]]. + generalize C. + change ((s, r0) :: sigma ++ (r0, d) :: nil) + with (((s, r0) :: sigma) ++ (r0, d) :: nil). + unfold temp_last; rewrite List.rev_unit. intros [E F]. + elim (F s r0). unfold is_not_temp. auto. + rewrite <- List.In_rev. apply in_eq. + apply tr_one. apply tr_pop. auto. auto. + apply tr_one. apply tr_last. auto. +Qed. + +Lemma transitions_determ: + forall mu1 sigma1 tau1 mu2 sigma2 tau2, + dtransitions mu1 sigma1 tau1 mu2 sigma2 tau2 -> + state_wf mu1 sigma1 tau1 -> + transitions mu1 sigma1 tau1 mu2 sigma2 tau2. +Proof. + induction 1; intros. + apply tr_refl. + eapply transition_determ; eauto. + eapply tr_trans. + apply IHdtransitions1. auto. + apply IHdtransitions2. eapply transitions_preserve_wf; eauto. +Qed. + +Theorem dtransitions_correctness: + forall mu tau, + move_no_temp mu -> + is_mill mu -> + dtransitions mu nil nil nil nil tau -> + forall e, env_equiv (exec_seq (List.rev tau) e) (exec_par mu e). +Proof. + intros. + eapply transitions_correctness; eauto. + apply transitions_determ. auto. apply state_wf_start; auto. +Qed. + +(* Transition function *) + +Function split_move (m: moves) (r: reg) {struct m} : option (moves * reg * moves) := + match m with + | nil => None + | (s, d) :: tl => + if reg_eq s r + then Some (nil, d, tl) + else match split_move tl r with + | None => None + | Some (before, d', after) => Some ((s, d) :: before, d', after) + end + end. + +Function is_last_source (r: reg) (m: moves) {struct m} : bool := + match m with + | nil => false + | (s, d) :: nil => + if reg_eq s r then true else false + | (s, d) :: tl => + is_last_source r tl + end. + +Function replace_last_source (r: reg) (m: moves) {struct m} : moves := + match m with + | nil => nil + | (s, d) :: nil => (r, d) :: nil + | s_d :: tl => s_d :: replace_last_source r tl + end. + +Inductive state : Set := State: moves -> moves -> moves -> state. + +Definition final_state (st: state) : bool := + match st with + | State nil nil _ => true + | _ => false + end. + +Function parmove_step (st: state) : state := + match st with + | State nil nil _ => st + | State ((s, d) :: tl) nil l => + if reg_eq s d + then State tl nil l + else State tl ((s, d) :: nil) l + | State t ((s, d) :: b) l => + match split_move t d with + | Some (t1, r, t2) => + State (t1 ++ t2) ((d, r) :: (s, d) :: b) l + | None => + match b with + | nil => State t nil ((s, d) :: l) + | _ => + if is_last_source d b + then State t (replace_last_source (temp d) b) ((s, d) :: (d, temp d) :: l) + else State t b ((s, d) :: l) + end + end + end. + +(* Correctness properties of these functions *) + +Lemma split_move_charact: + forall m r, + match split_move m r with + | Some (before, d, after) => m = before ++ (r, d) :: after /\ no_read before r + | None => no_read m r + end. +Proof. + unfold no_read. intros m r. functional induction (split_move m r). + red; simpl. tauto. + rewrite _x. split. reflexivity. simpl;auto. + rewrite e1 in IHo. simpl. intuition. + rewrite e1 in IHo. destruct IHo. split. rewrite H. reflexivity. + simpl. intuition. +Qed. + +Lemma is_last_source_charact: + forall r s d m, + if is_last_source r (m ++ (s, d) :: nil) + then s = r + else s <> r. +Proof. + induction m; simpl. + destruct (reg_eq s r); congruence. + destruct a as [s0 d0]. case_eq (m ++ (s, d) :: nil); intros. + generalize (app_cons_not_nil m nil (s, d)). congruence. + rewrite <- H. auto. +Qed. + +Lemma replace_last_source_charact: + forall s d s' m, + replace_last_source s' (m ++ (s, d) :: nil) = + m ++ (s', d) :: nil. +Proof. + induction m; simpl. + auto. + destruct a as [s0 d0]. case_eq (m ++ (s, d) :: nil); intros. + generalize (app_cons_not_nil m nil (s, d)). congruence. + rewrite <- H. congruence. +Qed. + +Lemma parmove_step_compatible: + forall mu sigma tau mu' sigma' tau', + final_state (State mu sigma tau) = false -> + parmove_step (State mu sigma tau) = State mu' sigma' tau' -> + dtransition mu sigma tau mu' sigma' tau'. +Proof. + intros until tau'. intro NOTFINAL. + unfold parmove_step. + case_eq mu; [intros MEQ | intros [ms md] mtl MEQ]. + case_eq sigma; [intros SEQ | intros [ss sd] stl SEQ]. + subst mu sigma. discriminate. + simpl. + case_eq stl; [intros STLEQ | intros xx1 xx2 STLEQ]. + intro R; inversion R; clear R; subst. + apply dtr_last. red; simpl; auto. + elim (@exists_last _ stl). 2:congruence. intros sigma1 [[ss1 sd1] SEQ2]. + rewrite <- STLEQ. clear STLEQ xx1 xx2. + generalize (is_last_source_charact sd ss1 sd1 sigma1). + rewrite SEQ2. destruct (is_last_source sd (sigma1 ++ (ss1, sd1) :: nil)). + intro. subst ss1. intro R; inversion R; clear R; subst. + rewrite replace_last_source_charact. apply dtr_loop_pop. + red; simpl; auto. + intro. intro R; inversion R; clear R; subst. + apply dtr_pop. red; simpl; auto. auto. + + case_eq sigma; [intros SEQ | intros [ss sd] stl SEQ]. + destruct (reg_eq ms md); intro R; inversion R; clear R; subst. + apply dtr_nop. + apply dtr_start. auto. + + generalize (split_move_charact ((ms, md) :: mtl) sd). + case (split_move ((ms, md) :: mtl) sd); [intros [[before r] after] | idtac]. + intros [MEQ2 NOREAD]. intro R; inversion R; clear R; subst. + rewrite MEQ2. apply dtr_push. auto. + intro NOREAD. + case_eq stl; [intros STLEQ | intros xx1 xx2 STLEQ]. + intro R; inversion R; clear R; subst. + apply dtr_last. auto. + elim (@exists_last _ stl). 2:congruence. intros sigma1 [[ss1 sd1] SEQ2]. + rewrite <- STLEQ. clear STLEQ xx1 xx2. + generalize (is_last_source_charact sd ss1 sd1 sigma1). + rewrite SEQ2. destruct (is_last_source sd (sigma1 ++ (ss1, sd1) :: nil)). + intro. subst ss1. intro R; inversion R; clear R; subst. + rewrite replace_last_source_charact. apply dtr_loop_pop. auto. + intro. intro R; inversion R; clear R; subst. + apply dtr_pop. auto. auto. +Qed. + +(* Decreasing measure over states *) + +Open Scope nat_scope. + +Definition measure (st: state) : nat := + match st with + | State mu sigma tau => 2 * List.length mu + List.length sigma + end. + +Lemma measure_decreasing_1: + forall mu1 sigma1 tau1 mu2 sigma2 tau2, + dtransition mu1 sigma1 tau1 mu2 sigma2 tau2 -> + measure (State mu2 sigma2 tau2) < measure (State mu1 sigma1 tau1). +Proof. + induction 1; repeat (simpl; rewrite List.app_length); simpl; omega. +Qed. + +Lemma measure_decreasing_2: + forall st, + final_state st = false -> + measure (parmove_step st) < measure st. +Proof. + intros. destruct st as [mu sigma tau]. + case_eq (parmove_step (State mu sigma tau)). intros mu' sigma' tau' EQ. + apply measure_decreasing_1. + apply parmove_step_compatible; auto. +Qed. + +(* Compilation function for parallel moves *) + +Function parmove_aux (st: state) {measure measure st} : moves := + if final_state st + then match st with State _ _ tau => tau end + else parmove_aux (parmove_step st). +Proof. + intros. apply measure_decreasing_2. auto. +Qed. + +Lemma parmove_aux_transitions: + forall mu sigma tau, + dtransitions mu sigma tau nil nil (parmove_aux (State mu sigma tau)). +Proof. + assert (forall st, + match st with State mu sigma tau => + dtransitions mu sigma tau nil nil (parmove_aux st) + end). + intro st. functional induction (parmove_aux st). + destruct _x; destruct _x0; simpl in e; discriminate || apply dtr_refl. + case_eq (parmove_step st). intros mu' sigma' tau' PSTEP. + destruct st as [mu sigma tau]. + eapply dtr_trans. apply dtr_one. apply parmove_step_compatible; eauto. + rewrite PSTEP in IHm. auto. + + intros. apply (H (State mu sigma tau)). +Qed. + +Definition parmove (mu: moves) : moves := + List.rev (parmove_aux (State mu nil nil)). + +Theorem parmove_correctness: + forall mu, + move_no_temp mu -> is_mill mu -> + forall e, + env_equiv (exec_seq (parmove mu) e) (exec_par mu e). +Proof. + intros. unfold parmove. apply dtransitions_correctness; auto. + apply parmove_aux_transitions. +Qed. + +Definition parmove2 (sl dl: list reg) : moves := + parmove (List.combine sl dl). + +Theorem parmove2_correctness: + forall sl dl, + List.length sl = List.length dl -> + list_norepet dl -> + (forall r, In r sl -> is_not_temp r) -> + (forall r, In r dl -> is_not_temp r) -> + forall e, + let e' := exec_seq (parmove2 sl dl) e in + List.map e' dl = List.map e sl /\ + forall r, ~In r dl -> is_not_temp r -> e' r = e r. +Proof. + intros. + destruct (srcs_dests_combine sl dl H) as [A B]. + assert (env_equiv e' (exec_par (List.combine sl dl) e)). + unfold e', parmove2. apply parmove_correctness. + red; intros; split. + apply H1. eapply List.in_combine_l; eauto. + apply H2. eapply List.in_combine_r; eauto. + red. rewrite B. auto. + destruct (exec_par_combine e sl dl H H0) as [C D]. + set (e1 := exec_par (combine sl dl) e) in *. + split. rewrite <- C. apply list_map_exten; intros. + symmetry. apply H3. auto. + intros. transitivity (e1 r); auto. +Qed. + +(* Additional properties on the generated sequence of moves. *) + +Section PROPERTIES. + +Variable initial_move: moves. + +Inductive wf_move: reg -> reg -> Prop := + | wf_move_same: forall s d, + In (s, d) initial_move -> wf_move s d + | wf_move_temp_left: forall s d, + wf_move s d -> wf_move (temp s) d + | wf_move_temp_right: forall s d, + wf_move s d -> wf_move s (temp s). + +Definition wf_moves (m: moves) : Prop := + forall s d, In (s, d) m -> wf_move s d. + +Lemma wf_moves_cons: forall s d m, + wf_moves ((s, d) :: m) <-> wf_move s d /\ wf_moves m. +Proof. + unfold wf_moves; intros; simpl. firstorder. + inversion H0; subst s0 d0. auto. +Qed. + +Lemma wf_moves_append: forall m1 m2, + wf_moves (m1 ++ m2) <-> wf_moves m1 /\ wf_moves m2. +Proof. + unfold wf_moves; intros. split; intros. + split; intros; apply H; apply in_or_app; auto. + destruct H. elim (in_app_or _ _ _ H0); intro; auto. +Qed. + +Hint Rewrite wf_moves_cons wf_moves_append: pmov. + +Definition wf_state (mu sigma tau: moves) : Prop := + wf_moves mu /\ wf_moves sigma /\ wf_moves tau. + +Lemma dtransition_preserves_wf_state: + forall mu1 sigma1 tau1 mu2 sigma2 tau2, + dtransition mu1 sigma1 tau1 mu2 sigma2 tau2 -> + wf_state mu1 sigma1 tau1 -> wf_state mu2 sigma2 tau2. +Proof. + induction 1; intros [A [B C]]; unfold wf_state; + autorewrite with pmov in A; autorewrite with pmov in B; + autorewrite with pmov in C; autorewrite with pmov. + + tauto. + + tauto. + + tauto. + + intuition. apply wf_move_temp_left; auto. + eapply wf_move_temp_right; eauto. + + intuition. + + intuition. +Qed. + +Lemma dtransitions_preserve_wf_state: + forall mu1 sigma1 tau1 mu2 sigma2 tau2, + dtransitions mu1 sigma1 tau1 mu2 sigma2 tau2 -> + wf_state mu1 sigma1 tau1 -> wf_state mu2 sigma2 tau2. +Proof. + induction 1; intros; eauto. + eapply dtransition_preserves_wf_state; eauto. +Qed. + +End PROPERTIES. + +Lemma parmove_wf_moves: + forall mu, wf_moves mu (parmove mu). +Proof. + intros. + assert (wf_state mu mu nil nil). + split. red; intros. apply wf_move_same. auto. + split. red; simpl; tauto. red; simpl; tauto. + generalize (dtransitions_preserve_wf_state mu + _ _ _ _ _ _ + (parmove_aux_transitions mu nil nil) H). + intros [A [B C]]. + unfold parmove. red; intros. apply C. + rewrite List.In_rev. auto. +Qed. + +Lemma parmove2_wf_moves: + forall sl dl, wf_moves (List.combine sl dl) (parmove2 sl dl). +Proof. + intros. unfold parmove2. apply parmove_wf_moves. +Qed. + +End PARMOV. diff --git a/lib/union_find.v b/lib/union_find.v index 61817d7..452459f 100644 --- a/lib/union_find.v +++ b/lib/union_find.v @@ -1,6 +1,7 @@ (** A purely functional union-find algorithm *) Require Import Wf. +Require Recdef. (** The ``union-find'' algorithm is used to represent equivalence classes over a given type. It maintains a data structure representing a partition @@ -27,21 +28,6 @@ Require Import Wf. presentation where the mapping is a separate functional data structure. *) -Ltac CaseEq name := - generalize (refl_equal name); pattern name at -1 in |- *; case name. - -Ltac IntroElim := - match goal with - | |- (forall id : exists x : _, _, _) => - intro id; elim id; clear id; IntroElim - | |- (forall id : _ /\ _, _) => intro id; elim id; clear id; IntroElim - | |- (forall id : _ \/ _, _) => intro id; elim id; clear id; IntroElim - | |- (_ -> _) => intro; IntroElim - | _ => idtac - end. - -Ltac MyElim n := elim n; IntroElim. - (** The elements of equivalence classes are represented by the following signature: a type with a decidable equality. *) @@ -139,82 +125,47 @@ Definition repr_order (m: M.T) (a a': elt) : Prop := (** The canonical representative of an element. Needs Noetherian recursion. *) -Lemma option_sum: - forall (x: option elt), {y: elt | x = Some y} + {x = None}. -Proof. - intro x. case x. - left. exists e. auto. - right. auto. -Qed. +Section REPR. + +Variable m: M.T. +Variable wf: well_founded (repr_order m). -Definition repr_rec - (m: M.T) (a: elt) (rec: forall b: elt, repr_order m b a -> elt) := - match option_sum (M.get a m) with - | inleft (exist b P) => rec b P - | inright _ => a - end. - -Definition repr_aux - (m: M.T) (wf: well_founded (repr_order m)) (a: elt) : elt := - Fix wf (fun (_: elt) => elt) (repr_rec m) a. - -Lemma repr_rec_ext: - forall (m: M.T) (x: elt) (f g: forall y:elt, repr_order m y x -> elt), - (forall (y: elt) (p: repr_order m y x), f y p = g y p) -> - repr_rec m x f = repr_rec m x g. +Function repr_aux (a: elt) {wf (repr_order m) a} : elt := + match M.get a m with + | Some a' => repr_aux a' + | None => a + end. Proof. - intros. unfold repr_rec. - case (option_sum (M.get x m)). - intros. elim s; intros. apply H. - intros. auto. + intros. assumption. + assumption. Qed. Lemma repr_aux_none: - forall (m: M.T) (wf: well_founded (repr_order m)) (a: elt), + forall (a: elt), M.get a m = None -> - repr_aux m wf a = a. + repr_aux a = a. Proof. - intros. - generalize (Fix_eq wf (fun (_:elt) => elt) (repr_rec m) (repr_rec_ext m) a). - intro. unfold repr_aux. rewrite H0. - unfold repr_rec. - case (option_sum (M.get a m)). - intro s; elim s; intros. - rewrite H in p; discriminate. - intros. auto. + intros. rewrite repr_aux_equation. rewrite H. auto. Qed. Lemma repr_aux_some: - forall (m: M.T) (wf: well_founded (repr_order m)) (a a': elt), + forall (a a': elt), M.get a m = Some a' -> - repr_aux m wf a = repr_aux m wf a'. + repr_aux a = repr_aux a'. Proof. - intros. - generalize (Fix_eq wf (fun (_:elt) => elt) (repr_rec m) (repr_rec_ext m) a). - intro. unfold repr_aux. rewrite H0. unfold repr_rec. - case (option_sum (M.get a m)). - intro s; elim s; intros. - rewrite H in p. injection p; intros. rewrite H1. auto. - intros. rewrite H in e. discriminate. + intros. rewrite repr_aux_equation. rewrite H. auto. Qed. - + Lemma repr_aux_canon: - forall (m: M.T) (wf: well_founded (repr_order m)) (a: elt), - M.get (repr_aux m wf a) m = None. + forall (a: elt), M.get (repr_aux a) m = None. Proof. - intros. - apply (well_founded_ind wf (fun (a: elt) => M.get (repr_aux m wf a) m = None)). - intros. - generalize (Fix_eq wf (fun (_:elt) => elt) (repr_rec m) (repr_rec_ext m) x). - intro. unfold repr_aux. rewrite H0. - unfold repr_rec. - case (option_sum (M.get x m)). - intro s; elim s; intros. - unfold repr_aux in H. apply H. - unfold repr_order. auto. - intro. auto. + intros a0. + apply (repr_aux_ind (fun a a' => M.get a' m = None)). + auto. auto. Qed. +End REPR. + (** The empty partition (each element in its own class) is well founded. *) Lemma wf_empty: @@ -282,11 +233,9 @@ Proof. induction 1. apply Acc_intro. intros. - MyElim (identify_base_repr_order y x H1). + destruct (identify_base_repr_order y x H1) as [A | [A B]]. apply H0; auto. - rewrite H3. - apply Acc_intro. - intros z H4. + subst x y. apply Acc_intro. intros z H4. red in H4. rewrite identify_base_b_canon in H4. discriminate. Qed. @@ -312,31 +261,29 @@ Lemma identify_base_repr: repr_aux identify_base identify_base_order_wf x = (if E.eq (repr_aux m mwf x) a then b else repr_aux m mwf x). Proof. - intro x0. apply (well_founded_ind mwf (fun (x: elt) => repr_aux identify_base identify_base_order_wf x = (if E.eq (repr_aux m mwf x) a then b else repr_aux m mwf x))); intros. - MyElim (identify_aux_decomp x). + destruct (identify_aux_decomp x) as [[A B] | [[A [B C]] | [y [A B]]]]. - rewrite (repr_aux_none identify_base). - rewrite (repr_aux_none m mwf x). + rewrite (repr_aux_none identify_base); auto. + rewrite (repr_aux_none m mwf x); auto. case (E.eq x a); intro. subst x. - rewrite identify_base_a_maps_to_b in H1. - discriminate. - auto. auto. auto. + rewrite identify_base_a_maps_to_b in B. discriminate. + auto. subst x. rewrite (repr_aux_none m mwf a); auto. case (E.eq a a); intro. - rewrite (repr_aux_some identify_base identify_base_order_wf a b). - rewrite (repr_aux_none identify_base identify_base_order_wf b). - auto. apply identify_base_b_canon. auto. + rewrite (repr_aux_some identify_base identify_base_order_wf a b); auto. + rewrite (repr_aux_none identify_base identify_base_order_wf b); auto. + apply identify_base_b_canon. tauto. - rewrite (repr_aux_some identify_base identify_base_order_wf x x1); auto. - rewrite (repr_aux_some m mwf x x1); auto. + rewrite (repr_aux_some identify_base identify_base_order_wf x y); auto. + rewrite (repr_aux_some m mwf x y); auto. Qed. Lemma identify_base_sameclass_1: diff --git a/test/cminor/Makefile b/test/cminor/Makefile index 35d3e07..f9b863e 100644 --- a/test/cminor/Makefile +++ b/test/cminor/Makefile @@ -1,10 +1,11 @@ CCOMP=../../ccomp CPP=cpp -P CC=gcc -CFLAGS=-g +CFLAGS=-arch ppc -g +ASFLAGS=-arch ppc VPATH=../harness ../lib -PROGS=fib integr qsort fft sha1 aes almabench manyargs +PROGS=fib integr qsort fft sha1 aes almabench manyargs lists all_s: $(PROGS:%=%.s) @@ -27,13 +28,13 @@ qsort: qsort.o mainqsort.o clean:: rm -f qsort -fft: fft.o mainfft.o staticlib.o - $(CC) $(CFLAGS) -o fft fft.o mainfft.o staticlib.o -lm +fft: fft.o mainfft.o + $(CC) $(CFLAGS) -o fft fft.o mainfft.o -lm clean:: rm -f fft -sha1: sha1.o mainsha1.o staticlib.o - $(CC) $(CFLAGS) -o sha1 sha1.o mainsha1.o staticlib.o +sha1: sha1.o mainsha1.o + $(CC) $(CFLAGS) -o sha1 sha1.o mainsha1.o clean:: rm -f sha1 sha1.cm @@ -42,8 +43,8 @@ aes: aes.o mainaes.o clean:: rm -f aes aes.cm -almabench: almabench.o mainalmabench.o staticlib.o - $(CC) $(CFLAGS) -o almabench almabench.o mainalmabench.o staticlib.o -lm +almabench: almabench.o mainalmabench.o + $(CC) $(CFLAGS) -o almabench almabench.o mainalmabench.o -lm clean:: rm -f almabench almabench.cm @@ -52,6 +53,11 @@ manyargs: manyargs.o mainmanyargs.o clean:: rm -f manyargs +lists: lists.o mainlists.o + $(CC) $(CFLAGS) -o lists lists.o mainlists.o +clean:: + rm -f lists + .SUFFIXES: .SUFFIXES: .cmp .cm .s .o .c .S diff --git a/test/cminor/almabench.cmp b/test/cminor/almabench.cmp index e9e8392..bafcb5d 100644 --- a/test/cminor/almabench.cmp +++ b/test/cminor/almabench.cmp @@ -28,12 +28,20 @@ #define sl(x,y) float64["sl" + ((x) * 80 + (y) * 8)] /* Function calls */ -#define cos(x) ("cos_static"(x): float -> float) -#define sin(x) ("sin_static"(x): float -> float) -#define atan2(x,y) ("atan2_static"(x,y): float -> float -> float) -#define asin(x) ("asin_static"(x): float -> float) -#define sqrt(x) ("sqrt_static"(x): float -> float) -#define fmod(x,y) ("fmod_static"(x,y): float -> float -> float) + +extern "cos": float -> float +extern "sin": float -> float +extern "atan2": float -> float -> float +extern "asin": float -> float +extern "sqrt": float -> float +extern "fmod": float -> float -> float + +#define cos(x) ("cos"(x): float -> float) +#define sin(x) ("sin"(x): float -> float) +#define atan2(x,y) ("atan2"(x,y): float -> float -> float) +#define asin(x) ("asin"(x): float -> float) +#define sqrt(x) ("sqrt"(x): float -> float) +#define fmod(x,y) ("fmod"(x,y): float -> float -> float) #define anpm(x) ("anpm"(x) : float -> float) "anpm"(a): float -> float @@ -90,7 +98,7 @@ k = k + 1; } }} - dl = "fmod_static"(dl,TWOPI) : float -> float -> float; + dl = "fmod"(dl,TWOPI) : float -> float -> float; am = dl -f dp; ae = am +f de *f sin(am); diff --git a/test/cminor/fft.cm b/test/cminor/fft.cm index b4e6a40..ed3b103 100644 --- a/test/cminor/fft.cm +++ b/test/cminor/fft.cm @@ -5,6 +5,9 @@ /* Length is n. */ /********************************************************/ +extern "cos" : float -> float +extern "sin" : float -> float + "dfft"(x, y, np): int /*float ptr*/ -> int /*float ptr*/ -> int -> int { var px, py, /*float ptr*/ @@ -48,11 +51,11 @@ j = 1; {{ loop { if (! (j <= n4)) exit; - cc1 = "cos_static"(a) : float -> float; - ss1 = "sin_static"(a) : float -> float; + cc1 = "cos"(a) : float -> float; + ss1 = "sin"(a) : float -> float; a3 = 3.0 *f a; - cc3 = "cos_static"(a3) : float -> float; - ss3 = "sin_static"(a3) : float -> float; + cc3 = "cos"(a3) : float -> float; + ss3 = "sin"(a3) : float -> float; a = e *f floatofint(j); is = j; id = 2 * n2; diff --git a/test/cminor/lists.cm b/test/cminor/lists.cm new file mode 100644 index 0000000..c445623 --- /dev/null +++ b/test/cminor/lists.cm @@ -0,0 +1,27 @@ +/* List manipulations */ + +"buildlist"(n): int -> int +{ + var b; + + if (n < 0) return 0; + b = alloc 8; + int32[b] = n; + int32[b+4] = "buildlist"(n - 1) : int -> int; + return b; +} + +"reverselist"(l): int -> int +{ + var r, r2; + r = 0; + loop { + if (l == 0) return r; + r2 = alloc 8; + int32[r2] = int32[l]; + int32[r2+4] = r; + r = r2; + l = int32[l+4]; + } +} + diff --git a/test/cminor/sha1.cmp b/test/cminor/sha1.cmp index 9a588e4..ca24544 100644 --- a/test/cminor/sha1.cmp +++ b/test/cminor/sha1.cmp @@ -3,6 +3,9 @@ /* To be preprocessed by cpp -P */ +extern "memcpy" : int -> int -> int -> void +extern "memset" : int -> int -> int -> void + #define ARCH_BIG_ENDIAN #define rol1(x) (((x) << 1) | ((x) >>u 31)) @@ -12,7 +15,7 @@ "SHA1_copy_and_swap"(src, dst, numwords) : int -> int -> int -> void { #ifdef ARCH_BIG_ENDIAN - "memcpy_static"(dst, src, numwords * 4) : int -> int -> int -> void; + "memcpy"(dst, src, numwords * 4) : int -> int -> int -> void; #else var s, d, a, b; s = src; @@ -134,12 +137,12 @@ if (context_numbytes(ctx) != 0) { t = 64 - context_numbytes(ctx); if (len <u t) { - "memcpy_static"(context_buffer(ctx) + context_numbytes(ctx), data, len) + "memcpy"(context_buffer(ctx) + context_numbytes(ctx), data, len) : int -> int -> int -> void; context_numbytes(ctx) = context_numbytes(ctx) + len; return; } - "memcpy_static"(context_buffer(ctx) + context_numbytes(ctx), data, t) + "memcpy"(context_buffer(ctx) + context_numbytes(ctx), data, t) : int -> int -> int -> void; "SHA1_transform"(ctx) : int -> void; data = data + t; @@ -148,14 +151,14 @@ /* Munge data in 64-byte chunks */ {{ loop { if (! (len >=u 64)) exit; - "memcpy_static"(context_buffer(ctx), data, 64) + "memcpy"(context_buffer(ctx), data, 64) : int -> int -> int -> void; "SHA1_transform"(ctx) : int -> void; data = data + 64; len = len - 64; } }} /* Save remaining data */ - "memcpy_static"(context_buffer(ctx), data, len) + "memcpy"(context_buffer(ctx), data, len) : int -> int -> int -> void; context_numbytes(ctx) = len; } @@ -170,13 +173,13 @@ /* If we do not have room for the length (8 bytes), pad to 64 bytes with zeroes and munge the data block */ if (i > 56) { - "memset_static"(context_buffer(ctx) + i, 0, 64 - i) + "memset"(context_buffer(ctx) + i, 0, 64 - i) : int -> int -> int -> void; "SHA1_transform"(ctx) : int -> void; i = 0; } /* Pad to byte 56 with zeroes */ - "memset_static"(context_buffer(ctx) + i, 0, 56 - i) + "memset"(context_buffer(ctx) + i, 0, 56 - i) : int -> int -> int -> void; /* Add length in big-endian */ "SHA1_copy_and_swap"(context_length(ctx), context_buffer(ctx) + 56, 2) diff --git a/test/harness/mainlists.c b/test/harness/mainlists.c new file mode 100644 index 0000000..ef11f6e --- /dev/null +++ b/test/harness/mainlists.c @@ -0,0 +1,40 @@ +#include <stdio.h> +#include <stddef.h> +#include <stdlib.h> + +void * compcert_alloc(int sz) +{ + return malloc(sz); +} + +struct cons { int hd; struct cons * tl; }; +typedef struct cons * list; + +extern list buildlist(int n); +extern list reverselist(list l); + +int checklist(int n, list l) +{ + int i; + for (i = 0; i <= n; i++) { + if (l == NULL) return 0; + if (l->hd != i) return 0; + l = l->tl; + } + return (l == NULL); +} + +int main(int argc, char ** argv) +{ + int n; + + if (argc >= 2) n = atoi(argv[1]); else n = 10; + if (checklist(n, reverselist(buildlist(n)))) { + printf("OK\n"); + return 0; + } else { + printf("Bug!\n"); + return 2; + } +} + |