diff options
56 files changed, 13619 insertions, 6180 deletions
@@ -36,6 +36,8 @@ backend/Tailcall.vo: backend/Tailcall.v lib/Coqlib.vo lib/Maps.vo common/AST.vo backend/Tailcallproof.vo: backend/Tailcallproof.v lib/Coqlib.vo lib/Maps.vo common/AST.vo lib/Integers.vo common/Values.vo common/Memory.vo $(ARCH)/Op.vo common/Events.vo common/Globalenvs.vo common/Smallstep.vo backend/Registers.vo backend/RTL.vo backend/Conventions.vo backend/Tailcall.vo backend/RTLtyping.vo: backend/RTLtyping.v lib/Coqlib.vo common/Errors.vo lib/Maps.vo common/AST.vo $(ARCH)/Op.vo backend/Registers.vo common/Globalenvs.vo common/Values.vo common/Memory.vo lib/Integers.vo common/Events.vo common/Smallstep.vo backend/RTL.vo backend/Conventions.vo backend/Kildall.vo: backend/Kildall.v lib/Coqlib.vo lib/Iteration.vo lib/Maps.vo lib/Lattice.vo lib/Ordered.vo +backend/CastOptim.vo: backend/CastOptim.v lib/Coqlib.vo lib/Maps.vo common/AST.vo lib/Integers.vo lib/Floats.vo common/Values.vo common/Globalenvs.vo $(ARCH)/Op.vo backend/Registers.vo backend/RTL.vo lib/Lattice.vo backend/Kildall.vo +backend/CastOptimproof.vo: backend/CastOptimproof.v lib/Coqlib.vo lib/Maps.vo common/AST.vo lib/Integers.vo lib/Floats.vo common/Values.vo common/Events.vo common/Memory.vo common/Globalenvs.vo common/Smallstep.vo $(ARCH)/Op.vo backend/Registers.vo backend/RTL.vo lib/Lattice.vo backend/Kildall.vo backend/CastOptim.vo $(ARCH)/ConstpropOp.vo: $(ARCH)/ConstpropOp.v lib/Coqlib.vo common/AST.vo lib/Integers.vo lib/Floats.vo common/Values.vo $(ARCH)/Op.vo backend/Registers.vo backend/Constprop.vo: backend/Constprop.v lib/Coqlib.vo lib/Maps.vo common/AST.vo lib/Integers.vo lib/Floats.vo common/Values.vo common/Globalenvs.vo $(ARCH)/Op.vo backend/Registers.vo backend/RTL.vo lib/Lattice.vo backend/Kildall.vo $(ARCH)/ConstpropOp.vo $(ARCH)/ConstpropOpproof.vo: $(ARCH)/ConstpropOpproof.v lib/Coqlib.vo common/AST.vo lib/Integers.vo lib/Floats.vo common/Values.vo common/Memory.vo common/Globalenvs.vo $(ARCH)/Op.vo backend/Registers.vo backend/RTL.vo $(ARCH)/ConstpropOp.vo backend/Constprop.vo @@ -83,15 +85,17 @@ $(ARCH)/Asmgen.vo: $(ARCH)/Asmgen.v lib/Coqlib.vo lib/Maps.vo common/Errors.vo c $(ARCH)/Asmgenretaddr.vo: $(ARCH)/Asmgenretaddr.v lib/Coqlib.vo lib/Maps.vo common/AST.vo lib/Integers.vo lib/Floats.vo common/Values.vo common/Memory.vo common/Globalenvs.vo $(ARCH)/Op.vo backend/Locations.vo backend/Mach.vo $(ARCH)/Asm.vo $(ARCH)/Asmgen.vo $(ARCH)/Asmgenproof1.vo: $(ARCH)/Asmgenproof1.v lib/Coqlib.vo lib/Maps.vo common/AST.vo lib/Integers.vo lib/Floats.vo common/Values.vo common/Memory.vo common/Globalenvs.vo $(ARCH)/Op.vo backend/Locations.vo backend/Mach.vo backend/Machconcr.vo backend/Machtyping.vo $(ARCH)/Asm.vo $(ARCH)/Asmgen.vo backend/Conventions.vo $(ARCH)/Asmgenproof.vo: $(ARCH)/Asmgenproof.v lib/Coqlib.vo lib/Maps.vo common/Errors.vo common/AST.vo lib/Integers.vo lib/Floats.vo common/Values.vo common/Memory.vo common/Events.vo common/Globalenvs.vo common/Smallstep.vo $(ARCH)/Op.vo backend/Locations.vo backend/Conventions.vo backend/Mach.vo backend/Machconcr.vo backend/Machtyping.vo $(ARCH)/Asm.vo $(ARCH)/Asmgen.vo $(ARCH)/Asmgenretaddr.vo $(ARCH)/Asmgenproof1.vo -cfrontend/Csyntax.vo: cfrontend/Csyntax.v lib/Coqlib.vo common/Errors.vo lib/Integers.vo lib/Floats.vo common/AST.vo +cfrontend/Csyntax.vo: cfrontend/Csyntax.v lib/Coqlib.vo common/Errors.vo lib/Integers.vo lib/Floats.vo common/Values.vo common/AST.vo cfrontend/Csem.vo: cfrontend/Csem.v lib/Coqlib.vo common/Errors.vo lib/Maps.vo lib/Integers.vo lib/Floats.vo common/Values.vo common/AST.vo common/Memory.vo common/Events.vo common/Globalenvs.vo cfrontend/Csyntax.vo common/Smallstep.vo -cfrontend/Ctyping.vo: cfrontend/Ctyping.v lib/Coqlib.vo lib/Maps.vo common/AST.vo cfrontend/Csyntax.vo -cfrontend/Cshmgen.vo: cfrontend/Cshmgen.v lib/Coqlib.vo common/Errors.vo lib/Integers.vo lib/Floats.vo common/AST.vo cfrontend/Csyntax.vo backend/Cminor.vo cfrontend/Csharpminor.vo -cfrontend/Cshmgenproof1.vo: cfrontend/Cshmgenproof1.v lib/Coqlib.vo common/Errors.vo lib/Maps.vo lib/Integers.vo lib/Floats.vo common/AST.vo common/Values.vo common/Events.vo common/Memory.vo common/Globalenvs.vo cfrontend/Csyntax.vo cfrontend/Csem.vo cfrontend/Ctyping.vo backend/Cminor.vo cfrontend/Csharpminor.vo cfrontend/Cshmgen.vo -cfrontend/Cshmgenproof2.vo: cfrontend/Cshmgenproof2.v lib/Coqlib.vo common/Errors.vo lib/Maps.vo lib/Integers.vo lib/Floats.vo common/AST.vo common/Values.vo common/Events.vo common/Memory.vo common/Globalenvs.vo cfrontend/Csyntax.vo cfrontend/Csem.vo cfrontend/Ctyping.vo backend/Cminor.vo cfrontend/Csharpminor.vo cfrontend/Cshmgen.vo cfrontend/Cshmgenproof1.vo -cfrontend/Cshmgenproof3.vo: cfrontend/Cshmgenproof3.v lib/Coqlib.vo common/Errors.vo lib/Maps.vo lib/Integers.vo lib/Floats.vo common/AST.vo common/Values.vo common/Events.vo common/Memory.vo common/Globalenvs.vo common/Smallstep.vo cfrontend/Csyntax.vo cfrontend/Csem.vo cfrontend/Ctyping.vo backend/Cminor.vo cfrontend/Csharpminor.vo cfrontend/Cshmgen.vo cfrontend/Cshmgenproof1.vo cfrontend/Cshmgenproof2.vo +cfrontend/Cstrategy.vo: cfrontend/Cstrategy.v lib/Axioms.vo lib/Coqlib.vo common/Errors.vo lib/Maps.vo lib/Integers.vo lib/Floats.vo common/Values.vo common/AST.vo common/Memory.vo common/Events.vo common/Globalenvs.vo common/Smallstep.vo common/Determinism.vo cfrontend/Csyntax.vo cfrontend/Csem.vo +cfrontend/SimplExpr.vo: cfrontend/SimplExpr.v lib/Coqlib.vo common/Errors.vo lib/Integers.vo lib/Floats.vo common/Values.vo common/AST.vo cfrontend/Csyntax.vo cfrontend/Clight.vo +cfrontend/SimplExprspec.vo: cfrontend/SimplExprspec.v lib/Coqlib.vo common/Errors.vo lib/Maps.vo lib/Integers.vo lib/Floats.vo common/Values.vo common/Memory.vo common/AST.vo cfrontend/Csyntax.vo cfrontend/Clight.vo cfrontend/SimplExpr.vo +cfrontend/SimplExprproof.vo: cfrontend/SimplExprproof.v lib/Axioms.vo lib/Coqlib.vo lib/Maps.vo common/AST.vo common/Errors.vo lib/Integers.vo common/Values.vo common/Memory.vo common/Events.vo common/Smallstep.vo common/Globalenvs.vo common/Determinism.vo cfrontend/Csyntax.vo cfrontend/Csem.vo cfrontend/Cstrategy.vo cfrontend/Clight.vo cfrontend/SimplExpr.vo cfrontend/SimplExprspec.vo +cfrontend/Clight.vo: cfrontend/Clight.v lib/Coqlib.vo common/Errors.vo lib/Maps.vo lib/Integers.vo lib/Floats.vo common/Values.vo common/AST.vo common/Memory.vo common/Events.vo common/Globalenvs.vo common/Smallstep.vo cfrontend/Csyntax.vo cfrontend/Csem.vo +cfrontend/Cshmgen.vo: cfrontend/Cshmgen.v lib/Coqlib.vo common/Errors.vo lib/Integers.vo lib/Floats.vo common/AST.vo cfrontend/Csyntax.vo cfrontend/Clight.vo backend/Cminor.vo cfrontend/Csharpminor.vo +cfrontend/Cshmgenproof.vo: cfrontend/Cshmgenproof.v lib/Coqlib.vo common/Errors.vo lib/Maps.vo lib/Integers.vo lib/Floats.vo common/AST.vo common/Values.vo common/Events.vo common/Memory.vo common/Globalenvs.vo common/Smallstep.vo cfrontend/Csyntax.vo cfrontend/Csem.vo cfrontend/Clight.vo backend/Cminor.vo cfrontend/Csharpminor.vo cfrontend/Cshmgen.vo cfrontend/Csharpminor.vo: cfrontend/Csharpminor.v lib/Coqlib.vo lib/Maps.vo common/AST.vo lib/Integers.vo lib/Floats.vo common/Values.vo common/Memory.vo common/Events.vo common/Globalenvs.vo backend/Cminor.vo common/Smallstep.vo cfrontend/Cminorgen.vo: cfrontend/Cminorgen.v lib/Coqlib.vo common/Errors.vo lib/Maps.vo lib/Ordered.vo common/AST.vo lib/Integers.vo common/Memdata.vo cfrontend/Csharpminor.vo backend/Cminor.vo cfrontend/Cminorgenproof.vo: cfrontend/Cminorgenproof.v lib/Coqlib.vo lib/Intv.vo common/Errors.vo lib/Maps.vo common/AST.vo lib/Integers.vo lib/Floats.vo common/Values.vo common/Memdata.vo common/Memory.vo common/Events.vo common/Globalenvs.vo common/Smallstep.vo common/Switch.vo cfrontend/Csharpminor.vo backend/Cminor.vo cfrontend/Cminorgen.vo -driver/Compiler.vo: driver/Compiler.v lib/Axioms.vo lib/Coqlib.vo lib/Maps.vo common/Errors.vo common/AST.vo common/Values.vo common/Smallstep.vo cfrontend/Csyntax.vo cfrontend/Csem.vo cfrontend/Csharpminor.vo backend/Cminor.vo backend/CminorSel.vo backend/RTL.vo backend/LTL.vo backend/LTLin.vo backend/Linear.vo backend/Mach.vo $(ARCH)/Asm.vo cfrontend/Cshmgen.vo cfrontend/Cminorgen.vo backend/Selection.vo backend/RTLgen.vo backend/Tailcall.vo backend/Constprop.vo backend/CSE.vo backend/Allocation.vo backend/Tunneling.vo backend/Linearize.vo backend/Reload.vo backend/Stacking.vo $(ARCH)/Asmgen.vo cfrontend/Ctyping.vo backend/RTLtyping.vo backend/LTLtyping.vo backend/LTLintyping.vo backend/Lineartyping.vo backend/Machtyping.vo cfrontend/Cshmgenproof3.vo cfrontend/Cminorgenproof.vo backend/Selectionproof.vo backend/RTLgenproof.vo backend/Tailcallproof.vo backend/Constpropproof.vo backend/CSEproof.vo backend/Allocproof.vo backend/Alloctyping.vo backend/Tunnelingproof.vo backend/Tunnelingtyping.vo backend/Linearizeproof.vo backend/Linearizetyping.vo backend/Reloadproof.vo backend/Reloadtyping.vo backend/Stackingproof.vo backend/Stackingtyping.vo backend/Machabstr2concr.vo $(ARCH)/Asmgenproof.vo -driver/Complements.vo: driver/Complements.v lib/Coqlib.vo common/AST.vo lib/Integers.vo common/Values.vo common/Events.vo common/Globalenvs.vo common/Smallstep.vo common/Determinism.vo cfrontend/Csyntax.vo cfrontend/Csem.vo $(ARCH)/Asm.vo driver/Compiler.vo common/Errors.vo +driver/Compiler.vo: driver/Compiler.v lib/Axioms.vo lib/Coqlib.vo lib/Maps.vo common/Errors.vo common/AST.vo common/Values.vo common/Smallstep.vo cfrontend/Csyntax.vo cfrontend/Csem.vo cfrontend/Cstrategy.vo cfrontend/Clight.vo cfrontend/Csharpminor.vo backend/Cminor.vo backend/CminorSel.vo backend/RTL.vo backend/LTL.vo backend/LTLin.vo backend/Linear.vo backend/Mach.vo $(ARCH)/Asm.vo cfrontend/SimplExpr.vo cfrontend/Cshmgen.vo cfrontend/Cminorgen.vo backend/Selection.vo backend/RTLgen.vo backend/Tailcall.vo backend/CastOptim.vo backend/Constprop.vo backend/CSE.vo backend/Allocation.vo backend/Tunneling.vo backend/Linearize.vo backend/Reload.vo backend/Stacking.vo $(ARCH)/Asmgen.vo backend/RTLtyping.vo backend/LTLtyping.vo backend/LTLintyping.vo backend/Lineartyping.vo backend/Machtyping.vo cfrontend/SimplExprproof.vo cfrontend/Cshmgenproof.vo cfrontend/Cminorgenproof.vo backend/Selectionproof.vo backend/RTLgenproof.vo backend/Tailcallproof.vo backend/CastOptimproof.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/Reloadproof.vo backend/Reloadtyping.vo backend/Stackingproof.vo backend/Stackingtyping.vo backend/Machabstr2concr.vo $(ARCH)/Asmgenproof.vo +driver/Complements.vo: driver/Complements.v lib/Coqlib.vo common/AST.vo lib/Integers.vo common/Values.vo common/Events.vo common/Globalenvs.vo common/Smallstep.vo common/Determinism.vo cfrontend/Csyntax.vo cfrontend/Csem.vo cfrontend/Cstrategy.vo $(ARCH)/Asm.vo driver/Compiler.vo common/Errors.vo @@ -51,6 +51,7 @@ BACKEND=\ Tailcall.v Tailcallproof.v \ RTLtyping.v \ Kildall.v \ + CastOptim.v CastOptimproof.v \ ConstpropOp.v Constprop.v ConstpropOpproof.v Constpropproof.v \ CSE.v CSEproof.v \ Machregs.v Locations.v Conventions1.v Conventions.v LTL.v LTLtyping.v \ @@ -68,8 +69,9 @@ BACKEND=\ # C front-end modules (in cfrontend/) -CFRONTEND=Csyntax.v Csem.v Ctyping.v Cshmgen.v \ - Cshmgenproof1.v Cshmgenproof2.v Cshmgenproof3.v \ +CFRONTEND=Csyntax.v Csem.v Cstrategy.v \ + SimplExpr.v SimplExprspec.v SimplExprproof.v \ + Clight.v Cshmgen.v Cshmgenproof.v \ Csharpminor.v Cminorgen.v Cminorgenproof.v # Putting everything together (in driver/) @@ -79,7 +79,7 @@ Inductive operation : Type := | Osub: operation (**r [rd = r1 - r2] *) | Osubshift: shift -> operation (**r [rd = r1 - shifted r2] *) | Orsubshift: shift -> operation (**r [rd = shifted r2 - r1] *) - | Orsubimm: int -> operation (**r [rd = r1 - n] *) + | Orsubimm: int -> operation (**r [rd = n - r1] *) | Omul: operation (**r [rd = r1 * r2] *) | Odiv: operation (**r [rd = r1 / r2] (signed) *) | Odivu: operation (**r [rd = r1 / r2] (unsigned) *) diff --git a/arm/PrintOp.ml b/arm/PrintOp.ml new file mode 100644 index 0000000..75d8593 --- /dev/null +++ b/arm/PrintOp.ml @@ -0,0 +1,115 @@ +(* *********************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Xavier Leroy, INRIA Paris-Rocquencourt *) +(* *) +(* Copyright Institut National de Recherche en Informatique et en *) +(* Automatique. All rights reserved. This file is distributed *) +(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* *) +(* *********************************************************************) + +(** Pretty-printing of operators, conditions, addressing modes *) + +open Format +open Camlcoq +open Integers +open Op + +let comparison_name = function + | Ceq -> "==" + | Cne -> "!=" + | Clt -> "<" + | Cle -> "<=" + | Cgt -> ">" + | Cge -> ">=" + +let shift pp = function + | Slsl a -> fprintf pp "<< %ld" (camlint_of_coqint a) + | Slsr a -> fprintf pp ">>u %ld" (camlint_of_coqint a) + | Sasr a -> fprintf pp ">>s %ld" (camlint_of_coqint a) + | Sror a -> fprintf pp "ror %ld" (camlint_of_coqint a) + +let print_condition reg pp = function + | (Ccomp c, [r1;r2]) -> + fprintf pp "%a %ss %a" reg r1 (comparison_name c) reg r2 + | (Ccompu c, [r1;r2]) -> + fprintf pp "%a %su %a" reg r1 (comparison_name c) reg r2 + | (Ccompshift(c, s), [r1;r2]) -> + fprintf pp "%a %ss %a %a" reg r1 (comparison_name c) reg r2 shift s + | (Ccompu(c, s), [r1;r2]) -> + fprintf pp "%a %su %a %a" reg r1 (comparison_name c) reg r2 shift s + | (Ccompimm(c, n), [r1]) -> + fprintf pp "%a %ss %ld" reg r1 (comparison_name c) (camlint_of_coqint n) + | (Ccompuimm(c, n), [r1]) -> + fprintf pp "%a %su %ld" reg r1 (comparison_name c) (camlint_of_coqint n) + | (Ccompf c, [r1;r2]) -> + fprintf pp "%a %sf %a" reg r1 (comparison_name c) reg r2 + | (Cnotcompf c, [r1;r2]) -> + fprintf pp "%a not(%sf) %a" reg r1 (comparison_name c) reg r2 + | _ -> + fprintf pp "<bad condition>" + +let print_operation reg pp = function + | Omove, [r1] -> reg pp r1 + | Ointconst n, [] -> fprintf pp "%ld" (camlint_of_coqint n) + | Ofloatconst n, [] -> fprintf pp "%F" n + | Oaddrsymbol(id, ofs), [] -> + fprintf pp "\"%s\" + %ld" (extern_atom id) (camlint_of_coqint ofs) + | Oaddrstack ofs, [] -> + fprintf pp "stack(%ld)" (camlint_of_coqint ofs) + | Ocast8signed, [r1] -> fprintf pp "int8signed(%a)" reg r1 + | Ocast8unsigned, [r1] -> fprintf pp "int8unsigned(%a)" reg r1 + | Ocast16signed, [r1] -> fprintf pp "int16signed(%a)" reg r1 + | Ocast16unsigned, [r1] -> fprintf pp "int16unsigned(%a)" reg r1 + | Oadd, [r1;r2] -> fprintf pp "%a + %a" reg r1 reg r2 + | Oaddshift s, [r1;r2] -> fprintf pp "%a + %a %a" reg r1 reg r2 shift s + | Oaddimm n, [r1] -> fprintf pp "%a + %ld" reg r1 (camlint_of_coqint n) + | Osub, [r1;r2] -> fprintf pp "%a - %a" reg r1 reg r2 + | Osubshift s, [r1;r2] -> fprintf pp "%a - %a %a" reg r1 reg r2 shift s + | Osubrshift s, [r1;r2] -> fprintf pp "%a %a - %a" reg r2 shift s reg r1 + | Orsubimm n, [r1] -> fprintf pp "%ld - %a" (camlint_of_coqint n) reg r1 + | Omul, [r1;r2] -> fprintf pp "%a * %a" reg r1 reg r2 + | Odiv, [r1;r2] -> fprintf pp "%a /s %a" reg r1 reg r2 + | Odivu, [r1;r2] -> fprintf pp "%a /u %a" reg r1 reg r2 + | Oand, [r1;r2] -> fprintf pp "%a & %a" reg r1 reg r2 + | Oandshift s, [r1;r2] -> fprintf pp "%a & %a %a" reg r1 reg r2 shift s + | Oandimm n, [r1] -> fprintf pp "%a & %ld" reg r1 (camlint_of_coqint n) + | Oor, [r1;r2] -> fprintf pp "%a | %a" reg r1 reg r2 + | Oorshift s, [r1;r2] -> fprintf pp "%a | %a %a" reg r1 reg r2 shift s + | Oorimm n, [r1] -> fprintf pp "%a | %ld" reg r1 (camlint_of_coqint n) + | Oxor, [r1;r2] -> fprintf pp "%a ^ %a" reg r1 reg r2 + | Oxorshift s, [r1;r2] -> fprintf pp "%a ^ %a %a" reg r1 reg r2 shift s + | Oxorimm n, [r1] -> fprintf pp "%a ^ %ld" reg r1 (camlint_of_coqint n) + | Obic, [r1;r2] -> fprintf pp "%a & not %a" reg r1 reg r2 + | Obicshift s, [r1;r2] -> fprintf pp "%a & not(%a %a)" reg r1 reg r2 shift s + | Onot, [r1] -> fprintf pp "not(%a)" reg r1 + | Onotshift s, [r1] -> fprintf pp "not(%a %a)" reg r1 shift s + | Oshl, [r1;r2] -> fprintf pp "%a << %a" reg r1 reg r2 + | Oshr, [r1;r2] -> fprintf pp "%a >>s %a" reg r1 reg r2 + | Oshru, [r1;r2] -> fprintf pp "%a >>u %a" reg r1 reg r2 + | Oshift s, [r1] -> fprintf pp "%a %a" reg r1 shift s + | Oshrximm n, [r1] -> fprintf pp "%a >>x %ld" reg r1 (camlint_of_coqint n) + | Onegf, [r1] -> fprintf pp "negf(%a)" reg r1 + | Oabsf, [r1] -> fprintf pp "absf(%a)" reg r1 + | Oaddf, [r1;r2] -> fprintf pp "%a +f %a" reg r1 reg r2 + | Osubf, [r1;r2] -> fprintf pp "%a -f %a" reg r1 reg r2 + | Omulf, [r1;r2] -> fprintf pp "%a *f %a" reg r1 reg r2 + | Odivf, [r1;r2] -> fprintf pp "%a /f %a" reg r1 reg r2 + | Osingleoffloat, [r1] -> fprintf pp "singleoffloat(%a)" reg r1 + | Ointoffloat, [r1] -> fprintf pp "intoffloat(%a)" reg r1 + | Ointuoffloat, [r1] -> fprintf pp "intuoffloat(%a)" reg r1 + | Ofloatofint, [r1] -> fprintf pp "floatofint(%a)" reg r1 + | Ofloatofintu, [r1] -> fprintf pp "floatofintu(%a)" reg r1 + | Ocmp c, args -> print_condition reg pp (c, args) + | _ -> fprintf pp "<bad operator>" + +let print_addressing reg pp = function + | Aindexed n, [r1] -> fprintf pp "%a + %ld" reg r1 (camlint_of_coqint n) + | Aindexed2, [r1; r2] -> fprintf pp "%a + %a" reg r1 reg r2 + | Aindexed2shift s, [r1; r2] -> fprintf pp "%a + %a %a" reg r1 reg r2 shift s + | Ainstack ofs, [] -> fprintf pp "stack(%ld)" (camlint_of_coqint ofs) + | _ -> fprintf pp "<bad addressing>" + + diff --git a/backend/CastOptim.v b/backend/CastOptim.v new file mode 100644 index 0000000..3ae5ab0 --- /dev/null +++ b/backend/CastOptim.v @@ -0,0 +1,276 @@ +(* *********************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Xavier Leroy, INRIA Paris-Rocquencourt *) +(* *) +(* Copyright Institut National de Recherche en Informatique et en *) +(* Automatique. All rights reserved. This file is distributed *) +(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* *) +(* *********************************************************************) + +(** Elimination of redundant conversions to small numerical types. *) + +Require Import Coqlib. +Require Import Maps. +Require Import AST. +Require Import Integers. +Require Import Floats. +Require Import Values. +Require Import Globalenvs. +Require Import Op. +Require Import Registers. +Require Import RTL. +Require Import Lattice. +Require Import Kildall. + +(** * Static analysis *) + +(** Compile-time approximations *) + +Inductive approx : Type := + | Unknown (**r any value *) + | Int7 (**r [[0,127]] *) + | Int8s (**r [[-128,127] *) + | Int8u (**r [[0,255]] *) + | Int15 (**r [[0,32767]] *) + | Int16s (**r [[-32768,32767]] *) + | Int16u (**r [[0,65535] *) + | Single (**r single-precision float *) + | Novalue. (**r empty *) + +(** We equip this type of approximations with a semi-lattice structure. + The ordering is inclusion between the sets of values denoted by + the approximations. *) + +Module Approx <: SEMILATTICE_WITH_TOP. + Definition t := approx. + Definition eq (x y: t) := (x = y). + Definition eq_refl: forall x, eq x x := (@refl_equal t). + Definition eq_sym: forall x y, eq x y -> eq y x := (@sym_equal t). + Definition eq_trans: forall x y z, eq x y -> eq y z -> eq x z := (@trans_equal t). + Lemma eq_dec: forall (x y: t), {x=y} + {x<>y}. + Proof. + decide equality. + Qed. + Definition beq (x y: t) := if eq_dec x y then true else false. + Lemma beq_correct: forall x y, beq x y = true -> x = y. + Proof. + unfold beq; intros. destruct (eq_dec x y). auto. congruence. + Qed. + Definition ge (x y: t) : Prop := + match x, y with + | Unknown, _ => True + | _, Novalue => True + | Int7, Int7 => True + | Int8s, (Int7 | Int8s) => True + | Int8u, (Int7 | Int8u) => True + | Int15, (Int7 | Int8u | Int15) => True + | Int16s, (Int7 | Int8s | Int8u | Int15 | Int16s) => True + | Int16u, (Int7 | Int8u | Int15 | Int16u) => True + | Single, Single => True + | _, _ => False + end. + Lemma ge_refl: forall x y, eq x y -> ge x y. + Proof. + unfold eq, ge; intros. subst y. destruct x; auto. + Qed. + Lemma ge_trans: forall x y z, ge x y -> ge y z -> ge x z. + Proof. + unfold ge; intros. + destruct x; auto; (destruct y; auto; try contradiction; destruct z; auto). + Qed. + Lemma ge_compat: forall x x' y y', eq x x' -> eq y y' -> ge x y -> ge x' y'. + Proof. + unfold eq; intros. congruence. + Qed. + Definition bge (x y: t) : bool := + match x, y with + | Unknown, _ => true + | _, Novalue => true + | Int7, Int7 => true + | Int8s, (Int7 | Int8s) => true + | Int8u, (Int7 | Int8u) => true + | Int15, (Int7 | Int8u | Int15) => true + | Int16s, (Int7 | Int8s | Int8u | Int15 | Int16s) => true + | Int16u, (Int7 | Int8u | Int15 | Int16u) => true + | Single, Single => true + | _, _ => false + end. + Lemma bge_correct: forall x y, bge x y = true -> ge x y. + Proof. + destruct x; destruct y; simpl; auto || congruence. + Qed. + Definition bot := Novalue. + Definition top := Unknown. + Lemma ge_bot: forall x, ge x bot. + Proof. + unfold ge, bot. destruct x; auto. + Qed. + Lemma ge_top: forall x, ge top x. + Proof. + unfold ge, top. auto. + Qed. + Definition lub (x y: t) : t := + match x, y with + | Novalue, _ => y + | _, Novalue => x + | Int7, Int7 => Int7 + | Int7, Int8u => Int8u + | Int7, Int8s => Int8s + | Int7, Int15 => Int15 + | Int7, Int16u => Int16u + | Int7, Int16s => Int16s + | Int8u, (Int7|Int8u) => Int8u + | Int8u, Int15 => Int15 + | Int8u, Int16u => Int16u + | Int8u, Int16s => Int16s + | Int8s, (Int7|Int8s) => Int8s + | Int8s, (Int15|Int16s) => Int16s + | Int15, (Int7|Int8u|Int15) => Int15 + | Int15, Int16u => Int16u + | Int15, (Int8s|Int16s) => Int16s + | Int16u, (Int7|Int8u|Int15|Int16u) => Int16u + | Int16s, (Int7|Int8u|Int8s|Int15|Int16s) => Int16s + | Single, Single => Single + | _, _ => Unknown + end. + Lemma lub_commut: forall x y, eq (lub x y) (lub y x). + Proof. + unfold lub, eq; intros. + destruct x; destruct y; auto. + Qed. + Lemma ge_lub_left: forall x y, ge (lub x y) x. + Proof. + unfold lub, ge; intros. + destruct x; destruct y; auto. + Qed. +End Approx. + +Module D := LPMap Approx. + +(** Abstract interpretation of operators *) + +Definition approx_bitwise_op (v1 v2: approx) : approx := + if Approx.bge Int8u v1 && Approx.bge Int8u v2 then Int8u + else if Approx.bge Int16u v1 && Approx.bge Int16u v2 then Int16u + else Unknown. + +Function approx_operation (op: operation) (vl: list approx) : approx := + match op, vl with + | Omove, v1 :: nil => v1 + | Ointconst n, _ => + if Int.eq_dec n (Int.zero_ext 7 n) then Int7 + else if Int.eq_dec n (Int.zero_ext 8 n) then Int8u + else if Int.eq_dec n (Int.sign_ext 8 n) then Int8s + else if Int.eq_dec n (Int.zero_ext 15 n) then Int15 + else if Int.eq_dec n (Int.zero_ext 16 n) then Int16u + else if Int.eq_dec n (Int.sign_ext 16 n) then Int16s + else Unknown + | Ofloatconst n, _ => + if Float.eq_dec n (Float.singleoffloat n) then Single else Unknown + | Ocast8signed, _ => Int8s + | Ocast8unsigned, _ => Int8u + | Ocast16signed, _ => Int16s + | Ocast16unsigned, _ => Int16u + | Osingleoffloat, _ => Single + | Oand, v1 :: v2 :: nil => approx_bitwise_op v1 v2 + | Oor, v1 :: v2 :: nil => approx_bitwise_op v1 v2 + | Oxor, v1 :: v2 :: nil => approx_bitwise_op v1 v2 + (* Problem: what about and/or/xor immediate? and other + machine-specific operators? *) + | Ocmp c, _ => Int7 + | _, _ => Unknown + end. + +Definition approx_of_chunk (chunk: memory_chunk) := + match chunk with + | Mint8signed => Int8s + | Mint8unsigned => Int8u + | Mint16signed => Int16s + | Mint16unsigned => Int16u + | Mint32 => Unknown + | Mfloat32 => Single + | Mfloat64 => Unknown + end. + +(** Transfer function for the analysis *) + +Definition approx_reg (app: D.t) (r: reg) := + D.get r app. + +Definition approx_regs (app: D.t) (rl: list reg):= + List.map (approx_reg app) rl. + +Definition transfer (f: function) (pc: node) (before: D.t) := + match f.(fn_code)!pc with + | None => before + | Some i => + match i with + | Iop op args res s => + let a := approx_operation op (approx_regs before args) in + D.set res a before + | Iload chunk addr args dst s => + D.set dst (approx_of_chunk chunk) before + | Icall sig ros args res s => + D.set res Unknown before + | Ibuiltin ef args res s => + D.set res Unknown before + | _ => + before + end + end. + +(** The static analysis is a forward dataflow analysis. *) + +Module DS := Dataflow_Solver(D)(NodeSetForward). + +Definition analyze (f: RTL.function): PMap.t D.t := + match DS.fixpoint (successors f) (transfer f) + ((f.(fn_entrypoint), D.top) :: nil) with + | None => PMap.init D.top + | Some res => res + end. + +(** * Code transformation *) + +(** Cast operations that have no effect (because the argument is already + in the right range) are turned into moves. *) + +Function transf_operation (op: operation) (vl: list approx) : operation := + match op, vl with + | Ocast8signed, v :: nil => if Approx.bge Int8s v then Omove else op + | Ocast8unsigned, v :: nil => if Approx.bge Int8u v then Omove else op + | Ocast16signed, v :: nil => if Approx.bge Int16s v then Omove else op + | Ocast16unsigned, v :: nil => if Approx.bge Int16u v then Omove else op + | Osingleoffloat, v :: nil => if Approx.bge Single v then Omove else op + | _, _ => op + end. + +Definition transf_instr (app: D.t) (instr: instruction) := + match instr with + | Iop op args res s => + let op' := transf_operation op (approx_regs app args) in + Iop op' args res s + | _ => + instr + end. + +Definition transf_code (approxs: PMap.t D.t) (instrs: code) : code := + PTree.map (fun pc instr => transf_instr approxs!!pc instr) instrs. + +Definition transf_function (f: function) : function := + let approxs := analyze f in + mkfunction + f.(fn_sig) + f.(fn_params) + f.(fn_stacksize) + (transf_code approxs f.(fn_code)) + f.(fn_entrypoint). + +Definition transf_fundef (fd: fundef) : fundef := + AST.transf_fundef transf_function fd. + +Definition transf_program (p: program) : program := + transform_program transf_fundef p. diff --git a/backend/CastOptimproof.v b/backend/CastOptimproof.v new file mode 100644 index 0000000..60b10c2 --- /dev/null +++ b/backend/CastOptimproof.v @@ -0,0 +1,577 @@ +(* *********************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Xavier Leroy, INRIA Paris-Rocquencourt *) +(* *) +(* Copyright Institut National de Recherche en Informatique et en *) +(* Automatique. All rights reserved. This file is distributed *) +(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* *) +(* *********************************************************************) + +(** Correctness proof for cast optimization. *) + +Require Import Coqlib. +Require Import Maps. +Require Import AST. +Require Import Integers. +Require Import Floats. +Require Import Values. +Require Import Events. +Require Import Memory. +Require Import Globalenvs. +Require Import Smallstep. +Require Import Op. +Require Import Registers. +Require Import RTL. +Require Import Lattice. +Require Import Kildall. +Require Import CastOptim. + +(** * Correctness of the static analysis *) + +Section ANALYSIS. + +Definition val_match_approx (a: approx) (v: val) : Prop := + match a with + | Novalue => False + | Int7 => v = Val.zero_ext 8 v /\ v = Val.sign_ext 8 v + | Int8u => v = Val.zero_ext 8 v + | Int8s => v = Val.sign_ext 8 v + | Int15 => v = Val.zero_ext 16 v /\ v = Val.sign_ext 16 v + | Int16u => v = Val.zero_ext 16 v + | Int16s => v = Val.sign_ext 16 v + | Single => v = Val.singleoffloat v + | Unknown => True + end. + +Definition regs_match_approx (a: D.t) (rs: regset) : Prop := + forall r, val_match_approx (D.get r a) rs#r. + +Lemma regs_match_approx_top: + forall rs, regs_match_approx D.top rs. +Proof. + intros. red; intros. simpl. rewrite PTree.gempty. + unfold Approx.top, val_match_approx. auto. +Qed. + +Lemma val_match_approx_increasing: + forall a1 a2 v, + Approx.ge a1 a2 -> val_match_approx a2 v -> val_match_approx a1 v. +Proof. + assert (A: forall v, v = Val.zero_ext 8 v -> v = Val.zero_ext 16 v). + intros. rewrite H. + destruct v; simpl; auto. decEq. symmetry. + apply Int.zero_ext_widen. compute; auto. split. omega. compute; auto. + assert (B: forall v, v = Val.sign_ext 8 v -> v = Val.sign_ext 16 v). + intros. rewrite H. + destruct v; simpl; auto. decEq. symmetry. + apply Int.sign_ext_widen. compute; auto. split. omega. compute; auto. + assert (C: forall v, v = Val.zero_ext 8 v -> v = Val.sign_ext 16 v). + intros. rewrite H. + destruct v; simpl; auto. decEq. symmetry. + apply Int.sign_zero_ext_widen. compute; auto. split. omega. compute; auto. + intros. destruct a1; destruct a2; simpl in *; intuition; auto. +Qed. + +Lemma regs_match_approx_increasing: + forall a1 a2 rs, + D.ge a1 a2 -> regs_match_approx a2 rs -> regs_match_approx a1 rs. +Proof. + unfold D.ge, regs_match_approx. intros. + apply val_match_approx_increasing with (D.get r a2); auto. +Qed. + +Lemma regs_match_approx_update: + forall ra rs a v r, + val_match_approx a v -> + regs_match_approx ra rs -> + regs_match_approx (D.set r a ra) (rs#r <- v). +Proof. + intros; red; intros. rewrite Regmap.gsspec. + case (peq r0 r); intro. + subst r0. rewrite D.gss. auto. + rewrite D.gso; auto. +Qed. + +Lemma approx_regs_val_list: + forall ra rs rl, + regs_match_approx ra rs -> + list_forall2 val_match_approx (approx_regs ra rl) rs##rl. +Proof. + induction rl; simpl; intros. + constructor. + constructor. apply H. auto. +Qed. + +Lemma analyze_correct: + forall f pc rs pc' i, + f.(fn_code)!pc = Some i -> + In pc' (successors_instr i) -> + regs_match_approx (transfer f pc (analyze f)!!pc) rs -> + regs_match_approx (analyze f)!!pc' rs. +Proof. + intros until i. unfold analyze. + caseEq (DS.fixpoint (successors f) (transfer f) + ((fn_entrypoint f, D.top) :: nil)). + intros approxs; intros. + apply regs_match_approx_increasing with (transfer f pc approxs!!pc). + eapply DS.fixpoint_solution; eauto. + unfold successors_list, successors. rewrite PTree.gmap. rewrite H0. auto. + auto. + intros. rewrite PMap.gi. apply regs_match_approx_top. +Qed. + +Lemma analyze_correct_start: + forall f rs, + regs_match_approx (analyze f)!!(f.(fn_entrypoint)) rs. +Proof. + intros. unfold analyze. + caseEq (DS.fixpoint (successors f) (transfer f) + ((fn_entrypoint f, D.top) :: nil)). + intros approxs; intros. + apply regs_match_approx_increasing with D.top. + eapply DS.fixpoint_entry; eauto. auto with coqlib. + apply regs_match_approx_top. + intros. rewrite PMap.gi. apply regs_match_approx_top. +Qed. + +Lemma approx_bitwise_correct: + forall (sem_op: int -> int -> int) a1 n1 a2 n2, + (forall a b c, sem_op (Int.and a c) (Int.and b c) = Int.and (sem_op a b) c) -> + val_match_approx a1 (Vint n1) -> val_match_approx a2 (Vint n2) -> + val_match_approx (approx_bitwise_op a1 a2) (Vint (sem_op n1 n2)). +Proof. + intros. + assert (forall N, 0 < N < Z_of_nat Int.wordsize -> + sem_op (Int.zero_ext N n1) (Int.zero_ext N n2) = + Int.zero_ext N (sem_op (Int.zero_ext N n1) (Int.zero_ext N n2))). + intros. repeat rewrite Int.zero_ext_and; auto. rewrite H. + rewrite Int.and_assoc. rewrite Int.and_idem. auto. + unfold approx_bitwise_op. + caseEq (Approx.bge Int8u a1 && Approx.bge Int8u a2); intro EQ1. + destruct (andb_prop _ _ EQ1). + assert (V1: val_match_approx Int8u (Vint n1)). + eapply val_match_approx_increasing; eauto. apply Approx.bge_correct; eauto. + assert (V2: val_match_approx Int8u (Vint n2)). + eapply val_match_approx_increasing; eauto. apply Approx.bge_correct; eauto. + simpl in *. inversion V1; inversion V2; decEq. apply H2. compute; auto. + caseEq (Approx.bge Int16u a1 && Approx.bge Int16u a2); intro EQ2. + destruct (andb_prop _ _ EQ2). + assert (V1: val_match_approx Int16u (Vint n1)). + eapply val_match_approx_increasing; eauto. apply Approx.bge_correct; eauto. + assert (V2: val_match_approx Int16u (Vint n2)). + eapply val_match_approx_increasing; eauto. apply Approx.bge_correct; eauto. + simpl in *. inversion V1; inversion V2; decEq. apply H2. compute; auto. + exact I. +Qed. + +Lemma approx_operation_correct: + forall app rs (ge: genv) sp op args v, + regs_match_approx app rs -> + eval_operation ge sp op rs##args = Some v -> + val_match_approx (approx_operation op (approx_regs app args)) v. +Proof. + intros. destruct op; simpl; try (exact I). +(* move *) + destruct args; try (exact I). destruct args; try (exact I). + simpl. simpl in H0. inv H0. apply H. +(* const int *) + destruct args; simpl in H0; inv H0. + destruct (Int.eq_dec i (Int.zero_ext 7 i)). red; simpl. + split. + decEq. rewrite e. symmetry. apply Int.zero_ext_widen. compute; auto. split. omega. compute; auto. + decEq. rewrite e. symmetry. apply Int.sign_zero_ext_widen. compute; auto. compute; auto. + destruct (Int.eq_dec i (Int.zero_ext 8 i)). red; simpl; congruence. + destruct (Int.eq_dec i (Int.sign_ext 8 i)). red; simpl; congruence. + destruct (Int.eq_dec i (Int.zero_ext 15 i)). red; simpl. + split. + decEq. rewrite e. symmetry. apply Int.zero_ext_widen. compute; auto. split. omega. compute; auto. + decEq. rewrite e. symmetry. apply Int.sign_zero_ext_widen. compute; auto. compute; auto. + destruct (Int.eq_dec i (Int.zero_ext 16 i)). red; simpl; congruence. + destruct (Int.eq_dec i (Int.sign_ext 16 i)). red; simpl; congruence. + exact I. +(* const float *) + destruct args; simpl in H0; inv H0. + destruct (Float.eq_dec f (Float.singleoffloat f)). red; simpl; congruence. + exact I. +(* cast8signed *) + destruct args; simpl in H0; try congruence. + destruct args; simpl in H0; try congruence. + inv H0. destruct (rs#p); simpl; auto. + decEq. symmetry. apply Int.sign_ext_idem. compute; auto. +(* cast8unsigned *) + destruct args; simpl in H0; try congruence. + destruct args; simpl in H0; try congruence. + inv H0. destruct (rs#p); simpl; auto. + decEq. symmetry. apply Int.zero_ext_idem. compute; auto. +(* cast16signed *) + destruct args; simpl in H0; try congruence. + destruct args; simpl in H0; try congruence. + inv H0. destruct (rs#p); simpl; auto. + decEq. symmetry. apply Int.sign_ext_idem. compute; auto. +(* cast16unsigned *) + destruct args; simpl in H0; try congruence. + destruct args; simpl in H0; try congruence. + inv H0. destruct (rs#p); simpl; auto. + decEq. symmetry. apply Int.zero_ext_idem. compute; auto. +(* and *) + destruct args; try (exact I). + destruct args; try (exact I). + destruct args; try (exact I). + generalize (H p) (H p0). simpl in *. FuncInv. subst. + apply approx_bitwise_correct; auto. + intros. repeat rewrite Int.and_assoc. decEq. + rewrite (Int.and_commut b c). rewrite <- Int.and_assoc. rewrite Int.and_idem. auto. +(* or *) + destruct args; try (exact I). + destruct args; try (exact I). + destruct args; try (exact I). + generalize (H p) (H p0). simpl in *. FuncInv. subst. + apply approx_bitwise_correct; auto. + intros. rewrite (Int.and_commut a c); rewrite (Int.and_commut b c). + rewrite <- Int.and_or_distrib. apply Int.and_commut. +(* xor *) + destruct args; try (exact I). + destruct args; try (exact I). + destruct args; try (exact I). + generalize (H p) (H p0). simpl in *. FuncInv. subst. + apply approx_bitwise_correct; auto. + intros. rewrite (Int.and_commut a c); rewrite (Int.and_commut b c). + rewrite <- Int.and_xor_distrib. apply Int.and_commut. +(* singleoffloat *) + destruct args; simpl in H0; try congruence. + destruct args; simpl in H0; try congruence. + inv H0. destruct (rs#p); simpl; auto. + decEq. rewrite Float.singleoffloat_idem; auto. +(* comparison *) + simpl in H0. destruct (eval_condition c rs##args); try discriminate. + destruct b; inv H0; auto. +Qed. + +Lemma approx_of_chunk_correct: + forall chunk m a v, + Mem.loadv chunk m a = Some v -> + val_match_approx (approx_of_chunk chunk) v. +Proof. + intros. destruct a; simpl in H; try discriminate. + exploit Mem.load_cast; eauto. + destruct chunk; intros; simpl; auto. +Qed. + +End ANALYSIS. + +(** * Correctness of the code transformation *) + +Section PRESERVATION. + +Variable prog: program. +Let tprog := transf_program prog. +Let ge := Genv.globalenv prog. +Let tge := Genv.globalenv tprog. + +Lemma symbols_preserved: + forall (s: ident), Genv.find_symbol tge s = Genv.find_symbol ge s. +Proof. + intros; unfold ge, tge, tprog, transf_program. + apply Genv.find_symbol_transf. +Qed. + +Lemma varinfo_preserved: + forall b, Genv.find_var_info tge b = Genv.find_var_info ge b. +Proof. + intros; unfold ge, tge, tprog, transf_program. + apply Genv.find_var_info_transf. +Qed. + +Lemma functions_translated: + forall (v: val) (f: fundef), + Genv.find_funct ge v = Some f -> + Genv.find_funct tge v = Some (transf_fundef f). +Proof. + intros. + exact (Genv.find_funct_transf transf_fundef _ _ H). +Qed. + +Lemma function_ptr_translated: + forall (b: block) (f: fundef), + Genv.find_funct_ptr ge b = Some f -> + Genv.find_funct_ptr tge b = Some (transf_fundef f). +Proof. + intros. + exact (Genv.find_funct_ptr_transf transf_fundef _ _ H). +Qed. + +Lemma sig_function_translated: + forall f, + funsig (transf_fundef f) = funsig f. +Proof. + intros. destruct f; reflexivity. +Qed. + +Lemma find_function_translated: + forall ros rs fd, + find_function ge ros rs = Some fd -> + find_function tge ros rs = Some (transf_fundef fd). +Proof. + intros. destruct ros; simpl in *. + apply functions_translated; auto. + rewrite symbols_preserved. destruct (Genv.find_symbol ge i); try congruence. + apply function_ptr_translated; auto. +Qed. + +(** Correctness of [transf_operation]. *) + +Lemma transf_operation_correct: + forall (ge: genv) app rs sp op args v, + regs_match_approx app rs -> + eval_operation ge sp op rs##args = Some v -> + eval_operation ge sp (transf_operation op (approx_regs app args)) rs##args = Some v. +Proof. + intros until v. intro RMA. + assert (A: forall a r, Approx.bge a (approx_reg app r) = true -> val_match_approx a rs#r). + intros. eapply val_match_approx_increasing. apply Approx.bge_correct; eauto. apply RMA. +Opaque Approx.bge. + destruct op; simpl; auto. +(* cast8signed *) + destruct args; simpl; try congruence. destruct args; simpl; try congruence. + intros EQ; inv EQ. + caseEq (Approx.bge Int8s (approx_reg app p)); intros. + exploit A; eauto. unfold val_match_approx. simpl. congruence. + auto. +(* cast8unsigned *) + destruct args; simpl; try congruence. destruct args; simpl; try congruence. + intros EQ; inv EQ. + caseEq (Approx.bge Int8u (approx_reg app p)); intros. + exploit A; eauto. unfold val_match_approx. simpl. congruence. + auto. +(* cast8signed *) + destruct args; simpl; try congruence. destruct args; simpl; try congruence. + intros EQ; inv EQ. + caseEq (Approx.bge Int16s (approx_reg app p)); intros. + exploit A; eauto. unfold val_match_approx. simpl. congruence. + auto. +(* cast8unsigned *) + destruct args; simpl; try congruence. destruct args; simpl; try congruence. + intros EQ; inv EQ. + caseEq (Approx.bge Int16u (approx_reg app p)); intros. + exploit A; eauto. unfold val_match_approx. simpl. congruence. + auto. +(* singleoffloat *) + destruct args; simpl; try congruence. destruct args; simpl; try congruence. + intros EQ; inv EQ. + caseEq (Approx.bge Single (approx_reg app p)); intros. + exploit A; eauto. unfold val_match_approx. simpl. congruence. + auto. +Qed. + +(** Matching between states. *) + +Inductive match_stackframes: stackframe -> stackframe -> Prop := + match_stackframe_intro: + forall res sp pc rs f, + (forall v, regs_match_approx (analyze f)!!pc (rs#res <- v)) -> + match_stackframes + (Stackframe res f sp pc rs) + (Stackframe res (transf_function f) sp pc rs). + +Inductive match_states: state -> state -> Prop := + | match_states_intro: + forall s sp pc rs m f s' + (MATCH: regs_match_approx (analyze f)!!pc rs) + (STACKS: list_forall2 match_stackframes s s'), + match_states (State s f sp pc rs m) + (State s' (transf_function f) sp pc rs m) + | match_states_call: + forall s f args m s', + list_forall2 match_stackframes s s' -> + match_states (Callstate s f args m) + (Callstate s' (transf_fundef f) args m) + | match_states_return: + forall s s' v m, + list_forall2 match_stackframes s s' -> + match_states (Returnstate s v m) + (Returnstate s' v m). + +Ltac TransfInstr := + match goal with + | H1: (PTree.get ?pc ?c = Some ?instr), f: function |- _ => + cut ((transf_function f).(fn_code)!pc = Some(transf_instr (analyze f)!!pc instr)); + [ simpl transf_instr + | unfold transf_function, transf_code; simpl; rewrite PTree.gmap; + unfold option_map; rewrite H1; reflexivity ] + end. + +(** The proof of semantic preservation follows from the lock-step simulation lemma below. *) + +Lemma transf_step_correct: + forall s1 t s2, + step ge s1 t s2 -> + forall s1' (MS: match_states s1 s1'), + exists s2', step tge s1' t s2' /\ match_states s2 s2'. +Proof. + induction 1; intros; inv MS. + + (* Inop *) + econstructor; split. + TransfInstr; intro. eapply exec_Inop; eauto. + econstructor; eauto. + eapply analyze_correct with (pc := pc); eauto. + simpl; auto. + unfold transfer; rewrite H. auto. + + (* Iop *) + exists (State s' (transf_function f) sp pc' (rs#res <- v) m); split. + TransfInstr; intro. eapply exec_Iop; eauto. + apply transf_operation_correct; auto. + rewrite <- H0. apply eval_operation_preserved. exact symbols_preserved. + econstructor; eauto. + eapply analyze_correct with (pc := pc); eauto. + simpl; auto. + unfold transfer; rewrite H. apply regs_match_approx_update; auto. + eapply approx_operation_correct; eauto. + + (* Iload *) + econstructor; split. + TransfInstr; intro. eapply exec_Iload; eauto. + rewrite <- H0. apply eval_addressing_preserved. exact symbols_preserved. + econstructor; eauto. + eapply analyze_correct with (pc := pc); eauto. + simpl; auto. + unfold transfer; rewrite H. apply regs_match_approx_update; auto. + eapply approx_of_chunk_correct; eauto. + + (* Istore *) + econstructor; split. + TransfInstr; intro. eapply exec_Istore; eauto. + rewrite <- H0. apply eval_addressing_preserved. exact symbols_preserved. + econstructor; eauto. + eapply analyze_correct with (pc := pc); eauto. + simpl; auto. + unfold transfer; rewrite H. auto. + + (* Icall *) + TransfInstr; intro. + econstructor; split. + eapply exec_Icall. eauto. apply find_function_translated; eauto. + apply sig_function_translated; auto. + constructor; auto. constructor; auto. + econstructor; eauto. + intros. eapply analyze_correct; eauto. simpl; auto. + unfold transfer; rewrite H. + apply regs_match_approx_update; auto. exact I. + + (* Itailcall *) + TransfInstr; intro. + econstructor; split. + eapply exec_Itailcall. eauto. apply find_function_translated; eauto. + apply sig_function_translated; auto. + simpl; eauto. + constructor; auto. + + (* Ibuiltin *) + TransfInstr. intro. + exists (State s' (transf_function f) sp pc' (rs#res <- v) m'); split. + eapply exec_Ibuiltin; eauto. + eapply external_call_symbols_preserved; eauto. + exact symbols_preserved. exact varinfo_preserved. + econstructor; eauto. + eapply analyze_correct; eauto. simpl; auto. + unfold transfer; rewrite H. + apply regs_match_approx_update; auto. exact I. + + (* Icond, true *) + exists (State s' (transf_function f) sp ifso rs m); split. + TransfInstr. intro. + eapply exec_Icond_true; eauto. + econstructor; eauto. + eapply analyze_correct; eauto. + simpl; auto. + unfold transfer; rewrite H; auto. + + (* Icond, false *) + exists (State s' (transf_function f) sp ifnot rs m); split. + TransfInstr. intro. + eapply exec_Icond_false; eauto. + econstructor; eauto. + eapply analyze_correct; eauto. + simpl; auto. + unfold transfer; rewrite H; auto. + + (* Ijumptable *) + exists (State s' (transf_function f) sp pc' rs m); split. + TransfInstr. intro. + eapply exec_Ijumptable; eauto. + constructor; auto. + eapply analyze_correct; eauto. + simpl. eapply list_nth_z_in; eauto. + unfold transfer; rewrite H; auto. + + (* Ireturn *) + exists (Returnstate s' (regmap_optget or Vundef rs) m'); split. + eapply exec_Ireturn; eauto. TransfInstr; auto. + constructor; auto. + + (* internal function *) + simpl. unfold transf_function. + econstructor; split. + eapply exec_function_internal; simpl; eauto. + simpl. econstructor; eauto. + apply analyze_correct_start; auto. + + (* external function *) + simpl. econstructor; split. + eapply exec_function_external; eauto. + eapply external_call_symbols_preserved; eauto. + exact symbols_preserved. exact varinfo_preserved. + constructor; auto. + + (* return *) + inv H3. inv H1. + econstructor; split. + eapply exec_return; eauto. + econstructor; eauto. +Qed. + +Lemma transf_initial_states: + forall st1, initial_state prog st1 -> + exists st2, initial_state tprog st2 /\ match_states st1 st2. +Proof. + intros. inversion H. + exploit function_ptr_translated; eauto. intro FIND. + exists (Callstate nil (transf_fundef f) nil m0); split. + econstructor; eauto. + apply Genv.init_mem_transf; auto. + replace (prog_main tprog) with (prog_main prog). + rewrite symbols_preserved. eauto. + reflexivity. + rewrite <- H3. apply sig_function_translated. + constructor. constructor. +Qed. + +Lemma transf_final_states: + forall st1 st2 r, + match_states st1 st2 -> final_state st1 r -> final_state st2 r. +Proof. + intros. inv H0. inv H. inv H4. constructor. +Qed. + +(** The preservation of the observable behavior of the program then + follows, using the generic preservation theorem + [Smallstep.simulation_step_preservation]. *) + +Theorem transf_program_correct: + forall (beh: program_behavior), not_wrong beh -> + exec_program prog beh -> exec_program tprog beh. +Proof. + unfold exec_program; intros. + eapply simulation_step_preservation; eauto. + eexact transf_initial_states. + eexact transf_final_states. + exact transf_step_correct. +Qed. + +End PRESERVATION. + + diff --git a/backend/Coloringaux.ml b/backend/Coloringaux.ml index 63f2190..922506f 100644 --- a/backend/Coloringaux.ml +++ b/backend/Coloringaux.ml @@ -39,6 +39,7 @@ open Conventions type node = { ident: int; (*r unique identifier *) typ: typ; (*r its type *) + regname: reg option; (*r the RTL register it comes from *) regclass: int; (*r identifier of register class *) mutable spillcost: float; (*r estimated cost of spilling *) mutable adjlist: node list; (*r all nodes it interferes with *) @@ -84,14 +85,15 @@ and movestate = (*i let name_of_node n = - match n.color with - | Some(R r) -> + match n.color, n.regname with + | Some(R r), _ -> begin match Machregsaux.name_of_register r with | None -> "fixed-reg" | Some s -> s end - | Some(S _) -> "fixed-slot" - | None -> string_of_int n.ident + | Some(S _), _ -> "fixed-slot" + | None, Some r -> Printf.sprintf "x%ld" (camlint_of_positive r) + | None, None -> "unknown-reg" *) (* The algorithm manipulates partitions of the nodes and of the moves @@ -106,7 +108,7 @@ module DLinkNode = struct type t = node let make state = let rec empty = - { ident = 0; typ = Tint; regclass = 0; + { ident = 0; typ = Tint; regname = None; regclass = 0; adjlist = []; degree = 0; spillcost = 0.0; movelist = []; alias = None; color = None; nstate = state; nprev = empty; nnext = empty } @@ -363,7 +365,8 @@ let checkInvariants () = let nodeOfReg r typenv spillcosts = let ty = typenv r in incr nextRegIdent; - { ident = !nextRegIdent; typ = ty; regclass = class_of_type ty; + { ident = !nextRegIdent; typ = ty; + regname = Some r; regclass = class_of_type ty; spillcost = float(spillcosts r); adjlist = []; degree = 0; movelist = []; alias = None; color = None; @@ -373,7 +376,8 @@ let nodeOfReg r typenv spillcosts = let nodeOfMreg mr = let ty = mreg_type mr in incr nextRegIdent; - { ident = !nextRegIdent; typ = ty; regclass = class_of_type ty; + { ident = !nextRegIdent; typ = ty; + regname = None; regclass = class_of_type ty; spillcost = 0.0; adjlist = []; degree = 0; movelist = []; alias = None; color = Some (R mr); @@ -521,8 +525,10 @@ let canCoalesceBriggs u v = try iterAdjacent (consider v) u; iterAdjacent (consider u) v; + (*i Printf.printf " Briggs: OK\n"; *) true with Exit -> + (*i Printf.printf " Briggs: no\n"; *) false (* George's conservative coalescing criterion: all high-degree neighbors @@ -537,8 +543,11 @@ let canCoalesceGeorge u v = if t.degree < k || interfere t u then () else raise Exit in try - iterAdjacent isOK v; true + iterAdjacent isOK v; + (*i Printf.printf " George: OK\n"; *) + true with Exit -> + (*i Printf.printf " George: no\n"; *) false (* The combined coalescing criterion. [u] can be precolored, but @@ -603,7 +612,7 @@ let coalesce () = let m = DLinkMove.pick worklistMoves in let x = getAlias m.src and y = getAlias m.dst in let (u, v) = if y.nstate = Colored then (y, x) else (x, y) in - (*i Printf.printf "Attempt coalescing %s and %s\n" (name_of_node u) (name_of_node v);*) + (*i Printf.printf "Attempt coalescing %s and %s\n" (name_of_node u) (name_of_node v); *) if u == v then begin DLinkMove.insert m coalescedMoves; addWorkList u diff --git a/backend/PrintCminor.ml b/backend/PrintCminor.ml new file mode 100644 index 0000000..6a74506 --- /dev/null +++ b/backend/PrintCminor.ml @@ -0,0 +1,285 @@ +(* *********************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Xavier Leroy, INRIA Paris-Rocquencourt *) +(* *) +(* Copyright Institut National de Recherche en Informatique et en *) +(* Automatique. All rights reserved. This file is distributed *) +(* under the terms of the GNU General Public License as published by *) +(* the Free Software Foundation, either version 2 of the License, or *) +(* (at your option) any later version. This file is also distributed *) +(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* *) +(* *********************************************************************) + +(** Pretty-printer for Cminor *) + +open Format +open Camlcoq +open Datatypes +open BinPos +open Integers +open AST +open Cminor + +(* Precedences and associativity -- like those of C *) + +type associativity = LtoR | RtoL | NA + +let rec precedence = function + | Evar _ -> (16, NA) + | Econst _ -> (16, NA) + | Eunop _ -> (15, RtoL) + | Ebinop((Omul|Odiv|Odivu|Omod|Omodu|Omulf|Odivf), _, _) -> (13, LtoR) + | Ebinop((Oadd|Osub|Oaddf|Osubf), _, _) -> (12, LtoR) + | Ebinop((Oshl|Oshr|Oshru), _, _) -> (11, LtoR) + | Ebinop((Ocmp _|Ocmpu _|Ocmpf _), _, _) -> (10, LtoR) + | Ebinop(Oand, _, _) -> (8, LtoR) + | Ebinop(Oxor, _, _) -> (7, LtoR) + | Ebinop(Oor, _, _) -> (6, LtoR) + | Eload _ -> (15, RtoL) + | Econdition _ -> (3, RtoL) + +(* Naming idents. We assume we run after Cminorgen, which encoded idents. *) + +let ident_name id = + match id with + | Coq_xO n -> extern_atom n + | Coq_xI n -> Printf.sprintf "$%ld" (camlint_of_positive n) + | Coq_xH -> "$0" + +(* Naming operators *) + +let name_of_unop = function + | Ocast8unsigned -> "int8u" + | Ocast8signed -> "int8s" + | Ocast16unsigned -> "int16u" + | Ocast16signed -> "int16s" + | Onegint -> "-" + | Onotbool -> "!" + | Onotint -> "~" + | Onegf -> "-f" + | Oabsf -> "absf" + | Osingleoffloat -> "float32" + | Ointoffloat -> "intoffloat" + | Ointuoffloat -> "intuoffloat" + | Ofloatofint -> "floatofint" + | Ofloatofintu -> "floatofintu" + +let comparison_name = function + | Ceq -> "==" + | Cne -> "!=" + | Clt -> "<" + | Cle -> "<=" + | Cgt -> ">" + | Cge -> ">=" + +let name_of_binop = function + | Oadd -> "+" + | Osub -> "-" + | Omul -> "*" + | Odiv -> "/" + | Odivu -> "/u" + | Omod -> "%" + | Omodu -> "%u" + | Oand -> "&" + | Oor -> "|" + | Oxor -> "^" + | Oshl -> "<<" + | Oshr -> ">>" + | Oshru -> ">>u" + | Oaddf -> "+f" + | Osubf -> "-f" + | Omulf -> "*f" + | Odivf -> "/f" + | Ocmp c -> comparison_name c + | Ocmpu c -> comparison_name c ^ "u" + | Ocmpf c -> comparison_name c ^ "f" + +let name_of_chunk = function + | Mint8signed -> "int8signed" + | Mint8unsigned -> "int8unsigned" + | Mint16signed -> "int16signed" + | Mint16unsigned -> "int16unsigned" + | Mint32 -> "int32" + | Mfloat32 -> "float32" + | Mfloat64 -> "float64" + +(* Expressions *) + +let rec expr p (prec, e) = + let (prec', assoc) = precedence e in + let (prec1, prec2) = + if assoc = LtoR + then (prec', prec' + 1) + else (prec' + 1, prec') in + if prec' < prec + then fprintf p "@[<hov 2>(" + else fprintf p "@[<hov 2>"; + begin match e with + | Evar id -> + fprintf p "%s" (ident_name id) + | Econst(Ointconst n) -> + fprintf p "%ld" (camlint_of_coqint n) + | Econst(Ofloatconst f) -> + fprintf p "%F" f + | Econst(Oaddrsymbol(id, ofs)) -> + let ofs = camlint_of_coqint ofs in + if ofs = 0l + then fprintf p "\"%s\"" (extern_atom id) + else fprintf p "(\"%s\" + %ld)" (extern_atom id) ofs + | Econst(Oaddrstack n) -> + fprintf p "&%ld" (camlint_of_coqint n) + | Eunop(op, a1) -> + fprintf p "%s %a" (name_of_unop op) expr (prec', a1) + | Ebinop(op, a1, a2) -> + fprintf p "%a@ %s %a" + expr (prec1, a1) (name_of_binop op) expr (prec2, a2) + | Eload(chunk, a1) -> + fprintf p "%s[%a]" (name_of_chunk chunk) expr (0, a1) + | Econdition(a1, a2, a3) -> + fprintf p "%a@ ? %a@ : %a" expr (4, a1) expr (4, a2) expr (4, a3) + end; + if prec' < prec then fprintf p ")@]" else fprintf p "@]" + +let print_expr p e = expr p (0, e) + +let rec print_expr_list p (first, rl) = + match rl with + | [] -> () + | r :: rl -> + if not first then fprintf p ",@ "; + expr p (2, r); + print_expr_list p (false, rl) + +(* Types *) + +let name_of_type = function + | Tint -> "int" + | Tfloat -> "float" + +let rec print_sig p = function + | {sig_args = []; sig_res = None} -> fprintf p "void" + | {sig_args = []; sig_res = Some ty} -> fprintf p "%s" (name_of_type ty) + | {sig_args = t1 :: tl; sig_res = tres} -> + fprintf p "%s ->@ " (name_of_type t1); + print_sig p {sig_args = tl; sig_res = tres} + +(* Statements *) + +let rec print_stmt p s = + match s with + | Sskip -> + fprintf p "/*skip*/;" + | Sassign(id, e2) -> + fprintf p "@[<hv 2>%s =@ %a;@]" (ident_name id) print_expr e2 + | Sstore(chunk, a1, a2) -> + fprintf p "@[<hv 2>%s[%a] =@ %a;@]" + (name_of_chunk chunk) print_expr a1 print_expr a2 + | Scall(None, sg, e1, el) -> + fprintf p "@[<hv 2>%a@,(@[<hov 0>%a@])@ : @[<hov 0>%a@];@]" + print_expr e1 + print_expr_list (true, el) + print_sig sg + | Scall(Some id, sg, e1, el) -> + fprintf p "@[<hv 2>%s =@ %a@,(@[<hov 0>%a@]);@] : @[<hov 0>%a@]" + (ident_name id) + print_expr e1 + print_expr_list (true, el) + print_sig sg + | Stailcall(sg, e1, el) -> + fprintf p "@[<hv 2>tailcall %a@,(@[<hov 0>%a@])@ : @[<hov 0>%a@];@]" + print_expr e1 + print_expr_list (true, el) + print_sig sg + | Sseq(Sskip, s2) -> + print_stmt p s2 + | Sseq(s1, Sskip) -> + print_stmt p s1 + | Sseq(s1, s2) -> + fprintf p "%a@ %a" print_stmt s1 print_stmt s2 + | Sifthenelse(e, s1, Sskip) -> + fprintf p "@[<v 2>if (%a) {@ %a@;<0 -2>}@]" + print_expr e + print_stmt s1 + | Sifthenelse(e, Sskip, s2) -> + fprintf p "@[<v 2>if (! %a) {@ %a@;<0 -2>}@]" + expr (15, e) + print_stmt s2 + | Sifthenelse(e, s1, s2) -> + fprintf p "@[<v 2>if (%a) {@ %a@;<0 -2>} else {@ %a@;<0 -2>}@]" + print_expr e + print_stmt s1 + print_stmt s2 + | Sloop(s) -> + fprintf p "@[<v 2>loop {@ %a@;<0 -2>}@]" + print_stmt s + | Sblock(s) -> + fprintf p "@[<v 3>{{ %a@;<0 -3>}}@]" + print_stmt s + | Sexit n -> + fprintf p "exit %d;" (camlint_of_nat n + 1) + | Sswitch(e, cases, dfl) -> + fprintf p "@[<v 2>switch (%a) {" print_expr e; + List.iter + (fun (Coq_pair(n, x)) -> + fprintf p "@ case %ld: exit %d;\n" + (camlint_of_coqint n) (camlint_of_nat x)) + cases; + fprintf p "@ default: exit %d;\n" (camlint_of_nat dfl); + fprintf p "@;<0 -2>}@]" + | Sreturn None -> + fprintf p "return;" + | Sreturn (Some e) -> + fprintf p "return %a;" print_expr e + | Slabel(lbl, s1) -> + fprintf p "%s:@ %a" (extern_atom lbl) print_stmt s1 + | Sgoto lbl -> + fprintf p "goto %s;" (extern_atom lbl) + +(* Functions *) + +let rec print_varlist p (vars, first) = + match vars with + | [] -> () + | v1 :: vl -> + if not first then fprintf p ",@ "; + fprintf p "%s" (ident_name v1); + print_varlist p (vl, false) + +let print_function p id f = + fprintf p "@[<hov 4>\"%s\"(@[<hov 0>%a@])@ : @[<hov 0>%a@]@]@ " + (extern_atom id) + print_varlist (f.fn_params, true) + print_sig f.fn_sig; + fprintf p "@[<v 2>{@ "; + let stksz = camlint_of_z f.fn_stackspace in + if stksz <> 0l then + fprintf p "stack %ld;@ " stksz; + if f.fn_vars <> [] then + fprintf p "var @[<hov 0>%a;@]@ " print_varlist (f.fn_vars, true); + print_stmt p f.fn_body; + fprintf p "@;<0 -2>}@]@ " + +let print_fundef p (Coq_pair(id, fd)) = + match fd with + | External ef -> + () (* Todo? *) + | Internal f -> + print_function p id f + +let print_program p prog = + fprintf p "@[<v 0>"; + List.iter (print_fundef p) prog.prog_funct; + fprintf p "@]@." + +let destination : string option ref = ref None + +let print_if prog = + match !destination with + | None -> () + | Some f -> + let oc = open_out f in + print_program (formatter_of_out_channel oc) prog; + close_out oc diff --git a/backend/PrintLTLin.ml b/backend/PrintLTLin.ml new file mode 100644 index 0000000..0f38a3f --- /dev/null +++ b/backend/PrintLTLin.ml @@ -0,0 +1,130 @@ +(* *********************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Xavier Leroy, INRIA Paris-Rocquencourt *) +(* *) +(* Copyright Institut National de Recherche en Informatique et en *) +(* Automatique. All rights reserved. This file is distributed *) +(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* *) +(* *********************************************************************) + +(** Pretty-printer for LTLin code *) + +open Format +open Camlcoq +open Datatypes +open Maps +open AST +open Integers +open Locations +open Machregsaux +open LTLin +open PrintOp + +let name_of_chunk = function + | Mint8signed -> "int8signed" + | Mint8unsigned -> "int8unsigned" + | Mint16signed -> "int16signed" + | Mint16unsigned -> "int16unsigned" + | Mint32 -> "int32" + | Mfloat32 -> "float32" + | Mfloat64 -> "float64" + +let name_of_type = function + | Tint -> "int" + | Tfloat -> "float" + +let reg pp loc = + match loc with + | R r -> + begin match name_of_register r with + | Some s -> fprintf pp "%s" s + | None -> fprintf pp "<unknown reg>" + end + | S (Local(ofs, ty)) -> + fprintf pp "local(%s,%ld)" (name_of_type ty) (camlint_of_coqint ofs) + | S (Incoming(ofs, ty)) -> + fprintf pp "incoming(%s,%ld)" (name_of_type ty) (camlint_of_coqint ofs) + | S (Outgoing(ofs, ty)) -> + fprintf pp "outgoing(%s,%ld)" (name_of_type ty) (camlint_of_coqint ofs) + +let rec regs pp = function + | [] -> () + | [r] -> reg pp r + | r1::rl -> fprintf pp "%a, %a" reg r1 regs rl + +let ros pp = function + | Coq_inl r -> reg pp r + | Coq_inr s -> fprintf pp "\"%s\"" (extern_atom s) + +let print_instruction pp i = + match i with + | Lop(op, args, res) -> + fprintf pp "%a = %a@ " + reg res (PrintOp.print_operation reg) (op, args) + | Lload(chunk, addr, args, dst) -> + fprintf pp "%a = %s[%a]@ " + reg dst (name_of_chunk chunk) + (PrintOp.print_addressing reg) (addr, args) + | Lstore(chunk, addr, args, src) -> + fprintf pp "%s[%a] = %a@ " + (name_of_chunk chunk) + (PrintOp.print_addressing reg) (addr, args) + reg src + | Lcall(sg, fn, args, res) -> + fprintf pp "%a = %a(%a)@ " + reg res ros fn regs args + | Ltailcall(sg, fn, args) -> + fprintf pp "tailcall %a(%a)@ " + ros fn regs args + | Lbuiltin(ef, args, res) -> + fprintf pp "%a = builtin \"%s\"(%a)@ " + reg res (extern_atom ef.ef_id) regs args + | Llabel lbl -> + fprintf pp "%5ld: " (camlint_of_positive lbl) + | Lgoto lbl -> + fprintf pp "goto %ld@ " (camlint_of_positive lbl) + | Lcond(cond, args, lbl) -> + fprintf pp "if (%a) goto %ld@ " + (PrintOp.print_condition reg) (cond, args) + (camlint_of_positive lbl) + | Ljumptable(arg, tbl) -> + let tbl = Array.of_list tbl in + fprintf pp "@[<v 2>jumptable (%a)" reg arg; + for i = 0 to Array.length tbl - 1 do + fprintf pp "@ case %d: goto %ld" i (camlint_of_positive tbl.(i)) + done; + fprintf pp "@]@ " + | Lreturn None -> + fprintf pp "return@ " + | Lreturn (Some arg) -> + fprintf pp "return %a@ " reg arg + +let print_function pp f = + fprintf pp "@[<v 2>f(%a) {@ " regs f.fn_params; + List.iter (print_instruction pp) f.fn_code; + fprintf pp "@;<0 -2>}@]@." + +let print_fundef pp fd = + match fd with + | Internal f -> print_function pp f + | External _ -> () + +let destination : string option ref = ref None +let currpp : formatter option ref = ref None + +let print_if fd = + match !destination with + | None -> () + | Some f -> + let pp = + match !currpp with + | Some pp -> pp + | None -> + let oc = open_out f in + let pp = formatter_of_out_channel oc in + currpp := Some pp; + pp + in print_fundef pp fd diff --git a/backend/PrintRTL.ml b/backend/PrintRTL.ml index 6e8c578..62ee2c9 100644 --- a/backend/PrintRTL.ml +++ b/backend/PrintRTL.ml @@ -21,6 +21,8 @@ open Integers open RTL open PrintOp +(* Printing of RTL code *) + let name_of_chunk = function | Mint8signed -> "int8signed" | Mint8unsigned -> "int8unsigned" @@ -55,15 +57,19 @@ let print_instruction pp (pc, i) = then fprintf pp "nop@ " else fprintf pp "goto %ld@ " s | Iop(op, args, res, s) -> - fprintf pp "%a = %a@ " reg res (print_operator reg) (op, args); + fprintf pp "%a = %a@ " + reg res (PrintOp.print_operation reg) (op, args); print_succ pp s (Int32.pred pc) | Iload(chunk, addr, args, dst, s) -> fprintf pp "%a = %s[%a]@ " - reg dst (name_of_chunk chunk) (print_addressing reg) (addr, args); + reg dst (name_of_chunk chunk) + (PrintOp.print_addressing reg) (addr, args); print_succ pp s (Int32.pred pc) | Istore(chunk, addr, args, src, s) -> fprintf pp "%s[%a] = %a@ " - (name_of_chunk chunk) (print_addressing reg) (addr, args) reg src; + (name_of_chunk chunk) + (PrintOp.print_addressing reg) (addr, args) + reg src; print_succ pp s (Int32.pred pc) | Icall(sg, fn, args, res, s) -> fprintf pp "%a = %a(%a)@ " @@ -72,9 +78,13 @@ let print_instruction pp (pc, i) = | Itailcall(sg, fn, args) -> fprintf pp "tailcall %a(%a)@ " ros fn regs args + | Ibuiltin(ef, args, res, s) -> + fprintf pp "%a = builtin \"%s\"(%a)@ " + reg res (extern_atom ef.ef_id) regs args; + print_succ pp s (Int32.pred pc) | Icond(cond, args, s1, s2) -> fprintf pp "if (%a) goto %ld else goto %ld@ " - (print_condition reg) (cond, args) + (PrintOp.print_condition reg) (cond, args) (camlint_of_positive s1) (camlint_of_positive s2) | Ijumptable(arg, tbl) -> let tbl = Array.of_list tbl in @@ -101,11 +111,42 @@ let print_function pp f = List.iter (print_instruction pp) instrs; fprintf pp "@;<0 -2>}@]@." -let print_fundef fd = - begin match fd with - | Internal f -> print_function std_formatter f +let print_fundef pp fd = + match fd with + | Internal f -> print_function pp f | External _ -> () - end; - fd +let print_if optdest currpp fd = + match !optdest with + | None -> () + | Some f -> + let pp = + match !currpp with + | Some pp -> pp + | None -> + let oc = open_out f in + let pp = formatter_of_out_channel oc in + currpp := Some pp; + pp + in print_fundef pp fd + +let destination_rtl : string option ref = ref None +let pp_rtl : formatter option ref = ref None +let print_rtl = print_if destination_rtl pp_rtl + +let destination_tailcall : string option ref = ref None +let pp_tailcall : formatter option ref = ref None +let print_tailcall = print_if destination_tailcall pp_tailcall + +let destination_castopt : string option ref = ref None +let pp_castopt : formatter option ref = ref None +let print_castopt = print_if destination_castopt pp_castopt + +let destination_constprop : string option ref = ref None +let pp_constprop : formatter option ref = ref None +let print_constprop = print_if destination_constprop pp_constprop + +let destination_cse : string option ref = ref None +let pp_cse : formatter option ref = ref None +let print_cse = print_if destination_cse pp_cse diff --git a/backend/RTLgen.v b/backend/RTLgen.v index aec2c86..b728829 100644 --- a/backend/RTLgen.v +++ b/backend/RTLgen.v @@ -363,6 +363,16 @@ Fixpoint alloc_regs (map: mapping) (al: exprlist) ret (r :: rl) end. +(** [alloc_optreg] is used for function calls. If a destination is + specified for the call, it is returned. Otherwise, a fresh + register is returned. *) + +Definition alloc_optreg (map: mapping) (dest: option ident) : mon reg := + match dest with + | Some id => find_var map id + | None => new_reg + end. + (** * RTL generation **) (** Insertion of a register-to-register move instruction. *) @@ -440,20 +450,6 @@ with transl_exprlist (map: mapping) (al: exprlist) (rl: list reg) (nd: node) error (Errors.msg "RTLgen.transl_exprlist") end. -(** Generation of code for variable assignments. *) - -Definition store_var - (map: mapping) (rs: reg) (id: ident) (nd: node) : mon node := - do rv <- find_var map id; - add_move rs rv nd. - -Definition store_optvar - (map: mapping) (rs: reg) (optid: option ident) (nd: node) : mon node := - match optid with - | None => ret nd - | Some id => store_var map rs id nd - end. - (** Auxiliary for branch prediction. When compiling an if/then/else statement, we have a choice between translating the ``then'' branch first or the ``else'' branch first. Linearization of RTL control-flow @@ -535,11 +531,10 @@ Fixpoint transl_stmt (map: mapping) (s: stmt) (nd: node) | Scall optid sig b cl => do rf <- alloc_reg map b; do rargs <- alloc_regs map cl; - do r <- new_reg; - do n1 <- store_optvar map r optid nd; - do n2 <- add_instr (Icall sig (inl _ rf) rargs r n1); - do n3 <- transl_exprlist map cl rargs n2; - transl_expr map b rf n3 + do r <- alloc_optreg map optid; + do n1 <- add_instr (Icall sig (inl _ rf) rargs r nd); + do n2 <- transl_exprlist map cl rargs n1; + transl_expr map b rf n2 | Stailcall sig b cl => do rf <- alloc_reg map b; do rargs <- alloc_regs map cl; @@ -548,10 +543,9 @@ Fixpoint transl_stmt (map: mapping) (s: stmt) (nd: node) transl_expr map b rf n2 | Sbuiltin optid ef al => do rargs <- alloc_regs map al; - do r <- new_reg; - do n1 <- store_optvar map r optid nd; - do n2 <- add_instr (Ibuiltin ef rargs r n1); - transl_exprlist map al rargs n2 + do r <- alloc_optreg map optid; + do n1 <- add_instr (Ibuiltin ef rargs r nd); + transl_exprlist map al rargs n1 | Sseq s1 s2 => do ns <- transl_stmt map s2 nd nexits ngoto nret rret; transl_stmt map s1 ns nexits ngoto nret rret diff --git a/backend/RTLgenproof.v b/backend/RTLgenproof.v index a1bd661..12a8e2b 100644 --- a/backend/RTLgenproof.v +++ b/backend/RTLgenproof.v @@ -200,18 +200,12 @@ Qed. (** A variant of [match_env_update_var] where a variable is optionally assigned to, depending on the [dst] parameter. *) -Definition assign_dest (dst: option ident) (v: val) (e: Cminor.env) : Cminor.env := - match dst with - | None => e - | Some id => PTree.set id v e - end. - Lemma match_env_update_dest: forall map e le rs dst r v, map_wf map -> reg_map_ok map r dst -> match_env map e le rs -> - match_env map (assign_dest dst v e) le (rs#r <- v). + match_env map (set_optvar dst v e) le (rs#r <- v). Proof. intros. inv H0; simpl. eapply match_env_update_temp; eauto. @@ -410,43 +404,6 @@ Proof. split. apply Regmap.gss. intros; apply Regmap.gso; auto. Qed. -(** Correctness of the code generated by [store_var] and [store_optvar]. *) - -Lemma tr_store_var_correct: - forall rs cs f map r id ns nd e sp m, - tr_store_var f.(fn_code) map r id ns nd -> - map_wf map -> - match_env map e nil rs -> - exists rs', - star step tge (State cs f sp ns rs m) - E0 (State cs f sp nd rs' m) - /\ match_env map (PTree.set id rs#r e) nil rs'. -Proof. - intros. destruct H as [rv [A B]]. - exploit tr_move_correct; eauto. intros [rs' [EX [RES OTHER]]]. - exists rs'; split. eexact EX. - apply match_env_invariant with (rs#rv <- (rs#r)). - apply match_env_update_var; auto. - intros. rewrite Regmap.gsspec. destruct (peq r0 rv). - subst r0; auto. - auto. -Qed. - -Lemma tr_store_optvar_correct: - forall rs cs f map r optid ns nd e sp m, - tr_store_optvar f.(fn_code) map r optid ns nd -> - map_wf map -> - match_env map e nil rs -> - exists rs', - star step tge (State cs f sp ns rs m) - E0 (State cs f sp nd rs' m) - /\ match_env map (set_optvar optid rs#r e) nil rs'. -Proof. - intros. destruct optid; simpl in *. - eapply tr_store_var_correct; eauto. - exists rs; split. subst nd. apply star_refl. auto. -Qed. - (** Correctness of the translation of [switch] statements *) Lemma transl_switch_correct: @@ -558,7 +515,7 @@ Definition transl_expr_prop (ME: match_env map e le rs), exists rs', star step tge (State cs f sp ns rs m) E0 (State cs f sp nd rs' m) - /\ match_env map (assign_dest dst v e) le rs' + /\ match_env map (set_optvar dst v e) le rs' /\ rs'#rd = v /\ (forall r, In r pr -> rs'#r = rs#r). @@ -1042,13 +999,12 @@ Inductive tr_cont: RTL.code -> mapping -> with match_stacks: CminorSel.cont -> list RTL.stackframe -> Prop := | match_stacks_stop: match_stacks Kstop nil - | match_stacks_call: forall optid f sp e k r tf n rs cs map nexits ngoto nret rret n', + | match_stacks_call: forall optid f sp e k r tf n rs cs map nexits ngoto nret rret, map_wf map -> tr_fun tf map f ngoto nret rret -> match_env map e nil rs -> - tr_store_optvar tf.(fn_code) map r optid n n' -> - ~reg_in_map map r -> - tr_cont tf.(fn_code) map k n' nexits ngoto nret rret cs -> + reg_map_ok map r optid -> + tr_cont tf.(fn_code) map k n nexits ngoto nret rret cs -> match_stacks (Kcall optid f sp e k) (Stackframe r tf sp n rs :: cs). Inductive match_states: CminorSel.state -> RTL.state -> Prop := @@ -1218,16 +1174,14 @@ Proof. inv TS. exploit transl_exprlist_correct; eauto. intros [rs' [E [F [G J]]]]. - exploit tr_store_optvar_correct. eauto. eauto. - apply match_env_update_temp. eexact F. eauto. - intros [rs'' [A B]]. econstructor; split. - left. eapply star_plus_trans. eexact E. eapply plus_left. + left. eapply plus_right. eexact E. eapply exec_Ibuiltin. eauto. rewrite G. eapply external_call_symbols_preserved; eauto. exact symbols_preserved. exact varinfo_preserved. - eexact A. reflexivity. traceEq. - econstructor; eauto. constructor. rewrite Regmap.gss in B. auto. + traceEq. + econstructor; eauto. constructor. + eapply match_env_update_dest; eauto. (* seq *) inv TS. @@ -1347,12 +1301,10 @@ Proof. (* return *) inv MS. - set (rs' := (rs#r <- v)). - assert (match_env map e nil rs'). unfold rs'; eauto with rtlg. - exploit tr_store_optvar_correct. eauto. eauto. eexact H. intros [rs'' [A B]]. - econstructor; split. - left; eapply plus_left. constructor. eexact A. traceEq. - econstructor; eauto. constructor. unfold rs' in B. rewrite Regmap.gss in B. auto. + econstructor; split. + left; apply plus_one; constructor. + econstructor; eauto. constructor. + eapply match_env_update_dest; eauto. Qed. Lemma transl_initial_states: diff --git a/backend/RTLgenspec.v b/backend/RTLgenspec.v index 0b18a99..22a1e79 100644 --- a/backend/RTLgenspec.v +++ b/backend/RTLgenspec.v @@ -483,6 +483,27 @@ Proof. intros [A|B]. auto. right; eauto with rtlg. Qed. +Lemma alloc_optreg_valid: + forall dest s1 s2 map r i, + map_valid map s1 -> + alloc_optreg map dest s1 = OK r s2 i -> reg_valid r s2. +Proof. + intros until r. unfold alloc_reg. + case dest; eauto with rtlg. +Qed. +Hint Resolve alloc_optreg_valid: rtlg. + +Lemma alloc_optreg_fresh_or_in_map: + forall map dest s r s' i, + map_valid map s -> + alloc_optreg map dest s = OK r s' i -> + reg_in_map map r \/ reg_fresh r s. +Proof. + intros until s'. unfold alloc_optreg. destruct dest; intros. + left; eauto with rtlg. + right; eauto with rtlg. +Qed. + (** A register is an adequate target for holding the value of an expression if - either the register is associated with a Cminor let-bound variable @@ -736,19 +757,6 @@ with tr_exprlist (c: code): tr_exprlist c map (r1 :: pr) al n1 nd rl -> tr_exprlist c map pr (Econs a1 al) ns nd (r1 :: rl). -(** Auxiliary for the compilation of variable assignments. *) - -Definition tr_store_var (c: code) (map: mapping) - (rs: reg) (id: ident) (ns nd: node): Prop := - exists rv, map.(map_vars)!id = Some rv /\ tr_move c ns rs nd rv. - -Definition tr_store_optvar (c: code) (map: mapping) - (rs: reg) (optid: option ident) (ns nd: node): Prop := - match optid with - | None => ns = nd - | Some id => tr_store_var c map rs id ns nd - end. - (** Auxiliary for the compilation of [switch] statements. *) Definition tr_jumptable (nexits: list node) (tbl: list nat) (ttbl: list node) : Prop := @@ -804,23 +812,21 @@ Inductive tr_stmt (c: code) (map: mapping): tr_expr c map rl b n1 n2 rd None -> c!n2 = Some (Istore chunk addr rl rd nd) -> tr_stmt c map (Sstore chunk addr al b) ns nd nexits ngoto nret rret - | tr_Scall: forall optid sig b cl ns nd nexits ngoto nret rret rd n1 rf n2 n3 rargs, + | tr_Scall: forall optid sig b cl ns nd nexits ngoto nret rret rd n1 rf n2 rargs, tr_expr c map nil b ns n1 rf None -> tr_exprlist c map (rf :: nil) cl n1 n2 rargs -> - c!n2 = Some (Icall sig (inl _ rf) rargs rd n3) -> - tr_store_optvar c map rd optid n3 nd -> - ~reg_in_map map rd -> + c!n2 = Some (Icall sig (inl _ rf) rargs rd nd) -> + reg_map_ok map rd optid -> tr_stmt c map (Scall optid sig b cl) ns nd nexits ngoto nret rret | tr_Stailcall: forall sig b cl ns nd nexits ngoto nret rret n1 rf n2 rargs, tr_expr c map nil b ns n1 rf None -> tr_exprlist c map (rf :: nil) cl n1 n2 rargs -> c!n2 = Some (Itailcall sig (inl _ rf) rargs) -> tr_stmt c map (Stailcall sig b cl) ns nd nexits ngoto nret rret - | tr_Sbuiltin: forall optid ef al ns nd nexits ngoto nret rret rd n1 n2 rargs, + | tr_Sbuiltin: forall optid ef al ns nd nexits ngoto nret rret rd n1 rargs, tr_exprlist c map nil al ns n1 rargs -> - c!n1 = Some (Ibuiltin ef rargs rd n2) -> - tr_store_optvar c map rd optid n2 nd -> - ~reg_in_map map rd -> + c!n1 = Some (Ibuiltin ef rargs rd nd) -> + reg_map_ok map rd optid -> tr_stmt c map (Sbuiltin optid ef al) ns nd nexits ngoto nret rret | tr_Sseq: forall s1 s2 ns nd nexits ngoto nret rret n, tr_stmt c map s2 n nd nexits ngoto nret rret -> @@ -1077,25 +1083,15 @@ Proof. monadInv EQ1. Qed. -Lemma tr_store_var_incr: - forall s1 s2, state_incr s1 s2 -> - forall map rs id ns nd, - tr_store_var s1.(st_code) map rs id ns nd -> - tr_store_var s2.(st_code) map rs id ns nd. -Proof. - intros. destruct H0 as [rv [A B]]. - econstructor; split. eauto. eapply tr_move_incr; eauto. -Qed. - -Lemma tr_store_optvar_incr: - forall s1 s2, state_incr s1 s2 -> - forall map rs optid ns nd, - tr_store_optvar s1.(st_code) map rs optid ns nd -> - tr_store_optvar s2.(st_code) map rs optid ns nd. +Lemma alloc_optreg_map_ok: + forall map optid s1 r s2 i, + map_valid map s1 -> + alloc_optreg map optid s1 = OK r s2 i -> + reg_map_ok map r optid. Proof. - intros until nd. destruct optid; simpl. - apply tr_store_var_incr; auto. - auto. + unfold alloc_optreg; intros. destruct optid. + constructor. unfold find_var in H0. destruct (map_vars map)!i0; monadInv H0. auto. + constructor. eapply new_reg_not_in_map; eauto. Qed. Lemma tr_switch_incr: @@ -1116,32 +1112,10 @@ Proof. intros s1 s2 EXT. generalize tr_expr_incr tr_condition_incr tr_exprlist_incr; intros I1 I2 I3. pose (AT := fun pc i => instr_at_incr s1 s2 pc i EXT). - pose (STV := tr_store_var_incr s1 s2 EXT). - pose (STOV := tr_store_optvar_incr s1 s2 EXT). induction 1; econstructor; eauto. eapply tr_switch_incr; eauto. Qed. -Lemma store_var_charact: - forall map rs id nd s ns s' incr, - store_var map rs id nd s = OK ns s' incr -> - tr_store_var s'.(st_code) map rs id ns nd. -Proof. - intros. monadInv H. generalize EQ. unfold find_var. - caseEq ((map_vars map)!id). 2: intros; discriminate. intros. monadInv EQ1. - exists x; split. auto. eapply add_move_charact; eauto. -Qed. - -Lemma store_optvar_charact: - forall map rs optid nd s ns s' incr, - store_optvar map rs optid nd s = OK ns s' incr -> - tr_store_optvar s'.(st_code) map rs optid ns nd. -Proof. - intros. destruct optid; simpl in H; simpl. - eapply store_var_charact; eauto. - monadInv H. auto. -Qed. - Lemma transl_exit_charact: forall nexits n s ne s' incr, transl_exit nexits n s = OK ne s' incr -> @@ -1218,15 +1192,14 @@ Proof. (* Scall *) econstructor; eauto 4 with rtlg. eapply transl_expr_charact; eauto 3 with rtlg. - apply tr_exprlist_incr with s6. auto. + apply tr_exprlist_incr with s5. auto. eapply transl_exprlist_charact; eauto 3 with rtlg. eapply alloc_regs_target_ok with (s1 := s1); eauto 3 with rtlg. apply regs_valid_cons; eauto 3 with rtlg. apply regs_valid_incr with s1; eauto 3 with rtlg. apply regs_valid_cons; eauto 3 with rtlg. apply regs_valid_incr with s2; eauto 3 with rtlg. - apply tr_store_optvar_incr with s4; auto. - eapply store_optvar_charact; eauto with rtlg. + eapply alloc_optreg_map_ok with (s1 := s2); eauto 3 with rtlg. (* Stailcall *) assert (RV: regs_valid (x :: nil) s1). apply regs_valid_cons; eauto 3 with rtlg. @@ -1237,8 +1210,7 @@ Proof. (* Sbuiltin *) econstructor; eauto 4 with rtlg. eapply transl_exprlist_charact; eauto 3 with rtlg. - apply tr_store_optvar_incr with s2; auto. - eapply store_optvar_charact; eauto with rtlg. + eapply alloc_optreg_map_ok with (s1 := s0); eauto with rtlg. (* Sseq *) econstructor. apply tr_stmt_incr with s0; auto. diff --git a/cfrontend/C2Clight.ml b/cfrontend/C2Clight.ml index 035840b..f62099a 100644 --- a/cfrontend/C2Clight.ml +++ b/cfrontend/C2Clight.ml @@ -7,6 +7,7 @@ open Cparser.Builtins open Camlcoq open AST +open Values open Csyntax (** Record the declarations of global variables and associate them @@ -286,62 +287,96 @@ let rec convertTypList env = function | [] -> Tnil | t1 :: tl -> Tcons(convertTyp env t1, convertTypList env tl) +let rec projFunType env ty = + match Cutil.unroll env ty with + | TFun(res, args, vararg, attr) -> Some(res, vararg) + | TPtr(ty', attr) -> projFunType env ty' + | _ -> None + +(* Handling of volatile *) + +let is_volatile_access env e = + List.mem C.AVolatile (Cutil.attributes_of_type env e.etyp) + && Cutil.is_lvalue env e + +let volatile_fun_suffix_type ty = + match ty with + | Tint(I8, Unsigned) -> ("int8unsigned", ty) + | Tint(I8, Signed) -> ("int8signed", ty) + | Tint(I16, Unsigned) -> ("int16unsigned", ty) + | Tint(I16, Signed) -> ("int16signed", ty) + | Tint(I32, _) -> ("int32", Tint(I32, Signed)) + | Tfloat F32 -> ("float32", ty) + | Tfloat F64 -> ("float64", ty) + | Tpointer _ | Tarray _ | Tfunction _ | Tcomp_ptr _ -> + ("pointer", Tpointer Tvoid) + | _ -> + unsupported "operation on volatile struct or union"; ("", Tvoid) + +let volatile_read_fun ty = + let (suffix, ty') = volatile_fun_suffix_type ty in + let funty = Tfunction(Tcons(Tpointer Tvoid, Tnil), ty') in + Evalof(Evar(intern_string ("__builtin_volatile_read_" ^ suffix), funty), funty) + +let volatile_write_fun ty = + let (suffix, ty') = volatile_fun_suffix_type ty in + let funty = Tfunction(Tcons(Tpointer Tvoid, Tcons(ty', Tnil)), Tvoid) in + Evalof(Evar(intern_string ("__builtin_volatile_write_" ^ suffix), funty), funty) + (** Expressions *) -let ezero = Expr(Econst_int(coqint_of_camlint 0l), Tint(I32, Signed)) +let ezero = Eval(Vint(coqint_of_camlint 0l), Tint(I32, Signed)) let rec convertExpr env e = let ty = convertTyp env e.etyp in match e.edesc with + | C.EVar _ + | C.EUnop((C.Oderef|C.Odot _|C.Oarrow _), _) + | C.EBinop(C.Oindex, _, _, _) -> + let l = convertLvalue env e in + if is_volatile_access env e then + Ecall(volatile_read_fun (typeof l), + Econs(Eaddrof(l, Tpointer(typeof l)), Enil), + ty) + else + Evalof(l, ty) + | C.EConst(C.CInt(i, _, _)) -> - Expr(Econst_int(convertInt i), ty) + Eval(Vint(convertInt i), ty) | C.EConst(C.CFloat(f, _, _)) -> - Expr(Econst_float f, ty) + Eval(Vfloat(f), ty) | C.EConst(C.CStr s) -> - Expr(Evar(name_for_string_literal env s), typeStringLiteral s) + let ty = typeStringLiteral s in + Evalof(Evar(name_for_string_literal env s, ty), ty) | C.EConst(C.CWStr s) -> unsupported "wide string literal"; ezero | C.EConst(C.CEnum(id, i)) -> - Expr(Econst_int(convertInt i), ty) - + Eval(Vint(convertInt i), ty) | C.ESizeof ty1 -> - Expr(Esizeof(convertTyp env ty1), ty) - | C.EVar id -> - Expr(Evar(intern_string id.name), ty) + Esizeof(convertTyp env ty1, ty) - | C.EUnop(C.Oderef, e1) -> - Expr(Ederef(convertExpr env e1), ty) - | C.EUnop(C.Oaddrof, e1) -> - Expr(Eaddrof(convertExpr env e1), ty) - | C.EUnop(C.Odot id, e1) -> - Expr(Efield(convertExpr env e1, intern_string id), ty) - | C.EUnop(C.Oarrow id, e1) -> - let e1' = convertExpr env e1 in - let ty1 = - match typeof e1' with - | Tpointer t -> t - | _ -> error ("wrong type for ->" ^ id ^ " access"); Tvoid in - Expr(Efield(Expr(Ederef(convertExpr env e1), ty1), - intern_string id), ty) + | C.EUnop(C.Ominus, e1) -> + Eunop(Oneg, convertExpr env e1, ty) | C.EUnop(C.Oplus, e1) -> convertExpr env e1 - | C.EUnop(C.Ominus, e1) -> - Expr(Eunop(Oneg, convertExpr env e1), ty) | C.EUnop(C.Olognot, e1) -> - Expr(Eunop(Onotbool, convertExpr env e1), ty) + Eunop(Onotbool, convertExpr env e1, ty) | C.EUnop(C.Onot, e1) -> - Expr(Eunop(Onotint, convertExpr env e1), ty) - | C.EUnop(_, _) -> - unsupported "pre/post increment/decrement operator"; ezero - - | C.EBinop(C.Oindex, e1, e2, _) -> - Expr(Ederef(Expr(Ebinop(Oadd, convertExpr env e1, convertExpr env e2), - Tpointer ty)), ty) - | C.EBinop(C.Ologand, e1, e2, _) -> - Expr(Eandbool(convertExpr env e1, convertExpr env e2), ty) - | C.EBinop(C.Ologor, e1, e2, _) -> - Expr(Eorbool(convertExpr env e1, convertExpr env e2), ty) - | C.EBinop(op, e1, e2, _) -> + Eunop(Onotint, convertExpr env e1, ty) + | C.EUnop(C.Oaddrof, e1) -> + Eaddrof(convertLvalue env e1, ty) + | C.EUnop(C.Opreincr, e1) -> + coq_Epreincr Incr (convertLvalue env e1) ty + | C.EUnop(C.Opredecr, e1) -> + coq_Epreincr Decr (convertLvalue env e1) ty + | C.EUnop(C.Opostincr, e1) -> + Epostincr(Incr, convertLvalue env e1, ty) + | C.EUnop(C.Opostdecr, e1) -> + Epostincr(Decr, convertLvalue env e1, ty) + + | C.EBinop((C.Oadd|C.Osub|C.Omul|C.Odiv|C.Omod|C.Oand|C.Oor|C.Oxor| + C.Oshl|C.Oshr|C.Oeq|C.One|C.Olt|C.Ogt|C.Ole|C.Oge) as op, + e1, e2, _) -> let op' = match op with | C.Oadd -> Oadd @@ -360,121 +395,106 @@ let rec convertExpr env e = | C.Ogt -> Ogt | C.Ole -> Ole | C.Oge -> Oge - | C.Ocomma -> unsupported "sequence operator"; Oadd - | _ -> unsupported "assignment operator"; Oadd in - Expr(Ebinop(op', convertExpr env e1, convertExpr env e2), ty) + | _ -> assert false in + Ebinop(op', convertExpr env e1, convertExpr env e2, ty) + | C.EBinop(C.Oassign, e1, e2, _) -> + let e1' = convertLvalue env e1 in + let e2' = convertExpr env e2 in + if Cutil.is_composite_type env e1.etyp then + unsupported "assignment between structs or between unions"; + if is_volatile_access env e1 then + Ecall(volatile_write_fun (typeof e1'), + Econs(Eaddrof(e1', Tpointer(typeof e1')), Econs(e2', Enil)), + Tvoid) (* typing issue here *) + else + Eassign(e1', e2', ty) + | C.EBinop((C.Oadd_assign|C.Osub_assign|C.Omul_assign|C.Odiv_assign| + C.Omod_assign|C.Oand_assign|C.Oor_assign|C.Oxor_assign| + C.Oshl_assign|C.Oshr_assign) as op, + e1, e2, tyres) -> + let tyres = convertTyp env tyres in + let op' = + match op with + | C.Oadd_assign -> Oadd + | C.Osub_assign -> Osub + | C.Omul_assign -> Omul + | C.Odiv_assign -> Odiv + | C.Omod_assign -> Omod + | C.Oand_assign -> Oand + | C.Oor_assign -> Oor + | C.Oxor_assign -> Oxor + | C.Oshl_assign -> Oshl + | C.Oshr_assign -> Oshr + | _ -> assert false in + let e1' = convertLvalue env e1 in + let e2' = convertExpr env e2 in + if is_volatile_access env e1 then + (error "assign-op to volatile not supported"; ezero) + else + Eassignop(op', e1', e2', tyres, ty) + | C.EBinop(C.Ocomma, e1, e2, _) -> + Ecomma(convertExpr env e1, convertExpr env e2, ty) + | C.EBinop(C.Ologand, e1, e2, _) -> + coq_Eseqand (convertExpr env e1) (convertExpr env e2) ty + | C.EBinop(C.Ologor, e1, e2, _) -> + coq_Eseqor (convertExpr env e1) (convertExpr env e2) ty + | C.EConditional(e1, e2, e3) -> - Expr(Econdition(convertExpr env e1, convertExpr env e2, convertExpr env e3), ty) + Econdition(convertExpr env e1, convertExpr env e2, convertExpr env e3, ty) | C.ECast(ty1, e1) -> - Expr(Ecast(convertTyp env ty1, convertExpr env e1), ty) - | C.ECall _ -> - unsupported "function call within expression"; ezero - -(* Function calls *) - -let rec projFunType env ty = - match Cutil.unroll env ty with - | TFun(res, args, vararg, attr) -> Some(res, vararg) - | TPtr(ty', attr) -> projFunType env ty' - | _ -> None - -let convertFuncall env lhs fn args = - match projFunType env fn.etyp with - | None -> - error "wrong type for function part of a call"; Sskip - | Some(res, false) -> - (* Non-variadic function *) - Scall(lhs, convertExpr env fn, List.map (convertExpr env) args) - | Some(res, true) -> - (* Variadic function: generate a call to a stub function with - the appropriate number and types of arguments. Works only if - the function expression e is a global variable. *) - let fun_name = - match fn with - | {edesc = C.EVar id} when !Clflags.option_fvararg_calls -> - (*warning "emulating call to variadic function"; *) - id.name - | _ -> - unsupported "call to variadic function"; - "<error>" in - let targs = convertTypList env (List.map (fun e -> e.etyp) args) in - let tres = convertTyp env res in - let (stub_fun_name, stub_fun_typ) = - register_stub_function fun_name tres targs in - Scall(lhs, - Expr(Evar(intern_string stub_fun_name), stub_fun_typ), - List.map (convertExpr env) args) - -(* Handling of volatile *) - -let is_volatile_access env e = - List.mem C.AVolatile (Cutil.attributes_of_type env e.etyp) - && Cutil.is_lvalue env e - -let volatile_fun_suffix_type ty = - match ty with - | Tint(I8, Unsigned) -> ("int8unsigned", ty) - | Tint(I8, Signed) -> ("int8signed", ty) - | Tint(I16, Unsigned) -> ("int16unsigned", ty) - | Tint(I16, Signed) -> ("int16signed", ty) - | Tint(I32, _) -> ("int32", Tint(I32, Signed)) - | Tfloat F32 -> ("float32", ty) - | Tfloat F64 -> ("float64", ty) - | Tpointer _ | Tarray _ | Tfunction _ | Tcomp_ptr _ -> - ("pointer", Tpointer Tvoid) - | _ -> - unsupported "operation on volatile struct or union"; ("", Tvoid) - -let volatile_read_fun ty = - let (suffix, ty') = volatile_fun_suffix_type ty in - Expr(Evar(intern_string ("__builtin_volatile_read_" ^ suffix)), - Tfunction(Tcons(Tpointer Tvoid, Tnil), ty')) - -let volatile_write_fun ty = - let (suffix, ty') = volatile_fun_suffix_type ty in - Expr(Evar(intern_string ("__builtin_volatile_write_" ^ suffix)), - Tfunction(Tcons(Tpointer Tvoid, Tcons(ty', Tnil)), Tvoid)) - -(* Toplevel expression, argument of an Sdo *) - -let convertTopExpr env e = - match e.edesc with - | C.EBinop(C.Oassign, lhs, {edesc = C.ECall(fn, args)}, _) -> - convertFuncall env (Some (convertExpr env lhs)) fn args -(**** - (* Recognize __builtin_fabs and turn it into Clight operator *) - begin match fn, args with - | {edesc = C.EVar {name = "__builtin_fabs"}}, [arg1] -> - Sassign(convertExpr env lhs, - Expr(Eunop(Ofabs, convertExpr env arg1), Tfloat F64)) - | _ -> - convertFuncall env (Some (convertExpr env lhs)) fn args - end -*****) - | C.EBinop(C.Oassign, lhs, rhs, _) -> - if Cutil.is_composite_type env lhs.etyp then - unsupported "assignment between structs or between unions"; - let lhs' = convertExpr env lhs - and rhs' = convertExpr env rhs in - begin match (is_volatile_access env lhs, is_volatile_access env rhs) with - | true, true -> (* should not happen *) - unsupported "volatile-to-volatile assignment"; - Sskip - | false, true -> (* volatile read *) - Scall(Some lhs', - volatile_read_fun (typeof rhs'), - [ Expr (Eaddrof rhs', Tpointer (typeof rhs')) ]) - | true, false -> (* volatile write *) - Scall(None, - volatile_write_fun (typeof lhs'), - [ Expr(Eaddrof lhs', Tpointer (typeof lhs')); rhs' ]) - | false, false -> (* regular assignment *) - Sassign(convertExpr env lhs, convertExpr env rhs) - end + Ecast(convertExpr env e1, convertTyp env ty1) | C.ECall(fn, args) -> - convertFuncall env None fn args + match projFunType env fn.etyp with + | None -> + error "wrong type for function part of a call"; ezero + | Some(res, false) -> + (* Non-variadic function *) + Ecall(convertExpr env fn, convertExprList env args, ty) + | Some(res, true) -> + (* Variadic function: generate a call to a stub function with + the appropriate number and types of arguments. Works only if + the function expression e is a global variable. *) + let fun_name = + match fn with + | {edesc = C.EVar id} when !Clflags.option_fvararg_calls -> + (*warning "emulating call to variadic function"; *) + id.name + | _ -> + unsupported "call to variadic function"; + "<error>" in + let targs = convertTypList env (List.map (fun e -> e.etyp) args) in + let tres = convertTyp env res in + let (stub_fun_name, stub_fun_typ) = + register_stub_function fun_name tres targs in + Ecall(Evalof(Evar(intern_string stub_fun_name, stub_fun_typ), + stub_fun_typ), + convertExprList env args, ty) + +and convertLvalue env e = + let ty = convertTyp env e.etyp in + match e.edesc with + | C.EVar id -> + Evar(intern_string id.name, ty) + | C.EUnop(C.Oderef, e1) -> + Ederef(convertExpr env e1, ty) + | C.EUnop(C.Odot id, e1) -> + Efield(convertLvalue env e1, intern_string id, ty) + | C.EUnop(C.Oarrow id, e1) -> + let e1' = convertExpr env e1 in + let ty1 = + match typeof e1' with + | Tpointer t -> t + | _ -> error ("wrong type for ->" ^ id ^ " access"); Tvoid in + Efield(Ederef(e1', ty1), intern_string id, ty) + | C.EBinop(C.Oindex, e1, e2, _) -> + coq_Eindex (convertExpr env e1) (convertExpr env e2) ty | _ -> - unsupported "illegal toplevel expression"; Sskip + error "illegal l-value"; ezero + +and convertExprList env el = + match el with + | [] -> Enil + | e1 :: el' -> Econs(convertExpr env e1, convertExprList env el') (* Separate the cases of a switch statement body *) @@ -514,7 +534,7 @@ let rec convertStmt env s = | C.Sskip -> Sskip | C.Sdo e -> - convertTopExpr env e + Sdo(convertExpr env e) | C.Sseq(s1, s2) -> Ssequence(convertStmt env s1, convertStmt env s2) | C.Sif(e, s1, s2) -> @@ -699,6 +719,7 @@ let convertInit env ty init = | Some(C.CEnum _) -> error "enum tag after constant folding" | None -> + Format.printf "%a@." Cprint.exp (0, e); error "initializer is not a compile-time constant" end | Init_array il -> diff --git a/cfrontend/Clight.v b/cfrontend/Clight.v new file mode 100644 index 0000000..4cc97ab --- /dev/null +++ b/cfrontend/Clight.v @@ -0,0 +1,623 @@ +(* *********************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Xavier Leroy, INRIA Paris-Rocquencourt *) +(* *) +(* Copyright Institut National de Recherche en Informatique et en *) +(* Automatique. All rights reserved. This file is distributed *) +(* under the terms of the GNU General Public License as published by *) +(* the Free Software Foundation, either version 2 of the License, or *) +(* (at your option) any later version. This file is also distributed *) +(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* *) +(* *********************************************************************) + +(** The Clight language: a simplified version of Compcert C where all + expressions are pure and assignments and function calls are + statements, not expressions. *) + +Require Import Coqlib. +Require Import Errors. +Require Import Maps. +Require Import Integers. +Require Import Floats. +Require Import Values. +Require Import AST. +Require Import Memory. +Require Import Events. +Require Import Globalenvs. +Require Import Smallstep. +Require Import Csyntax. +Require Import Csem. + +(** * Abstract syntax *) + + +(** ** Expressions *) + +(** Clight expressions correspond to the "pure" subset of C expressions. + The main omissions are string literals and assignment operators + ([=], [+=], [++], etc). In Clight, assignment is a statement, + not an expression. Additionally, an expression can also refer to + temporary variables, which are a separate class of local variables + that do not reside in memory and whose address cannot be taken. + + As in Compcert C, all expressions are annotated with their types, + as needed to resolve operator overloading and type-dependent behaviors. *) + +Inductive expr : Type := + | Econst_int: int -> type -> expr (**r integer literal *) + | Econst_float: float -> type -> expr (**r float literal *) + | Evar: ident -> type -> expr (**r variable *) + | Etempvar: ident -> type -> expr (**r temporary variable *) + | Ederef: expr -> type -> expr (**r pointer dereference (unary [*]) *) + | Eaddrof: expr -> type -> expr (**r address-of operator ([&]) *) + | Eunop: unary_operation -> expr -> type -> expr (**r unary operation *) + | Ebinop: binary_operation -> expr -> expr -> type -> expr (**r binary operation *) + | Ecast: expr -> type -> expr (**r type cast ([(ty) e]) *) + | Econdition: expr -> expr -> expr -> type -> expr (**r conditional ([e1 ? e2 : e3]) *) + | Esizeof: type -> type -> expr (**r size of a type *) + | Efield: expr -> ident -> type -> expr. (**r access to a member of a struct or union *) + +(** Extract the type part of a type-annotated Clight expression. *) + +Definition typeof (e: expr) : type := + match e with + | Econst_int _ ty => ty + | Econst_float _ ty => ty + | Evar _ ty => ty + | Etempvar _ ty => ty + | Ederef _ ty => ty + | Eaddrof _ ty => ty + | Eunop _ _ ty => ty + | Ebinop _ _ _ ty => ty + | Ecast _ ty => ty + | Econdition _ _ _ ty => ty + | Esizeof _ ty => ty + | Efield _ _ ty => ty + end. + +(** ** Statements *) + +(** Clight statements are similar to those of Compcert C, with the addition + of assigment (of a rvalue to a lvalue), assignment to a temporary, + and function call (with assignment of the result to a temporary). + The [for] loop is slightly simplified: there is no initial statement. *) + +Definition label := ident. + +Inductive statement : Type := + | Sskip : statement (**r do nothing *) + | Sassign : expr -> expr -> statement (**r assignment [lvalue = rvalue] *) + | Sset : ident -> expr -> statement (**r assignment [tempvar = rvalue] *) + | Scall: option ident -> expr -> list expr -> statement (**r function call *) + | Ssequence : statement -> statement -> statement (**r sequence *) + | Sifthenelse : expr -> statement -> statement -> statement (**r conditional *) + | Swhile : expr -> statement -> statement (**r [while] loop *) + | Sdowhile : expr -> statement -> statement (**r [do] loop *) + | Sfor': expr -> statement -> statement -> statement (**r [for] loop *) + | Sbreak : statement (**r [break] statement *) + | Scontinue : statement (**r [continue] statement *) + | Sreturn : option expr -> statement (**r [return] statement *) + | Sswitch : expr -> labeled_statements -> statement (**r [switch] statement *) + | Slabel : label -> statement -> statement + | Sgoto : label -> statement + +with labeled_statements : Type := (**r cases of a [switch] *) + | LSdefault: statement -> labeled_statements + | LScase: int -> statement -> labeled_statements -> labeled_statements. + +(** The full [for] loop is a derived form. *) + +Definition Sfor (s1: statement) (e2: expr) (s3 s4: statement) := + Ssequence s1 (Sfor' e2 s3 s4). + +(** ** Functions *) + +(** A function definition is composed of its return type ([fn_return]), + the names and types of its parameters ([fn_params]), the names + and types of its local variables ([fn_vars]), and the body of the + function (a statement, [fn_body]). *) + +Record function : Type := mkfunction { + fn_return: type; + fn_params: list (ident * type); + fn_vars: list (ident * type); + fn_temps: list (ident * type); + fn_body: statement +}. + +Definition var_names (vars: list(ident * type)) : list ident := + List.map (@fst ident type) vars. + +(** Functions can either be defined ([Internal]) or declared as + external functions ([External]). *) + +Inductive fundef : Type := + | Internal: function -> fundef + | External: external_function -> typelist -> type -> fundef. + +(** ** Programs *) + +(** A program is a collection of named functions, plus a collection + of named global variables, carrying their types and optional initialization + data. See module [AST] for more details. *) + +Definition program : Type := AST.program fundef type. + +(** * Operations over types *) + +(** The type of a function definition. *) + +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. + +(** * Operational semantics *) + +(** The semantics uses two environments. The global environment + maps names of functions and global variables to memory block references, + and function pointers to their definitions. (See module [Globalenvs].) *) + +Definition genv := Genv.t fundef type. + +(** The local environment maps local variables to block references + and types. The current value of the variable is stored in the associated memory + block. *) + +Definition env := PTree.t (block * type). (* map variable -> location & type *) + +Definition empty_env: env := (PTree.empty (block * type)). + +(** The temporary environment maps local temporaries to values. *) + +Definition temp_env := PTree.t val. + + +(** Selection of the appropriate case of a [switch], given the value [n] + of the selector expression. *) + +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. + +(** Turn a labeled statement into a sequence *) + +Fixpoint seq_of_labeled_statement (sl: labeled_statements) : statement := + match sl with + | LSdefault s => s + | LScase c s sl' => Ssequence s (seq_of_labeled_statement sl') + end. + +Section SEMANTICS. + +Variable ge: genv. + +(** [type_of_global b] returns the type of the global variable or function + at address [b]. *) + +Definition type_of_global (b: block) : option type := + match Genv.find_var_info ge b with + | Some gv => Some gv.(gvar_info) + | None => + match Genv.find_funct_ptr ge b with + | Some fd => Some(type_of_fundef fd) + | None => None + end + end. + +(** ** Evaluation of expressions *) + +Section EXPR. + +Variable e: env. +Variable le: temp_env. +Variable m: mem. + +(** [eval_expr ge e m a v] defines the evaluation of expression [a] + in r-value position. [v] is the value of the expression. + [e] is the current environment and [m] is the current memory state. *) + +Inductive eval_expr: expr -> val -> Prop := + | eval_Econst_int: forall i ty, + eval_expr (Econst_int i ty) (Vint i) + | eval_Econst_float: forall f ty, + eval_expr (Econst_float f ty) (Vfloat f) + | eval_Etempvar: forall id ty v, + le!id = Some v -> + eval_expr (Etempvar id ty) v + | eval_Eaddrof: forall a ty loc ofs, + eval_lvalue a loc ofs -> + eval_expr (Eaddrof a ty) (Vptr loc ofs) + | eval_Esizeof: forall ty' ty, + eval_expr (Esizeof ty' ty) (Vint (Int.repr (sizeof ty'))) + | eval_Eunop: forall op a ty v1 v, + eval_expr a v1 -> + sem_unary_operation op v1 (typeof a) = Some v -> + eval_expr (Eunop op a ty) v + | eval_Ebinop: forall op a1 a2 ty v1 v2 v, + eval_expr a1 v1 -> + eval_expr a2 v2 -> + sem_binary_operation op v1 (typeof a1) v2 (typeof a2) m = Some v -> + eval_expr (Ebinop op a1 a2 ty) v + | eval_Econdition_true: forall a1 a2 a3 ty v1 v2, + eval_expr a1 v1 -> + is_true v1 (typeof a1) -> + eval_expr a2 v2 -> + eval_expr (Econdition a1 a2 a3 ty) v2 + | eval_Econdition_false: forall a1 a2 a3 ty v1 v3, + eval_expr a1 v1 -> + is_false v1 (typeof a1) -> + eval_expr a3 v3 -> + eval_expr (Econdition a1 a2 a3 ty) v3 + | eval_Ecast: forall a ty v1 v, + eval_expr a v1 -> + cast v1 (typeof a) ty v -> + eval_expr (Ecast a ty) v + | eval_Elvalue: forall a loc ofs v, + eval_lvalue a loc ofs -> + load_value_of_type (typeof a) m loc ofs = Some v -> + eval_expr a v + +(** [eval_lvalue ge e m a b ofs] defines the evaluation of expression [a] + in l-value position. The result is the memory location [b, ofs] + that contains the value of the expression [a]. *) + +with eval_lvalue: expr -> block -> int -> Prop := + | eval_Evar_local: forall id l ty, + e!id = Some(l, ty) -> + eval_lvalue (Evar id ty) l Int.zero + | eval_Evar_global: forall id l ty, + e!id = None -> + Genv.find_symbol ge id = Some l -> + type_of_global l = Some ty -> + eval_lvalue (Evar id ty) l Int.zero + | eval_Ederef: forall a ty l ofs, + eval_expr a (Vptr l ofs) -> + eval_lvalue (Ederef a ty) l ofs + | eval_Efield_struct: forall a i ty l ofs id fList delta, + eval_lvalue a l ofs -> + typeof a = Tstruct id fList -> + field_offset i fList = OK delta -> + eval_lvalue (Efield a i ty) l (Int.add ofs (Int.repr delta)) + | eval_Efield_union: forall a i ty l ofs id fList, + eval_lvalue a l ofs -> + typeof a = Tunion id fList -> + eval_lvalue (Efield a i ty) l ofs. + +Scheme eval_expr_ind2 := Minimality for eval_expr Sort Prop + with eval_lvalue_ind2 := Minimality for eval_lvalue Sort Prop. +Combined Scheme eval_expr_lvalue_ind from eval_expr_ind2, eval_lvalue_ind2. + +(** [eval_exprlist ge e m al tyl vl] evaluates a list of r-value + expressions [al], cast their values to the types given in [tyl], + and produces the list of cast values [vl]. It is used to + evaluate the arguments of function calls. *) + +Inductive eval_exprlist: list expr -> typelist -> list val -> Prop := + | eval_Enil: + eval_exprlist nil Tnil nil + | eval_Econs: forall a bl ty tyl v1 v2 vl, + eval_expr a v1 -> + cast v1 (typeof a) ty v2 -> + eval_exprlist bl tyl vl -> + eval_exprlist (a :: bl) (Tcons ty tyl) (v2 :: vl). + +End EXPR. + +(** ** Transition semantics for statements and functions *) + +(** Continuations *) + +Inductive cont: Type := + | Kstop: cont + | Kseq: statement -> cont -> cont + (**r [Kseq s2 k] = after [s1] in [s1;s2] *) + | Kwhile: expr -> statement -> cont -> cont + (**r [Kwhile e s k] = after [s] in [while (e) s] *) + | Kdowhile: expr -> statement -> cont -> cont + (**r [Kdowhile e s k] = after [s] in [do s while (e)] *) + | Kfor2: expr -> statement -> statement -> cont -> cont + (**r [Kfor2 e2 e3 s k] = after [s] in [for'(e2;e3) s] *) + | Kfor3: expr -> statement -> statement -> cont -> cont + (**r [Kfor3 e2 e3 s k] = after [e3] in [for'(e2;e3) s] *) + | Kswitch: cont -> cont + (**r catches [break] statements arising out of [switch] *) + | Kcall: option ident -> (**r where to store result *) + function -> (**r calling function *) + env -> (**r local env of calling function *) + temp_env -> (**r temporary env of calling function *) + cont -> cont. + +(** Pop continuation until a call or stop *) + +Fixpoint call_cont (k: cont) : cont := + match k with + | Kseq s k => call_cont k + | Kwhile e s k => call_cont k + | Kdowhile e s k => call_cont k + | Kfor2 e2 e3 s k => call_cont k + | Kfor3 e2 e3 s k => call_cont k + | Kswitch k => call_cont k + | _ => k + end. + +Definition is_call_cont (k: cont) : Prop := + match k with + | Kstop => True + | Kcall _ _ _ _ _ => True + | _ => False + end. + +(** States *) + +Inductive state: Type := + | State + (f: function) + (s: statement) + (k: cont) + (e: env) + (le: temp_env) + (m: mem) : state + | Callstate + (fd: fundef) + (args: list val) + (k: cont) + (m: mem) : state + | Returnstate + (res: val) + (k: cont) + (m: mem) : state. + +(** Find the statement and manufacture the continuation + corresponding to a label *) + +Fixpoint find_label (lbl: label) (s: statement) (k: cont) + {struct s}: option (statement * cont) := + match s with + | Ssequence s1 s2 => + match find_label lbl s1 (Kseq s2 k) with + | Some sk => Some sk + | None => find_label lbl s2 k + end + | Sifthenelse a s1 s2 => + match find_label lbl s1 k with + | Some sk => Some sk + | None => find_label lbl s2 k + end + | Swhile a s1 => + find_label lbl s1 (Kwhile a s1 k) + | Sdowhile a s1 => + find_label lbl s1 (Kdowhile a s1 k) + | Sfor' a2 a3 s1 => + match find_label lbl s1 (Kfor2 a2 a3 s1 k) with + | Some sk => Some sk + | None => find_label lbl a3 (Kfor3 a2 a3 s1 k) + end + | Sswitch e sl => + find_label_ls lbl sl (Kswitch k) + | Slabel lbl' s' => + if ident_eq lbl lbl' then Some(s', k) else find_label lbl s' k + | _ => None + end + +with find_label_ls (lbl: label) (sl: labeled_statements) (k: cont) + {struct sl}: option (statement * cont) := + match sl with + | LSdefault s => find_label lbl s k + | LScase _ s sl' => + match find_label lbl s (Kseq (seq_of_labeled_statement sl') k) with + | Some sk => Some sk + | None => find_label_ls lbl sl' k + end + end. + +(** Transition relation *) + +Inductive step: state -> trace -> state -> Prop := + + | step_assign: forall f a1 a2 k e le m loc ofs v2 v m', + eval_lvalue e le m a1 loc ofs -> + eval_expr e le m a2 v2 -> + cast v2 (typeof a2) (typeof a1) v -> + store_value_of_type (typeof a1) m loc ofs v = Some m' -> + step (State f (Sassign a1 a2) k e le m) + E0 (State f Sskip k e le m') + + | step_set: forall f id a k e le m v, + eval_expr e le m a v -> + step (State f (Sset id a) k e le m) + E0 (State f Sskip k e (PTree.set id v le) m) + + | step_call: forall f optid a al k e le m tyargs tyres vf vargs fd, + typeof a = Tfunction tyargs tyres -> + eval_expr e le m a vf -> + eval_exprlist e le m al tyargs vargs -> + Genv.find_funct ge vf = Some fd -> + type_of_fundef fd = typeof a -> + step (State f (Scall optid a al) k e le m) + E0 (Callstate fd vargs (Kcall optid f e le k) m) + + | step_seq: forall f s1 s2 k e le m, + step (State f (Ssequence s1 s2) k e le m) + E0 (State f s1 (Kseq s2 k) e le m) + | step_skip_seq: forall f s k e le m, + step (State f Sskip (Kseq s k) e le m) + E0 (State f s k e le m) + | step_continue_seq: forall f s k e le m, + step (State f Scontinue (Kseq s k) e le m) + E0 (State f Scontinue k e le m) + | step_break_seq: forall f s k e le m, + step (State f Sbreak (Kseq s k) e le m) + E0 (State f Sbreak k e le m) + + | step_ifthenelse_true: forall f a s1 s2 k e le m v1, + eval_expr e le m a v1 -> + is_true v1 (typeof a) -> + step (State f (Sifthenelse a s1 s2) k e le m) + E0 (State f s1 k e le m) + | step_ifthenelse_false: forall f a s1 s2 k e le m v1, + eval_expr e le m a v1 -> + is_false v1 (typeof a) -> + step (State f (Sifthenelse a s1 s2) k e le m) + E0 (State f s2 k e le m) + + | step_while_false: forall f a s k e le m v, + eval_expr e le m a v -> + is_false v (typeof a) -> + step (State f (Swhile a s) k e le m) + E0 (State f Sskip k e le m) + | step_while_true: forall f a s k e le m v, + eval_expr e le m a v -> + is_true v (typeof a) -> + step (State f (Swhile a s) k e le m) + E0 (State f s (Kwhile a s k) e le m) + | step_skip_or_continue_while: forall f x a s k e le m, + x = Sskip \/ x = Scontinue -> + step (State f x (Kwhile a s k) e le m) + E0 (State f (Swhile a s) k e le m) + | step_break_while: forall f a s k e le m, + step (State f Sbreak (Kwhile a s k) e le m) + E0 (State f Sskip k e le m) + + | step_dowhile: forall f a s k e le m, + step (State f (Sdowhile a s) k e le m) + E0 (State f s (Kdowhile a s k) e le m) + | step_skip_or_continue_dowhile_false: forall f x a s k e le m v, + x = Sskip \/ x = Scontinue -> + eval_expr e le m a v -> + is_false v (typeof a) -> + step (State f x (Kdowhile a s k) e le m) + E0 (State f Sskip k e le m) + | step_skip_or_continue_dowhile_true: forall f x a s k e le m v, + x = Sskip \/ x = Scontinue -> + eval_expr e le m a v -> + is_true v (typeof a) -> + step (State f x (Kdowhile a s k) e le m) + E0 (State f (Sdowhile a s) k e le m) + | step_break_dowhile: forall f a s k e le m, + step (State f Sbreak (Kdowhile a s k) e le m) + E0 (State f Sskip k e le m) + + | step_for_false: forall f a2 a3 s k e le m v, + eval_expr e le m a2 v -> + is_false v (typeof a2) -> + step (State f (Sfor' a2 a3 s) k e le m) + E0 (State f Sskip k e le m) + | step_for_true: forall f a2 a3 s k e le m v, + eval_expr e le m a2 v -> + is_true v (typeof a2) -> + step (State f (Sfor' a2 a3 s) k e le m) + E0 (State f s (Kfor2 a2 a3 s k) e le m) + | step_skip_or_continue_for2: forall f x a2 a3 s k e le m, + x = Sskip \/ x = Scontinue -> + step (State f x (Kfor2 a2 a3 s k) e le m) + E0 (State f a3 (Kfor3 a2 a3 s k) e le m) + | step_break_for2: forall f a2 a3 s k e le m, + step (State f Sbreak (Kfor2 a2 a3 s k) e le m) + E0 (State f Sskip k e le m) + | step_skip_for3: forall f a2 a3 s k e le m, + step (State f Sskip (Kfor3 a2 a3 s k) e le m) + E0 (State f (Sfor' a2 a3 s) k e le m) + | step_break_for3: forall f a2 a3 s k e le m, + step (State f Sbreak (Kfor3 a2 a3 s k) e le m) + E0 (State f Sskip k e le m) + + | step_return_0: forall f k e le m m', + f.(fn_return) = Tvoid -> + Mem.free_list m (blocks_of_env e) = Some m' -> + step (State f (Sreturn None) k e le m) + E0 (Returnstate Vundef (call_cont k) m') + | step_return_1: forall f a k e le m v v' m', + eval_expr e le m a v -> + cast v (typeof a) f.(fn_return) v' -> + Mem.free_list m (blocks_of_env e) = Some m' -> + step (State f (Sreturn (Some a)) k e le m) + E0 (Returnstate v' (call_cont k) m') + | step_skip_call: forall f k e le m m', + is_call_cont k -> + f.(fn_return) = Tvoid -> + Mem.free_list m (blocks_of_env e) = Some m' -> + step (State f Sskip k e le m) + E0 (Returnstate Vundef k m') + + | step_switch: forall f a sl k e le m n, + eval_expr e le m a (Vint n) -> + step (State f (Sswitch a sl) k e le m) + E0 (State f (seq_of_labeled_statement (select_switch n sl)) (Kswitch k) e le m) + | step_skip_break_switch: forall f x k e le m, + x = Sskip \/ x = Sbreak -> + step (State f x (Kswitch k) e le m) + E0 (State f Sskip k e le m) + | step_continue_switch: forall f k e le m, + step (State f Scontinue (Kswitch k) e le m) + E0 (State f Scontinue k e le m) + + | step_label: forall f lbl s k e le m, + step (State f (Slabel lbl s) k e le m) + E0 (State f s k e le m) + + | step_goto: forall f lbl k e le m s' k', + find_label lbl f.(fn_body) (call_cont k) = Some (s', k') -> + step (State f (Sgoto lbl) k e le m) + E0 (State f s' k' e le m) + + | step_internal_function: forall f vargs k m e m1 m2, + list_norepet (var_names f.(fn_params) ++ var_names f.(fn_vars)) -> + alloc_variables empty_env m (f.(fn_params) ++ f.(fn_vars)) e m1 -> + bind_parameters e m1 f.(fn_params) vargs m2 -> + step (Callstate (Internal f) vargs k m) + E0 (State f f.(fn_body) k e (PTree.empty val) m2) + + | step_external_function: forall ef targs tres vargs k m vres t m', + external_call ef ge vargs m t vres m' -> + step (Callstate (External ef targs tres) vargs k m) + t (Returnstate vres k m') + + | step_returnstate_none: forall v f e le k m, + step (Returnstate v (Kcall None f e le k) m) + E0 (State f Sskip k e le m) + | step_returnstate_some: forall v id f e le k m, + step (Returnstate v (Kcall (Some id) f e le k) m) + E0 (State f Sskip k e (PTree.set id v le) m). + +End SEMANTICS. + +(** * Whole-program semantics *) + +(** Execution of whole programs are described as sequences of transitions + from an initial state to a final state. An initial state is a [Callstate] + corresponding to the invocation of the ``main'' function of the program + without arguments and with an empty continuation. *) + +Inductive initial_state (p: program): state -> Prop := + | initial_state_intro: forall b f m0, + let ge := Genv.globalenv p in + Genv.init_mem p = Some m0 -> + 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) -> + initial_state p (Callstate f nil Kstop m0). + +(** A final state is a [Returnstate] with an empty continuation. *) + +Inductive final_state: state -> int -> Prop := + | final_state_intro: forall r m, + final_state (Returnstate (Vint r) Kstop m) r. + +(** Execution of a whole program: [exec_program p beh] + holds if the application of [p]'s main function to no arguments + in the initial memory state for [p] has [beh] as observable + behavior. *) + +Definition exec_program (p: program) (beh: program_behavior) : Prop := + program_behaves step (initial_state p) final_state (Genv.globalenv p) beh. diff --git a/cfrontend/Cminorgen.v b/cfrontend/Cminorgen.v index e60de3d..22c3a5a 100644 --- a/cfrontend/Cminorgen.v +++ b/cfrontend/Cminorgen.v @@ -48,6 +48,9 @@ Open Local Scope error_monad_scope. of Cminor. *) +Definition for_var (id: ident) : ident := xO id. +Definition for_temp (id: ident) : ident := xI id. + (** Compile-time information attached to each Csharpminor variable: global variables, local variables, function parameters. [Var_local] denotes a scalar local variable whose address is not @@ -66,128 +69,7 @@ Inductive var_info: Type := Definition compilenv := PMap.t var_info. -(** Infer the type or memory chunk of the result of an expression. *) - -Definition chunktype_const (c: Csharpminor.constant) := - match c with - | Csharpminor.Ointconst n => - if Int.ltu n (Int.repr 256) then Mint8unsigned - else if Int.ltu n (Int.repr 65536) then Mint16unsigned - else Mint32 - | Csharpminor.Ofloatconst n => Mfloat64 - end. - -Definition chunktype_unop (op: unary_operation) := - match op with - | Ocast8unsigned => Mint8unsigned - | Ocast8signed => Mint8signed - | Ocast16unsigned => Mint16unsigned - | Ocast16signed => Mint16signed - | Onegint => Mint32 - | Onotbool => Mint8unsigned - | Onotint => Mint32 - | Onegf => Mfloat64 - | Oabsf => Mfloat64 - | Osingleoffloat => Mfloat32 - | Ointoffloat => Mint32 - | Ointuoffloat => Mint32 - | Ofloatofint => Mfloat64 - | Ofloatofintu => Mfloat64 - end. - -Definition chunktype_logical_op (chunk1 chunk2: memory_chunk) := - match chunk1, chunk2 with - | Mint8unsigned, Mint8unsigned => Mint8unsigned - | Mint8unsigned, Mint16unsigned => Mint16unsigned - | Mint16unsigned, Mint8unsigned => Mint16unsigned - | Mint16unsigned, Mint16unsigned => Mint16unsigned - | _, _ => Mint32 - end. - -Definition chunktype_binop (op: binary_operation) (chunk1 chunk2: memory_chunk) := - match op with - | Oadd => Mint32 - | Osub => Mint32 - | Omul => Mint32 - | Odiv => Mint32 - | Odivu => Mint32 - | Omod => Mint32 - | Omodu => Mint32 - | Oand => chunktype_logical_op chunk1 chunk2 - | Oor => chunktype_logical_op chunk1 chunk2 - | Oxor => chunktype_logical_op chunk1 chunk2 - | Oshl => Mint32 - | Oshr => Mint32 - | Oshru => Mint32 - | Oaddf => Mfloat64 - | Osubf => Mfloat64 - | Omulf => Mfloat64 - | Odivf => Mfloat64 - | Ocmp c => Mint8unsigned - | Ocmpu c => Mint8unsigned - | Ocmpf c => Mint8unsigned - end. - -Definition chunktype_compat (src dst: memory_chunk) : bool := - match src, dst with - | Mint8unsigned, (Mint8unsigned|Mint16unsigned|Mint16signed|Mint32) => true - | Mint8signed, (Mint8signed|Mint16signed|Mint32) => true - | Mint16unsigned, (Mint16unsigned|Mint32) => true - | Mint16signed, (Mint16signed|Mint32) => true - | Mint32, Mint32 => true - | Mfloat32, (Mfloat32|Mfloat64) => true - | Mfloat64, Mfloat64 => true - | _, _ => false - end. - -Definition chunk_for_type (ty: typ) : memory_chunk := - match ty with Tint => Mint32 | Tfloat => Mfloat64 end. - -Definition chunktype_merge (c1 c2: memory_chunk) : res memory_chunk := - if chunktype_compat c1 c2 then - OK c2 - else if chunktype_compat c2 c1 then - OK c1 - else if typ_eq (type_of_chunk c1) (type_of_chunk c2) then - OK (chunk_for_type (type_of_chunk c1)) - else - Error(msg "Cminorgen: chunktype_merge"). - -Fixpoint chunktype_expr (cenv: compilenv) (e: Csharpminor.expr) - {struct e}: res memory_chunk := - match e with - | Csharpminor.Evar id => - match cenv!!id with - | Var_local chunk => OK chunk - | Var_stack_scalar chunk ofs => OK chunk - | Var_global_scalar chunk => OK chunk - | _ => Error(msg "Cminorgen.chunktype_expr") - end - | Csharpminor.Eaddrof id => - OK Mint32 - | Csharpminor.Econst cst => - OK (chunktype_const cst) - | Csharpminor.Eunop op e1 => - OK (chunktype_unop op) - | Csharpminor.Ebinop op e1 e2 => - do chunk1 <- chunktype_expr cenv e1; - do chunk2 <- chunktype_expr cenv e2; - OK (chunktype_binop op chunk1 chunk2) - | Csharpminor.Eload chunk e => - OK chunk - | Csharpminor.Econdition e1 e2 e3 => - do chunk2 <- chunktype_expr cenv e2; - do chunk3 <- chunktype_expr cenv e3; - chunktype_merge chunk2 chunk3 - end. - -Definition type_expr (cenv: compilenv) (e: Csharpminor.expr): res typ := - do c <- chunktype_expr cenv e; OK(type_of_chunk c). - -Definition type_exprlist (cenv: compilenv) (el: list Csharpminor.expr): - res (list typ) := - mmap (type_expr cenv) el. - +(***** (** [make_cast chunk e] returns a Cminor expression that normalizes the value of Cminor expression [e] as prescribed by the memory chunk [chunk]. For instance, 8-bit sign extension is performed if @@ -203,6 +85,7 @@ Definition make_cast (chunk: memory_chunk) (e: expr): expr := | Mfloat32 => Eunop Osingleoffloat e | Mfloat64 => e end. +**********) (** When the translation of an expression is stored in memory, a cast at the toplevel of the expression can be redundant @@ -233,24 +116,12 @@ Definition make_stackaddr (ofs: Z): expr := Definition make_globaladdr (id: ident): expr := Econst (Oaddrsymbol id Int.zero). -(** Auxiliary to remove useless conversions. *) - -Definition unop_is_cast (op: unary_operation) : option memory_chunk := - match op with - | Ocast8unsigned => Some Mint8unsigned - | Ocast8signed => Some Mint8signed - | Ocast16unsigned => Some Mint16unsigned - | Ocast16signed => Some Mint16signed - | Osingleoffloat => Some Mfloat32 - | _ => None - end. - (** Generation of a Cminor expression for reading a Csharpminor variable. *) Definition var_get (cenv: compilenv) (id: ident): res expr := match PMap.get id cenv with | Var_local chunk => - OK(Evar id) + OK(Evar (for_var id)) | Var_stack_scalar chunk ofs => OK(Eload chunk (make_stackaddr ofs)) | Var_global_scalar chunk => @@ -271,45 +142,33 @@ Definition var_addr (cenv: compilenv) (id: ident): res expr := end. (** Generation of a Cminor statement performing an assignment to - a variable. [rhs_chunk] is the inferred chunk type for the - right-hand side. If the variable was allocated to a Cminor variable, - a cast may need to be inserted to normalize the value of the r.h.s., - as per Csharpminor's semantics. *) + a variable. The value being assigned is normalized according to + its chunk type, as guaranteed by C#minor semantics. *) Definition var_set (cenv: compilenv) - (id: ident) (rhs: expr) (rhs_chunk: memory_chunk): res stmt := + (id: ident) (rhs: expr): res stmt := match PMap.get id cenv with | Var_local chunk => - if chunktype_compat rhs_chunk chunk then - OK(Sassign id rhs) - else if typ_eq (type_of_chunk chunk) (type_of_chunk rhs_chunk) then - OK(Sassign id (make_cast chunk rhs)) - else - Error(msg "Cminorgen.var_set.1") + OK(Sassign (for_var id) rhs) | Var_stack_scalar chunk ofs => OK(make_store chunk (make_stackaddr ofs) rhs) | Var_global_scalar chunk => OK(make_store chunk (make_globaladdr id) rhs) | _ => - Error(msg "Cminorgen.var_set.2") + Error(msg "Cminorgen.var_set") end. -(** A variant of [var_set] used for initializing function parameters - and storing the return values of function calls. The value to - be stored already resides in the Cminor variable called [id]. - Moreover, its chunk type is not known, only its int-or-float type. *) +(** A variant of [var_set] used for initializing function parameters. + The value to be stored already resides in the Cminor variable called [id]. *) -Definition var_set_self (cenv: compilenv) (id: ident) (ty: typ): res stmt := +Definition var_set_self (cenv: compilenv) (id: ident) (ty: typ) (k: stmt): res stmt := match PMap.get id cenv with | Var_local chunk => - if typ_eq (type_of_chunk chunk) ty then - OK(Sassign id (make_cast chunk (Evar id))) - else - Error(msg "Cminorgen.var_set_self.1") + OK k | Var_stack_scalar chunk ofs => - OK(make_store chunk (make_stackaddr ofs) (Evar id)) + OK (Sseq (make_store chunk (make_stackaddr ofs) (Evar (for_var id))) k) | Var_global_scalar chunk => - OK(make_store chunk (make_globaladdr id) (Evar id)) + OK (Sseq (make_store chunk (make_globaladdr id) (Evar (for_var id))) k) | _ => Error(msg "Cminorgen.var_set_self.2") end. @@ -329,19 +188,13 @@ Fixpoint transl_expr (cenv: compilenv) (e: Csharpminor.expr) {struct e}: res expr := match e with | Csharpminor.Evar id => var_get cenv id + | Csharpminor.Etempvar id => OK (Evar (for_temp id)) | Csharpminor.Eaddrof id => var_addr cenv id | Csharpminor.Econst cst => OK (Econst (transl_constant cst)) | Csharpminor.Eunop op e1 => do te1 <- transl_expr cenv e1; - match unop_is_cast op with - | None => OK (Eunop op te1) - | Some chunk => - do chunk1 <- chunktype_expr cenv e1; - if chunktype_compat chunk1 chunk - then OK te1 - else OK (Eunop op te1) - end + OK (Eunop op te1) | Csharpminor.Ebinop op e1 e2 => do te1 <- transl_expr cenv e1; do te2 <- transl_expr cenv e2; @@ -425,28 +278,19 @@ Fixpoint transl_stmt (ret: option typ) (cenv: compilenv) | Csharpminor.Sskip => OK Sskip | Csharpminor.Sassign id e => - do chunk <- chunktype_expr cenv e; do te <- transl_expr cenv e; - var_set cenv id te chunk + var_set cenv id te + | Csharpminor.Sset id e => + do te <- transl_expr cenv e; + OK (Sassign (for_temp id) te) | Csharpminor.Sstore chunk e1 e2 => do te1 <- transl_expr cenv e1; do te2 <- transl_expr cenv e2; OK (make_store chunk te1 te2) - | Csharpminor.Scall None sig e el => - do te <- transl_expr cenv e; - do tel <- transl_exprlist cenv el; - do tyl <- type_exprlist cenv el; - if list_eq_dec typ_eq tyl sig.(sig_args) - then OK (Scall None sig te tel) - else Error(msg "Cminorgen.transl_stmt(call0)") - | Csharpminor.Scall (Some id) sig e el => + | Csharpminor.Scall optid sig e el => do te <- transl_expr cenv e; do tel <- transl_exprlist cenv el; - do tyl <- type_exprlist cenv el; - do s <- var_set_self cenv id (proj_sig_res sig); - if list_eq_dec typ_eq tyl sig.(sig_args) - then OK (Sseq (Scall (Some id) sig te tel) s) - else Error(msg "Cminorgen.transl_stmt(call1)") + OK (Scall (option_map for_temp optid) sig te tel) | Csharpminor.Sseq s1 s2 => do ts1 <- transl_stmt ret cenv xenv s1; do ts2 <- transl_stmt ret cenv xenv s2; @@ -473,10 +317,7 @@ Fixpoint transl_stmt (ret: option typ) (cenv: compilenv) OK (Sreturn None) | Csharpminor.Sreturn (Some e) => do te <- transl_expr cenv e; - do ty <- type_expr cenv e; - if typ_eq ty (typ_of_opttyp ret) - then OK (Sreturn (Some te)) - else Error(msg "Cminorgen.transl_stmt(return)") + OK (Sreturn (Some te)) | Csharpminor.Slabel lbl s => do ts <- transl_stmt ret cenv xenv s; OK (Slabel lbl ts) | Csharpminor.Sgoto lbl => @@ -503,6 +344,7 @@ Module Identset := FSetAVL.Make(OrderedPositive). Fixpoint addr_taken_expr (e: Csharpminor.expr): Identset.t := match e with | Csharpminor.Evar id => Identset.empty + | Csharpminor.Etempvar id => Identset.empty | Csharpminor.Eaddrof id => Identset.add id Identset.empty | Csharpminor.Econst cst => Identset.empty | Csharpminor.Eunop op e1 => addr_taken_expr e1 @@ -525,6 +367,7 @@ Fixpoint addr_taken_stmt (s: Csharpminor.stmt): Identset.t := match s with | Csharpminor.Sskip => Identset.empty | Csharpminor.Sassign id e => addr_taken_expr e + | Csharpminor.Sset id e => addr_taken_expr e | Csharpminor.Sstore chunk e1 e2 => Identset.union (addr_taken_expr e1) (addr_taken_expr e2) | Csharpminor.Scall optid sig e el => @@ -601,8 +444,11 @@ Definition build_compilenv Definition assign_global_variable (ce: compilenv) (info: ident * globvar var_kind) : compilenv := match info with - | (id, mkglobvar (Vscalar chunk) _ _ _ ) => PMap.set id (Var_global_scalar chunk) ce - | (id, mkglobvar (Varray _) _ _ _) => PMap.set id Var_global_array ce + | (id, mkglobvar vk _ _ _) => + PMap.set id (match vk with Vscalar chunk => Var_global_scalar chunk + | Varray _ => Var_global_array + end) + ce end. Definition build_global_compilenv (p: Csharpminor.program) : compilenv := @@ -619,45 +465,10 @@ Fixpoint store_parameters match params with | nil => OK Sskip | (id, chunk) :: rem => - do s1 <- var_set_self cenv id (type_of_chunk chunk); - do s2 <- store_parameters cenv rem; - OK (Sseq s1 s2) + do s <- store_parameters cenv rem; + var_set_self cenv id (type_of_chunk chunk) s end. -(** The local variables of the generated Cminor function - must include all local variables of the C#minor function - (to help the proof in [Cminorgenproof] go through). - We must also add the destinations [x] of calls [x = f(args)], - because some of these [x] can be global variables and therefore - not part of the C#minor local variables. *) - -Fixpoint call_dest (s: stmt) : Identset.t := - match s with - | Sskip => Identset.empty - | Sassign x e => Identset.empty - | Sstore chunk e1 e2 => Identset.empty - | Scall None sg e el => Identset.empty - | Scall (Some x) sg e el => Identset.singleton x - | Stailcall sg e el => Identset.empty - | Sseq s1 s2 => Identset.union (call_dest s1) (call_dest s2) - | Sifthenelse e s1 s2 => Identset.union (call_dest s1) (call_dest s2) - | Sloop s1 => call_dest s1 - | Sblock s1 => call_dest s1 - | Sexit n => Identset.empty - | Sswitch e cases dfl => Identset.empty - | Sreturn opte => Identset.empty - | Slabel lbl s1 => call_dest s1 - | Sgoto lbl => Identset.empty - end. - -Definition identset_removelist (l: list ident) (s: Identset.t) : Identset.t := - List.fold_right Identset.remove s l. - -Definition make_vars (params: list ident) (vars: list ident) - (body: Cminor.stmt) : list ident := - vars ++ - Identset.elements (identset_removelist (params ++ vars) (call_dest body)). - (** Translation of a Csharpminor function. We must check that the required Cminor stack block is no bigger than [Int.max_signed], otherwise address computations within the stack block could @@ -669,10 +480,9 @@ Definition transl_funbody do sparams <- store_parameters cenv f.(Csharpminor.fn_params); OK (mkfunction (Csharpminor.fn_sig f) - (Csharpminor.fn_params_names f) - (make_vars (Csharpminor.fn_params_names f) - (Csharpminor.fn_vars_names f) - (Sseq sparams tbody)) + (List.map for_var (Csharpminor.fn_params_names f)) + (List.map for_var (Csharpminor.fn_vars_names f) ++ + List.map for_temp (Csharpminor.fn_temps f)) stacksize (Sseq sparams tbody)). diff --git a/cfrontend/Cminorgenproof.v b/cfrontend/Cminorgenproof.v index bb7d95a..e28228a 100644 --- a/cfrontend/Cminorgenproof.v +++ b/cfrontend/Cminorgenproof.v @@ -40,8 +40,6 @@ Variable prog: Csharpminor.program. Variable tprog: program. Hypothesis TRANSL: transl_program prog = OK tprog. Let ge : Csharpminor.genv := Genv.globalenv prog. -Let gvare : gvarenv := global_var_env prog. -Let gve := (ge, gvare). Let gce : compilenv := build_global_compilenv prog. Let tge: genv := Genv.globalenv tprog. @@ -83,35 +81,42 @@ Proof. intro. inv H. reflexivity. Qed. -Definition global_compilenv_match (ce: compilenv) (gv: gvarenv) : Prop := +Definition global_compilenv_match (ce: compilenv) (ge: Csharpminor.genv) : Prop := forall id, match ce!!id with - | Var_global_scalar chunk => gv!id = Some (Vscalar chunk) + | Var_global_scalar chunk => + forall b gv, Genv.find_symbol ge id = Some b -> + Genv.find_var_info ge b = Some gv -> + gv.(gvar_info) = Vscalar chunk | Var_global_array => True | _ => False end. Lemma global_compilenv_charact: - global_compilenv_match gce gvare. -Proof. - set (mkgve := fun gv (vars: list (ident * globvar var_kind)) => - List.fold_left - (fun gve x => match x with (id, v) => PTree.set id v.(gvar_info) gve end) - vars gv). - assert (forall vars gv ce, - global_compilenv_match ce gv -> - global_compilenv_match (List.fold_left assign_global_variable vars ce) - (mkgve gv vars)). - induction vars; simpl; intros. - auto. - apply IHvars. intro id1. unfold assign_global_variable. - destruct a as [id2 lv2]. destruct lv2. destruct gvar_info; simpl; rewrite PMap.gsspec; rewrite PTree.gsspec. - case (peq id1 id2); intro. auto. apply H. - case (peq id1 id2); intro. auto. apply H. - - change gvare with (mkgve (PTree.empty var_kind) prog.(prog_vars)). - unfold gce, build_global_compilenv. apply H. - intro. rewrite PMap.gi. auto. + global_compilenv_match gce ge. +Proof. + assert (A: forall ge, global_compilenv_match (PMap.init Var_global_array) ge). + intros; red; intros. rewrite PMap.gi. auto. + assert (B: forall ce ge v, + global_compilenv_match ce ge -> + global_compilenv_match (assign_global_variable ce v) + (Genv.add_variable ge v)). + intros; red; intros. destruct v as [id1 [info1 init1 ro1 vo1]]. + unfold assign_global_variable, Genv.find_symbol, Genv.find_var_info; simpl. + rewrite PMap.gsspec. destruct (peq id id1). subst id. + destruct info1; auto. + rewrite PTree.gss. intros. inv H0. rewrite ZMap.gss in H1. inv H1. auto. + generalize (H id). destruct (ce!!id); auto. + rewrite PTree.gso; auto. intros. rewrite ZMap.gso in H2. eapply H0; eauto. + exploit Genv.genv_symb_range; eauto. unfold block, ZIndexed.t; omega. + assert (C: forall vl ce ge, + global_compilenv_match ce ge -> + global_compilenv_match (fold_left assign_global_variable vl ce) + (Genv.add_variables ge vl)). + induction vl; simpl; intros. auto. apply IHvl. apply B. auto. + + unfold gce, build_global_compilenv, ge, Genv.globalenv. + apply C. apply A. Qed. (** * Derived properties of memory operations *) @@ -192,182 +197,6 @@ Proof. eapply Mem.nextblock_store; eauto. Qed. -(** * Normalized values and operations over memory chunks *) - -(** A value is normalized with respect to a memory chunk if it is - invariant under the cast (truncation, sign extension) corresponding to - the chunk. *) - -Definition val_normalized (v: val) (chunk: memory_chunk) : Prop := - Val.load_result chunk v = v. - -Lemma val_normalized_has_type: - forall chunk v, val_normalized v chunk -> Val.has_type v (type_of_chunk chunk). -Proof. - intros until v; unfold val_normalized, Val.load_result. - destruct chunk; destruct v; intro EQ; try (inv EQ); simpl; exact I. -Qed. - -Lemma val_has_type_normalized: - forall ty v, Val.has_type v ty -> val_normalized v (chunk_for_type ty). -Proof. - unfold Val.has_type, val_normalized; intros; destruct ty; destruct v; - contradiction || reflexivity. -Qed. - -Lemma chunktype_compat_correct: - forall src dst v, - chunktype_compat src dst = true -> - val_normalized v src -> val_normalized v dst. -Proof. - unfold val_normalized; intros. rewrite <- H0. - assert (A: 0 < 8 < Z_of_nat Int.wordsize). compute; auto. - assert (B: 0 < 16 < Z_of_nat Int.wordsize). compute; auto. - assert (C: 8 <= 16 < Z_of_nat Int.wordsize). omega. - destruct src; destruct dst; simpl in H; try discriminate; auto; - destruct v; simpl; auto. - rewrite Int.sign_ext_idem; auto. - rewrite Int.sign_ext_widen; auto. - rewrite Int.zero_ext_idem; auto. - rewrite Int.sign_zero_ext_widen; auto. - rewrite Int.zero_ext_widen; auto. - rewrite Int.sign_ext_widen; auto. omega. - rewrite Int.zero_ext_idem; auto. - rewrite Float.singleoffloat_idem; auto. -Qed. - -Remark int_zero_ext_small: - forall x n, - 0 <= Int.unsigned x < two_p n -> - Int.zero_ext n x = x. -Proof. - intros. unfold Int.zero_ext. rewrite Zmod_small; auto. apply Int.repr_unsigned. -Qed. - -Lemma chunktype_const_correct: - forall c v, - Csharpminor.eval_constant c = Some v -> - val_normalized v (chunktype_const c). -Proof. - unfold Csharpminor.eval_constant; intros. - destruct c; inv H; unfold val_normalized; simpl. - case_eq (Int.ltu i (Int.repr 256)); intros. - simpl. decEq. apply int_zero_ext_small. exact (Int.ltu_inv _ _ H). - case_eq (Int.ltu i (Int.repr 65536)); intros. - simpl. decEq. apply int_zero_ext_small. exact (Int.ltu_inv _ _ H0). - simpl; auto. - auto. -Qed. - -Lemma chunktype_unop_correct: - forall op v1 v, - Csharpminor.eval_unop op v1 = Some v -> - val_normalized v (chunktype_unop op). -Proof. - intros; destruct op; simpl in *; unfold val_normalized. - inv H. destruct v1; simpl; auto. rewrite Int.zero_ext_idem; auto. compute; auto. - inv H. destruct v1; simpl; auto. rewrite Int.sign_ext_idem; auto. compute; auto. - inv H. destruct v1; simpl; auto. rewrite Int.zero_ext_idem; auto. compute; auto. - inv H. destruct v1; simpl; auto. rewrite Int.sign_ext_idem; auto. compute; auto. - destruct v1; inv H; auto. - destruct v1; inv H. destruct (Int.eq i Int.zero); auto. reflexivity. - destruct v1; inv H; auto. - destruct v1; inv H; auto. - destruct v1; inv H; auto. - inv H. destruct v1; simpl; auto. rewrite Float.singleoffloat_idem; auto. - destruct v1; inv H; auto. - destruct v1; inv H; auto. - destruct v1; inv H; auto. - destruct v1; inv H; auto. -Qed. - -Lemma chunktype_logical_op_correct: - forall (logop: int -> int -> int) - (DISTR: forall a b c, logop (Int.and a c) (Int.and b c) = - Int.and (logop a b) c) - n1 c1 n2 c2, - val_normalized (Vint n1) c1 -> val_normalized (Vint n2) c2 -> - val_normalized (Vint (logop n1 n2)) (chunktype_logical_op c1 c2). -Proof. - intros. set (c := chunktype_logical_op c1 c2). - assert (val_normalized (Vint n1) c /\ val_normalized (Vint n2) c). - unfold c, chunktype_logical_op. - destruct c1; destruct c2; split; try (auto; unfold val_normalized; reflexivity). - apply chunktype_compat_correct with Mint8unsigned; auto. - apply chunktype_compat_correct with Mint8unsigned; auto. - destruct H1. - assert (c = Mint8unsigned \/ c = Mint16unsigned \/ c = Mint32). - unfold c. destruct c1; auto; destruct c2; auto. - destruct H3 as [A | [A | A]]; rewrite A in *. - unfold val_normalized in *. simpl in *. - assert (0 < 8 < Z_of_nat Int.wordsize). compute; auto. - rewrite Int.zero_ext_and in *; auto. - set (m := Int.repr (two_p 8 - 1)) in *. - rewrite <- DISTR. congruence. - unfold val_normalized in *. simpl in *. - assert (0 < 16 < Z_of_nat Int.wordsize). compute; auto. - rewrite Int.zero_ext_and in *; auto. - set (m := Int.repr (two_p 16 - 1)) in *. - rewrite <- DISTR. congruence. - red. auto. -Qed. - -Lemma chunktype_binop_correct: - forall op v1 v2 c1 c2 m v, - Csharpminor.eval_binop op v1 v2 m = Some v -> - val_normalized v1 c1 -> val_normalized v2 c2 -> - val_normalized v (chunktype_binop op c1 c2). -Proof. - intros; destruct op; simpl in *; unfold val_normalized; - destruct v1; destruct v2; try (inv H; reflexivity). - destruct (eq_block b b0); inv H; auto. - destruct (Int.eq i0 Int.zero); inv H; auto. - destruct (Int.eq i0 Int.zero); inv H; auto. - destruct (Int.eq i0 Int.zero); inv H; auto. - destruct (Int.eq i0 Int.zero); inv H; auto. - inv H. apply chunktype_logical_op_correct; auto. - intros. repeat rewrite Int.and_assoc. decEq. - rewrite (Int.and_commut b c). rewrite <- Int.and_assoc. rewrite Int.and_idem. auto. - inv H. apply chunktype_logical_op_correct; auto. - intros. rewrite (Int.and_commut a c). rewrite (Int.and_commut b c). - rewrite <- Int.and_or_distrib. apply Int.and_commut. - inv H. apply chunktype_logical_op_correct; auto. - intros. rewrite (Int.and_commut a c). rewrite (Int.and_commut b c). - rewrite <- Int.and_xor_distrib. apply Int.and_commut. - destruct (Int.ltu i0 Int.iwordsize); inv H; auto. - destruct (Int.ltu i0 Int.iwordsize); inv H; auto. - destruct (Int.ltu i0 Int.iwordsize); inv H; auto. - inv H; destruct (Int.cmp c i i0); reflexivity. - unfold eval_compare_null in H. destruct (Int.eq i Int.zero). - destruct c; inv H; auto. inv H. - unfold eval_compare_null in H. destruct (Int.eq i0 Int.zero). - destruct c; inv H; auto. inv H. - destruct (Mem.valid_pointer m b (Int.signed i) && - Mem.valid_pointer m b0 (Int.signed i0)). - destruct (eq_block b b0); inv H. destruct (Int.cmp c i i0); auto. - destruct c; inv H3; auto. inv H. - inv H. destruct (Int.cmpu c i i0); auto. - inv H. destruct (Float.cmp c f f0); auto. -Qed. - -Lemma chunktype_merge_correct: - forall c1 c2 c v, - chunktype_merge c1 c2 = OK c -> - val_normalized v c1 \/ val_normalized v c2 -> - val_normalized v c. -Proof. - intros until v. unfold chunktype_merge. - case_eq (chunktype_compat c1 c2). - intros. inv H0. destruct H1. eapply chunktype_compat_correct; eauto. auto. - case_eq (chunktype_compat c2 c1). - intros. inv H1. destruct H2. auto. eapply chunktype_compat_correct; eauto. - intros. destruct (typ_eq (type_of_chunk c1) (type_of_chunk c2)); inv H1. - apply val_has_type_normalized. destruct H2. - apply val_normalized_has_type. auto. - rewrite e. apply val_normalized_has_type. auto. -Qed. - - (** * Correspondence between Csharpminor's and Cminor's environments and memory states *) (** In Csharpminor, every variable is stored in a separate memory block. @@ -407,7 +236,7 @@ Inductive match_var (f: meminj) (id: ident) PTree.get id e = Some (b, Vscalar chunk) -> Mem.load chunk m b 0 = Some v -> f b = None -> - PTree.get id te = Some v' -> + PTree.get (for_var id) te = Some v' -> val_inject f v v' -> match_var f id e m te sp (Var_local chunk) | match_var_stack_scalar: @@ -423,7 +252,9 @@ Inductive match_var (f: meminj) (id: ident) | match_var_global_scalar: forall chunk, PTree.get id e = None -> - PTree.get id gvare = Some (Vscalar chunk) -> + (forall b gv, Genv.find_symbol ge id = Some b -> + Genv.find_var_info ge b = Some gv -> + gvar_info gv = Vscalar chunk) -> match_var f id e m te sp (Var_global_scalar chunk) | match_var_global_array: PTree.get id e = None -> @@ -434,7 +265,8 @@ Inductive match_var (f: meminj) (id: ident) of addresses for the blocks referenced from [te]. *) Record match_env (f: meminj) (cenv: compilenv) - (e: Csharpminor.env) (m: mem) (te: env) (sp: block) + (e: Csharpminor.env) (le: Csharpminor.temp_env) (m: mem) + (te: env) (sp: block) (lo hi: Z) : Prop := mk_match_env { @@ -443,6 +275,11 @@ Record match_env (f: meminj) (cenv: compilenv) me_vars: forall id, match_var f id e m te sp (PMap.get id cenv); +(** Temporaries match *) + me_temps: + forall id v, le!id = Some v -> + exists v', te!(for_temp id) = Some v' /\ val_inject f v v'; + (** [lo, hi] is a proper interval. *) me_low_high: lo <= hi; @@ -490,11 +327,11 @@ Ltac geninv x := let H := fresh in (generalize x; intro H; inv H). Lemma match_env_store_mapped: - forall f cenv e m1 m2 te sp lo hi chunk b ofs v, + forall f cenv e le m1 m2 te sp lo hi chunk b ofs v, f b <> None -> Mem.store chunk m1 b ofs v = Some m2 -> - match_env f cenv e m1 te sp lo hi -> - match_env f cenv e m2 te sp lo hi. + match_env f cenv e le m1 te sp lo hi -> + match_env f cenv e le m2 te sp lo hi. Proof. intros; inv H1; constructor; auto. (* vars *) @@ -507,17 +344,24 @@ Qed. (** Preservation by assignment to a Csharpminor variable that is translated to a Cminor local variable. The value being assigned - must be normalized with respect to the memory chunk of the variable, - in the following sense. *) + must be normalized with respect to the memory chunk of the variable. *) + +Remark val_normalized_has_type: + forall v chunk, + val_normalized v chunk -> Val.has_type v (type_of_chunk chunk). +Proof. + intros. red in H. rewrite <- H. + destruct chunk; destruct v; exact I. +Qed. Lemma match_env_store_local: - forall f cenv e m1 m2 te sp lo hi id b chunk v tv, + forall f cenv e le m1 m2 te sp lo hi id b chunk v tv, e!id = Some(b, Vscalar chunk) -> - Val.has_type v (type_of_chunk chunk) -> - val_inject f (Val.load_result chunk v) tv -> + val_normalized v chunk -> + val_inject f v tv -> Mem.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. + match_env f cenv e le m1 te sp lo hi -> + match_env f cenv e le m2 (PTree.set (for_var id) tv te) sp lo hi. Proof. intros. inv H3. constructor; auto. (* vars *) @@ -529,13 +373,13 @@ Proof. assert (b0 = b) by congruence. subst. assert (chunk0 = chunk) by congruence. subst. econstructor. eauto. - eapply Mem.load_store_same; eauto. auto. + eapply Mem.load_store_same; eauto. apply val_normalized_has_type; auto. auto. rewrite PTree.gss. reflexivity. - auto. + red in H0. rewrite H0. auto. (* a different variable *) econstructor; eauto. rewrite <- H6. eapply Mem.load_store_other; eauto. - rewrite PTree.gso; auto. + rewrite PTree.gso; auto. unfold for_var; congruence. (* var_stack_scalar *) econstructor; eauto. (* var_stack_array *) @@ -544,22 +388,52 @@ Proof. econstructor; eauto. (* var_global_array *) econstructor; eauto. + (* temps *) + intros. rewrite PTree.gso. auto. unfold for_temp, for_var; congruence. (* bounds *) intros. rewrite (Mem.bounds_store _ _ _ _ _ _ H2). eauto. Qed. +(** Preservation by assignment to a Csharpminor temporary and the + corresponding Cminor local variable. *) + +Lemma match_env_set_temp: + forall f cenv e le m te sp lo hi id v tv, + val_inject f v tv -> + match_env f cenv e le m te sp lo hi -> + match_env f cenv e (PTree.set id v le) m (PTree.set (for_temp id) tv te) sp lo hi. +Proof. + intros. inv H0. constructor; auto. + (* vars *) + intros. geninv (me_vars0 id0). + (* var_local *) + econstructor; eauto. rewrite PTree.gso. auto. unfold for_var, for_temp; congruence. + (* var_stack_scalar *) + econstructor; eauto. + (* var_stack_array *) + econstructor; eauto. + (* var_global_scalar *) + econstructor; eauto. + (* var_global_array *) + econstructor; eauto. + (* temps *) + intros. rewrite PTree.gsspec in H0. destruct (peq id0 id). + inv H0. exists tv; split; auto. apply PTree.gss. + rewrite PTree.gso. eauto. unfold for_temp; congruence. +Qed. + (** The [match_env] relation is preserved by any memory operation that preserves sizes and loads from blocks in the [lo, hi] range. *) Lemma match_env_invariant: - forall f cenv e m1 m2 te sp lo hi, + forall f cenv e le m1 m2 te sp lo hi, (forall b ofs chunk v, lo <= b < hi -> Mem.load chunk m1 b ofs = Some v -> Mem.load chunk m2 b ofs = Some v) -> (forall b, lo <= b < hi -> Mem.bounds m2 b = Mem.bounds m1 b) -> - match_env f cenv e m1 te sp lo hi -> - match_env f cenv e m2 te sp lo hi. + match_env f cenv e le m1 te sp lo hi -> + match_env f cenv e le m2 te sp lo hi. Proof. intros. inv H1. constructor; eauto. (* vars *) @@ -571,14 +445,15 @@ Qed. (** [match_env] is insensitive to the Cminor values of stack-allocated data. *) Lemma match_env_extensional: - forall f cenv e m te1 sp lo hi te2, - match_env f cenv e m te1 sp lo hi -> - (forall id chunk, cenv!!id = Var_local chunk -> te2!id = te1!id) -> - match_env f cenv e m te2 sp lo hi. + forall f cenv e le m te1 sp lo hi te2, + match_env f cenv e le m te1 sp lo hi -> + (forall id chunk, cenv!!id = Var_local chunk -> te2!(for_var id) = te1!(for_var id)) -> + (forall id v, le!id = Some v -> te2!(for_temp id) = te1!(for_temp id)) -> + match_env f cenv e le m te2 sp lo hi. Proof. intros. inv H; econstructor; eauto. - intros. geninv (me_vars0 id); econstructor; eauto. - rewrite <- H5. eauto. + intros. geninv (me_vars0 id); econstructor; eauto. rewrite <- H6. eauto. + intros. rewrite (H1 _ _ H). auto. Qed. (** [match_env] and allocations *) @@ -592,15 +467,15 @@ Inductive alloc_condition: var_info -> var_kind -> block -> option (block * Z) - alloc_condition (Var_stack_array pos) (Varray sz) sp (Some(sp, pos)). Lemma match_env_alloc_same: - forall f1 cenv e m1 te sp lo lv m2 b f2 id info tv, - match_env f1 cenv e m1 te sp lo (Mem.nextblock m1) -> + forall f1 cenv e le m1 te sp lo lv m2 b f2 id info tv, + match_env f1 cenv e le m1 te sp lo (Mem.nextblock m1) -> Mem.alloc m1 0 (sizeof lv) = (m2, b) -> inject_incr f1 f2 -> alloc_condition info lv sp (f2 b) -> (forall b', b' <> b -> f2 b' = f1 b') -> - te!id = Some tv -> + te!(for_var id) = Some tv -> e!id = None -> - match_env f2 (PMap.set id info cenv) (PTree.set id (b, lv) e) m2 te sp lo (Mem.nextblock m2). + match_env f2 (PMap.set id info cenv) (PTree.set id (b, lv) e) le m2 te sp lo (Mem.nextblock m2). Proof. intros until tv. intros ME ALLOC INCR ACOND OTHER TE E. @@ -638,6 +513,9 @@ Proof. rewrite PTree.gso; auto. auto. (* global array *) rewrite PTree.gso; auto. +(* temps *) + intros. exploit me_temps0; eauto. intros [v' [A B]]. + exists v'; split; auto. eapply val_inject_incr; eauto. (* low high *) exploit Mem.nextblock_alloc; eauto. unfold block in *; omega. (* bounded *) @@ -675,14 +553,14 @@ Proof. Qed. Lemma match_env_alloc_other: - forall f1 cenv e m1 te sp lo hi sz m2 b f2, - match_env f1 cenv e m1 te sp lo hi -> + forall f1 cenv e le m1 te sp lo hi sz m2 b f2, + match_env f1 cenv e le m1 te sp lo hi -> Mem.alloc m1 0 sz = (m2, b) -> inject_incr f1 f2 -> (forall b', b' <> b -> f2 b' = f1 b') -> hi <= b -> match f2 b with None => True | Some(b',ofs) => sp < b' end -> - match_env f2 cenv e m2 te sp lo hi. + match_env f2 cenv e le m2 te sp lo hi. Proof. intros until f2; intros ME ALLOC INCR OTHER BOUND TBOUND. inv ME. @@ -703,6 +581,9 @@ Proof. auto. auto. (* global array *) auto. +(* temps *) + intros. exploit me_temps0; eauto. intros [v' [A B]]. + exists v'; split; auto. eapply val_inject_incr; eauto. (* inv *) intros. rewrite OTHER in H. eauto. red; intro; subst b0. rewrite H in TBOUND. omegaContradiction. @@ -740,14 +621,14 @@ Proof. Qed. Lemma match_env_external_call: - forall f1 cenv e m1 te sp lo hi m2 f2 m1', - match_env f1 cenv e m1 te sp lo hi -> + forall f1 cenv e le m1 te sp lo hi m2 f2 m1', + match_env f1 cenv e le m1 te sp lo hi -> mem_unchanged_on (loc_unmapped f1) m1 m2 -> inject_incr f1 f2 -> inject_separated f1 f2 m1 m1' -> (forall b, Mem.valid_block m1 b -> Mem.bounds m2 b = Mem.bounds m1 b) -> hi <= Mem.nextblock m1 -> sp < Mem.nextblock m1' -> - match_env f2 cenv e m2 te sp lo hi. + match_env f2 cenv e le m2 te sp lo hi. Proof. intros until m1'. intros ME UNCHANGED INCR SEPARATED BOUNDS VALID VALID'. destruct UNCHANGED as [UNCHANGED1 UNCHANGED2]. @@ -761,6 +642,9 @@ Proof. rewrite <- H3. eapply inject_incr_separated_same; eauto. red. exploit me_bounded0; eauto. omega. eauto. eauto. +(* temps *) + intros. exploit me_temps0; eauto. intros [v' [A B]]. + exists v'; split; auto. eapply val_inject_incr; eauto. (* inv *) intros. apply me_inv0 with delta. eapply inject_incr_separated_same'; eauto. (* incr *) @@ -785,6 +669,7 @@ Inductive frame : Type := Frame(cenv: compilenv) (tf: Cminor.function) (e: Csharpminor.env) + (le: Csharpminor.temp_env) (te: Cminor.env) (sp: block) (lo hi: Z). @@ -827,13 +712,13 @@ Inductive match_callstack (f: meminj) (m: mem) (tm: mem): hi <= bound -> hi <= tbound -> match_callstack f m tm nil bound tbound | mcs_cons: - forall cenv tf e te sp lo hi cs bound tbound + forall cenv tf e le te sp lo hi cs bound tbound (BOUND: hi <= bound) (TBOUND: sp < tbound) - (MENV: match_env f cenv e m te sp lo hi) + (MENV: match_env f cenv e le m te sp lo hi) (PERM: padding_freeable f m tm sp tf.(fn_stackspace)) (MCS: match_callstack f m tm cs lo sp), - match_callstack f m tm (Frame cenv tf e te sp lo hi :: cs) bound tbound. + match_callstack f m tm (Frame cenv tf e le te sp lo hi :: cs) bound tbound. (** [match_callstack] implies [match_globalenvs]. *) @@ -849,9 +734,9 @@ Qed. generalize those for [match_env]. *) Lemma padding_freeable_invariant: - forall f1 m1 tm1 sp sz cenv e te lo hi f2 m2 tm2, + forall f1 m1 tm1 sp sz cenv e le te lo hi f2 m2 tm2, padding_freeable f1 m1 tm1 sp sz -> - match_env f1 cenv e m1 te sp lo hi -> + match_env f1 cenv e le m1 te sp lo hi -> (forall ofs, Mem.perm tm1 sp ofs Freeable -> Mem.perm tm2 sp ofs Freeable) -> (forall b, b < hi -> Mem.bounds m2 b = Mem.bounds m1 b) -> (forall b, b < hi -> f2 b = f1 b) -> @@ -903,10 +788,10 @@ Lemma match_callstack_invariant: forall f m tm cs bound tbound, match_callstack f m tm cs bound tbound -> forall m' tm', - (forall cenv e te sp lo hi, + (forall cenv e le te sp lo hi, hi <= bound -> - match_env f cenv e m te sp lo hi -> - match_env f cenv e m' te sp lo hi) -> + match_env f cenv e le m te sp lo hi -> + match_env f cenv e le m' te sp lo hi) -> (forall b, b < bound -> Mem.bounds m' b = Mem.bounds m b) -> (forall b ofs p, @@ -925,13 +810,13 @@ Proof. Qed. Lemma match_callstack_store_local: - forall f cenv e te sp lo hi cs bound tbound m1 m2 tm tf id b chunk v tv, + forall f cenv e le te sp lo hi cs bound tbound m1 m2 tm tf id b chunk v tv, e!id = Some(b, Vscalar chunk) -> - Val.has_type v (type_of_chunk chunk) -> - val_inject f (Val.load_result chunk v) tv -> + val_normalized v chunk -> + val_inject f v tv -> Mem.store chunk m1 b 0 v = Some m2 -> - match_callstack f m1 tm (Frame cenv tf e te sp lo hi :: cs) bound tbound -> - match_callstack f m2 tm (Frame cenv tf e (PTree.set id tv te) sp lo hi :: cs) bound tbound. + match_callstack f m1 tm (Frame cenv tf e le te sp lo hi :: cs) bound tbound -> + match_callstack f m2 tm (Frame cenv tf e le (PTree.set (for_var id) tv te) sp lo hi :: cs) bound tbound. Proof. intros. inv H3. constructor; auto. eapply match_env_store_local; eauto. @@ -951,19 +836,34 @@ Qed. takes place on the Cminor side. *) Lemma match_callstack_store_local_unchanged: - forall f cenv e te sp lo hi cs bound tbound m1 m2 id b chunk v tv tf tm, + forall f cenv e le te sp lo hi cs bound tbound m1 m2 id b chunk v tv tf tm, e!id = Some(b, Vscalar chunk) -> - Val.has_type v (type_of_chunk chunk) -> - val_inject f (Val.load_result chunk v) tv -> + val_normalized v chunk -> + val_inject f v tv -> Mem.store chunk m1 b 0 v = Some m2 -> - te!id = Some tv -> - match_callstack f m1 tm (Frame cenv tf e te sp lo hi :: cs) bound tbound -> - match_callstack f m2 tm (Frame cenv tf e te sp lo hi :: cs) bound tbound. + te!(for_var id) = Some tv -> + match_callstack f m1 tm (Frame cenv tf e le te sp lo hi :: cs) bound tbound -> + match_callstack f m2 tm (Frame cenv tf e le te sp lo hi :: cs) bound tbound. Proof. +Opaque for_var. intros. exploit match_callstack_store_local; eauto. intro MCS. inv MCS. constructor; auto. eapply match_env_extensional; eauto. - intros. rewrite PTree.gsspec. - case (peq id0 id); intros. congruence. auto. + intros. rewrite PTree.gsspec. +Transparent for_var. + case (peq (for_var id0) (for_var id)); intros. + unfold for_var in e0. congruence. + auto. + intros. rewrite PTree.gso; auto. unfold for_temp, for_var; congruence. +Qed. + +Lemma match_callstack_set_temp: + forall f cenv e le te sp lo hi cs bound tbound m tm tf id v tv, + val_inject f v tv -> + match_callstack f m tm (Frame cenv tf e le te sp lo hi :: cs) bound tbound -> + match_callstack f m tm (Frame cenv tf e (PTree.set id v le) (PTree.set (for_temp id) tv te) sp lo hi :: cs) bound tbound. +Proof. + intros. inv H0. constructor; auto. + eapply match_env_set_temp; eauto. Qed. Lemma match_callstack_incr_bound: @@ -1018,10 +918,10 @@ Qed. *) Lemma match_callstack_freelist: - forall f cenv tf e te sp lo hi cs m m' tm, + forall f cenv tf e le te sp lo hi cs m m' tm, Mem.inject f m tm -> Mem.free_list m (blocks_of_env e) = Some m' -> - match_callstack f m tm (Frame cenv tf e te sp lo hi :: cs) (Mem.nextblock m) (Mem.nextblock tm) -> + match_callstack f m tm (Frame cenv tf e le te sp lo hi :: cs) (Mem.nextblock m) (Mem.nextblock tm) -> exists tm', Mem.free tm sp 0 tf.(fn_stackspace) = Some tm' /\ match_callstack f m' tm' cs (Mem.nextblock m') (Mem.nextblock tm') @@ -1091,18 +991,18 @@ Proof. Qed. Lemma match_callstack_alloc_left: - forall f1 m1 tm cenv tf e te sp lo cs lv m2 b f2 info id tv, + forall f1 m1 tm cenv tf e le te sp lo cs lv m2 b f2 info id tv, match_callstack f1 m1 tm - (Frame cenv tf e te sp lo (Mem.nextblock m1) :: cs) + (Frame cenv tf e le te sp lo (Mem.nextblock m1) :: cs) (Mem.nextblock m1) (Mem.nextblock tm) -> Mem.alloc m1 0 (sizeof lv) = (m2, b) -> inject_incr f1 f2 -> alloc_condition info lv sp (f2 b) -> (forall b', b' <> b -> f2 b' = f1 b') -> - te!id = Some tv -> + te!(for_var id) = Some tv -> e!id = None -> match_callstack f2 m2 tm - (Frame (PMap.set id info cenv) tf (PTree.set id (b, lv) e) te sp lo (Mem.nextblock m2) :: cs) + (Frame (PMap.set id info cenv) tf (PTree.set id (b, lv) e) le te sp lo (Mem.nextblock m2) :: cs) (Mem.nextblock m2) (Mem.nextblock tm). Proof. intros until tv; intros MCS ALLOC INCR ACOND OTHER TE E. @@ -1126,7 +1026,7 @@ Lemma match_callstack_alloc_right: Mem.alloc tm 0 tf.(fn_stackspace) = (tm', sp) -> Mem.inject f m tm -> match_callstack f m tm' - (Frame gce tf empty_env te sp (Mem.nextblock m) (Mem.nextblock m) :: cs) + (Frame gce tf empty_env empty_temp_env te sp (Mem.nextblock m) (Mem.nextblock m) :: cs) (Mem.nextblock m) (Mem.nextblock tm'). Proof. intros. @@ -1139,7 +1039,9 @@ Proof. intros. generalize (global_compilenv_charact id); intro. destruct (gce!!id); try contradiction. constructor. apply PTree.gempty. auto. - constructor. apply PTree.gempty. + constructor. apply PTree.gempty. +(* temps *) + intros. rewrite PTree.gempty in H2. congruence. (* low high *) omega. (* bounded *) @@ -1171,8 +1073,8 @@ Definition is_reachable (f: meminj) (m: mem) (sp: block) (ofs: Z) : Prop := /\ Mem.low_bound m b + delta <= ofs < Mem.high_bound m b + delta. Lemma is_reachable_dec: - forall f cenv e m te sp lo hi ofs, - match_env f cenv e m te sp lo hi -> + forall f cenv e le m te sp lo hi ofs, + match_env f cenv e le m te sp lo hi -> {is_reachable f m sp ofs} + {~is_reachable f m sp ofs}. Proof. intros. @@ -1233,7 +1135,7 @@ Proof. eapply match_env_external_call; eauto. omega. omega. (* padding-freeable *) red; intros. - destruct (is_reachable_dec _ _ _ _ _ _ _ _ ofs MENV). + destruct (is_reachable_dec _ _ _ _ _ _ _ _ _ ofs MENV). destruct i as [b [delta [A B]]]. right; exists b; exists delta; split. apply INCR; auto. rewrite BOUNDS. auto. @@ -1270,77 +1172,6 @@ Proof. intros. symmetry. eapply IMAGE; eauto. Qed. -(** * Soundness of chunk and type inference. *) - -Lemma load_normalized: - forall chunk m b ofs v, - Mem.load chunk m b ofs = Some v -> val_normalized v chunk. -Proof. - intros. - exploit Mem.load_type; eauto. intro TY. - exploit Mem.load_cast; eauto. intro CST. - red. destruct chunk; destruct v; simpl in *; auto; contradiction. -Qed. - -Lemma chunktype_expr_correct: - forall f m tm cenv tf e te sp lo hi cs bound tbound, - match_callstack f m tm (Frame cenv tf e te sp lo hi :: cs) bound tbound -> - forall a v, - Csharpminor.eval_expr gve e m a v -> - forall chunk (CTE: chunktype_expr cenv a = OK chunk), - val_normalized v chunk. -Proof. - intros until tbound; intro MCS. induction 1; intros; try (monadInv CTE). -(* var *) - assert (chunk0 = chunk). - unfold chunktype_expr in CTE. - inv MCS. inv MENV. generalize (me_vars0 id); intro MV. - inv MV; rewrite <- H1 in CTE; monadInv CTE; inv H; try congruence. - unfold gve in H6. simpl in H6. congruence. - subst chunk0. - inv H; exploit load_normalized; eauto. unfold val_normalized; auto. -(* const *) - eapply chunktype_const_correct; eauto. -(* unop *) - eapply chunktype_unop_correct; eauto. -(* binop *) - eapply chunktype_binop_correct; eauto. -(* load *) - destruct v1; simpl in H0; try discriminate. - eapply load_normalized; eauto. -(* cond *) - eapply chunktype_merge_correct; eauto. - destruct vb1; eauto. -Qed. - -Lemma type_expr_correct: - forall f m tm cenv tf e te sp lo hi cs bound tbound, - match_callstack f m tm (Frame cenv tf e te sp lo hi :: cs) bound tbound -> - forall a v ty, - Csharpminor.eval_expr gve e m a v -> - type_expr cenv a = OK ty -> - Val.has_type v ty. -Proof. - intros. monadInv H1. apply val_normalized_has_type. - eapply chunktype_expr_correct; eauto. -Qed. - -Lemma type_exprlist_correct: - forall f m tm cenv tf e te sp lo hi cs bound tbound, - match_callstack f m tm (Frame cenv tf e te sp lo hi :: cs) bound tbound -> - forall al vl tyl, - Csharpminor.eval_exprlist gve e m al vl -> - type_exprlist cenv al = OK tyl -> - Val.has_type_list vl tyl. -Proof. - intros. monadInv H1. - generalize al vl H0 tyl H2. induction 1; intros. - inv H3. simpl. auto. - inv H5. simpl. split. - eapply type_expr_correct; eauto. - auto. -Qed. - (** * Correctness of Cminor construction functions *) Remark val_inject_val_of_bool: @@ -1503,41 +1334,6 @@ Proof. inv H0; try discriminate; inv H1; inv H; TrivialOp. Qed. -(** Correctness of [make_cast]. Note that the resulting Cminor value is - normalized according to the given memory chunk. *) - -Lemma make_cast_correct: - forall f sp te tm a v tv chunk, - eval_expr tge sp te tm a tv -> - val_inject f v tv -> - exists tv', - eval_expr tge sp te tm (make_cast chunk a) tv' - /\ val_inject f (Val.load_result chunk v) tv'. -Proof. - intros. destruct chunk; simpl make_cast. - - exists (Val.sign_ext 8 tv). - split. eauto with evalexpr. inversion H0; simpl; constructor. - - exists (Val.zero_ext 8 tv). - split. eauto with evalexpr. inversion H0; simpl; constructor. - - exists (Val.sign_ext 16 tv). - split. eauto with evalexpr. inversion H0; simpl; constructor. - - exists (Val.zero_ext 16 tv). - split. eauto with evalexpr. inversion H0; simpl; constructor. - - exists tv. - split. auto. inversion H0; simpl; econstructor; eauto. - - exists (Val.singleoffloat tv). - split. eauto with evalexpr. inversion H0; simpl; constructor. - - exists tv. - split. auto. inversion H0; simpl; econstructor; eauto. -Qed. - Lemma make_stackaddr_correct: forall sp te tm ofs, eval_expr tge (Vptr sp Int.zero) te tm @@ -1558,14 +1354,6 @@ Proof. eapply eval_Econst. simpl. rewrite H. auto. Qed. -Lemma unop_is_cast_correct: - forall op chunk v, - unop_is_cast op = Some chunk -> - Csharpminor.eval_unop op v = Some (Val.load_result chunk v). -Proof. - intros. destruct op; simpl in H; inv H; reflexivity. -Qed. - (** Correctness of [make_store]. *) Inductive val_content_inject (f: meminj): memory_chunk -> val -> val -> Prop := @@ -1663,11 +1451,11 @@ Qed. and [var_set]. *) Lemma var_get_correct: - forall cenv id a f tf e te sp lo hi m cs tm b chunk v, + forall cenv id a f tf e le te sp lo hi m cs tm b chunk v, var_get cenv id = OK a -> - match_callstack f m tm (Frame cenv tf e te sp lo hi :: cs) (Mem.nextblock m) (Mem.nextblock tm) -> + match_callstack f m tm (Frame cenv tf e le te sp lo hi :: cs) (Mem.nextblock m) (Mem.nextblock tm) -> Mem.inject f m tm -> - eval_var_ref gve e id b chunk -> + eval_var_ref ge e id b chunk -> Mem.load chunk m b 0 = Some v -> exists tv, eval_expr tge (Vptr sp Int.zero) te tm a tv /\ @@ -1692,7 +1480,7 @@ Proof. (* var_global_scalar *) simpl in *. exploit match_callstack_match_globalenvs; eauto. intros [bnd MG]. inv MG. - assert (chunk0 = chunk). congruence. subst chunk0. + assert (chunk0 = chunk). exploit H7; eauto. congruence. subst chunk0. assert (val_inject f (Vptr b Int.zero) (Vptr b Int.zero)). econstructor; eauto. exploit Mem.loadv_inject; eauto. simpl. eauto. @@ -1704,10 +1492,10 @@ Proof. Qed. Lemma var_addr_correct: - forall cenv id a f tf e te sp lo hi m cs tm b, - match_callstack f m tm (Frame cenv tf e te sp lo hi :: cs) (Mem.nextblock m) (Mem.nextblock tm) -> + forall cenv id a f tf e le te sp lo hi m cs tm b, + match_callstack f m tm (Frame cenv tf e le te sp lo hi :: cs) (Mem.nextblock m) (Mem.nextblock tm) -> var_addr cenv id = OK a -> - eval_var_addr gve e id b -> + eval_var_addr ge e id b -> exists tv, eval_expr tge (Vptr sp Int.zero) te tm a tv /\ val_inject f (Vptr b Int.zero) tv. @@ -1735,51 +1523,35 @@ Proof. Qed. Lemma var_set_correct: - forall cenv id rhs rhs_chunk a f tf e te sp lo hi m cs tm tv v m' fn k, - var_set cenv id rhs rhs_chunk = OK a -> - match_callstack f m tm (Frame cenv tf e te sp lo hi :: cs) (Mem.nextblock m) (Mem.nextblock tm) -> + forall cenv id rhs a f tf e le te sp lo hi m cs tm tv v m' fn k, + var_set cenv id rhs = OK a -> + match_callstack f m tm (Frame cenv tf e le te sp lo hi :: cs) (Mem.nextblock m) (Mem.nextblock tm) -> eval_expr tge (Vptr sp Int.zero) te tm rhs tv -> val_inject f v tv -> Mem.inject f m tm -> - exec_assign gve e m id v m' -> - val_normalized v rhs_chunk -> + exec_assign ge e m id v m' -> exists te', exists tm', step tge (State fn a k (Vptr sp Int.zero) te tm) E0 (State fn Sskip k (Vptr sp Int.zero) te' tm') /\ Mem.inject f m' tm' /\ - match_callstack f m' tm' (Frame cenv tf e te' sp lo hi :: cs) (Mem.nextblock m') (Mem.nextblock tm') /\ - (forall id', id' <> id -> te'!id' = te!id'). + match_callstack f m' tm' (Frame cenv tf e le te' sp lo hi :: cs) (Mem.nextblock m') (Mem.nextblock tm') /\ + (forall id', id' <> for_var id -> te'!id' = te!id'). Proof. intros until k. - intros VS MCS EVAL VINJ MINJ ASG VNORM. + intros VS MCS EVAL VINJ MINJ ASG. unfold var_set in VS. inv ASG. assert (NEXTBLOCK: Mem.nextblock m' = Mem.nextblock m). eapply Mem.nextblock_store; eauto. assert (MV: match_var f id e m te sp cenv!!id). inv MCS. inv MENV. auto. - inv MV; rewrite <- H1 in VS; inv VS; inv H; try congruence. + revert VS; inv MV; intro VS; inv VS; inv H; try congruence. (* var_local *) assert (b0 = b) by congruence. subst b0. assert (chunk0 = chunk) by congruence. subst chunk0. - generalize H8; clear H8. case_eq (chunktype_compat rhs_chunk chunk). - (* compatible chunks *) - intros CCOMPAT EQ; inv EQ. - exploit chunktype_compat_correct; eauto. intro VNORM'. - exists (PTree.set id tv te); exists tm. - split. eapply step_assign. eauto. - split. eapply Mem.store_unmapped_inject; eauto. - split. rewrite NEXTBLOCK. eapply match_callstack_store_local; eauto. - eapply val_normalized_has_type; eauto. red in VNORM'. congruence. - intros. apply PTree.gso; auto. - (* incompatible chunks but same type *) - intros. destruct (typ_eq (type_of_chunk chunk) (type_of_chunk rhs_chunk)); inv H8. - exploit make_cast_correct; eauto. - intros [tv' [EVAL' INJ']]. - exists (PTree.set id tv' te); exists tm. + exists (PTree.set (for_var id) tv te); exists tm. split. eapply step_assign. eauto. split. eapply Mem.store_unmapped_inject; eauto. split. rewrite NEXTBLOCK. eapply match_callstack_store_local; eauto. - rewrite e0. eapply val_normalized_has_type; eauto. intros. apply PTree.gso; auto. (* var_stack_scalar *) assert (b0 = b) by congruence. subst b0. @@ -1796,7 +1568,7 @@ Proof. auto. (* var_global_scalar *) simpl in *. - assert (chunk0 = chunk) by congruence. subst chunk0. + assert (chunk0 = chunk). exploit H4; eauto. congruence. subst chunk0. assert (Mem.storev chunk m (Vptr b Int.zero) v = Some m'). assumption. exploit match_callstack_match_globalenvs; eauto. intros [bnd MG]. inv MG. exploit make_store_correct. @@ -1811,56 +1583,122 @@ Proof. Qed. Lemma match_callstack_extensional: - forall f cenv tf e te1 te2 sp lo hi cs bound tbound m tm, - (forall id chunk, cenv!!id = Var_local chunk -> te2!id = te1!id) -> - match_callstack f m tm (Frame cenv tf e te1 sp lo hi :: cs) bound tbound -> - match_callstack f m tm (Frame cenv tf e te2 sp lo hi :: cs) bound tbound. + forall f cenv tf e le te1 te2 sp lo hi cs bound tbound m tm, + (forall id chunk, cenv!!id = Var_local chunk -> te2!(for_var id) = te1!(for_var id)) -> + (forall id v, le!id = Some v -> te2!(for_temp id) = te1!(for_temp id)) -> + match_callstack f m tm (Frame cenv tf e le te1 sp lo hi :: cs) bound tbound -> + match_callstack f m tm (Frame cenv tf e le te2 sp lo hi :: cs) bound tbound. Proof. - intros. inv H0. constructor; auto. + intros. inv H1. constructor; auto. apply match_env_extensional with te1; auto. Qed. Lemma var_set_self_correct: - forall cenv id ty a f tf e te sp lo hi m cs tm tv te' v m' fn k, - var_set_self cenv id ty = OK a -> - match_callstack f m tm (Frame cenv tf e te sp lo hi :: cs) (Mem.nextblock m) (Mem.nextblock tm) -> + forall cenv id ty s a f tf e le te sp lo hi m cs tm tv v m' fn k, + var_set_self cenv id ty s = OK a -> + match_callstack f m tm (Frame cenv tf e le te sp lo hi :: cs) (Mem.nextblock m) (Mem.nextblock tm) -> + val_inject f v tv -> + Mem.inject f m tm -> + exec_assign ge e m id v m' -> + te!(for_var id) = Some tv -> + exists tm', + star step tge (State fn a k (Vptr sp Int.zero) te tm) + E0 (State fn s k (Vptr sp Int.zero) te tm') /\ + Mem.inject f m' tm' /\ + match_callstack f m' tm' (Frame cenv tf e le te sp lo hi :: cs) (Mem.nextblock m') (Mem.nextblock tm'). +Proof. + intros until k. + intros VS MCS VINJ MINJ ASG VAL. + unfold var_set_self in VS. inv ASG. + assert (NEXTBLOCK: Mem.nextblock m' = Mem.nextblock m). + eapply Mem.nextblock_store; eauto. + assert (MV: match_var f id e m te sp cenv!!id). + inv MCS. inv MENV. auto. + assert (EVAR: eval_expr tge (Vptr sp Int.zero) te tm (Evar (for_var id)) tv). + constructor. auto. + revert VS; inv MV; intro VS; inv VS; inv H; try congruence. + (* var_local *) + assert (b0 = b) by congruence. subst b0. + assert (chunk0 = chunk) by congruence. subst chunk0. + exists tm. + split. apply star_refl. + split. eapply Mem.store_unmapped_inject; eauto. + rewrite NEXTBLOCK. + apply match_callstack_extensional with (PTree.set (for_var id) tv te). + intros. repeat rewrite PTree.gsspec. + destruct (peq (for_var id0) (for_var id)). congruence. auto. + intros. rewrite PTree.gso; auto. unfold for_temp, for_var; congruence. + eapply match_callstack_store_local; eauto. + (* var_stack_scalar *) + assert (b0 = b) by congruence. subst b0. + assert (chunk0 = chunk) by congruence. subst chunk0. + assert (Mem.storev chunk m (Vptr b Int.zero) v = Some m'). assumption. + exploit make_store_correct. + eapply make_stackaddr_correct. + eauto. eauto. eauto. eauto. eauto. + intros [tm' [tvrhs' [EVAL' [STORE' MEMINJ]]]]. + exists tm'. + split. eapply star_three. constructor. eauto. constructor. traceEq. + split. auto. + rewrite NEXTBLOCK. rewrite (nextblock_storev _ _ _ _ _ STORE'). + eapply match_callstack_storev_mapped; eauto. + (* var_global_scalar *) + simpl in *. + assert (chunk0 = chunk). exploit H4; eauto. congruence. subst chunk0. + assert (Mem.storev chunk m (Vptr b Int.zero) v = Some m'). assumption. + exploit match_callstack_match_globalenvs; eauto. intros [bnd MG]. inv MG. + exploit make_store_correct. + eapply make_globaladdr_correct; eauto. + rewrite symbols_preserved; eauto. eauto. eauto. eauto. eauto. eauto. + intros [tm' [tvrhs' [EVAL' [STORE' MEMINJ]]]]. + exists tm'. + split. eapply star_three. constructor. eauto. constructor. traceEq. + split. auto. + rewrite NEXTBLOCK. rewrite (nextblock_storev _ _ _ _ _ STORE'). + eapply match_callstack_store_mapped; eauto. +Qed. + +(* +Lemma var_set_self_correct: + forall cenv id ty s a f tf e le te sp lo hi m cs tm tv te' v m' fn k, + var_set_self cenv id ty s = OK a -> + match_callstack f m tm (Frame cenv tf e le te sp lo hi :: cs) (Mem.nextblock m) (Mem.nextblock tm) -> val_inject f v tv -> Mem.inject f m tm -> - exec_assign gve e m id v m' -> - Val.has_type v ty -> - te'!id = Some tv -> - (forall i, i <> id -> te'!i = te!i) -> + exec_assign ge e m id v m' -> + te'!(for_var id) = Some tv -> + (forall i, i <> for_var id -> te'!i = te!i) -> exists te'', exists tm', - step tge (State fn a k (Vptr sp Int.zero) te' tm) - E0 (State fn Sskip k (Vptr sp Int.zero) te'' tm') /\ + star step tge (State fn a k (Vptr sp Int.zero) te' tm) + E0 (State fn s k (Vptr sp Int.zero) te'' tm') /\ Mem.inject f m' tm' /\ - match_callstack f m' tm' (Frame cenv tf e te'' sp lo hi :: cs) (Mem.nextblock m') (Mem.nextblock tm') /\ - (forall id', id' <> id -> te''!id' = te'!id'). + match_callstack f m' tm' (Frame cenv tf e le te'' sp lo hi :: cs) (Mem.nextblock m') (Mem.nextblock tm') /\ + (forall id', id' <> for_var id -> te''!id' = te'!id'). Proof. intros until k. - intros VS MCS VINJ MINJ ASG VTY VAL OTHERS. + intros VS MCS VINJ MINJ ASG VAL OTHERS. unfold var_set_self in VS. inv ASG. assert (NEXTBLOCK: Mem.nextblock m' = Mem.nextblock m). eapply Mem.nextblock_store; eauto. assert (MV: match_var f id e m te sp cenv!!id). inv MCS. inv MENV. auto. - assert (EVAR: eval_expr tge (Vptr sp Int.zero) te' tm (Evar id) tv). + assert (EVAR: eval_expr tge (Vptr sp Int.zero) te' tm (Evar (for_var id)) tv). constructor. auto. - inv MV; rewrite <- H1 in VS; inv VS; inv H; try congruence. + revert VS; inv MV; intro VS; inv VS; inv H; try congruence. (* var_local *) assert (b0 = b) by congruence. subst b0. assert (chunk0 = chunk) by congruence. subst chunk0. - destruct (typ_eq (type_of_chunk chunk) ty); inv H8. - exploit make_cast_correct; eauto. - intros [tv' [EVAL' INJ']]. - exists (PTree.set id tv' te'); exists tm. - split. eapply step_assign. eauto. + exists te'; exists tm. + split. apply star_refl. split. eapply Mem.store_unmapped_inject; eauto. split. rewrite NEXTBLOCK. - apply match_callstack_extensional with (PTree.set id tv' te). - intros. repeat rewrite PTree.gsspec. destruct (peq id0 id); auto. + apply match_callstack_extensional with (PTree.set (for_var id) tv te). + intros. repeat rewrite PTree.gsspec. + destruct (peq (for_var id0) (for_var id)). congruence. auto. + intros. assert (for_temp id0 <> for_var id). unfold for_temp, for_var; congruence. + rewrite PTree.gso; auto. eapply match_callstack_store_local; eauto. - intros; apply PTree.gso; auto. + intros. auto. (* var_stack_scalar *) assert (b0 = b) by congruence. subst b0. assert (chunk0 = chunk) by congruence. subst chunk0. @@ -1870,15 +1708,17 @@ Proof. eauto. eauto. eauto. eauto. eauto. intros [tm' [tvrhs' [EVAL' [STORE' MEMINJ]]]]. exists te'; exists tm'. - split. eauto. split. auto. + split. eapply star_three. constructor. eauto. constructor. traceEq. + split. auto. split. rewrite NEXTBLOCK. rewrite (nextblock_storev _ _ _ _ _ STORE'). apply match_callstack_extensional with te. - intros. apply OTHERS. congruence. + intros. apply OTHERS. unfold for_var; congruence. + intros. apply OTHERS. unfold for_var, for_temp; congruence. eapply match_callstack_storev_mapped; eauto. auto. (* var_global_scalar *) simpl in *. - assert (chunk0 = chunk) by congruence. subst chunk0. + assert (chunk0 = chunk). exploit H4; eauto. congruence. subst chunk0. assert (Mem.storev chunk m (Vptr b Int.zero) v = Some m'). assumption. exploit match_callstack_match_globalenvs; eauto. intros [bnd MG]. inv MG. exploit make_store_correct. @@ -1886,13 +1726,16 @@ Proof. rewrite symbols_preserved; eauto. eauto. eauto. eauto. eauto. eauto. intros [tm' [tvrhs' [EVAL' [STORE' MEMINJ]]]]. exists te'; exists tm'. - split. eauto. split. auto. + split. eapply star_three. constructor. eauto. constructor. traceEq. + split. auto. split. rewrite NEXTBLOCK. rewrite (nextblock_storev _ _ _ _ _ STORE'). apply match_callstack_extensional with te. - intros. apply OTHERS. congruence. + intros. apply OTHERS. unfold for_var; congruence. + intros. apply OTHERS. unfold for_var, for_temp; congruence. eapply match_callstack_store_mapped; eauto. auto. Qed. +*) (** * Correctness of stack allocation of local variables *) @@ -1983,7 +1826,7 @@ Proof. Qed. Lemma match_callstack_alloc_variable: - forall atk id lv cenv sz cenv' sz' tm sp e tf m m' b te lo cs f tv, + forall atk id lv cenv sz cenv' sz' tm sp e tf m m' b te le lo cs f tv, assign_variable atk (id, lv) (cenv, sz) = (cenv', sz') -> Mem.valid_block tm sp -> Mem.bounds tm sp = (0, tf.(fn_stackspace)) -> @@ -1991,18 +1834,18 @@ Lemma match_callstack_alloc_variable: tf.(fn_stackspace) <= Int.max_signed -> Mem.alloc m 0 (sizeof lv) = (m', b) -> match_callstack f m tm - (Frame cenv tf e te sp lo (Mem.nextblock m) :: cs) + (Frame cenv tf e le te sp lo (Mem.nextblock m) :: cs) (Mem.nextblock m) (Mem.nextblock tm) -> Mem.inject f m tm -> 0 <= sz -> sz' <= tf.(fn_stackspace) -> (forall b delta, f b = Some(sp, delta) -> Mem.high_bound m b + delta <= sz) -> e!id = None -> - te!id = Some tv -> + te!(for_var id) = Some tv -> exists f', inject_incr f f' /\ Mem.inject f' m' tm /\ match_callstack f' m' tm - (Frame cenv' tf (PTree.set id (b, lv) e) te sp lo (Mem.nextblock m') :: cs) + (Frame cenv' tf (PTree.set id (b, lv) e) le te sp lo (Mem.nextblock m') :: cs) (Mem.nextblock m') (Mem.nextblock tm) /\ (forall b delta, f' b = Some(sp, delta) -> Mem.high_bound m' b + delta <= sz'). @@ -2076,7 +1919,7 @@ Proof. Qed. Lemma match_callstack_alloc_variables_rec: - forall tm sp cenv' tf te lo cs atk, + forall tm sp cenv' tf le te lo cs atk, Mem.valid_block tm sp -> Mem.bounds tm sp = (0, tf.(fn_stackspace)) -> Mem.range_perm tm sp 0 tf.(fn_stackspace) Freeable -> @@ -2086,20 +1929,20 @@ Lemma match_callstack_alloc_variables_rec: forall f cenv sz, assign_variables atk vars (cenv, sz) = (cenv', tf.(fn_stackspace)) -> match_callstack f m tm - (Frame cenv tf e te sp lo (Mem.nextblock m) :: cs) + (Frame cenv tf e le te sp lo (Mem.nextblock m) :: cs) (Mem.nextblock m) (Mem.nextblock tm) -> Mem.inject f m tm -> 0 <= sz -> (forall b delta, f b = Some(sp, delta) -> Mem.high_bound m b + delta <= sz) -> - (forall id lv, In (id, lv) vars -> te!id <> None) -> + (forall id lv, In (id, lv) vars -> te!(for_var id) <> None) -> list_norepet (List.map (@fst ident var_kind) vars) -> (forall id lv, In (id, lv) vars -> e!id = None) -> exists f', inject_incr f f' /\ Mem.inject f' m' tm /\ match_callstack f' m' tm - (Frame cenv' tf e' te sp lo (Mem.nextblock m') :: cs) + (Frame cenv' tf e' le te sp lo (Mem.nextblock m') :: cs) (Mem.nextblock m') (Mem.nextblock tm). Proof. intros until atk. intros VALID BOUNDS PERM NOOV. @@ -2113,11 +1956,11 @@ Proof. with (assign_variables atk vars (assign_variable atk (id, lv) (cenv, sz))). caseEq (assign_variable atk (id, lv) (cenv, sz)). intros cenv1 sz1 ASV1 ASVS MATCH MINJ SZPOS BOUND DEFINED NOREPET UNDEFINED. - assert (DEFINED1: forall id0 lv0, In (id0, lv0) vars -> te!id0 <> None). + assert (DEFINED1: forall id0 lv0, In (id0, lv0) vars -> te!(for_var id0) <> None). intros. eapply DEFINED. simpl. right. eauto. - assert (exists tv, te!id = Some tv). - assert (te!id <> None). eapply DEFINED. simpl; left; auto. - destruct (te!id). exists v; auto. congruence. + assert (exists tv, te!(for_var id) = Some tv). + assert (te!(for_var id) <> None). eapply DEFINED. simpl; left; auto. + destruct (te!(for_var id)). exists v; auto. congruence. destruct H1 as [tv TEID]. assert (sz1 <= fn_stackspace tf). eapply assign_variables_incr; eauto. exploit match_callstack_alloc_variable; eauto with coqlib. @@ -2171,7 +2014,7 @@ Qed. of Csharpminor local variables and of the Cminor stack data block. *) Lemma match_callstack_alloc_variables: - forall fn cenv tf m e m' tm tm' sp f cs targs body, + forall fn cenv tf m e m' tm tm' sp f cs targs, build_compilenv gce fn = (cenv, tf.(fn_stackspace)) -> tf.(fn_stackspace) <= Int.max_signed -> list_norepet (fn_params_names fn ++ fn_vars_names fn) -> @@ -2179,13 +2022,15 @@ Lemma match_callstack_alloc_variables: Mem.alloc tm 0 tf.(fn_stackspace) = (tm', sp) -> match_callstack f m tm cs (Mem.nextblock m) (Mem.nextblock tm) -> Mem.inject f m tm -> - let tvars := make_vars (fn_params_names fn) (fn_vars_names fn) body in - let te := set_locals tvars (set_params targs (fn_params_names fn)) in + let tparams := List.map for_var (fn_params_names fn) in + let tvars := List.map for_var (fn_vars_names fn) in + let ttemps := List.map for_temp (Csharpminor.fn_temps fn) in + let te := set_locals (tvars ++ ttemps) (set_params targs tparams) in exists f', inject_incr f f' /\ Mem.inject f' m' tm' /\ match_callstack f' m' tm' - (Frame cenv tf e te sp (Mem.nextblock m) (Mem.nextblock m') :: cs) + (Frame cenv tf e empty_temp_env te sp (Mem.nextblock m) (Mem.nextblock m') :: cs) (Mem.nextblock m') (Mem.nextblock tm'). Proof. intros. @@ -2200,8 +2045,8 @@ Proof. intros. unfold te. apply set_locals_params_defined. elim (in_app_or _ _ _ H6); intros. elim (list_in_map_inv _ _ _ H7). intros x [A B]. - apply in_or_app; left. inversion A. apply List.in_map. auto. - apply in_or_app; right. unfold tvars, make_vars. apply in_or_app; left. + apply in_or_app; left. unfold tparams. apply List.in_map. inversion A. apply List.in_map. auto. + apply in_or_app; right. apply in_or_app; left. unfold tvars. apply List.in_map. change id with (fst (id, lv)). apply List.in_map; auto. (* norepet *) unfold fn_variables. @@ -2221,9 +2066,9 @@ Inductive vars_vals_match (f:meminj): vars_vals_match f nil nil te | vars_vals_cons: forall te id chunk vars v vals tv, - te!id = Some tv -> + te!(for_var id) = Some tv -> val_inject f v tv -> - Val.has_type v (type_of_chunk chunk) -> + val_normalized v chunk -> vars_vals_match f vars vals te -> vars_vals_match f ((id, chunk) :: vars) (v :: vals) te. @@ -2231,7 +2076,7 @@ Lemma vars_vals_match_extensional: forall f vars vals te, vars_vals_match f vars vals te -> forall te', - (forall id lv, In (id, lv) vars -> te'!id = te!id) -> + (forall id lv, In (id, lv) vars -> te'!(for_var id) = te!(for_var id)) -> vars_vals_match f vars vals te'. Proof. induction 1; intros. @@ -2242,24 +2087,24 @@ Proof. Qed. Lemma store_parameters_correct: - forall e m1 params vl m2, + forall e le te m1 params vl m2, bind_parameters e m1 params vl m2 -> - forall s f te1 cenv tf sp lo hi cs tm1 fn k, - vars_vals_match f params vl te1 -> + forall s f cenv tf sp lo hi cs tm1 fn k, + vars_vals_match f params vl te -> list_norepet (List.map param_name params) -> Mem.inject f m1 tm1 -> - match_callstack f m1 tm1 (Frame cenv tf e te1 sp lo hi :: cs) (Mem.nextblock m1) (Mem.nextblock tm1) -> + match_callstack f m1 tm1 (Frame cenv tf e le te sp lo hi :: cs) (Mem.nextblock m1) (Mem.nextblock tm1) -> store_parameters cenv params = OK s -> - exists te2, exists tm2, - star step tge (State fn s k (Vptr sp Int.zero) te1 tm1) - E0 (State fn Sskip k (Vptr sp Int.zero) te2 tm2) + exists tm2, + star step tge (State fn s k (Vptr sp Int.zero) te tm1) + E0 (State fn Sskip k (Vptr sp Int.zero) te tm2) /\ Mem.inject f m2 tm2 - /\ match_callstack f m2 tm2 (Frame cenv tf e te2 sp lo hi :: cs) (Mem.nextblock m2) (Mem.nextblock tm2). + /\ match_callstack f m2 tm2 (Frame cenv tf e le te sp lo hi :: cs) (Mem.nextblock m2) (Mem.nextblock tm2). Proof. induction 1. (* base case *) intros; simpl. monadInv H3. - exists te1; exists tm1. split. constructor. tauto. + exists tm1. split. constructor. tauto. (* inductive case *) intros until k. intros VVM NOREPET MINJ MATCH STOREP. monadInv STOREP. @@ -2267,18 +2112,11 @@ Proof. inv NOREPET. exploit var_set_self_correct; eauto. econstructor; eauto. econstructor; eauto. - intros [te2 [tm2 [EXEC1 [MINJ1 [MATCH1 UNCHANGED1]]]]]. - assert (vars_vals_match f params vl te2). - apply vars_vals_match_extensional with te1; auto. - intros. apply UNCHANGED1. red; intro; subst id0. - elim H4. change id with (param_name (id, lv)). apply List.in_map. auto. + intros [tm2 [EXEC1 [MINJ1 MATCH1]]]. exploit IHbind_parameters; eauto. - intros [te3 [tm3 [EXEC2 [MINJ2 MATCH2]]]]. - exists te3; exists tm3. - split. eapply star_left. constructor. - eapply star_left. eexact EXEC1. - eapply star_left. constructor. eexact EXEC2. - reflexivity. reflexivity. reflexivity. + intros [tm3 [EXEC2 [MINJ2 MATCH2]]]. + exists tm3. + split. eapply star_trans; eauto. auto. Qed. @@ -2286,87 +2124,67 @@ Lemma vars_vals_match_holds_1: forall f params args targs, list_norepet (List.map param_name params) -> val_list_inject f args targs -> - Val.has_type_list args (List.map type_of_chunk (List.map param_chunk params)) -> + list_forall2 val_normalized args (List.map param_chunk params) -> vars_vals_match f params args - (set_params targs (List.map (@fst ident memory_chunk) params)). + (set_params targs (List.map for_var (List.map param_name params))). Proof. +Opaque for_var. induction params; simpl; intros. - destruct args; simpl in H1; try contradiction. inv H0. - constructor. - destruct args; simpl in H1; try contradiction. destruct H1. inv H0. inv H. + inv H1. constructor. + inv H. inv H1. inv H0. destruct a as [id chunk]; simpl in *. econstructor. rewrite PTree.gss. reflexivity. auto. auto. apply vars_vals_match_extensional - with (set_params vl' (map param_name params)). + with (set_params vl' (map for_var (map param_name params))). eapply IHparams; eauto. - intros. simpl. apply PTree.gso. red; intro; subst id0. +Transparent for_var. + intros. apply PTree.gso. unfold for_var; red; intros. inv H0. elim H4. change id with (param_name (id, lv)). apply List.in_map; auto. Qed. -Lemma vars_vals_match_holds: - forall f params args targs, - list_norepet (List.map param_name params) -> - val_list_inject f args targs -> - Val.has_type_list args (List.map type_of_chunk (List.map param_chunk params)) -> - forall vars, - list_norepet (vars ++ List.map param_name params) -> - vars_vals_match f params args - (set_locals vars (set_params targs (List.map param_name params))). -Proof. - induction vars; simpl; intros. - eapply vars_vals_match_holds_1; eauto. - inv H2. - eapply vars_vals_match_extensional; eauto. - intros. apply PTree.gso. red; intro; subst id; elim H5. - apply in_or_app. right. change a with (param_name (a, lv)). apply List.in_map; auto. -Qed. - -Remark identset_removelist_charact: - forall l s x, Identset.In x (identset_removelist l s) <-> Identset.In x s /\ ~In x l. +Lemma vars_vals_match_holds_2: + forall f params args e, + vars_vals_match f params args e -> + forall vl, + (forall id1 id2, In id1 (List.map param_name params) -> In id2 vl -> for_var id1 <> id2) -> + vars_vals_match f params args (set_locals vl e). Proof. - induction l; simpl; intros. tauto. - split; intros. - exploit Identset.remove_3; eauto. rewrite IHl. intros [P Q]. - split. auto. intuition. elim (Identset.remove_1 H1 H). - destruct H as [P Q]. apply Identset.remove_2. tauto. rewrite IHl. tauto. + induction vl; simpl; intros. + auto. + apply vars_vals_match_extensional with (set_locals vl e); auto. + intros. apply PTree.gso. apply H0. + change id with (param_name (id, lv)). apply List.in_map. auto. + auto. Qed. -Remark InA_In: - forall (A: Type) (x: A) (l: list A), - InA (fun (x y: A) => x = y) x l <-> In x l. +Lemma vars_vals_match_holds: + forall f params args targs vars temps, + list_norepet (List.map param_name params ++ vars) -> + val_list_inject f args targs -> + list_forall2 val_normalized args (List.map param_chunk params) -> + vars_vals_match f params args + (set_locals (List.map for_var vars ++ List.map for_temp temps) + (set_params targs (List.map for_var (List.map param_name params)))). Proof. - intros. rewrite InA_alt. split; intros. destruct H as [y [P Q]]. congruence. exists x; auto. + intros. rewrite list_norepet_app in H. destruct H as [A [B C]]. + apply vars_vals_match_holds_2; auto. apply vars_vals_match_holds_1; auto. + intros. + destruct (in_app_or _ _ _ H2). + exploit list_in_map_inv. eexact H3. intros [x2 [J K]]. + subst. assert (id1 <> x2). apply C; auto. unfold for_var; congruence. + exploit list_in_map_inv. eexact H3. intros [x2 [J K]]. + subst id2. unfold for_var, for_temp; congruence. Qed. -Remark NoDupA_norepet: - forall (A: Type) (l: list A), - NoDupA (fun (x y: A) => x = y) l -> list_norepet l. +Remark bind_parameters_normalized: + forall e m params args m', + bind_parameters e m params args m' -> + list_forall2 val_normalized args (List.map param_chunk params). Proof. - induction 1. constructor. constructor; auto. red; intros; elim H. - rewrite InA_In. auto. -Qed. - -Lemma make_vars_norepet: - forall fn body, - list_norepet (fn_params_names fn ++ fn_vars_names fn) -> - list_norepet (make_vars (fn_params_names fn) (fn_vars_names fn) body - ++ fn_params_names fn). -Proof. - intros. rewrite list_norepet_app in H. destruct H as [A [B C]]. - rewrite list_norepet_app. split. - unfold make_vars. rewrite list_norepet_app. split. auto. - split. apply NoDupA_norepet. apply Identset.elements_3w. - red; intros. red; intros; subst y. rewrite <- InA_In in H0. - exploit Identset.elements_2. eexact H0. - rewrite identset_removelist_charact. intros [P Q]. elim Q. - apply in_or_app. auto. - split. auto. - red; intros. unfold make_vars in H. destruct (in_app_or _ _ _ H). - apply sym_not_equal. apply C; auto. - rewrite <- InA_In in H1. exploit Identset.elements_2. eexact H1. - rewrite identset_removelist_charact. intros [P Q]. - red; intros; elim Q. apply in_or_app. left; congruence. + induction 1; simpl. + constructor. + constructor; auto. Qed. (** The main result in this section: the behaviour of function entry @@ -2376,7 +2194,7 @@ Qed. and initialize the blocks corresponding to function parameters). *) Lemma function_entry_ok: - forall fn m e m1 vargs m2 f cs tm cenv tf tm1 sp tvargs body s fn' k, + forall fn m e m1 vargs m2 f cs tm cenv tf tm1 sp tvargs s fn' k, list_norepet (fn_params_names fn ++ fn_vars_names fn) -> alloc_variables empty_env m (fn_variables fn) e m1 -> bind_parameters e m1 fn.(Csharpminor.fn_params) vargs m2 -> @@ -2384,36 +2202,37 @@ Lemma function_entry_ok: build_compilenv gce fn = (cenv, tf.(fn_stackspace)) -> tf.(fn_stackspace) <= Int.max_signed -> Mem.alloc tm 0 tf.(fn_stackspace) = (tm1, sp) -> - let vars := - make_vars (fn_params_names fn) (fn_vars_names fn) body in - let te := - set_locals vars (set_params tvargs (fn_params_names fn)) in + let tparams := List.map for_var (fn_params_names fn) in + let tvars := List.map for_var (fn_vars_names fn) in + let ttemps := List.map for_temp (Csharpminor.fn_temps fn) in + let te := set_locals (tvars ++ ttemps) (set_params tvargs tparams) in val_list_inject f vargs tvargs -> - Val.has_type_list vargs (Csharpminor.fn_sig fn).(sig_args) -> Mem.inject f m tm -> store_parameters cenv fn.(Csharpminor.fn_params) = OK s -> - exists f2, exists te2, exists tm2, + exists f2, exists tm2, star step tge (State fn' s k (Vptr sp Int.zero) te tm1) - E0 (State fn' Sskip k (Vptr sp Int.zero) te2 tm2) + E0 (State fn' Sskip k (Vptr sp Int.zero) te tm2) /\ Mem.inject f2 m2 tm2 /\ inject_incr f f2 /\ match_callstack f2 m2 tm2 - (Frame cenv tf e te2 sp (Mem.nextblock m) (Mem.nextblock m1) :: cs) + (Frame cenv tf e empty_temp_env te sp (Mem.nextblock m) (Mem.nextblock m1) :: cs) (Mem.nextblock m2) (Mem.nextblock tm2). Proof. intros. exploit match_callstack_alloc_variables; eauto. intros [f1 [INCR1 [MINJ1 MATCH1]]]. exploit vars_vals_match_holds. - eapply list_norepet_append_left. eexact H. + eexact H. apply val_list_inject_incr with f. eauto. eauto. - auto. eapply make_vars_norepet. auto. + eapply bind_parameters_normalized; eauto. + instantiate (1 := Csharpminor.fn_temps fn). + fold tvars. fold ttemps. fold (fn_params_names fn). fold tparams. fold te. intro VVM. exploit store_parameters_correct. eauto. eauto. eapply list_norepet_append_left; eauto. - eexact MINJ1. fold (fn_params_names fn). eexact MATCH1. eauto. - intros [te2 [tm2 [EXEC [MINJ2 MATCH2]]]]. - exists f1; exists te2; exists tm2. eauto. + eexact MINJ1. eexact MATCH1. eauto. + intros [tm2 [EXEC [MINJ2 MATCH2]]]. + exists f1; exists tm2. eauto. Qed. (** * Semantic preservation for the translation *) @@ -2450,13 +2269,13 @@ Proof. Qed. Lemma transl_expr_correct: - forall f m tm cenv tf e te sp lo hi cs + forall f m tm cenv tf e le te sp lo hi cs (MINJ: Mem.inject f m tm) (MATCH: match_callstack f m tm - (Frame cenv tf e te sp lo hi :: cs) + (Frame cenv tf e le te sp lo hi :: cs) (Mem.nextblock m) (Mem.nextblock tm)), forall a v, - Csharpminor.eval_expr gve e m a v -> + Csharpminor.eval_expr ge e le m a v -> forall ta (TR: transl_expr cenv a = OK ta), exists tv, @@ -2466,6 +2285,9 @@ Proof. induction 3; intros; simpl in TR; try (monadInv TR). (* Evar *) eapply var_get_correct; eauto. + (* Etempvar *) + inv MATCH. inv MENV. exploit me_temps0; eauto. intros [tv [A B]]. + exists tv; split; auto. constructor; auto. (* Eaddrof *) eapply var_addr_correct; eauto. (* Econst *) @@ -2474,16 +2296,6 @@ Proof. (* Eunop *) exploit IHeval_expr; eauto. intros [tv1 [EVAL1 INJ1]]. exploit eval_unop_compat; eauto. intros [tv [EVAL INJ]]. - revert EQ0. case_eq (unop_is_cast op); intros; monadInv EQ0. - revert EQ2. case_eq (chunktype_compat x0 m0); intros; monadInv EQ2. - exploit unop_is_cast_correct; eauto. instantiate (1 := v1); intros. - assert (val_normalized v1 m0). - eapply chunktype_compat_correct; eauto. - eapply chunktype_expr_correct; eauto. - red in H4. - assert (v = v1) by congruence. subst v. - exists tv1; auto. - exists tv; split. econstructor; eauto. auto. exists tv; split. econstructor; eauto. auto. (* Ebinop *) exploit IHeval_expr1; eauto. intros [tv1 [EVAL1 INJ1]]. @@ -2505,13 +2317,13 @@ Proof. Qed. Lemma transl_exprlist_correct: - forall f m tm cenv tf e te sp lo hi cs + forall f m tm cenv tf e le te sp lo hi cs (MINJ: Mem.inject f m tm) (MATCH: match_callstack f m tm - (Frame cenv tf e te sp lo hi :: cs) + (Frame cenv tf e le te sp lo hi :: cs) (Mem.nextblock m) (Mem.nextblock tm)), forall a v, - Csharpminor.eval_exprlist gve e m a v -> + Csharpminor.eval_exprlist ge e le m a v -> forall ta (TR: transl_exprlist cenv a = OK ta), exists tv, @@ -2545,44 +2357,36 @@ Inductive match_cont: Csharpminor.cont -> Cminor.cont -> option typ -> compilenv | match_Kblock2: forall k tk ty cenv xenv cs, match_cont k tk ty cenv xenv cs -> match_cont k (Kblock tk) ty cenv (false :: xenv) cs - | match_Kcall_none: forall fn e k tfn sp te tk ty cenv xenv lo hi cs sz cenv', + | match_Kcall: forall optid fn e le k tfn sp te tk ty cenv xenv lo hi cs sz cenv', transl_funbody cenv sz fn = OK tfn -> match_cont k tk fn.(fn_return) cenv xenv cs -> - match_cont (Csharpminor.Kcall None fn e k) - (Kcall None tfn (Vptr sp Int.zero) te tk) + match_cont (Csharpminor.Kcall optid fn e le k) + (Kcall (option_map for_temp optid) tfn (Vptr sp Int.zero) te tk) ty cenv' nil - (Frame cenv tfn e te sp lo hi :: cs) - | match_Kcall_some: forall id fn e k tfn s sp te tk ty cenv xenv lo hi cs sz cenv', - transl_funbody cenv sz fn = OK tfn -> - var_set_self cenv id (typ_of_opttyp ty) = OK s -> - match_cont k tk fn.(fn_return) cenv xenv cs -> - match_cont (Csharpminor.Kcall (Some id) fn e k) - (Kcall (Some id) tfn (Vptr sp Int.zero) te (Kseq s tk)) - ty cenv' nil - (Frame cenv tfn e te sp lo hi :: cs). + (Frame cenv tfn e le te sp lo hi :: cs). Inductive match_states: Csharpminor.state -> Cminor.state -> Prop := | match_state: - forall fn s k e m tfn ts tk sp te tm cenv xenv f lo hi cs sz + forall fn s k e le m tfn ts tk sp te tm cenv xenv f lo hi cs sz (TRF: transl_funbody cenv sz fn = OK tfn) (TR: transl_stmt fn.(fn_return) cenv xenv s = OK ts) (MINJ: Mem.inject f m tm) (MCS: match_callstack f m tm - (Frame cenv tfn e te sp lo hi :: cs) + (Frame cenv tfn e le te sp lo hi :: cs) (Mem.nextblock m) (Mem.nextblock tm)) (MK: match_cont k tk fn.(fn_return) cenv xenv cs), - match_states (Csharpminor.State fn s k e m) + match_states (Csharpminor.State fn s k e le m) (State tfn ts tk (Vptr sp Int.zero) te tm) | match_state_seq: - forall fn s1 s2 k e m tfn ts1 tk sp te tm cenv xenv f lo hi cs sz + forall fn s1 s2 k e le m tfn ts1 tk sp te tm cenv xenv f lo hi cs sz (TRF: transl_funbody cenv sz fn = OK tfn) (TR: transl_stmt fn.(fn_return) cenv xenv s1 = OK ts1) (MINJ: Mem.inject f m tm) (MCS: match_callstack f m tm - (Frame cenv tfn e te sp lo hi :: cs) + (Frame cenv tfn e le te sp lo hi :: cs) (Mem.nextblock m) (Mem.nextblock tm)) (MK: match_cont (Csharpminor.Kseq s2 k) tk fn.(fn_return) cenv xenv cs), - match_states (Csharpminor.State fn (Csharpminor.Sseq s1 s2) k e m) + match_states (Csharpminor.State fn (Csharpminor.Sseq s1 s2) k e le m) (State tfn ts1 tk (Vptr sp Int.zero) te tm) | match_callstate: forall fd args k m tfd targs tk tm f cs cenv @@ -2591,8 +2395,7 @@ Inductive match_states: Csharpminor.state -> Cminor.state -> Prop := (MCS: match_callstack f m tm cs (Mem.nextblock m) (Mem.nextblock tm)) (MK: match_cont k tk (Csharpminor.funsig fd).(sig_res) cenv nil cs) (ISCC: Csharpminor.is_call_cont k) - (ARGSINJ: val_list_inject f args targs) - (ARGSTY: Val.has_type_list args (Csharpminor.funsig fd).(sig_args)), + (ARGSINJ: val_list_inject f args targs), match_states (Csharpminor.Callstate fd args k m) (Callstate tfd targs tk tm) | match_returnstate: @@ -2600,8 +2403,7 @@ Inductive match_states: Csharpminor.state -> Cminor.state -> Prop := (MINJ: Mem.inject f m tm) (MCS: match_callstack f m tm cs (Mem.nextblock m) (Mem.nextblock tm)) (MK: match_cont k tk ty cenv nil cs) - (RESINJ: val_inject f v tv) - (RESTY: Val.has_type v (typ_of_opttyp ty)), + (RESINJ: val_inject f v tv), match_states (Csharpminor.Returnstate v k m) (Returnstate tv tk tm). @@ -2643,7 +2445,6 @@ Proof. intros [tk' [A B]]. exists tk'; split. eapply star_left; eauto. constructor. traceEq. auto. econstructor; split. apply star_refl. split. exact I. econstructor; eauto. - econstructor; split. apply star_refl. split. exact I. econstructor; eauto. Qed. (** Properties of [switch] compilation *) @@ -2744,18 +2545,18 @@ Proof. Qed. Lemma switch_match_states: - forall fn k e m tfn ts tk sp te tm cenv xenv f lo hi cs sz ls body tk' + forall fn k e le m tfn ts tk sp te tm cenv xenv f lo hi cs sz ls body tk' (TRF: transl_funbody cenv sz fn = OK tfn) (TR: transl_lblstmt (fn_return fn) cenv (switch_env ls xenv) ls body = OK ts) (MINJ: Mem.inject f m tm) (MCS: match_callstack f m tm - (Frame cenv tfn e te sp lo hi :: cs) + (Frame cenv tfn e le te sp lo hi :: cs) (Mem.nextblock m) (Mem.nextblock tm)) (MK: match_cont k tk (fn_return fn) cenv xenv cs) (TK: transl_lblstmt_cont (fn_return fn) cenv xenv ls tk tk'), exists S, plus step tge (State tfn (Sexit O) tk' (Vptr sp Int.zero) te tm) E0 S - /\ match_states (Csharpminor.State fn (seq_of_lbl_stmt ls) k e m) S. + /\ match_states (Csharpminor.State fn (seq_of_lbl_stmt ls) k e le m) S. Proof. intros. destruct ls; simpl. inv TK. econstructor; split. @@ -2777,24 +2578,21 @@ Variable cenv: compilenv. Variable cs: callstack. Remark find_label_var_set: - forall id e chunk s k, - var_set cenv id e chunk = OK s -> + forall id e s k, + var_set cenv id e = OK s -> find_label lbl s k = None. Proof. intros. unfold var_set in H. destruct (cenv!!id); try (monadInv H; reflexivity). - destruct (chunktype_compat chunk m). inv H; auto. - destruct (typ_eq (type_of_chunk m) (type_of_chunk chunk)); inv H; auto. Qed. Remark find_label_var_set_self: - forall id ty s k, - var_set_self cenv id ty = OK s -> - find_label lbl s k = None. + forall id ty s0 s k, + var_set_self cenv id ty s0 = OK s -> + find_label lbl s k = find_label lbl s0 k. Proof. intros. unfold var_set_self in H. destruct (cenv!!id); try (monadInv H; reflexivity). - destruct (typ_eq (type_of_chunk m) ty0); inv H; reflexivity. Qed. Lemma transl_lblstmt_find_label_context: @@ -2842,12 +2640,6 @@ Proof. intros. destruct s; try (monadInv H); simpl; auto. (* assign *) eapply find_label_var_set; eauto. - (* call *) - destruct o; monadInv H; simpl; auto. - destruct (list_eq_dec typ_eq x1 (sig_args s)); monadInv EQ4. - simpl. eapply find_label_var_set_self; eauto. - destruct (list_eq_dec typ_eq x1 (sig_args s)); monadInv EQ3. - simpl; eauto. (* seq *) exploit (transl_find_label s1). eauto. eapply match_Kseq. eexact EQ1. eauto. destruct (Csharpminor.find_label lbl s1 (Csharpminor.Kseq s2 k)) as [[s' k'] | ]. @@ -2869,7 +2661,6 @@ Proof. eapply transl_lblstmt_find_label. eauto. eauto. eauto. reflexivity. (* return *) destruct o; monadInv H; auto. - destruct (typ_eq x0 (typ_of_opttyp ty)); monadInv EQ2; auto. (* label *) destruct (ident_eq lbl l). exists x; exists tk; exists xenv; auto. @@ -2899,7 +2690,7 @@ Proof. induction vars; intros. monadInv H. auto. simpl in H. destruct a as [id lv]. monadInv H. - simpl. rewrite (find_label_var_set_self id (type_of_chunk lv)); auto. + transitivity (find_label lbl x k). eapply find_label_var_set_self; eauto. eauto. Qed. End FIND_LABEL. @@ -2930,12 +2721,12 @@ Fixpoint seq_left_depth (s: Csharpminor.stmt) : nat := Definition measure (S: Csharpminor.state) : nat := match S with - | Csharpminor.State fn s k e m => seq_left_depth s + | Csharpminor.State fn s k e le m => seq_left_depth s | _ => O end. Lemma transl_step_correct: - forall S1 t S2, Csharpminor.step gve S1 t S2 -> + forall S1 t S2, Csharpminor.step ge S1 t S2 -> forall T1, match_states S1 T1 -> (exists T2, plus step tge T1 t T2 /\ match_states S2 T2) \/ (measure S2 < measure S1 /\ t = E0 /\ match_states S2 T1)%nat. @@ -2970,16 +2761,24 @@ Proof. econstructor; split. eapply plus_right. eexact A. apply step_skip_call. auto. rewrite (sig_preserved_body _ _ _ _ TRF). auto. eauto. traceEq. - econstructor; eauto. exact I. + econstructor; eauto. (* assign *) monadInv TR. exploit transl_expr_correct; eauto. intros [tv [EVAL VINJ]]. - exploit var_set_correct; eauto. eapply chunktype_expr_correct; eauto. + exploit var_set_correct; eauto. intros [te' [tm' [EXEC [MINJ' [MCS' OTHER]]]]]. left; econstructor; split. apply plus_one. eexact EXEC. + econstructor; eauto. + +(* set *) + monadInv TR. + exploit transl_expr_correct; eauto. intros [tv [EVAL VINJ]]. + left; econstructor; split. + apply plus_one. econstructor; eauto. econstructor; eauto. + eapply match_callstack_set_temp; eauto. (* store *) monadInv TR. @@ -2999,31 +2798,8 @@ Proof. (* call *) simpl in H1. exploit functions_translated; eauto. intros [tfd [FIND TRANS]]. - simpl in TR. destruct optid; monadInv TR. -(* with return value *) - destruct (list_eq_dec typ_eq x1 (sig_args (Csharpminor.funsig fd))); monadInv EQ4. - exploit transl_expr_correct; eauto. - intros [tvf [EVAL1 VINJ1]]. - assert (tvf = vf). - exploit match_callstack_match_globalenvs; eauto. intros [bnd MG]. - eapply val_inject_function_pointer; eauto. - subst tvf. - exploit transl_exprlist_correct; eauto. - intros [tvargs [EVAL2 VINJ2]]. - left; econstructor; split. - eapply plus_left. constructor. apply star_one. - eapply step_call; eauto. - apply sig_preserved; eauto. - traceEq. - econstructor; eauto. - eapply match_Kcall_some with (cenv' := cenv); eauto. - red; auto. - eapply type_exprlist_correct; eauto. - -(* without return value *) - destruct (list_eq_dec typ_eq x1 (sig_args (Csharpminor.funsig fd))); monadInv EQ3. - exploit transl_expr_correct; eauto. - intros [tvf [EVAL1 VINJ1]]. + monadInv TR. + exploit transl_expr_correct; eauto. intros [tvf [EVAL1 VINJ1]]. assert (tvf = vf). exploit match_callstack_match_globalenvs; eauto. intros [bnd MG]. eapply val_inject_function_pointer; eauto. @@ -3031,13 +2807,11 @@ Proof. exploit transl_exprlist_correct; eauto. intros [tvargs [EVAL2 VINJ2]]. left; econstructor; split. - apply plus_one. - eapply step_call; eauto. + apply plus_one. eapply step_call; eauto. apply sig_preserved; eauto. econstructor; eauto. - eapply match_Kcall_none with (cenv' := cenv); eauto. + eapply match_Kcall with (cenv' := cenv); eauto. red; auto. - eapply type_exprlist_correct; eauto. (* seq *) monadInv TR. @@ -3126,14 +2900,12 @@ Proof. simpl; auto. (* return some *) - monadInv TR. destruct (typ_eq x0 (typ_of_opttyp (fn_return f))); monadInv EQ2. - left. + monadInv TR. left. exploit transl_expr_correct; eauto. intros [tv [EVAL VINJ]]. exploit match_callstack_freelist; eauto. intros [tm' [A [B C]]]. econstructor; split. apply plus_one. eapply step_return_1. eauto. eauto. econstructor; eauto. eapply match_call_cont; eauto. - eapply type_expr_correct; eauto. (* label *) monadInv TR. @@ -3155,12 +2927,15 @@ Proof. destruct (zle sz Int.max_signed); try congruence. intro TRBODY. generalize TRBODY; intro TMP. monadInv TMP. - set (tf := mkfunction (Csharpminor.fn_sig f) (fn_params_names f) - (make_vars (fn_params_names f) (fn_vars_names f) (Sseq x1 x0)) - sz (Sseq x1 x0)) in *. + set (tf := mkfunction (Csharpminor.fn_sig f) + (List.map for_var (fn_params_names f)) + (List.map for_var (fn_vars_names f) + ++ List.map for_temp (Csharpminor.fn_temps f)) + sz + (Sseq x1 x0)) in *. caseEq (Mem.alloc tm 0 (fn_stackspace tf)). intros tm' sp ALLOC'. exploit function_entry_ok; eauto; simpl; auto. - intros [f2 [te2 [tm2 [EXEC [MINJ2 [IINCR MCS2]]]]]]. + intros [f2 [tm2 [EXEC [MINJ2 [IINCR MCS2]]]]]. left; econstructor; split. eapply plus_left. constructor; simpl; eauto. simpl. eapply star_left. constructor. @@ -3189,25 +2964,13 @@ Proof. omega. omega. eapply external_call_nextblock_incr; eauto. eapply external_call_nextblock_incr; eauto. - simpl. change (Val.has_type vres (proj_sig_res (ef_sig ef))). - eapply external_call_well_typed; eauto. -(* return *) - inv MK; inv H. - (* no argument *) +(* return none *) + inv MK. simpl. left; econstructor; split. apply plus_one. econstructor; eauto. - simpl. econstructor; eauto. - (* one argument *) - exploit var_set_self_correct. eauto. eauto. eauto. eauto. eauto. eauto. - instantiate (1 := PTree.set id tv te). apply PTree.gss. - intros; apply PTree.gso; auto. - intros [te' [tm' [A [B [C D]]]]]. - left; econstructor; split. - eapply plus_left. econstructor. simpl. eapply star_left. econstructor. - eapply star_one. eexact A. - reflexivity. traceEq. - econstructor; eauto. + unfold set_optvar. destruct optid; simpl option_map; econstructor; eauto. + eapply match_callstack_set_temp; eauto. Qed. Lemma match_globalenvs_init: @@ -3244,7 +3007,7 @@ Proof. eapply Genv.initmem_inject; eauto. apply mcs_nil with (Mem.nextblock m0). apply match_globalenvs_init; auto. omega. omega. instantiate (1 := gce). constructor. - red; auto. constructor. rewrite H2; simpl; auto. + red; auto. constructor. Qed. Lemma transl_final_states: diff --git a/cfrontend/Csem.v b/cfrontend/Csem.v index 212c2ad..2858e64 100644 --- a/cfrontend/Csem.v +++ b/cfrontend/Csem.v @@ -30,6 +30,67 @@ Require Import Smallstep. (** * Semantics of type-dependent operations *) +(** Semantics of casts. [cast v1 t1 t2 v2] holds if value [v1], + viewed with static type [t1], can be cast to type [t2], + resulting in value [v2]. *) + +Definition cast_int_int (sz: intsize) (sg: signedness) (i: int) : int := + match sz, sg with + | I8, Signed => Int.sign_ext 8 i + | I8, Unsigned => Int.zero_ext 8 i + | I16, Signed => Int.sign_ext 16 i + | I16, Unsigned => Int.zero_ext 16 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_int (si : signedness) (f: float) : int := + match si with + | Signed => Float.intoffloat f + | Unsigned => Float.intuoffloat f + end. + +Definition cast_float_float (sz: floatsize) (f: float) : float := + match sz with + | F32 => Float.singleoffloat f + | F64 => f + end. + +Inductive neutral_for_cast: type -> Prop := + | nfc_int: forall sg, + neutral_for_cast (Tint I32 sg) + | nfc_ptr: forall ty, + neutral_for_cast (Tpointer ty) + | nfc_array: forall ty sz, + neutral_for_cast (Tarray ty sz) + | nfc_fun: forall targs tres, + neutral_for_cast (Tfunction targs tres). + +Inductive cast : val -> type -> type -> val -> Prop := + | cast_ii: forall i sz2 sz1 si1 si2, (**r int to int *) + cast (Vint i) (Tint sz1 si1) (Tint sz2 si2) + (Vint (cast_int_int sz2 si2 i)) + | cast_fi: forall f sz1 sz2 si2, (**r float to int *) + cast (Vfloat f) (Tfloat sz1) (Tint sz2 si2) + (Vint (cast_int_int sz2 si2 (cast_float_int si2 f))) + | cast_if: forall i sz1 sz2 si1, (**r int to float *) + cast (Vint i) (Tint sz1 si1) (Tfloat sz2) + (Vfloat (cast_float_float sz2 (cast_int_float si1 i))) + | cast_ff: forall f sz1 sz2, (**r float to float *) + cast (Vfloat f) (Tfloat sz1) (Tfloat sz2) + (Vfloat (cast_float_float sz2 f)) + | cast_nn_p: forall b ofs t1 t2, (**r no change in data representation *) + neutral_for_cast t1 -> neutral_for_cast t2 -> + cast (Vptr b ofs) t1 t2 (Vptr b ofs) + | cast_nn_i: forall n t1 t2, (**r no change in data representation *) + neutral_for_cast t1 -> neutral_for_cast t2 -> + cast (Vint n) t1 t2 (Vint n). + (** Interpretation of values as truth values. Non-zero integers, non-zero floats and non-null pointers are considered as true. The integer zero (which also represents @@ -59,6 +120,7 @@ Inductive is_true: val -> type -> Prop := Float.cmp Ceq f Float.zero = false -> 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 -> @@ -66,67 +128,69 @@ Inductive bool_of_val : val -> type -> val -> Prop := | bool_of_val_false: forall v ty, is_false v ty -> bool_of_val v ty Vfalse. +*) (** The following [sem_] functions compute the result of an operator application. Since operators are overloaded, the result depends both on the static types of the arguments and on their run-time values. - Unlike in C, automatic conversions between integers and floats - are not performed. For instance, [e1 + e2] is undefined if [e1] - is a float and [e2] an integer. The Clight producer must have explicitly - promoted [e2] to a float. *) + For binary operations, the "usual binary conversions", adapted to a 32-bit + platform, state that: +- If both arguments are of integer type, an integer operation is performed. + For operations that behave differently at unsigned and signed types + (e.g. division, modulus, comparisons), the unsigned operation is selected + if at least one of the arguments is of type "unsigned int 32", otherwise + the signed operation is performed. +- If both arguments are of float type, a float operation is performed. + We choose to perform all float arithmetic in double precision, + even if both arguments are single-precision floats. +- If one argument has integer type and the other has float type, + we convert the integer argument to float, then perform the float operation. + *) Function sem_neg (v: val) (ty: type) : option val := - match ty with - | Tint _ _ => + match classify_neg ty with + | neg_case_i sg => match v with | Vint n => Some (Vint (Int.neg n)) | _ => None end - | Tfloat _ => + | neg_case_f => 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 + | neg_default => None end. -Function sem_notbool (v: val) (ty: type) : option val := - match typeconv ty with - | Tint _ _ => +Function sem_notint (v: val) (ty: type): option val := + match classify_notint ty with + | notint_case_i sg => match v with - | Vint n => Some (Val.of_bool (Int.eq n Int.zero)) - | Vptr _ _ => Some Vfalse + | Vint n => Some (Vint (Int.xor n Int.mone)) | _ => None end - | Tpointer _ => + | notint_default => None + end. + +Function sem_notbool (v: val) (ty: type) : option val := + match classify_bool ty with + | bool_case_ip => match v with | Vint n => Some (Val.of_bool (Int.eq n Int.zero)) | Vptr _ _ => Some Vfalse | _ => None end - | Tfloat _ => + | bool_case_f => match v with | Vfloat f => Some (Val.of_bool (Float.cmp Ceq f Float.zero)) | _ => None end - | _ => None - end. - -Function sem_fabs (v: val) : option val := - match v with - | Vfloat f => Some (Vfloat (Float.abs f)) - | _ => None + | bool_default => None end. Function sem_add (v1:val) (t1:type) (v2: val) (t2:type) : option val := match classify_add t1 t2 with - | add_case_ii => (**r integer addition *) + | add_case_ii sg => (**r integer addition *) match v1, v2 with | Vint n1, Vint n2 => Some (Vint (Int.add n1 n2)) | _, _ => None @@ -136,6 +200,16 @@ Function sem_add (v1:val) (t1:type) (v2: val) (t2:type) : option val := | Vfloat n1, Vfloat n2 => Some (Vfloat (Float.add n1 n2)) | _, _ => None end + | add_case_if sg => (**r int plus float *) + match v1, v2 with + | Vint n1, Vfloat n2 => Some (Vfloat (Float.add (cast_int_float sg n1) n2)) + | _, _ => None + end + | add_case_fi sg => (**r float plus int *) + match v1, v2 with + | Vfloat n1, Vint n2 => Some (Vfloat (Float.add n1 (cast_int_float sg n2))) + | _, _ => None + end | add_case_pi ty => (**r pointer plus integer *) match v1,v2 with | Vptr b1 ofs1, Vint n2 => @@ -153,7 +227,7 @@ end. Function sem_sub (v1:val) (t1:type) (v2: val) (t2:type) : option val := match classify_sub t1 t2 with - | sub_case_ii => (**r integer subtraction *) + | sub_case_ii sg => (**r integer subtraction *) match v1,v2 with | Vint n1, Vint n2 => Some (Vint (Int.sub n1 n2)) | _, _ => None @@ -163,6 +237,16 @@ Function sem_sub (v1:val) (t1:type) (v2: val) (t2:type) : option val := | Vfloat f1, Vfloat f2 => Some (Vfloat(Float.sub f1 f2)) | _, _ => None end + | sub_case_if sg => (**r int minus float *) + match v1, v2 with + | Vint n1, Vfloat n2 => Some (Vfloat (Float.sub (cast_int_float sg n1) n2)) + | _, _ => None + end + | sub_case_fi sg => (**r float minus int *) + match v1, v2 with + | Vfloat n1, Vint n2 => Some (Vfloat (Float.sub n1 (cast_int_float sg n2))) + | _, _ => None + end | sub_case_pi ty => (**r pointer minus integer *) match v1,v2 with | Vptr b1 ofs1, Vint n2 => @@ -183,7 +267,7 @@ Function sem_sub (v1:val) (t1:type) (v2: val) (t2:type) : option val := Function sem_mul (v1:val) (t1:type) (v2: val) (t2:type) : option val := match classify_mul t1 t2 with - | mul_case_ii => + | mul_case_ii sg => match v1,v2 with | Vint n1, Vint n2 => Some (Vint (Int.mul n1 n2)) | _, _ => None @@ -193,19 +277,29 @@ Function sem_mul (v1:val) (t1:type) (v2: val) (t2:type) : option val := | Vfloat f1, Vfloat f2 => Some (Vfloat (Float.mul f1 f2)) | _, _ => None end + | mul_case_if sg => + match v1, v2 with + | Vint n1, Vfloat n2 => Some (Vfloat (Float.mul (cast_int_float sg n1) n2)) + | _, _ => None + end + | mul_case_fi sg => + match v1, v2 with + | Vfloat n1, Vint n2 => Some (Vfloat (Float.mul n1 (cast_int_float sg n2))) + | _, _ => 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 => + | div_case_ii Unsigned => 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 => + | div_case_ii Signed => match v1,v2 with | Vint n1, Vint n2 => if Int.eq n2 Int.zero then None else Some (Vint(Int.divs n1 n2)) @@ -216,68 +310,94 @@ Function sem_div (v1:val) (t1:type) (v2: val) (t2:type) : option val := | Vfloat f1, Vfloat f2 => Some (Vfloat(Float.div f1 f2)) | _, _ => None end + | div_case_if sg => + match v1, v2 with + | Vint n1, Vfloat n2 => Some (Vfloat (Float.div (cast_int_float sg n1) n2)) + | _, _ => None + end + | div_case_fi sg => + match v1, v2 with + | Vfloat n1, Vint n2 => Some (Vfloat (Float.div n1 (cast_int_float sg n2))) + | _, _ => 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 classify_binint t1 t2 with + | binint_case_ii Unsigned => 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 => + | binint_case_ii Signed => 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 => + | binint_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 +Function sem_and (v1:val) (t1:type) (v2: val) (t2:type) : option val := + match classify_binint t1 t2 with + | binint_case_ii sg => + match v1, v2 with + | Vint n1, Vint n2 => Some (Vint(Int.and n1 n2)) + | _, _ => None + end + | binint_default => None + end. + +Function sem_or (v1:val) (t1:type) (v2: val) (t2:type) : option val := + match classify_binint t1 t2 with + | binint_case_ii sg => + match v1, v2 with + | Vint n1, Vint n2 => Some (Vint(Int.or n1 n2)) + | _, _ => None + end + | binint_default => None + end. + +Function sem_xor (v1:val) (t1:type) (v2: val) (t2:type) : option val := + match classify_binint t1 t2 with + | binint_case_ii sg => + match v1, v2 with + | Vint n1, Vint n2 => Some (Vint(Int.xor n1 n2)) + | _, _ => None + end + | binint_default => None end. -Function sem_shl (v1 v2: val): option val := - match v1, v2 with - | Vint n1, Vint n2 => - if Int.ltu n2 Int.iwordsize then Some (Vint(Int.shl n1 n2)) else None - | _, _ => None +Function sem_shl (v1:val) (t1:type) (v2: val) (t2:type) : option val := + match classify_shift t1 t2 with + | shift_case_ii sg => + match v1, v2 with + | Vint n1, Vint n2 => + if Int.ltu n2 Int.iwordsize then Some (Vint(Int.shl n1 n2)) else None + | _, _ => None + end + | shift_default => 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 classify_shift t1 t2 with + | shift_case_ii Unsigned => match v1,v2 with | Vint n1, Vint n2 => if Int.ltu n2 Int.iwordsize then Some (Vint (Int.shru n1 n2)) else None | _,_ => None end - | shr_case_ii => + | shift_case_ii Signed => match v1,v2 with | Vint n1, Vint n2 => if Int.ltu n2 Int.iwordsize then Some (Vint (Int.shr n1 n2)) else None | _, _ => None end - | shr_default=> + | shift_default => None end. @@ -292,7 +412,7 @@ 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 => + | cmp_case_iiu => match v1,v2 with | Vint n1, Vint n2 => Some (Val.of_bool (Int.cmpu c n1 n2)) | _, _ => None @@ -318,6 +438,16 @@ Function sem_cmp (c:comparison) | Vfloat f1, Vfloat f2 => Some (Val.of_bool (Float.cmp c f1 f2)) | _, _ => None end + | cmp_case_if sg => + match v1, v2 with + | Vint n1, Vfloat n2 => Some (Val.of_bool (Float.cmp c (cast_int_float sg n1) n2)) + | _, _ => None + end + | cmp_case_fi sg => + match v1, v2 with + | Vfloat n1, Vint n2 => Some (Val.of_bool (Float.cmp c n1 (cast_int_float sg n2))) + | _, _ => None + end | cmp_default => None end. @@ -325,9 +455,8 @@ 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 + | Onotint => sem_notint v ty | Oneg => sem_neg v ty - | Ofabs => sem_fabs v end. Definition sem_binary_operation @@ -340,10 +469,10 @@ Definition sem_binary_operation | 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 + | Oand => sem_and v1 t1 v2 t2 + | Oor => sem_or v1 t1 v2 t2 + | Oxor => sem_xor v1 t1 v2 t2 + | Oshl => sem_shl v1 t1 v2 t2 | 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 @@ -353,67 +482,12 @@ Definition sem_binary_operation | Oge => sem_cmp Cge v1 t1 v2 t2 m end. -(** Semantic of casts. [cast v1 t1 t2 v2] holds if value [v1], - viewed with static type [t1], can be cast to type [t2], - resulting in value [v2]. *) - -Definition cast_int_int (sz: intsize) (sg: signedness) (i: int) : int := - match sz, sg with - | I8, Signed => Int.sign_ext 8 i - | I8, Unsigned => Int.zero_ext 8 i - | I16, Signed => Int.sign_ext 16 i - | I16, Unsigned => Int.zero_ext 16 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_int (si : signedness) (f: float) : int := - match si with - | Signed => Float.intoffloat f - | Unsigned => Float.intuoffloat f - end. - -Definition cast_float_float (sz: floatsize) (f: float) : float := - match sz with - | F32 => Float.singleoffloat f - | F64 => f +Definition sem_incrdecr (id: incr_or_decr) (v: val) (ty: type) := + match id with + | Incr => sem_add v ty (Vint Int.one) (Tint I32 Signed) + | Decr => sem_sub v ty (Vint Int.one) (Tint I32 Signed) end. -Inductive neutral_for_cast: type -> Prop := - | nfc_int: forall sg, - neutral_for_cast (Tint I32 sg) - | nfc_ptr: forall ty, - neutral_for_cast (Tpointer ty) - | nfc_array: forall ty sz, - neutral_for_cast (Tarray ty sz) - | nfc_fun: forall targs tres, - neutral_for_cast (Tfunction targs tres). - -Inductive cast : val -> type -> type -> val -> Prop := - | cast_ii: forall i sz2 sz1 si1 si2, (**r int to int *) - cast (Vint i) (Tint sz1 si1) (Tint sz2 si2) - (Vint (cast_int_int sz2 si2 i)) - | cast_fi: forall f sz1 sz2 si2, (**r float to int *) - cast (Vfloat f) (Tfloat sz1) (Tint sz2 si2) - (Vint (cast_int_int sz2 si2 (cast_float_int si2 f))) - | cast_if: forall i sz1 sz2 si1, (**r int to float *) - cast (Vint i) (Tint sz1 si1) (Tfloat sz2) - (Vfloat (cast_float_float sz2 (cast_int_float si1 i))) - | cast_ff: forall f sz1 sz2, (**r float to float *) - cast (Vfloat f) (Tfloat sz1) (Tfloat sz2) - (Vfloat (cast_float_float sz2 f)) - | cast_nn_p: forall b ofs t1 t2, (**r no change in data representation *) - neutral_for_cast t1 -> neutral_for_cast t2 -> - cast (Vptr b ofs) t1 t2 (Vptr b ofs) - | cast_nn_i: forall n t1 t2, (**r no change in data representation *) - neutral_for_cast t1 -> neutral_for_cast t2 -> - cast (Vint n) t1 t2 (Vint n). - (** * Operational semantics *) (** The semantics uses two environments. The global environment @@ -422,7 +496,7 @@ Inductive cast : val -> type -> type -> val -> Prop := Definition genv := Genv.t fundef type. -(** The local environment maps local variables to block references. +(** The local environment maps local variables to block references and types. The current value of the variable is stored in the associated memory block. *) @@ -522,180 +596,328 @@ Section SEMANTICS. Variable ge: genv. -(** ** Evaluation of expressions *) +(** [type_of_global b] returns the type of the global variable or function + at address [b]. *) + +Definition type_of_global (b: block) : option type := + match Genv.find_var_info ge b with + | Some gv => Some gv.(gvar_info) + | None => + match Genv.find_funct_ptr ge b with + | Some fd => Some(type_of_fundef fd) + | None => None + end + end. + +(** ** Reduction semantics for expressions *) Section EXPR. Variable e: env. -Variable m: mem. - -(** [eval_expr ge e m a v] defines the evaluation of expression [a] - in r-value position. [v] is the value of the expression. - [e] is the current environment and [m] is the current memory state. *) - -Inductive eval_expr: expr -> val -> Prop := - | eval_Econst_int: forall i ty, - eval_expr (Expr (Econst_int i) ty) (Vint i) - | eval_Econst_float: forall f ty, - eval_expr (Expr (Econst_float f) ty) (Vfloat f) - | eval_Elvalue: forall a ty loc ofs v, - eval_lvalue (Expr a ty) loc ofs -> - load_value_of_type ty m loc ofs = Some v -> - eval_expr (Expr a ty) v - | eval_Eaddrof: forall a ty loc ofs, - eval_lvalue a loc ofs -> - eval_expr (Expr (Eaddrof a) ty) (Vptr loc ofs) - | eval_Esizeof: forall ty' ty, - eval_expr (Expr (Esizeof ty') ty) (Vint (Int.repr (sizeof ty'))) - | eval_Eunop: forall op a ty v1 v, - eval_expr a v1 -> - sem_unary_operation op v1 (typeof a) = Some v -> - eval_expr (Expr (Eunop op a) ty) v - | eval_Ebinop: forall op a1 a2 ty v1 v2 v, - eval_expr a1 v1 -> - eval_expr a2 v2 -> - sem_binary_operation op v1 (typeof a1) v2 (typeof a2) m = Some v -> - eval_expr (Expr (Ebinop op a1 a2) ty) v - | eval_Econdition_true: forall a1 a2 a3 ty v1 v2, - eval_expr a1 v1 -> - is_true v1 (typeof a1) -> - eval_expr a2 v2 -> - eval_expr (Expr (Econdition a1 a2 a3) ty) v2 - | eval_Econdition_false: forall a1 a2 a3 ty v1 v3, - eval_expr a1 v1 -> - is_false v1 (typeof a1) -> - eval_expr a3 v3 -> - eval_expr (Expr (Econdition a1 a2 a3) ty) v3 - | eval_Eorbool_1: forall a1 a2 ty v1, - eval_expr a1 v1 -> - is_true v1 (typeof a1) -> - eval_expr (Expr (Eorbool a1 a2) ty) Vtrue - | eval_Eorbool_2: forall a1 a2 ty v1 v2 v, - eval_expr a1 v1 -> - is_false v1 (typeof a1) -> - eval_expr a2 v2 -> - bool_of_val v2 (typeof a2) v -> - eval_expr (Expr (Eorbool a1 a2) ty) v - | eval_Eandbool_1: forall a1 a2 ty v1, - eval_expr a1 v1 -> - is_false v1 (typeof a1) -> - eval_expr (Expr (Eandbool a1 a2) ty) Vfalse - | eval_Eandbool_2: forall a1 a2 ty v1 v2 v, - eval_expr a1 v1 -> - is_true v1 (typeof a1) -> - eval_expr a2 v2 -> - bool_of_val v2 (typeof a2) v -> - eval_expr (Expr (Eandbool a1 a2) ty) v - | eval_Ecast: forall a ty ty' v1 v, - eval_expr a v1 -> - cast v1 (typeof a) ty v -> - eval_expr (Expr (Ecast ty a) ty') v - -(** [eval_lvalue ge e m a b ofs] defines the evaluation of expression [a] - in l-value position. The result is the memory location [b, ofs] - that contains the value of the expression [a]. *) - -with eval_lvalue: expr -> block -> int -> Prop := - | eval_Evar_local: forall id l ty, - e!id = Some(l, ty) -> - eval_lvalue (Expr (Evar id) ty) l Int.zero - | eval_Evar_global: forall id l ty, - e!id = None -> - Genv.find_symbol ge id = Some l -> - eval_lvalue (Expr (Evar id) ty) l Int.zero - | eval_Ederef: forall a ty l ofs, - eval_expr a (Vptr l ofs) -> - eval_lvalue (Expr (Ederef a) ty) l ofs - | eval_Efield_struct: forall a i ty l ofs id fList delta, - eval_lvalue a l ofs -> - typeof a = Tstruct id fList -> - field_offset i fList = OK delta -> - eval_lvalue (Expr (Efield a i) ty) l (Int.add ofs (Int.repr delta)) - | eval_Efield_union: forall a i ty l ofs id fList, - eval_lvalue a l ofs -> - typeof a = Tunion id fList -> - eval_lvalue (Expr (Efield a i) ty) l ofs. - -Scheme eval_expr_ind2 := Minimality for eval_expr Sort Prop - with eval_lvalue_ind2 := Minimality for eval_lvalue Sort Prop. - -(** [eval_exprlist ge e m al vl] evaluates a list of r-value - expressions [al] to their values [vl]. *) - -Inductive eval_exprlist: list expr -> list val -> Prop := - | eval_Enil: - eval_exprlist nil nil - | eval_Econs: forall a bl v vl, - eval_expr a v -> - eval_exprlist bl vl -> - eval_exprlist (a :: bl) (v :: vl). - -End EXPR. - -(** ** Transition semantics for statements and functions *) - -(** Continuations *) + +(** The semantics of expressions follows the popular Wright-Felleisen style. + It is a small-step semantics that reduces one redex at a time. + We first define head reductions (at the top of an expression, then + use reduction contexts to define reduction within an expression. *) + +(** Head reduction for l-values. *) + +Inductive lred: expr -> mem -> expr -> mem -> Prop := + | red_var_local: forall x ty m b, + e!x = Some(b, ty) -> + lred (Evar x ty) m + (Eloc b Int.zero ty) m + | red_var_global: forall x ty m b, + e!x = None -> + Genv.find_symbol ge x = Some b -> + type_of_global b = Some ty -> + lred (Evar x ty) m + (Eloc b Int.zero ty) m + | red_deref: forall b ofs ty1 ty m, + lred (Ederef (Eval (Vptr b ofs) ty1) ty) m + (Eloc b ofs ty) m + | red_field_struct: forall b ofs id fList f ty m delta, + field_offset f fList = OK delta -> + lred (Efield (Eloc b ofs (Tstruct id fList)) f ty) m + (Eloc b (Int.add ofs (Int.repr delta)) ty) m + | red_field_union: forall b ofs id fList f ty m, + lred (Efield (Eloc b ofs (Tunion id fList)) f ty) m + (Eloc b ofs ty) m. + +(** Head reductions for r-values *) + +Inductive rred: expr -> mem -> expr -> mem -> Prop := + | red_rvalof: forall b ofs ty m v, + load_value_of_type ty m b ofs = Some v -> + rred (Evalof (Eloc b ofs ty) ty) m + (Eval v ty) m + | red_addrof: forall b ofs ty1 ty m, + rred (Eaddrof (Eloc b ofs ty1) ty) m + (Eval (Vptr b ofs) ty) m + | red_unop: forall op v1 ty1 ty m v, + sem_unary_operation op v1 ty1 = Some v -> + rred (Eunop op (Eval v1 ty1) ty) m + (Eval v ty) m + | red_binop: forall op v1 ty1 v2 ty2 ty m v, + sem_binary_operation op v1 ty1 v2 ty2 m = Some v -> + rred (Ebinop op (Eval v1 ty1) (Eval v2 ty2) ty) m + (Eval v ty) m + | red_cast: forall ty v1 ty1 m v, + cast v1 ty1 ty v -> + rred (Ecast (Eval v1 ty1) ty) m + (Eval v ty) m + | red_condition_true: forall v1 ty1 r1 r2 ty m, + is_true v1 ty1 -> typeof r1 = ty -> + rred (Econdition (Eval v1 ty1) r1 r2 ty) m + (Eparen r1 ty) m + | red_condition_false: forall v1 ty1 r1 r2 ty m, + is_false v1 ty1 -> typeof r2 = ty -> + rred (Econdition (Eval v1 ty1) r1 r2 ty) m + (Eparen r2 ty) m + | red_sizeof: forall ty1 ty m, + rred (Esizeof ty1 ty) m + (Eval (Vint (Int.repr (sizeof ty1))) ty) m + | red_assign: forall b ofs ty1 v2 ty2 m v m', + cast v2 ty2 ty1 v -> + store_value_of_type ty1 m b ofs v = Some m' -> + rred (Eassign (Eloc b ofs ty1) (Eval v2 ty2) ty1) m + (Eval v ty1) m' + | red_assignop: forall op b ofs ty1 v2 ty2 tyres m v1 v v' m', + load_value_of_type ty1 m b ofs = Some v1 -> + sem_binary_operation op v1 ty1 v2 ty2 m = Some v -> + cast v tyres ty1 v' -> + store_value_of_type ty1 m b ofs v' = Some m' -> + rred (Eassignop op (Eloc b ofs ty1) (Eval v2 ty2) tyres ty1) m + (Eval v' ty1) m' + | red_postincr: forall id b ofs ty m v1 v2 v3 m', + load_value_of_type ty m b ofs = Some v1 -> + sem_incrdecr id v1 ty = Some v2 -> + cast v2 (typeconv ty) ty v3 -> + store_value_of_type ty m b ofs v3 = Some m' -> + rred (Epostincr id (Eloc b ofs ty) ty) m + (Eval v1 ty) m' + | red_comma: forall v ty1 r2 ty m, + typeof r2 = ty -> + rred (Ecomma (Eval v ty1) r2 ty) m + r2 m + | red_paren: forall r ty m, + typeof r = ty -> + rred (Eparen r ty) m + r m. + +(** Head reduction for function calls. + (More exactly, identification of function calls that can reduce.) *) + +Inductive cast_arguments: exprlist -> typelist -> list val -> Prop := + | cast_args_nil: + cast_arguments Enil Tnil nil + | cast_args_cons: forall v ty el targ1 targs v1 vl, + cast v ty targ1 v1 -> cast_arguments el targs vl -> + cast_arguments (Econs (Eval v ty) el) (Tcons targ1 targs) (v1 :: vl). + +Inductive callred: expr -> fundef -> list val -> type -> Prop := + | red_Ecall: forall vf tyargs tyres el ty fd vargs, + Genv.find_funct ge vf = Some fd -> + cast_arguments el tyargs vargs -> + type_of_fundef fd = Tfunction tyargs tyres -> + callred (Ecall (Eval vf (Tfunction tyargs tyres)) el ty) + fd vargs ty. + +(** Reduction contexts. In accordance with C's nondeterministic semantics, + we allow reduction both to the left and to the right of a binary operator. + To enforce C's notion of sequence point, reductions within a conditional + [a ? b : c] can only take place in [a], not in [b] nor [c]; + and reductions within a sequence [a, b] can only take place in [a], not in [b]. + + Reduction contexts are represented by functions [C] from expressions to expressions, + suitably constrained by the [context from to C] predicate below. + Contexts are "kinded" with respect to l-values and r-values: + [from] is the kind of the hole in the context and [to] is the kind of + the term resulting from filling the hole. +*) + +Inductive kind : Type := LV | RV. + +Inductive context: kind -> kind -> (expr -> expr) -> Prop := + | ctx_top: forall k, + context k k (fun x => x) + | ctx_deref: forall k C ty, + context k RV C -> context k LV (fun x => Ederef (C x) ty) + | ctx_field: forall k C f ty, + context k LV C -> context k LV (fun x => Efield (C x) f ty) + | ctx_rvalof: forall k C ty, + context k LV C -> context k RV (fun x => Evalof (C x) ty) + | ctx_addrof: forall k C ty, + context k LV C -> context k RV (fun x => Eaddrof (C x) ty) + | ctx_unop: forall k C op ty, + context k RV C -> context k RV (fun x => Eunop op (C x) ty) + | ctx_binop_left: forall k C op e2 ty, + context k RV C -> context k RV (fun x => Ebinop op (C x) e2 ty) + | ctx_binop_right: forall k C op e1 ty, + context k RV C -> context k RV (fun x => Ebinop op e1 (C x) ty) + | ctx_cast: forall k C ty, + context k RV C -> context k RV (fun x => Ecast (C x) ty) + | ctx_condition: forall k C r2 r3 ty, + context k RV C -> context k RV (fun x => Econdition (C x) r2 r3 ty) + | ctx_assign_left: forall k C e2 ty, + context k LV C -> context k RV (fun x => Eassign (C x) e2 ty) + | ctx_assign_right: forall k C e1 ty, + context k RV C -> context k RV (fun x => Eassign e1 (C x) ty) + | ctx_assignop_left: forall k C op e2 tyres ty, + context k LV C -> context k RV (fun x => Eassignop op (C x) e2 tyres ty) + | ctx_assignop_right: forall k C op e1 tyres ty, + context k RV C -> context k RV (fun x => Eassignop op e1 (C x) tyres ty) + | ctx_postincr: forall k C id ty, + context k LV C -> context k RV (fun x => Epostincr id (C x) ty) + | ctx_call_left: forall k C el ty, + context k RV C -> context k RV (fun x => Ecall (C x) el ty) + | ctx_call_right: forall k C e1 ty, + contextlist k C -> context k RV (fun x => Ecall e1 (C x) ty) + | ctx_comma: forall k C e2 ty, + context k RV C -> context k RV (fun x => Ecomma (C x) e2 ty) + | ctx_paren: forall k C ty, + context k RV C -> context k RV (fun x => Eparen (C x) ty) + +with contextlist: kind -> (expr -> exprlist) -> Prop := + | ctx_list_head: forall k C el, + context k RV C -> contextlist k (fun x => Econs (C x) el) + | ctx_list_tail: forall k C e1, + contextlist k C -> contextlist k (fun x => Econs e1 (C x)). + +(** In a nondeterministic semantics, expressions can go wrong according + to one reduction order while being defined according to another. + Consider for instance [(x = 1) + (10 / x)] where [x] is initially [0]. + This expression goes wrong if evaluated right-to-left, but is defined + if evaluated left-to-right. Since our compiler is going to pick one + particular evaluation order, we must make sure that all orders are safe, + i.e. never evaluate a subexpression that goes wrong. + + Being safe is a stronger requirement than just not getting stuck during + reductions. Consider [f() + (10 / x)], where [f()] does not terminate. + This expression is never stuck because the evaluation of [f()] can make + infinitely many transitions. Yet it contains a subexpression [10 / x] + that can go wrong if [x = 0], and the compiler may choose to evaluate + [10 / x] first, before calling [f()]. + + Therefore, we must make sure that not only an expression cannot get stuck, + but none of its subexpressions can either. We say that a subexpression + is not immediately stuck if it is a value (of the appropriate kind) + or it can reduce (at head or within). *) + +Inductive not_imm_stuck: kind -> expr -> mem -> Prop := + | not_stuck_val: forall v ty m, + not_imm_stuck RV (Eval v ty) m + | not_stuck_loc: forall b ofs ty m, + not_imm_stuck LV (Eloc b ofs ty) m + | not_stuck_lred: forall to C e m e' m', + lred e m e' m' -> + context LV to C -> + not_imm_stuck to (C e) m + | not_stuck_rred: forall to C e m e' m', + rred e m e' m' -> + context RV to C -> + not_imm_stuck to (C e) m + | not_stuck_callred: forall to C e m fd args ty, + callred e fd args ty -> + context RV to C -> + not_imm_stuck to (C e) m. + +(* An expression is not stuck if none of the potential redexes contained within + is immediately stuck. *) + +Definition not_stuck (e: expr) (m: mem) : Prop := + forall k C e' , + context k RV C -> e = C e' -> not_imm_stuck k e' m. + +End EXPR. + +(** ** Transition semantics. *) + +(** Continuations describe the computations that remain to be performed + after the statement or expression under consideration has + evaluated completely. *) Inductive cont: Type := | Kstop: cont - | Kseq: statement -> cont -> cont - (**r [Kseq s2 k] = after [s1] in [s1;s2] *) - | Kwhile: expr -> statement -> cont -> cont - (**r [Kwhile e s k] = after [s] in [while (e) s] *) - | Kdowhile: expr -> statement -> cont -> cont - (**r [Kdowhile e s k] = after [s] in [do s while (e)] *) - | Kfor2: expr -> statement -> statement -> cont -> cont - (**r [Kfor2 e2 e3 s k] = after [s] in [for(e1;e2;e3) s] *) - | Kfor3: expr -> statement -> statement -> cont -> cont - (**r [Kfor3 e2 e3 s k] = after [e3] in [for(e1;e2;e3) s] *) - | Kswitch: cont -> cont - (**r catches [break] statements arising out of [switch] *) - | Kcall: option (block * int * type) -> (**r where to store result *) - function -> (**r calling function *) - env -> (**r local env of calling function *) + | Kdo: cont -> cont (**r [Kdo k] = after [x] in [x;] *) + | Kseq: statement -> cont -> cont (**r [Kseq s2 k] = after [s1] in [s1;s2] *) + | Kifthenelse: statement -> statement -> cont -> cont (**r [Kifthenelse s1 s2 k] = after [x] in [if (x) { s1 } else { s2 }] *) + | Kwhile1: expr -> statement -> cont -> cont (**r [Kwhile1 x s k] = after [x] in [while(x) s] *) + | Kwhile2: expr -> statement -> cont -> cont (**r [Kwhile x s k] = after [s] in [while (x) s] *) + | Kdowhile1: expr -> statement -> cont -> cont (**r [Kdowhile1 x s k] = after [s] in [do s while (x)] *) + | Kdowhile2: expr -> statement -> cont -> cont (**r [Kdowhile2 x s k] = after [x] in [do s while (x)] *) + | Kfor2: expr -> statement -> statement -> cont -> cont (**r [Kfor2 e2 e3 s k] = after [e2] in [for(e1;e2;e3) s] *) + | Kfor3: expr -> statement -> statement -> cont -> cont (**r [Kfor3 e2 e3 s k] = after [s] in [for(e1;e2;e3) s] *) + | Kfor4: expr -> statement -> statement -> cont -> cont (**r [Kfor3 e2 e3 s k] = after [e3] in [for(e1;e2;e3) s] *) + | Kswitch1: labeled_statements -> cont -> cont (**r [Kswitch1 ls k] = after [e] in [switch(e) { ls }] *) + | Kswitch2: cont -> cont (**r catches [break] statements arising out of [switch] *) + | Kreturn: cont -> cont (**r [Kreturn k] = after [e] in [return e;] *) + | Kcall: function -> (**r calling function *) + env -> (**r local env of calling function *) + (expr -> expr) -> (**r context of the call *) + type -> (**r type of call expression *) cont -> cont. (** Pop continuation until a call or stop *) Fixpoint call_cont (k: cont) : cont := match k with + | Kstop => k + | Kdo k => k | Kseq s k => call_cont k - | Kwhile e s k => call_cont k - | Kdowhile e s k => call_cont k + | Kifthenelse s1 s2 k => call_cont k + | Kwhile1 e s k => call_cont k + | Kwhile2 e s k => call_cont k + | Kdowhile1 e s k => call_cont k + | Kdowhile2 e s k => call_cont k | Kfor2 e2 e3 s k => call_cont k | Kfor3 e2 e3 s k => call_cont k - | Kswitch k => call_cont k - | _ => k + | Kfor4 e2 e3 s k => call_cont k + | Kswitch1 ls k => call_cont k + | Kswitch2 k => call_cont k + | Kreturn k => call_cont k + | Kcall _ _ _ _ _ => k end. Definition is_call_cont (k: cont) : Prop := match k with | Kstop => True - | Kcall _ _ _ _ => True + | Kcall _ _ _ _ _ => True | _ => False end. -(** States *) +(** Execution states of the program are grouped in 4 classes corresponding + to the part of the program we are currently executing. It can be + a statement ([State]), an expression ([ExprState]), a transition + from a calling function to a called function ([Callstate]), or + the symmetrical transition from a function back to its caller + ([Returnstate]). *) Inductive state: Type := - | State + | State (**r execution of a statement *) (f: function) (s: statement) (k: cont) (e: env) (m: mem) : state - | Callstate + | ExprState (**r reduction of an expression *) + (f: function) + (r: expr) + (k: cont) + (e: env) + (m: mem) : state + | Callstate (**r calling a function *) (fd: fundef) (args: list val) (k: cont) (m: mem) : state - | Returnstate + | Returnstate (**r returning from a function *) (res: val) (k: cont) (m: mem) : state. (** Find the statement and manufacture the continuation - corresponding to a label *) + corresponding to a label. *) Fixpoint find_label (lbl: label) (s: statement) (k: cont) {struct s}: option (statement * cont) := @@ -711,20 +933,20 @@ Fixpoint find_label (lbl: label) (s: statement) (k: cont) | None => find_label lbl s2 k end | Swhile a s1 => - find_label lbl s1 (Kwhile a s1 k) + find_label lbl s1 (Kwhile2 a s1 k) | Sdowhile a s1 => - find_label lbl s1 (Kdowhile a s1 k) + find_label lbl s1 (Kdowhile1 a s1 k) | Sfor a1 a2 a3 s1 => match find_label lbl a1 (Kseq (Sfor Sskip a2 a3 s1) k) with | Some sk => Some sk | None => - match find_label lbl s1 (Kfor2 a2 a3 s1 k) with + match find_label lbl s1 (Kfor3 a2 a3 s1 k) with | Some sk => Some sk - | None => find_label lbl a3 (Kfor3 a2 a3 s1 k) + | None => find_label lbl a3 (Kfor4 a2 a3 s1 k) end end | Sswitch e sl => - find_label_ls lbl sl (Kswitch k) + find_label_ls lbl sl (Kswitch2 k) | Slabel lbl' s' => if ident_eq lbl lbl' then Some(s', k) else find_label lbl s' k | _ => None @@ -741,481 +963,196 @@ with find_label_ls (lbl: label) (sl: labeled_statements) (k: cont) end end. -(** Transition relation *) - -Inductive step: state -> trace -> state -> Prop := - - | step_assign: forall f a1 a2 k e m loc ofs v2 m', - eval_lvalue e m a1 loc ofs -> - eval_expr e m a2 v2 -> - store_value_of_type (typeof a1) m loc ofs v2 = Some m' -> - step (State f (Sassign a1 a2) k e m) - E0 (State f Sskip k e m') - - | step_call_none: forall f a al k e m vf vargs fd, - eval_expr e m a vf -> - eval_exprlist e m al vargs -> - Genv.find_funct ge vf = Some fd -> - type_of_fundef fd = typeof a -> - step (State f (Scall None a al) k e m) - E0 (Callstate fd vargs (Kcall None f e k) m) - - | step_call_some: forall f lhs a al k e m loc ofs vf vargs fd, - eval_lvalue e m lhs loc ofs -> - eval_expr e m a vf -> - eval_exprlist e m al vargs -> - Genv.find_funct ge vf = Some fd -> - type_of_fundef fd = typeof a -> - step (State f (Scall (Some lhs) a al) k e m) - E0 (Callstate fd vargs (Kcall (Some(loc, ofs, typeof lhs)) f e k) m) +(** We separate the transition rules in two groups: +- one group that deals with reductions over expressions; +- the other group that deals with everything else: statements, function calls, etc. + +This makes it easy to express different reduction strategies for expressions: +the second group of rules can be reused as is. *) + +Inductive estep: state -> trace -> state -> Prop := + + | step_lred: forall C f a k e m a' m', + lred e a m a' m' -> + not_stuck e (C a) m -> + context LV RV C -> + estep (ExprState f (C a) k e m) + E0 (ExprState f (C a') k e m') + + | step_rred: forall C f a k e m a' m', + rred a m a' m' -> + not_stuck e (C a) m -> + context RV RV C -> + estep (ExprState f (C a) k e m) + E0 (ExprState f (C a') k e m') + + | step_call: forall C f a k e m fd vargs ty, + callred a fd vargs ty -> + not_stuck e (C a) m -> + context RV RV C -> + estep (ExprState f (C a) k e m) + E0 (Callstate fd vargs (Kcall f e C ty k) m). + +Inductive sstep: state -> trace -> state -> Prop := + + | step_do_1: forall f x k e m, + sstep (State f (Sdo x) k e m) + E0 (ExprState f x (Kdo k) e m) + | step_do_2: forall f v ty k e m, + sstep (ExprState f (Eval v ty) (Kdo k) e m) + E0 (State f Sskip k e m) | step_seq: forall f s1 s2 k e m, - step (State f (Ssequence s1 s2) k e m) + sstep (State f (Ssequence s1 s2) k e m) E0 (State f s1 (Kseq s2 k) e m) | step_skip_seq: forall f s k e m, - step (State f Sskip (Kseq s k) e m) + sstep (State f Sskip (Kseq s k) e m) E0 (State f s k e m) | step_continue_seq: forall f s k e m, - step (State f Scontinue (Kseq s k) e m) + sstep (State f Scontinue (Kseq s k) e m) E0 (State f Scontinue k e m) | step_break_seq: forall f s k e m, - step (State f Sbreak (Kseq s k) e m) + sstep (State f Sbreak (Kseq s k) e m) E0 (State f Sbreak k e m) - | step_ifthenelse_true: forall f a s1 s2 k e m v1, - eval_expr e m a v1 -> - is_true v1 (typeof a) -> - step (State f (Sifthenelse a s1 s2) k e m) + | step_ifthenelse: forall f a s1 s2 k e m, + sstep (State f (Sifthenelse a s1 s2) k e m) + E0 (ExprState f a (Kifthenelse s1 s2 k) e m) + | step_ifthenelse_true: forall f v ty s1 s2 k e m, + is_true v ty -> + sstep (ExprState f (Eval v ty) (Kifthenelse s1 s2 k) e m) E0 (State f s1 k e m) - | step_ifthenelse_false: forall f a s1 s2 k e m v1, - eval_expr e m a v1 -> - is_false v1 (typeof a) -> - step (State f (Sifthenelse a s1 s2) k e m) + | step_ifthenelse_false: forall f v ty s1 s2 k e m, + is_false v ty -> + sstep (ExprState f (Eval v ty) (Kifthenelse s1 s2 k) e m) E0 (State f s2 k e m) - | step_while_false: forall f a s k e m v, - eval_expr e m a v -> - is_false v (typeof a) -> - step (State f (Swhile a s) k e m) + | step_while: forall f x s k e m, + sstep (State f (Swhile x s) k e m) + E0 (ExprState f x (Kwhile1 x s k) e m) + | step_while_false: forall f v ty x s k e m, + is_false v ty -> + sstep (ExprState f (Eval v ty) (Kwhile1 x s k) e m) E0 (State f Sskip k e m) - | step_while_true: forall f a s k e m v, - eval_expr e m a v -> - is_true v (typeof a) -> - step (State f (Swhile a s) k e m) - E0 (State f s (Kwhile a s k) e m) - | step_skip_or_continue_while: forall f x a s k e m, - x = Sskip \/ x = Scontinue -> - step (State f x (Kwhile a s k) e m) - E0 (State f (Swhile a s) k e m) - | step_break_while: forall f a s k e m, - step (State f Sbreak (Kwhile a s k) e m) + | step_while_true: forall f v ty x s k e m , + is_true v ty -> + sstep (ExprState f (Eval v ty) (Kwhile1 x s k) e m) + E0 (State f s (Kwhile2 x s k) e m) + | step_skip_or_continue_while: forall f s0 x s k e m, + s0 = Sskip \/ s0 = Scontinue -> + sstep (State f s0 (Kwhile2 x s k) e m) + E0 (State f (Swhile x s) k e m) + | step_break_while: forall f x s k e m, + sstep (State f Sbreak (Kwhile2 x s k) e m) E0 (State f Sskip k e m) | step_dowhile: forall f a s k e m, - step (State f (Sdowhile a s) k e m) - E0 (State f s (Kdowhile a s k) e m) - | step_skip_or_continue_dowhile_false: forall f x a s k e m v, - x = Sskip \/ x = Scontinue -> - eval_expr e m a v -> - is_false v (typeof a) -> - step (State f x (Kdowhile a s k) e m) + sstep (State f (Sdowhile a s) k e m) + E0 (State f s (Kdowhile1 a s k) e m) + | step_skip_or_continue_dowhile: forall f s0 x s k e m, + s0 = Sskip \/ s0 = Scontinue -> + sstep (State f s0 (Kdowhile1 x s k) e m) + E0 (ExprState f x (Kdowhile2 x s k) e m) + | step_dowhile_false: forall f v ty x s k e m, + is_false v ty -> + sstep (ExprState f (Eval v ty) (Kdowhile2 x s k) e m) E0 (State f Sskip k e m) - | step_skip_or_continue_dowhile_true: forall f x a s k e m v, - x = Sskip \/ x = Scontinue -> - eval_expr e m a v -> - is_true v (typeof a) -> - step (State f x (Kdowhile a s k) e m) - E0 (State f (Sdowhile a s) k e m) + | step_dowhile_true: forall f v ty x s k e m, + is_true v ty -> + sstep (ExprState f (Eval v ty) (Kdowhile2 x s k) e m) + E0 (State f (Sdowhile x s) k e m) | step_break_dowhile: forall f a s k e m, - step (State f Sbreak (Kdowhile a s k) e m) + sstep (State f Sbreak (Kdowhile1 a s k) e m) E0 (State f Sskip k e m) | step_for_start: forall f a1 a2 a3 s k e m, a1 <> Sskip -> - step (State f (Sfor a1 a2 a3 s) k e m) + sstep (State f (Sfor a1 a2 a3 s) k e m) E0 (State f a1 (Kseq (Sfor Sskip a2 a3 s) k) e m) - | step_for_false: forall f a2 a3 s k e m v, - eval_expr e m a2 v -> - is_false v (typeof a2) -> - step (State f (Sfor Sskip a2 a3 s) k e m) + | step_for: forall f a2 a3 s k e m, + sstep (State f (Sfor Sskip a2 a3 s) k e m) + E0 (ExprState f a2 (Kfor2 a2 a3 s k) e m) + | step_for_false: forall f v ty a2 a3 s k e m, + is_false v ty -> + sstep (ExprState f (Eval v ty) (Kfor2 a2 a3 s k) e m) E0 (State f Sskip k e m) - | step_for_true: forall f a2 a3 s k e m v, - eval_expr e m a2 v -> - is_true v (typeof a2) -> - step (State f (Sfor Sskip a2 a3 s) k e m) - E0 (State f s (Kfor2 a2 a3 s k) e m) - | step_skip_or_continue_for2: forall f x a2 a3 s k e m, + | step_for_true: forall f v ty a2 a3 s k e m, + is_true v ty -> + sstep (ExprState f (Eval v ty) (Kfor2 a2 a3 s k) e m) + E0 (State f s (Kfor3 a2 a3 s k) e m) + | step_skip_or_continue_for3: forall f x a2 a3 s k e m, x = Sskip \/ x = Scontinue -> - step (State f x (Kfor2 a2 a3 s k) e m) - E0 (State f a3 (Kfor3 a2 a3 s k) e m) - | step_break_for2: forall f a2 a3 s k e m, - step (State f Sbreak (Kfor2 a2 a3 s k) e m) + sstep (State f x (Kfor3 a2 a3 s k) e m) + E0 (State f a3 (Kfor4 a2 a3 s k) e m) + | step_break_for3: forall f a2 a3 s k e m, + sstep (State f Sbreak (Kfor3 a2 a3 s k) e m) E0 (State f Sskip k e m) - | step_skip_for3: forall f a2 a3 s k e m, - step (State f Sskip (Kfor3 a2 a3 s k) e m) + | step_skip_for4: forall f a2 a3 s k e m, + sstep (State f Sskip (Kfor4 a2 a3 s k) e m) E0 (State f (Sfor Sskip a2 a3 s) k e m) | step_return_0: forall f k e m m', f.(fn_return) = Tvoid -> Mem.free_list m (blocks_of_env e) = Some m' -> - step (State f (Sreturn None) k e m) + sstep (State f (Sreturn None) k e m) E0 (Returnstate Vundef (call_cont k) m') - | step_return_1: forall f a k e m v m', + | step_return_1: forall f x k e m, f.(fn_return) <> Tvoid -> - eval_expr e m a v -> + sstep (State f (Sreturn (Some x)) k e m) + E0 (ExprState f x (Kreturn k) e m) + | step_return_2: forall f v1 ty k e m v2 m', + cast v1 ty f.(fn_return) v2 -> Mem.free_list m (blocks_of_env e) = Some m' -> - step (State f (Sreturn (Some a)) k e m) - E0 (Returnstate v (call_cont k) m') + sstep (ExprState f (Eval v1 ty) (Kreturn k) e m) + E0 (Returnstate v2 (call_cont k) m') | step_skip_call: forall f k e m m', is_call_cont k -> f.(fn_return) = Tvoid -> Mem.free_list m (blocks_of_env e) = Some m' -> - step (State f Sskip k e m) + sstep (State f Sskip k e m) E0 (Returnstate Vundef k m') - | step_switch: forall f a sl k e m n, - eval_expr e m a (Vint n) -> - step (State f (Sswitch a sl) k e m) - E0 (State f (seq_of_labeled_statement (select_switch n sl)) (Kswitch k) e m) + | step_switch: forall f x sl k e m, + sstep (State f (Sswitch x sl) k e m) + E0 (ExprState f x (Kswitch1 sl k) e m) + | step_expr_switch: forall f n ty sl k e m, + sstep (ExprState f (Eval (Vint n) ty) (Kswitch1 sl k) e m) + E0 (State f (seq_of_labeled_statement (select_switch n sl)) (Kswitch2 k) e m) | step_skip_break_switch: forall f x k e m, x = Sskip \/ x = Sbreak -> - step (State f x (Kswitch k) e m) + sstep (State f x (Kswitch2 k) e m) E0 (State f Sskip k e m) | step_continue_switch: forall f k e m, - step (State f Scontinue (Kswitch k) e m) + sstep (State f Scontinue (Kswitch2 k) e m) E0 (State f Scontinue k e m) | step_label: forall f lbl s k e m, - step (State f (Slabel lbl s) k e m) + sstep (State f (Slabel lbl s) k e m) E0 (State f s k e m) | step_goto: forall f lbl k e m s' k', find_label lbl f.(fn_body) (call_cont k) = Some (s', k') -> - step (State f (Sgoto lbl) k e m) + sstep (State f (Sgoto lbl) k e m) E0 (State f s' k' e m) | step_internal_function: forall f vargs k m e m1 m2, + list_norepet (var_names (fn_params f) ++ var_names (fn_vars f)) -> alloc_variables empty_env m (f.(fn_params) ++ f.(fn_vars)) e m1 -> bind_parameters e m1 f.(fn_params) vargs m2 -> - step (Callstate (Internal f) vargs k m) + sstep (Callstate (Internal f) vargs k m) E0 (State f f.(fn_body) k e m2) | step_external_function: forall ef targs tres vargs k m vres t m', external_call ef ge vargs m t vres m' -> - step (Callstate (External ef targs tres) vargs k m) + sstep (Callstate (External ef targs tres) vargs k m) t (Returnstate vres k m') - | step_returnstate_0: forall v f e k m, - step (Returnstate v (Kcall None f e k) m) - E0 (State f Sskip k e m) - - | step_returnstate_1: forall v f e k m m' loc ofs ty, - store_value_of_type ty m loc ofs v = Some m' -> - step (Returnstate v (Kcall (Some(loc, ofs, ty)) f e k) m) - E0 (State f Sskip k e m'). - -(** * Alternate big-step semantics *) - -(** ** Big-step semantics for terminating statements and functions *) + | step_returnstate: forall v f e C ty k m, + sstep (Returnstate v (Kcall f e C ty k) m) + E0 (ExprState f (C (Eval v ty)) k e m). -(** The execution of a statement produces an ``outcome'', indicating - how the execution terminated: either normally or prematurely - through the execution of a [break], [continue] or [return] statement. *) - -Inductive outcome: Type := - | Out_break: outcome (**r terminated by [break] *) - | Out_continue: outcome (**r terminated by [continue] *) - | Out_normal: outcome (**r terminated normally *) - | Out_return: option val -> outcome. (**r terminated by [return] *) - -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. - -(** [exec_stmt ge e m1 s t m2 out] describes the execution of - the statement [s]. [out] is the outcome for this execution. - [m1] is the initial memory state, [m2] the final memory state. - [t] is the trace of input/output events performed during this - evaluation. *) - -Inductive exec_stmt: env -> mem -> statement -> trace -> mem -> outcome -> Prop := - | exec_Sskip: forall e m, - exec_stmt e m Sskip - E0 m Out_normal - | exec_Sassign: forall e m a1 a2 loc ofs v2 m', - eval_lvalue e m a1 loc ofs -> - eval_expr e m a2 v2 -> - store_value_of_type (typeof a1) m loc ofs v2 = Some m' -> - exec_stmt e m (Sassign a1 a2) - E0 m' Out_normal - | exec_Scall_none: forall e m a al vf vargs f t m' vres, - eval_expr e m a vf -> - eval_exprlist e m al vargs -> - Genv.find_funct ge vf = Some f -> - type_of_fundef f = typeof a -> - eval_funcall m f vargs t m' vres -> - exec_stmt e m (Scall None a al) - t m' Out_normal - | exec_Scall_some: forall e m lhs a al loc ofs vf vargs f t m' vres m'', - eval_lvalue e m lhs loc ofs -> - eval_expr e m a vf -> - eval_exprlist e m al vargs -> - Genv.find_funct ge vf = Some f -> - type_of_fundef f = typeof a -> - eval_funcall m f vargs t m' vres -> - store_value_of_type (typeof lhs) m' loc ofs vres = Some m'' -> - exec_stmt e m (Scall (Some lhs) a al) - t m'' 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 v1 t m' out, - eval_expr e m a v1 -> - is_true v1 (typeof a) -> - exec_stmt e m s1 t m' out -> - exec_stmt e m (Sifthenelse a s1 s2) - t m' out - | exec_Sifthenelse_false: forall e m a s1 s2 v1 t m' out, - eval_expr e m a v1 -> - is_false v1 (typeof a) -> - exec_stmt e m s2 t m' out -> - exec_stmt e m (Sifthenelse a s1 s2) - t m' 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 v, - eval_expr e m a v -> - exec_stmt e m (Sreturn (Some a)) - E0 m (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 a s v, - eval_expr e m a v -> - is_false v (typeof a) -> - exec_stmt e m (Swhile a s) - E0 m Out_normal - | exec_Swhile_stop: forall e m a v s t m' out' out, - eval_expr e m a v -> - is_true v (typeof a) -> - exec_stmt e m s t m' out' -> - out_break_or_return out' out -> - exec_stmt e m (Swhile a s) - t m' out - | exec_Swhile_loop: forall e m a s v t1 m1 out1 t2 m2 out, - eval_expr e m a v -> - is_true v (typeof a) -> - exec_stmt e m s t1 m1 out1 -> - out_normal_or_continue out1 -> - exec_stmt e m1 (Swhile a s) t2 m2 out -> - exec_stmt e m (Swhile a s) - (t1 ** t2) m2 out - | exec_Sdowhile_false: forall e m s a t m1 out1 v, - exec_stmt e m s t m1 out1 -> - out_normal_or_continue out1 -> - eval_expr e m1 a v -> - is_false v (typeof a) -> - exec_stmt e m (Sdowhile a s) - t m1 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 t1 t2 out out1 v, - exec_stmt e m s t1 m1 out1 -> - out_normal_or_continue out1 -> - eval_expr e m1 a v -> - is_true v (typeof a) -> - exec_stmt e m1 (Sdowhile a s) t2 m2 out -> - exec_stmt e m (Sdowhile a s) - (t1 ** t2) m2 out - | exec_Sfor_start: forall e m s a1 a2 a3 out m1 m2 t1 t2, - a1 <> Sskip -> - 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 v, - eval_expr e m a2 v -> - is_false v (typeof a2) -> - exec_stmt e m (Sfor Sskip a2 a3 s) - E0 m Out_normal - | exec_Sfor_stop: forall e m s a2 a3 v m1 t out1 out, - eval_expr e m a2 v -> - is_true v (typeof a2) -> - exec_stmt e m s t m1 out1 -> - out_break_or_return out1 out -> - exec_stmt e m (Sfor Sskip a2 a3 s) - t m1 out - | exec_Sfor_loop: forall e m s a2 a3 v m1 m2 m3 t1 t2 t3 out1 out, - eval_expr e m a2 v -> - is_true v (typeof a2) -> - exec_stmt e m s t1 m1 out1 -> - out_normal_or_continue out1 -> - exec_stmt e m1 a3 t2 m2 Out_normal -> - exec_stmt e m2 (Sfor Sskip a2 a3 s) t3 m3 out -> - exec_stmt e m (Sfor Sskip a2 a3 s) - (t1 ** t2 ** t3) m3 out - | exec_Sswitch: forall e m a t n sl m1 out, - eval_expr e m a (Vint n) -> - exec_stmt e m (seq_of_labeled_statement (select_switch n sl)) t m1 out -> - exec_stmt e m (Sswitch a sl) - t m1 (outcome_switch out) - -(** [eval_funcall m1 fd args t m2 res] describes the invocation of - function [fd] with arguments [args]. [res] is the value returned - by the call. *) - -with eval_funcall: mem -> fundef -> list val -> trace -> mem -> val -> Prop := - | eval_funcall_internal: forall m f vargs t e m1 m2 m3 out vres m4, - alloc_variables empty_env m (f.(fn_params) ++ f.(fn_vars)) e m1 -> - 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 -> - Mem.free_list m3 (blocks_of_env e) = Some m4 -> - eval_funcall m (Internal f) vargs t m4 vres - | eval_funcall_external: forall m ef targs tres vargs t vres m', - external_call ef ge vargs m t vres m' -> - eval_funcall m (External ef targs tres) vargs t m' vres. - -Scheme exec_stmt_ind2 := Minimality for exec_stmt Sort Prop - with eval_funcall_ind2 := Minimality for eval_funcall Sort Prop. - -(** ** Big-step semantics for diverging statements and functions *) - -(** Coinductive semantics for divergence. - [execinf_stmt ge e m s t] holds if the execution of statement [s] - diverges, i.e. loops infinitely. [t] is the possibly infinite - trace of observable events performed during the execution. *) - -CoInductive execinf_stmt: env -> mem -> statement -> traceinf -> Prop := - | execinf_Scall_none: forall e m a al vf vargs f t, - eval_expr e m a vf -> - eval_exprlist e m al vargs -> - Genv.find_funct ge vf = Some f -> - type_of_fundef f = typeof a -> - evalinf_funcall m f vargs t -> - execinf_stmt e m (Scall None a al) t - | execinf_Scall_some: forall e m lhs a al loc ofs vf vargs f t, - eval_lvalue e m lhs loc ofs -> - eval_expr e m a vf -> - eval_exprlist e m al vargs -> - Genv.find_funct ge vf = Some f -> - type_of_fundef f = typeof a -> - evalinf_funcall m f vargs t -> - execinf_stmt e m (Scall (Some lhs) a al) t - | execinf_Sseq_1: forall e m s1 s2 t, - execinf_stmt e m s1 t -> - execinf_stmt e m (Ssequence s1 s2) t - | execinf_Sseq_2: forall e m s1 s2 t1 m1 t2, - exec_stmt e m s1 t1 m1 Out_normal -> - execinf_stmt e m1 s2 t2 -> - execinf_stmt e m (Ssequence s1 s2) (t1 *** t2) - | execinf_Sifthenelse_true: forall e m a s1 s2 v1 t, - eval_expr e m a v1 -> - is_true v1 (typeof a) -> - execinf_stmt e m s1 t -> - execinf_stmt e m (Sifthenelse a s1 s2) t - | execinf_Sifthenelse_false: forall e m a s1 s2 v1 t, - eval_expr e m a v1 -> - is_false v1 (typeof a) -> - execinf_stmt e m s2 t -> - execinf_stmt e m (Sifthenelse a s1 s2) t - | execinf_Swhile_body: forall e m a v s t, - eval_expr e m a v -> - is_true v (typeof a) -> - execinf_stmt e m s t -> - execinf_stmt e m (Swhile a s) t - | execinf_Swhile_loop: forall e m a s v t1 m1 out1 t2, - eval_expr e m a v -> - is_true v (typeof a) -> - exec_stmt e m s t1 m1 out1 -> - out_normal_or_continue out1 -> - execinf_stmt e m1 (Swhile a s) t2 -> - execinf_stmt e m (Swhile a s) (t1 *** t2) - | execinf_Sdowhile_body: forall e m s a t, - execinf_stmt e m s t -> - execinf_stmt e m (Sdowhile a s) t - | execinf_Sdowhile_loop: forall e m s a m1 t1 t2 out1 v, - exec_stmt e m s t1 m1 out1 -> - out_normal_or_continue out1 -> - eval_expr e m1 a v -> - is_true v (typeof a) -> - execinf_stmt e m1 (Sdowhile a s) t2 -> - execinf_stmt e m (Sdowhile a s) (t1 *** t2) - | execinf_Sfor_start_1: forall e m s a1 a2 a3 t, - execinf_stmt e m a1 t -> - execinf_stmt e m (Sfor a1 a2 a3 s) t - | execinf_Sfor_start_2: forall e m s a1 a2 a3 m1 t1 t2, - a1 <> Sskip -> - exec_stmt e m a1 t1 m1 Out_normal -> - execinf_stmt e m1 (Sfor Sskip a2 a3 s) t2 -> - execinf_stmt e m (Sfor a1 a2 a3 s) (t1 *** t2) - | execinf_Sfor_body: forall e m s a2 a3 v t, - eval_expr e m a2 v -> - is_true v (typeof a2) -> - execinf_stmt e m s t -> - execinf_stmt e m (Sfor Sskip a2 a3 s) t - | execinf_Sfor_next: forall e m s a2 a3 v m1 t1 t2 out1, - eval_expr e m a2 v -> - is_true v (typeof a2) -> - exec_stmt e m s t1 m1 out1 -> - out_normal_or_continue out1 -> - execinf_stmt e m1 a3 t2 -> - execinf_stmt e m (Sfor Sskip a2 a3 s) (t1 *** t2) - | execinf_Sfor_loop: forall e m s a2 a3 v m1 m2 t1 t2 t3 out1, - eval_expr e m a2 v -> - is_true v (typeof a2) -> - exec_stmt e m s t1 m1 out1 -> - out_normal_or_continue out1 -> - exec_stmt e m1 a3 t2 m2 Out_normal -> - execinf_stmt e m2 (Sfor Sskip a2 a3 s) t3 -> - execinf_stmt e m (Sfor Sskip a2 a3 s) (t1 *** t2 *** t3) - | execinf_Sswitch: forall e m a t n sl, - eval_expr e m a (Vint n) -> - execinf_stmt e m (seq_of_labeled_statement (select_switch n sl)) t -> - execinf_stmt e m (Sswitch a sl) t - -(** [evalinf_funcall ge m fd args t] holds if the invocation of function - [fd] on arguments [args] diverges, with observable trace [t]. *) - -with evalinf_funcall: mem -> fundef -> list val -> traceinf -> Prop := - | evalinf_funcall_internal: forall m f vargs t e m1 m2, - alloc_variables empty_env m (f.(fn_params) ++ f.(fn_vars)) e m1 -> - bind_parameters e m1 f.(fn_params) vargs m2 -> - execinf_stmt e m2 f.(fn_body) t -> - evalinf_funcall m (Internal f) vargs t. +Definition step (S: state) (t: trace) (S': state) : Prop := + estep S t S' \/ sstep S t S'. End SEMANTICS. @@ -1232,6 +1169,7 @@ Inductive initial_state (p: program): state -> Prop := Genv.init_mem p = Some m0 -> 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) -> initial_state p (Callstate f nil Kstop m0). (** A final state is a [Returnstate] with an empty continuation. *) @@ -1248,500 +1186,3 @@ Inductive final_state: state -> int -> Prop := Definition exec_program (p: program) (beh: program_behavior) : Prop := program_behaves step (initial_state p) final_state (Genv.globalenv p) beh. -(** Big-step execution of a whole program. *) - -Inductive bigstep_program_terminates (p: program): trace -> int -> Prop := - | bigstep_program_terminates_intro: forall b f m0 m1 t r, - let ge := Genv.globalenv p in - Genv.init_mem p = Some m0 -> - Genv.find_symbol ge p.(prog_main) = Some b -> - Genv.find_funct_ptr ge b = Some f -> - eval_funcall ge m0 f nil t m1 (Vint r) -> - bigstep_program_terminates p t r. - -Inductive bigstep_program_diverges (p: program): traceinf -> Prop := - | bigstep_program_diverges_intro: forall b f m0 t, - let ge := Genv.globalenv p in - Genv.init_mem p = Some m0 -> - Genv.find_symbol ge p.(prog_main) = Some b -> - Genv.find_funct_ptr ge b = Some f -> - evalinf_funcall ge m0 f nil t -> - bigstep_program_diverges p t. - -(** * Implication from big-step semantics to transition semantics *) - -Section BIGSTEP_TO_TRANSITIONS. - -Variable prog: program. -Let ge : genv := Genv.globalenv prog. - -Definition exec_stmt_eval_funcall_ind - (PS: env -> mem -> statement -> trace -> mem -> outcome -> Prop) - (PF: mem -> fundef -> list val -> trace -> mem -> val -> Prop) := - fun a b c d e f g h i j k l m n o p q r s t u v w x y => - conj (exec_stmt_ind2 ge PS PF a b c d e f g h i j k l m n o p q r s t u v w x y) - (eval_funcall_ind2 ge PS PF a b c d e f g h i j k l m n o p q r s t u v w x y). - -Inductive outcome_state_match - (e: env) (m: mem) (f: function) (k: cont): outcome -> state -> Prop := - | osm_normal: - outcome_state_match e m f k Out_normal (State f Sskip k e m) - | osm_break: - outcome_state_match e m f k Out_break (State f Sbreak k e m) - | osm_continue: - outcome_state_match e m f k Out_continue (State f Scontinue k e m) - | osm_return_none: forall k', - call_cont k' = call_cont k -> - outcome_state_match e m f k - (Out_return None) (State f (Sreturn None) k' e m) - | osm_return_some: forall a v k', - call_cont k' = call_cont k -> - eval_expr ge e m a v -> - outcome_state_match e m f k - (Out_return (Some v)) (State f (Sreturn (Some a)) k' e m). - -Lemma is_call_cont_call_cont: - forall k, is_call_cont k -> call_cont k = k. -Proof. - destruct k; simpl; intros; contradiction || auto. -Qed. - -Lemma exec_stmt_eval_funcall_steps: - (forall e m s t m' out, - exec_stmt ge e m s t m' out -> - forall f k, exists S, - star step ge (State f s k e m) t S - /\ outcome_state_match e m' f k out S) -/\ - (forall m fd args t m' res, - eval_funcall ge m fd args t m' res -> - forall k, - is_call_cont k -> - star step ge (Callstate fd args k m) t (Returnstate res k m')). -Proof. - apply exec_stmt_eval_funcall_ind; intros. - -(* skip *) - econstructor; split. apply star_refl. constructor. - -(* assign *) - econstructor; split. apply star_one. econstructor; eauto. constructor. - -(* call none *) - econstructor; split. - eapply star_left. econstructor; eauto. - eapply star_right. apply H4. simpl; auto. econstructor. reflexivity. traceEq. - constructor. - -(* call some *) - econstructor; split. - eapply star_left. econstructor; eauto. - eapply star_right. apply H5. simpl; auto. econstructor; eauto. reflexivity. traceEq. - constructor. - -(* sequence 2 *) - destruct (H0 f (Kseq s2 k)) as [S1 [A1 B1]]. inv B1. - destruct (H2 f k) as [S2 [A2 B2]]. - econstructor; split. - eapply star_left. econstructor. - eapply star_trans. eexact A1. - eapply star_left. constructor. eexact A2. - reflexivity. reflexivity. traceEq. - auto. - -(* sequence 1 *) - destruct (H0 f (Kseq s2 k)) as [S1 [A1 B1]]. - set (S2 := - match out with - | Out_break => State f Sbreak k e m1 - | Out_continue => State f Scontinue k e m1 - | _ => S1 - end). - exists S2; split. - eapply star_left. econstructor. - eapply star_trans. eexact A1. - unfold S2; inv B1. - congruence. - apply star_one. apply step_break_seq. - apply star_one. apply step_continue_seq. - apply star_refl. - apply star_refl. - reflexivity. traceEq. - unfold S2; inv B1; congruence || econstructor; eauto. - -(* ifthenelse true *) - destruct (H2 f k) as [S1 [A1 B1]]. - exists S1; split. - eapply star_left. eapply step_ifthenelse_true; eauto. eexact A1. traceEq. - auto. - -(* ifthenelse false *) - destruct (H2 f k) as [S1 [A1 B1]]. - exists S1; split. - eapply star_left. eapply step_ifthenelse_false; eauto. eexact A1. traceEq. - auto. - -(* return none *) - econstructor; split. apply star_refl. constructor. auto. - -(* return some *) - econstructor; split. apply star_refl. econstructor; eauto. - -(* break *) - econstructor; split. apply star_refl. constructor. - -(* continue *) - econstructor; split. apply star_refl. constructor. - -(* while false *) - econstructor; split. - apply star_one. eapply step_while_false; eauto. - constructor. - -(* while stop *) - destruct (H2 f (Kwhile a s k)) as [S1 [A1 B1]]. - set (S2 := - match out' with - | Out_break => State f Sskip k e m' - | _ => S1 - end). - exists S2; split. - eapply star_left. eapply step_while_true; eauto. - eapply star_trans. eexact A1. - unfold S2. inversion H3; subst. - inv B1. apply star_one. constructor. - apply star_refl. - reflexivity. traceEq. - unfold S2. inversion H3; subst. constructor. inv B1; econstructor; eauto. - -(* while loop *) - destruct (H2 f (Kwhile a s k)) as [S1 [A1 B1]]. - destruct (H5 f k) as [S2 [A2 B2]]. - exists S2; split. - eapply star_left. eapply step_while_true; eauto. - eapply star_trans. eexact A1. - eapply star_left. - inv H3; inv B1; apply step_skip_or_continue_while; auto. - eexact A2. - reflexivity. reflexivity. traceEq. - auto. - -(* dowhile false *) - destruct (H0 f (Kdowhile a s k)) as [S1 [A1 B1]]. - exists (State f Sskip k e m1); split. - eapply star_left. constructor. - eapply star_right. eexact A1. - inv H1; inv B1; eapply step_skip_or_continue_dowhile_false; eauto. - reflexivity. traceEq. - constructor. - -(* dowhile stop *) - destruct (H0 f (Kdowhile a s k)) as [S1 [A1 B1]]. - set (S2 := - match out1 with - | Out_break => State f Sskip k e m1 - | _ => S1 - end). - exists S2; split. - eapply star_left. apply step_dowhile. - eapply star_trans. eexact A1. - unfold S2. inversion H1; subst. - inv B1. apply star_one. constructor. - apply star_refl. - reflexivity. traceEq. - unfold S2. inversion H1; subst. constructor. inv B1; econstructor; eauto. - -(* dowhile loop *) - destruct (H0 f (Kdowhile a s k)) as [S1 [A1 B1]]. - destruct (H5 f k) as [S2 [A2 B2]]. - exists S2; split. - eapply star_left. apply step_dowhile. - eapply star_trans. eexact A1. - eapply star_left. - inv H1; inv B1; eapply step_skip_or_continue_dowhile_true; eauto. - eexact A2. - reflexivity. reflexivity. traceEq. - auto. - -(* for start *) - destruct (H1 f (Kseq (Sfor Sskip a2 a3 s) k)) as [S1 [A1 B1]]. inv B1. - destruct (H3 f k) as [S2 [A2 B2]]. - exists S2; split. - eapply star_left. apply step_for_start; auto. - eapply star_trans. eexact A1. - eapply star_left. constructor. eexact A2. - reflexivity. reflexivity. traceEq. - auto. - -(* for false *) - econstructor; split. - eapply star_one. eapply step_for_false; eauto. - constructor. - -(* for stop *) - destruct (H2 f (Kfor2 a2 a3 s k)) as [S1 [A1 B1]]. - set (S2 := - match out1 with - | Out_break => State f Sskip k e m1 - | _ => S1 - end). - exists S2; split. - eapply star_left. eapply step_for_true; eauto. - eapply star_trans. eexact A1. - unfold S2. inversion H3; subst. - inv B1. apply star_one. constructor. - apply star_refl. - reflexivity. traceEq. - unfold S2. inversion H3; subst. constructor. inv B1; econstructor; eauto. - -(* for loop *) - destruct (H2 f (Kfor2 a2 a3 s k)) as [S1 [A1 B1]]. - destruct (H5 f (Kfor3 a2 a3 s k)) as [S2 [A2 B2]]. inv B2. - destruct (H7 f k) as [S3 [A3 B3]]. - exists S3; split. - eapply star_left. eapply step_for_true; eauto. - eapply star_trans. eexact A1. - eapply star_trans with (s2 := State f a3 (Kfor3 a2 a3 s k) e m1). - inv H3; inv B1. - apply star_one. constructor. auto. - apply star_one. constructor. auto. - eapply star_trans. eexact A2. - eapply star_left. constructor. - eexact A3. - reflexivity. reflexivity. reflexivity. reflexivity. traceEq. - auto. - -(* switch *) - destruct (H1 f (Kswitch k)) as [S1 [A1 B1]]. - set (S2 := - match out with - | Out_normal => State f Sskip k e m1 - | Out_break => State f Sskip k e m1 - | Out_continue => State f Scontinue k e m1 - | _ => S1 - end). - exists S2; split. - eapply star_left. eapply step_switch; eauto. - eapply star_trans. eexact A1. - unfold S2; inv B1. - apply star_one. constructor. auto. - apply star_one. constructor. auto. - apply star_one. constructor. - apply star_refl. - apply star_refl. - reflexivity. traceEq. - unfold S2. inv B1; simpl; econstructor; eauto. - -(* call internal *) - destruct (H2 f k) as [S1 [A1 B1]]. - eapply star_left. eapply step_internal_function; eauto. - eapply star_right. eexact A1. - inv B1; simpl in H3; try contradiction. - (* Out_normal *) - assert (fn_return f = Tvoid /\ vres = Vundef). - destruct (fn_return f); auto || contradiction. - destruct H6. subst vres. apply step_skip_call; auto. - (* Out_return None *) - assert (fn_return f = Tvoid /\ vres = Vundef). - destruct (fn_return f); auto || contradiction. - destruct H7. subst vres. - rewrite <- (is_call_cont_call_cont k H5). rewrite <- H6. - apply step_return_0; auto. - (* Out_return Some *) - destruct H3. subst vres. - rewrite <- (is_call_cont_call_cont k H5). rewrite <- H6. - eapply step_return_1; eauto. - reflexivity. traceEq. - -(* call external *) - apply star_one. apply step_external_function; auto. -Qed. - -Lemma exec_stmt_steps: - forall e m s t m' out, - exec_stmt ge e m s t m' out -> - forall f k, exists S, - star step ge (State f s k e m) t S - /\ outcome_state_match e m' f k out S. -Proof (proj1 exec_stmt_eval_funcall_steps). - -Lemma eval_funcall_steps: - forall m fd args t m' res, - eval_funcall ge m fd args t m' res -> - forall k, - is_call_cont k -> - star step ge (Callstate fd args k m) t (Returnstate res k m'). -Proof (proj2 exec_stmt_eval_funcall_steps). - -Definition order (x y: unit) := False. - -Lemma evalinf_funcall_forever: - forall m fd args T k, - evalinf_funcall ge m fd args T -> - forever_N step order ge tt (Callstate fd args k m) T. -Proof. - cofix CIH_FUN. - assert (forall e m s T f k, - execinf_stmt ge e m s T -> - forever_N step order ge tt (State f s k e m) T). - cofix CIH_STMT. - intros. inv H. - -(* call none *) - eapply forever_N_plus. - apply plus_one. eapply step_call_none; eauto. - apply CIH_FUN. eauto. traceEq. -(* call some *) - eapply forever_N_plus. - apply plus_one. eapply step_call_some; eauto. - apply CIH_FUN. eauto. traceEq. - -(* seq 1 *) - eapply forever_N_plus. - apply plus_one. econstructor. - apply CIH_STMT; eauto. traceEq. -(* seq 2 *) - destruct (exec_stmt_steps _ _ _ _ _ _ H0 f (Kseq s2 k)) as [S1 [A1 B1]]. - inv B1. - eapply forever_N_plus. - eapply plus_left. constructor. eapply star_trans. eexact A1. - apply star_one. constructor. reflexivity. reflexivity. - apply CIH_STMT; eauto. traceEq. - -(* ifthenelse true *) - eapply forever_N_plus. - apply plus_one. eapply step_ifthenelse_true; eauto. - apply CIH_STMT; eauto. traceEq. -(* ifthenelse false *) - eapply forever_N_plus. - apply plus_one. eapply step_ifthenelse_false; eauto. - apply CIH_STMT; eauto. traceEq. - -(* while body *) - eapply forever_N_plus. - eapply plus_one. eapply step_while_true; eauto. - apply CIH_STMT; eauto. traceEq. -(* while loop *) - destruct (exec_stmt_steps _ _ _ _ _ _ H2 f (Kwhile a s0 k)) as [S1 [A1 B1]]. - eapply forever_N_plus with (s2 := State f (Swhile a s0) k e m1). - eapply plus_left. eapply step_while_true; eauto. - eapply star_right. eexact A1. - inv H3; inv B1; apply step_skip_or_continue_while; auto. - reflexivity. reflexivity. - apply CIH_STMT; eauto. traceEq. - -(* dowhile body *) - eapply forever_N_plus. - eapply plus_one. eapply step_dowhile. - apply CIH_STMT; eauto. - traceEq. - -(* dowhile loop *) - destruct (exec_stmt_steps _ _ _ _ _ _ H0 f (Kdowhile a s0 k)) as [S1 [A1 B1]]. - eapply forever_N_plus with (s2 := State f (Sdowhile a s0) k e m1). - eapply plus_left. eapply step_dowhile. - eapply star_right. eexact A1. - inv H1; inv B1; eapply step_skip_or_continue_dowhile_true; eauto. - reflexivity. reflexivity. - apply CIH_STMT. eauto. - traceEq. - -(* for start 1 *) - assert (a1 <> Sskip). red; intros; subst. inv H0. - eapply forever_N_plus. - eapply plus_one. apply step_for_start; auto. - apply CIH_STMT; eauto. - traceEq. - -(* for start 2 *) - destruct (exec_stmt_steps _ _ _ _ _ _ H1 f (Kseq (Sfor Sskip a2 a3 s0) k)) as [S1 [A1 B1]]. - inv B1. - eapply forever_N_plus. - eapply plus_left. eapply step_for_start; eauto. - eapply star_right. eexact A1. - apply step_skip_seq. - reflexivity. reflexivity. - apply CIH_STMT; eauto. - traceEq. - -(* for body *) - eapply forever_N_plus. - apply plus_one. eapply step_for_true; eauto. - apply CIH_STMT; eauto. - traceEq. - -(* for next *) - destruct (exec_stmt_steps _ _ _ _ _ _ H2 f (Kfor2 a2 a3 s0 k)) as [S1 [A1 B1]]. - eapply forever_N_plus. - eapply plus_left. eapply step_for_true; eauto. - eapply star_trans. eexact A1. - apply star_one. - inv H3; inv B1; apply step_skip_or_continue_for2; auto. - reflexivity. reflexivity. - apply CIH_STMT; eauto. - traceEq. - -(* for body *) - destruct (exec_stmt_steps _ _ _ _ _ _ H2 f (Kfor2 a2 a3 s0 k)) as [S1 [A1 B1]]. - destruct (exec_stmt_steps _ _ _ _ _ _ H4 f (Kfor3 a2 a3 s0 k)) as [S2 [A2 B2]]. - inv B2. - eapply forever_N_plus. - eapply plus_left. eapply step_for_true; eauto. - eapply star_trans. eexact A1. - eapply star_left. inv H3; inv B1; apply step_skip_or_continue_for2; auto. - eapply star_right. eexact A2. - constructor. - reflexivity. reflexivity. reflexivity. reflexivity. - apply CIH_STMT; eauto. - traceEq. - -(* switch *) - eapply forever_N_plus. - eapply plus_one. eapply step_switch; eauto. - apply CIH_STMT; eauto. - traceEq. - -(* call internal *) - intros. inv H0. - eapply forever_N_plus. - eapply plus_one. econstructor; eauto. - apply H; eauto. - traceEq. -Qed. - -Theorem bigstep_program_terminates_exec: - forall t r, bigstep_program_terminates prog t r -> exec_program prog (Terminates t r). -Proof. - intros. inv H. - econstructor. - econstructor. eauto. eauto. eauto. - apply eval_funcall_steps. eauto. red; auto. - econstructor. -Qed. - -Theorem bigstep_program_diverges_exec: - forall T, bigstep_program_diverges prog T -> - exec_program prog (Reacts T) \/ - exists t, exec_program prog (Diverges t) /\ traceinf_prefix t T. -Proof. - intros. inv H. - set (st := Callstate f nil Kstop m0). - assert (forever step ge0 st T). - eapply forever_N_forever with (order := order). - red; intros. constructor; intros. red in H. elim H. - eapply evalinf_funcall_forever; eauto. - destruct (forever_silent_or_reactive _ _ _ _ _ _ H) - as [A | [t [s' [T' [B [C D]]]]]]. - left. econstructor. econstructor; eauto. eauto. - right. exists t. split. - econstructor. econstructor; eauto. eauto. auto. - subst T. rewrite <- (E0_right t) at 1. apply traceinf_prefix_app. constructor. -Qed. - -End BIGSTEP_TO_TRANSITIONS. - - - - - - diff --git a/cfrontend/Csharpminor.v b/cfrontend/Csharpminor.v index 558ae1c..1a362e3 100644 --- a/cfrontend/Csharpminor.v +++ b/cfrontend/Csharpminor.v @@ -46,6 +46,7 @@ Definition binary_operation : Type := Cminor.binary_operation. Inductive expr : Type := | Evar : ident -> expr (**r reading a scalar variable *) + | Etempvar : ident -> expr (**r reading a temporary variable *) | Eaddrof : ident -> expr (**r taking the address of a variable *) | Econst : constant -> expr (**r constants *) | Eunop : unary_operation -> expr -> expr (**r unary operation *) @@ -64,6 +65,7 @@ Definition label := ident. Inductive stmt : Type := | Sskip: stmt | Sassign : ident -> expr -> stmt + | Sset : ident -> expr -> stmt | Sstore : memory_chunk -> expr -> expr -> stmt | Scall : option ident -> signature -> expr -> list expr -> stmt | Sseq: stmt -> stmt -> stmt @@ -109,6 +111,7 @@ Record function : Type := mkfunction { fn_return: option typ; fn_params: list (ident * memory_chunk); fn_vars: list (ident * var_kind); + fn_temps: list ident; fn_body: stmt }. @@ -137,17 +140,21 @@ Definition fn_vars_names (f: function) := List.map variable_name f.(fn_vars). (** * Operational semantics *) -(** Three kinds of evaluation environments are involved: -- [genv]: global environments, define symbols and functions; -- [gvarenv]: map global variables to variable informations (type [var_kind]); +(** Three evaluation environments are involved: +- [genv]: global environments, map symbols and functions to memory blocks, + and maps symbols to variable informations (type [var_kind]) - [env]: local environments, map local variables - to memory blocks and variable informations. + to pairs (memory block, variable information) +- [temp_env]: local environments, map temporary variables to + their current values. *) Definition genv := Genv.t fundef var_kind. -Definition gvarenv := PTree.t var_kind. Definition env := PTree.t (block * var_kind). +Definition temp_env := PTree.t val. + Definition empty_env : env := PTree.empty (block * var_kind). +Definition empty_temp_env : temp_env := PTree.empty val. (** Continuations *) @@ -155,7 +162,7 @@ Inductive cont: Type := | Kstop: cont (**r stop program execution *) | Kseq: stmt -> cont -> cont (**r execute stmt, then cont *) | Kblock: cont -> cont (**r exit a block, then do cont *) - | Kcall: option ident -> function -> env -> cont -> cont. + | Kcall: option ident -> function -> env -> temp_env -> cont -> cont. (**r return to caller *) (** States *) @@ -166,6 +173,7 @@ Inductive state: Type := (s: stmt) (**r statement under consideration *) (k: cont) (**r its continuation -- what to do next *) (e: env) (**r current local environment *) + (le: temp_env) (**r current temporary environment *) (m: mem), (**r current memory state *) state | Callstate: (**r Invocation of a function *) @@ -192,7 +200,7 @@ Fixpoint call_cont (k: cont) : cont := Definition is_call_cont (k: cont) : Prop := match k with | Kstop => True - | Kcall _ _ _ _ => True + | Kcall _ _ _ _ _ => True | _ => False end. @@ -298,6 +306,9 @@ Definition blocks_of_env (e: env) : list (block * Z * Z) := of the corresponding argument is stored into the memory block bound to the parameter. *) +Definition val_normalized (v: val) (chunk: memory_chunk) : Prop := + Val.load_result chunk v = v. + Inductive bind_parameters: env -> mem -> list (ident * memory_chunk) -> list val -> mem -> Prop := @@ -307,15 +318,14 @@ Inductive bind_parameters: env -> | bind_parameters_cons: forall e m id chunk params v1 vl b m1 m2, PTree.get id e = Some (b, Vscalar chunk) -> + val_normalized v1 chunk -> 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. Section RELSEM. -Variable globenv : genv * gvarenv. -Let ge := fst globenv. -Let gvare := snd globenv. +Variable ge: genv. (* Evaluation of the address of a variable: [eval_var_addr prg ge e id b] states that variable [id] @@ -343,10 +353,11 @@ Inductive eval_var_ref: env -> ident -> block -> memory_chunk -> Prop := PTree.get id e = Some (b, Vscalar chunk) -> eval_var_ref e id b chunk | eval_var_ref_global: - forall e id b chunk, + forall e id b gv chunk, PTree.get id e = None -> Genv.find_symbol ge id = Some b -> - PTree.get id gvare = Some (Vscalar chunk) -> + Genv.find_var_info ge b = Some gv -> + gvar_info gv = Vscalar chunk -> eval_var_ref e id b chunk. (** Evaluation of an expression: [eval_expr prg e m a v] states @@ -356,6 +367,7 @@ Inductive eval_var_ref: env -> ident -> block -> memory_chunk -> Prop := Section EVAL_EXPR. Variable e: env. +Variable le: temp_env. Variable m: mem. Inductive eval_expr: expr -> val -> Prop := @@ -363,6 +375,9 @@ Inductive eval_expr: expr -> val -> Prop := eval_var_ref e id b chunk -> Mem.load chunk m b 0 = Some v -> eval_expr (Evar id) v + | eval_Etempvar: forall id v, + le!id = Some v -> + eval_expr (Etempvar id) v | eval_Eaddrof: forall id b, eval_var_addr e id b -> eval_expr (Eaddrof id) (Vptr b Int.zero) @@ -407,123 +422,130 @@ End EVAL_EXPR. Inductive exec_assign: env -> mem -> ident -> val -> mem -> Prop := exec_assign_intro: forall e m id v b chunk m', eval_var_ref e id b chunk -> + val_normalized v chunk -> Mem.store chunk m b 0 v = Some m' -> exec_assign e m id v m'. +(* Inductive exec_opt_assign: env -> mem -> option ident -> val -> mem -> Prop := | exec_assign_none: forall e m v, exec_opt_assign e m None v m | exec_assign_some: forall e m id v m', exec_assign e m id v m' -> exec_opt_assign e m (Some id) v m'. +*) (** One step of execution *) Inductive step: state -> trace -> state -> Prop := - | step_skip_seq: forall f s k e m, - step (State f Sskip (Kseq s k) e m) - E0 (State f s k e m) - | step_skip_block: forall f k e m, - step (State f Sskip (Kblock k) e m) - E0 (State f Sskip k e m) - | step_skip_call: forall f k e m m', + | step_skip_seq: forall f s k e le m, + step (State f Sskip (Kseq s k) e le m) + E0 (State f s k e le m) + | step_skip_block: forall f k e le m, + step (State f Sskip (Kblock k) e le m) + E0 (State f Sskip k e le m) + | step_skip_call: forall f k e le m m', is_call_cont k -> f.(fn_return) = None -> Mem.free_list m (blocks_of_env e) = Some m' -> - step (State f Sskip k e m) + step (State f Sskip k e le m) E0 (Returnstate Vundef k m') - | step_assign: forall f id a k e m m' v, - eval_expr e m a v -> + | step_assign: forall f id a k e le m m' v, + eval_expr e le m a v -> exec_assign e m id v m' -> - step (State f (Sassign id a) k e m) - E0 (State f Sskip k e m') + step (State f (Sassign id a) k e le m) + E0 (State f Sskip k e le m') + + | step_set: forall f id a k e le m v, + eval_expr e le m a v -> + step (State f (Sset id a) k e le m) + E0 (State f Sskip k e (PTree.set id v le) m) - | step_store: forall f chunk addr a k e m vaddr v m', - eval_expr e m addr vaddr -> - eval_expr e m a v -> + | step_store: forall f chunk addr a k e le m vaddr v m', + eval_expr e le m addr vaddr -> + eval_expr e le m a v -> Mem.storev chunk m vaddr v = Some m' -> - step (State f (Sstore chunk addr a) k e m) - E0 (State f Sskip k e m') + step (State f (Sstore chunk addr a) k e le m) + E0 (State f Sskip k e le m') - | step_call: forall f optid sig a bl k e m vf vargs fd, - eval_expr e m a vf -> - eval_exprlist e m bl vargs -> + | step_call: forall f optid sig a bl k e le m vf vargs fd, + eval_expr e le m a vf -> + eval_exprlist e le m bl vargs -> Genv.find_funct ge vf = Some fd -> funsig fd = sig -> - step (State f (Scall optid sig a bl) k e m) - E0 (Callstate fd vargs (Kcall optid f e k) m) + step (State f (Scall optid sig a bl) k e le m) + E0 (Callstate fd vargs (Kcall optid f e le k) m) - | step_seq: forall f s1 s2 k e m, - step (State f (Sseq s1 s2) k e m) - E0 (State f s1 (Kseq s2 k) e m) + | step_seq: forall f s1 s2 k e le m, + step (State f (Sseq s1 s2) k e le m) + E0 (State f s1 (Kseq s2 k) e le m) - | step_ifthenelse: forall f a s1 s2 k e m v b, - eval_expr e m a v -> + | step_ifthenelse: forall f a s1 s2 k e le m v b, + eval_expr e le m a v -> Val.bool_of_val v b -> - step (State f (Sifthenelse a s1 s2) k e m) - E0 (State f (if b then s1 else s2) k e m) - - | step_loop: forall f s k e m, - step (State f (Sloop s) k e m) - E0 (State f s (Kseq (Sloop s) k) e m) - - | step_block: forall f s k e m, - step (State f (Sblock s) k e m) - E0 (State f s (Kblock k) e m) - - | step_exit_seq: forall f n s k e m, - step (State f (Sexit n) (Kseq s k) e m) - E0 (State f (Sexit n) k e m) - | step_exit_block_0: forall f k e m, - step (State f (Sexit O) (Kblock k) e m) - E0 (State f Sskip k e m) - | step_exit_block_S: forall f n k e m, - step (State f (Sexit (S n)) (Kblock k) e m) - E0 (State f (Sexit n) k e m) - - | step_switch: forall f a cases k e m n, - eval_expr e m a (Vint n) -> - step (State f (Sswitch a cases) k e m) - E0 (State f (seq_of_lbl_stmt (select_switch n cases)) k e m) - - | step_return_0: forall f k e m m', + step (State f (Sifthenelse a s1 s2) k e le m) + E0 (State f (if b then s1 else s2) k e le m) + + | step_loop: forall f s k e le m, + step (State f (Sloop s) k e le m) + E0 (State f s (Kseq (Sloop s) k) e le m) + + | step_block: forall f s k e le m, + step (State f (Sblock s) k e le m) + E0 (State f s (Kblock k) e le m) + + | step_exit_seq: forall f n s k e le m, + step (State f (Sexit n) (Kseq s k) e le m) + E0 (State f (Sexit n) k e le m) + | step_exit_block_0: forall f k e le m, + step (State f (Sexit O) (Kblock k) e le m) + E0 (State f Sskip k e le m) + | step_exit_block_S: forall f n k e le m, + step (State f (Sexit (S n)) (Kblock k) e le m) + E0 (State f (Sexit n) k e le m) + + | step_switch: forall f a cases k e le m n, + eval_expr e le m a (Vint n) -> + step (State f (Sswitch a cases) k e le m) + E0 (State f (seq_of_lbl_stmt (select_switch n cases)) k e le m) + + | step_return_0: forall f k e le m m', f.(fn_return) = None -> Mem.free_list m (blocks_of_env e) = Some m' -> - step (State f (Sreturn None) k e m) + step (State f (Sreturn None) k e le m) E0 (Returnstate Vundef (call_cont k) m') - | step_return_1: forall f a k e m v m', + | step_return_1: forall f a k e le m v m', f.(fn_return) <> None -> - eval_expr e m a v -> + eval_expr e le m a v -> Mem.free_list m (blocks_of_env e) = Some m' -> - step (State f (Sreturn (Some a)) k e m) + step (State f (Sreturn (Some a)) k e le m) E0 (Returnstate v (call_cont k) m') - | step_label: forall f lbl s k e m, - step (State f (Slabel lbl s) k e m) - E0 (State f s k e m) + | step_label: forall f lbl s k e le m, + step (State f (Slabel lbl s) k e le m) + E0 (State f s k e le m) - | step_goto: forall f lbl k e m s' k', + | step_goto: forall f lbl k e le m s' k', find_label lbl f.(fn_body) (call_cont k) = Some(s', k') -> - step (State f (Sgoto lbl) k e m) - E0 (State f s' k' e m) + step (State f (Sgoto lbl) k e le m) + E0 (State f s' k' e le m) | step_internal_function: forall f vargs k m m1 m2 e, list_norepet (fn_params_names f ++ fn_vars_names f) -> alloc_variables empty_env m (fn_variables f) e m1 -> bind_parameters e m1 f.(fn_params) vargs m2 -> step (Callstate (Internal f) vargs k m) - E0 (State f f.(fn_body) k e m2) + E0 (State f f.(fn_body) k e empty_temp_env m2) | step_external_function: forall ef vargs k m t vres m', external_call ef ge vargs m t vres m' -> step (Callstate (External ef) vargs k m) t (Returnstate vres k m') - | step_return: forall v optid f e k m m', - exec_opt_assign e m optid v m' -> - step (Returnstate v (Kcall optid f e k) m) - E0 (State f Sskip k e m'). + | step_return: forall v optid f e le k m, + step (Returnstate v (Kcall optid f e le k) m) + E0 (State f Sskip k e (Cminor.set_optvar optid v le) m). End RELSEM. @@ -552,13 +574,8 @@ Inductive final_state: state -> int -> Prop := in the initial memory state for [p] has [beh] as observable behavior. *) -Definition global_var_env (p: program): gvarenv := - List.fold_left - (fun gve x => match x with (id, v) => PTree.set id (gvar_info v) gve end) - p.(prog_vars) (PTree.empty var_kind). - Definition exec_program (p: program) (beh: program_behavior) : Prop := program_behaves step (initial_state p) final_state - (Genv.globalenv p, global_var_env p) beh. + (Genv.globalenv p) beh. diff --git a/cfrontend/Cshmgen.v b/cfrontend/Cshmgen.v index 56bef55..a54bfcb 100644 --- a/cfrontend/Cshmgen.v +++ b/cfrontend/Cshmgen.v @@ -26,6 +26,7 @@ Require Import Integers. Require Import Floats. Require Import AST. Require Import Csyntax. +Require Import Clight. Require Import Cminor. Require Import Csharpminor. @@ -105,28 +106,28 @@ Definition make_boolean (e: expr) (ty: type) := end. Definition make_neg (e: expr) (ty: type) := - match ty with - | Tint _ _ => OK (Eunop Onegint e) - | Tfloat _ => OK (Eunop Onegf e) + match classify_neg ty with + | neg_case_i _ => OK (Eunop Onegint e) + | neg_case_f => OK (Eunop Onegf e) | _ => Error (msg "Cshmgen.make_neg") end. Definition make_notbool (e: expr) (ty: type) := - match typeconv ty with - | Tfloat _ => Ebinop (Ocmpf Ceq) e (make_floatconst Float.zero) - | _ => Eunop Onotbool e + match classify_bool ty with + | bool_case_ip => OK (Eunop Onotbool e) + | bool_case_f => OK (Ebinop (Ocmpf Ceq) e (make_floatconst Float.zero)) + | _ => Error (msg "Cshmgen.make_notbool") end. Definition make_notint (e: expr) (ty: type) := Eunop Onotint e. -Definition make_fabs (e: expr) (ty: type) := - Eunop Oabsf e. - Definition make_add (e1: expr) (ty1: type) (e2: expr) (ty2: type) := match classify_add ty1 ty2 with - | add_case_ii => OK (Ebinop Oadd e1 e2) + | add_case_ii _ => OK (Ebinop Oadd e1 e2) | add_case_ff => OK (Ebinop Oaddf e1 e2) + | add_case_if sg => OK (Ebinop Oaddf (make_floatofint e1 sg) e2) + | add_case_fi sg => OK (Ebinop Oaddf e1 (make_floatofint e2 sg)) | add_case_pi ty => let n := make_intconst (Int.repr (Csyntax.sizeof ty)) in OK (Ebinop Oadd e1 (Ebinop Omul n e2)) @@ -138,8 +139,10 @@ Definition make_add (e1: expr) (ty1: type) (e2: expr) (ty2: type) := Definition make_sub (e1: expr) (ty1: type) (e2: expr) (ty2: type) := match classify_sub ty1 ty2 with - | sub_case_ii => OK (Ebinop Osub e1 e2) + | sub_case_ii _ => OK (Ebinop Osub e1 e2) | sub_case_ff => OK (Ebinop Osubf e1 e2) + | sub_case_if sg => OK (Ebinop Osubf (make_floatofint e1 sg) e2) + | sub_case_fi sg => OK (Ebinop Osubf e1 (make_floatofint e2 sg)) | sub_case_pi ty => let n := make_intconst (Int.repr (Csyntax.sizeof ty)) in OK (Ebinop Osub e1 (Ebinop Omul n e2)) @@ -151,23 +154,27 @@ Definition make_sub (e1: expr) (ty1: type) (e2: expr) (ty2: type) := Definition make_mul (e1: expr) (ty1: type) (e2: expr) (ty2: type) := match classify_mul ty1 ty2 with - | mul_case_ii => OK (Ebinop Omul e1 e2) + | mul_case_ii _ => OK (Ebinop Omul e1 e2) | mul_case_ff => OK (Ebinop Omulf e1 e2) + | mul_case_if sg => OK (Ebinop Omulf (make_floatofint e1 sg) e2) + | mul_case_fi sg => OK (Ebinop Omulf e1 (make_floatofint e2 sg)) | mul_default => Error (msg "Cshmgen.make_mul") end. Definition make_div (e1: expr) (ty1: type) (e2: expr) (ty2: type) := match classify_div ty1 ty2 with - | div_case_I32unsi => OK (Ebinop Odivu e1 e2) - | div_case_ii => OK (Ebinop Odiv e1 e2) + | div_case_ii Unsigned => OK (Ebinop Odivu e1 e2) + | div_case_ii Signed => OK (Ebinop Odiv e1 e2) | div_case_ff => OK (Ebinop Odivf e1 e2) + | div_case_if sg => OK (Ebinop Odivf (make_floatofint e1 sg) e2) + | div_case_fi sg => OK (Ebinop Odivf e1 (make_floatofint e2 sg)) | div_default => Error (msg "Cshmgen.make_div") end. Definition make_mod (e1: expr) (ty1: type) (e2: expr) (ty2: type) := - match classify_mod ty1 ty2 with - | mod_case_I32unsi => OK (Ebinop Omodu e1 e2) - | mod_case_ii=> OK (Ebinop Omod e1 e2) + match classify_binint ty1 ty2 with + | binint_case_ii Unsigned => OK (Ebinop Omodu e1 e2) + | binint_case_ii Signed => OK (Ebinop Omod e1 e2) | mod_default => Error (msg "Cshmgen.make_mod") end. @@ -184,38 +191,22 @@ Definition make_shl (e1: expr) (ty1: type) (e2: expr) (ty2: type) := OK(Ebinop Oshl e1 e2). Definition make_shr (e1: expr) (ty1: type) (e2: expr) (ty2: type) := - match classify_shr ty1 ty2 with - | shr_case_I32unsi => OK (Ebinop Oshru e1 e2) - | shr_case_ii=> OK (Ebinop Oshr e1 e2) + match classify_shift ty1 ty2 with + | shift_case_ii Unsigned => OK (Ebinop Oshru e1 e2) + | shift_case_ii Signed => OK (Ebinop Oshr e1 e2) | shr_default => Error (msg "Cshmgen.make_shr") end. Definition make_cmp (c: comparison) (e1: expr) (ty1: type) (e2: expr) (ty2: type) := match classify_cmp ty1 ty2 with - | cmp_case_I32unsi => OK (Ebinop (Ocmpu c) e1 e2) + | cmp_case_iiu => OK (Ebinop (Ocmpu c) e1 e2) | cmp_case_ipip => OK (Ebinop (Ocmp c) e1 e2) | cmp_case_ff => OK (Ebinop (Ocmpf c) e1 e2) + | cmp_case_if sg => OK (Ebinop (Ocmpf c) (make_floatofint e1 sg) e2) + | cmp_case_fi sg => OK (Ebinop (Ocmpf c) e1 (make_floatofint e2 sg)) | cmp_default => Error (msg "Cshmgen.make_cmp") 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: @@ -271,9 +262,9 @@ Definition make_store (addr: expr) (ty: type) (rhs: expr) := (** Determine if a C expression is a variable *) -Definition is_variable (e: Csyntax.expr) : option ident := +Definition is_variable (e: Clight.expr) : option ident := match e with - | Expr (Csyntax.Evar id) _ => Some id + | Clight.Evar id _ => Some id | _ => None end. @@ -301,26 +292,13 @@ Definition var_set (id: ident) (ty: type) (rhs: expr) := | _ => Error (MSG "Cshmgen.var_set " :: CTX id :: nil) end. -(** Auxiliary for translating call statements *) - -Definition transl_lhs_call (opta: option Csyntax.expr) : res (option ident) := - match opta with - | None => OK None - | Some a => - match is_variable a with - | None => Error (msg "LHS of function call is not a variable") - | Some id => OK (Some id) - end - end. - (** ** Translation of operators *) Definition transl_unop (op: Csyntax.unary_operation) (a: expr) (ta: type) : res expr := match op with - | Csyntax.Onotbool => OK(make_notbool a ta) + | Csyntax.Onotbool => make_notbool a ta | Csyntax.Onotint => OK(make_notint a ta) | Csyntax.Oneg => make_neg a ta - | Csyntax.Ofabs => OK(make_fabs a ta) end. Definition transl_binop (op: Csyntax.binary_operation) @@ -349,55 +327,41 @@ Definition transl_binop (op: Csyntax.binary_operation) (** [transl_expr a] returns the Csharpminor code that computes the value of expression [a]. The computation is performed in the error monad - (see module [Errors]) 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) ->> -*) + (see module [Errors]) to enable error reporting. *) -Fixpoint transl_expr (a: Csyntax.expr) {struct a} : res expr := +Fixpoint transl_expr (a: Clight.expr) {struct a} : res expr := match a with - | Expr (Csyntax.Econst_int n) _ => + | Clight.Econst_int n _ => OK(make_intconst n) - | Expr (Csyntax.Econst_float n) _ => + | Clight.Econst_float n _ => OK(make_floatconst n) - | Expr (Csyntax.Evar id) ty => + | Clight.Evar id ty => var_get id ty - | Expr (Csyntax.Ederef b) _ => + | Clight.Etempvar id ty => + OK(Etempvar id) + | Clight.Ederef b _ => do tb <- transl_expr b; make_load tb (typeof a) - | Expr (Csyntax.Eaddrof b) _ => + | Clight.Eaddrof b _ => transl_lvalue b - | Expr (Csyntax.Eunop op b) _ => + | Clight.Eunop op b _ => do tb <- transl_expr b; transl_unop op tb (typeof b) - | Expr (Csyntax.Ebinop op b c) _ => + | Clight.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) _ => + | Clight.Ecast b ty => do tb <- transl_expr b; OK (make_cast (typeof b) ty tb) - | Expr (Csyntax.Econdition b c d) _ => + | Clight.Econdition b c d _ => do tb <- transl_expr b; do tc <- transl_expr c; do td <- transl_expr d; OK(Econdition (make_boolean tb (typeof b)) tc td) - | Expr (Csyntax.Eandbool b c) _ => - do tb <- transl_expr b; - do tc <- transl_expr c; - OK(make_andbool tb (typeof b) tc (typeof c)) - | Expr (Csyntax.Eorbool b c) _ => - do tb <- transl_expr b; - do tc <- transl_expr c; - OK(make_orbool tb (typeof b) tc (typeof c)) - | Expr (Csyntax.Esizeof ty) _ => + | Clight.Esizeof ty _ => OK(make_intconst (Int.repr (Csyntax.sizeof ty))) - | Expr (Csyntax.Efield b i) ty => + | Clight.Efield b i ty => match typeof b with | Tstruct _ fld => do tb <- transl_lvalue b; @@ -418,13 +382,13 @@ Fixpoint transl_expr (a: Csyntax.expr) {struct a} : res expr := where the value of [a] is stored. *) -with transl_lvalue (a: Csyntax.expr) {struct a} : res expr := +with transl_lvalue (a: Clight.expr) {struct a} : res expr := match a with - | Expr (Csyntax.Evar id) _ => + | Clight.Evar id _ => OK (Eaddrof id) - | Expr (Csyntax.Ederef b) _ => + | Clight.Ederef b _ => transl_expr b - | Expr (Csyntax.Efield b i) ty => + | Clight.Efield b i ty => match typeof b with | Tstruct _ fld => do tb <- transl_lvalue b; @@ -439,17 +403,21 @@ with transl_lvalue (a: Csyntax.expr) {struct a} : res expr := Error(msg "Cshmgen.transl_lvalue") end. -(** [transl_exprlist al] returns a list of Csharpminor expressions - that compute the values of the list [al] of Csyntax expressions. +(** [transl_exprlist al tyl] returns a list of Csharpminor expressions + that compute the values of the list [al] of Csyntax expressions, + casted to the corresponding types in [tyl]. Used for function applications. *) -Fixpoint transl_exprlist (al: list Csyntax.expr): res (list expr) := - match al with - | nil => OK nil - | a1 :: a2 => +Fixpoint transl_exprlist (al: list Clight.expr) (tyl: typelist) + {struct al}: res (list expr) := + match al, tyl with + | nil, Tnil => OK nil + | a1 :: a2, Tcons ty1 ty2 => do ta1 <- transl_expr a1; - do ta2 <- transl_exprlist a2; - OK (ta1 :: ta2) + do ta2 <- transl_exprlist a2 ty2; + OK (make_cast (typeof a1) ty1 ta1 :: ta2) + | _, _ => + Error(msg "Cshmgen.transl_exprlist: arity mismatch") end. (** * Translation of statements *) @@ -459,7 +427,7 @@ Fixpoint transl_exprlist (al: list Csyntax.expr): res (list expr) := an [exit 0] is performed. If [e] evaluates to true, the generated statement continues in sequence. *) -Definition exit_if_false (e: Csyntax.expr) : res stmt := +Definition exit_if_false (e: Clight.expr) : res stmt := do te <- transl_expr e; OK(Sifthenelse (make_boolean te (typeof e)) @@ -497,8 +465,7 @@ do s; while (e1); ---> block { } // break in s branches here -for (e1;e2;e3) s; ---> e1; - block { +for (;e2;e3) s; ---> block { loop { if (!e2) exit 0; block { s } @@ -510,93 +477,84 @@ for (e1;e2;e3) s; ---> e1; >> *) -Definition is_Sskip: - forall (s: Csyntax.statement), {s = Csyntax.Sskip} + {s <> Csyntax.Sskip}. -Proof. - destruct s; ((left; reflexivity) || (right; congruence)). -Qed. - -Fixpoint transl_statement (nbrk ncnt: nat) (s: Csyntax.statement) {struct s} : res stmt := +Fixpoint transl_statement (tyret: type) (nbrk ncnt: nat) + (s: Clight.statement) {struct s} : res stmt := match s with - | Csyntax.Sskip => + | Clight.Sskip => OK Sskip - | Csyntax.Sassign b c => + | Clight.Sassign b c => match is_variable b with | Some id => do tc <- transl_expr c; - var_set id (typeof b) tc + var_set id (typeof b) (make_cast (typeof c) (typeof b) tc) | None => do tb <- transl_lvalue b; do tc <- transl_expr c; - make_store tb (typeof b) tc + make_store tb (typeof b) (make_cast (typeof c) (typeof b) tc) end - | Csyntax.Scall opta b cl => + | Clight.Sset x b => + do tb <- transl_expr b; + OK(Sset x tb) + | Clight.Scall x b cl => match classify_fun (typeof b) with | fun_case_f args res => - do optid <- transl_lhs_call opta; do tb <- transl_expr b; - do tcl <- transl_exprlist cl; - OK(Scall optid (signature_of_type args res) tb tcl) + do tcl <- transl_exprlist cl args; + OK(Scall x (signature_of_type args res) tb tcl) | _ => Error(msg "Cshmgen.transl_stmt(call)") end - | Csyntax.Ssequence s1 s2 => - do ts1 <- transl_statement nbrk ncnt s1; - do ts2 <- transl_statement nbrk ncnt s2; + | Clight.Ssequence s1 s2 => + do ts1 <- transl_statement tyret nbrk ncnt s1; + do ts2 <- transl_statement tyret nbrk ncnt s2; OK (Sseq ts1 ts2) - | Csyntax.Sifthenelse e s1 s2 => + | Clight.Sifthenelse e s1 s2 => do te <- transl_expr e; - do ts1 <- transl_statement nbrk ncnt s1; - do ts2 <- transl_statement nbrk ncnt s2; + do ts1 <- transl_statement tyret nbrk ncnt s1; + do ts2 <- transl_statement tyret nbrk ncnt s2; OK (Sifthenelse (make_boolean te (typeof e)) ts1 ts2) - | Csyntax.Swhile e s1 => + | Clight.Swhile e s1 => do te <- exit_if_false e; - do ts1 <- transl_statement 1%nat 0%nat s1; + do ts1 <- transl_statement tyret 1%nat 0%nat s1; OK (Sblock (Sloop (Sseq te (Sblock ts1)))) - | Csyntax.Sdowhile e s1 => + | Clight.Sdowhile e s1 => do te <- exit_if_false e; - do ts1 <- transl_statement 1%nat 0%nat s1; + do ts1 <- transl_statement tyret 1%nat 0%nat s1; OK (Sblock (Sloop (Sseq (Sblock ts1) te))) - | Csyntax.Sfor e1 e2 e3 s1 => - if is_Sskip e1 then - (do te2 <- exit_if_false e2; - do te3 <- transl_statement nbrk ncnt e3; - do ts1 <- transl_statement 1%nat 0%nat s1; - OK (Sblock (Sloop (Sseq te2 (Sseq (Sblock ts1) te3))))) - else - (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; - OK (Sseq te1 (Sblock (Sloop (Sseq te2 (Sseq (Sblock ts1) te3)))))) - | Csyntax.Sbreak => + | Clight.Sfor' e2 e3 s1 => + do te2 <- exit_if_false e2; + do te3 <- transl_statement tyret 0%nat (S ncnt) e3; + do ts1 <- transl_statement tyret 1%nat 0%nat s1; + OK (Sblock (Sloop (Sseq te2 (Sseq (Sblock ts1) te3)))) + | Clight.Sbreak => OK (Sexit nbrk) - | Csyntax.Scontinue => + | Clight.Scontinue => OK (Sexit ncnt) - | Csyntax.Sreturn (Some e) => + | Clight.Sreturn (Some e) => do te <- transl_expr e; - OK (Sreturn (Some te)) - | Csyntax.Sreturn None => + OK (Sreturn (Some (make_cast (typeof e) tyret te))) + | Clight.Sreturn None => OK (Sreturn None) - | Csyntax.Sswitch a sl => + | Clight.Sswitch a sl => do ta <- transl_expr a; - do tsl <- transl_lbl_stmt 0%nat (S ncnt) sl; + do tsl <- transl_lbl_stmt tyret 0%nat (S ncnt) sl; OK (Sblock (Sswitch ta tsl)) - | Csyntax.Slabel lbl s => - do ts <- transl_statement nbrk ncnt s; + | Clight.Slabel lbl s => + do ts <- transl_statement tyret nbrk ncnt s; OK (Slabel lbl ts) - | Csyntax.Sgoto lbl => + | Clight.Sgoto lbl => OK (Sgoto lbl) end -with transl_lbl_stmt (nbrk ncnt: nat) (sl: Csyntax.labeled_statements) +with transl_lbl_stmt (tyret: type) (nbrk ncnt: nat) + (sl: Clight.labeled_statements) {struct sl}: res lbl_stmt := match sl with - | Csyntax.LSdefault s => - do ts <- transl_statement nbrk ncnt s; + | Clight.LSdefault s => + do ts <- transl_statement tyret nbrk ncnt s; OK (LSdefault ts) - | Csyntax.LScase n s sl' => - do ts <- transl_statement nbrk ncnt s; - do tsl' <- transl_lbl_stmt nbrk ncnt sl'; + | Clight.LScase n s sl' => + do ts <- transl_statement tyret nbrk ncnt s; + do tsl' <- transl_lbl_stmt tyret nbrk ncnt sl'; OK (LScase n ts tsl') end. @@ -610,23 +568,37 @@ Definition transl_params (l: list (ident * type)) := Definition transl_vars (l: list (ident * type)) := AST.map_partial prefix_var_name var_kind_of_type l. -Definition transl_function (f: Csyntax.function) : res 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); - OK (mkfunction (opttyp_of_type (Csyntax.fn_return f)) tparams tvars tbody). +Definition transl_function (f: Clight.function) : res function := + do tparams <- transl_params (Clight.fn_params f); + do tvars <- transl_vars (Clight.fn_vars f); + do tbody <- transl_statement f.(Clight.fn_return) 1%nat 0%nat (Clight.fn_body f); + OK (mkfunction + (opttyp_of_type (Clight.fn_return f)) + tparams + tvars + (List.map (@fst ident type) f.(Clight.fn_temps)) + tbody). + +Definition list_typ_eq: + forall (l1 l2: list typ), {l1=l2} + {l1<>l2}. +Proof. + generalize typ_eq; intro. decide equality. +Qed. -Definition transl_fundef (f: Csyntax.fundef) : res fundef := +Definition transl_fundef (f: Clight.fundef) : res fundef := match f with - | Csyntax.Internal g => + | Clight.Internal g => do tg <- transl_function g; OK(AST.Internal tg) - | Csyntax.External ef args res => - OK(AST.External ef) + | Clight.External ef args res => + if list_typ_eq ef.(ef_sig).(sig_args) (typlist_of_typelist args) + && opt_typ_eq ef.(ef_sig).(sig_res) (opttyp_of_type res) + then OK(AST.External ef) + else Error(msg "Cshmgen.transl_fundef: wrong external signature") end. (** ** Translation of programs *) Definition transl_globvar (ty: type) := var_kind_of_type ty. -Definition transl_program (p: Csyntax.program) : res program := +Definition transl_program (p: Clight.program) : res program := transform_partial_program2 transl_fundef transl_globvar p. diff --git a/cfrontend/Cshmgenproof.v b/cfrontend/Cshmgenproof.v new file mode 100644 index 0000000..02fab6f --- /dev/null +++ b/cfrontend/Cshmgenproof.v @@ -0,0 +1,1869 @@ +(* *********************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Xavier Leroy, INRIA Paris-Rocquencourt *) +(* *) +(* Copyright Institut National de Recherche en Informatique et en *) +(* Automatique. All rights reserved. This file is distributed *) +(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* *) +(* *********************************************************************) + +(** * Correctness of the translation from Clight to C#minor. *) + +Require Import Coqlib. +Require Import Errors. +Require Import Maps. +Require Import Integers. +Require Import Floats. +Require Import AST. +Require Import Values. +Require Import Events. +Require Import Memory. +Require Import Globalenvs. +Require Import Smallstep. +Require Import Csyntax. +Require Import Csem. +Require Import Clight. +Require Import Cminor. +Require Import Csharpminor. +Require Import Cshmgen. + +(** * Properties of operations over types *) + +Remark type_of_chunk_of_type: + forall ty chunk, + chunk_of_type ty = OK chunk -> + type_of_chunk chunk = typ_of_type ty. +Proof. + intros. unfold chunk_of_type in H. destruct ty; simpl in H; try monadInv H. + destruct i; destruct s; monadInv H; reflexivity. + destruct f; monadInv H; reflexivity. + reflexivity. reflexivity. +Qed. + +Remark transl_params_types: + forall p tp, + transl_params p = OK tp -> + map type_of_chunk (map param_chunk tp) = typlist_of_typelist (type_of_params p). +Proof. + induction p; simpl; intros. + inv H. auto. + destruct a as [id ty]. generalize H; clear H. case_eq (chunk_of_type ty); intros. + monadInv H0. simpl. f_equal; auto. apply type_of_chunk_of_type; auto. + inv H0. +Qed. + +Lemma transl_fundef_sig1: + forall f tf args res, + transl_fundef f = OK tf -> + classify_fun (type_of_fundef f) = fun_case_f args res -> + funsig tf = signature_of_type args res. +Proof. + intros. destruct f; simpl in *. + monadInv H. monadInv EQ. simpl. inversion H0. + unfold fn_sig; simpl. unfold signature_of_type. f_equal. + apply transl_params_types; auto. + destruct (list_typ_eq (sig_args (ef_sig e)) (typlist_of_typelist t)); simpl in H. + destruct (opt_typ_eq (sig_res (ef_sig e)) (opttyp_of_type t0)); simpl in H. + inv H. simpl. destruct (ef_sig e); simpl in *. inv H0. + unfold signature_of_type. auto. + congruence. + congruence. +Qed. + +Lemma transl_fundef_sig2: + forall f tf args res, + transl_fundef f = OK 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 = OK(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 = OK 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. + +Remark cast_int_int_normalized: + forall sz si chunk n, + access_mode (Tint sz si) = By_value chunk -> + val_normalized (Vint (cast_int_int sz si n)) chunk. +Proof. + unfold access_mode, cast_int_int, val_normalized; intros. destruct sz. + destruct si; inv H; simpl. + rewrite Int.sign_ext_idem; auto. compute; auto. + rewrite Int.zero_ext_idem; auto. compute; auto. + destruct si; inv H; simpl. + rewrite Int.sign_ext_idem; auto. compute; auto. + rewrite Int.zero_ext_idem; auto. compute; auto. + inv H. auto. +Qed. + +Remark cast_float_float_normalized: + forall sz chunk n, + access_mode (Tfloat sz) = By_value chunk -> + val_normalized (Vfloat (cast_float_float sz n)) chunk. +Proof. + unfold access_mode, cast_float_float, val_normalized; intros. + destruct sz; inv H; simpl. + rewrite Float.singleoffloat_idem. auto. + auto. +Qed. + +Remark neutral_for_cast_chunk: + forall ty chunk, + neutral_for_cast ty -> access_mode ty = By_value chunk -> chunk = Mint32. +Proof. + induction 1; simpl; intros; inv H; auto. +Qed. + +Lemma cast_result_normalized: + forall chunk v1 ty1 ty2 v2, + cast v1 ty1 ty2 v2 -> + access_mode ty2 = By_value chunk -> + val_normalized v2 chunk. +Proof. + induction 1; intros; simpl. + apply cast_int_int_normalized; auto. + apply cast_int_int_normalized; auto. + apply cast_float_float_normalized; auto. + apply cast_float_float_normalized; auto. + rewrite (neutral_for_cast_chunk _ _ H0 H1). red; auto. + rewrite (neutral_for_cast_chunk _ _ H0 H1). red; auto. +Qed. + +Definition val_casted (v: val) (ty: type) : Prop := + exists v0, exists ty0, cast v0 ty0 ty v. + +Lemma val_casted_normalized: + forall v ty chunk, + val_casted v ty -> access_mode ty = By_value chunk -> val_normalized v chunk. +Proof. + intros. destruct H as [v0 [ty0 CAST]]. eapply cast_result_normalized; eauto. +Qed. + +Fixpoint val_casted_list (vl: list val) (tyl: typelist) {struct vl}: Prop := + match vl, tyl with + | nil, Tnil => True + | v1 :: vl', Tcons ty1 tyl' => val_casted v1 ty1 /\ val_casted_list vl' tyl' + | _, _ => False + end. + +Lemma eval_exprlist_casted: + forall ge e le m al tyl vl, + Clight.eval_exprlist ge e le m al tyl vl -> + val_casted_list vl tyl. +Proof. + induction 1; simpl. + auto. + split. exists v1; exists (typeof a); auto. eauto. +Qed. + +(** * Properties of the translation functions *) + +Lemma map_partial_names: + forall (A B: Type) (f: A -> res B) + (l: list (ident * A)) (tl: list (ident * B)), + map_partial prefix_var_name f l = OK 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 (map_partial prefix_var_name f l); simpl; intros; try congruence. + inv H0. simpl. decEq. auto. +Qed. + +Lemma map_partial_append: + forall (A B: Type) (f: A -> res B) + (l1 l2: list (ident * A)) (tl1 tl2: list (ident * B)), + map_partial prefix_var_name f l1 = OK tl1 -> + map_partial prefix_var_name f l2 = OK tl2 -> + map_partial prefix_var_name f (l1 ++ l2) = OK (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 (map_partial prefix_var_name f l1); simpl; intros; try congruence. + inv H0. rewrite (IHl1 _ _ _ H H1). auto. +Qed. + +Lemma transl_params_names: + forall vars tvars, + transl_params vars = OK tvars -> + List.map param_name tvars = var_names vars. +Proof. + exact (map_partial_names _ _ chunk_of_type). +Qed. + +Lemma transl_vars_names: + forall vars tvars, + transl_vars vars = OK tvars -> + List.map variable_name tvars = var_names vars. +Proof. + exact (map_partial_names _ _ var_kind_of_type). +Qed. + +Lemma transl_names_norepet: + forall params vars sg tparams tvars temps body, + list_norepet (var_names params ++ var_names vars) -> + transl_params params = OK tparams -> + transl_vars vars = OK tvars -> + let f := Csharpminor.mkfunction sg tparams tvars temps 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 = OK tl1 -> transl_vars l2 = OK tl2 -> + transl_vars (l1 ++ l2) = OK (tl1 ++ tl2). +Proof. + exact (map_partial_append _ _ var_kind_of_type). +Qed. + +Lemma transl_params_vars: + forall params tparams, + transl_params params = OK tparams -> + transl_vars params = + OK (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); simpl; intros; try congruence. + inv H0. + rewrite (var_kind_by_value _ _ AM). + rewrite (IHparams _ H). reflexivity. +Qed. + +Lemma transl_fn_variables: + forall params vars sg tparams tvars temps body, + transl_params params = OK tparams -> + transl_vars vars = OK tvars -> + let f := Csharpminor.mkfunction sg tparams tvars temps body in + transl_vars (params ++ vars) = OK (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 = Clight.Evar id (typeof a). +Proof. + intros until id. unfold is_variable; destruct a; intros; try discriminate. + simpl. congruence. +Qed. + +Lemma transl_expr_lvalue: + forall ge e le m a loc ofs ta, + Clight.eval_lvalue ge e le m a loc ofs -> + transl_expr a = OK ta -> + (exists id, exists ty, a = Clight.Evar id ty /\ var_get id ty = OK ta) \/ + (exists tb, transl_lvalue a = OK tb /\ + make_load tb (typeof a) = OK ta). +Proof. + intros. inversion H; subst; clear H; simpl in H0. + left; exists id; exists ty; auto. + left; exists id; exists ty; auto. + monadInv H0. right. exists x; split; auto. + rewrite H2 in H0. monadInv H0. right. + exists (Ebinop Oadd x (make_intconst (Int.repr x0))). split; auto. + simpl. rewrite H2. rewrite EQ. rewrite EQ1. auto. + rewrite H2 in H0. monadInv H0. right. + exists x; split; auto. + simpl. rewrite H2. auto. +Qed. + +(** Properties of labeled statements *) + +Lemma transl_lbl_stmt_1: + forall tyret nbrk ncnt n sl tsl, + transl_lbl_stmt tyret nbrk ncnt sl = OK tsl -> + transl_lbl_stmt tyret nbrk ncnt (Clight.select_switch n sl) = OK (select_switch n tsl). +Proof. + induction sl; intros. + monadInv H. simpl. rewrite EQ. auto. + generalize H; intro TR. monadInv TR. simpl. + destruct (Int.eq i n). auto. auto. +Qed. + +Lemma transl_lbl_stmt_2: + forall tyret nbrk ncnt sl tsl, + transl_lbl_stmt tyret nbrk ncnt sl = OK tsl -> + transl_statement tyret nbrk ncnt (seq_of_labeled_statement sl) = OK (seq_of_lbl_stmt tsl). +Proof. + induction sl; intros. + monadInv H. simpl. auto. + monadInv H. simpl. rewrite EQ; simpl. rewrite (IHsl _ EQ1). simpl. auto. +Qed. + +(** * Correctness of Csharpminor construction functions *) + +Section CONSTRUCTORS. + +Variable ge: genv. + +Lemma make_intconst_correct: + forall n e le m, + eval_expr ge e le m (make_intconst n) (Vint n). +Proof. + intros. unfold make_intconst. econstructor. reflexivity. +Qed. + +Lemma make_floatconst_correct: + forall n e le m, + eval_expr ge e le m (make_floatconst n) (Vfloat n). +Proof. + intros. unfold make_floatconst. econstructor. reflexivity. +Qed. + +Lemma make_floatofint_correct: + forall a n sg e le m, + eval_expr ge e le m a (Vint n) -> + eval_expr ge e le m (make_floatofint a sg) (Vfloat(cast_int_float sg n)). +Proof. + intros. unfold make_floatofint, cast_int_float. + destruct sg; econstructor; eauto. +Qed. + +Hint Resolve make_intconst_correct make_floatconst_correct + make_floatofint_correct + eval_Eunop eval_Ebinop: 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 e le m a v ty, + eval_expr ge e le m a v -> + is_true v ty -> + exists vb, + eval_expr ge e le m (make_boolean a ty) 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 eval_Ebinop; eauto with cshm. + inversion VTRUE; simpl. + rewrite Float.cmp_ne_eq. rewrite H1. auto. + apply Vtrue_is_true. +Qed. + +Lemma make_boolean_correct_false: + forall e le m a v ty, + eval_expr ge e le m a v -> + is_false v ty -> + exists vb, + eval_expr ge e le m (make_boolean a ty) 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 eval_Ebinop; eauto with cshm. + inversion VFALSE; simpl. + rewrite Float.cmp_ne_eq. rewrite H1. auto. + apply Vfalse_is_false. +Qed. + +Lemma make_neg_correct: + forall a tya c va v e le m, + sem_neg va tya = Some v -> + make_neg a tya = OK c -> + eval_expr ge e le m a va -> + eval_expr ge e le m c v. +Proof. + intros until m; intro SEM. unfold make_neg. + functional inversion SEM; intros. + rewrite H0 in H4. inv H4. eapply eval_Eunop; eauto with cshm. + rewrite H0 in H4. inv H4. eauto with cshm. +Qed. + +Lemma make_notbool_correct: + forall a tya c va v e le m, + sem_notbool va tya = Some v -> + make_notbool a tya = OK c -> + eval_expr ge e le m a va -> + eval_expr ge e le m c v. +Proof. + intros until m; intro SEM. unfold make_notbool. + functional inversion SEM; intros; rewrite H0 in H4; inversion H4; simpl; + eauto with cshm. +Qed. + +Lemma make_notint_correct: + forall a tya c va v e le m, + sem_notint va tya = Some v -> + make_notint a tya = c -> + eval_expr ge e le m a va -> + eval_expr ge e le m c v. +Proof. + intros until m; intro SEM. unfold make_notint. + functional inversion SEM; intros. subst. eauto with cshm. +Qed. + +Definition binary_constructor_correct + (make: expr -> type -> expr -> type -> res expr) + (sem: val -> type -> val -> type -> option val): Prop := + forall a tya b tyb c va vb v e le m, + sem va tya vb tyb = Some v -> + make a tya b tyb = OK c -> + eval_expr ge e le m a va -> + eval_expr ge e le m b vb -> + eval_expr ge e le m c v. + +(* +Definition binary_constructor_correct' + (make: expr -> type -> expr -> type -> res expr) + (sem: val -> val -> option val): Prop := + forall a tya b tyb c va vb v e le m, + sem va vb = Some v -> + make a tya b tyb = OK c -> + eval_expr ge e le m a va -> + eval_expr ge e le m b vb -> + eval_expr ge e le m c v. +*) + +Lemma make_add_correct: binary_constructor_correct make_add sem_add. +Proof. + red; intros until m. intro SEM. unfold make_add. + functional inversion SEM; rewrite H0; intros; + inversion H7; eauto with cshm. + eapply eval_Ebinop. eauto. + eapply eval_Ebinop. eauto with cshm. eauto. + simpl. reflexivity. reflexivity. + eapply eval_Ebinop. eauto. + eapply eval_Ebinop. eauto with cshm. eauto. + simpl. reflexivity. simpl. reflexivity. +Qed. + +Lemma make_sub_correct: binary_constructor_correct make_sub sem_sub. +Proof. + red; intros until m. intro SEM. unfold make_sub. + functional inversion SEM; rewrite H0; intros; + inversion H7; eauto with cshm. + eapply eval_Ebinop. eauto. + eapply eval_Ebinop. eauto with cshm. eauto. + simpl. reflexivity. reflexivity. + inversion H9. eapply eval_Ebinop. + eapply eval_Ebinop; eauto. + simpl. unfold eq_block; rewrite H3. reflexivity. + eauto with cshm. simpl. rewrite H8. reflexivity. +Qed. + +Lemma make_mul_correct: binary_constructor_correct make_mul sem_mul. +Proof. + red; intros until m. 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 m. intro SEM. unfold make_div. + functional inversion SEM; rewrite H0; intros. + inversion H8. eapply eval_Ebinop; eauto with cshm. + simpl. rewrite H7; auto. + inversion H8. eapply eval_Ebinop; eauto with cshm. + simpl. rewrite H7; auto. + inversion H7; eauto with cshm. + inversion H7; eauto with cshm. + inversion H7; eauto with cshm. +Qed. + +Lemma make_mod_correct: binary_constructor_correct make_mod sem_mod. + red; intros until m. intro SEM. unfold make_mod. + functional inversion SEM; rewrite H0; intros. + inversion H8. eapply eval_Ebinop; eauto with cshm. + simpl. rewrite H7; auto. + inversion H8. eapply eval_Ebinop; eauto with cshm. + simpl. rewrite H7; auto. +Qed. + +Lemma make_and_correct: binary_constructor_correct make_and sem_and. +Proof. + red; intros until m. intro SEM. unfold make_and. + functional inversion SEM. intros. inversion H7. + eauto with cshm. +Qed. + +Lemma make_or_correct: binary_constructor_correct make_or sem_or. +Proof. + red; intros until m. intro SEM. unfold make_or. + functional inversion SEM. intros. inversion H7. + eauto with cshm. +Qed. + +Lemma make_xor_correct: binary_constructor_correct make_xor sem_xor. +Proof. + red; intros until m. intro SEM. unfold make_xor. + functional inversion SEM. intros. inversion H7. + eauto with cshm. +Qed. + +Lemma make_shl_correct: binary_constructor_correct make_shl sem_shl. +Proof. + red; intros until m. intro SEM. unfold make_shl. + functional inversion SEM. intros. inversion H8. + eapply eval_Ebinop; eauto with cshm. + simpl. rewrite H7. auto. +Qed. + +Lemma make_shr_correct: binary_constructor_correct make_shr sem_shr. +Proof. + red; intros until m. intro SEM. unfold make_shr. + functional inversion SEM; intros; rewrite H0 in H8; inversion H8. + eapply eval_Ebinop; eauto with cshm. + simpl; rewrite H7; auto. + eapply eval_Ebinop; eauto with cshm. + simpl; rewrite H7; auto. +Qed. + +Lemma make_cmp_correct: + forall cmp a tya b tyb c va vb v e le m, + sem_cmp cmp va tya vb tyb m = Some v -> + make_cmp cmp a tya b tyb = OK c -> + eval_expr ge e le m a va -> + eval_expr ge e le m b vb -> + eval_expr ge e le m c v. +Proof. + intros until m. intro SEM. unfold make_cmp. + functional inversion SEM; rewrite H0; intros. + (* iiu *) + inversion H8. eauto with cshm. + (* ipip int int *) + inversion H8. eauto with cshm. + (* ipip ptr ptr *) + inversion H10. eapply eval_Ebinop; eauto with cshm. + simpl. rewrite H3. unfold eq_block. rewrite H9. auto. + inversion H10. eapply eval_Ebinop; eauto with cshm. + simpl. rewrite H3. unfold eq_block. rewrite H9. auto. + (* ipip ptr int *) + inversion H9. eapply eval_Ebinop; eauto with cshm. + simpl. unfold eval_compare_null. rewrite H8. auto. + (* ipip int ptr *) + inversion H9. eapply eval_Ebinop; eauto with cshm. + simpl. unfold eval_compare_null. rewrite H8. auto. + (* ff *) + inversion H8. eauto with cshm. + (* if *) + inversion H8. eauto with cshm. + (* fi *) + inversion H8. eauto with cshm. +Qed. + +Lemma transl_unop_correct: + forall op a tya c va v e le m, + transl_unop op a tya = OK c -> + sem_unary_operation op va tya = Some v -> + eval_expr ge e le m a va -> + eval_expr ge e le m c v. +Proof. + intros. destruct op; simpl in *. + eapply make_notbool_correct; eauto. + 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 va vb v e le m, + transl_binop op a tya b tyb = OK c -> + sem_binary_operation op va tya vb tyb m = Some v -> + eval_expr ge e le m a va -> + eval_expr ge e le m b vb -> + eval_expr ge e le m c 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 e le m a v ty1 ty2 v', + eval_expr ge e le m a v -> + cast v ty1 ty2 v' -> + eval_expr ge e le m (make_cast ty1 ty2 a) v'. +Proof. + unfold make_cast, make_cast1, make_cast2. + intros until v'; intros EVAL CAST. + inversion CAST; clear CAST; subst. + (* cast_int_int *) + destruct sz2; destruct si2; repeat econstructor; eauto with cshm. + (* cast_float_int *) + destruct sz2; destruct si2; unfold make_intoffloat; repeat econstructor; eauto with cshm; simpl; auto. + (* cast_int_float *) + destruct sz2; destruct si1; unfold make_floatofint; repeat econstructor; eauto with cshm; simpl; auto. + (* cast_float_float *) + destruct sz2; repeat econstructor; eauto with cshm. + (* neutral, ptr *) + inversion H0; auto; inversion H; auto. + (* neutral, int *) + inversion H0; auto; inversion H; auto. +Qed. + +Lemma make_load_correct: + forall addr ty code b ofs v e le m, + make_load addr ty = OK code -> + eval_expr ge e le m addr (Vptr b ofs) -> + load_value_of_type ty m b ofs = Some v -> + eval_expr ge e le m code v. +Proof. + unfold make_load, load_value_of_type. + intros until m; 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 le m b ofs v m' f k, + make_store addr ty rhs = OK code -> + eval_expr ge e le m addr (Vptr b ofs) -> + eval_expr ge e le m rhs v -> + store_value_of_type ty m b ofs v = Some m' -> + step ge (State f code k e le m) E0 (State f Sskip k e le m'). +Proof. + unfold make_store, store_value_of_type. + intros until k; intros MKSTORE EV1 EV2 STVAL. + destruct (access_mode ty); inversion MKSTORE. + (* access_mode ty = By_value m *) + eapply step_store; eauto. +Qed. + +End CONSTRUCTORS. + +(** * Basic preservation invariants *) + +Section CORRECTNESS. + +Variable prog: Clight.program. +Variable tprog: Csharpminor.program. +Hypothesis TRANSL: transl_program prog = OK tprog. + +Let ge := Genv.globalenv prog. +Let tge := Genv.globalenv tprog. + +Lemma symbols_preserved: + forall s, Genv.find_symbol tge s = Genv.find_symbol ge s. +Proof (Genv.find_symbol_transf_partial2 transl_fundef transl_globvar _ TRANSL). + +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 = OK tf. +Proof (Genv.find_funct_transf_partial2 transl_fundef transl_globvar _ TRANSL). + +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 = OK tf. +Proof (Genv.find_funct_ptr_transf_partial2 transl_fundef transl_globvar _ TRANSL). + +Lemma var_info_translated: + forall b v, + Genv.find_var_info ge b = Some v -> + exists tv, Genv.find_var_info tge b = Some tv /\ transf_globvar transl_globvar v = OK tv. +Proof (Genv.find_var_info_transf_partial2 transl_fundef transl_globvar _ TRANSL). + +(** * Matching between environments *) + +(** In this section, we define a matching relation between + a Clight local environment and a Csharpminor local environment. *) + +Record match_env (e: Clight.env) (te: Csharpminor.env) : Prop := + mk_match_env { + me_local: + forall id b ty, + e!id = Some (b, ty) -> + exists vk, var_kind_of_type ty = OK vk /\ te!id = Some (b, vk); + me_local_inv: + forall id b vk, + te!id = Some (b, vk) -> exists ty, e!id = Some(b, ty) + }. + +Lemma match_env_globals: + forall e te id l ty, + match_env e te -> + e!id = None -> + Genv.find_symbol ge id = Some l -> + type_of_global ge l = Some ty -> + te!id = None /\ + (forall chunk, access_mode ty = By_value chunk -> + exists gv, Genv.find_var_info tge l = Some gv /\ gvar_info gv = Vscalar chunk). +Proof. + intros. + case_eq (te!id). intros [b' vk] EQ. + exploit me_local_inv; eauto. intros [ty' EQ']. congruence. + intros. split; auto; intros. + revert H2; unfold type_of_global. + case_eq (Genv.find_var_info ge l). intros. inv H5. + exploit var_info_translated; eauto. intros [gv [A B]]. monadInv B. unfold transl_globvar in EQ. + econstructor; split. eauto. simpl. + exploit var_kind_by_value; eauto. congruence. + intros. destruct (Genv.find_funct_ptr ge l); intros; inv H5. + destruct f; simpl in H4; discriminate. +Qed. + +Lemma match_env_same_blocks: + forall e te, + match_env e te -> + blocks_of_env te = Csem.blocks_of_env e. +Proof. + intros. + set (R := fun (x: (block * type)) (y: (block * var_kind)) => + match x, y with + | (b1, ty), (b2, vk) => b2 = b1 /\ var_kind_of_type ty = OK vk + end). + assert (list_forall2 + (fun i_x i_y => fst i_x = fst i_y /\ R (snd i_x) (snd i_y)) + (PTree.elements e) (PTree.elements te)). + apply PTree.elements_canonical_order. + intros id [b ty] GET. exploit me_local; eauto. intros [vk [A B]]. + exists (b, vk); split; auto. red. auto. + intros id [b vk] GET. + exploit me_local_inv; eauto. intros [ty A]. + exploit me_local; eauto. intros [vk' [B C]]. + assert (vk' = vk) by congruence. subst vk'. + exists (b, ty); split; auto. red. auto. + + unfold blocks_of_env, Csem.blocks_of_env. + generalize H0. induction 1. auto. + simpl. f_equal; auto. + unfold block_of_binding, Csem.block_of_binding. + destruct a1 as [id1 [blk1 ty1]]. destruct b1 as [id2 [blk2 vk2]]. + simpl in *. destruct H1 as [A [B C]]. subst blk2 id2. f_equal. + apply sizeof_var_kind_of_type. auto. +Qed. + +Lemma match_env_free_blocks: + forall e te m m', + match_env e te -> + Mem.free_list m (Csem.blocks_of_env e) = Some m' -> + Mem.free_list m (blocks_of_env te) = Some m'. +Proof. + intros. rewrite (match_env_same_blocks _ _ H). auto. +Qed. + +Lemma match_env_empty: + match_env Clight.empty_env Csharpminor.empty_env. +Proof. + unfold Clight.empty_env, Csharpminor.empty_env. + constructor. + intros until b. repeat rewrite PTree.gempty. congruence. + intros until vk. rewrite PTree.gempty. congruence. +Qed. + +(** The following lemmas establish the [match_env] invariant at + the beginning of a function invocation, after allocation of + local variables and initialization of the parameters. *) + +Lemma match_env_alloc_variables: + forall e1 m1 vars e2 m2, + Csem.alloc_variables e1 m1 vars e2 m2 -> + forall te1 tvars, + match_env e1 te1 -> + transl_vars vars = OK tvars -> + exists te2, + Csharpminor.alloc_variables te1 m1 tvars te2 m2 + /\ match_env e2 te2. +Proof. + induction 1; intros. + monadInv H0. + exists te1; split. constructor. auto. + generalize H2. simpl. + caseEq (var_kind_of_type ty); simpl; [intros vk VK | congruence]. + caseEq (transl_vars vars); simpl; [intros tvrs TVARS | congruence]. + intro EQ; inversion EQ; subst tvars; clear EQ. + set (te2 := PTree.set id (b1, vk) te1). + assert (match_env (PTree.set id (b1, ty) e) te2). + inversion H1. unfold te2. constructor. + (* me_local *) + intros until ty0. simpl. repeat rewrite PTree.gsspec. + destruct (peq id0 id); intros. + inv H3. exists vk; intuition. + auto. + (* me_local_inv *) + intros until vk0. repeat rewrite PTree.gsspec. + destruct (peq id0 id); intros. exists ty; congruence. eauto. + destruct (IHalloc_variables _ _ H3 TVARS) as [te3 [ALLOC MENV]]. + exists te3; split. + econstructor; eauto. + rewrite (sizeof_var_kind_of_type _ _ VK). eauto. + auto. +Qed. + +Lemma bind_parameters_match: + forall e m1 vars vals m2, + Csem.bind_parameters e m1 vars vals m2 -> + forall te tvars, + val_casted_list vals (type_of_params vars) -> + match_env e te -> + transl_params vars = OK tvars -> + Csharpminor.bind_parameters te m1 tvars vals m2. +Proof. + induction 1; intros. +(* base case *) + monadInv H1. constructor. +(* inductive case *) + simpl in H2. destruct H2. + revert H4; simpl. + caseEq (chunk_of_type ty); simpl; [intros chunk CHK | congruence]. + caseEq (transl_params params); simpl; [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. + exploit me_local; eauto. intros [vk [A B]]. + exploit var_kind_by_value; eauto. congruence. + eapply val_casted_normalized; eauto. + assumption. + apply IHbind_parameters; auto. +Qed. + +(* ** Correctness of variable accessors *) + +(** Correctness of the code generated by [var_get]. *) + +Lemma var_get_correct: + forall e le m id ty loc ofs v code te, + Clight.eval_lvalue ge e le m (Clight.Evar id ty) loc ofs -> + load_value_of_type ty m loc ofs = Some v -> + var_get id ty = OK code -> + match_env e te -> + eval_expr tge te le m code v. +Proof. + intros. revert H0 H1. unfold load_value_of_type, var_get. + case_eq (access_mode ty). + (* access mode By_value *) + intros chunk ACC LOAD EQ. inv EQ. + inv H. + (* local variable *) + exploit me_local; eauto. intros [vk [A B]]. + assert (vk = Vscalar chunk). + exploit var_kind_by_value; eauto. congruence. + subst vk. + eapply eval_Evar. + eapply eval_var_ref_local. eauto. assumption. + (* global variable *) + exploit match_env_globals; eauto. intros [A B]. + exploit B; eauto. intros [gv [C D]]. + eapply eval_Evar. + eapply eval_var_ref_global. auto. + rewrite symbols_preserved. eauto. + eauto. eauto. + assumption. + (* access mode By_reference *) + intros ACC EQ1 EQ2. inv EQ1; inv EQ2; inv H. + (* local variable *) + exploit me_local; eauto. intros [vk [A B]]. + eapply eval_Eaddrof. + eapply eval_var_addr_local. eauto. + (* global variable *) + exploit match_env_globals; eauto. intros [A B]. + eapply eval_Eaddrof. + eapply eval_var_addr_global. auto. + rewrite symbols_preserved. eauto. + (* access mode By_nothing *) + congruence. +Qed. + +(** Correctness of the code generated by [var_set]. *) + +Lemma var_set_correct: + forall e le m id ty loc ofs v m' code te rhs f k, + Clight.eval_lvalue ge e le m (Clight.Evar id ty) loc ofs -> + val_casted v ty -> + store_value_of_type ty m loc ofs v = Some m' -> + var_set id ty rhs = OK code -> + match_env e te -> + eval_expr tge te le m rhs v -> + step tge (State f code k te le m) E0 (State f Sskip k te le m'). +Proof. + intros. revert H1 H2. unfold store_value_of_type, var_set. + caseEq (access_mode ty). + (* access mode By_value *) + intros chunk ACC STORE EQ. inv EQ. + inv H. + (* local variable *) + exploit me_local; eauto. intros [vk [A B]]. + assert (vk = Vscalar chunk). + exploit var_kind_by_value; eauto. congruence. + subst vk. + eapply step_assign. eauto. + econstructor. eapply eval_var_ref_local. eauto. + eapply val_casted_normalized; eauto. assumption. + (* global variable *) + exploit match_env_globals; eauto. intros [A B]. + exploit B; eauto. intros [gv [C D]]. + eapply step_assign. eauto. + econstructor. eapply eval_var_ref_global. auto. + rewrite symbols_preserved. eauto. + eauto. eauto. + eapply val_casted_normalized; eauto. assumption. + (* access mode By_reference *) + congruence. + (* access mode By_nothing *) + congruence. +Qed. + +(**************************** +Lemma call_dest_correct: + forall e m lhs loc ofs optid te, + Csem.eval_lvalue ge e m lhs loc ofs -> + transl_lhs_call (Some lhs) = OK optid -> + match_env e te -> + exists id, + optid = Some id + /\ ofs = Int.zero + /\ match access_mode (typeof lhs) with + | By_value chunk => eval_var_ref tge te id loc chunk + | _ => True + end. +Proof. + intros. revert H0. simpl. caseEq (is_variable lhs); try congruence. + intros id ISV EQ. inv EQ. + exploit is_variable_correct; eauto. intro EQ. + rewrite EQ in H. clear EQ. + exists id. split; auto. + inv H. +(* local variable *) + split. auto. + exploit me_local; eauto. intros [vk [A B]]. + case_eq (access_mode (typeof lhs)); intros; auto. + assert (vk = Vscalar m0). + exploit var_kind_by_value; eauto. congruence. + subst vk. apply eval_var_ref_local; auto. +(* global variable *) + split. auto. + exploit match_env_globals; eauto. intros [A B]. + case_eq (access_mode (typeof lhs)); intros; auto. + exploit B; eauto. intros [gv [C D]]. + eapply eval_var_ref_global; eauto. + rewrite symbols_preserved. auto. +Qed. + +Lemma set_call_dest_correct: + forall ty m loc v m' e te id, + store_value_of_type ty m loc Int.zero v = Some m' -> + match access_mode ty with + | By_value chunk => eval_var_ref tge te id loc chunk + | _ => True + end -> + match_env e te -> + exec_opt_assign tge te m (Some id) v m'. +Proof. + intros. generalize H. unfold store_value_of_type. case_eq (access_mode ty); intros; try congruence. + rewrite H2 in H0. + constructor. econstructor. eauto. auto. +Qed. +**************************) + +(** * Proof of semantic preservation *) + +(** ** Semantic preservation for expressions *) + +(** The proof of semantic preservation for the translation of expressions + relies on simulation diagrams of the following form: +<< + e, le, m, a ------------------- te, le, m, ta + | | + | | + | | + v v + e, le, m, v ------------------- te, le, m, v +>> + Left: evaluation of r-value expression [a] in Clight. + Right: evaluation of its translation [ta] in Csharpminor. + Top (precondition): matching between environments [e], [te], + plus well-typedness of expression [a]. + Bottom (postcondition): the result values [v] + are identical in both evaluations. + + We state these diagrams as the following properties, parameterized + by the Clight evaluation. *) + +Section EXPR. + +Variable e: Clight.env. +Variable le: temp_env. +Variable m: mem. +Variable te: Csharpminor.env. +Hypothesis MENV: match_env e te. + +Lemma transl_expr_lvalue_correct: + (forall a v, + Clight.eval_expr ge e le m a v -> + forall ta (TR: transl_expr a = OK ta) , + Csharpminor.eval_expr tge te le m ta v) +/\(forall a b ofs, + Clight.eval_lvalue ge e le m a b ofs -> + forall ta (TR: transl_lvalue a = OK ta), + Csharpminor.eval_expr tge te le m ta (Vptr b ofs)). +Proof. + apply eval_expr_lvalue_ind; intros; try (monadInv TR). +(* const int *) + apply make_intconst_correct. +(* const float *) + apply make_floatconst_correct. +(* temp var *) + constructor; auto. +(* addrof *) + simpl in TR. auto. +(* sizeof *) + constructor; auto. +(* unop *) + eapply transl_unop_correct; eauto. +(* binop *) + eapply transl_binop_correct; eauto. +(* condition true *) + exploit make_boolean_correct_true. eapply H0; eauto. eauto. + intros [vb [EVAL ISTRUE]]. + eapply eval_Econdition; eauto. apply Val.bool_of_true_val; eauto. + simpl. eauto. +(* condition false *) + exploit make_boolean_correct_false. eapply H0; eauto. eauto. + intros [vb [EVAL ISFALSE]]. + eapply eval_Econdition; eauto. apply Val.bool_of_false_val; eauto. + simpl. eauto. +(* cast *) + eapply make_cast_correct; eauto. +(* rvalue out of lvalue *) + exploit transl_expr_lvalue; eauto. + intros [[id [ty [EQ VARGET]]] | [tb [TRLVAL MKLOAD]]]. + (* Case a is a variable *) + subst a. eapply var_get_correct; eauto. + (* Case a is another lvalue *) + eapply make_load_correct; eauto. +(* var local *) + exploit (me_local _ _ MENV); eauto. + intros [vk [A B]]. + econstructor. eapply eval_var_addr_local. eauto. +(* var global *) + exploit match_env_globals; eauto. intros [A B]. + econstructor. eapply eval_var_addr_global. eauto. + rewrite symbols_preserved. auto. +(* deref *) + simpl in TR. eauto. +(* field struct *) + simpl in TR. rewrite H1 in TR. monadInv TR. + eapply eval_Ebinop; eauto. + apply make_intconst_correct. + simpl. congruence. +(* field union *) + simpl in TR. rewrite H1 in TR. eauto. +Qed. + +Lemma transl_expr_correct: + forall a v, + Clight.eval_expr ge e le m a v -> + forall ta, transl_expr a = OK ta -> + Csharpminor.eval_expr tge te le m ta v. +Proof (proj1 transl_expr_lvalue_correct). + +Lemma transl_lvalue_correct: + forall a b ofs, + Clight.eval_lvalue ge e le m a b ofs -> + forall ta, transl_lvalue a = OK ta -> + Csharpminor.eval_expr tge te le m ta (Vptr b ofs). +Proof (proj2 transl_expr_lvalue_correct). + +Lemma transl_exprlist_correct: + forall al tyl vl, + Clight.eval_exprlist ge e le m al tyl vl -> + forall tal, transl_exprlist al tyl = OK tal -> + Csharpminor.eval_exprlist tge te le m tal vl. +Proof. + induction 1; intros. + monadInv H. constructor. + monadInv H2. constructor. + eapply make_cast_correct. eapply transl_expr_correct; eauto. auto. + eauto. +Qed. + +End EXPR. + +Lemma exit_if_false_true: + forall a ts e le m v te f tk, + exit_if_false a = OK ts -> + Clight.eval_expr ge e le m a v -> + is_true v (typeof a) -> + match_env e te -> + step tge (State f ts tk te le m) E0 (State f Sskip tk te le m). +Proof. + intros. monadInv H. + exploit make_boolean_correct_true. + eapply (transl_expr_correct _ _ _ _ H2 _ _ H0); eauto. + eauto. + intros [vb [EVAL ISTRUE]]. + change Sskip with (if true then Sskip else Sexit 0). + eapply step_ifthenelse; eauto. + apply Val.bool_of_true_val; eauto. +Qed. + +Lemma exit_if_false_false: + forall a ts e le m v te f tk, + exit_if_false a = OK ts -> + Clight.eval_expr ge e le m a v -> + is_false v (typeof a) -> + match_env e te -> + step tge (State f ts tk te le m) E0 (State f (Sexit 0) tk te le m). +Proof. + intros. monadInv H. + exploit make_boolean_correct_false. + eapply (transl_expr_correct _ _ _ _ H2 _ _ H0); eauto. + eauto. + intros [vb [EVAL ISFALSE]]. + change (Sexit 0) with (if false then Sskip else Sexit 0). + eapply step_ifthenelse; eauto. + apply Val.bool_of_false_val; eauto. +Qed. + +(** ** Semantic preservation for statements *) + +(** The simulation diagram for the translation of statements and functions + is a "plus" diagram of the form +<< + I + S1 ------- R1 + | | + t | + | t + v v + S2 ------- R2 + I I +>> + +The invariant [I] is the [match_states] predicate that we now define. +*) + +Inductive match_transl: stmt -> cont -> stmt -> cont -> Prop := + | match_transl_0: forall ts tk, + match_transl ts tk ts tk + | match_transl_1: forall ts tk, + match_transl (Sblock ts) tk ts (Kblock tk). + +Lemma match_transl_step: + forall ts tk ts' tk' f te le m, + match_transl (Sblock ts) tk ts' tk' -> + star step tge (State f ts' tk' te le m) E0 (State f ts (Kblock tk) te le m). +Proof. + intros. inv H. + apply star_one. constructor. + apply star_refl. +Qed. + +Inductive match_cont: type -> nat -> nat -> Clight.cont -> Csharpminor.cont -> Prop := + | match_Kstop: forall tyret nbrk ncnt, + match_cont tyret nbrk ncnt Clight.Kstop Kstop + | match_Kseq: forall tyret nbrk ncnt s k ts tk, + transl_statement tyret nbrk ncnt s = OK ts -> + match_cont tyret nbrk ncnt k tk -> + match_cont tyret nbrk ncnt + (Clight.Kseq s k) + (Kseq ts tk) + | match_Kwhile: forall tyret nbrk ncnt a s k ta ts tk, + exit_if_false a = OK ta -> + transl_statement tyret 1%nat 0%nat s = OK ts -> + match_cont tyret nbrk ncnt k tk -> + match_cont tyret 1%nat 0%nat + (Clight.Kwhile a s k) + (Kblock (Kseq (Sloop (Sseq ta (Sblock ts))) (Kblock tk))) + | match_Kdowhile: forall tyret nbrk ncnt a s k ta ts tk, + exit_if_false a = OK ta -> + transl_statement tyret 1%nat 0%nat s = OK ts -> + match_cont tyret nbrk ncnt k tk -> + match_cont tyret 1%nat 0%nat + (Clight.Kdowhile a s k) + (Kblock (Kseq ta (Kseq (Sloop (Sseq (Sblock ts) ta)) (Kblock tk)))) + | match_Kfor2: forall tyret nbrk ncnt a2 a3 s k ta2 ta3 ts tk, + exit_if_false a2 = OK ta2 -> + transl_statement tyret 0%nat (S ncnt) a3 = OK ta3 -> + transl_statement tyret 1%nat 0%nat s = OK ts -> + match_cont tyret nbrk ncnt k tk -> + match_cont tyret 1%nat 0%nat + (Clight.Kfor2 a2 a3 s k) + (Kblock (Kseq ta3 (Kseq (Sloop (Sseq ta2 (Sseq (Sblock ts) ta3))) (Kblock tk)))) + | match_Kfor3: forall tyret nbrk ncnt a2 a3 s k ta2 ta3 ts tk, + exit_if_false a2 = OK ta2 -> + transl_statement tyret 0%nat (S ncnt) a3 = OK ta3 -> + transl_statement tyret 1%nat 0%nat s = OK ts -> + match_cont tyret nbrk ncnt k tk -> + match_cont tyret 0%nat (S ncnt) + (Clight.Kfor3 a2 a3 s k) + (Kseq (Sloop (Sseq ta2 (Sseq (Sblock ts) ta3))) (Kblock tk)) + | match_Kswitch: forall tyret nbrk ncnt k tk, + match_cont tyret nbrk ncnt k tk -> + match_cont tyret 0%nat (S ncnt) + (Clight.Kswitch k) + (Kblock tk) + | match_Kcall_some: forall tyret nbrk ncnt nbrk' ncnt' f e k id tf te le tk, + transl_function f = OK tf -> + match_env e te -> + match_cont (Clight.fn_return f) nbrk' ncnt' k tk -> + match_cont tyret nbrk ncnt + (Clight.Kcall id f e le k) + (Kcall id tf te le tk). + +Inductive match_states: Clight.state -> Csharpminor.state -> Prop := + | match_state: + forall f nbrk ncnt s k e le m tf ts tk te ts' tk' + (TRF: transl_function f = OK tf) + (TR: transl_statement (Clight.fn_return f) nbrk ncnt s = OK ts) + (MTR: match_transl ts tk ts' tk') + (MENV: match_env e te) + (MK: match_cont (Clight.fn_return f) nbrk ncnt k tk), + match_states (Clight.State f s k e le m) + (State tf ts' tk' te le m) + | match_callstate: + forall fd args k m tfd tk targs tres + (TR: transl_fundef fd = OK tfd) + (MK: match_cont Tvoid 0%nat 0%nat k tk) + (ISCC: Clight.is_call_cont k) + (TY: type_of_fundef fd = Tfunction targs tres) + (VCAST: val_casted_list args targs), + match_states (Clight.Callstate fd args k m) + (Callstate tfd args tk m) + | match_returnstate: + forall res k m tk + (MK: match_cont Tvoid 0%nat 0%nat k tk), + match_states (Clight.Returnstate res k m) + (Returnstate res tk m). + +Remark match_states_skip: + forall f e le te nbrk ncnt k tf tk m, + transl_function f = OK tf -> + match_env e te -> + match_cont (Clight.fn_return f) nbrk ncnt k tk -> + match_states (Clight.State f Clight.Sskip k e le m) (State tf Sskip tk te le m). +Proof. + intros. econstructor; eauto. simpl; reflexivity. constructor. +Qed. + +(** Commutation between label resolution and compilation *) + +Section FIND_LABEL. +Variable lbl: label. +Variable tyret: type. + +Remark exit_if_false_no_label: + forall a s, exit_if_false a = OK s -> forall k, find_label lbl s k = None. +Proof. + intros. unfold exit_if_false in H. monadInv H. simpl. auto. +Qed. + +Lemma transl_find_label: + forall s nbrk ncnt k ts tk + (TR: transl_statement tyret nbrk ncnt s = OK ts) + (MC: match_cont tyret nbrk ncnt k tk), + match Clight.find_label lbl s k with + | None => find_label lbl ts tk = None + | Some (s', k') => + exists ts', exists tk', exists nbrk', exists ncnt', + find_label lbl ts tk = Some (ts', tk') + /\ transl_statement tyret nbrk' ncnt' s' = OK ts' + /\ match_cont tyret nbrk' ncnt' k' tk' + end + +with transl_find_label_ls: + forall ls nbrk ncnt k tls tk + (TR: transl_lbl_stmt tyret nbrk ncnt ls = OK tls) + (MC: match_cont tyret nbrk ncnt k tk), + match Clight.find_label_ls lbl ls k with + | None => find_label_ls lbl tls tk = None + | Some (s', k') => + exists ts', exists tk', exists nbrk', exists ncnt', + find_label_ls lbl tls tk = Some (ts', tk') + /\ transl_statement tyret nbrk' ncnt' s' = OK ts' + /\ match_cont tyret nbrk' ncnt' k' tk' + end. + +Proof. + intro s; case s; intros; try (monadInv TR); simpl. +(* skip *) + auto. +(* assign *) + simpl in TR. destruct (is_variable e); monadInv TR. + unfold var_set in EQ0. destruct (access_mode (typeof e)); inv EQ0. auto. + unfold make_store in EQ2. destruct (access_mode (typeof e)); inv EQ2. auto. +(* set *) + auto. +(* call *) + simpl in TR. destruct (classify_fun (typeof e)); monadInv TR. auto. +(* seq *) + exploit (transl_find_label s0 nbrk ncnt (Clight.Kseq s1 k)); eauto. constructor; eauto. + destruct (Clight.find_label lbl s0 (Clight.Kseq s1 k)) as [[s' k'] | ]. + intros [ts' [tk' [nbrk' [ncnt' [A [B C]]]]]]. + rewrite A. exists ts'; exists tk'; exists nbrk'; exists ncnt'; auto. + intro. rewrite H. eapply transl_find_label; eauto. +(* ifthenelse *) + exploit (transl_find_label s0); eauto. + destruct (Clight.find_label lbl s0 k) as [[s' k'] | ]. + intros [ts' [tk' [nbrk' [ncnt' [A [B C]]]]]]. + rewrite A. exists ts'; exists tk'; exists nbrk'; exists ncnt'; auto. + intro. rewrite H. eapply transl_find_label; eauto. +(* while *) + rewrite (exit_if_false_no_label _ _ EQ). + eapply transl_find_label; eauto. econstructor; eauto. +(* dowhile *) + exploit (transl_find_label s0 1%nat 0%nat (Clight.Kdowhile e s0 k)); eauto. econstructor; eauto. + destruct (Clight.find_label lbl s0 (Kdowhile e s0 k)) as [[s' k'] | ]. + intros [ts' [tk' [nbrk' [ncnt' [A [B C]]]]]]. + rewrite A. exists ts'; exists tk'; exists nbrk'; exists ncnt'; auto. + intro. rewrite H. eapply exit_if_false_no_label; eauto. +(* for *) + rewrite (exit_if_false_no_label _ _ EQ). + exploit (transl_find_label s1 1%nat 0%nat (Kfor2 e s0 s1 k)); eauto. econstructor; eauto. + destruct (Clight.find_label lbl s1 (Kfor2 e s0 s1 k)) as [[s' k'] | ]. + intros [ts' [tk' [nbrk' [ncnt' [A [B C]]]]]]. + rewrite A. exists ts'; exists tk'; exists nbrk'; exists ncnt'; auto. + intro. rewrite H. + eapply transl_find_label; eauto. econstructor; eauto. +(* break *) + auto. +(* continue *) + auto. +(* return *) + simpl in TR. destruct o; monadInv TR. auto. auto. +(* switch *) + eapply transl_find_label_ls with (k := Clight.Kswitch k); eauto. econstructor; eauto. +(* label *) + destruct (ident_eq lbl l). + exists x; exists tk; exists nbrk; exists ncnt; auto. + eapply transl_find_label; eauto. +(* goto *) + auto. + + intro ls; case ls; intros; monadInv TR; simpl. +(* default *) + eapply transl_find_label; eauto. +(* case *) + exploit (transl_find_label s nbrk ncnt (Clight.Kseq (seq_of_labeled_statement l) k)); eauto. + econstructor; eauto. apply transl_lbl_stmt_2; eauto. + destruct (Clight.find_label lbl s (Clight.Kseq (seq_of_labeled_statement l) k)) as [[s' k'] | ]. + intros [ts' [tk' [nbrk' [ncnt' [A [B C]]]]]]. + rewrite A. exists ts'; exists tk'; exists nbrk'; exists ncnt'; auto. + intro. rewrite H. + eapply transl_find_label_ls; eauto. +Qed. + +End FIND_LABEL. + +(** Properties of call continuations *) + +Lemma match_cont_call_cont: + forall tyret' nbrk' ncnt' tyret nbrk ncnt k tk, + match_cont tyret nbrk ncnt k tk -> + match_cont tyret' nbrk' ncnt' (Clight.call_cont k) (call_cont tk). +Proof. + induction 1; simpl; auto. + constructor. + econstructor; eauto. +Qed. + +Lemma match_cont_is_call_cont: + forall tyret nbrk ncnt k tk tyret' nbrk' ncnt', + match_cont tyret nbrk ncnt k tk -> + Clight.is_call_cont k -> + match_cont tyret' nbrk' ncnt' k tk /\ is_call_cont tk. +Proof. + intros. inv H; simpl in H0; try contradiction; simpl. + split; auto; constructor. + split; auto; econstructor; eauto. +Qed. + +(** The simulation proof *) + +Lemma transl_step: + forall S1 t S2, Clight.step ge S1 t S2 -> + forall T1, match_states S1 T1 -> + exists T2, plus step tge T1 t T2 /\ match_states S2 T2. +Proof. + induction 1; intros T1 MST; inv MST. + +(* assign *) + revert TR. simpl. case_eq (is_variable a1); intros; monadInv TR. + exploit is_variable_correct; eauto. intro EQ1. rewrite EQ1 in H. + assert (ts' = ts /\ tk' = tk). + inversion MTR. auto. + subst ts. unfold var_set in EQ0. destruct (access_mode (typeof a1)); congruence. + destruct H4; subst ts' tk'. + econstructor; split. + apply plus_one. eapply var_set_correct; eauto. exists v2; exists (typeof a2); auto. + eapply make_cast_correct; eauto. eapply transl_expr_correct; eauto. + eapply match_states_skip; eauto. + + assert (ts' = ts /\ tk' = tk). + inversion MTR. auto. + subst ts. unfold make_store in EQ2. destruct (access_mode (typeof a1)); congruence. + destruct H4; subst ts' tk'. + econstructor; split. + apply plus_one. eapply make_store_correct; eauto. + exploit transl_lvalue_correct; eauto. + eapply make_cast_correct; eauto. eapply transl_expr_correct; eauto. + eapply match_states_skip; eauto. + +(* set *) + monadInv TR. inv MTR. econstructor; split. + apply plus_one. econstructor. eapply transl_expr_correct; eauto. + eapply match_states_skip; eauto. + +(* call *) + revert TR. simpl. case_eq (classify_fun (typeof a)); try congruence. + intros targs tres CF TR. monadInv TR. inv MTR. + exploit functions_translated; eauto. intros [tfd [FIND TFD]]. + rewrite H in CF. simpl in CF. inv CF. + econstructor; split. + apply plus_one. econstructor; eauto. + exploit transl_expr_correct; eauto. + exploit transl_exprlist_correct; eauto. + eapply transl_fundef_sig1; eauto. + rewrite H3. rewrite H. auto. + econstructor; eauto. + econstructor; eauto. + simpl. auto. + rewrite H3; rewrite H; eauto. + eapply eval_exprlist_casted; eauto. + +(* seq *) + monadInv TR. inv MTR. + econstructor; split. + apply plus_one. constructor. + econstructor; eauto. constructor. + econstructor; eauto. + +(* skip seq *) + monadInv TR. inv MTR. inv MK. + econstructor; split. + apply plus_one. apply step_skip_seq. + econstructor; eauto. constructor. + +(* continue seq *) + monadInv TR. inv MTR. inv MK. + econstructor; split. + apply plus_one. constructor. + econstructor; eauto. simpl. reflexivity. constructor. + +(* break seq *) + monadInv TR. inv MTR. inv MK. + econstructor; split. + apply plus_one. constructor. + econstructor; eauto. simpl. reflexivity. constructor. + +(* ifthenelse true *) + monadInv TR. inv MTR. + exploit make_boolean_correct_true; eauto. + exploit transl_expr_correct; eauto. + intros [v [A B]]. + econstructor; split. + apply plus_one. apply step_ifthenelse with (v := v) (b := true). + auto. apply Val.bool_of_true_val. auto. + econstructor; eauto. constructor. + +(* ifthenelse false *) + monadInv TR. inv MTR. + exploit make_boolean_correct_false; eauto. + exploit transl_expr_correct; eauto. + intros [v [A B]]. + econstructor; split. + apply plus_one. apply step_ifthenelse with (v := v) (b := false). + auto. apply Val.bool_of_false_val. auto. + econstructor; eauto. constructor. + +(* while false *) + monadInv TR. + econstructor; split. + eapply star_plus_trans. eapply match_transl_step; eauto. + eapply plus_left. constructor. + eapply star_left. constructor. + eapply star_left. eapply exit_if_false_false; eauto. + eapply star_left. constructor. + eapply star_left. constructor. + apply star_one. constructor. + reflexivity. reflexivity. reflexivity. reflexivity. reflexivity. traceEq. + eapply match_states_skip; eauto. + +(* while true *) + monadInv TR. + econstructor; split. + eapply star_plus_trans. eapply match_transl_step; eauto. + eapply plus_left. constructor. + eapply star_left. constructor. + eapply star_left. eapply exit_if_false_true; eauto. + eapply star_left. constructor. + apply star_one. constructor. + reflexivity. reflexivity. reflexivity. reflexivity. traceEq. + econstructor; eauto. constructor. + econstructor; eauto. + +(* skip or continue while *) + assert ((ts' = Sskip \/ ts' = Sexit ncnt) /\ tk' = tk). + destruct H; subst x; monadInv TR; inv MTR; auto. + destruct H0. inv MK. + econstructor; split. + eapply plus_left. + destruct H0; subst ts'; constructor. + apply star_one. constructor. traceEq. + econstructor; eauto. + simpl. rewrite H8; simpl. rewrite H10; simpl. reflexivity. + constructor. + +(* break while *) + monadInv TR. inv MTR. inv MK. + econstructor; split. + eapply plus_left. constructor. + eapply star_left. constructor. + apply star_one. constructor. + reflexivity. traceEq. + eapply match_states_skip; eauto. + +(* dowhile *) + monadInv TR. + econstructor; split. + eapply star_plus_trans. eapply match_transl_step; eauto. + eapply plus_left. constructor. + eapply star_left. constructor. + apply star_one. constructor. + reflexivity. reflexivity. traceEq. + econstructor; eauto. constructor. + econstructor; eauto. + +(* skip or continue dowhile false *) + assert ((ts' = Sskip \/ ts' = Sexit ncnt) /\ tk' = tk). + destruct H; subst x; monadInv TR; inv MTR; auto. + destruct H2. inv MK. + econstructor; split. + eapply plus_left. destruct H2; subst ts'; constructor. + eapply star_left. constructor. + eapply star_left. eapply exit_if_false_false; eauto. + eapply star_left. constructor. + apply star_one. constructor. + reflexivity. reflexivity. reflexivity. traceEq. + eapply match_states_skip; eauto. + +(* skip or continue dowhile true *) + assert ((ts' = Sskip \/ ts' = Sexit ncnt) /\ tk' = tk). + destruct H; subst x; monadInv TR; inv MTR; auto. + destruct H2. inv MK. + econstructor; split. + eapply plus_left. destruct H2; subst ts'; constructor. + eapply star_left. constructor. + eapply star_left. eapply exit_if_false_true; eauto. + apply star_one. constructor. + reflexivity. reflexivity. traceEq. + econstructor; eauto. + simpl. rewrite H10; simpl. rewrite H12; simpl. reflexivity. constructor. + +(* break dowhile *) + monadInv TR. inv MTR. inv MK. + econstructor; split. + eapply plus_left. constructor. + eapply star_left. constructor. + eapply star_left. constructor. + apply star_one. constructor. + reflexivity. reflexivity. traceEq. + eapply match_states_skip; eauto. + +(* for false *) + monadInv TR. + econstructor; split. + eapply star_plus_trans. eapply match_transl_step; eauto. + eapply plus_left. constructor. + eapply star_left. constructor. + eapply star_left. eapply exit_if_false_false; eauto. + eapply star_left. constructor. + eapply star_left. constructor. + apply star_one. constructor. + reflexivity. reflexivity. reflexivity. reflexivity. reflexivity. reflexivity. + eapply match_states_skip; eauto. + +(* for true *) + monadInv TR. + econstructor; split. + eapply star_plus_trans. eapply match_transl_step; eauto. + eapply plus_left. constructor. + eapply star_left. constructor. + eapply star_left. eapply exit_if_false_true; eauto. + eapply star_left. constructor. + eapply star_left. constructor. + apply star_one. constructor. + reflexivity. reflexivity. reflexivity. reflexivity. reflexivity. reflexivity. + econstructor; eauto. constructor. + econstructor; eauto. + +(* skip or continue for2 *) + assert ((ts' = Sskip \/ ts' = Sexit ncnt) /\ tk' = tk). + destruct H; subst x; monadInv TR; inv MTR; auto. + destruct H0. inv MK. + econstructor; split. + eapply plus_left. destruct H0; subst ts'; constructor. + apply star_one. constructor. reflexivity. + econstructor; eauto. constructor. + econstructor; eauto. + +(* break for2 *) + monadInv TR. inv MTR. inv MK. + econstructor; split. + eapply plus_left. constructor. + eapply star_left. constructor. + eapply star_left. constructor. + apply star_one. constructor. + reflexivity. reflexivity. traceEq. + eapply match_states_skip; eauto. + +(* skip for3 *) + monadInv TR. inv MTR. inv MK. + econstructor; split. + apply plus_one. constructor. + econstructor; eauto. + simpl. rewrite H6; simpl. rewrite H8; simpl. rewrite H9; simpl. reflexivity. + constructor. + +(* break for3 *) + monadInv TR. inv MTR. inv MK. + econstructor; split. + eapply plus_left. constructor. apply star_one. constructor. + econstructor; eauto. + eapply match_states_skip; eauto. + +(* return none *) + monadInv TR. inv MTR. + econstructor; split. + apply plus_one. constructor. monadInv TRF. simpl. rewrite H. auto. + eapply match_env_free_blocks; eauto. + econstructor; eauto. + eapply match_cont_call_cont. eauto. + +(* return some *) + monadInv TR. inv MTR. + econstructor; split. + apply plus_one. constructor. monadInv TRF. simpl. + unfold opttyp_of_type. destruct (Clight.fn_return f); try congruence. + inv H0. inv H3. inv H3. + eapply make_cast_correct. eapply transl_expr_correct; eauto. eauto. + eapply match_env_free_blocks; eauto. + econstructor; eauto. + eapply match_cont_call_cont. eauto. + +(* skip call *) + monadInv TR. inv MTR. + exploit match_cont_is_call_cont; eauto. intros [A B]. + econstructor; split. + apply plus_one. apply step_skip_call. auto. + monadInv TRF. simpl. rewrite H0. auto. + eapply match_env_free_blocks; eauto. + constructor. eauto. + +(* switch *) + monadInv TR. + exploit transl_expr_correct; eauto. intro EV. + econstructor; split. + eapply star_plus_trans. eapply match_transl_step; eauto. + apply plus_one. econstructor. eauto. traceEq. + econstructor; eauto. + apply transl_lbl_stmt_2. apply transl_lbl_stmt_1. eauto. + constructor. + econstructor. eauto. + +(* skip or break switch *) + assert ((ts' = Sskip \/ ts' = Sexit nbrk) /\ tk' = tk). + destruct H; subst x; monadInv TR; inv MTR; auto. + destruct H0. inv MK. + econstructor; split. + apply plus_one. destruct H0; subst ts'; constructor. + eapply match_states_skip; eauto. + + +(* continue switch *) + monadInv TR. inv MTR. inv MK. + econstructor; split. + apply plus_one. constructor. + econstructor; eauto. simpl. reflexivity. constructor. + +(* label *) + monadInv TR. inv MTR. + econstructor; split. + apply plus_one. constructor. + econstructor; eauto. constructor. + +(* goto *) + monadInv TR. inv MTR. + generalize TRF. unfold transl_function. intro TRF'. monadInv TRF'. + exploit (transl_find_label lbl). eexact EQ0. eapply match_cont_call_cont. eauto. + rewrite H. + intros [ts' [tk'' [nbrk' [ncnt' [A [B C]]]]]]. + econstructor; split. + apply plus_one. constructor. simpl. eexact A. + econstructor; eauto. constructor. + +(* internal function *) + monadInv TR. monadInv EQ. + exploit match_cont_is_call_cont; eauto. intros [A B]. + exploit match_env_alloc_variables; eauto. + apply match_env_empty. + apply transl_fn_variables. eauto. eauto. + intros [te1 [C D]]. + econstructor; split. + apply plus_one. econstructor. + eapply transl_names_norepet; eauto. + eexact C. eapply bind_parameters_match; eauto. + simpl in TY. unfold type_of_function in TY. congruence. + econstructor; eauto. + unfold transl_function. rewrite EQ0; simpl. rewrite EQ; simpl. rewrite EQ1; auto. + constructor. + +(* external function *) + simpl in TR. + destruct (list_typ_eq (sig_args (ef_sig ef)) (typlist_of_typelist targs) && + opt_typ_eq (sig_res (ef_sig ef)) (opttyp_of_type tres)); + monadInv TR. + exploit match_cont_is_call_cont; eauto. intros [A B]. + econstructor; split. + apply plus_one. constructor. eauto. + eapply external_call_symbols_preserved_2; eauto. + exact symbols_preserved. + eexact (Genv.find_var_info_transf_partial2 transl_fundef transl_globvar _ TRANSL). + eexact (Genv.find_var_info_rev_transf_partial2 transl_fundef transl_globvar _ TRANSL). + econstructor; eauto. + +(* returnstate *) + inv MK. + econstructor; split. + apply plus_one. constructor. + econstructor; eauto. simpl; reflexivity. constructor. + inv MK. + econstructor; split. + apply plus_one. constructor. + econstructor; eauto. simpl; reflexivity. constructor. +Qed. + +Lemma transl_initial_states: + forall S t S', Clight.initial_state prog S -> Clight.step ge S t S' -> + exists R, initial_state tprog R /\ match_states S R. +Proof. + intros. inv H. + exploit function_ptr_translated; eauto. intros [tf [A B]]. + assert (C: Genv.find_symbol tge (prog_main tprog) = Some b). + rewrite symbols_preserved. replace (prog_main tprog) with (prog_main prog). + exact H2. symmetry. unfold transl_program in TRANSL. + eapply transform_partial_program2_main; eauto. + assert (funsig tf = signature_of_type Tnil (Tint I32 Signed)). + eapply transl_fundef_sig2; eauto. + econstructor; split. + econstructor; eauto. eapply Genv.init_mem_transf_partial2; eauto. + econstructor; eauto. constructor; auto. exact I. red; auto. +Qed. + +Lemma transl_final_states: + forall S R r, + match_states S R -> Clight.final_state S r -> final_state R r. +Proof. + intros. inv H0. inv H. inv MK. constructor. +Qed. + +Theorem transl_program_correct: + forall (beh: program_behavior), + not_wrong beh -> Clight.exec_program prog beh -> + Csharpminor.exec_program tprog beh. +Proof. + set (order := fun (S1 S2: Clight.state) => False). + assert (WF: well_founded order). + unfold order; red. intros. constructor; intros. contradiction. + assert (transl_step': + forall S1 t S2, Clight.step ge S1 t S2 -> + forall T1, match_states S1 T1 -> + exists T2, + (plus step tge T1 t T2 \/ star step tge T1 t T2 /\ order S2 S1) + /\ match_states S2 T2). + intros. exploit transl_step; eauto. intros [T2 [A B]]. + exists T2; split. auto. auto. + intros. inv H0. +(* Terminates *) + assert (exists t1, exists s1, Clight.step (Genv.globalenv prog) s t1 s1). + inv H3. inv H2. inv H1. exists t1; exists s2; auto. + destruct H0 as [t1 [s1 ST]]. + exploit transl_initial_states; eauto. intros [R [A B]]. + exploit simulation_star_star; eauto. intros [R' [C D]]. + econstructor; eauto. eapply transl_final_states; eauto. +(* Diverges *) + assert (exists t1, exists s1, Clight.step (Genv.globalenv prog) s t1 s1). + inv H2. inv H3. exists E0; exists s2; auto. exists t1; exists s2; auto. + destruct H0 as [t1 [s1 ST]]. + exploit transl_initial_states; eauto. intros [R [A B]]. + exploit simulation_star_star; eauto. intros [R' [C D]]. + econstructor; eauto. eapply simulation_star_forever_silent; eauto. +(* Reacts *) + assert (exists t1, exists s1, Clight.step (Genv.globalenv prog) s t1 s1). + inv H2. inv H0. congruence. exists t1; exists s0; auto. + destruct H0 as [t1 [s1 ST]]. + exploit transl_initial_states; eauto. intros [R [A B]]. + exploit simulation_star_forever_reactive; eauto. + intro C. + econstructor; eauto. +(* Goes wrong *) + contradiction. contradiction. +Qed. + +End CORRECTNESS. diff --git a/cfrontend/Cshmgenproof1.v b/cfrontend/Cshmgenproof1.v deleted file mode 100644 index 73a3824..0000000 --- a/cfrontend/Cshmgenproof1.v +++ /dev/null @@ -1,292 +0,0 @@ -(* *********************************************************************) -(* *) -(* The Compcert verified compiler *) -(* *) -(* Xavier Leroy, INRIA Paris-Rocquencourt *) -(* *) -(* Copyright Institut National de Recherche en Informatique et en *) -(* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) -(* *) -(* *********************************************************************) - -(** * Correctness of the C front end, part 1: syntactic properties *) - -Require Import Coqlib. -Require Import Errors. -Require Import Maps. -Require Import Integers. -Require Import Floats. -Require Import AST. -Require Import Values. -Require Import Events. -Require Import Memory. -Require Import Globalenvs. -Require Import Csyntax. -Require Import Csem. -Require Import Ctyping. -Require Import Cminor. -Require Import Csharpminor. -Require Import Cshmgen. - -(** * Properties of operations over types *) - -Remark type_of_chunk_of_type: - forall ty chunk, - chunk_of_type ty = OK chunk -> - type_of_chunk chunk = typ_of_type ty. -Proof. - intros. unfold chunk_of_type in H. destruct ty; simpl in H; try monadInv H. - destruct i; destruct s; monadInv H; reflexivity. - destruct f; monadInv H; reflexivity. - reflexivity. reflexivity. -Qed. - -Remark transl_params_types: - forall p tp, - transl_params p = OK tp -> - map type_of_chunk (map param_chunk tp) = typlist_of_typelist (type_of_params p). -Proof. - induction p; simpl; intros. - inv H. auto. - destruct a as [id ty]. generalize H; clear H. case_eq (chunk_of_type ty); intros. - monadInv H0. simpl. f_equal; auto. apply type_of_chunk_of_type; auto. - inv H0. -Qed. - -Lemma transl_fundef_sig1: - forall tenv f tf args res, - wt_fundef tenv f -> - transl_fundef f = OK tf -> - classify_fun (type_of_fundef f) = fun_case_f args res -> - funsig tf = signature_of_type args res. -Proof. - intros. inv H; monadInv H0. - monadInv EQ. simpl. - simpl in H1. inversion H1. - unfold fn_sig; simpl. unfold signature_of_type. f_equal. - apply transl_params_types; auto. - simpl. simpl in H1. inv H1. destruct (ef_sig ef); simpl in *. - unfold signature_of_type. congruence. -Qed. - -Lemma transl_fundef_sig2: - forall tenv f tf args res, - wt_fundef tenv f -> - transl_fundef f = OK tf -> - type_of_fundef f = Tfunction args res -> - funsig tf = signature_of_type args res. -Proof. - intros. eapply transl_fundef_sig1; eauto. - rewrite H1; reflexivity. -Qed. - -Lemma var_kind_by_value: - forall ty chunk, - access_mode ty = By_value chunk -> - var_kind_of_type ty = OK(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 = OK 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. - -(** * Properties of the translation functions *) - -Lemma map_partial_names: - forall (A B: Type) (f: A -> res B) - (l: list (ident * A)) (tl: list (ident * B)), - map_partial prefix_var_name f l = OK 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 (map_partial prefix_var_name f l); simpl; intros; try congruence. - inv H0. simpl. decEq. auto. -Qed. - -Lemma map_partial_append: - forall (A B: Type) (f: A -> res B) - (l1 l2: list (ident * A)) (tl1 tl2: list (ident * B)), - map_partial prefix_var_name f l1 = OK tl1 -> - map_partial prefix_var_name f l2 = OK tl2 -> - map_partial prefix_var_name f (l1 ++ l2) = OK (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 (map_partial prefix_var_name f l1); simpl; intros; try congruence. - inv H0. rewrite (IHl1 _ _ _ H H1). auto. -Qed. - -Lemma transl_params_names: - forall vars tvars, - transl_params vars = OK tvars -> - List.map param_name tvars = Ctyping.var_names vars. -Proof. - exact (map_partial_names _ _ chunk_of_type). -Qed. - -Lemma transl_vars_names: - forall vars tvars, - transl_vars vars = OK tvars -> - List.map variable_name tvars = Ctyping.var_names vars. -Proof. - exact (map_partial_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 = OK tparams -> - transl_vars vars = OK 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 = OK tl1 -> transl_vars l2 = OK tl2 -> - transl_vars (l1 ++ l2) = OK (tl1 ++ tl2). -Proof. - exact (map_partial_append _ _ var_kind_of_type). -Qed. - -Lemma transl_params_vars: - forall params tparams, - transl_params params = OK tparams -> - transl_vars params = - OK (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); simpl; intros; try congruence. - inv 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 = OK tparams -> - transl_vars vars = OK tvars -> - let f := Csharpminor.mkfunction sg tparams tvars body in - transl_vars (params ++ vars) = OK (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 m a ty loc ofs ta, - Csem.eval_lvalue ge e m (Expr a ty) loc ofs -> - transl_expr (Expr a ty) = OK ta -> - (exists id, a = Csyntax.Evar id /\ var_get id ty = OK ta) \/ - (exists tb, transl_lvalue (Expr a ty) = OK tb /\ - make_load tb ty = OK ta). -Proof. - intros. inversion H; subst; clear H; simpl in H0. - left; exists id; auto. - left; exists id; auto. - monadInv H0. right. exists x; split; auto. - rewrite H4 in H0. monadInv H0. right. - exists (Ebinop Oadd x (make_intconst (Int.repr x0))). split; auto. - simpl. rewrite H4. rewrite EQ. rewrite EQ1. auto. - rewrite H6 in H0. monadInv H0. right. - exists x; split; auto. - simpl. rewrite H6. auto. -Qed. - -Lemma is_Sskip_true: - forall (A: Type) (a b: A), - (if is_Sskip Csyntax.Sskip then a else b) = a. -Proof. - intros. destruct (is_Sskip Csyntax.Sskip); congruence. -Qed. - -Lemma is_Sskip_false: - forall (A: Type) (a b: A) s, - s <> Csyntax.Sskip -> - (if is_Sskip s then a else b) = b. -Proof. - intros. destruct (is_Sskip s); congruence. -Qed. - -(** Properties of labeled statements *) - -Lemma transl_lbl_stmt_1: - forall nbrk ncnt n sl tsl, - transl_lbl_stmt nbrk ncnt sl = OK tsl -> - transl_lbl_stmt nbrk ncnt (Csem.select_switch n sl) = OK (select_switch n tsl). -Proof. - induction sl; intros. - monadInv H. simpl. rewrite EQ. auto. - generalize H; intro TR. monadInv TR. simpl. - destruct (Int.eq i n). auto. auto. -Qed. - -Lemma transl_lbl_stmt_2: - forall nbrk ncnt sl tsl, - transl_lbl_stmt nbrk ncnt sl = OK tsl -> - transl_statement nbrk ncnt (seq_of_labeled_statement sl) = OK (seq_of_lbl_stmt tsl). -Proof. - induction sl; intros. - monadInv H. simpl. auto. - monadInv H. simpl. rewrite EQ; simpl. rewrite (IHsl _ EQ1). simpl. auto. -Qed. - -Lemma wt_select_switch: - forall n tyenv sl, - wt_lblstmts tyenv sl -> - wt_lblstmts tyenv (Csem.select_switch n sl). -Proof. - induction 1; simpl. - constructor; auto. - destruct (Int.eq n0 n). constructor; auto. auto. -Qed. - -Lemma wt_seq_of_labeled_statement: - forall tyenv sl, - wt_lblstmts tyenv sl -> - wt_stmt tyenv (seq_of_labeled_statement sl). -Proof. - induction 1; simpl. - auto. - constructor; auto. -Qed. diff --git a/cfrontend/Cshmgenproof2.v b/cfrontend/Cshmgenproof2.v deleted file mode 100644 index e58570b..0000000 --- a/cfrontend/Cshmgenproof2.v +++ /dev/null @@ -1,394 +0,0 @@ -(* *********************************************************************) -(* *) -(* The Compcert verified compiler *) -(* *) -(* Xavier Leroy, INRIA Paris-Rocquencourt *) -(* *) -(* Copyright Institut National de Recherche en Informatique et en *) -(* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) -(* *) -(* *********************************************************************) - -(** * Correctness of the C front end, part 2: Csharpminor construction functions *) - -Require Import Coqlib. -Require Import Errors. -Require Import Maps. -Require Import Integers. -Require Import Floats. -Require Import AST. -Require Import Values. -Require Import Events. -Require Import Memory. -Require Import Globalenvs. -Require Import Csyntax. -Require Import Csem. -Require Import Ctyping. -Require Import Cminor. -Require Import Csharpminor. -Require Import Cshmgen. -Require Import Cshmgenproof1. - -Section CONSTRUCTORS. - -Variable globenv : genv * gvarenv. -Let ge := fst globenv. - -(** * Correctness of Csharpminor construction functions *) - -Lemma make_intconst_correct: - forall n e m, - eval_expr globenv e m (make_intconst n) (Vint n). -Proof. - intros. unfold make_intconst. econstructor. reflexivity. -Qed. - -Lemma make_floatconst_correct: - forall n e m, - eval_expr globenv e m (make_floatconst n) (Vfloat n). -Proof. - intros. unfold make_floatconst. econstructor. reflexivity. -Qed. - -Hint Resolve make_intconst_correct make_floatconst_correct - eval_Eunop eval_Ebinop: 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 e m a v ty, - eval_expr globenv e m a v -> - is_true v ty -> - exists vb, - eval_expr globenv e m (make_boolean a ty) 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 eval_Ebinop; eauto with cshm. - inversion VTRUE; simpl. - rewrite Float.cmp_ne_eq. rewrite H1. auto. - apply Vtrue_is_true. -Qed. - -Lemma make_boolean_correct_false: - forall e m a v ty, - eval_expr globenv e m a v -> - is_false v ty -> - exists vb, - eval_expr globenv e m (make_boolean a ty) 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 eval_Ebinop; eauto with cshm. - inversion VFALSE; simpl. - rewrite Float.cmp_ne_eq. rewrite H1. auto. - apply Vfalse_is_false. -Qed. - -Lemma make_neg_correct: - forall a tya c va v e m, - sem_neg va tya = Some v -> - make_neg a tya = OK c -> - eval_expr globenv e m a va -> - eval_expr globenv e m c v. -Proof. - intros until m; intro SEM. unfold make_neg. - functional inversion SEM; intros. - inversion H4. eapply eval_Eunop; eauto with cshm. - inversion H4. eauto with cshm. -Qed. - -Lemma make_notbool_correct: - forall a tya c va v e m, - sem_notbool va tya = Some v -> - make_notbool a tya = c -> - eval_expr globenv e m a va -> - eval_expr globenv e m c v. -Proof. - intros until m; intro SEM. unfold make_notbool. - functional inversion SEM; intros; rewrite H0 in H4; inversion H4; simpl; - eauto with cshm. -Qed. - -Lemma make_notint_correct: - forall a tya c va v e m, - sem_notint va = Some v -> - make_notint a tya = c -> - eval_expr globenv e m a va -> - eval_expr globenv e m c v. -Proof. - intros until m; intro SEM. unfold make_notint. - functional inversion SEM; intros. - inversion H2; eauto with cshm. -Qed. - -Lemma make_fabs_correct: - forall a tya c va v e m, - sem_fabs va = Some v -> - make_fabs a tya = c -> - eval_expr globenv e m a va -> - eval_expr globenv e m c v. -Proof. - intros until m; intro SEM. unfold make_fabs. - functional inversion SEM; intros. - inversion H2; eauto with cshm. -Qed. - -Definition binary_constructor_correct - (make: expr -> type -> expr -> type -> res expr) - (sem: val -> type -> val -> type -> option val): Prop := - forall a tya b tyb c va vb v e m, - sem va tya vb tyb = Some v -> - make a tya b tyb = OK c -> - eval_expr globenv e m a va -> - eval_expr globenv e m b vb -> - eval_expr globenv e m c v. - -Definition binary_constructor_correct' - (make: expr -> type -> expr -> type -> res expr) - (sem: val -> val -> option val): Prop := - forall a tya b tyb c va vb v e m, - sem va vb = Some v -> - make a tya b tyb = OK c -> - eval_expr globenv e m a va -> - eval_expr globenv e m b vb -> - eval_expr globenv e m c v. - -Lemma make_add_correct: binary_constructor_correct make_add sem_add. -Proof. - red; intros until m. intro SEM. unfold make_add. - functional inversion SEM; rewrite H0; intros. - inversion H7. eauto with cshm. - inversion H7. eauto with cshm. - inversion H7. - eapply eval_Ebinop. eauto. - eapply eval_Ebinop. eauto with cshm. eauto. - simpl. reflexivity. reflexivity. - inversion H7. - eapply eval_Ebinop. eauto. - eapply eval_Ebinop. eauto with cshm. eauto. - simpl. reflexivity. simpl. reflexivity. -Qed. - -Lemma make_sub_correct: binary_constructor_correct make_sub sem_sub. -Proof. - red; intros until m. intro SEM. unfold make_sub. - functional inversion SEM; rewrite H0; intros; - inversion H7; eauto with cshm. - eapply eval_Ebinop. eauto. - eapply eval_Ebinop. eauto with cshm. eauto. - simpl. reflexivity. reflexivity. - inversion H9. eapply eval_Ebinop. - eapply eval_Ebinop; eauto. - simpl. unfold eq_block; rewrite H3. reflexivity. - eauto with cshm. simpl. rewrite H8. reflexivity. -Qed. - -Lemma make_mul_correct: binary_constructor_correct make_mul sem_mul. -Proof. - red; intros until m. 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 m. intro SEM. unfold make_div. - functional inversion SEM; rewrite H0; intros. - inversion H8. eapply eval_Ebinop; eauto with cshm. - simpl. rewrite H7; auto. - inversion H8. eapply eval_Ebinop; 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 m. intro SEM. unfold make_mod. - functional inversion SEM; rewrite H0; intros. - inversion H8. eapply eval_Ebinop; eauto with cshm. - simpl. rewrite H7; auto. - inversion H8. eapply eval_Ebinop; eauto with cshm. - simpl. rewrite H7; auto. -Qed. - -Lemma make_and_correct: binary_constructor_correct' make_and sem_and. -Proof. - red; intros until m. 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 m. 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 m. 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 m. intro SEM. unfold make_shl. - functional inversion SEM. intros. inversion H5. - eapply eval_Ebinop; eauto with cshm. - simpl. rewrite H4. auto. -Qed. - -Lemma make_shr_correct: binary_constructor_correct make_shr sem_shr. -Proof. - red; intros until m. intro SEM. unfold make_shr. - functional inversion SEM; intros; rewrite H0 in H8; inversion H8. - eapply eval_Ebinop; eauto with cshm. - simpl; rewrite H7; auto. - eapply eval_Ebinop; eauto with cshm. - simpl; rewrite H7; auto. -Qed. - -Lemma make_cmp_correct: - forall cmp a tya b tyb c va vb v e m, - sem_cmp cmp va tya vb tyb m = Some v -> - make_cmp cmp a tya b tyb = OK c -> - eval_expr globenv e m a va -> - eval_expr globenv e m b vb -> - eval_expr globenv e m c v. -Proof. - intros until m. intro SEM. unfold make_cmp. - functional inversion SEM; rewrite H0; intros. - (* I32unsi *) - inversion H8. eauto with cshm. - (* ipip int int *) - inversion H8. eauto with cshm. - (* ipip ptr ptr *) - inversion H10. eapply eval_Ebinop; eauto with cshm. - simpl. rewrite H3. unfold eq_block. rewrite H9. auto. - inversion H10. eapply eval_Ebinop; eauto with cshm. - simpl. rewrite H3. unfold eq_block. rewrite H9. auto. - (* ipip ptr int *) - inversion H9. eapply eval_Ebinop; eauto with cshm. - simpl. unfold eval_compare_null. rewrite H8. auto. - (* ipip int ptr *) - inversion H9. eapply eval_Ebinop; eauto with cshm. - simpl. unfold eval_compare_null. rewrite H8. auto. - (* ff *) - inversion H8. eauto with cshm. -Qed. - -Lemma transl_unop_correct: - forall op a tya c va v e m, - transl_unop op a tya = OK c -> - sem_unary_operation op va tya = Some v -> - eval_expr globenv e m a va -> - eval_expr globenv e m c 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. - eapply make_fabs_correct with (tya := tya); eauto. congruence. -Qed. - -Lemma transl_binop_correct: - forall op a tya b tyb c va vb v e m, - transl_binop op a tya b tyb = OK c -> - sem_binary_operation op va tya vb tyb m = Some v -> - eval_expr globenv e m a va -> - eval_expr globenv e m b vb -> - eval_expr globenv e m c 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 e m a v ty1 ty2 v', - eval_expr globenv e m a v -> - cast v ty1 ty2 v' -> - eval_expr globenv e m (make_cast ty1 ty2 a) v'. -Proof. - unfold make_cast, make_cast1, make_cast2. - intros until v'; intros EVAL CAST. - inversion CAST; clear CAST; subst. - (* cast_int_int *) - destruct sz2; destruct si2; repeat econstructor; eauto with cshm. - (* cast_float_int *) - destruct sz2; destruct si2; unfold make_intoffloat; repeat econstructor; eauto with cshm; simpl; auto. - (* cast_int_float *) - destruct sz2; destruct si1; unfold make_floatofint; repeat econstructor; eauto with cshm; simpl; auto. - (* cast_float_float *) - destruct sz2; repeat econstructor; eauto with cshm. - (* neutral, ptr *) - inversion H0; auto; inversion H; auto. - (* neutral, int *) - inversion H0; auto; inversion H; auto. -Qed. - -Lemma make_load_correct: - forall addr ty code b ofs v e m, - make_load addr ty = OK code -> - eval_expr globenv e m addr (Vptr b ofs) -> - load_value_of_type ty m b ofs = Some v -> - eval_expr globenv e m code v. -Proof. - unfold make_load, load_value_of_type. - intros until m; 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 m b ofs v m' f k, - make_store addr ty rhs = OK code -> - eval_expr globenv e m addr (Vptr b ofs) -> - eval_expr globenv e m rhs v -> - store_value_of_type ty m b ofs v = Some m' -> - step globenv (State f code k e m) E0 (State f Sskip k e m'). -Proof. - unfold make_store, store_value_of_type. - intros until k; intros MKSTORE EV1 EV2 STVAL. - destruct (access_mode ty); inversion MKSTORE. - (* access_mode ty = By_value m *) - eapply step_store; eauto. -Qed. - -End CONSTRUCTORS. - diff --git a/cfrontend/Cshmgenproof3.v b/cfrontend/Cshmgenproof3.v deleted file mode 100644 index 0e9e5b1..0000000 --- a/cfrontend/Cshmgenproof3.v +++ /dev/null @@ -1,1667 +0,0 @@ -(* *********************************************************************) -(* *) -(* The Compcert verified compiler *) -(* *) -(* Xavier Leroy, INRIA Paris-Rocquencourt *) -(* *) -(* Copyright Institut National de Recherche en Informatique et en *) -(* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) -(* *) -(* *********************************************************************) - -(** * Correctness of the C front end, part 3: semantic preservation *) - -Require Import Coqlib. -Require Import Errors. -Require Import Maps. -Require Import Integers. -Require Import Floats. -Require Import AST. -Require Import Values. -Require Import Events. -Require Import Memory. -Require Import Globalenvs. -Require Import Smallstep. -Require Import Csyntax. -Require Import Csem. -Require Import Ctyping. -Require Import Cminor. -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 = OK tprog. - -Let ge := Genv.globalenv prog. -Let tge := Genv.globalenv tprog. -Let tgvare : gvarenv := global_var_env tprog. -Let tgve := (tge, tgvare). - -Lemma symbols_preserved: - forall s, Genv.find_symbol tge s = Genv.find_symbol ge s. -Proof (Genv.find_symbol_transf_partial2 transl_fundef transl_globvar _ TRANSL). - -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 = OK tf. -Proof (Genv.find_funct_transf_partial2 transl_fundef transl_globvar _ TRANSL). - -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 = OK tf. -Proof (Genv.find_funct_ptr_transf_partial2 transl_fundef transl_globvar _ TRANSL). - -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)) 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)) prog b f). - intros. apply wt_program_funct with id. assumption. - assumption. -Qed. - -(** * Matching between environments *) - -(** In this section, we define a matching relation between - a Clight local environment and a Csharpminor local environment, - parameterized by an assignment of types to the Clight variables. *) - -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, ty) -> - exists vk, - tyenv!id = Some ty - /\ var_kind_of_type ty = OK vk - /\ te!id = Some (b, vk); - me_local_inv: - forall id b vk, - te!id = Some (b, vk) -> exists ty, e!id = Some(b, ty); - 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)) - }. - -Lemma match_env_same_blocks: - forall tyenv e te, - match_env tyenv e te -> - blocks_of_env te = Csem.blocks_of_env e. -Proof. - intros. - set (R := fun (x: (block * type)) (y: (block * var_kind)) => - match x, y with - | (b1, ty), (b2, vk) => b2 = b1 /\ var_kind_of_type ty = OK vk - end). - assert (list_forall2 - (fun i_x i_y => fst i_x = fst i_y /\ R (snd i_x) (snd i_y)) - (PTree.elements e) (PTree.elements te)). - apply PTree.elements_canonical_order. - intros id [b ty] GET. exploit me_local; eauto. intros [vk [A [B C]]]. - exists (b, vk); split; auto. red. auto. - intros id [b vk] GET. - exploit me_local_inv; eauto. intros [ty A]. - exploit me_local; eauto. intros [vk' [B [C D]]]. - assert (vk' = vk) by congruence. subst vk'. - exists (b, ty); split; auto. red. auto. - - unfold blocks_of_env, Csem.blocks_of_env. - generalize H0. induction 1. auto. - simpl. f_equal; auto. - unfold block_of_binding, Csem.block_of_binding. - destruct a1 as [id1 [blk1 ty1]]. destruct b1 as [id2 [blk2 vk2]]. - simpl in *. destruct H1 as [A [B C]]. subst blk2 id2. f_equal. - apply sizeof_var_kind_of_type. auto. -Qed. - -Lemma match_env_free_blocks: - forall tyenv e te m m', - match_env tyenv e te -> - Mem.free_list m (Csem.blocks_of_env e) = Some m' -> - Mem.free_list m (blocks_of_env te) = Some m'. -Proof. - intros. rewrite (match_env_same_blocks _ _ _ H). auto. -Qed. - -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 b. repeat rewrite PTree.gempty. congruence. - intros until vk. rewrite PTree.gempty. congruence. - intros. split. - apply PTree.gempty. - intros. red in H. eauto. -Qed. - -(** The following lemmas establish the [match_env] invariant at - the beginning of a function invocation, after allocation of - local variables and initialization of the parameters. *) - -Lemma match_env_alloc_variables: - forall e1 m1 vars e2 m2, - Csem.alloc_variables e1 m1 vars e2 m2 -> - forall tyenv te1 tvars, - match_env tyenv e1 te1 -> - transl_vars vars = OK tvars -> - exists te2, - Csharpminor.alloc_variables te1 m1 tvars te2 m2 - /\ 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); simpl; [intros vk VK | congruence]. - caseEq (transl_vars vars); simpl; [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, ty) e) te2). - inversion H1. unfold te2, add_var. constructor. - (* me_local *) - intros until ty0. simpl. repeat rewrite PTree.gsspec. - destruct (peq id0 id); intros. - inv H3. exists vk; intuition. - auto. - (* me_local_inv *) - intros until vk0. repeat rewrite PTree.gsspec. - destruct (peq id0 id); intros. exists ty; congruence. eauto. - (* 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). eauto. - 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 = OK 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); simpl; [intros chunk CHK | congruence]. - caseEq (transl_params params); simpl; [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) as [vk [A [B C]]]. - exploit var_kind_by_value; eauto. 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 = OK 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. - -(** The following lemmas establish the matching property - between the global environments constructed at the beginning - of program execution. *) - -Definition globvarenv - (gv: gvarenv) - (vars: list (ident * globvar var_kind)) := - List.fold_left - (fun gve x => match x with (id, v) => PTree.set id (gvar_info v) 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) prog.(prog_funct). - -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 (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 -> - map_partial AST.prefix_name (transf_globvar transl_globvar) vars = OK tvars -> - match_globalenv (add_global_vars tenv vars) (globvarenv gv tvars). -Proof. - induction vars; simpl. - intros. inversion H0. assumption. - destruct a as [id v]. intros until tvars; intro. - caseEq (transf_globvar transl_globvar v); simpl; try congruence. intros vk VK. - caseEq (map_partial AST.prefix_name (transf_globvar transl_globvar) vars); simpl; try congruence. intros tvars' EQ1 EQ2. - inversion EQ2; clear EQ2. simpl. - apply IHvars; auto. - red. intros until chunk. unfold add_global_var. repeat rewrite PTree.gsspec. simpl. - destruct (peq id0 id); intros. - inv H0. monadInv VK. unfold transl_globvar in EQ. - generalize (var_kind_by_value _ _ H2). simpl. 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. - unfold transl_program in TRANSL. monadInv TRANSL. auto. -Qed. - -(* ** Correctness of variable accessors *) - -(** Correctness of the code generated by [var_get]. *) - -Lemma var_get_correct: - forall e m id ty loc ofs v tyenv code te, - Csem.eval_lvalue ge e m (Expr (Csyntax.Evar id) ty) loc ofs -> - load_value_of_type ty m loc ofs = Some v -> - wt_expr tyenv (Expr (Csyntax.Evar id) ty) -> - var_get id ty = OK code -> - match_env tyenv e te -> - eval_expr tgve te m code 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 C]]]. - assert (vk = Vscalar chunk). - exploit var_kind_by_value; eauto. congruence. - 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 C]]]. - 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. - -(** Correctness of the code generated by [var_set]. *) - -Lemma var_set_correct: - forall e m id ty loc ofs v m' tyenv code te rhs f k, - Csem.eval_lvalue ge e m (Expr (Csyntax.Evar id) ty) loc ofs -> - store_value_of_type ty m loc ofs v = Some m' -> - wt_expr tyenv (Expr (Csyntax.Evar id) ty) -> - var_set id ty rhs = OK code -> - match_env tyenv e te -> - eval_expr tgve te m rhs v -> - step tgve (State f code k te m) E0 (State f Sskip k te m'). -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. - (* local variable *) - exploit me_local; eauto. intros [vk [A [B C]]]. - assert (vk = Vscalar chunk). - exploit var_kind_by_value; eauto. congruence. - subst vk. - eapply step_assign. eauto. - econstructor. eapply eval_var_ref_local. eauto. assumption. - (* global variable *) - exploit me_global; eauto. intros [A B]. - eapply step_assign. eauto. - econstructor. eapply eval_var_ref_global. auto. - change (fst tgve) with 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. - -Lemma call_dest_correct: - forall e m lhs loc ofs tyenv optid te, - Csem.eval_lvalue ge e m lhs loc ofs -> - wt_expr tyenv lhs -> - transl_lhs_call (Some lhs) = OK optid -> - match_env tyenv e te -> - exists id, - optid = Some id - /\ tyenv!id = Some (typeof lhs) - /\ ofs = Int.zero - /\ match access_mode (typeof lhs) with - | By_value chunk => eval_var_ref tgve te id loc chunk - | _ => True - end. -Proof. - intros. generalize H1. simpl. caseEq (is_variable lhs); try congruence. - intros id ISV EQ. inv EQ. - exploit is_variable_correct; eauto. intro EQ. - rewrite EQ in H0. inversion H0. subst id0 ty. - exists id. split; auto. split. rewrite EQ in H0. inversion H0. auto. - rewrite EQ in H. inversion H. -(* local variable *) - split. auto. - subst id0 ty l ofs. exploit me_local; eauto. - intros [vk [A [B C]]]. - case_eq (access_mode (typeof lhs)); intros; auto. - assert (vk = Vscalar m0). - exploit var_kind_by_value; eauto. congruence. - subst vk. apply eval_var_ref_local; auto. -(* global variable *) - split. auto. - subst id0 ty l ofs. exploit me_global; eauto. intros [A B]. - case_eq (access_mode (typeof lhs)); intros; auto. - apply eval_var_ref_global; auto. - simpl. rewrite <- H9. apply symbols_preserved. -Qed. - -Lemma set_call_dest_correct: - forall ty m loc v m' tyenv e te id, - store_value_of_type ty m loc Int.zero v = Some m' -> - match access_mode ty with - | By_value chunk => eval_var_ref tgve te id loc chunk - | _ => True - end -> - match_env tyenv e te -> - tyenv!id = Some ty -> - exec_opt_assign tgve te m (Some id) v m'. -Proof. - intros. generalize H. unfold store_value_of_type. case_eq (access_mode ty); intros; try congruence. - rewrite H3 in H0. - constructor. econstructor. eauto. auto. -Qed. - -(** * Proof of semantic preservation *) - -(** ** Semantic preservation for expressions *) - -(** The proof of semantic preservation for the translation of expressions - relies on simulation diagrams of the following form: -<< - e, m, a ------------------- te, m, ta - | | - | | - | | - v v - e, m, v ------------------- te, m, v ->> - Left: evaluation of r-value expression [a] in Clight. - Right: evaluation of its translation [ta] in Csharpminor. - Top (precondition): matching between environments [e], [te], - plus well-typedness of expression [a]. - Bottom (postcondition): the result values [v] - are identical in both evaluations. - - We state these diagrams as the following properties, parameterized - by the Clight evaluation. *) - -Section EXPR. - -Variable e: Csem.env. -Variable m: mem. -Variable te: Csharpminor.env. -Variable tyenv: typenv. -Hypothesis MENV: match_env tyenv e te. - -Definition eval_expr_prop (a: Csyntax.expr) (v: val) : Prop := - forall ta - (WT: wt_expr tyenv a) - (TR: transl_expr a = OK ta), - Csharpminor.eval_expr tgve te m ta v. - -Definition eval_lvalue_prop (a: Csyntax.expr) (b: block) (ofs: int) : Prop := - forall ta - (WT: wt_expr tyenv a) - (TR: transl_lvalue a = OK ta), - Csharpminor.eval_expr tgve te m ta (Vptr b ofs). - -Definition eval_exprlist_prop (al: list Csyntax.expr) (vl: list val) : Prop := - forall tal - (WT: wt_exprlist tyenv al) - (TR: transl_exprlist al = OK tal), - Csharpminor.eval_exprlist tgve te m tal vl. - -(* Check (eval_expr_ind2 ge e m eval_expr_prop eval_lvalue_prop). *) - -Lemma transl_Econst_int_correct: - forall (i : int) (ty : type), - eval_expr_prop (Expr (Econst_int i) ty) (Vint i). -Proof. - intros; red; intros. - monadInv TR. apply make_intconst_correct. -Qed. - -Lemma transl_Econst_float_correct: - forall (f0 : float) (ty : type), - eval_expr_prop (Expr (Econst_float f0) ty) (Vfloat f0). -Proof. - intros; red; intros. - monadInv TR. apply make_floatconst_correct. -Qed. - -Lemma transl_Elvalue_correct: - forall (a : expr_descr) (ty : type) (loc : block) (ofs : int) - (v : val), - eval_lvalue ge e m (Expr a ty) loc ofs -> - eval_lvalue_prop (Expr a ty) loc ofs -> - load_value_of_type ty m loc ofs = Some v -> - eval_expr_prop (Expr a ty) v. -Proof. - intros; red; intros. - exploit transl_expr_lvalue; eauto. - intros [[id [EQ VARGET]] | [tb [TRLVAL MKLOAD]]]. - (* Case a is a variable *) - subst a. eapply var_get_correct; eauto. - (* Case a is another lvalue *) - eapply make_load_correct; eauto. -Qed. - -Lemma transl_Eaddrof_correct: - forall (a : Csyntax.expr) (ty : type) (loc : block) (ofs : int), - eval_lvalue ge e m a loc ofs -> - eval_lvalue_prop a loc ofs -> - eval_expr_prop (Expr (Csyntax.Eaddrof a) ty) (Vptr loc ofs). -Proof. - intros; red; intros. inversion WT; clear WT; subst. simpl in TR. - eauto. -Qed. - -Lemma transl_Esizeof_correct: - forall ty' ty : type, - eval_expr_prop (Expr (Esizeof ty') ty) - (Vint (Int.repr (Csyntax.sizeof ty'))). -Proof. - intros; red; intros. monadInv TR. apply make_intconst_correct. -Qed. - -Lemma transl_Eunop_correct: - forall (op : Csyntax.unary_operation) (a : Csyntax.expr) (ty : type) - (v1 v : val), - Csem.eval_expr ge e m a v1 -> - eval_expr_prop a v1 -> - sem_unary_operation op v1 (typeof a) = Some v -> - eval_expr_prop (Expr (Csyntax.Eunop op a) ty) v. -Proof. - intros; red; intros. - inversion WT; clear WT; subst. - monadInv TR. - eapply transl_unop_correct; eauto. -Qed. - -Lemma transl_Ebinop_correct: - forall (op : Csyntax.binary_operation) (a1 a2 : Csyntax.expr) - (ty : type) (v1 v2 v : val), - Csem.eval_expr ge e m a1 v1 -> - eval_expr_prop a1 v1 -> - Csem.eval_expr ge e m a2 v2 -> - eval_expr_prop a2 v2 -> - sem_binary_operation op v1 (typeof a1) v2 (typeof a2) m = Some v -> - eval_expr_prop (Expr (Csyntax.Ebinop op a1 a2) ty) v. -Proof. - intros; red; intros. - inversion WT; clear WT; subst. - monadInv TR. - eapply transl_binop_correct; eauto. -Qed. - -Lemma transl_Econdition_true_correct: - forall (a1 a2 a3 : Csyntax.expr) (ty : type) (v1 v2 : val), - Csem.eval_expr ge e m a1 v1 -> - eval_expr_prop a1 v1 -> - is_true v1 (typeof a1) -> - Csem.eval_expr ge e m a2 v2 -> - eval_expr_prop a2 v2 -> - eval_expr_prop (Expr (Csyntax.Econdition a1 a2 a3) ty) v2. -Proof. - intros; red; intros. inv WT. monadInv TR. - exploit make_boolean_correct_true. eapply H0; eauto. eauto. - intros [vb [EVAL ISTRUE]]. - eapply eval_Econdition; eauto. apply Val.bool_of_true_val; eauto. - simpl. eauto. -Qed. - -Lemma transl_Econdition_false_correct: - forall (a1 a2 a3 : Csyntax.expr) (ty : type) (v1 v3 : val), - Csem.eval_expr ge e m a1 v1 -> - eval_expr_prop a1 v1 -> - is_false v1 (typeof a1) -> - Csem.eval_expr ge e m a3 v3 -> - eval_expr_prop a3 v3 -> - eval_expr_prop (Expr (Csyntax.Econdition a1 a2 a3) ty) v3. -Proof. - intros; red; intros. inv WT. monadInv TR. - exploit make_boolean_correct_false. eapply H0; eauto. eauto. - intros [vb [EVAL ISTRUE]]. - eapply eval_Econdition; eauto. apply Val.bool_of_false_val; eauto. - simpl. eauto. -Qed. - -Lemma transl_Eorbool_1_correct: - forall (a1 a2 : Csyntax.expr) (ty : type) (v1 : val), - Csem.eval_expr ge e m a1 v1 -> - eval_expr_prop a1 v1 -> - is_true v1 (typeof a1) -> - eval_expr_prop (Expr (Eorbool a1 a2) ty) Vtrue. -Proof. - intros; red; intros. inversion WT; clear WT; subst. monadInv TR. - unfold make_orbool. - exploit make_boolean_correct_true; eauto. intros [vb [EVAL ISTRUE]]. - eapply eval_Econdition; eauto. apply Val.bool_of_true_val; eauto. - simpl. unfold Vtrue; apply make_intconst_correct. -Qed. - -Lemma transl_Eorbool_2_correct: - forall (a1 a2 : Csyntax.expr) (ty : type) (v1 v2 v : val), - Csem.eval_expr ge e m a1 v1 -> - eval_expr_prop a1 v1 -> - is_false v1 (typeof a1) -> - Csem.eval_expr ge e m a2 v2 -> - eval_expr_prop a2 v2 -> - bool_of_val v2 (typeof a2) v -> - eval_expr_prop (Expr (Eorbool a1 a2) ty) v. -Proof. - intros; red; intros. inversion WT; clear WT; subst. monadInv TR. - unfold make_orbool. - exploit make_boolean_correct_false. eapply H0; eauto. eauto. intros [vb [EVAL ISFALSE]]. - eapply eval_Econdition; eauto. apply Val.bool_of_false_val; eauto. - simpl. inversion H4; subst. - exploit make_boolean_correct_true. eapply H3; eauto. eauto. intros [vc [EVAL' ISTRUE']]. - eapply eval_Econdition; eauto. apply Val.bool_of_true_val; eauto. - unfold Vtrue; apply make_intconst_correct. - exploit make_boolean_correct_false. eapply H3; eauto. eauto. intros [vc [EVAL' ISFALSE']]. - eapply eval_Econdition; eauto. apply Val.bool_of_false_val; eauto. - unfold Vfalse; apply make_intconst_correct. -Qed. - -Lemma transl_Eandbool_1_correct: - forall (a1 a2 : Csyntax.expr) (ty : type) (v1 : val), - Csem.eval_expr ge e m a1 v1 -> - eval_expr_prop a1 v1 -> - is_false v1 (typeof a1) -> - eval_expr_prop (Expr (Eandbool a1 a2) ty) Vfalse. -Proof. - intros; red; intros. inversion WT; clear WT; subst. monadInv TR. - unfold make_andbool. - exploit make_boolean_correct_false; eauto. intros [vb [EVAL ISFALSE]]. - eapply eval_Econdition; eauto. apply Val.bool_of_false_val; eauto. - unfold Vfalse; apply make_intconst_correct. -Qed. - -Lemma transl_Eandbool_2_correct: - forall (a1 a2 : Csyntax.expr) (ty : type) (v1 v2 v : val), - Csem.eval_expr ge e m a1 v1 -> - eval_expr_prop a1 v1 -> - is_true v1 (typeof a1) -> - Csem.eval_expr ge e m a2 v2 -> - eval_expr_prop a2 v2 -> - bool_of_val v2 (typeof a2) v -> - eval_expr_prop (Expr (Eandbool a1 a2) ty) v. -Proof. - intros; red; intros. inversion WT; clear WT; subst. monadInv TR. - unfold make_andbool. - exploit make_boolean_correct_true. eapply H0; eauto. eauto. intros [vb [EVAL ISTRUE]]. - eapply eval_Econdition; eauto. apply Val.bool_of_true_val; eauto. - simpl. inversion H4; subst. - exploit make_boolean_correct_true. eapply H3; eauto. eauto. intros [vc [EVAL' ISTRUE']]. - eapply eval_Econdition; eauto. apply Val.bool_of_true_val; eauto. - unfold Vtrue; apply make_intconst_correct. - exploit make_boolean_correct_false. eapply H3; eauto. eauto. intros [vc [EVAL' ISFALSE']]. - eapply eval_Econdition; eauto. apply Val.bool_of_false_val; eauto. - unfold Vfalse; apply make_intconst_correct. -Qed. - -Lemma transl_Ecast_correct: - forall (a : Csyntax.expr) (ty ty': type) (v1 v : val), - Csem.eval_expr ge e m a v1 -> - eval_expr_prop a v1 -> - cast v1 (typeof a) ty v -> eval_expr_prop (Expr (Ecast ty a) ty') v. -Proof. - intros; red; intros. inversion WT; clear WT; subst. monadInv TR. - eapply make_cast_correct; eauto. -Qed. - -Lemma transl_Evar_local_correct: - forall (id : ident) (l : block) (ty : type), - e ! id = Some(l, ty) -> - eval_lvalue_prop (Expr (Csyntax.Evar id) ty) l Int.zero. -Proof. - intros; red; intros. inversion WT; clear WT; subst. monadInv TR. - exploit (me_local _ _ _ MENV); eauto. - intros [vk [A [B C]]]. - econstructor. eapply eval_var_addr_local. eauto. -Qed. - -Lemma transl_Evar_global_correct: - forall (id : ident) (l : block) (ty : type), - e ! id = None -> - Genv.find_symbol ge id = Some l -> - eval_lvalue_prop (Expr (Csyntax.Evar id) ty) l Int.zero. -Proof. - intros; red; intros. inversion WT; clear WT; subst. monadInv TR. - 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 (a : Csyntax.expr) (ty : type) (l : block) (ofs : int), - Csem.eval_expr ge e m a (Vptr l ofs) -> - eval_expr_prop a (Vptr l ofs) -> - eval_lvalue_prop (Expr (Ederef a) ty) l ofs. -Proof. - intros; red; intros. inversion WT; clear WT; subst. simpl in TR. - eauto. -Qed. - -Lemma transl_Efield_struct_correct: - forall (a : Csyntax.expr) (i : ident) (ty : type) (l : block) - (ofs : int) (id : ident) (fList : fieldlist) (delta : Z), - eval_lvalue ge e m a l ofs -> - eval_lvalue_prop a l ofs -> - typeof a = Tstruct id fList -> - field_offset i fList = OK delta -> - eval_lvalue_prop (Expr (Efield a i) ty) 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. - eapply eval_Ebinop; eauto. - apply make_intconst_correct. - simpl. congruence. -Qed. - -Lemma transl_Efield_union_correct: - forall (a : Csyntax.expr) (i : ident) (ty : type) (l : block) - (ofs : int) (id : ident) (fList : fieldlist), - eval_lvalue ge e m a l ofs -> - eval_lvalue_prop a l ofs -> - typeof a = Tunion id fList -> - eval_lvalue_prop (Expr (Efield a i) ty) l ofs. -Proof. - intros; red; intros. inversion WT; clear WT; subst. - simpl in TR. rewrite H1 in TR. eauto. -Qed. - -Lemma transl_expr_correct: - forall a v, - Csem.eval_expr ge e m a v -> - eval_expr_prop a v. -Proof - (eval_expr_ind2 ge e m eval_expr_prop eval_lvalue_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_Econdition_true_correct - transl_Econdition_false_correct - transl_Eorbool_1_correct - transl_Eorbool_2_correct - transl_Eandbool_1_correct - transl_Eandbool_2_correct - transl_Ecast_correct - transl_Evar_local_correct - transl_Evar_global_correct - transl_Ederef_correct - transl_Efield_struct_correct - transl_Efield_union_correct). - -Lemma transl_lvalue_correct: - forall a blk ofs, - Csem.eval_lvalue ge e m a blk ofs -> - eval_lvalue_prop a blk ofs. -Proof - (eval_lvalue_ind2 ge e m eval_expr_prop eval_lvalue_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_Econdition_true_correct - transl_Econdition_false_correct - transl_Eorbool_1_correct - transl_Eorbool_2_correct - transl_Eandbool_1_correct - transl_Eandbool_2_correct - transl_Ecast_correct - transl_Evar_local_correct - transl_Evar_global_correct - transl_Ederef_correct - transl_Efield_struct_correct - transl_Efield_union_correct). - -Lemma transl_exprlist_correct: - forall al vl, - Csem.eval_exprlist ge e m al vl -> - eval_exprlist_prop al vl. -Proof. - induction 1; red; intros; monadInv TR; inv WT. - constructor. - constructor. eapply (transl_expr_correct _ _ H); eauto. eauto. -Qed. - -End EXPR. - -Lemma exit_if_false_true: - forall a ts e m v tyenv te f tk, - exit_if_false a = OK ts -> - Csem.eval_expr ge e m a v -> - is_true v (typeof a) -> - match_env tyenv e te -> - wt_expr tyenv a -> - step tgve (State f ts tk te m) E0 (State f Sskip tk te m). -Proof. - intros. monadInv H. - exploit make_boolean_correct_true. - eapply (transl_expr_correct _ _ _ _ H2 _ _ H0); eauto. - eauto. - intros [vb [EVAL ISTRUE]]. - change Sskip with (if true then Sskip else Sexit 0). - eapply step_ifthenelse; eauto. - apply Val.bool_of_true_val; eauto. -Qed. - -Lemma exit_if_false_false: - forall a ts e m v tyenv te f tk, - exit_if_false a = OK ts -> - Csem.eval_expr ge e m a v -> - is_false v (typeof a) -> - match_env tyenv e te -> - wt_expr tyenv a -> - step tgve (State f ts tk te m) E0 (State f (Sexit 0) tk te m). -Proof. - intros. monadInv H. - exploit make_boolean_correct_false. - eapply (transl_expr_correct _ _ _ _ H2 _ _ H0); eauto. - eauto. - intros [vb [EVAL ISFALSE]]. - change (Sexit 0) with (if false then Sskip else Sexit 0). - eapply step_ifthenelse; eauto. - apply Val.bool_of_false_val; eauto. -Qed. - -(** ** Semantic preservation for statements *) - -(** The simulation diagram for the translation of statements and functions - is a "plus" diagram of the form -<< - I - S1 ------- R1 - | | - t | + | t - v v - S2 ------- R2 - I I ->> - -The invariant [I] is the [match_states] predicate that we now define. -*) - -Definition typenv_fun (f: Csyntax.function) := - add_vars (global_typenv prog) (f.(Csyntax.fn_params) ++ f.(Csyntax.fn_vars)). - -Inductive match_transl: stmt -> cont -> stmt -> cont -> Prop := - | match_transl_0: forall ts tk, - match_transl ts tk ts tk - | match_transl_1: forall ts tk, - match_transl (Sblock ts) tk ts (Kblock tk). - -Lemma match_transl_step: - forall ts tk ts' tk' f te m, - match_transl (Sblock ts) tk ts' tk' -> - star step tgve (State f ts' tk' te m) E0 (State f ts (Kblock tk) te m). -Proof. - intros. inv H. - apply star_one. constructor. - apply star_refl. -Qed. - -Inductive match_cont: typenv -> nat -> nat -> Csem.cont -> Csharpminor.cont -> Prop := - | match_Kstop: forall tyenv nbrk ncnt, - match_cont tyenv nbrk ncnt Csem.Kstop Kstop - | match_Kseq: forall tyenv nbrk ncnt s k ts tk, - transl_statement nbrk ncnt s = OK ts -> - wt_stmt tyenv s -> - match_cont tyenv nbrk ncnt k tk -> - match_cont tyenv nbrk ncnt - (Csem.Kseq s k) - (Kseq ts tk) - | match_Kwhile: forall tyenv nbrk ncnt a s k ta ts tk, - exit_if_false a = OK ta -> - transl_statement 1%nat 0%nat s = OK ts -> - wt_expr tyenv a -> - wt_stmt tyenv s -> - match_cont tyenv nbrk ncnt k tk -> - match_cont tyenv 1%nat 0%nat - (Csem.Kwhile a s k) - (Kblock (Kseq (Sloop (Sseq ta (Sblock ts))) (Kblock tk))) - | match_Kdowhile: forall tyenv nbrk ncnt a s k ta ts tk, - exit_if_false a = OK ta -> - transl_statement 1%nat 0%nat s = OK ts -> - wt_expr tyenv a -> - wt_stmt tyenv s -> - match_cont tyenv nbrk ncnt k tk -> - match_cont tyenv 1%nat 0%nat - (Csem.Kdowhile a s k) - (Kblock (Kseq ta (Kseq (Sloop (Sseq (Sblock ts) ta)) (Kblock tk)))) - | match_Kfor2: forall tyenv nbrk ncnt a2 a3 s k ta2 ta3 ts tk, - exit_if_false a2 = OK ta2 -> - transl_statement nbrk ncnt a3 = OK ta3 -> - transl_statement 1%nat 0%nat s = OK ts -> - wt_expr tyenv a2 -> wt_stmt tyenv a3 -> wt_stmt tyenv s -> - match_cont tyenv nbrk ncnt k tk -> - match_cont tyenv 1%nat 0%nat - (Csem.Kfor2 a2 a3 s k) - (Kblock (Kseq ta3 (Kseq (Sloop (Sseq ta2 (Sseq (Sblock ts) ta3))) (Kblock tk)))) - | match_Kfor3: forall tyenv nbrk ncnt a2 a3 s k ta2 ta3 ts tk, - exit_if_false a2 = OK ta2 -> - transl_statement nbrk ncnt a3 = OK ta3 -> - transl_statement 1%nat 0%nat s = OK ts -> - wt_expr tyenv a2 -> wt_stmt tyenv a3 -> wt_stmt tyenv s -> - match_cont tyenv nbrk ncnt k tk -> - match_cont tyenv nbrk ncnt - (Csem.Kfor3 a2 a3 s k) - (Kseq (Sloop (Sseq ta2 (Sseq (Sblock ts) ta3))) (Kblock tk)) - | match_Kswitch: forall tyenv nbrk ncnt k tk, - match_cont tyenv nbrk ncnt k tk -> - match_cont tyenv 0%nat (S ncnt) - (Csem.Kswitch k) - (Kblock tk) - | match_Kcall_none: forall tyenv nbrk ncnt nbrk' ncnt' f e k tf te tk, - transl_function f = OK tf -> - wt_stmt (typenv_fun f) f.(Csyntax.fn_body) -> - match_env (typenv_fun f) e te -> - match_cont (typenv_fun f) nbrk' ncnt' k tk -> - match_cont tyenv nbrk ncnt - (Csem.Kcall None f e k) - (Kcall None tf te tk) - | match_Kcall_some: forall tyenv nbrk ncnt nbrk' ncnt' loc ofs ty f e k id tf te tk, - transl_function f = OK tf -> - wt_stmt (typenv_fun f) f.(Csyntax.fn_body) -> - match_env (typenv_fun f) e te -> - ofs = Int.zero -> - (typenv_fun f)!id = Some ty -> - match access_mode ty with - | By_value chunk => eval_var_ref tgve te id loc chunk - | _ => True - end -> - match_cont (typenv_fun f) nbrk' ncnt' k tk -> - match_cont tyenv nbrk ncnt - (Csem.Kcall (Some(loc, ofs, ty)) f e k) - (Kcall (Some id) tf te tk). - -Inductive match_states: Csem.state -> Csharpminor.state -> Prop := - | match_state: - forall f nbrk ncnt s k e m tf ts tk te ts' tk' - (TRF: transl_function f = OK tf) - (TR: transl_statement nbrk ncnt s = OK ts) - (MTR: match_transl ts tk ts' tk') - (WTF: wt_stmt (typenv_fun f) f.(Csyntax.fn_body)) - (WT: wt_stmt (typenv_fun f) s) - (MENV: match_env (typenv_fun f) e te) - (MK: match_cont (typenv_fun f) nbrk ncnt k tk), - match_states (Csem.State f s k e m) - (State tf ts' tk' te m) - | match_callstate: - forall fd args k m tfd tk - (TR: transl_fundef fd = OK tfd) - (WT: wt_fundef (global_typenv prog) fd) - (MK: match_cont (global_typenv prog) 0%nat 0%nat k tk) - (ISCC: Csem.is_call_cont k), - match_states (Csem.Callstate fd args k m) - (Callstate tfd args tk m) - | match_returnstate: - forall res k m tk - (MK: match_cont (global_typenv prog) 0%nat 0%nat k tk), - match_states (Csem.Returnstate res k m) - (Returnstate res tk m). - -Remark match_states_skip: - forall f e te nbrk ncnt k tf tk m, - transl_function f = OK tf -> - wt_stmt (typenv_fun f) f.(Csyntax.fn_body) -> - match_env (typenv_fun f) e te -> - match_cont (typenv_fun f) nbrk ncnt k tk -> - match_states (Csem.State f Csyntax.Sskip k e m) (State tf Sskip tk te m). -Proof. - intros. econstructor; eauto. simpl; reflexivity. constructor. constructor. -Qed. - -(** Commutation between label resolution and compilation *) - -Section FIND_LABEL. -Variable lbl: label. -Variable tyenv: typenv. - -Remark exit_if_false_no_label: - forall a s, exit_if_false a = OK s -> forall k, find_label lbl s k = None. -Proof. - intros. unfold exit_if_false in H. monadInv H. simpl. auto. -Qed. - -Lemma transl_find_label: - forall s nbrk ncnt k ts tk - (WT: wt_stmt tyenv s) - (TR: transl_statement nbrk ncnt s = OK ts) - (MC: match_cont tyenv nbrk ncnt k tk), - match Csem.find_label lbl s k with - | None => find_label lbl ts tk = None - | Some (s', k') => - exists ts', exists tk', exists nbrk', exists ncnt', - find_label lbl ts tk = Some (ts', tk') - /\ transl_statement nbrk' ncnt' s' = OK ts' - /\ match_cont tyenv nbrk' ncnt' k' tk' - /\ wt_stmt tyenv s' - end - -with transl_find_label_ls: - forall ls nbrk ncnt k tls tk - (WT: wt_lblstmts tyenv ls) - (TR: transl_lbl_stmt nbrk ncnt ls = OK tls) - (MC: match_cont tyenv nbrk ncnt k tk), - match Csem.find_label_ls lbl ls k with - | None => find_label_ls lbl tls tk = None - | Some (s', k') => - exists ts', exists tk', exists nbrk', exists ncnt', - find_label_ls lbl tls tk = Some (ts', tk') - /\ transl_statement nbrk' ncnt' s' = OK ts' - /\ match_cont tyenv nbrk' ncnt' k' tk' - /\ wt_stmt tyenv s' - end. - -Proof. - intro s; case s; intros; inv WT; try (monadInv TR); simpl. -(* skip *) - auto. -(* assign *) - simpl in TR. destruct (is_variable e); monadInv TR. - unfold var_set in EQ0. destruct (access_mode (typeof e)); inv EQ0. auto. - unfold make_store in EQ2. destruct (access_mode (typeof e)); inv EQ2. auto. -(* call *) - simpl in TR. destruct (classify_fun (typeof e)); monadInv TR. auto. -(* seq *) - exploit (transl_find_label s0 nbrk ncnt (Csem.Kseq s1 k)); eauto. constructor; eauto. - destruct (Csem.find_label lbl s0 (Csem.Kseq s1 k)) as [[s' k'] | ]. - intros [ts' [tk' [nbrk' [ncnt' [A [B [C D]]]]]]]. - rewrite A. exists ts'; exists tk'; exists nbrk'; exists ncnt'; auto. - intro. rewrite H. eapply transl_find_label; eauto. -(* ifthenelse *) - exploit (transl_find_label s0); eauto. - destruct (Csem.find_label lbl s0 k) as [[s' k'] | ]. - intros [ts' [tk' [nbrk' [ncnt' [A [B [C D]]]]]]]. - rewrite A. exists ts'; exists tk'; exists nbrk'; exists ncnt'; auto. - intro. rewrite H. eapply transl_find_label; eauto. -(* while *) - rewrite (exit_if_false_no_label _ _ EQ). - eapply transl_find_label; eauto. econstructor; eauto. -(* dowhile *) - exploit (transl_find_label s0 1%nat 0%nat (Csem.Kdowhile e s0 k)); eauto. econstructor; eauto. - destruct (Csem.find_label lbl s0 (Kdowhile e s0 k)) as [[s' k'] | ]. - intros [ts' [tk' [nbrk' [ncnt' [A [B [C D]]]]]]]. - rewrite A. exists ts'; exists tk'; exists nbrk'; exists ncnt'; auto. - intro. rewrite H. eapply exit_if_false_no_label; eauto. -(* for *) - simpl in TR. destruct (is_Sskip s0); monadInv TR. - simpl. rewrite (exit_if_false_no_label _ _ EQ). - exploit (transl_find_label s2 1%nat 0%nat (Kfor2 e s1 s2 k)); eauto. econstructor; eauto. - destruct (Csem.find_label lbl s2 (Kfor2 e s1 s2 k)) as [[s' k'] | ]. - intros [ts' [tk' [nbrk' [ncnt' [A [B [C D]]]]]]]. - rewrite A. exists ts'; exists tk'; exists nbrk'; exists ncnt'; auto. - intro. rewrite H. - eapply transl_find_label; eauto. econstructor; eauto. - exploit (transl_find_label s0 nbrk ncnt (Csem.Kseq (Sfor Csyntax.Sskip e s1 s2) k)); eauto. - econstructor; eauto. simpl. rewrite is_Sskip_true. rewrite EQ1; simpl. rewrite EQ0; simpl. rewrite EQ2; simpl. reflexivity. - constructor; auto. constructor. - simpl. rewrite (exit_if_false_no_label _ _ EQ1). - destruct (Csem.find_label lbl s0 (Csem.Kseq (Sfor Csyntax.Sskip e s1 s2) k)) as [[s' k'] | ]. - intros [ts' [tk' [nbrk' [ncnt' [A [B [C D]]]]]]]. - rewrite A. exists ts'; exists tk'; exists nbrk'; exists ncnt'; auto. - intro. rewrite H. - exploit (transl_find_label s2 1%nat 0%nat (Kfor2 e s1 s2 k)); eauto. econstructor; eauto. - destruct (Csem.find_label lbl s2 (Kfor2 e s1 s2 k)) as [[s' k'] | ]. - intros [ts' [tk' [nbrk' [ncnt' [A [B [C D]]]]]]]. - rewrite A. exists ts'; exists tk'; exists nbrk'; exists ncnt'; auto. - intro. rewrite H0. - eapply transl_find_label; eauto. econstructor; eauto. -(* break *) - auto. -(* continue *) - auto. -(* return *) - simpl in TR. destruct o; monadInv TR. auto. auto. -(* switch *) - eapply transl_find_label_ls with (k := Csem.Kswitch k); eauto. econstructor; eauto. -(* label *) - destruct (ident_eq lbl l). - exists x; exists tk; exists nbrk; exists ncnt; auto. - eapply transl_find_label; eauto. -(* goto *) - auto. - - intro ls; case ls; intros; inv WT; monadInv TR; simpl. -(* default *) - eapply transl_find_label; eauto. -(* case *) - exploit (transl_find_label s nbrk ncnt (Csem.Kseq (seq_of_labeled_statement l) k)); eauto. - econstructor; eauto. apply transl_lbl_stmt_2; eauto. - apply wt_seq_of_labeled_statement; auto. - destruct (Csem.find_label lbl s (Csem.Kseq (seq_of_labeled_statement l) k)) as [[s' k'] | ]. - intros [ts' [tk' [nbrk' [ncnt' [A [B [C D]]]]]]]. - rewrite A. exists ts'; exists tk'; exists nbrk'; exists ncnt'; auto. - intro. rewrite H. - eapply transl_find_label_ls; eauto. -Qed. - -End FIND_LABEL. - -(** Properties of call continuations *) - -Lemma match_cont_call_cont: - forall nbrk' ncnt' tyenv' tyenv nbrk ncnt k tk, - match_cont tyenv nbrk ncnt k tk -> - match_cont tyenv' nbrk' ncnt' (Csem.call_cont k) (call_cont tk). -Proof. - induction 1; simpl; auto. - constructor. - econstructor; eauto. - econstructor; eauto. -Qed. - -Lemma match_cont_is_call_cont: - forall typenv nbrk ncnt k tk typenv' nbrk' ncnt', - match_cont typenv nbrk ncnt k tk -> - Csem.is_call_cont k -> - match_cont typenv' nbrk' ncnt' k tk /\ is_call_cont tk. -Proof. - intros. inv H; simpl in H0; try contradiction; simpl; intuition. - constructor. - econstructor; eauto. - econstructor; eauto. -Qed. - -(** The simulation proof *) - -Lemma transl_step: - forall S1 t S2, Csem.step ge S1 t S2 -> - forall T1, match_states S1 T1 -> - exists T2, plus step tgve T1 t T2 /\ match_states S2 T2. -Proof. - induction 1; intros T1 MST; inv MST. - -(* assign *) - simpl in TR. inv WT. - case_eq (is_variable a1); intros. - rewrite H2 in TR. monadInv TR. - exploit is_variable_correct; eauto. intro EQ1. rewrite EQ1 in H. - assert (ts' = ts /\ tk' = tk). - inversion MTR. auto. - subst ts. unfold var_set in EQ0. destruct (access_mode (typeof a1)); congruence. - destruct H3; subst ts' tk'. - econstructor; split. - apply plus_one. eapply var_set_correct; eauto. congruence. - exploit transl_expr_correct; eauto. - eapply match_states_skip; eauto. - - rewrite H2 in TR. monadInv TR. - assert (ts' = ts /\ tk' = tk). - inversion MTR. auto. - subst ts. unfold make_store in EQ2. destruct (access_mode (typeof a1)); congruence. - destruct H3; subst ts' tk'. - econstructor; split. - apply plus_one. eapply make_store_correct; eauto. - exploit transl_lvalue_correct; eauto. - exploit transl_expr_correct; eauto. - eapply match_states_skip; eauto. - -(* call none *) - generalize TR. simpl. case_eq (classify_fun (typeof a)); try congruence. - intros targs tres CF TR'. monadInv TR'. inv MTR. inv WT. - exploit functions_translated; eauto. intros [tfd [FIND TFD]]. - econstructor; split. - apply plus_one. econstructor; eauto. - exploit transl_expr_correct; eauto. - exploit transl_exprlist_correct; eauto. - eapply transl_fundef_sig1; eauto. eapply functions_well_typed; eauto. - congruence. - econstructor; eauto. eapply functions_well_typed; eauto. - econstructor; eauto. simpl. auto. - -(* call some *) - generalize TR. simpl. case_eq (classify_fun (typeof a)); try congruence. - intros targs tres CF TR'. monadInv TR'. inv MTR. inv WT. - exploit functions_translated; eauto. intros [tfd [FIND TFD]]. - inv H7. exploit call_dest_correct; eauto. - intros [id [A [B [C D]]]]. subst x ofs. - econstructor; split. - apply plus_one. econstructor; eauto. - exploit transl_expr_correct; eauto. - exploit transl_exprlist_correct; eauto. - eapply transl_fundef_sig1; eauto. eapply functions_well_typed; eauto. - congruence. - econstructor; eauto. eapply functions_well_typed; eauto. - econstructor; eauto. simpl; auto. - -(* seq *) - monadInv TR. inv WT. inv MTR. - econstructor; split. - apply plus_one. constructor. - econstructor; eauto. constructor. - econstructor; eauto. - -(* skip seq *) - monadInv TR. inv MTR. inv MK. - econstructor; split. - apply plus_one. apply step_skip_seq. - econstructor; eauto. constructor. - -(* continue seq *) - monadInv TR. inv MTR. inv MK. - econstructor; split. - apply plus_one. constructor. - econstructor; eauto. simpl. reflexivity. constructor. - -(* break seq *) - monadInv TR. inv MTR. inv MK. - econstructor; split. - apply plus_one. constructor. - econstructor; eauto. simpl. reflexivity. constructor. - -(* ifthenelse true *) - monadInv TR. inv MTR. inv WT. - exploit make_boolean_correct_true; eauto. - exploit transl_expr_correct; eauto. - intros [v [A B]]. - econstructor; split. - apply plus_one. apply step_ifthenelse with (v := v) (b := true). - auto. apply Val.bool_of_true_val. auto. - econstructor; eauto. constructor. - -(* ifthenelse false *) - monadInv TR. inv MTR. inv WT. - exploit make_boolean_correct_false; eauto. - exploit transl_expr_correct; eauto. - intros [v [A B]]. - econstructor; split. - apply plus_one. apply step_ifthenelse with (v := v) (b := false). - auto. apply Val.bool_of_false_val. auto. - econstructor; eauto. constructor. - -(* while false *) - monadInv TR. inv WT. - econstructor; split. - eapply star_plus_trans. eapply match_transl_step; eauto. - eapply plus_left. constructor. - eapply star_left. constructor. - eapply star_left. eapply exit_if_false_false; eauto. - eapply star_left. constructor. - eapply star_left. constructor. - apply star_one. constructor. - reflexivity. reflexivity. reflexivity. reflexivity. reflexivity. traceEq. - eapply match_states_skip; eauto. - -(* while true *) - monadInv TR. inv WT. - econstructor; split. - eapply star_plus_trans. eapply match_transl_step; eauto. - eapply plus_left. constructor. - eapply star_left. constructor. - eapply star_left. eapply exit_if_false_true; eauto. - eapply star_left. constructor. - apply star_one. constructor. - reflexivity. reflexivity. reflexivity. reflexivity. traceEq. - econstructor; eauto. constructor. - econstructor; eauto. - -(* skip or continue while *) - assert ((ts' = Sskip \/ ts' = Sexit ncnt) /\ tk' = tk). - destruct H; subst x; monadInv TR; inv MTR; auto. - destruct H0. inv MK. - econstructor; split. - eapply plus_left. - destruct H0; subst ts'; constructor. - apply star_one. constructor. traceEq. - econstructor; eauto. - simpl. rewrite H5; simpl. rewrite H6; simpl. reflexivity. - constructor. constructor; auto. - -(* break while *) - monadInv TR. inv MTR. inv MK. - econstructor; split. - eapply plus_left. constructor. - eapply star_left. constructor. - apply star_one. constructor. - reflexivity. traceEq. - eapply match_states_skip; eauto. - -(* dowhile *) - monadInv TR. inv WT. - econstructor; split. - eapply star_plus_trans. eapply match_transl_step; eauto. - eapply plus_left. constructor. - eapply star_left. constructor. - apply star_one. constructor. - reflexivity. reflexivity. traceEq. - econstructor; eauto. constructor. - econstructor; eauto. - -(* skip or continue dowhile false *) - assert ((ts' = Sskip \/ ts' = Sexit ncnt) /\ tk' = tk). - destruct H; subst x; monadInv TR; inv MTR; auto. - destruct H2. inv MK. - econstructor; split. - eapply plus_left. destruct H2; subst ts'; constructor. - eapply star_left. constructor. - eapply star_left. eapply exit_if_false_false; eauto. - eapply star_left. constructor. - apply star_one. constructor. - reflexivity. reflexivity. reflexivity. traceEq. - eapply match_states_skip; eauto. - -(* skip or continue dowhile true *) - assert ((ts' = Sskip \/ ts' = Sexit ncnt) /\ tk' = tk). - destruct H; subst x; monadInv TR; inv MTR; auto. - destruct H2. inv MK. - econstructor; split. - eapply plus_left. destruct H2; subst ts'; constructor. - eapply star_left. constructor. - eapply star_left. eapply exit_if_false_true; eauto. - apply star_one. constructor. - reflexivity. reflexivity. traceEq. - econstructor; eauto. - simpl. rewrite H7; simpl. rewrite H8; simpl. reflexivity. constructor. - constructor; auto. - -(* break dowhile *) - monadInv TR. inv MTR. inv MK. - econstructor; split. - eapply plus_left. constructor. - eapply star_left. constructor. - eapply star_left. constructor. - apply star_one. constructor. - reflexivity. reflexivity. traceEq. - eapply match_states_skip; eauto. - -(* for start *) - simpl in TR. rewrite is_Sskip_false in TR; auto. monadInv TR. inv MTR. inv WT. - econstructor; split. - apply plus_one. constructor. - econstructor; eauto. constructor. - constructor; auto. simpl. rewrite is_Sskip_true. rewrite EQ1; simpl. rewrite EQ0; simpl. rewrite EQ2; auto. - constructor; auto. constructor. - -(* for false *) - simpl in TR. rewrite is_Sskip_true in TR. monadInv TR. inv WT. - econstructor; split. - eapply star_plus_trans. eapply match_transl_step; eauto. - eapply plus_left. constructor. - eapply star_left. constructor. - eapply star_left. eapply exit_if_false_false; eauto. - eapply star_left. constructor. - eapply star_left. constructor. - apply star_one. constructor. - reflexivity. reflexivity. reflexivity. reflexivity. reflexivity. reflexivity. - eapply match_states_skip; eauto. - -(* for true *) - simpl in TR. rewrite is_Sskip_true in TR. monadInv TR. inv WT. - econstructor; split. - eapply star_plus_trans. eapply match_transl_step; eauto. - eapply plus_left. constructor. - eapply star_left. constructor. - eapply star_left. eapply exit_if_false_true; eauto. - eapply star_left. constructor. - eapply star_left. constructor. - apply star_one. constructor. - reflexivity. reflexivity. reflexivity. reflexivity. reflexivity. reflexivity. - econstructor; eauto. constructor. - econstructor; eauto. - -(* skip or continue for2 *) - assert ((ts' = Sskip \/ ts' = Sexit ncnt) /\ tk' = tk). - destruct H; subst x; monadInv TR; inv MTR; auto. - destruct H0. inv MK. - econstructor; split. - eapply plus_left. destruct H0; subst ts'; constructor. - apply star_one. constructor. reflexivity. - econstructor; eauto. constructor. - constructor; auto. - -(* break for2 *) - monadInv TR. inv MTR. inv MK. - econstructor; split. - eapply plus_left. constructor. - eapply star_left. constructor. - eapply star_left. constructor. - apply star_one. constructor. - reflexivity. reflexivity. traceEq. - eapply match_states_skip; eauto. - -(* skip for3 *) - monadInv TR. inv MTR. inv MK. - econstructor; split. - apply plus_one. constructor. - econstructor; eauto. - simpl. rewrite is_Sskip_true. rewrite H3; simpl. rewrite H4; simpl. rewrite H5; simpl. reflexivity. - constructor. constructor; auto. - -(* return none *) - monadInv TR. inv MTR. - econstructor; split. - apply plus_one. constructor. monadInv TRF. simpl. rewrite H. auto. - eapply match_env_free_blocks; eauto. - econstructor; eauto. - eapply match_cont_call_cont. eauto. - -(* return some *) - monadInv TR. inv MTR. inv WT. inv H3. - econstructor; split. - apply plus_one. constructor. monadInv TRF. simpl. - unfold opttyp_of_type. destruct (Csyntax.fn_return f); congruence. - exploit transl_expr_correct; eauto. - eapply match_env_free_blocks; eauto. - econstructor; eauto. - eapply match_cont_call_cont. eauto. - -(* skip call *) - monadInv TR. inv MTR. - exploit match_cont_is_call_cont; eauto. intros [A B]. - econstructor; split. - apply plus_one. apply step_skip_call. auto. - monadInv TRF. simpl. rewrite H0. auto. - eapply match_env_free_blocks; eauto. - constructor. eauto. - -(* switch *) - monadInv TR. inv WT. - exploit transl_expr_correct; eauto. intro EV. - econstructor; split. - eapply star_plus_trans. eapply match_transl_step; eauto. - apply plus_one. econstructor. eauto. traceEq. - econstructor; eauto. - apply transl_lbl_stmt_2. apply transl_lbl_stmt_1. eauto. - constructor. - apply wt_seq_of_labeled_statement. apply wt_select_switch. auto. - econstructor. eauto. - -(* skip or break switch *) - assert ((ts' = Sskip \/ ts' = Sexit nbrk) /\ tk' = tk). - destruct H; subst x; monadInv TR; inv MTR; auto. - destruct H0. inv MK. - econstructor; split. - apply plus_one. destruct H0; subst ts'; constructor. - eapply match_states_skip; eauto. - - -(* continue switch *) - monadInv TR. inv MTR. inv MK. - econstructor; split. - apply plus_one. constructor. - econstructor; eauto. simpl. reflexivity. constructor. - -(* label *) - monadInv TR. inv WT. inv MTR. - econstructor; split. - apply plus_one. constructor. - econstructor; eauto. constructor. - -(* goto *) - monadInv TR. inv MTR. - generalize TRF. unfold transl_function. intro TRF'. monadInv TRF'. - exploit (transl_find_label lbl). eexact WTF. eexact EQ0. eapply match_cont_call_cont. eauto. - rewrite H. - intros [ts' [tk'' [nbrk' [ncnt' [A [B [C D]]]]]]]. - econstructor; split. - apply plus_one. constructor. simpl. eexact A. - econstructor; eauto. constructor. - -(* internal function *) - monadInv TR. inv WT. inv H3. monadInv EQ. - exploit match_cont_is_call_cont; eauto. intros [A B]. - exploit match_env_alloc_variables; eauto. - apply match_globalenv_match_env_empty. apply match_global_typenv. - apply transl_fn_variables. eauto. eauto. - intros [te1 [C D]]. - econstructor; split. - apply plus_one. econstructor. - eapply transl_names_norepet; eauto. - eexact C. eapply bind_parameters_match; eauto. - econstructor; eauto. - unfold transl_function. rewrite EQ0; simpl. rewrite EQ; simpl. rewrite EQ1; auto. - constructor. - -(* external function *) - monadInv TR. - exploit match_cont_is_call_cont; eauto. intros [A B]. - econstructor; split. - apply plus_one. constructor. eauto. - eapply external_call_symbols_preserved_2; eauto. - exact symbols_preserved. - eexact (Genv.find_var_info_transf_partial2 transl_fundef transl_globvar _ TRANSL). - eexact (Genv.find_var_info_rev_transf_partial2 transl_fundef transl_globvar _ TRANSL). - econstructor; eauto. - -(* returnstate 0 *) - inv MK. - econstructor; split. - apply plus_one. constructor. constructor. - econstructor; eauto. simpl; reflexivity. constructor. constructor. - -(* returnstate 1 *) - inv MK. - econstructor; split. - apply plus_one. constructor. eapply set_call_dest_correct; eauto. - econstructor; eauto. simpl; reflexivity. constructor. constructor. -Qed. - -Lemma transl_initial_states: - forall S t S', Csem.initial_state prog S -> Csem.step ge S t S' -> - exists R, initial_state tprog R /\ match_states S R. -Proof. - intros. inv H. - exploit function_ptr_translated; eauto. intros [tf [A B]]. - assert (C: Genv.find_symbol tge (prog_main tprog) = Some b). - rewrite symbols_preserved. replace (prog_main tprog) with (prog_main prog). - exact H2. symmetry. unfold transl_program in TRANSL. - eapply transform_partial_program2_main; eauto. - exploit function_ptr_well_typed. eauto. intro WTF. - assert (exists targs, type_of_fundef f = Tfunction targs (Tint I32 Signed)). - eapply wt_program_main. eauto. - eapply Genv.find_funct_ptr_symbol_inversion; eauto. - destruct H as [targs D]. - assert (targs = Tnil). - inv H0. - (* internal function *) - inv H10. simpl in D. unfold type_of_function in D. rewrite <- H5 in D. - simpl in D. congruence. - (* external function *) - simpl in D. inv D. - exploit external_call_arity; eauto. intro ARITY. - exploit function_ptr_well_typed; eauto. intro WT. inv WT. - rewrite H5 in ARITY. destruct targs; simpl in ARITY; congruence. - subst targs. - assert (funsig tf = signature_of_type Tnil (Tint I32 Signed)). - eapply transl_fundef_sig2; eauto. - econstructor; split. - econstructor; eauto. eapply Genv.init_mem_transf_partial2; eauto. - constructor; auto. constructor. exact I. -Qed. - -Lemma transl_final_states: - forall S R r, - match_states S R -> Csem.final_state S r -> final_state R r. -Proof. - intros. inv H0. inv H. inv MK. constructor. -Qed. - -Theorem transl_program_correct: - forall (beh: program_behavior), - not_wrong beh -> Csem.exec_program prog beh -> - Csharpminor.exec_program tprog beh. -Proof. - set (order := fun (S1 S2: Csem.state) => False). - assert (WF: well_founded order). - unfold order; red. intros. constructor; intros. contradiction. - assert (transl_step': - forall S1 t S2, Csem.step ge S1 t S2 -> - forall T1, match_states S1 T1 -> - exists T2, - (plus step tgve T1 t T2 \/ star step tgve T1 t T2 /\ order S2 S1) - /\ match_states S2 T2). - intros. exploit transl_step; eauto. intros [T2 [A B]]. - exists T2; split. auto. auto. - intros. inv H0. -(* Terminates *) - assert (exists t1, exists s1, Csem.step (Genv.globalenv prog) s t1 s1). - inv H3. inv H2. inv H1. exists t1; exists s2; auto. - destruct H0 as [t1 [s1 ST]]. - exploit transl_initial_states; eauto. intros [R [A B]]. - exploit simulation_star_star; eauto. intros [R' [C D]]. - econstructor; eauto. eapply transl_final_states; eauto. -(* Diverges *) - assert (exists t1, exists s1, Csem.step (Genv.globalenv prog) s t1 s1). - inv H2. inv H3. exists E0; exists s2; auto. exists t1; exists s2; auto. - destruct H0 as [t1 [s1 ST]]. - exploit transl_initial_states; eauto. intros [R [A B]]. - exploit simulation_star_star; eauto. intros [R' [C D]]. - econstructor; eauto. eapply simulation_star_forever_silent; eauto. -(* Reacts *) - assert (exists t1, exists s1, Csem.step (Genv.globalenv prog) s t1 s1). - inv H2. inv H0. congruence. exists t1; exists s0; auto. - destruct H0 as [t1 [s1 ST]]. - exploit transl_initial_states; eauto. intros [R [A B]]. - exploit simulation_star_forever_reactive; eauto. - intro C. - econstructor; eauto. -(* Goes wrong *) - contradiction. contradiction. -Qed. - -End CORRECTNESS. diff --git a/cfrontend/Cstrategy.v b/cfrontend/Cstrategy.v new file mode 100644 index 0000000..3d81899 --- /dev/null +++ b/cfrontend/Cstrategy.v @@ -0,0 +1,2825 @@ +(* *********************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Xavier Leroy, INRIA Paris-Rocquencourt *) +(* *) +(* Copyright Institut National de Recherche en Informatique et en *) +(* Automatique. All rights reserved. This file is distributed *) +(* under the terms of the GNU General Public License as published by *) +(* the Free Software Foundation, either version 2 of the License, or *) +(* (at your option) any later version. This file is also distributed *) +(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* *) +(* *********************************************************************) + +(** A deterministic evaluation strategy for C. *) + +Require Import Coq.Program.Equality. +Require Import Axioms. +Require Import Coqlib. +Require Import Errors. +Require Import Maps. +Require Import Integers. +Require Import Floats. +Require Import Values. +Require Import AST. +Require Import Memory. +Require Import Events. +Require Import Globalenvs. +Require Import Smallstep. +Require Import Determinism. +Require Import Csyntax. +Require Import Csem. + +Section STRATEGY. + +Variable ge: genv. + +(** * Definition of the strategy *) + +(** We now formalize a particular strategy for reducing expressions which + is the one implemented by the CompCert compiler. It evaluates effectful + subexpressions first, in leftmost-innermost order, then finishes + with the evaluation of the remaining simple expression. *) + +(** Simple expressions are defined as follows. *) + +Fixpoint simple (a: expr) : Prop := + match a with + | Eloc _ _ _ => True + | Evar _ _ => True + | Ederef r _ => simple r + | Efield l1 _ _ => simple l1 + | Eval _ _ => True + | Evalof l _ => simple l + | Eaddrof l _ => simple l + | Eunop _ r1 _ => simple r1 + | Ebinop _ r1 r2 _ => simple r1 /\ simple r2 + | Ecast r1 _ => simple r1 + | Econdition _ _ _ _ => False + | Esizeof _ _ => True + | Eassign _ _ _ => False + | Eassignop _ _ _ _ _ => False + | Epostincr _ _ _ => False + | Ecomma _ _ _ => False + | Ecall _ _ _ => False + | Eparen _ _ => False + end. + +Fixpoint simplelist (rl: exprlist) : Prop := + match rl with Enil => True | Econs r rl' => simple r /\ simplelist rl' end. + +(** Simple expressions have interesting properties: their evaluations always + terminate, are deterministic, and preserve the memory state. + We seize this opportunity to define a big-step semantics for simple + expressions. *) + +Section SIMPLE_EXPRS. + +Variable e: env. +Variable m: mem. + +Inductive eval_simple_lvalue: expr -> block -> int -> Prop := + | esl_loc: forall b ofs ty, + eval_simple_lvalue (Eloc b ofs ty) b ofs + | esl_var_local: forall x ty b, + e!x = Some(b, ty) -> + eval_simple_lvalue (Evar x ty) b Int.zero + | esl_var_global: forall x ty b, + e!x = None -> + Genv.find_symbol ge x = Some b -> + type_of_global ge b = Some ty -> + eval_simple_lvalue (Evar x ty) b Int.zero + | esl_deref: forall r ty b ofs, + eval_simple_rvalue r (Vptr b ofs) -> + eval_simple_lvalue (Ederef r ty) b ofs + | esl_field_struct: forall l f ty b ofs id fList delta, + eval_simple_lvalue l b ofs -> + typeof l = Tstruct id fList -> field_offset f fList = OK delta -> + eval_simple_lvalue (Efield l f ty) b (Int.add ofs (Int.repr delta)) + | esl_field_union: forall l f ty b ofs id fList, + eval_simple_lvalue l b ofs -> + typeof l = Tunion id fList -> + eval_simple_lvalue (Efield l f ty) b ofs + +with eval_simple_rvalue: expr -> val -> Prop := + | esr_val: forall v ty, + eval_simple_rvalue (Eval v ty) v + | esr_rvalof: forall b ofs l ty v, + eval_simple_lvalue l b ofs -> + ty = typeof l -> + load_value_of_type ty m b ofs = Some v -> + eval_simple_rvalue (Evalof l ty) v + | esr_addrof: forall b ofs l ty, + eval_simple_lvalue l b ofs -> + eval_simple_rvalue (Eaddrof l ty) (Vptr b ofs) + | esr_unop: forall op r1 ty v1 v, + eval_simple_rvalue r1 v1 -> + sem_unary_operation op v1 (typeof r1) = Some v -> + eval_simple_rvalue (Eunop op r1 ty) v + | esr_binop: forall op r1 r2 ty v1 v2 v, + eval_simple_rvalue r1 v1 -> eval_simple_rvalue r2 v2 -> + sem_binary_operation op v1 (typeof r1) v2 (typeof r2) m = Some v -> + eval_simple_rvalue (Ebinop op r1 r2 ty) v + | esr_cast: forall ty r1 v1 v, + eval_simple_rvalue r1 v1 -> + cast v1 (typeof r1) ty v -> + eval_simple_rvalue (Ecast r1 ty) v + | esr_sizeof: forall ty1 ty, + eval_simple_rvalue (Esizeof ty1 ty) (Vint (Int.repr (sizeof ty1))). + +Inductive eval_simple_list: exprlist -> typelist -> list val -> Prop := + | esrl_nil: + eval_simple_list Enil Tnil nil + | esrl_cons: forall r rl ty tyl v vl v', + eval_simple_rvalue r v' -> cast v' (typeof r) ty v -> + eval_simple_list rl tyl vl -> + eval_simple_list (Econs r rl) (Tcons ty tyl) (v :: vl). + +Scheme eval_simple_rvalue_ind2 := Minimality for eval_simple_rvalue Sort Prop + with eval_simple_lvalue_ind2 := Minimality for eval_simple_lvalue Sort Prop. +Combined Scheme eval_simple_rvalue_lvalue_ind from eval_simple_rvalue_ind2, eval_simple_lvalue_ind2. + +End SIMPLE_EXPRS. + +(** Left reduction contexts. These contexts allow reducing to the right + of a binary operator only if the left subexpression is simple. *) + +Inductive leftcontext: kind -> kind -> (expr -> expr) -> Prop := + | lctx_top: forall k, + leftcontext k k (fun x => x) + | lctx_deref: forall k C ty, + leftcontext k RV C -> leftcontext k LV (fun x => Ederef (C x) ty) + | lctx_field: forall k C f ty, + leftcontext k LV C -> leftcontext k LV (fun x => Efield (C x) f ty) + | lctx_rvalof: forall k C ty, + leftcontext k LV C -> leftcontext k RV (fun x => Evalof (C x) ty) + | lctx_addrof: forall k C ty, + leftcontext k LV C -> leftcontext k RV (fun x => Eaddrof (C x) ty) + | lctx_unop: forall k C op ty, + leftcontext k RV C -> leftcontext k RV (fun x => Eunop op (C x) ty) + | lctx_binop_left: forall k C op e2 ty, + leftcontext k RV C -> leftcontext k RV (fun x => Ebinop op (C x) e2 ty) + | lctx_binop_right: forall k C op e1 ty, + simple e1 -> leftcontext k RV C -> + leftcontext k RV (fun x => Ebinop op e1 (C x) ty) + | lctx_cast: forall k C ty, + leftcontext k RV C -> leftcontext k RV (fun x => Ecast (C x) ty) + | lctx_condition: forall k C r2 r3 ty, + leftcontext k RV C -> leftcontext k RV (fun x => Econdition (C x) r2 r3 ty) + | lctx_assign_left: forall k C e2 ty, + leftcontext k LV C -> leftcontext k RV (fun x => Eassign (C x) e2 ty) + | lctx_assign_right: forall k C e1 ty, + simple e1 -> leftcontext k RV C -> + leftcontext k RV (fun x => Eassign e1 (C x) ty) + | lctx_assignop_left: forall k C op e2 tyres ty, + leftcontext k LV C -> leftcontext k RV (fun x => Eassignop op (C x) e2 tyres ty) + | lctx_assignop_right: forall k C op e1 tyres ty, + simple e1 -> leftcontext k RV C -> + leftcontext k RV (fun x => Eassignop op e1 (C x) tyres ty) + | lctx_postincr: forall k C id ty, + leftcontext k LV C -> leftcontext k RV (fun x => Epostincr id (C x) ty) + | lctx_call_left: forall k C el ty, + leftcontext k RV C -> leftcontext k RV (fun x => Ecall (C x) el ty) + | lctx_call_right: forall k C e1 ty, + simple e1 -> leftcontextlist k C -> + leftcontext k RV (fun x => Ecall e1 (C x) ty) + | lctx_comma: forall k C e2 ty, + leftcontext k RV C -> leftcontext k RV (fun x => Ecomma (C x) e2 ty) + | lctx_paren: forall k C ty, + leftcontext k RV C -> leftcontext k RV (fun x => Eparen (C x) ty) + +with leftcontextlist: kind -> (expr -> exprlist) -> Prop := + | lctx_list_head: forall k C el, + leftcontext k RV C -> leftcontextlist k (fun x => Econs (C x) el) + | lctx_list_tail: forall k C e1, + simple e1 -> leftcontextlist k C -> + leftcontextlist k (fun x => Econs e1 (C x)). + +Lemma leftcontext_context: + forall k1 k2 C, leftcontext k1 k2 C -> context k1 k2 C +with leftcontextlist_contextlist: + forall k C, leftcontextlist k C -> contextlist k C. +Proof. + induction 1; constructor; auto. + induction 1; constructor; auto. +Qed. + +Hint Resolve leftcontext_context. + +(** Strategy for reducing expressions. We reduce the leftmost innermost + non-simple subexpression, evaluating its arguments (which are necessarily + simple expressions) with the big-step semantics. + If there are none, the whole expression is simple and is evaluated in + one big step. *) + +Inductive estep: state -> trace -> state -> Prop := + + | step_expr: forall f r k e m v ty, + eval_simple_rvalue e m r v -> + match r with Eval _ _ => False | _ => True end -> + ty = typeof r -> + estep (ExprState f r k e m) + E0 (ExprState f (Eval v ty) k e m) + + | step_condition_true: forall f C r1 r2 r3 ty k e m v, + leftcontext RV RV C -> + eval_simple_rvalue e m r1 v -> + is_true v (typeof r1) -> + typeof r2 = ty -> + estep (ExprState f (C (Econdition r1 r2 r3 ty)) k e m) + E0 (ExprState f (C (Eparen r2 ty)) k e m) + + | step_condition_false: forall f C r1 r2 r3 ty k e m v, + leftcontext RV RV C -> + eval_simple_rvalue e m r1 v -> + is_false v (typeof r1) -> + typeof r3 = ty -> + estep (ExprState f (C (Econdition r1 r2 r3 ty)) k e m) + E0 (ExprState f (C (Eparen r3 ty)) k e m) + + | step_assign: forall f C l r ty k e m b ofs v v' m', + leftcontext RV RV C -> + eval_simple_lvalue e m l b ofs -> + eval_simple_rvalue e m r v -> + cast v (typeof r) (typeof l) v' -> + store_value_of_type (typeof l) m b ofs v' = Some m' -> + ty = typeof l -> + estep (ExprState f (C (Eassign l r ty)) k e m) + E0 (ExprState f (C (Eval v' ty)) k e m') + + | step_assignop: forall f C op l r tyres ty k e m b ofs v1 v2 v3 v4 m', + leftcontext RV RV C -> + eval_simple_lvalue e m l b ofs -> + load_value_of_type (typeof l) m b ofs = Some v1 -> + eval_simple_rvalue e m r v2 -> + sem_binary_operation op v1 (typeof l) v2 (typeof r) m = Some v3 -> + cast v3 tyres (typeof l) v4 -> + store_value_of_type (typeof l) m b ofs v4 = Some m' -> + ty = typeof l -> + estep (ExprState f (C (Eassignop op l r tyres ty)) k e m) + E0 (ExprState f (C (Eval v4 ty)) k e m') + + | step_postincr: forall f C id l ty k e m b ofs v1 v2 v3 m', + leftcontext RV RV C -> + eval_simple_lvalue e m l b ofs -> + load_value_of_type ty m b ofs = Some v1 -> + sem_incrdecr id v1 ty = Some v2 -> + cast v2 (typeconv ty) ty v3 -> + store_value_of_type ty m b ofs v3 = Some m' -> + ty = typeof l -> + estep (ExprState f (C (Epostincr id l ty)) k e m) + E0 (ExprState f (C (Eval v1 ty)) k e m') + + | step_comma: forall f C r1 r2 ty k e m v, + leftcontext RV RV C -> + eval_simple_rvalue e m r1 v -> + ty = typeof r2 -> + estep (ExprState f (C (Ecomma r1 r2 ty)) k e m) + E0 (ExprState f (C r2) k e m) + + | step_paren: forall f C r ty k e m v, + leftcontext RV RV C -> + eval_simple_rvalue e m r v -> + ty = typeof r -> + estep (ExprState f (C (Eparen r ty)) k e m) + E0 (ExprState f (C (Eval v ty)) k e m) + + | step_call: forall f C rf rargs ty k e m targs tres vf vargs fd, + leftcontext RV RV C -> + typeof rf = Tfunction targs tres -> + eval_simple_rvalue e m rf vf -> + eval_simple_list e m rargs targs vargs -> + Genv.find_funct ge vf = Some fd -> + type_of_fundef fd = Tfunction targs tres -> + estep (ExprState f (C (Ecall rf rargs ty)) k e m) + E0 (Callstate fd vargs (Kcall f e C ty k) m). + +Definition step (S: state) (t: trace) (S': state) : Prop := + estep S t S' \/ sstep ge S t S'. + +(** * Safe executions. *) + +(** A C program is safe (in the nondeterministic strategy) + if it cannot get stuck. The definition is parameterized by + an external world (cf. file [Determinism]) to constrain the behavior + of external functions. *) + +Inductive immsafe: world -> state -> Prop := + | immsafe_final: forall w s r, + final_state s r -> + immsafe w s + | immsafe_step: forall w s t s' w', + Csem.step ge s t s' -> possible_trace w t w' -> + immsafe w s. + +Definition safe (w: world) (s: Csem.state) : Prop := + forall t s' w', star Csem.step ge s t s' -> possible_trace w t w' -> immsafe w' s'. + +Lemma safe_steps: + forall w s t s' w', + safe w s -> star Csem.step ge s t s' -> possible_trace w t w' -> safe w' s'. +Proof. + intros; red; intros. + eapply H. eapply star_trans; eauto. eapply possible_trace_app; eauto. +Qed. + +Lemma safe_imm: + forall w s, safe w s -> immsafe w s. +Proof. + intros. eapply H. apply star_refl. constructor. +Qed. + +Lemma not_stuck_val: + forall e v ty m, + not_stuck ge e (Eval v ty) m. +Proof. + intros; red; intros. inv H; try congruence. subst e'. constructor. +Qed. + +Lemma safe_not_stuck: + forall w f a k e m, + safe w (ExprState f a k e m) -> + not_stuck ge e a m. +Proof. + intros. exploit safe_imm; eauto; intro IS; inv IS. + inv H0. + inv H0. inv H2; auto; apply not_stuck_val. inv H2; apply not_stuck_val. +Qed. + +Lemma safe_not_imm_stuck: + forall k C w f a K e m, + safe w (ExprState f (C a) K e m) -> + context k RV C -> + not_imm_stuck ge e k a m. +Proof. + intros. exploit safe_not_stuck; eauto. +Qed. + +(** Simple, non-stuck expressions are well-formed with respect to + l-values and r-values. *) + +Lemma context_compose: + forall k2 k3 C2, context k2 k3 C2 -> + forall k1 C1, context k1 k2 C1 -> + context k1 k3 (fun x => C2(C1 x)) +with contextlist_compose: + forall k2 C2, contextlist k2 C2 -> + forall k1 C1, context k1 k2 C1 -> + contextlist k1 (fun x => C2(C1 x)). +Proof. + induction 1; intros; try (constructor; eauto). + replace (fun x => C1 x) with C1. auto. apply extensionality; auto. + induction 1; intros; constructor; eauto. +Qed. + +Definition expr_kind (a: expr) : kind := + match a with + | Eloc _ _ _ => LV + | Evar _ _ => LV + | Ederef _ _ => LV + | Efield _ _ _ => LV + | _ => RV + end. + +Lemma lred_kind: + forall e a m a' m', lred ge e a m a' m' -> expr_kind a = LV. +Proof. + induction 1; auto. +Qed. + +Lemma rred_kind: + forall a m a' m', rred a m a' m' -> expr_kind a = RV. +Proof. + induction 1; auto. +Qed. + +Lemma callred_kind: + forall a fd args ty, callred ge a fd args ty -> expr_kind a = RV. +Proof. + induction 1; auto. +Qed. + +Lemma context_kind: + forall a from to C, context from to C -> expr_kind a = from -> expr_kind (C a) = to. +Proof. + induction 1; intros; simpl; auto. +Qed. + +Lemma not_imm_stuck_kind: + forall e k a m, not_imm_stuck ge e k a m -> expr_kind a = k. +Proof. + induction 1. + auto. + auto. + eapply context_kind; eauto. eapply lred_kind; eauto. + eapply context_kind; eauto. eapply rred_kind; eauto. + eapply context_kind; eauto. eapply callred_kind; eauto. +Qed. + +Lemma safe_expr_kind: + forall from C w f a k e m, + context from RV C -> + safe w (ExprState f (C a) k e m) -> + expr_kind a = from. +Proof. + intros. eapply not_imm_stuck_kind. eapply safe_not_imm_stuck; eauto. +Qed. + +(** Painful inversion lemmas on particular states that are not stuck. *) + +Section INVERSION_LEMMAS. + +Variable e: env. + +Fixpoint exprlist_all_values (rl: exprlist) : Prop := + match rl with + | Enil => True + | Econs (Eval v ty) rl' => exprlist_all_values rl' + | Econs _ _ => False + end. + +Definition invert_expr_prop (a: expr) (m: mem) : Prop := + match a with + | Eloc b ofs ty => False + | Evar x ty => + exists b, + e!x = Some(b, ty) + \/ (e!x = None /\ Genv.find_symbol ge x = Some b /\ type_of_global ge b = Some ty) + | Ederef (Eval v ty1) ty => + exists b, exists ofs, v = Vptr b ofs + | Efield (Eloc b ofs ty1) f ty => + match ty1 with + | Tstruct _ fList => exists delta, field_offset f fList = Errors.OK delta + | Tunion _ _ => True + | _ => False + end + | Eval v ty => False + | Evalof (Eloc b ofs ty') ty => + ty' = ty /\ exists v, load_value_of_type ty m b ofs = Some v + | Eunop op (Eval v1 ty1) ty => + exists v, sem_unary_operation op v1 ty1 = Some v + | Ebinop op (Eval v1 ty1) (Eval v2 ty2) ty => + exists v, sem_binary_operation op v1 ty1 v2 ty2 m = Some v + | Ecast (Eval v1 ty1) ty => + exists v, cast v1 ty1 ty v + | Econdition (Eval v1 ty1) r1 r2 ty => + ((is_true v1 ty1 /\ typeof r1 = ty) \/ (is_false v1 ty1 /\ typeof r2 = ty)) + | Eassign (Eloc b ofs ty1) (Eval v2 ty2) ty => + exists v, exists m', + ty = ty1 /\ cast v2 ty2 ty1 v /\ store_value_of_type ty1 m b ofs v = Some m' + | Eassignop op (Eloc b ofs ty1) (Eval v2 ty2) tyres ty => + exists v1, exists v, exists v', exists m', + ty = ty1 + /\ load_value_of_type ty1 m b ofs = Some v1 + /\ sem_binary_operation op v1 ty1 v2 ty2 m = Some v + /\ cast v tyres ty1 v' + /\ store_value_of_type ty1 m b ofs v' = Some m' + | Epostincr id (Eloc b ofs ty1) ty => + exists v1, exists v2, exists v3, exists m', + ty = ty1 + /\ load_value_of_type ty m b ofs = Some v1 + /\ sem_incrdecr id v1 ty = Some v2 + /\ cast v2 (typeconv ty) ty v3 + /\ store_value_of_type ty m b ofs v3 = Some m' + | Ecomma (Eval v ty1) r2 ty => + typeof r2 = ty + | Eparen (Eval v ty1) ty => + ty = ty1 + | Ecall (Eval vf tyf) rargs ty => + exprlist_all_values rargs -> + exists tyargs, exists tyres, exists fd, exists vl, + tyf = Tfunction tyargs tyres + /\ Genv.find_funct ge vf = Some fd + /\ cast_arguments rargs tyargs vl + /\ type_of_fundef fd = Tfunction tyargs tyres + | _ => True + end. + +Lemma lred_invert: + forall l m l' m', lred ge e l m l' m' -> invert_expr_prop l m. +Proof. + induction 1; red; auto. + exists b; auto. + exists b; auto. + exists b; exists ofs; auto. + exists delta; auto. +Qed. + +Lemma rred_invert: + forall r m r' m', rred r m r' m' -> invert_expr_prop r m. +Proof. + induction 1; red; auto. + split; auto; exists v; auto. + exists v; auto. + exists v; auto. + exists v; auto. + exists v; exists m'; auto. + exists v1; exists v; exists v'; exists m'; auto. + exists v1; exists v2; exists v3; exists m'; auto. + destruct r; auto. +Qed. + +Lemma callred_invert: + forall r fd args ty m, + callred ge r fd args ty -> + invert_expr_prop r m. +Proof. + intros. inv H. simpl. + intros. exists tyargs; exists tyres; exists fd; exists args; auto. +Qed. + +Scheme context_ind2 := Minimality for context Sort Prop + with contextlist_ind2 := Minimality for contextlist Sort Prop. +Combined Scheme context_contextlist_ind from context_ind2, contextlist_ind2. + +Lemma invert_expr_context: + (forall from to C, context from to C -> + forall a m, + invert_expr_prop a m -> + invert_expr_prop (C a) m) +/\(forall from C, contextlist from C -> + forall a m, + invert_expr_prop a m -> + ~exprlist_all_values (C a)). +Proof. + apply context_contextlist_ind; intros; try (exploit H0; [eauto|intros]). + auto. + simpl. destruct (C a); auto. contradiction. + simpl. destruct (C a); auto. contradiction. + simpl. destruct (C a); auto. contradiction. + simpl. auto. + simpl. destruct (C a); auto. contradiction. + simpl. destruct (C a); auto. contradiction. + simpl. + destruct e1; auto. destruct (C a); auto. contradiction. + simpl. destruct (C a); auto. contradiction. + simpl. destruct (C a); auto. contradiction. + simpl. destruct (C a); auto. contradiction. + simpl. + destruct e1; auto. destruct (C a); auto. contradiction. + simpl. destruct (C a); auto. contradiction. + simpl. + destruct e1; auto. destruct (C a); auto. contradiction. + simpl. destruct (C a); auto. contradiction. + simpl. destruct (C a); auto. contradiction. + simpl. destruct e1; auto. intros. elim (H0 a m); auto. + simpl. destruct (C a); auto. contradiction. + simpl. destruct (C a); auto. contradiction. + simpl. red; intros. destruct (C a); auto. + simpl; red; intros. destruct e1; auto. elim (H0 a m); auto. +Qed. + +Lemma not_imm_stuck_inv: + forall k a m, + not_imm_stuck ge e k a m -> + match a with + | Eloc _ _ _ => True + | Eval _ _ => True + | _ => invert_expr_prop a m + end. +Proof. + destruct invert_expr_context as [A B]. + intros. inv H. + auto. + auto. + assert (invert_expr_prop (C e0) m). + eapply A; eauto. eapply lred_invert; eauto. + red in H. destruct (C e0); auto; contradiction. + assert (invert_expr_prop (C e0) m). + eapply A; eauto. eapply rred_invert; eauto. + red in H. destruct (C e0); auto; contradiction. + assert (invert_expr_prop (C e0) m). + eapply A; eauto. eapply callred_invert; eauto. + red in H. destruct (C e0); auto; contradiction. +Qed. + +End INVERSION_LEMMAS. + +(** * Correctness of the strategy. *) + +Section SIMPLE_EVAL. + +Variable f: function. +Variable k: cont. +Variable e: env. +Variable m: mem. +Variable w: world. + +Lemma simple_eval: + forall a from C, + simple a -> context from RV C -> safe w (ExprState f (C a) k e m) -> + match from with + | LV => + exists b, exists ofs, + eval_simple_lvalue e m a b ofs + /\ star Csem.step ge (ExprState f (C a) k e m) + E0 (ExprState f (C (Eloc b ofs (typeof a))) k e m) + | RV => + exists v, + eval_simple_rvalue e m a v + /\ star Csem.step ge (ExprState f (C a) k e m) + E0 (ExprState f (C (Eval v (typeof a))) k e m) + end. +Proof. + induction a; intros from C S CTX SAFE; + generalize (safe_expr_kind _ _ _ _ _ _ _ _ CTX SAFE); intro K; subst; + simpl in S; try contradiction; simpl. +(* val *) + exists v; split. constructor. apply star_refl. +(* var *) + exploit not_imm_stuck_inv. eapply safe_not_imm_stuck; eauto. + simpl. intros [b A]. + exists b; exists Int.zero; split. + intuition. apply esl_var_local; auto. apply esl_var_global; auto. + apply star_one. left; apply step_lred. + intuition. apply red_var_local; auto. apply red_var_global; auto. + eapply safe_not_stuck; eauto. auto. +(* field *) + set (C1 := fun x => Efield x f0 ty). + set (C2 := fun x => C(C1 x)). + exploit (IHa LV C2); auto. eapply context_compose; eauto. repeat constructor. + unfold C2, C1; intros [b [ofs [A B]]]. + exploit not_imm_stuck_inv. + eapply safe_not_imm_stuck. eapply safe_steps; eauto. constructor. eauto. + simpl. + case_eq (typeof a); intros; try contradiction. + destruct H0 as [delta EQ]. + exists b; econstructor; split. + eapply esl_field_struct; eauto. + eapply star_right. eauto. left; apply step_lred. + rewrite H. constructor; auto. + eapply safe_not_stuck. eapply safe_steps; eauto. constructor. auto. + traceEq. + exists b; exists ofs; split. + eapply esl_field_union; eauto. + eapply star_right. eauto. left; apply step_lred. + rewrite H. constructor; auto. + eapply safe_not_stuck. eapply safe_steps; eauto. constructor. auto. + traceEq. +(* valof *) + set (C1 := fun x => Evalof x ty). + set (C2 := fun x => C(C1 x)). + exploit (IHa LV C2); auto. eapply context_compose; eauto. repeat constructor. + unfold C2, C1; intros [b [ofs [A B]]]. + exploit not_imm_stuck_inv. + eapply safe_not_imm_stuck. eapply safe_steps; eauto. constructor. eauto. + simpl. intros [D [v E]]. + exists v; split. + econstructor; eauto. + eapply star_right. eauto. left; apply step_rred. + simpl. rewrite D. constructor. auto. + eapply safe_not_stuck. eapply safe_steps; eauto. constructor. auto. + traceEq. +(* deref *) + set (C1 := fun x => Ederef x ty). + set (C2 := fun x => C(C1 x)). + exploit (IHa RV C2); auto. eapply context_compose; eauto. repeat constructor. + unfold C2, C1; intros [v1 [A B]]. + exploit not_imm_stuck_inv. + eapply safe_not_imm_stuck. eapply safe_steps; eauto. constructor. eauto. + simpl. intros [b [ofs D]]. subst v1. + exists b; exists ofs; split. + econstructor; eauto. + eapply star_right. eauto. left; apply step_lred. + simpl. constructor. + eapply safe_not_stuck. eapply safe_steps; eauto. constructor. auto. + traceEq. +(* addrof *) + set (C1 := fun x => Eaddrof x ty). + set (C2 := fun x => C(C1 x)). + exploit (IHa LV C2); auto. eapply context_compose; eauto. repeat constructor. + unfold C2, C1; intros [b [ofs [A B]]]. + exists (Vptr b ofs); split. + econstructor; eauto. + eapply star_right. eauto. left; apply step_rred. + simpl. constructor. + eapply safe_not_stuck. eapply safe_steps; eauto. constructor. auto. + traceEq. +(* unop *) + set (C1 := fun x => Eunop op x ty). + set (C2 := fun x => C(C1 x)). + exploit (IHa RV C2); auto. eapply context_compose; eauto. repeat constructor. + unfold C2, C1; intros [v1 [A B]]. + exploit not_imm_stuck_inv. + eapply safe_not_imm_stuck. eapply safe_steps; eauto. constructor. eauto. + simpl. intros [v E]. + exists v; split. + econstructor; eauto. + eapply star_right. eauto. left; apply step_rred. + simpl. constructor. auto. + eapply safe_not_stuck. eapply safe_steps; eauto. constructor. auto. + traceEq. +(* binop *) + set (C1 := fun x => Ebinop op x a2 ty). + set (C2 := fun x => C(C1 x)). + exploit (IHa1 RV C2). tauto. eapply context_compose; eauto. repeat constructor. auto. + unfold C2, C1; intros [v1 [A B]]. + assert (safe w (ExprState f (C (Ebinop op (Eval v1 (typeof a1)) a2 ty)) k e m)). + eapply safe_steps; eauto. constructor. + set (C3 := fun x => Ebinop op (Eval v1 (typeof a1)) x ty). + set (C4 := fun x => C(C3 x)). + exploit (IHa2 RV C4). tauto. eapply context_compose; eauto. repeat constructor. auto. + unfold C4, C3; intros [v2 [D E]]. + assert (safe w (ExprState f (C (Ebinop op (Eval v1 (typeof a1)) (Eval v2 (typeof a2)) ty)) k e m)). + eapply safe_steps; eauto. constructor. + exploit not_imm_stuck_inv. + eapply safe_not_imm_stuck. eexact H0. eauto. + simpl. intros [v F]. + exists v; split. + econstructor; eauto. + eapply star_right. eapply star_trans; eauto. left; apply step_rred. + simpl. constructor. auto. + eapply safe_not_stuck. eauto. + auto. + traceEq. +(* cast *) + set (C1 := fun x => Ecast x ty). + set (C2 := fun x => C(C1 x)). + exploit (IHa RV C2); auto. eapply context_compose; eauto. repeat constructor. + unfold C2, C1; intros [v1 [A B]]. + exploit not_imm_stuck_inv. + eapply safe_not_imm_stuck. eapply safe_steps; eauto. constructor. eauto. + simpl. intros [v E]. + exists v; split. + econstructor; eauto. + eapply star_right. eauto. left; apply step_rred. + simpl. constructor. auto. + eapply safe_not_stuck. eapply safe_steps; eauto. constructor. auto. + traceEq. +(* sizeof *) + econstructor; split. constructor. + apply star_one. left; apply step_rred. constructor. + eapply safe_not_stuck; eauto. + auto. +(* loc *) + exploit not_imm_stuck_inv. eapply safe_not_imm_stuck; eauto. + simpl. intros. + exists b; exists ofs; split. constructor. apply star_refl. +Qed. + +Lemma simple_eval_r: + forall r C, + simple r -> context RV RV C -> safe w (ExprState f (C r) k e m) -> + exists v, + eval_simple_rvalue e m r v + /\ star Csem.step ge (ExprState f (C r) k e m) + E0 (ExprState f (C (Eval v (typeof r))) k e m). +Proof. + intros. apply (simple_eval r RV); auto. +Qed. + +Lemma simple_eval_l: + forall l C, + simple l -> context LV RV C -> safe w (ExprState f (C l) k e m) -> + exists b, exists ofs, + eval_simple_lvalue e m l b ofs + /\ star Csem.step ge (ExprState f (C l) k e m) + E0 (ExprState f (C (Eloc b ofs (typeof l))) k e m). +Proof. + intros. apply (simple_eval l LV); auto. +Qed. + +Fixpoint rval_list (vl: list val) (rl: exprlist) : exprlist := + match vl, rl with + | v1 :: vl', Econs r1 rl' => Econs (Eval v1 (typeof r1)) (rval_list vl' rl') + | _, _ => Enil + end. + +Inductive eval_simple_list': exprlist -> list val -> Prop := + | esrl'_nil: + eval_simple_list' Enil nil + | esrl'_cons: forall r rl v vl, + eval_simple_rvalue e m r v -> + eval_simple_list' rl vl -> + eval_simple_list' (Econs r rl) (v :: vl). + +Fixpoint exprlist_app (rl1 rl2: exprlist) : exprlist := + match rl1 with + | Enil => rl2 + | Econs r1 rl1' => Econs r1 (exprlist_app rl1' rl2) + end. + +Lemma exprlist_app_assoc: + forall rl2 rl3 rl1, + exprlist_app (exprlist_app rl1 rl2) rl3 = + exprlist_app rl1 (exprlist_app rl2 rl3). +Proof. + induction rl1; auto. simpl. congruence. +Qed. + +Inductive contextlist' : (exprlist -> expr) -> Prop := + | contextlist'_intro: forall r1 rl0 ty C, + context RV RV C -> + contextlist' (fun rl => C (Ecall r1 (exprlist_app rl0 rl) ty)). + +Lemma exprlist_app_context: + forall rl1 rl2, + contextlist RV (fun x => exprlist_app rl1 (Econs x rl2)). +Proof. + induction rl1; simpl; intros. + apply ctx_list_head. constructor. + apply ctx_list_tail. auto. +Qed. + +Lemma contextlist'_head: + forall rl C, + contextlist' C -> + context RV RV (fun x => C (Econs x rl)). +Proof. + intros. inv H. + set (C' := fun x => Ecall r1 (exprlist_app rl0 (Econs x rl)) ty). + assert (context RV RV C'). constructor. apply exprlist_app_context. + change (context RV RV (fun x => C0 (C' x))). + eapply context_compose; eauto. +Qed. + +Lemma contextlist'_tail: + forall r1 C, + contextlist' C -> + contextlist' (fun x => C (Econs r1 x)). +Proof. + intros. inv H. + replace (fun x => C0 (Ecall r0 (exprlist_app rl0 (Econs r1 x)) ty)) + with (fun x => C0 (Ecall r0 (exprlist_app (exprlist_app rl0 (Econs r1 Enil)) x) ty)). + constructor. auto. + apply extensionality; intros. f_equal. f_equal. apply exprlist_app_assoc. +Qed. + +Lemma simple_eval_rlist: + forall rl C, + simplelist rl -> + contextlist' C -> + safe w (ExprState f (C rl) k e m) -> + exists vl, + eval_simple_list' rl vl + /\ star Csem.step ge (ExprState f (C rl) k e m) + E0 (ExprState f (C (rval_list vl rl)) k e m). +Proof. + induction rl; intros. + econstructor; split. constructor. simpl. apply star_refl. + simpl in H; destruct H. + set (C1 := fun x => C (Econs x rl)). + exploit (simple_eval_r r1 C1). auto. apply contextlist'_head. auto. auto. + unfold C1; intros [v [X Y]]. + assert (safe w (ExprState f (C (Econs (Eval v (typeof r1)) rl)) k e m)). + eapply safe_steps; eauto. constructor. + set (C2 := fun x => C (Econs (Eval v (typeof r1)) x)). + destruct (IHrl C2) as [vl [U V]]. auto. apply contextlist'_tail. auto. auto. + unfold C2 in V. + exists (v :: vl); split. constructor; auto. + simpl. eapply star_trans; eauto. +Qed. + +Lemma rval_list_all_values: + forall vl rl, exprlist_all_values (rval_list vl rl). +Proof. + induction vl; simpl; intros. auto. + destruct rl; simpl; auto. +Qed. + +Lemma can_eval_simple_list: + forall rl vl, + eval_simple_list' rl vl -> + forall tyl vl', + cast_arguments (rval_list vl rl) tyl vl' -> + eval_simple_list e m rl tyl vl'. +Proof. + induction 1; simpl; intros. + inv H. constructor. + inv H1. econstructor; eauto. +Qed. + +End SIMPLE_EVAL. + +(** Decomposition *) + +Section DECOMPOSITION. + +Variable f: function. +Variable k: cont. +Variable e: env. +Variable m: mem. +Variable w: world. + +Definition simple_side_effect (r: expr) : Prop := + match r with + | Econdition r1 r2 r3 ty => simple r1 + | Eassign l1 r2 _ => simple l1 /\ simple r2 + | Eassignop _ l1 r2 _ _ => simple l1 /\ simple r2 + | Epostincr _ l1 _ => simple l1 + | Ecomma r1 r2 _ => simple r1 + | Ecall r1 rl _ => simple r1 /\ simplelist rl + | Eparen r1 _ => simple r1 + | _ => False + end. + +Scheme expr_ind2 := Induction for expr Sort Prop + with exprlist_ind2 := Induction for exprlist Sort Prop. +Combined Scheme expr_expr_list_ind from expr_ind2, exprlist_ind2. + +Lemma decompose_expr: + (forall a from C, + context from RV C -> safe w (ExprState f (C a) k e m) -> + simple a + \/ exists C', exists a', simple_side_effect a' /\ leftcontext RV from C' /\ a = C' a') +/\(forall rl C, + contextlist' C -> safe w (ExprState f (C rl) k e m) -> + simplelist rl + \/ exists C', exists a', simple_side_effect a' /\ leftcontextlist RV C' /\ rl = C' a'). +Proof. + apply expr_expr_list_ind; intros; simpl; auto. +(* field *) + exploit safe_expr_kind; eauto; simpl; intros. subst. + destruct (H LV (fun x => C (Efield x f0 ty))) as [A | [C' [a' [A [B D]]]]]. + eapply context_compose; eauto. repeat constructor. auto. + auto. + right; exists (fun x => Efield (C' x) f0 ty); exists a'. + split. auto. split. constructor; auto. rewrite D; auto. +(* rvalof *) + exploit safe_expr_kind; eauto; simpl; intros. subst. + destruct (H LV (fun x => C (Evalof x ty))) as [A | [C' [a' [A [B D]]]]]. + eapply context_compose; eauto. repeat constructor. auto. + auto. + right; exists (fun x => Evalof (C' x) ty); exists a'. + split. auto. split. constructor; auto. rewrite D; auto. +(* deref *) + exploit safe_expr_kind; eauto; simpl; intros. subst. + subst. destruct (H RV (fun x => C (Ederef x ty))) as [A | [C' [a' [A [B D]]]]]. + eapply context_compose; eauto. repeat constructor. auto. + auto. + right; exists (fun x => Ederef (C' x) ty); exists a'. + split. auto. split. constructor; auto. rewrite D; auto. +(* addrof *) + exploit safe_expr_kind; eauto; simpl; intros. subst. + destruct (H LV (fun x => C (Eaddrof x ty))) as [A | [C' [a' [A [B D]]]]]. + eapply context_compose; eauto. repeat constructor. auto. + auto. + right; exists (fun x => Eaddrof (C' x) ty); exists a'. + split. auto. split. constructor; auto. rewrite D; auto. +(* unop *) + exploit safe_expr_kind; eauto; simpl; intros. subst. + destruct (H RV (fun x => C (Eunop op x ty))) as [A | [C' [a' [A [B D]]]]]. + eapply context_compose; eauto. repeat constructor. auto. + auto. + right; exists (fun x => Eunop op (C' x) ty); exists a'. + split. auto. split. constructor; auto. rewrite D; auto. +(* binop *) + exploit safe_expr_kind; eauto; simpl; intros. subst. + destruct (H RV (fun x => C (Ebinop op x r2 ty))) as [A | [C' [a' [A [B D]]]]]. + eapply context_compose; eauto. repeat constructor. auto. + destruct (H0 RV (fun x => C (Ebinop op r1 x ty))) as [A' | [C' [a' [A' [B D]]]]]. + eapply context_compose; eauto. repeat constructor. auto. + auto. + right; exists (fun x => Ebinop op r1 (C' x) ty); exists a'. + split. auto. split. constructor; auto. rewrite D; auto. + right; exists (fun x => Ebinop op (C' x) r2 ty); exists a'. + split. auto. split. constructor; auto. rewrite D; auto. +(* cast *) + exploit safe_expr_kind; eauto; simpl; intros. subst. + destruct (H RV (fun x => C (Ecast x ty))) as [A | [C' [a' [A [B D]]]]]. + eapply context_compose; eauto. repeat constructor. auto. + auto. + right; exists (fun x => Ecast (C' x) ty); exists a'. + split. auto. split. constructor; auto. rewrite D; auto. +(* condition *) + exploit safe_expr_kind; eauto; simpl; intros. subst. + destruct (H RV (fun x => C(Econdition x r2 r3 ty))) as [A | [C' [a' [A [B D]]]]]. + eapply context_compose; eauto. repeat constructor. auto. + right. exists (fun x => x); exists (Econdition r1 r2 r3 ty). + split. red; auto. split. constructor. auto. + right; exists (fun x => Econdition (C' x) r2 r3 ty); exists a'. + split. auto. split. constructor; auto. rewrite D; auto. +(* assign *) + exploit safe_expr_kind; eauto; simpl; intros. subst. + destruct (H LV (fun x => C (Eassign x r ty))) as [A | [C' [a' [A [B D]]]]]. + eapply context_compose; eauto. repeat constructor. auto. + destruct (H0 RV (fun x => C (Eassign l x ty))) as [A' | [C' [a' [A' [B D]]]]]. + eapply context_compose; eauto. repeat constructor. auto. + right. exists (fun x => x); exists (Eassign l r ty). + split. red; auto. split. constructor. auto. + right; exists (fun x => Eassign l (C' x) ty); exists a'. + split. auto. split. constructor; auto. rewrite D; auto. + right; exists (fun x => Eassign (C' x) r ty); exists a'. + split. auto. split. constructor; auto. rewrite D; auto. +(* assignop *) + exploit safe_expr_kind; eauto; simpl; intros. subst. + destruct (H LV (fun x => C (Eassignop op x r tyres ty))) as [A | [C' [a' [A [B D]]]]]. + eapply context_compose; eauto. repeat constructor. auto. + destruct (H0 RV (fun x => C (Eassignop op l x tyres ty))) as [A' | [C' [a' [A' [B D]]]]]. + eapply context_compose; eauto. repeat constructor. auto. + right. exists (fun x => x); exists (Eassignop op l r tyres ty). + split. red; auto. split. constructor. auto. + right; exists (fun x => Eassignop op l (C' x) tyres ty); exists a'. + split. auto. split. constructor; auto. rewrite D; auto. + right; exists (fun x => Eassignop op (C' x) r tyres ty); exists a'. + split. auto. split. constructor; auto. rewrite D; auto. +(* postincr *) + exploit safe_expr_kind; eauto; simpl; intros. subst. + destruct (H LV (fun x => C(Epostincr id x ty))) as [A | [C' [a' [A [B D]]]]]. + eapply context_compose; eauto. repeat constructor. auto. + right. exists (fun x => x); exists (Epostincr id l ty). + split. red; auto. split. constructor. auto. + right; exists (fun x => Epostincr id (C' x) ty); exists a'. + split. auto. split. econstructor; eauto. rewrite D; auto. +(* comma *) + exploit safe_expr_kind; eauto; simpl; intros. subst. + destruct (H RV (fun x => C(Ecomma x r2 ty))) as [A | [C' [a' [A [B D]]]]]. + eapply context_compose; eauto. repeat constructor. auto. + right. exists (fun x => x); exists (Ecomma r1 r2 ty). + split. red; auto. split. constructor. auto. + right; exists (fun x => Ecomma (C' x) r2 ty); exists a'. + split. auto. split. econstructor; eauto. rewrite D; auto. +(* call *) + exploit safe_expr_kind; eauto; simpl; intros. subst. + destruct (H RV (fun x => C (Ecall x rargs ty))) as [A | [C' [a' [A [B D]]]]]. + eapply context_compose; eauto. repeat constructor. auto. + destruct (H0 (fun x => C (Ecall r1 x ty))) as [A' | [C' [a' [A' [B D]]]]]. + eapply contextlist'_intro with (C := C) (rl0 := Enil). auto. auto. + right. exists (fun x => x); exists (Ecall r1 rargs ty). + split. red; auto. split. constructor. auto. + right; exists (fun x => Ecall r1 (C' x) ty); exists a'. + split. auto. split. constructor; auto. rewrite D; auto. + right; exists (fun x => Ecall (C' x) rargs ty); exists a'. + split. auto. split. constructor; auto. rewrite D; auto. +(* rparen *) + exploit safe_expr_kind; eauto; simpl; intros. subst. + destruct (H RV (fun x => C (Eparen x ty))) as [A | [C' [a' [A [B D]]]]]. + eapply context_compose; eauto. repeat constructor. auto. + right. exists (fun x => x); exists (Eparen r ty). + split. red; auto. split. constructor. auto. + right; exists (fun x => Eparen (C' x) ty); exists a'. + split. auto. split. econstructor; eauto. rewrite D; auto. +(* cons *) + destruct (H RV (fun x => C (Econs x rl))) as [A | [C' [a' [A [B D]]]]]. + eapply contextlist'_head; eauto. auto. + destruct (H0 (fun x => C (Econs r1 x))) as [A' | [C' [a' [A' [B D]]]]]. + eapply contextlist'_tail; eauto. auto. + auto. + right; exists (fun x => Econs r1 (C' x)); exists a'. + split. auto. split. constructor; auto. rewrite D; auto. + right; exists (fun x => Econs (C' x) rl); exists a'. + split. auto. split. constructor; auto. rewrite D; auto. +Qed. + +Lemma decompose_topexpr: + forall a, + safe w (ExprState f a k e m) -> + simple a + \/ exists C, exists a', simple_side_effect a' /\ leftcontext RV RV C /\ a = C a'. +Proof. + intros. eapply (proj1 decompose_expr). apply ctx_top. auto. +Qed. + +End DECOMPOSITION. + +(** Simulation for expressions. *) + +Lemma can_estep: + forall w f a k e m, + safe w (ExprState f a k e m) -> + match a with Eval _ _ => False | _ => True end -> + exists S, + estep (ExprState f a k e m) E0 S + /\ plus Csem.step ge (ExprState f a k e m) E0 S. +Proof. + intros. destruct (decompose_topexpr f k e m w a H) as [A | [C [b [P [Q R]]]]]. +(* expr *) + exploit (simple_eval_r f k e m w a (fun x => x)); auto. constructor. + intros [v [S T]]. + econstructor; split. + eapply step_expr; eauto. + inversion T. rewrite H2 in H0. contradiction. econstructor; eauto. +(* side effect *) + clear H0. subst a. red in P. destruct b; try contradiction. +(* condition *) + set (C1 := fun x => Econdition x b2 b3 ty). + exploit (simple_eval_r f k e m w b1 (fun x => C(C1 x))). auto. + eapply context_compose; eauto. repeat constructor. auto. + unfold C1; intros [v [A B]]. + exploit not_imm_stuck_inv. + eapply safe_not_imm_stuck. eapply safe_steps; eauto. constructor. eauto. + simpl. intros [[X Y] | [X Y]]. + econstructor; split. eapply step_condition_true; eauto. + eapply plus_right. eauto. left; eapply step_rred. constructor; auto. + eapply safe_not_stuck. eapply safe_steps; eauto. constructor. apply leftcontext_context; auto. + traceEq. + econstructor; split. eapply step_condition_false; eauto. + eapply plus_right. eauto. left; eapply step_rred. constructor; auto. + eapply safe_not_stuck. eapply safe_steps; eauto. constructor. apply leftcontext_context; auto. + traceEq. +(* assign *) + destruct P. + set (C1 := fun x => Eassign x b2 ty). + exploit (simple_eval_l f k e m w b1 (fun x => C(C1 x))). auto. + eapply context_compose; eauto. repeat constructor. auto. + unfold C1; intros [blk [ofs [A B]]]. + assert (S1: safe w (ExprState f (C (Eassign (Eloc blk ofs (typeof b1)) b2 ty)) k e m)). + eapply safe_steps; eauto. constructor. + set (C2 := fun x => Eassign (Eloc blk ofs (typeof b1)) x ty). + exploit (simple_eval_r f k e m w b2 (fun x => C(C2 x))). auto. + eapply context_compose; eauto. repeat constructor. auto. + unfold C2; intros [v [E F]]. + assert (S2: safe w (ExprState f + (C (Eassign (Eloc blk ofs (typeof b1)) (Eval v (typeof b2)) ty)) k e + m)). + eapply safe_steps; eauto. constructor. + exploit not_imm_stuck_inv. eapply safe_not_imm_stuck. eexact S2. eauto. + simpl. intros [v' [m' [X [Y Z]]]]. + econstructor; split. + eapply step_assign with (C := C); eauto. + eapply star_plus_trans. eapply star_trans; eauto. + apply plus_one. left. apply step_rred. rewrite X. econstructor; eauto. + eapply safe_not_stuck; eauto. apply leftcontext_context; auto. + traceEq. +(* assignop *) + destruct P. + set (C1 := fun x => Eassignop op x b2 tyres ty). + exploit (simple_eval_l f k e m w b1 (fun x => C(C1 x))). auto. + eapply context_compose; eauto. repeat constructor. auto. + unfold C1; intros [blk [ofs [A B]]]. + assert (S1: safe w (ExprState f (C (Eassignop op (Eloc blk ofs (typeof b1)) b2 tyres ty)) k e m)). + eapply safe_steps; eauto. constructor. + set (C2 := fun x => Eassignop op (Eloc blk ofs (typeof b1)) x tyres ty). + exploit (simple_eval_r f k e m w b2 (fun x => C(C2 x))). auto. + eapply context_compose; eauto. repeat constructor. auto. + unfold C2; intros [v [E F]]. + assert (S2: safe w (ExprState f + (C + (Eassignop op (Eloc blk ofs (typeof b1)) (Eval v (typeof b2)) + tyres ty)) k e m)). + eapply safe_steps; eauto. constructor. + exploit not_imm_stuck_inv. eapply safe_not_imm_stuck. eexact S2. eauto. + simpl. intros [v1 [v2 [v3 [m' [U [V [W [X Y]]]]]]]]. + econstructor; split. + eapply step_assignop with (C := C); eauto. + eapply star_plus_trans. eapply star_trans; eauto. + apply plus_one. left. apply step_rred. rewrite U. econstructor; eauto. + eapply safe_not_stuck; eauto. apply leftcontext_context; auto. + traceEq. +(* postincr *) + set (C1 := fun x => Epostincr id x ty). + exploit (simple_eval_l f k e m w b (fun x => C(C1 x))). auto. + eapply context_compose; eauto. repeat constructor. auto. + unfold C1; intros [blk [ofs [A B]]]. + assert (S1: safe w (ExprState f (C (Epostincr id (Eloc blk ofs (typeof b)) ty)) k e m)). + eapply safe_steps; eauto. constructor. + exploit not_imm_stuck_inv. eapply safe_not_imm_stuck. eexact S1. eauto. + simpl. intros [v1 [v2 [v3 [m' [U [V [W [X Y]]]]]]]]. + econstructor; split. + eapply step_postincr with (C := C); eauto. + eapply star_plus_trans. eauto. + apply plus_one. left. apply step_rred. subst ty. econstructor; eauto. + eapply safe_not_stuck; eauto. apply leftcontext_context; auto. + traceEq. +(* comma *) + set (C1 := fun x => Ecomma x b2 ty). + exploit (simple_eval_r f k e m w b1 (fun x => C(C1 x))). auto. + eapply context_compose; eauto. repeat constructor. auto. + unfold C1; intros [v1 [A B]]. + assert (S1: safe w (ExprState f (C (Ecomma (Eval v1 (typeof b1)) b2 ty)) k e m)). + eapply safe_steps; eauto. constructor. + exploit not_imm_stuck_inv. eapply safe_not_imm_stuck. eexact S1. eauto. + simpl. intro X. + econstructor; split. + eapply step_comma with (C := C); eauto. + eapply star_plus_trans. eauto. + apply plus_one. left. apply step_rred. subst ty. econstructor; eauto. + eapply safe_not_stuck; eauto. apply leftcontext_context; auto. + traceEq. +(* call *) + destruct P. + set (C1 := fun x => Ecall x rargs ty). + exploit (simple_eval_r f k e m w b (fun x => C(C1 x))). auto. + eapply context_compose; eauto. repeat constructor. auto. + unfold C1; intros [vf [A B]]. + assert (S1: safe w (ExprState f (C (Ecall (Eval vf (typeof b)) rargs ty)) k e m)). + eapply safe_steps; eauto. constructor. + exploit (simple_eval_rlist f k e m w rargs (fun x => C(Ecall (Eval vf (typeof b)) x ty))). + auto. eapply contextlist'_intro with (rl0 := Enil). auto. auto. + intros [vl [E F]]. + assert (S2: safe w (ExprState f (C (Ecall (Eval vf (typeof b)) (rval_list vl rargs) ty)) + k e m)). + eapply safe_steps; eauto. constructor. + exploit not_imm_stuck_inv. eapply safe_not_imm_stuck. eexact S2. eauto. + simpl. intros X. + destruct X as [tyargs [tyres [fd [vl' [U [V [W X]]]]]]]. + apply rval_list_all_values. + econstructor; split. + eapply step_call with (C := C); eauto. eapply can_eval_simple_list; eauto. + eapply plus_right. eapply star_trans; eauto. + left. econstructor. rewrite U. econstructor; eauto. + eapply safe_not_stuck; eauto. apply leftcontext_context; auto. + traceEq. +(* rparen *) + set (C1 := fun x => Eparen x ty). + exploit (simple_eval_r f k e m w b (fun x => C(C1 x))). auto. + eapply context_compose; eauto. repeat constructor. auto. + unfold C1; intros [v [A B]]. + assert (S1: safe w (ExprState f (C (Eparen (Eval v (typeof b)) ty)) k e m)). + eapply safe_steps; eauto. constructor. + exploit not_imm_stuck_inv. eapply safe_not_imm_stuck. eexact S1. eauto. + simpl. intros EQ. subst ty. + econstructor; split. + eapply step_paren with (C := C); eauto. + eapply star_plus_trans. eauto. + apply plus_one. left. apply step_rred. econstructor; eauto. + eapply safe_not_stuck; eauto. apply leftcontext_context; auto. + traceEq. +Qed. + +(** The main simulation result. *) + +Theorem strategy_simulation: + forall w S, + safe w S -> + (exists r, final_state S r) + \/ (exists t, exists S', exists w', + step S t S' + /\ plus Csem.step ge S t S' + /\ possible_trace w t w'). +Proof. + intros. exploit safe_imm; eauto. intros IS; inv IS. +(* terminated *) + left; exists r; auto. + destruct H0. +(* expression step *) + inv H0. + (* lred *) + exploit can_estep; eauto. inv H4; auto. + intros [S [A B]]. right. exists E0; exists S; exists w. + split. left; auto. split. auto. constructor. + (* rred *) + exploit can_estep; eauto. inv H4; auto. inv H2; auto. + intros [S [A B]]. right. exists E0; exists S; exists w. + split. left; auto. split. auto. constructor. + (* callred *) + exploit can_estep; eauto. inv H4; auto. inv H2; auto. + intros [S [A B]]. right. exists E0; exists S; exists w. + split. left; auto. split. auto. constructor. +(* other step *) + right. exists t; exists s'; exists w'. + split. right. auto. + split. apply plus_one. right. auto. + auto. +Qed. + +End STRATEGY. + +(** * Whole-program behaviors *) + +Definition exec_program (p: program) (beh: program_behavior) : Prop := + program_behaves step (initial_state p) final_state (Genv.globalenv p) beh. + +Definition safeprog (p: program) (w: world) : Prop := + (exists s, initial_state p s) + /\ (forall s, initial_state p s -> safe (Genv.globalenv p) w s). + +(** We now show the existence of a safe behavior for the strategy, + which is also an acceptable behavior for the nondeterministic semantics. *) + +Section BEHAVIOR. + +Variable prog: program. +Variable initial_world: world. + +(** We define a transition semantics that combines +- one strategy step; +- one or several nondeterministic steps; +- the state of the external world. +*) + +Local Open Scope pair_scope. + +Definition comb_state := (state * world)%type. + +Definition comb_step (ge: genv) (s: comb_state) (t: trace) (s': comb_state) : Prop := + (step ge s#1 t s'#1 /\ plus Csem.step ge s#1 t s'#1) + /\ possible_trace s#2 t s'#2. + +Definition comb_initial_state (s: comb_state) : Prop := + initial_state prog s#1 /\ s#2 = initial_world. + +Definition comb_final_state (s: comb_state) (r: int) : Prop := + final_state s#1 r. + +Definition comb_program_behaves (beh: program_behavior) : Prop := + program_behaves comb_step comb_initial_state comb_final_state (Genv.globalenv prog) beh. + +(** If the source program is safe, the combined semantics cannot go wrong. *) + +Remark proj_star_comb_step: + forall ge s t s', + star comb_step ge s t s' -> + star Csem.step ge s#1 t s'#1 /\ possible_trace s#2 t s'#2. +Proof. + induction 1. split; constructor. + destruct H as [[A B] C]. destruct IHstar. + split. eapply star_trans. apply plus_star; eauto. eauto. auto. + subst t. eapply possible_trace_app; eauto. +Qed. + +Lemma comb_behavior_not_wrong: + forall beh, + safeprog prog initial_world -> comb_program_behaves beh -> not_wrong beh. +Proof. + intros. destruct H. inv H0; simpl; auto. +(* Goes wrong after some steps *) + destruct H2. exploit proj_star_comb_step; eauto. intros [A B]. + assert (C: safe (Genv.globalenv prog) s'#2 s'#1). + eapply safe_steps. apply H1. eauto. eauto. congruence. + exploit strategy_simulation. eexact C. + intros [[r P] | [t' [s'' [w'' [P [Q R]]]]]]. + elim (H5 r). auto. + elim (H4 t' (s'', w'')). red. auto. +(* Goes initiall wrong *) + destruct H as [s A]. elim (H2 (s, initial_world)). red; auto. +Qed. + +(** Any non-wrong behavior of the combined semantics is a behavior + for the nondeterministic semantics. *) + +Lemma proj1_comb_behavior: + forall beh, + not_wrong beh -> + comb_program_behaves beh -> + Csem.exec_program prog beh. +Proof. + intros. red in H0. red. + eapply simulation_plus_preservation with + (match_states := fun (S1: comb_state) (S2: state) => S2 = S1#1); eauto. + intros. destruct H1. exists (st1#1); auto. + intros. red in H2. congruence. + intros. destruct H1 as [[A B] D]. subst st2. exists (st1'#1); auto. +Qed. + +(** Likewise, any non-wrong behavior of the combined semantics is a behavior + for the strategy. *) + +Lemma proj2_comb_behavior: + forall beh, + not_wrong beh -> + comb_program_behaves beh -> + exec_program prog beh. +Proof. + intros. red in H0. red. + eapply simulation_step_preservation with + (match_states := fun (S1: comb_state) (S2: state) => S2 = S1#1); eauto. + intros. destruct H1. exists (st1#1); auto. + intros. red in H2. congruence. + intros. destruct H1 as [[A B] D]. subst st2. exists (st1'#1); auto. +Qed. + +(** Finally, any behavior of the combined semantics is possible in the + initial world. *) + +Lemma possible_comb_behavior: + forall beh, + comb_program_behaves beh -> + possible_behavior initial_world beh. +Proof. + intros. + apply (project_behaviors_trace _ _ + (fun ge s t s' => step ge s t s' /\ plus Csem.step ge s t s') + (initial_state prog) + final_state + initial_world (Genv.globalenv prog)). + exact H. +Qed. + +(** It follows that a safe C program has a non-wrong behavior that + follows the strategy. *) + +Theorem strategy_behavior: + safeprog prog initial_world -> + exists beh, not_wrong beh + /\ Csem.exec_program prog beh + /\ exec_program prog beh + /\ possible_behavior initial_world beh. +Proof. + intros. + assert (exists beh, comb_program_behaves beh). + unfold comb_program_behaves. apply program_behaves_exists. + destruct H0 as [beh CPB]. + assert (not_wrong beh). eapply comb_behavior_not_wrong; eauto. + exists beh. split. auto. + split. apply proj1_comb_behavior; auto. + split. apply proj2_comb_behavior; auto. + apply possible_comb_behavior; auto. +Qed. + +End BEHAVIOR. + +(** * A big-step semantics implementing the reduction strategy. *) + +Section BIGSTEP. + +Variable ge: genv. + +(** The execution of a statement produces an ``outcome'', indicating + how the execution terminated: either normally or prematurely + through the execution of a [break], [continue] or [return] statement. *) + +Inductive outcome: Type := + | Out_break: outcome (**r terminated by [break] *) + | Out_continue: outcome (**r terminated by [continue] *) + | Out_normal: outcome (**r terminated normally *) + | Out_return: option (val * type) -> outcome. (**r terminated by [return] *) + +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 => ty <> Tvoid /\ cast v' ty' ty v + | _, _ => False + end. + +(** [eval_expression ge e m1 a t m2 a'] describes the evaluation of the + complex expression e. [v] is the resulting value, [m2] the final + memory state, and [t] the trace of input/output events performed + during this evaluation. *) + +Inductive eval_expression: env -> mem -> expr -> trace -> mem -> val -> Prop := + | eval_expression_intro: forall e m a t m' a' v, + eval_expr e m RV a t m' a' -> eval_simple_rvalue ge e m' a' v -> + eval_expression e m a t m' v + +with eval_expr: env -> mem -> kind -> expr -> trace -> mem -> expr -> Prop := + | eval_val: forall e m v ty, + eval_expr e m RV (Eval v ty) E0 m (Eval v ty) + | eval_var: forall e m x ty, + eval_expr e m LV (Evar x ty) E0 m (Evar x ty) + | eval_field: forall e m a t m' a' f ty, + eval_expr e m LV a t m' a' -> + eval_expr e m LV (Efield a f ty) t m' (Efield a' f ty) + | eval_valof: forall e m a t m' a' ty, + eval_expr e m LV a t m' a' -> + eval_expr e m RV (Evalof a ty) t m' (Evalof a' ty) + | eval_deref: forall e m a t m' a' ty, + eval_expr e m RV a t m' a' -> + eval_expr e m LV (Ederef a ty) t m' (Ederef a' ty) + | eval_addrof: forall e m a t m' a' ty, + eval_expr e m LV a t m' a' -> + eval_expr e m RV (Eaddrof a ty) t m' (Eaddrof a' ty) + | eval_unop: forall e m a t m' a' op ty, + eval_expr e m RV a t m' a' -> + eval_expr e m RV (Eunop op a ty) t m' (Eunop op a' ty) + | eval_binop: forall e m a1 t1 m' a1' a2 t2 m'' a2' op ty, + eval_expr e m RV a1 t1 m' a1' -> eval_expr e m' RV a2 t2 m'' a2' -> + eval_expr e m RV (Ebinop op a1 a2 ty) (t1 ** t2) m'' (Ebinop op a1' a2' ty) + | eval_cast: forall e m a t m' a' ty, + eval_expr e m RV a t m' a' -> + eval_expr e m RV (Ecast a ty) t m' (Ecast a' ty) + | eval_condition_true: forall e m a1 a2 a3 ty t1 m' a1' v1 t2 m'' a2' v, + eval_expr e m RV a1 t1 m' a1' -> eval_simple_rvalue ge e m' a1' v1 -> is_true v1 (typeof a1) -> + eval_expr e m' RV a2 t2 m'' a2' -> eval_simple_rvalue ge e m'' a2' v -> + ty = typeof a2 -> + eval_expr e m RV (Econdition a1 a2 a3 ty) (t1**t2) m'' (Eval v ty) + | eval_condition_false: forall e m a1 a2 a3 ty t1 m' a1' v1 t2 m'' a3' v, + eval_expr e m RV a1 t1 m' a1' -> eval_simple_rvalue ge e m' a1' v1 -> is_false v1 (typeof a1) -> + eval_expr e m' RV a3 t2 m'' a3' -> eval_simple_rvalue ge e m'' a3' v -> + ty = typeof a3 -> + eval_expr e m RV (Econdition a1 a2 a3 ty) (t1**t2) m'' (Eval v ty) + | eval_sizeof: forall e m ty' ty, + eval_expr e m RV (Esizeof ty' ty) E0 m (Esizeof ty' ty) + | eval_assign: forall e m l r ty t1 m1 l' t2 m2 r' b ofs v v' m3, + eval_expr e m LV l t1 m1 l' -> eval_expr e m1 RV r t2 m2 r' -> + eval_simple_lvalue ge e m2 l' b ofs -> + eval_simple_rvalue ge e m2 r' v -> + cast v (typeof r) (typeof l) v' -> + store_value_of_type (typeof l) m2 b ofs v' = Some m3 -> + ty = typeof l -> + eval_expr e m RV (Eassign l r ty) (t1**t2) m3 (Eval v' ty) + | eval_assignop: forall e m op l r tyres ty t1 m1 l' t2 m2 r' b ofs + v1 v2 v3 v4 m3, + eval_expr e m LV l t1 m1 l' -> eval_expr e m1 RV r t2 m2 r' -> + eval_simple_lvalue ge e m2 l' b ofs -> + load_value_of_type (typeof l) m2 b ofs = Some v1 -> + eval_simple_rvalue ge e m2 r' v2 -> + sem_binary_operation op v1 (typeof l) v2 (typeof r) m2 = Some v3 -> + cast v3 tyres (typeof l) v4 -> + store_value_of_type (typeof l) m2 b ofs v4 = Some m3 -> + ty = typeof l -> + eval_expr e m RV (Eassignop op l r tyres ty) (t1**t2) m3 (Eval v4 ty) + | eval_postincr: forall e m id l ty t m1 l' b ofs v1 v2 v3 m2, + eval_expr e m LV l t m1 l' -> + eval_simple_lvalue ge e m1 l' b ofs -> + load_value_of_type ty m1 b ofs = Some v1 -> + sem_incrdecr id v1 ty = Some v2 -> + cast v2 (typeconv ty) ty v3 -> + store_value_of_type ty m1 b ofs v3 = Some m2 -> + ty = typeof l -> + eval_expr e m RV (Epostincr id l ty) t m2 (Eval v1 ty) + | eval_comma: forall e m r1 r2 ty t1 m1 r1' v1 t2 m2 r2', + eval_expr e m RV r1 t1 m1 r1' -> + eval_simple_rvalue ge e m1 r1' v1 -> + eval_expr e m1 RV r2 t2 m2 r2' -> + ty = typeof r2 -> + eval_expr e m RV (Ecomma r1 r2 ty) (t1**t2) m2 r2' + | eval_call: forall e m rf rargs ty t1 m1 rf' t2 m2 rargs' vf vargs + targs tres fd t3 m3 vres, + eval_expr e m RV rf t1 m1 rf' -> eval_exprlist e m1 rargs t2 m2 rargs' -> + eval_simple_rvalue ge e m2 rf' vf -> + eval_simple_list ge e m2 rargs' targs vargs -> + typeof rf = Tfunction targs tres -> + Genv.find_funct ge vf = Some fd -> + type_of_fundef fd = Tfunction targs tres -> + eval_funcall m2 fd vargs t3 m3 vres -> + eval_expr e m RV (Ecall rf rargs ty) (t1**t2**t3) m3 (Eval vres ty) + +with eval_exprlist: env -> mem -> exprlist -> trace -> mem -> exprlist -> Prop := + | eval_nil: forall e m, + eval_exprlist e m Enil E0 m Enil + | eval_cons: forall e m a1 al t1 m1 a1' t2 m2 al', + eval_expr e m RV a1 t1 m1 a1' -> eval_exprlist e m1 al t2 m2 al' -> + eval_exprlist e m (Econs a1 al) (t1**t2) m2 (Econs a1' al') + +(** [exec_stmt ge e m1 s t m2 out] describes the execution of + the statement [s]. [out] is the outcome for this execution. + [m1] is the initial memory state, [m2] the final memory state. + [t] is the trace of input/output events performed during this + evaluation. *) + +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_Sdo: forall e m a t m' v, + eval_expression e m a t m' v -> + exec_stmt e m (Sdo a) + t m' 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_expression 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_expression 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 m' v, + eval_expression e m a t m' v -> + exec_stmt e m (Sreturn (Some a)) + t m' (Out_return (Some(v, typeof a))) + | 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 a s t m' v, + eval_expression e m a t m' v -> + is_false v (typeof a) -> + exec_stmt e m (Swhile a s) + t m' Out_normal + | exec_Swhile_stop: forall e m a s t1 m1 v t2 m2 out' out, + eval_expression e m a t1 m1 v -> + is_true v (typeof a) -> + exec_stmt e m1 s t2 m2 out' -> + out_break_or_return out' out -> + exec_stmt e m (Swhile a s) + (t1**t2) m2 out + | exec_Swhile_loop: forall e m a s t1 m1 v t2 m2 out1 t3 m3 out, + eval_expression e m a t1 m1 v -> + is_true v (typeof a) -> + exec_stmt e m1 s t2 m2 out1 -> + out_normal_or_continue out1 -> + 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 t2 m2 v, + exec_stmt e m s t1 m1 out1 -> + out_normal_or_continue out1 -> + eval_expression 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 t1 m1 out1 t2 m2 v t3 m3 out, + exec_stmt e m s t1 m1 out1 -> + out_normal_or_continue out1 -> + eval_expression 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 m' v, + eval_expression e m a2 t m' v -> + is_false v (typeof a2) -> + exec_stmt e m (Sfor Sskip a2 a3 s) + t m' Out_normal + | exec_Sfor_stop: forall e m s a2 a3 t1 m1 v t2 m2 out1 out, + eval_expression e m a2 t1 m1 v -> + is_true v (typeof a2) -> + exec_stmt e m1 s t2 m2 out1 -> + out_break_or_return out1 out -> + exec_stmt e m (Sfor Sskip a2 a3 s) + (t1 ** t2) m2 out + | exec_Sfor_loop: forall e m s a2 a3 t1 m1 v t2 m2 out1 t3 m3 t4 m4 out, + eval_expression e m a2 t1 m1 v -> + is_true v (typeof a2) -> + exec_stmt e m1 s t2 m2 out1 -> + out_normal_or_continue out1 -> + 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 sl t1 m1 n t2 m2 out, + eval_expression e m a t1 m1 (Vint n) -> + exec_stmt e m1 (seq_of_labeled_statement (select_switch n sl)) t2 m2 out -> + exec_stmt e m (Sswitch a sl) + (t1 ** t2) m2 (outcome_switch out) + +(** [eval_funcall m1 fd args t m2 res] describes the invocation of + function [fd] with arguments [args]. [res] is the value returned + by the call. *) + +with eval_funcall: mem -> fundef -> list val -> trace -> mem -> val -> Prop := + | eval_funcall_internal: forall m f vargs t e m1 m2 m3 out vres m4, + list_norepet (var_names f.(fn_params) ++ var_names f.(fn_vars)) -> + alloc_variables empty_env m (f.(fn_params) ++ f.(fn_vars)) e m1 -> + 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 -> + Mem.free_list m3 (blocks_of_env e) = Some m4 -> + eval_funcall m (Internal f) vargs t m4 vres + | eval_funcall_external: forall m ef targs tres vargs t vres m', + external_call ef ge vargs m t vres m' -> + eval_funcall m (External ef targs tres) vargs t m' vres. + +Scheme eval_expression_ind5 := Minimality for eval_expression Sort Prop + with eval_expr_ind5 := Minimality for eval_expr Sort Prop + with eval_exprlist_ind5 := Minimality for eval_exprlist Sort Prop + with exec_stmt_ind5 := Minimality for exec_stmt Sort Prop + with eval_funcall_ind5 := Minimality for eval_funcall Sort Prop. + +Combined Scheme bigstep_induction from + eval_expression_ind5, eval_expr_ind5, eval_exprlist_ind5, + exec_stmt_ind5, eval_funcall_ind5. + +(** [evalinf_expr ge e m1 K a T] denotes the fact that expression [a] + diverges in initial state [m1]. [T] is the trace of input/output + events performed during this evaluation. *) + +CoInductive evalinf_expr: env -> mem -> kind -> expr -> traceinf -> Prop := + | evalinf_field: forall e m a t f ty, + evalinf_expr e m LV a t -> + evalinf_expr e m LV (Efield a f ty) t + | evalinf_valof: forall e m a t ty, + evalinf_expr e m LV a t -> + evalinf_expr e m RV (Evalof a ty) t + | evalinf_deref: forall e m a t ty, + evalinf_expr e m RV a t -> + evalinf_expr e m LV (Ederef a ty) t + | evalinf_addrof: forall e m a t ty, + evalinf_expr e m LV a t -> + evalinf_expr e m RV (Eaddrof a ty) t + | evalinf_unop: forall e m a t op ty, + evalinf_expr e m RV a t -> + evalinf_expr e m RV (Eunop op a ty) t + | evalinf_binop_left: forall e m a1 t1 a2 op ty, + evalinf_expr e m RV a1 t1 -> + evalinf_expr e m RV (Ebinop op a1 a2 ty) t1 + | evalinf_binop_right: forall e m a1 t1 m' a1' a2 t2 op ty, + eval_expr e m RV a1 t1 m' a1' -> evalinf_expr e m' RV a2 t2 -> + evalinf_expr e m RV (Ebinop op a1 a2 ty) (t1 *** t2) + | evalinf_cast: forall e m a t ty, + evalinf_expr e m RV a t -> + evalinf_expr e m RV (Ecast a ty) t + | evalinf_condition: forall e m a1 a2 a3 ty t1, + evalinf_expr e m RV a1 t1 -> + evalinf_expr e m RV (Econdition a1 a2 a3 ty) t1 + | evalinf_condition_true: forall e m a1 a2 a3 ty t1 m' a1' v1 t2, + eval_expr e m RV a1 t1 m' a1' -> eval_simple_rvalue ge e m' a1' v1 -> is_true v1 (typeof a1) -> + evalinf_expr e m' RV a2 t2 -> + ty = typeof a2 -> + evalinf_expr e m RV (Econdition a1 a2 a3 ty) (t1***t2) + | evalinf_condition_false: forall e m a1 a2 a3 ty t1 m' a1' v1 t2, + eval_expr e m RV a1 t1 m' a1' -> eval_simple_rvalue ge e m' a1' v1 -> is_false v1 (typeof a1) -> + evalinf_expr e m' RV a3 t2 -> + ty = typeof a3 -> + evalinf_expr e m RV (Econdition a1 a2 a3 ty) (t1***t2) + | evalinf_assign_left: forall e m a1 t1 a2 ty, + evalinf_expr e m LV a1 t1 -> + evalinf_expr e m RV (Eassign a1 a2 ty) t1 + | evalinf_assign_right: forall e m a1 t1 m' a1' a2 t2 ty, + eval_expr e m LV a1 t1 m' a1' -> evalinf_expr e m' RV a2 t2 -> + evalinf_expr e m RV (Eassign a1 a2 ty) (t1 *** t2) + | evalinf_assignop_left: forall e m a1 t1 a2 op tyres ty, + evalinf_expr e m LV a1 t1 -> + evalinf_expr e m RV (Eassignop op a1 a2 tyres ty) t1 + | evalinf_assignop_right: forall e m a1 t1 m' a1' a2 t2 op tyres ty, + eval_expr e m LV a1 t1 m' a1' -> evalinf_expr e m' RV a2 t2 -> + evalinf_expr e m RV (Eassignop op a1 a2 tyres ty) (t1 *** t2) + | evalinf_postincr: forall e m a t id ty, + evalinf_expr e m LV a t -> + evalinf_expr e m RV (Epostincr id a ty) t + | evalinf_comma_left: forall e m a1 t1 a2 ty, + evalinf_expr e m RV a1 t1 -> + evalinf_expr e m RV (Ecomma a1 a2 ty) t1 + | evalinf_comma_right: forall e m a1 t1 m1 a1' v1 a2 t2 ty, + eval_expr e m RV a1 t1 m1 a1' -> eval_simple_rvalue ge e m1 a1' v1 -> + ty = typeof a2 -> + evalinf_expr e m1 RV a2 t2 -> + evalinf_expr e m RV (Ecomma a1 a2 ty) (t1 *** t2) + | evalinf_call_left: forall e m a1 t1 a2 ty, + evalinf_expr e m RV a1 t1 -> + evalinf_expr e m RV (Ecall a1 a2 ty) t1 + | evalinf_call_right: forall e m a1 t1 m1 a1' a2 t2 ty, + eval_expr e m RV a1 t1 m1 a1' -> + evalinf_exprlist e m1 a2 t2 -> + evalinf_expr e m RV (Ecall a1 a2 ty) (t1 *** t2) + | evalinf_call: forall e m rf rargs ty t1 m1 rf' t2 m2 rargs' vf vargs + targs tres fd t3, + eval_expr e m RV rf t1 m1 rf' -> eval_exprlist e m1 rargs t2 m2 rargs' -> + eval_simple_rvalue ge e m2 rf' vf -> + eval_simple_list ge e m2 rargs' targs vargs -> + typeof rf = Tfunction targs tres -> + Genv.find_funct ge vf = Some fd -> + type_of_fundef fd = Tfunction targs tres -> + evalinf_funcall m2 fd vargs t3 -> + evalinf_expr e m RV (Ecall rf rargs ty) (t1***t2***t3) + +with evalinf_exprlist: env -> mem -> exprlist -> traceinf -> Prop := + | evalinf_cons_left: forall e m a1 al t1, + evalinf_expr e m RV a1 t1 -> + evalinf_exprlist e m (Econs a1 al) t1 + | evalinf_cons_right: forall e m a1 al t1 m1 a1' t2, + eval_expr e m RV a1 t1 m1 a1' -> evalinf_exprlist e m1 al t2 -> + evalinf_exprlist e m (Econs a1 al) (t1***t2) + +(** [execinf_stmt ge e m1 s t] describes the diverging execution of + the statement [s]. *) + +with execinf_stmt: env -> mem -> statement -> traceinf -> Prop := + | execinf_Sdo: forall e m a t, + evalinf_expr e m RV a t -> + execinf_stmt e m (Sdo a) t + | execinf_Sseq_1: forall e m s1 s2 t1, + execinf_stmt e m s1 t1 -> + execinf_stmt e m (Ssequence s1 s2) t1 + | execinf_Sseq_2: forall e m s1 s2 t1 m1 t2, + exec_stmt e m s1 t1 m1 Out_normal -> + execinf_stmt e m1 s2 t2 -> + execinf_stmt e m (Ssequence s1 s2) (t1***t2) + | execinf_Sifthenelse_test: forall e m a s1 s2 t1, + evalinf_expr e m RV a t1 -> + execinf_stmt e m (Sifthenelse a s1 s2) t1 + | execinf_Sifthenelse_true: forall e m a s1 s2 t1 m1 v1 t2, + eval_expression e m a t1 m1 v1 -> + is_true v1 (typeof a) -> + execinf_stmt e m1 s1 t2 -> + execinf_stmt e m (Sifthenelse a s1 s2) (t1***t2) + | execinf_Sifthenelse_false: forall e m a s1 s2 t1 m1 v1 t2, + eval_expression e m a t1 m1 v1 -> + is_false v1 (typeof a) -> + execinf_stmt e m1 s2 t2 -> + execinf_stmt e m (Sifthenelse a s1 s2) (t1***t2) + | execinf_Sreturn_some: forall e m a t, + evalinf_expr e m RV a t -> + execinf_stmt e m (Sreturn (Some a)) t + | execinf_Swhile_test: forall e m a s t1, + evalinf_expr e m RV a t1 -> + execinf_stmt e m (Swhile a s) t1 + | execinf_Swhile_body: forall e m a s t1 m1 v t2, + eval_expression e m a t1 m1 v -> + is_true v (typeof a) -> + execinf_stmt e m1 s t2 -> + execinf_stmt e m (Swhile a s) (t1***t2) + | execinf_Swhile_loop: forall e m a s t1 m1 v t2 m2 out1 t3, + eval_expression e m a t1 m1 v -> + is_true v (typeof a) -> + exec_stmt e m1 s t2 m2 out1 -> + out_normal_or_continue out1 -> + execinf_stmt e m2 (Swhile a s) t3 -> + execinf_stmt e m (Swhile a s) (t1***t2***t3) + | execinf_Sdowhile_body: forall e m s a t1, + execinf_stmt e m s t1 -> + execinf_stmt e m (Sdowhile a s) t1 + | execinf_Sdowhile_test: forall e m s a t1 m1 out1 t2, + exec_stmt e m s t1 m1 out1 -> + out_normal_or_continue out1 -> + evalinf_expr e m1 RV a t2 -> + execinf_stmt e m (Sdowhile a s) (t1***t2) + | execinf_Sdowhile_loop: forall e m s a t1 m1 out1 t2 m2 v t3, + exec_stmt e m s t1 m1 out1 -> + out_normal_or_continue out1 -> + eval_expression e m1 a t2 m2 v -> + is_true v (typeof a) -> + execinf_stmt e m2 (Sdowhile a s) t3 -> + execinf_stmt e m (Sdowhile a s) (t1***t2***t3) + | execinf_Sfor_start_1: forall e m s a1 a2 a3 t1, + execinf_stmt e m a1 t1 -> + execinf_stmt e m (Sfor a1 a2 a3 s) t1 + | execinf_Sfor_start_2: forall e m s a1 a2 a3 m1 t1 t2, + exec_stmt e m a1 t1 m1 Out_normal -> a1 <> Sskip -> + execinf_stmt e m1 (Sfor Sskip a2 a3 s) t2 -> + execinf_stmt e m (Sfor a1 a2 a3 s) (t1***t2) + | execinf_Sfor_test: forall e m s a2 a3 t, + evalinf_expr e m RV a2 t -> + execinf_stmt e m (Sfor Sskip a2 a3 s) t + | execinf_Sfor_body: forall e m s a2 a3 t1 m1 v t2, + eval_expression e m a2 t1 m1 v -> + is_true v (typeof a2) -> + execinf_stmt e m1 s t2 -> + execinf_stmt e m (Sfor Sskip a2 a3 s) (t1***t2) + | execinf_Sfor_next: forall e m s a2 a3 t1 m1 v t2 m2 out1 t3, + eval_expression e m a2 t1 m1 v -> + is_true v (typeof a2) -> + exec_stmt e m1 s t2 m2 out1 -> + out_normal_or_continue out1 -> + execinf_stmt e m2 a3 t3 -> + execinf_stmt e m (Sfor Sskip a2 a3 s) (t1***t2***t3) + | execinf_Sfor_loop: forall e m s a2 a3 t1 m1 v t2 m2 out1 t3 m3 t4, + eval_expression e m a2 t1 m1 v -> + is_true v (typeof a2) -> + exec_stmt e m1 s t2 m2 out1 -> + out_normal_or_continue out1 -> + exec_stmt e m2 a3 t3 m3 Out_normal -> + execinf_stmt e m3 (Sfor Sskip a2 a3 s) t4 -> + execinf_stmt e m (Sfor Sskip a2 a3 s) (t1***t2***t3***t4) + | execinf_Sswitch_expr: forall e m a sl t1, + evalinf_expr e m RV a t1 -> + execinf_stmt e m (Sswitch a sl) t1 + | execinf_Sswitch_body: forall e m a sl t1 m1 n t2, + eval_expression e m a t1 m1 (Vint n) -> + execinf_stmt e m1 (seq_of_labeled_statement (select_switch n sl)) t2 -> + execinf_stmt e m (Sswitch a sl) (t1***t2) + +(** [evalinf_funcall m1 fd args t m2 res] describes a diverging + invocation of function [fd] with arguments [args]. *) + +with evalinf_funcall: mem -> fundef -> list val -> traceinf -> Prop := + | evalinf_funcall_internal: forall m f vargs t e m1 m2, + list_norepet (var_names f.(fn_params) ++ var_names f.(fn_vars)) -> + alloc_variables empty_env m (f.(fn_params) ++ f.(fn_vars)) e m1 -> + bind_parameters e m1 f.(fn_params) vargs m2 -> + execinf_stmt e m2 f.(fn_body) t -> + evalinf_funcall m (Internal f) vargs t. + +(** ** Implication from big-step semantics to transition semantics *) + +Inductive outcome_state_match + (e: env) (m: mem) (f: function) (k: cont): outcome -> state -> Prop := + | osm_normal: + outcome_state_match e m f k Out_normal (State f Sskip k e m) + | osm_break: + outcome_state_match e m f k Out_break (State f Sbreak k e m) + | osm_continue: + outcome_state_match e m f k Out_continue (State f Scontinue k e m) + | osm_return_none: forall k', + call_cont k' = call_cont k -> + outcome_state_match e m f k + (Out_return None) (State f (Sreturn None) k' e m) + | osm_return_some: forall v ty k', + call_cont k' = call_cont k -> + outcome_state_match e m f k + (Out_return (Some (v, ty))) (ExprState f (Eval v ty) (Kreturn k') e m). + +Lemma is_call_cont_call_cont: + forall k, is_call_cont k -> call_cont k = k. +Proof. + destruct k; simpl; intros; contradiction || auto. +Qed. + +Lemma leftcontext_compose: + forall k2 k3 C2, leftcontext k2 k3 C2 -> + forall k1 C1, leftcontext k1 k2 C1 -> + leftcontext k1 k3 (fun x => C2(C1 x)) +with leftcontextlist_compose: + forall k2 C2, leftcontextlist k2 C2 -> + forall k1 C1, leftcontext k1 k2 C1 -> + leftcontextlist k1 (fun x => C2(C1 x)). +Proof. + induction 1; intros; try (constructor; eauto). + replace (fun x => C1 x) with C1. auto. apply extensionality; auto. + induction 1; intros; constructor; eauto. +Qed. + +Lemma exprlist_app_leftcontext: + forall rl1 rl2, + simplelist rl1 -> leftcontextlist RV (fun x => exprlist_app rl1 (Econs x rl2)). +Proof. + induction rl1; simpl; intros. + apply lctx_list_head. constructor. + destruct H. apply lctx_list_tail. auto. auto. +Qed. + +Lemma exprlist_app_simple: + forall rl1 rl2, simplelist rl1 -> simplelist rl2 -> simplelist (exprlist_app rl1 rl2). +Proof. + induction rl1; simpl; intros. auto. destruct H; auto. +Qed. + +Lemma bigstep_to_steps: + (forall e m a t m' v, + eval_expression e m a t m' v -> + forall f k, + star step ge (ExprState f a k e m) t (ExprState f (Eval v (typeof a)) k e m')) +/\(forall e m K a t m' a', + eval_expr e m K a t m' a' -> + forall C f k, leftcontext K RV C -> + simple a' /\ typeof a' = typeof a /\ + star step ge (ExprState f (C a) k e m) t (ExprState f (C a') k e m')) +/\(forall e m al t m' al', + eval_exprlist e m al t m' al' -> + forall a1 al2 ty C f k, leftcontext RV RV C -> simple a1 -> simplelist al2 -> + simplelist al' /\ + star step ge (ExprState f (C (Ecall a1 (exprlist_app al2 al) ty)) k e m) + t (ExprState f (C (Ecall a1 (exprlist_app al2 al') ty)) k e m')) +/\(forall e m s t m' out, + exec_stmt e m s t m' out -> + forall f k, + match out with + | Out_return None => fn_return f = Tvoid + | Out_return (Some(v, ty)) => fn_return f <> Tvoid + | _ => True + end -> + exists S, + star step ge (State f s k e m) t S /\ outcome_state_match e m' f k out S) +/\(forall m fd args t m' res, + eval_funcall m fd args t m' res -> + forall k, + is_call_cont k -> + star step ge (Callstate fd args k m) t (Returnstate res k m')). +Proof. + apply bigstep_induction; intros. +(* expression, general *) + exploit (H0 (fun x => x) f k). constructor. intros [A [B C]]. + assert (match a' with Eval _ _ => False | _ => True end -> + star step ge (ExprState f a k e m) t (ExprState f (Eval v (typeof a)) k e m')). + intro. eapply star_right. eauto. left. eapply step_expr; eauto. traceEq. + destruct a'; auto. + simpl in B. rewrite B in C. inv H1. auto. + +(* val *) + simpl; intuition. apply star_refl. +(* var *) + simpl; intuition. apply star_refl. +(* field *) + exploit (H0 (fun x => C(Efield x f ty))). + eapply leftcontext_compose; eauto. repeat constructor. intros [A [B D]]. + simpl; intuition; eauto. +(* valof *) + exploit (H0 (fun x => C(Evalof x ty))). + eapply leftcontext_compose; eauto. repeat constructor. intros [A [B D]]. + simpl; intuition; eauto. +(* deref *) + exploit (H0 (fun x => C(Ederef x ty))). + eapply leftcontext_compose; eauto. repeat constructor. intros [A [B D]]. + simpl; intuition; eauto. +(* addrof *) + exploit (H0 (fun x => C(Eaddrof x ty))). + eapply leftcontext_compose; eauto. repeat constructor. intros [A [B D]]. + simpl; intuition; eauto. +(* unop *) + exploit (H0 (fun x => C(Eunop op x ty))). + eapply leftcontext_compose; eauto. repeat constructor. intros [A [B D]]. + simpl; intuition; eauto. +(* binop *) + exploit (H0 (fun x => C(Ebinop op x a2 ty))). + eapply leftcontext_compose; eauto. repeat constructor. intros [A [B D]]. + exploit (H2 (fun x => C(Ebinop op a1' x ty))). + eapply leftcontext_compose; eauto. repeat constructor. auto. intros [E [F G]]. + simpl; intuition. eapply star_trans; eauto. +(* cast *) + exploit (H0 (fun x => C(Ecast x ty))). + eapply leftcontext_compose; eauto. repeat constructor. intros [A [B D]]. + simpl; intuition; eauto. +(* condition *) + exploit (H0 (fun x => C(Econdition x a2 a3 ty))). + eapply leftcontext_compose; eauto. repeat constructor. intros [A [B D]]. + exploit (H4 (fun x => C(Eparen x ty))). + eapply leftcontext_compose; eauto. repeat constructor. intros [E [F G]]. + simpl; intuition. + eapply star_trans. eexact D. + eapply star_left. left; eapply step_condition_true; eauto. congruence. + eapply star_right. eexact G. left; eapply step_paren; eauto. congruence. + reflexivity. reflexivity. traceEq. +(* condition false *) + exploit (H0 (fun x => C(Econdition x a2 a3 ty))). + eapply leftcontext_compose; eauto. repeat constructor. intros [A [B D]]. + exploit (H4 (fun x => C(Eparen x ty))). + eapply leftcontext_compose; eauto. repeat constructor. intros [E [F G]]. + simpl; intuition. + eapply star_trans. eexact D. + eapply star_left. left; eapply step_condition_false; eauto. congruence. + eapply star_right. eexact G. left; eapply step_paren; eauto. congruence. + reflexivity. reflexivity. traceEq. +(* sizeof *) + simpl; intuition. apply star_refl. +(* assign *) + exploit (H0 (fun x => C(Eassign x r ty))). + eapply leftcontext_compose; eauto. repeat constructor. intros [A [B D]]. + exploit (H2 (fun x => C(Eassign l' x ty))). + eapply leftcontext_compose; eauto. repeat constructor. auto. intros [E [F G]]. + simpl; intuition. + eapply star_trans. eexact D. + eapply star_right. eexact G. + left. eapply step_assign; eauto. congruence. congruence. congruence. + reflexivity. traceEq. +(* assignop *) + exploit (H0 (fun x => C(Eassignop op x r tyres ty))). + eapply leftcontext_compose; eauto. repeat constructor. intros [A [B D]]. + exploit (H2 (fun x => C(Eassignop op l' x tyres ty))). + eapply leftcontext_compose; eauto. repeat constructor. auto. intros [E [F G]]. + simpl; intuition. + eapply star_trans. eexact D. + eapply star_right. eexact G. + left. eapply step_assignop; eauto. + rewrite B; eauto. rewrite B; rewrite F; eauto. congruence. congruence. congruence. + reflexivity. traceEq. +(* postincr *) + exploit (H0 (fun x => C(Epostincr id x ty))). + eapply leftcontext_compose; eauto. repeat constructor. intros [A [B D]]. + simpl; intuition. + eapply star_right. eexact D. + left. eapply step_postincr; eauto. congruence. + traceEq. +(* comma *) + exploit (H0 (fun x => C(Ecomma x r2 ty))). + eapply leftcontext_compose; eauto. repeat constructor. intros [A [B D]]. + exploit (H3 C). auto. intros [E [F G]]. + simpl; intuition. congruence. + eapply star_trans. eexact D. + eapply star_left. left; eapply step_comma; eauto. + eexact G. + reflexivity. traceEq. +(* call *) + exploit (H0 (fun x => C(Ecall x rargs ty))). + eapply leftcontext_compose; eauto. repeat constructor. intros [A [B D]]. + exploit (H2 rf' Enil ty C); eauto. red; auto. intros [E F]. + simpl; intuition. + eapply star_trans. eexact D. + eapply star_trans. eexact F. + eapply star_left. left; eapply step_call; eauto. congruence. + eapply star_right. eapply H9. red; auto. + right; constructor. + reflexivity. reflexivity. reflexivity. traceEq. +(* nil *) + simpl; intuition. apply star_refl. +(* cons *) + exploit (H0 (fun x => C(Ecall a0 (exprlist_app al2 (Econs x al)) ty))). + eapply leftcontext_compose; eauto. repeat constructor. auto. + apply exprlist_app_leftcontext; auto. intros [A [B D]]. + exploit (H2 a0 (exprlist_app al2 (Econs a1' Enil))); eauto. + apply exprlist_app_simple; auto. simpl. auto. + repeat rewrite exprlist_app_assoc. simpl. + intros [E F]. + + simpl; intuition. + eapply star_trans; eauto. + +(* skip *) + econstructor; split. apply star_refl. constructor. + +(* do *) + econstructor; split. + eapply star_left. right; constructor. + eapply star_right. apply H0. right; constructor. + reflexivity. traceEq. + constructor. + +(* sequence 2 *) + destruct (H0 f (Kseq s2 k)) as [S1 [A1 B1]]; auto. inv B1. + destruct (H2 f k) as [S2 [A2 B2]]; auto. + econstructor; split. + eapply star_left. right; econstructor. + eapply star_trans. eexact A1. + eapply star_left. right; constructor. eexact A2. + reflexivity. reflexivity. traceEq. + auto. + +(* sequence 1 *) + destruct (H0 f (Kseq s2 k)) as [S1 [A1 B1]]; auto. + set (S2 := + match out with + | Out_break => State f Sbreak k e m1 + | Out_continue => State f Scontinue k e m1 + | _ => S1 + end). + exists S2; split. + eapply star_left. right; econstructor. + eapply star_trans. eexact A1. + unfold S2; inv B1. + congruence. + apply star_one. right; apply step_break_seq. + apply star_one. right; apply step_continue_seq. + apply star_refl. + apply star_refl. + reflexivity. traceEq. + unfold S2; inv B1; congruence || econstructor; eauto. + +(* ifthenelse true *) + destruct (H3 f k) as [S1 [A1 B1]]; auto. + exists S1; split. + eapply star_left. right; apply step_ifthenelse. + eapply star_trans. eapply H0. + eapply star_left. right; eapply step_ifthenelse_true; eauto. + eexact A1. + reflexivity. reflexivity. traceEq. + auto. + +(* ifthenelse false *) + destruct (H3 f k) as [S1 [A1 B1]]; auto. + exists S1; split. + eapply star_left. right; apply step_ifthenelse. + eapply star_trans. eapply H0. + eapply star_left. right; eapply step_ifthenelse_false; eauto. + eexact A1. + reflexivity. reflexivity. traceEq. + auto. + +(* return none *) + econstructor; split. apply star_refl. constructor. auto. + +(* return some *) + econstructor; split. + eapply star_left. right; apply step_return_1. auto. + eapply H0. traceEq. + econstructor; eauto. + +(* break *) + econstructor; split. apply star_refl. constructor. + +(* continue *) + econstructor; split. apply star_refl. constructor. + +(* while false *) + econstructor; split. + eapply star_left. right; apply step_while. + eapply star_right. apply H0. right; eapply step_while_false; eauto. + reflexivity. traceEq. + constructor. + +(* while stop *) + destruct (H3 f (Kwhile2 a s k)) as [S1 [A1 B1]]. inv H4; auto. + set (S2 := + match out' with + | Out_break => State f Sskip k e m2 + | _ => S1 + end). + exists S2; split. + eapply star_left. right; apply step_while. + eapply star_trans. apply H0. + eapply star_left. right; eapply step_while_true; eauto. + eapply star_trans. eexact A1. + unfold S2. inversion H4; subst. + inv B1. apply star_one. right; constructor. + apply star_refl. + reflexivity. reflexivity. reflexivity. traceEq. + unfold S2. inversion H4; subst. constructor. inv B1; econstructor; eauto. + +(* while loop *) + destruct (H3 f (Kwhile2 a s k)) as [S1 [A1 B1]]. inv H4; auto. + destruct (H6 f k) as [S2 [A2 B2]]; auto. + exists S2; split. + eapply star_left. right; apply step_while. + eapply star_trans. apply H0. + eapply star_left. right; eapply step_while_true; eauto. + eapply star_trans. eexact A1. + eapply star_left. + inv H4; inv B1; right; apply step_skip_or_continue_while; auto. + eexact A2. + reflexivity. reflexivity. reflexivity. reflexivity. traceEq. + auto. + +(* dowhile false *) + destruct (H0 f (Kdowhile1 a s k)) as [S1 [A1 B1]]. inv H1; auto. + exists (State f Sskip k e m2); split. + eapply star_left. right; constructor. + eapply star_trans. eexact A1. + eapply star_left. + inv H1; inv B1; right; eapply step_skip_or_continue_dowhile; eauto. + eapply star_right. apply H3. + right; eapply step_dowhile_false; eauto. + reflexivity. reflexivity. reflexivity. traceEq. + constructor. + +(* dowhile stop *) + destruct (H0 f (Kdowhile1 a s k)) as [S1 [A1 B1]]. inv H1; auto. + set (S2 := + match out1 with + | Out_break => State f Sskip k e m1 + | _ => S1 + end). + exists S2; split. + eapply star_left. right; apply step_dowhile. + eapply star_trans. eexact A1. + unfold S2. inversion H1; subst. + inv B1. apply star_one. right; constructor. + apply star_refl. + reflexivity. traceEq. + unfold S2. inversion H1; subst. constructor. inv B1; econstructor; eauto. + +(* dowhile loop *) + destruct (H0 f (Kdowhile1 a s k)) as [S1 [A1 B1]]. inv H1; auto. + destruct (H6 f k) as [S2 [A2 B2]]; auto. + exists S2; split. + eapply star_left. right; constructor. + eapply star_trans. eexact A1. + eapply star_left. + inv H1; inv B1; right; eapply step_skip_or_continue_dowhile; eauto. + eapply star_trans. apply H3. + eapply star_left. right; eapply step_dowhile_true; eauto. + eexact A2. + reflexivity. reflexivity. reflexivity. reflexivity. traceEq. + auto. + +(* for start *) + assert (a1 = Sskip \/ a1 <> Sskip). destruct a1; auto; right; congruence. + destruct H4. + subst a1. inv H. apply H2; auto. + destruct (H0 f (Kseq (Sfor Sskip a2 a3 s) k)) as [S1 [A1 B1]]; auto. inv B1. + destruct (H2 f k) as [S2 [A2 B2]]; auto. + exists S2; split. + eapply star_left. right; apply step_for_start; auto. + eapply star_trans. eexact A1. + eapply star_left. right; constructor. eexact A2. + reflexivity. reflexivity. traceEq. + auto. + +(* for false *) + econstructor; split. + eapply star_left. right; apply step_for. + eapply star_right. apply H0. right; eapply step_for_false; eauto. + reflexivity. traceEq. + constructor. + +(* for stop *) + destruct (H3 f (Kfor3 a2 a3 s k)) as [S1 [A1 B1]]. inv H4; auto. + set (S2 := + match out1 with + | Out_break => State f Sskip k e m2 + | _ => S1 + end). + exists S2; split. + eapply star_left. right; apply step_for. + eapply star_trans. apply H0. + eapply star_left. right; eapply step_for_true; eauto. + eapply star_trans. eexact A1. + unfold S2. inversion H4; subst. + inv B1. apply star_one. right; constructor. + apply star_refl. + reflexivity. reflexivity. reflexivity. traceEq. + unfold S2. inversion H4; subst. constructor. inv B1; econstructor; eauto. + +(* for loop *) + destruct (H3 f (Kfor3 a2 a3 s k)) as [S1 [A1 B1]]. inv H4; auto. + destruct (H6 f (Kfor4 a2 a3 s k)) as [S2 [A2 B2]]; auto. inv B2. + destruct (H8 f k) as [S3 [A3 B3]]; auto. + exists S3; split. + eapply star_left. right; apply step_for. + eapply star_trans. apply H0. + eapply star_left. right; eapply step_for_true; eauto. + eapply star_trans. eexact A1. + eapply star_trans with (s2 := State f a3 (Kfor4 a2 a3 s k) e m2). + inv H4; inv B1. + apply star_one. right; constructor; auto. + apply star_one. right; constructor; auto. + eapply star_trans. eexact A2. + eapply star_left. right; constructor. + eexact A3. + reflexivity. reflexivity. reflexivity. reflexivity. + reflexivity. reflexivity. traceEq. + auto. + +(* switch *) + destruct (H2 f (Kswitch2 k)) as [S1 [A1 B1]]. destruct out; auto. + set (S2 := + match out with + | Out_normal => State f Sskip k e m2 + | Out_break => State f Sskip k e m2 + | Out_continue => State f Scontinue k e m2 + | _ => S1 + end). + exists S2; split. + eapply star_left. right; eapply step_switch. + eapply star_trans. apply H0. + eapply star_left. right; eapply step_expr_switch. + eapply star_trans. eexact A1. + unfold S2; inv B1. + apply star_one. right; constructor. auto. + apply star_one. right; constructor. auto. + apply star_one. right; constructor. + apply star_refl. + apply star_refl. + reflexivity. reflexivity. reflexivity. traceEq. + unfold S2. inv B1; simpl; econstructor; eauto. + +(* call internal *) + destruct (H3 f k) as [S1 [A1 B1]]. + red in H4. destruct out; auto. destruct o as [[v' ty'] | ]. + tauto. destruct (fn_return f); tauto. + eapply star_left. right; eapply step_internal_function; eauto. + eapply star_right. eexact A1. + inv B1; simpl in H4; try contradiction. + (* Out_normal *) + assert (fn_return f = Tvoid /\ vres = Vundef). + destruct (fn_return f); auto || contradiction. + destruct H7. subst vres. right; apply step_skip_call; auto. + (* Out_return None *) + assert (fn_return f = Tvoid /\ vres = Vundef). + destruct (fn_return f); auto || contradiction. + destruct H8. subst vres. + rewrite <- (is_call_cont_call_cont k H6). rewrite <- H7. + right; apply step_return_0; auto. + (* Out_return Some *) + destruct H4. + rewrite <- (is_call_cont_call_cont k H6). rewrite <- H7. + right; eapply step_return_2; eauto. + reflexivity. traceEq. + +(* call external *) + apply star_one. right; apply step_external_function; auto. +Qed. + +Lemma eval_expression_to_steps: + forall e m a t m' v, + eval_expression e m a t m' v -> + forall f k, + star step ge (ExprState f a k e m) t (ExprState f (Eval v (typeof a)) k e m'). +Proof (proj1 bigstep_to_steps). + +Lemma eval_expr_to_steps: + forall e m K a t m' a', + eval_expr e m K a t m' a' -> + forall C f k, leftcontext K RV C -> + simple a' /\ typeof a' = typeof a /\ + star step ge (ExprState f (C a) k e m) t (ExprState f (C a') k e m'). +Proof (proj1 (proj2 bigstep_to_steps)). + +Lemma eval_exprlist_to_steps: + forall e m al t m' al', + eval_exprlist e m al t m' al' -> + forall a1 al2 ty C f k, leftcontext RV RV C -> simple a1 -> simplelist al2 -> + simplelist al' /\ + star step ge (ExprState f (C (Ecall a1 (exprlist_app al2 al) ty)) k e m) + t (ExprState f (C (Ecall a1 (exprlist_app al2 al') ty)) k e m'). +Proof (proj1 (proj2 (proj2 bigstep_to_steps))). + +Lemma exec_stmt_to_steps: + forall e m s t m' out, + exec_stmt e m s t m' out -> + forall f k, + match out with + | Out_return None => fn_return f = Tvoid + | Out_return (Some(v, ty)) => fn_return f <> Tvoid + | _ => True + end -> + exists S, + star step ge (State f s k e m) t S /\ outcome_state_match e m' f k out S. +Proof (proj1 (proj2 (proj2 (proj2 bigstep_to_steps)))). + +Lemma eval_funcall_to_steps: + forall m fd args t m' res, + eval_funcall m fd args t m' res -> + forall k, + is_call_cont k -> + star step ge (Callstate fd args k m) t (Returnstate res k m'). +Proof (proj2 (proj2 (proj2 (proj2 bigstep_to_steps)))). + +Fixpoint esize (a: expr) : nat := + match a with + | Eloc _ _ _ => 1%nat + | Evar _ _ => 1%nat + | Ederef r1 _ => S(esize r1) + | Efield l1 _ _ => S(esize l1) + | Eval _ _ => O + | Evalof l1 _ => S(esize l1) + | Eaddrof l1 _ => S(esize l1) + | Eunop _ r1 _ => S(esize r1) + | Ebinop _ r1 r2 _ => S(esize r1 + esize r2)%nat + | Ecast r1 _ => S(esize r1) + | Econdition r1 _ _ _ => S(esize r1) + | Esizeof _ _ => 1%nat + | Eassign l1 r2 _ => S(esize l1 + esize r2)%nat + | Eassignop _ l1 r2 _ _ => S(esize l1 + esize r2)%nat + | Epostincr _ l1 _ => S(esize l1) + | Ecomma r1 r2 _ => S(esize r1 + esize r2)%nat + | Ecall r1 rl2 _ => S(esize r1 + esizelist rl2)%nat + | Eparen r1 _ => S(esize r1) + end + +with esizelist (el: exprlist) : nat := + match el with + | Enil => O + | Econs r1 rl2 => S(esize r1 + esizelist rl2)%nat + end. + +Lemma leftcontext_size: + forall from to C, + leftcontext from to C -> + forall e1 e2, + (esize e1 < esize e2)%nat -> + (esize (C e1) < esize (C e2))%nat +with leftcontextlist_size: + forall from C, + leftcontextlist from C -> + forall e1 e2, + (esize e1 < esize e2)%nat -> + (esizelist (C e1) < esizelist (C e2))%nat. +Proof. + induction 1; intros; simpl; auto with arith. exploit leftcontextlist_size; eauto. auto with arith. + induction 1; intros; simpl; auto with arith. exploit leftcontext_size; eauto. auto with arith. +Qed. + +Axiom ADMITTED: forall (P: Prop), P. + +Lemma evalinf_funcall_steps: + forall m fd args t k, + evalinf_funcall m fd args t -> + forever_N step lt ge O (Callstate fd args k m) t. +Proof. + cofix COF. + + assert (COS: + forall e m s t f k, + execinf_stmt e m s t -> + forever_N step lt ge O (State f s k e m) t). + cofix COS. + + assert (COE: + forall e m K a t C f k, + evalinf_expr e m K a t -> + leftcontext K RV C -> + forever_N step lt ge (esize a) (ExprState f (C a) k e m) t). + cofix COE. + + assert (COEL: + forall e m a t C f k a1 al ty, + evalinf_exprlist e m a t -> + leftcontext RV RV C -> simple a1 -> simplelist al -> + forever_N step lt ge (esizelist a) + (ExprState f (C (Ecall a1 (exprlist_app al a) ty)) k e m) t). + cofix COEL. + intros. inv H. +(* cons left *) + eapply forever_N_star with (a2 := (esize a0)). apply star_refl. simpl; omega. + eapply COE with (C := fun x => C(Ecall a1 (exprlist_app al (Econs x al0)) ty)). + eauto. eapply leftcontext_compose; eauto. constructor. auto. + apply exprlist_app_leftcontext; auto. traceEq. +(* cons right *) + destruct (eval_expr_to_steps _ _ _ _ _ _ _ H3 + (fun x => C(Ecall a1 (exprlist_app al (Econs x al0)) ty)) f k) + as [P [Q R]]. + eapply leftcontext_compose; eauto. repeat constructor. auto. + apply exprlist_app_leftcontext; auto. + eapply forever_N_star with (a2 := (esizelist al0)). + eexact R. simpl; omega. + change (Econs a1' al0) with (exprlist_app (Econs a1' Enil) al0). + rewrite <- exprlist_app_assoc. + eapply COEL. eauto. auto. auto. + apply exprlist_app_simple. auto. simpl; auto. traceEq. + + intros. inv H. +(* field *) + eapply forever_N_star with (a2 := (esize a0)). apply star_refl. simpl; omega. + eapply COE with (C := fun x => C(Efield x f0 ty)). eauto. + eapply leftcontext_compose; eauto. repeat constructor. traceEq. +(* valof *) + eapply forever_N_star with (a2 := (esize a0)). apply star_refl. simpl; omega. + eapply COE with (C := fun x => C(Evalof x ty)). eauto. + eapply leftcontext_compose; eauto. repeat constructor. traceEq. +(* deref *) + eapply forever_N_star with (a2 := (esize a0)). apply star_refl. simpl; omega. + eapply COE with (C := fun x => C(Ederef x ty)). eauto. + eapply leftcontext_compose; eauto. repeat constructor. traceEq. +(* addrof *) + eapply forever_N_star with (a2 := (esize a0)). apply star_refl. simpl; omega. + eapply COE with (C := fun x => C(Eaddrof x ty)). eauto. + eapply leftcontext_compose; eauto. repeat constructor. traceEq. +(* unop *) + eapply forever_N_star with (a2 := (esize a0)). apply star_refl. simpl; omega. + eapply COE with (C := fun x => C(Eunop op x ty)). eauto. + eapply leftcontext_compose; eauto. repeat constructor. traceEq. +(* binop left *) + eapply forever_N_star with (a2 := (esize a1)). apply star_refl. simpl; omega. + eapply COE with (C := fun x => C(Ebinop op x a2 ty)). eauto. + eapply leftcontext_compose; eauto. repeat constructor. traceEq. +(* binop right *) + destruct (eval_expr_to_steps _ _ _ _ _ _ _ H1 (fun x => C(Ebinop op x a2 ty)) f k) + as [P [Q R]]. + eapply leftcontext_compose; eauto. repeat constructor. + eapply forever_N_star with (a2 := (esize a2)). eexact R. simpl; omega. + eapply COE with (C := fun x => C(Ebinop op a1' x ty)). eauto. + eapply leftcontext_compose; eauto. repeat constructor. auto. traceEq. +(* cast *) + eapply forever_N_star with (a2 := (esize a0)). apply star_refl. simpl; omega. + eapply COE with (C := fun x => C(Ecast x ty)). eauto. + eapply leftcontext_compose; eauto. repeat constructor. traceEq. +(* condition top *) + eapply forever_N_star with (a2 := (esize a1)). apply star_refl. simpl; omega. + eapply COE with (C := fun x => C(Econdition x a2 a3 ty)). eauto. + eapply leftcontext_compose; eauto. repeat constructor. traceEq. +(* condition true *) + destruct (eval_expr_to_steps _ _ _ _ _ _ _ H1 (fun x => C(Econdition x a2 a3 (typeof a2))) f k) + as [P [Q R]]. + eapply leftcontext_compose; eauto. repeat constructor. + eapply forever_N_plus. eapply plus_right. eexact R. + left; eapply step_condition_true; eauto. congruence. + reflexivity. + eapply COE with (C := fun x => (C (Eparen x (typeof a2)))). eauto. + eapply leftcontext_compose; eauto. repeat constructor. traceEq. +(* condition false *) + destruct (eval_expr_to_steps _ _ _ _ _ _ _ H1 (fun x => C(Econdition x a2 a3 (typeof a3))) f k) + as [P [Q R]]. + eapply leftcontext_compose; eauto. repeat constructor. + eapply forever_N_plus. eapply plus_right. eexact R. + left; eapply step_condition_false; eauto. congruence. + reflexivity. + eapply COE with (C := fun x => (C (Eparen x (typeof a3)))). eauto. + eapply leftcontext_compose; eauto. repeat constructor. traceEq. +(* assign left *) + eapply forever_N_star with (a2 := (esize a1)). apply star_refl. simpl; omega. + eapply COE with (C := fun x => C(Eassign x a2 ty)). eauto. + eapply leftcontext_compose; eauto. repeat constructor. traceEq. +(* assign right *) + destruct (eval_expr_to_steps _ _ _ _ _ _ _ H1 (fun x => C(Eassign x a2 ty)) f k) + as [P [Q R]]. + eapply leftcontext_compose; eauto. repeat constructor. + eapply forever_N_star with (a2 := (esize a2)). eexact R. simpl; omega. + eapply COE with (C := fun x => C(Eassign a1' x ty)). eauto. + eapply leftcontext_compose; eauto. repeat constructor. auto. traceEq. +(* assignop left *) + eapply forever_N_star with (a2 := (esize a1)). apply star_refl. simpl; omega. + eapply COE with (C := fun x => C(Eassignop op x a2 tyres ty)). eauto. + eapply leftcontext_compose; eauto. repeat constructor. traceEq. +(* assignop right *) + destruct (eval_expr_to_steps _ _ _ _ _ _ _ H1 (fun x => C(Eassignop op x a2 tyres ty)) f k) + as [P [Q R]]. + eapply leftcontext_compose; eauto. repeat constructor. + eapply forever_N_star with (a2 := (esize a2)). eexact R. simpl; omega. + eapply COE with (C := fun x => C(Eassignop op a1' x tyres ty)). eauto. + eapply leftcontext_compose; eauto. repeat constructor. auto. traceEq. +(* postincr *) + eapply forever_N_star with (a2 := (esize a0)). apply star_refl. simpl; omega. + eapply COE with (C := fun x => C(Epostincr id x ty)). eauto. + eapply leftcontext_compose; eauto. repeat constructor. traceEq. +(* comma left *) + eapply forever_N_star with (a2 := (esize a1)). apply star_refl. simpl; omega. + eapply COE with (C := fun x => C(Ecomma x a2 ty)). eauto. + eapply leftcontext_compose; eauto. repeat constructor. traceEq. +(* comma right *) + destruct (eval_expr_to_steps _ _ _ _ _ _ _ H1 (fun x => C(Ecomma x a2 (typeof a2))) f k) + as [P [Q R]]. + eapply leftcontext_compose; eauto. repeat constructor. + eapply forever_N_plus. eapply plus_right. eexact R. + left; eapply step_comma; eauto. reflexivity. + eapply COE with (C := C); eauto. traceEq. +(* call left *) + eapply forever_N_star with (a2 := (esize a1)). apply star_refl. simpl; omega. + eapply COE with (C := fun x => C(Ecall x a2 ty)). eauto. + eapply leftcontext_compose; eauto. repeat constructor. traceEq. +(* call right *) + destruct (eval_expr_to_steps _ _ _ _ _ _ _ H1 (fun x => C(Ecall x a2 ty)) f k) + as [P [Q R]]. + eapply leftcontext_compose; eauto. repeat constructor. + eapply forever_N_star with (a2 := (esizelist a2)). eexact R. simpl; omega. + eapply COEL with (al := Enil). eauto. auto. auto. red; auto. traceEq. +(* call *) + destruct (eval_expr_to_steps _ _ _ _ _ _ _ H1 (fun x => C(Ecall x rargs ty)) f k) + as [P [Q R]]. + eapply leftcontext_compose; eauto. repeat constructor. + destruct (eval_exprlist_to_steps _ _ _ _ _ _ H2 rf' Enil ty C f k) + as [S T]. auto. auto. simpl; auto. + eapply forever_N_plus. eapply plus_right. + eapply star_trans. eexact R. eexact T. reflexivity. + simpl. left; eapply step_call; eauto. congruence. reflexivity. + apply COF. eauto. traceEq. + +(* statements *) + intros. inv H. +(* do *) + eapply forever_N_plus. apply plus_one; right; constructor. + eapply COE with (C := fun x => x); eauto. constructor. traceEq. +(* seq 1 *) + eapply forever_N_plus. apply plus_one; right; constructor. + eapply COS; eauto. traceEq. +(* seq 2 *) + destruct (exec_stmt_to_steps _ _ _ _ _ _ H0 f (Kseq s2 k)) as [S1 [A1 B1]]; auto. inv B1. + eapply forever_N_plus. + eapply plus_left. right; constructor. + eapply star_right. eauto. right; constructor. + reflexivity. reflexivity. + eapply COS; eauto. traceEq. +(* if test *) + eapply forever_N_plus. apply plus_one; right; constructor. + eapply COE with (C := fun x => x); eauto. constructor. traceEq. +(* if true *) + eapply forever_N_plus. + eapply plus_left. right; constructor. + eapply star_right. eapply eval_expression_to_steps; eauto. + right. apply step_ifthenelse_true. auto. + reflexivity. reflexivity. + eapply COS; eauto. traceEq. +(* if false *) + eapply forever_N_plus. + eapply plus_left. right; constructor. + eapply star_right. eapply eval_expression_to_steps; eauto. + right. apply step_ifthenelse_false. auto. + reflexivity. reflexivity. + eapply COS; eauto. traceEq. +(* return some *) + eapply forever_N_plus. apply plus_one; right; constructor. apply ADMITTED. + eapply COE with (C := fun x => x); eauto. constructor. traceEq. +(* while test *) + eapply forever_N_plus. apply plus_one; right; constructor. + eapply COE with (C := fun x => x); eauto. constructor. traceEq. +(* while body *) + eapply forever_N_plus. + eapply plus_left. right; constructor. + eapply star_right. eapply eval_expression_to_steps; eauto. + right; apply step_while_true; auto. + reflexivity. reflexivity. + eapply COS; eauto. traceEq. +(* while loop *) + destruct (exec_stmt_to_steps _ _ _ _ _ _ H2 f (Kwhile2 a s0 k)) as [S1 [A1 B1]]; auto. inv H3; auto. + eapply forever_N_plus. + eapply plus_left. right; constructor. + eapply star_trans. eapply eval_expression_to_steps; eauto. + eapply star_left. right; apply step_while_true; auto. + eapply star_trans. eexact A1. + inv H3; inv B1; apply star_one; right; apply step_skip_or_continue_while; auto. + reflexivity. reflexivity. reflexivity. reflexivity. + eapply COS; eauto. traceEq. +(* dowhile body *) + eapply forever_N_plus. apply plus_one; right; constructor. + eapply COS; eauto. traceEq. +(* dowhile test *) + destruct (exec_stmt_to_steps _ _ _ _ _ _ H0 f (Kdowhile1 a s0 k)) as [S1 [A1 B1]]; auto. inv H1; auto. + eapply forever_N_plus. + eapply plus_left. right; constructor. + eapply star_trans. eexact A1. + eapply star_one. right. inv H1; inv B1; apply step_skip_or_continue_dowhile; auto. + reflexivity. reflexivity. + eapply COE with (C := fun x => x); eauto. constructor. traceEq. +(* dowhile loop *) + destruct (exec_stmt_to_steps _ _ _ _ _ _ H0 f (Kdowhile1 a s0 k)) as [S1 [A1 B1]]; auto. inv H1; auto. + eapply forever_N_plus. + eapply plus_left. right; constructor. + eapply star_trans. eexact A1. + eapply star_left. right. inv H1; inv B1; apply step_skip_or_continue_dowhile; auto. + eapply star_right. eapply eval_expression_to_steps; eauto. + right; apply step_dowhile_true; auto. + reflexivity. reflexivity. reflexivity. reflexivity. + eapply COS; eauto. traceEq. +(* for start 1 *) + assert (a1 <> Sskip). red; intros; subst a1; inv H0. + eapply forever_N_plus. apply plus_one. right. constructor. auto. + eapply COS; eauto. traceEq. +(* for start 2 *) + destruct (exec_stmt_to_steps _ _ _ _ _ _ H0 f (Kseq (Sfor Sskip a2 a3 s0) k)) as [S1 [A1 B1]]; auto. inv B1. + eapply forever_N_plus. + eapply plus_left. right; constructor. auto. + eapply star_trans. eexact A1. + apply star_one. right; constructor. + reflexivity. reflexivity. + eapply COS; eauto. traceEq. +(* for test *) + eapply forever_N_plus. apply plus_one; right; apply step_for. + eapply COE with (C := fun x => x); eauto. constructor. traceEq. +(* for body *) + eapply forever_N_plus. + eapply plus_left. right; apply step_for. + eapply star_right. eapply eval_expression_to_steps; eauto. + right; apply step_for_true; auto. + reflexivity. reflexivity. + eapply COS; eauto. traceEq. +(* for next *) + destruct (exec_stmt_to_steps _ _ _ _ _ _ H2 f (Kfor3 a2 a3 s0 k)) as [S1 [A1 B1]]; auto. inv H3; auto. + eapply forever_N_plus. + eapply plus_left. right; apply step_for. + eapply star_trans. eapply eval_expression_to_steps; eauto. + eapply star_left. right; apply step_for_true; auto. + eapply star_trans. eexact A1. + inv H3; inv B1; apply star_one; right; apply step_skip_or_continue_for3; auto. + reflexivity. reflexivity. reflexivity. reflexivity. + eapply COS; eauto. traceEq. +(* for loop *) + destruct (exec_stmt_to_steps _ _ _ _ _ _ H2 f (Kfor3 a2 a3 s0 k)) as [S1 [A1 B1]]; auto. inv H3; auto. + destruct (exec_stmt_to_steps _ _ _ _ _ _ H4 f (Kfor4 a2 a3 s0 k)) as [S2 [A2 B2]]; auto. inv B2. + eapply forever_N_plus. + eapply plus_left. right; apply step_for. + eapply star_trans. eapply eval_expression_to_steps; eauto. + eapply star_left. right; apply step_for_true; auto. + eapply star_trans. eexact A1. + eapply star_left. + inv H3; inv B1; right; apply step_skip_or_continue_for3; auto. + eapply star_right. eexact A2. + right; constructor. + reflexivity. reflexivity. reflexivity. reflexivity. reflexivity. reflexivity. + eapply COS; eauto. traceEq. +(* switch expr *) + eapply forever_N_plus. apply plus_one; right; constructor. + eapply COE with (C := fun x => x); eauto. constructor. traceEq. +(* switch body *) + eapply forever_N_plus. + eapply plus_left. right; constructor. + eapply star_right. eapply eval_expression_to_steps; eauto. + right; constructor. + reflexivity. reflexivity. + eapply COS; eauto. traceEq. + +(* funcalls *) + intros. inv H. + eapply forever_N_plus. apply plus_one. right; econstructor; eauto. + eapply COS; eauto. traceEq. +Qed. + +End BIGSTEP. + +(** ** Whole-program behaviors, big-step style. *) + +Inductive bigstep_program_terminates (p: program): trace -> int -> Prop := + | bigstep_program_terminates_intro: forall b f m0 m1 t r, + let ge := Genv.globalenv p in + Genv.init_mem p = Some m0 -> + 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 (Vint r) -> + bigstep_program_terminates p t r. + +Inductive bigstep_program_diverges (p: program): traceinf -> Prop := + | bigstep_program_diverges_intro: forall b f m0 t, + let ge := Genv.globalenv p in + Genv.init_mem p = Some m0 -> + 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) -> + evalinf_funcall ge m0 f nil t -> + bigstep_program_diverges p t. + +Theorem bigstep_program_terminates_exec: + forall prog t r, + bigstep_program_terminates prog t r -> exec_program prog (Terminates t r). +Proof. + intros. inv H. + econstructor. + econstructor; eauto. + apply eval_funcall_to_steps. eauto. red; auto. + econstructor. +Qed. + +Theorem bigstep_program_diverges_exec: + forall prog T, + bigstep_program_diverges prog T -> + exec_program prog (Reacts T) \/ + exists t, exec_program prog (Diverges t) /\ traceinf_prefix t T. +Proof. + intros. inv H. + set (st := Callstate f nil Kstop m0). + assert (forever step ge st T). + eapply forever_N_forever with (order := lt). + apply lt_wf. + eapply evalinf_funcall_steps; eauto. + destruct (forever_silent_or_reactive _ _ _ _ _ _ H) + as [A | [t [s' [T' [B [C D]]]]]]. + left. econstructor. econstructor; eauto. eauto. + right. exists t. split. + econstructor. econstructor; eauto. eauto. auto. + subst T. rewrite <- (E0_right t) at 1. apply traceinf_prefix_app. constructor. +Qed. + diff --git a/cfrontend/Csyntax.v b/cfrontend/Csyntax.v index 9d0791e..6e9a860 100644 --- a/cfrontend/Csyntax.v +++ b/cfrontend/Csyntax.v @@ -13,19 +13,20 @@ (* *) (* *********************************************************************) -(** Abstract syntax for the Clight language *) +(** Abstract syntax for the Compcert C language *) Require Import Coqlib. Require Import Errors. Require Import Integers. Require Import Floats. +Require Import Values. Require Import AST. (** * Abstract syntax *) (** ** Types *) -(** Clight types are similar to those of C. They include numeric types, +(** Compcert C types are similar to those of C. They include numeric types, pointers, arrays, function types, and composite types (struct and union). Numeric types (integers and floats) fully specify the bit size of the type. An integer type is a pair of a signed/unsigned @@ -64,7 +65,7 @@ Inductive floatsize : Type := << struct s2 { int n; struct s2 next; }; >> - In Clight, struct and union types [Tstruct id fields] and + In Compcert C, struct and union types [Tstruct id fields] and [Tunion id fields] are compared by structure: the [fields] argument gives the names and types of the members. The identifier [id] is a local name which can be used in conjuction with the @@ -101,6 +102,18 @@ with fieldlist : Type := | Fnil: fieldlist | Fcons: ident -> type -> fieldlist -> fieldlist. +(** The usual unary conversion. Promotes small integer types to [signed int32] + and degrades array types and function types to pointer types. *) + +Definition typeconv (ty: type) : type := + match ty with + | Tint I32 Unsigned => ty + | Tint _ _ => Tint I32 Signed + | Tarray t sz => Tpointer t + | Tfunction _ _ => Tpointer ty + | _ => ty + end. + (** ** Expressions *) (** Arithmetic and logical operators. *) @@ -108,8 +121,7 @@ with fieldlist : Type := Inductive unary_operation : Type := | Onotbool : unary_operation (**r boolean negation ([!] in C) *) | Onotint : unary_operation (**r integer complement ([~] in C) *) - | Oneg : unary_operation (**r opposite (unary [-]) *) - | Ofabs : unary_operation. (**r floating-point absolute value *) + | Oneg : unary_operation. (**r opposite (unary [-]) *) Inductive binary_operation : Type := | Oadd : binary_operation (**r addition (binary [+]) *) @@ -129,52 +141,146 @@ Inductive binary_operation : Type := | Ole: binary_operation (**r comparison ([<=]) *) | Oge: binary_operation. (**r comparison ([>=]) *) -(** Clight expressions are a large subset of those of C. - The main omissions are string literals and assignment operators - ([=], [+=], [++], etc). In Clight, assignment is a statement, - not an expression. +Inductive incr_or_decr : Type := Incr | Decr. - All expressions are annotated with their types. An expression - (type [expr]) is therefore a pair of a type and an expression - description (type [expr_descr]). -*) +(** Compcert C expressions are almost identical to those of C. + The only omission is string literals. Some operators are treated + as derived forms: array indexing, pre-increment, pre-decrement, and + the [&&] and [||] operators. All expressions are annotated with + their types. *) Inductive expr : Type := - | Expr: expr_descr -> type -> expr - -with expr_descr : Type := - | Econst_int: int -> expr_descr (**r integer literal *) - | Econst_float: float -> expr_descr (**r float literal *) - | Evar: ident -> expr_descr (**r variable *) - | Ederef: expr -> expr_descr (**r pointer dereference (unary [*]) *) - | Eaddrof: expr -> expr_descr (**r address-of operator ([&]) *) - | Eunop: unary_operation -> expr -> expr_descr (**r unary operation *) - | Ebinop: binary_operation -> expr -> expr -> expr_descr (**r binary operation *) - | Ecast: type -> expr -> expr_descr (**r type cast ([(ty) e]) *) - | Econdition: expr -> expr -> expr -> expr_descr (**r conditional ([e1 ? e2 : e3]) *) - | Eandbool: expr -> expr -> expr_descr (**r sequential and ([&&]) *) - | Eorbool: expr -> expr -> expr_descr (**r sequential or ([||]) *) - | Esizeof: type -> expr_descr (**r size of a type *) - | Efield: expr -> ident -> expr_descr. (**r access to a member of a struct or union *) - -(** Extract the type part of a type-annotated Clight expression. *) - -Definition typeof (e: expr) : type := - match e with Expr de te => te end. + | Eval (v: val) (ty: type) (**r constant *) + | Evar (x: ident) (ty: type) (**r variable *) + | Efield (l: expr) (f: ident) (ty: type) + (**r access to a member of a struct or union *) + | Evalof (l: expr) (ty: type) (**r l-value used as a r-value *) + | Ederef (r: expr) (ty: type) (**r pointer dereference (unary [*]) *) + | Eaddrof (l: expr) (ty: type) (**r address-of operators ([&]) *) + | Eunop (op: unary_operation) (r: expr) (ty: type) + (**r unary arithmetic operation *) + | Ebinop (op: binary_operation) (r1 r2: expr) (ty: type) + (**r binary arithmetic operation *) + | Ecast (r: expr) (ty: type) (**r type cast [(ty)r] *) + | Econdition (r1 r2 r3: expr) (ty: type) (**r conditional [r1 ? r2 : r3] *) + | Esizeof (ty': type) (ty: type) (**r size of a type *) + | Eassign (l: expr) (r: expr) (ty: type) (**r assignment [l = r] *) + | Eassignop (op: binary_operation) (l: expr) (r: expr) (tyres ty: type) + (**r assignment with arithmetic [l op= r] *) + | Epostincr (id: incr_or_decr) (l: expr) (ty: type) + (**r post-increment [l++] and post-decrement [l--] *) + | Ecomma (r1 r2: expr) (ty: type) (**r sequence expression [r1, r2] *) + | Ecall (r1: expr) (rargs: exprlist) (ty: type) + (**r function call [r1(rargs)] *) + | Eloc (b: block) (ofs: int) (ty: type) + (**r memory location, result of evaluating a l-value *) + | Eparen (r: expr) (ty: type) (**r marked subexpression *) + +with exprlist : Type := + | Enil + | Econs (r1: expr) (rl: exprlist). + +(** Expressions are implicitly classified into l-values and r-values, +ranged over by [l] and [r], respectively, in the grammar above. + +L-values are those expressions that can occur to the left of an assignment. +They denote memory locations. (Indeed, the reduction semantics for +expression reduces them to [Eloc b ofs] expressions.) L-values are +variables ([Evar]), pointer dereferences ([Ederef]), field accesses ([Efield]). +R-values are all other expressions. They denote values, and the reduction +semantics reduces them to [Eval v] expressions. + +A l-value can be used in a r-value context, but this use must be marked +explicitly with the [Evalof] operator, which is not materialized in the +concrete syntax of C but denotes a read from the location corresponding to +the l-value [l] argument of [Evalof l]. + +The grammar above contains some forms that cannot appear in source terms +but appear during reduction. These forms are: +- [Eval v] where [v] is a pointer or [Vundef]. ([Eval] of an integer or + float value can occur in a source term and represents a numeric literal.) +- [Eloc b ofs], which appears during reduction of l-values. +- [Eparen r], which appears during reduction of conditionals [r1 ? r2 : r3]. + +Some C expressions are derived forms. Array access [r1[r2]] is expressed +as [*(r1 + r2)]. +*) + +Definition Eindex (r1 r2: expr) (ty: type) := + Ederef (Ebinop Oadd r1 r2 (Tpointer ty)) ty. + +(** Pre-increment [++l] and pre-decrement [--l] are expressed as + [l += 1] and [l -= 1], respectively. *) + +Definition Epreincr (id: incr_or_decr) (l: expr) (ty: type) := + Eassignop (match id with Incr => Oadd | Decr => Osub end) + l (Eval (Vint Int.one) (Tint I32 Signed)) (typeconv ty) ty. + +(** Sequential ``and'' [r1 && r2] is viewed as two conditionals + [r1 ? (r2 ? 1 : 0) : 0]. *) + +Definition Eseqand (r1 r2: expr) (ty: type) := + Econdition r1 + (Econdition r2 (Eval (Vint Int.one) (Tint I32 Signed)) + (Eval (Vint Int.zero) (Tint I32 Signed)) ty) + (Eval (Vint Int.zero) (Tint I32 Signed)) + ty. + +(** Sequential ``or'' [r1 || r2] is viewed as two conditionals + [r1 ? 1 : (r2 ? 1 : 0)]. *) + +Definition Eseqor (r1 r2: expr) (ty: type) := + Econdition r1 + (Eval (Vint Int.one) (Tint I32 Signed)) + (Econdition r2 (Eval (Vint Int.one) (Tint I32 Signed)) + (Eval (Vint Int.zero) (Tint I32 Signed)) ty) + ty. + +(** Extract the type part of a type-annotated expression. *) + +Definition typeof (a: expr) : type := + match a with + | Eloc _ _ ty => ty + | Evar _ ty => ty + | Ederef _ ty => ty + | Efield _ _ ty => ty + | Eval _ ty => ty + | Evalof _ ty => ty + | Eaddrof _ ty => ty + | Eunop _ _ ty => ty + | Ebinop _ _ _ ty => ty + | Ecast _ ty => ty + | Econdition _ _ _ ty => ty + | Esizeof _ ty => ty + | Eassign _ _ ty => ty + | Eassignop _ _ _ _ ty => ty + | Epostincr _ _ ty => ty + | Ecomma _ _ ty => ty + | Ecall _ _ ty => ty + | Eparen _ ty => ty + end. (** ** Statements *) -(** Clight statements include all C statements. - Only structured forms of [switch] are supported; moreover, - the [default] case must occur last. Blocks and block-scoped declarations - are not supported. *) +(** Compcert C statements are very much like those of C and include: +- empty statement [Sskip] +- evaluation of an expression for its side-effects [Sdo r] +- conditional [if (...) { ... } else { ... }] +- the three loops [while(...) { ... }] and [do { ... } while (...)] + and [for(..., ..., ...) { ... }] +- the [switch] construct +- [break], [continue], [return] (with and without argument) +- [goto] and labeled statements. + +Only structured forms of [switch] are supported; moreover, +the [default] case must occur last. Blocks and block-scoped declarations +are not supported. *) Definition label := ident. Inductive statement : Type := | Sskip : statement (**r do nothing *) - | Sassign : expr -> expr -> statement (**r assignment [lvalue = rvalue] *) - | Scall: option expr -> expr -> list expr -> statement (**r function call *) + | Sdo : expr -> statement (**r evaluate expression for side effects *) | Ssequence : statement -> statement -> statement (**r sequence *) | Sifthenelse : expr -> statement -> statement -> statement (**r conditional *) | Swhile : expr -> statement -> statement (**r [while] loop *) @@ -182,7 +288,7 @@ Inductive statement : Type := | Sfor: statement -> expr -> statement -> statement -> statement (**r [for] loop *) | Sbreak : statement (**r [break] statement *) | Scontinue : statement (**r [continue] statement *) - | Sreturn : option expr -> statement (**r [return] statement *) + | Sreturn : option expr -> statement (**r [return] statement *) | Sswitch : expr -> labeled_statements -> statement (**r [switch] statement *) | Slabel : label -> statement -> statement | Sgoto : label -> statement @@ -205,6 +311,9 @@ Record function : Type := mkfunction { fn_body: statement }. +Definition var_names (vars: list(ident * type)) : list ident := + List.map (@fst ident type) vars. + (** Functions can either be defined ([Internal]) or declared as external functions ([External]). *) @@ -266,23 +375,73 @@ with alignof_fields (f: fieldlist) : Z := 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. +Lemma alignof_power_of_2: + forall t, exists n, alignof t = two_power_nat n +with alignof_fields_power_of_2: + forall f, exists n, alignof_fields f = two_power_nat n. Proof. + induction t; simpl. + exists 0%nat; auto. + destruct i. exists 0%nat; auto. exists 1%nat; auto. exists 2%nat; auto. + destruct f. exists 2%nat; auto. exists 3%nat; auto. + exists 2%nat; auto. + auto. + exists 0%nat; auto. + apply alignof_fields_power_of_2. + apply alignof_fields_power_of_2. + exists 2%nat; auto. induction f; simpl. - omega. - generalize (Zmax2 (alignof t) (alignof_fields f)). omega. + exists 0%nat; auto. + rewrite Zmax_spec. destruct (zlt (alignof_fields f) (alignof t)); auto. 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. + intros. destruct (alignof_power_of_2 t) as [p EQ]. rewrite EQ. apply two_power_nat_pos. +Qed. + +Lemma alignof_fields_pos: + forall f, alignof_fields f > 0. +Proof. + intros. destruct (alignof_fields_power_of_2 f) as [p EQ]. rewrite EQ. apply two_power_nat_pos. +Qed. + +(* +Fixpoint In_fieldlist (id: ident) (ty: type) (f: fieldlist) : Prop := + match f with + | Fnil => False + | Fcons id1 ty1 f1 => (id1 = id /\ ty1 = ty) \/ In_fieldlist id ty f1 + end. + +Remark divides_max_pow_two: + forall a b, + (two_power_nat b | Zmax (two_power_nat a) (two_power_nat b)). +Proof. + intros. + rewrite Zmax_spec. destruct (zlt (two_power_nat b) (two_power_nat a)). + repeat rewrite two_power_nat_two_p in *. + destruct (zle (Z_of_nat a) (Z_of_nat b)). + assert (two_p (Z_of_nat a) <= two_p (Z_of_nat b)). apply two_p_monotone; omega. + omegaContradiction. + exists (two_p (Z_of_nat a - Z_of_nat b)). + rewrite <- two_p_is_exp. decEq. omega. omega. omega. + apply Zdivide_refl. +Qed. + +Lemma alignof_each_field: + forall f id t, In_fieldlist id t f -> (alignof t | alignof_fields f). +Proof. + induction f; simpl; intros. + contradiction. + destruct (alignof_power_of_2 t) as [k1 EQ1]. + destruct (alignof_fields_power_of_2 f) as [k2 EQ2]. + destruct H as [[A B] | A]; subst; rewrite EQ1; rewrite EQ2. + rewrite Zmax_comm. apply divides_max_pow_two. + eapply Zdivide_trans. eapply IHf; eauto. + rewrite EQ2. apply divides_max_pow_two. Qed. +*) (** Size of a type, in bytes. *) @@ -346,6 +505,15 @@ Proof. assert (sizeof t > 0) by apply sizeof_pos. omega. Qed. +Lemma sizeof_alignof_compat: + forall t, (alignof t | sizeof t). +Proof. + induction t; simpl; try (apply Zdivide_refl). + apply Zdivide_mult_l. auto. + apply align_divides. apply alignof_fields_pos. + apply align_divides. apply alignof_fields_pos. +Qed. + (** Byte offset for a field in a struct or union. Field are laid out consecutively, and padding is inserted to align each field to the natural alignment for its type. *) @@ -389,11 +557,13 @@ Proof. Qed. Lemma field_offset_in_range: - forall id fld ofs ty, - field_offset id fld = OK ofs -> field_type id fld = OK ty -> - 0 <= ofs /\ ofs + sizeof ty <= sizeof_struct fld 0. + forall sid fld fid ofs ty, + field_offset fid fld = OK ofs -> field_type fid fld = OK ty -> + 0 <= ofs /\ ofs + sizeof ty <= sizeof (Tstruct sid fld). Proof. - intros. eapply field_offset_rec_in_range. unfold field_offset in H; eauto. eauto. + intros. exploit field_offset_rec_in_range; eauto. intros [A B]. + split. auto. simpl. eapply Zle_trans. eauto. + eapply Zle_trans. eapply Zle_max_r. apply align_le. apply alignof_fields_pos. Qed. (** Second, two distinct fields do not overlap *) @@ -422,8 +592,8 @@ Proof. apply H with fld0 0; auto. Qed. -(** Third, if a struct is a prefix of another, the offsets of fields - in common is the same. *) +(** Third, if a struct is a prefix of another, the offsets of common fields + are the same. *) Fixpoint fieldlist_app (fld1 fld2: fieldlist) {struct fld1} : fieldlist := match fld1 with @@ -445,16 +615,31 @@ Proof. intros. unfold field_offset; auto. Qed. -(** The [access_mode] function describes how a variable of the given +(** Fourth, the position of each field respects its alignment. *) + +Lemma field_offset_aligned: + forall id fld ofs ty, + field_offset id fld = OK ofs -> field_type id fld = OK ty -> + (alignof ty | ofs). +Proof. + assert (forall id ofs ty fld pos, + field_offset_rec id fld pos = OK ofs -> field_type id fld = OK ty -> + (alignof ty | ofs)). + induction fld; simpl; intros. + discriminate. + destruct (ident_eq id i). inv H; inv H0. + apply align_divides. apply alignof_pos. + eapply IHfld; eauto. + intros. eapply H with (pos := 0); eauto. +Qed. + +(** The [access_mode] function describes how a l-value of the given type must be accessed: - [By_value ch]: access by value, i.e. by loading from the address - of the variable using the memory chunk [ch]; + of the l-value using the memory chunk [ch]; - [By_reference]: access by reference, i.e. by just returning - the address of the variable; + the address of the l-value; - [By_nothing]: no access is possible, e.g. for the [void] type. - -We currently do not support 64-bit integers and 128-bit floats, so these -have an access mode of [By_nothing]. *) Inductive mode: Type := @@ -480,124 +665,182 @@ Definition access_mode (ty: type) : mode := | Tcomp_ptr _ => By_value Mint32 end. -(** The usual unary conversion. Promotes small integer types to [signed int32] - and degrades array types and function types to pointer types. *) - -Definition typeconv (ty: type) : type := - match ty with - | Tint I32 Unsigned => ty - | Tint _ _ => Tint I32 Signed - | Tarray t sz => Tpointer t - | Tfunction _ _ => Tpointer ty - | _ => ty - end. - (** Classification of arithmetic operations and comparisons. The following [classify_] functions take as arguments the types of the arguments of an operation. They return enough information to resolve overloading for this operator applications, such as ``both arguments are floats'', or ``the first is a pointer and the second is an integer''. These functions are used to resolve - overloading both in the dynamic semantics (module [Csem]) and in the - compiler (module [Cshmgen]). + overloading both in the dynamic semantics (module [Csem]), in the + type system (module [Ctyping]), and in the compiler (module + [Cshmgen]). *) +Inductive classify_neg_cases : Type := + | neg_case_i(s: signedness) (**r int *) + | neg_case_f (**r float *) + | neg_default. + +Definition classify_neg (ty: type) : classify_neg_cases := + match ty with + | Tint I32 Unsigned => neg_case_i Unsigned + | Tint _ _ => neg_case_i Signed + | Tfloat _ => neg_case_f + | _ => neg_default + end. + +Inductive classify_notint_cases : Type := + | notint_case_i(s: signedness) (**r int *) + | notint_default. + +Definition classify_notint (ty: type) : classify_notint_cases := + match ty with + | Tint I32 Unsigned => notint_case_i Unsigned + | Tint _ _ => notint_case_i Signed + | _ => notint_default + end. + +(** The following describes types that can be interpreted as a boolean: + integers, floats, pointers. It is used for the semantics of + the [!] and [?] operators, as well as the [if], [while], [for] statements. *) + +Inductive classify_bool_cases : Type := + | bool_case_ip (**r integer or pointer *) + | bool_case_f (**r float *) + | bool_default. + +Definition classify_bool (ty: type) : classify_bool_cases := + match typeconv ty with + | Tint _ _ => bool_case_ip + | Tpointer _ => bool_case_ip + | Tfloat _ => bool_case_f + | _ => bool_default + end. + Inductive classify_add_cases : Type := - | add_case_ii: classify_add_cases (**r int , int *) - | add_case_ff: classify_add_cases (**r float , float *) - | add_case_pi: type -> classify_add_cases (**r ptr or array, int *) - | add_case_ip: type -> classify_add_cases (**r int, ptr or array *) - | add_default: classify_add_cases. (**r other *) + | add_case_ii(s: signedness) (**r int, int *) + | add_case_ff (**r float, float *) + | add_case_if(s: signedness) (**r int, float *) + | add_case_fi(s: signedness) (**r float, int *) + | add_case_pi(ty: type) (**r pointer, int *) + | add_case_ip(ty: type) (**r int, pointer *) + | add_default. Definition classify_add (ty1: type) (ty2: type) := match typeconv ty1, typeconv ty2 with - | Tint _ _, Tint _ _ => add_case_ii + | Tint I32 Unsigned, Tint _ _ => add_case_ii Unsigned + | Tint _ _, Tint I32 Unsigned => add_case_ii Unsigned + | Tint _ _, Tint _ _ => add_case_ii Signed | Tfloat _, Tfloat _ => add_case_ff + | Tint _ sg, Tfloat _ => add_case_if sg + | Tfloat _, Tint _ sg => add_case_fi sg | Tpointer ty, Tint _ _ => add_case_pi ty | Tint _ _, Tpointer ty => add_case_ip ty | _, _ => add_default end. Inductive classify_sub_cases : Type := - | sub_case_ii: classify_sub_cases (**r int , int *) - | sub_case_ff: classify_sub_cases (**r float , float *) - | sub_case_pi: type -> classify_sub_cases (**r ptr or array , int *) - | sub_case_pp: type -> classify_sub_cases (**r ptr or array , ptr or array *) - | sub_default: classify_sub_cases . (**r other *) + | sub_case_ii(s: signedness) (**r int , int *) + | sub_case_ff (**r float , float *) + | sub_case_if(s: signedness) (**r int, float *) + | sub_case_fi(s: signedness) (**r float, int *) + | sub_case_pi(ty: type) (**r pointer, int *) + | sub_case_pp(ty: type) (**r pointer, pointer *) + | sub_default. Definition classify_sub (ty1: type) (ty2: type) := match typeconv ty1, typeconv ty2 with - | Tint _ _ , Tint _ _ => sub_case_ii + | Tint I32 Unsigned, Tint _ _ => sub_case_ii Unsigned + | Tint _ _, Tint I32 Unsigned => sub_case_ii Unsigned + | Tint _ _, Tint _ _ => sub_case_ii Signed | Tfloat _ , Tfloat _ => sub_case_ff + | Tint _ sg, Tfloat _ => sub_case_if sg + | Tfloat _, Tint _ sg => sub_case_fi sg | Tpointer ty , Tint _ _ => sub_case_pi ty | Tpointer ty , Tpointer _ => sub_case_pp ty | _ ,_ => sub_default end. Inductive classify_mul_cases : Type:= - | mul_case_ii: classify_mul_cases (**r int , int *) - | mul_case_ff: classify_mul_cases (**r float , float *) - | mul_default: classify_mul_cases . (**r other *) + | mul_case_ii(s: signedness) (**r int , int *) + | mul_case_ff (**r float , float *) + | mul_case_if(s: signedness) (**r int, float *) + | mul_case_fi(s: signedness) (**r float, int *) + | mul_default. Definition classify_mul (ty1: type) (ty2: type) := match typeconv ty1, typeconv ty2 with - | Tint _ _, Tint _ _ => mul_case_ii + | Tint I32 Unsigned, Tint _ _ => mul_case_ii Unsigned + | Tint _ _, Tint I32 Unsigned => mul_case_ii Unsigned + | Tint _ _, Tint _ _ => mul_case_ii Signed | Tfloat _ , Tfloat _ => mul_case_ff + | Tint _ sg, Tfloat _ => mul_case_if sg + | Tfloat _, Tint _ sg => mul_case_fi sg | _,_ => mul_default end. Inductive classify_div_cases : Type:= - | div_case_I32unsi: classify_div_cases (**r unsigned int32 , int *) - | div_case_ii: classify_div_cases (**r int , int *) - | div_case_ff: classify_div_cases (**r float , float *) - | div_default: classify_div_cases. (**r other *) + | div_case_ii(s: signedness) (**r int , int *) + | div_case_ff (**r float , float *) + | div_case_if(s: signedness) (**r int, float *) + | div_case_fi(s: signedness) (**r float, int *) + | div_default. Definition classify_div (ty1: type) (ty2: type) := - match typeconv ty1, typeconv 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 + match typeconv ty1, typeconv ty2 with + | Tint I32 Unsigned, Tint _ _ => div_case_ii Unsigned + | Tint _ _, Tint I32 Unsigned => div_case_ii Unsigned + | Tint _ _, Tint _ _ => div_case_ii Signed + | Tfloat _ , Tfloat _ => div_case_ff + | Tint _ sg, Tfloat _ => div_case_if sg + | Tfloat _, Tint _ sg => div_case_fi sg + | _,_ => div_default end. -Inductive classify_mod_cases : Type:= - | mod_case_I32unsi: classify_mod_cases (**r unsigned I32 , int *) - | mod_case_ii: classify_mod_cases (**r int , int *) - | mod_default: classify_mod_cases . (**r other *) +(** The following is common to binary integer-only operators: + modulus, bitwise "and", "or", and "xor". *) -Definition classify_mod (ty1: type) (ty2: type) := +Inductive classify_binint_cases : Type:= + | binint_case_ii(s: signedness) (**r int , int *) + | binint_default. + +Definition classify_binint (ty1: type) (ty2: type) := match typeconv ty1, typeconv 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 :Type:= - | shr_case_I32unsi: classify_shr_cases (**r unsigned I32 , int *) - | shr_case_ii :classify_shr_cases (**r int , int *) - | shr_default : classify_shr_cases . (**r other *) - -Definition classify_shr (ty1: type) (ty2: type) := + | Tint I32 Unsigned, Tint _ _ => binint_case_ii Unsigned + | Tint _ _, Tint I32 Unsigned => binint_case_ii Unsigned + | Tint _ _, Tint _ _ => binint_case_ii Signed + | _,_ => binint_default +end. + +(** The following is common to shift operators [<<] and [>>]. *) + +Inductive classify_shift_cases : Type:= + | shift_case_ii(s: signedness) (**r int , int *) + | shift_default. + +Definition classify_shift (ty1: type) (ty2: type) := match typeconv ty1, typeconv ty2 with - | Tint I32 Unsigned , Tint _ _ => shr_case_I32unsi - | Tint _ _ , Tint _ _ => shr_case_ii - | _ , _ => shr_default - end. + | Tint I32 Unsigned, Tint _ _ => shift_case_ii Unsigned + | Tint _ _, Tint _ _ => shift_case_ii Signed + | _,_ => shift_default +end. Inductive classify_cmp_cases : Type:= - | cmp_case_I32unsi: classify_cmp_cases (**r unsigned I32 , int *) - | cmp_case_ipip: classify_cmp_cases (**r int|ptr|array , int|ptr|array*) - | cmp_case_ff: classify_cmp_cases (**r float , float *) - | cmp_default: classify_cmp_cases . (**r other *) + | cmp_case_iiu (**r unsigned int, unsigned int *) + | cmp_case_ipip (**r int-or-pointer, int-or-pointer *) + | cmp_case_ff (**r float , float *) + | cmp_case_if(s: signedness) (**r int, float *) + | cmp_case_fi(s: signedness) (**r float, int *) + | cmp_default. Definition classify_cmp (ty1: type) (ty2: type) := match typeconv ty1, typeconv ty2 with - | Tint I32 Unsigned , Tint _ _ => cmp_case_I32unsi - | Tint _ _ , Tint I32 Unsigned => cmp_case_I32unsi + | Tint I32 Unsigned , Tint _ _ => cmp_case_iiu + | Tint _ _ , Tint I32 Unsigned => cmp_case_iiu | Tint _ _ , Tint _ _ => cmp_case_ipip | Tfloat _ , Tfloat _ => cmp_case_ff + | Tint _ sg, Tfloat _ => cmp_case_if sg + | Tfloat _, Tint _ sg => cmp_case_fi sg | Tpointer _ , Tpointer _ => cmp_case_ipip | Tpointer _ , Tint _ _ => cmp_case_ipip | Tint _ _, Tpointer _ => cmp_case_ipip @@ -605,8 +848,8 @@ Definition classify_cmp (ty1: type) (ty2: type) := end. Inductive classify_fun_cases : Type:= - | fun_case_f: typelist -> type -> classify_fun_cases (**r (pointer to) function *) - | fun_default: classify_fun_cases . (**r other *) + | fun_case_f (targs: typelist) (tres: type) (**r (pointer to) function *) + | fun_default. Definition classify_fun (ty: type) := match ty with @@ -615,7 +858,7 @@ Definition classify_fun (ty: type) := | _ => fun_default end. -(** Translating Clight types to Cminor types, function signatures, +(** Translating C types to Cminor types, function signatures, and external functions. *) Definition typ_of_type (t: type) : AST.typ := diff --git a/cfrontend/Ctyping.v b/cfrontend/Ctyping.v deleted file mode 100644 index 8e089f1..0000000 --- a/cfrontend/Ctyping.v +++ /dev/null @@ -1,459 +0,0 @@ -(* *********************************************************************) -(* *) -(* The Compcert verified compiler *) -(* *) -(* Xavier Leroy, INRIA Paris-Rocquencourt *) -(* *) -(* Copyright Institut National de Recherche en Informatique et en *) -(* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) -(* *) -(* *********************************************************************) - -(** * Typing constraints on C programs *) - -Require Import Coqlib. -Require Import Maps. -Require Import AST. -Require Import Csyntax. - -(** ** Typing rules *) - -(** We now define a simple, incomplete type system for the Clight language. - 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. *) - -(** A typing environment maps variable names to their types. *) - -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_Econdition: forall e1 e2 e3 ty, - wt_expr e1 -> wt_expr e2 -> wt_expr e3 -> - wt_expr (Expr (Econdition e1 e2 e3) 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). - -Inductive wt_optexpr: option expr -> Prop := - | wt_Enone: - wt_optexpr None - | wt_Esome: forall e, - wt_expr e -> - wt_optexpr (Some e). - -Inductive wt_exprlist: list expr -> Prop := - | wt_Enil: - wt_exprlist nil - | wt_Econs: forall e el, - wt_expr e -> wt_exprlist el -> wt_exprlist (e :: el). - -Inductive wt_stmt: statement -> Prop := - | wt_Sskip: - wt_stmt Sskip - | wt_Sassign: forall e1 e2, - wt_expr e1 -> wt_expr e2 -> - wt_stmt (Sassign e1 e2) - | wt_Scall: forall lhs e1 el, - wt_optexpr lhs -> - wt_expr e1 -> - wt_exprlist el -> - wt_stmt (Scall lhs e1 el) - | 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: forall opte, - wt_optexpr opte -> - wt_stmt (Sreturn opte) - | wt_Sswitch: forall e sl, - wt_expr e -> wt_lblstmts sl -> - wt_stmt (Sswitch e sl) - | wt_Slabel: forall lbl s, - wt_stmt s -> - wt_stmt (Slabel lbl s) - | wt_Sgoto: forall lbl, - wt_stmt (Sgoto lbl) - -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 ef args res, - (ef_sig ef).(sig_args) = typlist_of_typelist args -> - (ef_sig ef).(sig_res) = opttyp_of_type res -> - wt_fundef env (External ef args res). - -Definition add_global_var - (env: typenv) (id_v: ident * globvar type) : typenv := - PTree.set (fst id_v) (gvar_info (snd id_v)) env. - -Definition add_global_vars - (env: typenv) (vars: list(ident * globvar type)) : 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_vars). - -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) -> - exists targs, type_of_fundef fd = Tfunction targs (Tint I32 Signed) -}. - -(* ** Type-checking algorithm *) - -(** We now define and prove correct a type-checking algorithm - for the type system defined above. *) - -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 id1 f1, Tstruct id2 f2 => - if ident_eq id1 id2 then eq_fieldlist f1 f2 else false - | Tunion id1 f1, Tunion id2 f2 => - if ident_eq id1 id2 then eq_fieldlist f1 f2 else false - | Tcomp_ptr id1, Tcomp_ptr id2 => - if ident_eq id1 id2 then true else false - | _, _ => 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. - TrueInv. subst i0. decEq; auto. - TrueInv. subst i0. decEq; auto. - TrueInv. congruence. - 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.Econdition b c d => typecheck_expr b && typecheck_expr c && typecheck_expr d - | 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. - -Fixpoint typecheck_exprlist (al: list Csyntax.expr): bool := - match al with - | nil => true - | a1 :: a2 => typecheck_expr a1 && typecheck_exprlist a2 - end. - -Definition typecheck_optexpr (opta: option Csyntax.expr): bool := - match opta with - | None => true - | Some a => typecheck_expr a - end. - -Scheme expr_ind_2 := Induction for expr Sort Prop - with expr_descr_ind_2 := Induction for expr_descr Sort Prop. - -Lemma typecheck_expr_correct: - forall a, typecheck_expr a = true -> wt_expr env a. -Proof. - apply (expr_ind_2 (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))); - simpl; intros; TrueInv; try constructor; auto. - destruct (env!i). decEq; symmetry; apply eq_type_correct; auto. - discriminate. -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. - -Lemma typecheck_optexpr_correct: - forall a, typecheck_optexpr a = true -> wt_optexpr env a. -Proof. - destruct a; simpl; intros. - constructor. apply typecheck_expr_correct; auto. - constructor. -Qed. - -Fixpoint typecheck_stmt (s: Csyntax.statement) {struct s} : bool := - match s with - | Csyntax.Sskip => true - | Csyntax.Sassign b c => typecheck_expr b && typecheck_expr c - | Csyntax.Scall a b cl => typecheck_optexpr a && typecheck_expr b && typecheck_exprlist cl - | 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 - | Csyntax.Slabel lbl s => typecheck_stmt s - | Csyntax.Sgoto lbl => true - 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. - generalize typecheck_exprlist_correct; intro. - generalize typecheck_optexpr_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; 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 ef targs tres => - let s := ef_sig ef in - list_eq_dec typ_eq s.(sig_args) (typlist_of_typelist targs) - && opt_typ_eq s.(sig_res) (opttyp_of_type tres) - end && - if ident_eq id main - then match type_of_fundef fd with - | Tfunction targs tres => eq_type tres (Tint I32 Signed) - | _ => false - end - else true. - -Lemma typecheck_fundef_correct: - forall main env id fd, - typecheck_fundef main env (id, fd) = true -> - wt_fundef env fd /\ - (id = main -> - exists targs, type_of_fundef fd = Tfunction targs (Tint I32 Signed)). -Proof. - intros. unfold typecheck_fundef in H; TrueInv. - split. - destruct fd. - constructor. apply typecheck_function_correct; auto. - TrueInv. constructor; eapply proj_sumbool_true; eauto. - intro. destruct (ident_eq id main). - destruct (type_of_fundef fd); try discriminate. - exists t; decEq; auto. 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/cfrontend/PrintClight.ml b/cfrontend/PrintClight.ml new file mode 100644 index 0000000..ad6887c --- /dev/null +++ b/cfrontend/PrintClight.ml @@ -0,0 +1,365 @@ +(* *********************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Xavier Leroy, INRIA Paris-Rocquencourt *) +(* *) +(* Copyright Institut National de Recherche en Informatique et en *) +(* Automatique. All rights reserved. This file is distributed *) +(* under the terms of the GNU General Public License as published by *) +(* the Free Software Foundation, either version 2 of the License, or *) +(* (at your option) any later version. This file is also distributed *) +(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* *) +(* *********************************************************************) + +(** Pretty-printer for Clight *) + +open Format +open Camlcoq +open Datatypes +open Values +open AST +open Csyntax +open PrintCsyntax +open Clight + +(* Collecting the names and fields of structs and unions *) + +module StructUnionSet = Set.Make(struct + type t = string * fieldlist + let compare (n1, _ : t) (n2, _ : t) = compare n1 n2 +end) + +let struct_unions = ref StructUnionSet.empty + +let register_struct_union id fld = + struct_unions := StructUnionSet.add (extern_atom id, fld) !struct_unions + +(* Naming temporaries *) + +let temp_name (id: ident) = + Printf.sprintf "$%ld" (camlint_of_positive id) + +(* Declarator (identifier + type) -- reuse from PrintCsyntax *) + +(* Precedences and associativity (H&S section 7.2) *) + +type associativity = LtoR | RtoL | NA + +let rec precedence = function + | Evar _ -> (16, NA) + | Etempvar _ -> (16, NA) + | Ederef _ -> (15, RtoL) + | Efield _ -> (16, LtoR) + | Econst_int _ -> (16, NA) + | Econst_float _ -> (16, NA) + | Esizeof _ -> (15, RtoL) + | Eunop _ -> (15, RtoL) + | Eaddrof _ -> (15, RtoL) + | Ecast _ -> (14, RtoL) + | Ebinop((Omul|Odiv|Omod), _, _, _) -> (13, LtoR) + | Ebinop((Oadd|Osub), _, _, _) -> (12, LtoR) + | Ebinop((Oshl|Oshr), _, _, _) -> (11, LtoR) + | Ebinop((Olt|Ogt|Ole|Oge), _, _, _) -> (10, LtoR) + | Ebinop((Oeq|One), _, _, _) -> (9, LtoR) + | Ebinop(Oand, _, _, _) -> (8, LtoR) + | Ebinop(Oxor, _, _, _) -> (7, LtoR) + | Ebinop(Oor, _, _, _) -> (6, LtoR) + | Econdition _ -> (3, RtoL) + +(* Expressions *) + +let rec expr p (prec, e) = + let (prec', assoc) = precedence e in + let (prec1, prec2) = + if assoc = LtoR + then (prec', prec' + 1) + else (prec' + 1, prec') in + if prec' < prec + then fprintf p "@[<hov 2>(" + else fprintf p "@[<hov 2>"; + begin match e with + | Evar(id, _) -> + fprintf p "%s" (extern_atom id) + | Etempvar(id, _) -> + fprintf p "%s" (temp_name id) + | Ederef(a1, _) -> + fprintf p "*%a" expr (prec', a1) + | Efield(a1, f, _) -> + fprintf p "%a.%s" expr (prec', a1) (extern_atom f) + | Econst_int(n, _) -> + fprintf p "%ld" (camlint_of_coqint n) + | Econst_float(f, _) -> + fprintf p "%F" f + | Esizeof(ty, _) -> + fprintf p "sizeof(%s)" (name_type ty) + | Eunop(op, a1, _) -> + fprintf p "%s%a" (name_unop op) expr (prec', a1) + | Eaddrof(a1, _) -> + fprintf p "&%a" expr (prec', a1) + | Ebinop(op, a1, a2, _) -> + fprintf p "%a@ %s %a" + expr (prec1, a1) (name_binop op) expr (prec2, a2) + | Ecast(a1, ty) -> + fprintf p "(%s) %a" (name_type ty) expr (prec', a1) + | Econdition(a1, a2, a3, _) -> + fprintf p "%a@ ? %a@ : %a" expr (4, a1) expr (4, a2) expr (4, a3) + end; + if prec' < prec then fprintf p ")@]" else fprintf p "@]" + +let print_expr p e = expr p (0, e) + +let rec print_expr_list p (first, rl) = + match rl with + | [] -> () + | r :: rl -> + if not first then fprintf p ",@ "; + expr p (2, r); + print_expr_list p (false, rl) + +(* Statements *) + +let rec print_stmt p s = + match s with + | Sskip -> + fprintf p "/*skip*/;" + | Sassign(e1, e2) -> + fprintf p "@[<hv 2>%a =@ %a;@]" print_expr e1 print_expr e2 + | Sset(id, e2) -> + fprintf p "@[<hv 2>%s =@ %a;@]" (temp_name id) print_expr e2 + | Scall(None, e1, el) -> + fprintf p "@[<hv 2>%a@,(@[<hov 0>%a@]);@]" + print_expr e1 + print_expr_list (true, el) + | Scall(Some id, e1, el) -> + fprintf p "@[<hv 2>%s =@ %a@,(@[<hov 0>%a@]);@]" + (temp_name id) + print_expr e1 + print_expr_list (true, el) + | Ssequence(Sskip, s2) -> + print_stmt p s2 + | Ssequence(s1, Sskip) -> + print_stmt p s1 + | Ssequence(s1, s2) -> + fprintf p "%a@ %a" print_stmt s1 print_stmt s2 + | Sifthenelse(e, s1, Sskip) -> + fprintf p "@[<v 2>if (%a) {@ %a@;<0 -2>}@]" + print_expr e + print_stmt s1 + | Sifthenelse(e, Sskip, s2) -> + fprintf p "@[<v 2>if (! %a) {@ %a@;<0 -2>}@]" + expr (15, e) + print_stmt s2 + | Sifthenelse(e, s1, s2) -> + fprintf p "@[<v 2>if (%a) {@ %a@;<0 -2>} else {@ %a@;<0 -2>}@]" + print_expr e + print_stmt s1 + print_stmt s2 + | Swhile(e, s) -> + fprintf p "@[<v 2>while (%a) {@ %a@;<0 -2>}@]" + print_expr e + print_stmt s + | Sdowhile(e, s) -> + fprintf p "@[<v 2>do {@ %a@;<0 -2>} while(%a);@]" + print_stmt s + print_expr e + | Sfor'(e, s_iter, s_body) -> + fprintf p "@[<v 2>for (@[<hv 0>;@ %a;@ %a) {@]@ %a@;<0 -2>}@]" + print_expr e + print_stmt_for s_iter + print_stmt s_body + | Sbreak -> + fprintf p "break;" + | Scontinue -> + fprintf p "continue;" + | Sswitch(e, cases) -> + fprintf p "@[<v 2>switch (%a) {@ %a@;<0 -2>}@]" + print_expr e + print_cases cases + | Sreturn None -> + fprintf p "return;" + | Sreturn (Some e) -> + fprintf p "return %a;" print_expr e + | Slabel(lbl, s1) -> + fprintf p "%s:@ %a" (extern_atom lbl) print_stmt s1 + | Sgoto lbl -> + fprintf p "goto %s;" (extern_atom lbl) + +and print_cases p cases = + match cases with + | LSdefault Sskip -> + () + | LSdefault s -> + fprintf p "@[<v 2>default:@ %a@]" print_stmt s + | LScase(lbl, Sskip, rem) -> + fprintf p "case %ld:@ %a" + (camlint_of_coqint lbl) + print_cases rem + | LScase(lbl, s, rem) -> + fprintf p "@[<v 2>case %ld:@ %a@]@ %a" + (camlint_of_coqint lbl) + print_stmt s + print_cases rem + +and print_stmt_for p s = + match s with + | Sskip -> + fprintf p "/*nothing*/" + | Sassign(e1, e2) -> + fprintf p "%a = %a" print_expr e1 print_expr e2 + | Sset(id, e2) -> + fprintf p "%s = %a" (temp_name id) print_expr e2 + | Ssequence(s1, s2) -> + fprintf p "%a, %a" print_stmt_for s1 print_stmt_for s2 + | Scall(None, e1, el) -> + fprintf p "@[<hv 2>%a@,(@[<hov 0>%a@])@]" + print_expr e1 + print_expr_list (true, el) + | Scall(Some id, e1, el) -> + fprintf p "@[<hv 2>%s =@ %a@,(@[<hov 0>%a@])@]" + (temp_name id) + print_expr e1 + print_expr_list (true, el) + | _ -> + fprintf p "({ %a })" print_stmt s + +let print_function p id f = + fprintf p "%s@ " + (name_cdecl (name_function_parameters (extern_atom id) + f.fn_params) + f.fn_return); + fprintf p "@[<v 2>{@ "; + List.iter + (fun (Coq_pair(id, ty)) -> + fprintf p "%s;@ " (name_cdecl (extern_atom id) ty)) + f.fn_vars; + List.iter + (fun (Coq_pair(id, ty)) -> + fprintf p "register %s;@ " (name_cdecl (temp_name id) ty)) + f.fn_temps; + print_stmt p f.fn_body; + fprintf p "@;<0 -2>}@]@ @ " + +let print_fundef p (Coq_pair(id, fd)) = + match fd with + | External(_, args, res) -> + fprintf p "extern %s;@ @ " + (name_cdecl (extern_atom id) (Tfunction(args, res))) + | Internal f -> + print_function p id f + +(* Collect struct and union types *) + +let rec collect_type = function + | Tvoid -> () + | Tint(sz, sg) -> () + | Tfloat sz -> () + | Tpointer t -> collect_type t + | Tarray(t, n) -> collect_type t + | Tfunction(args, res) -> collect_type_list args; collect_type res + | Tstruct(id, fld) -> register_struct_union id fld; collect_fields fld + | Tunion(id, fld) -> register_struct_union id fld; collect_fields fld + | Tcomp_ptr _ -> () + +and collect_type_list = function + | Tnil -> () + | Tcons(hd, tl) -> collect_type hd; collect_type_list tl + +and collect_fields = function + | Fnil -> () + | Fcons(id, hd, tl) -> collect_type hd; collect_fields tl + +let rec collect_expr = function + | Econst_int _ -> () + | Econst_float _ -> () + | Evar _ -> () + | Etempvar _ -> () + | Ederef(r, _) -> collect_expr r + | Efield(l, _, _) -> collect_expr l + | Eaddrof(l, _) -> collect_expr l + | Eunop(_, r, _) -> collect_expr r + | Ebinop(_, r1, r2, _) -> collect_expr r1; collect_expr r2 + | Ecast(r, _) -> collect_expr r + | Econdition(r1, r2, r3, _) -> + collect_expr r1; collect_expr r2; collect_expr r3 + | Esizeof _ -> () + +let rec collect_exprlist = function + | [] -> () + | r1 :: rl -> collect_expr r1; collect_exprlist rl + +let rec collect_stmt = function + | Sskip -> () + | Sassign(e1, e2) -> collect_expr e1; collect_expr e2 + | Sset(id, e2) -> collect_expr e2 + | Scall(optid, e1, el) -> collect_expr e1; collect_exprlist el + | Ssequence(s1, s2) -> collect_stmt s1; collect_stmt s2 + | Sifthenelse(e, s1, s2) -> collect_expr e; collect_stmt s1; collect_stmt s2 + | Swhile(e, s) -> collect_expr e; collect_stmt s + | Sdowhile(e, s) -> collect_stmt s; collect_expr e + | Sfor'(e, s_iter, s_body) -> + collect_expr e; collect_stmt s_iter; collect_stmt s_body + | Sbreak -> () + | Scontinue -> () + | Sswitch(e, cases) -> collect_expr e; collect_cases cases + | Sreturn None -> () + | Sreturn (Some e) -> collect_expr e + | Slabel(lbl, s) -> collect_stmt s + | Sgoto lbl -> () + +and collect_cases = function + | LSdefault s -> collect_stmt s + | LScase(lbl, s, rem) -> collect_stmt s; collect_cases rem + +let collect_function f = + collect_type f.fn_return; + List.iter (fun (Coq_pair(id, ty)) -> collect_type ty) f.fn_params; + List.iter (fun (Coq_pair(id, ty)) -> collect_type ty) f.fn_vars; + List.iter (fun (Coq_pair(id, ty)) -> collect_type ty) f.fn_temps; + collect_stmt f.fn_body + +let collect_fundef (Coq_pair(id, fd)) = + match fd with + | External(_, args, res) -> collect_type_list args; collect_type res + | Internal f -> collect_function f + +let collect_globvar (Coq_pair(id, v)) = + collect_type v.gvar_info + +let collect_program p = + List.iter collect_globvar p.prog_vars; + List.iter collect_fundef p.prog_funct + +let declare_struct_or_union p (name, fld) = + fprintf p "%s;@ @ " name + +let print_struct_or_union p (name, fld) = + fprintf p "@[<v 2>%s {" name; + let rec print_fields = function + | Fnil -> () + | Fcons(id, ty, rem) -> + fprintf p "@ %s;" (name_cdecl (extern_atom id) ty); + print_fields rem in + print_fields fld; + fprintf p "@;<0 -2>};@]@ " + +let print_program p prog = + struct_unions := StructUnionSet.empty; + collect_program prog; + fprintf p "@[<v 0>"; + StructUnionSet.iter (declare_struct_or_union p) !struct_unions; + StructUnionSet.iter (print_struct_or_union p) !struct_unions; + List.iter (print_globvar p) prog.prog_vars; + List.iter (print_fundef p) prog.prog_funct; + fprintf p "@]@." + +let destination : string option ref = ref None + +let print_if prog = + match !destination with + | None -> () + | Some f -> + let oc = open_out f in + print_program (formatter_of_out_channel oc) prog; + close_out oc diff --git a/cfrontend/PrintCsyntax.ml b/cfrontend/PrintCsyntax.ml index 3b5dbc5..61599cf 100644 --- a/cfrontend/PrintCsyntax.ml +++ b/cfrontend/PrintCsyntax.ml @@ -18,6 +18,7 @@ open Format open Camlcoq open Datatypes +open Values open AST open Csyntax @@ -25,7 +26,6 @@ let name_unop = function | Onotbool -> "!" | Onotint -> "~" | Oneg -> "-" - | Ofabs -> "__builtin_fabs" let name_binop = function | Oadd -> "+" @@ -124,108 +124,112 @@ let rec name_cdecl id ty = let name_type ty = name_cdecl "" ty +(* Precedences and associativity (H&S section 7.2) *) + +type associativity = LtoR | RtoL | NA + +let rec precedence = function + | Eloc _ -> assert false + | Evar _ -> (16, NA) + | Ederef _ -> (15, RtoL) + | Efield _ -> (16, LtoR) + | Eval _ -> (16, NA) + | Evalof(l, _) -> precedence l + | Esizeof _ -> (15, RtoL) + | Ecall _ -> (16, LtoR) + | Epostincr _ -> (16, LtoR) + | Eunop _ -> (15, RtoL) + | Eaddrof _ -> (15, RtoL) + | Ecast _ -> (14, RtoL) + | Ebinop((Omul|Odiv|Omod), _, _, _) -> (13, LtoR) + | Ebinop((Oadd|Osub), _, _, _) -> (12, LtoR) + | Ebinop((Oshl|Oshr), _, _, _) -> (11, LtoR) + | Ebinop((Olt|Ogt|Ole|Oge), _, _, _) -> (10, LtoR) + | Ebinop((Oeq|One), _, _, _) -> (9, LtoR) + | Ebinop(Oand, _, _, _) -> (8, LtoR) + | Ebinop(Oxor, _, _, _) -> (7, LtoR) + | Ebinop(Oor, _, _, _) -> (6, LtoR) + | Econdition _ -> (3, RtoL) + | Eassign _ -> (2, RtoL) + | Eassignop _ -> (2, RtoL) + | Ecomma _ -> (1, LtoR) + | Eparen _ -> assert false + (* Expressions *) -let parenthesis_level (Expr (e, ty)) = - match e with - | Econst_int _ -> 0 - | Econst_float _ -> 0 - | Evar _ -> 0 - | Eunop(Ofabs, _) -> -10 (* force parentheses around argument *) - | Eunop(_, _) -> 30 - | Ederef _ -> 20 - | Eaddrof _ -> 30 - | Ebinop(op, _, _) -> - begin match op with - | Oand | Oor | Oxor -> 75 - | Oeq | One | Olt | Ogt | Ole | Oge -> 70 - | Oadd | Osub | Oshl | Oshr -> 60 - | Omul | Odiv | Omod -> 40 - end - | Ecast _ -> 30 - | Econdition(_, _, _) -> 80 - | Eandbool(_, _) -> 80 - | Eorbool(_, _) -> 80 - | Esizeof _ -> 20 - | Efield _ -> 20 - -let rec print_expr p (Expr (eb, ty) as e) = - let level = parenthesis_level e in - match eb with - | Econst_int n -> +let rec expr p (prec, e) = + let (prec', assoc) = precedence e in + let (prec1, prec2) = + if assoc = LtoR + then (prec', prec' + 1) + else (prec' + 1, prec') in + if prec' < prec + then fprintf p "@[<hov 2>(" + else fprintf p "@[<hov 2>"; + begin match e with + | Eloc _ -> + assert false + | Evar(id, _) -> + fprintf p "%s" (extern_atom id) + | Ederef(a1, _) -> + fprintf p "*%a" expr (prec', a1) + | Efield(a1, f, _) -> + fprintf p "%a.%s" expr (prec', a1) (extern_atom f) + | Evalof(l, _) -> + expr p (prec, l) + | Eval(Vint n, _) -> fprintf p "%ld" (camlint_of_coqint n) - | Econst_float f -> + | Eval(Vfloat f, _) -> fprintf p "%F" f - | Evar id -> - fprintf p "%s" (extern_atom id) - | Eunop(op, e1) -> - fprintf p "%s%a" (name_unop op) print_expr_prec (level, e1) - | Ederef (Expr (Ebinop(Oadd, e1, e2), _)) -> - fprintf p "@[<hov 2>%a@,[%a]@]" - print_expr_prec (level, e1) - print_expr_prec (level, e2) - | Ederef (Expr (Efield(e1, id), _)) -> - fprintf p "%a->%s" print_expr_prec (level, e1) (extern_atom id) - | Ederef e -> - fprintf p "*%a" print_expr_prec (level, e) - | Eaddrof e -> - fprintf p "&%a" print_expr_prec (level, e) - | Ebinop(op, e1, e2) -> - fprintf p "@[<hov 0>%a@ %s %a@]" - print_expr_prec (level, e1) - (name_binop op) - print_expr_prec (level, e2) - | Ecast(ty, e1) -> - fprintf p "@[<hov 2>(%s)@,%a@]" - (name_type ty) - print_expr_prec (level, e1) - | Econdition(e1, e2, e3) -> - fprintf p "@[<hov 0>%a@ ? %a@ : %a@]" - print_expr_prec (level, e1) - print_expr_prec (level, e2) - print_expr_prec (level, e3) - | Eandbool(e1, e2) -> - fprintf p "@[<hov 0>%a@ && %a@]" - print_expr_prec (level, e1) - print_expr_prec (level, e2) - | Eorbool(e1, e2) -> - fprintf p "@[<hov 0>%a@ || %a@]" - print_expr_prec (level, e1) - print_expr_prec (level, e2) - | Esizeof ty -> + | Eval(_, _) -> + assert false + | Esizeof(ty, _) -> fprintf p "sizeof(%s)" (name_type ty) - | Efield(e1, id) -> - fprintf p "%a.%s" print_expr_prec (level, e1) (extern_atom id) - -and print_expr_prec p (context_prec, e) = - let this_prec = parenthesis_level e in - if this_prec >= context_prec - then fprintf p "(%a)" print_expr e - else print_expr p e - -let rec print_expr_list p (first, el) = - match el with - | [] -> () - | e1 :: et -> + | Eunop(op, a1, _) -> + fprintf p "%s%a" (name_unop op) expr (prec', a1) + | Eaddrof(a1, _) -> + fprintf p "&%a" expr (prec', a1) + | Epostincr(id, a1, _) -> + fprintf p "%a%s" expr (prec', a1) + (match id with Incr -> "++" | Decr -> "--") + | Ebinop(op, a1, a2, _) -> + fprintf p "%a@ %s %a" + expr (prec1, a1) (name_binop op) expr (prec2, a2) + | Ecast(a1, ty) -> + fprintf p "(%s) %a" (name_type ty) expr (prec', a1) + | Eassign(a1, a2, _) -> + fprintf p "%a =@ %a" expr (prec1, a1) expr (prec2, a2) + | Eassignop(op, a1, a2, _, _) -> + fprintf p "%a %s=@ %a" expr (prec1, a1) (name_binop op) expr (prec2, a2) + | Econdition(a1, a2, a3, _) -> + fprintf p "%a@ ? %a@ : %a" expr (4, a1) expr (4, a2) expr (4, a3) + | Ecomma(a1, a2, _) -> + fprintf p "%a,@ %a" expr (prec1, a1) expr (prec2, a2) + | Ecall(a1, al, _) -> + fprintf p "%a@[<hov 1>(%a)@]" expr (prec', a1) exprlist (true, al) + | Eparen _ -> + assert false + end; + if prec' < prec then fprintf p ")@]" else fprintf p "@]" + +and exprlist p (first, rl) = + match rl with + | Enil -> () + | Econs(r, rl) -> if not first then fprintf p ",@ "; - print_expr p e1; - print_expr_list p (false, et) + expr p (2, r); + exprlist p (false, rl) + +let print_expr p e = expr p (0, e) + +(* Statements *) let rec print_stmt p s = match s with | Sskip -> fprintf p "/*skip*/;" - | Sassign(e1, e2) -> - fprintf p "@[<hv 2>%a =@ %a;@]" print_expr e1 print_expr e2 - | Scall(None, e1, el) -> - fprintf p "@[<hv 2>%a@,(@[<hov 0>%a@]);@]" - print_expr e1 - print_expr_list (true, el) - | Scall(Some lhs, e1, el) -> - fprintf p "@[<hv 2>%a =@ %a@,(@[<hov 0>%a@]);@]" - print_expr lhs - print_expr e1 - print_expr_list (true, el) + | Sdo e -> + fprintf p "%a;" print_expr e | Ssequence(s1, s2) -> fprintf p "%a@ %a" print_stmt s1 print_stmt s2 | Sifthenelse(e, s1, Sskip) -> @@ -288,19 +292,10 @@ and print_stmt_for p s = match s with | Sskip -> fprintf p "/*nothing*/" - | Sassign(e1, e2) -> - fprintf p "%a = %a" print_expr e1 print_expr e2 + | Sdo e -> + print_expr p e | Ssequence(s1, s2) -> fprintf p "%a, %a" print_stmt_for s1 print_stmt_for s2 - | Scall(None, e1, el) -> - fprintf p "@[<hv 2>%a@,(@[<hov 0>%a@])@]" - print_expr e1 - print_expr_list (true, el) - | Scall(Some lhs, e1, el) -> - fprintf p "@[<hv 2>%a =@ %a@,(@[<hov 0>%a@])@]" - print_expr lhs - print_expr e1 - print_expr_list (true, el) | _ -> fprintf p "({ %a })" print_stmt s @@ -422,31 +417,34 @@ and collect_fields = function | Fnil -> () | Fcons(id, hd, tl) -> collect_type hd; collect_fields tl -let rec collect_expr (Expr(ed, ty)) = - match ed with - | Econst_int n -> () - | Econst_float f -> () - | Evar id -> () - | Eunop(op, e1) -> collect_expr e1 - | Ederef e -> collect_expr e - | Eaddrof e -> collect_expr e - | Ebinop(op, e1, e2) -> collect_expr e1; collect_expr e2 - | Ecast(ty, e1) -> collect_type ty; collect_expr e1 - | Econdition(e1, e2, e3) -> collect_expr e1; collect_expr e2; collect_expr e3 - | Eandbool(e1, e2) -> collect_expr e1; collect_expr e2 - | Eorbool(e1, e2) -> collect_expr e1; collect_expr e2 - | Esizeof ty -> collect_type ty - | Efield(e1, id) -> collect_expr e1 - -let rec collect_expr_list = function - | [] -> () - | hd :: tl -> collect_expr hd; collect_expr_list tl +let rec collect_expr = function + | Eloc _ -> assert false + | Evar _ -> () + | Ederef(r, _) -> collect_expr r + | Efield(l, _, _) -> collect_expr l + | Eval _ -> () + | Evalof(l, _) -> collect_expr l + | Eaddrof(l, _) -> collect_expr l + | Eunop(_, r, _) -> collect_expr r + | Ebinop(_, r1, r2, _) -> collect_expr r1; collect_expr r2 + | Ecast(r, _) -> collect_expr r + | Econdition(r1, r2, r3, _) -> + collect_expr r1; collect_expr r2; collect_expr r3 + | Esizeof _ -> () + | Eassign(l, r, _) -> collect_expr l; collect_expr r + | Eassignop(_, l, r, _, _) -> collect_expr l; collect_expr r + | Epostincr(_, l, _) -> collect_expr l + | Ecomma(r1, r2, _) -> collect_expr r1; collect_expr r2 + | Ecall(r1, rl, _) -> collect_expr r1; collect_exprlist rl + | Eparen _ -> assert false + +and collect_exprlist = function + | Enil -> () + | Econs(r1, rl) -> collect_expr r1; collect_exprlist rl let rec collect_stmt = function | Sskip -> () - | Sassign(e1, e2) -> collect_expr e1; collect_expr e2 - | Scall(None, e1, el) -> collect_expr e1; collect_expr_list el - | Scall(Some lhs, e1, el) -> collect_expr lhs; collect_expr e1; collect_expr_list el + | Sdo e -> collect_expr e | Ssequence(s1, s2) -> collect_stmt s1; collect_stmt s2 | Sifthenelse(e, s1, s2) -> collect_expr e; collect_stmt s1; collect_stmt s2 | Swhile(e, s) -> collect_expr e; collect_stmt s @@ -507,4 +505,12 @@ let print_program p prog = List.iter (print_fundef p) prog.prog_funct; fprintf p "@]@." +let destination : string option ref = ref None +let print_if prog = + match !destination with + | None -> () + | Some f -> + let oc = open_out f in + print_program (formatter_of_out_channel oc) prog; + close_out oc diff --git a/cfrontend/SimplExpr.v b/cfrontend/SimplExpr.v new file mode 100644 index 0000000..a10e55e --- /dev/null +++ b/cfrontend/SimplExpr.v @@ -0,0 +1,403 @@ +(* *********************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Xavier Leroy, INRIA Paris-Rocquencourt *) +(* *) +(* Copyright Institut National de Recherche en Informatique et en *) +(* Automatique. All rights reserved. This file is distributed *) +(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* *) +(* *********************************************************************) + +(** Translation from Compcert C to Clight. + Side effects are pulled out of Compcert C expressions. *) + +Require Import Coqlib. +Require Import Errors. +Require Import Integers. +Require Import Floats. +Require Import Values. +Require Import AST. +Require Import Csyntax. +Require Import Clight. + +Module C := Csyntax. + +Open Local Scope string_scope. + +(** State and error monad for generating fresh identifiers. *) + +Record generator : Type := mkgenerator { + gen_next: ident; + gen_trail: list (ident * type) +}. + +Inductive result (A: Type) (g: generator) : Type := + | Err: Errors.errmsg -> result A g + | Res: A -> forall (g': generator), Ple (gen_next g) (gen_next g') -> result A g. + +Implicit Arguments Err [A g]. +Implicit Arguments Res [A g]. + +Definition mon (A: Type) := forall (g: generator), result A g. + +Definition ret (A: Type) (x: A) : mon A := + fun g => Res x g (Ple_refl (gen_next g)). + +Implicit Arguments ret [A]. + +Definition error (A: Type) (msg: Errors.errmsg) : mon A := + fun g => Err msg. + +Implicit Arguments error [A]. + +Definition bind (A B: Type) (x: mon A) (f: A -> mon B) : mon B := + fun g => + match x g with + | Err msg => Err msg + | Res a g' i => + match f a g' with + | Err msg => Err msg + | Res b g'' i' => Res b g'' (Ple_trans _ _ _ i i') + end + end. + +Implicit Arguments bind [A B]. + +Definition bind2 (A B C: Type) (x: mon (A * B)) (f: A -> B -> mon C) : mon C := + bind x (fun p => f (fst p) (snd p)). + +Implicit Arguments bind2 [A B C]. + +Notation "'do' X <- A ; B" := (bind A (fun X => B)) + (at level 200, X ident, A at level 100, B at level 200) + : gensym_monad_scope. +Notation "'do' ( X , Y ) <- A ; B" := (bind2 A (fun X Y => B)) + (at level 200, X ident, Y ident, A at level 100, B at level 200) + : gensym_monad_scope. + +Local Open Scope gensym_monad_scope. + +Definition initial_generator : generator := + mkgenerator 1%positive nil. + +Definition gensym (ty: type): mon ident := + fun (g: generator) => + Res (gen_next g) + (mkgenerator (Psucc (gen_next g)) ((gen_next g, ty) :: gen_trail g)) + (Ple_succ (gen_next g)). + +(** Construct a sequence from a list of statements. To facilitate the + proof, the sequence is nested to the left and starts with a [Sskip]. *) + +Fixpoint makeseq_rec (s: statement) (l: list statement) : statement := + match l with + | nil => s + | s' :: l' => makeseq_rec (Ssequence s s') l' + end. + +Definition makeseq (l: list statement) : statement := + makeseq_rec Sskip l. + +(** Smart constructor for [if ... then ... else]. *) + +Function makeif (a: expr) (s1 s2: statement) : statement := + match a with + | Econst_int n _ => if Int.eq_dec n Int.zero then s2 else s1 + | _ => Sifthenelse a s1 s2 + end. + +(** Translation of pre/post-increment/decrement. *) + +Definition transl_incrdecr (id: incr_or_decr) (a: expr) (ty: type) : expr := + match id with + | Incr => Ebinop Oadd a (Econst_int Int.one (Tint I32 Signed)) (typeconv ty) + | Decr => Ebinop Osub a (Econst_int Int.one (Tint I32 Signed)) (typeconv ty) + end. + +(** Translation of expressions. Return a pair [(sl, a)] of + a list of statements [sl] and a pure expression [a]. +- If the [dst] argument is [For_val], the statements [sl] + perform the side effects of the original expression, + and [a] evaluates to the same value as the original expression. +- If the [dst] argument is [For_effects], the statements [sl] + perform the side effects of the original expression, + and [a] is meaningless. +- If the [dst] argument is [For_test s1 s2], the statements [sl] + perform the side effects of the original expression, followed + by an [if (v) { s1 } else { s2 }] test, where [v] is the value + of the original expression. [a] is meaningless. +*) + +Inductive purpose : Type := + | For_val + | For_effects + | For_test (s1 s2: statement). + +Definition dummy_expr := Econst_int Int.zero (Tint I32 Signed). + +Definition finish (dst: purpose) (sl: list statement) (a: expr) := + match dst with + | For_val => (sl, a) + | For_effects => (sl, a) + | For_test s1 s2 => (sl ++ makeif a s1 s2 :: nil, a) + end. + +Fixpoint transl_expr (dst: purpose) (a: C.expr) : mon (list statement * expr) := + match a with + | C.Eloc b ofs ty => + error (msg "SimplExpr.transl_expr: C.Eloc") + | C.Evar x ty => + ret (finish dst nil (Evar x ty)) + | C.Ederef r ty => + do (sl, a) <- transl_expr For_val r; + ret (finish dst sl (Ederef a ty)) + | C.Efield l1 f ty => + do (sl, a) <- transl_expr For_val l1; + ret (finish dst sl (Efield a f ty)) + | C.Eval (Vint n) ty => + ret (finish dst nil (Econst_int n ty)) + | C.Eval (Vfloat n) ty => + ret (finish dst nil (Econst_float n ty)) + | C.Eval _ ty => + error (msg "SimplExpr.transl_expr: val") + | C.Esizeof ty' ty => + ret (finish dst nil (Esizeof ty' ty)) + | C.Evalof l ty => + do (sl, a) <- transl_expr For_val l; + ret (finish dst sl a) + | C.Eaddrof l ty => + do (sl, a) <- transl_expr For_val l; + ret (finish dst sl (Eaddrof a ty)) + | C.Eunop op r1 ty => + do (sl1, a1) <- transl_expr For_val r1; + ret (finish dst sl1 (Eunop op a1 ty)) + | C.Ebinop op r1 r2 ty => + do (sl1, a1) <- transl_expr For_val r1; + do (sl2, a2) <- transl_expr For_val r2; + ret (finish dst (sl1 ++ sl2) (Ebinop op a1 a2 ty)) + | C.Ecast r1 ty => + do (sl1, a1) <- transl_expr For_val r1; + ret (finish dst sl1 (Ecast a1 ty)) + | C.Econdition r1 r2 r3 ty => + do (sl1, a1) <- transl_expr For_val r1; + do (sl2, a2) <- transl_expr dst r2; + do (sl3, a3) <- transl_expr dst r3; + match dst with + | For_val => + do t <- gensym ty; + ret (sl1 ++ makeif a1 (Ssequence (makeseq sl2) (Sset t a2)) + (Ssequence (makeseq sl3) (Sset t a3)) :: nil, + Etempvar t ty) + | For_effects | For_test _ _ => + ret (sl1 ++ makeif a1 (makeseq sl2) (makeseq sl3) :: nil, + dummy_expr) + end + | C.Eassign l1 r2 ty => + do (sl1, a1) <- transl_expr For_val l1; + do (sl2, a2) <- transl_expr For_val r2; + let ty1 := C.typeof l1 in + let ty2 := C.typeof r2 in + match dst with + | For_val | For_test _ _ => + do t <- gensym ty2; + ret (finish dst + (sl1 ++ sl2 ++ Sset t a2 :: Sassign a1 (Etempvar t ty2) :: nil) + (Ecast (Etempvar t ty2) ty1)) + | For_effects => + ret (sl1 ++ sl2 ++ Sassign a1 a2 :: nil, + dummy_expr) + end + | C.Eassignop op l1 r2 tyres ty => + do (sl1, a1) <- transl_expr For_val l1; + do (sl2, a2) <- transl_expr For_val r2; + let ty1 := C.typeof l1 in + match dst with + | For_val | For_test _ _ => + do t <- gensym tyres; + ret (finish dst + (sl1 ++ sl2 ++ + Sset t (Ebinop op a1 a2 tyres) :: + Sassign a1 (Etempvar t tyres) :: nil) + (Ecast (Etempvar t tyres) ty1)) + | For_effects => + ret (sl1 ++ sl2 ++ Sassign a1 (Ebinop op a1 a2 tyres) :: nil, + dummy_expr) + end + | C.Epostincr id l1 ty => + do (sl1, a1) <- transl_expr For_val l1; + let ty1 := C.typeof l1 in + match dst with + | For_val | For_test _ _ => + do t <- gensym ty1; + ret (finish dst + (sl1 ++ Sset t a1 :: + Sassign a1 (transl_incrdecr id (Etempvar t ty1) ty1) :: nil) + (Etempvar t ty1)) + | For_effects => + ret (sl1 ++ Sassign a1 (transl_incrdecr id a1 ty1) :: nil, + dummy_expr) + end + | C.Ecomma r1 r2 ty => + do (sl1, a1) <- transl_expr For_effects r1; + do (sl2, a2) <- transl_expr dst r2; + ret (sl1 ++ sl2, a2) + | C.Ecall r1 rl2 ty => + do (sl1, a1) <- transl_expr For_val r1; + do (sl2, al2) <- transl_exprlist rl2; + match dst with + | For_val | For_test _ _ => + do t <- gensym ty; + ret (finish dst (sl1 ++ sl2 ++ Scall (Some t) a1 al2 :: nil) + (Etempvar t ty)) + | For_effects => + ret (sl1 ++ sl2 ++ Scall None a1 al2 :: nil, dummy_expr) + end + | C.Eparen r1 ty => + error (msg "SimplExpr.transl_expr: paren") + end + +with transl_exprlist (rl: exprlist) : mon (list statement * list expr) := + match rl with + | C.Enil => + ret (nil, nil) + | C.Econs r1 rl2 => + do (sl1, a1) <- transl_expr For_val r1; + do (sl2, al2) <- transl_exprlist rl2; + ret (sl1 ++ sl2, a1 :: al2) + end. + +Definition transl_expression (r: C.expr) : mon (statement * expr) := + do (sl, a) <- transl_expr For_val r; ret (makeseq sl, a). + +Definition transl_expr_stmt (r: C.expr) : mon statement := + do (sl, a) <- transl_expr For_effects r; ret (makeseq sl). + +Definition transl_if (r: C.expr) (s1 s2: statement) : mon statement := + do (sl, a) <- transl_expr (For_test s1 s2) r; ret (makeseq sl). + +(** Translation of statements *) + +Definition expr_true := Econst_int Int.one (Tint I32 Signed). + +Definition is_Sskip: + forall s, {s = C.Sskip} + {s <> C.Sskip}. +Proof. + destruct s; ((left; reflexivity) || (right; congruence)). +Defined. + +(** There are two possible translations for an "if then else" statement. + One is more efficient if the condition contains "?" constructors + but can duplicate the "then" and "else" branches. + The other produces no code duplication. We choose between the + two based on the shape of the "then" and "else" branches. *) + +Fixpoint small_stmt (s: statement) : bool := + match s with + | Sskip => true + | Sbreak => true + | Scontinue => true + | Sgoto _ => true + | Sreturn None => true + | Ssequence s1 s2 => small_stmt s1 && small_stmt s2 + | _ => false + end. + +Fixpoint transl_stmt (s: C.statement) : mon statement := + match s with + | C.Sskip => ret Sskip + | C.Sdo e => transl_expr_stmt e + | C.Ssequence s1 s2 => + do ts1 <- transl_stmt s1; + do ts2 <- transl_stmt s2; + ret (Ssequence ts1 ts2) + | C.Sifthenelse e s1 s2 => + do ts1 <- transl_stmt s1; + do ts2 <- transl_stmt s2; + if small_stmt ts1 && small_stmt ts2 then + transl_if e ts1 ts2 + else + (do (s', a) <- transl_expression e; + ret (Ssequence s' (Sifthenelse a ts1 ts2))) + | C.Swhile e s1 => + do s' <- transl_if e Sskip Sbreak; + do ts1 <- transl_stmt s1; + ret (Swhile expr_true (Ssequence s' ts1)) + | C.Sdowhile e s1 => + do s' <- transl_if e Sskip Sbreak; + do ts1 <- transl_stmt s1; + ret (Sfor' expr_true s' ts1) + | C.Sfor s1 e2 s3 s4 => + do ts1 <- transl_stmt s1; + do s' <- transl_if e2 Sskip Sbreak; + do ts3 <- transl_stmt s3; + do ts4 <- transl_stmt s4; + if is_Sskip s1 then + ret (Sfor' expr_true ts3 (Ssequence s' ts4)) + else + ret (Ssequence ts1 (Sfor' expr_true ts3 (Ssequence s' ts4))) + | C.Sbreak => + ret Sbreak + | C.Scontinue => + ret Scontinue + | C.Sreturn None => + ret (Sreturn None) + | C.Sreturn (Some e) => + do (s', a) <- transl_expression e; + ret (Ssequence s' (Sreturn (Some a))) + | C.Sswitch e ls => + do (s', a) <- transl_expression e; + do tls <- transl_lblstmt ls; + ret (Ssequence s' (Sswitch a tls)) + | C.Slabel lbl s1 => + do ts1 <- transl_stmt s1; + ret (Slabel lbl ts1) + | C.Sgoto lbl => + ret (Sgoto lbl) + end + +with transl_lblstmt (ls: C.labeled_statements) : mon labeled_statements := + match ls with + | C.LSdefault s => + do ts <- transl_stmt s; + ret (LSdefault ts) + | C.LScase n s ls1 => + do ts <- transl_stmt s; + do tls1 <- transl_lblstmt ls1; + ret (LScase n ts tls1) + end. + +(** Translation of a function *) + +Definition transl_function (f: C.function) : res function := + match transl_stmt f.(C.fn_body) initial_generator with + | Err msg => + Error msg + | Res tbody g i => + OK (mkfunction + f.(C.fn_return) + f.(C.fn_params) + f.(C.fn_vars) + g.(gen_trail) + tbody) + end. + +Local Open Scope error_monad_scope. + +Definition transl_fundef (fd: C.fundef) : res fundef := + match fd with + | C.Internal f => + do tf <- transl_function f; OK (Internal tf) + | C.External ef targs tres => + OK (External ef targs tres) + end. + +Definition transl_program (p: C.program) : res program := + transform_partial_program transl_fundef p. + + + + + + diff --git a/cfrontend/SimplExprproof.v b/cfrontend/SimplExprproof.v new file mode 100644 index 0000000..603e273 --- /dev/null +++ b/cfrontend/SimplExprproof.v @@ -0,0 +1,1851 @@ +(* *********************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Xavier Leroy, INRIA Paris-Rocquencourt *) +(* *) +(* Copyright Institut National de Recherche en Informatique et en *) +(* Automatique. All rights reserved. This file is distributed *) +(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* *) +(* *********************************************************************) + +(** Correctness proof for expression simplification. *) + +Require Import Coq.Program.Equality. +Require Import Axioms. +Require Import Coqlib. +Require Import Maps. +Require Import AST. +Require Import Errors. +Require Import Integers. +Require Import Values. +Require Import Memory. +Require Import Events. +Require Import Smallstep. +Require Import Globalenvs. +Require Import Determinism. +Require Import Csyntax. +Require Import Csem. +Require Import Cstrategy. +Require Import Clight. +Require Import SimplExpr. +Require Import SimplExprspec. + +Section PRESERVATION. + +Variable prog: C.program. +Variable tprog: Clight.program. +Hypothesis TRANSL: transl_program prog = OK tprog. + +Let ge := Genv.globalenv prog. +Let tge := Genv.globalenv tprog. + +(** Invariance properties. *) + +Lemma symbols_preserved: + forall (s: ident), Genv.find_symbol tge s = Genv.find_symbol ge s. +Proof + (Genv.find_symbol_transf_partial transl_fundef _ TRANSL). + +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 = OK tf. +Proof + (Genv.find_funct_ptr_transf_partial transl_fundef _ TRANSL). + +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 = OK tf. +Proof + (Genv.find_funct_transf_partial transl_fundef _ TRANSL). + +Lemma varinfo_preserved: + forall b, Genv.find_var_info tge b = Genv.find_var_info ge b. +Proof + (Genv.find_var_info_transf_partial transl_fundef _ TRANSL). + +Lemma type_of_fundef_preserved: + forall f tf, transl_fundef f = OK tf -> + type_of_fundef tf = C.type_of_fundef f. +Proof. + intros. destruct f; monadInv H. + exploit transl_function_spec; eauto. intros [A [B [C D]]]. + simpl. unfold type_of_function, C.type_of_function. congruence. + auto. +Qed. + +Lemma function_return_preserved: + forall f tf, transl_function f = OK tf -> + fn_return tf = C.fn_return f. +Proof. + intros. unfold transl_function in H. + destruct (transl_stmt (C.fn_body f) initial_generator); inv H. + auto. +Qed. + +Lemma type_of_global_preserved: + forall b ty, + Csem.type_of_global ge b = Some ty -> + type_of_global tge b = Some ty. +Proof. + intros until ty. unfold Csem.type_of_global, type_of_global. + rewrite varinfo_preserved. destruct (Genv.find_var_info ge b). auto. + case_eq (Genv.find_funct_ptr ge b); intros. + inv H0. exploit function_ptr_translated; eauto. intros [tf [A B]]. + rewrite A. decEq. apply type_of_fundef_preserved; auto. + congruence. +Qed. + +(** Translation of simple expressions. *) + +Lemma tr_simple_nil: + (forall le dst r sl a tmps, tr_expr le dst r sl a tmps -> + dst = For_val \/ dst = For_effects -> simple r -> sl = nil) +/\(forall le rl sl al tmps, tr_exprlist le rl sl al tmps -> + simplelist rl -> sl = nil). +Proof. + assert (A: forall dst a, dst = For_val \/ dst = For_effects -> final dst a = nil). + intros. destruct H; subst dst; auto. + apply tr_expr_exprlist; intros; simpl in *; try contradiction; auto. + rewrite H0; auto. simpl; auto. + rewrite H0; auto. simpl; auto. + destruct H1; congruence. + rewrite H0; auto. simpl; auto. + rewrite H0; auto. simpl; auto. + rewrite H0; auto. simpl; auto. + destruct H7. rewrite H0; auto. rewrite H2; auto. simpl; auto. + rewrite H0; auto. simpl; auto. + destruct H6. rewrite H0; auto. +Qed. + +Lemma tr_simple_expr_nil: + forall le dst r sl a tmps, tr_expr le dst r sl a tmps -> + dst = For_val \/ dst = For_effects -> simple r -> sl = nil. +Proof (proj1 tr_simple_nil). + +Lemma tr_simple_exprlist_nil: + forall le rl sl al tmps, tr_exprlist le rl sl al tmps -> + simplelist rl -> sl = nil. +Proof (proj2 tr_simple_nil). + +(** Evaluation of simple expressions and of their translation *) + +Lemma tr_simple: + forall e m, + (forall r v, + eval_simple_rvalue ge e m r v -> + forall le dst sl a tmps, + tr_expr le dst r sl a tmps -> + match dst with + | For_val => sl = nil /\ C.typeof r = typeof a /\ eval_expr tge e le m a v + | For_effects => sl = nil + | For_test s1 s2 => + exists b, sl = makeif b s1 s2 :: nil /\ C.typeof r = typeof b /\ eval_expr tge e le m b v + end) +/\ + (forall l b ofs, + eval_simple_lvalue ge e m l b ofs -> + forall le sl a tmps, + tr_expr le For_val l sl a tmps -> + sl = nil /\ C.typeof l = typeof a /\ eval_lvalue tge e le m a b ofs). +Proof. +Opaque makeif. + intros e m. + apply (eval_simple_rvalue_lvalue_ind ge e m); intros until tmps; intros TR; inv TR. +(* value *) + auto. + auto. + exists a0; auto. +(* rvalof *) + exploit H0; eauto. intros [A [B C]]. + subst sl1; simpl. + assert (eval_expr tge e le m a v). eapply eval_Elvalue. eauto. congruence. + destruct dst; auto. + econstructor. split. simpl; eauto. auto. +(* addrof *) + exploit H0; eauto. intros [A [B C]]. + subst sl1; simpl. + assert (eval_expr tge e le m (Eaddrof a1 ty) (Vptr b ofs)). econstructor; eauto. + destruct dst; auto. simpl; econstructor; eauto. +(* unop *) + exploit H0; eauto. intros [A [B C]]. + subst sl1; simpl. + assert (eval_expr tge e le m (Eunop op a1 ty) v). econstructor; eauto. congruence. + destruct dst; auto. simpl; econstructor; eauto. +(* binop *) + exploit H0; eauto. intros [A [B C]]. + exploit H2; eauto. intros [D [E F]]. + subst sl1 sl2; simpl. + assert (eval_expr tge e le m (Ebinop op a1 a2 ty) v). econstructor; eauto. congruence. + destruct dst; auto. simpl; econstructor; eauto. +(* cast *) + exploit H0; eauto. intros [A [B C]]. + subst sl1; simpl. + assert (eval_expr tge e le m (Ecast a1 ty) v). econstructor; eauto. congruence. + destruct dst; auto. simpl; econstructor; eauto. +(* sizeof *) + destruct dst. + split; auto. split; auto. constructor. + auto. + exists (Esizeof ty1 ty). split. auto. split. auto. constructor. +(* var local *) + split; auto. split; auto. apply eval_Evar_local; auto. +(* var global *) + split; auto. split; auto. apply eval_Evar_global; auto. + rewrite symbols_preserved; auto. + eapply type_of_global_preserved; eauto. +(* deref *) + exploit H0; eauto. intros [A [B C]]. subst sl1. + split; auto. split; auto. constructor; auto. +(* field struct *) + exploit H0; eauto. intros [A [B C]]. subst sl1. + split; auto. split; auto. rewrite B in H1. eapply eval_Efield_struct; eauto. +(* field union *) + exploit H0; eauto. intros [A [B C]]. subst sl1. + split; auto. split; auto. rewrite B in H1. eapply eval_Efield_union; eauto. +Qed. + +Lemma tr_simple_rvalue: + forall e m r v, + eval_simple_rvalue ge e m r v -> + forall le dst sl a tmps, + tr_expr le dst r sl a tmps -> + match dst with + | For_val => sl = nil /\ C.typeof r = typeof a /\ eval_expr tge e le m a v + | For_effects => sl = nil + | For_test s1 s2 => + exists b, sl = makeif b s1 s2 :: nil /\ C.typeof r = typeof b /\ eval_expr tge e le m b v + end. +Proof. + intros e m. exact (proj1 (tr_simple e m)). +Qed. + +Lemma tr_simple_lvalue: + forall e m l b ofs, + eval_simple_lvalue ge e m l b ofs -> + forall le sl a tmps, + tr_expr le For_val l sl a tmps -> + sl = nil /\ C.typeof l = typeof a /\ eval_lvalue tge e le m a b ofs. +Proof. + intros e m. exact (proj2 (tr_simple e m)). +Qed. + +Lemma tr_simple_exprlist: + forall le rl sl al tmps, + tr_exprlist le rl sl al tmps -> + forall e m tyl vl, + eval_simple_list ge e m rl tyl vl -> + sl = nil /\ eval_exprlist tge e le m al tyl vl. +Proof. + induction 1; intros. + inv H. split. auto. constructor. + inv H4. + exploit tr_simple_rvalue; eauto. intros [A [B C]]. + exploit IHtr_exprlist; eauto. intros [D E]. + split. subst; auto. econstructor; eauto. congruence. +Qed. + +(** Commutation between the translation of expressions and left contexts. *) + +Lemma typeof_context: + forall k1 k2 C, leftcontext k1 k2 C -> + forall e1 e2, C.typeof e1 = C.typeof e2 -> + C.typeof (C e1) = C.typeof (C e2). +Proof. + induction 1; intros; auto. +Qed. + +Inductive compat_dest: (C.expr -> C.expr) -> purpose -> purpose -> list statement -> Prop := + | compat_dest_base: forall dst, + compat_dest (fun x => x) dst dst nil + | compat_dest_val: forall C dst sl, + compat_dest C For_val dst sl + | compat_dest_effects: forall C dst sl, + compat_dest C For_effects dst sl + | compat_dest_paren: forall C ty dst' dst sl, + compat_dest C dst' dst sl -> + compat_dest (fun x => C.Eparen (C x) ty) dst' dst sl. + +Lemma compat_dest_not_test: + forall C dst' dst sl, + compat_dest C dst' dst sl -> + dst = For_val \/ dst = For_effects -> + dst' = For_val \/ dst' = For_effects. +Proof. + induction 1; intros; auto. +Qed. + +Lemma compat_dest_change: + forall C1 dst' dst1 sl1 C2 dst2 sl2, + compat_dest C1 dst' dst1 sl1 -> + dst1 = For_val \/ dst1 = For_effects -> + compat_dest C2 dst' dst2 sl2. +Proof. + intros. exploit compat_dest_not_test; eauto. intros [A | A]; subst dst'; constructor. +Qed. + +Scheme leftcontext_ind2 := Minimality for leftcontext Sort Prop + with leftcontextlist_ind2 := Minimality for leftcontextlist Sort Prop. +Combined Scheme leftcontext_leftcontextlist_ind from leftcontext_ind2, leftcontextlist_ind2. + +Lemma tr_expr_leftcontext_rec: + ( + forall from to C, leftcontext from to C -> + forall le e dst sl a tmps, + tr_expr le dst (C e) sl a tmps -> + exists dst', exists sl1, exists sl2, exists a', exists tmp', + tr_expr le dst' e sl1 a' tmp' + /\ sl = sl1 ++ sl2 + /\ compat_dest C dst' dst sl2 + /\ incl tmp' tmps + /\ (forall le' e' sl3, + tr_expr le' dst' e' sl3 a' tmp' -> + (forall id, ~In id tmp' -> le'!id = le!id) -> + C.typeof e' = C.typeof e -> + tr_expr le' dst (C e') (sl3 ++ sl2) a tmps) + ) /\ ( + forall from C, leftcontextlist from C -> + forall le e sl a tmps, + tr_exprlist le (C e) sl a tmps -> + exists dst', exists sl1, exists sl2, exists a', exists tmp', + tr_expr le dst' e sl1 a' tmp' + /\ sl = sl1 ++ sl2 + /\ match dst' with For_test _ _ => False | _ => True end + /\ incl tmp' tmps + /\ (forall le' e' sl3, + tr_expr le' dst' e' sl3 a' tmp' -> + (forall id, ~In id tmp' -> le'!id = le!id) -> + C.typeof e' = C.typeof e -> + tr_exprlist le' (C e') (sl3 ++ sl2) a tmps) +). +Proof. + +Ltac TR := + econstructor; econstructor; econstructor; econstructor; econstructor; + split; [eauto | split; [idtac | split; [eauto | split]]]. + +Ltac NOTIN := + match goal with + | [ H1: In ?x ?l, H2: list_disjoint ?l _ |- ~In ?x _ ] => + red; intro; elim (H2 x x); auto + | [ H1: In ?x ?l, H2: list_disjoint _ ?l |- ~In ?x _ ] => + red; intro; elim (H2 x x); auto + end. + +Ltac UNCHANGED := + match goal with + | [ H: (forall (id: ident), ~In id _ -> ?le' ! id = ?le ! id) |- + (forall (id: ident), In id _ -> ?le' ! id = ?le ! id) ] => + intros; apply H; NOTIN + end. + + generalize compat_dest_change; intro CDC. + apply leftcontext_leftcontextlist_ind; intros. + +(* base *) + TR. rewrite <- app_nil_end; auto. constructor. red; auto. + intros. rewrite <- app_nil_end; auto. +(* deref *) + inv H1. + exploit H0; eauto. intros [dst' [sl1' [sl2' [a' [tmp' [P [Q [U [R S]]]]]]]]]. + TR. subst sl1; rewrite app_ass; eauto. auto. + intros. rewrite <- app_ass. econstructor; eauto. +(* field *) + inv H1. + exploit H0. eauto. intros [dst' [sl1' [sl2' [a' [tmp' [P [Q [U [R S]]]]]]]]]. + TR. subst sl1; rewrite app_ass; eauto. auto. + intros. rewrite <- app_ass. econstructor; eauto. +(* rvalof *) + inv H1. + exploit H0; eauto. intros [dst' [sl1' [sl2' [a' [tmp' [P [Q [U [R S]]]]]]]]]. + TR. subst sl1; rewrite app_ass; eauto. auto. + intros. rewrite <- app_ass; econstructor; eauto. +(* addrof *) + inv H1. + exploit H0; eauto. intros [dst' [sl1' [sl2' [a' [tmp' [P [Q [U [R S]]]]]]]]]. + TR. subst sl1; rewrite app_ass; eauto. auto. + intros. rewrite <- app_ass. econstructor; eauto. +(* unop *) + inv H1. + exploit H0; eauto. intros [dst' [sl1' [sl2' [a' [tmp' [P [Q [U [R S]]]]]]]]]. + TR. subst sl1; rewrite app_ass; eauto. auto. + intros. rewrite <- app_ass. econstructor; eauto. +(* binop left *) + inv H1. + exploit H0; eauto. intros [dst' [sl1' [sl2' [a' [tmp' [P [Q [U [R S]]]]]]]]]. + TR. subst sl1. rewrite app_ass. eauto. + red; auto. + intros. rewrite <- app_ass. econstructor; eauto. + eapply tr_expr_invariant; eauto. UNCHANGED. +(* binop right *) + inv H2. + assert (sl1 = nil) by (eapply tr_simple_expr_nil; eauto). subst sl1; simpl. + exploit H1; eauto. intros [dst' [sl1' [sl2' [a' [tmp' [P [Q [U [R S]]]]]]]]]. + TR. subst sl2. rewrite app_ass. eauto. + red; auto. + intros. rewrite <- app_ass. change (sl3 ++ sl2') with (nil ++ sl3 ++ sl2'). rewrite app_ass. econstructor; eauto. + eapply tr_expr_invariant; eauto. UNCHANGED. +(* cast *) + inv H1. + exploit H0; eauto. intros [dst' [sl1' [sl2' [a' [tmp' [P [Q [U [R S]]]]]]]]]. + TR. subst sl1; rewrite app_ass; eauto. auto. + intros. rewrite <- app_ass. econstructor; eauto. +(* condition *) + inv H1. + (* for val *) + exploit H0; eauto. intros [dst' [sl1' [sl2' [a' [tmp' [P [Q [U [R S]]]]]]]]]. + TR. + rewrite Q. rewrite app_ass. eauto. + red; auto. + intros. rewrite <- app_ass. econstructor. apply S; auto. + eapply tr_expr_invariant; eauto. UNCHANGED. + eapply tr_expr_invariant; eauto. UNCHANGED. + auto. auto. auto. auto. auto. auto. auto. + (* for effects *) + exploit H0; eauto. intros [dst' [sl1' [sl2' [a' [tmp' [P [Q [U [R S]]]]]]]]]. + TR. + rewrite Q. rewrite app_ass. eauto. + red; auto. + intros. rewrite <- app_ass. econstructor. auto. apply S; auto. + eapply tr_expr_invariant; eauto. UNCHANGED. + eapply tr_expr_invariant; eauto. UNCHANGED. + auto. auto. auto. auto. auto. +(* assign left *) + inv H1. + (* for effects *) + exploit H0; eauto. intros [dst' [sl1' [sl2' [a' [tmp' [P [Q [U [R S]]]]]]]]]. + TR. subst sl1. rewrite app_ass. eauto. + red; auto. + intros. rewrite <- app_ass. econstructor. apply S; auto. + eapply tr_expr_invariant; eauto. UNCHANGED. + auto. auto. auto. + (* for val *) + exploit H0; eauto. intros [dst' [sl1' [sl2' [a' [tmp' [P [Q [U [R S]]]]]]]]]. + TR. subst sl1. rewrite app_ass. eauto. + red; auto. + intros. rewrite <- app_ass. econstructor. apply S; auto. + eapply tr_expr_invariant; eauto. UNCHANGED. + auto. auto. auto. auto. auto. auto. + eapply typeof_context; eauto. + auto. +(* assign right *) + inv H2. + (* for effects *) + assert (sl1 = nil) by (eapply tr_simple_expr_nil; eauto). subst sl1; simpl. + exploit H1; eauto. intros [dst' [sl1' [sl2' [a' [tmp' [P [Q [U [R S]]]]]]]]]. + TR. subst sl2. rewrite app_ass. eauto. + red; auto. + intros. rewrite <- app_ass. change (sl3 ++ sl2') with (nil ++ (sl3 ++ sl2')). rewrite app_ass. + econstructor. + eapply tr_expr_invariant; eauto. UNCHANGED. + apply S; auto. auto. auto. auto. + (* for val *) + assert (sl1 = nil) by (eapply tr_simple_expr_nil; eauto). subst sl1; simpl. + exploit H1; eauto. intros [dst' [sl1' [sl2' [a' [tmp' [P [Q [U [R S]]]]]]]]]. + TR. subst sl2. rewrite app_ass. eauto. + red; auto. + intros. rewrite <- app_ass. change (sl3 ++ sl2') with (nil ++ (sl3 ++ sl2')). rewrite app_ass. + econstructor. + eapply tr_expr_invariant; eauto. UNCHANGED. + apply S; auto. auto. auto. auto. auto. auto. auto. auto. + eapply typeof_context; eauto. +(* assignop left *) + inv H1. + (* for effects *) + exploit H0; eauto. intros [dst' [sl1' [sl2' [a' [tmp' [P [Q [U [R S]]]]]]]]]. + TR. subst sl1. rewrite app_ass. eauto. + red; auto. + intros. rewrite <- app_ass. econstructor. apply S; auto. + eapply tr_expr_invariant; eauto. UNCHANGED. + auto. auto. auto. + (* for val *) + exploit H0; eauto. intros [dst' [sl1' [sl2' [a' [tmp' [P [Q [U [R S]]]]]]]]]. + TR. subst sl1. rewrite app_ass. eauto. + red; auto. + intros. rewrite <- app_ass. econstructor. apply S; auto. + eapply tr_expr_invariant; eauto. UNCHANGED. + auto. auto. auto. auto. auto. auto. + eapply typeof_context; eauto. +(* assignop right *) + inv H2. + (* for effects *) + assert (sl1 = nil) by (eapply tr_simple_expr_nil; eauto). subst sl1; simpl. + exploit H1; eauto. intros [dst' [sl1' [sl2' [a' [tmp' [P [Q [U [R S]]]]]]]]]. + TR. subst sl2. rewrite app_ass. eauto. + red; auto. + intros. rewrite <- app_ass. change (sl3 ++ sl2') with (nil ++ sl3 ++ sl2'). rewrite app_ass. econstructor. + eapply tr_expr_invariant; eauto. UNCHANGED. + apply S; auto. auto. auto. auto. + (* for val *) + assert (sl1 = nil) by (eapply tr_simple_expr_nil; eauto). subst sl1; simpl. + exploit H1; eauto. intros [dst' [sl1' [sl2' [a' [tmp' [P [Q [U [R S]]]]]]]]]. + TR. subst sl2. rewrite app_ass. eauto. + red; auto. + intros. rewrite <- app_ass. change (sl3 ++ sl2') with (nil ++ sl3 ++ sl2'). rewrite app_ass. econstructor. + eapply tr_expr_invariant; eauto. UNCHANGED. + apply S; auto. auto. auto. auto. auto. auto. auto. auto. +(* postincr *) + inv H1. + (* for effects *) + exploit H0; eauto. intros [dst' [sl1' [sl2' [a' [tmp' [P [Q [U [R S]]]]]]]]]. + TR. rewrite Q; rewrite app_ass; eauto. red; auto. + intros. replace (C.typeof (C e)) with (C.typeof (C e')). rewrite <- app_ass. + econstructor; eauto. + eapply typeof_context; eauto. + (* for val *) + exploit H0; eauto. intros [dst' [sl1' [sl2' [a' [tmp' [P [Q [U [R S]]]]]]]]]. + TR. rewrite Q; rewrite app_ass; eauto. red; auto. + intros. rewrite <- app_ass. econstructor; eauto. + eapply typeof_context; eauto. +(* call left *) + inv H1. + (* for effects *) + exploit H0; eauto. intros [dst' [sl1' [sl2' [a' [tmp' [P [Q [U [R S]]]]]]]]]. + TR. rewrite Q; rewrite app_ass; eauto. red; auto. + intros. rewrite <- app_ass. econstructor. apply S; auto. + eapply tr_exprlist_invariant; eauto. UNCHANGED. + auto. auto. auto. + (* for val *) + exploit H0; eauto. intros [dst' [sl1' [sl2' [a' [tmp' [P [Q [U [R S]]]]]]]]]. + TR. rewrite Q; rewrite app_ass; eauto. red; auto. + intros. rewrite <- app_ass. econstructor. auto. apply S; auto. + eapply tr_exprlist_invariant; eauto. UNCHANGED. + auto. auto. auto. auto. +(* call right *) + inv H2. + (* for effects *) + assert (sl1 = nil) by (eapply tr_simple_expr_nil; eauto). subst sl1; simpl. + exploit H1; eauto. intros [dst' [sl1' [sl2' [a' [tmp' [P [Q [U [R S]]]]]]]]]. + TR. rewrite Q; rewrite app_ass; eauto. destruct dst'; contradiction || constructor. + red; auto. + intros. rewrite <- app_ass. change (sl3++sl2') with (nil ++ sl3 ++ sl2'). rewrite app_ass. econstructor. + eapply tr_expr_invariant; eauto. UNCHANGED. + apply S; auto. auto. auto. auto. + (* for val *) + assert (sl1 = nil) by (eapply tr_simple_expr_nil; eauto). subst sl1; simpl. + exploit H1; eauto. intros [dst' [sl1' [sl2' [a' [tmp' [P [Q [U [R S]]]]]]]]]. + TR. rewrite Q; rewrite app_ass; eauto. destruct dst'; contradiction || constructor. + red; auto. + intros. rewrite <- app_ass. change (sl3++sl2') with (nil ++ sl3 ++ sl2'). rewrite app_ass. econstructor. + auto. eapply tr_expr_invariant; eauto. UNCHANGED. + apply S; auto. + auto. auto. auto. auto. +(* comma *) + inv H1. + exploit H0; eauto. intros [dst' [sl1' [sl2' [a' [tmp' [P [Q [U [R S]]]]]]]]]. + TR. rewrite Q; rewrite app_ass; eauto. red; auto. + intros. rewrite <- app_ass. econstructor. apply S; auto. + eapply tr_expr_invariant; eauto. UNCHANGED. + auto. auto. auto. +(* paren *) + inv H1. + (* for val *) + exploit H0; eauto. intros [dst' [sl1' [sl2' [a' [tmp' [P [Q [U [R S]]]]]]]]]. + TR. rewrite Q. rewrite app_ass. eauto. red; auto. + intros. rewrite <- app_ass. econstructor; eauto. + (* for effects *) + exploit H0; eauto. intros [dst' [sl1' [sl2' [a' [tmp' [P [Q [U [R S]]]]]]]]]. + TR. rewrite Q. eauto. constructor; auto. auto. + intros. econstructor; eauto. +(* cons left *) + inv H1. + exploit H0; eauto. intros [dst' [sl1' [sl2' [a' [tmp' [P [Q [U [R S]]]]]]]]]. + TR. subst sl1. rewrite app_ass. eauto. + exploit compat_dest_not_test; eauto. intros [A|A]; subst dst'; auto. + red; auto. + intros. rewrite <- app_ass. econstructor. apply S; auto. + eapply tr_exprlist_invariant; eauto. UNCHANGED. + auto. auto. auto. +(* cons right *) + inv H2. + assert (sl1 = nil) by (eapply tr_simple_expr_nil; eauto). subst sl1; simpl. + exploit H1; eauto. intros [dst' [sl1' [sl2' [a' [tmp' [P [Q [U [R S]]]]]]]]]. + TR. subst sl2. eauto. + red; auto. + intros. change sl3 with (nil ++ sl3). rewrite app_ass. econstructor. + eapply tr_expr_invariant; eauto. UNCHANGED. + apply S; auto. + auto. auto. auto. +Qed. + +Theorem tr_expr_leftcontext: + forall C le r dst sl a tmps, + leftcontext RV RV C -> + tr_expr le dst (C r) sl a tmps -> + exists dst', exists sl1, exists sl2, exists a', exists tmp', + tr_expr le dst' r sl1 a' tmp' + /\ sl = sl1 ++ sl2 + /\ compat_dest C dst' dst sl2 + /\ incl tmp' tmps + /\ (forall le' r' sl3, + tr_expr le' dst' r' sl3 a' tmp' -> + (forall id, ~In id tmp' -> le'!id = le!id) -> + C.typeof r' = C.typeof r -> + tr_expr le' dst (C r') (sl3 ++ sl2) a tmps). +Proof. + intros. eapply (proj1 tr_expr_leftcontext_rec); eauto. +Qed. + +Theorem tr_top_leftcontext: + forall e le m dst rtop sl a tmps, + tr_top tge e le m dst rtop sl a tmps -> + forall r C, + rtop = C r -> + leftcontext RV RV C -> + exists dst', exists sl1, exists sl2, exists a', exists tmp', + tr_top tge e le m dst' r sl1 a' tmp' + /\ sl = sl1 ++ sl2 + /\ compat_dest C dst' dst sl2 + /\ incl tmp' tmps + /\ (forall le' m' r' sl3, + tr_expr le' dst' r' sl3 a' tmp' -> + (forall id, ~In id tmp' -> le'!id = le!id) -> + C.typeof r' = C.typeof r -> + tr_top tge e le' m' dst (C r') (sl3 ++ sl2) a tmps). +Proof. + induction 1; intros. +(* val for val *) + inv H2; inv H1. + exists For_val; econstructor; econstructor; econstructor; econstructor. + split. apply tr_top_val_val; eauto. + split. instantiate (1 := nil); auto. + split. constructor. + split. apply incl_refl. + intros. rewrite <- app_nil_end. constructor; auto. +(* val for test *) + inv H2; inv H1. + exists (For_test s1 s2); econstructor; econstructor; econstructor; econstructor. + split. apply tr_top_val_test; eauto. + split. instantiate (1 := nil); auto. + split. constructor. + split. apply incl_refl. + intros. rewrite <- app_nil_end. constructor; eauto. +(* base *) + subst r. exploit tr_expr_leftcontext; eauto. + intros [dst' [sl1 [sl2 [a' [tmp' [P [Q [R [S T]]]]]]]]]. + exists dst'; exists sl1; exists sl2; exists a'; exists tmp'. + split. apply tr_top_base; auto. + split. auto. split. auto. split. auto. + intros. apply tr_top_base. apply T; auto. +(* paren *) + inv H1; inv H0. + (* at top *) + exists (For_test s1 s2); econstructor; econstructor; econstructor; econstructor. + split. apply tr_top_paren_test; eauto. + split. instantiate (1 := nil). rewrite <- app_nil_end; auto. + split. constructor. + split. apply incl_refl. + intros. rewrite <- app_nil_end. constructor; eauto. + (* below *) + exploit (IHtr_top r0 C0); auto. + intros [dst' [sl1 [sl2 [a' [tmp' [P [Q [T [R S]]]]]]]]]. + exists dst'; exists sl1; exists sl2; exists a'; exists tmp'. + split. auto. + split. auto. + split. constructor; auto. + split. auto. + intros. apply tr_top_paren_test. apply S; auto. +Qed. + +Theorem tr_top_testcontext: + forall C s1 s2 dst sl2 r sl1 a tmps e le m, + compat_dest C (For_test s1 s2) dst sl2 -> + tr_top tge e le m (For_test s1 s2) r sl1 a tmps -> + dst = For_test s1 s2 /\ tr_top tge e le m dst (C r) (sl1 ++ sl2) a tmps. +Proof. + intros. dependent induction H. + split. auto. rewrite <- app_nil_end. auto. + exploit IHcompat_dest; eauto. intros [A B]. + split. auto. subst dst. apply tr_top_paren_test. auto. +Qed. + +(** Semantics of smart constructors *) + +Lemma step_makeif_true: + forall f a s1 s2 k e le m v1, + eval_expr tge e le m a v1 -> + is_true v1 (typeof a) -> + star step tge (State f (makeif a s1 s2) k e le m) + E0 (State f s1 k e le m). +Proof. + intros. functional induction (makeif a s1 s2). + inversion H. subst v1. inversion H0. congruence. congruence. + inversion H1. + apply star_refl. + apply star_one. apply step_ifthenelse_true with v1; auto. +Qed. + +Lemma step_makeif_false: + forall f a s1 s2 k e le m v1, + eval_expr tge e le m a v1 -> + is_false v1 (typeof a) -> + star step tge (State f (makeif a s1 s2) k e le m) + E0 (State f s2 k e le m). +Proof. + intros. functional induction (makeif a s1 s2). + apply star_refl. + inversion H. subst v1. inversion H0. congruence. congruence. + inversion H1. + apply star_one. apply step_ifthenelse_false with v1; auto. +Qed. + +(** Matching between continuations *) + +Fixpoint Kseqlist (sl: list statement) (k: cont) := + match sl with + | nil => k + | s :: l => Kseq s (Kseqlist l k) + end. + +Remark Kseqlist_app: + forall sl1 sl2 k, + Kseqlist (sl1 ++ sl2) k = Kseqlist sl1 (Kseqlist sl2 k). +Proof. + induction sl1; simpl; congruence. +Qed. + +Inductive match_cont : Csem.cont -> cont -> Prop := + | match_Kstop: + match_cont Csem.Kstop Kstop + | match_Kseq: forall s k ts tk, + tr_stmt s ts -> + match_cont k tk -> + match_cont (Csem.Kseq s k) (Kseq ts tk) + | match_Kwhile2: forall r s k s' ts tk, + tr_if r Sskip Sbreak s' -> + tr_stmt s ts -> + match_cont k tk -> + match_cont (Csem.Kwhile2 r s k) + (Kwhile expr_true (Ssequence s' ts) tk) + | match_Kdowhile1: forall r s k s' ts tk, + tr_if r Sskip Sbreak s' -> + tr_stmt s ts -> + match_cont k tk -> + match_cont (Csem.Kdowhile1 r s k) + (Kfor2 expr_true s' ts tk) + | match_Kfor3: forall r s3 s k ts3 s' ts tk, + tr_if r Sskip Sbreak s' -> + tr_stmt s3 ts3 -> + tr_stmt s ts -> + match_cont k tk -> + match_cont (Csem.Kfor3 r s3 s k) + (Kfor2 expr_true ts3 (Ssequence s' ts) tk) + | match_Kfor4: forall r s3 s k ts3 s' ts tk, + tr_if r Sskip Sbreak s' -> + tr_stmt s3 ts3 -> + tr_stmt s ts -> + match_cont k tk -> + match_cont (Csem.Kfor4 r s3 s k) + (Kfor3 expr_true ts3 (Ssequence s' ts) tk) + | match_Kswitch2: forall k tk, + match_cont k tk -> + match_cont (Csem.Kswitch2 k) (Kswitch tk) + | match_Kcall_none: forall f e C ty k tf le sl tk a dest tmps, + transl_function f = Errors.OK tf -> + leftcontext RV RV C -> + (forall v m, tr_top tge e le m dest (C (C.Eval v ty)) sl a tmps) -> + match_cont_exp dest a k tk -> + match_cont (Csem.Kcall f e C ty k) + (Kcall None tf e le (Kseqlist sl tk)) + | match_Kcall_some: forall f e C ty k dst tf le sl tk a dest tmps, + transl_function f = Errors.OK tf -> + leftcontext RV RV C -> + (forall v m, tr_top tge e (PTree.set dst v le) m dest (C (C.Eval v ty)) sl a tmps) -> + match_cont_exp dest a k tk -> + match_cont (Csem.Kcall f e C ty k) + (Kcall (Some dst) tf e le (Kseqlist sl tk)) + +with match_cont_exp : purpose -> expr -> Csem.cont -> cont -> Prop := + | match_Kdo: forall k a tk, + match_cont k tk -> + match_cont_exp For_effects a (Csem.Kdo k) tk + | match_Kifthenelse_1: forall a s1 s2 k ts1 ts2 tk, + tr_stmt s1 ts1 -> tr_stmt s2 ts2 -> + match_cont k tk -> + match_cont_exp For_val a (Csem.Kifthenelse s1 s2 k) (Kseq (Sifthenelse a ts1 ts2) tk) + | match_Kifthenelse_2: forall a s1 s2 k ts1 ts2 tk, + tr_stmt s1 ts1 -> tr_stmt s2 ts2 -> + match_cont k tk -> + match_cont_exp (For_test ts1 ts2) a (Csem.Kifthenelse s1 s2 k) tk + | match_Kwhile1: forall r s k s' a ts tk, + tr_if r Sskip Sbreak s' -> + tr_stmt s ts -> + match_cont k tk -> + match_cont_exp (For_test Sskip Sbreak) a + (Csem.Kwhile1 r s k) + (Kseq ts (Kwhile expr_true (Ssequence s' ts) tk)) + | match_Kdowhile2: forall r s k s' a ts tk, + tr_if r Sskip Sbreak s' -> + tr_stmt s ts -> + match_cont k tk -> + match_cont_exp (For_test Sskip Sbreak) a + (Csem.Kdowhile2 r s k) + (Kfor3 expr_true s' ts tk) + | match_Kfor2: forall r s3 s k s' a ts3 ts tk, + tr_if r Sskip Sbreak s' -> + tr_stmt s3 ts3 -> + tr_stmt s ts -> + match_cont k tk -> + match_cont_exp (For_test Sskip Sbreak) a + (Csem.Kfor2 r s3 s k) + (Kseq ts (Kfor2 expr_true ts3 (Ssequence s' ts) tk)) + | match_Kswitch1: forall ls k a tls tk, + tr_lblstmts ls tls -> + match_cont k tk -> + match_cont_exp For_val a (Csem.Kswitch1 ls k) (Kseq (Sswitch a tls) tk) + | match_Kreturn: forall k a tk, + match_cont k tk -> + match_cont_exp For_val a (Csem.Kreturn k) (Kseq (Sreturn (Some a)) tk). + +Lemma match_cont_call: + forall k tk, + match_cont k tk -> + match_cont (Csem.call_cont k) (call_cont tk). +Proof. + induction 1; simpl; auto. constructor. econstructor; eauto. econstructor; eauto. +Qed. + +Lemma match_cont_exp_for_test_inv: + forall s1 s2 a a' k tk, + match_cont_exp (For_test s1 s2) a k tk -> + match_cont_exp (For_test s1 s2) a' k tk. +Proof. + intros. inv H; econstructor; eauto. +Qed. + +(** Matching between states *) + +Inductive match_states: Csem.state -> state -> Prop := + | match_exprstates: forall f r k e m tf sl tk le dest a tmps, + transl_function f = Errors.OK tf -> + tr_top tge e le m dest r sl a tmps -> + match_cont_exp dest a k tk -> + match_states (Csem.ExprState f r k e m) + (State tf Sskip (Kseqlist sl tk) e le m) + | match_regularstates: forall f s k e m tf ts tk le, + transl_function f = Errors.OK tf -> + tr_stmt s ts -> + match_cont k tk -> + match_states (Csem.State f s k e m) + (State tf ts tk e le m) + | match_callstates: forall fd args k m tfd tk, + transl_fundef fd = Errors.OK tfd -> + match_cont k tk -> + match_states (Csem.Callstate fd args k m) + (Callstate tfd args tk m) + | match_returnstates: forall res k m tk, + match_cont k tk -> + match_states (Csem.Returnstate res k m) + (Returnstate res tk m). + +Lemma push_seq: + forall f sl k e le m, + star step tge (State f (makeseq sl) k e le m) + E0 (State f Sskip (Kseqlist sl k) e le m). +Proof. + intros. unfold makeseq. generalize Sskip. revert sl k. + induction sl; simpl; intros. + apply star_refl. + eapply star_right. apply IHsl. constructor. traceEq. +Qed. + +(** Additional results on translation of statements *) + +Lemma tr_select_switch: + forall n ls tls, + tr_lblstmts ls tls -> + tr_lblstmts (Csem.select_switch n ls) (select_switch n tls). +Proof. + induction 1; simpl. + constructor; auto. + destruct (Int.eq n0 n). constructor; auto. auto. +Qed. + +Lemma tr_seq_of_labeled_statement: + forall ls tls, + tr_lblstmts ls tls -> + tr_stmt (Csem.seq_of_labeled_statement ls) (seq_of_labeled_statement tls). +Proof. + induction 1; simpl. auto. constructor; auto. +Qed. + +(** Commutation between translation and the "find label" operation. *) + +Section FIND_LABEL. + +Variable lbl: label. + +Definition nolabel (s: statement) : Prop := + forall k, find_label lbl s k = None. + +Fixpoint nolabel_list (sl: list statement) : Prop := + match sl with + | nil => True + | s1 :: sl' => nolabel s1 /\ nolabel_list sl' + end. + +Lemma nolabel_list_app: + forall sl2 sl1, nolabel_list sl1 -> nolabel_list sl2 -> nolabel_list (sl1 ++ sl2). +Proof. + induction sl1; simpl; intros. auto. tauto. +Qed. + +Lemma makeseq_nolabel: + forall sl, nolabel_list sl -> nolabel (makeseq sl). +Proof. + assert (forall sl s, nolabel s -> nolabel_list sl -> nolabel (makeseq_rec s sl)). + induction sl; simpl; intros. auto. destruct H0. apply IHsl; auto. + red. intros; simpl. rewrite H. apply H0. + intros. unfold makeseq. apply H; auto. red. auto. +Qed. + +Lemma small_stmt_nolabel: + forall s, small_stmt s = true -> nolabel s. +Proof. + induction s; simpl; intros; congruence || (red; auto). + destruct (andb_prop _ _ H). intros; simpl. rewrite IHs1; auto. apply IHs2; auto. +Qed. + +Lemma makeif_nolabel: + forall a s1 s2, nolabel s1 -> nolabel s2 -> nolabel (makeif a s1 s2). +Proof. + intros. functional induction (makeif a s1 s2); auto. + red; simpl; intros. rewrite H; auto. +Qed. + +Definition nolabel_dest (dst: purpose) : Prop := + match dst with + | For_val => True + | For_effects => True + | For_test s1 s2 => nolabel s1 /\ nolabel s2 + end. + +Lemma nolabel_final: + forall dst a, nolabel_dest dst -> nolabel_list (final dst a). +Proof. + destruct dst; simpl; intros. auto. auto. + split; auto. destruct H. apply makeif_nolabel; auto. +Qed. + +Ltac NoLabelTac := + match goal with + | [ |- nolabel_list nil ] => exact I + | [ |- nolabel_list (final _ _) ] => apply nolabel_final; NoLabelTac + | [ |- nolabel_list (_ :: _) ] => simpl; split; NoLabelTac + | [ |- nolabel_list (_ ++ _) ] => apply nolabel_list_app; NoLabelTac + | [ |- nolabel_dest For_val ] => exact I + | [ |- nolabel_dest For_effects ] => exact I + | [ H: _ -> nolabel_list ?x |- nolabel_list ?x ] => apply H; NoLabelTac + | [ |- nolabel _ ] => red; intros; simpl; auto + | [ |- _ /\ _ ] => split; NoLabelTac + | _ => auto + end. + +Lemma tr_find_label_expr: + (forall le dst r sl a tmps, tr_expr le dst r sl a tmps -> nolabel_dest dst -> nolabel_list sl) +/\(forall le rl sl al tmps, tr_exprlist le rl sl al tmps -> nolabel_list sl). +Proof. + apply tr_expr_exprlist; intros; NoLabelTac. + destruct H1. apply makeif_nolabel; auto. + apply makeif_nolabel; NoLabelTac. + rewrite (makeseq_nolabel sl2); auto. + rewrite (makeseq_nolabel sl3); auto. + apply makeif_nolabel; NoLabelTac. + rewrite (makeseq_nolabel sl2); auto. + rewrite (makeseq_nolabel sl3); auto. +Qed. + +Lemma tr_find_label_top: + forall e le m dst r sl a tmps, + tr_top tge e le m dst r sl a tmps -> nolabel_dest dst -> nolabel_list sl. +Proof. + induction 1; intros; NoLabelTac. + destruct H1. apply makeif_nolabel; auto. + eapply (proj1 tr_find_label_expr); eauto. +Qed. + +Lemma tr_find_label_expression: + forall r s a, tr_expression r s a -> forall k, find_label lbl s k = None. +Proof. + intros. inv H. + assert (nolabel (makeseq sl)). apply makeseq_nolabel. + eapply tr_find_label_top with (e := empty_env) (le := PTree.empty val) (m := Mem.empty). + eauto. exact I. + apply H. +Qed. + +Lemma tr_find_label_expr_stmt: + forall r s, tr_expr_stmt r s -> forall k, find_label lbl s k = None. +Proof. + intros. inv H. + assert (nolabel (makeseq sl)). apply makeseq_nolabel. + eapply tr_find_label_top with (e := empty_env) (le := PTree.empty val) (m := Mem.empty). + eauto. exact I. + apply H. +Qed. + +Lemma tr_find_label_if: + forall r s1 s2 s, + tr_if r s1 s2 s -> + small_stmt s1 = true -> small_stmt s2 = true -> + forall k, find_label lbl s k = None. +Proof. + intros. inv H. + assert (nolabel (makeseq sl)). apply makeseq_nolabel. + eapply tr_find_label_top with (e := empty_env) (le := PTree.empty val) (m := Mem.empty). + eauto. split; apply small_stmt_nolabel; auto. + apply H. +Qed. + +Lemma tr_find_label: + forall s k ts tk + (TR: tr_stmt s ts) + (MC: match_cont k tk), + match Csem.find_label lbl s k with + | None => + find_label lbl ts tk = None + | Some (s', k') => + exists ts', exists tk', + find_label lbl ts tk = Some (ts', tk') + /\ tr_stmt s' ts' + /\ match_cont k' tk' + end +with tr_find_label_ls: + forall s k ts tk + (TR: tr_lblstmts s ts) + (MC: match_cont k tk), + match Csem.find_label_ls lbl s k with + | None => + find_label_ls lbl ts tk = None + | Some (s', k') => + exists ts', exists tk', + find_label_ls lbl ts tk = Some (ts', tk') + /\ tr_stmt s' ts' + /\ match_cont k' tk' + end. +Proof. + induction s; intros; inversion TR; subst; clear TR; simpl. + auto. + eapply tr_find_label_expr_stmt; eauto. +(* seq *) + exploit (IHs1 (Csem.Kseq s2 k)); eauto. constructor; eauto. + destruct (Csem.find_label lbl s1 (Csem.Kseq s2 k)) as [[s' k'] | ]. + intros [ts' [tk' [A [B C]]]]. rewrite A. exists ts'; exists tk'; auto. + intro EQ. rewrite EQ. eapply IHs2; eauto. +(* if no-opt *) + rename s' into sr. + rewrite (tr_find_label_expression _ _ _ H2). + exploit (IHs1 k); eauto. + destruct (Csem.find_label lbl s1 k) as [[s' k'] | ]. + intros [ts' [tk' [A [B C]]]]. rewrite A. exists ts'; exists tk'; intuition. + intro EQ. rewrite EQ. eapply IHs2; eauto. +(* if opt *) + rewrite (tr_find_label_if _ _ _ _ H7); auto. + exploit (IHs1 k); eauto. + destruct (Csem.find_label lbl s1 k) as [[s' k'] | ]. + intros [ts' [tk' [A [B C]]]]. + exploit small_stmt_nolabel. eexact H4. instantiate (1 := tk). congruence. + intros. + exploit (IHs2 k); eauto. + destruct (Csem.find_label lbl s2 k) as [[s' k'] | ]. + intros [ts' [tk' [A [B C]]]]. + exploit small_stmt_nolabel. eexact H6. instantiate (1 := tk). congruence. + auto. +(* while *) + rename s' into sr. + rewrite (tr_find_label_if _ _ _ _ H1); auto. + eapply IHs; eauto. econstructor; eauto. +(* dowhile *) + rename s' into sr. + rewrite (tr_find_label_if _ _ _ _ H1); auto. + exploit (IHs (Kdowhile1 e s k)); eauto. econstructor; eauto. + destruct (Csem.find_label lbl s (Kdowhile1 e s k)) as [[s' k'] | ]. + intros [ts' [tk' [A [B C]]]]. rewrite A. exists ts'; exists tk'; intuition. + intro EQ. rewrite EQ. auto. +(* for skip *) + rename s' into sr. + rewrite (tr_find_label_if _ _ _ _ H4); auto. + exploit (IHs3 (Csem.Kfor3 e s2 s3 k)); eauto. econstructor; eauto. + destruct (Csem.find_label lbl s3 (Csem.Kfor3 e s2 s3 k)) as [[s' k'] | ]. + intros [ts' [tk' [A [B C]]]]. rewrite A. exists ts'; exists tk'; intuition. + intro EQ. rewrite EQ. + exploit (IHs2 (Csem.Kfor4 e s2 s3 k)); eauto. econstructor; eauto. +(* for not skip *) + rename s' into sr. + rewrite (tr_find_label_if _ _ _ _ H3); auto. + exploit (IHs1 (Csem.Kseq (C.Sfor C.Sskip e s2 s3) k)); eauto. + econstructor; eauto. econstructor; eauto. + destruct (Csem.find_label lbl s1 + (Csem.Kseq (C.Sfor C.Sskip e s2 s3) k)) as [[s' k'] | ]. + intros [ts' [tk' [A [B C]]]]. rewrite A. exists ts'; exists tk'; intuition. + intro EQ; rewrite EQ. + exploit (IHs3 (Csem.Kfor3 e s2 s3 k)); eauto. econstructor; eauto. + destruct (Csem.find_label lbl s3 (Csem.Kfor3 e s2 s3 k)) as [[s'' k''] | ]. + intros [ts' [tk' [A [B C]]]]. rewrite A. exists ts'; exists tk'; intuition. + intro EQ'. rewrite EQ'. + exploit (IHs2 (Csem.Kfor4 e s2 s3 k)); eauto. econstructor; eauto. +(* break, continue, return 0 *) + auto. auto. auto. +(* return 1 *) + rewrite (tr_find_label_expression _ _ _ H0). auto. +(* switch *) + rewrite (tr_find_label_expression _ _ _ H1). apply tr_find_label_ls. auto. constructor; auto. +(* labeled stmt *) + destruct (ident_eq lbl l). exists ts0; exists tk; auto. apply IHs; auto. +(* goto *) + auto. + + induction s; intros; inversion TR; subst; clear TR; simpl. +(* default *) + apply tr_find_label; auto. +(* case *) + exploit (tr_find_label s (Csem.Kseq (Csem.seq_of_labeled_statement s0) k)); eauto. + econstructor; eauto. apply tr_seq_of_labeled_statement; eauto. + destruct (Csem.find_label lbl s + (Csem.Kseq (Csem.seq_of_labeled_statement s0) k)) as [[s' k'] | ]. + intros [ts' [tk' [A [B C]]]]. rewrite A. exists ts'; exists tk'; auto. + intro EQ. rewrite EQ. eapply IHs; eauto. +Qed. + +End FIND_LABEL. + +(** Anti-stuttering measure *) + +(** There are some stuttering steps in the translation: +- The execution of [Sdo a] where [a] is side-effect free, + which is three transitions in the source: +<< + Sdo a, k ---> a, Kdo k ---> rval v, Kdo k ---> Sskip, k +>> + but the translation, which is [Sskip], makes no transitions. +- The reduction [C.Ecomma (C.Eval v) r2 --> r2]. +- The reduction [C.Eparen (C.Eval v) --> C.Eval v] in a [For_effects] context. + +The following measure decreases for these stuttering steps. *) + +Fixpoint esize (a: C.expr) : nat := + match a with + | C.Eloc _ _ _ => 1%nat + | C.Evar _ _ => 1%nat + | C.Ederef r1 _ => S(esize r1) + | C.Efield l1 _ _ => S(esize l1) + | C.Eval _ _ => O + | C.Evalof l1 _ => S(esize l1) + | C.Eaddrof l1 _ => S(esize l1) + | C.Eunop _ r1 _ => S(esize r1) + | C.Ebinop _ r1 r2 _ => S(esize r1 + esize r2)%nat + | C.Ecast r1 _ => S(esize r1) + | C.Econdition r1 _ _ _ => S(esize r1) + | C.Esizeof _ _ => 1%nat + | C.Eassign l1 r2 _ => S(esize l1 + esize r2)%nat + | C.Eassignop _ l1 r2 _ _ => S(esize l1 + esize r2)%nat + | C.Epostincr _ l1 _ => S(esize l1) + | C.Ecomma r1 r2 _ => S(esize r1 + esize r2)%nat + | C.Ecall r1 rl2 _ => S(esize r1 + esizelist rl2)%nat + | C.Eparen r1 _ => S(esize r1) + end + +with esizelist (el: C.exprlist) : nat := + match el with + | C.Enil => O + | C.Econs r1 rl2 => (esize r1 + esizelist rl2)%nat + end. + +Definition measure (st: Csem.state) : nat := + match st with + | Csem.ExprState _ r _ _ _ => (esize r + 1)%nat + | Csem.State _ C.Sskip _ _ _ => 0%nat + | Csem.State _ (C.Sdo r) _ _ _ => (esize r + 2)%nat + | Csem.State _ (C.Sifthenelse r _ _) _ _ _ => (esize r + 2)%nat + | _ => 0%nat + end. + +Lemma leftcontext_size: + forall from to C, + leftcontext from to C -> + forall e1 e2, + (esize e1 < esize e2)%nat -> + (esize (C e1) < esize (C e2))%nat +with leftcontextlist_size: + forall from C, + leftcontextlist from C -> + forall e1 e2, + (esize e1 < esize e2)%nat -> + (esizelist (C e1) < esizelist (C e2))%nat. +Proof. + induction 1; intros; simpl; auto with arith. exploit leftcontextlist_size; eauto. auto with arith. + induction 1; intros; simpl; auto with arith. exploit leftcontext_size; eauto. auto with arith. +Qed. + +(** Forward simulation for expressions. *) + +Lemma tr_val_gen: + forall le dst v ty a tmp, + typeof a = ty -> + (forall tge e le' m, + (forall id, In id tmp -> le'!id = le!id) -> + eval_expr tge e le' m a v) -> + tr_expr le dst (C.Eval v ty) (final dst a) a tmp. +Proof. + intros. destruct dst; simpl; econstructor; auto. +Qed. + +Lemma estep_simulation: + forall S1 t S2, Cstrategy.estep ge S1 t S2 -> + forall S1' (MS: match_states S1 S1'), + exists S2', + (plus step tge S1' t S2' \/ + (star step tge S1' t S2' /\ measure S2 < measure S1)%nat) + /\ match_states S2 S2'. +Proof. + induction 1; intros; inv MS. +(* expr *) + assert (tr_expr le dest r sl a tmps). + inv H9. contradiction. contradiction. auto. inv H. + econstructor; split. + right; split. apply star_refl. destruct r; simpl; (contradiction || omega). + econstructor; eauto. + instantiate (1 := tmps). + exploit tr_simple_rvalue; eauto. destruct dest. + intros [A [B C]]. subst sl. apply tr_top_val_val; auto. + intros A. subst sl. apply tr_top_base. constructor. + intros [b [A [B C]]]. subst sl. apply tr_top_val_test; auto. +(* condition true *) + exploit tr_top_leftcontext; eauto. clear H10. + intros [dst' [sl1 [sl2 [a' [tmp' [P [Q [T [R S]]]]]]]]]. + inv P. inv H2. + (* for value *) + exploit tr_simple_rvalue; eauto. intros [SL [TY EV]]. + subst sl0; simpl Kseqlist. + econstructor; split. + left. eapply plus_left. constructor. + eapply star_trans. apply step_makeif_true with v; auto. congruence. + eapply star_left. constructor. apply push_seq. + reflexivity. reflexivity. traceEq. + replace (Kseqlist sl3 (Kseq (Sset t a2) (Kseqlist sl2 tk))) + with (Kseqlist (sl3 ++ Sset t a2 :: sl2) tk). + eapply match_exprstates; eauto. + change (Sset t a2 :: sl2) with ((Sset t a2 :: nil) ++ sl2). rewrite <- app_ass. + apply S. econstructor; eauto. auto. auto. + rewrite Kseqlist_app. auto. + (* for effects *) + exploit tr_simple_rvalue; eauto. intros [SL [TY EV]]. + subst sl0; simpl Kseqlist. + econstructor; split. + left. eapply plus_left. constructor. + eapply star_trans. apply step_makeif_true with v; auto. congruence. + apply push_seq. + reflexivity. traceEq. + rewrite <- Kseqlist_app. + econstructor. eauto. apply S. + econstructor; eauto. apply tr_expr_monotone with tmp2; eauto. + econstructor; eauto. + auto. auto. +(* condition false *) + exploit tr_top_leftcontext; eauto. clear H10. + intros [dst' [sl1 [sl2 [a' [tmp' [P [Q [T [R S]]]]]]]]]. + inv P. inv H2. + (* for value *) + exploit tr_simple_rvalue; eauto. intros [SL [TY EV]]. + subst sl0; simpl Kseqlist. + econstructor; split. + left. eapply plus_left. constructor. + eapply star_trans. apply step_makeif_false with v; auto. congruence. + eapply star_left. constructor. apply push_seq. + reflexivity. reflexivity. traceEq. + replace (Kseqlist sl4 (Kseq (Sset t a3) (Kseqlist sl2 tk))) + with (Kseqlist (sl4 ++ Sset t a3 :: sl2) tk). + eapply match_exprstates; eauto. + change (Sset t a3 :: sl2) with ((Sset t a3 :: nil) ++ sl2). rewrite <- app_ass. + apply S. econstructor; eauto. auto. auto. + rewrite Kseqlist_app. auto. + (* for effects *) + exploit tr_simple_rvalue; eauto. intros [SL [TY EV]]. + subst sl0; simpl Kseqlist. + econstructor; split. + left. eapply plus_left. constructor. + eapply star_trans. apply step_makeif_false with v; auto. congruence. + apply push_seq. + reflexivity. traceEq. + rewrite <- Kseqlist_app. + econstructor. eauto. apply S. + econstructor; eauto. apply tr_expr_monotone with tmp3; eauto. + auto. auto. auto. +(* assign *) + exploit tr_top_leftcontext; eauto. clear H12. + intros [dst' [sl1 [sl2 [a' [tmp' [P [Q [T [R S]]]]]]]]]. + inv P. inv H4. + (* for effects *) + exploit tr_simple_rvalue; eauto. intros [SL2 [TY2 EV2]]. + exploit tr_simple_lvalue; eauto. intros [SL1 [TY1 EV1]]. + subst; simpl Kseqlist. + econstructor; split. + left. eapply plus_left. constructor. + apply star_one. econstructor; eauto. + rewrite <- TY1; rewrite <- TY2; eauto. + rewrite <- TY1; eauto. + traceEq. + econstructor. auto. change sl2 with (nil ++ sl2). apply S. + constructor. auto. auto. auto. + (* for value *) + exploit tr_simple_rvalue; eauto. intros [SL2 [TY2 EV2]]. + exploit tr_simple_lvalue. eauto. + eapply tr_expr_invariant with (le' := PTree.set t v le). eauto. + intros. apply PTree.gso. intuition congruence. + intros [SL1 [TY1 EV1]]. + subst; simpl Kseqlist. + econstructor; split. + left. eapply plus_left. constructor. + eapply star_left. constructor. eauto. + eapply star_left. constructor. + apply star_one. econstructor; eauto. constructor. apply PTree.gss. + simpl. rewrite <- TY1; eauto. + rewrite <- TY1; eauto. + reflexivity. reflexivity. traceEq. + econstructor. auto. apply S. + apply tr_val_gen. auto. intros. econstructor; eauto. constructor. + rewrite H4; auto. apply PTree.gss. + intros. apply PTree.gso. intuition congruence. + auto. auto. +(* assignop *) + exploit tr_top_leftcontext; eauto. clear H14. + intros [dst' [sl1 [sl2 [a' [tmp' [P [Q [T [R S]]]]]]]]]. + inv P. inv H6. + (* for effects *) + exploit tr_simple_rvalue; eauto. intros [SL2 [TY2 EV2]]. + exploit tr_simple_lvalue; eauto. intros [SL1 [TY1 EV1]]. + subst; simpl Kseqlist. + econstructor; split. + left. eapply plus_left. constructor. + apply star_one. econstructor; eauto. + econstructor; eauto. eapply eval_Elvalue; eauto. rewrite <- TY1; eauto. + rewrite <- TY1; rewrite <- TY2; eauto. + rewrite <- TY1; eauto. + rewrite <- TY1; eauto. + traceEq. + econstructor. auto. change sl2 with (nil ++ sl2). apply S. + constructor. auto. auto. auto. + (* for value *) + exploit tr_simple_rvalue; eauto. intros [SL2 [TY2 EV2]]. + exploit tr_simple_lvalue; eauto. intros [SL1 [TY1 EV1]]. + exploit tr_simple_lvalue. eauto. + eapply tr_expr_invariant with (le' := PTree.set t v3 le). eauto. + intros. apply PTree.gso. intuition congruence. + intros [SL3 [TY3 EV3]]. + subst; simpl Kseqlist. + econstructor; split. + left. eapply plus_left. constructor. + eapply star_left. constructor. + econstructor. eapply eval_Elvalue; eauto. rewrite <- TY1; eauto. eauto. + rewrite <- TY1; rewrite <- TY2. eauto. + eapply star_left. constructor. + apply star_one. econstructor. eauto. constructor. apply PTree.gss. + rewrite <- TY1. eauto. rewrite <- TY1. eauto. + reflexivity. reflexivity. traceEq. + econstructor. auto. apply S. + apply tr_val_gen. auto. intros. econstructor; eauto. constructor. + rewrite H6; auto. apply PTree.gss. + intros. apply PTree.gso. intuition congruence. + auto. auto. +(* postincr *) + exploit tr_top_leftcontext; eauto. clear H13. + intros [dst' [sl1 [sl2 [a' [tmp' [P [Q [T [R S]]]]]]]]]. + inv P. inv H5. + (* for effects *) + exploit tr_simple_lvalue; eauto. intros [SL1 [TY1 EV1]]. + assert (EV2: eval_expr tge e le m a1 v1). eapply eval_Elvalue; eauto. rewrite <- TY1; auto. + subst; simpl Kseqlist. + econstructor; split. + left. eapply plus_two. constructor. + econstructor; eauto. + unfold transl_incrdecr. destruct id; simpl in H2. + econstructor. eauto. constructor. simpl. rewrite <- TY1. eauto. + econstructor. eauto. constructor. simpl. rewrite <- TY1. eauto. + rewrite <- TY1. instantiate (1 := v3). destruct id; auto. + rewrite <- TY1. eauto. + traceEq. + econstructor. auto. change sl2 with (nil ++ sl2). apply S. + constructor. auto. auto. auto. + (* for value *) + exploit tr_simple_lvalue; eauto. intros [SL1 [TY1 EV1]]. + exploit tr_simple_lvalue. eauto. + eapply tr_expr_invariant with (le' := PTree.set t v1 le). eauto. + intros. apply PTree.gso. intuition congruence. + intros [SL2 [TY2 EV2]]. + subst; simpl Kseqlist. + econstructor; split. + left. eapply plus_four. constructor. + constructor. eapply eval_Elvalue; eauto. rewrite <- TY1; eauto. + constructor. + econstructor. eauto. + unfold transl_incrdecr. destruct id; simpl in H2. + econstructor. constructor. apply PTree.gss. constructor. simpl. eauto. + econstructor. constructor. apply PTree.gss. constructor. simpl. eauto. + rewrite <- TY1. instantiate (1 := v3). destruct id; auto. + rewrite <- TY1. eauto. + traceEq. + econstructor. auto. apply S. + apply tr_val_gen. auto. intros. econstructor; eauto. + rewrite H5; auto. apply PTree.gss. + intros. apply PTree.gso. intuition congruence. + auto. auto. +(* comma *) + exploit tr_top_leftcontext; eauto. clear H9. + intros [dst' [sl1 [sl2 [a' [tmp' [P [Q [T [R S]]]]]]]]]. + inv P. inv H1. + exploit tr_simple_rvalue; eauto. simpl; intro SL1. + subst sl0; simpl Kseqlist. + econstructor; split. + right; split. apply star_refl. simpl. apply plus_lt_compat_r. + apply (leftcontext_size _ _ _ H). simpl. omega. + econstructor; eauto. apply S. + eapply tr_expr_monotone; eauto. + auto. auto. +(* paren *) + exploit tr_top_leftcontext; eauto. clear H9. + intros [dst' [sl1 [sl2 [a' [tmp' [P [Q [T [R S]]]]]]]]]. + inv P. inv H1. + (* for value *) + exploit tr_simple_rvalue; eauto. intros [SL1 [TY1 EV1]]. + subst sl0; simpl Kseqlist. + econstructor; split. + left. eapply plus_left. constructor. apply star_one. + econstructor. eauto. traceEq. + econstructor; eauto. change sl2 with (final For_val (Etempvar t (C.typeof r)) ++ sl2). apply S. + constructor. auto. intros. constructor. rewrite H1; auto. apply PTree.gss. + intros. apply PTree.gso. intuition congruence. + auto. + (* for effects *) + econstructor; split. + right; split. apply star_refl. simpl. apply plus_lt_compat_r. + apply (leftcontext_size _ _ _ H). simpl. omega. + econstructor; eauto. + exploit tr_simple_rvalue; eauto. destruct dst'. + (* dst' = For_val: impossible *) + congruence. + (* dst' = For_effects: easy *) + intros A. subst sl1. apply S. constructor; auto. auto. auto. + (* dst' = For_test: then dest is For_test as well and C is a string of C.Eparen, + so we can apply tr_top_paren. *) + intros [b [A [B D]]]. + eapply tr_top_testcontext; eauto. + subst sl1. apply tr_top_val_test; auto. + (* already reduced *) + econstructor; split. + right; split. apply star_refl. simpl. apply plus_lt_compat_r. + apply (leftcontext_size _ _ _ H). simpl. omega. + econstructor; eauto. instantiate (1 := @nil ident). + inv H7. + inv H0. eapply tr_top_testcontext; eauto. constructor. auto. auto. + exploit tr_simple_rvalue; eauto. simpl. intros [b [A [B D]]]. + eapply tr_top_testcontext; eauto. subst sl1. apply tr_top_val_test. auto. auto. + inv H0. +(* call *) + exploit tr_top_leftcontext; eauto. clear H12. + intros [dst' [sl1 [sl2 [a' [tmp' [P [Q [U [R S]]]]]]]]]. + inv P. inv H5. + (* for effects *) + exploit tr_simple_rvalue; eauto. intros [SL1 [TY1 EV1]]. + exploit tr_simple_exprlist; eauto. intros [SL2 EV2]. + subst. simpl Kseqlist. + exploit functions_translated; eauto. intros [tfd [J K]]. + econstructor; split. + left. eapply plus_left. constructor. apply star_one. + econstructor; eauto. rewrite <- TY1; eauto. + exploit type_of_fundef_preserved; eauto. congruence. + traceEq. + constructor; auto. econstructor; eauto. + intros. change sl2 with (nil ++ sl2). apply S. + constructor. auto. auto. + (* for value *) + exploit tr_simple_rvalue; eauto. intros [SL1 [TY1 EV1]]. + exploit tr_simple_exprlist; eauto. intros [SL2 EV2]. + subst. simpl Kseqlist. + exploit functions_translated; eauto. intros [tfd [J K]]. + econstructor; split. + left. eapply plus_left. constructor. apply star_one. + econstructor; eauto. rewrite <- TY1; eauto. + exploit type_of_fundef_preserved; eauto. congruence. + traceEq. + constructor; auto. econstructor; eauto. + intros. apply S. + destruct dst'; constructor. + auto. intros. constructor. rewrite H5; auto. apply PTree.gss. + auto. intros. constructor. rewrite H5; auto. apply PTree.gss. + intros. apply PTree.gso. intuition congruence. + auto. +Qed. + +(** Forward simulation for statements. *) + +Lemma tr_top_val_for_val_inv: + forall e le m v ty sl a tmps, + tr_top tge e le m For_val (C.Eval v ty) sl a tmps -> + sl = nil /\ typeof a = ty /\ eval_expr tge e le m a v. +Proof. + intros. inv H. auto. inv H0. auto. +Qed. + +Lemma tr_top_val_for_test_inv: + forall s1 s2 e le m v ty sl a tmps, + tr_top tge e le m (For_test s1 s2) (C.Eval v ty) sl a tmps -> + exists b, sl = makeif b s1 s2 :: nil /\ typeof b = ty /\ eval_expr tge e le m b v. +Proof. + intros. inv H. exists a0; auto. + inv H0. exists a0; auto. +Qed. + +Lemma sstep_simulation: + forall S1 t S2, Csem.sstep ge S1 t S2 -> + forall S1' (MS: match_states S1 S1'), + exists S2', + (plus step tge S1' t S2' \/ + (star step tge S1' t S2' /\ measure S2 < measure S1)%nat) + /\ match_states S2 S2'. +Proof. + induction 1; intros; inv MS. +(* do 1 *) + inv H6. inv H0. + econstructor; split. + right; split. apply push_seq. + simpl. omega. + econstructor; eauto. constructor. auto. +(* do 2 *) + inv H7. inv H6. inv H. + econstructor; split. + right; split. apply star_refl. simpl. omega. + econstructor; eauto. constructor. + +(* seq *) + inv H6. econstructor; split. left. apply plus_one. constructor. + econstructor; eauto. constructor; auto. +(* skip seq *) + inv H6; inv H7. econstructor; split. + left. apply plus_one; constructor. + econstructor; eauto. +(* continue seq *) + inv H6; inv H7. econstructor; split. + left. apply plus_one; constructor. + econstructor; eauto. constructor. +(* break seq *) + inv H6; inv H7. econstructor; split. + left. apply plus_one; constructor. + econstructor; eauto. constructor. + +(* ifthenelse *) + inv H6. + (* not optimized *) + inv H2. econstructor; split. + left. eapply plus_left. constructor. apply push_seq. traceEq. + econstructor; eauto. econstructor; eauto. + (* optimized *) + inv H10. econstructor; split. + right; split. apply push_seq. simpl. omega. + econstructor; eauto. constructor; auto. +(* ifthenelse true *) + inv H8. + (* not optimized *) + exploit tr_top_val_for_val_inv; eauto. intros [A [B C]]. subst. + econstructor; split. + left. eapply plus_two. constructor. + apply step_ifthenelse_true with v; auto. traceEq. + econstructor; eauto. + (* optimized *) + exploit tr_top_val_for_test_inv; eauto. intros [b [A [B C]]]. subst. + econstructor; split. + left. simpl. eapply plus_left. constructor. + apply step_makeif_true with v; auto. traceEq. + econstructor; eauto. +(* ifthenelse false *) + inv H8. + (* not optimized *) + exploit tr_top_val_for_val_inv; eauto. intros [A [B C]]. subst. + econstructor; split. + left. eapply plus_two. constructor. + apply step_ifthenelse_false with v; auto. traceEq. + econstructor; eauto. + (* optimized *) + exploit tr_top_val_for_test_inv; eauto. intros [b [A [B C]]]. subst. + econstructor; split. + left. simpl. eapply plus_left. constructor. + apply step_makeif_false with v; auto. traceEq. + econstructor; eauto. + +(* while *) + inv H6. inv H1. econstructor; split. + left. eapply plus_left. eapply step_while_true. constructor. + simpl. constructor. apply Int.one_not_zero. + eapply star_left. constructor. + apply push_seq. + reflexivity. traceEq. + econstructor; eauto. econstructor; eauto. econstructor; eauto. +(* while false *) + inv H8. + exploit tr_top_val_for_test_inv; eauto. intros [b [A [B C]]]. subst. + econstructor; split. + left. simpl. eapply plus_left. constructor. + eapply star_trans. apply step_makeif_false with v; auto. + eapply star_two. constructor. apply step_break_while. + reflexivity. reflexivity. traceEq. + constructor; auto. constructor. +(* while true *) + inv H8. + exploit tr_top_val_for_test_inv; eauto. intros [b [A [B C]]]. subst. + econstructor; split. + left. simpl. eapply plus_left. constructor. + eapply star_right. apply step_makeif_true with v; auto. + constructor. + reflexivity. traceEq. + constructor; auto. constructor; auto. +(* skip-or-continue while *) + assert (ts = Sskip \/ ts = Scontinue). destruct H; subst s0; inv H7; auto. + inv H8. + econstructor; split. + left. apply plus_one. apply step_skip_or_continue_while; auto. + constructor; auto. constructor; auto. +(* break while *) + inv H6. inv H7. + econstructor; split. + left. apply plus_one. apply step_break_while. + constructor; auto. constructor. + +(* dowhile *) + inv H6. + econstructor; split. + left. apply plus_one. + apply step_for_true with (Vint Int.one). constructor. simpl; constructor. apply Int.one_not_zero. + constructor; auto. constructor; auto. +(* skip_or_continue dowhile *) + assert (ts = Sskip \/ ts = Scontinue). destruct H; subst s0; inv H7; auto. + inv H8. inv H4. + econstructor; split. + left. eapply plus_left. apply step_skip_or_continue_for2. auto. + apply push_seq. + reflexivity. traceEq. + econstructor; eauto. econstructor; auto. econstructor; eauto. +(* dowhile false *) + inv H8. + exploit tr_top_val_for_test_inv; eauto. intros [b [A [B C]]]. subst. + econstructor; split. + left. simpl. eapply plus_left. constructor. + eapply star_right. apply step_makeif_false with v; auto. + constructor. + reflexivity. traceEq. + constructor; auto. constructor. +(* dowhile true *) + inv H8. + exploit tr_top_val_for_test_inv; eauto. intros [b [A [B C]]]. subst. + econstructor; split. + left. simpl. eapply plus_left. constructor. + eapply star_right. apply step_makeif_true with v; auto. + constructor. + reflexivity. traceEq. + constructor; auto. constructor; auto. +(* break dowhile *) + inv H6. inv H7. + econstructor; split. + left. apply plus_one. apply step_break_for2. + constructor; auto. constructor. + +(* for start *) + inv H7. congruence. + econstructor; split. + left; apply plus_one. constructor. + econstructor; eauto. constructor; auto. econstructor; eauto. +(* for *) + inv H6; try congruence. inv H2. + econstructor; split. + left. eapply plus_left. apply step_for_true with (Vint Int.one). + constructor. simpl; constructor. apply Int.one_not_zero. + eapply star_left. constructor. apply push_seq. + reflexivity. traceEq. + econstructor; eauto. constructor; auto. econstructor; eauto. +(* for false *) + inv H8. exploit tr_top_val_for_test_inv; eauto. intros [b [A [B C]]]. subst. + econstructor; split. + left. simpl. eapply plus_left. constructor. + eapply star_trans. apply step_makeif_false with v; auto. + eapply star_two. constructor. apply step_break_for2. + reflexivity. reflexivity. traceEq. + constructor; auto. constructor. +(* for true *) + inv H8. exploit tr_top_val_for_test_inv; eauto. intros [b [A [B C]]]. subst. + econstructor; split. + left. simpl. eapply plus_left. constructor. + eapply star_right. apply step_makeif_true with v; auto. + constructor. + reflexivity. traceEq. + constructor; auto. constructor; auto. +(* skip_or_continue for3 *) + assert (ts = Sskip \/ ts = Scontinue). destruct H; subst x; inv H7; auto. + inv H8. + econstructor; split. + left. apply plus_one. apply step_skip_or_continue_for2. auto. + econstructor; eauto. econstructor; auto. +(* break for3 *) + inv H6. inv H7. + econstructor; split. + left. apply plus_one. apply step_break_for2. + econstructor; eauto. constructor. +(* skip for4 *) + inv H6. inv H7. + econstructor; split. + left. apply plus_one. constructor. + econstructor; eauto. constructor; auto. + +(* return none *) + inv H8. econstructor; split. + left. apply plus_one. econstructor; eauto. + rewrite <- H. apply function_return_preserved; auto. + constructor. apply match_cont_call; auto. +(* return some 1 *) + inv H7. inv H1. econstructor; split. + left; eapply plus_left. constructor. apply push_seq. traceEq. + econstructor; eauto. constructor. auto. +(* return some 2 *) + inv H9. exploit tr_top_val_for_val_inv; eauto. intros [A [B C]]. subst. + econstructor; split. + left. eapply plus_two. constructor. econstructor. eauto. + replace (fn_return tf) with (C.fn_return f). eauto. + exploit transl_function_spec; eauto. intuition congruence. + eauto. traceEq. + constructor. apply match_cont_call; auto. +(* skip return *) + inv H9. + assert (is_call_cont tk). inv H10; simpl in *; auto. + econstructor; split. + left. apply plus_one. apply step_skip_call; eauto. + rewrite <- H0. apply function_return_preserved; auto. + constructor. auto. + +(* switch *) + inv H6. inv H1. + econstructor; split. + left; eapply plus_left. constructor. apply push_seq. traceEq. + econstructor; eauto. constructor; auto. +(* expr switch *) + inv H7. exploit tr_top_val_for_val_inv; eauto. intros [A [B C]]. subst. + econstructor; split. + left; eapply plus_two. constructor. econstructor; eauto. traceEq. + econstructor; eauto. + apply tr_seq_of_labeled_statement. apply tr_select_switch. auto. + constructor; auto. + +(* skip-or-break switch *) + assert (ts = Sskip \/ ts = Sbreak). destruct H; subst x; inv H7; auto. + inv H8. + econstructor; split. + left; apply plus_one. apply step_skip_break_switch. auto. + constructor; auto. constructor. + +(* continue switch *) + inv H6. inv H7. + econstructor; split. + left; apply plus_one. apply step_continue_switch. + constructor; auto. constructor. + +(* label *) + inv H6. econstructor; split. + left; apply plus_one. constructor. + constructor; auto. + +(* goto *) + inv H7. + exploit transl_function_spec; eauto. intros [A [B [C D]]]. + exploit tr_find_label. eexact A. apply match_cont_call. eauto. + instantiate (1 := lbl). rewrite H. + intros [ts' [tk' [P [Q R]]]]. + econstructor; split. + left. apply plus_one. econstructor; eauto. + econstructor; eauto. + +(* internal function *) + monadInv H7. + exploit transl_function_spec; eauto. intros [A [B [C D]]]. + econstructor; split. + left; apply plus_one. eapply step_internal_function. + rewrite C; rewrite D; auto. + rewrite C; rewrite D; eauto. + rewrite C; eauto. + constructor; auto. + +(* external function *) + monadInv H5. + econstructor; split. + left; apply plus_one. econstructor; eauto. + eapply external_call_symbols_preserved; eauto. + exact symbols_preserved. exact varinfo_preserved. + constructor; auto. + +(* return *) + inv H3. + (* none *) + econstructor; split. + left; apply plus_one. constructor. + econstructor; eauto. + (* some *) + econstructor; split. + left; apply plus_one. constructor. + econstructor; eauto. +Qed. + +(** Semantic preservation *) + +Theorem simulation: + forall S1 t S2, Cstrategy.step ge S1 t S2 -> + forall S1' (MS: match_states S1 S1'), + exists S2', + (plus step tge S1' t S2' \/ + (star step tge S1' t S2' /\ measure S2 < measure S1)%nat) + /\ match_states S2 S2'. +Proof. + intros S1 t S2 STEP. destruct STEP. + apply estep_simulation; auto. + apply sstep_simulation; auto. +Qed. + +Lemma transl_initial_states: + forall S, + Csem.initial_state prog S -> + exists S', Clight.initial_state tprog S' /\ match_states S S'. +Proof. + intros. inv H. + exploit function_ptr_translated; eauto. intros [tf [FIND TR]]. + econstructor; split. + econstructor. + apply (Genv.init_mem_transf_partial _ _ TRANSL). eauto. + simpl. fold tge. rewrite symbols_preserved. + replace (prog_main tprog) with (prog_main prog). eexact H1. + symmetry. unfold transl_program in TRANSL. + eapply transform_partial_program_main; eauto. + eexact FIND. + rewrite <- H3. apply type_of_fundef_preserved. auto. + constructor. auto. constructor. +Qed. + +Lemma transl_final_states: + forall S S' r, + match_states S S' -> Csem.final_state S r -> Clight.final_state S' r. +Proof. + intros. inv H0. inv H. inv H4. constructor. +Qed. + +Theorem transl_program_correct: + forall (beh: program_behavior), + not_wrong beh -> Cstrategy.exec_program prog beh -> + Clight.exec_program tprog beh. +Proof. + unfold Cstrategy.exec_program, Clight.exec_program. intros. + eapply simulation_star_wf_preservation; eauto. + eexact transl_initial_states. + eexact transl_final_states. + instantiate (1 := ltof _ measure). apply well_founded_ltof. + exact simulation. +Qed. + +End PRESERVATION. diff --git a/cfrontend/SimplExprspec.v b/cfrontend/SimplExprspec.v new file mode 100644 index 0000000..7829c24 --- /dev/null +++ b/cfrontend/SimplExprspec.v @@ -0,0 +1,815 @@ +(* *********************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Xavier Leroy, INRIA Paris-Rocquencourt *) +(* *) +(* Copyright Institut National de Recherche en Informatique et en *) +(* Automatique. All rights reserved. This file is distributed *) +(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* *) +(* *********************************************************************) + +(** Relational specification of expression simplification. *) + +Require Import Coqlib. +Require Import Errors. +Require Import Maps. +Require Import Integers. +Require Import Floats. +Require Import Values. +Require Import Memory. +Require Import AST. +Require Import Csyntax. +Require Import Clight. +Require Import SimplExpr. + +Section SPEC. + +Local Open Scope gensym_monad_scope. + +(** * Relational specification of the translation. *) + +(** ** Translation of expressions *) + +(** This specification covers: +- all cases of [transl_lvalue] and [transl_rvalue]; +- two additional cases for [C.Eparen], so that reductions of [C.Econdition] + expressions are properly tracked; +- three additional cases allowing [C.Eval v] C expressions to match + any Clight expression [a] that evaluates to [v] in any environment + matching the given temporary environment [le]. +*) + +Definition final (dst: purpose) (a: expr) : list statement := + match dst with + | For_val => nil + | For_effects => nil + | For_test s1 s2 => makeif a s1 s2 :: nil + end. + +Inductive tr_expr: temp_env -> purpose -> C.expr -> list statement -> expr -> list ident -> Prop := + | tr_var: forall le dst id ty tmp, + tr_expr le dst (C.Evar id ty) + (final dst (Evar id ty)) (Evar id ty) tmp + | tr_deref: forall le dst e1 ty sl1 a1 tmp, + tr_expr le For_val e1 sl1 a1 tmp -> + tr_expr le dst (C.Ederef e1 ty) + (sl1 ++ final dst (Ederef a1 ty)) (Ederef a1 ty) tmp + | tr_field: forall le dst e1 f ty sl1 a1 tmp, + tr_expr le For_val e1 sl1 a1 tmp -> + tr_expr le dst (C.Efield e1 f ty) + (sl1 ++ final dst (Efield a1 f ty)) (Efield a1 f ty) tmp + | tr_val_effect: forall le v ty any tmp, + tr_expr le For_effects (C.Eval v ty) nil any tmp + | tr_val_value: forall le v ty a tmp, + typeof a = ty -> + (forall tge e le' m, + (forall id, In id tmp -> le'!id = le!id) -> + eval_expr tge e le' m a v) -> + tr_expr le For_val (C.Eval v ty) + nil a tmp + | tr_val_test: forall le s1 s2 v ty a any tmp, + typeof a = ty -> + (forall tge e le' m, + (forall id, In id tmp -> le'!id = le!id) -> + eval_expr tge e le' m a v) -> + tr_expr le (For_test s1 s2) (C.Eval v ty) + (makeif a s1 s2 :: nil) any tmp + | tr_sizeof: forall le dst ty' ty tmp, + tr_expr le dst (C.Esizeof ty' ty) + (final dst (Esizeof ty' ty)) + (Esizeof ty' ty) tmp + | tr_valof: forall le dst e1 ty tmp sl1 a1, + tr_expr le For_val e1 sl1 a1 tmp -> + tr_expr le dst (C.Evalof e1 ty) + (sl1 ++ final dst a1) + a1 tmp + | tr_addrof: forall le dst e1 ty tmp sl1 a1, + tr_expr le For_val e1 sl1 a1 tmp -> + tr_expr le dst (C.Eaddrof e1 ty) + (sl1 ++ final dst (Eaddrof a1 ty)) + (Eaddrof a1 ty) tmp + | tr_unop: forall le dst op e1 ty tmp sl1 a1, + tr_expr le For_val e1 sl1 a1 tmp -> + tr_expr le dst (C.Eunop op e1 ty) + (sl1 ++ final dst (Eunop op a1 ty)) + (Eunop op a1 ty) tmp + | tr_binop: forall le dst op e1 e2 ty sl1 a1 tmp1 sl2 a2 tmp2 tmp, + tr_expr le For_val e1 sl1 a1 tmp1 -> + tr_expr le For_val e2 sl2 a2 tmp2 -> + list_disjoint tmp1 tmp2 -> incl tmp1 tmp -> incl tmp2 tmp -> + tr_expr le dst (C.Ebinop op e1 e2 ty) + (sl1 ++ sl2 ++ final dst (Ebinop op a1 a2 ty)) + (Ebinop op a1 a2 ty) tmp + | tr_cast: forall le dst e1 ty sl1 a1 tmp, + tr_expr le For_val e1 sl1 a1 tmp -> + tr_expr le dst (C.Ecast e1 ty) + (sl1 ++ final dst (Ecast a1 ty)) + (Ecast a1 ty) tmp + | tr_condition_val: forall le e1 e2 e3 ty sl1 a1 tmp1 sl2 a2 tmp2 sl3 a3 tmp3 t tmp, + tr_expr le For_val e1 sl1 a1 tmp1 -> + tr_expr le For_val e2 sl2 a2 tmp2 -> + tr_expr le For_val e3 sl3 a3 tmp3 -> + list_disjoint tmp1 tmp2 -> + list_disjoint tmp1 tmp3 -> + incl tmp1 tmp -> incl tmp2 tmp -> incl tmp3 tmp -> + In t tmp -> ~In t tmp1 -> + tr_expr le For_val (C.Econdition e1 e2 e3 ty) + (sl1 ++ makeif a1 + (Ssequence (makeseq sl2) (Sset t a2)) + (Ssequence (makeseq sl3) (Sset t a3)) :: nil) + (Etempvar t ty) tmp + | tr_condition_effects: forall le dst e1 e2 e3 ty sl1 a1 tmp1 sl2 a2 tmp2 sl3 a3 tmp3 any tmp, + dst <> For_val -> + tr_expr le For_val e1 sl1 a1 tmp1 -> + tr_expr le dst e2 sl2 a2 tmp2 -> + tr_expr le dst e3 sl3 a3 tmp3 -> + list_disjoint tmp1 tmp2 -> + list_disjoint tmp1 tmp3 -> + incl tmp1 tmp -> incl tmp2 tmp -> incl tmp3 tmp -> + tr_expr le dst (C.Econdition e1 e2 e3 ty) + (sl1 ++ makeif a1 (makeseq sl2) (makeseq sl3) :: nil) + any tmp + | tr_assign_effects: forall le e1 e2 ty sl1 a1 tmp1 sl2 a2 tmp2 any tmp, + tr_expr le For_val e1 sl1 a1 tmp1 -> + tr_expr le For_val e2 sl2 a2 tmp2 -> + list_disjoint tmp1 tmp2 -> + incl tmp1 tmp -> incl tmp2 tmp -> + tr_expr le For_effects (C.Eassign e1 e2 ty) + (sl1 ++ sl2 ++ Sassign a1 a2 :: nil) + any tmp + | tr_assign_val: forall le dst e1 e2 ty sl1 a1 tmp1 sl2 a2 tmp2 t tmp ty1 ty2, + tr_expr le For_val e1 sl1 a1 tmp1 -> + tr_expr le For_val e2 sl2 a2 tmp2 -> + incl tmp1 tmp -> incl tmp2 tmp -> + list_disjoint tmp1 tmp2 -> + In t tmp -> ~In t tmp1 -> ~In t tmp2 -> + ty1 = C.typeof e1 -> + ty2 = C.typeof e2 -> + tr_expr le dst (C.Eassign e1 e2 ty) + (sl1 ++ sl2 ++ + Sset t a2 :: + Sassign a1 (Etempvar t ty2) :: + final dst (Ecast (Etempvar t ty2) ty1)) + (Ecast (Etempvar t ty2) ty1) tmp + | tr_assignop_effects: forall le op e1 e2 tyres ty sl1 a1 tmp1 sl2 a2 tmp2 any tmp, + tr_expr le For_val e1 sl1 a1 tmp1 -> + tr_expr le For_val e2 sl2 a2 tmp2 -> + list_disjoint tmp1 tmp2 -> + incl tmp1 tmp -> incl tmp2 tmp -> + tr_expr le For_effects (C.Eassignop op e1 e2 tyres ty) + (sl1 ++ sl2 ++ Sassign a1 (Ebinop op a1 a2 tyres) :: nil) + any tmp + | tr_assignop_val: forall le dst op e1 e2 tyres ty sl1 a1 tmp1 sl2 a2 tmp2 t tmp ty1, + tr_expr le For_val e1 sl1 a1 tmp1 -> + tr_expr le For_val e2 sl2 a2 tmp2 -> + list_disjoint tmp1 tmp2 -> + incl tmp1 tmp -> incl tmp2 tmp -> + In t tmp -> ~In t tmp1 -> ~In t tmp2 -> + ty1 = C.typeof e1 -> + tr_expr le dst (C.Eassignop op e1 e2 tyres ty) + (sl1 ++ sl2 ++ + Sset t (Ebinop op a1 a2 tyres) :: + Sassign a1 (Etempvar t tyres) :: + final dst (Ecast (Etempvar t tyres) ty1)) + (Ecast (Etempvar t tyres) ty1) tmp + | tr_postincr_effects: forall le id e1 ty sl1 a1 tmp any, + tr_expr le For_val e1 sl1 a1 tmp -> + tr_expr le For_effects (C.Epostincr id e1 ty) + (sl1 ++ Sassign a1 (transl_incrdecr id a1 (C.typeof e1)) :: nil) + any tmp + | tr_postincr_val: forall le dst id e1 ty sl1 a1 tmp1 t ty1 tmp, + tr_expr le For_val e1 sl1 a1 tmp1 -> + incl tmp1 tmp -> In t tmp -> ~In t tmp1 -> + ty1 = C.typeof e1 -> + tr_expr le dst (C.Epostincr id e1 ty) + (sl1 ++ Sset t a1 :: + Sassign a1 (transl_incrdecr id (Etempvar t ty1) ty1) :: + final dst (Etempvar t ty1)) + (Etempvar t ty1) tmp + | tr_comma: forall le dst e1 e2 ty sl1 a1 tmp1 sl2 a2 tmp2 tmp, + tr_expr le For_effects e1 sl1 a1 tmp1 -> + tr_expr le dst e2 sl2 a2 tmp2 -> + list_disjoint tmp1 tmp2 -> + incl tmp1 tmp -> incl tmp2 tmp -> + tr_expr le dst (C.Ecomma e1 e2 ty) (sl1 ++ sl2) a2 tmp + | tr_call_effects: forall le e1 el2 ty sl1 a1 tmp1 sl2 al2 tmp2 any tmp, + tr_expr le For_val e1 sl1 a1 tmp1 -> + tr_exprlist le el2 sl2 al2 tmp2 -> + list_disjoint tmp1 tmp2 -> + incl tmp1 tmp -> incl tmp2 tmp -> + tr_expr le For_effects (C.Ecall e1 el2 ty) + (sl1 ++ sl2 ++ Scall None a1 al2 :: nil) + any tmp + | tr_call_val: forall le dst e1 el2 ty sl1 a1 tmp1 sl2 al2 tmp2 t tmp, + dst <> For_effects -> + tr_expr le For_val e1 sl1 a1 tmp1 -> + tr_exprlist le el2 sl2 al2 tmp2 -> + list_disjoint tmp1 tmp2 -> In t tmp -> + incl tmp1 tmp -> incl tmp2 tmp -> + tr_expr le dst (C.Ecall e1 el2 ty) + (sl1 ++ sl2 ++ Scall (Some t) a1 al2 :: final dst (Etempvar t ty)) + (Etempvar t ty) tmp + | tr_paren_val: forall le e1 ty sl1 a1 tmp1 t tmp, + tr_expr le For_val e1 sl1 a1 tmp1 -> + incl tmp1 tmp -> In t tmp -> + tr_expr le For_val (C.Eparen e1 ty) + (sl1 ++ Sset t a1 :: nil) + (Etempvar t ty) tmp + | tr_paren_effects: forall le dst e1 ty sl1 a1 tmp any, + dst <> For_val -> + tr_expr le dst e1 sl1 a1 tmp -> + tr_expr le dst (C.Eparen e1 ty) sl1 any tmp + +with tr_exprlist: temp_env -> C.exprlist -> list statement -> list expr -> list ident -> Prop := + | tr_nil: forall le tmp, + tr_exprlist le C.Enil nil nil tmp + | tr_cons: forall le e1 el2 sl1 a1 tmp1 sl2 al2 tmp2 tmp, + tr_expr le For_val e1 sl1 a1 tmp1 -> + tr_exprlist le el2 sl2 al2 tmp2 -> + list_disjoint tmp1 tmp2 -> + incl tmp1 tmp -> incl tmp2 tmp -> + tr_exprlist le (C.Econs e1 el2) (sl1 ++ sl2) (a1 :: al2) tmp. + +Scheme tr_expr_ind2 := Minimality for tr_expr Sort Prop + with tr_exprlist_ind2 := Minimality for tr_exprlist Sort Prop. +Combined Scheme tr_expr_exprlist from tr_expr_ind2, tr_exprlist_ind2. + +(** Useful invariance properties. *) + +Lemma tr_expr_invariant: + forall le dst r sl a tmps, tr_expr le dst r sl a tmps -> + forall le', (forall x, In x tmps -> le'!x = le!x) -> + tr_expr le' dst r sl a tmps +with tr_exprlist_invariant: + forall le rl sl al tmps, tr_exprlist le rl sl al tmps -> + forall le', (forall x, In x tmps -> le'!x = le!x) -> + tr_exprlist le' rl sl al tmps. +Proof. + induction 1; intros; econstructor; eauto. + intros. apply H0. intros. transitivity (le'!id); auto. + intros. apply H0. intros. transitivity (le'!id); auto. + induction 1; intros; econstructor; eauto. +Qed. + +Lemma tr_expr_monotone: + forall le dst r sl a tmps, tr_expr le dst r sl a tmps -> + forall tmps', incl tmps tmps' -> tr_expr le dst r sl a tmps' +with tr_exprlist_monotone: + forall le rl sl al tmps, tr_exprlist le rl sl al tmps -> + forall tmps', incl tmps tmps' -> tr_exprlist le rl sl al tmps'. +Proof. + induction 1; intros; econstructor; unfold incl in *; eauto. + induction 1; intros; econstructor; unfold incl in *; eauto. +Qed. + +(** ** Top-level translation *) + +(** The "top-level" translation is equivalent to [tr_expr] above + for source terms. It brings additional flexibility in the matching + between C values and Cminor expressions: in the case of + [tr_expr], the Cminor expression must not depend on memory, + while in the case of [tr_top] it can depend on the current memory + state. This special case is extended to values occurring under + one or several [C.Eparen]. *) + +Section TR_TOP. + +Variable ge: genv. +Variable e: env. +Variable le: temp_env. +Variable m: mem. + +Inductive tr_top: purpose -> C.expr -> list statement -> expr -> list ident -> Prop := + | tr_top_val_val: forall v ty a tmp, + typeof a = ty -> eval_expr ge e le m a v -> + tr_top For_val (C.Eval v ty) nil a tmp + | tr_top_val_test: forall s1 s2 v ty a any tmp, + typeof a = ty -> eval_expr ge e le m a v -> + tr_top (For_test s1 s2) (C.Eval v ty) (makeif a s1 s2 :: nil) any tmp + | tr_top_base: forall dst r sl a tmp, + tr_expr le dst r sl a tmp -> + tr_top dst r sl a tmp + | tr_top_paren_test: forall s1 s2 r ty sl a tmp, + tr_top (For_test s1 s2) r sl a tmp -> + tr_top (For_test s1 s2) (C.Eparen r ty) sl a tmp. + +End TR_TOP. + +(** ** Translation of statements *) + +Inductive tr_expression: C.expr -> statement -> expr -> Prop := + | tr_expression_intro: forall r sl a tmps, + (forall ge e le m, tr_top ge e le m For_val r sl a tmps) -> + tr_expression r (makeseq sl) a. + +Inductive tr_expr_stmt: C.expr -> statement -> Prop := + | tr_expr_stmt_intro: forall r sl a tmps, + (forall ge e le m, tr_top ge e le m For_effects r sl a tmps) -> + tr_expr_stmt r (makeseq sl). + +Inductive tr_if: C.expr -> statement -> statement -> statement -> Prop := + | tr_if_intro: forall r s1 s2 sl a tmps, + (forall ge e le m, tr_top ge e le m (For_test s1 s2) r sl a tmps) -> + tr_if r s1 s2 (makeseq sl). + +Inductive tr_stmt: C.statement -> statement -> Prop := + | tr_skip: + tr_stmt C.Sskip Sskip + | tr_do: forall r s, + tr_expr_stmt r s -> + tr_stmt (C.Sdo r) s + | tr_seq: forall s1 s2 ts1 ts2, + tr_stmt s1 ts1 -> tr_stmt s2 ts2 -> + tr_stmt (C.Ssequence s1 s2) (Ssequence ts1 ts2) + | tr_ifthenelse_big: forall r s1 s2 s' a ts1 ts2, + tr_expression r s' a -> + tr_stmt s1 ts1 -> tr_stmt s2 ts2 -> + tr_stmt (C.Sifthenelse r s1 s2) (Ssequence s' (Sifthenelse a ts1 ts2)) + | tr_ifthenelse_small: forall r s1 s2 ts1 ts2 ts, + tr_stmt s1 ts1 -> tr_stmt s2 ts2 -> + small_stmt ts1 = true -> small_stmt ts2 = true -> + tr_if r ts1 ts2 ts -> + tr_stmt (C.Sifthenelse r s1 s2) ts + | tr_while: forall r s1 s' ts1, + tr_if r Sskip Sbreak s' -> + tr_stmt s1 ts1 -> + tr_stmt (C.Swhile r s1) + (Swhile expr_true (Ssequence s' ts1)) + | tr_dowhile: forall r s1 s' ts1, + tr_if r Sskip Sbreak s' -> + tr_stmt s1 ts1 -> + tr_stmt (C.Sdowhile r s1) + (Sfor' expr_true s' ts1) + | tr_for_1: forall r s3 s4 s' ts3 ts4, + tr_if r Sskip Sbreak s' -> + tr_stmt s3 ts3 -> + tr_stmt s4 ts4 -> + tr_stmt (C.Sfor C.Sskip r s3 s4) + (Sfor' expr_true ts3 (Ssequence s' ts4)) + | tr_for_2: forall s1 r s3 s4 s' ts1 ts3 ts4, + tr_if r Sskip Sbreak s' -> + s1 <> C.Sskip -> + tr_stmt s1 ts1 -> + tr_stmt s3 ts3 -> + tr_stmt s4 ts4 -> + tr_stmt (C.Sfor s1 r s3 s4) + (Ssequence ts1 (Sfor' expr_true ts3 (Ssequence s' ts4))) + | tr_break: + tr_stmt C.Sbreak Sbreak + | tr_continue: + tr_stmt C.Scontinue Scontinue + | tr_return_none: + tr_stmt (C.Sreturn None) (Sreturn None) + | tr_return_some: forall r s' a, + tr_expression r s' a -> + tr_stmt (C.Sreturn (Some r)) (Ssequence s' (Sreturn (Some a))) + | tr_switch: forall r ls s' a tls, + tr_expression r s' a -> + tr_lblstmts ls tls -> + tr_stmt (C.Sswitch r ls) (Ssequence s' (Sswitch a tls)) + | tr_label: forall lbl s ts, + tr_stmt s ts -> + tr_stmt (C.Slabel lbl s) (Slabel lbl ts) + | tr_goto: forall lbl, + tr_stmt (C.Sgoto lbl) (Sgoto lbl) + +with tr_lblstmts: C.labeled_statements -> labeled_statements -> Prop := + | tr_default: forall s ts, + tr_stmt s ts -> + tr_lblstmts (C.LSdefault s) (LSdefault ts) + | tr_case: forall n s ls ts tls, + tr_stmt s ts -> + tr_lblstmts ls tls -> + tr_lblstmts (C.LScase n s ls) (LScase n ts tls). + +(** * Correctness proof with respect to the specification. *) + +(** ** Properties of the monad *) + +Remark bind_inversion: + forall (A B: Type) (f: mon A) (g: A -> mon B) (y: B) (z1 z3: generator) I, + bind f g z1 = Res y z3 I -> + exists x, exists z2, exists I1, exists I2, + f z1 = Res x z2 I1 /\ g x z2 = Res y z3 I2. +Proof. + intros until I. unfold bind. destruct (f z1). + congruence. + caseEq (g a g'); intros; inv H0. + econstructor; econstructor; econstructor; econstructor; eauto. +Qed. + +Remark bind2_inversion: + forall (A B C: Type) (f: mon (A*B)) (g: A -> B -> mon C) (y: C) (z1 z3: generator) I, + bind2 f g z1 = Res y z3 I -> + exists x1, exists x2, exists z2, exists I1, exists I2, + f z1 = Res (x1,x2) z2 I1 /\ g x1 x2 z2 = Res y z3 I2. +Proof. + unfold bind2. intros. + exploit bind_inversion; eauto. + intros [[x1 x2] [z2 [I1 [I2 [P Q]]]]]. simpl in Q. + exists x1; exists x2; exists z2; exists I1; exists I2; auto. +Qed. + +Ltac monadInv1 H := + match type of H with + | (Res _ _ _ = Res _ _ _) => + inversion H; clear H; try subst + | (@ret _ _ _ = Res _ _ _) => + inversion H; clear H; try subst + | (@error _ _ _ = Res _ _ _) => + inversion H + | (bind ?F ?G ?Z = Res ?X ?Z' ?I) => + let x := fresh "x" in ( + let z := fresh "z" in ( + let I1 := fresh "I" in ( + let I2 := fresh "I" in ( + let EQ1 := fresh "EQ" in ( + let EQ2 := fresh "EQ" in ( + destruct (bind_inversion _ _ F G X Z Z' I H) as [x [z [I1 [I2 [EQ1 EQ2]]]]]; + clear H; + try (monadInv1 EQ2))))))) + | (bind2 ?F ?G ?Z = Res ?X ?Z' ?I) => + let x := fresh "x" in ( + let y := fresh "y" in ( + let z := fresh "z" in ( + let I1 := fresh "I" in ( + let I2 := fresh "I" in ( + let EQ1 := fresh "EQ" in ( + let EQ2 := fresh "EQ" in ( + destruct (bind2_inversion _ _ _ F G X Z Z' I H) as [x [y [z [I1 [I2 [EQ1 EQ2]]]]]]; + clear H; + try (monadInv1 EQ2)))))))) + end. + +Ltac monadInv H := + match type of H with + | (@ret _ _ _ = Res _ _ _) => monadInv1 H + | (@error _ _ _ = Res _ _ _) => monadInv1 H + | (bind ?F ?G ?Z = Res ?X ?Z' ?I) => monadInv1 H + | (bind2 ?F ?G ?Z = Res ?X ?Z' ?I) => monadInv1 H + | (?F _ _ _ _ _ _ _ _ = Res _ _ _) => + ((progress simpl in H) || unfold F in H); monadInv1 H + | (?F _ _ _ _ _ _ _ = Res _ _ _) => + ((progress simpl in H) || unfold F in H); monadInv1 H + | (?F _ _ _ _ _ _ = Res _ _ _) => + ((progress simpl in H) || unfold F in H); monadInv1 H + | (?F _ _ _ _ _ = Res _ _ _) => + ((progress simpl in H) || unfold F in H); monadInv1 H + | (?F _ _ _ _ = Res _ _ _) => + ((progress simpl in H) || unfold F in H); monadInv1 H + | (?F _ _ _ = Res _ _ _) => + ((progress simpl in H) || unfold F in H); monadInv1 H + | (?F _ _ = Res _ _ _) => + ((progress simpl in H) || unfold F in H); monadInv1 H + | (?F _ = Res _ _ _) => + ((progress simpl in H) || unfold F in H); monadInv1 H + end. + +(** ** Freshness and separation properties. *) + +Definition within (id: ident) (g1 g2: generator) : Prop := + Ple (gen_next g1) id /\ Plt id (gen_next g2). + +Lemma gensym_within: + forall ty g1 id g2 I, + gensym ty g1 = Res id g2 I -> within id g1 g2. +Proof. + intros. monadInv H. split. apply Ple_refl. apply Plt_succ. +Qed. + +Lemma within_widen: + forall id g1 g2 g1' g2', + within id g1 g2 -> + Ple (gen_next g1') (gen_next g1) -> + Ple (gen_next g2) (gen_next g2') -> + within id g1' g2'. +Proof. + intros. destruct H. split. + eapply Ple_trans; eauto. + unfold Plt, Ple in *. omega. +Qed. + +Definition contained (l: list ident) (g1 g2: generator) : Prop := + forall id, In id l -> within id g1 g2. + +Lemma contained_nil: + forall g1 g2, contained nil g1 g2. +Proof. + intros; red; intros; contradiction. +Qed. + +Lemma contained_widen: + forall l g1 g2 g1' g2', + contained l g1 g2 -> + Ple (gen_next g1') (gen_next g1) -> + Ple (gen_next g2) (gen_next g2') -> + contained l g1' g2'. +Proof. + intros; red; intros. eapply within_widen; eauto. +Qed. + +Lemma contained_cons: + forall id l g1 g2, + within id g1 g2 -> contained l g1 g2 -> contained (id :: l) g1 g2. +Proof. + intros; red; intros. simpl in H1; destruct H1. subst id0. auto. auto. +Qed. + +Lemma contained_app: + forall l1 l2 g1 g2, + contained l1 g1 g2 -> contained l2 g1 g2 -> contained (l1 ++ l2) g1 g2. +Proof. + intros; red; intros. destruct (in_app_or _ _ _ H1); auto. +Qed. + +Lemma contained_disjoint: + forall g1 l1 g2 l2 g3, + contained l1 g1 g2 -> contained l2 g2 g3 -> list_disjoint l1 l2. +Proof. + intros; red; intros. red; intro; subst y. + exploit H; eauto. intros [A B]. exploit H0; eauto. intros [C D]. + elim (Plt_strict x). apply Plt_Ple_trans with (gen_next g2); auto. +Qed. + +Lemma contained_notin: + forall g1 l g2 id g3, + contained l g1 g2 -> within id g2 g3 -> ~In id l. +Proof. + intros; red; intros. exploit H; eauto. intros [C D]. destruct H0 as [A B]. + elim (Plt_strict id). apply Plt_Ple_trans with (gen_next g2); auto. +Qed. + +Hint Resolve gensym_within within_widen contained_widen + contained_cons contained_app contained_disjoint + contained_notin contained_nil + incl_refl incl_tl incl_app incl_appl incl_appr + in_eq in_cons + Ple_trans Ple_refl: gensym. + +(** ** Correctness of the translation functions *) + +Lemma finish_meets_spec_1: + forall dst sl a sl' a', + finish dst sl a = (sl', a') -> sl' = sl ++ final dst a. +Proof. + intros. destruct dst; simpl in *; inv H. apply app_nil_end. apply app_nil_end. auto. +Qed. + +Lemma finish_meets_spec_2: + forall dst sl a sl' a', + finish dst sl a = (sl', a') -> a' = a. +Proof. + intros. destruct dst; simpl in *; inv H; auto. +Qed. + +Ltac UseFinish := + match goal with + | [ H: finish _ _ _ = (_, _) |- _ ] => + try (rewrite (finish_meets_spec_2 _ _ _ _ _ H)); + try (rewrite (finish_meets_spec_1 _ _ _ _ _ H)); + repeat rewrite app_ass + end. + +Scheme expr_ind2 := Induction for C.expr Sort Prop + with exprlist_ind2 := Induction for C.exprlist Sort Prop. +Combined Scheme expr_exprlist_ind from expr_ind2, exprlist_ind2. + +Lemma transl_meets_spec: + (forall r dst g sl a g' I, + transl_expr dst r g = Res (sl, a) g' I -> + exists tmps, (forall le, tr_expr le dst r sl a tmps) /\ contained tmps g g') + /\ + (forall rl g sl al g' I, + transl_exprlist rl g = Res (sl, al) g' I -> + exists tmps, (forall le, tr_exprlist le rl sl al tmps) /\ contained tmps g g'). +Proof. + apply expr_exprlist_ind; intros. +(* val *) + simpl in H. destruct v; monadInv H; exists (@nil ident); split; auto with gensym. +Opaque makeif. + intros. destruct dst; simpl in H1; inv H1. + constructor. auto. intros; constructor. + constructor. + constructor. auto. intros; constructor. + intros. destruct dst; simpl in H1; inv H1. + constructor. auto. intros; constructor. + constructor. + constructor. auto. intros; constructor. +(* var *) + monadInv H; econstructor; split; auto with gensym. UseFinish. constructor. +(* field *) + monadInv H0. exploit H; eauto. intros [tmp [A B]]. UseFinish. + econstructor; split; eauto. constructor; auto. +(* valof *) + monadInv H0. exploit H; eauto. intros [tmp [A B]]. UseFinish. + econstructor; split. + econstructor; eauto. eauto with gensym. +(* deref *) + monadInv H0. exploit H; eauto. intros [tmp [A B]]. UseFinish. + econstructor; split; eauto. constructor; auto. +(* addrof *) + monadInv H0. exploit H; eauto. intros [tmp [A B]]. UseFinish. + econstructor; split; eauto. econstructor; eauto. +(* unop *) + monadInv H0. exploit H; eauto. intros [tmp [A B]]. UseFinish. + econstructor; split; eauto. constructor; auto. +(* binop *) + monadInv H1. exploit H; eauto. intros [tmp1 [A B]]. + exploit H0; eauto. intros [tmp2 [C D]]. UseFinish. + exists (tmp1 ++ tmp2); split. + econstructor; eauto with gensym. + eauto with gensym. +(* cast *) + monadInv H0. exploit H; eauto. intros [tmp [A B]]. UseFinish. + econstructor; split; eauto. constructor; auto. +(* condition *) + monadInv H2. exploit H; eauto. intros [tmp1 [A B]]. + exploit H0; eauto. intros [tmp2 [C D]]. + exploit H1; eauto. intros [tmp3 [E F]]. + destruct dst; monadInv EQ3. + (* for value *) + exists (x2 :: tmp1 ++ tmp2 ++ tmp3); split. + econstructor; eauto with gensym. + apply contained_cons. eauto with gensym. + apply contained_app. eauto with gensym. + apply contained_app; eauto with gensym. + (* for effects *) + exists (tmp1 ++ tmp2 ++ tmp3); split. + econstructor; eauto with gensym. congruence. + apply contained_app; eauto with gensym. + (* for test *) + exists (tmp1 ++ tmp2 ++ tmp3); split. + econstructor; eauto with gensym. congruence. + apply contained_app; eauto with gensym. +(* sizeof *) + monadInv H. UseFinish. + exists (@nil ident); split; auto with gensym. constructor. +(* assign *) + monadInv H1. exploit H; eauto. intros [tmp1 [A B]]. + exploit H0; eauto. intros [tmp2 [C D]]. + destruct dst; monadInv EQ2. + (* for value *) + exists (x1 :: tmp1 ++ tmp2); split. + intros. eapply tr_assign_val with (dst := For_val); eauto with gensym. + apply contained_cons. eauto with gensym. + apply contained_app; eauto with gensym. + (* for effects *) + exists (tmp1 ++ tmp2); split. + econstructor; eauto with gensym. + apply contained_app; eauto with gensym. + (* for test *) + exists (x1 :: tmp1 ++ tmp2); split. + repeat rewrite app_ass. simpl. + intros. eapply tr_assign_val with (dst := For_test s1 s2); eauto with gensym. + apply contained_cons. eauto with gensym. + apply contained_app; eauto with gensym. +(* assignop *) + monadInv H1. exploit H; eauto. intros [tmp1 [A B]]. + exploit H0; eauto. intros [tmp2 [C D]]. + destruct dst; monadInv EQ2. + (* for value *) + exists (x1 :: tmp1 ++ tmp2); split. + intros. eapply tr_assignop_val with (dst := For_val); eauto with gensym. + apply contained_cons. eauto with gensym. + apply contained_app; eauto with gensym. + (* for effects *) + exists (tmp1 ++ tmp2); split. + econstructor; eauto with gensym. + apply contained_app; eauto with gensym. + (* for test *) + exists (x1 :: tmp1 ++ tmp2); split. + repeat rewrite app_ass. simpl. + intros. eapply tr_assignop_val with (dst := For_test s1 s2); eauto with gensym. + apply contained_cons. eauto with gensym. + apply contained_app; eauto with gensym. +(* postincr *) + monadInv H0. exploit H; eauto. intros [tmp1 [A B]]. + destruct dst; monadInv EQ0. + (* for value *) + exists (x0 :: tmp1); split. + econstructor; eauto with gensym. + apply contained_cons; eauto with gensym. + (* for effects *) + exists tmp1; split. + econstructor; eauto with gensym. auto. + (* for test *) + repeat rewrite app_ass; simpl. + exists (x0 :: tmp1); split. + econstructor; eauto with gensym. + apply contained_cons; eauto with gensym. +(* comma *) + monadInv H1. exploit H; eauto. intros [tmp1 [A B]]. + exploit H0; eauto. intros [tmp2 [C D]]. + exists (tmp1 ++ tmp2); split. + econstructor; eauto with gensym. + apply contained_app; eauto with gensym. +(* call *) + monadInv H1. exploit H; eauto. intros [tmp1 [A B]]. + exploit H0; eauto. intros [tmp2 [C D]]. + destruct dst; monadInv EQ2. + (* for value *) + exists (x1 :: tmp1 ++ tmp2); split. + econstructor; eauto with gensym. congruence. + apply contained_cons. eauto with gensym. + apply contained_app; eauto with gensym. + (* for effects *) + exists (tmp1 ++ tmp2); split. + econstructor; eauto with gensym. + apply contained_app; eauto with gensym. + (* for test *) + exists (x1 :: tmp1 ++ tmp2); split. + repeat rewrite app_ass. econstructor; eauto with gensym. congruence. + apply contained_cons. eauto with gensym. + apply contained_app; eauto with gensym. +(* loc *) + monadInv H. + +(* paren *) + monadInv H0. +(* nil *) + monadInv H; exists (@nil ident); split; auto with gensym. constructor. +(* cons *) + monadInv H1. exploit H; eauto. intros [tmp1 [A B]]. + exploit H0; eauto. intros [tmp2 [C D]]. + exists (tmp1 ++ tmp2); split. + econstructor; eauto with gensym. + eauto with gensym. +Qed. + +Lemma transl_expr_meets_spec: + forall r dst g sl a g' I, + transl_expr dst r g = Res (sl, a) g' I -> + exists tmps, forall ge e le m, tr_top ge e le m dst r sl a tmps. +Proof. + intros. exploit (proj1 transl_meets_spec); eauto. intros [tmps [A B]]. + exists tmps; intros. apply tr_top_base. auto. +Qed. + +Lemma transl_expression_meets_spec: + forall r g s a g' I, + transl_expression r g = Res (s, a) g' I -> + tr_expression r s a. +Proof. + intros. monadInv H. exploit transl_expr_meets_spec; eauto. + intros [tmps A]. econstructor; eauto. +Qed. + +Lemma transl_expr_stmt_meets_spec: + forall r g s g' I, + transl_expr_stmt r g = Res s g' I -> + tr_expr_stmt r s. +Proof. + intros. monadInv H. exploit transl_expr_meets_spec; eauto. + intros [tmps A]. econstructor; eauto. +Qed. + +Lemma transl_if_meets_spec: + forall r s1 s2 g s g' I, + transl_if r s1 s2 g = Res s g' I -> + tr_if r s1 s2 s. +Proof. + intros. monadInv H. exploit transl_expr_meets_spec; eauto. + intros [tmps A]. econstructor; eauto. +Qed. + +Lemma transl_stmt_meets_spec: + forall s g ts g' I, transl_stmt s g = Res ts g' I -> tr_stmt s ts +with transl_lblstmt_meets_spec: + forall s g ts g' I, transl_lblstmt s g = Res ts g' I -> tr_lblstmts s ts. +Proof. + generalize transl_expression_meets_spec transl_expr_stmt_meets_spec transl_if_meets_spec; intros T1 T2 T3. +Opaque transl_expression transl_expr_stmt. + clear transl_stmt_meets_spec. + induction s; simpl; intros until I; intros TR; + try (monadInv TR); try (constructor; eauto). + remember (small_stmt x && small_stmt x0). destruct b. + exploit andb_prop; eauto. intros [A B]. + eapply tr_ifthenelse_small; eauto. + monadInv EQ2. eapply tr_ifthenelse_big; eauto. + destruct (is_Sskip s1); monadInv EQ4. + apply tr_for_1; eauto. + apply tr_for_2; eauto. + destruct o; monadInv TR; constructor; eauto. + + clear transl_lblstmt_meets_spec. + induction s; simpl; intros until I; intros TR; + monadInv TR; constructor; eauto. +Qed. + +Theorem transl_function_spec: + forall f tf, + transl_function f = OK tf -> + tr_stmt f.(C.fn_body) tf.(fn_body) + /\ fn_return tf = C.fn_return f + /\ fn_params tf = C.fn_params f + /\ fn_vars tf = C.fn_vars f. +Proof. + intros until tf. unfold transl_function. + case_eq (transl_stmt (C.fn_body f) initial_generator); intros; inv H0. + simpl. intuition. eapply transl_stmt_meets_spec; eauto. +Qed. + +End SPEC. + diff --git a/common/Determinism.v b/common/Determinism.v index 02fb860..00d8855 100644 --- a/common/Determinism.v +++ b/common/Determinism.v @@ -186,13 +186,25 @@ Definition possible_behavior (w: world) (b: program_behavior) : Prop := | Goes_wrong t => exists w', possible_trace w t w' end. -(** * Deterministic semantics *) +CoInductive possible_traceinf': world -> traceinf -> Prop := + | possible_traceinf'_app: forall w1 t w2 T, + possible_trace w1 t w2 -> t <> E0 -> + possible_traceinf' w2 T -> + possible_traceinf' w1 (t *** T). + +Lemma possible_traceinf'_traceinf: + forall w T, possible_traceinf' w T -> possible_traceinf w T. +Proof. + cofix COINDHYP; intros. inv H. inv H0. congruence. + simpl. econstructor. eauto. apply COINDHYP. + inv H3. simpl. auto. econstructor; eauto. econstructor; eauto. unfold E0; congruence. +Qed. + +(** * Properties of deterministic semantics *) Section DETERM_SEM. -(** We assume given a transition semantics that is internally - deterministic: the only source of non-determinism is the return - value of system calls. *) +(** We assume given a semantics that is deterministic, in the following sense. *) Variable genv: Type. Variable state: Type. @@ -200,9 +212,10 @@ Variable step: genv -> state -> trace -> state -> Prop. Variable initial_state: state -> Prop. Variable final_state: state -> int -> Prop. -Hypothesis step_internal_deterministic: - forall ge s t1 s1 t2 s2, - step ge s t1 s1 -> step ge s t2 s2 -> matching_traces t1 t2 -> s1 = s2 /\ t1 = t2. +Hypothesis step_deterministic: + forall ge s0 t1 s1 t2 s2, + step ge s0 t1 s1 -> step ge s0 t2 s2 -> + s1 = s2 /\ t1 = t2. Hypothesis initial_state_determ: forall s1 s2, initial_state s1 -> initial_state s2 -> s1 = s2. @@ -213,70 +226,37 @@ Hypothesis final_state_determ: Hypothesis final_state_nostep: forall ge st r, final_state st r -> nostep step ge st. -(** Consequently, the [step] relation is deterministic if restricted - to traces that are possible in a deterministic world. *) - -Remark matching_possible_traces: - forall w0 t1 w1, possible_trace w0 t1 w1 -> - forall t2 w2, possible_trace w0 t2 w2 -> - matching_traces t1 t2. -Proof. - induction 1; intros. - destruct t2; simpl; auto. - destruct t2; simpl. destruct ev; auto. inv H1. - inv H; inv H5; auto; intros. - destruct H2. subst. rewrite H in H1; inv H1. split; eauto. - destruct H2. destruct H3. subst. rewrite H in H1; inv H1. split; eauto. - destruct H2. destruct H3. destruct H4. subst. rewrite H in H1; inv H1. eauto. -Qed. - -Lemma step_deterministic: - forall ge s0 t1 s1 t2 s2 w0 w1 w2, - step ge s0 t1 s1 -> step ge s0 t2 s2 -> - possible_trace w0 t1 w1 -> possible_trace w0 t2 w2 -> - s1 = s2 /\ t1 = t2 /\ w1 = w2. -Proof. - intros. exploit step_internal_deterministic. eexact H. eexact H0. - eapply matching_possible_traces; eauto. intuition. - subst. eapply possible_trace_final_world; eauto. -Qed. - Ltac use_step_deterministic := match goal with - | [ S1: step _ _ ?t1 _, P1: possible_trace _ ?t1 _, - S2: step _ _ ?t2 _, P2: possible_trace _ ?t2 _ |- _ ] => - destruct (step_deterministic _ _ _ _ _ _ _ _ _ S1 S2 P1 P2) - as [EQ1 [EQ2 EQ3]]; subst + | [ S1: step _ _ ?t1 _, S2: step _ _ ?t2 _ |- _ ] => + destruct (step_deterministic _ _ _ _ _ _ S1 S2) as [EQ1 EQ2]; subst end. (** Determinism for finite transition sequences. *) Lemma star_step_diamond: forall ge s0 t1 s1, star step ge s0 t1 s1 -> - forall t2 s2 w0 w1 w2, star step ge s0 t2 s2 -> - possible_trace w0 t1 w1 -> possible_trace w0 t2 w2 -> + forall t2 s2, star step ge s0 t2 s2 -> exists t, - (star step ge s1 t s2 /\ possible_trace w1 t w2 /\ t2 = t1 ** t) - \/ (star step ge s2 t s1 /\ possible_trace w2 t w1 /\ t1 = t2 ** t). + (star step ge s1 t s2 /\ t2 = t1 ** t) + \/ (star step ge s2 t s1 /\ t1 = t2 ** t). Proof. induction 1; intros. - inv H0. exists t2; auto. - inv H2. inv H4. exists (t1 ** t2); right. + exists t2; auto. + inv H2. exists (t1 ** t2); right. split. econstructor; eauto. auto. - possibleTraceInv. use_step_deterministic. - exploit IHstar. eexact H6. eauto. eauto. - intros [t A]. exists t. + use_step_deterministic. + exploit IHstar. eexact H4. intros [t A]. exists t. destruct A. left; intuition. traceEq. right; intuition. traceEq. Qed. Ltac use_star_step_diamond := match goal with - | [ S1: star step _ _ ?t1 _, P1: possible_trace _ ?t1 _, - S2: star step _ _ ?t2 _, P2: possible_trace _ ?t2 _ |- _ ] => - let t := fresh "t" in let P := fresh "P" in let Q := fresh "Q" in let EQ := fresh "EQ" in - destruct (star_step_diamond _ _ _ _ S1 _ _ _ _ _ S2 P1 P2) - as [t [ [P [Q EQ]] | [P [Q EQ]] ]]; subst - end. + | [ S1: star step _ _ ?t1 _, S2: star step _ _ ?t2 _ |- _ ] => + let t := fresh "t" in let P := fresh "P" in let EQ := fresh "EQ" in + destruct (star_step_diamond _ _ _ _ S1 _ _ S2) + as [t [ [P EQ] | [P EQ] ]]; subst + end. Ltac use_nostep := match goal with @@ -284,163 +264,149 @@ Ltac use_nostep := end. Lemma star_step_triangle: - forall ge s0 t1 s1 t2 s2 w0 w1 w2, + forall ge s0 t1 s1 t2 s2, star step ge s0 t1 s1 -> star step ge s0 t2 s2 -> - possible_trace w0 t1 w1 -> possible_trace w0 t2 w2 -> nostep step ge s2 -> exists t, - star step ge s1 t s2 /\ possible_trace w1 t w2 /\ t2 = t1 ** t. + star step ge s1 t s2 /\ t2 = t1 ** t. Proof. - intros. use_star_step_diamond; possibleTraceInv. + intros. use_star_step_diamond. exists t; auto. - inv P. inv Q. exists E0. split. constructor. split. constructor. traceEq. + inv P. exists E0. split. constructor. traceEq. use_nostep. Qed. Ltac use_star_step_triangle := match goal with - | [ S1: star step _ _ ?t1 _, P1: possible_trace _ ?t1 _, - S2: star step _ _ ?t2 ?s2, P2: possible_trace _ ?t2 _, + | [ S1: star step _ _ ?t1 _, S2: star step _ _ ?t2 ?s2, NO: nostep step _ ?s2 |- _ ] => - let t := fresh "t" in let P := fresh "P" in let Q := fresh "Q" in let EQ := fresh "EQ" in - destruct (star_step_triangle _ _ _ _ _ _ _ _ _ S1 S2 P1 P2 NO) - as [t [P [Q EQ]]]; subst + let t := fresh "t" in let P := fresh "P" in let EQ := fresh "EQ" in + destruct (star_step_triangle _ _ _ _ _ _ S1 S2 NO) + as [t [P EQ]]; subst end. Lemma steps_deterministic: - forall ge s0 t1 s1 t2 s2 w0 w1 w2, + forall ge s0 t1 s1 t2 s2, star step ge s0 t1 s1 -> star step ge s0 t2 s2 -> nostep step ge s1 -> nostep step ge s2 -> - possible_trace w0 t1 w1 -> possible_trace w0 t2 w2 -> t1 = t2 /\ s1 = s2. Proof. intros. use_star_step_triangle. inv P. - inv Q. split; auto; traceEq. use_nostep. + split; auto; traceEq. use_nostep. Qed. Lemma terminates_not_goes_wrong: - forall ge s t1 s1 r w w1 t2 s2 w2, - star step ge s t1 s1 -> final_state s1 r -> possible_trace w t1 w1 -> - star step ge s t2 s2 -> nostep step ge s2 -> possible_trace w t2 w2 -> + forall ge s t1 s1 r t2 s2, + star step ge s t1 s1 -> final_state s1 r -> + star step ge s t2 s2 -> nostep step ge s2 -> (forall r, ~final_state s2 r) -> False. Proof. intros. assert (t1 = t2 /\ s1 = s2). eapply steps_deterministic; eauto. - destruct H6; subst. elim (H5 _ H0). + destruct H4; subst. elim (H3 _ H0). Qed. (** Determinism for infinite transition sequences. *) Lemma star_final_not_forever_silent: forall ge s t s', star step ge s t s' -> - forall w w', possible_trace w t w' -> nostep step ge s' -> + nostep step ge s' -> forever_silent step ge s -> False. Proof. induction 1; intros. - inv H1. use_nostep. - inv H4. possibleTraceInv. assert (possible_trace w E0 w) by constructor. - use_step_deterministic. eauto. + inv H0. use_nostep. + inv H3. use_step_deterministic. eauto. Qed. Lemma star2_final_not_forever_silent: - forall ge s t1 s1 w w1 t2 s2 w2, - star step ge s t1 s1 -> possible_trace w t1 w1 -> nostep step ge s1 -> - star step ge s t2 s2 -> possible_trace w t2 w2 -> forever_silent step ge s2 -> + forall ge s t1 s1 t2 s2, + star step ge s t1 s1 -> nostep step ge s1 -> + star step ge s t2 s2 -> forever_silent step ge s2 -> False. Proof. - intros. use_star_step_triangle. possibleTraceInv. - eapply star_final_not_forever_silent. eexact P. eauto. auto. auto. + intros. use_star_step_triangle. + eapply star_final_not_forever_silent. eexact P. eauto. auto. Qed. Lemma star_final_not_forever_reactive: forall ge s t s', star step ge s t s' -> - forall w w' T, possible_trace w t w' -> possible_traceinf w T -> nostep step ge s' -> - forever_reactive step ge s T -> False. + forall T, nostep step ge s' -> forever_reactive step ge s T -> False. Proof. induction 1; intros. - inv H2. inv H3. congruence. use_nostep. - inv H5. possibleTraceInv. inv H6. congruence. possibleTraceInv. + inv H0. inv H1. congruence. use_nostep. + inv H3. inv H4. congruence. use_step_deterministic. eapply IHstar with (T := t4 *** T0). eauto. - eapply possible_traceinf_app; eauto. auto. eapply star_forever_reactive; eauto. Qed. Lemma star_forever_silent_inv: forall ge s t s', star step ge s t s' -> - forall w w', possible_trace w t w' -> forever_silent step ge s -> t = E0 /\ forever_silent step ge s'. Proof. induction 1; intros. auto. - subst. possibleTraceInv. inv H3. assert (possible_trace w E0 w) by constructor. - use_step_deterministic. eauto. + subst. inv H2. use_step_deterministic. eauto. Qed. Lemma forever_silent_reactive_exclusive: - forall ge s w T, - forever_silent step ge s -> forever_reactive step ge s T -> - possible_traceinf w T -> False. + forall ge s T, + forever_silent step ge s -> forever_reactive step ge s T -> False. Proof. - intros. inv H0. possibleTraceInv. exploit star_forever_silent_inv; eauto. + intros. inv H0. exploit star_forever_silent_inv; eauto. intros [A B]. contradiction. Qed. Lemma forever_reactive_inv2: forall ge s t1 s1, star step ge s t1 s1 -> - forall t2 s2 T1 T2 w w1 w2, - possible_trace w t1 w1 -> - star step ge s t2 s2 -> possible_trace w t2 w2 -> + forall t2 s2 T1 T2, + star step ge s t2 s2 -> t1 <> E0 -> t2 <> E0 -> - forever_reactive step ge s1 T1 -> possible_traceinf w1 T1 -> - forever_reactive step ge s2 T2 -> possible_traceinf w2 T2 -> - exists s', exists t, exists T1', exists T2', exists w', + forever_reactive step ge s1 T1 -> + forever_reactive step ge s2 T2 -> + exists s', exists t, exists T1', exists T2', t <> E0 /\ - forever_reactive step ge s' T1' /\ possible_traceinf w' T1' /\ - forever_reactive step ge s' T2' /\ possible_traceinf w' T2' /\ + forever_reactive step ge s' T1' /\ + forever_reactive step ge s' T2' /\ t1 *** T1 = t *** T1' /\ t2 *** T2 = t *** T2'. Proof. induction 1; intros. congruence. - inv H3. congruence. possibleTraceInv. - use_step_deterministic. + inv H2. congruence. use_step_deterministic. destruct t3. (* inductive case *) - simpl in *. inv P1; inv P. eapply IHstar; eauto. + simpl in *. eapply IHstar; eauto. (* base case *) exists s5; exists (e :: t3); - exists (t2 *** T1); exists (t4 *** T2); exists w3. + exists (t2 *** T1); exists (t4 *** T2). split. unfold E0; congruence. split. eapply star_forever_reactive; eauto. - split. eapply possible_traceinf_app; eauto. split. eapply star_forever_reactive; eauto. - split. eapply possible_traceinf_app; eauto. split; traceEq. Qed. Lemma forever_reactive_determ': - forall ge s T1 T2 w, - forever_reactive step ge s T1 -> possible_traceinf w T1 -> - forever_reactive step ge s T2 -> possible_traceinf w T2 -> + forall ge s T1 T2, + forever_reactive step ge s T1 -> + forever_reactive step ge s T2 -> traceinf_sim' T1 T2. Proof. cofix COINDHYP; intros. - inv H. inv H1. possibleTraceInv. - destruct (forever_reactive_inv2 _ _ _ _ H _ _ _ _ _ _ _ P H3 P1 H6 H4 - H7 P0 H5 P2) - as [s' [t' [T1' [T2' [w' [A [B [C [D [E [G K]]]]]]]]]]]. - rewrite G; rewrite K. constructor. auto. + inv H. inv H0. + destruct (forever_reactive_inv2 _ _ _ _ H t s2 T0 T) + as [s' [t' [T1' [T2' [A [B [C [D E]]]]]]]]; auto. + rewrite D; rewrite E. constructor. auto. eapply COINDHYP; eauto. Qed. Lemma forever_reactive_determ: - forall ge s T1 T2 w, - forever_reactive step ge s T1 -> possible_traceinf w T1 -> - forever_reactive step ge s T2 -> possible_traceinf w T2 -> + forall ge s T1 T2, + forever_reactive step ge s T1 -> + forever_reactive step ge s T2 -> traceinf_sim T1 T2. Proof. intros. apply traceinf_sim'_sim. eapply forever_reactive_determ'; eauto. @@ -448,27 +414,25 @@ Qed. Lemma star_forever_reactive_inv: forall ge s t s', star step ge s t s' -> - forall w w' T, possible_trace w t w' -> forever_reactive step ge s T -> - possible_traceinf w T -> - exists T', forever_reactive step ge s' T' /\ possible_traceinf w' T' /\ T = t *** T'. + forall T, forever_reactive step ge s T -> + exists T', forever_reactive step ge s' T' /\ T = t *** T'. Proof. induction 1; intros. - possibleTraceInv. exists T; auto. - inv H3. possibleTraceInv. inv H5. congruence. possibleTraceInv. + exists T; auto. + inv H2. inv H3. congruence. use_step_deterministic. - exploit IHstar. eauto. eapply star_forever_reactive. 2: eauto. eauto. - eapply possible_traceinf_app; eauto. - intros [T' [A [B C]]]. exists T'; intuition. traceEq. congruence. + exploit IHstar. eapply star_forever_reactive. 2: eauto. eauto. + intros [T' [A B]]. exists T'; intuition. traceEq. congruence. Qed. Lemma forever_silent_reactive_exclusive2: - forall ge s t s' w w' T, - star step ge s t s' -> possible_trace w t w' -> forever_silent step ge s' -> - forever_reactive step ge s T -> possible_traceinf w T -> + forall ge s t s' T, + star step ge s t s' -> forever_silent step ge s' -> + forever_reactive step ge s T -> False. Proof. intros. exploit star_forever_reactive_inv; eauto. - intros [T' [A [B C]]]. subst T. + intros [T' [A B]]. subst T. eapply forever_silent_reactive_exclusive; eauto. Qed. @@ -484,14 +448,13 @@ Ltac use_init_state := end. Theorem program_behaves_deterministic: - forall ge w beh1 beh2, - program_behaves step initial_state final_state ge beh1 -> possible_behavior w beh1 -> - program_behaves step initial_state final_state ge beh2 -> possible_behavior w beh2 -> + forall ge beh1 beh2, + program_behaves step initial_state final_state ge beh1 -> + program_behaves step initial_state final_state ge beh2 -> beh1 = beh2. Proof. - intros until beh2; intros BEH1 POS1 BEH2 POS2. - inv BEH1; inv BEH2; simpl in POS1; simpl in POS2; - possibleTraceInv; use_init_state. + intros until beh2; intros BEH1 BEH2. + inv BEH1; inv BEH2; use_init_state. (* terminates, terminates *) assert (t = t0 /\ s' = s'0). eapply steps_deterministic; eauto. destruct H2. f_equal; auto. subst. eauto. @@ -505,9 +468,9 @@ Proof. byContradiction. eapply star2_final_not_forever_silent with (s2 := s') (s1 := s'0); eauto. (* diverges, diverges *) f_equal. use_star_step_diamond. - exploit star_forever_silent_inv. eexact P1. eauto. eauto. + exploit star_forever_silent_inv. eexact P. eauto. intros [A B]. subst; traceEq. - exploit star_forever_silent_inv. eexact P1. eauto. eauto. + exploit star_forever_silent_inv. eexact P. eauto. intros [A B]. subst; traceEq. (* diverges, reacts *) byContradiction. eapply forever_silent_reactive_exclusive2; eauto. @@ -536,3 +499,276 @@ Proof. Qed. End DETERM_SEM. + +(** * Integrating an external world in a semantics. *) + +(** Given a transition semantics, we can build another semantics that + integrates an external world in its state and allows only world-possible + transitions. *) + +Section WORLD_SEM. + +Variable genv: Type. +Variable state: Type. +Variable step: genv -> state -> trace -> state -> Prop. +Variable initial_state: state -> Prop. +Variable final_state: state -> int -> Prop. +Variable initial_world: world. + +Definition wstate : Type := (state * world)%type. + +Notation "s #1" := (fst s) (at level 9, format "s '#1'") : pair_scope. +Notation "s #2" := (snd s) (at level 9, format "s '#2'") : pair_scope. +Local Open Scope pair_scope. + +Definition wstep (ge: genv) (S: wstate) (t: trace) (S': wstate) := + step ge S#1 t S'#1 /\ possible_trace S#2 t S'#2. + +Definition winitial_state (S: wstate) := + initial_state S#1 /\ S#2 = initial_world. + +Definition wfinal_state (S: wstate) (r: int) := + final_state S#1 r. + +Definition wprogram_behaves (ge: genv) (beh: program_behavior) := + program_behaves wstep winitial_state wfinal_state ge beh. + +(** We now relate sequences of transitions and behaviors between the two semantics. *) + +Section TRANSITIONS. + +Variable ge: genv. + +Lemma inject_star: + forall S t S', star step ge S t S' -> + forall w w', possible_trace w t w' -> + star wstep ge (S, w) t (S', w'). +Proof. + induction 1; intros; subst; possibleTraceInv. + constructor. + apply star_step with t1 (s2,w0) t2. split; auto. auto. auto. +Qed. + +Lemma project_star: + forall S t S', star wstep ge S t S' -> star step ge S#1 t S'#1. +Proof. + induction 1. constructor. destruct H. econstructor; eauto. +Qed. + +Lemma project_star_trace: + forall S t S', star wstep ge S t S' -> possible_trace S#2 t S'#2. +Proof. + induction 1. constructor. subst t. destruct H. eapply possible_trace_app. eauto. eauto. +Qed. + +Lemma inject_forever_silent: + forall S w, forever_silent step ge S -> forever_silent wstep ge (S, w). +Proof. + cofix COINDHYP; intros. inv H. + apply forever_silent_intro with (s2,w). + split. auto. constructor. apply COINDHYP; auto. +Qed. + +Lemma project_forever_silent: + forall S, forever_silent wstep ge S -> forever_silent step ge S#1. +Proof. + cofix COINDHYP; intros. inv H. destruct H0. + apply forever_silent_intro with (s2#1). auto. apply COINDHYP; auto. +Qed. + +Lemma inject_forever_reactive: + forall S T w, forever_reactive step ge S T -> possible_traceinf w T -> + forever_reactive wstep ge (S, w) T. +Proof. + cofix COINDHYP; intros. inv H. possibleTraceInv. + apply forever_reactive_intro with (s2,w0). + apply inject_star; auto. auto. apply COINDHYP; auto. +Qed. + +Lemma project_forever_reactive: + forall S T, forever_reactive wstep ge S T -> forever_reactive step ge S#1 T. +Proof. + cofix COINDHYP; intros. inv H. + apply forever_reactive_intro with (s2#1). + apply project_star; auto. auto. apply COINDHYP; auto. +Qed. + +Lemma project_forever_reactive_trace: + forall S T, forever_reactive wstep ge S T -> possible_traceinf S#2 T. +Proof. + intros. apply possible_traceinf'_traceinf. revert S T H. + cofix COINDHYP; intros. inv H. econstructor. + apply project_star_trace. eauto. auto. apply COINDHYP; auto. +Qed. + +Lemma inject_behaviors: + forall beh, + program_behaves step initial_state final_state ge beh -> + possible_behavior initial_world beh -> + wprogram_behaves ge beh. +Proof. + intros. inv H; simpl in H0. +(* terminates *) + destruct H0 as [w' A]. econstructor. + instantiate (1 := (s, initial_world)). red; eauto. + apply inject_star; eauto. + red; auto. +(* diverges silently *) + destruct H0 as [w' A]. econstructor. + instantiate (1 := (s, initial_world)). red; eauto. + apply inject_star; eauto. apply inject_forever_silent; auto. +(* diverges reactively *) + econstructor. + instantiate (1 := (s, initial_world)). red; eauto. + apply inject_forever_reactive; auto. +(* goes wrong *) + destruct H0 as [w' A]. red in H3. + econstructor. + instantiate (1 := (s, initial_world)). red; eauto. + apply inject_star; eauto. + red. intros. red; intros [C D]. elim (H3 t0 s'0#1); auto. + unfold wfinal_state; simpl. auto. +(* goes initially wrong *) + apply program_goes_initially_wrong. intros; red; intros. destruct H. + elim (H1 s#1); auto. +Qed. + +Lemma project_behaviors_trace: + forall beh, + wprogram_behaves ge beh -> + possible_behavior initial_world beh. +Proof. + intros. inv H; simpl. + destruct H0. rewrite <- H0. exists (s'#2); apply project_star_trace; auto. + destruct H0. rewrite <- H0. exists (s'#2); apply project_star_trace; auto. + destruct H0. rewrite <- H0. apply project_forever_reactive_trace; auto. + destruct H0. rewrite <- H0. exists (s'#2); apply project_star_trace; auto. + exists initial_world; constructor. +Qed. + +Lemma project_behaviors: + forall beh, + wprogram_behaves ge beh -> + program_behaves step initial_state final_state ge beh + \/ exists S, exists t, exists S', exists w', exists S'', exists t', + beh = Goes_wrong t /\ + initial_state S /\ star step ge S t S' /\ possible_trace initial_world t w' /\ + step ge S' t' S'' /\ forall w'', ~(possible_trace w' t' w''). +Proof. + intros. inv H. +(* terminates *) + destruct H0. + left. econstructor; eauto. apply project_star; auto. +(* diverges silently *) + destruct H0. + left. econstructor; eauto. apply project_star; eauto. apply project_forever_silent; auto. +(* diverges reactively *) + destruct H0. + left. econstructor; eauto. apply project_forever_reactive; auto. +(* goes wrong *) + destruct H0. + red in H2. + destruct (classic (forall t s'', ~step ge s'#1 t s'')). + left. econstructor; eauto. apply project_star; eauto. + destruct (not_all_ex_not _ _ H4) as [t' A]. clear H4. + destruct (not_all_ex_not _ _ A) as [s'' B]. clear A. + assert (C: step ge s'#1 t' s''). apply NNPP; auto. clear B. + right. do 6 econstructor. split. eauto. split. eauto. + split. apply project_star; eauto. + split. rewrite <- H0. apply project_star_trace; eauto. + split. eauto. + intros; red; intros. elim (H2 t' (s'',w'')). split; auto. +(* goes initially wrong *) + left. apply program_goes_initially_wrong. intros; red; intros. + elim (H0 (s, initial_world)). split; auto. +Qed. + +End TRANSITIONS. + +Section INTERNAL_DET_TO_DET. + +(** We assume given a transition semantics that is internally + deterministic: the only source of non-determinism is the return + value of system calls. Under this assumption, the world-aware semantics + is deterministic. *) + +Hypothesis step_internal_deterministic: + forall ge s t1 s1 t2 s2, + step ge s t1 s1 -> step ge s t2 s2 -> matching_traces t1 t2 -> s1 = s2 /\ t1 = t2. + +Hypothesis initial_state_determ: + forall s1 s2, initial_state s1 -> initial_state s2 -> s1 = s2. + +Hypothesis final_state_determ: + forall st r1 r2, final_state st r1 -> final_state st r2 -> r1 = r2. + +Hypothesis final_state_nostep: + forall ge st r, final_state st r -> nostep step ge st. + +Remark matching_possible_traces: + forall w0 t1 w1, possible_trace w0 t1 w1 -> + forall t2 w2, possible_trace w0 t2 w2 -> + matching_traces t1 t2. +Proof. + induction 1; intros. + destruct t2; simpl; auto. + destruct t2; simpl. destruct ev; auto. inv H1. + inv H; inv H5; auto; intros. + destruct H2. subst. rewrite H in H1; inv H1. split; eauto. + destruct H2. destruct H3. subst. rewrite H in H1; inv H1. split; eauto. + destruct H2. destruct H3. destruct H4. subst. rewrite H in H1; inv H1. eauto. +Qed. + +Lemma wstep_deterministic: + forall ge S0 t1 S1 t2 S2, + wstep ge S0 t1 S1 -> wstep ge S0 t2 S2 -> S1 = S2 /\ t1 = t2. +Proof. + intros. destruct H; destruct H0. + exploit step_internal_deterministic. eexact H. eexact H0. + eapply matching_possible_traces; eauto. + intros [A B]. split. apply injective_projections. auto. + subst t2. eapply possible_trace_final_world; eauto. + auto. +Qed. + +Lemma winitial_state_determ: + forall s1 s2, winitial_state s1 -> winitial_state s2 -> s1 = s2. +Proof. + intros. destruct H; destruct H0. apply injective_projections. eauto. congruence. +Qed. + +Lemma wfinal_state_determ: + forall st r1 r2, wfinal_state st r1 -> wfinal_state st r2 -> r1 = r2. +Proof. + unfold wfinal_state. eauto. +Qed. + +Lemma wfinal_state_nostep: + forall ge st r, wfinal_state st r -> nostep wstep ge st. +Proof. + unfold wfinal_state. intros; red; intros; red; intros [A B]. + eapply final_state_nostep; eauto. +Qed. + +Theorem program_behaves_world_deterministic: + forall ge beh1 beh2, + program_behaves step initial_state final_state ge beh1 -> possible_behavior initial_world beh1 -> + program_behaves step initial_state final_state ge beh2 -> possible_behavior initial_world beh2 -> + beh1 = beh2. +Proof. + intros. + apply program_behaves_deterministic with + (step := wstep) (initial_state := winitial_state) (final_state := wfinal_state) (ge := ge). + exact wstep_deterministic. + exact winitial_state_determ. + exact wfinal_state_determ. + exact wfinal_state_nostep. + apply inject_behaviors; auto. + apply inject_behaviors; auto. +Qed. + +End INTERNAL_DET_TO_DET. + +End WORLD_SEM. + + diff --git a/common/Smallstep.v b/common/Smallstep.v index cd61ec3..63426c1 100644 --- a/common/Smallstep.v +++ b/common/Smallstep.v @@ -66,6 +66,31 @@ Proof. intros. eapply star_step; eauto. apply star_refl. traceEq. Qed. +Lemma star_two: + forall ge s1 t1 s2 t2 s3 t, + step ge s1 t1 s2 -> step ge s2 t2 s3 -> t = t1 ** t2 -> + star ge s1 t s3. +Proof. + intros. eapply star_step; eauto. apply star_one; auto. +Qed. + +Lemma star_three: + forall ge s1 t1 s2 t2 s3 t3 s4 t, + step ge s1 t1 s2 -> step ge s2 t2 s3 -> step ge s3 t3 s4 -> t = t1 ** t2 ** t3 -> + star ge s1 t s4. +Proof. + intros. eapply star_step; eauto. eapply star_two; eauto. +Qed. + +Lemma star_four: + forall ge s1 t1 s2 t2 s3 t3 s4 t4 s5 t, + step ge s1 t1 s2 -> step ge s2 t2 s3 -> + step ge s3 t3 s4 -> step ge s4 t4 s5 -> t = t1 ** t2 ** t3 ** t4 -> + star ge s1 t s5. +Proof. + intros. eapply star_step; eauto. eapply star_three; eauto. +Qed. + Lemma star_trans: forall ge s1 t1 s2, star ge s1 t1 s2 -> forall t2 s3 t, star ge s2 t2 s3 -> t = t1 ** t2 -> star ge s1 t s3. @@ -103,6 +128,31 @@ Proof. intros. econstructor; eauto. apply star_refl. traceEq. Qed. +Lemma plus_two: + forall ge s1 t1 s2 t2 s3 t, + step ge s1 t1 s2 -> step ge s2 t2 s3 -> t = t1 ** t2 -> + plus ge s1 t s3. +Proof. + intros. eapply plus_left; eauto. apply star_one; auto. +Qed. + +Lemma plus_three: + forall ge s1 t1 s2 t2 s3 t3 s4 t, + step ge s1 t1 s2 -> step ge s2 t2 s3 -> step ge s3 t3 s4 -> t = t1 ** t2 ** t3 -> + plus ge s1 t s4. +Proof. + intros. eapply plus_left; eauto. eapply star_two; eauto. +Qed. + +Lemma plus_four: + forall ge s1 t1 s2 t2 s3 t3 s4 t4 s5 t, + step ge s1 t1 s2 -> step ge s2 t2 s3 -> + step ge s3 t3 s4 -> step ge s4 t4 s5 -> t = t1 ** t2 ** t3 ** t4 -> + plus ge s1 t s5. +Proof. + intros. eapply plus_left; eauto. eapply star_three; eauto. +Qed. + Lemma plus_star: forall ge s1 t s2, plus ge s1 t s2 -> star ge s1 t s2. Proof. diff --git a/cparser/Bitfields.ml b/cparser/Bitfields.ml index dea1862..2abe6b1 100644 --- a/cparser/Bitfields.ml +++ b/cparser/Bitfields.ml @@ -175,107 +175,194 @@ let bitfield_assign bf carrier newval = {edesc = EBinop(Oor, oldval_masked, newval_masked, TInt(IUInt,[])); etyp = TInt(IUInt,[])} -(* Expressions *) +(* Detect invariant l-values *) + +let rec invariant_lvalue e = + match e.edesc with + | EVar _ -> true + | EUnop(Oderef, {edesc = EVar _}) -> true (* to check *) + | EUnop(Odot _, e1) -> invariant_lvalue e1 + | _ -> false + +(* Bind a l-value to a temporary variable if it is not invariant. *) + +let bind_lvalue e fn = + if invariant_lvalue e then + fn e + else begin + let tmp = new_temp (TPtr(e.etyp, [])) in + ecomma (eassign tmp (eaddrof e)) + (fn {edesc = EUnop(Oderef, tmp); etyp = e.etyp}) + end + +(* Transformation of operators *) + +let op_for_incr_decr = function + | Opreincr -> Oadd + | Opredecr -> Osub + | Opostincr -> Oadd + | Opostdecr -> Osub + | _ -> assert false -let transf_expr env e = +let op_for_assignop = function + | Oadd_assign -> Oadd + | Osub_assign -> Osub + | Omul_assign -> Omul + | Odiv_assign -> Odiv + | Omod_assign -> Omod + | Oand_assign -> Oand + | Oor_assign -> Oor + | Oxor_assign -> Oxor + | Oshl_assign -> Oshl + | Oshr_assign -> Oshr + | _ -> assert false - let is_bitfield_access ty fieldname = - match unroll env ty with - | TStruct(id, _) -> - (try Some(Hashtbl.find bitfield_table (id, fieldname)) - with Not_found -> None) - | _ -> None in +(* Check whether a field access (e.f or e->f) is a bitfield access. + If so, return carrier expression (e and *e, respectively) + and bitfield_info *) + +let rec is_bitfield_access env e = + match e.edesc with + | EUnop(Odot fieldname, e1) -> + begin match unroll env e1.etyp with + | TStruct(id, _) -> + (try Some(e1, Hashtbl.find bitfield_table (id, fieldname)) + with Not_found -> None) + | _ -> + None + end + | EUnop(Oarrow fieldname, e1) -> + begin match unroll env e1.etyp with + | TPtr(ty, _) -> + is_bitfield_access env + {edesc = EUnop(Odot fieldname, + {edesc = EUnop(Oderef, e1); etyp = ty}); + etyp = e.etyp} + | _ -> + None + end + | _ -> None - let is_bitfield_access_ptr ty fieldname = - match unroll env ty with - | TPtr(ty', _) -> is_bitfield_access ty' fieldname - | _ -> None in +(* Expressions *) - let rec texp e = +type context = Val | Effects + +let transf_expr env ctx e = + + let rec texp ctx e = match e.edesc with | EConst _ -> e | ESizeof _ -> e | EVar _ -> e - | EUnop(Odot fieldname, e1) -> - let e1' = texp e1 in - begin match is_bitfield_access e1.etyp fieldname with + | EUnop(Odot s, e1) -> + begin match is_bitfield_access env e with | None -> - {edesc = EUnop(Odot fieldname, e1'); etyp = e.etyp} - | Some bf -> - bitfield_extract bf - {edesc = EUnop(Odot bf.bf_carrier, e1'); - etyp = bf.bf_carrier_typ} + {edesc = EUnop(Odot s, texp Val e1); etyp = e.etyp} + | Some(ex, bf) -> + transf_read ex bf end - - | EUnop(Oarrow fieldname, e1) -> - let e1' = texp e1 in - begin match is_bitfield_access_ptr e1.etyp fieldname with + | EUnop(Oarrow s, e1) -> + begin match is_bitfield_access env e with | None -> - {edesc = EUnop(Oarrow fieldname, e1'); etyp = e.etyp} - | Some bf -> - bitfield_extract bf - {edesc = EUnop(Oarrow bf.bf_carrier, e1'); - etyp = bf.bf_carrier_typ} + {edesc = EUnop(Oarrow s, texp Val e1); etyp = e.etyp} + | Some(ex, bf) -> + transf_read ex bf end - - | EUnop(op, e1) -> - (* Note: simplified expr, so no ++/-- *) - {edesc = EUnop(op, texp e1); etyp = e.etyp} + | EUnop((Opreincr|Opredecr) as op, e1) -> + begin match is_bitfield_access env e1 with + | None -> + {edesc = EUnop(op, texp Val e1); etyp = e.etyp} + | Some(ex, bf) -> + transf_pre ctx (op_for_incr_decr op) ex bf e1.etyp + end + | EUnop((Opostincr|Opostdecr) as op, e1) -> + begin match is_bitfield_access env e1 with + | None -> + {edesc = EUnop(op, texp Val e1); etyp = e.etyp} + | Some(ex, bf) -> + transf_post ctx (op_for_incr_decr op) ex bf e1.etyp + end + | EUnop(op, e1) -> + {edesc = EUnop(op, texp Val e1); etyp = e.etyp} | EBinop(Oassign, e1, e2, ty) -> - begin match e1.edesc with - | EUnop(Odot fieldname, e11) -> - let lhs = texp e11 in let rhs = texp e2 in - begin match is_bitfield_access e11.etyp fieldname with - | None -> - {edesc = EBinop(Oassign, - {edesc = EUnop(Odot fieldname, lhs); - etyp = e1.etyp}, - rhs, ty); - etyp = e.etyp} - | Some bf -> - let carrier = - {edesc = EUnop(Odot bf.bf_carrier, lhs); - etyp = bf.bf_carrier_typ} in - {edesc = EBinop(Oassign, carrier, - bitfield_assign bf carrier rhs, - carrier.etyp); - etyp = carrier.etyp} - end - | EUnop(Oarrow fieldname, e11) -> - let lhs = texp e11 in let rhs = texp e2 in - begin match is_bitfield_access_ptr e11.etyp fieldname with - | None -> - {edesc = EBinop(Oassign, - {edesc = EUnop(Oarrow fieldname, lhs); - etyp = e1.etyp}, - rhs, ty); - etyp = e.etyp} - | Some bf -> - let carrier = - {edesc = EUnop(Oarrow bf.bf_carrier, lhs); - etyp = bf.bf_carrier_typ} in - {edesc = EBinop(Oassign, carrier, - bitfield_assign bf carrier rhs, - carrier.etyp); - etyp = carrier.etyp} - end - | _ -> - {edesc = EBinop(Oassign, texp e1, texp e2, e1.etyp); etyp = e1.etyp} + begin match is_bitfield_access env e1 with + | None -> + {edesc = EBinop(Oassign, texp Val e1, texp Val e2, ty); + etyp = e.etyp} + | Some(ex, bf) -> + transf_assign ctx ex bf e2 end - + | EBinop((Oadd_assign|Osub_assign|Omul_assign|Odiv_assign + |Omod_assign|Oand_assign|Oor_assign|Oxor_assign + |Oshl_assign|Oshr_assign) as op, + e1, e2, ty) -> + begin match is_bitfield_access env e1 with + | None -> + {edesc = EBinop(op, texp Val e1, texp Val e2, ty); etyp = e.etyp} + | Some(ex, bf) -> + transf_assignop ctx (op_for_assignop op) ex bf e2 ty + end + | EBinop(Ocomma, e1, e2, ty) -> + {edesc = EBinop(Ocomma, texp Effects e1, texp Val e2, ty); + etyp = e.etyp} | EBinop(op, e1, e2, ty) -> - (* Note: simplified expr assumed, so no assign-op *) - {edesc = EBinop(op, texp e1, texp e2, ty); etyp = e.etyp} + {edesc = EBinop(op, texp Val e1, texp Val e2, ty); etyp = e.etyp} + | EConditional(e1, e2, e3) -> - {edesc = EConditional(texp e1, texp e2, texp e3); etyp = e.etyp} + {edesc = EConditional(texp Val e1, texp ctx e2, texp ctx e3); + etyp = e.etyp} | ECast(ty, e1) -> - {edesc = ECast(ty, texp e1); etyp = e.etyp} + {edesc = ECast(ty, texp Val e1); etyp = e.etyp} | ECall(e1, el) -> - {edesc = ECall(texp e1, List.map texp el); etyp = e.etyp} - - in texp e + {edesc = ECall(texp Val e1, List.map (texp Val) el); etyp = e.etyp} + + and transf_read e bf = + bitfield_extract bf + {edesc = EUnop(Odot bf.bf_carrier, texp Val e); etyp = bf.bf_carrier_typ} + + and transf_assign ctx e1 bf e2 = + bind_lvalue (texp Val e1) (fun base -> + let carrier = + {edesc = EUnop(Odot bf.bf_carrier, base); etyp = bf.bf_carrier_typ} in + let asg = + eassign carrier (bitfield_assign bf carrier (texp Val e2)) in + if ctx = Val then ecomma asg (bitfield_extract bf carrier) else asg) + + and transf_assignop ctx op e1 bf e2 tyres = + bind_lvalue (texp Val e1) (fun base -> + let carrier = + {edesc = EUnop(Odot bf.bf_carrier, base); etyp = bf.bf_carrier_typ} in + let rhs = + {edesc = EBinop(op, bitfield_extract bf carrier, texp Val e2, tyres); + etyp = tyres} in + let asg = + eassign carrier (bitfield_assign bf carrier rhs) in + if ctx = Val then ecomma asg (bitfield_extract bf carrier) else asg) + + and transf_pre ctx op e1 bf tyfield = + transf_assignop ctx op e1 bf (intconst 1L IInt) + (unary_conversion env tyfield) + + and transf_post ctx op e1 bf tyfield = + if ctx = Effects then + transf_pre ctx op e1 bf tyfield + else begin + bind_lvalue (texp Val e1) (fun base -> + let carrier = + {edesc = EUnop(Odot bf.bf_carrier, base); etyp = bf.bf_carrier_typ} in + let temp = new_temp tyfield in + let tyres = unary_conversion env tyfield in + let settemp = eassign temp (bitfield_extract bf carrier) in + let rhs = + {edesc = EBinop(op, temp, intconst 1L IInt, tyres); etyp = tyres} in + let asg = + eassign carrier (bitfield_assign bf carrier rhs) in + ecomma (ecomma settemp asg) temp) + end + + in texp ctx e (* Statements *) @@ -283,39 +370,43 @@ let rec transf_stmt env s = match s.sdesc with | Sskip -> s | Sdo e -> - {sdesc = Sdo(transf_expr env e); sloc = s.sloc} + {sdesc = Sdo(transf_expr env Effects e); sloc = s.sloc} | Sseq(s1, s2) -> {sdesc = Sseq(transf_stmt env s1, transf_stmt env s2); sloc = s.sloc } | Sif(e, s1, s2) -> - {sdesc = Sif(transf_expr env e, transf_stmt env s1, transf_stmt env s2); + {sdesc = Sif(transf_expr env Val e, transf_stmt env s1, transf_stmt env s2); sloc = s.sloc} | Swhile(e, s1) -> - {sdesc = Swhile(transf_expr env e, transf_stmt env s1); + {sdesc = Swhile(transf_expr env Val e, transf_stmt env s1); sloc = s.sloc} | Sdowhile(s1, e) -> - {sdesc = Sdowhile(transf_stmt env s1, transf_expr env e); + {sdesc = Sdowhile(transf_stmt env s1, transf_expr env Val e); sloc = s.sloc} | Sfor(s1, e, s2, s3) -> - {sdesc = Sfor(transf_stmt env s1, transf_expr env e, transf_stmt env s2, - transf_stmt env s3); + {sdesc = Sfor(transf_stmt env s1, transf_expr env Val e, + transf_stmt env s2, transf_stmt env s3); sloc = s.sloc} | Sbreak -> s | Scontinue -> s | Sswitch(e, s1) -> - {sdesc = Sswitch(transf_expr env e, transf_stmt env s1); sloc = s.sloc} + {sdesc = Sswitch(transf_expr env Val e, transf_stmt env s1); + sloc = s.sloc} | Slabeled(lbl, s) -> {sdesc = Slabeled(lbl, transf_stmt env s); sloc = s.sloc} | Sgoto lbl -> s | Sreturn None -> s | Sreturn (Some e) -> - {sdesc = Sreturn(Some(transf_expr env e)); sloc = s.sloc} + {sdesc = Sreturn(Some(transf_expr env Val e)); sloc = s.sloc} | Sblock _ | Sdecl _ -> assert false (* should not occur in unblocked code *) (* Functions *) let transf_fundef env f = - { f with fd_body = transf_stmt env f.fd_body } + reset_temps(); + let newbody = transf_stmt env f.fd_body in + let temps = get_temps() in + { f with fd_locals = f.fd_locals @ temps; fd_body = newbody } (* Initializers *) @@ -374,7 +465,7 @@ let rec transf_struct_init id fld_init_list = let rec transf_init env i = match i with - | Init_single e -> Init_single (transf_expr env e) + | Init_single e -> Init_single (transf_expr env Val e) | Init_array il -> Init_array (List.map (transf_init env) il) | Init_struct(id, fld_init_list) -> let fld_init_list' = diff --git a/cparser/Cutil.ml b/cparser/Cutil.ml index 49b25a2..c7c5e30 100644 --- a/cparser/Cutil.ml +++ b/cparser/Cutil.ml @@ -655,6 +655,18 @@ let floatconst v fk = let nullconst = { edesc = EConst(CInt(0L, ptr_t_ikind, "0")); etyp = TPtr(TVoid [], []) } +(* Construct an address-of expression *) + +let eaddrof e = { edesc = EUnop(Oaddrof, e); etyp = TPtr(e.etyp, []) } + +(* Construct an assignment expression *) + +let eassign e1 e2 = { edesc = EBinop(Oassign, e1, e2, e1.etyp); etyp = e1.etyp } + +(* Construct a "," expression *) + +let ecomma e1 e2 = { edesc = EBinop(Ocomma, e1, e2, e2.etyp); etyp = e2.etyp } + (* Construct a sequence *) let sseq loc s1 s2 = @@ -667,8 +679,7 @@ let sseq loc s1 s2 = (* Construct an assignment statement *) let sassign loc lv rv = - { sdesc = Sdo {edesc = EBinop(Oassign, lv, rv, lv.etyp); etyp = lv.etyp}; - sloc = loc } + { sdesc = Sdo (eassign lv rv); sloc = loc } (* Empty location *) diff --git a/cparser/Cutil.mli b/cparser/Cutil.mli index 9587c57..2e61cf5 100644 --- a/cparser/Cutil.mli +++ b/cparser/Cutil.mli @@ -155,6 +155,12 @@ val floatconst : float -> fkind -> exp (* Build expression for given float constant. *) val nullconst : exp (* Expression for [(void * ) 0] *) +val eaddrof : exp -> exp + (* Expression for [&e] *) +val eassign : exp -> exp -> exp + (* Expression for [e1 = e2] *) +val ecomma : exp -> exp -> exp + (* Expression for [e1, e2] *) val sskip: stmt (* The [skip] statement. No location. *) val sseq : location -> stmt -> stmt -> stmt diff --git a/cparser/Makefile b/cparser/Makefile index 59d4b47..f4c1274 100644 --- a/cparser/Makefile +++ b/cparser/Makefile @@ -40,7 +40,7 @@ cparser.byte: $(COBJS) $(BOBJS) Main.cmo $(OCAMLC) -custom -o cparser.byte str.cma $(COBJS) $(BOBJS) Main.cmo clean:: - rm -f cparser + rm -f cparser.byte cparser.cma libcparser.a: uint64.o Cparser.cmo $(OCAMLMKLIB) -o cparser uint64.o Cparser.cmo @@ -82,7 +82,7 @@ beforedepend:: Lexer.ml $(OCAMLC) -c $*.c clean:: - rm -f *.cm? *.o *.so + rm -f *.cm? *.cmxa *.o *.so *.a depend: beforedepend $(OCAMLDEP) *.mli *.ml > .depend diff --git a/cparser/Parse.ml b/cparser/Parse.ml index 7dcc8d1..ed988f9 100644 --- a/cparser/Parse.ml +++ b/cparser/Parse.ml @@ -21,10 +21,10 @@ let transform_program t p = let run_pass pass flag p = if CharSet.mem flag t then pass p else p in Rename.program (run_pass (AddCasts.program ~all:(CharSet.mem 'C' t)) 'c' + (run_pass (SimplExpr.program ~volatile:(CharSet.mem 'v' t)) 'e' (run_pass StructAssign.program 'S' (run_pass StructByValue.program 's' (run_pass Bitfields.program 'f' - (run_pass (SimplExpr.program ~volatile:(CharSet.mem 'v' t)) 'e' (run_pass Unblock.program 'b' p)))))) @@ -37,9 +37,9 @@ let parse_transformations s = | 'c' -> set "ec" | 'C' -> set "ecC" | 's' -> set "s" - | 'S' -> set "esS" + | 'S' -> set "bsS" | 'v' -> set "ev" - | 'f' -> set "bef" + | 'f' -> set "bf" | _ -> ()) s; !t diff --git a/cparser/StructAssign.ml b/cparser/StructAssign.ml index 725c136..51cb489 100644 --- a/cparser/StructAssign.ml +++ b/cparser/StructAssign.ml @@ -15,17 +15,23 @@ (* Expand assignments between structs and between unions *) -(* Assumes: simplified code. - Preserves: simplified code, unblocked code *) +(* Assumes: unblocked code. + Preserves: unblocked code *) open C open Machine open Cutil open Env open Errors +open Transform + +(* Max number of assignments that can be inlined. Above this threshold, + we call memcpy() instead. *) let maxsize = ref 8 +(* Finding appropriate memcpy functions *) + let memcpy_decl = ref (None : ident option) let memcpy_type = @@ -57,7 +63,18 @@ let memcpy_words_ident env = try lookup_function env "__builtin_memcpy_words" with Env.Error _ -> memcpy_ident env -let transf_assign env loc lhs rhs = +(* Smart constructor for "," expressions *) + +let comma e1 e2 = + match e1.edesc, e2.edesc with + | EConst _, _ -> e2 + | _, EConst _ -> e1 + | _, _ -> ecomma e1 e2 + +(* Translate an assignment [lhs = rhs] between composite types. + [lhs] and [rhs] must be pure, invariant l-values. *) + +let transf_assign env lhs rhs = let num_assign = ref 0 in @@ -65,38 +82,35 @@ let transf_assign env loc lhs rhs = incr num_assign; if !num_assign > !maxsize then raise Exit - else sassign loc l r in + else eassign l r in let rec transf l r = match unroll env l.etyp with | TStruct(id, attr) -> let ci = Env.find_struct env id in - if ci.ci_sizeof = None then - error "%a: Error: incomplete struct '%s'" formatloc loc id.name; transf_struct l r ci.ci_members | TUnion(id, attr) -> raise Exit | TArray(ty_elt, Some sz, attr) -> transf_array l r ty_elt 0L sz | TArray(ty_elt, None, attr) -> - error "%a: Error: array of unknown size" formatloc loc; - sskip (* will be ignored later *) + assert false | _ -> assign l r and transf_struct l r = function - | [] -> sskip + | [] -> nullconst | f :: fl -> - sseq loc (transf {edesc = EUnop(Odot f.fld_name, l); etyp = f.fld_typ} - {edesc = EUnop(Odot f.fld_name, r); etyp = f.fld_typ}) - (transf_struct l r fl) + comma (transf {edesc = EUnop(Odot f.fld_name, l); etyp = f.fld_typ} + {edesc = EUnop(Odot f.fld_name, r); etyp = f.fld_typ}) + (transf_struct l r fl) and transf_array l r ty idx sz = - if idx >= sz then sskip else begin + if idx >= sz then nullconst else begin let e = intconst idx size_t_ikind in - sseq loc (transf {edesc = EBinop(Oindex, l, e, ty); etyp = ty} - {edesc = EBinop(Oindex, r, e, ty); etyp = ty}) - (transf_array l r ty (Int64.add idx 1L) sz) + comma (transf {edesc = EBinop(Oindex, l, e, ty); etyp = ty} + {edesc = EBinop(Oindex, r, e, ty); etyp = ty}) + (transf_array l r ty (Int64.add idx 1L) sz) end in @@ -115,42 +129,101 @@ let transf_assign env loc lhs rhs = let e_lhs = {edesc = EUnop(Oaddrof, lhs); etyp = TPtr(lhs.etyp, [])} in let e_rhs = {edesc = EUnop(Oaddrof, rhs); etyp = TPtr(rhs.etyp, [])} in let e_size = {edesc = ESizeof(lhs.etyp); etyp = TInt(size_t_ikind, [])} in - {sdesc = Sdo {edesc = ECall(memcpy, [e_lhs; e_rhs; e_size]); - etyp = TVoid[]}; - sloc = loc} + {edesc = ECall(memcpy, [e_lhs; e_rhs; e_size]); etyp = TVoid[]} + +(* Detect invariant l-values *) + +let rec invariant_lvalue e = + match e.edesc with + | EVar _ -> true + | EUnop(Oderef, {edesc = EVar _}) -> true (* to check *) + | EUnop(Odot _, e1) -> invariant_lvalue e1 + | _ -> false + +(* Bind a l-value to a temporary variable if it is not invariant. *) + +let rec bind_lvalue e fn = + match e.edesc with + | EBinop(Ocomma, e1, e2, _) -> + ecomma e1 (bind_lvalue e2 fn) + | _ -> + if invariant_lvalue e then + fn e + else begin + let tmp = new_temp (TPtr(e.etyp, [])) in + ecomma (eassign tmp (eaddrof e)) + (fn {edesc = EUnop(Oderef, tmp); etyp = e.etyp}) + end + +(* Transformation of expressions. *) + +type context = Val | Effects + +let rec transf_expr env ctx e = + match e.edesc with + | EBinop(Oassign, lhs, rhs, _) when is_composite_type env lhs.etyp -> + bind_lvalue (transf_expr env Val lhs) (fun l -> + bind_lvalue (transf_expr env Val rhs) (fun r -> + let e' = transf_assign env l r in + if ctx = Val then ecomma e' l else e')) + | EConst c -> e + | ESizeof ty -> e + | EVar x -> e + | EUnop(op, e1) -> + {edesc = EUnop(op, transf_expr env Val e1); etyp = e.etyp} + | EBinop(Ocomma, e1, e2, ty) -> + {edesc = EBinop(Ocomma, transf_expr env Effects e1, + transf_expr env ctx e2, ty); + etyp = e.etyp} + | EBinop(op, e1, e2, ty) -> + {edesc = EBinop(op, transf_expr env Val e1, + transf_expr env Val e2, ty); + etyp = e.etyp} + | EConditional(e1, e2, e3) -> + {edesc = EConditional(transf_expr env Val e1, + transf_expr env ctx e2, transf_expr env ctx e3); + etyp = e.etyp} + | ECast(ty, e1) -> + {edesc = ECast(ty, transf_expr env Val e1); etyp = e.etyp} + | ECall(e1, el) -> + {edesc = ECall(transf_expr env Val e1, + List.map (transf_expr env Val) el); + etyp = e.etyp} + +(* Transformation of statements *) let rec transf_stmt env s = match s.sdesc with | Sskip -> s - | Sdo {edesc = EBinop(Oassign, lhs, rhs, _)} - when is_composite_type env lhs.etyp -> - transf_assign env s.sloc lhs rhs - | Sdo _ -> s + | Sdo e -> {s with sdesc = Sdo(transf_expr env Effects e)} | Sseq(s1, s2) -> {s with sdesc = Sseq(transf_stmt env s1, transf_stmt env s2)} | Sif(e, s1, s2) -> - {s with sdesc = Sif(e, transf_stmt env s1, transf_stmt env s2)} + {s with sdesc = Sif(transf_expr env Val e, + transf_stmt env s1, transf_stmt env s2)} | Swhile(e, s1) -> - {s with sdesc = Swhile(e, transf_stmt env s1)} + {s with sdesc = Swhile(transf_expr env Val e, transf_stmt env s1)} | Sdowhile(s1, e) -> - {s with sdesc = Sdowhile(transf_stmt env s1, e)} + {s with sdesc = Sdowhile(transf_stmt env s1, transf_expr env Val e)} | Sfor(s1, e, s2, s3) -> - {s with sdesc = Sfor(transf_stmt env s1, e, + {s with sdesc = Sfor(transf_stmt env s1, transf_expr env Val e, transf_stmt env s2, transf_stmt env s3)} | Sbreak -> s | Scontinue -> s | Sswitch(e, s1) -> - {s with sdesc = Sswitch(e, transf_stmt env s1)} + {s with sdesc = Sswitch(transf_expr env Val e, transf_stmt env s1)} | Slabeled(lbl, s1) -> {s with sdesc = Slabeled(lbl, transf_stmt env s1)} | Sgoto lbl -> s - | Sreturn _ -> s - | Sblock sl -> - {s with sdesc = Sblock(List.map (transf_stmt env) sl)} - | Sdecl d -> s - -let transf_fundef env fd = - {fd with fd_body = transf_stmt env fd.fd_body} + | Sreturn None -> s + | Sreturn (Some e) -> {s with sdesc = Sreturn(Some(transf_expr env Val e))} + | Sblock _ | Sdecl _ -> assert false (* not in unblocked code *) + +let transf_fundef env f = + reset_temps(); + let newbody = transf_stmt env f.fd_body in + let temps = get_temps() in + {f with fd_locals = f.fd_locals @ temps; fd_body = newbody} let program p = memcpy_decl := None; diff --git a/cparser/StructByValue.ml b/cparser/StructByValue.ml index de79737..c66af32 100644 --- a/cparser/StructByValue.ml +++ b/cparser/StructByValue.ml @@ -16,7 +16,7 @@ (* Eliminate by-value passing of structs and unions. *) (* Assumes: nothing. - Preserves: simplified code, unblocked code *) + Preserves: unblocked code *) open C open Cutil @@ -55,30 +55,126 @@ and transf_funarg env (id, t) = then (id, TPtr(add_attributes_type [AConst] t, [])) else (id, t) -(* Simple exprs: no change in structure, since calls cannot occur within, - but need to rewrite the types. *) - -let rec transf_expr env e = - { etyp = transf_type env e.etyp; - edesc = match e.edesc with - | EConst c -> EConst c - | ESizeof ty -> ESizeof (transf_type env ty) - | EVar x -> EVar x - | EUnop(op, e1) -> EUnop(op, transf_expr env e1) - | EBinop(op, e1, e2, ty) -> - EBinop(op, transf_expr env e1, transf_expr env e2, transf_type env ty) - | EConditional(e1, e2, e3) -> - assert (not (is_composite_type env e.etyp)); - EConditional(transf_expr env e1, transf_expr env e2, transf_expr env e3) - | ECast(ty, e1) -> ECast(transf_type env ty, transf_expr env e1) - | ECall(e1, el) -> assert false - } +(* Expressions: transform calls + rewrite the types *) + +type context = Val | Effects + +let rec transf_expr env ctx e = + let newty = transf_type env e.etyp in + match e.edesc with + | EConst c -> + {edesc = EConst c; etyp = newty} + | ESizeof ty -> + {edesc = ESizeof (transf_type env ty); etyp = newty} + | EVar x -> + {edesc = EVar x; etyp = newty} + | EUnop(op, e1) -> + {edesc = EUnop(op, transf_expr env Val e1); etyp = newty} + | EBinop(Oassign, lhs, {edesc = ECall(fn, args)}, ty) + when is_composite_type env ty -> + transf_composite_call env ctx (Some lhs) fn args ty + | EBinop(Ocomma, e1, e2, ty) -> + {edesc = EBinop(Ocomma, transf_expr env Effects e1, + transf_expr env ctx e2, + transf_type env ty); + etyp = newty} + | EBinop(op, e1, e2, ty) -> + {edesc = EBinop(op, transf_expr env Val e1, + transf_expr env Val e2, + transf_type env ty); + etyp = newty} + | EConditional(e1, e2, e3) -> + {edesc = EConditional(transf_expr env Val e1, + transf_expr env ctx e2, + transf_expr env ctx e3); + etyp = newty} + | ECast(ty, e1) -> + {edesc = ECast(transf_type env ty, transf_expr env Val e1); etyp = newty} + | ECall(fn, args) -> + if is_composite_type env e.etyp then + transf_composite_call env ctx None fn args e.etyp + else + {edesc = ECall(transf_expr env Val fn, List.map (transf_arg env) args); + etyp = newty} + +(* Function arguments: pass by reference those having composite type *) + +and transf_arg env e = + let e' = transf_expr env Val e in + if is_composite_type env e'.etyp then eaddrof e' else e' + +(* Function calls returning a composite: add first argument. + ctx = Effects: lv = f(...) -> f(&lv, ...) + f(...) -> f(&newtemp, ...) + ctx = Val: lv = f(...) -> f(&newtemp, ...), lv = newtemp, newtemp + f(...) -> f(&newtemp, ...), newtemp +*) + +and transf_composite_call env ctx opt_lhs fn args ty = + let ty = transf_type env ty in + let fn = transf_expr env Val fn in + let args = List.map (transf_arg env) args in + match ctx, opt_lhs with + | Effects, None -> + let tmp = new_temp ~name:"_res" ty in + {edesc = ECall(fn, eaddrof tmp :: args); etyp = TVoid []} + | Effects, Some lhs -> + let lhs = transf_expr env Val lhs in + {edesc = ECall(fn, eaddrof lhs :: args); etyp = TVoid []} + | Val, None -> + let tmp = new_temp ~name:"_res" ty in + ecomma {edesc = ECall(fn, eaddrof tmp :: args); etyp = TVoid []} tmp + | Val, Some lhs -> + let lhs = transf_expr env Val lhs in + let tmp = new_temp ~name:"_res" ty in + ecomma (ecomma {edesc = ECall(fn, eaddrof tmp :: args); etyp = TVoid []} + (eassign lhs tmp)) + tmp + +(* The transformation above can create ill-formed lhs containing ",", as in + f().x = y ---> (f(&tmp), tmp).x = y + f(g(x)); ---> f(&(g(&tmp),tmp)) + We fix this by floating the "," above the lhs, up to the nearest enclosing + rhs: + f().x = y ---> (f(&tmp), tmp).x = y --> f(&tmp), tmp.x = y + f(g(x)); ---> f(&(g(&tmp),tmp)) --> f((g(&tmp), &tmp)) +*) + +let rec float_comma e = + match e.edesc with + | EConst c -> e + | ESizeof ty -> e + | EVar x -> e + (* lvalue-consuming unops *) + | EUnop((Oaddrof|Opreincr|Opredecr|Opostincr|Opostdecr|Odot _) as op, + {edesc = EBinop(Ocomma, e1, e2, _)}) -> + ecomma (float_comma e1) + (float_comma {edesc = EUnop(op, e2); etyp = e.etyp}) + (* lvalue-consuming binops *) + | EBinop((Oassign|Oadd_assign|Osub_assign|Omul_assign|Odiv_assign + |Omod_assign|Oand_assign|Oor_assign|Oxor_assign + |Oshl_assign|Oshr_assign) as op, + {edesc = EBinop(Ocomma, e1, e2, _)}, e3, tyres) -> + ecomma (float_comma e1) + (float_comma {edesc = EBinop(op, e2, e3, tyres); etyp = e.etyp}) + (* other expressions *) + | EUnop(op, e1) -> + {edesc = EUnop(op, float_comma e1); etyp = e.etyp} + | EBinop(op, e1, e2, tyres) -> + {edesc = EBinop(op, float_comma e1, float_comma e2, tyres); etyp = e.etyp} + | EConditional(e1, e2, e3) -> + {edesc = EConditional(float_comma e1, float_comma e2, float_comma e3); + etyp = e.etyp} + | ECast(ty, e1) -> + {edesc = ECast(ty, float_comma e1); etyp = e.etyp} + | ECall(e1, el) -> + {edesc = ECall(float_comma e1, List.map float_comma el); etyp = e.etyp} (* Initializers *) let rec transf_init env = function | Init_single e -> - Init_single (transf_expr env e) + Init_single (float_comma(transf_expr env Val e)) | Init_array il -> Init_array (List.map (transf_init env) il) | Init_struct(id, fil) -> @@ -96,70 +192,39 @@ let transf_decl env (sto, id, ty, init) = let transf_funbody env body optres = -let transf_type t = transf_type env t -and transf_expr e = transf_expr env e in - -(* Function arguments: pass by reference those having struct/union type *) - -let transf_arg e = - let e' = transf_expr e in - if is_composite_type env e'.etyp - then {edesc = EUnop(Oaddrof, e'); etyp = TPtr(e'.etyp, [])} - else e' -in +let transf_expr ctx e = float_comma(transf_expr env ctx e) in -(* Function calls: if return type is struct or union, - lv = f(...) -> f(&lv, ...) - f(...) -> f(&newtemp, ...) - Returns: if return type is struct or union, +(* Function returns: if return type is struct or union, return x -> _res = x; return *) let rec transf_stmt s = match s.sdesc with | Sskip -> s - | Sdo {edesc = ECall(fn, args); etyp = ty} -> - let fn = transf_expr fn in - let args = List.map transf_arg args in - if is_composite_type env ty then begin - let tmp = new_temp ~name:"_res" ty in - let arg0 = {edesc = EUnop(Oaddrof, tmp); etyp = TPtr(ty, [])} in - {s with sdesc = Sdo {edesc = ECall(fn, arg0 :: args); etyp = TVoid []}} - end else - {s with sdesc = Sdo {edesc = ECall(fn, args); etyp = ty}} - | Sdo {edesc = EBinop(Oassign, dst, {edesc = ECall(fn, args); etyp = ty}, _)} -> - let dst = transf_expr dst in - let fn = transf_expr fn in - let args = List.map transf_arg args in - let ty = transf_type ty in - if is_composite_type env ty then begin - let arg0 = {edesc = EUnop(Oaddrof, dst); etyp = TPtr(dst.etyp, [])} in - {s with sdesc = Sdo {edesc = ECall(fn, arg0 :: args); etyp = TVoid []}} - end else - sassign s.sloc dst {edesc = ECall(fn, args); etyp = ty} | Sdo e -> - {s with sdesc = Sdo(transf_expr e)} + {s with sdesc = Sdo(transf_expr Effects e)} | Sseq(s1, s2) -> {s with sdesc = Sseq(transf_stmt s1, transf_stmt s2)} | Sif(e, s1, s2) -> - {s with sdesc = Sif(transf_expr e, transf_stmt s1, transf_stmt s2)} + {s with sdesc = Sif(transf_expr Val e, + transf_stmt s1, transf_stmt s2)} | Swhile(e, s1) -> - {s with sdesc = Swhile(transf_expr e, transf_stmt s1)} + {s with sdesc = Swhile(transf_expr Val e, transf_stmt s1)} | Sdowhile(s1, e) -> - {s with sdesc = Sdowhile(transf_stmt s1, transf_expr e)} + {s with sdesc = Sdowhile(transf_stmt s1, transf_expr Val e)} | Sfor(s1, e, s2, s3) -> - {s with sdesc = Sfor(transf_stmt s1, transf_expr e, + {s with sdesc = Sfor(transf_stmt s1, transf_expr Val e, transf_stmt s2, transf_stmt s3)} | Sbreak -> s | Scontinue -> s | Sswitch(e, s1) -> - {s with sdesc = Sswitch(transf_expr e, transf_stmt s1)} + {s with sdesc = Sswitch(transf_expr Val e, transf_stmt s1)} | Slabeled(lbl, s1) -> {s with sdesc = Slabeled(lbl, transf_stmt s1)} | Sgoto lbl -> s | Sreturn None -> s | Sreturn(Some e) -> - let e = transf_expr e in + let e = transf_expr Val e in begin match optres with | None -> {s with sdesc = Sreturn(Some e)} diff --git a/doc/index.html b/doc/index.html index dff66ce..07ab0ff 100644 --- a/doc/index.html +++ b/doc/index.html @@ -104,8 +104,11 @@ semantics. <H3>Source, intermediate and target languages: syntax and semantics</H3> <UL> -<LI> <A HREF="html/Csyntax.html">Clight syntax</A> and its -<A HREF="html/Csem.html">semantics</A>: the source language. +<LI> The Cmedium source language: +<A HREF="html/Csyntax.html">syntax</A> and +<A HREF="html/Csem.html">semantics</A> and +<A HREF="html/Cstrategy.html">determinized semantics</A>. +<LI> <A HREF="html/Clight.html">Clight</A>: a simpler version of Cmedium where expressions contain no side-effects. <LI> <A HREF="html/Csharpminor.html">Csharpminor</A>: low-level structured language. <LI> <A HREF="html/Cminor.html">Cminor</A>: low-level structured @@ -144,13 +147,20 @@ code. </TR> <TR valign="top"> + <TD>Pulling side-effects out of expressions;<br> + fixing an evaluation order</TD> + <TD>Cmedium to Clight</TD> + <TD><A HREF="html/SimplExpr.html">SimplExpr</A></TD> + <TD><A HREF="html/SimplExprspec.html">SimplExprspec</A><br> + <A HREF="html/SimplExprproof.html">SimplExprproof</A></TD> +</TR> +<TR valign="top"> <TD>Simplification of control structures; <br> explication of type-dependent computations</TD> <TD>Clight to Csharpminor</TD> <TD><A HREF="html/Cshmgen.html">Cshmgen</A></TD> - <TD><A HREF="html/Cshmgenproof1.html">Cshmgenproof1</A><br> - <A HREF="html/Cshmgenproof2.html">Cshmgenproof2</A><br> - <A HREF="html/Cshmgenproof3.html">Cshmgenproof3</A></TD> + <TD><A HREF="html/Cshmgenproof.html">Cshmgenproof</A></TD> +</TR> <TR valign="top"> <TD>Stack allocation of local variables<br> whose address is taken;<br> @@ -263,7 +273,6 @@ code. Trivial type systems are used to statically capture well-formedness conditions on the source and intermediate languages. <UL> -<LI> <A HREF="html/Ctyping.html">Ctyping</A>: partial typing for Clight + type-checking <LI> <A HREF="html/RTLtyping.html">RTLtyping</A>: typing for RTL + type reconstruction. <LI> <A HREF="html/LTLtyping.html">LTLtyping</A>: typing for LTL. @@ -283,8 +292,8 @@ Proofs that compiler passes are type-preserving: <H3>All together</H3> <UL> -<LI> <A HREF="html/Compiler.html">Compiler</A>: composing the passes together; the -final semantic preservation theorems. +<LI> <A HREF="html/Compiler.html">Compiler</A>: composing the passes together; +whole-compiler semantic preservation theorems. <LI> <A HREF="html/Complements.html">Complements</A>: interesting consequences of the semantic preservation theorems. </UL> diff --git a/driver/Clflags.ml b/driver/Clflags.ml index fcec4c6..e825c66 100644 --- a/driver/Clflags.ml +++ b/driver/Clflags.ml @@ -22,7 +22,15 @@ let option_fbitfields = ref false let option_fvararg_calls = ref true let option_fmadd = ref false let option_dparse = ref false +let option_dcmedium = ref false let option_dclight = ref false +let option_dcminor = ref false +let option_drtl = ref false +let option_dtailcall = ref false +let option_dcastopt = ref false +let option_dconstprop = ref false +let option_dcse = ref false +let option_dalloc = ref false let option_dasm = ref false let option_E = ref false let option_S = ref false diff --git a/driver/Compiler.v b/driver/Compiler.v index 09a6c52..e57d80d 100644 --- a/driver/Compiler.v +++ b/driver/Compiler.v @@ -23,6 +23,8 @@ Require Import Smallstep. (** Languages (syntax and semantics). *) Require Csyntax. Require Csem. +Require Cstrategy. +Require Clight. Require Csharpminor. Require Cminor. Require CminorSel. @@ -33,11 +35,13 @@ Require Linear. Require Mach. Require Asm. (** Translation passes. *) +Require SimplExpr. Require Cshmgen. Require Cminorgen. Require Selection. Require RTLgen. Require Tailcall. +Require CastOptim. Require Constprop. Require CSE. Require Allocation. @@ -47,18 +51,19 @@ Require Reload. Require Stacking. Require Asmgen. (** Type systems. *) -Require Ctyping. Require RTLtyping. Require LTLtyping. Require LTLintyping. Require Lineartyping. Require Machtyping. (** Proofs of semantic preservation and typing preservation. *) -Require Cshmgenproof3. +Require SimplExprproof. +Require Cshmgenproof. Require Cminorgenproof. Require Selectionproof. Require RTLgenproof. Require Tailcallproof. +Require CastOptimproof. Require Constpropproof. Require CSEproof. Require Allocproof. @@ -73,6 +78,16 @@ Require Stackingproof. Require Stackingtyping. Require Machabstr2concr. Require Asmgenproof. +(** Pretty-printers (defined in Caml). *) +Parameter print_Csyntax: Csyntax.program -> unit. +Parameter print_Clight: Clight.program -> unit. +Parameter print_Cminor: Cminor.program -> unit. +Parameter print_RTL: RTL.fundef -> unit. +Parameter print_RTL_tailcall: RTL.fundef -> unit. +Parameter print_RTL_castopt: RTL.fundef -> unit. +Parameter print_RTL_constprop: RTL.fundef -> unit. +Parameter print_RTL_cse: RTL.fundef -> unit. +Parameter print_LTLin: LTLin.fundef -> unit. Open Local Scope string_scope. @@ -93,6 +108,9 @@ Notation "a @@@ b" := Notation "a @@ b" := (apply_total _ _ a b) (at level 50, left associativity). +Definition print {A: Type} (printer: A -> unit) (prog: A) : A := + match printer prog with tt => prog end. + (** We define three translation functions for whole programs: one starting with a C program, one with a Cminor program, one with an RTL program. The three translations produce Asm programs ready for @@ -111,12 +129,19 @@ Notation "a @@ b" := Definition transf_rtl_fundef (f: RTL.fundef) : res Asm.fundef := OK f + @@ print print_RTL @@ Tailcall.transf_fundef + @@ print print_RTL_tailcall + @@ CastOptim.transf_fundef + @@ print print_RTL_castopt @@ Constprop.transf_fundef + @@ print print_RTL_constprop @@ CSE.transf_fundef + @@ print print_RTL_cse @@@ Allocation.transf_fundef @@ Tunneling.tunnel_fundef @@@ Linearize.transf_fundef + @@ print print_LTLin @@ Reload.transf_fundef @@@ Stacking.transf_fundef @@@ Asmgen.transf_fundef. @@ -135,22 +160,28 @@ Definition transf_rtl_program (p: RTL.program) : res Asm.program := Definition transf_cminor_program (p: Cminor.program) : res Asm.program := OK p + @@ print print_Cminor @@ Selection.sel_program @@@ transform_partial_program transf_cminorsel_fundef. Definition transf_c_program (p: Csyntax.program) : res Asm.program := - match Ctyping.typecheck_program p with - | false => - Error (msg "Ctyping: type error") - | true => - OK p - @@@ Cshmgen.transl_program - @@@ Cminorgen.transl_program - @@@ transf_cminor_program - end. + OK p + @@ print print_Csyntax + @@@ SimplExpr.transl_program + @@ print print_Clight + @@@ Cshmgen.transl_program + @@@ Cminorgen.transl_program + @@@ transf_cminor_program. (** The following lemmas help reason over compositions of passes. *) +Lemma print_identity: + forall (A: Type) (printer: A -> unit) (prog: A), + print printer prog = prog. +Proof. + intros; unfold print. destruct (printer prog); auto. +Qed. + Lemma map_partial_compose: forall (X A B C: Type) (ctx: X -> errmsg) @@ -221,12 +252,42 @@ Proof. apply extensionality; auto. Qed. +Lemma transform_program_print_identity: + forall (A V: Type) (p: program A V) (f: A -> unit), + transform_program (print f) p = p. +Proof. + intros until f. unfold transform_program, transf_program. + destruct p; simpl; f_equal. + transitivity (map (fun x => x) prog_funct). + apply list_map_exten; intros. destruct x; simpl. rewrite print_identity. auto. + apply list_map_identity. +Qed. + +Lemma compose_print_identity: + forall (A: Type) (x: res A) (f: A -> unit), + x @@ print f = x. +Proof. + intros. destruct x; simpl. rewrite print_identity. auto. auto. +Qed. + (** * Semantic preservation *) (** We prove that the [transf_program] translations preserve semantics. The proof composes the semantic preservation results for each pass. This establishes the correctness of the whole compiler! *) +Ltac TransfProgInv := + match goal with + | [ H: transform_partial_program (fun f => _ @@@ _) _ = OK _ |- _ ] => + let p := fresh "p" in let X := fresh "X" in let P := fresh "P" in + destruct (transform_partial_program_compose _ _ _ _ _ _ _ _ H) as [p [X P]]; + clear H + | [ H: transform_partial_program (fun f => _ @@ _) _ = OK _ |- _ ] => + let p := fresh "p" in let X := fresh "X" in let P := fresh "P" in + destruct (transform_program_compose _ _ _ _ _ _ _ _ H) as [p [X P]]; + clear H + end. + Theorem transf_rtl_program_correct: forall p tp beh, transf_rtl_program p = OK tp -> @@ -235,47 +296,25 @@ Theorem transf_rtl_program_correct: Asm.exec_program tp beh. Proof. intros. unfold transf_rtl_program, transf_rtl_fundef in H. - destruct (transform_partial_program_compose _ _ _ _ _ _ _ _ H) as [p7 [X7 P7]]. - clear H. - destruct (transform_partial_program_compose _ _ _ _ _ _ _ _ X7) as [p6 [X6 P6]]. - clear X7. - destruct (transform_partial_program_compose _ _ _ _ _ _ _ _ X6) as [p5 [X5 P5]]. - clear X6. generalize (transform_program_partial_program _ _ _ _ _ _ P5). clear P5. intro P5. - destruct (transform_partial_program_compose _ _ _ _ _ _ _ _ X5) as [p4 [X4 P4]]. - clear X5. - destruct (transform_partial_program_compose _ _ _ _ _ _ _ _ X4) as [p3 [X3 P3]]. - clear X4. generalize (transform_program_partial_program _ _ _ _ _ _ P3). clear P3. intro P3. - destruct (transform_partial_program_compose _ _ _ _ _ _ _ _ X3) as [p2 [X2 P2]]. - clear X3. - destruct (transform_program_compose _ _ _ _ _ _ _ _ X2) as [p1 [X1 P1]]. - clear X2. - destruct (transform_program_compose _ _ _ _ _ _ _ _ X1) as [p0 [X0 P0]]. - clear X1. - destruct (transform_program_compose _ _ _ _ _ _ _ _ X0) as [p00 [X00 P00]]. - clear X0. - generalize (transform_partial_program_identity _ _ _ _ X00). clear X00. intro. subst p00. - - assert (WT3 : LTLtyping.wt_program p3). - apply Alloctyping.program_typing_preserved with p2. auto. - assert (WT4 : LTLtyping.wt_program p4). - subst p4. apply Tunnelingtyping.program_typing_preserved. auto. - assert (WT5 : LTLintyping.wt_program p5). - apply Linearizetyping.program_typing_preserved with p4. auto. auto. - assert (WT6 : Lineartyping.wt_program p6). - subst p6. apply Reloadtyping.program_typing_preserved. auto. - assert (WT7: Machtyping.wt_program p7). - apply Stackingtyping.program_typing_preserved with p6. auto. auto. - - apply Asmgenproof.transf_program_correct with p7; auto. - apply Machabstr2concr.exec_program_equiv; auto. - apply Stackingproof.transf_program_correct with p6; auto. - subst p6; apply Reloadproof.transf_program_correct; auto. - apply Linearizeproof.transf_program_correct with p4; auto. - subst p4; apply Tunnelingproof.transf_program_correct; auto. - apply Allocproof.transf_program_correct with p2; auto. - subst p2; apply CSEproof.transf_program_correct; auto. - subst p1; apply Constpropproof.transf_program_correct; auto. - subst p0; apply Tailcallproof.transf_program_correct; auto. + repeat TransfProgInv. + repeat rewrite transform_program_print_identity in *. subst. + exploit transform_partial_program_identity; eauto. intro EQ. subst. + + generalize Alloctyping.program_typing_preserved Tunnelingtyping.program_typing_preserved + Linearizetyping.program_typing_preserved Reloadtyping.program_typing_preserved + Stackingtyping.program_typing_preserved; intros. + + eapply Asmgenproof.transf_program_correct; eauto 6. + eapply Machabstr2concr.exec_program_equiv; eauto 6. + eapply Stackingproof.transf_program_correct; eauto. + eapply Reloadproof.transf_program_correct; eauto. + eapply Linearizeproof.transf_program_correct; eauto. + eapply Tunnelingproof.transf_program_correct; eauto. + eapply Allocproof.transf_program_correct; eauto. + eapply CSEproof.transf_program_correct; eauto. + eapply Constpropproof.transf_program_correct; eauto. + eapply CastOptimproof.transf_program_correct; eauto. + eapply Tailcallproof.transf_program_correct; eauto. Qed. Theorem transf_cminor_program_correct: @@ -286,30 +325,29 @@ Theorem transf_cminor_program_correct: Asm.exec_program tp beh. Proof. intros. unfold transf_cminor_program, transf_cminorsel_fundef in H. - destruct (transform_partial_program_compose _ _ _ _ _ _ _ _ H) as [p3 [X3 P3]]. - clear H. - destruct (transform_partial_program_compose _ _ _ _ _ _ _ _ X3) as [p2 [X2 P2]]. - clear X3. - generalize (transform_partial_program_identity _ _ _ _ X2). clear X2. intro. subst p2. - apply transf_rtl_program_correct with p3; auto. - apply RTLgenproof.transf_program_correct with (Selection.sel_program p); auto. - apply Selectionproof.transf_program_correct; auto. + simpl in H. repeat TransfProgInv. + eapply transf_rtl_program_correct; eauto. + eapply RTLgenproof.transf_program_correct; eauto. + eapply Selectionproof.transf_program_correct; eauto. + rewrite print_identity. auto. Qed. Theorem transf_c_program_correct: forall p tp beh, transf_c_program p = OK tp -> not_wrong beh -> - Csem.exec_program p beh -> + Cstrategy.exec_program p beh -> Asm.exec_program tp beh. Proof. intros until beh; unfold transf_c_program; simpl. - caseEq (Ctyping.typecheck_program p); try congruence; intro. - caseEq (Cshmgen.transl_program p); simpl; try congruence; intros p1 EQ1. + rewrite print_identity. + caseEq (SimplExpr.transl_program p); simpl; try congruence; intros p0 EQ0. + rewrite print_identity. + caseEq (Cshmgen.transl_program p0); simpl; try congruence; intros p1 EQ1. caseEq (Cminorgen.transl_program p1); simpl; try congruence; intros p2 EQ2. intros EQ3 NOTW SEM. eapply transf_cminor_program_correct; eauto. eapply Cminorgenproof.transl_program_correct; eauto. - eapply Cshmgenproof3.transl_program_correct; eauto. - apply Ctyping.typecheck_program_correct; auto. + eapply Cshmgenproof.transl_program_correct; eauto. + eapply SimplExprproof.transl_program_correct; eauto. Qed. diff --git a/driver/Complements.v b/driver/Complements.v index 3f32cc6..334b9b0 100644 --- a/driver/Complements.v +++ b/driver/Complements.v @@ -23,15 +23,74 @@ Require Import Smallstep. Require Import Determinism. Require Import Csyntax. Require Import Csem. +Require Import Cstrategy. Require Import Asm. Require Import Compiler. Require Import Errors. -(** * Determinism of Asm semantics *) +(** * Integrating a deterministic external world *) -(** In this section, we show that the semantics for the Asm language - are deterministic, provided that the program is executed against a - deterministic world, as formalized in module [Determinism]. *) +(** We now integrate a deterministic external world in the semantics + of Compcert C and Asm. *) + +Section WORLD. + +Variable initial_world: world. + +Definition exec_C_program (p: Csyntax.program) (beh: program_behavior) : Prop := + wprogram_behaves _ _ + Csem.step (Csem.initial_state p) Csem.final_state + initial_world (Genv.globalenv p) beh. + +Definition exec_asm_program (p: Asm.program) (beh: program_behavior) : Prop := + wprogram_behaves _ _ + Asm.step (Asm.initial_state p) Asm.final_state + initial_world (Genv.globalenv p) beh. + +(** ** Safety of C programs. *) + +(** We show that a C program is safe (in the sense of [Cstrategy.safeprog]) + if it cannot go wrong in the world-aware semantics. *) + +Lemma notwrong_safeprog: + forall p, + (forall beh, exec_C_program p beh -> not_wrong beh) -> + Cstrategy.safeprog p initial_world. +Proof. + intros; red. + assert (exists beh1, exec_C_program p beh1). + unfold exec_C_program. apply program_behaves_exists. + destruct H0 as [beh1 A]. + assert (B: not_wrong beh1) by auto. + split. + inv A; simpl in B. + destruct H0. exists (fst s); auto. + destruct H0. exists (fst s); auto. + destruct H0. exists (fst s); auto. + contradiction. + contradiction. + intros; red; intros. + destruct (classic (exists r, Csem.final_state s' r)). + (* 1. Final state. This is immsafe. *) + destruct H3 as [r F]. eapply immsafe_final; eauto. + (* 2. Not a final state. *) + destruct (classic (nostep (wstep _ _ Csem.step) (Genv.globalenv p) (s', w'))). + (* 2.1 No step possible -> going wrong *) + elim (H (Goes_wrong t)). + eapply program_goes_wrong. + instantiate (1 := (s, initial_world)). split; auto. + instantiate (1 := (s', w')). apply Determinism.inject_star; auto. + auto. + intros; red; intros. elim H3. exists r; auto. + (* 2.2 One step possible -> this is immsafe *) + unfold nostep in H4. + generalize (not_all_ex_not _ _ H4). clear H4. intros [t' P]. + generalize (not_all_ex_not _ _ P). clear P. intros [s'' Q]. + generalize (NNPP _ Q). clear Q. intros R. destruct R as [R1 R2]. simpl in *. + eapply immsafe_step. eauto. eauto. +Qed. + +(** ** Determinism of Asm semantics *) Remark extcall_arguments_deterministic: forall rs m sg args args', @@ -100,17 +159,20 @@ Proof. Qed. Theorem asm_exec_program_deterministic: - forall p w beh1 beh2, - Asm.exec_program p beh1 -> Asm.exec_program p beh2 -> - possible_behavior w beh1 -> possible_behavior w beh2 -> + forall p beh1 beh2, + exec_asm_program p beh1 -> exec_asm_program p beh2 -> beh1 = beh2. Proof. - intros. - eapply (program_behaves_deterministic _ _ step (initial_state p) final_state); eauto. - exact step_internal_deterministic. - exact (initial_state_deterministic p). - exact final_state_deterministic. - exact final_state_not_step. + intros. hnf in H; hnf in H0. + eapply (program_behaves_deterministic _ _ + (wstep _ _ step) + (winitial_state _ (initial_state p) initial_world) + (wfinal_state _ final_state)); + eauto. + apply wstep_deterministic. apply step_internal_deterministic. + apply winitial_state_determ. apply initial_state_deterministic. + apply wfinal_state_determ. apply final_state_deterministic. + apply wfinal_state_nostep. apply final_state_not_step. Qed. (** * Additional semantic preservation property *) @@ -118,28 +180,34 @@ Qed. (** Combining the semantic preservation theorem from module [Compiler] with the determinism of Asm executions, we easily obtain additional, stronger semantic preservation properties. - The first property states that, when compiling a Clight + The first property states that, when compiling a Compcert C program that has well-defined semantics, all possible executions of the resulting Asm code correspond to an execution of - the source Clight program. *) + the source program. *) Theorem transf_c_program_is_refinement: - forall p tp w, + forall p tp, transf_c_program p = OK tp -> - (exists b, Csem.exec_program p b /\ possible_behavior w b /\ not_wrong b) -> - (forall b, Asm.exec_program tp b -> possible_behavior w b -> Csem.exec_program p b). + (forall beh, exec_C_program p beh -> not_wrong beh) -> + (forall beh, exec_asm_program tp beh -> exec_C_program p beh). Proof. - intros. destruct H0 as [b0 [A [B C]]]. - assert (Asm.exec_program tp b0). + intros. + exploit Cstrategy.strategy_behavior. + apply notwrong_safeprog. eauto. + intros [beh1 [A [B [C D]]]]. + assert (Asm.exec_program tp beh1). eapply transf_c_program_correct; eauto. - assert (b = b0). eapply asm_exec_program_deterministic; eauto. - subst b0. auto. + assert (exec_asm_program tp beh1). + red. apply inject_behaviors; auto. + assert (beh = beh1). eapply asm_exec_program_deterministic; eauto. + subst beh. + red. apply inject_behaviors; auto. Qed. Section SPECS_PRESERVED. (** The second additional results shows that if one execution - of the source Clight program satisfies a given specification + of the source C program satisfies a given specification (a predicate on the observable behavior of the program), then all executions of the produced Asm program satisfy this specification as well. *) @@ -149,16 +217,15 @@ Variable spec: program_behavior -> Prop. Hypothesis spec_not_wrong: forall b, spec b -> not_wrong b. Theorem transf_c_program_preserves_spec: - forall p tp w, + forall p tp, transf_c_program p = OK tp -> - (exists b, Csem.exec_program p b /\ possible_behavior w b /\ spec b) -> - (forall b, Asm.exec_program tp b -> possible_behavior w b -> spec b). + (forall beh, exec_C_program p beh -> spec beh) -> + (forall beh, exec_asm_program tp beh -> spec beh). Proof. - intros. destruct H0 as [b1 [A [B C]]]. - assert (Asm.exec_program tp b1). - eapply transf_c_program_correct; eauto. - assert (b1 = b). eapply asm_exec_program_deterministic; eauto. - subst b1. auto. + intros. apply H0. apply transf_c_program_is_refinement with tp; auto. Qed. End SPECS_PRESERVED. + +End WORLD. + diff --git a/driver/Driver.ml b/driver/Driver.ml index 2776604..8afe03c 100644 --- a/driver/Driver.ml +++ b/driver/Driver.ml @@ -64,7 +64,7 @@ let compile_c_file sourcename ifile ofile = Sections.initialize(); (* Simplification options *) let simplifs = - "becv" (* blocks, impure exprs, implicit casts, volatiles: mandatory *) + "b" (* blocks: mandatory *) ^ (if !option_fstruct_passing then "s" else "") ^ (if !option_fstruct_assign then "S" else "") ^ (if !option_fbitfields then "f" else "") in @@ -87,13 +87,20 @@ let compile_c_file sourcename ifile ofile = match C2Clight.convertProgram ast with | None -> exit 2 | Some p -> p in - (* Save Csyntax if requested *) - if !option_dclight then begin - let ofile = Filename.chop_suffix sourcename ".c" ^ ".light.c" in - let oc = open_out ofile in - PrintCsyntax.print_program (Format.formatter_of_out_channel oc) csyntax; - close_out oc - end; + flush stderr; + (* Prepare to dump Csyntax, Clight, RTL, etc, if requested *) + let set_dest dst opt ext = + dst := if !opt then Some (Filename.chop_suffix sourcename ".c" ^ ext) + else None in + set_dest PrintCsyntax.destination option_dcmedium ".compcert.c"; + set_dest PrintClight.destination option_dclight ".light.c"; + set_dest PrintCminor.destination option_dcminor ".cm"; + set_dest PrintRTL.destination_rtl option_drtl ".rtl"; + set_dest PrintRTL.destination_tailcall option_dtailcall ".tailcall.rtl"; + set_dest PrintRTL.destination_castopt option_dcastopt ".castopt.rtl"; + set_dest PrintRTL.destination_constprop option_dconstprop ".constprop.rtl"; + set_dest PrintRTL.destination_cse option_dcse ".cse.rtl"; + set_dest PrintLTLin.destination option_dalloc ".alloc.ltl"; (* Convert to Asm *) let ppc = match Compiler.transf_c_program csyntax with @@ -228,6 +235,7 @@ Code generation options: -fsmall-const <n> Set maximal size <n> for allocation in small constant area Tracing options: -dparse Save C file after parsing and elaboration in <file>.parse.c + -dcmedium Save generated Cmedium in <file>.medium.c -dclight Save generated Clight in <file>.light.c -dasm Save generated assembly in <file>.s Linking options: @@ -304,7 +312,15 @@ let cmdline_actions = "-o$", String(fun s -> exe_name := s); "-stdlib$", String(fun s -> stdlib_path := s); "-dparse$", Set option_dparse; + "-dcmedium$", Set option_dcmedium; "-dclight$", Set option_dclight; + "-dcminor", Set option_dcminor; + "-drtl$", Set option_drtl; + "-dtailcall$", Set option_dtailcall; + "-dcastopt$", Set option_dcastopt; + "-dconstprop$", Set option_dconstprop; + "-dcse$", Set option_dcse; + "-dalloc$", Set option_dalloc; "-dasm$", Set option_dasm; "-E$", Set option_E; "-S$", Set option_S; diff --git a/extraction/extraction.v b/extraction/extraction.v index 797204f..706d1db 100644 --- a/extraction/extraction.v +++ b/extraction/extraction.v @@ -75,6 +75,17 @@ Extract Constant Coloring.graph_coloring => "Coloringaux.graph_coloring". (* Linearize *) Extract Constant Linearize.enumerate_aux => "Linearizeaux.enumerate_aux". +(* Compiler *) +Extract Constant Compiler.print_Csyntax => "PrintCsyntax.print_if". +Extract Constant Compiler.print_Clight => "PrintClight.print_if". +Extract Constant Compiler.print_Cminor => "PrintCminor.print_if". +Extract Constant Compiler.print_RTL => "PrintRTL.print_rtl". +Extract Constant Compiler.print_RTL_tailcall => "PrintRTL.print_tailcall". +Extract Constant Compiler.print_RTL_castopt => "PrintRTL.print_castopt". +Extract Constant Compiler.print_RTL_constprop => "PrintRTL.print_constprop". +Extract Constant Compiler.print_RTL_cse => "PrintRTL.print_cse". +Extract Constant Compiler.print_LTLin => "PrintLTLin.print_if". + (* Suppression of stupidly big equality functions *) Extract Constant Op.eq_operation => "fun (x: operation) (y: operation) -> x = y". Extract Constant Op.eq_addressing => "fun (x: addressing) (y: addressing) -> x = y". diff --git a/powerpc/PrintOp.ml b/powerpc/PrintOp.ml new file mode 100644 index 0000000..31de8d1 --- /dev/null +++ b/powerpc/PrintOp.ml @@ -0,0 +1,109 @@ +(* *********************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Xavier Leroy, INRIA Paris-Rocquencourt *) +(* *) +(* Copyright Institut National de Recherche en Informatique et en *) +(* Automatique. All rights reserved. This file is distributed *) +(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* *) +(* *********************************************************************) + +(** Pretty-printing of operators, conditions, addressing modes *) + +open Format +open Camlcoq +open Integers +open Op + +let comparison_name = function + | Ceq -> "==" + | Cne -> "!=" + | Clt -> "<" + | Cle -> "<=" + | Cgt -> ">" + | Cge -> ">=" + +let print_condition reg pp = function + | (Ccomp c, [r1;r2]) -> + fprintf pp "%a %ss %a" reg r1 (comparison_name c) reg r2 + | (Ccompu c, [r1;r2]) -> + fprintf pp "%a %su %a" reg r1 (comparison_name c) reg r2 + | (Ccompimm(c, n), [r1]) -> + fprintf pp "%a %ss %ld" reg r1 (comparison_name c) (camlint_of_coqint n) + | (Ccompuimm(c, n), [r1]) -> + fprintf pp "%a %su %ld" reg r1 (comparison_name c) (camlint_of_coqint n) + | (Ccompf c, [r1;r2]) -> + fprintf pp "%a %sf %a" reg r1 (comparison_name c) reg r2 + | (Cnotcompf c, [r1;r2]) -> + fprintf pp "%a not(%sf) %a" reg r1 (comparison_name c) reg r2 + | (Cmaskzero n, [r1]) -> + fprintf pp "%a & 0x%lx == 0" reg r1 (camlint_of_coqint n) + | (Cmasknotzero n, [r1]) -> + fprintf pp "%a & 0x%lx != 0" reg r1 (camlint_of_coqint n) + | _ -> + fprintf pp "<bad condition>" + +let print_operation reg pp = function + | Omove, [r1] -> reg pp r1 + | Ointconst n, [] -> fprintf pp "%ld" (camlint_of_coqint n) + | Ofloatconst n, [] -> fprintf pp "%F" n + | Oaddrsymbol(id, ofs), [] -> + fprintf pp "\"%s\" + %ld" (extern_atom id) (camlint_of_coqint ofs) + | Oaddrstack ofs, [] -> + fprintf pp "stack(%ld)" (camlint_of_coqint ofs) + | Ocast8signed, [r1] -> fprintf pp "int8signed(%a)" reg r1 + | Ocast8unsigned, [r1] -> fprintf pp "int8unsigned(%a)" reg r1 + | Ocast16signed, [r1] -> fprintf pp "int16signed(%a)" reg r1 + | Ocast16unsigned, [r1] -> fprintf pp "int16unsigned(%a)" reg r1 + | Oadd, [r1;r2] -> fprintf pp "%a + %a" reg r1 reg r2 + | Oaddimm n, [r1] -> fprintf pp "%a + %ld" reg r1 (camlint_of_coqint n) + | Osub, [r1;r2] -> fprintf pp "%a - %a" reg r1 reg r2 + | Osubimm n, [r1] -> fprintf pp "%ld - %a" (camlint_of_coqint n) reg r1 + | Omul, [r1;r2] -> fprintf pp "%a * %a" reg r1 reg r2 + | Omulimm n, [r1] -> fprintf pp "%a * %ld" reg r1 (camlint_of_coqint n) + | Odiv, [r1;r2] -> fprintf pp "%a /s %a" reg r1 reg r2 + | Odivu, [r1;r2] -> fprintf pp "%a /u %a" reg r1 reg r2 + | Oand, [r1;r2] -> fprintf pp "%a & %a" reg r1 reg r2 + | Oandimm n, [r1] -> fprintf pp "%a & %ld" reg r1 (camlint_of_coqint n) + | Oor, [r1;r2] -> fprintf pp "%a | %a" reg r1 reg r2 + | Oorimm n, [r1] -> fprintf pp "%a | %ld" reg r1 (camlint_of_coqint n) + | Oxor, [r1;r2] -> fprintf pp "%a ^ %a" reg r1 reg r2 + | Oxorimm n, [r1] -> fprintf pp "%a ^ %ld" reg r1 (camlint_of_coqint n) + | Onand, [r1;r2] -> fprintf pp "not(%a & %a)" reg r1 reg r2 + | Onor, [r1;r2] -> fprintf pp "not(%a | %a)" reg r1 reg r2 + | Onxor, [r1;r2] -> fprintf pp "not(%a ^ %a)" reg r1 reg r2 + | Oshl, [r1;r2] -> fprintf pp "%a << %a" reg r1 reg r2 + | Oshr, [r1;r2] -> fprintf pp "%a >>s %a" reg r1 reg r2 + | Oshrimm n, [r1] -> fprintf pp "%a >>s %ld" reg r1 (camlint_of_coqint n) + | Oshrximm n, [r1] -> fprintf pp "%a >>x %ld" reg r1 (camlint_of_coqint n) + | Oshru, [r1;r2] -> fprintf pp "%a >>u %a" reg r1 reg r2 + | Orolm(n,m), [r1] -> + fprintf pp "(%a rol %ld) & 0x%lx" + reg r1 (camlint_of_coqint n) (camlint_of_coqint m) + | Onegf, [r1] -> fprintf pp "negf(%a)" reg r1 + | Oabsf, [r1] -> fprintf pp "absf(%a)" reg r1 + | Oaddf, [r1;r2] -> fprintf pp "%a +f %a" reg r1 reg r2 + | Osubf, [r1;r2] -> fprintf pp "%a -f %a" reg r1 reg r2 + | Omulf, [r1;r2] -> fprintf pp "%a *f %a" reg r1 reg r2 + | Odivf, [r1;r2] -> fprintf pp "%a /f %a" reg r1 reg r2 + | Omuladdf, [r1;r2;r3] -> fprintf pp "%a *f %a +f %a" reg r1 reg r2 reg r3 + | Omulsubf, [r1;r2;r3] -> fprintf pp "%a *f %a -f %a" reg r1 reg r2 reg r3 + | Osingleoffloat, [r1] -> fprintf pp "singleoffloat(%a)" reg r1 + | Ointoffloat, [r1] -> fprintf pp "intoffloat(%a)" reg r1 + | Ointuoffloat, [r1] -> fprintf pp "intuoffloat(%a)" reg r1 + | Ofloatofint, [r1] -> fprintf pp "floatofint(%a)" reg r1 + | Ofloatofintu, [r1] -> fprintf pp "floatofintu(%a)" reg r1 + | Ocmp c, args -> print_condition reg pp (c, args) + | _ -> fprintf pp "<bad operator>" + +let print_addressing reg pp = function + | Aindexed n, [r1] -> fprintf pp "%a + %ld" reg r1 (camlint_of_coqint n) + | Aindexed2, [r1; r2] -> fprintf pp "%a + %a" reg r1 reg r2 + | Aglobal(id, ofs), [] -> fprintf pp "%s + %ld" (extern_atom id) (camlint_of_coqint ofs) + | Abased(id, ofs), [r1] -> fprintf pp "%s + %ld + %a" (extern_atom id) (camlint_of_coqint ofs) reg r1 + | Ainstack ofs, [] -> fprintf pp "stack(%ld)" (camlint_of_coqint ofs) + | _ -> fprintf pp "<bad addressing>" + + diff --git a/test/c/Makefile b/test/c/Makefile index 3f2df78..b4fd1fd 100644 --- a/test/c/Makefile +++ b/test/c/Makefile @@ -1,7 +1,7 @@ include ../../Makefile.config CCOMP=../../ccomp -CCOMPFLAGS=-stdlib ../../runtime -fmadd -dclight -dasm +CCOMPFLAGS=-stdlib ../../runtime -fmadd -dcmedium -dclight -dasm CFLAGS=-O1 -Wall @@ -58,4 +58,4 @@ time_compcert: clean: rm -f *.compcert *.gcc - rm -f *.light.c *.s *.o *~ + rm -f *.light.c *.medium.c *.s *.o *~ diff --git a/test/regression/Makefile b/test/regression/Makefile index 4ebf042..06ad9ef 100644 --- a/test/regression/Makefile +++ b/test/regression/Makefile @@ -1,13 +1,14 @@ include ../../Makefile.config CCOMP=../../ccomp -CCOMPFLAGS=-stdlib ../../runtime -dparse -dclight -dasm \ +CCOMPFLAGS=-stdlib ../../runtime -dparse -dcmedium -dclight -dasm \ -fstruct-passing -fstruct-assign -fbitfields LIBS=$(LIBMATH) # Can run and have reference output in Results -TESTS=bitfields1 bitfields2 bitfields3 expr1 initializers volatile2 \ +TESTS=bitfields1 bitfields2 bitfields3 bitfields4 \ + expr1 initializers volatile2 \ funct3 expr5 struct7 struct8 casts1 casts2 # Other tests: should compile to .s without errors (but expect warnings) diff --git a/test/regression/Results/bitfields4 b/test/regression/Results/bitfields4 new file mode 100644 index 0000000..ff8e093 --- /dev/null +++ b/test/regression/Results/bitfields4 @@ -0,0 +1,12 @@ +x = {a = 28, b = 2 } +(x.a += 10) = -26 +(x.b = 17) = 1 +x = {a = -26, b = 1 } +f(&x) = -28 +f(&x) = -30 +f(&x) = -32 +x = {a = -29, b = 4 } +Ding! +x = {a = 10, b = 4 } +Ding! +x = {a = 12, b = 4 } diff --git a/test/regression/Results/struct7 b/test/regression/Results/struct7 index ae630bf..597007c 100644 --- a/test/regression/Results/struct7 +++ b/test/regression/Results/struct7 @@ -1,4 +1,7 @@ A2 = { 1234, 3.141590, { 'H', ... , 'o' } } +A2 = { 1234, 3.141590, { 'H', ... , 'o' } } +B2 = { 1, ..., 5, ..., 0 } B2 = { 1, ..., 5, ..., 0 } C2.c = 'z' D2.v = { 0, ..., 4, ..., 0 } +AA[0] = { 1234, 3.141590, { 'H', ... , 'o' } } diff --git a/test/regression/Results/struct8 b/test/regression/Results/struct8 index a215193..19ec15d 100644 --- a/test/regression/Results/struct8 +++ b/test/regression/Results/struct8 @@ -1,2 +1,5 @@ a = { 123, 2.718000, 'a' } b = { 125, 5.436000, 'f' } +c = { 128, 16.308000, 'f' } +d = { 125, 5.436000, 'f' } +e = { 128, 16.308000, 'f' } diff --git a/test/regression/bitfields4.c b/test/regression/bitfields4.c new file mode 100644 index 0000000..6333e6d --- /dev/null +++ b/test/regression/bitfields4.c @@ -0,0 +1,39 @@ +#include <stdio.h> + +struct s { + signed char a: 6; + unsigned int b: 4; +}; + +int f(struct s * x) +{ + return (x->a)-- - ++(x->b); +} + +struct s * ding(struct s * x) +{ + printf ("Ding!\n"); + return x; +} + +int main() +{ + struct s x; + + x.a = 28; + x.b = 2; + + printf("x = {a = %d, b = %d }\n", x.a, x.b); + printf("(x.a += 10) = %d\n", (x.a += 10)); + printf("(x.b = 17) = %d\n", (x.b = 17)); + printf("x = {a = %d, b = %d }\n", x.a, x.b); + printf("f(&x) = %d\n", f(&x)); + printf("f(&x) = %d\n", f(&x)); + printf("f(&x) = %d\n", f(&x)); + printf("x = {a = %d, b = %d }\n", x.a, x.b); + ding(&x)->a = 10; + printf("x = {a = %d, b = %d }\n", x.a, x.b); + ding(&x)->a += 2; + printf("x = {a = %d, b = %d }\n", x.a, x.b); + return 0; +} diff --git a/test/regression/struct7.c b/test/regression/struct7.c index 136602b..fe3ef82 100644 --- a/test/regression/struct7.c +++ b/test/regression/struct7.c @@ -29,8 +29,8 @@ union u2 D; int main() { - struct small A2; - struct big B2; + struct small A1, A2, AA[1]; + struct big B1, B2; union u1 C2; union u2 D2; int i; @@ -42,10 +42,18 @@ int main() printf("A2 = { %d, %f, { '%c', ... , '%c' } }\n", A2.x, A2.d, A2.c[0], A2.c[4]); + A2 = (A1 = A); + printf("A2 = { %d, %f, { '%c', ... , '%c' } }\n", + A2.x, A2.d, A2.c[0], A2.c[4]); + B2 = B; printf("B2 = { %d, ..., %d, ..., %d }\n", B2.x[0], B2.x[4], B2.x[99]); + B2 = (B1 = B); + printf("B2 = { %d, ..., %d, ..., %d }\n", + B2.x[0], B2.x[4], B2.x[99]); + C2 = C; printf("C2.c = '%c'\n", C2.c); @@ -53,6 +61,14 @@ int main() printf("D2.v = { %d, ..., %d, ..., %d }\n", D2.v.x[0], D2.v.x[4], D2.v.x[99]); + AA[0] = A; + A1.x = 0; + A2.x = 0; + AA[A1.x] = AA[A2.x]; + + printf("AA[0] = { %d, %f, { '%c', ... , '%c' } }\n", + AA[0].x, AA[0].d, AA[0].c[0], AA[0].c[4]); + return 0; } diff --git a/test/regression/struct8.c b/test/regression/struct8.c index 989c352..a100cbe 100644 --- a/test/regression/struct8.c +++ b/test/regression/struct8.c @@ -16,8 +16,14 @@ struct S f(struct S s, int scale) int main() { struct S a = { 123, 2.718, 'a' }; - struct S b = f(a, 2); + struct S b, c, d, e; + b = f(a, 2); + c = f(f(a, 2), 3); + e = f((d = f(a, 2)), 3); printf("a = { %d, %f, '%c' }\n", a.x, a.d, a.c); printf("b = { %d, %f, '%c' }\n", b.x, b.d, b.c); + printf("c = { %d, %f, '%c' }\n", c.x, c.d, c.c); + printf("d = { %d, %f, '%c' }\n", d.x, d.d, d.c); + printf("e = { %d, %f, '%c' }\n", e.x, e.d, e.c); return 0; } |